- FHASP ; HISC/REL - Nutrition Profile ;11/16/94 16:55
- ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- ;RVD patch #8 - added drug screening and print order of a drug based on the site parameter.
- ; replaced Ideal to Target and added BMI.
- P0 S ALL=1 D ^FHDPA G:'DFN KIL S:WARD="" ADM=""
- ;ask user for how far to print encounter, 1 yr back as default.
- W ! S %DT="AEP",%DT("A")="Print Dietetics Encounter since Date: "
- S %DT("B")="T-365",%DT(0)="-T" D ^%DT K %DT Q:X["^"!$D(DTOUT)
- S FHET=Y
- D MONUM^FHOMUTL I FHNUM="" Q
- ;
- L0 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="Q0^FHASP",FHLST="FHDFN^DFN^PID^ADM^WARD^FHNUM" D EN2^FH D KILL^XUSCLEAN G P0
- U IO D Q0 D ^%ZISC K %ZIS,IOP G FHASP
- Q0 ; Print Profile
- D NOW^%DTC S NOW=%,DT=NOW\1 S FHU=$S($D(^FH(119.9,1,3)):$P(^(3),"^",1),1:"E")
- S Y=^DPT(DFN,0),NAM=$P(Y,"^",1),SEX=$P(Y,"^",2),DOB=$P(Y,"^",3)
- S AGE="" I DOB'="" S AGE=$E(NOW,1,3)-$E(DOB,1,3)-($E(NOW,4,7)<$E(DOB,4,7))
- S LN="",$P(LN,"-",80)="",ANS="",PG=0,S1=$S(IOST?1"C".E:IOSL-2,1:IOSL-7) D HEAD
- W !!,"Status: " I WARD="" W "Outpatient"
- E S DTP=$P(^DGPM(ADM,0),"^",1) D DTP^FH W "Inpatient admitted ",DTP D ^FHASP2
- S RC="",ASE=$O(^FHPT(FHDFN,"S",0)) I ASE S Y=^(ASE,0),RC=$P(Y,"^",2),DTP=$P(Y,"^",1)
- ;get problem and additional problem for the last assessment on file.
- S (FHADPROB,FHPROB)=""
- S ASN=$O(^FHPT(FHDFN,"N",0)) I ASN D
- .S (FHADPROB,FHPROB)=""
- .I $D(^FHPT(FHDFN,"N",ASN,3)) S FHPROB=$P(^(3),U,4)
- .I $D(^FHPT(FHDFN,"N",ASN,"DI")) S FHADPROB=$P(^("DI"),U,3)
- W !!,"Problem: ",FHPROB,!,"Additional Problem: ",FHADPROB
- W !!,"Nutrition Status: " I RC W ?20,$P($G(^FH(115.4,RC,0)),"^",2) D DTP^FH W " (",$E(DTP,1,9),")"
- D ALG^FHCLN W !!,"Allergies: " S ALG=$S(ALG="":"None on file",1:ALG) D LNE^FHDMP
- W !!?29,"Nutrition Assessments"
- I ASN'>0 W !!?5,"No assessments on file." G Q1
- W !!,"Recent Assessments:"
- S N1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"N",K)) Q:K<1 S DTP=$P(^(K,0),"^",1) D DTP^FH W " ",$E(DTP,1,9) S N1=N1+1 Q:N1=3
- S Y=^FHPT(FHDFN,"N",ASN,0)
- S N1=0 F K=1,4:1:11,21 S N1=N1+1,@$P("ADT HGT HGP WGT WGP DWGT UWGT IBW XD BMI"," ",N1)=$P(Y,"^",K)
- 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,FHX1,FHX2,FHDVT)=""
- I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVT=$P(X,"^",1),FHWWT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHHT=$P(X,"^",8)
- S:'FHDVT FHDVT=$P(X,"^",1)
- 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 !!,"Vitals Height: " W:FHX2'="" FHX2 W:FHX1'="" " (",FHX1,")"
- K FHX2,FHX1
- S (FHX1,FHX2)=""
- I FHWWT'="" S FHX1=FHWWT_" lbs",FHX2=+$J(FHWWT/2.2,0,1)_" kg"
- W ?40,"Vitals Wt: " W:FHWWT'="" FHX2," (",FHX1,")"
- I WGT S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg"
- W !,"Last Wt: " W:WGT X2," (",X1,")"
- I UWGT S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg"
- W !,"Usual Wt: " W:UWGT X2," (",X1,")" W ?40,"Last Wt/Usual Wt: " W:UWGT $J(WGT/UWGT*100,3,0),"%"
- S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg"
- W !,"Target Wt: " W:IBW X2," (",X1,")" W ?40,"Last Wt/TBW: " W:IBW $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 !,"Body Mass Index: ",BMI
- S DTP=FHDVT D:DTP'="" DTP^FH W ?40,"Date Taken: ",DTP
- I XD W !!?5,"Nutrition Class: " W ?20,$P($G(^FH(115.3,XD,0)),"^",1)
- Q1 S PX=0 D LAB^FHASM4 S PX=$S(WARD="":0,1:1) D DRUG^FHASM4
- W !!?34,"Medications" S N1=0
- F N2=0:0 S N2=$O(PSCNS(N2)) Q:N2="" S FHCN3="" F S FHCN3=$O(PSCNS(N2,FHCN3)) Q:FHCN3="" D
- .D:$Y'<S1 HF Q:ANS="^" W:'N1 ! W !?5,FHCN3 S N1=N1+1
- Q:ANS="^"
- I 'N1 W !!?5,"No current medications in selected drug classes."
- W !!?32,"Laboratory Data"
- S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D:$Y'<S1 HF Q:ANS="^" D LAB
- Q:ANS="^"
- I 'N1 W !!?5,"No selected laboratory data available last ",$S($D(^FH(119.9,1,3)):$P(^(3),"^",2),1:90)," days."
- G ^FHASP1
- LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH
- I 'N1 W !?5,"Test",?30,"Result units",?51,"Ref. range",?67,"Date",!
- 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
- HF ; Do Header and Footer
- D FOOT Q:ANS="^" D HEAD
- Q
- HEAD ; Page Header
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=DT D DTP^FH
- W !,LN,!,DTP,?31,"NUTRITION PROFILE",?73,"Page ",PG,!,LN
- W !,NAM,?40,$S(SEX="M":"Male",SEX="F":"Female",1:""),?73,"Age ",AGE,! Q
- D PAUSE Q:IOST?1"C".E
- F KK=1:1:IOSL-$Y-6 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 W ?66,"(Vice SF 509)"
- W !,LN,! Q
- PAUSE ; Pause For Scroll
- I IOST?1"C".E R !!,"Press RETURN to continue. ",X:DTIME S:'$T!(X["^") ANS="^" Q:ANS="^" I "^"'[X W !,"Enter a RETURN to Continue." G PAUSE
- Q
- KIL ; Final variable kill
- G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASP 4997 printed Feb 18, 2025@23:13:32 Page 2
- FHASP ; HISC/REL - Nutrition Profile ;11/16/94 16:55
- +1 ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
- +2 ;RVD patch #8 - added drug screening and print order of a drug based on the site parameter.
- +3 ; replaced Ideal to Target and added BMI.
- P0 SET ALL=1
- DO ^FHDPA
- if 'DFN
- GOTO KIL
- if WARD=""
- SET ADM=""
- +1 ;ask user for how far to print encounter, 1 yr back as default.
- +2 WRITE !
- SET %DT="AEP"
- SET %DT("A")="Print Dietetics Encounter since Date: "
- +3 SET %DT("B")="T-365"
- SET %DT(0)="-T"
- DO ^%DT
- KILL %DT
- if X["^"!$DATA(DTOUT)
- QUIT
- +4 SET FHET=Y
- +5 DO MONUM^FHOMUTL
- IF FHNUM=""
- QUIT
- +6 ;
- L0 KILL IOP
- SET %ZIS="MQ"
- SET %ZIS("B")="HOME"
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO KIL
- +1 IF $DATA(IO("Q"))
- SET FHPGM="Q0^FHASP"
- SET FHLST="FHDFN^DFN^PID^ADM^WARD^FHNUM"
- DO EN2^FH
- DO KILL^XUSCLEAN
- GOTO P0
- +2 USE IO
- DO Q0
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO FHASP
- Q0 ; Print Profile
- +1 DO NOW^%DTC
- SET NOW=%
- SET DT=NOW\1
- SET FHU=$SELECT($DATA(^FH(119.9,1,3)):$PIECE(^(3),"^",1),1:"E")
- +2 SET Y=^DPT(DFN,0)
- SET NAM=$PIECE(Y,"^",1)
- SET SEX=$PIECE(Y,"^",2)
- SET DOB=$PIECE(Y,"^",3)
- +3 SET AGE=""
- IF DOB'=""
- SET AGE=$EXTRACT(NOW,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(NOW,4,7)<$EXTRACT(DOB,4,7))
- +4 SET LN=""
- SET $PIECE(LN,"-",80)=""
- SET ANS=""
- SET PG=0
- SET S1=$SELECT(IOST?1"C".E:IOSL-2,1:IOSL-7)
- DO HEAD
- +5 WRITE !!,"Status: "
- IF WARD=""
- WRITE "Outpatient"
- +6 IF '$TEST
- SET DTP=$PIECE(^DGPM(ADM,0),"^",1)
- DO DTP^FH
- WRITE "Inpatient admitted ",DTP
- DO ^FHASP2
- +7 SET RC=""
- SET ASE=$ORDER(^FHPT(FHDFN,"S",0))
- IF ASE
- SET Y=^(ASE,0)
- SET RC=$PIECE(Y,"^",2)
- SET DTP=$PIECE(Y,"^",1)
- +8 ;get problem and additional problem for the last assessment on file.
- +9 SET (FHADPROB,FHPROB)=""
- +10 SET ASN=$ORDER(^FHPT(FHDFN,"N",0))
- IF ASN
- Begin DoDot:1
- +11 SET (FHADPROB,FHPROB)=""
- +12 IF $DATA(^FHPT(FHDFN,"N",ASN,3))
- SET FHPROB=$PIECE(^(3),U,4)
- +13 IF $DATA(^FHPT(FHDFN,"N",ASN,"DI"))
- SET FHADPROB=$PIECE(^("DI"),U,3)
- End DoDot:1
- +14 WRITE !!,"Problem: ",FHPROB,!,"Additional Problem: ",FHADPROB
- +15 WRITE !!,"Nutrition Status: "
- IF RC
- WRITE ?20,$PIECE($GET(^FH(115.4,RC,0)),"^",2)
- DO DTP^FH
- WRITE " (",$EXTRACT(DTP,1,9),")"
- +16 DO ALG^FHCLN
- WRITE !!,"Allergies: "
- SET ALG=$SELECT(ALG="":"None on file",1:ALG)
- DO LNE^FHDMP
- +17 WRITE !!?29,"Nutrition Assessments"
- +18 IF ASN'>0
- WRITE !!?5,"No assessments on file."
- GOTO Q1
- +19 WRITE !!,"Recent Assessments:"
- +20 SET N1=0
- FOR K=0:0
- SET K=$ORDER(^FHPT(FHDFN,"N",K))
- if K<1
- QUIT
- SET DTP=$PIECE(^(K,0),"^",1)
- DO DTP^FH
- WRITE " ",$EXTRACT(DTP,1,9)
- SET N1=N1+1
- if N1=3
- QUIT
- +21 SET Y=^FHPT(FHDFN,"N",ASN,0)
- +22 SET N1=0
- FOR K=1,4:1:11,21
- SET N1=N1+1
- SET @$PIECE("ADT HGT HGP WGT WGP DWGT UWGT IBW XD BMI"," ",N1)=$PIECE(Y,"^",K)
- +23 SET X1=$SELECT(HGT\12:HGT\12_"'",1:"")_$SELECT(HGT#12:" "_(HGT#12)_"""",1:"")
- SET X2=+$JUSTIFY(HGT*2.54,0,0)_" cm"
- +24 ;
- +25 SET (FHHT,FHWWT,FHX1,FHX2,FHDVT)=""
- +26 IF DFN
- SET GMRVSTR="WT"
- DO EN6^GMRVUTL
- SET FHDVT=$PIECE(X,"^",1)
- SET FHWWT=$PIECE(X,"^",8)
- SET GMRVSTR="HT"
- DO EN6^GMRVUTL
- SET FHHT=$PIECE(X,"^",8)
- +27 if 'FHDVT
- SET FHDVT=$PIECE(X,"^",1)
- +28 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"
- +29 WRITE !!,"Vitals Height: "
- if FHX2'=""
- WRITE FHX2
- if FHX1'=""
- WRITE " (",FHX1,")"
- +30 KILL FHX2,FHX1
- +31 SET (FHX1,FHX2)=""
- +32 IF FHWWT'=""
- SET FHX1=FHWWT_" lbs"
- SET FHX2=+$JUSTIFY(FHWWT/2.2,0,1)_" kg"
- +33 WRITE ?40,"Vitals Wt: "
- if FHWWT'=""
- WRITE FHX2," (",FHX1,")"
- +34 IF WGT
- SET X1=WGT_" lbs"
- SET X2=+$JUSTIFY(WGT/2.2,0,1)_" kg"
- +35 WRITE !,"Last Wt: "
- if WGT
- WRITE X2," (",X1,")"
- +36 IF UWGT
- SET X1=UWGT_" lbs"
- SET X2=+$JUSTIFY(UWGT/2.2,0,1)_" kg"
- +37 WRITE !,"Usual Wt: "
- if UWGT
- WRITE X2," (",X1,")"
- WRITE ?40,"Last Wt/Usual Wt: "
- if UWGT
- WRITE $JUSTIFY(WGT/UWGT*100,3,0),"%"
- +38 SET X1=IBW_" lbs"
- SET X2=+$JUSTIFY(IBW/2.2,0,1)_" kg"
- +39 WRITE !,"Target Wt: "
- if IBW
- WRITE X2," (",X1,")"
- WRITE ?40,"Last Wt/TBW: "
- if IBW
- WRITE $JUSTIFY(WGT/IBW*100,3,0),"%"
- +40 SET BMI=""
- +41 IF FHWWT
- IF FHHT
- SET A2=FHHT*.0254
- SET BMI=+$JUSTIFY(FHWWT/2.2/(A2*A2),0,1)
- +42 WRITE !,"Body Mass Index: ",BMI
- +43 SET DTP=FHDVT
- if DTP'=""
- DO DTP^FH
- WRITE ?40,"Date Taken: ",DTP
- +44 IF XD
- WRITE !!?5,"Nutrition Class: "
- WRITE ?20,$PIECE($GET(^FH(115.3,XD,0)),"^",1)
- Q1 SET PX=0
- DO LAB^FHASM4
- SET PX=$SELECT(WARD="":0,1:1)
- DO DRUG^FHASM4
- +1 WRITE !!?34,"Medications"
- SET N1=0
- +2 FOR N2=0:0
- SET N2=$ORDER(PSCNS(N2))
- if N2=""
- QUIT
- SET FHCN3=""
- FOR
- SET FHCN3=$ORDER(PSCNS(N2,FHCN3))
- if FHCN3=""
- QUIT
- Begin DoDot:1
- +3 if $Y'<S1
- DO HF
- if ANS="^"
- QUIT
- if 'N1
- WRITE !
- WRITE !?5,FHCN3
- SET N1=N1+1
- End DoDot:1
- +4 if ANS="^"
- QUIT
- +5 IF 'N1
- WRITE !!?5,"No current medications in selected drug classes."
- +6 WRITE !!?32,"Laboratory Data"
- +7 SET N1=0
- FOR K=0:0
- SET K=$ORDER(LRTST(K))
- if K=""
- QUIT
- if $Y'<S1
- DO HF
- if ANS="^"
- QUIT
- DO LAB
- +8 if ANS="^"
- QUIT
- +9 IF 'N1
- WRITE !!?5,"No selected laboratory data available last ",$SELECT($DATA(^FH(119.9,1,3)):$PIECE(^(3),"^",2),1:90)," days."
- +10 GOTO ^FHASP1
- LAB SET X1=$PIECE(LRTST(K),"^",7)
- if X1=""
- QUIT
- SET DTP=X1\1
- DO DTP^FH
- +1 IF 'N1
- WRITE !?5,"Test",?30,"Result units",?51,"Ref. range",?67,"Date",!
- +2 SET N1=N1+1
- +3 WRITE !?5,$PIECE(LRTST(K),"^",1),?27,$PIECE(LRTST(K),"^",6),?40,$PIECE(LRTST(K),"^",4),?51,$PIECE(LRTST(K),"^",5),?65,DTP
- QUIT
- HF ; Do Header and Footer
- +1 DO FOOT
- if ANS="^"
- QUIT
- DO HEAD
- +2 QUIT
- 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,?31,"NUTRITION PROFILE",?73,"Page ",PG,!,LN
- +3 WRITE !,NAM,?40,$SELECT(SEX="M":"Male",SEX="F":"Female",1:""),?73,"Age ",AGE,!
- QUIT
- +1 DO PAUSE
- if IOST?1"C".E
- QUIT
- +2 FOR KK=1:1:IOSL-$Y-6
- 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
- WRITE ?66,"(Vice SF 509)"
- +6 WRITE !,LN,!
- QUIT
- PAUSE ; Pause For Scroll
- +1 IF IOST?1"C".E
- READ !!,"Press RETURN to continue. ",X:DTIME
- if '$TEST!(X["^")
- SET ANS="^"
- if ANS="^"
- QUIT
- IF "^"'[X
- WRITE !,"Enter a RETURN to Continue."
- GOTO PAUSE
- +2 QUIT
- KIL ; Final variable kill
- +1 GOTO KILL^XUSCLEAN