AUPNPC.m

AUPNPC ; IHS/CMI/LAB - PERCENTILES ;

 ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999

 ;

 ;FOR PERCENTILES, HT AND WT

 ;

 ; 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)

 ;

AUHTWT(TYPE,SEX,AGE,VALUE) ; EXTRINSIC FUNCTION TO RETURN HT/WT PERCENTILE

START ;

 NEW %,AGEINC,GRP,INTERP,LASTINT,LOWAGE,MSR1,MSR2,P,P1,P2,R,RATA,V1,V2,XAGE,XSEX,XTYPE

 ; ----------

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

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

 I AGE<0 G ERR

 I AGE'=+AGE G ERR

 I AGE'<216 G ERR

 I VALUE'=+VALUE G ERR

 ; ----------

 S XTYPE=$O(^AUTTPCT("B",TYPE,""))

 S XSEX=$O(^AUTTPCT(XTYPE,1,"B",SEX,""))

 S AGEINC=$S(AGE<18:3,1:6)

 S LOWAGE=AGE-(AGE#AGEINC)

 S XAGE=$O(^AUTTPCT(XTYPE,1,XSEX,1,"B",LOWAGE,""))

 ; ----------

FIND S MSR1=$P(^AUTTPCT(XTYPE,1,XSEX,1,XAGE,0),"^",2)

 S MSR2=$P(^AUTTPCT(XTYPE,1,XSEX,1,XAGE+1,0),"^",2)

 S RATA=(AGE-LOWAGE)/AGEINC

 F GRP=0:1:7 Q:GRP=7  S V1=$E(MSR1,GRP*4+1,GRP*4+4)/10,V2=$E(MSR2,GRP*4+1,GRP*4+4)/10,INTERP=V1+((V2-V1)*RATA) Q:VALUE<INTERP  S LASTINT=INTERP

 S GRP=GRP+1

 I GRP=1 S %="<3" G EXIT

 I GRP=8 S %=">97" G EXIT

 S R=(VALUE-LASTINT)/(INTERP-LASTINT)

 S P=$P($T(PCT),";;",2),P2=$P(P,"^",GRP),P1=$P(P,"^",GRP-1),%=P1+(R*(P2-P1)),%=%+.5\1

DEBUG ;W LASTINT,"-",VALUE,"-",INTERP," ",R,"  ",P1,"..",%,"..",P2,!

 G EXIT

ERR ;

 S %=""

EXIT ;

 Q %

 ;

 ;

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

AUPNPC    ; IHS/CMI/LAB - PERCENTILES ;

 +1       ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999

 +2       ;

 +3       ;FOR PERCENTILES, HT AND WT

 +4       ;

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

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

 +7       ; or invalid null is returned.

 +8       ;

 +9       ; Formal list:

 +10      ;

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

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

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

 +14      ;            must be less than 216 months

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

 +16      ;

AUHTWT(TYPE,SEX,AGE,VALUE) ; EXTRINSIC FUNCTION TO RETURN HT/WT PERCENTILE

START     ;

 +1        NEW %,AGEINC,GRP,INTERP,LASTINT,LOWAGE,MSR1,MSR2,P,P1,P2,R,RATA,V1,V2,XAGE,XSEX,XTYPE

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

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

               GOTO ERR

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

               GOTO ERR

 +5        IF AGE<0

               GOTO ERR

 +6        IF AGE'=+AGE

               GOTO ERR

 +7        IF AGE'<216

               GOTO ERR

 +8        IF VALUE'=+VALUE

               GOTO ERR

 +9       ; ----------

 +10       SET XTYPE=$ORDER(^AUTTPCT("B",TYPE,""))

 +11       SET XSEX=$ORDER(^AUTTPCT(XTYPE,1,"B",SEX,""))

 +12       SET AGEINC=$SELECT(AGE<18:3,1:6)

 +13       SET LOWAGE=AGE-(AGE#AGEINC)

 +14       SET XAGE=$ORDER(^AUTTPCT(XTYPE,1,XSEX,1,"B",LOWAGE,""))

 +15      ; ----------

FIND       SET MSR1=$PIECE(^AUTTPCT(XTYPE,1,XSEX,1,XAGE,0),"^",2)

 +1        SET MSR2=$PIECE(^AUTTPCT(XTYPE,1,XSEX,1,XAGE+1,0),"^",2)

 +2        SET RATA=(AGE-LOWAGE)/AGEINC

 +3        FOR GRP=0:1:7

               IF GRP=7

                   QUIT 

               SET V1=$EXTRACT(MSR1,GRP*4+1,GRP*4+4)/10

               SET V2=$EXTRACT(MSR2,GRP*4+1,GRP*4+4)/10

               SET INTERP=V1+((V2-V1)*RATA)

               IF VALUE<INTERP

                   QUIT 

               SET LASTINT=INTERP

 +4        SET GRP=GRP+1

 +5        IF GRP=1

               SET %="<3"

               GOTO EXIT

 +6        IF GRP=8

               SET %=">97"

               GOTO EXIT

 +7        SET R=(VALUE-LASTINT)/(INTERP-LASTINT)

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

           SET P2=$PIECE(P,"^",GRP)

           SET P1=$PIECE(P,"^",GRP-1)

           SET %=P1+(R*(P2-P1))

           SET %=%+.5\1

DEBUG     ;W LASTINT,"-",VALUE,"-",INTERP," ",R,"  ",P1,"..",%,"..",P2,!

 +1        GOTO EXIT

ERR       ;

 +1        SET %=""

EXIT      ;

 +1        QUIT %

 +2       ;

 +3       ;

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