BGP9DPA1 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 01 Oct 2007 2:53 PM 26 Aug 2008 4:43 PM ; 03 Jun 2009 7:53 PM
;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
;
ISS ;EP
S BGPBDATE=BGPBD,BGPEDATE=BGPED,BGPTIME=1
S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBD)
S BGPIC=0 F S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC'=+BGPIC D
.K BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
.K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30
.K BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13
.K BGPNUMV
.K ^TMP($J,"A")
.S BGPGPRAI=0 F S BGPGPRAI=$O(^BGPINDNC("B",BGPIC,BGPGPRAI)) Q:BGPGPRAI'=+BGPGPRAI D
..Q:$P($G(^BGPINDNC(BGPGPRAI,12)),U,9)="" ;not a item for this report 1209 field
..S (BGPNUM,BGPDEN)=0
..S BGPISSV="",BGPSKIP=0
..Q:'$D(^BGPINDNC(BGPGPRAI,4))
..X ^BGPINDNC(BGPGPRAI,4)
..S $P(BGPISSV,U,4)=$$TITLE2^BGP9DPA1(BGPGPRAI)
..Q:BGPSKIP ;SKIP THIS ONE FOR THIS PATIENT, EITHER MET MEASURE OR NOT IN DENOM
..S C=$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN")
..S S=$P(^DPT(DFN,0),U,2)
..I BGPISST="A" D
...S ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"ANY",$P(^DPT(DFN,0),U,1),DFN,BGPIC,BGPGPRAI)=BGPISSV ;_"%%"_$G(BGPISSV(1))
..I BGPISST="C" D
...S X=BGPAPPTS(BGPSOX)
...S ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"APPTS",$P(^SC($P(X,U,2),0),U),$P($P(X,U,3),"."),$P(X,U,3),$P(^DPT(DFN,0),U),DFN,BGPIC,BGPGPRAI)=BGPISSV ;_"%%"_$G(BGPISSV(1))
..I BGPISST="P" D
...S X=BGPAPPTS(BGPSOX)
...S ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"PATS",$P(^DPT(DFN,0),U),DFN,$P($P(X,U,3),"."),$P(^SC($P(X,U,2),0),U),$P(X,U,3),BGPIC,BGPGPRAI)=BGPISSV ;_"%%"_$G(BGPISSV(1))
..I BGPISST="D" D
...S X=BGPAPPTS(BGPSOX)
...S ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"APPTS",BGPDIVI,$P(^SC($P(X,U,2),0),U),$P($P(X,U,3),"."),$P(X,U,3),$P(^DPT(DFN,0),U),DFN,BGPIC,BGPGPRAI)=BGPISSV ;_"%%"_$G(BGPISSV(1))
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPISSV
Q
I003 ;EP - DM ideal glycemic control
;get last date and value for patient DFN
;patient will display this item if they had a dm diagnosis ever and first dm dx
;was prior to beginning date of date range
;TITLE^LINE 1^LINE 2
S BGPSKIP=""
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPV,BGPD,BGPND
S BGPIN=""
K BGPISSV
S BGPV=$$HGBA1C^BGP9D2(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPV="" S BGPISSV=$P($G(^BGPINDNC(BGPGPRAI,12)),U,9)_U_"Last A1c: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBDATE) Q
S BGPD=$P(BGPV,U,3)
S BGPND=$$FMADD^XLFDT(BGPD,365)
I BGPND'>BGPED S BGPIN=1
S BGPND=$$DATE^BGP9UTL(BGPND)
S BGPMET=$S($P(BGPV,U,2)'=6:"Not Ideal Control",1:"Ideal Control")
I BGPMET="" S BGPMET=$S($P(BGPV,U,4)="":"No VALUE",1:"")
I 'BGPIN,BGPMET="Ideal Control" S BGPSKIP=1 Q ;not due before end of gpra year, in control
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last A1c: "_$$DATE^BGP9UTL(BGPD)_" value: "_$P(BGPV,U,4)_" - "_BGPMET_"|"_$S(BGPIN:"Overdue as of: ",1:"Next Due: ")_BGPND
I BGPIN,BGPMET["Not Ideal Control" S BGPISSV=BGPISSV_"|Next Due: "_BGPND
Q
I004 ;EP - DM BP control
;get date of last BP and value for patient DFN
;patient will display this item if they had a dm diagnosis ever and first dm dx
;was prior to beginning date of date range
;date of last^value of last^next date due
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPV,BGPD,BGPND
S (BGPISSV,BGPIN)=""
K BGPISSV
S BGPV=$$MEANBP^BGP9D2(DFN,$$FMADD^XLFDT(BGPED,-365),BGPED)
I BGPV="" S BGPV=$$BPCPT^BGP9D22(DFN,BGP365,BGPED) I $P(BGPV,U) S BGPV=U_2_U_$P(BGPV,U,2)
;
I BGPV="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: 2 BPs not documented "_$$DATE^BGP9UTL(BGPBD)_"-"_$$DATE^BGP9UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
I $P(BGPV,U,2)=2 S BGPSKIP=1 Q ;in control BP in report period, do not display
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: "_$P(BGPV,U)
I $P(BGPV,U,2)'=2 S BGPISSV=BGPISSV_" - Not Controlled BP"
Q
I005 ;EP - DM LDL
;get last date and value for patient DFN
;patient will display this item if they had a dm diagnosis ever and first dm dx
;was prior to beginning date of date range
;date of last^value of last^next date due
S BGPSKIP=""
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$LDL^BGP9D2(DFN,$$DOB^AUPNPAT(DFN),BGPED)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,2)
S BGPND=$$FMADD^XLFDT(BGPD,365)
I BGPND'>BGPED S BGPIN=1
I 'BGPIN S BGPSKIP=1 Q ;had LDL in time period
S BGPND=$$DATE^BGP9UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: "_$$DATE^BGP9UTL(BGPD)_"|"_"Overdue as of: "_BGPND
Q
I006 ;EP - DM Nephropathy
;get last date and value for patient DFN
;patient will display this item if they had a dm diagnosis ever and first dm dx
;was prior to beginning date of date range
;
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN="",BGPIN1=""
K BGPISSV
S (BGPBD1,BGPBD2)=$$DOB^AUPNPAT(DFN),BGPEDATE=BGPED,BGPN1=0
S BGPHOLD=""
D I61^BGP9D21
S BGPGFR=$P(BGPHOLD,"|",1)
S BGPQUP=$P(BGPHOLD,"|",3)
S BGPESRD=$P(BGPHOLD,"|",2)
I BGPESRD S BGPSKIP=1 D I006X Q ;has esrd so skip and do not display S BGPISSV=$$TITLE(BGPGPRAI)_U_"ESRD diagnosis/CPT: "_$$DATE^BGP9UTL($P(BGPESRD,U,3)) Q
S BGPGD=$P(BGPGFR,U,2),BGPNGFR=$S($P(BGPGFR,U,2):$$FMADD^XLFDT($P(BGPGFR,U,2),365),1:"") I BGPNGFR'>BGPED S BGPIN=1
S BGPUD=$P(BGPQUP,U,3),BGPNQUP=$S($P(BGPQUP,U,3):$$FMADD^XLFDT($P(BGPQUP,U,3),365),1:"") I BGPNQUP'>BGPED S BGPIN1=1
I 'BGPIN,'BGPIN1 D I006X S BGPSKIP=1 Q ;had both GFR and QUP
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Est GFR: "_$S($P(BGPGFR,U,2)]"":$$DATE^BGP9UTL($P(BGPGFR,U,2)),1:"Never")_"|"_"Last Quantitative Urine Protein: "_$S($P(BGPQUP,U,3)]"":$$DATE^BGP9UTL($P(BGPQUP,U,3)),1:"Never")
S BGPND=$S(BGPGD:$$FMADD^XLFDT(BGPGD,365),1:BGPBD)
I BGPUD]"",BGPND<$$FMADD^XLFDT(BGPUD,365) S BGPND=$$FMADD^XLFDT(BGPUD,365)
I BGPND="" S BGPND=BGPBD
S BGPISSV=BGPISSV_"|Est GFR & Quant Urine Protein Overdue as of: "_$$DATE^BGP9UTL(BGPND)
I006X ;
K BGPN1,BGPGFR,BGPQUP,BGPN2,BGPESRD,BGPIN,BGPIN1,BGPNQUP,BGPNGFR,BGPGD,BGPUD
Q
I007 ;EP DM eye exam
;get last date and value for patient DFN
;patient will display this item if they had a dm diagnosis ever and first dm dx
;was prior to beginning date of date range
;date of last^value of last^next date due
S BGPSKIP=""
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$EYE^BGP9DPA4(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
S BGPREF=$$EYEREF^BGP9DPA4(DFN,BGPBD,BGPED)
I BGPREF]"" S BGPSKIP=1 Q
I BGPVALUE="",BGPREF="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
I BGPVALUE="",BGPREF]"" D Q
.S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Patient refused on "_$$DATE^BGP9UTL($P(BGPREF,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) S BGPD=$P(BGPVALUE,U,2)
S BGPD=$P(BGPVALUE,U,2)
S BGPND=$$FMADD^XLFDT(BGPD,365)
I BGPND'>BGPED S BGPIN=1
I 'BGPIN S BGPSKIP=1 Q ;not due this gpra year so don't display
S BGPND=$$DATE^BGP9UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: "_$$DATE^BGP9UTL(BGPD)
I BGPREF]"" S BGPISSV=BGPISSV_"|Patient refused on "_$$DATE^BGP9UTL($P(BGPREF,U,2))
S BGPISSV=BGPISSV_"|Overdue as of: "_BGPND
Q
I009 ;EP DENTAL EXAM
;get last date and value for patient DFN
S BGPSKIP=""
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$DENTSRV^BGP9D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,2)
S BGPND=$$FMADD^XLFDT(BGPD,365)
I BGPND'>BGPED S BGPIN=1
I 'BGPIN S BGPSKIP=1 Q ;not due this rp
S BGPND=$$DATE^BGP9UTL(BGPND)
S BGPREF=$$DENTSRV^BGP9D21(DFN,BGPBD,BGPED)
I BGPREF["Ref" S BGPSKIP=1 Q
;I BGPVALUE["Refused" S BGPSKIP=1 Q ;S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: patient refused on "_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND
S $P(BGPISSV,U,4)=$$TITLE2(BGPGPRAI)
Q
I012 ;EP - FLU
;get last date and value for patient DFN
;date of last^value of last^next date due
S BGPSKIP=""
NEW BGPVALUE,BGPD,BGPND
I BGPAGEB<65 S BGPSKIP=1 Q
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$FLU^BGP9D3(DFN,BGPBD,BGPED)
I BGPVALUE]"" S BGPSKIP=1 Q ;not due this year
S BGPVALUE=$$FLU^BGP9D3(DFN,$$DOB^AUPNPAT(DFN),BGPED)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,1)
S BGPND=$$FMADD^XLFDT(BGPD,365)
S BGPND=$$DATE^BGP9UTL(BGPND)
I BGPVALUE["Refus" S BGPIN=1 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP9UTL($P(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND
Q
I013 ;EP - PNEU
;get last date and value for patient DFN
;date of last^value of last^next date due
S BGPSKIP=""
NEW BGPVALUE,BGPD,BGPND
I BGPAGEB<65 S BGPSKIP=1 Q ;GPRA MEASURE IS 65 AND OLDER
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$PNEU^BGP9D31(DFN,$$DOB^AUPNPAT(DFN),BGPED)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,1)
S BGPND=$S(BGPD="":DT,1:"")
I BGPND]"",BGPND'>BGPED S BGPIN=1
I 'BGPIN S BGPSKIP=1 Q ;not due so skip
I BGPVALUE["Refus" S BGPSKIP=1 Q
S BGPND=$$DATE^BGP9UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND
Q
I014 ;EP - Childhood IZ
;
NEW BGPVALUE,BGPD,BGPND
S BGPISSO=1,BGPIN="",BGPIN1=""
K BGPISSV
D I14^BGP9D32
I $G(BGPSTOP)=1 S BGPSKIP=1 D I014X Q
I BGPN21 S BGPSKIP=1 D I014X Q ;up to date
I 'BGPN21 S BGPISSV=$$TITLE(BGPGPRAI)_U_$P(BGPVALUE,"|||",2)_"|"_$S('BGPD3:"NOT ",1:"")_"Active on Immunization Register."
I014X ;
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27
K BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPI7,BGPN28,BGPN29
K BGPVALUE
K BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR
Q
I015 ;EP - PAP
;
;
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN="",BGPIN1=""
K BGPISSV
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB
S BGPI7DA=0,BGPI7DB=0,BGPN1=0,BGPN2=0
S BGPI7=$$DEN7^BGP9D3(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
I BGPACTUP,BGPI7 S BGPI7DA=1
I BGPACTCL,BGPI7 S BGPI7DB=1
I 'BGPI7DA,'BGPI7DB S BGPSKIP=1 D I015X Q ;not in either denom so quit
S BGPVALUE=$$PAP^BGP9D3(DFN,BGPEDATE,$$AGE^AUPNPAT(DFN))
S BGPREF=$$PAPREF(DFN,BGPBDATE,BGPEDATE)
I BGPREF]"" S BGPSKIP=1 Q
I BGPVALUE="",BGPREF="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last PAP: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) D I015X Q ; as of "_$$DATE^BGP9UTL(DT) Q
S BGPD=$P(BGPVALUE,U,2)
S BGPND=$S(BGPD="":DT,1:$$FMADD^XLFDT(BGPD,(3*365)))
I BGPND]"",BGPND'>BGPED S BGPIN=1
I 'BGPIN S BGPSKIP=1 D I015X Q ;not due, don't display
I BGPVALUE="",BGPREF]"" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap Smear: Never - patient refused on "_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) D I015X Q
S BGPND=$$DATE^BGP9UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND_$S(BGPREF]"":"|Patient refused a Pap Smear on "_$$DATE^BGP9UTL($P(BGPREF,U,2)),1:"")
I015X ;
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB,BGPREF
K BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27
Q
I016 ;EP -MAMMOGRAM
;
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN="",BGPIN1=""
K BGPISSV
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPMAM,BGPI8,BGPI81,BGPI8DA,BGPI8DB,BGPI8DC,BGPI8DD,BGPI8DE
S BGPI8=$$DEN8^BGP9D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
I 'BGPI8 S BGPSKIP=1 D I016X Q
S BGPVALUE=$$MAM^BGP9D4(DFN,BGPEDATE,15,1)
S BGPREF=$$MAMREF(DFN,BGPBDATE,BGPEDATE)
I BGPREF]"" S BGPSKIP=1 Q
I BGPVALUE="",BGPREF="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) D I016X Q ; as of "_$$DATE^BGP9UTL(DT) Q
S BGPD=$P(BGPVALUE,U,2)
S BGPND=$S(BGPD="":DT,1:$$FMADD^XLFDT(BGPD,(2*365)))
I BGPND]"",BGPND'>BGPED S BGPIN=1
I 'BGPIN S BGPSKIP=1 D I015X Q ;not due, don't display
I BGPVALUE="",BGPREF]"" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap Smear: Never - patient refused on "_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) D I016X Q
S BGPND=$$DATE^BGP9UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND_$S(BGPREF]"":"|Patient refused a Mammogram on "_$$DATE^BGP9UTL($P(BGPREF,U,2)),1:"")
;
I016X ;
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB
K BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27
Q
I031A ;
Q
TITLE(I) ;
Q $P($G(^BGPINDNC(I,12)),U,9)
TITLE2(I) ;EP
Q $P($G(^BGPINDNC(I,12)),U,16)
PAPREF(P,BDATE,EDATE) ;
S T=$$REFUSAL^BGP9UTL1(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),BDATE,EDATE)
I T Q "1^"_$P(T,U,2)_"^ref"
S BGPLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
I 'BGPLT Q 0
S X=0,T="" F S X=$O(^ATXLAB(BGPLT,21,X)) Q:X'=+X!($P(T,U)=1) D
.S T=""
.S Y=$P(^ATXLAB(BGPLT,21,X,0),U)
.Q:'Y
.S T=$$REFUSAL^BGP9UTL1(P,60,Y,BDATE,EDATE)
I T Q 1_"^"_$P(T,U,2)_"^ref"
Q ""
MAMREF(P,BDATE,EDATE) ;
S T=$$CPTREFT^BGP9UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$S(BGPRTYPE'=3:$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$O(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))
I T S T="1^"_$P(T,U,2)_"^ref CPT" Q T
S T=$$RADREF^BGP9UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$S(BGPRTYPE'=3:$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$O(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))
I T S T="1^"_$P(T,U,2)_"^ref CPT"
Q $S(T:T,1:"")
BGP9DPA1 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 01 Oct 2007 2:53 PM 26 Aug 2008 4:43 PM ; 03 Jun 2009 7:53 PM
+1 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
+2 ;
ISS ;EP
+1 SET BGPBDATE=BGPBD
SET BGPEDATE=BGPED
SET BGPTIME=1
+2 SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBD)
+3 SET BGPIC=0
FOR
SET BGPIC=$ORDER(BGPIND(BGPIC))
IF BGPIC'=+BGPIC
QUIT
Begin DoDot:1
+4 KILL BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+5 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30
+6 KILL BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13
+7 KILL BGPNUMV
+8 KILL ^TMP($JOB,"A")
+9 SET BGPGPRAI=0
FOR
SET BGPGPRAI=$ORDER(^BGPINDNC("B",BGPIC,BGPGPRAI))
IF BGPGPRAI'=+BGPGPRAI
QUIT
Begin DoDot:2
+10 ;not a item for this report 1209 field
IF $PIECE($GET(^BGPINDNC(BGPGPRAI,12)),U,9)=""
QUIT
+11 SET (BGPNUM,BGPDEN)=0
+12 SET BGPISSV=""
SET BGPSKIP=0
+13 IF '$DATA(^BGPINDNC(BGPGPRAI,4))
QUIT
+14 XECUTE ^BGPINDNC(BGPGPRAI,4)
+15 SET $PIECE(BGPISSV,U,4)=$$TITLE2^BGP9DPA1(BGPGPRAI)
+16 ;SKIP THIS ONE FOR THIS PATIENT, EITHER MET MEASURE OR NOT IN DENOM
IF BGPSKIP
QUIT
+17 SET C=$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN")
+18 SET S=$PIECE(^DPT(DFN,0),U,2)
+19 IF BGPISST="A"
Begin DoDot:3
+20 ;_"%%"_$G(BGPISSV(1))
SET ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"ANY",$PIECE(^DPT(DFN,0),U,1),DFN,BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
+21 IF BGPISST="C"
Begin DoDot:3
+22 SET X=BGPAPPTS(BGPSOX)
+23 ;_"%%"_$G(BGPISSV(1))
SET ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"APPTS",$PIECE(^SC($PIECE(X,U,2),0),U),$PIECE($PIECE(X,U,3),"."),$PIECE(X,U,3),$PIECE(^DPT(DFN,0),U),DFN,BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
+24 IF BGPISST="P"
Begin DoDot:3
+25 SET X=BGPAPPTS(BGPSOX)
+26 ;_"%%"_$G(BGPISSV(1))
SET ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"PATS",$PIECE(^DPT(DFN,0),U),DFN,$PIECE($PIECE(X,U,3),"."),$PIECE(^SC($PIECE(X,U,2),0),U),$PIECE(X,U,3),BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
+27 IF BGPISST="D"
Begin DoDot:3
+28 SET X=BGPAPPTS(BGPSOX)
+29 ;_"%%"_$G(BGPISSV(1))
SET ^XTMP("BGP9DPA",BGPGPRAJ,BGPGPRAH,"APPTS",BGPDIVI,$PIECE(^SC($PIECE(X,U,2),0),U),$PIECE($PIECE(X,U,3),"."),$PIECE(X,U,3),$PIECE(^DPT(DFN,0),U),DFN,BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
End DoDot:2
End DoDot:1
+30 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPISSV
+31 QUIT
I003 ;EP - DM ideal glycemic control
+1 ;get last date and value for patient DFN
+2 ;patient will display this item if they had a dm diagnosis ever and first dm dx
+3 ;was prior to beginning date of date range
+4 ;TITLE^LINE 1^LINE 2
+5 SET BGPSKIP=""
+6 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+7 NEW BGPV,BGPD,BGPND
+8 SET BGPIN=""
+9 KILL BGPISSV
+10 SET BGPV=$$HGBA1C^BGP9D2(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+11 IF BGPV=""
SET BGPISSV=$PIECE($GET(^BGPINDNC(BGPGPRAI,12)),U,9)_U_"Last A1c: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBDATE)
QUIT
+12 SET BGPD=$PIECE(BGPV,U,3)
+13 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+14 IF BGPND'>BGPED
SET BGPIN=1
+15 SET BGPND=$$DATE^BGP9UTL(BGPND)
+16 SET BGPMET=$SELECT($PIECE(BGPV,U,2)'=6:"Not Ideal Control",1:"Ideal Control")
+17 IF BGPMET=""
SET BGPMET=$SELECT($PIECE(BGPV,U,4)="":"No VALUE",1:"")
+18 ;not due before end of gpra year, in control
IF 'BGPIN
IF BGPMET="Ideal Control"
SET BGPSKIP=1
QUIT
+19 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last A1c: "_$$DATE^BGP9UTL(BGPD)_" value: "_$PIECE(BGPV,U,4)_" - "_BGPMET_"|"_$SELECT(BGPIN:"Overdue as of: ",1:"Next Due: ")_BGPND
+20 IF BGPIN
IF BGPMET["Not Ideal Control"
SET BGPISSV=BGPISSV_"|Next Due: "_BGPND
+21 QUIT
I004 ;EP - DM BP control
+1 ;get date of last BP and value for patient DFN
+2 ;patient will display this item if they had a dm diagnosis ever and first dm dx
+3 ;was prior to beginning date of date range
+4 ;date of last^value of last^next date due
+5 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+6 NEW BGPV,BGPD,BGPND
+7 SET (BGPISSV,BGPIN)=""
+8 KILL BGPISSV
+9 SET BGPV=$$MEANBP^BGP9D2(DFN,$$FMADD^XLFDT(BGPED,-365),BGPED)
+10 IF BGPV=""
SET BGPV=$$BPCPT^BGP9D22(DFN,BGP365,BGPED)
IF $PIECE(BGPV,U)
SET BGPV=U_2_U_$PIECE(BGPV,U,2)
+11 ;
+12 IF BGPV=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: 2 BPs not documented "_$$DATE^BGP9UTL(BGPBD)_"-"_$$DATE^BGP9UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
QUIT
+13 ;in control BP in report period, do not display
IF $PIECE(BGPV,U,2)=2
SET BGPSKIP=1
QUIT
+14 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: "_$PIECE(BGPV,U)
+15 IF $PIECE(BGPV,U,2)'=2
SET BGPISSV=BGPISSV_" - Not Controlled BP"
+16 QUIT
I005 ;EP - DM LDL
+1 ;get last date and value for patient DFN
+2 ;patient will display this item if they had a dm diagnosis ever and first dm dx
+3 ;was prior to beginning date of date range
+4 ;date of last^value of last^next date due
+5 SET BGPSKIP=""
+6 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+7 NEW BGPVALUE,BGPD,BGPND
+8 SET BGPISSV=""
SET BGPIN=""
+9 KILL BGPISSV
+10 SET BGPVALUE=$$LDL^BGP9D2(DFN,$$DOB^AUPNPAT(DFN),BGPED)
+11 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
QUIT
+12 SET BGPD=$PIECE(BGPVALUE,U,2)
+13 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+14 IF BGPND'>BGPED
SET BGPIN=1
+15 ;had LDL in time period
IF 'BGPIN
SET BGPSKIP=1
QUIT
+16 SET BGPND=$$DATE^BGP9UTL(BGPND)
+17 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: "_$$DATE^BGP9UTL(BGPD)_"|"_"Overdue as of: "_BGPND
+18 QUIT
I006 ;EP - DM Nephropathy
+1 ;get last date and value for patient DFN
+2 ;patient will display this item if they had a dm diagnosis ever and first dm dx
+3 ;was prior to beginning date of date range
+4 ;
+5 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+6 NEW BGPVALUE,BGPD,BGPND
+7 SET BGPISSV=""
SET BGPIN=""
SET BGPIN1=""
+8 KILL BGPISSV
+9 SET (BGPBD1,BGPBD2)=$$DOB^AUPNPAT(DFN)
SET BGPEDATE=BGPED
SET BGPN1=0
+10 SET BGPHOLD=""
+11 DO I61^BGP9D21
+12 SET BGPGFR=$PIECE(BGPHOLD,"|",1)
+13 SET BGPQUP=$PIECE(BGPHOLD,"|",3)
+14 SET BGPESRD=$PIECE(BGPHOLD,"|",2)
+15 ;has esrd so skip and do not display S BGPISSV=$$TITLE(BGPGPRAI)_U_"ESRD diagnosis/CPT: "_$$DATE^BGP9UTL($P(BGPESRD,U,3)) Q
IF BGPESRD
SET BGPSKIP=1
DO I006X
QUIT
+16 SET BGPGD=$PIECE(BGPGFR,U,2)
SET BGPNGFR=$SELECT($PIECE(BGPGFR,U,2):$$FMADD^XLFDT($PIECE(BGPGFR,U,2),365),1:"")
IF BGPNGFR'>BGPED
SET BGPIN=1
+17 SET BGPUD=$PIECE(BGPQUP,U,3)
SET BGPNQUP=$SELECT($PIECE(BGPQUP,U,3):$$FMADD^XLFDT($PIECE(BGPQUP,U,3),365),1:"")
IF BGPNQUP'>BGPED
SET BGPIN1=1
+18 ;had both GFR and QUP
IF 'BGPIN
IF 'BGPIN1
DO I006X
SET BGPSKIP=1
QUIT
+19 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Est GFR: "_$SELECT($PIECE(BGPGFR,U,2)]"":$$DATE^BGP9UTL($PIECE(BGPGFR,U,2)),1:"Never")_"|"_"Last Quantitative Urine Protein: "_$SELECT($PIECE(BGPQUP,U,3)]"":$$DATE^BGP9UTL($PIECE(BGPQUP,U,3)),1:"Never")
+20 SET BGPND=$SELECT(BGPGD:$$FMADD^XLFDT(BGPGD,365),1:BGPBD)
+21 IF BGPUD]""
IF BGPND<$$FMADD^XLFDT(BGPUD,365)
SET BGPND=$$FMADD^XLFDT(BGPUD,365)
+22 IF BGPND=""
SET BGPND=BGPBD
+23 SET BGPISSV=BGPISSV_"|Est GFR & Quant Urine Protein Overdue as of: "_$$DATE^BGP9UTL(BGPND)
I006X ;
+1 KILL BGPN1,BGPGFR,BGPQUP,BGPN2,BGPESRD,BGPIN,BGPIN1,BGPNQUP,BGPNGFR,BGPGD,BGPUD
+2 QUIT
I007 ;EP DM eye exam
+1 ;get last date and value for patient DFN
+2 ;patient will display this item if they had a dm diagnosis ever and first dm dx
+3 ;was prior to beginning date of date range
+4 ;date of last^value of last^next date due
+5 SET BGPSKIP=""
+6 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+7 NEW BGPVALUE,BGPD,BGPND
+8 SET BGPISSV=""
SET BGPIN=""
+9 KILL BGPISSV
+10 SET BGPVALUE=$$EYE^BGP9DPA4(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+11 SET BGPREF=$$EYEREF^BGP9DPA4(DFN,BGPBD,BGPED)
+12 IF BGPREF]""
SET BGPSKIP=1
QUIT
+13 IF BGPVALUE=""
IF BGPREF=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
QUIT
+14 IF BGPVALUE=""
IF BGPREF]""
Begin DoDot:1
+15 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Patient refused on "_$$DATE^BGP9UTL($PIECE(BGPREF,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
SET BGPD=$PIECE(BGPVALUE,U,2)
End DoDot:1
QUIT
+16 SET BGPD=$PIECE(BGPVALUE,U,2)
+17 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+18 IF BGPND'>BGPED
SET BGPIN=1
+19 ;not due this gpra year so don't display
IF 'BGPIN
SET BGPSKIP=1
QUIT
+20 SET BGPND=$$DATE^BGP9UTL(BGPND)
+21 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: "_$$DATE^BGP9UTL(BGPD)
+22 IF BGPREF]""
SET BGPISSV=BGPISSV_"|Patient refused on "_$$DATE^BGP9UTL($PIECE(BGPREF,U,2))
+23 SET BGPISSV=BGPISSV_"|Overdue as of: "_BGPND
+24 QUIT
I009 ;EP DENTAL EXAM
+1 ;get last date and value for patient DFN
+2 SET BGPSKIP=""
+3 NEW BGPVALUE,BGPD,BGPND
+4 SET BGPISSV=""
SET BGPIN=""
+5 KILL BGPISSV
+6 SET BGPVALUE=$$DENTSRV^BGP9D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+7 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
QUIT
+8 SET BGPD=$PIECE(BGPVALUE,U,2)
+9 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+10 IF BGPND'>BGPED
SET BGPIN=1
+11 ;not due this rp
IF 'BGPIN
SET BGPSKIP=1
QUIT
+12 SET BGPND=$$DATE^BGP9UTL(BGPND)
+13 SET BGPREF=$$DENTSRV^BGP9D21(DFN,BGPBD,BGPED)
+14 IF BGPREF["Ref"
SET BGPSKIP=1
QUIT
+15 ;I BGPVALUE["Refused" S BGPSKIP=1 Q ;S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: patient refused on "_$$DATE^BGP9UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) Q
+16 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND
+17 SET $PIECE(BGPISSV,U,4)=$$TITLE2(BGPGPRAI)
+18 QUIT
I012 ;EP - FLU
+1 ;get last date and value for patient DFN
+2 ;date of last^value of last^next date due
+3 SET BGPSKIP=""
+4 NEW BGPVALUE,BGPD,BGPND
+5 IF BGPAGEB<65
SET BGPSKIP=1
QUIT
+6 SET BGPISSV=""
SET BGPIN=""
+7 KILL BGPISSV
+8 SET BGPVALUE=$$FLU^BGP9D3(DFN,BGPBD,BGPED)
+9 ;not due this year
IF BGPVALUE]""
SET BGPSKIP=1
QUIT
+10 SET BGPVALUE=$$FLU^BGP9D3(DFN,$$DOB^AUPNPAT(DFN),BGPED)
+11 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
QUIT
+12 SET BGPD=$PIECE(BGPVALUE,U,1)
+13 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+14 SET BGPND=$$DATE^BGP9UTL(BGPND)
+15 IF BGPVALUE["Refus"
SET BGPIN=1
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
QUIT
+16 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND
+17 QUIT
I013 ;EP - PNEU
+1 ;get last date and value for patient DFN
+2 ;date of last^value of last^next date due
+3 SET BGPSKIP=""
+4 NEW BGPVALUE,BGPD,BGPND
+5 ;GPRA MEASURE IS 65 AND OLDER
IF BGPAGEB<65
SET BGPSKIP=1
QUIT
+6 SET BGPISSV=""
SET BGPIN=""
+7 KILL BGPISSV
+8 SET BGPVALUE=$$PNEU^BGP9D31(DFN,$$DOB^AUPNPAT(DFN),BGPED)
+9 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
QUIT
+10 SET BGPD=$PIECE(BGPVALUE,U,1)
+11 SET BGPND=$SELECT(BGPD="":DT,1:"")
+12 IF BGPND]""
IF BGPND'>BGPED
SET BGPIN=1
+13 ;not due so skip
IF 'BGPIN
SET BGPSKIP=1
QUIT
+14 IF BGPVALUE["Refus"
SET BGPSKIP=1
QUIT
+15 SET BGPND=$$DATE^BGP9UTL(BGPND)
+16 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND
+17 QUIT
I014 ;EP - Childhood IZ
+1 ;
+2 NEW BGPVALUE,BGPD,BGPND
+3 SET BGPISSO=1
SET BGPIN=""
SET BGPIN1=""
+4 KILL BGPISSV
+5 DO I14^BGP9D32
+6 IF $GET(BGPSTOP)=1
SET BGPSKIP=1
DO I014X
QUIT
+7 ;up to date
IF BGPN21
SET BGPSKIP=1
DO I014X
QUIT
+8 IF 'BGPN21
SET BGPISSV=$$TITLE(BGPGPRAI)_U_$PIECE(BGPVALUE,"|||",2)_"|"_$SELECT('BGPD3:"NOT ",1:"")_"Active on Immunization Register."
I014X ;
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27
+2 KILL BGPI1,BGPI2,BGPI3,BGPI4,BGPI5,BGPI6,BGPI7,BGPN28,BGPN29
+3 KILL BGPVALUE
+4 KILL BGPDTAP,BGPOPV,BGPMMR,BGPD,BGPT,BGPPER,BGPTET,BGPM,BGPMU,BGPME,BGPHIB,BGPHEP,BGPVAR
+5 QUIT
I015 ;EP - PAP
+1 ;
+2 ;
+3 NEW BGPVALUE,BGPD,BGPND
+4 SET BGPISSV=""
SET BGPIN=""
SET BGPIN1=""
+5 KILL BGPISSV
+6 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB
+7 SET BGPI7DA=0
SET BGPI7DB=0
SET BGPN1=0
SET BGPN2=0
+8 SET BGPI7=$$DEN7^BGP9D3(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+9 IF BGPACTUP
IF BGPI7
SET BGPI7DA=1
+10 IF BGPACTCL
IF BGPI7
SET BGPI7DB=1
+11 ;not in either denom so quit
IF 'BGPI7DA
IF 'BGPI7DB
SET BGPSKIP=1
DO I015X
QUIT
+12 SET BGPVALUE=$$PAP^BGP9D3(DFN,BGPEDATE,$$AGE^AUPNPAT(DFN))
+13 SET BGPREF=$$PAPREF(DFN,BGPBDATE,BGPEDATE)
+14 IF BGPREF]""
SET BGPSKIP=1
QUIT
+15 ; as of "_$$DATE^BGP9UTL(DT) Q
IF BGPVALUE=""
IF BGPREF=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last PAP: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I015X
QUIT
+16 SET BGPD=$PIECE(BGPVALUE,U,2)
+17 SET BGPND=$SELECT(BGPD="":DT,1:$$FMADD^XLFDT(BGPD,(3*365)))
+18 IF BGPND]""
IF BGPND'>BGPED
SET BGPIN=1
+19 ;not due, don't display
IF 'BGPIN
SET BGPSKIP=1
DO I015X
QUIT
+20 IF BGPVALUE=""
IF BGPREF]""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap Smear: Never - patient refused on "_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I015X
QUIT
+21 SET BGPND=$$DATE^BGP9UTL(BGPND)
+22 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND_$SELECT(BGPREF]"":"|Patient refused a Pap Smear on "_$$DATE^BGP9UTL($PIECE(BGPREF,U,2)),1:"")
I015X ;
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB,BGPREF
+2 KILL BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27
+3 QUIT
I016 ;EP -MAMMOGRAM
+1 ;
+2 NEW BGPVALUE,BGPD,BGPND
+3 SET BGPISSV=""
SET BGPIN=""
SET BGPIN1=""
+4 KILL BGPISSV
+5 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPMAM,BGPI8,BGPI81,BGPI8DA,BGPI8DB,BGPI8DC,BGPI8DD,BGPI8DE
+6 SET BGPI8=$$DEN8^BGP9D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+7 IF 'BGPI8
SET BGPSKIP=1
DO I016X
QUIT
+8 SET BGPVALUE=$$MAM^BGP9D4(DFN,BGPEDATE,15,1)
+9 SET BGPREF=$$MAMREF(DFN,BGPBDATE,BGPEDATE)
+10 IF BGPREF]""
SET BGPSKIP=1
QUIT
+11 ; as of "_$$DATE^BGP9UTL(DT) Q
IF BGPVALUE=""
IF BGPREF=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I016X
QUIT
+12 SET BGPD=$PIECE(BGPVALUE,U,2)
+13 SET BGPND=$SELECT(BGPD="":DT,1:$$FMADD^XLFDT(BGPD,(2*365)))
+14 IF BGPND]""
IF BGPND'>BGPED
SET BGPIN=1
+15 ;not due, don't display
IF 'BGPIN
SET BGPSKIP=1
DO I015X
QUIT
+16 IF BGPVALUE=""
IF BGPREF]""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap Smear: Never - patient refused on "_$$DATE^BGP9UTL($PIECE(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I016X
QUIT
+17 SET BGPND=$$DATE^BGP9UTL(BGPND)
+18 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_BGPND_$SELECT(BGPREF]"":"|Patient refused a Mammogram on "_$$DATE^BGP9UTL($PIECE(BGPREF,U,2)),1:"")
+19 ;
I016X ;
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB
+2 KILL BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27
+3 QUIT
I031A ;
+1 QUIT
TITLE(I) ;
+1 QUIT $PIECE($GET(^BGPINDNC(I,12)),U,9)
TITLE2(I) ;EP
+1 QUIT $PIECE($GET(^BGPINDNC(I,12)),U,16)
PAPREF(P,BDATE,EDATE) ;
+1 SET T=$$REFUSAL^BGP9UTL1(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),BDATE,EDATE)
+2 IF T
QUIT "1^"_$PIECE(T,U,2)_"^ref"
+3 SET BGPLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+4 IF 'BGPLT
QUIT 0
+5 SET X=0
SET T=""
FOR
SET X=$ORDER(^ATXLAB(BGPLT,21,X))
IF X'=+X!($PIECE(T,U)=1)
QUIT
Begin DoDot:1
+6 SET T=""
+7 SET Y=$PIECE(^ATXLAB(BGPLT,21,X,0),U)
+8 IF 'Y
QUIT
+9 SET T=$$REFUSAL^BGP9UTL1(P,60,Y,BDATE,EDATE)
End DoDot:1
+10 IF T
QUIT 1_"^"_$PIECE(T,U,2)_"^ref"
+11 QUIT ""
MAMREF(P,BDATE,EDATE) ;
+1 SET T=$$CPTREFT^BGP9UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$SELECT(BGPRTYPE'=3:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))
+2 IF T
SET T="1^"_$PIECE(T,U,2)_"^ref CPT"
QUIT T
+3 SET T=$$RADREF^BGP9UTL1(P,$$FMADD^XLFDT(EDATE,-365),EDATE,$SELECT(BGPRTYPE'=3:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1:$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM HEDIS",0))))
+4 IF T
SET T="1^"_$PIECE(T,U,2)_"^ref CPT"
+5 QUIT $SELECT(T:T,1:"")
