ADEGRL2 ; IHS/HQT/MJL - DENTAL ENTRY PART 3 ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**26**;APRIL 1999;Build 13
;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
;
; RETURNS ADENEWVS=1 AND ADEVDATE (IF A NEW VISIT),
; ADENEWVS=0 AND ADEDFN (IF OLD VISIT)
; Y=1 IF SUCCESSFUL, OTHERWISE Y=0
; IF NO TIME ENTERED, DEFAULTS TO 0800 ***TODO: Parameterize
;------->GET VISIT DATE
CTRL D VSLOOK
G:'Y END
;------->CHECK DATE OF DEATH
D DOD G:'Y CTRL
;------->CHECK DELIVERY MODE
I 'ADENEWVS D DELIV G:'Y CTRL
END Q
DELIV I ADECON,$P(^ADEPCD(ADEDFN,0),U,9)'="c" W !?5,"***Only CONTRACT Visits may be edited in this mode***" S Y=0 Q
I ADEDIR,$P(^ADEPCD(ADEDFN,0),U,9)="c" W !?5,"***CONTRACT Visits cannot be selected in this option***" S Y=0 Q
Q
DOD S X=ADEVDATE,%DT="T" D ^%DT
I $D(^DPT(ADEPAT,.35)),$P(^(.35),U),$P(^(.35),U)<Y S Y=0 W !?5,"***PATIENT DIED BEFORE THIS DATE***",*7 Q
I Y<2840101 S Y=0 W !?5,"***MUST BE AFTER 1 JANUARY 84***",*7 Q
S Y=1
Q
VSLOOK ;EP
S ADENEWVS=0 K ADEDFN,ADEVDATE
N ADETIMEE
S ADETIMEE="08" ;***TODO: Replace with site parameter
R !!,"Date of Visit: ",X:DTIME
I '$T!(X["^")!(X="") S Y=0 Q
;------->FORCED NEW VISIT WITH QUOTES
I X[$C(34) S X=$P(X,$C(34),2),%DT="TEP",%DT(0)=-(DT+.235959) D ^%DT K %DT G:Y<1 VSLOOK X ^DD("DD") S ADENEWVS=1,ADEVDATE=Y,Y=1 Q
I X["?" D VSHELP G VSLOOK
S %DT="TEP",%DT(0)=-(DT+.235959) D ^%DT K %DT G:Y<1 VSLOOK
;I '$D(^ADEPCD("DATE",ADEPAT,Y)) S ADENEWVS=1 S:$P(Y,".",2)="" $P(Y,".",2)=$S(ADETIMEE]"":ADETIMEE,1:"09") X ^DD("DD") S ADEVDATE=Y,Y=1 Q
I '$D(^ADEPCD("DATE",ADEPAT,Y)) S:$P(Y,".",2)="" $P(Y,".",2)=$S(ADETIMEE]"":ADETIMEE,1:"09") I '$D(^ADEPCD("DATE",ADEPAT,Y)) S ADENEWVS=1 X ^DD("DD") S ADEVDATE=Y,Y=1 Q
;------->AT LEAST ONE VISIT ALREADY EXISTS FOR DATE
S ADEVFM=Y X ^DD("DD") S ADEVDATE=Y
S ADEVCNT=0,ADEDFN=0
F ADE=0:0 S ADEDFN=$O(^ADEPCD("DATE",ADEPAT,ADEVFM,ADEDFN)) Q:ADEDFN="" D VSLOOK4
I ADEVCNT=1 S ADEDFN=ADEVDFN(1) S ADENEWVS=0,Y=1 K ADEVDFN Q
I ADEVCNT=0 S ADENEWVS=1,Y=1 Q
;------->MORE THAN ONE VISIT FOR DATE
F ADE=1:1:ADEVCNT S ADEDFN=ADEVDFN(ADE) D VSHELP1
W !,"Select Visit Number 1-",ADE,": "
R ADEX:DTIME
I '$T!(ADEX="") S Y=0 K ADEVDFN,ADEVCNT,ADEVFM,ADE,ADEVDATE G VSLOOK
I +ADEX<1!(+ADEX>ADEVCNT) W *7," ??" K ADEVDFN,ADEVCNT,ADEVFM,ADE,ADEVDATE G VSLOOK
S ADEDFN=ADEVDFN(ADEX) S Y=1,ADENEWVS=0
K ADEVDFN,ADEX,ADE,ADEVCNT Q
VSLOOK4 Q:'$D(^ADEPCD(ADEDFN,0))
I '$D(ADEDIR) S ADEVCNT=ADEVCNT+1,ADEVDFN(ADEVCNT)=ADEDFN Q
I ADEDIR,$P(^ADEPCD(ADEDFN,0),U,9)'="c" S ADEVCNT=ADEVCNT+1,ADEVDFN(ADEVCNT)=ADEDFN Q
I ADECON,$P(^ADEPCD(ADEDFN,0),U,9)="c" S ADEVCNT=ADEVCNT+1,ADEVDFN(ADEVCNT)=ADEDFN Q
Q
VSHELP I X'="?" S XQH="ADE-DVIS-DATE" D EN^XQH K XQH D ^ADECLS Q
W !,"You may enter a new visit if you wish."
W !,"Enter two question marks `??' for general help on entering dates, or"
W !,"Enter the Date of an old Visit"
Q:'$D(^ADEPCD("DATE",ADEPAT))
W !,"Choose from:"
S ADEVFM=0 F ADE=0:0 S ADEVFM=$O(^ADEPCD("DATE",ADEPAT,ADEVFM)) Q:'+ADEVFM S ADEDFN=0 S Y=ADEVFM X ^DD("DD") F ADEQ=0:0 S ADEDFN=$O(^ADEPCD("DATE",ADEPAT,ADEVFM,ADEDFN)) Q:'+ADEDFN D VSHELP1
VSHELP0 K ADEQ Q
VSHELP1 Q:'$D(^ADEPCD(ADEDFN,0))
I $D(ADECON),ADECON,$P(^ADEPCD(ADEDFN,0),U,9)'="c" Q
I $D(ADEDIR),ADEDIR,$P(^ADEPCD(ADEDFN,0),U,9)="c" Q
W ! W:+ADE ADE,". " W Y
W ?20," ",$S($P(^ADEPCD(ADEDFN,0),U,9)="c":"CONTRACT",1:"DIRECT")
I $P(^ADEPCD(ADEDFN,0),U,4)]"",$D(^DIC(16,$P(^ADEPCD(ADEDFN,0),U,4),0)) W ?30," ",$P(^(0),U) ;IHS/HMW 1-4-90
I $D(^AUTTADA("B","9140")),$O(^AUTTADA("B","9140",0)),$D(^ADEPCD(ADEDFN,"ADA","B",$O(^AUTTADA("B","9140",0)))) W ?60,"<CANCELLATION>"
I $D(^AUTTADA("B","9130")),$O(^AUTTADA("B","9130",0)),$D(^ADEPCD(ADEDFN,"ADA","B",$O(^AUTTADA("B","9130",0)))) W ?60,"<BROKEN APPT.>"
;/IHS/OIT/GAB Patch #26 Added below two lines for 2015 codes, will be replacing 9130 & 9140 (don't remove old codes yet)
I $D(^AUTTADA("B","9987")),$O(^AUTTADA("B","9987",0)),$D(^ADEPCD(ADEDFN,"ADA","B",$O(^AUTTADA("B","9987",0)))) W ?60,"<CANCELLATION>"
I $D(^AUTTADA("B","9986")),$O(^AUTTADA("B","9986",0)),$D(^ADEPCD(ADEDFN,"ADA","B",$O(^AUTTADA("B","9986",0)))) W ?60,"<MISSED APPT.>"
Q
ADEGRL2 ; IHS/HQT/MJL - DENTAL ENTRY PART 3 ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**26**;APRIL 1999;Build 13
+2 ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
+3 ;
+4 ; RETURNS ADENEWVS=1 AND ADEVDATE (IF A NEW VISIT),
+5 ; ADENEWVS=0 AND ADEDFN (IF OLD VISIT)
+6 ; Y=1 IF SUCCESSFUL, OTHERWISE Y=0
+7 ; IF NO TIME ENTERED, DEFAULTS TO 0800 ***TODO: Parameterize
+8 ;------->GET VISIT DATE
CTRL DO VSLOOK
+1 IF 'Y
GOTO END
+2 ;------->CHECK DATE OF DEATH
+3 DO DOD
IF 'Y
GOTO CTRL
+4 ;------->CHECK DELIVERY MODE
+5 IF 'ADENEWVS
DO DELIV
IF 'Y
GOTO CTRL
END QUIT
DELIV IF ADECON
IF $PIECE(^ADEPCD(ADEDFN,0),U,9)'="c"
WRITE !?5,"***Only CONTRACT Visits may be edited in this mode***"
SET Y=0
QUIT
+1 IF ADEDIR
IF $PIECE(^ADEPCD(ADEDFN,0),U,9)="c"
WRITE !?5,"***CONTRACT Visits cannot be selected in this option***"
SET Y=0
QUIT
+2 QUIT
DOD SET X=ADEVDATE
SET %DT="T"
DO ^%DT
+1 IF $DATA(^DPT(ADEPAT,.35))
IF $PIECE(^(.35),U)
IF $PIECE(^(.35),U)<Y
SET Y=0
WRITE !?5,"***PATIENT DIED BEFORE THIS DATE***",*7
QUIT
+2 IF Y<2840101
SET Y=0
WRITE !?5,"***MUST BE AFTER 1 JANUARY 84***",*7
QUIT
+3 SET Y=1
+4 QUIT
VSLOOK ;EP
+1 SET ADENEWVS=0
KILL ADEDFN,ADEVDATE
+2 NEW ADETIMEE
+3 ;***TODO: Replace with site parameter
SET ADETIMEE="08"
+4 READ !!,"Date of Visit: ",X:DTIME
+5 IF '$TEST!(X["^")!(X="")
SET Y=0
QUIT
+6 ;------->FORCED NEW VISIT WITH QUOTES
+7 IF X[$CHAR(34)
SET X=$PIECE(X,$CHAR(34),2)
SET %DT="TEP"
SET %DT(0)=-(DT+.235959)
DO ^%DT
KILL %DT
IF Y<1
GOTO VSLOOK
XECUTE ^DD("DD")
SET ADENEWVS=1
SET ADEVDATE=Y
SET Y=1
QUIT
+8 IF X["?"
DO VSHELP
GOTO VSLOOK
+9 SET %DT="TEP"
SET %DT(0)=-(DT+.235959)
DO ^%DT
KILL %DT
IF Y<1
GOTO VSLOOK
+10 ;I '$D(^ADEPCD("DATE",ADEPAT,Y)) S ADENEWVS=1 S:$P(Y,".",2)="" $P(Y,".",2)=$S(ADETIMEE]"":ADETIMEE,1:"09") X ^DD("DD") S ADEVDATE=Y,Y=1 Q
+11 IF '$DATA(^ADEPCD("DATE",ADEPAT,Y))
IF $PIECE(Y,".",2)=""
SET $PIECE(Y,".",2)=$SELECT(ADETIMEE]"":ADETIMEE,1:"09")
IF '$DATA(^ADEPCD("DATE",ADEPAT,Y))
SET ADENEWVS=1
XECUTE ^DD("DD")
SET ADEVDATE=Y
SET Y=1
QUIT
+12 ;------->AT LEAST ONE VISIT ALREADY EXISTS FOR DATE
+13 SET ADEVFM=Y
XECUTE ^DD("DD")
SET ADEVDATE=Y
+14 SET ADEVCNT=0
SET ADEDFN=0
+15 FOR ADE=0:0
SET ADEDFN=$ORDER(^ADEPCD("DATE",ADEPAT,ADEVFM,ADEDFN))
IF ADEDFN=""
QUIT
DO VSLOOK4
+16 IF ADEVCNT=1
SET ADEDFN=ADEVDFN(1)
SET ADENEWVS=0
SET Y=1
KILL ADEVDFN
QUIT
+17 IF ADEVCNT=0
SET ADENEWVS=1
SET Y=1
QUIT
+18 ;------->MORE THAN ONE VISIT FOR DATE
+19 FOR ADE=1:1:ADEVCNT
SET ADEDFN=ADEVDFN(ADE)
DO VSHELP1
+20 WRITE !,"Select Visit Number 1-",ADE,": "
+21 READ ADEX:DTIME
+22 IF '$TEST!(ADEX="")
SET Y=0
KILL ADEVDFN,ADEVCNT,ADEVFM,ADE,ADEVDATE
GOTO VSLOOK
+23 IF +ADEX<1!(+ADEX>ADEVCNT)
WRITE *7," ??"
KILL ADEVDFN,ADEVCNT,ADEVFM,ADE,ADEVDATE
GOTO VSLOOK
+24 SET ADEDFN=ADEVDFN(ADEX)
SET Y=1
SET ADENEWVS=0
+25 KILL ADEVDFN,ADEX,ADE,ADEVCNT
QUIT
VSLOOK4 IF '$DATA(^ADEPCD(ADEDFN,0))
QUIT
+1 IF '$DATA(ADEDIR)
SET ADEVCNT=ADEVCNT+1
SET ADEVDFN(ADEVCNT)=ADEDFN
QUIT
+2 IF ADEDIR
IF $PIECE(^ADEPCD(ADEDFN,0),U,9)'="c"
SET ADEVCNT=ADEVCNT+1
SET ADEVDFN(ADEVCNT)=ADEDFN
QUIT
+3 IF ADECON
IF $PIECE(^ADEPCD(ADEDFN,0),U,9)="c"
SET ADEVCNT=ADEVCNT+1
SET ADEVDFN(ADEVCNT)=ADEDFN
QUIT
+4 QUIT
VSHELP IF X'="?"
SET XQH="ADE-DVIS-DATE"
DO EN^XQH
KILL XQH
DO ^ADECLS
QUIT
+1 WRITE !,"You may enter a new visit if you wish."
+2 WRITE !,"Enter two question marks `??' for general help on entering dates, or"
+3 WRITE !,"Enter the Date of an old Visit"
+4 IF '$DATA(^ADEPCD("DATE",ADEPAT))
QUIT
+5 WRITE !,"Choose from:"
+6 SET ADEVFM=0
FOR ADE=0:0
SET ADEVFM=$ORDER(^ADEPCD("DATE",ADEPAT,ADEVFM))
IF '+ADEVFM
QUIT
SET ADEDFN=0
SET Y=ADEVFM
XECUTE ^DD("DD")
FOR ADEQ=0:0
SET ADEDFN=$ORDER(^ADEPCD("DATE",ADEPAT,ADEVFM,ADEDFN))
IF '+ADEDFN
QUIT
DO VSHELP1
VSHELP0 KILL ADEQ
QUIT
VSHELP1 IF '$DATA(^ADEPCD(ADEDFN,0))
QUIT
+1 IF $DATA(ADECON)
IF ADECON
IF $PIECE(^ADEPCD(ADEDFN,0),U,9)'="c"
QUIT
+2 IF $DATA(ADEDIR)
IF ADEDIR
IF $PIECE(^ADEPCD(ADEDFN,0),U,9)="c"
QUIT
+3 WRITE !
IF +ADE
WRITE ADE,". "
WRITE Y
+4 WRITE ?20," ",$SELECT($PIECE(^ADEPCD(ADEDFN,0),U,9)="c":"CONTRACT",1:"DIRECT")
+5 ;IHS/HMW 1-4-90
IF $PIECE(^ADEPCD(ADEDFN,0),U,4)]""
IF $DATA(^DIC(16,$PIECE(^ADEPCD(ADEDFN,0),U,4),0))
WRITE ?30," ",$PIECE(^(0),U)
+6 IF $DATA(^AUTTADA("B","9140"))
IF $ORDER(^AUTTADA("B","9140",0))
IF $DATA(^ADEPCD(ADEDFN,"ADA","B",$ORDER(^AUTTADA("B","9140",0))))
WRITE ?60,"<CANCELLATION>"
+7 IF $DATA(^AUTTADA("B","9130"))
IF $ORDER(^AUTTADA("B","9130",0))
IF $DATA(^ADEPCD(ADEDFN,"ADA","B",$ORDER(^AUTTADA("B","9130",0))))
WRITE ?60,"<BROKEN APPT.>"
+8 ;/IHS/OIT/GAB Patch #26 Added below two lines for 2015 codes, will be replacing 9130 & 9140 (don't remove old codes yet)
+9 IF $DATA(^AUTTADA("B","9987"))
IF $ORDER(^AUTTADA("B","9987",0))
IF $DATA(^ADEPCD(ADEDFN,"ADA","B",$ORDER(^AUTTADA("B","9987",0))))
WRITE ?60,"<CANCELLATION>"
+10 IF $DATA(^AUTTADA("B","9986"))
IF $ORDER(^AUTTADA("B","9986",0))
IF $DATA(^ADEPCD(ADEDFN,"ADA","B",$ORDER(^AUTTADA("B","9986",0))))
WRITE ?60,"<MISSED APPT.>"
+11 QUIT
