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

BGP0DPA2.m

Go to the documentation of this file. 
  1. BGP0DPA2 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 09 Jan 2009 3:36 PM 26 Jun 2009 3:40 PM 03 Jun 2010 8:04 AM ; 
  1.  ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
  1.  ;
  1. I017 ;EP - colorectal cancer
  1.  ;
  1.  K BGPFOB,BGPSIG,BGPBE,BGPCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
  1.  I BGPAGEB<51 S BGPSKIP=1 Q
  1.  I BGPAGEB>80 S BGPSKIP=1 Q
  1.  I $$CRC^BGP0D61(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^BGP0D61(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^BGP0D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))  ;last SIG test
  1.  ;S D=$P(BGPSIG,U,3),BGPNSIG=$S($P(BGPSIG,U,3):$$FMADD^XLFDT(D,(5*365)),1:BGPBDATE) I BGPNSIG'>BGPED S BGPIN1=1
  1.  ;I D>BGPLAST S BGPLAST=D_U_BGPNSIG
  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^BGP0D61(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.  S BGPBE=$$BE^BGP0D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))  ;last BE test
  1.  ;S D=$P(BGPBE,U,3),BGPNBE=$S($P(BGPBE,U,3):$$FMADD^XLFDT(D,(5*365)),1:DT) I BGPNBE'>BGPED S BGPIN3=1
  1.  ;I D>BGPLAST S BGPLAST=D_U_BGPNBE
  1.  S D=$P(BGPBE,U,3)
  1.  I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN3=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 BGPREF=$$REF^BGP0D61(DFN,BGPBDATE,BGPEDATE) I BGPREF S BGPSKIP=1 Q  ;refusal in past year
  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 FOBT: "_$$DATE^BGP0UTL($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^BGP0UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP0UTL(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 (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ
  1.  S (BGPIN,BGPIN1)=0
  1.  I 'BGPACTUP S BGPSKIP=1  ;must be at least user pop
  1.  S BGPTOBP=$$TOBACCO^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  S BGPTOBD=$P(BGPTOBP,U,3)
  1.  S BGPSDX=$$DX^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  I BGPTOBD<$P(BGPSDX,U,2) S BGPTOBD=$P(BGPSDX,U,2)
  1.  S BGPSCPT=$$CPTSM^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  I BGPTOBD<$P(BGPSCPT,U,2) S BGPTOBD=$P(BGPSDX,U,2)
  1.  S X=0
  1.  I BGPSDX]"",$P(BGPSDX,U,1)="305.13" S X=1
  1.  I BGPSDX]"",$P(BGPSDX,U,1)="V15.82" S X=1
  1.  I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&('X))!(BGPTOBP["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)=99406)!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)="G0376") S BGPD2=1
  1.  I 'BGPD2 S BGPSKIP=1 Q  ;S BGPISSV=$$TITLE(BGPGPRAI)_U_BGPN_U_BGPT D I019X Q  ;not a smoker
  1.  S BGPN="",BGPT=""
  1.  S BGPFOB=$$PED^BGP0D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
  1.  I BGPFOB="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: Never|Overdue as of: "_$$DATE^BGP0UTL(BGPBD) D I019X Q
  1.  S D=$P(BGPFOB,U,1),BGPNFOB=$S($P(BGPFOB,U,1):$$FMADD^XLFDT(D,365),1:DT) I BGPNFOB'>BGPED S BGPIN1=1
  1.  I 'BGPIN1 S BGPSKIP=1 Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$$DATE^BGP0UTL($P(BGPFOB,U,1))_"|Overdue as of: "_$$DATE^BGP0UTL(BGPNFOB)
  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.  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.  S BGPN1=$$ALHF^BGP0D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
  1.  S BGPN1=$$ALDX^BGP0D5A(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^BGP0D5(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^BGP0UTL(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^BGP0UTL(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^BGP0UTL(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^BGP0D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  I BGPN1 NEW X S X=$P(BGPN1,U,4),%DT="" D ^%DT S BGPD=Y,BGPV="2 Mood Disorder DXs "
  1.  S BGPN1=$$DEPSCR^BGP0D25(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^BGP0D25(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^BGP0UTL(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^BGP0UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP0UTL(BGPNS)
  1.  ;
  1. IAAX ;
  1.  K BGPD,BGPN,BGPN1,BGPREF,BGPNS
  1.  Q
  1. I014 ;EP
  1.  I BGPAGEB<5 S BGPSKIP=1 Q
  1.  I BGPAGEB>17 S BGPSKIP=1 Q
  1.  S BGPLDS=$$SEAL(DFN,$$DOB^AUPNPAT(DFN),DT) I 'BGPLDS S BGPSKIP=1 Q  ;never had a sealant
  1.  S D=$P($$DENTSRV(DFN,$$DOB^AUPNPAT(DFN),DT),U,1)
  1.  S BGPS=""
  1.  I D]"",$$FMDIFF^XLFDT(DT,D)<180 S BGPSKIP=1 Q  ;dental exam less than 6 months ago
  1.  I D]"",$$FMDIFF^XLFDT(DT,D)>180 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" Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP0UTL(BGPLDS)_"|"_BGPS
  1.  Q
  1. SEAL(P,BDATE,EDATE) ;
  1.  NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V
  1.  K BGPG,BGPX
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"","
  1.  S BGPC=0
  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.  ...Q:A'=1351
  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.  ...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" 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 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 BGPC
  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=$$LASTDXI^BGP0UTL1(P,"V72.2",BDATE,EDATE)
  1.  I BGPG,$P(BGPG,U,3)>$P(BGPC,U,1) S BGPC=$P(BGPG,U,3)_"^V72.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<3 S BGPSKIP=1 Q
  1.  I BGPAGEB>18 S BGPSKIP=1 Q
  1.  S BGPLDS=$$TF(DFN,$$DOB^AUPNPAT(DFN),DT) 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" Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP0UTL(BGPLDS)_"|"_BGPS
  1.  Q
  1. TF(P,BDATE,EDATE) ;
  1.  NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R
  1.  K BGPG,BGPZ S BGPC=0
  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.  S X=0,Y=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPC>3)  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!(G>0)!(BGPC>3)  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 S BGPC=BGPC+T,G=G+1
  1.  ...Q
  1.  .Q:G
  1.  .S Y=0,G=0 F  S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3)  D
  1.  ..S A=$P($G(^AUPNVCPT(Y,0)),U)
  1.  ..Q:'A
  1.  ..I $$ICD^ATXCHK(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 S BGPC=BGPC+T,G=G+1
  1.  .Q:G  ;one per visit
  1.  .S Y=0,G=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3)  D
  1.  ..S A=$P($G(^AUPNVPOV(Y,0)),U) I A S A=$P($$ICDDX^ICDCODE(A),U,2) D
  1.  ...I A="V07.31" S BGPC=BGPC+1,G=1
  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<15 S BGPSKIP=1 Q
  1.  I BGPAGEB>40 S BGPSKIP=1 Q
  1.  S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPVA)=""
  1.  S BGPN1=$$DVEX^BGP0D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
  1.  S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
  1.  S BGPN1=$$DVDX^BGP0D5(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^BGP0D5(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^BGP0UTL(BGPBD) D I021X Q
  1.  I BGPNS>BGPED S BGPSKIP=1 D I021X Q
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP0UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP0UTL(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^BGP0D8
  1.  I $D(BGPSTOP) S BGPSKIP=1 Q
  1.  S BGPISSV=""
  1.  I BGPN4 S BGPSKIP=1 Q
  1.  I 'BGPD1 S BGPSKIP=1 Q  ;only ac pregnant
  1.  S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
  1.  I 'BGPN4 S $P(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP0UTL(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.  I '$$FIRSTIHD^BGP0D721(DFN,BGPEDATE) S BGPSKIP=1 Q  ;first dx not prior to report period
  1.  I '$$V2IHD^BGP0D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSKIP=1 Q  ;at least 2 IHD dxs ever
  1.  D I0302ASC^BGP0D41
  1.  S BGPISSV=""
  1.  I BGPN9 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 'BGPN1 S BGPVAL=BGPVAL_"2 BPs"
  1. LDL ;
  1.  I 'BGPN2 S BGPVAL=BGPVAL_$S(BGPVAL]"":", ",1:"")_"LDL"
  1. TOB ;
  1.  I 'BGPN3 S BGPVAL=BGPVAL_$S(BGPVAL]"":", ",1:"")_"Tobacco Screen"
  1. BMI ;
  1.  I 'BGPN4 S BGPVAL2=BGPVAL2_$S(BGPVAL2]"":", ",1:"")_"BMI"
  1. LIFE ;
  1.  I 'BGPN5 S BGPVAL2=BGPVAL2_$S(BGPVAL2]"":", ",1:"")_"Lifestyle Counseling"
  1.  S BGPISSV=BGPISSV_U_"Sreenings 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
  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^BGP0D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
  1.  I $P(BGPBMI,U)="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP0UTL(BGPBD) D I031AX Q
  1.  I $$FMADD^XLFDT($P(BGPBMI,U,2),365)<BGPED S BGPIN1=1
  1.  S BGPOW=$$OW^BGP0D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
  1.  S BGPOB=$$OB^BGP0D6(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^BGP0UTL($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^BGP0UTL($$FMADD^XLFDT($P(BGPBMI,U,2),365))
  1. I031AX ; 
  1.  K BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
  1.  Q
  1. TITLE(I) ;
  1.  Q $P($G(^BGPINDTC(I,12)),U,9)
  1. BFR ;EP
  1.  S BGPSKIP=""
  1.  K BGPSTOP,BGPBFR
  1.  S BGPADAY=$$FMDIFF^XLFDT(DT,$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^BGP0UTL(DT) D BFRX Q
  1.  ;GET LASTEST (highest days old)
  1.  S X=0,Y="" F  S X=$O(BGPBFR(X)) Q:X'=+X  S Y=X
  1.  S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP0UTL($P(BGPBFR(Y),U,2))  ;_"|Overdue as of: "_$$DATE^BGP0UTL(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