BKMRMWH ;PRXM/HC/ALA-HMS Women's Health Reminders ; 13 Nov 2007 4:13 PM
;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
MAM(GUI) ;EP - REM.P.03
; Mammogram Due
; Numerator: All female patients ages 50-69 without documented bilateral mastectomy (P.01)
; Due date = Today, if no Mammogram (P.05) ever documented.
; Due date = Date of most mammogram + 365 days (or 12 months).
; If "Now," then text = "Mammogram may be due now; last documented [date]."
NEW LAST,DUE,LAST1,LIST
S GUI=$G(GUI,0)
S (LAST,DUE,LAST1)=""
S APCHSDOB=$P(^DPT(APCHSPAT,0),U,3)
S APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
I APCHSEX="F",APCHSAGE'<50,APCHSAGE'>69 D
. D PRCTAX^BKMIXX1(APCHSPAT,"BGP MASTECTOMY PROCEDURES","","","",.LAST)
. ; If patient had this procedure then no need for a mammogram.
. Q:LAST'=""
. D ICDTAX^BKMIXX1(APCHSPAT,"BGP MAMMOGRAM ICDS","","","",.LAST)
. D CPTTAX^BKMIXX(APCHSPAT,"BGP CPT MAMMOGRAM","","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
. D RADTAX^BKMIXX1(APCHSPAT,"BGP CPT MAMMOGRAM","","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
. D PRCTAX^BKMIXX1(APCHSPAT,"BGP MAMMOGRAM PROCEDURES","","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
. D WHTAX^BKMIXX2(APCHSPAT,"MAMMOGRAM DX BILAT","","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
. D WHTAX^BKMIXX2(APCHSPAT,"MAMMOGRAM DX UNILAT","","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
. D WHTAX^BKMIXX2(APCHSPAT,"MAMMOGRAM SCREENING","","","",.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("28 REM.P.03",.LIST,"Mammogram",LAST,DUE)
D WRITE("28 REM.P.03",GUI)
Q
;
PAP(GUI) ;EP - REM.T.06
; Pap Smear Due
; Numerator: All female patients ages 18 through 64 (on Report end date) without documented hysterectomy (P.04)
; Due date = Today, if Pap smear (T.20) not ever documented. OR
; ** EN/KH - Next two lines conflict (<= and >=) and Eric P. agreed, go with 6/4/2004 logic (+183 days if <200, else +365)
; Due date = Most recent Pap smear + 183 days (or 6 months) if most recent CD4 Absolute laboratory (T.30) value is <= 200. OR
; Due date = Most recent Pap smear + 365 days (or 12 months) if most recent CD4 Absolute laboratory (T.30) value is >= 200.
; Above two lines were changed from CD4 (T.2) to CD4 Absolute (T.30)
; If "Now," then text = "A Pap smear may be due now; last documented [date]."
NEW LAST,DUE,LAST1,LRESULT
S (LAST,DUE,LAST1,LRESULT)=""
I $G(BDATE)="" S BDATE=DT
S APCHSDOB=$P(^DPT(APCHSPAT,0),U,3)
S APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
I APCHSEX="F",APCHSAGE'<18,APCHSAGE'>64 D
. D CPTTAX^BKMIXX(APCHSPAT,"BGP HYSTERECTOMY CPTS","","","",.LAST1)
. I LAST1'="" Q
. D PRCTAX^BKMIXX1(APCHSPAT,"BGP HYSTERECTOMY PROCEDURES","","","",.LAST1)
. I LAST1'="" Q
. D LABCODES^BKMVF32(APCHSPAT,"BGP PAP SMEAR TAX","BGP PAP LOINC CODES","BGP CPT PAP","BGP PAP ICDS","",.LAST)
. D PRCTAX^BKMIXX1(APCHSPAT,"BQI PAP PROCEDURES","","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
. D WHTAX^BKMIXX2(APCHSPAT,"PAP SMEAR","","","",.LAST1)
. S LAST=$S(LAST>LAST1:LAST,1:LAST1)
. I LAST="" S DUE=BDATE Q
. ; Check result of CD4 T.2
. D LABCODES^BKMVF32(APCHSPAT,"BKMV CD4 ABS TESTS TAX","BKMV CD4 ABS LOINC CODES","BKMV CD4 ABS CPTS","","","","",.LRESULT)
. I LRESULT]"",LRESULT<200 S DUE=+$$SCH^XLFDT("6M",LAST) Q
. S DUE=+$$SCH^XLFDT("12M",LAST)
D ADDLINE^BKMVF32("19 REM.T.06",.LIST,"Pap Smear",LAST,DUE)
D WRITE("19 REM.T.06",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'="",APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
I APCHNEXT'="",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
BKMRMWH ;PRXM/HC/ALA-HMS Women's Health Reminders ; 13 Nov 2007 4:13 PM
+1 ;;2.2;HIV MANAGEMENT SYSTEM;;Apr 01, 2015;Build 40
MAM(GUI) ;EP - REM.P.03
+1 ; Mammogram Due
+2 ; Numerator: All female patients ages 50-69 without documented bilateral mastectomy (P.01)
+3 ; Due date = Today, if no Mammogram (P.05) ever documented.
+4 ; Due date = Date of most mammogram + 365 days (or 12 months).
+5 ; If "Now," then text = "Mammogram may be due now; last documented [date]."
+6 NEW LAST,DUE,LAST1,LIST
+7 SET GUI=$GET(GUI,0)
+8 SET (LAST,DUE,LAST1)=""
+9 SET APCHSDOB=$PIECE(^DPT(APCHSPAT,0),U,3)
+10 SET APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
+11 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+12 IF APCHSEX="F"
IF APCHSAGE'<50
IF APCHSAGE'>69
Begin DoDot:1
+13 DO PRCTAX^BKMIXX1(APCHSPAT,"BGP MASTECTOMY PROCEDURES","","","",.LAST)
+14 ; If patient had this procedure then no need for a mammogram.
+15 IF LAST'=""
QUIT
+16 DO ICDTAX^BKMIXX1(APCHSPAT,"BGP MAMMOGRAM ICDS","","","",.LAST)
+17 DO CPTTAX^BKMIXX(APCHSPAT,"BGP CPT MAMMOGRAM","","","",.LAST1)
+18 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+19 DO RADTAX^BKMIXX1(APCHSPAT,"BGP CPT MAMMOGRAM","","","",.LAST1)
+20 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+21 DO PRCTAX^BKMIXX1(APCHSPAT,"BGP MAMMOGRAM PROCEDURES","","","",.LAST1)
+22 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+23 DO WHTAX^BKMIXX2(APCHSPAT,"MAMMOGRAM DX BILAT","","","",.LAST1)
+24 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+25 DO WHTAX^BKMIXX2(APCHSPAT,"MAMMOGRAM DX UNILAT","","","",.LAST1)
+26 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+27 DO WHTAX^BKMIXX2(APCHSPAT,"MAMMOGRAM SCREENING","","","",.LAST1)
+28 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+29 IF LAST'=""
SET DUE=+$$SCH^XLFDT("12M",LAST)
+30 IF LAST=""
SET DUE=DT
End DoDot:1
+31 DO ADDLINE^BKMVF32("28 REM.P.03",.LIST,"Mammogram",LAST,DUE)
+32 DO WRITE("28 REM.P.03",GUI)
+33 QUIT
+34 ;
PAP(GUI) ;EP - REM.T.06
+1 ; Pap Smear Due
+2 ; Numerator: All female patients ages 18 through 64 (on Report end date) without documented hysterectomy (P.04)
+3 ; Due date = Today, if Pap smear (T.20) not ever documented. OR
+4 ; ** EN/KH - Next two lines conflict (<= and >=) and Eric P. agreed, go with 6/4/2004 logic (+183 days if <200, else +365)
+5 ; Due date = Most recent Pap smear + 183 days (or 6 months) if most recent CD4 Absolute laboratory (T.30) value is <= 200. OR
+6 ; Due date = Most recent Pap smear + 365 days (or 12 months) if most recent CD4 Absolute laboratory (T.30) value is >= 200.
+7 ; Above two lines were changed from CD4 (T.2) to CD4 Absolute (T.30)
+8 ; If "Now," then text = "A Pap smear may be due now; last documented [date]."
+9 NEW LAST,DUE,LAST1,LRESULT
+10 SET (LAST,DUE,LAST1,LRESULT)=""
+11 IF $GET(BDATE)=""
SET BDATE=DT
+12 SET APCHSDOB=$PIECE(^DPT(APCHSPAT,0),U,3)
+13 SET APCHSAGE=$$AGE^BQIAGE(APCHSPAT)
+14 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+15 IF APCHSEX="F"
IF APCHSAGE'<18
IF APCHSAGE'>64
Begin DoDot:1
+16 DO CPTTAX^BKMIXX(APCHSPAT,"BGP HYSTERECTOMY CPTS","","","",.LAST1)
+17 IF LAST1'=""
QUIT
+18 DO PRCTAX^BKMIXX1(APCHSPAT,"BGP HYSTERECTOMY PROCEDURES","","","",.LAST1)
+19 IF LAST1'=""
QUIT
+20 DO LABCODES^BKMVF32(APCHSPAT,"BGP PAP SMEAR TAX","BGP PAP LOINC CODES","BGP CPT PAP","BGP PAP ICDS","",.LAST)
+21 DO PRCTAX^BKMIXX1(APCHSPAT,"BQI PAP PROCEDURES","","","",.LAST1)
+22 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+23 DO WHTAX^BKMIXX2(APCHSPAT,"PAP SMEAR","","","",.LAST1)
+24 SET LAST=$SELECT(LAST>LAST1:LAST,1:LAST1)
+25 IF LAST=""
SET DUE=BDATE
QUIT
+26 ; Check result of CD4 T.2
+27 DO LABCODES^BKMVF32(APCHSPAT,"BKMV CD4 ABS TESTS TAX","BKMV CD4 ABS LOINC CODES","BKMV CD4 ABS CPTS","","","","",.LRESULT)
+28 IF LRESULT]""
IF LRESULT<200
SET DUE=+$$SCH^XLFDT("6M",LAST)
QUIT
+29 SET DUE=+$$SCH^XLFDT("12M",LAST)
End DoDot:1
+30 DO ADDLINE^BKMVF32("19 REM.T.06",.LIST,"Pap Smear",LAST,DUE)
+31 DO WRITE("19 REM.T.06",GUI)
+32 QUIT
+33 ;
WRITE(REM,GUI) ; Write out the reminder
+1 SET APCHLAST=$GET(LIST(REM,1,"LAST"))
+2 ;I APCHLAST="" S APCHSTEX(1)="MAY BE DUE NOW"
+3 SET APCHNEXT=$GET(LIST(REM,1,"DUE"))
+4 IF APCHNEXT'=""
IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+5 IF APCHNEXT'=""
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
