BUDHRP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
;
ADOLWT ;EP - called from xbdbque
;
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)-4)_"1231" ;REPORT PERIOD 3 BD
Q:BUDDOB>BUD3RB
Q:BUDDOB<BUD17RB
Q:BUDMEDV<1
S BUD18BD=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD18BD,-1)) Q
Q:$$HOSPIND^BUDHRP6C(DFN,BUDBD,BUDED) ;new v18, hospice
Q:$$PREG^BUDHRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
S BUDBMI=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)
S G=0 F X=1:1:5 I $P(BUDBMI,U,X)]"" S G=G+1
I G=5 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'=5 S ^XTMP("BUDHRP6B",BUDJ,BUDH,"WAC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI
.I $G(BUDWAC1L) D
..I G=5 S ^XTMP("BUDHRP6B",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(^BUDHSITE(BUDSITE,11,L))
.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,BUDHT,BUDWT,BUDVAL
S BUDVAL=""
S BUDHT=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",BDATE,EDATE,"A") I BUDHT]"" S BUDHT="HT: "_$P(BUDHT,U,3)
S BUDWT=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",BDATE,EDATE,"A") I BUDWT]"" S BUDWT="WT: "_$P(BUDWT,U,3)
S BUDBMI=$$LASTITEM^APCLAPIU(P,"BMIP","MEASUREMENT",BDATE,EDATE,"A") I BUDBMI]"" S BUDBMI="BMIP: "_$P(BUDBMI,U,3)
S BUDNE=$$NUTR(P,BDATE,EDATE)
S BUDPA=$$PA(P,BDATE,EDATE)
Q BUDHT_U_BUDWT_U_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(^BUDHTSSC("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(^BUDHTSSC("AD",Y,T)) S G="POV "_$P(BUDG(X),U,2)
Q G
REF(P,BDATE,EDATE) ;EP
NEW F,G,I,ID,C,X,D,H,W,R,T
S G=0
S T=$O(^BUDHTSSC("B","T6B ADULTWT REFUSAL",0))
S F=9999999.07,I=$O(^AUTTMSR("B","BMI",0))
S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G) D
.S D=9999999-$P(ID,".") ;ID
.Q:D'=BDATE
.S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G) D
..;get snomed reason not done and it must be in one of the subsets
..S R=$$VALI^XBDIQ1(9000022,X,1.01) ;SNOMED REASON NOT DONE
..I R]"",$D(^BUDHTSSC(T,13,"B",R)) S G=1 Q
..S R=$$VALI^XBDIQ1(9000022,X,.07)
..I R="R"!(R="N")!(R="U") S G=1 Q
I G Q G
;now check for WT or HT
S (W,H)=""
S F=9999999.07,I=$O(^AUTTMSR("B","WT",0))
S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(W) D
.S D=9999999-$P(ID,".") ;ID
.Q:D'=BDATE
.S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(W) D
..S R=$$VALI^XBDIQ1(9000022,X,.07)
..I R="R"!(R="N")!(R="U") S W=1
I W Q 1
S F=9999999.07,I=$O(^AUTTMSR("B","HT",0))
S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(H) D
.S D=9999999-$P(ID,".") ;ID
.Q:D'=BDATE
.S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(H) D
..S R=$$VALI^XBDIQ1(9000022,X,.07)
..I R="R"!(R="N")!(R="U") S H=1
I H Q 1
S H=$$MRND(P,BDATE,EDATE)
Q H
MRND(P,BDATE,EDATE) ;EP
NEW F,G,I,ID,C,X,D,H,W,R,TNDM,TAN,TBN
S TNDM=$O(^BUDHTSSC("B","PXRM BGP IPC NOT DONE MED",0))
S TAN=$O(^BUDHTSSC("B","T6B ADULTWT ABOVE NORM",0))
S TBN=$O(^BUDHTSSC("B","T6B ADULTWT BELOW NORM",0))
S G=0
S F=81,I=""
F S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G) D
.I '$$ICD^ATXCHK(I,$O(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0)),1),'$$ICD^ATXCHK(I,$O(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0)),1) Q
.S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G) D
..S D=9999999-$P(ID,".") ;ID
..Q:D<BDATE
..Q:D>EDATE
..S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G) D
...;get snomed reason not done and it must be in one of the subsets
...S R=$$VALI^XBDIQ1(9000022,X,1.01) ;SNOMED REASON NOT DONE
...I R]"",$D(^BUDHTSSC(TNDM,13,"B",R)) S G=1 Q
...S R=$$VALI^XBDIQ1(9000022,X,.07)
...I R="N"!(R="U") S G=1
I G Q G
S F=9002318.4,I=""
F S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G) D
.I '$D(^BUDHTSSC(TAN,13,"B",I)),'$D(^BUDHTSSC(TBN,13,"B",I)) Q
.S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G) D
..S D=9999999-$P(ID,".") ;ID
..Q:D<BDATE
..Q:D>EDATE
..S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G) D
...;get snomed reason not done and it must be in one of the subsets
...S R=$$VALI^XBDIQ1(9000022,X,1.01) ;SNOMED REASON NOT DONE
...I R]"",$D(^BUDHTSSC(TNDM,13,"B",R)) S G=1 Q
...S R=$$VALI^XBDIQ1(9000022,X,.07)
...I R="N"!(R="U") S G=1
I G Q G
;MEDS
S F=50,I=""
NEW T,T1
S T=$O(^ATXAX("B","BGP IPC BELOW NORMAL MEDS",0))
S T1=$O(^ATXAX("B","BGP IPC ABOVE NORMAL MEDS",0))
F S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G) D
.I '$D(^ATXAX(T,21,"B",I)),'$D(^ATXAX(T,21,"B",I)) Q
.S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G) D
..S D=9999999-$P(ID,".") ;ID
..Q:D<BDATE
..Q:D>EDATE
..S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G) D
...;get snomed reason not done and it must be in one of the subsets
...S R=$$VALI^XBDIQ1(9000022,X,1.01) ;SNOMED REASON NOT DONE
...I R]"",$D(^BUDHTSSC(TDNM,"B",13,R)) S G=1 Q
I G Q G
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(^BUDHTSSC("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_" "_$$DATE^BUDHUTL1(VDATE) Q
..I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804") S BUDNUT=T_" "_$$DATE^BUDHUTL1(VDATE) Q
..S S=$P(T,"-",1) I S]"",$D(^BUDHTSSC("AS",S,TIEN)) S BUDNUT=T_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDNUT="CPT: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDNUT="CPT/TRAN: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AS",Y,TIEN)) S BUDNUT="SNOMED: "_Y_" "_$$DATE^BUDHUTL1(VDATE) Q
I BUDNUT]"" Q BUDNUT
;CHECK PROBLEM LIST FOR SNOMED
S X=$$PLCL^BUDHDU(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(^BUDHTSSC("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" S BUDPA=T_" "_$$DATE^BUDHUTL1(VDATE) Q
..S S=$P(T,"-",1)
..I S]"",$D(^BUDHTSSC("AS",S,TIEN)) S BUDPA=T_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDPA="CPT: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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(^BUDHTSSC("AC",Y,TIEN)) S BUDPA="CPT/TRAN: "_Y_" "_$$DATE^BUDHUTL1(VDATE) 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 Y]"",$D(^BUDHTSSC("AS",Y,TIEN)) S BUDPA="SNOMED: "_Y_" "_$$DATE^BUDHUTL1(VDATE) Q
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDHTSSC("AD",Y,TIEN)) S BUDPA="DX "_Y_" "_$$DATE^BUDHUTL1(VDATE) Q
I BUDPA]"" Q BUDPA
;CHECK PROBLEM LIST FOR SNOMED
S X=$$PLCL^BUDHDU(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^BUDHRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
;REFUSAL, ETC.
;PALLIATIVE CARE
S D=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-365)
Q:$$PALL(DFN,D,$$VD^APCLV(BUDLASTV)) ;HAD PALLIATIVE CARE
Q:$$REF(DFN,D,$$VD^APCLV(BUDLASTV)) ;HAD A REFUSAL
S D=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-394)
;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("BUDHRP6B",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^BUDHDU(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=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 D=$$VD^APCLV(BUDLASTV)
I BUDOW]"" S BUDPLAN=$$ANFU^BUDHUTL3(DFN,$$FMADD^XLFDT(D,-394),D)
I BUDUW]"" S BUDPLAN=$$BLFU^BUDHUTL3(DFN,$$FMADD^XLFDT(D,-394),D)
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("BUDHRP6B",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^BUDHUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
.I $G(BUDAWS1L) D
..I G S ^XTMP("BUDHRP6B",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^BUDHUTL1(BUDBMID)_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN
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(^BUDHTSSC("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(^BUDHTSSC("AD",Z,T)) S G=1 Q
.S Y=$$VAL^XBDIQ1(9000010.07,Y,1101)
.Q:Y=""
.I $D(^BUDHTSSC("AS",Y,T)) S G=1
I G Q G
S X=$$PLCL^BUDHDU(P,"T6B ADULTWT PALLIATIVE CARE",EDATE,0,BDATE) I X Q 1 ;"PROBLEM SNOMED "_$P(X,U,2)
Q G
G ;EP
G G^BUDHRP6R
BUDHRP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
+3 ;
ADOLWT ;EP - called from xbdbque
+1 ;
+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)-4)_"1231"
+6 IF BUDDOB>BUD3RB
QUIT
+7 IF BUDDOB<BUD17RB
QUIT
+8 IF BUDMEDV<1
QUIT
+9 SET BUD18BD=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+10 IF '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD18BD,-1))
QUIT
+11 ;new v18, hospice
IF $$HOSPIND^BUDHRP6C(DFN,BUDBD,BUDED)
QUIT
+12 IF $$PREG^BUDHRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
QUIT
+13 SET BUDBMI=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)
+14 SET G=0
FOR X=1:1:5
IF $PIECE(BUDBMI,U,X)]""
SET G=G+1
+15 IF G=5
SET BUDSECTE("AWT")=$GET(BUDSECTE("AWT"))+1
+16 ;put the rest in demoninator
+17 SET BUDSECTE("PTS")=$GET(BUDSECTE("PTS"))+1
Begin DoDot:1
+18 IF $GET(BUDWAC2L)
Begin DoDot:2
+19 IF G'=5
SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"WAC2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI
End DoDot:2
+20 IF $GET(BUDWAC1L)
Begin DoDot:2
+21 IF G=5
SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"WAC1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
+24 ;
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 IF '$DATA(^BUDHSITE(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,BUDHT,BUDWT,BUDVAL
+2 SET BUDVAL=""
+3 SET BUDHT=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",BDATE,EDATE,"A")
IF BUDHT]""
SET BUDHT="HT: "_$PIECE(BUDHT,U,3)
+4 SET BUDWT=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",BDATE,EDATE,"A")
IF BUDWT]""
SET BUDWT="WT: "_$PIECE(BUDWT,U,3)
+5 SET BUDBMI=$$LASTITEM^APCLAPIU(P,"BMIP","MEASUREMENT",BDATE,EDATE,"A")
IF BUDBMI]""
SET BUDBMI="BMIP: "_$PIECE(BUDBMI,U,3)
+6 SET BUDNE=$$NUTR(P,BDATE,EDATE)
+7 SET BUDPA=$$PA(P,BDATE,EDATE)
+8 QUIT BUDHT_U_BUDWT_U_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(^BUDHTSSC("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(^BUDHTSSC("AD",Y,T))
SET G="POV "_$PIECE(BUDG(X),U,2)
End DoDot:1
+10 QUIT G
REF(P,BDATE,EDATE) ;EP
+1 NEW F,G,I,ID,C,X,D,H,W,R,T
+2 SET G=0
+3 SET T=$ORDER(^BUDHTSSC("B","T6B ADULTWT REFUSAL",0))
+4 SET F=9999999.07
SET I=$ORDER(^AUTTMSR("B","BMI",0))
+5 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:1
+6 ;ID
SET D=9999999-$PIECE(ID,".")
+7 IF D'=BDATE
QUIT
+8 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+9 ;get snomed reason not done and it must be in one of the subsets
+10 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+11 IF R]""
IF $DATA(^BUDHTSSC(T,13,"B",R))
SET G=1
QUIT
+12 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+13 IF R="R"!(R="N")!(R="U")
SET G=1
QUIT
End DoDot:2
End DoDot:1
+14 IF G
QUIT G
+15 ;now check for WT or HT
+16 SET (W,H)=""
+17 SET F=9999999.07
SET I=$ORDER(^AUTTMSR("B","WT",0))
+18 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(W)
QUIT
Begin DoDot:1
+19 ;ID
SET D=9999999-$PIECE(ID,".")
+20 IF D'=BDATE
QUIT
+21 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(W)
QUIT
Begin DoDot:2
+22 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+23 IF R="R"!(R="N")!(R="U")
SET W=1
End DoDot:2
End DoDot:1
+24 IF W
QUIT 1
+25 SET F=9999999.07
SET I=$ORDER(^AUTTMSR("B","HT",0))
+26 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(H)
QUIT
Begin DoDot:1
+27 ;ID
SET D=9999999-$PIECE(ID,".")
+28 IF D'=BDATE
QUIT
+29 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(H)
QUIT
Begin DoDot:2
+30 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+31 IF R="R"!(R="N")!(R="U")
SET H=1
End DoDot:2
End DoDot:1
+32 IF H
QUIT 1
+33 SET H=$$MRND(P,BDATE,EDATE)
+34 QUIT H
MRND(P,BDATE,EDATE) ;EP
+1 NEW F,G,I,ID,C,X,D,H,W,R,TNDM,TAN,TBN
+2 SET TNDM=$ORDER(^BUDHTSSC("B","PXRM BGP IPC NOT DONE MED",0))
+3 SET TAN=$ORDER(^BUDHTSSC("B","T6B ADULTWT ABOVE NORM",0))
+4 SET TBN=$ORDER(^BUDHTSSC("B","T6B ADULTWT BELOW NORM",0))
+5 SET G=0
+6 SET F=81
SET I=""
+7 FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+8 IF '$$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0)),1)
IF '$$ICD^ATXCHK(I,$ORDER(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0)),1)
QUIT
+9 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+10 ;ID
SET D=9999999-$PIECE(ID,".")
+11 IF D<BDATE
QUIT
+12 IF D>EDATE
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 ;get snomed reason not done and it must be in one of the subsets
+15 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+16 IF R]""
IF $DATA(^BUDHTSSC(TNDM,13,"B",R))
SET G=1
QUIT
+17 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+18 IF R="N"!(R="U")
SET G=1
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF G
QUIT G
+20 SET F=9002318.4
SET I=""
+21 FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+22 IF '$DATA(^BUDHTSSC(TAN,13,"B",I))
IF '$DATA(^BUDHTSSC(TBN,13,"B",I))
QUIT
+23 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+24 ;ID
SET D=9999999-$PIECE(ID,".")
+25 IF D<BDATE
QUIT
+26 IF D>EDATE
QUIT
+27 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+28 ;get snomed reason not done and it must be in one of the subsets
+29 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+30 IF R]""
IF $DATA(^BUDHTSSC(TNDM,13,"B",R))
SET G=1
QUIT
+31 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+32 IF R="N"!(R="U")
SET G=1
End DoDot:3
End DoDot:2
End DoDot:1
+33 IF G
QUIT G
+34 ;MEDS
+35 SET F=50
SET I=""
+36 NEW T,T1
+37 SET T=$ORDER(^ATXAX("B","BGP IPC BELOW NORMAL MEDS",0))
+38 SET T1=$ORDER(^ATXAX("B","BGP IPC ABOVE NORMAL MEDS",0))
+39 FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+40 IF '$DATA(^ATXAX(T,21,"B",I))
IF '$DATA(^ATXAX(T,21,"B",I))
QUIT
+41 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+42 ;ID
SET D=9999999-$PIECE(ID,".")
+43 IF D<BDATE
QUIT
+44 IF D>EDATE
QUIT
+45 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+46 ;get snomed reason not done and it must be in one of the subsets
+47 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+48 IF R]""
IF $DATA(^BUDHTSSC(TDNM,"B",13,R))
SET G=1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+49 IF G
QUIT G
+50 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(^BUDHTSSC("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_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
+14 IF $PIECE(T,"-",1)="97802"!($PIECE(T,"-",1)="97803")!($PIECE(T,"-",1)="97804")
SET BUDNUT=T_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
+15 SET S=$PIECE(T,"-",1)
IF S]""
IF $DATA(^BUDHTSSC("AS",S,TIEN))
SET BUDNUT=T_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDNUT="CPT: "_Y_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDNUT="CPT/TRAN: "_Y_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+28 ;SNOMED
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+31 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+32 IF Y=""
QUIT
+33 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDNUT="SNOMED: "_Y_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+34 IF BUDNUT]""
QUIT BUDNUT
+35 ;CHECK PROBLEM LIST FOR SNOMED
+36 SET X=$$PLCL^BUDHDU(P,"T6B ADOLWT NUTRITION CODES",EDATE,0,BDATE)
IF X
QUIT "PROBLEM SNOMED "_$PIECE(X,U,2)
+37 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(^BUDHTSSC("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"
SET BUDPA=T_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
+14 SET S=$PIECE(T,"-",1)
+15 IF S]""
IF $DATA(^BUDHTSSC("AS",S,TIEN))
SET BUDPA=T_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDPA="CPT: "_Y_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
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(^BUDHTSSC("AC",Y,TIEN))
SET BUDPA="CPT/TRAN: "_Y_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
+28 ;SNOMED
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+31 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+32 ;Q:Y=""
+33 IF Y]""
IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDPA="SNOMED: "_Y_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
+34 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDHTSSC("AD",Y,TIEN))
SET BUDPA="DX "_Y_" "_$$DATE^BUDHUTL1(VDATE)
QUIT
End DoDot:2
End DoDot:1
+35 IF BUDPA]""
QUIT BUDPA
+36 ;CHECK PROBLEM LIST FOR SNOMED
+37 SET X=$$PLCL^BUDHDU(P,"T6B ADOLWT PHYSICAL ACT CODES",EDATE,0,BDATE)
IF X
QUIT "PROBLEM SNOMED "_$PIECE(X,U,2)
+38 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^BUDHRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED,BUDBD)
QUIT
+9 ;REFUSAL, ETC.
+10 ;PALLIATIVE CARE
+11 SET D=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-365)
+12 ;HAD PALLIATIVE CARE
IF $$PALL(DFN,D,$$VD^APCLV(BUDLASTV))
QUIT
+13 ;HAD A REFUSAL
IF $$REF(DFN,D,$$VD^APCLV(BUDLASTV))
QUIT
+14 SET D=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-394)
+15 ;I D<BUDBD S D=BUDBD
+16 SET BUDBMI=$$ADULTBMI(DFN,D,$$VD^APCLV(BUDLASTV),BUDAGE)
+17 SET BUDBMIV=$PIECE(BUDBMI,U,1)
+18 SET BUDBMID=$PIECE(BUDBMI,U,2)
+19 SET BUDOW=""
SET BUDUW=""
SET BUDPLAN=""
+20 ;I BUDBMI="" S BUDPLAN=$$PLAN(DFN,BUDBD,BUDED) I BUDPLAN]"" S G=0 S ^XTMP("BUDHRP6B",BUDJ,BUDH,"AWS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=BUDBMI_U_$S(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERWEIGHT",1:"")_U_BUDPLAN Q ;NO BMI
+21 ;I BUDBMI="" S Y=$$CPTI^BUDHDU(P,BUDBD,BUDED,$P($$CPT^ICPTCOD("3008F"),U,1)) I Y S BUDBMI="CPT: 3008F" S G=0 G D
+22 IF BUDBMI=""
SET G=0
GOTO D
+23 IF BUDBMI>25
SET BUDOW="OW"
+24 IF +BUDBMI=25
SET BUDOW="OW"
+25 IF BUDBMI<18.5
SET BUDUW="UW"
+26 ;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 D=$$VD^APCLV(BUDLASTV)
+2 IF BUDOW]""
SET BUDPLAN=$$ANFU^BUDHUTL3(DFN,$$FMADD^XLFDT(D,-394),D)
+3 IF BUDUW]""
SET BUDPLAN=$$BLFU^BUDHUTL3(DFN,$$FMADD^XLFDT(D,-394),D)
+4 SET G=0
+5 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("BUDHRP6B",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^BUDHUTL1(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("BUDHRP6B",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^BUDHUTL1(BUDBMID)_U_$SELECT(BUDOW]"":"OVERWEIGHT",BUDUW]"":"UNDERW
EIGHT",1:"")_U_BUDPLAN
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
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(^BUDHTSSC("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(^BUDHTSSC("AD",Z,T))
SET G=1
QUIT
+10 SET Y=$$VAL^XBDIQ1(9000010.07,Y,1101)
+11 IF Y=""
QUIT
+12 IF $DATA(^BUDHTSSC("AS",Y,T))
SET G=1
End DoDot:1
+13 IF G
QUIT G
+14 ;"PROBLEM SNOMED "_$P(X,U,2)
SET X=$$PLCL^BUDHDU(P,"T6B ADULTWT PALLIATIVE CARE",EDATE,0,BDATE)
IF X
QUIT 1
+15 QUIT G
G ;EP
+1 GOTO G^BUDHRP6R
