BKMRMEX ;PRXM/HC/ALA-HMS Exam Reminders ; 13 Nov 2007 4:02 PM
;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
EX01(GUI) ;EP - REM.P.01
; Eye Exam Due
; Due date = Today, if no dilated eye exam (P.03) ever documented.
; Due date = Date of most recent dilated eye exam + 183 days (or 6 months)
; if any CD4 Absolute laboratory test (T.30) since most recent
; dilated eye exam is < 50.
; Above definition changed from CD4 (T.2) to CD4 Absolute (T.30) and from most recent to any.
; Due date = Date of most recent dilated eye exam + 365 days (or 12 months).
; If "Now," then text = "Dilated eye exam may be due now; last documented [date]."
NEW LAST,DUE,LAST1,LRESULT,LIST,PRV,CLN,CD4
S GUI=$G(GUI,0)
S (LAST,DUE,LAST1,LRESULT)=""
D EXAMTAX^BKMIXX1(DFN,"03","","","",.LAST)
D CPTTAX^BKMIXX(DFN,"BGP EYE EXAM CPTS","","","",.LAST1)
S LAST=$S(LAST>LAST1:LAST,1:LAST1)
D ICDTAX^BKMIXX1(DFN,"BQI EYE EXAM DXS","","","",.LAST1)
S LAST=$S(LAST>LAST1:LAST,1:LAST1)
;Check provider codes
F PRV="79","24","08" D
. D PRVTAX^BKMIXX2(DFN,PRV,"","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
;Check clinic codes
F CLN="17","18","64","A2" D
. D CLNTAX^BKMIXX2(DFN,CLN,"","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
I LAST'="" D
. N GLOBAL,LABTEST,SINCE,CD4
. S SINCE=LAST\1_".2400" ;Get tests since most recent eye exam
. S GLOBAL="LABTEST(VSTDT,TEST,""LAB"")"
. D LABTAX^BKMIXX(DFN,"BKMV CD4 ABS TESTS TAX","",SINCE,GLOBAL)
. D LOINC^BKMIXX(DFN,"BKMV CD4 ABS LOINC CODES","",SINCE,GLOBAL)
. S GLOBAL="LABTEST(VSTDT,TEST,""CPT"")"
. D CPTTAX^BKMIXX(DFN,"BKMV CD4 ABS CPTS","",SINCE,GLOBAL)
. S DUE=+$$SCH^XLFDT("12M",LAST)
. S CD4="LABTEST"
. F S CD4=$Q(@CD4) Q:CD4="" I $P(@CD4,U)]"",$P(@CD4,U)<50 S DUE=+$$SCH^XLFDT("6M",LAST) Q
I LAST="" S DUE=DT
D ADDLINE^BKMVF32("29 REM.P.01",.LIST,"Dilated Eye Exam",LAST,DUE)
D WRITE("29 REM.P.01",GUI)
Q
;
EX02(GUI) ;EP - REM.P.02
; Dental Exam Due
; Due date = Today, if no dental exam (P.02) ever documented.
; Due date = Date of most recent dental exam + 365 days (or 12 months)
; If "Now," then text = "Dental Exam may be due now; last documented [date]."
NEW LAST,DUE,LAST1,LIST
S GUI=$G(GUI,0)
S (LAST,DUE,LAST1)=""
D EXAMTAX^BKMIXX1(DFN,"30","","","",.LAST)
D ADATAX^BKMIXX(DFN,"BGP DENTAL EXAM DENTAL CODE","","","",.LAST1)
S LAST=$S(LAST>LAST1:LAST,1:LAST1)
D ICDTAX^BKMIXX1(DFN,"BKM DENTAL EXAMINATION","","","",.LAST1)
S LAST=$S(LAST>LAST1:LAST,1:LAST1)
I LAST'="" S DUE=+$$SCH^XLFDT("12M",LAST)
I LAST="" S DUE=DT
D ADDLINE^BKMVF32("30 REM.P.02",.LIST,"Dental Exam",LAST,DUE)
D WRITE("30 REM.P.02",GUI)
Q
;
WRITE(REM,GUI) ; Write out the reminder
S APCHLAST=$G(LIST(REM,1,"LAST"))
I APCHLAST="" S APCHSTEX(1)="MAY BE DUE NOW"
S APCHNEXT=$G(LIST(REM,1,"DUE"))
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
I APCHNEXT'>DT S APCHSTEX(1)="MAY BE DUE NOW (WAS DUE "_$$DATE^APCHSMU(APCHNEXT)_")"
I 'GUI D WRITE^APCHSMU
I GUI S REMLAST=APCHLAST,REMNEXT=$G(APCHSTEX(1)),REMDUE=APCHNEXT
I $G(BKMSUP) M REMLIST=LIST
K APCHLAST,APCHNEXT,APCHSTEX,LIST
Q
BKMRMEX ;PRXM/HC/ALA-HMS Exam Reminders ; 13 Nov 2007 4:02 PM
+1 ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
EX01(GUI) ;EP - REM.P.01
+1 ; Eye Exam Due
+2 ; Due date = Today, if no dilated eye exam (P.03) ever documented.
+3 ; Due date = Date of most recent dilated eye exam + 183 days (or 6 months)
+4 ; if any CD4 Absolute laboratory test (T.30) since most recent
+5 ; dilated eye exam is < 50.
+6 ; Above definition changed from CD4 (T.2) to CD4 Absolute (T.30) and from most recent to any.
+7 ; Due date = Date of most recent dilated eye exam + 365 days (or 12 months).
+8 ; If "Now," then text = "Dilated eye exam may be due now; last documented [date]."
+9 NEW LAST,DUE,LAST1,LRESULT,LIST,PRV,CLN,CD4
+10 SET GUI=$GET(GUI,0)
+11 SET (LAST,DUE,LAST1,LRESULT)=""
+12 DO EXAMTAX^BKMIXX1(DFN,"03","","","",.LAST)
+13 DO CPTTAX^BKMIXX(DFN,"BGP EYE EXAM CPTS","","","",.LAST1)
+14 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+15 DO ICDTAX^BKMIXX1(DFN,"BQI EYE EXAM DXS","","","",.LAST1)
+16 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+17 ;Check provider codes
+18 FOR PRV="79","24","08"
Begin DoDot:1
+19 DO PRVTAX^BKMIXX2(DFN,PRV,"","","",.LAST1)
+20 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
End DoDot:1
+21 ;Check clinic codes
+22 FOR CLN="17","18","64","A2"
Begin DoDot:1
+23 DO CLNTAX^BKMIXX2(DFN,CLN,"","","",.LAST1)
+24 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
End DoDot:1
+25 IF LAST'=""
Begin DoDot:1
+26 NEW GLOBAL,LABTEST,SINCE,CD4
+27 ;Get tests since most recent eye exam
SET SINCE=LAST\1_".2400"
+28 SET GLOBAL="LABTEST(VSTDT,TEST,""LAB"")"
+29 DO LABTAX^BKMIXX(DFN,"BKMV CD4 ABS TESTS TAX","",SINCE,GLOBAL)
+30 DO LOINC^BKMIXX(DFN,"BKMV CD4 ABS LOINC CODES","",SINCE,GLOBAL)
+31 SET GLOBAL="LABTEST(VSTDT,TEST,""CPT"")"
+32 DO CPTTAX^BKMIXX(DFN,"BKMV CD4 ABS CPTS","",SINCE,GLOBAL)
+33 SET DUE=+$$SCH^XLFDT("12M",LAST)
+34 SET CD4="LABTEST"
+35 FOR
SET CD4=$QUERY(@CD4)
IF CD4=""
QUIT
IF $PIECE(@CD4,U)]""
IF $PIECE(@CD4,U)<50
SET DUE=+$$SCH^XLFDT("6M",LAST)
QUIT
End DoDot:1
+36 IF LAST=""
SET DUE=DT
+37 DO ADDLINE^BKMVF32("29 REM.P.01",.LIST,"Dilated Eye Exam",LAST,DUE)
+38 DO WRITE("29 REM.P.01",GUI)
+39 QUIT
+40 ;
EX02(GUI) ;EP - REM.P.02
+1 ; Dental Exam Due
+2 ; Due date = Today, if no dental exam (P.02) ever documented.
+3 ; Due date = Date of most recent dental exam + 365 days (or 12 months)
+4 ; If "Now," then text = "Dental Exam may be due now; last documented [date]."
+5 NEW LAST,DUE,LAST1,LIST
+6 SET GUI=$GET(GUI,0)
+7 SET (LAST,DUE,LAST1)=""
+8 DO EXAMTAX^BKMIXX1(DFN,"30","","","",.LAST)
+9 DO ADATAX^BKMIXX(DFN,"BGP DENTAL EXAM DENTAL CODE","","","",.LAST1)
+10 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+11 DO ICDTAX^BKMIXX1(DFN,"BKM DENTAL EXAMINATION","","","",.LAST1)
+12 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+13 IF LAST'=""
SET DUE=+$$SCH^XLFDT("12M",LAST)
+14 IF LAST=""
SET DUE=DT
+15 DO ADDLINE^BKMVF32("30 REM.P.02",.LIST,"Dental Exam",LAST,DUE)
+16 DO WRITE("30 REM.P.02",GUI)
+17 QUIT
+18 ;
WRITE(REM,GUI) ; Write out the reminder
+1 SET APCHLAST=$GET(LIST(REM,1,"LAST"))
+2 IF APCHLAST=""
SET APCHSTEX(1)="MAY BE DUE NOW"
+3 SET APCHNEXT=$GET(LIST(REM,1,"DUE"))
+4 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+5 IF APCHNEXT'>DT
SET APCHSTEX(1)="MAY BE DUE NOW (WAS DUE "_$$DATE^APCHSMU(APCHNEXT)_")"
+6 IF 'GUI
DO WRITE^APCHSMU
+7 IF GUI
SET REMLAST=APCHLAST
SET REMNEXT=$GET(APCHSTEX(1))
SET REMDUE=APCHNEXT
+8 IF $GET(BKMSUP)
MERGE REMLIST=LIST
+9 KILL APCHLAST,APCHNEXT,APCHSTEX,LIST
+10 QUIT
