APCL2A3 ; IHS/CMI/LAB - BODY MASS INDEX & RELATIVE WEIGHT FOR MEASUREMENT TRANSFORMS ;
;;2.0;IHS PCC SUITE;**4**;MAY 14, 2009
;DL/IHS/TPA 12-2-91
;IHS/TUCSON/LAB - patch 1 adds $G statement on error code 06/02/97
;
BMI(APCLPAT,APCLWT,APCLSDAT) ; ENTRY POINT - TO OBTAIN BODY MASS INDEX
NEW APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA
;------------
I (APCLWT="")!(APCLSDAT="")!(APCLPAT="") G ERROR
;------------
D COMMON G:$E(APCLCOMT)="!" ERROR
;S APCLWT=(APCLWT/5)*2.3,APCLHT=(APCLHT*2.5),APCLHT=(APCLHT*APCLHT)/10000,APCLBMI=(APCLWT/APCLHT),APCLBMI=$J(APCLBMI,5,1)
S APCLWT=APCLWT*.45359,APCLHT=(APCLHT*.0254),APCLHT=(APCLHT*APCLHT),APCLBMI=(APCLWT/APCLHT),APCLBMI=$J(APCLBMI,5,1)
S APCLSWT=APCLBMI_$S(APCLCOMT]"":" **",1:" ")
G EXIT
;
RW(APCLPAT,APCLWT,APCLSDAT) ; ENTRY POINT - TO OBTAIN RELATIVE WEIGHT PERCENTAGE
NEW APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA
;------------
I (APCLWT="")!(APCLSDAT="")!(APCLPAT="") G ERROR
;------------
D COMMON G:$E(APCLCOMT)="!" ERROR
I (APCLHT>70)!(APCLHT<58)&(APCLSEX="F") S APCLCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR
I (APCLHT>75)!(APCLHT<61)&(APCLSEX="M") S APCLCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR
S APCLHT=APCLHT-57,APCLRW=$P($T(SIZES+APCLHT),";;",APCLSX),APCLPRW=(APCLWT*100/APCLRW)\1
S APCLSWT=APCLPRW_"%"_$S(APCLCOMT]"":" **",1:" ")
G EXIT
ERROR S:$G(APCLCOMT)="" APCLCOMT="" S APCLSWT="***",APCLCOMT="*** "_$E(APCLCOMT,2,$L(APCLCOMT)) ;IHS/TUCSON/LAB patch 1 added $G statement
EXIT K X,X1,X2 ; note that the rest of the variables were NEWed
S Y=APCLSWT_"^"_$G(APCLCOMT)
K APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA,APCLSDAT
Q Y
;
COMMON ;OBTAIN DOB, AGE, SEX, and COMN
;------------
I '$D(^AUPNVMSR("AA",APCLPAT,1)) S APCLCOMT="!NO HEIGHT FOR PATIENT." Q
S APCLDOB=$P(^DPT(APCLPAT,0),U,3),APCLSEX=$P(^DPT(APCLPAT,0),U,2),X2=APCLDOB,X1=DT D ^%DTC S APCLAGE=X,APCLSX=$S(APCLSEX="M":2,APCLSEX="F":3,1:"")
S APCLCOMT=""
S APCLDA="",APCLHDA=""
NXTHT S APCLDA=0 F S APCLDA=$O(^AUPNVMSR("AA",APCLPAT,1,APCLSDAT,APCLDA)) Q:APCLDA'=+APCLDA D
.Q:$P($G(^AUPNVMSR(APCLDA,2)),U,1)
.S APCLHDA=APCLDA
S APCLDA=APCLHDA
G:APCLDA]"" HITE
NXTDATE S APCLSDAT=$O(^AUPNVMSR("AA",APCLPAT,1,APCLSDAT)) G:APCLSDAT]"" NXTHT
S APCLCOMT="!NO HEIGHT FOUND." Q
HITE S X1=9999999-(APCLSDAT\1),X2=APCLDOB D ^%DTC S APCLMDT=X
S APCLHT=$P(^AUPNVMSR(APCLDA,0),U,4),X1=DT,X2=9999999-(APCLSDAT\1) D ^%DTC
I ((X>90)&(APCLAGE<1096))!((X>180)&(APCLAGE<4381))!((X>365)&(APCLAGE<6571))!((APCLMDT<6571)&(APCLAGE>6571)) S APCLCOMT="** HEIGHT MAY BE OLD."
Q
;
;; TEMPORARY ENTRY POINTS UNTIL FILEMAN WILL ACCEPT $$FUNCTIONS
;
SIZES ;;
;;;;107
;;;;110
;;;;113
;;120;;116
;;123;;119
;;126;;123
;;130;;126
;;133;;130
;;138;;134
;;142;;138
;;146;;143
;;150;;147
;;155;;152
;;159
;;164
;;168
;;173
;;177
APCL2A3 ; IHS/CMI/LAB - BODY MASS INDEX & RELATIVE WEIGHT FOR MEASUREMENT TRANSFORMS ;
+1 ;;2.0;IHS PCC SUITE;**4**;MAY 14, 2009
+2 ;DL/IHS/TPA 12-2-91
+3 ;IHS/TUCSON/LAB - patch 1 adds $G statement on error code 06/02/97
+4 ;
BMI(APCLPAT,APCLWT,APCLSDAT) ; ENTRY POINT - TO OBTAIN BODY MASS INDEX
+1 NEW APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA
+2 ;------------
+3 IF (APCLWT="")!(APCLSDAT="")!(APCLPAT="")
GOTO ERROR
+4 ;------------
+5 DO COMMON
IF $EXTRACT(APCLCOMT)="!"
GOTO ERROR
+6 ;S APCLWT=(APCLWT/5)*2.3,APCLHT=(APCLHT*2.5),APCLHT=(APCLHT*APCLHT)/10000,APCLBMI=(APCLWT/APCLHT),APCLBMI=$J(APCLBMI,5,1)
+7 SET APCLWT=APCLWT*.45359
SET APCLHT=(APCLHT*.0254)
SET APCLHT=(APCLHT*APCLHT)
SET APCLBMI=(APCLWT/APCLHT)
SET APCLBMI=$JUSTIFY(APCLBMI,5,1)
+8 SET APCLSWT=APCLBMI_$SELECT(APCLCOMT]"":" **",1:" ")
+9 GOTO EXIT
+10 ;
RW(APCLPAT,APCLWT,APCLSDAT) ; ENTRY POINT - TO OBTAIN RELATIVE WEIGHT PERCENTAGE
+1 NEW APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA
+2 ;------------
+3 IF (APCLWT="")!(APCLSDAT="")!(APCLPAT="")
GOTO ERROR
+4 ;------------
+5 DO COMMON
IF $EXTRACT(APCLCOMT)="!"
GOTO ERROR
+6 IF (APCLHT>70)!(APCLHT<58)&(APCLSEX="F")
SET APCLCOMT="!HEIGHT OUT OF RANGE FOR SEX."
GOTO ERROR
+7 IF (APCLHT>75)!(APCLHT<61)&(APCLSEX="M")
SET APCLCOMT="!HEIGHT OUT OF RANGE FOR SEX."
GOTO ERROR
+8 SET APCLHT=APCLHT-57
SET APCLRW=$PIECE($TEXT(SIZES+APCLHT),";;",APCLSX)
SET APCLPRW=(APCLWT*100/APCLRW)\1
+9 SET APCLSWT=APCLPRW_"%"_$SELECT(APCLCOMT]"":" **",1:" ")
+10 GOTO EXIT
ERROR ;IHS/TUCSON/LAB patch 1 added $G statement
IF $GET(APCLCOMT)=""
SET APCLCOMT=""
SET APCLSWT="***"
SET APCLCOMT="*** "_$EXTRACT(APCLCOMT,2,$LENGTH(APCLCOMT))
EXIT ; note that the rest of the variables were NEWed
KILL X,X1,X2
+1 SET Y=APCLSWT_"^"_$GET(APCLCOMT)
+2 KILL APCLDOB,APCLSEX,APCLAGE,APCLSX,APCLHT,APCLBMI,APCLPRW,APCLSWT,APCLCOMT,APCLRW,APCLMDT,APCLDA,APCLSDAT
+3 QUIT Y
+4 ;
COMMON ;OBTAIN DOB, AGE, SEX, and COMN
+1 ;------------
+2 IF '$DATA(^AUPNVMSR("AA",APCLPAT,1))
SET APCLCOMT="!NO HEIGHT FOR PATIENT."
QUIT
+3 SET APCLDOB=$PIECE(^DPT(APCLPAT,0),U,3)
SET APCLSEX=$PIECE(^DPT(APCLPAT,0),U,2)
SET X2=APCLDOB
SET X1=DT
DO ^%DTC
SET APCLAGE=X
SET APCLSX=$SELECT(APCLSEX="M":2,APCLSEX="F":3,1:"")
+4 SET APCLCOMT=""
+5 SET APCLDA=""
SET APCLHDA=""
NXTHT SET APCLDA=0
FOR
SET APCLDA=$ORDER(^AUPNVMSR("AA",APCLPAT,1,APCLSDAT,APCLDA))
IF APCLDA'=+APCLDA
QUIT
Begin DoDot:1
+1 IF $PIECE($GET(^AUPNVMSR(APCLDA,2)),U,1)
QUIT
+2 SET APCLHDA=APCLDA
End DoDot:1
+3 SET APCLDA=APCLHDA
+4 IF APCLDA]""
GOTO HITE
NXTDATE SET APCLSDAT=$ORDER(^AUPNVMSR("AA",APCLPAT,1,APCLSDAT))
IF APCLSDAT]""
GOTO NXTHT
+1 SET APCLCOMT="!NO HEIGHT FOUND."
QUIT
HITE SET X1=9999999-(APCLSDAT\1)
SET X2=APCLDOB
DO ^%DTC
SET APCLMDT=X
+1 SET APCLHT=$PIECE(^AUPNVMSR(APCLDA,0),U,4)
SET X1=DT
SET X2=9999999-(APCLSDAT\1)
DO ^%DTC
+2 IF ((X>90)&(APCLAGE<1096))!((X>180)&(APCLAGE<4381))!((X>365)&(APCLAGE<6571))!((APCLMDT<6571)&(APCLAGE>6571))
SET APCLCOMT="** HEIGHT MAY BE OLD."
+3 QUIT
+4 ;
+5 ;; TEMPORARY ENTRY POINTS UNTIL FILEMAN WILL ACCEPT $$FUNCTIONS
+6 ;
SIZES ;;
+1 ;;;;107
+2 ;;;;110
+3 ;;;;113
+4 ;;120;;116
+5 ;;123;;119
+6 ;;126;;123
+7 ;;130;;126
+8 ;;133;;130
+9 ;;138;;134
+10 ;;142;;138
+11 ;;146;;143
+12 ;;150;;147
+13 ;;155;;152
+14 ;;159
+15 ;;164
+16 ;;168
+17 ;;173
+18 ;;177
