Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP6DPA2

BGP6DPA2.m

Go to the documentation of this file. 
  1. BGP6DPA2 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 03 Jun 2016 8:04 AM ;
  1.  ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
  1.  ;
  1. I017 ;EP - colorectal cancer
  1.  ;
  1.  K BGPFOB,BGPSIG,BGPBE,BGPCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
  1.  I BGPAGEB<50 S BGPSKIP=1 Q
  1.  I BGPAGEB>75 S BGPSKIP=1 Q
  1.  I $$CRC^BGP6D62(DFN,BGPEDATE) S BGPSKIP=1 Q
  1.  I 'BGPACTUP S BGPSKIP=1 Q
  1.  S (BGPIN,BGPIN1,BGPIN2,BGPIN3)=""
  1.  S BGPLAST=""
  1.  S BGPFOB=$$FOB^BGP6D62(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)  ;last FOB test
  1.  S D=$P(BGPFOB,U,2)
  1.  I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN=1
  1.  I D>BGPLAST S BGPLAST=D
  1.  S BGPSIG=$$SIG^BGP6D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))  ;last SIG test
  1.  S D=$P(BGPSIG,U,3)
  1.  I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN1=1
  1.  I D>BGPLAST S BGPLAST=D
  1.  S BGPCOLO=$$COLO^BGP6D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))  ;last COLO test
  1.  ;S D=$P(BGPCOLO,U,3),BGPNCOLO=$S($P(BGPCOLO,U,3):$$FMADD^XLFDT(D,(10*365)),1:BGPBDATE) I BGPNCOLO'>BGPED S BGPIN2=1
  1.  ;I D>BGPLAST S BGPLAST=D_U_BGPNCOLO
  1.  S D=$P(BGPCOLO,U,3)
  1.  I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN2=1
  1.  I D>BGPLAST S BGPLAST=D
  1.  I BGPLAST]"",(BGPIN!(BGPIN1)!(BGPIN2)!(BGPIN3)) S BGPSKIP=1 Q  ;met at least one of above
  1.  S BGPN1=0
  1.  S BGPISSV=$$TITLE(BGPGPRAI)
  1.  S BGPX=""
  1.  I BGPCOLO]"" S BGPX="Last Colonoscopy: "_$P(BGPCOLO,U,2)
  1.  I BGPSIG]"" S BGPX=BGPX_$S(BGPX]"":"|",1:"") S BGPX=BGPX_"Last Flex Sig: "_$P(BGPSIG,U,2)
  1.  ;
  1.  I BGPFOB]"" S BGPX=BGPX_$S(BGPX]"":"|",1:"") S BGPX=BGPX_"Last FOB: "_$$DATE^BGP6UTL($P(BGPFOB,U,2))
  1.  ;I BGPBE]"" S BGPX=BGPX_$S(BGPX]"":"|",1:"")_"Last DCBE: "_$P(BGPBE,U,2)
  1.  I BGPX="" S BGPX="No Colonoscopy, Flex Sig, FOBT or DCBE documented."
  1.  S BGPX=BGPX_"|May be overdue as of: "_$S(BGPLAST]"":$$DATE^BGP6UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP6UTL(BGPBD))
  1.  S BGPISSV=BGPISSV_U_BGPX
  1.  K BGPREF,BGPOTH,BGPN1,BGPFOB,BGPNFOB,BGPBE,BGPF,BGPBE,BGPNBE,BGPSIG,BGPNSIG,BGPCOLO,BGPNCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
  1.  Q
  1.  ;
  1. I019 ;EP - tobacco cessation
  1.  S BGPINFO=1  ;IN FORECASTER
  1.  D I91^BGP6D71
  1.  K BGPINFO
  1.  I 'BGPTU S BGPSKIP=1 G I019X  ;not a tobacco user
  1.  I BGPQ S BGPSKIP=1 G I019X  ;quit, nothing needed
  1.  I $P(BGPTC1,U,1)]"" S BGPSKIP=1 G I019X  ;had educ so don't display
  1.  S BGPTC1=$$PED^BGP6D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$S(BGPTC1="":"<Never>",1:$$DATE^BGP6UTL($P(BGPTC1,U,1))_"|Overdue as of: "_$$DATE^BGP6UTL(BGPBDATE))
  1. I019X ;
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9
  1.  K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BPGNTS,BGPN,BGPT,BGPIN1,BGPIN
  1.  K BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
  1.  K BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
  1.  Q
  1. I020 ;EP - Alcohol Screening
  1.  I 'BGPACTUP S BGPSKIP=1 Q
  1.  I BGPSEX'="F" S BGPSKIP=1 Q
  1.  I BGPAGEB<15 S BGPSKIP=1 Q
  1.  I BGPAGEB>44 S BGPSKIP=1 Q
  1.  S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
  1.  K BGPALL
  1.  D ALSCRN^BGP6D55(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,.BGPALL)
  1.  I $D(BGPALL) S BGPN1=1 S D=$O(BGPALL(0)),C=$O(BGPALL(D,0)) S BGPD=9999999-D,BGPV=$P(BGPALL(D,C),U,2)
  1.  ;S BGPN1=$$ALHF^BGP6D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  ;S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  S BGPN1=$$ALDX^BGP6D5A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  S BGPN1=$$ALPED^BGP6D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
  1.  I BGPD="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Alcohol Screen: Never|Overdue as of: "_$$DATE^BGP6UTL(BGPBD) D I020X Q
  1.  I BGPNS>BGPED S BGPSKIP=1 Q  ;not due
  1.  S BGPISSV=$$TITLE(BGPGPRAI)
  1.  I BGPV]"" S $P(BGPISSV,U,2)="Last Alcohol Screen: "_$$DATE^BGP6UTL(BGPD)
  1.  I BGPV="" S $P(BGPISSV,U,2)="Alcohol Screening not documented",$P(BGPISSV,U,3)="Alcohol Screening Overdue" D I020X Q
  1.  I BGPREF]"" S $P(BGPISSV,U,2)=$P(BGPISSV,U,2)_"|"_$S(BGPREF]"":"Patient Refused Alcohol Screening on "_$P(BGPREF,U,3),1:"")
  1.  S $P(BGPISSV,U,2)=$P(BGPISSV,U,2)_"|"_$S(BGPNS'>BGPED:"Alcohol Screening Overdue as of: ",1:"Alcohol Screening next due: ")_$$DATE^BGP6UTL(BGPNS)
  1. I020X ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. IAA ;EP
  1.  I 'BGPACTUP S BGPSKIP=1 Q
  1.  I BGPAGEB<18 S BGPSKIP=1 Q
  1.  S (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
  1.  S BGPN1=$$DEP^BGP6D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPN1 NEW X S X=$P(BGPN1,U,4) S BGPD=X,BGPV="2 Mood Disorder DXs "
  1.  S BGPN1=$$DEPSCR^BGP6D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  S BGPN1=$$DEPEDU^BGP6D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  I BGPD="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: Never|Overdue as of: "_$$DATE^BGP6UTL(BGPBD) D IAAX Q
  1.  S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
  1.  I BGPNS>BGPED S BGPSKIP=1 D IAAX Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: "_$$DATE^BGP6UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP6UTL(BGPNS)
  1.  ;
  1. IAAX ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. I014 ;EP
  1.  I BGPAGEB<2 S BGPSKIP=1 Q
  1.  I BGPAGEB>15 S BGPSKIP=1 Q
  1.  S BGPLDS=$$SEAL(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;I 'BGPLDS S BGPSKIP=1 Q  ;never had a sealant
  1.  S D=$P($$DENTSRV^BGP6D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1),U,2)
  1.  ;S D=$P($$DENTSRV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE),U,1)
  1.  S BGPS=""
  1.  I D]"",$$FMDIFF^XLFDT(BGPEDATE,D)<180 S BGPSKIP=1 Q  ;dental exam less than 6 months ago
  1.  I D]"",$$FMDIFF^XLFDT(BGPEDATE,D)>180 S BGPS="May be overdue:  Patient is overdue for dental|exam and assessment for additional sealants.|Refer to Dental Program."
  1.  I D="" S BGPS="May be overdue:  Patient is overdue for dental|exam and assessment for additional sealants.|Refer to Dental Program."
  1.  I 'BGPLDS S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: Never"_"|"_BGPS Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP6UTL(BGPLDS)_"|"_BGPS
  1.  Q
  1. SEAL(P,BDATE,EDATE) ;
  1.  NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,LAST
  1.  K BGPG,BGPX
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"","
  1.  S BGPC=0,LAST=""
  1.  S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1.  S X=0,Y=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X  S V=$P(^TMP($J,"A",X),U,5) D
  1.  .S Y=0,G=0 F  S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y  D
  1.  ..S A=$P($G(^AUPNVDEN(Y,0)),U) I A S A=$P($G(^AUTTADA(A,0)),U) D
  1.  ...I A'=1351,A'=1352,A'=1353 Q
  1.  ...S G=1
  1.  ...S T=$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1
  1.  ...S S=$P(^AUPNVDEN(Y,0),U,5)
  1.  ...I S]"" S BGPX(S)=$G(BGPX(S))+T
  1.  ...I S="" S BGPX("NO OS")=$G(BGPX("NO OS"))+T
  1.  ...S LAST=$P(^TMP($J,"A",X),U,1)
  1.  ...Q
  1.  .Q:G  ;had ADA codes so skip cpts
  1.  .S Y=0,G=0 F  S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y  D
  1.  ..S A=$P($G(^AUPNVCPT(Y,0)),U)
  1.  ..Q:'A
  1.  ..S A=$P($$CPT^ICPTCOD(A),U,2) I A="D1351"!(A="D1352")!(A="D1353") D
  1.  ...S T=$P($G(^AUPNVCPT(Y,0)),U,16) S:T=""!(T=0) T=1
  1.  ...S BGPX("CPT")=$G(BGPX("CPT"))+T
  1.  ...S LAST=$P(^TMP($J,"A",X),U,1)
  1.  S X="" F  S X=$O(BGPX(X)) Q:X=""  I X'="CPT" S BGPC=BGPC+$S(BGPX(X)>2:2,1:BGPX(X))
  1.  S BGPC=BGPC+$G(BGPX("CPT"))
  1.  Q LAST
  1. DENTSRV(P,BDATE,EDATE) ;EP
  1.  K BGPG
  1.  S BGPC="",%=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$P(BGPG(1),U,2)
  1.  K BGPG
  1.  S %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$P(BGPG(1),U,2)
  1.  K BGPG S %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_$P(BGPG(1),U,3)
  1.  K BGPG
  1.  S BGPG=$$LASTDX^BGP6UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
  1.  I BGPG,$P(BGPG,U,3)>$P(BGPC,U,1) S BGPC=$P(BGPG,U,3)_"^"_$P(BGPG,U,2)
  1.  K BGPG S G="" S %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG) D  I G]"" Q G
  1.  .S X=0 F  S X=$O(BGPG(X)) Q:X'=+X!(G]"")  S V=$P(BGPG(X),U,5) D
  1.  ..I $P($G(^AUPNVSIT(V,0)),U,3)="C",$$VD^APCLV(V)>$P(BGPC,U,1) S BGPC=$P(BGPG(X),U)_"^CHS VISIT ADA "_$P(BGPG(X),U,2)
  1.  Q BGPC
  1.  ;
  1. I016 ;EP
  1.  I BGPAGEB<1 S BGPSKIP=1 Q
  1.  I BGPAGEB>15 S BGPSKIP=1 Q
  1.  S BGPLDS=$$TF(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;I 'BGPLDS S BGPSKIP=1 Q  ;never had a TF
  1.  S BGPS=""
  1.  I BGPLDS]"",BGPLDS'<BGPBDATE S BGPSKIP=1 Q  ;fluoride during report period
  1.  I BGPLDS]"",BGPLDS<BGPBDATE S BGPS="May be overdue:  Apply topical fluoride or refer|to Dental Program for assessment."
  1.  I BGPLDS="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: Never|May be overdue:  Apply topical fluoride or refer|to Dental Program for assessment." Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP6UTL(BGPLDS)_"|"_BGPS
  1.  Q
  1. TF(P,BDATE,EDATE) ;
  1.  NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R,BJPC
  1.  K BGPG,BGPZ S BGPC=""
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"","
  1.  S Z=$O(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",0))
  1.  S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
  1.  ;reorder by visit date
  1.  S X=0,Y=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X  S V=$P(^TMP($J,"A",X),U,5) D
  1.  .S Y=0,G=0 F  S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y  D
  1.  ..S A=$P($G(^AUPNVDEN(Y,0)),U) D
  1.  ...I $D(^ATXAX(Z,21,"B",A)) S T=$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1 I $$VD^APCLV(V)>BGPC S BGPC=$$VD^APCLV(V)
  1.  ...Q
  1.  .Q:G
  1.  .S Y=0,G=0 F  S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y  D
  1.  ..S A=$P($G(^AUPNVCPT(Y,0)),U)
  1.  ..Q:'A
  1.  ..I $$ICD^BGP6UTL2(A,$O(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1) S T=$P($G(^AUPNVCPT(Y,0)),U,16) S:T=""!(T=0) T=1 I $$VD^APCLV(V)>BGPC S BGPC=$$VD^APCLV(V)
  1.  .Q:G  ;one per visit
  1.  .S Y=0,G=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y  D
  1.  ..S A=$P($G(^AUPNVPOV(Y,0)),U) I A S A=$P($$ICDDX^BGP6UTL2(A),U,2) D
  1.  ...I A="V07.31" I $$VD^APCLV(V)>BGPC S BGPC=$$VD^APCLV(V)
  1.  ...Q
  1.  Q BGPC
  1. I021 ;EP
  1.  I 'BGPACTUP S BGPSKIP=1 Q
  1.  I BGPSEX'="F" S BGPSKIP=1 Q
  1.  I BGPAGEB<13 S BGPSKIP=1 Q
  1.  I BGPAGEB>46 S BGPSKIP=1 Q
  1.  S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPVA)=""
  1.  S BGPN1=$$DVEX^BGP6D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
  1.  S BGPN1=$$DVDX^BGP6D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPD<$P(BGPN1,U,2) S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
  1.  S BGPN1=$$DVPED^BGP6D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPD<$P(BGPN1,U,2) S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
  1.  S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
  1.  I BGPNS="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: Never|Overdue as of: "_$$DATE^BGP6UTL(BGPBD) D I021X Q
  1.  I BGPNS>BGPED S BGPSKIP=1 D I021X Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP6UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP6UTL(BGPNS)
  1. I021X ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. IE2 ;EP
  1.  K BGPSTOP
  1.  S BGPISSO=1
  1.  D IE2^BGP6D8
  1.  I $D(BGPSTOP) S BGPSKIP=1 Q
  1.  S BGPISSV=""
  1.  I BGPN16 S BGPSKIP=1 Q
  1.  I 'BGPD2 S BGPSKIP=1 Q  ;13-64 WITH NO HIV
  1.  S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
  1.  I 'BGPN1 S $P(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP6UTL(BGPBD)
  1.  K BGPHIV,BGPN1,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPEDUC,BGPHIV
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9
  1.  Q
  1. I0302A ;EP
  1.  K BGPSTOP
  1.  I BGPAGEB<22 S BGPSKIP=1 Q
  1.  K ^TMP($J)
  1.  S BGPCHD=$$CHD^BGP6D729(DFN,BGPBDATE,BGPEDATE)
  1.  I 'BGPCHD S BGPSKIP=1 K BGPCHD Q
  1.  D I0302ASC^BGP6D41
  1.  S BGPISSV=""
  1.  I BGPN14 S BGPSKIP=1 D I0302AX Q  ;met measure 
  1.  S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
  1.  S X="",BGPVAL="",BGPVAL2=""
  1.  I BGPN8 S BGPN4=0
  1. BP ;
  1.  I 'BGPN16 S BGPVAL=BGPVAL_"2 BPs"
  1. TOB ;
  1.  I 'BGPN3 S BGPVAL=BGPVAL_$S(BGPVAL]"":", ",1:"")_"Tobacco Screen"
  1. BMI ;
  1.  I 'BGPN10 S BGPVAL2=BGPVAL2_$S(BGPVAL2]"":", ",1:"")_"BMI"
  1. LIFE ;
  1.  I 'BGPN15 S BGPVAL2=BGPVAL2_$S(BGPVAL2]"":", ",1:"")_"Lifestyle Counseling"
  1.  S BGPISSV=BGPISSV_U_"Screenings Overdue: "_BGPVAL_"|"_BGPVAL2
  1. I0302AX ;EP
  1.  K BGPBP,BGPLDL,BGPTOB,BGPBMI,BGPLIFE,BGPDEP,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPEDUC,BGPHIV
  1.  K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPCHD
  1.  Q
  1. I031A ;EP
  1.  S BGPSKIP=""
  1.  K BGPSTOP
  1.  I BGPAGEB<2 S BGPSKIP=1 Q
  1.  I BGPAGEB>5 S BGPSKIP=1 Q
  1.  I BGPAGEE>5 S BGPSKIP=1 Q
  1.  ;I 'BGPACTCL S BGPSKIP=1 Q
  1.  S BGPD1=1,BGPN1=0,BGPN2=0,BGPIN1=0
  1.  S BGPBMI=$$BMIOR^BGP6D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
  1.  I $P(BGPBMI,U)="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP6UTL(BGPBD) D I031AX Q
  1.  I $$FMADD^XLFDT($P(BGPBMI,U,2),365)<BGPED S BGPIN1=1
  1.  S BGPOW=$$OW^BGP6D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
  1.  S BGPOB=$$OB^BGP6D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOB S BGPN2=1
  1.  S A=$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))
  1.  I 'BGPIN1,'BGPOB S BGPSKIP=1 D I031AX Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: "_$P(BGPBMI,U)_":"_$$DATE^BGP6UTL($P(BGPBMI,U,2))_" Age at BMI: "_A_$S(BGPOW:" At Risk 85-94%",BGPOB:" OW 95%",1:"")
  1.  I BGPIN1 S BGPISSV=BGPISSV_"|Overdue as of: "_$$DATE^BGP6UTL($$FMADD^XLFDT($P(BGPBMI,U,2),365))
  1. I031AX ; 
  1.  K BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
  1.  Q
  1. TITLE(I) ;EP
  1.  Q $P($G(^BGPINDMC(I,12)),U,9)
  1. BFR ;EP
  1.  S BGPSKIP=""
  1.  K BGPSTOP,BGPBFR
  1.  S BGPADAY=$$FMDIFF^XLFDT(BGPBDATE,$P(^DPT(DFN,0),U,3))  ;LORI CHANGE AFTER TESTING TO DT
  1.  I BGPADAY<45 S BGPSKIP=1 Q
  1.  I BGPADAY>394 S BGPSKIP=1 Q
  1.  D GETIFC(DFN,BGPBDATE,BGPEDATE,.BGPBFR)
  1.  I '$D(BGPBFR) S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: Never" D BFRX Q   ;|Overdue as of: "_$$DATE^BGP6UTL(DT) D BFRX Q
  1.  ;GET LASTEST (highest days old)
  1.  S X="",Y="" F  S X=$O(BGPBFR(X)) Q:X=""  S Y=X
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP6UTL($P(BGPBFR(Y),U,2))  ;_"|Overdue as of: "_$$DATE^BGP6UTL(DT)
  1.  ;
  1. BFRX ;
  1.  K BGPADAY,BGPBFR
  1.  Q
  1. GETIFC(P,BDATE,EDATE,BGPRET) ;EP
  1.  K BGPRET,BGPG,C,X
  1.  S X=0 F  S X=$O(^AUPNVIF("AC",P,X)) Q:X'=+X  D
  1.  .Q:'$D(^AUPNVIF(X))
  1.  .S V=$P(^AUPNVIF(X,0),U,3),C=$P(^AUPNVIF(X,0),U,1)
  1.  .Q:V=""
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .S V=$P($P(^AUPNVSIT(V,0),U),".")
  1.  .S BGPRET($$FMDIFF^XLFDT(V,$P(^DPT(P,0),U,3)))=C_U_V
  1.  .Q
  1.  Q
  1. MH ;EP
  1.  K BGPSTOP
  1.  NEW BGPBP,BGPN1
  1.  S BGPN1=0
  1.  I BGPAGEE<18 S BGPSKIP=1 Q
  1.  I BGPAGEE>85 S BGPSKIP=1 Q
  1.  I $$ESRD^BGP6D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSKIP=1 Q  ;esrd anytime before end date
  1.  S X=$$PREG^BGP6D7(DFN,BGPBDATE,BGPEDATE,1,1) I X S BGPSKIP=1 Q
  1.  I '$$MHHTN^BGP6D9(DFN,BGPBDATE,BGPEDATE) S BGPSKIP=1 Q  ;no htn per definition
  1.  S BGPBP=$$LASTBP^BGP6D9(DFN,BGPBDATE,BGPEDATE)
  1.  I BGPBP]"" D
  1.  .S X=BGPBP
  1.  .I $P(X,"/",1)<140,$P(X,"/",2)<90 S BGPN1=1
  1.  NEW BGPV,BGPD,BGPND
  1.  S (BGPISSV,BGPIN)=""
  1.  K BGPISSV
  1.  ;
  1.  I BGPBP="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: 2 BPs not documented "_$$DATE^BGP6UTL(BGPBD)_"-"_$$DATE^BGP6UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP6UTL(BGPBD) Q
  1.  I BGPN1 S BGPSKIP=1 Q  ;in control BP in report period, do not display
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: "_$P(BGPBP,U)
  1.  I 'BGPN1 S BGPISSV=BGPISSV_" - Not Controlled BP"
  1.  Q