- 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 Feb 18, 2025@23:13:13 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