- BUDARP6R ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
- ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
- ;
- BMI(P,BDATE,EDATE,AGE) ;EP
- NEW HDATE,BUDBMIH,W,H,X,WD
- S BUDBMIH="",WD=""
- I AGE>18,AGE<51 D Q WD
- .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=$$WT(P,BDATE,EDATE)
- .S WD=$P(W,U,2)
- .S W=$P(W,U,1) I W=""!(W="?") Q
- .;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
- .;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>50 D Q WD
- .S HDATE=$$FMADD^XLFDT(BDATE,-(2*365)),HDATE=$$FMTE^XLFDT(HDATE)
- .S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
- .S W=$$WT(P,BDATE,EDATE)
- .S WD=$P(W,U,2)
- .S W=$P(W,U,1) I W=""!(W="?") Q
- .;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
- .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 WD
- .S X=$$HTWTSD(P,BDATE,EDATE)
- .I '$P(X,"^") Q
- .I '$P(X,"^",2) Q
- .S W=$P(X,"^"),H=$P(X,"^",2),WD=$P(X,U,3)
- .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,BUDLWD
- K BUDL S BUDLW="",BUDLWD="" 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),BUDLWD=$P(BUDL(BUDLN),U,1)
- ..Q
- Q BUDLW_U_BUDLWD
- 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)_U_X
- Q BUDLCHT
- BUDARP6R ; 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 ;
- BMI(P,BDATE,EDATE,AGE) ;EP
- +1 NEW HDATE,BUDBMIH,W,H,X,WD
- +2 SET BUDBMIH=""
- SET WD=""
- +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=$$WT(P,BDATE,EDATE)
- +8 SET WD=$PIECE(W,U,2)
- +9 SET W=$PIECE(W,U,1)
- IF W=""!(W="?")
- QUIT
- +10 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
- +11 ;S HDATE=BDATE
- +12 SET H=$$HT(P,HDATE,EDATE)
- IF H=""
- QUIT
- +13 SET W=W*.45359
- SET H=(H*.0254)
- SET H=(H*H)
- SET BUDBMIH=(W/H)
- End DoDot:1
- QUIT WD
- +14 IF AGE>50
- Begin DoDot:1
- +15 SET HDATE=$$FMADD^XLFDT(BDATE,-(2*365))
- SET HDATE=$$FMTE^XLFDT(HDATE)
- +16 SET BDATE=$$FMTE^XLFDT(BDATE)
- SET EDATE=$$FMTE^XLFDT(EDATE)
- +17 SET W=$$WT(P,BDATE,EDATE)
- +18 SET WD=$PIECE(W,U,2)
- +19 SET W=$PIECE(W,U,1)
- IF W=""!(W="?")
- QUIT
- +20 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
- +21 SET HDATE=BDATE
- +22 SET H=$$HT(P,HDATE,EDATE)
- IF H=""
- QUIT
- +23 SET W=W*.45359
- SET H=(H*.0254)
- SET H=(H*H)
- SET BUDBMIH=(W/H)
- End DoDot:1
- QUIT WD
- +24 IF AGE<19
- Begin DoDot:1
- +25 SET X=$$HTWTSD(P,BDATE,EDATE)
- +26 IF '$PIECE(X,"^")
- QUIT
- +27 IF '$PIECE(X,"^",2)
- QUIT
- +28 SET W=$PIECE(X,"^")
- SET H=$PIECE(X,"^",2)
- SET WD=$PIECE(X,U,3)
- +29 SET W=W*.45359
- SET H=(H*.0254)
- SET H=(H*H)
- SET BUDBMIH=(W/H)
- +30 QUIT
- End DoDot:1
- QUIT WD
- +31 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,BUDLWD
- +3 KILL BUDL
- SET BUDLW=""
- SET BUDLWD=""
- 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)
- SET BUDLWD=$PIECE(BUDL(BUDLN),U,1)
- End DoDot:3
- +17 QUIT
- End DoDot:2
- End DoDot:1
- +18 QUIT BUDLW_U_BUDLWD
- 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)_U_X
- +14 QUIT BUDLCHT
