BGP8DPA2 ;IHS/CMI/LAB - FORECAST;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
I017 ;EP - colorectal cancer
;
K BGPFOB,BGPSIG,BGPBE,BGPCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
I BGPAGEB<50 S BGPSKIP=1 Q
I BGPAGEB>75 S BGPSKIP=1 Q
I $$CRC^BGP8D62(DFN,BGPEDATE) S BGPSKIP=1 Q
I 'BGPACTUP S BGPSKIP=1 Q
S (BGPIN,BGPIN1,BGPIN2,BGPIN3)=""
S BGPLAST=""
S BGPFOB=$$FOB^BGP8D62(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^BGP8D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN)) ;last SIG test
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^BGP8D62(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
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^BGP8UTL($P(BGPFOB,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^BGP8UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP8UTL(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^BGP8D71
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^BGP8D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$S(BGPTC1="":"<Never>",1:$$DATE^BGP8UTL($P(BGPTC1,U,1))_"|Overdue as of: "_$$DATE^BGP8UTL(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<9 S BGPSKIP=1 Q
I BGPAGEB>75 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
K BGPALL
D ALSCRN^BGP8D55(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,.BGPALL)
I $D(BGPALL) S BGPN1=1 S D=$O(BGPALL(0)),C=$O(BGPALL(D,0)) S BGPD=9999999-D,BGPV=$P(BGPALL(D,C),U,2)
;S BGPN1=$$ALHF^BGP8D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
;S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
S BGPN1=$$ALDX^BGP8D5A(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^BGP8D5(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^BGP8UTL(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^BGP8UTL(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^BGP8UTL(BGPNS)
I020X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
IAA ;EP
I BGPAGEB<12 S BGPSKIP=1 Q
I BGPAGEB>17 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
S BGPN1=$$DEP^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
I BGPN1 NEW X S X=$P(BGPN1,U,4) S BGPD=X,BGPV="2 Mood Disorder DXs "
S BGPN1=$$DEPSCR^BGP8D25(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^BGP8D25(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^BGP8UTL(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^BGP8UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPNS)
;
IAAX ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
I014 ;EP
I BGPAGEB<2 S BGPSKIP=1 Q
I BGPAGEB>15 S BGPSKIP=1 Q
S BGPLDS=$$SEAL(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;I 'BGPLDS S BGPSKIP=1 Q ;never had a sealant
S D=$P($$DENTSRV^BGP8D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1),U,2)
;S D=$P($$DENTSRV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE),U,1)
S BGPS=""
I D]"",$$FMDIFF^XLFDT(BGPEDATE,D)<180 S BGPSKIP=1 Q ;dental exam less than 6 months ago
I D]"",$$FMDIFF^XLFDT(BGPEDATE,D)>180 S BGPS="May be overdue: Patient is overdue for dental|exam and assessment for additional sealants.|Refer to Dental Program."
I D="" 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"_"|"_BGPS Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP8UTL(BGPLDS)_"|"_BGPS
Q
SEAL(P,BDATE,EDATE) ;
NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,LAST
K BGPG,BGPX
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S BGPC=0,LAST=""
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,A'=1353 Q
...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
...S LAST=$P(^TMP($J,"A",X),U,1)
...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")!(A="D1353") D
...S T=$P($G(^AUPNVCPT(Y,0)),U,16) S:T=""!(T=0) T=1
...S BGPX("CPT")=$G(BGPX("CPT"))+T
...S LAST=$P(^TMP($J,"A",X),U,1)
S X="" F S X=$O(BGPX(X)) Q:X="" I X'="CPT" S BGPC=BGPC+$S(BGPX(X)>2:2,1:BGPX(X))
S BGPC=BGPC+$G(BGPX("CPT"))
Q LAST
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^BGP8UTL1(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<1 S BGPSKIP=1 Q
I BGPAGEB>15 S BGPSKIP=1 Q
S BGPLDS=$$TF(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) ;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|May be overdue: Apply topical fluoride or refer|to Dental Program for assessment." Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP8UTL(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^BGP8UTL2(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^BGP8UTL2(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<13 S BGPSKIP=1 Q
I BGPAGEB>46 S BGPSKIP=1 Q
S (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPVA)=""
S BGPN1=$$DVEX^BGP8D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
S BGPD=$P(BGPN1,U,2),BGPVA=$P(BGPN1,U,3)
S BGPN1=$$DVDX^BGP8D5(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^BGP8D5(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^BGP8UTL(BGPBD) D I021X Q
I BGPNS>BGPED S BGPSKIP=1 D I021X Q
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPNS)
I021X ;
K BGPD,BGPN,BGPN1,BGPREF,BGPNS
Q
IE2 ;EP
K BGPSTOP
S BGPISSO=1
D IE2^BGP8D8
I $D(BGPSTOP) S BGPSKIP=1 Q
S BGPISSV=""
I BGPN16 S BGPSKIP=1 Q
I 'BGPD2 S BGPSKIP=1 Q ;13-64 WITH NO HIV
S BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
I 'BGPN1 S $P(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP8UTL(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
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^BGP8D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
I $P(BGPBMI,U)="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) D I031AX Q
I $$FMADD^XLFDT($P(BGPBMI,U,2),365)<BGPED S BGPIN1=1
S BGPOW=$$OW^BGP8D6(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
S BGPOB=$$OB^BGP8D6(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^BGP8UTL($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^BGP8UTL($$FMADD^XLFDT($P(BGPBMI,U,2),365))
I031AX ;
K BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
Q
TITLE(I) ;EP
Q $P($G(^BGPINDRC(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^BGP8UTL(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^BGP8UTL($P(BGPBFR(Y),U,2)) ;_"|Overdue as of: "_$$DATE^BGP8UTL(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
MH ;EP
K BGPSTOP
NEW BGPBP,BGPN1
S BGPN1=0
I BGPAGEE<18 S BGPSKIP=1 Q
I BGPAGEE>85 S BGPSKIP=1 Q
I $$ESRD^BGP8D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSKIP=1 Q ;esrd anytime before end date
S X=$$PREG^BGP8D7(DFN,BGPBDATE,BGPEDATE,1,1,,BGPBDATE,BGPEDATE) I X S BGPSKIP=1 Q ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
I '$$MHHTN^BGP8D9(DFN,BGPBDATE,BGPEDATE) S BGPSKIP=1 Q ;no htn per definition
S BGPBP=$$LASTBP^BGP8D9(DFN,BGPBDATE,BGPEDATE)
I BGPBP]"" D
.S X=BGPBP
.I $P(X,"/",1)<140,$P(X,"/",2)<90 S BGPN1=1
NEW BGPV,BGPD,BGPND
S (BGPISSV,BGPIN)=""
K BGPISSV
;
I BGPBP="" S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: 2 BPs not documented "_$$DATE^BGP8UTL(BGPBD)_"-"_$$DATE^BGP8UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD) Q
I BGPN1 S BGPSKIP=1 Q ;in control BP in report period, do not display
S BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: "_$P(BGPBP,U)
I 'BGPN1 S BGPISSV=BGPISSV_" - Not Controlled BP"
Q
BGP8DPA2 ;IHS/CMI/LAB - FORECAST;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
I017 ;EP - colorectal cancer
+1 ;
+2 KILL BGPFOB,BGPSIG,BGPBE,BGPCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
+3 IF BGPAGEB<50
SET BGPSKIP=1
QUIT
+4 IF BGPAGEB>75
SET BGPSKIP=1
QUIT
+5 IF $$CRC^BGP8D62(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^BGP8D62(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^BGP8D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+14 SET D=$PIECE(BGPSIG,U,3)
+15 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN1=1
+16 IF D>BGPLAST
SET BGPLAST=D
+17 ;last COLO test
SET BGPCOLO=$$COLO^BGP8D62(DFN,BGPEDATE,$$DOB^AUPNPAT(DFN))
+18 ;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
+19 ;I D>BGPLAST S BGPLAST=D_U_BGPNCOLO
+20 SET D=$PIECE(BGPCOLO,U,3)
+21 IF D]""
IF $$FMDIFF^XLFDT(DT,D)<365
SET BGPIN2=1
+22 IF D>BGPLAST
SET BGPLAST=D
+23 ;met at least one of above
IF BGPLAST]""
IF (BGPIN!(BGPIN1)!(BGPIN2)!(BGPIN3))
SET BGPSKIP=1
QUIT
+24 SET BGPN1=0
+25 SET BGPISSV=$$TITLE(BGPGPRAI)
+26 SET BGPX=""
+27 IF BGPCOLO]""
SET BGPX="Last Colonoscopy: "_$PIECE(BGPCOLO,U,2)
+28 IF BGPSIG]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last Flex Sig: "_$PIECE(BGPSIG,U,2)
+29 ;
+30 IF BGPFOB]""
SET BGPX=BGPX_$SELECT(BGPX]"":"|",1:"")
SET BGPX=BGPX_"Last FOB: "_$$DATE^BGP8UTL($PIECE(BGPFOB,U,2))
+31 IF BGPX=""
SET BGPX="No Colonoscopy, Flex Sig, FOBT or DCBE documented."
+32 SET BGPX=BGPX_"|May be overdue as of: "_$SELECT(BGPLAST]"":$$DATE^BGP8UTL($$FMADD^XLFDT(BGPLAST,365)),1:$$DATE^BGP8UTL(BGPBD))
+33 SET BGPISSV=BGPISSV_U_BGPX
+34 KILL BGPREF,BGPOTH,BGPN1,BGPFOB,BGPNFOB,BGPBE,BGPF,BGPBE,BGPNBE,BGPSIG,BGPNSIG,BGPCOLO,BGPNCOLO,BGPIN,BGPIN1,BGPIN2,BGPIN3
+35 QUIT
+36 ;
I019 ;EP - tobacco cessation
+1 ;IN FORECASTER
SET BGPINFO=1
+2 DO I91^BGP8D71
+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^BGP8D711(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,1)
+8 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Intervention: "_$SELECT(BGPTC1="":"<Never>",1:$$DATE^BGP8UTL($PIECE(BGPTC1,U,1))_"|Overdue as of: "_$$DATE^BGP8UTL(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 ;I BGPSEX'="F" S BGPSKIP=1 Q
+3 IF BGPAGEB<9
SET BGPSKIP=1
QUIT
+4 IF BGPAGEB>75
SET BGPSKIP=1
QUIT
+5 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPV)=""
+6 KILL BGPALL
+7 DO ALSCRN^BGP8D55(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,.BGPALL)
+8 IF $DATA(BGPALL)
SET BGPN1=1
SET D=$ORDER(BGPALL(0))
SET C=$ORDER(BGPALL(D,0))
SET BGPD=9999999-D
SET BGPV=$PIECE(BGPALL(D,C),U,2)
+9 ;S BGPN1=$$ALHF^BGP8D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+10 ;S BGPD=$P(BGPN1,U,4),BGPV=$P(BGPN1,U,2)
+11 SET BGPN1=$$ALDX^BGP8D5A(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+12 IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+13 SET BGPN1=$$ALPED^BGP8D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+14 IF BGPD<$PIECE(BGPN1,U,4)
SET BGPD=$PIECE(BGPN1,U,4)
SET BGPV=$PIECE(BGPN1,U,2)
+15 SET BGPNS=$SELECT(BGPD:$$FMADD^XLFDT(BGPD,365),1:"")
+16 IF BGPD=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Alcohol Screen: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
DO I020X
QUIT
+17 ;not due
IF BGPNS>BGPED
SET BGPSKIP=1
QUIT
+18 SET BGPISSV=$$TITLE(BGPGPRAI)
+19 IF BGPV]""
SET $PIECE(BGPISSV,U,2)="Last Alcohol Screen: "_$$DATE^BGP8UTL(BGPD)
+20 IF BGPV=""
SET $PIECE(BGPISSV,U,2)="Alcohol Screening not documented"
SET $PIECE(BGPISSV,U,3)="Alcohol Screening Overdue"
DO I020X
QUIT
+21 IF BGPREF]""
SET $PIECE(BGPISSV,U,2)=$PIECE(BGPISSV,U,2)_"|"_$SELECT(BGPREF]"":"Patient Refused Alcohol Screening on "_$PIECE(BGPREF,U,3),1:"")
+22 SET $PIECE(BGPISSV,U,2)=$PIECE(BGPISSV,U,2)_"|"_$SELECT(BGPNS'>BGPED:"Alcohol Screening Overdue as of: ",1:"Alcohol Screening next due: ")_$$DATE^BGP8UTL(BGPNS)
I020X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
IAA ;EP
+1 IF BGPAGEB<12
SET BGPSKIP=1
QUIT
+2 IF BGPAGEB>17
SET BGPSKIP=1
QUIT
+3 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS)=""
+4 SET BGPN1=$$DEP^BGP8D25(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+5 IF BGPN1
NEW X
SET X=$PIECE(BGPN1,U,4)
SET BGPD=X
SET BGPV="2 Mood Disorder DXs "
+6 SET BGPN1=$$DEPSCR^BGP8D25(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^BGP8D25(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^BGP8UTL(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^BGP8UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPNS)
+14 ;
IAAX ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
I014 ;EP
+1 IF BGPAGEB<2
SET BGPSKIP=1
QUIT
+2 IF BGPAGEB>15
SET BGPSKIP=1
QUIT
+3 ;I 'BGPLDS S BGPSKIP=1 Q ;never had a sealant
SET BGPLDS=$$SEAL(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+4 SET D=$PIECE($$DENTSRV^BGP8D21(DFN,$$DOB^AUPNPAT(DFN),BGPED,1),U,2)
+5 ;S D=$P($$DENTSRV(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE),U,1)
+6 SET BGPS=""
+7 ;dental exam less than 6 months ago
IF D]""
IF $$FMDIFF^XLFDT(BGPEDATE,D)<180
SET BGPSKIP=1
QUIT
+8 IF D]""
IF $$FMDIFF^XLFDT(BGPEDATE,D)>180
SET BGPS="May be overdue: Patient is overdue for dental|exam and assessment for additional sealants.|Refer to Dental Program."
+9 IF D=""
SET BGPS="May be overdue: Patient is overdue for dental|exam and assessment for additional sealants.|Refer to Dental Program."
+10 IF 'BGPLDS
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: Never"_"|"_BGPS
QUIT
+11 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Dental Sealant: "_$$DATE^BGP8UTL(BGPLDS)_"|"_BGPS
+12 QUIT
SEAL(P,BDATE,EDATE) ;
+1 NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,LAST
+2 KILL BGPG,BGPX
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET BGPC=0
SET LAST=""
+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
IF A'=1353
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 SET LAST=$PIECE(^TMP($JOB,"A",X),U,1)
+17 QUIT
End DoDot:3
End DoDot:2
+18 ;had ADA codes so skip cpts
IF G
QUIT
+19 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+20 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+21 IF 'A
QUIT
+22 SET A=$PIECE($$CPT^ICPTCOD(A),U,2)
IF A="D1351"!(A="D1352")!(A="D1353")
Begin DoDot:3
+23 SET T=$PIECE($GET(^AUPNVCPT(Y,0)),U,16)
IF T=""!(T=0)
SET T=1
+24 SET BGPX("CPT")=$GET(BGPX("CPT"))+T
+25 SET LAST=$PIECE(^TMP($JOB,"A",X),U,1)
End DoDot:3
End DoDot:2
End DoDot:1
+26 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))
+27 SET BGPC=BGPC+$GET(BGPX("CPT"))
+28 QUIT LAST
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^BGP8UTL1(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<1
SET BGPSKIP=1
QUIT
+2 IF BGPAGEB>15
SET BGPSKIP=1
QUIT
+3 ;I 'BGPLDS S BGPSKIP=1 Q ;never had a TF
SET BGPLDS=$$TF(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+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|May be overdue: Apply topical fluoride or refer|to Dental Program for assessment."
QUIT
+8 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Topical Fluoride: "_$$DATE^BGP8UTL(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^BGP8UTL2(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^BGP8UTL2(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<13
SET BGPSKIP=1
QUIT
+4 IF BGPAGEB>46
SET BGPSKIP=1
QUIT
+5 SET (BGPD,BGPN,BGPN1,BGPREF,BGPNS,BGPVA)=""
+6 SET BGPN1=$$DVEX^BGP8D5(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
+7 SET BGPD=$PIECE(BGPN1,U,2)
SET BGPVA=$PIECE(BGPN1,U,3)
+8 SET BGPN1=$$DVDX^BGP8D5(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^BGP8D5(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^BGP8UTL(BGPBD)
DO I021X
QUIT
+14 IF BGPNS>BGPED
SET BGPSKIP=1
DO I021X
QUIT
+15 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last DV Screen: "_$$DATE^BGP8UTL(BGPD)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPNS)
I021X ;
+1 KILL BGPD,BGPN,BGPN1,BGPREF,BGPNS
+2 QUIT
IE2 ;EP
+1 KILL BGPSTOP
+2 SET BGPISSO=1
+3 DO IE2^BGP8D8
+4 IF $DATA(BGPSTOP)
SET BGPSKIP=1
QUIT
+5 SET BGPISSV=""
+6 IF BGPN16
SET BGPSKIP=1
QUIT
+7 ;13-64 WITH NO HIV
IF 'BGPD2
SET BGPSKIP=1
QUIT
+8 SET BGPISSV=BGPISSV_$$TITLE(BGPGPRAI)
+9 IF 'BGPN1
SET $PIECE(BGPISSV,U,2)="Overdue as of: "_$$DATE^BGP8UTL(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
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^BGP8D6(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,BGPAGEE)
+9 IF $PIECE(BGPBMI,U)=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last BMI: Never|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
DO I031AX
QUIT
+10 IF $$FMADD^XLFDT($PIECE(BGPBMI,U,2),365)<BGPED
SET BGPIN1=1
+11 SET BGPOW=$$OW^BGP8D6(DFN,$PIECE(BGPBMI,U),$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2)))
IF BGPOW
SET BGPN1=1
+12 SET BGPOB=$$OB^BGP8D6(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^BGP8UTL($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^BGP8UTL($$FMADD^XLFDT($PIECE(BGPBMI,U,2),365))
I031AX ;
+1 KILL BGPBMIH,BGPBMI,BGPOW,BGPOB,BGPD1
+2 QUIT
TITLE(I) ;EP
+1 QUIT $PIECE($GET(^BGPINDRC(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^BGP8UTL(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^BGP8UTL(DT)
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Infant Feeding Choice Screening: "_$$DATE^BGP8UTL($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
MH ;EP
+1 KILL BGPSTOP
+2 NEW BGPBP,BGPN1
+3 SET BGPN1=0
+4 IF BGPAGEE<18
SET BGPSKIP=1
QUIT
+5 IF BGPAGEE>85
SET BGPSKIP=1
QUIT
+6 ;esrd anytime before end date
IF $$ESRD^BGP8D211(DFN,$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
SET BGPSKIP=1
QUIT
+7 ;V17.1 CMI/LAB ADDED DATES FOR CURRENTLY PREGNANT
SET X=$$PREG^BGP8D7(DFN,BGPBDATE,BGPEDATE,1,1,,BGPBDATE,BGPEDATE)
IF X
SET BGPSKIP=1
QUIT
+8 ;no htn per definition
IF '$$MHHTN^BGP8D9(DFN,BGPBDATE,BGPEDATE)
SET BGPSKIP=1
QUIT
+9 SET BGPBP=$$LASTBP^BGP8D9(DFN,BGPBDATE,BGPEDATE)
+10 IF BGPBP]""
Begin DoDot:1
+11 SET X=BGPBP
+12 IF $PIECE(X,"/",1)<140
IF $PIECE(X,"/",2)<90
SET BGPN1=1
End DoDot:1
+13 NEW BGPV,BGPD,BGPND
+14 SET (BGPISSV,BGPIN)=""
+15 KILL BGPISSV
+16 ;
+17 IF BGPBP=""
SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: 2 BPs not documented "_$$DATE^BGP8UTL(BGPBD)_"-"_$$DATE^BGP8UTL(BGPED)_"|Overdue as of: "_$$DATE^BGP8UTL(BGPBD)
QUIT
+18 ;in control BP in report period, do not display
IF BGPN1
SET BGPSKIP=1
QUIT
+19 SET BGPISSV=$$TITLE(BGPGPRAI)_U_"Last Mean BPs: "_$PIECE(BGPBP,U)
+20 IF 'BGPN1
SET BGPISSV=BGPISSV_" - Not Controlled BP"
+21 QUIT
