FHASS ; GLRISC/REL - Nutritional Assessment ; 22-May-88 11:45 am ; [ 10/18/94 12:17 PM ]
;;3.16;DIETETICS;**1**;NOV 01, 1990
;
;IHS/ORDC/LJF 10/17/94 start of code for PATCH #1
I '$D(FHZRVN) D
.S FHNULL="",(FHZRVN,FHZRVF)="FHNULL"
.I $D(^%ZIS(2,IOST(0),5)) S FHZRVN=$P(^(5),U,4),FHZRVF=$P(^(5),U,5)
;IHS/ORDC/LJF 10/17/94 end of code for PATCH #1
;
W @IOF,@FHZRVN,!!?18,"N U T R I T I O N A L A S S E S S M E N T",?78,"",@FHZRVF,!! S X="T" D ^%DT S DT=Y ;IHS/ANMC/LJF 9/25/89 added reverse video
F1 ; Select Patient
S ALL=1,AUPNLK("ALL")="" D ^FHDPA K AUPNLK("ALL") G PAT:X="*",KIL:'DFN S NAM=$P(Y(0),U,1),SEX=$P(Y(0),U,2),AGE=$P(Y(0),U,3) G:SEX=""!(AGE="") P1 ;IHS/ANMC/LJF 5/22/90 added set of AUPNLK("ALL") for universal lookup
S AGE=$E(DT,1,3)-$E(AGE,1,3)-($E(DT,4,7)<$E(AGE,4,7))
I AGE<18 W *7,!!?5,"Calories may be inaccurate for ages less than 18!"
F4 R !!,"Height in Inches: ",HGT:DTIME G:"^"[HGT KIL I HGT'?.N.1".".N!(HGT<30)!(HGT>90) W *7," Valid range is 30-90" G F4
F5 R !,"Weight in Pounds: ",WGT:DTIME G:"^"[WGT KIL I WGT'?.N.1".".N!(WGT<60)!(WGT>400) W *7," Valid range is 60-400" G F5
F50 W !,"Usual Weight in Pounds: ",WGT," // " R UWGT:DTIME G:'$T KIL S:UWGT="" UWGT=WGT G:UWGT="^" KIL I UWGT'?.N.1".".N!(UWGT<60)!(UWGT>400) W *7," ??" G F50
F51 R !,"Frame Size (SMALL, MEDIUM, LARGE) MED// ",FRM:DTIME G:'$T!(FRM="^") KIL S:FRM="" FRM="M" I $P("SMALL",FRM,1)'="",$P("MEDIUM",FRM,1)'="",$P("LARGE",FRM,1)'="" W *7," ??" G F51
S FRM=$E(FRM,1) S A1=$S(FRM="S":0.9,FRM="L":1.1,1:1)
I SEX="M" S IBW=HGT-60*6+106*A1
I SEX="F" S IBW=HGT-60*5+100*A1
TYP R !,"Is Patient an In-Patient? (Y/N): ",TYP:DTIME G:'$T!("^"[TYP) KIL I $P("YES",TYP,1)'="",$P("NO",TYP,1)'="" W *7," ??" G TYP
S TYP=$E(TYP,1)
F7 R !,"Does Patient have an Amputation? NO// ",AMP:DTIME G:'$T!(AMP="^") KIL S:AMP="" AMP="N" I $P("YES",AMP,1)'="",$P("NO",AMP,1)'="" G F7
S AMP=$E(AMP,1),AMP=AMP="Y" G:'AMP F9
F71 W !!,"Amputee Types: (may be multiple, e.g: 2,2,5)",!!?2,"1 Upper Leg (11.6%)",?40,"5 Hand (0.8%)",!?2,"2 Below Knee (5.8%)",?40,"6 Forearm (2.3%)"
W !?2,"3 Above Knee (8.4%)",?40,"7 Upper Arm (3.6%)",!?2,"4 Foot (1.8%)"
F8 S AMP=1 R !!?2,"Type: ",X:DTIME F K=1:1 S Y=$P(X,",",K) Q:Y="" G:Y'?1N!(Y<1)!(Y>7) F81 S AMP=AMP-$P(".116,.058,.084,.018,.008,.023,.036",",",Y)
S IBW=$J(AMP*IBW,0,0) G F9
F81 W *7," ?? Enter digits 1-7 separated by commas" G F71
F9 S OPT=$S(.9*IBW'<WGT:"G",1.1*IBW<WGT:"L",1:"M")
W !!,"Comparison with IBW indicates need for ",$S(OPT="M":"MAINTENANCE",OPT="L":"WEIGHT LOSS",1:"WEIGHT GAIN")
F10 W !!,"Select Option (GAIN WT, LOSE WT, MAINTAIN WT): ",$S(OPT="M":"MAINTAIN",OPT="G":"GAIN",1:"LOSE"),"// " R XX:DTIME G:'$T!(XX="^") KIL
I $P("GAIN WT",XX,1)'="",$P("LOSE WT",XX,1)'="",$P("MAINTAIN WT",XX,1)'="" W *7," Enter G, L, or M" G F10
S XX=$E(XX,1) S:XX'="" OPT=XX
F11 R !!,"Do you wish Lab/Skinfold Assessment? NO// ",EXT:DTIME G:'$T KIL S:EXT="" EXT="N" G:EXT="^" KIL I $P("YES",EXT,1)'="",$P("NO",EXT,1)'="" W *7," ??" G F11
S EXT=$E(EXT,1) D:EXT="Y" ^FHASS2 G KIL:EXT="K",^FHASS1
KIL ; Final variable kill
K %IS,A1,A2,A3,ACT,AF,AGC,AGE,ALL,AMP,BEE,DFN,EXT,DTP,FF,FRM,HGT,IBW,IF,J,K,KCAL,NAM,NIT,OPT,Q,POP,PRO,RTE,SEX,SXC,TAB,TYP,UWGT,WGT,X,XX,Y Q
PAT R !!,"Enter Patient's Name: ",NAM:DTIME G:"^"[NAM KIL
I NAM["?"!(NAM'?.ANP)!(NAM["^") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT
P1 R !,"Sex: ",SEX:DTIME G:"^"[SEX KIL I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" G P1
S SEX=$E(SEX,1)
P2 R !,"Age: ",AGE:DTIME G:"^"[AGE KIL I AGE'?1N.N!(AGE<18)!(AGE>124) W !?5,"Enter Age in years between 18 and 124" G P2
G F4
FHASS ; GLRISC/REL - Nutritional Assessment ; 22-May-88 11:45 am ; [ 10/18/94 12:17 PM ]
+1 ;;3.16;DIETETICS;**1**;NOV 01, 1990
+2 ;
+3 ;IHS/ORDC/LJF 10/17/94 start of code for PATCH #1
+4 IF '$DATA(FHZRVN)
Begin DoDot:1
+5 SET FHNULL=""
SET (FHZRVN,FHZRVF)="FHNULL"
+6 IF $DATA(^%ZIS(2,IOST(0),5))
SET FHZRVN=$PIECE(^(5),U,4)
SET FHZRVF=$PIECE(^(5),U,5)
End DoDot:1
+7 ;IHS/ORDC/LJF 10/17/94 end of code for PATCH #1
+8 ;
+9 ;IHS/ANMC/LJF 9/25/89 added reverse video
WRITE @IOF,@FHZRVN,!!?18,"N U T R I T I O N A L A S S E S S M E N T",?78,"",@FHZRVF,!!
SET X="T"
DO ^%DT
SET DT=Y
F1 ; Select Patient
+1 ;IHS/ANMC/LJF 5/22/90 added set of AUPNLK("ALL") for universal lookup
SET ALL=1
SET AUPNLK("ALL")=""
DO ^FHDPA
KILL AUPNLK("ALL")
IF X="*"
GOTO PAT
IF 'DFN
GOTO KIL
SET NAM=$PIECE(Y(0),U,1)
SET SEX=$PIECE(Y(0),U,2)
SET AGE=$PIECE(Y(0),U,3)
IF SEX=""!(AGE="")
GOTO P1
+2 SET AGE=$EXTRACT(DT,1,3)-$EXTRACT(AGE,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(AGE,4,7))
+3 IF AGE<18
WRITE *7,!!?5,"Calories may be inaccurate for ages less than 18!"
F4 READ !!,"Height in Inches: ",HGT:DTIME
IF "^"[HGT
GOTO KIL
IF HGT'?.N.1".".N!(HGT<30)!(HGT>90)
WRITE *7," Valid range is 30-90"
GOTO F4
F5 READ !,"Weight in Pounds: ",WGT:DTIME
IF "^"[WGT
GOTO KIL
IF WGT'?.N.1".".N!(WGT<60)!(WGT>400)
WRITE *7," Valid range is 60-400"
GOTO F5
F50 WRITE !,"Usual Weight in Pounds: ",WGT," // "
READ UWGT:DTIME
IF '$TEST
GOTO KIL
IF UWGT=""
SET UWGT=WGT
IF UWGT="^"
GOTO KIL
IF UWGT'?.N.1".".N!(UWGT<60)!(UWGT>400)
WRITE *7," ??"
GOTO F50
F51 READ !,"Frame Size (SMALL, MEDIUM, LARGE) MED// ",FRM:DTIME
IF '$TEST!(FRM="^")
GOTO KIL
IF FRM=""
SET FRM="M"
IF $PIECE("SMALL",FRM,1)'=""
IF $PIECE("MEDIUM",FRM,1)'=""
IF $PIECE("LARGE",FRM,1)'=""
WRITE *7," ??"
GOTO F51
+1 SET FRM=$EXTRACT(FRM,1)
SET A1=$SELECT(FRM="S":0.9,FRM="L":1.1,1:1)
+2 IF SEX="M"
SET IBW=HGT-60*6+106*A1
+3 IF SEX="F"
SET IBW=HGT-60*5+100*A1
TYP READ !,"Is Patient an In-Patient? (Y/N): ",TYP:DTIME
IF '$TEST!("^"[TYP)
GOTO KIL
IF $PIECE("YES",TYP,1)'=""
IF $PIECE("NO",TYP,1)'=""
WRITE *7," ??"
GOTO TYP
+1 SET TYP=$EXTRACT(TYP,1)
F7 READ !,"Does Patient have an Amputation? NO// ",AMP:DTIME
IF '$TEST!(AMP="^")
GOTO KIL
IF AMP=""
SET AMP="N"
IF $PIECE("YES",AMP,1)'=""
IF $PIECE("NO",AMP,1)'=""
GOTO F7
+1 SET AMP=$EXTRACT(AMP,1)
SET AMP=AMP="Y"
IF 'AMP
GOTO F9
F71 WRITE !!,"Amputee Types: (may be multiple, e.g: 2,2,5)",!!?2,"1 Upper Leg (11.6%)",?40,"5 Hand (0.8%)",!?2,"2 Below Knee (5.8%)",?40,"6 Forearm (2.3%)"
+1 WRITE !?2,"3 Above Knee (8.4%)",?40,"7 Upper Arm (3.6%)",!?2,"4 Foot (1.8%)"
F8 SET AMP=1
READ !!?2,"Type: ",X:DTIME
FOR K=1:1
SET Y=$PIECE(X,",",K)
IF Y=""
QUIT
IF Y'?1N!(Y<1)!(Y>7)
GOTO F81
SET AMP=AMP-$PIECE(".116,.058,.084,.018,.008,.023,.036",",",Y)
+1 SET IBW=$JUSTIFY(AMP*IBW,0,0)
GOTO F9
F81 WRITE *7," ?? Enter digits 1-7 separated by commas"
GOTO F71
F9 SET OPT=$SELECT(.9*IBW'<WGT:"G",1.1*IBW<WGT:"L",1:"M")
+1 WRITE !!,"Comparison with IBW indicates need for ",$SELECT(OPT="M":"MAINTENANCE",OPT="L":"WEIGHT LOSS",1:"WEIGHT GAIN")
F10 WRITE !!,"Select Option (GAIN WT, LOSE WT, MAINTAIN WT): ",$SELECT(OPT="M":"MAINTAIN",OPT="G":"GAIN",1:"LOSE"),"// "
READ XX:DTIME
IF '$TEST!(XX="^")
GOTO KIL
+1 IF $PIECE("GAIN WT",XX,1)'=""
IF $PIECE("LOSE WT",XX,1)'=""
IF $PIECE("MAINTAIN WT",XX,1)'=""
WRITE *7," Enter G, L, or M"
GOTO F10
+2 SET XX=$EXTRACT(XX,1)
IF XX'=""
SET OPT=XX
F11 READ !!,"Do you wish Lab/Skinfold Assessment? NO// ",EXT:DTIME
IF '$TEST
GOTO KIL
IF EXT=""
SET EXT="N"
IF EXT="^"
GOTO KIL
IF $PIECE("YES",EXT,1)'=""
IF $PIECE("NO",EXT,1)'=""
WRITE *7," ??"
GOTO F11
+1 SET EXT=$EXTRACT(EXT,1)
IF EXT="Y"
DO ^FHASS2
IF EXT="K"
GOTO KIL
GOTO ^FHASS1
KIL ; Final variable kill
+1 KILL %IS,A1,A2,A3,ACT,AF,AGC,AGE,ALL,AMP,BEE,DFN,EXT,DTP,FF,FRM,HGT,IBW,IF,J,K,KCAL,NAM,NIT,OPT,Q,POP,PRO,RTE,SEX,SXC,TAB,TYP,UWGT,WGT,X,XX,Y
QUIT
PAT READ !!,"Enter Patient's Name: ",NAM:DTIME
IF "^"[NAM
GOTO KIL
+1 IF NAM["?"!(NAM'?.ANP)!(NAM["^")
WRITE *7,!?5,"Enter Patient's Name to be printed on the report."
GOTO PAT
P1 READ !,"Sex: ",SEX:DTIME
IF "^"[SEX
GOTO KIL
IF $PIECE("FEMALE",SEX,1)'=""
IF $PIECE("MALE",SEX,1)'=""
WRITE *7," Enter M or F"
GOTO P1
+1 SET SEX=$EXTRACT(SEX,1)
P2 READ !,"Age: ",AGE:DTIME
IF "^"[AGE
GOTO KIL
IF AGE'?1N.N!(AGE<18)!(AGE>124)
WRITE !?5,"Enter Age in years between 18 and 124"
GOTO P2
+1 GOTO F4
