FHASXR1 ; HISC/REL - Print Screening (cont) ;4/20/95 08:53
;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
Q1 ; Print assessment
I $G(DFN)="" Q
S X="T",%DT="X" D ^%DT S DT=Y,Y=^DPT(DFN,0),NAM=$P(Y,"^",1),SEX=$P(Y,"^",2),DOB=$P(Y,"^",3)
S AGE=$E(DT,1,3)-$E(DOB,1,3)-($E(DT,4,7)<$E(DOB,4,7)) D PID^FHDPA
S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1)
S LN="",$P(LN,"-",80)="",PG=0,S1=$S(IOST?1"C".E:IOSL-2,1:IOSL-6) D HEAD
S UL="",$P(UL,"_",80)="",ANS=""
W !!,"S: Chewing Problems: Y N",?41,"Pre-Admission Diet: ",$E(UL,1,18)
W !?4,"Dysphagia: Y N",?41,"Wt. + - ____ # in last ___ months"
W !?4,"Appetite: + -",?41,"Nausea: Y N",?58,"Vomiting: Y N"
W !?4,"Feeding Assistance Required: Y N",?41,"Diarrhea: Y N",?58,"Constipation: Y N"
D ALG^FHCLN W !?4,"Food Allergies: " S ALG=$S(ALG="":"None on file",1:ALG) D LNE
I $P(FHAP,"^",5)'="" W !?4,$P(FHAP,"^",5)
Q2 W !!,"O: Current Diet: " G:WARD="" Q21 I $D(^FHPT(FHDFN,"A",ADM,0)) D CUR^FHORD7 W Y
S X(0)=$G(^FHPT(FHDFN,"A",ADM,0))
I Y'="",FHORD>0 I $D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) S COM=^(1) W:COM'="" !?4,"Comment: ",COM
S TYP=$P(X,"^",8) I TYP'="" W !?4,"Service: ",$S(TYP="T":"Tray",TYP="D":"Dining Room",1:"Cafeteria")
S DTP=$P(X(0),"^",3) I DTP D DTP^FH W !?4,"Expires: ",DTP
S TF=$P(X(0),"^",4) G:TF<1 F2
S Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
S DTP=$P(Y,"^",1),COM=$P(Y,"^",5),TQU=$P(Y,"^",6),CAL=$P(Y,"^",7)
D DTP^FH W !?4,"Tubefeed Ordered: ",DTP
F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 S XY=^(TF2,0) D LP
W !?4,"Total Quantity: ",TQU," ml",?42,"Total KCAL: ",CAL
W:COM'="" !?4,"Comment: ",COM
F2 S X=$P($G(^DGPM(ADM,0)),"^",10) W !?4,"Adm. Dx: ",$E(X,1,27)
S DTP=$P($G(^DGPM(ADM,0)),"^",1) D DTP^FH W ?41,"Adm. Date: ",?59,DTP
Q21 W !?4,"Age: ",AGE,?18,"Sex: ",SEX,?41,"Prior Assessment:" S ASN=$O(^FHPT(FHDFN,"N",0)) I ASN>0 S DTP=9999999-ASN D DTP^FH W ?59,DTP
S Y=$S(ASN>0:^FHPT(FHDFN,"N",ASN,0),1:"")
S HGT=$P(Y,"^",4),WGT=$P(Y,"^",6),DWGT=$P(Y,"^",8),UWGT=$P(Y,"^",9),IBW=$P(Y,"^",10),FRM=$P(Y,"^",11),AMP=$P(Y,"^",12),HGP=$P(Y,"^",5),WGP=$P(Y,"^",7)
I HGT'="" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_" cm"
S (FHHT,FHWWT,FHDWT,FHX1,FHX2)=""
I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDWT=$P(X,"^",1),FHWWT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHHT=$P(X,"^",8)
I FHHT'="" S FHX1=$S(FHHT\12:FHHT\12_"'",1:"")_$S(FHHT#12:" "_(FHHT#12)_"""",1:""),FHX2=+$J(FHHT*2.54,0,0)_" cm"
W !?4,"Vitals Height:",?18 W:FHX2'="" FHX2
W:FHX1'="" " (",FHX1,")"
S (FHX1,FHX2)=""
W ?41,"Frame Size:",?59,$S(FRM="S":"Small",FRM="M":"Medium",FRM="L":"Large",1:"")
I FHWWT'="" S FHX1=FHWWT_" lbs",FHX2=+$J(FHWWT/2.2,0,1)_" kg"
W !?4,"Vitals Weight:" W:FHX2'="" ?18,FHX2 W:FHX1'="" " (",FHX1,")"
W ?41,"Weight Taken:"
S DTP=""
I FHDWT'="" S DTP=FHDWT D DTP^FH
W ?59,DTP
S DTP=DWGT D:DTP'="" DTP^FH
;W ?41,"Amputation %:",?59,AMP
S (X1,X2)=""
I WGT'="" S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg"
W !?4,"Last Weight:" I WGT'="" W ?18,X2 W:WGP'="" " ",WGP W " (",X1,")"
W ?41,"Weight Taken:"
S DTP=DWGT D DTP^FH W:WGT'="" ?59,DTP
I UWGT'="" S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg"
W !?4,"Usual Weight:" I UWGT'="" W ?18,X2," (",X1,")"
W ?41,"Last Weight/Usual Wt: " W:UWGT ?59,$J(WGT/UWGT*100,3,0),"%"
I IBW'="" S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg"
W !?4,"Target Weight:" I IBW'="" W ?18,X2," (",X1,")"
W ?41,"Last Weight/TBW:" W:IBW ?59,$J(WGT/IBW*100,3,0),"%"
S BMI=""
I FHWWT,FHHT S A2=FHHT*.0254,BMI=+$J(FHWWT/2.2/(A2*A2),0,1)
W !?4,"Body Mass Index: ",BMI,?41,"Amputation %:",?59,AMP
Q3 S PX=4 D LAB^FHASM4
W !!?32,"Laboratory Data",!?5,"Test",?30,"Result units",?51,"Ref. range",?67,"Date",!
S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D LAB
I 'N1 W !?5,"No laboratory data available last ",$S($D(^FH(119.9,1,3)):$P(^(3),"^",2),1:90)," days"
Q6 W !!?4,"Appearance: "
W !!,"A: Nutrition Status",?48,"Nutrition Education",!
S E(1)="Further Education Required: Y N",E(2)=$E(UL,1,31)
S N=0 F KK=0:0 S KK=$O(^FH(115.4,KK)) Q:KK<1&(N>1) S N=N+1 W !?4 W:$P($G(^FH(115.4,+KK,0)),"^",2)'="" "___ ",$P(^(0),"^",2) W:N<3 ?48,E(N)
W !?4,"Comments:"
W !!,"P: Nutrition Plan",!
F KK=0:0 S KK=$O(^FH(115.5,KK)) Q:KK<1 W !?4,"___ ",$P(^(KK,0),"^",1)
W !?4,"Recommendations:" F KK=1:1:IOSL-$Y-7 W !
W !?41,$E(UL,1,38)
W !?41,"Signature",?68,"Date"
D FOOT Q:'NP!(ANS="^") W:$E(IOST,1,2)'="C-" @IOF D Q0^FHASP Q
LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH S N1=N1+1
W !?5,$P(LRTST(K),"^",1),?27,$P(LRTST(K),"^",6),?40,$P(LRTST(K),"^",4),?51,$P(LRTST(K),"^",5),?65,DTP Q
LNE ; Break Line if longer than 56 chars
I $L(ALG)<57 W ALG Q
F L=58:-1:1 Q:$E(ALG,L-1,L)=", "
W $E(ALG,1,L-2)
S ALG=$E(ALG,L+1,999)
Q:ALG="" W !?20
G LNE
HEAD ; Page Header
W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=DT D DTP^FH
W !,LN,!,DTP,?30,"NUTRITION SCREENING",?73,"Page ",PG,!,LN Q
D PAUSE Q:IOST?1"C".E
F KK=1:1:IOSL-$Y-5 W !
D SITE^FH W !,LN,!,NAM W ?(80-$L(SITE)\2),SITE,?67,"VAF 10-9034"
W ! W:PID'="" PID
S W1=$G(^DPT(DFN,.1)) S:$D(^DPT(DFN,.101)) W1=W1_"/"_^DPT(DFN,.101) W:W1'="" ?(80-$L(W1)\2),W1,?66,"(Vice SF 509)"
W !,LN,! Q
PAUSE ; Pause to Scroll
I IOST?1"C".E R !!,"Press RETURN to continue." R X:DTIME S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PAUSE
Q
LP S TUN=$P(XY,"^",1),STR=$P(XY,"^",2),QUA=$P(XY,"^",3)
W !?7,$P($G(^FH(118.2,TUN,0)),"^",1),", ",$S(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASXR1 5577 printed Sep 23, 2025@19:23:12 Page 2
FHASXR1 ; HISC/REL - Print Screening (cont) ;4/20/95 08:53
+1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
Q1 ; Print assessment
+1 IF $GET(DFN)=""
QUIT
+2 SET X="T"
SET %DT="X"
DO ^%DT
SET DT=Y
SET Y=^DPT(DFN,0)
SET NAM=$PIECE(Y,"^",1)
SET SEX=$PIECE(Y,"^",2)
SET DOB=$PIECE(Y,"^",3)
+3 SET AGE=$EXTRACT(DT,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(DOB,4,7))
DO PID^FHDPA
+4 SET FHAP=$GET(^FH(119.9,1,3))
SET FHU=$PIECE(FHAP,"^",1)
+5 SET LN=""
SET $PIECE(LN,"-",80)=""
SET PG=0
SET S1=$SELECT(IOST?1"C".E:IOSL-2,1:IOSL-6)
DO HEAD
+6 SET UL=""
SET $PIECE(UL,"_",80)=""
SET ANS=""
+7 WRITE !!,"S: Chewing Problems: Y N",?41,"Pre-Admission Diet: ",$EXTRACT(UL,1,18)
+8 WRITE !?4,"Dysphagia: Y N",?41,"Wt. + - ____ # in last ___ months"
+9 WRITE !?4,"Appetite: + -",?41,"Nausea: Y N",?58,"Vomiting: Y N"
+10 WRITE !?4,"Feeding Assistance Required: Y N",?41,"Diarrhea: Y N",?58,"Constipation: Y N"
+11 DO ALG^FHCLN
WRITE !?4,"Food Allergies: "
SET ALG=$SELECT(ALG="":"None on file",1:ALG)
DO LNE
+12 IF $PIECE(FHAP,"^",5)'=""
WRITE !?4,$PIECE(FHAP,"^",5)
Q2 WRITE !!,"O: Current Diet: "
if WARD=""
GOTO Q21
IF $DATA(^FHPT(FHDFN,"A",ADM,0))
DO CUR^FHORD7
WRITE Y
+1 SET X(0)=$GET(^FHPT(FHDFN,"A",ADM,0))
+2 IF Y'=""
IF FHORD>0
IF $DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
SET COM=^(1)
if COM'=""
WRITE !?4,"Comment: ",COM
+3 SET TYP=$PIECE(X,"^",8)
IF TYP'=""
WRITE !?4,"Service: ",$SELECT(TYP="T":"Tray",TYP="D":"Dining Room",1:"Cafeteria")
+4 SET DTP=$PIECE(X(0),"^",3)
IF DTP
DO DTP^FH
WRITE !?4,"Expires: ",DTP
+5 SET TF=$PIECE(X(0),"^",4)
if TF<1
GOTO F2
+6 SET Y=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
+7 SET DTP=$PIECE(Y,"^",1)
SET COM=$PIECE(Y,"^",5)
SET TQU=$PIECE(Y,"^",6)
SET CAL=$PIECE(Y,"^",7)
+8 DO DTP^FH
WRITE !?4,"Tubefeed Ordered: ",DTP
+9 FOR TF2=0:0
SET TF2=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2))
if TF2<1
QUIT
SET XY=^(TF2,0)
DO LP
+10 WRITE !?4,"Total Quantity: ",TQU," ml",?42,"Total KCAL: ",CAL
+11 if COM'=""
WRITE !?4,"Comment: ",COM
F2 SET X=$PIECE($GET(^DGPM(ADM,0)),"^",10)
WRITE !?4,"Adm. Dx: ",$EXTRACT(X,1,27)
+1 SET DTP=$PIECE($GET(^DGPM(ADM,0)),"^",1)
DO DTP^FH
WRITE ?41,"Adm. Date: ",?59,DTP
Q21 WRITE !?4,"Age: ",AGE,?18,"Sex: ",SEX,?41,"Prior Assessment:"
SET ASN=$ORDER(^FHPT(FHDFN,"N",0))
IF ASN>0
SET DTP=9999999-ASN
DO DTP^FH
WRITE ?59,DTP
+1 SET Y=$SELECT(ASN>0:^FHPT(FHDFN,"N",ASN,0),1:"")
+2 SET HGT=$PIECE(Y,"^",4)
SET WGT=$PIECE(Y,"^",6)
SET DWGT=$PIECE(Y,"^",8)
SET UWGT=$PIECE(Y,"^",9)
SET IBW=$PIECE(Y,"^",10)
SET FRM=$PIECE(Y,"^",11)
SET AMP=$PIECE(Y,"^",12)
SET HGP=$PIECE(Y,"^",5)
SET WGP=$PIECE(Y,"^",7)
+3 IF HGT'=""
SET X1=$SELECT(HGT\12:HGT\12_"'",1:"")_$SELECT(HGT#12:" "_(HGT#12)_"""",1:"")
SET X2=+$JUSTIFY(HGT*2.54,0,0)_" cm"
+4 SET (FHHT,FHWWT,FHDWT,FHX1,FHX2)=""
+5 IF DFN
SET GMRVSTR="WT"
DO EN6^GMRVUTL
SET FHDWT=$PIECE(X,"^",1)
SET FHWWT=$PIECE(X,"^",8)
SET GMRVSTR="HT"
DO EN6^GMRVUTL
SET FHHT=$PIECE(X,"^",8)
+6 IF FHHT'=""
SET FHX1=$SELECT(FHHT\12:FHHT\12_"'",1:"")_$SELECT(FHHT#12:" "_(FHHT#12)_"""",1:"")
SET FHX2=+$JUSTIFY(FHHT*2.54,0,0)_" cm"
+7 WRITE !?4,"Vitals Height:",?18
if FHX2'=""
WRITE FHX2
+8 if FHX1'=""
WRITE " (",FHX1,")"
+9 SET (FHX1,FHX2)=""
+10 WRITE ?41,"Frame Size:",?59,$SELECT(FRM="S":"Small",FRM="M":"Medium",FRM="L":"Large",1:"")
+11 IF FHWWT'=""
SET FHX1=FHWWT_" lbs"
SET FHX2=+$JUSTIFY(FHWWT/2.2,0,1)_" kg"
+12 WRITE !?4,"Vitals Weight:"
if FHX2'=""
WRITE ?18,FHX2
if FHX1'=""
WRITE " (",FHX1,")"
+13 WRITE ?41,"Weight Taken:"
+14 SET DTP=""
+15 IF FHDWT'=""
SET DTP=FHDWT
DO DTP^FH
+16 WRITE ?59,DTP
+17 SET DTP=DWGT
if DTP'=""
DO DTP^FH
+18 ;W ?41,"Amputation %:",?59,AMP
+19 SET (X1,X2)=""
+20 IF WGT'=""
SET X1=WGT_" lbs"
SET X2=+$JUSTIFY(WGT/2.2,0,1)_" kg"
+21 WRITE !?4,"Last Weight:"
IF WGT'=""
WRITE ?18,X2
if WGP'=""
WRITE " ",WGP
WRITE " (",X1,")"
+22 WRITE ?41,"Weight Taken:"
+23 SET DTP=DWGT
DO DTP^FH
if WGT'=""
WRITE ?59,DTP
+24 IF UWGT'=""
SET X1=UWGT_" lbs"
SET X2=+$JUSTIFY(UWGT/2.2,0,1)_" kg"
+25 WRITE !?4,"Usual Weight:"
IF UWGT'=""
WRITE ?18,X2," (",X1,")"
+26 WRITE ?41,"Last Weight/Usual Wt: "
if UWGT
WRITE ?59,$JUSTIFY(WGT/UWGT*100,3,0),"%"
+27 IF IBW'=""
SET X1=IBW_" lbs"
SET X2=+$JUSTIFY(IBW/2.2,0,1)_" kg"
+28 WRITE !?4,"Target Weight:"
IF IBW'=""
WRITE ?18,X2," (",X1,")"
+29 WRITE ?41,"Last Weight/TBW:"
if IBW
WRITE ?59,$JUSTIFY(WGT/IBW*100,3,0),"%"
+30 SET BMI=""
+31 IF FHWWT
IF FHHT
SET A2=FHHT*.0254
SET BMI=+$JUSTIFY(FHWWT/2.2/(A2*A2),0,1)
+32 WRITE !?4,"Body Mass Index: ",BMI,?41,"Amputation %:",?59,AMP
Q3 SET PX=4
DO LAB^FHASM4
+1 WRITE !!?32,"Laboratory Data",!?5,"Test",?30,"Result units",?51,"Ref. range",?67,"Date",!
+2 SET N1=0
FOR K=0:0
SET K=$ORDER(LRTST(K))
if K=""
QUIT
DO LAB
+3 IF 'N1
WRITE !?5,"No laboratory data available last ",$SELECT($DATA(^FH(119.9,1,3)):$PIECE(^(3),"^",2),1:90)," days"
Q6 WRITE !!?4,"Appearance: "
+1 WRITE !!,"A: Nutrition Status",?48,"Nutrition Education",!
+2 SET E(1)="Further Education Required: Y N"
SET E(2)=$EXTRACT(UL,1,31)
+3 SET N=0
FOR KK=0:0
SET KK=$ORDER(^FH(115.4,KK))
if KK<1&(N>1)
QUIT
SET N=N+1
WRITE !?4
if $PIECE($GET(^FH(115.4,+KK,0)),"^",2)'=""
WRITE "___ ",$PIECE(^(0),"^",2)
if N<3
WRITE ?48,E(N)
+4 WRITE !?4,"Comments:"
+5 WRITE !!,"P: Nutrition Plan",!
+6 FOR KK=0:0
SET KK=$ORDER(^FH(115.5,KK))
if KK<1
QUIT
WRITE !?4,"___ ",$PIECE(^(KK,0),"^",1)
+7 WRITE !?4,"Recommendations:"
FOR KK=1:1:IOSL-$Y-7
WRITE !
+8 WRITE !?41,$EXTRACT(UL,1,38)
+9 WRITE !?41,"Signature",?68,"Date"
+10 DO FOOT
if 'NP!(ANS="^")
QUIT
if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
DO Q0^FHASP
QUIT
LAB SET X1=$PIECE(LRTST(K),"^",7)
if X1=""
QUIT
SET DTP=X1\1
DO DTP^FH
SET N1=N1+1
+1 WRITE !?5,$PIECE(LRTST(K),"^",1),?27,$PIECE(LRTST(K),"^",6),?40,$PIECE(LRTST(K),"^",4),?51,$PIECE(LRTST(K),"^",5),?65,DTP
QUIT
LNE ; Break Line if longer than 56 chars
+1 IF $LENGTH(ALG)<57
WRITE ALG
QUIT
+2 FOR L=58:-1:1
if $EXTRACT(ALG,L-1,L)=", "
QUIT
+3 WRITE $EXTRACT(ALG,1,L-2)
+4 SET ALG=$EXTRACT(ALG,L+1,999)
+5 if ALG=""
QUIT
WRITE !?20
+6 GOTO LNE
HEAD ; Page Header
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
SET DTP=DT
DO DTP^FH
+2 WRITE !,LN,!,DTP,?30,"NUTRITION SCREENING",?73,"Page ",PG,!,LN
QUIT
+1 DO PAUSE
if IOST?1"C".E
QUIT
+2 FOR KK=1:1:IOSL-$Y-5
WRITE !
+3 DO SITE^FH
WRITE !,LN,!,NAM
WRITE ?(80-$LENGTH(SITE)\2),SITE,?67,"VAF 10-9034"
+4 WRITE !
if PID'=""
WRITE PID
+5 SET W1=$GET(^DPT(DFN,.1))
if $DATA(^DPT(DFN,.101))
SET W1=W1_"/"_^DPT(DFN,.101)
if W1'=""
WRITE ?(80-$LENGTH(W1)\2),W1,?66,"(Vice SF 509)"
+6 WRITE !,LN,!
QUIT
PAUSE ; Pause to Scroll
+1 IF IOST?1"C".E
READ !!,"Press RETURN to continue."
READ X:DTIME
if '$TEST!(X["^")
SET ANS="^"
if ANS="^"
QUIT
IF "^"'[X
WRITE !,"Enter a RETURN to Continue."
GOTO PAUSE
+2 QUIT
LP SET TUN=$PIECE(XY,"^",1)
SET STR=$PIECE(XY,"^",2)
SET QUA=$PIECE(XY,"^",3)
+1 WRITE !?7,$PIECE($GET(^FH(118.2,TUN,0)),"^",1),", ",$SELECT(STR=4:"Full",STR=1:"1/4",STR=2:"1/2",1:"3/4")," Str., ",QUA
QUIT
