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 ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
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^BGP0D61(DFN,BGPEDATE) S BGPSKIP=1 Q
I 'BGPACTUP S BGPSKIP=1 Q
S (BGPIN,BGPIN1,BGPIN2,BGPIN3)=""
S BGPLAST=""
S BGPFOB=$$FOB^BGP0D61(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^BGP0D61(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^BGP0D61(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^BGP0D61(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^BGP0D61(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^BGP0UTL($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^BGP0UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP0UTL(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^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
S BGPTOBD=$P(BGPTOBP,U,3)
S BGPSDX=$$DX^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
I BGPTOBD<$P(BGPSDX,U,2) S BGPTOBD=$P(BGPSDX,U,2)
S BGPSCPT=$$CPTSM^BGP0D7(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")!($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=""
S BGPFOB=$$PED^BGP0D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
I BGPFOB="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: Never|Overdue as of: "_$$DATE^BGP0UTL(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^BGP0UTL($P(BGPFOB,U,1))_"|Overdue as of: "_$$DATE^BGP0UTL(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^BGP0D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPN1=$$ALDX^BGP0D5A(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^BGP0D5(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^BGP0UTL(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^BGP0UTL(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^BGP0UTL(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^BGP0D25(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^BGP0D25(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^BGP0D25(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^BGP0UTL(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^BGP0UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP0UTL(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^BGP0UTL(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
...Q:A'=1351
...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" 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=$$LASTDXI^BGP0UTL1(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."
I BGPLDS="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: Never" Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP0UTL(BGPLDS)_"|"_BGPS
Q
TF(P,BDATE,EDATE) ;
NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R
K BGPG,BGPZ S BGPC=0
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)
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
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y!(G>0)!(BGPC>3) 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 S BGPC=BGPC+T,G=G+1
...Q
.Q:G
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) 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 S BGPC=BGPC+T,G=G+1
.Q:G ;one per visit
.S Y=0,G=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) D
..S A=$P($G(^AUPNVPOV(Y,0)),U) I A S A=$P($$ICDDX^ICDCODE(A),U,2) D
...I A="V07.31" S BGPC=BGPC+1,G=1
...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^BGP0D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
S BGPN1=$$DVDX^BGP0D5(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^BGP0D5(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^BGP0UTL(BGPBD) D I021X Q
I BGPNS>BGPED S BGPSKIP=1 D I021X Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP0UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP0UTL(BGPNS)
I021X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
IE2 ;EP
K BGPSTOP
S BGPISSO=1
D IE2^BGP0D8
I $D(BGPSTOP) S BGPSKIP=1 Q
S BGPISSV=""
I BGPN4 S BGPSKIP=1 Q
I 'BGPD1 S BGPSKIP=1 Q ;only ac pregnant
S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
I 'BGPN4 S $P(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP0UTL(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^BGP0D721(DFN,BGPEDATE) S BGPSKIP=1 Q ;first dx not prior to report period
I '$$V2IHD^BGP0D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSKIP=1 Q ;at least 2 IHD dxs ever
D I0302ASC^BGP0D41
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_"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^BGP0D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
I $P(BGPBMI,U)="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP0UTL(BGPBD) D I031AX Q
I $$FMADD^XLFDT($P(BGPBMI,U,2),365)<BGPED S BGPIN1=1
S BGPOW=$$OW^BGP0D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
S BGPOB=$$OB^BGP0D6(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^BGP0UTL($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^BGP0UTL($$FMADD^XLFDT($P(BGPBMI,U,2),365))
I031AX ;
K BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
Q
TITLE(I) ;
Q $P($G(^BGPINDTC(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^BGP0UTL(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^BGP0UTL($P(BGPBFR(Y),U,2)) ;_"|Overdue as of: "_$$DATE^BGP0UTL(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
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
+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^BGP0D61(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^BGP0D61(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^BGP0D61(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^BGP0D61(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 ;last BE test
SET BGPBE=$$BE^BGP0D61(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+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 SET D=$PIECE(BGPBE,U,3)
+29 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN3=1
+30 IF D>BGPLAST
SET BGPLAST=D
+31 ;met at least one of above
IF BGPLAST]""
IF (BGPIN!(BGPIN1)!(BGPIN2)!(BGPIN3))
SET BGPSKIP=1
QUIT
+32 ;S BGPREF=$$REF^BGP0D61(DFN,BGPBDATE,BGPEDATE) I BGPREF S BGPSKIP=1 Q ;refusal in past year
+33 SET BGPN1=0
+34 SET BGPISSV=$$TITLE(BGPGPRAI)
+35 SET BGPX=""
+36 IF BGPCOLO]""
SET BGPX="Last Colonoscopy: "_$PIECE(BGPCOLO,U,2)
+37 IF BGPSIG]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last Flex Sig: "_$PIECE(BGPSIG,U,2)
+38 ;
+39 IF BGPFOB]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last FOBT: "_$$DATE^BGP0UTL($PIECE(BGPFOB,U,2))
+40 IF BGPBE]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")_"Last DCBE: "_$PIECE(BGPBE,U,2)
+41 IF BGPX=""
SET BGPX="No Colonoscopy, Flex Sig, FOBT or DCBE documented."
+42 SET BGPX=BGPX_"|May be overdue as of: "_$SELECT(BGPLAST]"":$$DATE^BGP0UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP0UTL(BGPBD))
+43 SET BGPISSV=BGPISSV_U_BGPX
+44 KILL BGPREF,BGPOTH,BGPN1,BGPFOB,BGPNFOB,BGPBE,BGPF,BGPBE,BGPNBE,BGPSIG,BGPNSIG,BGPCOLO,BGPNCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
+45 QUIT
+46 ;
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^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+6 SET BGPTOBD=$PIECE(BGPTOBP,U,3)
+7 SET BGPSDX=$$DX^BGP0D7(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^BGP0D7(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 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
+15 ;S BGPISSV=$$TITLE(BGPGPRAI)_U_BGPN_U_BGPT D I019X Q ;not a smoker
IF 'BGPD2
SET BGPSKIP=1
QUIT
+16 SET BGPN=""
SET BGPT=""
+17 SET BGPFOB=$$PED^BGP0D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
+18 IF BGPFOB=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: Never|Overdue as of: "_$$DATE^BGP0UTL(BGPBD)
DO I019X
QUIT
+19 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
+20 IF 'BGPIN1
SET BGPSKIP=1
QUIT
+21 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$$DATE^BGP0UTL($PIECE(BGPFOB,U,1))_"|Overdue as of: "_$$DATE^BGP0UTL(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^BGP0D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+8 SET BGPN1=$$ALDX^BGP0D5A(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^BGP0D5(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^BGP0UTL(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^BGP0UTL(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^BGP0UTL(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^BGP0D25(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^BGP0D25(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^BGP0D25(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^BGP0UTL(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^BGP0UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP0UTL(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^BGP0UTL(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
QUIT
+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"
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=$$LASTDXI^BGP0UTL1(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 IF BGPLDS=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: Never"
QUIT
+8 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP0UTL(BGPLDS)_"|"_BGPS
+9 QUIT
TF(P,BDATE,EDATE) ;
+1 NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R
+2 KILL BGPG,BGPZ
SET BGPC=0
+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 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPC>3)
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!(G>0)!(BGPC>3)
QUIT
Begin DoDot:2
+9 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
Begin DoDot:3
+10 IF $DATA(^ATXAX(Z,21,"B",A))
SET T=$PIECE($GET(^AUPNVDEN(Y,0)),U,4)
IF T=""!(T=0)
SET T=1
SET BGPC=BGPC+T
SET G=G+1
+11 QUIT
End DoDot:3
End DoDot:2
+12 IF G
QUIT
+13 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+14 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+15 IF 'A
QUIT
+16 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
SET BGPC=BGPC+T
SET G=G+1
End DoDot:2
+17 ;one per visit
IF G
QUIT
+18 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+19 SET A=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF A
SET A=$PIECE($$ICDDX^ICDCODE(A),U,2)
Begin DoDot:3
+20 IF A="V07.31"
SET BGPC=BGPC+1
SET G=1
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 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^BGP0D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 SET BGPD=$PIECE(BGPN1,U,2)
SET BGPVA=$PIECE(BGPN1,U,3)
+8 SET BGPN1=$$DVDX^BGP0D5(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^BGP0D5(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^BGP0UTL(BGPBD)
DO I021X
QUIT
+14 IF BGPNS>BGPED
SET BGPSKIP=1
DO I021X
QUIT
+15 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP0UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP0UTL(BGPNS)
I021X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
IE2 ;EP
+1 KILL BGPSTOP
+2 SET BGPISSO=1
+3 DO IE2^BGP0D8
+4 IF $DATA(BGPSTOP)
SET BGPSKIP=1
QUIT
+5 SET BGPISSV=""
+6 IF BGPN4
SET BGPSKIP=1
QUIT
+7 ;only ac pregnant
IF 'BGPD1
SET BGPSKIP=1
QUIT
+8 SET BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
+9 IF 'BGPN4
SET $PIECE(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP0UTL(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^BGP0D721(DFN,BGPEDATE)
SET BGPSKIP=1
QUIT
+5 ;at least 2 IHD dxs ever
IF '$$V2IHD^BGP0D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
SET BGPSKIP=1
QUIT
+6 DO I0302ASC^BGP0D41
+7 SET BGPISSV=""
+8 ;met measure
IF BGPN9
SET BGPSKIP=1
DO I0302AX
QUIT
+9 SET BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
+10 SET X=""
SET BGPVAL=""
SET BGPVAL2=""
+11 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_"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^BGP0D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
+9 IF $PIECE(BGPBMI,U)=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP0UTL(BGPBD)
DO I031AX
QUIT
+10 IF $$FMADD^XLFDT($PIECE(BGPBMI,U,2),365)<BGPED
SET BGPIN1=1
+11 SET BGPOW=$$OW^BGP0D6(DFN,$PIECE(BGPBMI,U),$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2)))
IF BGPOW
SET BGPN1=1
+12 SET BGPOB=$$OB^BGP0D6(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^BGP0UTL($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^BGP0UTL($$FMADD^XLFDT($PIECE(BGPBMI,U,2),365))
I031AX ;
+1 KILL BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
+2 QUIT
TITLE(I) ;
+1 QUIT $PIECE($GET(^BGPINDTC(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^BGP0UTL(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^BGP0UTL(DT)
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP0UTL($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
