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

APCHS2A3.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. 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
  1. ;------------
  1. I (APCHWT="")!(APCHDATE="")!(APCHPAT="") S APCHCOMT="!MISSING VALUE" G ERROR ;IHS/CMI/LAB 091615
  1. ;------------
  1. D COMMON G:$E(APCHCOMT)="!" ERROR
  1. I $G(APCHHT)="" S APCHCOMT="!NO HEIGHT FOR PATIENT" G ERROR
  1. ;S APCHWT=(APCHWT/5)*2.3,APCHHT=(APCHHT*2.5),APCHHT=(APCHHT*APCHHT)/10000,APCHBMI=(APCHWT/APCHHT),APCHBMI=$J(APCHBMI,5,1)
  1. S APCHWT=APCHWT*.45359,APCHHT=(APCHHT*.0254),APCHHT=APCHHT*APCHHT,APCHBMI=(APCHWT/APCHHT),APCHBMI=$J(APCHBMI,5,1)
  1. S APCHSWT=APCHBMI_$S(APCHCOMT]"":" **",1:" ")
  1. G EXIT
  1. ;
  1. 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
  1. ;------------
  1. I (APCHWT="")!(APCHDATE="")!(APCHPAT="") S APCHCOMT="!MISSING VALUE" G ERROR ;IHS/CMI/LAB 091615
  1. ;------------
  1. D COMMON G:$E(APCHCOMT)="!" ERROR
  1. I (APCHHT>70)!(APCHHT<58)&(APCHSEX="F") S APCHCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR
  1. I (APCHHT>75)!(APCHHT<61)&(APCHSEX="M") S APCHCOMT="!HEIGHT OUT OF RANGE FOR SEX." G ERROR
  1. S APCHHT=APCHHT-57,APCHRW=$P($T(SIZES+APCHHT),";;",APCHSX),APCHPRW=(APCHWT*100/APCHRW)\1
  1. S APCHSWT=APCHPRW_"%"_$S(APCHCOMT]"":" **",1:" ")
  1. G EXIT
  1. ERROR S APCHSWT="***",APCHCOMT="*** "_$E(APCHCOMT,2,$L(APCHCOMT))
  1. EXIT K X,X1,X2 ; note that the rest of the variables were NEWed
  1. S Y=APCHSWT_"^"_$G(APCHCOMT)
  1. K APCHDOB,APCHSEX,APCHAGE,APCHSX,APCHHT,APCHBMI,APCHPRW,APCHSWT,APCHCOMT,APCHRW,APCHMDT,APCHDA,APCHDATE,APCHPAT,APCHWT,APCHHPTR
  1. Q Y
  1. ;
  1. COMMON ;OBTAIN DOB, AGE, SEX, and COMN
  1. ;------------
  1. S APCHHPTR=$O(^AUTTMSR("B","HT",0)) ;IHS/CMI/GRL APCH*2.0*9
  1. ;I '$D(^AUPNVMSR("AA",APCHPAT,1)) S APCHCOMT="!NO HEIGHT FOR PATIENT." Q
  1. I '$D(^AUPNVMSR("AA",APCHPAT,APCHHPTR)) S APCHCOMT="!NO HEIGHT FOR PATIENT." Q ;IHS/CMI/GRL APCH*2.0*9
  1. 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:"")
  1. S APCHCOMT=""
  1. S APCHDA="",APCHHDA=""
  1. NXTHT S APCHDA=0 F S APCHDA=$O(^AUPNVMSR("AA",APCHPAT,APCHHPTR,APCHDATE,APCHDA)) Q:APCHDA'=+APCHDA D
  1. .Q:$P($G(^AUPNVMSR(APCHDA,2)),U,1)
  1. .S APCHHDA=APCHDA
  1. S APCHDA=APCHHDA
  1. G:APCHDA]"" HITE ;IHS/CMI/GRL APCH*2.0*9
  1. ;S APCHDA=$O(^AUPNVMSR("AA",APCHPAT,1,APCHDATE,"")) G:APCHDA]"" HITE
  1. NXTDATE S APCHDATE=$O(^AUPNVMSR("AA",APCHPAT,APCHHPTR,APCHDATE)) G:APCHDATE]"" NXTHT ;IHS/CMI/GRL APCH*2.9*9
  1. ;S APCHDATE=$O(^AUPNVMSR("AA",APCHPAT,1,APCHDATE)) G:APCHDATE]"" NXTHT
  1. S APCHCOMT="!NO HEIGHT IN APPROPRIATE TIME FRAME FOR COMPUTING BMI AND %RW." Q
  1. HITE S X1=9999999-(APCHDATE\1),X2=APCHDOB D ^%DTC S APCHMDT=X
  1. S APCHHT=$P(^AUPNVMSR(APCHDA,0),U,4),X1=DT,X2=9999999-(APCHDATE\1) D ^%DTC
  1. I ((X>90)&(APCHAGE<1096))!((X>180)&(APCHAGE<4381))!((X>365)&(APCHAGE<6571))!((APCHMDT<6571)&(APCHAGE>6571)) S APCHCOMT="** 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