ADEGRL4.m

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