- 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