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