- 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 Mar 13, 2025@20:51:52 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
