FHASXR1.m

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

FOOT ; Page Footer

 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

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 

FOOT      ; Page Footer

 +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