BGP8DPA1 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
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(^BGPINDRC("B",BGPIC,BGPGPRAI)) Q:BGPGPRAI'=+BGPGPRAI D
..Q:$P($G(^BGPINDRC(BGPGPRAI,12)),U,9)=""
..S (BGPNUM,BGPDEN)=0
..S BGPISSV="",BGPSKIP=0
..Q:'$D(^BGPINDRC(BGPGPRAI,4))
..X ^BGPINDRC(BGPGPRAI,4)
..S $P(BGPISSV,U,4)=$$TITLE2^BGP8DPA1(BGPGPRAI)
..Q:BGPSKIP
..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)
..S O=$P($P($G(^BGPINDRC(BGPGPRAI,12)),U,4),".",1)
..I BGPISST="A" D
...S ^XTMP("BGP8DPA",BGPGPRAJ,BGPGPRAH,"ANY",$P(^DPT(DFN,0),U,1),DFN,O,BGPIC,BGPGPRAI)=BGPISSV
..I BGPISST="C" D
...S X=BGPAPPTS(BGPSOX)
...S ^XTMP("BGP8DPA",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,O,BGPIC,BGPGPRAI)=BGPISSV ;_"%%"_$G(BGPISSV(1))
..I BGPISST="P" D
...S X=BGPAPPTS(BGPSOX)
...S ^XTMP("BGP8DPA",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),O,BGPIC,BGPGPRAI)=BGPISSV ;_"%%"_$G(BGPISSV(1))
..I BGPISST="D" D
...S X=BGPAPPTS(BGPSOX)
...S ^XTMP("BGP8DPA",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,O,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
S BGPSKIP=""
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPV,BGPD,BGPND
S BGPIN=""
K BGPISSV
S BGPV=$$HGBA1C^BGP8D2(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPV="" S BGPISSV=$P($G(^BGPINDRC(BGPGPRAI,12)),U,9)_U_"Last A1c: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBDATE) Q
S BGPD=$P(BGPV,U,3)
S BGPND=$$FMADD^XLFDT(BGPD,365)
I BGPND'>BGPED S BGPIN=1
S BGPND=$$DATE^BGP8UTL(BGPND)
S BGPMET=$S($P(BGPV,U,2)'=6&($P(BGPV,U,2)'=5):"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^BGP8UTL(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
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPV,BGPD,BGPND
S (BGPISSV,BGPIN)=""
K BGPISSV
S BGPV=$$MEANBP^BGP8D2(DFN,$$FMADD^XLFDT(BGPED,-365),BGPED)
I BGPV="" S BGPV=$$BPCPT^BGP8D22(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: BP not documented "_$$DATE^BGP8UTL(BGPBD)_"-"_$$DATE^BGP8UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
I $P(BGPV,U,2)=4!($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)'=4,$P(BGPV,U,2)'=2 S BGPISSV=BGPISSV_" - Not Controlled BP"
Q
I005 ;EP - DM LDL
S BGPSKIP=""
I 'BGPDMD1 S BGPSKIP=1 Q
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$LDL^BGP8D2(DFN,$$DOB^AUPNPAT(DFN),BGPED)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: Never|Overdue as of: "_$$DATE^BGP8UTL(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^BGP8UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: "_$$DATE^BGP8UTL(BGPD)_"|"_"Overdue as of: "_BGPND
Q
I006 ;EP - DM Nephropathy
I 'BGPDMD1 S BGPSKIP=1 Q
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN="",BGPIN1=""
K BGPISSV
S (BGPBD1,BGPBD2)=$$DOB^AUPNPAT(DFN),BGPEDATE=BGPED,BGPN1=0
S BGPHOLD=""
D I61^BGP8D21
S BGPGFR=$P(BGPHOLD,"|",1)
S BGPQUP=$P(BGPHOLD,"|",3)
S BGPESRD=$P(BGPHOLD,"|",2)
I BGPESRD S BGPSKIP=1 D I006X 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^BGP8UTL($P(BGPGFR,U,2)),1:"Never")_"|"_"Last UACR: "_$S($P(BGPQUP,U,3)]"":$$DATE^BGP8UTL($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 & UACR Overdue as of: "_$$DATE^BGP8UTL(BGPND)
I006X ;
K BGPN1,BGPGFR,BGPQUP,BGPN2,BGPESRD,BGPIN,BGPIN1,BGPNQUP,BGPNGFR,BGPGD,BGPUD
Q
I007 ;EP DM eye exam
S BGPSKIP=""
I 'BGPDMD1 S BGPSKIP=1 Q ;no dm diagnosis ever
NEW BGPVALUE,BGPD,BGPND
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$EYE^BGP8DPA4(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
S BGPREF=""
I BGPVALUE="",BGPREF="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
I BGPVALUE="",BGPREF]"" D Q
.S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Patient refused on "_$$DATE^BGP8UTL($P(BGPREF,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(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^BGP8UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: "_$$DATE^BGP8UTL(BGPD)
;I BGPREF]"" S BGPISSV=BGPISSV_"|Patient refused on "_$$DATE^BGP8UTL($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^BGP8D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: Never|Overdue as of: "_$$DATE^BGP8UTL(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^BGP8UTL(BGPND)
S BGPREF=$$DENTSRV^BGP8D21(DFN,BGPBD,BGPED,1)
;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^BGP8UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: "_$$DATE^BGP8UTL(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<18 S BGPSKIP=1 Q ;18 and older as of crs v16
S BGPISSV="",BGPIN=""
K BGPISSV
S BGPVALUE=$$FLU^BGP8D3(DFN,BGPBD,BGPED,1)
I BGPVALUE]"",$P(BGPVALUE,U,3)'=2 S BGPSKIP=1 Q
S BGPVALUE=$$FLU^BGP8D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,1)
S BGPND=$$FMADD^XLFDT(BGPD,365)
S BGPND=$$DATE^BGP8UTL(BGPND)
I BGPVALUE["Refus" S BGPIN=1 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP8UTL($P(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP8UTL(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^BGP8D31(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
S BGPD=$P(BGPVALUE,U,1)
S BGPND=DT
S BGPVAL=$$PNEU^BGP8D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
I $P(BGPVAL,U,3)=1!($P(BGPVAL,U,3)=3) S BGPIN=0 G N ;HAD IN PAST 5 YEARS SO "UP TO DATE"
;65TH DOB DATE
S B=$$DOB^AUPNPAT(DFN)
S BGPA65BD=$E(B,1,3)+65_$E(B,4,7)
S BGPA65="" S BGPA65=$$PNEU^BGP8D31(DFN,BGPA65BD,BGPEDATE) I $P(BGPA65,U,3)=1!($P(BGPA65,U,3)=3) S BGPIN=0
;I BGPVALUE["Refus" S BGPSKIP=1 Q
N ;
I 'BGPIN S BGPSKIP=1 Q ;had one in past 5 yrs or after 65 so not due
S BGPND=$$DATE^BGP8UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND
Q
I014 ;EP - Childhood IZ
;
NEW BGPVALUE,BGPD,BGPND
S BGPISSO=1,BGPIN="",BGPIN1=""
K BGPISSV
D I14^BGP8D32
I $G(BGPSTOP)=1 S BGPSKIP=1 D I014X Q
I BGPN40 S BGPSKIP=1 D I014X Q ;up to date
I 'BGPN40 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
I0141 ;EP - Childhood IZ
;
NEW BGPVALUE,BGPD,BGPND
S BGPISSO=1,BGPIN="",BGPIN1=""
K BGPISSV
D I14^BGP8D32
I $G(BGPSTOP)=1 S BGPSKIP=1 D I0141X Q
I BGPN41 S BGPSKIP=1 D I0141X Q ;up to date
I 'BGPN41 S BGPISSV=$$TITLE(BGPGPRAI)_U_$P(BGPVALUE,"|||",2)_"|"_$S('BGPD3:"NOT ",1:"")_"Active on Immunization Register."
I0141X ;
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
I0142 ;EP - Childhood IZ
;
NEW BGPVALUE,BGPD,BGPND
S BGPISSO=1,BGPIN="",BGPIN1=""
K BGPISSV
D I14^BGP8D32
I $G(BGPSTOP)=1 S BGPSKIP=1 D I0141X Q
I BGPN91 S BGPSKIP=1 D I0142X Q ;up to date
I 'BGPN91 S BGPISSV=$$TITLE(BGPGPRAI)_U_$P(BGPVALUE,"|||",2)_"|"_$S('BGPD3:"NOT ",1:"")_"Active on Immunization Register."
I0142X ;
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
I $P(^DPT(DFN,0),U,2)'="F" S BGPSKIP=1 D I015X Q ;female only
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^BGP8D3(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
I BGPACTUP,BGPI7 S BGPI7DA=1
I BGPACTCL,BGPI7 S BGPI7DB=1
S BGPI7DC=0 I BGPI7,BGPAGEB>23,BGPAGEE<65 S BGPI7DC=1
I 'BGPI7DC S BGPSKIP=1 D I015X Q ;not in either denom
S BGPVALUE=$$PAP^BGP8D3(DFN,BGPEDATE,$$AGE^AUPNPAT(DFN),1)
S BGPREF="" ;no refusals
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last PAP: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) D I015X Q ; as of "_$$DATE^BGP8UTL(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^BGP8UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) D I015X Q
S BGPND=$$DATE^BGP8UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND_$S(BGPREF]"":"|Patient refused a Pap Smear on "_$$DATE^BGP8UTL($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^BGP8D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
I 'BGPI8 S BGPSKIP=1 D I016X Q
S BGPVALUE=$$MAM^BGP8D4(DFN,BGPEDATE,15,1)
S BGPREF=""
I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) D I016X Q ; as of "_$$DATE^BGP8UTL(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^BGP8UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) D I016X Q
S BGPND=$$DATE^BGP8UTL(BGPND)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND_$S(BGPREF]"":"|Patient refused a Mammogram on "_$$DATE^BGP8UTL($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) ;EP
Q $P($G(^BGPINDRC(I,12)),U,9)
TITLE2(I) ;EP
Q $P($G(^BGPINDRC(I,12)),U,16)
BGP8DPA1 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+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(^BGPINDRC("B",BGPIC,BGPGPRAI))
IF BGPGPRAI'=+BGPGPRAI
QUIT
Begin DoDot:2
+10 IF $PIECE($GET(^BGPINDRC(BGPGPRAI,12)),U,9)=""
QUIT
+11 SET (BGPNUM,BGPDEN)=0
+12 SET BGPISSV=""
SET BGPSKIP=0
+13 IF '$DATA(^BGPINDRC(BGPGPRAI,4))
QUIT
+14 XECUTE ^BGPINDRC(BGPGPRAI,4)
+15 SET $PIECE(BGPISSV,U,4)=$$TITLE2^BGP8DPA1(BGPGPRAI)
+16 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 SET O=$PIECE($PIECE($GET(^BGPINDRC(BGPGPRAI,12)),U,4),".",1)
+20 IF BGPISST="A"
Begin DoDot:3
+21 SET ^XTMP("BGP8DPA",BGPGPRAJ,BGPGPRAH,"ANY",$PIECE(^DPT(DFN,0),U,1),DFN,O,BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
+22 IF BGPISST="C"
Begin DoDot:3
+23 SET X=BGPAPPTS(BGPSOX)
+24 ;_"%%"_$G(BGPISSV(1))
SET ^XTMP("BGP8DPA",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,O,BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
+25 IF BGPISST="P"
Begin DoDot:3
+26 SET X=BGPAPPTS(BGPSOX)
+27 ;_"%%"_$G(BGPISSV(1))
SET ^XTMP("BGP8DPA",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),O,BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
+28 IF BGPISST="D"
Begin DoDot:3
+29 SET X=BGPAPPTS(BGPSOX)
+30 ;_"%%"_$G(BGPISSV(1))
SET ^XTMP("BGP8DPA",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,O,BGPIC,BGPGPRAI)=BGPISSV
End DoDot:3
End DoDot:2
End DoDot:1
+31 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
+32 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 SET BGPSKIP=""
+5 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+6 NEW BGPV,BGPD,BGPND
+7 SET BGPIN=""
+8 KILL BGPISSV
+9 SET BGPV=$$HGBA1C^BGP8D2(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+10 IF BGPV=""
SET BGPISSV=$PIECE($GET(^BGPINDRC(BGPGPRAI,12)),U,9)_U_"Last A1c: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBDATE)
QUIT
+11 SET BGPD=$PIECE(BGPV,U,3)
+12 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+13 IF BGPND'>BGPED
SET BGPIN=1
+14 SET BGPND=$$DATE^BGP8UTL(BGPND)
+15 SET BGPMET=$SELECT($PIECE(BGPV,U,2)'=6&($PIECE(BGPV,U,2)'=5):"Not Ideal Control",1:"Ideal Control")
+16 IF BGPMET=""
SET BGPMET=$SELECT($PIECE(BGPV,U,4)="":"No VALUE",1:"")
+17 ;not due before end of gpra year, in control
IF 'BGPIN
IF BGPMET="Ideal Control"
SET BGPSKIP=1
QUIT
+18 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last A1c: "_$$DATE^BGP8UTL(BGPD)_" value: "_$PIECE(BGPV,U,4)_" - "_BGPMET_"|"_$SELECT(BGPIN:"Overdue as of: ",1:"Next Due: ")_BGPND
+19 IF BGPIN
IF BGPMET["Not Ideal Control"
SET BGPISSV=BGPISSV_"|Next Due: "_BGPND
+20 QUIT
I004 ;EP - DM BP control
+1 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+2 NEW BGPV,BGPD,BGPND
+3 SET (BGPISSV,BGPIN)=""
+4 KILL BGPISSV
+5 SET BGPV=$$MEANBP^BGP8D2(DFN,$$FMADD^XLFDT(BGPED,-365),BGPED)
+6 IF BGPV=""
SET BGPV=$$BPCPT^BGP8D22(DFN,BGP365,BGPED)
IF $PIECE(BGPV,U)
SET BGPV=U_2_U_$PIECE(BGPV,U,2)
+7 ;
+8 IF BGPV=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: BP not documented "_$$DATE^BGP8UTL(BGPBD)_"-"_$$DATE^BGP8UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+9 ;in control BP in report period, do not display
IF $PIECE(BGPV,U,2)=4!($PIECE(BGPV,U,2)=2)
SET BGPSKIP=1
QUIT
+10 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: "_$PIECE(BGPV,U)
+11 IF $PIECE(BGPV,U,2)'=4
IF $PIECE(BGPV,U,2)'=2
SET BGPISSV=BGPISSV_" - Not Controlled BP"
+12 QUIT
I005 ;EP - DM LDL
+1 SET BGPSKIP=""
+2 IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+3 NEW BGPVALUE,BGPD,BGPND
+4 SET BGPISSV=""
SET BGPIN=""
+5 KILL BGPISSV
+6 SET BGPVALUE=$$LDL^BGP8D2(DFN,$$DOB^AUPNPAT(DFN),BGPED)
+7 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+8 SET BGPD=$PIECE(BGPVALUE,U,2)
+9 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+10 IF BGPND'>BGPED
SET BGPIN=1
+11 ;had LDL in time period
IF 'BGPIN
SET BGPSKIP=1
QUIT
+12 SET BGPND=$$DATE^BGP8UTL(BGPND)
+13 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: "_$$DATE^BGP8UTL(BGPD)_"|"_"Overdue as of: "_BGPND
+14 QUIT
I006 ;EP - DM Nephropathy
+1 IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+2 NEW BGPVALUE,BGPD,BGPND
+3 SET BGPISSV=""
SET BGPIN=""
SET BGPIN1=""
+4 KILL BGPISSV
+5 SET (BGPBD1,BGPBD2)=$$DOB^AUPNPAT(DFN)
SET BGPEDATE=BGPED
SET BGPN1=0
+6 SET BGPHOLD=""
+7 DO I61^BGP8D21
+8 SET BGPGFR=$PIECE(BGPHOLD,"|",1)
+9 SET BGPQUP=$PIECE(BGPHOLD,"|",3)
+10 SET BGPESRD=$PIECE(BGPHOLD,"|",2)
+11 IF BGPESRD
SET BGPSKIP=1
DO I006X
QUIT
+12 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
+13 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
+14 ;had both GFR and QUP
IF 'BGPIN
IF 'BGPIN1
DO I006X
SET BGPSKIP=1
QUIT
+15 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Est GFR: "_$SELECT($PIECE(BGPGFR,U,2)]"":$$DATE^BGP8UTL($PIECE(BGPGFR,U,2)),1:"Never")_"|"_"Last UACR: "_$SELECT($PIECE(BGPQUP,U,3)]"":$$DATE^BGP8UTL($PIECE(BGPQUP,U,3)),1:"Never")
+16 SET BGPND=$SELECT(BGPGD:$$FMADD^XLFDT(BGPGD,365),1:BGPBD)
+17 IF BGPUD]""
IF BGPND<$$FMADD^XLFDT(BGPUD,365)
SET BGPND=$$FMADD^XLFDT(BGPUD,365)
+18 IF BGPND=""
SET BGPND=BGPBD
+19 SET BGPISSV=BGPISSV_"|Est GFR & UACR Overdue as of: "_$$DATE^BGP8UTL(BGPND)
I006X ;
+1 KILL BGPN1,BGPGFR,BGPQUP,BGPN2,BGPESRD,BGPIN,BGPIN1,BGPNQUP,BGPNGFR,BGPGD,BGPUD
+2 QUIT
I007 ;EP DM eye exam
+1 SET BGPSKIP=""
+2 ;no dm diagnosis ever
IF 'BGPDMD1
SET BGPSKIP=1
QUIT
+3 NEW BGPVALUE,BGPD,BGPND
+4 SET BGPISSV=""
SET BGPIN=""
+5 KILL BGPISSV
+6 SET BGPVALUE=$$EYE^BGP8DPA4(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+7 SET BGPREF=""
+8 IF BGPVALUE=""
IF BGPREF=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+9 IF BGPVALUE=""
IF BGPREF]""
Begin DoDot:1
+10 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Patient refused on "_$$DATE^BGP8UTL($PIECE(BGPREF,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
SET BGPD=$PIECE(BGPVALUE,U,2)
End DoDot:1
QUIT
+11 SET BGPD=$PIECE(BGPVALUE,U,2)
+12 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+13 IF BGPND'>BGPED
SET BGPIN=1
+14 ;not due this gpra year so don't display
IF 'BGPIN
SET BGPSKIP=1
QUIT
+15 SET BGPND=$$DATE^BGP8UTL(BGPND)
+16 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: "_$$DATE^BGP8UTL(BGPD)
+17 ;I BGPREF]"" S BGPISSV=BGPISSV_"|Patient refused on "_$$DATE^BGP8UTL($P(BGPREF,U,2))
+18 SET BGPISSV=BGPISSV_"|Overdue as of: "_BGPND
+19 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^BGP8D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+7 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: Never|Overdue as of: "_$$DATE^BGP8UTL(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^BGP8UTL(BGPND)
+13 SET BGPREF=$$DENTSRV^BGP8D21(DFN,BGPBD,BGPED,1)
+14 ;I BGPREF["Ref" S BGPSKIP=1 Q
+15 ;I BGPVALUE["Refused" S BGPSKIP=1 Q ;S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: patient refused on "_$$DATE^BGP8UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
+16 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: "_$$DATE^BGP8UTL(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 ;18 and older as of crs v16
IF BGPAGEB<18
SET BGPSKIP=1
QUIT
+6 SET BGPISSV=""
SET BGPIN=""
+7 KILL BGPISSV
+8 SET BGPVALUE=$$FLU^BGP8D3(DFN,BGPBD,BGPED,1)
+9 IF BGPVALUE]""
IF $PIECE(BGPVALUE,U,3)'=2
SET BGPSKIP=1
QUIT
+10 SET BGPVALUE=$$FLU^BGP8D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+11 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+12 SET BGPD=$PIECE(BGPVALUE,U,1)
+13 SET BGPND=$$FMADD^XLFDT(BGPD,365)
+14 SET BGPND=$$DATE^BGP8UTL(BGPND)
+15 IF BGPVALUE["Refus"
SET BGPIN=1
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP8UTL($PIECE(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+16 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP8UTL(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^BGP8D31(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)
+9 IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+10 SET BGPD=$PIECE(BGPVALUE,U,1)
+11 SET BGPND=DT
+12 SET BGPVAL=$$PNEU^BGP8D31(DFN,$$FMADD^XLFDT(BGPEDATE,-(5*365)),BGPEDATE)
+13 ;HAD IN PAST 5 YEARS SO "UP TO DATE"
IF $PIECE(BGPVAL,U,3)=1!($PIECE(BGPVAL,U,3)=3)
SET BGPIN=0
GOTO N
+14 ;65TH DOB DATE
+15 SET B=$$DOB^AUPNPAT(DFN)
+16 SET BGPA65BD=$EXTRACT(B,1,3)+65_$EXTRACT(B,4,7)
+17 SET BGPA65=""
SET BGPA65=$$PNEU^BGP8D31(DFN,BGPA65BD,BGPEDATE)
IF $PIECE(BGPA65,U,3)=1!($PIECE(BGPA65,U,3)=3)
SET BGPIN=0
+18 ;I BGPVALUE["Refus" S BGPSKIP=1 Q
N ;
+1 ;had one in past 5 yrs or after 65 so not due
IF 'BGPIN
SET BGPSKIP=1
QUIT
+2 SET BGPND=$$DATE^BGP8UTL(BGPND)
+3 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND
+4 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^BGP8D32
+6 IF $GET(BGPSTOP)=1
SET BGPSKIP=1
DO I014X
QUIT
+7 ;up to date
IF BGPN40
SET BGPSKIP=1
DO I014X
QUIT
+8 IF 'BGPN40
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
I0141 ;EP - Childhood IZ
+1 ;
+2 NEW BGPVALUE,BGPD,BGPND
+3 SET BGPISSO=1
SET BGPIN=""
SET BGPIN1=""
+4 KILL BGPISSV
+5 DO I14^BGP8D32
+6 IF $GET(BGPSTOP)=1
SET BGPSKIP=1
DO I0141X
QUIT
+7 ;up to date
IF BGPN41
SET BGPSKIP=1
DO I0141X
QUIT
+8 IF 'BGPN41
SET BGPISSV=$$TITLE(BGPGPRAI)_U_$PIECE(BGPVALUE,"|||",2)_"|"_$SELECT('BGPD3:"NOT ",1:"")_"Active on Immunization Register."
I0141X ;
+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
I0142 ;EP - Childhood IZ
+1 ;
+2 NEW BGPVALUE,BGPD,BGPND
+3 SET BGPISSO=1
SET BGPIN=""
SET BGPIN1=""
+4 KILL BGPISSV
+5 DO I14^BGP8D32
+6 IF $GET(BGPSTOP)=1
SET BGPSKIP=1
DO I0141X
QUIT
+7 ;up to date
IF BGPN91
SET BGPSKIP=1
DO I0142X
QUIT
+8 IF 'BGPN91
SET BGPISSV=$$TITLE(BGPGPRAI)_U_$PIECE(BGPVALUE,"|||",2)_"|"_$SELECT('BGPD3:"NOT ",1:"")_"Active on Immunization Register."
I0142X ;
+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 ;female only
IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET BGPSKIP=1
DO I015X
QUIT
+5 SET BGPISSV=""
SET BGPIN=""
SET BGPIN1=""
+6 KILL BGPISSV
+7 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPPAP,BGPI7,BGPI7DA,BGPI7DB
+8 SET BGPI7DA=0
SET BGPI7DB=0
SET BGPN1=0
SET BGPN2=0
+9 SET BGPI7=$$DEN7^BGP8D3(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+10 IF BGPACTUP
IF BGPI7
SET BGPI7DA=1
+11 IF BGPACTCL
IF BGPI7
SET BGPI7DB=1
+12 SET BGPI7DC=0
IF BGPI7
IF BGPAGEB>23
IF BGPAGEE<65
SET BGPI7DC=1
+13 ;not in either denom
IF 'BGPI7DC
SET BGPSKIP=1
DO I015X
QUIT
+14 SET BGPVALUE=$$PAP^BGP8D3(DFN,BGPEDATE,$$AGE^AUPNPAT(DFN),1)
+15 ;no refusals
SET BGPREF=""
+16 ; as of "_$$DATE^BGP8UTL(DT) Q
IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last PAP: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
DO I015X
QUIT
+17 SET BGPD=$PIECE(BGPVALUE,U,2)
+18 SET BGPND=$SELECT(BGPD="":DT,1:$$FMADD^XLFDT(BGPD,(3*365)))
+19 IF BGPND]""
IF BGPND'>BGPED
SET BGPIN=1
+20 ;not due, don't display
IF 'BGPIN
SET BGPSKIP=1
DO I015X
QUIT
+21 IF BGPVALUE=""
IF BGPREF]""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap Smear: Never - patient refused on "_$$DATE^BGP8UTL($PIECE(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
DO I015X
QUIT
+22 SET BGPND=$$DATE^BGP8UTL(BGPND)
+23 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND_$SELECT(BGPREF]"":"|Patient refused a Pap Smear on "_$$DATE^BGP8UTL($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^BGP8D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)
+7 IF 'BGPI8
SET BGPSKIP=1
DO I016X
QUIT
+8 SET BGPVALUE=$$MAM^BGP8D4(DFN,BGPEDATE,15,1)
+9 SET BGPREF=""
+10 ; as of "_$$DATE^BGP8UTL(DT) Q
IF BGPVALUE=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
DO I016X
QUIT
+11 SET BGPD=$PIECE(BGPVALUE,U,2)
+12 SET BGPND=$SELECT(BGPD="":DT,1:$$FMADD^XLFDT(BGPD,(2*365)))
+13 IF BGPND]""
IF BGPND'>BGPED
SET BGPIN=1
+14 ;not due, don't display
IF 'BGPIN
SET BGPSKIP=1
DO I015X
QUIT
+15 IF BGPVALUE=""
IF BGPREF]""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap Smear: Never - patient refused on "_$$DATE^BGP8UTL($PIECE(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
DO I016X
QUIT
+16 SET BGPND=$$DATE^BGP8UTL(BGPND)
+17 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_BGPND_$SELECT(BGPREF]"":"|Patient refused a Mammogram on "_$$DATE^BGP8UTL($PIECE(BGPREF,U,2)),1:"")
+18 ;
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) ;EP
+1 QUIT $PIECE($GET(^BGPINDRC(I,12)),U,9)
TITLE2(I) ;EP
+1 QUIT $PIECE($GET(^BGPINDRC(I,12)),U,16)
