APCHS2A3 ; IHS/CMI/LAB - BODY MASS INDEX & RELATIVE WEIGHT FOR MEASUREMENT TRANSFORMS ;
;;2.0;IHS PCC SUITE;**4,13**;MAY 14, 2009;Build 9
;
BMI(APCHPAT,APCHWT,APCHDATE) ; ENTRY POINT - TO OBTAIN BODY MASS INDEX
NEW APCHDOB,APCHSEX,APCHAGE,APCHSX,APCHHT,APCHBMI,APCHPRW,APCHSWT,APCHCOMT,APCHRW,APCHMDT,APCHDA
;------------
I (APCHWT="")!(APCHDATE="")!(APCHPAT="") S APCHCOMT="!MISSING VALUE" G ERROR ;IHS/CMI/LAB 091615
;------------
D COMMON G:$E(APCHCOMT)="!" ERROR
I $G(APCHHT)="" S APCHCOMT="!NO HEIGHT FOR PATIENT" G ERROR
;S APCHWT=(APCHWT/5)*2.3,APCHHT=(APCHHT*2.5),APCHHT=(APCHHT*APCHHT)/10000,APCHBMI=(APCHWT/APCHHT),APCHBMI=$J(APCHBMI,5,1)
S APCHWT=APCHWT*.45359,APCHHT=(APCHHT*.0254),APCHHT=APCHHT*APCHHT,APCHBMI=(APCHWT/APCHHT),APCHBMI=$J(APCHBMI,5,1)
S APCHSWT=APCHBMI_$S(APCHCOMT]"":" **",1:" ")
G EXIT
;
RW(APCHPAT,APCHWT,APCHDATE) ; ENTRY POINT - TO OBTAIN RELATIVE WEIGHT PERCENTAGE
NEW APCHDOB,APCHSEX,APCHAGE,APCHSX,APCHHT,APCHBMI,APCHPRW,APCHSWT,APCHCOMT,APCHRW,APCHMDT,APCHDA
;------------
I (APCHWT="")!(APCHDATE="")!(APCHPAT="") S APCHCOMT="!MISSING VALUE" G ERROR ;IHS/CMI/LAB 091615
;------------
D COMMON G:$E(APCHCOMT)="!" ERROR
I (APCHHT>70)!(APCHHT<58)&(APCHSEX="F") S APCHCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR
I (APCHHT>75)!(APCHHT<61)&(APCHSEX="M") S APCHCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR
S APCHHT=APCHHT-57,APCHRW=$P($T(SIZES+APCHHT),";;",APCHSX),APCHPRW=(APCHWT*100/APCHRW)\1
S APCHSWT=APCHPRW_"%"_$S(APCHCOMT]"":" **",1:" ")
G EXIT
ERROR S APCHSWT="***",APCHCOMT="*** "_$E(APCHCOMT,2,$L(APCHCOMT))
EXIT K X,X1,X2 ; note that the rest of the variables were NEWed
S Y=APCHSWT_"^"_$G(APCHCOMT)
K APCHDOB,APCHSEX,APCHAGE,APCHSX,APCHHT,APCHBMI,APCHPRW,APCHSWT,APCHCOMT,APCHRW,APCHMDT,APCHDA,APCHDATE,APCHPAT,APCHWT,APCHHPTR
Q Y
;
COMMON ;OBTAIN DOB, AGE, SEX, and COMN
;------------
S APCHHPTR=$O(^AUTTMSR("B","HT",0)) ;IHS/CMI/GRL APCH*2.0*9
;I '$D(^AUPNVMSR("AA",APCHPAT,1)) S APCHCOMT="!NO HEIGHT FOR PATIENT." Q
I '$D(^AUPNVMSR("AA",APCHPAT,APCHHPTR)) S APCHCOMT="!NO HEIGHT FOR PATIENT." Q ;IHS/CMI/GRL APCH*2.0*9
S APCHDOB=$P(^DPT(APCHPAT,0),U,3),APCHSEX=$P(^DPT(APCHPAT,0),U,2),X2=APCHDOB,X1=DT D ^%DTC S APCHAGE=X,APCHSX=$S(APCHSEX="M":2,APCHSEX="F":3,1:"")
S APCHCOMT=""
S APCHDA="",APCHHDA=""
NXTHT S APCHDA=0 F S APCHDA=$O(^AUPNVMSR("AA",APCHPAT,APCHHPTR,APCHDATE,APCHDA)) Q:APCHDA'=+APCHDA D
.Q:$P($G(^AUPNVMSR(APCHDA,2)),U,1)
.S APCHHDA=APCHDA
S APCHDA=APCHHDA
G:APCHDA]"" HITE ;IHS/CMI/GRL APCH*2.0*9
;S APCHDA=$O(^AUPNVMSR("AA",APCHPAT,1,APCHDATE,"")) G:APCHDA]"" HITE
NXTDATE S APCHDATE=$O(^AUPNVMSR("AA",APCHPAT,APCHHPTR,APCHDATE)) G:APCHDATE]"" NXTHT ;IHS/CMI/GRL APCH*2.9*9
;S APCHDATE=$O(^AUPNVMSR("AA",APCHPAT,1,APCHDATE)) G:APCHDATE]"" NXTHT
S APCHCOMT="!NO HEIGHT IN APPROPRIATE TIME FRAME FOR COMPUTING BMI AND %RW." Q
HITE S X1=9999999-(APCHDATE\1),X2=APCHDOB D ^%DTC S APCHMDT=X
S APCHHT=$P(^AUPNVMSR(APCHDA,0),U,4),X1=DT,X2=9999999-(APCHDATE\1) D ^%DTC
I ((X>90)&(APCHAGE<1096))!((X>180)&(APCHAGE<4381))!((X>365)&(APCHAGE<6571))!((APCHMDT<6571)&(APCHAGE>6571)) S APCHCOMT="** 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
APCHS2A3 ; IHS/CMI/LAB - BODY MASS INDEX & RELATIVE WEIGHT FOR MEASUREMENT TRANSFORMS ;
+1 ;;2.0;IHS PCC SUITE;**4,13**;MAY 14, 2009;Build 9
+2 ;
BMI(APCHPAT,APCHWT,APCHDATE) ; ENTRY POINT - TO OBTAIN BODY MASS INDEX
+1 NEW APCHDOB,APCHSEX,APCHAGE,APCHSX,APCHHT,APCHBMI,APCHPRW,APCHSWT,APCHCOMT,APCHRW,APCHMDT,APCHDA
+2 ;------------
+3 ;IHS/CMI/LAB 091615
IF (APCHWT="")!(APCHDATE="")!(APCHPAT="")
SET APCHCOMT="!MISSING VALUE"
GOTO ERROR
+4 ;------------
+5 DO COMMON
IF $EXTRACT(APCHCOMT)="!"
GOTO ERROR
+6 IF $GET(APCHHT)=""
SET APCHCOMT="!NO HEIGHT FOR PATIENT"
GOTO ERROR
+7 ;S APCHWT=(APCHWT/5)*2.3,APCHHT=(APCHHT*2.5),APCHHT=(APCHHT*APCHHT)/10000,APCHBMI=(APCHWT/APCHHT),APCHBMI=$J(APCHBMI,5,1)
+8 SET APCHWT=APCHWT*.45359
SET APCHHT=(APCHHT*.0254)
SET APCHHT=APCHHT*APCHHT
SET APCHBMI=(APCHWT/APCHHT)
SET APCHBMI=$JUSTIFY(APCHBMI,5,1)
+9 SET APCHSWT=APCHBMI_$SELECT(APCHCOMT]"":" **",1:" ")
+10 GOTO EXIT
+11 ;
RW(APCHPAT,APCHWT,APCHDATE) ; ENTRY POINT - TO OBTAIN RELATIVE WEIGHT PERCENTAGE
+1 NEW APCHDOB,APCHSEX,APCHAGE,APCHSX,APCHHT,APCHBMI,APCHPRW,APCHSWT,APCHCOMT,APCHRW,APCHMDT,APCHDA
+2 ;------------
+3 ;IHS/CMI/LAB 091615
IF (APCHWT="")!(APCHDATE="")!(APCHPAT="")
SET APCHCOMT="!MISSING VALUE"
GOTO ERROR
+4 ;------------
+5 DO COMMON
IF $EXTRACT(APCHCOMT)="!"
GOTO ERROR
+6 IF (APCHHT>70)!(APCHHT<58)&(APCHSEX="F")
SET APCHCOMT="!HEIGHT OUT OF RANGE FOR SEX."
GOTO ERROR
+7 IF (APCHHT>75)!(APCHHT<61)&(APCHSEX="M")
SET APCHCOMT="!HEIGHT OUT OF RANGE FOR SEX."
GOTO ERROR
+8 SET APCHHT=APCHHT-57
SET APCHRW=$PIECE($TEXT(SIZES+APCHHT),";;",APCHSX)
SET APCHPRW=(APCHWT*100/APCHRW)\1
+9 SET APCHSWT=APCHPRW_"%"_$SELECT(APCHCOMT]"":" **",1:" ")
+10 GOTO EXIT
ERROR SET APCHSWT="***"
SET APCHCOMT="*** "_$EXTRACT(APCHCOMT,2,$LENGTH(APCHCOMT))
EXIT ; note that the rest of the variables were NEWed
KILL X,X1,X2
+1 SET Y=APCHSWT_"^"_$GET(APCHCOMT)
+2 KILL APCHDOB,APCHSEX,APCHAGE,APCHSX,APCHHT,APCHBMI,APCHPRW,APCHSWT,APCHCOMT,APCHRW,APCHMDT,APCHDA,APCHDATE,APCHPAT,APCHWT,APCHHPTR
+3 QUIT Y
+4 ;
COMMON ;OBTAIN DOB, AGE, SEX, and COMN
+1 ;------------
+2 ;IHS/CMI/GRL APCH*2.0*9
SET APCHHPTR=$ORDER(^AUTTMSR("B","HT",0))
+3 ;I '$D(^AUPNVMSR("AA",APCHPAT,1)) S APCHCOMT="!NO HEIGHT FOR PATIENT." Q
+4 ;IHS/CMI/GRL APCH*2.0*9
IF '$DATA(^AUPNVMSR("AA",APCHPAT,APCHHPTR))
SET APCHCOMT="!NO HEIGHT FOR PATIENT."
QUIT
+5 SET APCHDOB=$PIECE(^DPT(APCHPAT,0),U,3)
SET APCHSEX=$PIECE(^DPT(APCHPAT,0),U,2)
SET X2=APCHDOB
SET X1=DT
DO ^%DTC
SET APCHAGE=X
SET APCHSX=$SELECT(APCHSEX="M":2,APCHSEX="F":3,1:"")
+6 SET APCHCOMT=""
+7 SET APCHDA=""
SET APCHHDA=""
NXTHT SET APCHDA=0
FOR
SET APCHDA=$ORDER(^AUPNVMSR("AA",APCHPAT,APCHHPTR,APCHDATE,APCHDA))
IF APCHDA'=+APCHDA
QUIT
Begin DoDot:1
+1 IF $PIECE($GET(^AUPNVMSR(APCHDA,2)),U,1)
QUIT
+2 SET APCHHDA=APCHDA
End DoDot:1
+3 SET APCHDA=APCHHDA
+4 ;IHS/CMI/GRL APCH*2.0*9
IF APCHDA]""
GOTO HITE
+5 ;S APCHDA=$O(^AUPNVMSR("AA",APCHPAT,1,APCHDATE,"")) G:APCHDA]"" HITE
NXTDATE ;IHS/CMI/GRL APCH*2.9*9
SET APCHDATE=$ORDER(^AUPNVMSR("AA",APCHPAT,APCHHPTR,APCHDATE))
IF APCHDATE]""
GOTO NXTHT
+1 ;S APCHDATE=$O(^AUPNVMSR("AA",APCHPAT,1,APCHDATE)) G:APCHDATE]"" NXTHT
+2 SET APCHCOMT="!NO HEIGHT IN APPROPRIATE TIME FRAME FOR COMPUTING BMI AND %RW."
QUIT
HITE SET X1=9999999-(APCHDATE\1)
SET X2=APCHDOB
DO ^%DTC
SET APCHMDT=X
+1 SET APCHHT=$PIECE(^AUPNVMSR(APCHDA,0),U,4)
SET X1=DT
SET X2=9999999-(APCHDATE\1)
DO ^%DTC
+2 IF ((X>90)&(APCHAGE<1096))!((X>180)&(APCHAGE<4381))!((X>365)&(APCHAGE<6571))!((APCHMDT<6571)&(APCHAGE>6571))
SET APCHCOMT="** 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
