BUDERP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
;
ADOLWT ;EP - called from xbdbque
;must have DOB between 1/1/06 and 12/31/06
NEW BUDBMI,BUDDOB,BUD17RB,BUD3RB,BUD18BD,X,G
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD17RB=($E(BUDBD,1,3)-17)_"0101" ;RERPORT PERIOD 17 BD
S BUD3RB=($E(BUDED,1,3)-3)_"1231" ;REPORT PERIOD 3 BD
Q:BUDDOB>BUD3RB
Q:BUDDOB<BUD17RB
Q:BUDMEDV<1 ;AT LEAST 1 MEDICAL VISIT
S BUD18BD=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD18BD,-1)) Q ;SEEN AT LEAST ONCE BEFORE 18TH DOB
Q:$$PREG^BUDERP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
S BUDBMI=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)
S G=0 F X=1:1:3 I $P(BUDBMI,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("BUDERP6B",BUDJ,BUDH,"WAC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI
.I $G(BUDWAC1L) D
..I G=3 S ^XTMP("BUDERP6B",BUDJ,BUDH,"WAC1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI
Q
;
;
VBBD(P,BDATE,EDATE) ;EP
NEW BUDVL,G,V,A,L
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(^BUDESITE(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=$$LASTITEM^APCLAPIU(P,"BMIP","MEASUREMENT",BDATE,EDATE,"A") I BUDBMI]"" S BUDBMI=$P(BUDBMI,U,3)_" %ile meas" ;get percentile
I BUDBMI="" S BUDBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",BDATE,EDATE,"A") I BUDBMI]"" S BUDBMI=$P(BUDBMI,U,3)_" BMI meas"
I BUDBMI="" S BUDBMI=$$BMI(P,BDATE,EDATE,AGE) I BUDBMI]"" S BUDBMI=BUDBMI_" BMI"
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 D,BUDG,E,%
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
NEW X,Y,G,T
S T=$O(^BUDETSSC("B","T6B ADOLWT BMI DIAGNOSES CODES",0))
S G=""
S X=0 F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDETSSC("AD",Y,T)) S G="POV "_$P(BUDG(X),U,2)
Q G
REF(P,BDATE,EDATE) ;EP
NEW H,W
S H=$$REFRNU^BUDEUTL1(P,9999999.07,$O(^AUTTMSR("B","HT",0)),BDATE,EDATE)
I H Q 1
S W=$$REFRNU^BUDEUTL1(P,9999999.07,$O(^AUTTMSR("B","WT",0)),BDATE,EDATE)
I W Q 1
Q ""
ADULTBMI(P,BDATE,EDATE,AGE) ;EP
NEW BUDBMI
S BUDBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",BDATE,EDATE,"A") I BUDBMI]"" S BUDBMI=$P(BUDBMI,U,3)_U_$P(BUDBMI,U)
I BUDBMI="" S BUDBMI=$$BMI(P,BDATE,EDATE,AGE) I BUDBMI]"" S BUDBMI=BUDBMI_U_$P($$WT(P,BDATE,EDATE),U,1)
Q BUDBMI
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)
.. I $$ICD^ATXAPI($P(^AUPNVPOV(BUDLD,0),U,1),$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) Q
.. S BUDLW=$P(BUDL(BUDLN),U,2)_U_$P(BUDL(BUDLN),U,1)
..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 BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDNUT
S BUDNUT=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDETSSC("B","T6B ADOLWT NUTRITION CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..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")!($P(T,"-",1)="MNT") S BUDNUT=T Q
..I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804") S BUDNUT=T Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDNUT="CPT: "_Y Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDNUT="CPT/TRAN: "_Y Q
.;SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDNUT="SNOMED: "_Y Q
I BUDNUT]"" Q BUDNUT
;CHECK PROBLEM LIST FOR SNOMED
S X=$$PLCL^BUDEDU(P,"T6B ADOLWT NUTRITION CODES",EDATE,0,BDATE) I X Q "PROBLEM SNOMED "_$P(X,U,2)
Q ""
PA(P,BDATE,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPA
S BUDPA=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDETSSC("B","T6B ADOLWT PHYSICAL ACT CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-",2)="EX"!($P(T,"-",1)="Z1.89") S BUDPA=T Q
..I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804") S BUDPA=T Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDPA="CPT: "_Y Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDPA="CPT/TRAN: "_Y Q
.;SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDETSSC("AS",Y,TIEN)) S BUDPA="SNOMED: "_Y Q
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDPA="DX "_Y Q
I BUDPA]"" Q BUDPA
;CHECK PROBLEM LIST FOR SNOMED
S X=$$PLCL^BUDEDU(P,"T6B ADOLWT PHYSICAL ACT CODES",EDATE,0,BDATE) I X Q "PROBLEM SNOMED "_$P(X,U,2)
Q ""
ADULT ;EP
NEW BUDDOB,BUDX18RB,BUDX18TH,BUDBMI,BUDOW,BUDUW,BUDPLAN,BUDBMIV,BUDBMID
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDX18RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDX18RB
Q:BUDMEDV<1
S BUDX18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD(DFN,BUDX18TH,BUDED) Q ;quit if no visiT AFTER 18TH BIRTHDAY
Q:$$PREG^BUDERP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
;REFUSAL, ETC.
;PALLIATIVE CARE
Q:$$PALL(DFN,BUDBD,BUDED) ;HAD PALLIATIVE CARE
Q:$$REF(DFN,BUDBD,BUDED) ;HAD A REFUSAL
S D=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-182)
;I D<BUDBD S D=BUDBD
S BUDBMI=$$ADULTBMI(DFN,D,$$VD^APCLV(BUDLASTV),BUDAGE)
S BUDBMIV=$P(BUDBMI,U,1)
S BUDBMID=$P(BUDBMI,U,2)
S BUDOW="",BUDUW="",BUDPLAN=""
;I BUDBMI="" S BUDPLAN=$$PLAN(DFN,BUDBD,BUDED) I BUDPLAN]"" S G=0 S ^XTMP("BUDERP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN Q ;NO BMI
I BUDBMI="" S Y=$$CPTI^BUDEDU(P,BUDBD,BUDED,$P($$CPT^ICPTCOD("3008F"),U,1)) I Y S BUDBMI="CPT: 3008F" S G=0 G D
I BUDBMI="" S G=0 G D
I BUDBMI>25 S BUDOW="OW"
I BUDBMI<18.5 S BUDUW="UW"
;put the rest in demoninator
N I BUDOW="",BUDUW="" S BUDSECTF("PLAN")=$G(BUDSECTF("PLAN"))+1 S G=1 G D ;not over/underweight & HAD BMI PUT IN NUM/DEN
S BUDPLAN=$$PLAN(DFN,$$FMADD^XLFDT(BUDBMID,-182),BUDBMID)
S G=0
I BUDPLAN]"" S G=1,BUDSECTF("PLAN")=$G(BUDSECTF("PLAN"))+1
D ;put the rest in demoninator
S BUDSECTF("PTS")=$G(BUDSECTF("PTS"))+1 D
.I $G(BUDAWS2L) D
..I 'G S ^XTMP("BUDERP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$S($P(BUDBMIV,U,1)]"":$J($P(BUDBMIV,U,1),6,2),1:"")_" "_$$DATE^BUDEUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
.I $G(BUDAWS1L) D
..I G S ^XTMP("BUDERP6B",BUDJ,BUDH,"AWS1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$S($P(BUDBMIV,U,1)]"":$J($P(BUDBMIV,U,1),6,2),1:"")_" "_$$DATE^BUDEUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
Q
;
PLAN(P,BDATE,EDATE) ;
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPL,C
S BUDPL=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDETSSC("B","T6B ADULTWT PLAN CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.S C=$$CLINIC^APCLV(VIEN,"C") I C]"",$D(^BUDETSSC(TIEN,17,"B",C)) S BUDPL="Clinic "_C_U_VDATE Q
.S X=0 F S X=$O(^AUPNVPED("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPED(X,0))
..S T=$$VALI^XBDIQ1(9000010.16,X,.01)
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-",2)="EX"!($P(T,"-",2)="LA")!($P(T,"-",2)="N")!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT") S BUDPL=T_U_VDATE 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")!($P(T,"-",1)="Z71.3") S BUDPL=T_U_VDATE Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDPL="CPT: "_Y_U_VDATE Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDETSSC("AC",Y,TIEN)) S BUDPL="CPT/TRAN: "_Y_U_VDATE Q
.;SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..I Y]"",$D(^BUDETSSC("AS",Y,TIEN)) S BUDPL="SNOMED: "_Y_U_VDATE Q
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDETSSC("AD",Y,TIEN)) S BUDPL="DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_U_VDATE Q
.;PROVIDER CODES
.S X=0 F S X=$O(^AUPNVPRV("AD",VIEN,X)) Q:X'=+X!(BUDPL]"") D
..Q:'$D(^AUPNVPRV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.06,X,.01)
..Q:Y=""
..S Y=$$PROVCLSC^XBFUNC1(Y)
..Q:Y=""
..I $D(^BUDETSSC(16,"B",Y)) S BUDPL="Prv: "_Y_U_VDATE Q
I BUDPL]"" Q BUDPL
;CHECK PROBLEM LIST FOR SNOMED
S X=$$PLCL^BUDEDU(P,"T6B ADULTWT PLAN CODES",EDATE,0,BDATE) I X Q "PROBLEM SNOMED "_$P(X,U,2)
Q ""
PALL(P,BDATE,EDATE) ;
NEW D,BUDG,E,%
S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
NEW X,Y,G,T,V,Z,A
S T=$O(^BUDETSSC("B","T6B ADULTWT PALLIATIVE CARE",0))
S G=""
S X=0 F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDETSSC("AD",Z,T)) S G=1 Q
.S Y=$$VAL^XBDIQ1(9000010.07,Y,1101)
.Q:Y=""
.I $D(^BUDETSSC("AS",Y,T)) S G=1
I G Q G
S X=$$PLCL^BUDEDU(P,"T6B ADULTWT PALLIATIVE CARE",EDATE,0,BDATE) I X Q 1 ;"PROBLEM SNOMED "_$P(X,U,2)
Q G
G ;EP
G G^BUDERP6R
BUDERP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
+3 ;
ADOLWT ;EP - called from xbdbque
+1 ;must have DOB between 1/1/06 and 12/31/06
+2 NEW BUDBMI,BUDDOB,BUD17RB,BUD3RB,BUD18BD,X,G
+3 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+4 ;RERPORT PERIOD 17 BD
SET BUD17RB=($EXTRACT(BUDBD,1,3)-17)_"0101"
+5 ;REPORT PERIOD 3 BD
SET BUD3RB=($EXTRACT(BUDED,1,3)-3)_"1231"
+6 IF BUDDOB>BUD3RB
QUIT
+7 IF BUDDOB<BUD17RB
QUIT
+8 ;AT LEAST 1 MEDICAL VISIT
IF BUDMEDV<1
QUIT
+9 SET BUD18BD=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+10 ;SEEN AT LEAST ONCE BEFORE 18TH DOB
IF '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD18BD,-1))
QUIT
+11 IF $$PREG^BUDERP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
QUIT
+12 SET BUDBMI=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)
+13 SET G=0
FOR X=1:1:3
IF $PIECE(BUDBMI,U,X)]""
SET G=G+1
+14 IF G=3
SET BUDSECTE("AWT")=$GET(BUDSECTE("AWT"))+1
+15 ;put the rest in demoninator
+16 SET BUDSECTE("PTS")=$GET(BUDSECTE("PTS"))+1
Begin DoDot:1
+17 IF $GET(BUDWAC2L)
Begin DoDot:2
+18 IF G'=3
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"WAC2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI
End DoDot:2
+19 IF $GET(BUDWAC1L)
Begin DoDot:2
+20 IF G=3
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"WAC1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
+23 ;
VBBD(P,BDATE,EDATE) ;EP
+1 NEW BUDVL,G,V,A,L
+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(^BUDESITE(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 ;get percentile
SET BUDBMI=$$LASTITEM^APCLAPIU(P,"BMIP","MEASUREMENT",BDATE,EDATE,"A")
IF BUDBMI]""
SET BUDBMI=$PIECE(BUDBMI,U,3)_" %ile meas"
+3 IF BUDBMI=""
SET BUDBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",BDATE,EDATE,"A")
IF BUDBMI]""
SET BUDBMI=$PIECE(BUDBMI,U,3)_" BMI meas"
+4 IF BUDBMI=""
SET BUDBMI=$$BMI(P,BDATE,EDATE,AGE)
IF BUDBMI]""
SET BUDBMI=BUDBMI_" BMI"
+5 IF BUDBMI=""
SET BUDBMI=$$BMIPROC(P,BDATE,EDATE)
+6 ;I BUDBMI="" I $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV)) Q "REF"
+7 SET BUDNE=$$NUTR(P,BDATE,EDATE)
+8 SET BUDPA=$$PA(P,BDATE,EDATE)
+9 QUIT BUDBMI_U_BUDNE_U_BUDPA
BMIPROC(P,BDATE,EDATE) ;EP
+1 NEW D,BUDG,E,%
+2 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 NEW X,Y,G,T
+4 SET T=$ORDER(^BUDETSSC("B","T6B ADOLWT BMI DIAGNOSES CODES",0))
+5 SET G=""
+6 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 SET Y=+$PIECE(BUDG(X),U,4)
+8 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+9 IF $DATA(^BUDETSSC("AD",Y,T))
SET G="POV "_$PIECE(BUDG(X),U,2)
End DoDot:1
+10 QUIT G
REF(P,BDATE,EDATE) ;EP
+1 NEW H,W
+2 SET H=$$REFRNU^BUDEUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","HT",0)),BDATE,EDATE)
+3 IF H
QUIT 1
+4 SET W=$$REFRNU^BUDEUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","WT",0)),BDATE,EDATE)
+5 IF W
QUIT 1
+6 QUIT ""
ADULTBMI(P,BDATE,EDATE,AGE) ;EP
+1 NEW BUDBMI
+2 SET BUDBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",BDATE,EDATE,"A")
IF BUDBMI]""
SET BUDBMI=$PIECE(BUDBMI,U,3)_U_$PIECE(BUDBMI,U)
+3 IF BUDBMI=""
SET BUDBMI=$$BMI(P,BDATE,EDATE,AGE)
IF BUDBMI]""
SET BUDBMI=BUDBMI_U_$PIECE($$WT(P,BDATE,EDATE),U,1)
+4 QUIT BUDBMI
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 IF $$ICD^ATXAPI($PIECE(^AUPNVPOV(BUDLD,0),U,1),$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)
QUIT
+10 SET BUDLW=$PIECE(BUDL(BUDLN),U,2)_U_$PIECE(BUDL(BUDLN),U,1)
+11 QUIT
End DoDot:2
End DoDot:1
+12 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 BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDNUT
+2 SET BUDNUT=""
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDETSSC("B","T6B ADOLWT NUTRITION CODES",0))
+5 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+6 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+7 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVPED(X,0))
QUIT
+10 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+11 IF '$DATA(^AUTTEDT(T,0))
QUIT
+12 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+13 IF $PIECE(T,"-",2)="N"!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")!($PIECE(T,"-",1)="MNT")
SET BUDNUT=T
QUIT
+14 IF $PIECE(T,"-",1)="97802"!($PIECE(T,"-",1)="97803")!($PIECE(T,"-",1)="97804")
SET BUDNUT=T
QUIT
End DoDot:2
+15 ;CPT
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+17 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+18 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+19 IF Y=""
QUIT
+20 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDNUT="CPT: "_Y
QUIT
End DoDot:2
+21 ;V TRANS
+22 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+23 IF '$DATA(^AUPNVTC(X,0))
QUIT
+24 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+25 IF Y=""
QUIT
+26 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDNUT="CPT/TRAN: "_Y
QUIT
End DoDot:2
+27 ;SNOMED
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+29 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+30 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+31 IF Y=""
QUIT
+32 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDNUT="SNOMED: "_Y
QUIT
End DoDot:2
End DoDot:1
+33 IF BUDNUT]""
QUIT BUDNUT
+34 ;CHECK PROBLEM LIST FOR SNOMED
+35 SET X=$$PLCL^BUDEDU(P,"T6B ADOLWT NUTRITION CODES",EDATE,0,BDATE)
IF X
QUIT "PROBLEM SNOMED "_$PIECE(X,U,2)
+36 QUIT ""
PA(P,BDATE,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPA
+2 SET BUDPA=""
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDETSSC("B","T6B ADOLWT PHYSICAL ACT CODES",0))
+5 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+6 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+7 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+9 IF '$DATA(^AUPNVPED(X,0))
QUIT
+10 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+11 IF '$DATA(^AUTTEDT(T,0))
QUIT
+12 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+13 IF $PIECE(T,"-",2)="EX"!($PIECE(T,"-",1)="Z1.89")
SET BUDPA=T
QUIT
+14 IF $PIECE(T,"-",1)="97802"!($PIECE(T,"-",1)="97803")!($PIECE(T,"-",1)="97804")
SET BUDPA=T
QUIT
End DoDot:2
+15 ;CPT
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+17 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+18 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+19 IF Y=""
QUIT
+20 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDPA="CPT: "_Y
QUIT
End DoDot:2
+21 ;V TRANS
+22 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+23 IF '$DATA(^AUPNVTC(X,0))
QUIT
+24 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+25 IF Y=""
QUIT
+26 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDPA="CPT/TRAN: "_Y
QUIT
End DoDot:2
+27 ;SNOMED
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+29 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+30 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+31 IF Y=""
QUIT
+32 IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDPA="SNOMED: "_Y
QUIT
+33 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDPA="DX "_Y
QUIT
End DoDot:2
End DoDot:1
+34 IF BUDPA]""
QUIT BUDPA
+35 ;CHECK PROBLEM LIST FOR SNOMED
+36 SET X=$$PLCL^BUDEDU(P,"T6B ADOLWT PHYSICAL ACT CODES",EDATE,0,BDATE)
IF X
QUIT "PROBLEM SNOMED "_$PIECE(X,U,2)
+37 QUIT ""
ADULT ;EP
+1 NEW BUDDOB,BUDX18RB,BUDX18TH,BUDBMI,BUDOW,BUDUW,BUDPLAN,BUDBMIV,BUDBMID
+2 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+3 SET BUDX18RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+4 IF BUDDOB>BUDX18RB
QUIT
+5 IF BUDMEDV<1
QUIT
+6 SET BUDX18TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+7 ;quit if no visiT AFTER 18TH BIRTHDAY
IF '$$VBBD(DFN,BUDX18TH,BUDED)
QUIT
+8 IF $$PREG^BUDERP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
QUIT
+9 ;REFUSAL, ETC.
+10 ;PALLIATIVE CARE
+11 ;HAD PALLIATIVE CARE
IF $$PALL(DFN,BUDBD,BUDED)
QUIT
+12 ;HAD A REFUSAL
IF $$REF(DFN,BUDBD,BUDED)
QUIT
+13 SET D=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-182)
+14 ;I D<BUDBD S D=BUDBD
+15 SET BUDBMI=$$ADULTBMI(DFN,D,$$VD^APCLV(BUDLASTV),BUDAGE)
+16 SET BUDBMIV=$PIECE(BUDBMI,U,1)
+17 SET BUDBMID=$PIECE(BUDBMI,U,2)
+18 SET BUDOW=""
SET BUDUW=""
SET BUDPLAN=""
+19 ;I BUDBMI="" S BUDPLAN=$$PLAN(DFN,BUDBD,BUDED) I BUDPLAN]"" S G=0 S ^XTMP("BUDERP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN Q ;NO BMI
+20 IF BUDBMI=""
SET Y=$$CPTI^BUDEDU(P,BUDBD,BUDED,$PIECE($$CPT^ICPTCOD("3008F"),U,1))
IF Y
SET BUDBMI="CPT: 3008F"
SET G=0
GOTO D
+21 IF BUDBMI=""
SET G=0
GOTO D
+22 IF BUDBMI>25
SET BUDOW="OW"
+23 IF BUDBMI<18.5
SET BUDUW="UW"
+24 ;put the rest in demoninator
N ;not over/underweight & HAD BMI PUT IN NUM/DEN
IF BUDOW=""
IF BUDUW=""
SET BUDSECTF("PLAN")=$GET(BUDSECTF("PLAN"))+1
SET G=1
GOTO D
+1 SET BUDPLAN=$$PLAN(DFN,$$FMADD^XLFDT(BUDBMID,-182),BUDBMID)
+2 SET G=0
+3 IF BUDPLAN]""
SET G=1
SET BUDSECTF("PLAN")=$GET(BUDSECTF("PLAN"))+1
D ;put the rest in demoninator
+1 SET BUDSECTF("PTS")=$GET(BUDSECTF("PTS"))+1
Begin DoDot:1
+2 IF $GET(BUDAWS2L)
Begin DoDot:2
+3 IF 'G
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"AWS2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$SELECT($PIECE(BUDBMIV,U,1)]"":$JUSTIFY($PIECE(BUDBMIV,U,1),6,2),1:"")_" "_$$DATE^BUDEUTL1(BUDBMID)_U_$SELECT(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERW
EIGHT",1:"")_U_BUDPLAN
End DoDot:2
+4 IF $GET(BUDAWS1L)
Begin DoDot:2
+5 IF G
SET ^XTMP("BUDERP6B",BUDJ,BUDH,"AWS1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$SELECT($PIECE(BUDBMIV,U,1)]"":$JUSTIFY($PIECE(BUDBMIV,U,1),6,2),1:"")_" "_$$DATE^BUDEUTL1(BUDBMID)_U_$SELECT(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERW
EIGHT",1:"")_U_BUDPLAN
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
PLAN(P,BDATE,EDATE) ;
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,S,T,BUDPL,C
+2 SET BUDPL=""
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDETSSC("B","T6B ADULTWT PLAN CODES",0))
+5 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+6 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+7 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+8 SET C=$$CLINIC^APCLV(VIEN,"C")
IF C]""
IF $DATA(^BUDETSSC(TIEN,17,"B",C))
SET BUDPL="Clinic "_C_U_VDATE
QUIT
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+10 IF '$DATA(^AUPNVPED(X,0))
QUIT
+11 SET T=$$VALI^XBDIQ1(9000010.16,X,.01)
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF $PIECE(T,"-",2)="EX"!($PIECE(T,"-",2)="LA")!($PIECE(T,"-",2)="N")!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")
SET BUDPL=T_U_VDATE
QUIT
+15 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")!($PIECE(T,"-",1)="Z71.3")
SET BUDPL=T_U_VDATE
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+19 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+20 IF Y=""
QUIT
+21 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDPL="CPT: "_Y_U_VDATE
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+26 IF Y=""
QUIT
+27 IF $DATA(^BUDETSSC("AC",Y,TIEN))
SET BUDPL="CPT/TRAN: "_Y_U_VDATE
QUIT
End DoDot:2
+28 ;SNOMED
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+31 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+32 IF Y]""
IF $DATA(^BUDETSSC("AS",Y,TIEN))
SET BUDPL="SNOMED: "_Y_U_VDATE
QUIT
+33 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDETSSC("AD",Y,TIEN))
SET BUDPL="DX "_$$VAL^XBDIQ1(9000010.07,X,.01)_U_VDATE
QUIT
End DoDot:2
+34 ;PROVIDER CODES
+35 SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",VIEN,X))
IF X'=+X!(BUDPL]"")
QUIT
Begin DoDot:2
+36 IF '$DATA(^AUPNVPRV(X,0))
QUIT
+37 SET Y=$$VALI^XBDIQ1(9000010.06,X,.01)
+38 IF Y=""
QUIT
+39 SET Y=$$PROVCLSC^XBFUNC1(Y)
+40 IF Y=""
QUIT
+41 IF $DATA(^BUDETSSC(16,"B",Y))
SET BUDPL="Prv: "_Y_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+42 IF BUDPL]""
QUIT BUDPL
+43 ;CHECK PROBLEM LIST FOR SNOMED
+44 SET X=$$PLCL^BUDEDU(P,"T6B ADULTWT PLAN CODES",EDATE,0,BDATE)
IF X
QUIT "PROBLEM SNOMED "_$PIECE(X,U,2)
+45 QUIT ""
PALL(P,BDATE,EDATE) ;
+1 NEW D,BUDG,E,%
+2 SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+3 NEW X,Y,G,T,V,Z,A
+4 SET T=$ORDER(^BUDETSSC("B","T6B ADULTWT PALLIATIVE CARE",0))
+5 SET G=""
+6 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 SET Y=+$PIECE(BUDG(X),U,4)
+8 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+9 IF $DATA(^BUDETSSC("AD",Z,T))
SET G=1
QUIT
+10 SET Y=$$VAL^XBDIQ1(9000010.07,Y,1101)
+11 IF Y=""
QUIT
+12 IF $DATA(^BUDETSSC("AS",Y,T))
SET G=1
End DoDot:1
+13 IF G
QUIT G
+14 ;"PROBLEM SNOMED "_$P(X,U,2)
SET X=$$PLCL^BUDEDU(P,"T6B ADULTWT PALLIATIVE CARE",EDATE,0,BDATE)
IF X
QUIT 1
+15 QUIT G
G ;EP
+1 GOTO G^BUDERP6R
