BGP5DPA1.m

BGP5DPA1 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ;

 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 ;

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(^BGPINDKC("B",BGPIC,BGPGPRAI)) Q:BGPGPRAI'=+BGPGPRAI  D

 ..Q:$P($G(^BGPINDKC(BGPGPRAI,12)),U,9)=""

 ..S (BGPNUM,BGPDEN)=0

 ..S BGPISSV="",BGPSKIP=0

 ..Q:'$D(^BGPINDKC(BGPGPRAI,4))

 ..X ^BGPINDKC(BGPGPRAI,4)

 ..S $P(BGPISSV,U,4)=$$TITLE2^BGP5DPA1(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)

 ..I BGPISST="A" D

 ...S ^XTMP("BGP5DPA",BGPGPRAJ,BGPGPRAH,"ANY",$P(^DPT(DFN,0),U,1),DFN,BGPIC,BGPGPRAI)=BGPISSV

 ..I BGPISST="C" D

 ...S X=BGPAPPTS(BGPSOX)

 ...S ^XTMP("BGP5DPA",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("BGP5DPA",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("BGP5DPA",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

 S BGPSKIP=""

 I 'BGPDMD1 S BGPSKIP=1 Q  ;no dm diagnosis ever

 NEW BGPV,BGPD,BGPND

 S BGPIN=""

 K BGPISSV

 S BGPV=$$HGBA1C^BGP5D2(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 I BGPV="" S BGPISSV=$P($G(^BGPINDKC(BGPGPRAI,12)),U,9)_U_"Last A1c: Never|Overdue as of: "_$$DATE^BGP5UTL(BGPBDATE) Q

 S BGPD=$P(BGPV,U,3)

 S BGPND=$$FMADD^XLFDT(BGPD,365)

 I BGPND'>BGPED S BGPIN=1

 S BGPND=$$DATE^BGP5UTL(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^BGP5UTL(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^BGP5D2(DFN,$$FMADD^XLFDT(BGPED,-365),BGPED)

 I BGPV="" S BGPV=$$BPCPT^BGP5D22(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^BGP5UTL(BGPBD)_"-"_$$DATE^BGP5UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP5UTL(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^BGP5D2(DFN,$$DOB^AUPNPAT(DFN),BGPED)

 I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: Never|Overdue as of: "_$$DATE^BGP5UTL(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^BGP5UTL(BGPND)

 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: "_$$DATE^BGP5UTL(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^BGP5D21

 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^BGP5UTL($P(BGPGFR,U,2)),1:"Never")_"|"_"Last UACR: "_$S($P(BGPQUP,U,3)]"":$$DATE^BGP5UTL($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^BGP5UTL(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^BGP5DPA4(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)

 S BGPREF=""

 I BGPVALUE="",BGPREF="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) Q

 I BGPVALUE="",BGPREF]"" D  Q

 .S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: Never|Patient refused on "_$$DATE^BGP5UTL($P(BGPREF,U,2))_"|Overdue as of: "_$$DATE^BGP5UTL(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^BGP5UTL(BGPND)

 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Evaluation: "_$$DATE^BGP5UTL(BGPD)

 ;I BGPREF]"" S BGPISSV=BGPISSV_"|Patient refused on "_$$DATE^BGP5UTL($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^BGP5D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)

 I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: Never|Overdue as of: "_$$DATE^BGP5UTL(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^BGP5UTL(BGPND)

 S BGPREF=$$DENTSRV^BGP5D21(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^BGP5UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) Q

 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Exam: "_$$DATE^BGP5UTL(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^BGP5D3(DFN,BGPBD,BGPED,1)

 I BGPVALUE]"",$P(BGPVALUE,U,3)'=2 S BGPSKIP=1 Q

 S BGPVALUE=$$FLU^BGP5D3(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)

 I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) Q

 S BGPD=$P(BGPVALUE,U,1)

 S BGPND=$$FMADD^XLFDT(BGPD,365)

 S BGPND=$$DATE^BGP5UTL(BGPND)

 I BGPVALUE["Refus" S BGPIN=1 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: patient refused on "_$$DATE^BGP5UTL($P(BGPVALUE,U,1))_"|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) Q

 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP5UTL(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^BGP5D31(DFN,$$DOB^AUPNPAT(DFN),BGPED,1)

 I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: Never|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) Q

 S BGPD=$P(BGPVALUE,U,1)

 S BGPND=DT

 S BGPVAL=$$PNEU^BGP5D31(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"

 S BGPA65="" S BGPA65=$$PNEU^BGP5D31(DFN,$$FMADD^XLFDT($$DOB^AUPNPAT(DFN),+(65*365)),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^BGP5UTL(BGPND)

 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last IZ: "_$$DATE^BGP5UTL(BGPD)_"|Overdue as of: "_BGPND

 Q

I014 ;EP - Childhood IZ

 ;

 NEW BGPVALUE,BGPD,BGPND

 S BGPISSO=1,BGPIN="",BGPIN1=""

 K BGPISSV

 D I14^BGP5D32

 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^BGP5D32

 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^BGP5D32

 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^BGP5D3(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^BGP5D3(DFN,BGPEDATE,$$AGE^AUPNPAT(DFN),1)

 S BGPREF=""  ;no refusals

 I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last PAP: Never|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) D I015X Q  ; as of "_$$DATE^BGP5UTL(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^BGP5UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) D I015X Q

 S BGPND=$$DATE^BGP5UTL(BGPND)

 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Pap: "_$$DATE^BGP5UTL(BGPD)_"|Overdue as of: "_BGPND_$S(BGPREF]"":"|Patient refused a Pap Smear on "_$$DATE^BGP5UTL($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^BGP5D4(DFN,BGPAGEB,BGPAGEE,BGPSEX,BGPEDATE)

 I 'BGPI8 S BGPSKIP=1 D I016X Q

 S BGPVALUE=$$MAM^BGP5D4(DFN,BGPEDATE,15,1)

 S BGPREF=""

 I BGPVALUE="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: Never|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) D I016X Q  ; as of "_$$DATE^BGP5UTL(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^BGP5UTL($P(BGPVALUE,U,2))_"|Overdue as of: "_$$DATE^BGP5UTL(BGPBD) D I016X Q

 S BGPND=$$DATE^BGP5UTL(BGPND)

 S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mammogram: "_$$DATE^BGP5UTL(BGPD)_"|Overdue as of: "_BGPND_$S(BGPREF]"":"|Patient refused a Mammogram on "_$$DATE^BGP5UTL($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(^BGPINDKC(I,12)),U,9)

TITLE2(I) ;EP

 Q $P($G(^BGPINDKC(I,12)),U,16)

BGP5DPA1  ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ;

 +1       ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143

 +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(^BGPINDKC("B",BGPIC,BGPGPRAI))

                       IF BGPGPRAI'=+BGPGPRAI

                           QUIT 

                       Begin DoDot:2

 +10                       IF $PIECE($GET(^BGPINDKC(BGPGPRAI,12)),U,9)=""

                               QUIT 

 +11                       SET (BGPNUM,BGPDEN)=0

 +12                       SET BGPISSV=""

                           SET BGPSKIP=0

 +13                       IF '$DATA(^BGPINDKC(BGPGPRAI,4))

                               QUIT 

 +14                       XECUTE ^BGPINDKC(BGPGPRAI,4)

 +15                       SET $PIECE(BGPISSV,U,4)=$$TITLE2^BGP5DPA1(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                       IF BGPISST="A"

                               Begin DoDot:3

 +20                               SET ^XTMP("BGP5DPA",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("BGP5DPA",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("BGP5DPA",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("BGP5DPA",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        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^BGP5D2(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

 +10       IF BGPV=""

               SET BGPISSV=$PIECE($GET(^BGPINDKC(BGPGPRAI,12)),U,9)_U_"Last A1c: Never|Overdue as of: "_$$DATE^BGP5UTL(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^BGP5UTL(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^BGP5UTL(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^BGP5D2(DFN,$$FMADD^XLFDT(BGPED,-365),BGPED)

 +6        IF BGPV=""

               SET BGPV=$$BPCPT^BGP5D22(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: 2 BPs not documented "_$$DATE^BGP5UTL(BGPBD)_"-"_$$DATE^BGP5UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP5UTL(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^BGP5D2(DFN,$$DOB^AUPNPAT(DFN),BGPED)

 +7        IF BGPVALUE=""

               SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: Never|Overdue as of: "_$$DATE^BGP5UTL(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^BGP5UTL(BGPND)

 +13       SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last LDL: "_$$DATE^BGP5UTL(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^BGP5D21

 +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^BGP5UTL($PIECE(BGPGFR,U,2)),1:"Never")_"|"_"Last UACR: "_$SELECT($PIECE(BGPQUP,U,3)]"":$$DATE^BGP5UTL($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^BGP5UTL(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