- 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
