BUDARP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
ADOLWT ;EP - called from xbdbque
;must have DOB between 1/1/06 and 12/31/06
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDX27RB=($E(BUDBD,1,3)-17)_"0101"
S BUDX2RB=($E(BUDED,1,3)-2)_"1231"
S BUD3RB=($E(BUDED,1,3)-3)_"1231"
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD3BD=$E(BUDDOB,1,3)+3_$E(BUDDOB,4,7)
Q:BUD3BD>BUDED
S BUDX27BD=$E(BUDDOB,1,3)+17_$E(BUDDOB,4,7)
Q:$$AGE^AUPNPAT(DFN,BUDED)>17
Q:BUDMEDV<1
S BUDX27TH=$E(BUDDOB,1,3)+17_$E(BUDDOB,4,7)
I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUDX27TH,-1)) Q
K BUDPAP
;S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
Q:$$PREG^BUDARP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
S BUDPAP=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)
Q:BUDPAP="REF"
S G=0 F X=1:1:3 I $P(BUDPAP,U,X)]"" S G=G+1
I G=3 S BUDSECTE("AWT")=$G(BUDSECTE("AWT"))+1
;put the rest in demoninator
S BUDSECTE("PTS")=$G(BUDSECTE("PTS"))+1 D
.I $G(BUDWAC2L) D
..I G'=3 S ^XTMP("BUDARP6B",BUDJ,BUDH,"WAC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDPAP
.I $G(BUDWAC1L) D
..I G=3 S ^XTMP("BUDARP6B",BUDJ,BUDH,"WAC1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDPAP
Q
;
;
VBBD(P,BDATE,EDATE) ;EP
NEW BUDVL,G
K BUDVL
S G=""
S A="BUDVL(",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BUDVL) Q ""
S X=0 F S X=$O(BUDVL(X)) Q:X'=+X S V=$P(BUDVL(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:'$D(^AUPNVPOV("AD",V))
.S L=$P(^AUPNVSIT(V,0),U,6)
.Q:L=""
.Q:'$D(^BUDQSITE(BUDSITE,11,L)) ;not valid location
.Q:$P(^AUPNVSIT(V,0),U,7)="C"
.Q:$P(^AUPNVSIT(V,0),U,7)="T"
.Q:$P(^AUPNVSIT(V,0),U,7)="N"
.Q:$P(^AUPNVSIT(V,0),U,7)="D"
.Q:$P(^AUPNVSIT(V,0),U,7)="X"
.Q:$P(^AUPNVSIT(V,0),U,7)="E"
.S G=V
.Q
Q G
;
BMINPA(P,BDATE,EDATE,AGE) ;EP
NEW %,W,H,B,D,%DT,RETVAL,BUDBMI,BUDNE,BUDPA
S BUDBMI=$$BMI(P,BDATE,EDATE,AGE)
I BUDBMI="" S BUDBMI=$$BMIPROC(P,BDATE,EDATE)
I BUDBMI="" I $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV)) Q "REF"
S BUDNE=$$NUTR(P,BDATE,EDATE)
S BUDPA=$$PA(P,BDATE,EDATE)
Q BUDBMI_U_BUDNE_U_BUDPA
BMIPROC(P,BDATE,EDATE) ;EP
NEW A
S A=$$LASTDX^BUDAUTL1(P,"BUD BMI PROCS",BDATE,EDATE)
I A Q "POV "_$P(A,U,2)
Q ""
REF(P,BDATE,EDATE) ;EP
NEW H,W
S H=$$REFRNU^BUDAUTL1(P,9999999.07,$O(^AUTTMSR("B","HT",0)),BDATE,EDATE)
I H="" Q 1
S W=$$REFRNU^BUDAUTL1(P,9999999.07,$O(^AUTTMSR("B","WT",0)),BDATE,EDATE)
I W="" Q 1
Q ""
BMI(P,BDATE,EDATE,AGE) ;EP
NEW HDATE,BUDBMIH,W,H,X
S BUDBMIH=""
I AGE>18,AGE<51 D Q BUDBMIH
.S HDATE=$$FMADD^XLFDT(BDATE,-(5*365)),HDATE=$$FMTE^XLFDT(HDATE)
.;S BDATE=$$FMADD^XLFDT(BDATE,-(5*365))
.S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S W=$P($$WT(P,BDATE,EDATE),U,1) I W=""!(W="?") Q
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),BUDBMIH=(W/H)
I AGE>50 D Q BUDBMIH
.S HDATE=$$FMADD^XLFDT(BDATE,-(2*365)),HDATE=$$FMTE^XLFDT(HDATE)
.S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S W=$P($$WT(P,BDATE,EDATE),U,1) I W=""!(W="?") Q
.S HDATE=BDATE
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),BUDBMIH=(W/H)
I AGE<19 D Q BUDBMIH
.S X=$$HTWTSD(P,BDATE,EDATE)
.I '$P(X,"^") Q
.I '$P(X,"^",2) Q
.S W=$P(X,"^"),H=$P(X,"^",2)
.S W=W*.45359,H=(H*.0254),H=(H*H),BUDBMIH=(W/H)
.Q
Q ""
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,BUDARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDARRY(") S H=$P($G(BUDARRY(1)),U,2)
I H="" Q H
I H["?" Q ""
S H=$J(H,2,0)
Q H
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,BUDLW,X,BUDLN,BUDL,BUDLD,BUDLZ,BUDLX,ICD
K BUDL S BUDLW="" S BUDLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BUDLX,"BUDL(")
S BUDLN=0 F S BUDLN=$O(BUDL(BUDLN)) Q:BUDLN'=+BUDLN!(BUDLW]"") D
.S BUDLZ=$P(BUDL(BUDLN),U,5)
.I '$D(^AUPNVPOV("AD",BUDLZ)) S BUDLW=$P(BUDL(BUDLN),U,2) Q
. S BUDLD=0 F S BUDLD=$O(^AUPNVPOV("AD",BUDLZ,BUDLD)) Q:'BUDLD!(BUDLW]"") D
.. S D=$P(BUDL(BUDLN),U)
.. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BUDLD,0),U),D),U,2) D
...I $E(ICD,1,3)="V22" Q
...I $E(ICD,1,3)="V23" Q
...I $E(ICD,1,3)="V27" Q
...I $E(ICD,1,3)="V28" Q
...I ICD>629.9999&(ICD<676.95) Q
...I ICD>61.49&(ICD<61.71) Q
...S BUDLW=$P(BUDL(BUDLN),U,2)
..Q
Q BUDLW
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
KILL BUDLWTS,BUDLHTS,%,X,BUDLWTS1,BUDLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDLHTS(")
S Y=0 F S Y=$O(BUDLHTS(Y)) Q:Y'=+Y I $P(BUDLHTS(Y),U,2)="?"!($P(BUDLHTS(Y),U,2)="") K BUDLHTS(Y)
;set the array up by date
K BUDLHTS1 S X=0 F S X=$O(BUDLHTS(X)) Q:X'=+X S BUDLHTS1($P(BUDLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDLWTS(")
S Y=0 F S Y=$O(BUDLWTS(Y)) Q:Y'=+Y I $P(BUDLWTS(Y),U,2)="?"!($P(BUDLWTS(Y),U,2)="") K BUDLWTS(Y)
;set the array up by date
K BUDLWTS1 S X=0 F S X=$O(BUDLWTS(X)) Q:X'=+X S BUDLWTS1($P(BUDLWTS(X),U))=X
S BUDLCHT="",X=9999999 F S X=$O(BUDLWTS1(X),-1) Q:X=""!(BUDLCHT]"") I $D(BUDLHTS1(X)) S BUDLCHT=$P(BUDLWTS(BUDLWTS1(X)),U,2)_U_$P(BUDLHTS(BUDLHTS1(X)),U,2)
Q BUDLCHT
;
NUTR(P,BDATE,EDATE) ;EP
NEW BUDALLED,BUDG,X,E,%,D,T,Y
S Y="BUDALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S (X,D)=0,%="",T="" F S X=$O(BUDALLED(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BUDALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-",2)="N"!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT") S %=T Q
.I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804") S %=T Q
I %]"" Q %
S T=$O(^ATXAX("B","BUD NUTRITION CPT",0))
S %=$$CPT^BUDADU(P,BDATE,EDATE,T,5)
I %]"" Q "CPT: "_$P(%,U,2)
Q ""
PA(P,BDATE,EDATE) ;EP
NEW BUDALLED,BUDG,X,E,%,D,T,Y
K BUDG S X=P_"^LAST DX V65.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
I $D(BUDG(1)) Q "POV V65.41"
S Y="BUDALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BUDALLED(1)) Q ""
S (X,D)=0,%="",T="" F S X=$O(BUDALLED(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BUDALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-",2)="EX" S %=T Q
.I $P(T,"-",1)="V65.41" S %=T Q
Q %
ADULT ;EP
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDX28RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDX28RB
Q:BUDMEDV<1
S BUDX28TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD(DFN,$$FMADD^XLFDT(BUDX28TH,1),BUDED) Q ;quit if no visiT AFTER 18TH BIRTHDAY
;HAD V66.7 WITHIN 6 MONTHS BEFORE LAST VISIT DATE
Q:$$LASTDX^BUDAUTL1(DFN,"V66.7",$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV))
K BUDBMI,BUDOW,BUDUW
S (BUDBMI,BUDOW,BUDUW,BUDPLAN)=""
;S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
Q:$$PREG^BUDARP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
S BUDBMI=$$BMI(DFN,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV),BUDAGE)
;I BUDBMI="" I $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV)) Q
I BUDBMI="" S BUDPLAN=$$PLAN(DFN,BUDBD,BUDED) I BUDPLAN]"" S G=0 S ^XTMP("BUDARP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDBMI_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN Q ;NO BMI
I BUDBMI="" Q
I BUDAGE<65 D G N
.I BUDBMI>25 S BUDOW="OW"
.I BUDBMI<18.5 S BUDUW="UW"
I BUDBMI'<30 S BUDOW="OW"
I BUDBMI<22 S BUDUW="UW"
;put the rest in demoninator
N I BUDOW="",BUDUW="" Q ;not over/underweight & HAD BMI
S BUDWTDT=$$BMI^BUDARP6R(DFN,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV),BUDAGE)
S BUDPLAN=$$PLAN(DFN,BUDWTDT,BUDED)
S G=0
I BUDPLAN]"" S G=1,BUDSECTF("PLAN")=$G(BUDSECTF("PLAN"))+1
;put the rest in demoninator
S BUDSECTF("PTS")=$G(BUDSECTF("PTS"))+1 D
.I $G(BUDAWS2L) D
..I 'G S ^XTMP("BUDARP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDBMI_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
.I $G(BUDAWS1L) D
..I G S ^XTMP("BUDARP6B",BUDJ,BUDH,"AWS1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDBMI_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
Q
;
PLAN(P,BD,ED) ;
NEW G,Y,X,E,T,%,Z,BUDALLED
;S BD=D,ED=D
;check for cpt codes
S G=$$CPT^BUDAUTL1(P,BD,ED,$O(^ATXAX("B","BUD WT PLAN CPTS",0)),5)
I G]"" Q $P(G,U,2)_" on "_$$FMTE^XLFDT($P(G,U,1))
S G=$$LASTDX^BUDAUTL1(P,"BUD WT PLAN DXS",BD,ED)
I G Q $P(G,U,2)_" on "_$$FMTE^XLFDT($P(G,U,3))
K BUDALLED
S Y="BUDALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,Y)
S (X,D)=0,%="",T="" F S X=$O(BUDALLED(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BUDALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.S E=$P(BUDALLED(X),U,1)
.I $P(T,"-",2)="EX"!($P(T,"-",2)="LA")!($P(T,"-",2)="N")!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT") S %=T_U_E Q
.I $P(T,"-",1)="OBS"!($P(T,"-",1)="V65.3")!($P(T,"-",1)="V65.41")!($P(T,"-",1)="278.00")!($P(T,"-",1)="278.01") S %=T_U_E Q
I %]"" Q $P(%,U,1)_" on "_$$FMTE^XLFDT($P(%,U,2))
;now check for a clinic or provider visit
NEW BUDG,W,R
K BUDG
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(%,"BUDG(")
S (X,Y,D)="" F S X=$O(BUDG(X)) Q:X'=+X!(Y) D
.S Z=0 F S Z=$O(^AUPNVPRV("AD",$P(BUDG(X),U,5),Z)) Q:Z'=+Z!(Y) D
..S W=$P($G(^AUPNVPRV(Z,0)),U,1)
..Q:W=""
..S R=$$VALI^XBDIQ1(200,W,53.5)
..I R="" Q
..S R=$P($G(^DIC(7,R,9999999)),U,1)
..I R="07"!(R=29) S Y=1,D="Provider "_R_" on "_$$FMTE^XLFDT($P(BUDG(X),U)) Q
..S R=$$CLINIC^APCLV($P(BUDG(X),U,5),"C") I R=67!(R=36) S Y=1,D="Clinic "_R_" on "_$$FMTE^XLFDT($P(BUDG(X),U)) Q
I Y Q D
Q ""
G1 ;EP
NEW BUDGOT
S BUDGOT=""
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDX28RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDX28RB
Q:BUDMEDV<1
S BUDX28TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD(DFN,$$FMADD^XLFDT(BUDX28TH,1),BUDED) Q
S X=$$GETV^BUDARP6U(DFN,BUDDOB,BUDED,BUDSITE)
Q:X<2
K BUDTOBS,BUDTOBD
S BUDTOBDD=$E(BUDBD,1,3)-1_$E(BUDBD,4,7)
S BUDTOBS=$$TOBACCO(DFN,$$DOB^AUPNPAT(DFN),BUDED)
I BUDTOBS]"",$P(BUDTOBS,U,3)'<BUDTOBDD S BUDSECG1("ABM")=$G(BUDSECG1("ABM"))+1,BUDGOT=1
;put the rest in demoninator
S BUDSECG1("PTS")=$G(BUDSECG1("PTS"))+1 D
.I $G(BUDTUA2L) D
..I 'BUDGOT S ^XTMP("BUDARP6B",BUDJ,BUDH,"TUA2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS
.I $G(BUDTUA1L) D
..I BUDGOT S ^XTMP("BUDARP6B",BUDJ,BUDH,"TUA1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS
Q
;
TOBACCO(P,BDATE,EDATE) ;
;TOBACCO SCREENING IN DATE RANGE?
NEW BUDTOB,BUDX,BUDPV,BUDLAST
K BUDLAST
D TOBACCO1
I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
;PATIENT ED
S BUDTOB=$$TOBPED(P,BDATE,EDATE)
I BUDTOB]"" S X=$P(BUDTOB,U,3),BUDLAST(X)=BUDTOB
S BUDPV=$$LASTDX^BUDAUTL1(P,"BUD TOBACCO SCREEN DXS",BDATE,EDATE)
I BUDPV S BUDLAST($P(BUDPV,U,3))=$P(BUDPV,U,2)_U_$$FMTE^XLFDT($P(BUDPV,U,3))_U_$P(BUDPV,U,3) ; Q BUDTOB
S BUDCPT=$$CPT^BUDAUTL1(P,BDATE,EDATE,$O(^ATXAX("B","BUD TOBACCO SCREEN CPTS",0)),7)
I BUDCPT]"" S BUDLAST($P(BUDCPT,U,3))=BUDCPT ;S BUDTOB=BUDCPT Q BUDTOB
I '$D(BUDLAST) Q ""
S BUDX=0 F S BUDX=$O(BUDLAST(BUDX)) Q:BUDX'=+BUDX S BUDTOB=BUDX
Q BUDLAST(BUDTOB)
TOBACCO1 ;
K BUDTOB
S BUDTOB=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE) K O,D,H
I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
S BUDTOB=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE) K O,D,H
I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
S BUDTOB=$$LASTHF(P,"TOBACCO (EXPOSURE)",BDATE,EDATE) K O,D,H
I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
S BUDTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE) K O,D,H
I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
Q
TOBACCO0 ;
S (X,Y)=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y) I $$VAL^XBDIQ1(9999999.64,X,.03)="TOBACCO" S Y=X
Q:'Y
S E=$O(^AUPNHF("AA",P,Y,0)) Q:'E
I (9999999-E)>EDATE Q
I (9999999-E)<BDATE Q
S Y=$P(^AUTTHF(Y,0),U)
S BUDTOB=Y_"^"_$$FMTE^XLFDT(9999999-E)_"^"_(9999999-E)
K Y,E,X
Q
;
LASTHF(P,C,BDATE,EDATE) ;EP
S C=$O(^AUTTHF("B",C,0))
I '$G(C) Q ""
S (H,D)=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
.Q:'$D(^AUPNVHF("AA",P,H))
.S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
..Q:(9999999-D)>EDATE
..Q:(9999999-D)<BDATE
..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
.Q
S D=$O(O(0))
I D="" Q D
Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$FMTE^XLFDT(9999999-D)_"^"_(9999999-D)
;
TOBPED(P,BDATE,EDATE) ;EP
NEW Y,X,E,D,T,%,BUDG,BUDPED
K BUDPED
S Y="BUDG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BUDG) Q ""
S (X,D)=0,%="",T="" F S X=$O(BUDG(X)) Q:X'=+X D
.S T=$P(^AUPNVPED(+$P(BUDG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-")="TO" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-",2)="TO" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-",2)="SHS" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="305.1" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.00" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.01" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.02" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.03" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.04" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="V15.82" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1034F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1035F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1036F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1000F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
I '$D(BUDPED) Q ""
S X=0 F S X=$O(BUDPED(X)) Q:X'=+X S %=X
Q BUDPED(%)
G2 ;
D G2^BUDARP6U
Q
BUDARP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
ADOLWT ;EP - called from xbdbque
+1 ;must have DOB between 1/1/06 and 12/31/06
+2 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+3 SET BUDX27RB=($EXTRACT(BUDBD,1,3)-17)_"0101"
+4 SET BUDX2RB=($EXTRACT(BUDED,1,3)-2)_"1231"
+5 SET BUD3RB=($EXTRACT(BUDED,1,3)-3)_"1231"
+6 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+7 SET BUD3BD=$EXTRACT(BUDDOB,1,3)+3_$EXTRACT(BUDDOB,4,7)
+8 IF BUD3BD>BUDED
QUIT
+9 SET BUDX27BD=$EXTRACT(BUDDOB,1,3)+17_$EXTRACT(BUDDOB,4,7)
+10 IF $$AGE^AUPNPAT(DFN,BUDED)>17
QUIT
+11 IF BUDMEDV<1
QUIT
+12 SET BUDX27TH=$EXTRACT(BUDDOB,1,3)+17_$EXTRACT(BUDDOB,4,7)
+13 IF '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUDX27TH,-1))
QUIT
+14 KILL BUDPAP
+15 ;S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
+16 IF $$PREG^BUDARP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
QUIT
+17 SET BUDPAP=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)
+18 IF BUDPAP="REF"
QUIT
+19 SET G=0
FOR X=1:1:3
IF $PIECE(BUDPAP,U,X)]""
SET G=G+1
+20 IF G=3
SET BUDSECTE("AWT")=$GET(BUDSECTE("AWT"))+1
+21 ;put the rest in demoninator
+22 SET BUDSECTE("PTS")=$GET(BUDSECTE("PTS"))+1
Begin DoDot:1
+23 IF $GET(BUDWAC2L)
Begin DoDot:2
+24 IF G'=3
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"WAC2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDPAP
End DoDot:2
+25 IF $GET(BUDWAC1L)
Begin DoDot:2
+26 IF G=3
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"WAC1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDPAP
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
+29 ;
VBBD(P,BDATE,EDATE) ;EP
+1 NEW BUDVL,G
+2 KILL BUDVL
+3 SET G=""
+4 SET A="BUDVL("
SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(BUDVL)
QUIT ""
+6 SET X=0
FOR
SET X=$ORDER(BUDVL(X))
IF X'=+X
QUIT
SET V=$PIECE(BUDVL(X),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+11 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+12 SET L=$PIECE(^AUPNVSIT(V,0),U,6)
+13 IF L=""
QUIT
+14 ;not valid location
IF '$DATA(^BUDQSITE(BUDSITE,11,L))
QUIT
+15 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+16 IF $PIECE(^AUPNVSIT(V,0),U,7)="T"
QUIT
+17 IF $PIECE(^AUPNVSIT(V,0),U,7)="N"
QUIT
+18 IF $PIECE(^AUPNVSIT(V,0),U,7)="D"
QUIT
+19 IF $PIECE(^AUPNVSIT(V,0),U,7)="X"
QUIT
+20 IF $PIECE(^AUPNVSIT(V,0),U,7)="E"
QUIT
+21 SET G=V
+22 QUIT
End DoDot:1
+23 QUIT G
+24 ;
BMINPA(P,BDATE,EDATE,AGE) ;EP
+1 NEW %,W,H,B,D,%DT,RETVAL,BUDBMI,BUDNE,BUDPA
+2 SET BUDBMI=$$BMI(P,BDATE,EDATE,AGE)
+3 IF BUDBMI=""
SET BUDBMI=$$BMIPROC(P,BDATE,EDATE)
+4 IF BUDBMI=""
IF $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV))
QUIT "REF"
+5 SET BUDNE=$$NUTR(P,BDATE,EDATE)
+6 SET BUDPA=$$PA(P,BDATE,EDATE)
+7 QUIT BUDBMI_U_BUDNE_U_BUDPA
BMIPROC(P,BDATE,EDATE) ;EP
+1 NEW A
+2 SET A=$$LASTDX^BUDAUTL1(P,"BUD BMI PROCS",BDATE,EDATE)
+3 IF A
QUIT "POV "_$PIECE(A,U,2)
+4 QUIT ""
REF(P,BDATE,EDATE) ;EP
+1 NEW H,W
+2 SET H=$$REFRNU^BUDAUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","HT",0)),BDATE,EDATE)
+3 IF H=""
QUIT 1
+4 SET W=$$REFRNU^BUDAUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","WT",0)),BDATE,EDATE)
+5 IF W=""
QUIT 1
+6 QUIT ""
BMI(P,BDATE,EDATE,AGE) ;EP
+1 NEW HDATE,BUDBMIH,W,H,X
+2 SET BUDBMIH=""
+3 IF AGE>18
IF AGE<51
Begin DoDot:1
+4 SET HDATE=$$FMADD^XLFDT(BDATE,-(5*365))
SET HDATE=$$FMTE^XLFDT(HDATE)
+5 ;S BDATE=$$FMADD^XLFDT(BDATE,-(5*365))
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+7 SET W=$PIECE($$WT(P,BDATE,EDATE),U,1)
IF W=""!(W="?")
QUIT
+8 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+9 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BUDBMIH=(W/H)
End DoDot:1
QUIT BUDBMIH
+10 IF AGE>50
Begin DoDot:1
+11 SET HDATE=$$FMADD^XLFDT(BDATE,-(2*365))
SET HDATE=$$FMTE^XLFDT(HDATE)
+12 SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+13 SET W=$PIECE($$WT(P,BDATE,EDATE),U,1)
IF W=""!(W="?")
QUIT
+14 SET HDATE=BDATE
+15 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+16 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BUDBMIH=(W/H)
End DoDot:1
QUIT BUDBMIH
+17 IF AGE<19
Begin DoDot:1
+18 SET X=$$HTWTSD(P,BDATE,EDATE)
+19 IF '$PIECE(X,"^")
QUIT
+20 IF '$PIECE(X,"^",2)
QUIT
+21 SET W=$PIECE(X,"^")
SET H=$PIECE(X,"^",2)
+22 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BUDBMIH=(W/H)
+23 QUIT
End DoDot:1
QUIT BUDBMIH
+24 QUIT ""
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,BUDARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDARRY(")
SET H=$PIECE($GET(BUDARRY(1)),U,2)
+4 IF H=""
QUIT H
+5 IF H["?"
QUIT ""
+6 SET H=$JUSTIFY(H,2,0)
+7 QUIT H
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,BUDLW,X,BUDLN,BUDL,BUDLD,BUDLZ,BUDLX,ICD
+3 KILL BUDL
SET BUDLW=""
SET BUDLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BUDLX,"BUDL(")
+4 SET BUDLN=0
FOR
SET BUDLN=$ORDER(BUDL(BUDLN))
IF BUDLN'=+BUDLN!(BUDLW]"")
QUIT
Begin DoDot:1
+5 SET BUDLZ=$PIECE(BUDL(BUDLN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",BUDLZ))
SET BUDLW=$PIECE(BUDL(BUDLN),U,2)
QUIT
+7 SET BUDLD=0
FOR
SET BUDLD=$ORDER(^AUPNVPOV("AD",BUDLZ,BUDLD))
IF 'BUDLD!(BUDLW]"")
QUIT
Begin DoDot:2
+8 SET D=$PIECE(BUDL(BUDLN),U)
+9 SET ICD=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVPOV(BUDLD,0),U),D),U,2)
Begin DoDot:3
+10 IF $EXTRACT(ICD,1,3)="V22"
QUIT
+11 IF $EXTRACT(ICD,1,3)="V23"
QUIT
+12 IF $EXTRACT(ICD,1,3)="V27"
QUIT
+13 IF $EXTRACT(ICD,1,3)="V28"
QUIT
+14 IF ICD>629.9999&(ICD<676.95)
QUIT
+15 IF ICD>61.49&(ICD<61.71)
QUIT
+16 SET BUDLW=$PIECE(BUDL(BUDLN),U,2)
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT BUDLW
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 KILL BUDLWTS,BUDLHTS,%,X,BUDLWTS1,BUDLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDLHTS(")
+5 SET Y=0
FOR
SET Y=$ORDER(BUDLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BUDLHTS(Y),U,2)="?"!($PIECE(BUDLHTS(Y),U,2)="")
KILL BUDLHTS(Y)
+6 ;set the array up by date
+7 KILL BUDLHTS1
SET X=0
FOR
SET X=$ORDER(BUDLHTS(X))
IF X'=+X
QUIT
SET BUDLHTS1($PIECE(BUDLHTS(X),U))=X
+8 ;get all wts during time frame
+9 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDLWTS(")
+10 SET Y=0
FOR
SET Y=$ORDER(BUDLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BUDLWTS(Y),U,2)="?"!($PIECE(BUDLWTS(Y),U,2)="")
KILL BUDLWTS(Y)
+11 ;set the array up by date
+12 KILL BUDLWTS1
SET X=0
FOR
SET X=$ORDER(BUDLWTS(X))
IF X'=+X
QUIT
SET BUDLWTS1($PIECE(BUDLWTS(X),U))=X
+13 SET BUDLCHT=""
SET X=9999999
FOR
SET X=$ORDER(BUDLWTS1(X),-1)
IF X=""!(BUDLCHT]"")
QUIT
IF $DATA(BUDLHTS1(X))
SET BUDLCHT=$PIECE(BUDLWTS(BUDLWTS1(X)),U,2)_U_$PIECE(BUDLHTS(BUDLHTS1(X)),U,2)
+14 QUIT BUDLCHT
+15 ;
NUTR(P,BDATE,EDATE) ;EP
+1 NEW BUDALLED,BUDG,X,E,%,D,T,Y
+2 SET Y="BUDALLED("
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+5 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDALLED(X),U,4),0),U)
+6 IF 'T
QUIT
+7 IF '$DATA(^AUTTEDT(T,0))
QUIT
+8 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+9 IF $PIECE(T,"-",2)="N"!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")
SET %=T
QUIT
+10 IF $PIECE(T,"-",1)="97802"!($PIECE(T,"-",1)="97803")!($PIECE(T,"-",1)="97804")
SET %=T
QUIT
End DoDot:1
+11 IF %]""
QUIT %
+12 SET T=$ORDER(^ATXAX("B","BUD NUTRITION CPT",0))
+13 SET %=$$CPT^BUDADU(P,BDATE,EDATE,T,5)
+14 IF %]""
QUIT "CPT: "_$PIECE(%,U,2)
+15 QUIT ""
PA(P,BDATE,EDATE) ;EP
+1 NEW BUDALLED,BUDG,X,E,%,D,T,Y
+2 KILL BUDG
SET X=P_"^LAST DX V65.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BUDG(")
+3 IF $DATA(BUDG(1))
QUIT "POV V65.41"
+4 SET Y="BUDALLED("
+5 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BUDALLED(1))
QUIT ""
+7 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDALLED(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $PIECE(T,"-",2)="EX"
SET %=T
QUIT
+13 IF $PIECE(T,"-",1)="V65.41"
SET %=T
QUIT
End DoDot:1
+14 QUIT %
ADULT ;EP
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUDX28RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+3 IF BUDDOB>BUDX28RB
QUIT
+4 IF BUDMEDV<1
QUIT
+5 SET BUDX28TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+6 ;quit if no visiT AFTER 18TH BIRTHDAY
IF '$$VBBD(DFN,$$FMADD^XLFDT(BUDX28TH,1),BUDED)
QUIT
+7 ;HAD V66.7 WITHIN 6 MONTHS BEFORE LAST VISIT DATE
+8 IF $$LASTDX^BUDAUTL1(DFN,"V66.7",$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV))
QUIT
+9 KILL BUDBMI,BUDOW,BUDUW
+10 SET (BUDBMI,BUDOW,BUDUW,BUDPLAN)=""
+11 ;S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
+12 IF $$PREG^BUDARP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
QUIT
+13 SET BUDBMI=$$BMI(DFN,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV),BUDAGE)
+14 ;I BUDBMI="" I $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV)) Q
+15 ;NO BMI
IF BUDBMI=""
SET BUDPLAN=$$PLAN(DFN,BUDBD,BUDED)
IF BUDPLAN]""
SET G=0
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"AWS2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDBMI_U_$SELECT(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
QUIT
+16 IF BUDBMI=""
QUIT
+17 IF BUDAGE<65
Begin DoDot:1
+18 IF BUDBMI>25
SET BUDOW="OW"
+19 IF BUDBMI<18.5
SET BUDUW="UW"
End DoDot:1
GOTO N
+20 IF BUDBMI'<30
SET BUDOW="OW"
+21 IF BUDBMI<22
SET BUDUW="UW"
+22 ;put the rest in demoninator
N ;not over/underweight & HAD BMI
IF BUDOW=""
IF BUDUW=""
QUIT
+1 SET BUDWTDT=$$BMI^BUDARP6R(DFN,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV),BUDAGE)
+2 SET BUDPLAN=$$PLAN(DFN,BUDWTDT,BUDED)
+3 SET G=0
+4 IF BUDPLAN]""
SET G=1
SET BUDSECTF("PLAN")=$GET(BUDSECTF("PLAN"))+1
+5 ;put the rest in demoninator
+6 SET BUDSECTF("PTS")=$GET(BUDSECTF("PTS"))+1
Begin DoDot:1
+7 IF $GET(BUDAWS2L)
Begin DoDot:2
+8 IF 'G
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"AWS2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDBMI_U_$SELECT(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
End DoDot:2
+9 IF $GET(BUDAWS1L)
Begin DoDot:2
+10 IF G
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"AWS1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDBMI_U_$SELECT(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
PLAN(P,BD,ED) ;
+1 NEW G,Y,X,E,T,%,Z,BUDALLED
+2 ;S BD=D,ED=D
+3 ;check for cpt codes
+4 SET G=$$CPT^BUDAUTL1(P,BD,ED,$ORDER(^ATXAX("B","BUD WT PLAN CPTS",0)),5)
+5 IF G]""
QUIT $PIECE(G,U,2)_" on "_$$FMTE^XLFDT($PIECE(G,U,1))
+6 SET G=$$LASTDX^BUDAUTL1(P,"BUD WT PLAN DXS",BD,ED)
+7 IF G
QUIT $PIECE(G,U,2)_" on "_$$FMTE^XLFDT($PIECE(G,U,3))
+8 KILL BUDALLED
+9 SET Y="BUDALLED("
+10 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(X,Y)
+11 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+12 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDALLED(X),U,4),0),U)
+13 IF 'T
QUIT
+14 IF '$DATA(^AUTTEDT(T,0))
QUIT
+15 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+16 SET E=$PIECE(BUDALLED(X),U,1)
+17 IF $PIECE(T,"-",2)="EX"!($PIECE(T,"-",2)="LA")!($PIECE(T,"-",2)="N")!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")
SET %=T_U_E
QUIT
+18 IF $PIECE(T,"-",1)="OBS"!($PIECE(T,"-",1)="V65.3")!($PIECE(T,"-",1)="V65.41")!($PIECE(T,"-",1)="278.00")!($PIECE(T,"-",1)="278.01")
SET %=T_U_E
QUIT
End DoDot:1
+19 IF %]""
QUIT $PIECE(%,U,1)_" on "_$$FMTE^XLFDT($PIECE(%,U,2))
+20 ;now check for a clinic or provider visit
+21 NEW BUDG,W,R
+22 KILL BUDG
+23 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(%,"BUDG(")
+24 SET (X,Y,D)=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+25 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRV("AD",$PIECE(BUDG(X),U,5),Z))
IF Z'=+Z!(Y)
QUIT
Begin DoDot:2
+26 SET W=$PIECE($GET(^AUPNVPRV(Z,0)),U,1)
+27 IF W=""
QUIT
+28 SET R=$$VALI^XBDIQ1(200,W,53.5)
+29 IF R=""
QUIT
+30 SET R=$PIECE($GET(^DIC(7,R,9999999)),U,1)
+31 IF R="07"!(R=29)
SET Y=1
SET D="Provider "_R_" on "_$$FMTE^XLFDT($PIECE(BUDG(X),U))
QUIT
+32 SET R=$$CLINIC^APCLV($PIECE(BUDG(X),U,5),"C")
IF R=67!(R=36)
SET Y=1
SET D="Clinic "_R_" on "_$$FMTE^XLFDT($PIECE(BUDG(X),U))
QUIT
End DoDot:2
End DoDot:1
+33 IF Y
QUIT D
+34 QUIT ""
G1 ;EP
+1 NEW BUDGOT
+2 SET BUDGOT=""
+3 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+4 SET BUDX28RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+5 IF BUDDOB>BUDX28RB
QUIT
+6 IF BUDMEDV<1
QUIT
+7 SET BUDX28TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+8 IF '$$VBBD(DFN,$$FMADD^XLFDT(BUDX28TH,1),BUDED)
QUIT
+9 SET X=$$GETV^BUDARP6U(DFN,BUDDOB,BUDED,BUDSITE)
+10 IF X<2
QUIT
+11 KILL BUDTOBS,BUDTOBD
+12 SET BUDTOBDD=$EXTRACT(BUDBD,1,3)-1_$EXTRACT(BUDBD,4,7)
+13 SET BUDTOBS=$$TOBACCO(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+14 IF BUDTOBS]""
IF $PIECE(BUDTOBS,U,3)'<BUDTOBDD
SET BUDSECG1("ABM")=$GET(BUDSECG1("ABM"))+1
SET BUDGOT=1
+15 ;put the rest in demoninator
+16 SET BUDSECG1("PTS")=$GET(BUDSECG1("PTS"))+1
Begin DoDot:1
+17 IF $GET(BUDTUA2L)
Begin DoDot:2
+18 IF 'BUDGOT
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"TUA2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS
End DoDot:2
+19 IF $GET(BUDTUA1L)
Begin DoDot:2
+20 IF BUDGOT
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"TUA1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
TOBACCO(P,BDATE,EDATE) ;
+1 ;TOBACCO SCREENING IN DATE RANGE?
+2 NEW BUDTOB,BUDX,BUDPV,BUDLAST
+3 KILL BUDLAST
+4 DO TOBACCO1
+5 IF BUDTOB]""
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+6 ;PATIENT ED
+7 SET BUDTOB=$$TOBPED(P,BDATE,EDATE)
+8 IF BUDTOB]""
SET X=$PIECE(BUDTOB,U,3)
SET BUDLAST(X)=BUDTOB
+9 SET BUDPV=$$LASTDX^BUDAUTL1(P,"BUD TOBACCO SCREEN DXS",BDATE,EDATE)
+10 ; Q BUDTOB
IF BUDPV
SET BUDLAST($PIECE(BUDPV,U,3))=$PIECE(BUDPV,U,2)_U_$$FMTE^XLFDT($PIECE(BUDPV,U,3))_U_$PIECE(BUDPV,U,3)
+11 SET BUDCPT=$$CPT^BUDAUTL1(P,BDATE,EDATE,$ORDER(^ATXAX("B","BUD TOBACCO SCREEN CPTS",0)),7)
+12 ;S BUDTOB=BUDCPT Q BUDTOB
IF BUDCPT]""
SET BUDLAST($PIECE(BUDCPT,U,3))=BUDCPT
+13 IF '$DATA(BUDLAST)
QUIT ""
+14 SET BUDX=0
FOR
SET BUDX=$ORDER(BUDLAST(BUDX))
IF BUDX'=+BUDX
QUIT
SET BUDTOB=BUDX
+15 QUIT BUDLAST(BUDTOB)
TOBACCO1 ;
+1 KILL BUDTOB
+2 SET BUDTOB=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE)
KILL O,D,H
+3 IF BUDTOB]""
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+4 SET BUDTOB=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE)
KILL O,D,H
+5 IF BUDTOB]""
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+6 SET BUDTOB=$$LASTHF(P,"TOBACCO (EXPOSURE)",BDATE,EDATE)
KILL O,D,H
+7 IF BUDTOB]""
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+8 SET BUDTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE)
KILL O,D,H
+9 IF BUDTOB]""
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+10 QUIT
TOBACCO0 ;
+1 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(Y)
QUIT
IF $$VAL^XBDIQ1(9999999.64,X,.03)="TOBACCO"
SET Y=X
+2 IF 'Y
QUIT
+3 SET E=$ORDER(^AUPNHF("AA",P,Y,0))
IF 'E
QUIT
+4 IF (9999999-E)>EDATE
QUIT
+5 IF (9999999-E)<BDATE
QUIT
+6 SET Y=$PIECE(^AUTTHF(Y,0),U)
+7 SET BUDTOB=Y_"^"_$$FMTE^XLFDT(9999999-E)_"^"_(9999999-E)
+8 KILL Y,E,X
+9 QUIT
+10 ;
LASTHF(P,C,BDATE,EDATE) ;EP
+1 SET C=$ORDER(^AUTTHF("B",C,0))
+2 IF '$GET(C)
QUIT ""
+3 SET (H,D)=0
KILL O
+4 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+6 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+7 IF (9999999-D)>EDATE
QUIT
+8 IF (9999999-D)<BDATE
QUIT
+9 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(O(0))
+12 IF D=""
QUIT D
+13 QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$FMTE^XLFDT(9999999-D)_"^"_(9999999-D)
+14 ;
TOBPED(P,BDATE,EDATE) ;EP
+1 NEW Y,X,E,D,T,%,BUDG,BUDPED
+2 KILL BUDPED
+3 SET Y="BUDG("
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BUDG)
QUIT ""
+6 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDG(X),U,4),0),U)
+8 IF 'T
QUIT
+9 IF '$DATA(^AUTTEDT(T,0))
QUIT
+10 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+11 IF $PIECE(T,"-")="TO"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+12 IF $PIECE(T,"-",2)="TO"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+13 IF $PIECE(T,"-",2)="SHS"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+14 IF $PIECE(T,"-")="305.1"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+15 IF $PIECE(T,"-")="649.00"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+16 IF $PIECE(T,"-")="649.01"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+17 IF $PIECE(T,"-")="649.02"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+18 IF $PIECE(T,"-")="649.03"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+19 IF $PIECE(T,"-")="649.04"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+20 IF $PIECE(T,"-")="V15.82"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+21 IF $PIECE(T,"-")="1034F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+22 IF $PIECE(T,"-")="1035F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+23 IF $PIECE(T,"-")="1036F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+24 IF $PIECE(T,"-")="1000F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
End DoDot:1
+25 IF '$DATA(BUDPED)
QUIT ""
+26 SET X=0
FOR
SET X=$ORDER(BUDPED(X))
IF X'=+X
QUIT
SET %=X
+27 QUIT BUDPED(%)
G2 ;
+1 DO G2^BUDARP6U
+2 QUIT
