ADEGRL4 ; IHS/HQT/MJL - DENTAL ENTRY PART 6 ;09:35 PM [ 03/24/1999 9:04 AM ]
;;6.0;ADE;;APRIL 1999;Build 13
;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
VSTAT ;EP
N ADEJ
S ADEJ=$$FYVIS(ADEPAT,ADEVDATE)
I ADEJ S ADEV($P(ADEJ,U,2))="1^" G VSTAT2
;
VSTAT1 D LIST^ADEGRL3
W !,"Visit Status Codes:",!,?8,"1 First Visit of the Fiscal Year",?52,"(0000)",!,?8,"2 Revisit (for any reason)",?52,"(0190)"
;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
;W:ADEDIR !,?8,"3 Broken Appointment",?52,"(9130)",!,?8,"4 Cancelled Appointment",?52,"(9140)"
W:ADEDIR !,?8,"3 Missed Appointment",?52,"(9986)",!,?8,"4 Cancelled Appointment",?52,"(9987)"
W !!,"Select Visit Status: "
R X:DTIME I $T<1 S Y=-1 Q
;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
;I X?4N S X=$S(X="0000":1,X="0190":2,(X=9130)&ADEDIR:3,(X=9140)&ADEDIR:4,1:"^")
I X?4N S X=$S(X="0000":1,X="0190":2,((X="9986")!(X="9130"))&ADEDIR:3,((X="9987")!(X="9140"))&ADEDIR:4,1:"^")
S X=$E(X_"^")
I X="^" S Y=-1 Q
I X["?" S XQH="ADE-DVIS-VCODE" D EN^XQH K XQH D ^ADECLS,^ADEHELP,LIST^ADEGRL3 G VSTAT1
I ADEDIR,("1234FRCBfrbc"'[X) W *7,"??" G VSTAT1
I ADECON,("12FRfr"'[X) W *7,"??" G VSTAT1
;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
;S ADEV($S((X="F")!(X="f")!(X=1):"0000",(X=2)!(X="R")!(X="r"):"0190",(X=3)!(X="B")!(X="b"):"9130",(X=4)!(X="C")!(X="c"):"9140"))="1^"
S ADEV($S((X="F")!(X="f")!(X=1):"0000",(X=2)!(X="R")!(X="r"):"0190",(X=3)!(X="B")!(X="b"):"9986",(X=4)!(X="C")!(X="c"):"9987"))="1^"
;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
;VSTAT2 S ADEDES("0000")="FIRST VISIT",ADEDES("0190")="REVISIT",ADEDES("9130")="BROKEN APPT",ADEDES("9140")="CANCELLED APPT",Y=1
VSTAT2 S ADEDES("0000")="FIRST VISIT",ADEDES("0190")="REVISIT",ADEDES("9130")="BROKEN APPT",ADEDES("9140")="CANCELLED APPT",ADEDES("9986")="MISSED APPT",ADEDES("9987")="CANCELLED APPT",Y=1
Q
;
FAC K DIC,Y S DIC="^ADEPARAM(DUZ(2),1,",DA(1)=DUZ(2),DIC(0)="AEZMQ",DIC("A")="Select Location of Encounter: " S:$D(ADELOE) DIC("B")=ADELOE D ^DIC Q:Y=-1
S ADELOED=Y(0),ADELOE=Y(0,0)
Q
PROV ;EP
N DIR
K DIC,Y S DIC=6,DIC(0)="MEZ"
S DIC("S")="D SCRN2^ADEGRL1"
W !,"Select HYGIENIST/THERAPIST: ",$S(ADEPVNM]"":ADEPVNM_"// ",1:"") R X:DTIME
Q:'$T
D ^DIC
I Y=-1,X="@" S (ADEPVNM,ADEPVNMD)="" D PROV2 K DIC,ADEDICS,Y Q
I Y=-1,X="" K DIC,ADEDICS,Y Q
I Y=-1 G PROV
S ADEPVNMD=$P(Y,U),ADEPVNM=Y(0,0)
K DIC,ADEDICS
PROV2 S DIR(0)="YA"
;S DIR("A")=""
W !!,"Do you want to use this same HYGIENIST/THERAPIST for subsequent",!,"visits in this data entry session?"
S DIR("B")="YES"
D ^DIR
I Y=1 S ADEPROD=ADEPVNMD,ADEPRO=ADEPVNM
Q
REPD ;EP
N DIR
K DIC,Y S DIC=6,DIC(0)="MEZ"
S DIC("S")="D SCRN1^ADEGRL1"
W !,"Select ATTENDING DENTIST: ",$S(ADERDNM]"":ADERDNM_"// ",1:"") R X:DTIME
Q:'$T
D ^DIC
I Y=-1,X="@" S (ADERDNM,ADERDNMD)="" D REPD2 K DIC,ADEDICS,Y Q
I Y=-1,X="" K DIC,ADEDICS,Y Q
I Y=-1 G REPD
S ADERDNMD=$P(Y,U),ADERDNM=Y(0,0)
K DIC,ADEDICS
REPD2 S DIR(0)="YA"
W !!,"Do you want to use this same ATTENDING DENTIST for subsequent",!,"visits in this data entry session?"
S DIR("B")="YES"
D ^DIR
I Y=1 S ADEREPD=ADERDNMD,ADEREP=ADERDNM
Q
NOTE ;EP
W !,"Dental Note: ",$S(ADENOTE]""&(ADENOTE'="@"):ADENOTE_"//",1:"")
R X:DTIME I '$T W *7 Q
I X=""!(X["^") Q
I X="@" S ADENOTE="@" Q
X $P(^DD(9002007,6,0),U,5,99) I '$D(X) W *7," ??" G NOTE
S ADENOTE=X Q
;
FYVIS(ADEPAT,ADEVDATE) ;EP - Returns "1/0^Visit Status"
;where 1 if able to compute first visit or revisit, otw 0
;and, if 1, where Visit Status=0000 or 0190
;Requires visit date and patient dfn
;
;Get FY of visit
N ADEVFM,ADEFY,ADEJ,ADEK,ADECNT,ADENDFY,ADEFV,ADERV
S %DT="T",X=ADEVDATE D ^%DT S ADEVFM=Y ;IHS/HMW **2**
;begin Y2K fix
;S ADEFY=1000
;S ADEFY="2"_$S($E(ADEVFM,4,5)<10:$E(ADEVFM,2,3)-1,1:$E(ADEVFM,2,3))_ADEFY
;S ADENDFY=ADEFY,$E(ADENDFY,2,3)=$E(ADENDFY,2,3)+1
Q:ADEVFM=-1 0 ;Y2000
S ADEFY=$E($P($$FISCAL^XBDT(ADEVFM),U,2),1,5)_"00" ;Y2000
S ADENDFY=ADEFY,$E(ADENDFY,1,3)=$E(ADENDFY,1,3)+1 ;Y2000
;Are there more than 5 visits in Oct of the fiscal year?
S ADEJ=ADEFY,ADECNT=0
;F S ADEJ=$O(^ADEPCD("AC",ADEJ)) Q:'+ADEJ Q:$E(ADEJ,2,5)'=$E(ADEFY,2,5) D Q:ADECNT>5
F S ADEJ=$O(^ADEPCD("AC",ADEJ)) Q:'+ADEJ Q:$E(ADEJ,1,5)'=$E(ADEFY,1,5) D Q:ADECNT>5 ;Y2000
. S ADEK=0 F S ADEK=$O(^ADEPCD("AC",ADEJ,ADEK)) Q:'+ADEK S ADECNT=ADECNT+1 Q:ADECNT>5
;end Y2K fix block
I ADECNT<6 Q 0
;Ok then, does this patient have a visit for this fy?
I '$D(^ADEPCD("DATE",ADEPAT)) Q "1^0000^FIRST VISIT"
S ADEJ=ADEFY
S ADEJ=$O(^ADEPCD("DATE",ADEPAT,ADEFY))
I ADEJ=""!(ADEJ>ADENDFY) Q "1^0000^FIRST VISIT"
;Check for a non-failed appt visit
S ADEFLG=0
S ADEJ=ADEFY
S ADEFV=$O(^AUTTADA("B","0000",0))
S ADERV=$O(^AUTTADA("B","0190",0))
F S ADEJ=$O(^ADEPCD("DATE",ADEPAT,ADEJ)) Q:'+ADEJ Q:ADEFLG D
. S ADEK=0 F S ADEK=$O(^ADEPCD("DATE",ADEPAT,ADEJ,ADEK)) Q:'+ADEK Q:ADEFLG D
. . I $D(^ADEPCD(ADEK,"ADA","B",ADEFV)) S ADEFLG=1 Q
. . I $D(^ADEPCD(ADEK,"ADA","B",ADERV)) S ADEFLG=1 Q
Q:ADEFLG "1^0190^REVISIT"
Q "1^0000^FIRST VISIT"
K ADEFY,ADENDFY ;*NE
ADEGRL4 ; IHS/HQT/MJL - DENTAL ENTRY PART 6 ;09:35 PM [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;;APRIL 1999;Build 13
+2 ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
VSTAT ;EP
+1 NEW ADEJ
+2 SET ADEJ=$$FYVIS(ADEPAT,ADEVDATE)
+3 IF ADEJ
SET ADEV($PIECE(ADEJ,U,2))="1^"
GOTO VSTAT2
+4 ;
VSTAT1 DO LIST^ADEGRL3
+1 WRITE !,"Visit Status Codes:",!,?8,"1 First Visit of the Fiscal Year",?52,"(0000)",!,?8,"2 Revisit (for any reason)",?52,"(0190)"
+2 ;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
+3 ;W:ADEDIR !,?8,"3 Broken Appointment",?52,"(9130)",!,?8,"4 Cancelled Appointment",?52,"(9140)"
+4 IF ADEDIR
WRITE !,?8,"3 Missed Appointment",?52,"(9986)",!,?8,"4 Cancelled Appointment",?52,"(9987)"
+5 WRITE !!,"Select Visit Status: "
+6 READ X:DTIME
IF $TEST<1
SET Y=-1
QUIT
+7 ;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
+8 ;I X?4N S X=$S(X="0000":1,X="0190":2,(X=9130)&ADEDIR:3,(X=9140)&ADEDIR:4,1:"^")
+9 IF X?4N
SET X=$SELECT(X="0000":1,X="0190":2,((X="9986")!(X="9130"))&ADEDIR:3,((X="9987")!(X="9140"))&ADEDIR:4,1:"^")
+10 SET X=$EXTRACT(X_"^")
+11 IF X="^"
SET Y=-1
QUIT
+12 IF X["?"
SET XQH="ADE-DVIS-VCODE"
DO EN^XQH
KILL XQH
DO ^ADECLS
DO ^ADEHELP
DO LIST^ADEGRL3
GOTO VSTAT1
+13 IF ADEDIR
IF ("1234FRCBfrbc"'[X)
WRITE *7,"??"
GOTO VSTAT1
+14 IF ADECON
IF ("12FRfr"'[X)
WRITE *7,"??"
GOTO VSTAT1
+15 ;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
+16 ;S ADEV($S((X="F")!(X="f")!(X=1):"0000",(X=2)!(X="R")!(X="r"):"0190",(X=3)!(X="B")!(X="b"):"9130",(X=4)!(X="C")!(X="c"):"9140"))="1^"
+17 SET ADEV($SELECT((X="F")!(X="f")!(X=1):"0000",(X=2)!(X="R")!(X="r"):"0190",(X=3)!(X="B")!(X="b"):"9986",(X=4)!(X="C")!(X="c"):"9987"))="1^"
+18 ;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates
+19 ;VSTAT2 S ADEDES("0000")="FIRST VISIT",ADEDES("0190")="REVISIT",ADEDES("9130")="BROKEN APPT",ADEDES("9140")="CANCELLED APPT",Y=1
VSTAT2 SET ADEDES("0000")="FIRST VISIT"
SET ADEDES("0190")="REVISIT"
SET ADEDES("9130")="BROKEN APPT"
SET ADEDES("9140")="CANCELLED APPT"
SET ADEDES("9986")="MISSED APPT"
SET ADEDES("9987")="CANCELLED APPT"
SET Y=1
+1 QUIT
+2 ;
FAC KILL DIC,Y
SET DIC="^ADEPARAM(DUZ(2),1,"
SET DA(1)=DUZ(2)
SET DIC(0)="AEZMQ"
SET DIC("A")="Select Location of Encounter: "
IF $DATA(ADELOE)
SET DIC("B")=ADELOE
DO ^DIC
IF Y=-1
QUIT
+1 SET ADELOED=Y(0)
SET ADELOE=Y(0,0)
+2 QUIT
PROV ;EP
+1 NEW DIR
+2 KILL DIC,Y
SET DIC=6
SET DIC(0)="MEZ"
+3 SET DIC("S")="D SCRN2^ADEGRL1"
+4 WRITE !,"Select HYGIENIST/THERAPIST: ",$SELECT(ADEPVNM]"":ADEPVNM_"// ",1:"")
READ X:DTIME
+5 IF '$TEST
QUIT
+6 DO ^DIC
+7 IF Y=-1
IF X="@"
SET (ADEPVNM,ADEPVNMD)=""
DO PROV2
KILL DIC,ADEDICS,Y
QUIT
+8 IF Y=-1
IF X=""
KILL DIC,ADEDICS,Y
QUIT
+9 IF Y=-1
GOTO PROV
+10 SET ADEPVNMD=$PIECE(Y,U)
SET ADEPVNM=Y(0,0)
+11 KILL DIC,ADEDICS
PROV2 SET DIR(0)="YA"
+1 ;S DIR("A")=""
+2 WRITE !!,"Do you want to use this same HYGIENIST/THERAPIST for subsequent",!,"visits in this data entry session?"
+3 SET DIR("B")="YES"
+4 DO ^DIR
+5 IF Y=1
SET ADEPROD=ADEPVNMD
SET ADEPRO=ADEPVNM
+6 QUIT
REPD ;EP
+1 NEW DIR
+2 KILL DIC,Y
SET DIC=6
SET DIC(0)="MEZ"
+3 SET DIC("S")="D SCRN1^ADEGRL1"
+4 WRITE !,"Select ATTENDING DENTIST: ",$SELECT(ADERDNM]"":ADERDNM_"// ",1:"")
READ X:DTIME
+5 IF '$TEST
QUIT
+6 DO ^DIC
+7 IF Y=-1
IF X="@"
SET (ADERDNM,ADERDNMD)=""
DO REPD2
KILL DIC,ADEDICS,Y
QUIT
+8 IF Y=-1
IF X=""
KILL DIC,ADEDICS,Y
QUIT
+9 IF Y=-1
GOTO REPD
+10 SET ADERDNMD=$PIECE(Y,U)
SET ADERDNM=Y(0,0)
+11 KILL DIC,ADEDICS
REPD2 SET DIR(0)="YA"
+1 WRITE !!,"Do you want to use this same ATTENDING DENTIST for subsequent",!,"visits in this data entry session?"
+2 SET DIR("B")="YES"
+3 DO ^DIR
+4 IF Y=1
SET ADEREPD=ADERDNMD
SET ADEREP=ADERDNM
+5 QUIT
NOTE ;EP
+1 WRITE !,"Dental Note: ",$SELECT(ADENOTE]""&(ADENOTE'="@"):ADENOTE_"//",1:"")
+2 READ X:DTIME
IF '$TEST
WRITE *7
QUIT
+3 IF X=""!(X["^")
QUIT
+4 IF X="@"
SET ADENOTE="@"
QUIT
+5 XECUTE $PIECE(^DD(9002007,6,0),U,5,99)
IF '$DATA(X)
WRITE *7," ??"
GOTO NOTE
+6 SET ADENOTE=X
QUIT
+7 ;
FYVIS(ADEPAT,ADEVDATE) ;EP - Returns "1/0^Visit Status"
+1 ;where 1 if able to compute first visit or revisit, otw 0
+2 ;and, if 1, where Visit Status=0000 or 0190
+3 ;Requires visit date and patient dfn
+4 ;
+5 ;Get FY of visit
+6 NEW ADEVFM,ADEFY,ADEJ,ADEK,ADECNT,ADENDFY,ADEFV,ADERV
+7 ;IHS/HMW **2**
SET %DT="T"
SET X=ADEVDATE
DO ^%DT
SET ADEVFM=Y
+8 ;begin Y2K fix
+9 ;S ADEFY=1000
+10 ;S ADEFY="2"_$S($E(ADEVFM,4,5)<10:$E(ADEVFM,2,3)-1,1:$E(ADEVFM,2,3))_ADEFY
+11 ;S ADENDFY=ADEFY,$E(ADENDFY,2,3)=$E(ADENDFY,2,3)+1
+12 ;Y2000
IF ADEVFM=-1
QUIT 0
+13 ;Y2000
SET ADEFY=$EXTRACT($PIECE($$FISCAL^XBDT(ADEVFM),U,2),1,5)_"00"
+14 ;Y2000
SET ADENDFY=ADEFY
SET $EXTRACT(ADENDFY,1,3)=$EXTRACT(ADENDFY,1,3)+1
+15 ;Are there more than 5 visits in Oct of the fiscal year?
+16 SET ADEJ=ADEFY
SET ADECNT=0
+17 ;F S ADEJ=$O(^ADEPCD("AC",ADEJ)) Q:'+ADEJ Q:$E(ADEJ,2,5)'=$E(ADEFY,2,5) D Q:ADECNT>5
+18 ;Y2000
FOR
SET ADEJ=$ORDER(^ADEPCD("AC",ADEJ))
IF '+ADEJ
QUIT
IF $EXTRACT(ADEJ,1,5)'=$EXTRACT(ADEFY,1,5)
QUIT
Begin DoDot:1
+19 SET ADEK=0
FOR
SET ADEK=$ORDER(^ADEPCD("AC",ADEJ,ADEK))
IF '+ADEK
QUIT
SET ADECNT=ADECNT+1
IF ADECNT>5
QUIT
End DoDot:1
IF ADECNT>5
QUIT
+20 ;end Y2K fix block
+21 IF ADECNT<6
QUIT 0
+22 ;Ok then, does this patient have a visit for this fy?
+23 IF '$DATA(^ADEPCD("DATE",ADEPAT))
QUIT "1^0000^FIRST VISIT"
+24 SET ADEJ=ADEFY
+25 SET ADEJ=$ORDER(^ADEPCD("DATE",ADEPAT,ADEFY))
+26 IF ADEJ=""!(ADEJ>ADENDFY)
QUIT "1^0000^FIRST VISIT"
+27 ;Check for a non-failed appt visit
+28 SET ADEFLG=0
+29 SET ADEJ=ADEFY
+30 SET ADEFV=$ORDER(^AUTTADA("B","0000",0))
+31 SET ADERV=$ORDER(^AUTTADA("B","0190",0))
+32 FOR
SET ADEJ=$ORDER(^ADEPCD("DATE",ADEPAT,ADEJ))
IF '+ADEJ
QUIT
IF ADEFLG
QUIT
Begin DoDot:1
+33 SET ADEK=0
FOR
SET ADEK=$ORDER(^ADEPCD("DATE",ADEPAT,ADEJ,ADEK))
IF '+ADEK
QUIT
IF ADEFLG
QUIT
Begin DoDot:2
+34 IF $DATA(^ADEPCD(ADEK,"ADA","B",ADEFV))
SET ADEFLG=1
QUIT
+35 IF $DATA(^ADEPCD(ADEK,"ADA","B",ADERV))
SET ADEFLG=1
QUIT
End DoDot:2
End DoDot:1
+36 IF ADEFLG
QUIT "1^0190^REVISIT"
+37 QUIT "1^0000^FIRST VISIT"
+38 ;*NE
KILL ADEFY,ADENDFY
