- 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
