BGP3DPA2 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 03 Jun 2013 8:04 AM ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;
I017 ;EP - colorectal cancer
;
K BGPFOB,BGPSIG,BGPBE,BGPCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
I BGPAGEB<51 S BGPSKIP=1 Q
I BGPAGEB>80 S BGPSKIP=1 Q
I $$CRC^BGP3D62(DFN,BGPEDATE) S BGPSKIP=1 Q
I 'BGPACTUP S BGPSKIP=1 Q
S (BGPIN,BGPIN1,BGPIN2,BGPIN3)=""
S BGPLAST=""
S BGPFOB=$$FOB^BGP3D62(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;last FOB test
S D=$P(BGPFOB,U,2)
I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN=1
I D>BGPLAST S BGPLAST=D
S BGPSIG=$$SIG^BGP3D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN)) ;last SIG test
;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
;I D>BGPLAST S BGPLAST=D_U_BGPNSIG
S D=$P(BGPSIG,U,3)
I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN1=1
I D>BGPLAST S BGPLAST=D
S BGPCOLO=$$COLO^BGP3D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN)) ;last COLO test
;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
;I D>BGPLAST S BGPLAST=D_U_BGPNCOLO
S D=$P(BGPCOLO,U,3)
I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN2=1
I D>BGPLAST S BGPLAST=D
;S BGPBE=$$BE^BGP3D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN)) ;last BE test
;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
;I D>BGPLAST S BGPLAST=D_U_BGPNBE
;S D=$P(BGPBE,U,3)
;I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN3=1
;I D>BGPLAST S BGPLAST=D
I BGPLAST]"",(BGPIN!(BGPIN1)!(BGPIN2)!(BGPIN3)) S BGPSKIP=1 Q ;met at least one of above
S BGPN1=0
S BGPISSV=$$TITLE(BGPGPRAI)
S BGPX=""
I BGPCOLO]"" S BGPX="Last Colonoscopy: "_$P(BGPCOLO,U,2)
I BGPSIG]"" S BGPX=BGPX_$S(BGPX]"":"|",1:"") S BGPX=BGPX_"Last Flex Sig: "_$P(BGPSIG,U,2)
;
I BGPFOB]"" S BGPX=BGPX_$S(BGPX]"":"|",1:"") S BGPX=BGPX_"Last FOB: "_$$DATE^BGP3UTL($P(BGPFOB,U,2))
;I BGPBE]"" S BGPX=BGPX_$S(BGPX]"":"|",1:"")_"Last DCBE: "_$P(BGPBE,U,2)
I BGPX="" S BGPX="No Colonoscopy, Flex Sig, FOBT or DCBE documented."
S BGPX=BGPX_"|May be overdue as of: "_$S(BGPLAST]"":$$DATE^BGP3UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP3UTL(BGPBD))
S BGPISSV=BGPISSV_U_BGPX
K BGPREF,BGPOTH,BGPN1,BGPFOB,BGPNFOB,BGPBE,BGPF,BGPBE,BGPNBE,BGPSIG,BGPNSIG,BGPCOLO,BGPNCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
Q
;
I019 ;EP - tobacco cessation
S BGPINFO=1 ;IN FORECASTER
D I91^BGP3D71
K BGPINFO
I 'BGPTU S BGPSKIP=1 G I019X ;not a tobacco user
I BGPQ S BGPSKIP=1 G I019X ;quit, nothing needed
I $P(BGPTC1,U,1)]"" S BGPSKIP=1 G I019X ;had educ so don't display
S BGPTC1=$$PED^BGP3D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$S(BGPTC1="":"<Never>",1:$$DATE^BGP3UTL($P(BGPTC1,U,1))_"|Overdue as of: "_$$DATE^BGP3UTL(BGPBDATE))
I019X ;
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9
K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BPGNTS,BGPN,BGPT,BGPIN1,BGPIN
K BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
K BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
Q
I020 ;EP - Alcohol Screening
I 'BGPACTUP S BGPSKIP=1 Q
I BGPSEX'="F" S BGPSKIP=1 Q
I BGPAGEB<15 S BGPSKIP=1 Q
I BGPAGEB>44 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
S BGPN1=$$ALHF^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPN1=$$ALDX^BGP3D5A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPN1=$$ALPED^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
I BGPD="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Alcohol Screen: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD) D I020X Q
I BGPNS>BGPED S BGPSKIP=1 Q ;not due
S BGPISSV=$$TITLE(BGPGPRAI)
I BGPV]"" S $P(BGPISSV,U,2)="Last Alcohol Screen: "_$$DATE^BGP3UTL(BGPD)
I BGPV="" S $P(BGPISSV,U,2)="Alcohol Screening not documented",$P(BGPISSV,U,3)="Alcohol Screening Overdue" D I020X Q
I BGPREF]"" S $P(BGPISSV,U,2)=$P(BGPISSV,U,2)_"|"_$S(BGPREF]"":"Patient Refused Alcohol Screening on "_$P(BGPREF,U,3),1:"")
S $P(BGPISSV,U,2)=$P(BGPISSV,U,2)_"|"_$S(BGPNS'>BGPED:"Alcohol Screening Overdue as of: ",1:"Alcohol Screening next due: ")_$$DATE^BGP3UTL(BGPNS)
I020X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
IAA ;EP
I 'BGPACTUP S BGPSKIP=1 Q
I BGPAGEB<18 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
S BGPN1=$$DEP^BGP3D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1 NEW X S X=$P(BGPN1,U,4),%DT="" D ^%DT S BGPD=Y,BGPV="2 Mood Disorder DXs "
S BGPN1=$$DEPSCR^BGP3D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPN1=$$DEPEDU^BGP3D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
I BGPD="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD) D IAAX Q
S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
I BGPNS>BGPED S BGPSKIP=1 D IAAX Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: "_$$DATE^BGP3UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP3UTL(BGPNS)
;
IAAX ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
I014 ;EP
I BGPAGEB<5 S BGPSKIP=1 Q
I BGPAGEB>17 S BGPSKIP=1 Q
S BGPLDS=$$SEAL(DFN,$$DOB^AUPNPAT(DFN),DT) I 'BGPLDS S BGPSKIP=1 Q ;never had a sealant
S D=$P($$DENTSRV(DFN,$$DOB^AUPNPAT(DFN),DT),U,1)
S BGPS=""
I D]"",$$FMDIFF^XLFDT(DT,D)<180 S BGPSKIP=1 Q ;dental exam less than 6 months ago
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."
I BGPLDS="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: Never" Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP3UTL(BGPLDS)_"|"_BGPS
Q
SEAL(P,BDATE,EDATE) ;
NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V
K BGPG,BGPX
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S BGPC=0
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
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
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVDEN(Y,0)),U) I A S A=$P($G(^AUTTADA(A,0)),U) D
...I A'=1351,A'=1352
...S G=1
...S T=$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1
...S S=$P(^AUPNVDEN(Y,0),U,5)
...I S]"" S BGPX(S)=$G(BGPX(S))+T
...I S="" S BGPX("NO OS")=$G(BGPX("NO OS"))+T
...Q
.Q:G ;had ADA codes so skip cpts
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..S A=$P($$CPT^ICPTCOD(A),U,2) I A="D1351"!(A="D1352") D
...S T=$P($G(^AUPNVCPT(Y,0)),U,16) S:T=""!(T=0) T=1
...S BGPX("CPT")=$G(BGPX("CPT"))+T
S X="" F S X=$O(BGPX(X)) Q:X="" I X'="CPT" S BGPC=BGPC+$S(BGPX(X)>2:2,1:BGPX(X))
S BGPC=BGPC+$G(BGPX("CPT"))
Q BGPC
DENTSRV(P,BDATE,EDATE) ;EP
K BGPG
S BGPC="",%=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$P(BGPG(1),U,2)
K BGPG
S %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_"ADA "_$P(BGPG(1),U,2)
K BGPG S %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)),$P(BGPG(1),U)>$P(BGPC,U) S BGPC=$P(BGPG(1),U)_"^"_$P(BGPG(1),U,3)
K BGPG
S BGPG=$$LASTDX^BGP3UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
I BGPG,$P(BGPG,U,3)>$P(BGPC,U,1) S BGPC=$P(BGPG,U,3)_"^"_$P(BGPG,U,2)
K BGPG S G="" S %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG) D I G]"" Q G
.S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G]"") S V=$P(BGPG(X),U,5) D
..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)
Q BGPC
;
I016 ;EP
I BGPAGEB<3 S BGPSKIP=1 Q
I BGPAGEB>18 S BGPSKIP=1 Q
S BGPLDS=$$TF(DFN,$$DOB^AUPNPAT(DFN),DT) I 'BGPLDS S BGPSKIP=1 Q ;never had a TF
S BGPS=""
I BGPLDS]"",BGPLDS'<BGPBDATE S BGPSKIP=1 Q ;fluoride during report period
I BGPLDS]"",BGPLDS<BGPBDATE S BGPS="May be overdue: Apply topical fluoride or refer|to Dental Program for assessment."
I BGPLDS="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: Never" Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP3UTL(BGPLDS)_"|"_BGPS
Q
TF(P,BDATE,EDATE) ;
NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R,BJPC
K BGPG,BGPZ S BGPC=""
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S Z=$O(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",0))
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
;reorder by visit date
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
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVDEN(Y,0)),U) D
...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)
...Q
.Q:G
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..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 I $$VD^APCLV(V)>BGPC S BGPC=$$VD^APCLV(V)
.Q:G ;one per visit
.S Y=0,G=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVPOV(Y,0)),U) I A S A=$P($$ICDDX^ICDCODE(A),U,2) D
...I A="V07.31" I $$VD^APCLV(V)>BGPC S BGPC=$$VD^APCLV(V)
...Q
Q BGPC
I021 ;EP
I 'BGPACTUP S BGPSKIP=1 Q
I BGPSEX'="F" S BGPSKIP=1 Q
I BGPAGEB<15 S BGPSKIP=1 Q
I BGPAGEB>40 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPVA)=""
S BGPN1=$$DVEX^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
S BGPN1=$$DVDX^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPD<$P(BGPN1,U,2) S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
S BGPN1=$$DVPED^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPD<$P(BGPN1,U,2) S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
I BGPNS="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD) D I021X Q
I BGPNS>BGPED S BGPSKIP=1 D I021X Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP3UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP3UTL(BGPNS)
I021X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
IE2 ;EP
K BGPSTOP
S BGPISSO=1
D IE2^BGP3D8
I $D(BGPSTOP) S BGPSKIP=1 Q
S BGPISSV=""
I BGPN1 S BGPSKIP=1 Q
I 'BGPD1 S BGPSKIP=1 Q ;only ac pregnant
S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
I 'BGPN1 S $P(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP3UTL(BGPBD)
K BGPHIV,BGPN1,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPEDUC,BGPHIV
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9
Q
I0302A ;EP
K BGPSTOP
I BGPAGEB<22 S BGPSKIP=1 Q
K ^TMP($J)
;I '$$FIRSTIHD^BGP3D721(DFN,BGPEDATE) S BGPSKIP=1 Q ;first dx not prior to report period
;I '$$V2IHD^BGP3D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSKIP=1 Q ;at least 2 IHD dxs ever
S BGPCHD=$$CHD^BGP3D729(DFN,BGPBDATE,BGPEDATE)
I 'BGPCHD S BGPSKIP=1 K BGPCHD Q
D I0302ASC^BGP3D41
S BGPISSV=""
I BGPN9 S BGPSKIP=1 D I0302AX Q ;met measure
S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
S X="",BGPVAL="",BGPVAL2=""
I BGPN8 S BGPN4=0
BP ;
I 'BGPN1 S BGPVAL=BGPVAL_"2 BPs"
LDL ;
I 'BGPN2 S BGPVAL=BGPVAL_$S(BGPVAL]"":", ",1:"")_"LDL"
TOB ;
I 'BGPN3 S BGPVAL=BGPVAL_$S(BGPVAL]"":", ",1:"")_"Tobacco Screen"
BMI ;
I 'BGPN4 S BGPVAL2=BGPVAL2_$S(BGPVAL2]"":", ",1:"")_"BMI"
LIFE ;
I 'BGPN5 S BGPVAL2=BGPVAL2_$S(BGPVAL2]"":", ",1:"")_"Lifestyle Counseling"
S BGPISSV=BGPISSV_U_"Screenings Overdue: "_BGPVAL_"|"_BGPVAL2
I0302AX ;EP
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
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPCHD
Q
I031A ;EP
S BGPSKIP=""
K BGPSTOP
I BGPAGEB<2 S BGPSKIP=1 Q
I BGPAGEB>5 S BGPSKIP=1 Q
I BGPAGEE>5 S BGPSKIP=1 Q
;I 'BGPACTCL S BGPSKIP=1 Q
S BGPD1=1,BGPN1=0,BGPN2=0,BGPIN1=0
S BGPBMI=$$BMIOR^BGP3D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
I $P(BGPBMI,U)="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD) D I031AX Q
I $$FMADD^XLFDT($P(BGPBMI,U,2),365)<BGPED S BGPIN1=1
S BGPOW=$$OW^BGP3D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
S BGPOB=$$OB^BGP3D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOB S BGPN2=1
S A=$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))
I 'BGPIN1,'BGPOB S BGPSKIP=1 D I031AX Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: "_$P(BGPBMI,U)_":"_$$DATE^BGP3UTL($P(BGPBMI,U,2))_" Age at BMI: "_A_$S(BGPOW:" At Risk 85-94%",BGPOB:" OW 95%",1:"")
I BGPIN1 S BGPISSV=BGPISSV_"|Overdue as of: "_$$DATE^BGP3UTL($$FMADD^XLFDT($P(BGPBMI,U,2),365))
I031AX ;
K BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
Q
TITLE(I) ;
Q $P($G(^BGPINDHC(I,12)),U,9)
BFR ;EP
S BGPSKIP=""
K BGPSTOP,BGPBFR
S BGPADAY=$$FMDIFF^XLFDT(BGPBDATE,$P(^DPT(DFN,0),U,3)) ;LORI CHANGE AFTER TESTING TO DT
I BGPADAY<45 S BGPSKIP=1 Q
I BGPADAY>394 S BGPSKIP=1 Q
D GETIFC(DFN,BGPBDATE,BGPEDATE,.BGPBFR)
I '$D(BGPBFR) S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: Never" D BFRX Q ;|Overdue as of: "_$$DATE^BGP3UTL(DT) D BFRX Q
;GET LASTEST (highest days old)
S X="",Y="" F S X=$O(BGPBFR(X)) Q:X="" S Y=X
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP3UTL($P(BGPBFR(Y),U,2)) ;_"|Overdue as of: "_$$DATE^BGP3UTL(DT)
;
BFRX ;
K BGPADAY,BGPBFR
Q
GETIFC(P,BDATE,EDATE,BGPRET) ;EP
K BGPRET,BGPG,C,X
S X=0 F S X=$O(^AUPNVIF("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIF(X))
.S V=$P(^AUPNVIF(X,0),U,3),C=$P(^AUPNVIF(X,0),U,1)
.Q:V=""
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.S BGPRET($$FMDIFF^XLFDT(V,$P(^DPT(P,0),U,3)))=C_U_V
.Q
Q
BGP3DPA2 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 03 Jun 2013 8:04 AM ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+2 ;
I017 ;EP - colorectal cancer
+1 ;
+2 KILL BGPFOB,BGPSIG,BGPBE,BGPCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
+3 IF BGPAGEB<51
SET BGPSKIP=1
QUIT
+4 IF BGPAGEB>80
SET BGPSKIP=1
QUIT
+5 IF $$CRC^BGP3D62(DFN,BGPEDATE)
SET BGPSKIP=1
QUIT
+6 IF 'BGPACTUP
SET BGPSKIP=1
QUIT
+7 SET (BGPIN,BGPIN1,BGPIN2,BGPIN3)=""
+8 SET BGPLAST=""
+9 ;last FOB test
SET BGPFOB=$$FOB^BGP3D62(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+10 SET D=$PIECE(BGPFOB,U,2)
+11 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN=1
+12 IF D>BGPLAST
SET BGPLAST=D
+13 ;last SIG test
SET BGPSIG=$$SIG^BGP3D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+14 ;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
+15 ;I D>BGPLAST S BGPLAST=D_U_BGPNSIG
+16 SET D=$PIECE(BGPSIG,U,3)
+17 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN1=1
+18 IF D>BGPLAST
SET BGPLAST=D
+19 ;last COLO test
SET BGPCOLO=$$COLO^BGP3D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+20 ;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
+21 ;I D>BGPLAST S BGPLAST=D_U_BGPNCOLO
+22 SET D=$PIECE(BGPCOLO,U,3)
+23 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN2=1
+24 IF D>BGPLAST
SET BGPLAST=D
+25 ;S BGPBE=$$BE^BGP3D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN)) ;last BE test
+26 ;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
+27 ;I D>BGPLAST S BGPLAST=D_U_BGPNBE
+28 ;S D=$P(BGPBE,U,3)
+29 ;I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN3=1
+30 ;I D>BGPLAST S BGPLAST=D
+31 ;met at least one of above
IF BGPLAST]""
IF (BGPIN!(BGPIN1)!(BGPIN2)!(BGPIN3))
SET BGPSKIP=1
QUIT
+32 SET BGPN1=0
+33 SET BGPISSV=$$TITLE(BGPGPRAI)
+34 SET BGPX=""
+35 IF BGPCOLO]""
SET BGPX="Last Colonoscopy: "_$PIECE(BGPCOLO,U,2)
+36 IF BGPSIG]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last Flex Sig: "_$PIECE(BGPSIG,U,2)
+37 ;
+38 IF BGPFOB]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last FOB: "_$$DATE^BGP3UTL($PIECE(BGPFOB,U,2))
+39 ;I BGPBE]"" S BGPX=BGPX_$S(BGPX]"":"|",1:"")_"Last DCBE: "_$P(BGPBE,U,2)
+40 IF BGPX=""
SET BGPX="No Colonoscopy, Flex Sig, FOBT or DCBE documented."
+41 SET BGPX=BGPX_"|May be overdue as of: "_$SELECT(BGPLAST]"":$$DATE^BGP3UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP3UTL(BGPBD))
+42 SET BGPISSV=BGPISSV_U_BGPX
+43 KILL BGPREF,BGPOTH,BGPN1,BGPFOB,BGPNFOB,BGPBE,BGPF,BGPBE,BGPNBE,BGPSIG,BGPNSIG,BGPCOLO,BGPNCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
+44 QUIT
+45 ;
I019 ;EP - tobacco cessation
+1 ;IN FORECASTER
SET BGPINFO=1
+2 DO I91^BGP3D71
+3 KILL BGPINFO
+4 ;not a tobacco user
IF 'BGPTU
SET BGPSKIP=1
GOTO I019X
+5 ;quit, nothing needed
IF BGPQ
SET BGPSKIP=1
GOTO I019X
+6 ;had educ so don't display
IF $PIECE(BGPTC1,U,1)]""
SET BGPSKIP=1
GOTO I019X
+7 SET BGPTC1=$$PED^BGP3D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
+8 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$SELECT(BGPTC1="":"<Never>",1:$$DATE^BGP3UTL($PIECE(BGPTC1,U,1))_"|Overdue as of: "_$$DATE^BGP3UTL(BGPBDATE))
I019X ;
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9
+2 KILL BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BPGNTS,BGPN,BGPT,BGPIN1,BGPIN
+3 KILL BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
+4 KILL BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
+5 QUIT
I020 ;EP - Alcohol Screening
+1 IF 'BGPACTUP
SET BGPSKIP=1
QUIT
+2 IF BGPSEX'="F"
SET BGPSKIP=1
QUIT
+3 IF BGPAGEB<15
SET BGPSKIP=1
QUIT
+4 IF BGPAGEB>44
SET BGPSKIP=1
QUIT
+5 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
+6 SET BGPN1=$$ALHF^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+8 SET BGPN1=$$ALDX^BGP3D5A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+9 IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+10 SET BGPN1=$$ALPED^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+11 IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+12 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+13 IF BGPD=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Alcohol Screen: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD)
DO I020X
QUIT
+14 ;not due
IF BGPNS>BGPED
SET BGPSKIP=1
QUIT
+15 SET BGPISSV=$$TITLE(BGPGPRAI)
+16 IF BGPV]""
SET $PIECE(BGPISSV,U,2)="Last Alcohol Screen: "_$$DATE^BGP3UTL(BGPD)
+17 IF BGPV=""
SET $PIECE(BGPISSV,U,2)="Alcohol Screening not documented"
SET $PIECE(BGPISSV,U,3)="Alcohol Screening Overdue"
DO I020X
QUIT
+18 IF BGPREF]""
SET $PIECE(BGPISSV,U,2)=$PIECE(BGPISSV,U,2)_"|"_$SELECT(BGPREF]"":"Patient Refused Alcohol Screening on "_$PIECE(BGPREF,U,3),1:"")
+19 SET $PIECE(BGPISSV,U,2)=$PIECE(BGPISSV,U,2)_"|"_$SELECT(BGPNS'>BGPED:"Alcohol Screening Overdue as of: ",1:"Alcohol Screening next due: ")_$$DATE^BGP3UTL(BGPNS)
I020X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
IAA ;EP
+1 IF 'BGPACTUP
SET BGPSKIP=1
QUIT
+2 IF BGPAGEB<18
SET BGPSKIP=1
QUIT
+3 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
+4 SET BGPN1=$$DEP^BGP3D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+5 IF BGPN1
NEW X
SET X=$PIECE(BGPN1,U,4)
SET %DT=""
DO ^%DT
SET BGPD=Y
SET BGPV="2 Mood Disorder DXs "
+6 SET BGPN1=$$DEPSCR^BGP3D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 IF BGPN1
IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+8 SET BGPN1=$$DEPEDU^BGP3D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+9 IF BGPN1
IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+10 IF BGPD=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD)
DO IAAX
QUIT
+11 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+12 IF BGPNS>BGPED
SET BGPSKIP=1
DO IAAX
QUIT
+13 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: "_$$DATE^BGP3UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP3UTL(BGPNS)
+14 ;
IAAX ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
I014 ;EP
+1 IF BGPAGEB<5
SET BGPSKIP=1
QUIT
+2 IF BGPAGEB>17
SET BGPSKIP=1
QUIT
+3 ;never had a sealant
SET BGPLDS=$$SEAL(DFN,$$DOB^AUPNPAT(DFN),DT)
IF 'BGPLDS
SET BGPSKIP=1
QUIT
+4 SET D=$PIECE($$DENTSRV(DFN,$$DOB^AUPNPAT(DFN),DT),U,1)
+5 SET BGPS=""
+6 ;dental exam less than 6 months ago
IF D]""
IF $$FMDIFF^XLFDT(DT,D)<180
SET BGPSKIP=1
QUIT
+7 IF D]""
IF $$FMDIFF^XLFDT(DT,D)>180
SET BGPS="May be overdue: Patient is overdue for dental|exam and assessment for additional sealants.|Refer to Dental Program."
+8 IF BGPLDS=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: Never"
QUIT
+9 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP3UTL(BGPLDS)_"|"_BGPS
+10 QUIT
SEAL(P,BDATE,EDATE) ;
+1 NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V
+2 KILL BGPG,BGPX
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET BGPC=0
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+7 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+8 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+9 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
IF A
SET A=$PIECE($GET(^AUTTADA(A,0)),U)
Begin DoDot:3
+10 IF A'=1351
IF A'=1352
+11 SET G=1
+12 SET T=$PIECE($GET(^AUPNVDEN(Y,0)),U,4)
IF T=""!(T=0)
SET T=1
+13 SET S=$PIECE(^AUPNVDEN(Y,0),U,5)
+14 IF S]""
SET BGPX(S)=$GET(BGPX(S))+T
+15 IF S=""
SET BGPX("NO OS")=$GET(BGPX("NO OS"))+T
+16 QUIT
End DoDot:3
End DoDot:2
+17 ;had ADA codes so skip cpts
IF G
QUIT
+18 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+19 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+20 IF 'A
QUIT
+21 SET A=$PIECE($$CPT^ICPTCOD(A),U,2)
IF A="D1351"!(A="D1352")
Begin DoDot:3
+22 SET T=$PIECE($GET(^AUPNVCPT(Y,0)),U,16)
IF T=""!(T=0)
SET T=1
+23 SET BGPX("CPT")=$GET(BGPX("CPT"))+T
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET X=""
FOR
SET X=$ORDER(BGPX(X))
IF X=""
QUIT
IF X'="CPT"
SET BGPC=BGPC+$SELECT(BGPX(X)>2:2,1:BGPX(X))
+25 SET BGPC=BGPC+$GET(BGPX("CPT"))
+26 QUIT BGPC
DENTSRV(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET BGPC=""
SET %=P_"^LAST ADA 0000;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
SET BGPC=$PIECE(BGPG(1),U)_"^"_"ADA "_$PIECE(BGPG(1),U,2)
+4 KILL BGPG
+5 SET %=P_"^LAST ADA 0190;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+6 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_"ADA "_$PIECE(BGPG(1),U,2)
+7 KILL BGPG
SET %=P_"^LAST EXAM DENTAL;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPG(1),U)>$PIECE(BGPC,U)
SET BGPC=$PIECE(BGPG(1),U)_"^"_$PIECE(BGPG(1),U,3)
+9 KILL BGPG
+10 SET BGPG=$$LASTDX^BGP3UTL1(P,"BGP DENTAL EXAM DXS",BDATE,EDATE)
+11 IF BGPG
IF $PIECE(BGPG,U,3)>$PIECE(BGPC,U,1)
SET BGPC=$PIECE(BGPG,U,3)_"^"_$PIECE(BGPG,U,2)
+12 KILL BGPG
SET G=""
SET %=P_"^ALL ADA;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+13 IF $DATA(BGPG)
Begin DoDot:1
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G]"")
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:2
+15 IF $PIECE($GET(^AUPNVSIT(V,0)),U,3)="C"
IF $$VD^APCLV(V)>$PIECE(BGPC,U,1)
SET BGPC=$PIECE(BGPG(X),U)_"^CHS VISIT ADA "_$PIECE(BGPG(X),U,2)
End DoDot:2
End DoDot:1
IF G]""
QUIT G
+16 QUIT BGPC
+17 ;
I016 ;EP
+1 IF BGPAGEB<3
SET BGPSKIP=1
QUIT
+2 IF BGPAGEB>18
SET BGPSKIP=1
QUIT
+3 ;never had a TF
SET BGPLDS=$$TF(DFN,$$DOB^AUPNPAT(DFN),DT)
IF 'BGPLDS
SET BGPSKIP=1
QUIT
+4 SET BGPS=""
+5 ;fluoride during report period
IF BGPLDS]""
IF BGPLDS'<BGPBDATE
SET BGPSKIP=1
QUIT
+6 IF BGPLDS]""
IF BGPLDS<BGPBDATE
SET BGPS="May be overdue: Apply topical fluoride or refer|to Dental Program for assessment."
+7 IF BGPLDS=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: Never"
QUIT
+8 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP3UTL(BGPLDS)_"|"_BGPS
+9 QUIT
TF(P,BDATE,EDATE) ;
+1 NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R,BJPC
+2 KILL BGPG,BGPZ
SET BGPC=""
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET Z=$ORDER(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",0))
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+7 ;reorder by visit date
+8 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+9 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+10 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
Begin DoDot:3
+11 IF $DATA(^ATXAX(Z,21,"B",A))
SET T=$PIECE($GET(^AUPNVDEN(Y,0)),U,4)
IF T=""!(T=0)
SET T=1
IF $$VD^APCLV(V)>BGPC
SET BGPC=$$VD^APCLV(V)
+12 QUIT
End DoDot:3
End DoDot:2
+13 IF G
QUIT
+14 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+15 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+16 IF 'A
QUIT
+17 IF $$ICD^ATXCHK(A,$ORDER(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1)
SET T=$PIECE($GET(^AUPNVCPT(Y,0)),U,16)
IF T=""!(T=0)
SET T=1
IF $$VD^APCLV(V)>BGPC
SET BGPC=$$VD^APCLV(V)
End DoDot:2
+18 ;one per visit
IF G
QUIT
+19 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+20 SET A=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF A
SET A=$PIECE($$ICDDX^ICDCODE(A),U,2)
Begin DoDot:3
+21 IF A="V07.31"
IF $$VD^APCLV(V)>BGPC
SET BGPC=$$VD^APCLV(V)
+22 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT BGPC
I021 ;EP
+1 IF 'BGPACTUP
SET BGPSKIP=1
QUIT
+2 IF BGPSEX'="F"
SET BGPSKIP=1
QUIT
+3 IF BGPAGEB<15
SET BGPSKIP=1
QUIT
+4 IF BGPAGEB>40
SET BGPSKIP=1
QUIT
+5 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPVA)=""
+6 SET BGPN1=$$DVEX^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 SET BGPD=$PIECE(BGPN1,U,2)
SET BGPVA=$PIECE(BGPN1,U,3)
+8 SET BGPN1=$$DVDX^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+9 IF BGPD<$PIECE(BGPN1,U,2)
SET BGPD=$PIECE(BGPN1,U,2)
SET BGPVA=$PIECE(BGPN1,U,3)
+10 SET BGPN1=$$DVPED^BGP3D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+11 IF BGPD<$PIECE(BGPN1,U,2)
SET BGPD=$PIECE(BGPN1,U,2)
SET BGPVA=$PIECE(BGPN1,U,3)
+12 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+13 IF BGPNS=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD)
DO I021X
QUIT
+14 IF BGPNS>BGPED
SET BGPSKIP=1
DO I021X
QUIT
+15 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP3UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP3UTL(BGPNS)
I021X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
IE2 ;EP
+1 KILL BGPSTOP
+2 SET BGPISSO=1
+3 DO IE2^BGP3D8
+4 IF $DATA(BGPSTOP)
SET BGPSKIP=1
QUIT
+5 SET BGPISSV=""
+6 IF BGPN1
SET BGPSKIP=1
QUIT
+7 ;only ac pregnant
IF 'BGPD1
SET BGPSKIP=1
QUIT
+8 SET BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
+9 IF 'BGPN1
SET $PIECE(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP3UTL(BGPBD)
+10 KILL BGPHIV,BGPN1,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPEDUC,BGPHIV
+11 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9
+12 QUIT
I0302A ;EP
+1 KILL BGPSTOP
+2 IF BGPAGEB<22
SET BGPSKIP=1
QUIT
+3 KILL ^TMP($JOB)
+4 ;I '$$FIRSTIHD^BGP3D721(DFN,BGPEDATE) S BGPSKIP=1 Q ;first dx not prior to report period
+5 ;I '$$V2IHD^BGP3D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSKIP=1 Q ;at least 2 IHD dxs ever
+6 SET BGPCHD=$$CHD^BGP3D729(DFN,BGPBDATE,BGPEDATE)
+7 IF 'BGPCHD
SET BGPSKIP=1
KILL BGPCHD
QUIT
+8 DO I0302ASC^BGP3D41
+9 SET BGPISSV=""
+10 ;met measure
IF BGPN9
SET BGPSKIP=1
DO I0302AX
QUIT
+11 SET BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
+12 SET X=""
SET BGPVAL=""
SET BGPVAL2=""
+13 IF BGPN8
SET BGPN4=0
BP ;
+1 IF 'BGPN1
SET BGPVAL=BGPVAL_"2 BPs"
LDL ;
+1 IF 'BGPN2
SET BGPVAL=BGPVAL_$SELECT(BGPVAL]"":", ",1:"")_"LDL"
TOB ;
+1 IF 'BGPN3
SET BGPVAL=BGPVAL_$SELECT(BGPVAL]"":", ",1:"")_"Tobacco Screen"
BMI ;
+1 IF 'BGPN4
SET BGPVAL2=BGPVAL2_$SELECT(BGPVAL2]"":", ",1:"")_"BMI"
LIFE ;
+1 IF 'BGPN5
SET BGPVAL2=BGPVAL2_$SELECT(BGPVAL2]"":", ",1:"")_"Lifestyle Counseling"
+2 SET BGPISSV=BGPISSV_U_"Screenings Overdue: "_BGPVAL_"|"_BGPVAL2
I0302AX ;EP
+1 KILL BGPBP,BGPLDL,BGPTOB,BGPBMI,BGPLIFE,BGPDEP,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPEDUC,BGPHIV
+2 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPCHD
+3 QUIT
I031A ;EP
+1 SET BGPSKIP=""
+2 KILL BGPSTOP
+3 IF BGPAGEB<2
SET BGPSKIP=1
QUIT
+4 IF BGPAGEB>5
SET BGPSKIP=1
QUIT
+5 IF BGPAGEE>5
SET BGPSKIP=1
QUIT
+6 ;I 'BGPACTCL S BGPSKIP=1 Q
+7 SET BGPD1=1
SET BGPN1=0
SET BGPN2=0
SET BGPIN1=0
+8 SET BGPBMI=$$BMIOR^BGP3D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
+9 IF $PIECE(BGPBMI,U)=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP3UTL(BGPBD)
DO I031AX
QUIT
+10 IF $$FMADD^XLFDT($PIECE(BGPBMI,U,2),365)<BGPED
SET BGPIN1=1
+11 SET BGPOW=$$OW^BGP3D6(DFN,$PIECE(BGPBMI,U),$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2)))
IF BGPOW
SET BGPN1=1
+12 SET BGPOB=$$OB^BGP3D6(DFN,$PIECE(BGPBMI,U),$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2)))
IF BGPOB
SET BGPN2=1
+13 SET A=$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2))
+14 IF 'BGPIN1
IF 'BGPOB
SET BGPSKIP=1
DO I031AX
QUIT
+15 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: "_$PIECE(BGPBMI,U)_":"_$$DATE^BGP3UTL($PIECE(BGPBMI,U,2))_" Age at BMI: "_A_$SELECT(BGPOW:" At Risk 85-94%",BGPOB:" OW 95%",1:"")
+16 IF BGPIN1
SET BGPISSV=BGPISSV_"|Overdue as of: "_$$DATE^BGP3UTL($$FMADD^XLFDT($PIECE(BGPBMI,U,2),365))
I031AX ;
+1 KILL BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
+2 QUIT
TITLE(I) ;
+1 QUIT $PIECE($GET(^BGPINDHC(I,12)),U,9)
BFR ;EP
+1 SET BGPSKIP=""
+2 KILL BGPSTOP,BGPBFR
+3 ;LORI CHANGE AFTER TESTING TO DT
SET BGPADAY=$$FMDIFF^XLFDT(BGPBDATE,$PIECE(^DPT(DFN,0),U,3))
+4 IF BGPADAY<45
SET BGPSKIP=1
QUIT
+5 IF BGPADAY>394
SET BGPSKIP=1
QUIT
+6 DO GETIFC(DFN,BGPBDATE,BGPEDATE,.BGPBFR)
+7 ;|Overdue as of: "_$$DATE^BGP3UTL(DT) D BFRX Q
IF '$DATA(BGPBFR)
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: Never"
DO BFRX
QUIT
+8 ;GET LASTEST (highest days old)
+9 SET X=""
SET Y=""
FOR
SET X=$ORDER(BGPBFR(X))
IF X=""
QUIT
SET Y=X
+10 ;_"|Overdue as of: "_$$DATE^BGP3UTL(DT)
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP3UTL($PIECE(BGPBFR(Y),U,2))
+11 ;
BFRX ;
+1 KILL BGPADAY,BGPBFR
+2 QUIT
GETIFC(P,BDATE,EDATE,BGPRET) ;EP
+1 KILL BGPRET,BGPG,C,X
+2 SET X=0
FOR
SET X=$ORDER(^AUPNVIF("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVIF(X))
QUIT
+4 SET V=$PIECE(^AUPNVIF(X,0),U,3)
SET C=$PIECE(^AUPNVIF(X,0),U,1)
+5 IF V=""
QUIT
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+8 SET BGPRET($$FMDIFF^XLFDT(V,$PIECE(^DPT(P,0),U,3)))=C_U_V
+9 QUIT
End DoDot:1
+10 QUIT
