BUDCRP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;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 BUDX18RB=($E(BUDBD,1,3)-18)_"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 BUDX18BD=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
Q:$$AGE^AUPNPAT(DFN,BUDED)>17
Q:BUDMEDV<1
S BUDX18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUDX18TH,-1)) Q
K BUDPAP
;S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
Q:$$PREG^BUDCRP6B(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("BUDCRP6B",BUDJ,BUDH,"WAC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDPAP
.I $G(BUDWAC1L) D
..I G=3 S ^XTMP("BUDCRP6B",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(^BUDCSITE(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 D,BUDG,E,%
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
NEW X,Y,G,T
S T=$O(^BUDCTSSC("B","BMI DIAGNOSIS 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(^BUDCTSSC("AD",Y,T)) S G="POV "_$P(BUDG(X),U,2)
Q G
REF(P,BDATE,EDATE) ;EP
NEW H,W
S H=$$REFRNU^BUDCUTL1(P,9999999.07,$O(^AUTTMSR("B","HT",0)),BDATE,EDATE)
I H="" Q 1
S W=$$REFRNU^BUDCUTL1(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)
.. 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)
..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")!($P(T,"-",1)="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^BUDCDU(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"
K BUDG S X=P_"^LAST DX Z71.89;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BUDG(")
I $D(BUDG(1)) Q "POV Z71.89"
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
.I $P(T,"-",1)="Z71.89" 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^BUDCUTL1(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^BUDCRP6B(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("BUDCRP6B",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<23 S BUDUW="UW"
;put the rest in demoninator
N I BUDOW="",BUDUW="" Q ;not over/underweight & HAD BMI
S BUDWTDT=$$BMI^BUDCRP6R(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("BUDCRP6B",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("BUDCRP6B",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^BUDCUTL1(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))
;WT PLAN DIAGNOSES CODES
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDCTSSC("B","WT PLAN DIAGNOSES CODES",0))
S X=0,G="" 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(^BUDCTSSC("AD",Y,T)) S G=$P(BUDG(X),U,2)_" on "_$$FMTE^XLFDT($P(BUDG(X),U))
I G]"" Q G
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")!($P(T,"-",1)="Z71.3") 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 ""
G ;EP
G G^BUDCRP6R
BUDCRP6V ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+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 BUDX18RB=($EXTRACT(BUDBD,1,3)-18)_"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 BUDX18BD=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+10 IF $$AGE^AUPNPAT(DFN,BUDED)>17
QUIT
+11 IF BUDMEDV<1
QUIT
+12 SET BUDX18TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+13 IF '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUDX18TH,-1))
QUIT
+14 KILL BUDPAP
+15 ;S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
+16 IF $$PREG^BUDCRP6B(DFN,$$FMADD^XLFDT(BUDED,-609),BUDED)
QUIT
+17 SET BUDPAP=$$BMINPA(DFN,BUDBD,BUDED,BUDAGE)
+18 ;Q:BUDPAP="REF"
+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("BUDCRP6B",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("BUDCRP6B",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(^BUDCSITE(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 ;I BUDBMI="" I $$REF(P,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-(6*30.5)),$$VD^APCLV(BUDLASTV)) Q "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 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(^BUDCTSSC("B","BMI DIAGNOSIS 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(^BUDCTSSC("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^BUDCUTL1(P,9999999.07,$ORDER(^AUTTMSR("B","HT",0)),BDATE,EDATE)
+3 IF H=""
QUIT 1
+4 SET W=$$REFRNU^BUDCUTL1(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 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)
+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 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")!($PIECE(T,"-",1)="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^BUDCDU(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 KILL BUDG
SET X=P_"^LAST DX Z71.89;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BUDG(")
+5 IF $DATA(BUDG(1))
QUIT "POV Z71.89"
+6 SET Y="BUDALLED("
+7 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+8 IF '$DATA(BUDALLED(1))
QUIT ""
+9 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF $PIECE(T,"-",2)="EX"
SET %=T
QUIT
+15 IF $PIECE(T,"-",1)="V65.41"
SET %=T
QUIT
+16 IF $PIECE(T,"-",1)="Z71.89"
SET %=T
QUIT
End DoDot:1
+17 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^BUDCUTL1(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^BUDCRP6B(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("BUDCRP6B",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<23
SET BUDUW="UW"
+22 ;put the rest in demoninator
N ;not over/underweight & HAD BMI
IF BUDOW=""
IF BUDUW=""
QUIT
+1 SET BUDWTDT=$$BMI^BUDCRP6R(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("BUDCRP6B",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("BUDCRP6B",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^BUDCUTL1(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 ;WT PLAN DIAGNOSES CODES
+7 ;V10.0 ICD10
+8 KILL BUDG
SET %=P_"^ALL DX;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BUDG(")
+9 SET T=$ORDER(^BUDCTSSC("B","WT PLAN DIAGNOSES CODES",0))
+10 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+11 SET Y=+$PIECE(BUDG(X),U,4)
+12 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+13 IF $DATA(^BUDCTSSC("AD",Y,T))
SET G=$PIECE(BUDG(X),U,2)_" on "_$$FMTE^XLFDT($PIECE(BUDG(X),U))
End DoDot:1
+14 IF G]""
QUIT G
+15 KILL BUDALLED
+16 SET Y="BUDALLED("
+17 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(X,Y)
+18 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+19 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDALLED(X),U,4),0),U)
+20 IF 'T
QUIT
+21 IF '$DATA(^AUTTEDT(T,0))
QUIT
+22 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+23 SET E=$PIECE(BUDALLED(X),U,1)
+24 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
+25 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 %=T_U_E
QUIT
End DoDot:1
+26 IF %]""
QUIT $PIECE(%,U,1)_" on "_$$FMTE^XLFDT($PIECE(%,U,2))
+27 ;now check for a clinic or provider visit
+28 NEW BUDG,W,R
+29 KILL BUDG
+30 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(%,"BUDG(")
+31 SET (X,Y,D)=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+32 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRV("AD",$PIECE(BUDG(X),U,5),Z))
IF Z'=+Z!(Y)
QUIT
Begin DoDot:2
+33 SET W=$PIECE($GET(^AUPNVPRV(Z,0)),U,1)
+34 IF W=""
QUIT
+35 SET R=$$VALI^XBDIQ1(200,W,53.5)
+36 IF R=""
QUIT
+37 SET R=$PIECE($GET(^DIC(7,R,9999999)),U,1)
+38 IF R="07"!(R=29)
SET Y=1
SET D="Provider "_R_" on "_$$FMTE^XLFDT($PIECE(BUDG(X),U))
QUIT
+39 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
+40 IF Y
QUIT D
+41 QUIT ""
G ;EP
+1 GOTO G^BUDCRP6R
