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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASM3 3903 printed Apr 09, 2024@20:59:20 Page 2
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
