Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCL2A3

APCL2A3.m

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