ADEGRL ; IHS/HQT/MJL - DENTAL DATA ENTRY PT 1 ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999
;V4.31 ORIG 5-14-88
;------->INITIALIZE
D INIT^ADEGRL0 G:'Y END
ONE ;------->RESET CONSTANT VALUES
D RESET^ADEGRL1 G:Y<1 END
TWO ;------->LOOK UP A PATIENT
W !!,"Press RETURN to change LOCATION of ENCOUNTER"
W !,?15,"-OR-"
D PTLOOK^ADEGRL1 G:Y<1 ONE
THREE ;------->GET A VISIT DATE
D ^ADEGRL2 I Y<1 K ^ADEUTL("ADELOCK",ADEPAT) G TWO
FOUR ;------->LOAD LOCAL VARIABLES WITH CURRENT VISIT DATA
D MOD
FIVE ;------->COLLECT VISIT INFO
D ^ADEGRL3
SIX ;------->WRITE DATA TO DISK
D ^ADEGRL6
SEVEN ;------->GET ANOTHER PATIENT
K ADETCH,ADETCHF G TWO
END ;EP
S:$D(ADEDUZ(2)) DUZ(2)=ADEDUZ(2) ;IHS/MFD added set, U lookup IHS/HMW added condition
I $D(^ADEUTL($J,"DUZ2")) S DUZ(2)=^ADEUTL($J,"DUZ2")
K ^ADEUTL($J,"DUZ2")
K ADE,ADECNT,ADECOD,ADECON,ADED0,ADEDEF,ADEDEL,ADEDENT,ADEDES,ADEDFN,ADEDIC,ADEDICS,ADEDIR,ADEDUP,ADEFAC,ADEFACD,ADEFAST,ADEFEE,ADEFLG,ADEHOLD
K ADEHRN,ADEI,ADEJ,ADEK,ADELIN,ADELN,ADELOE,ADELOED,ADEMOD,ADENEW,ADENEWPT,ADENEWVS,ADENOOP,ADENOTE,ADENOUPD,ADEODFN,ADEOP,ADEPAT,ADEPC,ADEPNM,ADEPRO
K ADEPROD,ADEPVNM,ADEPVNMD,ADEQTY,ADERDNM,ADERDNMD,ADEREB,ADEREP,ADEREPD,ADES,ADESTR,ADESVC,ADETCH,ADETCHF,ADETFE,ADETITL,ADETMP,ADEV,ADEVCNT,ADEVDATE
K ADEVDFN,ADEVFM,ADEVIS,ADEX,ADEY,ADEQUIT,ADELOCSI,ADELOCFC,ADEDUZ,AUPNLK("ALL")
Q
MOD ;EP
I ADENEWVS S ADELOE=ADEFAC,ADEPVNM=ADEPRO,ADERDNM=ADEREP,ADELOED=ADEFACD,ADEPVNMD=ADEPROD,ADERDNMD=ADEREPD,ADENOTE="",ADETCH=0,ADETCHF=0
E D LOAD(ADEDFN)
Q
LOAD(ADEDFN) ;Given ADEDFN, loads local arrays with visit data
N ADEJ,ADEOP,ADEK,ADESFC,ADETFE,ADEX,ADEY,ADEZ,ADENONR,ADENOD
MOD0 S ADEJ=0,ADEOP=""
MOD1 S ADEJ=$O(^ADEPCD(ADEDFN,"ADA","B",ADEJ)) I ADEJ="" K ADECNT,ADEK,ADEOP G MOD4
G:'$D(^AUTTADA(ADEJ)) MOD1
S (ADECNT,ADEK,ADETFE)=0,ADEOP="",ADESFC="",ADENONR=""
MOD2 S ADEK=$O(^ADEPCD(ADEDFN,"ADA","B",ADEJ,ADEK))
I ADEK="" S ADEK=$P(^AUTTADA(ADEJ,0),U),ADEV(ADEK)=ADECNT_U_ADEOP,ADEDES(ADEK)=$P(^AUTTADA(ADEJ,0),U,6) S:ADECON ADEV(ADEK)=ADEV(ADEK)_U_ADETFE S $P(ADEV(ADEK),U,4)=ADESFC,$P(ADEV(ADEK),U,5)=ADENONR G MOD1
S ADECNT=ADECNT+1
S ADENOD=^ADEPCD(ADEDFN,"ADA",ADEK,0)
A I ADECON,'ADETFE S ADETFE=+$P(ADENOD,U,3)
S ADEX=$P(ADENOD,U,2)
S ADEZ=$P(ADENOD,U,5)
S $P(ADENONR,",",ADECNT)=ADEZ G:ADEX="" MOD2
Z S ADEY=$P(ADENOD,U,4)
G:'$D(^ADEOPS(ADEX,88)) MOD2
S $P(ADEOP,",",ADECNT)=ADEX
S $P(ADESFC,",",ADECNT)=ADEY
G MOD2
MOD4 ;------->Get Location, Provider, etc.
K ADELOE,ADEPVNM,ADERDNM,ADELOED,ADEPVNMD,ADERDNMD
I $P(^ADEPCD(ADEDFN,0),U,3)]"",$D(^DIC(4,$P(^ADEPCD(ADEDFN,0),U,3),0)) S ADELOE=$P(^(0),U),ADELOED=$P(^ADEPCD(ADEDFN,0),U,3)
S:'$D(ADELOE) (ADELOE,ADELOED)=""
I $P(^ADEPCD(ADEDFN,0),U,5)]"",$D(^DIC(16,$P(^ADEPCD(ADEDFN,0),U,5),0)) S ADEPVNM=$P(^(0),U),ADEPVNMD=$P(^ADEPCD(ADEDFN,0),U,5)
S:'$D(ADEPVNM) (ADEPVNM,ADEPVNMD)=""
I $P(^ADEPCD(ADEDFN,0),U,4)]"",$D(^DIC(16,$P(^ADEPCD(ADEDFN,0),U,4),0)) S ADERDNM=$P(^(0),U),ADERDNMD=$P(^ADEPCD(ADEDFN,0),U,4)
S:'$D(ADERDNM) (ADERDNM,ADERDNMD)=""
I $P(^ADEPCD(ADEDFN,0),U,7)]"" S ADENOTE=$P(^(0),U,7)
S:'$D(ADENOTE) ADENOTE=""
S ADETCHF=1,ADETCH=+$P(^ADEPCD(ADEDFN,0),U,8)
Q
CHKQ S Y=1 Q:'$D(^ADEPOST)
I $O(^ADEPOST(0))&('$D(^ADEUTL("ADEDQUE"))) S Y=0 W !,*7,"ERROR DETECTED -- DENTAL RECORDS ARE IN THE QUEUE WHICH ARE NOT BEING",!,"POSTED. CONTACT SITE MANAGER OR DENTAL HEADQUARTERS FOR ASSISTANCE BEFORE",!,"ENTERING MORE DATA" Q
S Y=1 Q
ADEGRL ; IHS/HQT/MJL - DENTAL DATA ENTRY PT 1 ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;V4.31 ORIG 5-14-88
+3 ;------->INITIALIZE
+4 DO INIT^ADEGRL0
IF 'Y
GOTO END
ONE ;------->RESET CONSTANT VALUES
+1 DO RESET^ADEGRL1
IF Y<1
GOTO END
TWO ;------->LOOK UP A PATIENT
+1 WRITE !!,"Press RETURN to change LOCATION of ENCOUNTER"
+2 WRITE !,?15,"-OR-"
+3 DO PTLOOK^ADEGRL1
IF Y<1
GOTO ONE
THREE ;------->GET A VISIT DATE
+1 DO ^ADEGRL2
IF Y<1
KILL ^ADEUTL("ADELOCK",ADEPAT)
GOTO TWO
FOUR ;------->LOAD LOCAL VARIABLES WITH CURRENT VISIT DATA
+1 DO MOD
FIVE ;------->COLLECT VISIT INFO
+1 DO ^ADEGRL3
SIX ;------->WRITE DATA TO DISK
+1 DO ^ADEGRL6
SEVEN ;------->GET ANOTHER PATIENT
+1 KILL ADETCH,ADETCHF
GOTO TWO
END ;EP
+1 ;IHS/MFD added set, U lookup IHS/HMW added condition
IF $DATA(ADEDUZ(2))
SET DUZ(2)=ADEDUZ(2)
+2 IF $DATA(^ADEUTL($JOB,"DUZ2"))
SET DUZ(2)=^ADEUTL($JOB,"DUZ2")
+3 KILL ^ADEUTL($JOB,"DUZ2")
+4 KILL ADE,ADECNT,ADECOD,ADECON,ADED0,ADEDEF,ADEDEL,ADEDENT,ADEDES,ADEDFN,ADEDIC,ADEDICS,ADEDIR,ADEDUP,ADEFAC,ADEFACD,ADEFAST,ADEFEE,ADEFLG,ADEHOLD
+5 KILL ADEHRN,ADEI,ADEJ,ADEK,ADELIN,ADELN,ADELOE,ADELOED,ADEMOD,ADENEW,ADENEWPT,ADENEWVS,ADENOOP,ADENOTE,ADENOUPD,ADEODFN,ADEOP,ADEPAT,ADEPC,ADEPNM,ADEPRO
+6 KILL ADEPROD,ADEPVNM,ADEPVNMD,ADEQTY,ADERDNM,ADERDNMD,ADEREB,ADEREP,ADEREPD,ADES,ADESTR,ADESVC,ADETCH,ADETCHF,ADETFE,ADETITL,ADETMP,ADEV,ADEVCNT,ADEVDATE
+7 KILL ADEVDFN,ADEVFM,ADEVIS,ADEX,ADEY,ADEQUIT,ADELOCSI,ADELOCFC,ADEDUZ,AUPNLK("ALL")
+8 QUIT
MOD ;EP
+1 IF ADENEWVS
SET ADELOE=ADEFAC
SET ADEPVNM=ADEPRO
SET ADERDNM=ADEREP
SET ADELOED=ADEFACD
SET ADEPVNMD=ADEPROD
SET ADERDNMD=ADEREPD
SET ADENOTE=""
SET ADETCH=0
SET ADETCHF=0
+2 IF '$TEST
DO LOAD(ADEDFN)
+3 QUIT
LOAD(ADEDFN) ;Given ADEDFN, loads local arrays with visit data
+1 NEW ADEJ,ADEOP,ADEK,ADESFC,ADETFE,ADEX,ADEY,ADEZ,ADENONR,ADENOD
MOD0 SET ADEJ=0
SET ADEOP=""
MOD1 SET ADEJ=$ORDER(^ADEPCD(ADEDFN,"ADA","B",ADEJ))
IF ADEJ=""
KILL ADECNT,ADEK,ADEOP
GOTO MOD4
+1 IF '$DATA(^AUTTADA(ADEJ))
GOTO MOD1
+2 SET (ADECNT,ADEK,ADETFE)=0
SET ADEOP=""
SET ADESFC=""
SET ADENONR=""
MOD2 SET ADEK=$ORDER(^ADEPCD(ADEDFN,"ADA","B",ADEJ,ADEK))
+1 IF ADEK=""
SET ADEK=$PIECE(^AUTTADA(ADEJ,0),U)
SET ADEV(ADEK)=ADECNT_U_ADEOP
SET ADEDES(ADEK)=$PIECE(^AUTTADA(ADEJ,0),U,6)
IF ADECON
SET ADEV(ADEK)=ADEV(ADEK)_U_ADETFE
SET $PIECE(ADEV(ADEK),U,4)=ADESFC
SET $PIECE(ADEV(ADEK),U,5)=ADENONR
GOTO MOD1
+2 SET ADECNT=ADECNT+1
+3 SET ADENOD=^ADEPCD(ADEDFN,"ADA",ADEK,0)
A IF ADECON
IF 'ADETFE
SET ADETFE=+$PIECE(ADENOD,U,3)
+1 SET ADEX=$PIECE(ADENOD,U,2)
+2 SET ADEZ=$PIECE(ADENOD,U,5)
+3 SET $PIECE(ADENONR,",",ADECNT)=ADEZ
IF ADEX=""
GOTO MOD2
Z SET ADEY=$PIECE(ADENOD,U,4)
+1 IF '$DATA(^ADEOPS(ADEX,88))
GOTO MOD2
+2 SET $PIECE(ADEOP,",",ADECNT)=ADEX
+3 SET $PIECE(ADESFC,",",ADECNT)=ADEY
+4 GOTO MOD2
MOD4 ;------->Get Location, Provider, etc.
+1 KILL ADELOE,ADEPVNM,ADERDNM,ADELOED,ADEPVNMD,ADERDNMD
+2 IF $PIECE(^ADEPCD(ADEDFN,0),U,3)]""
IF $DATA(^DIC(4,$PIECE(^ADEPCD(ADEDFN,0),U,3),0))
SET ADELOE=$PIECE(^(0),U)
SET ADELOED=$PIECE(^ADEPCD(ADEDFN,0),U,3)
+3 IF '$DATA(ADELOE)
SET (ADELOE,ADELOED)=""
+4 IF $PIECE(^ADEPCD(ADEDFN,0),U,5)]""
IF $DATA(^DIC(16,$PIECE(^ADEPCD(ADEDFN,0),U,5),0))
SET ADEPVNM=$PIECE(^(0),U)
SET ADEPVNMD=$PIECE(^ADEPCD(ADEDFN,0),U,5)
+5 IF '$DATA(ADEPVNM)
SET (ADEPVNM,ADEPVNMD)=""
+6 IF $PIECE(^ADEPCD(ADEDFN,0),U,4)]""
IF $DATA(^DIC(16,$PIECE(^ADEPCD(ADEDFN,0),U,4),0))
SET ADERDNM=$PIECE(^(0),U)
SET ADERDNMD=$PIECE(^ADEPCD(ADEDFN,0),U,4)
+7 IF '$DATA(ADERDNM)
SET (ADERDNM,ADERDNMD)=""
+8 IF $PIECE(^ADEPCD(ADEDFN,0),U,7)]""
SET ADENOTE=$PIECE(^(0),U,7)
+9 IF '$DATA(ADENOTE)
SET ADENOTE=""
+10 SET ADETCHF=1
SET ADETCH=+$PIECE(^ADEPCD(ADEDFN,0),U,8)
+11 QUIT
CHKQ SET Y=1
IF '$DATA(^ADEPOST)
QUIT
+1 IF $ORDER(^ADEPOST(0))&('$DATA(^ADEUTL("ADEDQUE")))
SET Y=0
WRITE !,*7,"ERROR DETECTED -- DENTAL RECORDS ARE IN THE QUEUE WHICH ARE NOT BEING",!,"POSTED. CONTACT SITE MANAGER OR DENTAL HEADQUARTERS FOR ASSISTANCE BEFORE",!,"ENTERING MORE DATA"
QUIT
+2 SET Y=1
QUIT
