BPXRMBMI ; SLC/PKR - This is an example of a computed finding. ;26-Sep-2006 13:44;MGH
;;1.5;CLINICAL REMINDERS;**1004**;Jun 19, 2000
;IHS/CIA/MGH Patch 1004 Routine for Computed findings for BMI
;=======================================================================
BMI(DFN,TEST,DATE,VALUE,TEXT) ; EP Computed finding to return the BMI
N BMI,HT,WT,HTDATE,WTDATE,HTDATA,WTDATA,X,Y,TODAY
S (TEST,DATE,VALUE,TEXT)=""
S X="TODAY" D ^%DT S TODAY=Y
D CALCLATE I TEST=0 S DATE=TODAY,VALUE="" Q
I (HTDATE'="")&(WTDATE'="") D
.S DATE=$$MIN^XLFMTH(HTDATE,WTDATE)
S TEST=1
I BMI="" S VALUE="?"
E S VALUE=BMI
Q
CALCLATE ;Calculate the BMI
S HTDATA=$$LASTMSR($G(DFN),"HT") I HTDATA<1 S TEST=0 Q
S WTDATA=$$LASTMSR($G(DFN),"WT") I WTDATA<1 S TEST=0 Q
S BMI=""
S HT=$P(HTDATA,U,1),HTDATE=$P(HTDATA,U,3)
S WT=$P(WTDATA,U,1),WTDATE=$P(WTDATA,U,3)
S WT=WT*.45359,HT=HT*.0254,HT=HT*HT,BMI=+$J(WT/HT,0,2)
Q
LASTMSR(DFN,MSR) ;--Returns most current measurement
NEW VDT,IEN,X,TIU,LINE,ARR,DATE,STOP,BPX
S MSR=$O(^AUTTMSR("B",MSR,0)) I MSR="" Q ""
;
S STOP=$O(^AUPNVMSR("AA",DFN,MSR,0))\1 ;stop at most recent date
I 'STOP Q "" ;none to be found
S VDT=0
F S VDT=$O(^AUPNVMSR("AA",DFN,MSR,VDT)) Q:'VDT!(VDT\1'=STOP) D
. S IEN=0
. F S IEN=$O(^AUPNVMSR("AA",DFN,MSR,VDT,IEN)) Q:'IEN D
.. K ARR D ENP^XBDIQ1(9000010.01,IEN,".03;.04;1201","BPX(","I")
.. ; value ^ visit ien ^ event date internal format
.. S LINE=$G(BPX(.04))_U_$G(BPX(.03,"I"))_U_$G(BPX(1201,"I"))
.. S DATE=$S($G(BPX(1201,"I"))]"":BPX(1201,"I"),1:(9999999-$P(VDT,"."))_"."_$P(VDT,".",2))
.. S ARR(DATE,IEN)=LINE
I '$D(ARR) Q ""
S DATE=$O(ARR(""),-1),IEN=$O(ARR(DATE,""),-1),LINE=ARR(DATE,IEN)
Q $G(LINE)
HIBMI(DFN,TEST,DATE,VALUE,TEXT) ;EP Find BMI < 25
N BMI,HT,WT,HTDATE,WTDATE,HTDATA,WTDATA,X,Y,TODAY
S (TEST,DATE,VALUE,TEXT)=""
S X="TODAY" D ^%DT S TODAY=Y
D CALCLATE I TEST=0 S DATE=TODAY,VALUE="" Q
S DATE=$$MIN^XLFMTH(HTDATE,WTDATE)
I BMI="" S TEST=0,VALUE="?"
I BMI>25 S TEST=1,VALUE=BMI
I BMI=25 S TEST=1,VALUE=BMI
I BMI<25 S TEST=0,VALUE=BMI
Q
HIPCENT(DFN,TEST,DATE,VALUE,TEXT) ;EP Find the patients wt percentile
N PERCENT,WTDATE,X,Y,TODAY,PERC
S X="TODAY" D ^%DT S TODAY=Y
D PERCENT(DFN) I TEST=0 S DATE=TODAY,VALUE="" Q
I PERC<85 S TEST=0,VALUE=PERC,DATE=WTDATE
I PERC>85 S TEST=1,VALUE=PERC,DATE=WTDATE
Q
PERCENT(DFN) ;Find the wt percentile
N MOAGE,AGE,SEX,WTDATA,WT
S SEX=$$GET1^DIQ(2,DFN,.02,"I")
S AGE=$$GET1^DIQ(2,DFN,.03,"I")
D AGEMO
S WTDATA=$$LASTMSR($G(DFN),"WT") I WTDATA<1 S TEST=0 Q
S WT=$P(WTDATA,U,1),WTDATE=$P(WTDATA,U,3)
S PERC=$$AUHTWT^APCHS2A2("WT",SEX,MOAGE,WT)
I $E(PERC,1,1)=">"!($E(PERC,1,1)="<") S PERC=$E(PERC,2,$L(PERC))
Q
AGEMO ;Get age in months
N YR,MO
S X="TODAY" D ^%DT S TODAY=Y
S YR=$E(TODAY,1,3)-$E(AGE,1,3),MO=$E(TODAY,4,5)-$E(AGE,4,5)
I MO<0 S MO=MO+12,YR=YR-1
S MOAGE=12*YR+MO
Q
BPXRMBMI ; SLC/PKR - This is an example of a computed finding. ;26-Sep-2006 13:44;MGH
+1 ;;1.5;CLINICAL REMINDERS;**1004**;Jun 19, 2000
+2 ;IHS/CIA/MGH Patch 1004 Routine for Computed findings for BMI
+3 ;=======================================================================
BMI(DFN,TEST,DATE,VALUE,TEXT) ; EP Computed finding to return the BMI
+1 NEW BMI,HT,WT,HTDATE,WTDATE,HTDATA,WTDATA,X,Y,TODAY
+2 SET (TEST,DATE,VALUE,TEXT)=""
+3 SET X="TODAY"
DO ^%DT
SET TODAY=Y
+4 DO CALCLATE
IF TEST=0
SET DATE=TODAY
SET VALUE=""
QUIT
+5 IF (HTDATE'="")&(WTDATE'="")
Begin DoDot:1
+6 SET DATE=$$MIN^XLFMTH(HTDATE,WTDATE)
End DoDot:1
+7 SET TEST=1
+8 IF BMI=""
SET VALUE="?"
+9 IF '$TEST
SET VALUE=BMI
+10 QUIT
CALCLATE ;Calculate the BMI
+1 SET HTDATA=$$LASTMSR($GET(DFN),"HT")
IF HTDATA<1
SET TEST=0
QUIT
+2 SET WTDATA=$$LASTMSR($GET(DFN),"WT")
IF WTDATA<1
SET TEST=0
QUIT
+3 SET BMI=""
+4 SET HT=$PIECE(HTDATA,U,1)
SET HTDATE=$PIECE(HTDATA,U,3)
+5 SET WT=$PIECE(WTDATA,U,1)
SET WTDATE=$PIECE(WTDATA,U,3)
+6 SET WT=WT*.45359
SET HT=HT*.0254
SET HT=HT*HT
SET BMI=+$JUSTIFY(WT/HT,0,2)
+7 QUIT
LASTMSR(DFN,MSR) ;--Returns most current measurement
+1 NEW VDT,IEN,X,TIU,LINE,ARR,DATE,STOP,BPX
+2 SET MSR=$ORDER(^AUTTMSR("B",MSR,0))
IF MSR=""
QUIT ""
+3 ;
+4 ;stop at most recent date
SET STOP=$ORDER(^AUPNVMSR("AA",DFN,MSR,0))\1
+5 ;none to be found
IF 'STOP
QUIT ""
+6 SET VDT=0
+7 FOR
SET VDT=$ORDER(^AUPNVMSR("AA",DFN,MSR,VDT))
IF 'VDT!(VDT\1'=STOP)
QUIT
Begin DoDot:1
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(^AUPNVMSR("AA",DFN,MSR,VDT,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+10 KILL ARR
DO ENP^XBDIQ1(9000010.01,IEN,".03;.04;1201","BPX(","I")
+11 ; value ^ visit ien ^ event date internal format
+12 SET LINE=$GET(BPX(.04))_U_$GET(BPX(.03,"I"))_U_$GET(BPX(1201,"I"))
+13 SET DATE=$SELECT($GET(BPX(1201,"I"))]"":BPX(1201,"I"),1:(9999999-$PIECE(VDT,"."))_"."_$PIECE(VDT,".",2))
+14 SET ARR(DATE,IEN)=LINE
End DoDot:2
End DoDot:1
+15 IF '$DATA(ARR)
QUIT ""
+16 SET DATE=$ORDER(ARR(""),-1)
SET IEN=$ORDER(ARR(DATE,""),-1)
SET LINE=ARR(DATE,IEN)
+17 QUIT $GET(LINE)
HIBMI(DFN,TEST,DATE,VALUE,TEXT) ;EP Find BMI < 25
+1 NEW BMI,HT,WT,HTDATE,WTDATE,HTDATA,WTDATA,X,Y,TODAY
+2 SET (TEST,DATE,VALUE,TEXT)=""
+3 SET X="TODAY"
DO ^%DT
SET TODAY=Y
+4 DO CALCLATE
IF TEST=0
SET DATE=TODAY
SET VALUE=""
QUIT
+5 SET DATE=$$MIN^XLFMTH(HTDATE,WTDATE)
+6 IF BMI=""
SET TEST=0
SET VALUE="?"
+7 IF BMI>25
SET TEST=1
SET VALUE=BMI
+8 IF BMI=25
SET TEST=1
SET VALUE=BMI
+9 IF BMI<25
SET TEST=0
SET VALUE=BMI
+10 QUIT
HIPCENT(DFN,TEST,DATE,VALUE,TEXT) ;EP Find the patients wt percentile
+1 NEW PERCENT,WTDATE,X,Y,TODAY,PERC
+2 SET X="TODAY"
DO ^%DT
SET TODAY=Y
+3 DO PERCENT(DFN)
IF TEST=0
SET DATE=TODAY
SET VALUE=""
QUIT
+4 IF PERC<85
SET TEST=0
SET VALUE=PERC
SET DATE=WTDATE
+5 IF PERC>85
SET TEST=1
SET VALUE=PERC
SET DATE=WTDATE
+6 QUIT
PERCENT(DFN) ;Find the wt percentile
+1 NEW MOAGE,AGE,SEX,WTDATA,WT
+2 SET SEX=$$GET1^DIQ(2,DFN,.02,"I")
+3 SET AGE=$$GET1^DIQ(2,DFN,.03,"I")
+4 DO AGEMO
+5 SET WTDATA=$$LASTMSR($GET(DFN),"WT")
IF WTDATA<1
SET TEST=0
QUIT
+6 SET WT=$PIECE(WTDATA,U,1)
SET WTDATE=$PIECE(WTDATA,U,3)
+7 SET PERC=$$AUHTWT^APCHS2A2("WT",SEX,MOAGE,WT)
+8 IF $EXTRACT(PERC,1,1)=">"!($EXTRACT(PERC,1,1)="<")
SET PERC=$EXTRACT(PERC,2,$LENGTH(PERC))
+9 QUIT
AGEMO ;Get age in months
+1 NEW YR,MO
+2 SET X="TODAY"
DO ^%DT
SET TODAY=Y
+3 SET YR=$EXTRACT(TODAY,1,3)-$EXTRACT(AGE,1,3)
SET MO=$EXTRACT(TODAY,4,5)-$EXTRACT(AGE,4,5)
+4 IF MO<0
SET MO=MO+12
SET YR=YR-1
+5 SET MOAGE=12*YR+MO
+6 QUIT
