PXRMBMI ;SLC/PKR - National BMI and BSA computed finding. ;08/21/2019
;;2.0;CLINICAL REMINDERS;**12,18,42**;Feb 04, 2005;Build 245
;================================
BMI(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Multi-occurrence computed
;finding for BMI.
N BMI,HDATE,HT,IND,TDATE,WHL,WT
;Get the list of weight and height measurements.
D WANDHL(DFN,NGET,BDT,EDT,.NFOUND,.WHL)
F IND=1:1:NFOUND D
. S TDATE=$P(WHL(IND),U,1),WT=$P(WHL(IND),U,2)
. S HT=$P(WHL(IND),U,3),HDATE=$P(WHL(IND),U,4)
. S TEST(IND)=1,DATE(IND)=TDATE
. S TEXT(IND)="height measured "_$$EDATE^PXRMDATE(HDATE)
. S BMI=WT/(HT*HT)
. S BMI=$FN(BMI,"",1)
. S (DATA(IND,"VALUE"),DATA(IND,"BMI"))=BMI
Q
;
;================================
BSA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Multi-occurrence computed
;finding for BSA. The coefficients have been adjusted for heights
;in cm and weights in kg expect for Boyd where the weight is grams.
;The default is to use the Mosteller formula.
N BSA,FORMULA,HDATE,HT,IND,TDATE,TYPE,WHL,WT
S TYPE=$S(TEST="":"M",TEST="M":"M",TEST="D":"D",TEST="H":"H",TEST="G":"G",TEST="B":"B",1:"M")
S FORMULA=$S(TYPE="M":"Mosteller",TYPE="B":"Boyd",TYPE="D":"DuBois and Dubois",TYPE="H":"Haycock",TYPE="G":"Gehan and George",1:"Mosteller")_" formula"
;Get the list of weight and height measurements.
D WANDHL(DFN,NGET,BDT,EDT,.NFOUND,.WHL)
F IND=1:1:NFOUND D
. S TDATE=$P(WHL(IND),U,1),WT=$P(WHL(IND),U,2)
. S HT=$P(WHL(IND),U,3),HDATE=$P(WHL(IND),U,4)
. S TEST(IND)=1,DATE(IND)=TDATE
. I TYPE="M" S BSA=$$SQRT^XLFMTH((WT*HT)/36)
. I TYPE="D" S BSA=.20247*$$PWR^XLFMTH(HT,.725)*$$PWR^XLFMTH(WT,.425)
. I TYPE="H" S BSA=.15058*$$PWR^XLFMTH(HT,.3964)*$$PWR^XLFMTH(WT,.5378)
. I TYPE="G" S BSA=.164*$$PWR^XLFMTH(HT,.42246)*$$PWR^XLFMTH(WT,.51456)
. I TYPE="B" D
.. N WEXP
.. S WT=1000*WT
.. S WEXP=.7285-(.0188*$$LOG^XLFMTH(WT))
.. S BSA=.001277*$$PWR^XLFMTH(HT,.3)*$$PWR^XLFMTH(WT,WEXP)
. S BSA=$FN(BSA,"",2)
. S (DATA(IND,"VALUE"),DATA(IND,"BSA"))=BSA
. S TEXT(IND)=FORMULA_", height measured "_$$EDATE^PXRMDATE(HDATE)
Q
;
;================================
GHEIGHT(DFN,WDATE,HT,HDATE) ;Return the height measurement taken on the
;date closest to WDATE (WDATE is the date of the weight measurement).
;If no height is found return -1.
N BCKDATE,DAS,DIFFL,DIFFS,DONE,FWDDATE,TEMP
S (DONE,HDATE)=0,HT=-1
;Check for height measured on same date and time.
S DAS=$O(^PXRMINDX(120.5,"PI",DFN,8,WDATE,""))
I DAS'="" D
. D GETDATA^PXRMVITL(DAS,.TEMP)
. I TEMP("RATE")'=+TEMP("RATE") Q
. S HT=+(TEMP("RATE")*0.0254),HDATE=WDATE,DONE=1
I 'DONE S (BCKDATE,FWDDATE)=WDATE
F Q:DONE D
. S BCKDATE=+$O(^PXRMINDX(120.5,"PI",DFN,8,BCKDATE),-1)
. S FWDDATE=+$O(^PXRMINDX(120.5,"PI",DFN,8,FWDDATE))
. I (BCKDATE=0),(FWDDATE=0) S DONE=1 Q
. I BCKDATE>0 S DIFFS=$$FMDIFF^XLFDT(WDATE,BCKDATE,2),DIFFL(DIFFS,BCKDATE)=""
. I FWDDATE>0 S DIFFS=$$FMDIFF^XLFDT(FWDDATE,WDATE,2),DIFFL(DIFFS,FWDDATE)=""
. S DIFFS=$O(DIFFL("")),HDATE=$O(DIFFL(DIFFS,""))
. I HDATE=0 Q
. S DAS=$O(^PXRMINDX(120.5,"PI",DFN,8,HDATE,""))
. D GETDATA^PXRMVITL(DAS,.TEMP)
. I (TEMP("RATE")'=+TEMP("RATE"))!(TEMP("RATE")=0) K DIFFL(DIFFS,HDATE) Q
. S HT=+(TEMP("RATE")*0.0254)
. S DONE=1
Q
;
;================================
WANDHL(DFN,NGET,BDT,EDT,NFOUND,WHL) ;Return an ordered and
;paired list of weight and height measurements. Weight is in kilograms
;and height is in meters.
N DAS,DIFFL,DIFFS,DONE,HT,HDATE,NOCC
N SDIR,TDATE,TEMP,WLIST,WT
S SDIR=$S(NGET>0:-1,1:1)
S NOCC=$S(NGET>0:NGET,1:-NGET)
;Get a list of weight measurements in the date range.
S TDATE=BDT-.000001
F S TDATE=+$O(^PXRMINDX(120.5,"PI",DFN,9,TDATE)) Q:(TDATE=0)!(TDATE>EDT) D
. S DAS=$O(^PXRMINDX(120.5,"PI",DFN,9,TDATE,""))
. S WLIST(TDATE)=DAS
;Get up to NOCC BMI values.
S TDATE="",(DONE,NFOUND)=0
F S TDATE=$O(WLIST(TDATE),SDIR) Q:(DONE)!(TDATE="") D
. S DAS=WLIST(TDATE)
. K TEMP
. D GETDATA^PXRMVITL(DAS,.TEMP)
. I TEMP("RATE")'=+TEMP("RATE") Q
. S WT=+TEMP("RATE")*0.4535924
.;Find the closest height measurement.
. D GHEIGHT(DFN,TDATE,.HT,.HDATE)
. I HT=-1 Q
. S NFOUND=NFOUND+1
. S WHL(NFOUND)=TDATE_U_WT_U_HT_U_HDATE
. I NFOUND=NOCC S DONE=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMBMI 4283 printed Dec 13, 2024@01:43:03 Page 2
PXRMBMI ;SLC/PKR - National BMI and BSA computed finding. ;08/21/2019
+1 ;;2.0;CLINICAL REMINDERS;**12,18,42**;Feb 04, 2005;Build 245
+2 ;================================
BMI(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Multi-occurrence computed
+1 ;finding for BMI.
+2 NEW BMI,HDATE,HT,IND,TDATE,WHL,WT
+3 ;Get the list of weight and height measurements.
+4 DO WANDHL(DFN,NGET,BDT,EDT,.NFOUND,.WHL)
+5 FOR IND=1:1:NFOUND
Begin DoDot:1
+6 SET TDATE=$PIECE(WHL(IND),U,1)
SET WT=$PIECE(WHL(IND),U,2)
+7 SET HT=$PIECE(WHL(IND),U,3)
SET HDATE=$PIECE(WHL(IND),U,4)
+8 SET TEST(IND)=1
SET DATE(IND)=TDATE
+9 SET TEXT(IND)="height measured "_$$EDATE^PXRMDATE(HDATE)
+10 SET BMI=WT/(HT*HT)
+11 SET BMI=$FNUMBER(BMI,"",1)
+12 SET (DATA(IND,"VALUE"),DATA(IND,"BMI"))=BMI
End DoDot:1
+13 QUIT
+14 ;
+15 ;================================
BSA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Multi-occurrence computed
+1 ;finding for BSA. The coefficients have been adjusted for heights
+2 ;in cm and weights in kg expect for Boyd where the weight is grams.
+3 ;The default is to use the Mosteller formula.
+4 NEW BSA,FORMULA,HDATE,HT,IND,TDATE,TYPE,WHL,WT
+5 SET TYPE=$SELECT(TEST="":"M",TEST="M":"M",TEST="D":"D",TEST="H":"H",TEST="G":"G",TEST="B":"B",1:"M")
+6 SET FORMULA=$SELECT(TYPE="M":"Mosteller",TYPE="B":"Boyd",TYPE="D":"DuBois and Dubois",TYPE="H":"Haycock",TYPE="G":"Gehan and George",1:"Mosteller")_" formula"
+7 ;Get the list of weight and height measurements.
+8 DO WANDHL(DFN,NGET,BDT,EDT,.NFOUND,.WHL)
+9 FOR IND=1:1:NFOUND
Begin DoDot:1
+10 SET TDATE=$PIECE(WHL(IND),U,1)
SET WT=$PIECE(WHL(IND),U,2)
+11 SET HT=$PIECE(WHL(IND),U,3)
SET HDATE=$PIECE(WHL(IND),U,4)
+12 SET TEST(IND)=1
SET DATE(IND)=TDATE
+13 IF TYPE="M"
SET BSA=$$SQRT^XLFMTH((WT*HT)/36)
+14 IF TYPE="D"
SET BSA=.20247*$$PWR^XLFMTH(HT,.725)*$$PWR^XLFMTH(WT,.425)
+15 IF TYPE="H"
SET BSA=.15058*$$PWR^XLFMTH(HT,.3964)*$$PWR^XLFMTH(WT,.5378)
+16 IF TYPE="G"
SET BSA=.164*$$PWR^XLFMTH(HT,.42246)*$$PWR^XLFMTH(WT,.51456)
+17 IF TYPE="B"
Begin DoDot:2
+18 NEW WEXP
+19 SET WT=1000*WT
+20 SET WEXP=.7285-(.0188*$$LOG^XLFMTH(WT))
+21 SET BSA=.001277*$$PWR^XLFMTH(HT,.3)*$$PWR^XLFMTH(WT,WEXP)
End DoDot:2
+22 SET BSA=$FNUMBER(BSA,"",2)
+23 SET (DATA(IND,"VALUE"),DATA(IND,"BSA"))=BSA
+24 SET TEXT(IND)=FORMULA_", height measured "_$$EDATE^PXRMDATE(HDATE)
End DoDot:1
+25 QUIT
+26 ;
+27 ;================================
GHEIGHT(DFN,WDATE,HT,HDATE) ;Return the height measurement taken on the
+1 ;date closest to WDATE (WDATE is the date of the weight measurement).
+2 ;If no height is found return -1.
+3 NEW BCKDATE,DAS,DIFFL,DIFFS,DONE,FWDDATE,TEMP
+4 SET (DONE,HDATE)=0
SET HT=-1
+5 ;Check for height measured on same date and time.
+6 SET DAS=$ORDER(^PXRMINDX(120.5,"PI",DFN,8,WDATE,""))
+7 IF DAS'=""
Begin DoDot:1
+8 DO GETDATA^PXRMVITL(DAS,.TEMP)
+9 IF TEMP("RATE")'=+TEMP("RATE")
QUIT
+10 SET HT=+(TEMP("RATE")*0.0254)
SET HDATE=WDATE
SET DONE=1
End DoDot:1
+11 IF 'DONE
SET (BCKDATE,FWDDATE)=WDATE
+12 FOR
if DONE
QUIT
Begin DoDot:1
+13 SET BCKDATE=+$ORDER(^PXRMINDX(120.5,"PI",DFN,8,BCKDATE),-1)
+14 SET FWDDATE=+$ORDER(^PXRMINDX(120.5,"PI",DFN,8,FWDDATE))
+15 IF (BCKDATE=0)
IF (FWDDATE=0)
SET DONE=1
QUIT
+16 IF BCKDATE>0
SET DIFFS=$$FMDIFF^XLFDT(WDATE,BCKDATE,2)
SET DIFFL(DIFFS,BCKDATE)=""
+17 IF FWDDATE>0
SET DIFFS=$$FMDIFF^XLFDT(FWDDATE,WDATE,2)
SET DIFFL(DIFFS,FWDDATE)=""
+18 SET DIFFS=$ORDER(DIFFL(""))
SET HDATE=$ORDER(DIFFL(DIFFS,""))
+19 IF HDATE=0
QUIT
+20 SET DAS=$ORDER(^PXRMINDX(120.5,"PI",DFN,8,HDATE,""))
+21 DO GETDATA^PXRMVITL(DAS,.TEMP)
+22 IF (TEMP("RATE")'=+TEMP("RATE"))!(TEMP("RATE")=0)
KILL DIFFL(DIFFS,HDATE)
QUIT
+23 SET HT=+(TEMP("RATE")*0.0254)
+24 SET DONE=1
End DoDot:1
+25 QUIT
+26 ;
+27 ;================================
WANDHL(DFN,NGET,BDT,EDT,NFOUND,WHL) ;Return an ordered and
+1 ;paired list of weight and height measurements. Weight is in kilograms
+2 ;and height is in meters.
+3 NEW DAS,DIFFL,DIFFS,DONE,HT,HDATE,NOCC
+4 NEW SDIR,TDATE,TEMP,WLIST,WT
+5 SET SDIR=$SELECT(NGET>0:-1,1:1)
+6 SET NOCC=$SELECT(NGET>0:NGET,1:-NGET)
+7 ;Get a list of weight measurements in the date range.
+8 SET TDATE=BDT-.000001
+9 FOR
SET TDATE=+$ORDER(^PXRMINDX(120.5,"PI",DFN,9,TDATE))
if (TDATE=0)!(TDATE>EDT)
QUIT
Begin DoDot:1
+10 SET DAS=$ORDER(^PXRMINDX(120.5,"PI",DFN,9,TDATE,""))
+11 SET WLIST(TDATE)=DAS
End DoDot:1
+12 ;Get up to NOCC BMI values.
+13 SET TDATE=""
SET (DONE,NFOUND)=0
+14 FOR
SET TDATE=$ORDER(WLIST(TDATE),SDIR)
if (DONE)!(TDATE="")
QUIT
Begin DoDot:1
+15 SET DAS=WLIST(TDATE)
+16 KILL TEMP
+17 DO GETDATA^PXRMVITL(DAS,.TEMP)
+18 IF TEMP("RATE")'=+TEMP("RATE")
QUIT
+19 SET WT=+TEMP("RATE")*0.4535924
+20 ;Find the closest height measurement.
+21 DO GHEIGHT(DFN,TDATE,.HT,.HDATE)
+22 IF HT=-1
QUIT
+23 SET NFOUND=NFOUND+1
+24 SET WHL(NFOUND)=TDATE_U_WT_U_HT_U_HDATE
+25 IF NFOUND=NOCC
SET DONE=1
End DoDot:1
+26 QUIT
+27 ;
