Routine: BKMRMWH

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)

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)

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

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

BKMRMWH.m