Routine: APCHS2A2

APCHS2A2 ; IHS/CMI/LAB - PART 2A2 - HEIGHT/WEIGHT PERCENTILES ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

AUHTWT(APCHTYPE,APCHSEX,APCHAGE,APCHVALU) ; EP - Extrinsic Function to return HT/WT PERCENTILE

 ; This extrinsic function returns the height or weight percentile

 ; based on sex and age in months.  If any passed variable is missing

 ; or invalid null is returned.

 ; Formal list:

 ; 1) TYPE  = HT or WT (call by value)

 ; 2) SEX   = patient's sex, M or F (call by value)

 ; 3) AGE   = patient's age in whole months (call by value)

 ;            must be less than 216 months

 ; 4) VALUE = height in inches or weight in pounds (call by value)

START ;

 NEW APCHSP,APCHAINC,APCHGRP,APCHINTR,APCHLSTI,APCHLAGE,APCHMSR1,APCHMSR2,APCHP,APCHP1,APCHP2,APCHR,APCHRATA,APCHV1,APCHV2,APCHXAGE,APCHXSEX,APCHXTYP

 ; ----------

 I APCHTYPE'="HT"&(APCHTYPE'="WT") G ERR

 I APCHSEX'="M"&(APCHSEX'="F") G ERR

 I APCHAGE'=+APCHAGE G ERR

 I APCHAGE'<216 G ERR

 I APCHVALU'=+APCHVALU G ERR

 ; ----------

 S APCHXTYP=$O(^APCHSPER("B",APCHTYPE,""))

 S APCHXSEX=$O(^APCHSPER(APCHXTYP,1,"B",APCHSEX,""))

 S APCHAINC=$S(APCHAGE<18:3,1:6)

 S APCHLAGE=APCHAGE-(APCHAGE#APCHAINC)

 S APCHXAGE=$O(^APCHSPER(APCHXTYP,1,APCHXSEX,1,"B",APCHLAGE,""))

 ; ----------

FIND S APCHMSR1=$P(^APCHSPER(APCHXTYP,1,APCHXSEX,1,APCHXAGE,0),"^",2)

 S APCHMSR2=$P(^APCHSPER(APCHXTYP,1,APCHXSEX,1,APCHXAGE+1,0),"^",2)

 S APCHRATA=(APCHAGE-APCHLAGE)/APCHAINC

 F APCHGRP=0:1:7 Q:APCHGRP=7  S APCHV1=$E(APCHMSR1,APCHGRP*4+1,APCHGRP*4+4)/10,APCHV2=$E(APCHMSR2,APCHGRP*4+1,APCHGRP*4+4)/10,APCHINTR=APCHV1+((APCHV2-APCHV1)*APCHRATA) Q:APCHVALU<APCHINTR  S APCHLSTI=APCHINTR

 S APCHGRP=APCHGRP+1

 I APCHGRP=1 S APCHSP="<3" G EXIT

 I APCHGRP=8 S APCHSP=">97" G EXIT

 S APCHR=(APCHVALU-APCHLSTI)/(APCHINTR-APCHLSTI)

 S APCHP=$P($T(PCT),";;",2),APCHP2=$P(APCHP,"^",APCHGRP),APCHP1=$P(APCHP,"^",APCHGRP-1),APCHSP=APCHP1+(APCHR*(APCHP2-APCHP1)),APCHSP=APCHSP+.5\1

 G EXIT

ERR ;

 S APCHSP=""

EXIT ;

 K APCHAINC,APCHGRP,APCHINTR,APCHLSTI,APCHLAGE,APCHMSR1,APCHMSR2,APCHP,APCHP1,APCHP2,APCHR,APCHRATA,APCHV1,APCHV2,APCHXAGE,APCHXSEX,APCHXTYP

 S Y=APCHSP

 K APCHSP,APCHTYPE,APCHVALU

Q Y

PCT ;;3^10^25^50^75^90^97

APCHS2A2  ; IHS/CMI/LAB - PART 2A2 - HEIGHT/WEIGHT PERCENTILES ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

AUHTWT(APCHTYPE,APCHSEX,APCHAGE,APCHVALU) ; EP - Extrinsic Function to return HT/WT PERCENTILE

 +1       ;

 +2       ; This extrinsic function returns the height or weight percentile

 +3       ; based on sex and age in months.  If any passed variable is missing

 +4       ; or invalid null is returned.

 +5       ;

 +6       ; Formal list:

 +7       ;

 +8       ; 1) TYPE  = HT or WT (call by value)

 +9       ; 2) SEX   = patient's sex, M or F (call by value)

 +10      ; 3) AGE   = patient's age in whole months (call by value)

 +11      ;            must be less than 216 months

 +12      ; 4) VALUE = height in inches or weight in pounds (call by value)

 +13      ;

START     ;

 +1        NEW APCHSP,APCHAINC,APCHGRP,APCHINTR,APCHLSTI,APCHLAGE,APCHMSR1,APCHMSR2,APCHP,APCHP1,APCHP2,APCHR,APCHRATA,APCHV1,APCHV2,APCHXAGE,APCHXSEX,APCHXTYP

 +2       ; ----------

 +3        IF APCHTYPE'="HT"&(APCHTYPE'="WT")

               GOTO ERR

 +4        IF APCHSEX'="M"&(APCHSEX'="F")

               GOTO ERR

 +5        IF APCHAGE'=+APCHAGE

               GOTO ERR

 +6        IF APCHAGE'<216

               GOTO ERR

 +7        IF APCHVALU'=+APCHVALU

               GOTO ERR

 +8       ; ----------

 +9        SET APCHXTYP=$ORDER(^APCHSPER("B",APCHTYPE,""))

 +10       SET APCHXSEX=$ORDER(^APCHSPER(APCHXTYP,1,"B",APCHSEX,""))

 +11       SET APCHAINC=$SELECT(APCHAGE<18:3,1:6)

 +12       SET APCHLAGE=APCHAGE-(APCHAGE#APCHAINC)

 +13       SET APCHXAGE=$ORDER(^APCHSPER(APCHXTYP,1,APCHXSEX,1,"B",APCHLAGE,""))

 +14      ; ----------

FIND       SET APCHMSR1=$PIECE(^APCHSPER(APCHXTYP,1,APCHXSEX,1,APCHXAGE,0),"^",2)

 +1        SET APCHMSR2=$PIECE(^APCHSPER(APCHXTYP,1,APCHXSEX,1,APCHXAGE+1,0),"^",2)

 +2        SET APCHRATA=(APCHAGE-APCHLAGE)/APCHAINC

 +3        FOR APCHGRP=0:1:7

               IF APCHGRP=7

                   QUIT

               SET APCHV1=$EXTRACT(APCHMSR1,APCHGRP*4+1,APCHGRP*4+4)/10

               SET APCHV2=$EXTRACT(APCHMSR2,APCHGRP*4+1,APCHGRP*4+4)/10

               SET APCHINTR=APCHV1+((APCHV2-APCHV1)*APCHRATA)

               IF APCHVALU<APCHINTR

                   QUIT

               SET APCHLSTI=APCHINTR

 +4        SET APCHGRP=APCHGRP+1

 +5        IF APCHGRP=1

               SET APCHSP="<3"

               GOTO EXIT

 +6        IF APCHGRP=8

               SET APCHSP=">97"

               GOTO EXIT

 +7        SET APCHR=(APCHVALU-APCHLSTI)/(APCHINTR-APCHLSTI)

 +8        SET APCHP=$PIECE($TEXT(PCT),";;",2)

           SET APCHP2=$PIECE(APCHP,"^",APCHGRP)

           SET APCHP1=$PIECE(APCHP,"^",APCHGRP-1)

           SET APCHSP=APCHP1+(APCHR*(APCHP2-APCHP1))

           SET APCHSP=APCHSP+.5\1

 +9        GOTO EXIT

ERR       ;

 +1        SET APCHSP=""

EXIT      ;

 +1        KILL APCHAINC,APCHGRP,APCHINTR,APCHLSTI,APCHLAGE,APCHMSR1,APCHMSR2,APCHP,APCHP1,APCHP2,APCHR,APCHRATA,APCHV1,APCHV2,APCHXAGE,APCHXSEX,APCHXTYP

 +2        SET Y=APCHSP

 +3        KILL APCHSP,APCHTYPE,APCHVALU

 +4        QUIT Y

 +5       ;

 +6       ;

PCT       ;;3^10^25^50^75^90^97

APCHS2A2.m