FHASM3.m

FHASM3 ; HISC/REL - Antropometrics and TIU Notes ;5/14/93  09:17

 ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1

 I EXT="Y" G NEXT

EXT R !!,"Do you wish Anthropometric Assessment? NO// ",EXT:DTIME S:EXT=U FHQUIT=1 G:'$T!(EXT["^") KIL^FHASM1

 S:EXT="" EXT="N"

 S X=EXT D TR^FHASM1 S EXT=X

 I $P("YES",EXT,1)'="",$P("NO",EXT,1)'="" W *7,!," Enter YES if you have Anthropometric measurements; Otherwise NO" G EXT

 S EXT=$E(EXT,1) I EXT="Y" D ANT G:EXT="" KIL^FHASM1

NEXT ; Calculate BMI

 S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1)

 ;update nutrition assessment data in #115.

 ;

 ;

 D ^FHASM3A G ^FHASM4

ANT ; Anthropometric measurements

 W !!,"Triceps Skin Fold (mm): " W:$D(TSF) TSF_"// " R X:DTIME G QT:'$T!(X["^")

 S:X'="" TSF=X

 S:TSF="" TSF=X

 G A1:TSF=""

 I TSF'?.N.1".".N!(TSF<1)!(TSF>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G ANT

A1 W !,"Subscapular Skinfold (mm): " W:$D(SCA) SCA_"// " R X:DTIME G QT:'$T!(X["^")

 S:X'="" SCA=X

 S:SCA="" SCA=X

 G A2:SCA=""

 I SCA'?.N.1".".N!(SCA<1)!(SCA>100) W !?5,"Enter value between 1 and 100; outside values should be assessed manually" G A1

A2 W !,"Arm Circumference (cm): " W:$G(ACIR) ACIR_"// " R X:DTIME G QT:'$T!(X["^")

 S:X'="" ACIR=X

 S:SCA="" ACIR=X

 G A3:ACIR=""

 I ACIR'?.N.1".".N!(ACIR<5)!(ACIR>100) W !?5,"Enter number between 5 and 100; outside values should be assessed manually" G A2

A3 W !,"Calf Circumference (cm): " W:$G(CCIR) CCIR_"// " R X:DTIME G QT:'$T!(X["^")

 S:X'="" CCIR=X

 S:CCIR="" CCIR=X

 G A4:CCIR=""

 I CCIR'?.N.1".".N!(CCIR<10)!(CCIR>250) W !?5,"Enter value between 10 and 250; outside values should be assessed manually" G A3

A4 I ACIR,TSF S X1=ACIR-(TSF/10*3.1416),BFAMA=X1*X1/12.5664-$S(AGE<18:0,SEX="M":10,1:6.5),BFAMA=$J(BFAMA,0,1)

 Q

QT S EXT="" Q

 ;

REC ;recalculate calorie, protien and fluid requirements.

 I '$G(IBW)!'$G(WGT)!'$G(HGT)!'$G(AGE) Q

 I $D(CFRBO) S CB=CFRBO,W2=$S(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2

 Q:'$G(W2)

 ;calorie

 I $D(CENB),CENB=3 D

 .I SEX="M" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5

 .I SEX="F" S KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161

 .S KCAL=$J(KCAL,0,0)

 I $D(CENB),CENB=1 D

 .I SEX="F" S KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE))

 .I SEX="M" S KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE))

 .I $D(SEF),$G(AF) S KCAL=+$J(KCAL*AF*SEF,0,0)

 .S KCAL=$J(KCAL,0,0)

 I $D(CENB),(CENB=2),$G(EKKG) S KCAL=+$J(EKKG*W2,0,0)

 ;fluid

 I $G(CFRB),CFRB=1 D

 .S:AGE>17 FLD=35

 .S:AGE>64 FLD=30

 .S FLD=W2*FLD

 I $D(CFRB),CFRB=2 S W1=W2,FLD=$S(W1<10:W1*100,W1<20:W1-10*50+1000,1:W1-20*25+1500)

 I $D(CFRB),CFRB=3 S FLD=KCAL

 I $D(CFRB),CFRB=4 S FLD=.5*KCAL

 I $D(CFRB),CFRB=5 S X=W2,X1=.425 D PWR^FHASM6 S FLD=Y,X=HGT*2.54,X1=.725 D PWR^FHASM6 S FLD=FLD*Y*.007184*1500

 S FLD=+$J(FLD,0,0)

 I FLD'?1N.N!(FLD<0)!(FLD>10000) W *7,!,"Fluid level must be between 0-10000 ml/day" S FHQTALL=1 Q

 S FLD=+$J(FLD,0,0)

 ;protien

 S P1=$S(AGE>18:.8,AGE>14:.84,AGE>10:1,AGE>6:1.2,AGE>3:1.5,AGE>1:1.8,AGE>.5:2,1:2.2)

 I P1=FHPL S PRO=+$J(P1*W2,0,0)

 I P1'=FHPL  S PRO=+$J(FHPL*W2,0,0)

 I PRO'="",(PRO'>0!(PRO>400)) W *7," Protien level is greater than 0 but not more than 400." S FHQTALL=1

 ;FOLLOW-UP DATE.

 S (FHDD,DTP)=""

 I $G(RC),FHFUD<DT D

 .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH

 .I X["NORMAL" D

 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20)

 ..S:FHDD DTP="T+"_FHDD

 ..S:'FHDD DTP="T+11"

 .I X["MILD" D

 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21)

 ..S:FHDD DTP="T+"_FHDD

 ..S:'FHDD DTP="T+9"

 .I X["MODERATE" D

 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22)

 ..S:FHDD DTP="T+"_FHDD

 ..S:'FHDD DTP="T+7"

 .I X["SEVERE" D

 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23)

 ..S:FHDD DTP="T+"_FHDD

 ..S:'FHDD DTP="T+5"

 .S X=DTP,%DT="X",%DT(0)=DT D ^%DT S FHFUD=Y

 .W ! K %DT

 .S FHFUD=Y

 I 'RC,FHFUD<DT S X="NOW",%DT="X" D ^%DT S FHFUD=Y

 ;

 Q

FHASM3    ; HISC/REL - Antropometrics and TIU Notes ;5/14/93  09:17

 +1       ;;5.5;DIETETICS;**8,14**;Jan 28, 2005;Build 1

 +2        IF EXT="Y"

               GOTO NEXT

EXT        READ !!,"Do you wish Anthropometric Assessment? NO// ",EXT:DTIME

           IF EXT=U

               SET FHQUIT=1

           IF '$TEST!(EXT["^")

               GOTO KIL^FHASM1

 +1        IF EXT=""

               SET EXT="N"

 +2        SET X=EXT

           DO TR^FHASM1

           SET EXT=X

 +3        IF $PIECE("YES",EXT,1)'=""

               IF $PIECE("NO",EXT,1)'=""

                   WRITE *7,!," Enter YES if you have Anthropometric measurements; Otherwise NO"

                   GOTO EXT

 +4        SET EXT=$EXTRACT(EXT,1)

           IF EXT="Y"

               DO ANT

               IF EXT=""

                   GOTO KIL^FHASM1

NEXT      ; Calculate BMI

 +1        SET A2=HGT*.0254

           SET BMI=+$JUSTIFY(WGT/2.2/(A2*A2),0,1)

 +2       ;update nutrition assessment data in #115.

 +3       ;

 +4       ;

 +5        DO ^FHASM3A

           GOTO ^FHASM4

ANT       ; Anthropometric measurements

 +1        WRITE !!,"Triceps Skin Fold (mm): "

           IF $DATA(TSF)

               WRITE TSF_"// "

           READ X:DTIME

           IF '$TEST!(X["^")

               GOTO QT

 +2        IF X'=""

               SET TSF=X

 +3        IF TSF=""

               SET TSF=X

 +4        IF TSF=""

               GOTO A1

 +5        IF TSF'?.N.1".".N!(TSF<1)!(TSF>100)

               WRITE !?5,"Enter value between 1 and 100; outside values should be assessed manually"

               GOTO ANT

A1         WRITE !,"Subscapular Skinfold (mm): "

           IF $DATA(SCA)

               WRITE SCA_"// "

           READ X:DTIME

           IF '$TEST!(X["^")

               GOTO QT

 +1        IF X'=""

               SET SCA=X

 +2        IF SCA=""

               SET SCA=X

 +3        IF SCA=""

               GOTO A2

 +4        IF SCA'?.N.1".".N!(SCA<1)!(SCA>100)

               WRITE !?5,"Enter value between 1 and 100; outside values should be assessed manually"

               GOTO A1

A2         WRITE !,"Arm Circumference (cm): "

           IF $GET(ACIR)

               WRITE ACIR_"// "

           READ X:DTIME

           IF '$TEST!(X["^")

               GOTO QT

 +1        IF X'=""

               SET ACIR=X

 +2        IF SCA=""

               SET ACIR=X

 +3        IF ACIR=""

               GOTO A3

 +4        IF ACIR'?.N.1".".N!(ACIR<5)!(ACIR>100)

               WRITE !?5,"Enter number between 5 and 100; outside values should be assessed manually"

               GOTO A2

A3         WRITE !,"Calf Circumference (cm): "

           IF $GET(CCIR)

               WRITE CCIR_"// "

           READ X:DTIME

           IF '$TEST!(X["^")

               GOTO QT

 +1        IF X'=""

               SET CCIR=X

 +2        IF CCIR=""

               SET CCIR=X

 +3        IF CCIR=""

               GOTO A4

 +4        IF CCIR'?.N.1".".N!(CCIR<10)!(CCIR>250)

               WRITE !?5,"Enter value between 10 and 250; outside values should be assessed manually"

               GOTO A3

A4         IF ACIR

               IF TSF

                   SET X1=ACIR-(TSF/10*3.1416)

                   SET BFAMA=X1*X1/12.5664-$SELECT(AGE<18:0,SEX="M":10,1:6.5)

                   SET BFAMA=$JUSTIFY(BFAMA,0,1)

 +1        QUIT 

QT         SET EXT=""

           QUIT 

 +1       ;

REC       ;recalculate calorie, protien and fluid requirements.

 +1        IF '$GET(IBW)!'$GET(WGT)!'$GET(HGT)!'$GET(AGE)

               QUIT 

 +2        IF $DATA(CFRBO)

               SET CB=CFRBO

               SET W2=$SELECT(CB=2:IBW,CB=3:WGT-IBW*.25+IBW,1:WGT)/2.2

 +3        IF '$GET(W2)

               QUIT 

 +4       ;calorie

 +5        IF $DATA(CENB)

               IF CENB=3

                   Begin DoDot:1

 +6                    IF SEX="M"

                           SET KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)+5

 +7                    IF SEX="F"

                           SET KCAL=(10*W2)+(6.25*2.54*HGT)-(5*AGE)-161

 +8                    SET KCAL=$JUSTIFY(KCAL,0,0)

                   End DoDot:1

 +9        IF $DATA(CENB)

               IF CENB=1

                   Begin DoDot:1

 +10                   IF SEX="F"

                           SET KCAL=(655.10+(9.56*W2)+(1.85*HGT*2.54)-(4.68*AGE))

 +11                   IF SEX="M"

                           SET KCAL=(66.47+(13.75*W2)+(5.0*HGT*2.54)-(6.67*AGE))

 +12                   IF $DATA(SEF)

                           IF $GET(AF)

                               SET KCAL=+$JUSTIFY(KCAL*AF*SEF,0,0)

 +13                   SET KCAL=$JUSTIFY(KCAL,0,0)

                   End DoDot:1

 +14       IF $DATA(CENB)

               IF (CENB=2)

                   IF $GET(EKKG)

                       SET KCAL=+$JUSTIFY(EKKG*W2,0,0)

 +15      ;fluid

 +16       IF $GET(CFRB)

               IF CFRB=1

                   Begin DoDot:1

 +17                   IF AGE>17

                           SET FLD=35

 +18                   IF AGE>64

                           SET FLD=30

 +19                   SET FLD=W2*FLD

                   End DoDot:1

 +20       IF $DATA(CFRB)

               IF CFRB=2

                   SET W1=W2

                   SET FLD=$SELECT(W1<10:W1*100,W1<20:W1-10*50+1000,1:W1-20*25+1500)

 +21       IF $DATA(CFRB)

               IF CFRB=3

                   SET FLD=KCAL

 +22       IF $DATA(CFRB)

               IF CFRB=4

                   SET FLD=.5*KCAL

 +23       IF $DATA(CFRB)

               IF CFRB=5

                   SET X=W2

                   SET X1=.425

                   DO PWR^FHASM6

                   SET FLD=Y

                   SET X=HGT*2.54

                   SET X1=.725

                   DO PWR^FHASM6

                   SET FLD=FLD*Y*.007184*1500

 +24       SET FLD=+$JUSTIFY(FLD,0,0)

 +25       IF FLD'?1N.N!(FLD<0)!(FLD>10000)

               WRITE *7,!,"Fluid level must be between 0-10000 ml/day"

               SET FHQTALL=1

               QUIT 

 +26       SET FLD=+$JUSTIFY(FLD,0,0)

 +27      ;protien

 +28       SET P1=$SELECT(AGE>18:.8,AGE>14:.84,AGE>10:1,AGE>6:1.2,AGE>3:1.5,AGE>1:1.8,AGE>.5:2,1:2.2)

 +29       IF P1=FHPL

               SET PRO=+$JUSTIFY(P1*W2,0,0)

 +30       IF P1'=FHPL

               SET PRO=+$JUSTIFY(FHPL*W2,0,0)

 +31       IF PRO'=""

               IF (PRO'>0!(PRO>400))

                   WRITE *7," Protien level is greater than 0 but not more than 400."

                   SET FHQTALL=1

 +32      ;FOLLOW-UP DATE.

 +33       SET (FHDD,DTP)=""

 +34       IF $GET(RC)

               IF FHFUD<DT

                   Begin DoDot:1

 +35                   SET X=$PIECE($GET(^FH(115.4,RC,0)),U,2)

                       DO TR^FH

 +36                   IF X["NORMAL"

                           Begin DoDot:2

 +37                           IF FHLOC

                                   SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,20)

 +38                           IF FHDD

                                   SET DTP="T+"_FHDD

 +39                           IF 'FHDD

                                   SET DTP="T+11"

                           End DoDot:2

 +40                   IF X["MILD"

                           Begin DoDot:2

 +41                           IF FHLOC

                                   SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,21)

 +42                           IF FHDD

                                   SET DTP="T+"_FHDD

 +43                           IF 'FHDD

                                   SET DTP="T+9"

                           End DoDot:2

 +44                   IF X["MODERATE"

                           Begin DoDot:2

 +45                           IF FHLOC

                                   SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,22)

 +46                           IF FHDD

                                   SET DTP="T+"_FHDD

 +47                           IF 'FHDD

                                   SET DTP="T+7"

                           End DoDot:2

 +48                   IF X["SEVERE"

                           Begin DoDot:2

 +49                           IF FHLOC

                                   SET FHDD=$PIECE($GET(^FH(119.6,FHLOC,0)),U,23)

 +50                           IF FHDD

                                   SET DTP="T+"_FHDD

 +51                           IF 'FHDD

                                   SET DTP="T+5"

                           End DoDot:2

 +52                   SET X=DTP

                       SET %DT="X"

                       SET %DT(0)=DT

                       DO ^%DT

                       SET FHFUD=Y

 +53                   WRITE !

                       KILL %DT

 +54                   SET FHFUD=Y

                   End DoDot:1

 +55       IF 'RC

               IF FHFUD<DT

                   SET X="NOW"

                   SET %DT="X"

                   DO ^%DT

                   SET FHFUD=Y

 +56      ;

 +57       QUIT