BGP9DPA2 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 09 Jan 2008 3:36 PM 26 Jun 2008 3:40 PM ; 03 Jun 2009 8:04 AM
;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
;
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^BGP9D61(DFN,BGPEDATE) S BGPSKIP=1 Q
I 'BGPACTUP S BGPSKIP=1 Q
S (BGPIN,BGPIN1,BGPIN2,BGPIN3)=""
S BGPLAST=""
S BGPFOB=$$FOB^BGP9D61(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;last FOB test
S D=$P(BGPFOB,U,2)
I D]"",$$FMDIFF^XLFDT(DT,D)<365 S BGPIN=1
;S D=$P(BGPFOB,U,2),BGPNFOB=$S($P(BGPFOB,U,2):$$FMADD^XLFDT(D,365),1:BGPBDATE) I BGPNFOB'>BGPED S BGPIN=1
;S BGPLAST=D_U_BGPNFOB
I D>BGPLAST S BGPLAST=D
S BGPSIG=$$SIG^BGP9D61(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^BGP9D61(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^BGP9D61(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 BGPREF=$$REF^BGP9D61(DFN,BGPBDATE,BGPEDATE) I BGPREF S BGPSKIP=1 Q ;refusal in past year
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 FOBT: "_$$DATE^BGP9UTL($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^BGP9UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP9UTL(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 (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ
S (BGPIN,BGPIN1)=0
I 'BGPACTUP S BGPSKIP=1 ;must be at least user pop
S BGPTOBP=$$TOBACCO^BGP9D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
S BGPTOBD=$P(BGPTOBP,U,3)
S BGPSDX=$$DX^BGP9D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
I BGPTOBD<$P(BGPSDX,U,2) S BGPTOBD=$P(BGPSDX,U,2)
S BGPSCPT=$$CPTSM^BGP9D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
I BGPTOBD<$P(BGPSCPT,U,2) S BGPTOBD=$P(BGPSDX,U,2)
S X=0
I BGPSDX]"",$P(BGPSDX,U,1)="305.13" S X=1
I BGPSDX]"",$P(BGPSDX,U,1)="V15.82" S X=1
;I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&('X))!(BGPTOBP["CESSATION") S BGPD2=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
I 'BGPD2 S BGPSKIP=1 Q ;S BGPISSV=$$TITLE(BGPGPRAI)_U_BGPN_U_BGPT D I019X Q ;not a smoker
S BGPN="",BGPT=""
;I BGPTOBP]"" S BGPN=BGPN_"Last Tobacco Health Factor: "_$P(BGPTOBP,U)_" "_$P(BGPTOBP,U,2)_"|"
;I BGPSDX]"" S BGPN=BGPN_"Last Smoking Dx: "_$P(BGPSDX,U)_" "_$$DATE^BGP9UTL($P(BGPSDX,U,2))_"|"
;I BGP1320]"" S BGPN=BGPN_"Last Dental Smoking ADA: "_$P(BGP1320,U)_" "_$$DATE^BGP9UTL($P(BGP1320,U,2))_"|"
S BGPFOB=$$PED^BGP9D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
I BGPFOB="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) D I019X Q
S D=$P(BGPFOB,U,1),BGPNFOB=$S($P(BGPFOB,U,1):$$FMADD^XLFDT(D,365),1:DT) I BGPNFOB'>BGPED S BGPIN1=1
I 'BGPIN1 S BGPSKIP=1 Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$$DATE^BGP9UTL($P(BGPFOB,U,1))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPNFOB)
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
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^BGP9D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPN1=$$ALDX^BGP9D5(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^BGP9D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPREF=$$ALREF^BGP9D5(DFN,BGPBDATE,BGPEDATE)
I BGPREF]"" S BGPSKIP=1 Q
S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
I BGPD="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Alcohol Screen: Never|Overdue as of: "_$$DATE^BGP9UTL(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^BGP9UTL(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^BGP9UTL(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^BGP9D25(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^BGP9D25(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^BGP9D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1,BGPD<$P(BGPN1,U,4) S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPREF=$$DEPREF^BGP9D25(DFN,BGPBDATE,BGPEDATE)
I BGPREF]"" S BGPSKIP=1 Q
I BGPREF,BGPD<$P(BGPREF,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^BGP9UTL(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^BGP9UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP9UTL(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."
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP9UTL(BGPLDS)_"|"_BGPS
Q
SEAL(P,BDATE,EDATE) ;
NEW BGPG
S %=P_"^LAST ADA 1351;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q $P(BGPG(1),U)
Q ""
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=$$LASTDXI^BGP9UTL1(P,"V72.2",BDATE,EDATE)
I BGPG,$P(BGPG,U,3)>$P(BGPC,U,1) S BGPC=$P(BGPG,U,3)_"^V72.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."
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP9UTL(BGPLDS)_"|"_BGPS
Q
TF(P,BDATE,EDATE) ;
NEW BGPG,BGPC
K BGPG S BGPC=""
K ^TMP($J,"A")
S A="^TMP($J,""A"","
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!(G) D
..S A=$P($G(^AUPNVDEN(Y,0)),U) I A S A=$P($G(^AUTTADA(A,0)),U) D
...I A=1201!(A=1203)!(A=1204)!(A=1205)!(A=1206) D
....S G=1
....I $$VD^APCLV(V)>BGPC S BGPC=$$VD^APCLV(V)
....Q
.Q:G
.S Y=0,G=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G) D
..S A=$P($G(^AUPNVPOV(Y,0)),U) I A S A=$P($$ICDDX^ICDCODE(A),U,2) D
...I A="V07.31" D
....S G=1
....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^BGP9D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
S BGPN1=$$DVDX^BGP9D5(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^BGP9D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPD<$P(BGPN1,U,2) S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
S BGPREF=$$REFDV^BGP9D5(DFN,BGPBDATE,BGPEDATE)
I BGPREF]"" S BGPSKIP=1 Q
S BGPNS=$S(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
I BGPNS="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) D I021X Q
I BGPNS>BGPED S BGPSKIP=1 D I021X Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP9UTL(BGPNS)
I021X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
IE2 ;EP
K BGPSTOP
S BGPISSO=1
D IE2^BGP9D8
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^BGP9UTL(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^BGP9D721(DFN,BGPEDATE) S BGPSKIP=1 Q ;first dx not prior to report period
I '$$V2IHD^BGP9D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSKIP=1 Q ;at least 2 IHD dxs ever
D I0302ASC^BGP9D41
S BGPISSV=""
I BGPN7 S BGPSKIP=1 D I0302AX Q ;met measure
S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
S X="",BGPVAL="",BGPVAL2=""
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_"Sreenings 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
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^BGP9D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
I $P(BGPBMI,U)="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD) D I031AX Q
I $$FMADD^XLFDT($P(BGPBMI,U,2),365)<BGPED S BGPIN1=1
S BGPOW=$$OW^BGP9D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
S BGPOB=$$OB^BGP9D6(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^BGP9UTL($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^BGP9UTL($$FMADD^XLFDT($P(BGPBMI,U,2),365))
I031AX ;
K BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
Q
TITLE(I) ;
Q $P($G(^BGPINDNC(I,12)),U,9)
BFR ;EP
S BGPSKIP=""
K BGPSTOP,BGPBFR
S BGPADAY=$$FMDIFF^XLFDT(DT,$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^BGP9UTL(DT) D BFRX Q
;GET LASTEST (highest days old)
S X=0,Y="" F S X=$O(BGPBFR(X)) Q:X'=+X S Y=X
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP9UTL($P(BGPBFR(Y),U,2)) ;_"|Overdue as of: "_$$DATE^BGP9UTL(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
BGP9DPA2 ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT 09 Jan 2008 3:36 PM 26 Jun 2008 3:40 PM ; 03 Jun 2009 8:04 AM
+1 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
+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^BGP9D61(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^BGP9D61(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 ;S D=$P(BGPFOB,U,2),BGPNFOB=$S($P(BGPFOB,U,2):$$FMADD^XLFDT(D,365),1:BGPBDATE) I BGPNFOB'>BGPED S BGPIN=1
+13 ;S BGPLAST=D_U_BGPNFOB
+14 IF D>BGPLAST
SET BGPLAST=D
+15 ;last SIG test
SET BGPSIG=$$SIG^BGP9D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+16 ;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
+17 ;I D>BGPLAST S BGPLAST=D_U_BGPNSIG
+18 SET D=$PIECE(BGPSIG,U,3)
+19 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN1=1
+20 IF D>BGPLAST
SET BGPLAST=D
+21 ;last COLO test
SET BGPCOLO=$$COLO^BGP9D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+22 ;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
+23 ;I D>BGPLAST S BGPLAST=D_U_BGPNCOLO
+24 SET D=$PIECE(BGPCOLO,U,3)
+25 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN2=1
+26 IF D>BGPLAST
SET BGPLAST=D
+27 ;last BE test
SET BGPBE=$$BE^BGP9D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+28 ;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
+29 ;I D>BGPLAST S BGPLAST=D_U_BGPNBE
+30 SET D=$PIECE(BGPBE,U,3)
+31 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN3=1
+32 IF D>BGPLAST
SET BGPLAST=D
+33 ;met at least one of above
IF BGPLAST]""
IF (BGPIN!(BGPIN1)!(BGPIN2)!(BGPIN3))
SET BGPSKIP=1
QUIT
+34 ;refusal in past year
SET BGPREF=$$REF^BGP9D61(DFN,BGPBDATE,BGPEDATE)
IF BGPREF
SET BGPSKIP=1
QUIT
+35 SET BGPN1=0
+36 SET BGPISSV=$$TITLE(BGPGPRAI)
+37 SET BGPX=""
+38 IF BGPCOLO]""
SET BGPX="Last Colonoscopy: "_$PIECE(BGPCOLO,U,2)
+39 IF BGPSIG]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last Flex Sig: "_$PIECE(BGPSIG,U,2)
+40 ;
+41 IF BGPFOB]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last FOBT: "_$$DATE^BGP9UTL($PIECE(BGPFOB,U,2))
+42 IF BGPBE]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")_"Last DCBE: "_$PIECE(BGPBE,U,2)
+43 IF BGPX=""
SET BGPX="No Colonoscopy, Flex Sig, FOBT or DCBE documented."
+44 SET BGPX=BGPX_"|May be overdue as of: "_$SELECT(BGPLAST]"":$$DATE^BGP9UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP9UTL(BGPBD))
+45 SET BGPISSV=BGPISSV_U_BGPX
+46 KILL BGPREF,BGPOTH,BGPN1,BGPFOB,BGPNFOB,BGPBE,BGPF,BGPBE,BGPNBE,BGPSIG,BGPNSIG,BGPCOLO,BGPNCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
+47 QUIT
+48 ;
I019 ;EP - tobacco cessation
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 KILL BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ
+3 SET (BGPIN,BGPIN1)=0
+4 ;must be at least user pop
IF 'BGPACTUP
SET BGPSKIP=1
+5 SET BGPTOBP=$$TOBACCO^BGP9D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+6 SET BGPTOBD=$PIECE(BGPTOBP,U,3)
+7 SET BGPSDX=$$DX^BGP9D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+8 IF BGPTOBD<$PIECE(BGPSDX,U,2)
SET BGPTOBD=$PIECE(BGPSDX,U,2)
+9 SET BGPSCPT=$$CPTSM^BGP9D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+10 IF BGPTOBD<$PIECE(BGPSCPT,U,2)
SET BGPTOBD=$PIECE(BGPSDX,U,2)
+11 SET X=0
+12 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="305.13"
SET X=1
+13 IF BGPSDX]""
IF $PIECE(BGPSDX,U,1)="V15.82"
SET X=1
+14 ;I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&('X))!(BGPTOBP["CESSATION") S BGPD2=1
+15 IF $PIECE(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&('X))!(BGPTOBP["CESSATION")!($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)=99406)!($PIECE(BGPSCPT,U)=99407)!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)="G0376")
SET BGPD2=1
+16 ;S BGPISSV=$$TITLE(BGPGPRAI)_U_BGPN_U_BGPT D I019X Q ;not a smoker
IF 'BGPD2
SET BGPSKIP=1
QUIT
+17 SET BGPN=""
SET BGPT=""
+18 ;I BGPTOBP]"" S BGPN=BGPN_"Last Tobacco Health Factor: "_$P(BGPTOBP,U)_" "_$P(BGPTOBP,U,2)_"|"
+19 ;I BGPSDX]"" S BGPN=BGPN_"Last Smoking Dx: "_$P(BGPSDX,U)_" "_$$DATE^BGP9UTL($P(BGPSDX,U,2))_"|"
+20 ;I BGP1320]"" S BGPN=BGPN_"Last Dental Smoking ADA: "_$P(BGP1320,U)_" "_$$DATE^BGP9UTL($P(BGP1320,U,2))_"|"
+21 SET BGPFOB=$$PED^BGP9D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
+22 IF BGPFOB=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I019X
QUIT
+23 SET D=$PIECE(BGPFOB,U,1)
SET BGPNFOB=$SELECT($PIECE(BGPFOB,U,1):$$FMADD^XLFDT(D,365),1:DT)
IF BGPNFOB'>BGPED
SET BGPIN1=1
+24 IF 'BGPIN1
SET BGPSKIP=1
QUIT
+25 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$$DATE^BGP9UTL($PIECE(BGPFOB,U,1))_"|Overdue as of: "_$$DATE^BGP9UTL(BGPNFOB)
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 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^BGP9D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+8 SET BGPN1=$$ALDX^BGP9D5(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^BGP9D5(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 BGPREF=$$ALREF^BGP9D5(DFN,BGPBDATE,BGPEDATE)
+13 IF BGPREF]""
SET BGPSKIP=1
QUIT
+14 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+15 IF BGPD=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Alcohol Screen: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I020X
QUIT
+16 ;not due
IF BGPNS>BGPED
SET BGPSKIP=1
QUIT
+17 SET BGPISSV=$$TITLE(BGPGPRAI)
+18 IF BGPV]""
SET $PIECE(BGPISSV,U,2)="Last Alcohol Screen: "_$$DATE^BGP9UTL(BGPD)
+19 IF BGPV=""
SET $PIECE(BGPISSV,U,2)="Alcohol Screening not documented"
SET $PIECE(BGPISSV,U,3)="Alcohol Screening Overdue"
DO I020X
QUIT
+20 IF BGPREF]""
SET $PIECE(BGPISSV,U,2)=$PIECE(BGPISSV,U,2)_"|"_$SELECT(BGPREF]"":"Patient Refused Alcohol Screening on "_$PIECE(BGPREF,U,3),1:"")
+21 SET $PIECE(BGPISSV,U,2)=$PIECE(BGPISSV,U,2)_"|"_$SELECT(BGPNS'>BGPED:"Alcohol Screening Overdue as of: ",1:"Alcohol Screening next due: ")_$$DATE^BGP9UTL(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^BGP9D25(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^BGP9D25(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^BGP9D25(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 SET BGPREF=$$DEPREF^BGP9D25(DFN,BGPBDATE,BGPEDATE)
+11 IF BGPREF]""
SET BGPSKIP=1
QUIT
+12 IF BGPREF
IF BGPD<$PIECE(BGPREF,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+13 IF BGPD=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO IAAX
QUIT
+14 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+15 IF BGPNS>BGPED
SET BGPSKIP=1
DO IAAX
QUIT
+16 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Depression Screen: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP9UTL(BGPNS)
+17 ;
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 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP9UTL(BGPLDS)_"|"_BGPS
+9 QUIT
SEAL(P,BDATE,EDATE) ;
+1 NEW BGPG
+2 SET %=P_"^LAST ADA 1351;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)
+4 QUIT ""
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=$$LASTDXI^BGP9UTL1(P,"V72.2",BDATE,EDATE)
+11 IF BGPG
IF $PIECE(BGPG,U,3)>$PIECE(BGPC,U,1)
SET BGPC=$PIECE(BGPG,U,3)_"^V72.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 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP9UTL(BGPLDS)_"|"_BGPS
+8 QUIT
TF(P,BDATE,EDATE) ;
+1 NEW BGPG,BGPC
+2 KILL BGPG
SET BGPC=""
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+6 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
+7 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+8 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
IF A
SET A=$PIECE($GET(^AUTTADA(A,0)),U)
Begin DoDot:3
+9 IF A=1201!(A=1203)!(A=1204)!(A=1205)!(A=1206)
Begin DoDot:4
+10 SET G=1
+11 IF $$VD^APCLV(V)>BGPC
SET BGPC=$$VD^APCLV(V)
+12 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+13 IF G
QUIT
+14 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+15 SET A=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF A
SET A=$PIECE($$ICDDX^ICDCODE(A),U,2)
Begin DoDot:3
+16 IF A="V07.31"
Begin DoDot:4
+17 SET G=1
+18 IF $$VD^APCLV(V)>BGPC
SET BGPC=$$VD^APCLV(V)
End DoDot:4
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 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^BGP9D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 SET BGPD=$PIECE(BGPN1,U,2)
SET BGPVA=$PIECE(BGPN1,U,3)
+8 SET BGPN1=$$DVDX^BGP9D5(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^BGP9D5(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 BGPREF=$$REFDV^BGP9D5(DFN,BGPBDATE,BGPEDATE)
+13 IF BGPREF]""
SET BGPSKIP=1
QUIT
+14 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+15 IF BGPNS=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I021X
QUIT
+16 IF BGPNS>BGPED
SET BGPSKIP=1
DO I021X
QUIT
+17 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP9UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP9UTL(BGPNS)
I021X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
IE2 ;EP
+1 KILL BGPSTOP
+2 SET BGPISSO=1
+3 DO IE2^BGP9D8
+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^BGP9UTL(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 ;first dx not prior to report period
IF '$$FIRSTIHD^BGP9D721(DFN,BGPEDATE)
SET BGPSKIP=1
QUIT
+5 ;at least 2 IHD dxs ever
IF '$$V2IHD^BGP9D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
SET BGPSKIP=1
QUIT
+6 DO I0302ASC^BGP9D41
+7 SET BGPISSV=""
+8 ;met measure
IF BGPN7
SET BGPSKIP=1
DO I0302AX
QUIT
+9 SET BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
+10 SET X=""
SET BGPVAL=""
SET BGPVAL2=""
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_"Sreenings 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
+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^BGP9D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
+9 IF $PIECE(BGPBMI,U)=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP9UTL(BGPBD)
DO I031AX
QUIT
+10 IF $$FMADD^XLFDT($PIECE(BGPBMI,U,2),365)<BGPED
SET BGPIN1=1
+11 SET BGPOW=$$OW^BGP9D6(DFN,$PIECE(BGPBMI,U),$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2)))
IF BGPOW
SET BGPN1=1
+12 SET BGPOB=$$OB^BGP9D6(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^BGP9UTL($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^BGP9UTL($$FMADD^XLFDT($PIECE(BGPBMI,U,2),365))
I031AX ;
+1 KILL BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
+2 QUIT
TITLE(I) ;
+1 QUIT $PIECE($GET(^BGPINDNC(I,12)),U,9)
BFR ;EP
+1 SET BGPSKIP=""
+2 KILL BGPSTOP,BGPBFR
+3 ;LORI CHANGE AFTER TESTING TO DT
SET BGPADAY=$$FMDIFF^XLFDT(DT,$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^BGP9UTL(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=0
SET Y=""
FOR
SET X=$ORDER(BGPBFR(X))
IF X'=+X
QUIT
SET Y=X
+10 ;_"|Overdue as of: "_$$DATE^BGP9UTL(DT)
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP9UTL($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
