- 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