source: FOIAVistA/tag/r/DENTAL-DEN/DENTSCR.m@ 636

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