71 lines
3.8 KiB
Mathematica
71 lines
3.8 KiB
Mathematica
DENTSCR ; HISC/NCA-Enter Bulk Screening Treatments ;10/4/96 13:58
|
|
;;1.2;DENTAL;**21,24**;JAN 26, 1989
|
|
EN1 ; Process Initial Screening Treatment
|
|
W !!,"Each prompt needs to be filled in order for the treatment to be filed.",!,"To Exit, Enter ""^""."
|
|
K DIR S DIR(0)="SO^S:Screening;C:Complete Exam",DIR("A")="Select One For Batch Filing" D ^DIR G:$D(DIRUT)!($D(DIROUT)) KIL S DENTBAT=Y
|
|
K %DT S %DT="AETPX",%DT("A")="DATE/TIME OF TREATMENT: ",%DT("B")="NOW",%DT(0)="-NOW" W ! D ^%DT K %DT S:$D(DTOUT) Y=0 G:Y<1 KIL S DENTDTE=Y
|
|
STA K DIC S DIC="^DENT(225,",DIC(0)="AEMQ" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),STA:Y<1 S DENTSTA=$P(Y,"^",2)
|
|
PROV K DIC S DIC="^DENT(220.5,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),""^"",2)'="""",'$P(^(0),""^"",3)" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),PROV:Y<1 S DENTPRV=+Y G:$P(^DENT(220.5,DENTPRV,0),"^",2)="" PROV
|
|
PAT W !,"DENTAL PATIENT: " R X:DTIME G:'$T!(X=U) KIL
|
|
I X="GROUP" D GROUP G CAT
|
|
K DIC S DIC="^DENT(220,",DIC(0)="ELMQ" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),PAT:Y<1 S (DFN,DENTDFN,DENTPAT)=+Y D DEM^VADPT S DENTSSN=$P(VADM(2),"^",1),DENTNAM=$P(VADM(1),"^",1) D KVAR^VADPT
|
|
CAT K DIC S DIC="^DIC(220.2,",DIC(0)="AEMQ",DIC("A")="PATIENT CATEGORY: " D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),CAT:Y<1 S DENTCAT=+Y
|
|
BED K DIC S DIC="^DIC(220.4,",DIC(0)="AEMQ" D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),BED:Y<1 S DENTBED=+Y
|
|
W !! S DENTCT=0,DENTX=DENTDTE_"^"_DENTSSN_"^"_DENTPRV_"^"_DENTPAT_"^^"_DENTBED_"^"_DENTBAT,$P(DENTX,"^",19)=DENTCAT,$P(DENTX,"^",40)=DENTSTA,$P(DENTX,"^",39)=DENTNAM
|
|
S $P(DENTX,"^",10)=$P($G(^DENT(220.5,DENTPRV,0)),"^",2)
|
|
S:$D(DENTGRP) $P(DENTX,"^",26)=DENTGRP
|
|
S N1=$P(^DENT(221,0),"^",4),N1=N1+1,DENTCT=DENTCT+1
|
|
W " Treatment Added "
|
|
K DD,DO D SAVE^DENTCRD(221,DENTX,.DENTDTE)
|
|
S ^DENT(221,0)=$P(^DENT(221,0),"^",1,2)_"^"_DENTDTE_"^"_N1
|
|
S DENTSTR=$G(^DENT(221,DENTDTE,0))
|
|
W !! D REPEAT
|
|
I DENTCT W !!,"Total ",$S(DENTBAT="S":"Screening",1:"Complete Exam")," Treatment Entered: ",DENTCT
|
|
G KIL
|
|
REPEAT ; Store Bulk Screening Treatment
|
|
W ! S DENTX=$G(DENTSTR) D NULL(DENTX,.DENTY)
|
|
S DENTDAT=$P(DENTY,"^",1) S X=$$CHK(DENTDAT),$P(DENTY,"^",1)=X,DENTDT1=X
|
|
S N1=$P(^DENT(221,0),"^",4),N1=N1+1,DENTCT=DENTCT+1
|
|
W " Store Next Treatment "
|
|
D SAVE^DENTCRD(221,DENTY,.DENTDT1)
|
|
S ^DENT(221,0)=$P(^DENT(221,0),"^",1,2)_"^"_DENTDT1_"^"_N1
|
|
EDIT1 S E=0 W !! K DIC,DIE S DIE="^DENT(221,",DA=DENTDT1,DR="2;4.5;5" D ^DIE K DIE,DR
|
|
I $D(Y) S DIK="^DENT(221,",DA=DENTDT1 D ^DIK S DENTCT=DENTCT-1 Q
|
|
S DENTSTR=$G(^DENT(221,DENTDT1,0)) D CHECK
|
|
I $P(DENTSTR,"^",39)="" Q
|
|
G:E EDIT1
|
|
W ! G REPEAT
|
|
NULL(DENTREC,Y) ; Null the existing fields from Initial Treatment
|
|
N FLD
|
|
F FLD=2,4,6,26,39 S $P(DENTREC,"^",FLD)=""
|
|
S Y=$G(DENTREC)
|
|
Q
|
|
CHECK ; Check Fields Validity.
|
|
S DENTCA=$P(DENTSTR,"^",19)
|
|
I DENTCA="" S E=1 W !,"Patient Category is Missing."
|
|
I DENTCA<8&(DENTCA'=4)&(DENTCA'=5)&($P(DENTSTR,"^",6)="") S E=1 W *7,!!,"Bed section is missing.",!
|
|
I $P(DENTSTR,"^",6)'="" I DENTCA>8!(DENTCA=4)!(DENTCA=5) S E=1 W *7,!!,"Bed section must be blank if patient category is OPT, NHC or DOM.",!
|
|
Q
|
|
CHK(CD) ;FIND A PLACE TO PUT THE NEW RECORD
|
|
N MO,MD,AD,YR,FL
|
|
S YR=$E(CD,1,3),MO=$E(CD,4,5),AD=$E(CD,6,7),FL=""
|
|
S CD=CD+.000001 ; Add a second if date/time exist
|
|
I $E(CD,13,14)>59 D ; CHECK SECOUNDS
|
|
.S CD=CD+.000040
|
|
.I $E(CD,11,12)>59 D ; CHECK MINUTES
|
|
..S CD=CD+.004000
|
|
..I $E(CD,9,10)>23 D ; CHECK HOURS
|
|
...S AD=AD+1,MD=$P($T(DATE),";",MO+2)
|
|
...S:+MO=2 MD=MD+$$LEAP^DENTE1(1700+YR)
|
|
...I AD>MD D ; CHECK DAYS
|
|
....S AD="01",MO=MO+1
|
|
....I MO>12 S YR=YR+1,MO="01" ; CHECK MONTH
|
|
S CD=YR_MO_AD_"."_$P(CD,".",2)
|
|
Q CD
|
|
GROUP ; Set Group X'Reference
|
|
S DENTSSN="000000001",DENTGRP=4,DENTPAT="",DENTNAM="GROUP"
|
|
Q
|
|
DATE ;;31;28;31;30;31;30;31;31;30;31;30;31
|
|
KIL K %,%DT,DA,DIC,DFN,DIE,DENTBED,DENTCA,DENTCAT,DENTPAT,DENTDFN,DENTPAT,DENTCT,DENTDT1,DR,DENTDTE,DENTFLE,DENTNAM,DENTP,DENTREC,DENTSTA,DENTSTR,DENTX,DENTY,DTOUT
|
|
K DENTBAT,DIR,DENTSSN,DENTGRP,DENTDAT,DENTPRV,DENTZ3,DIK,E,H,I,K,K1,N1,V,X,X1,Y,Z Q
|