Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHASP

FHASP.m

Go to the documentation of this file.
  1. FHASP ; HISC/REL - Nutrition Profile ;11/16/94 16:55
  1. ;;5.5;DIETETICS;**5,8**;Jan 28, 2005;Build 28
  1. ;RVD patch #8 - added drug screening and print order of a drug based on the site parameter.
  1. ; replaced Ideal to Target and added BMI.
  1. P0 S ALL=1 D ^FHDPA G:'DFN KIL S:WARD="" ADM=""
  1. ;ask user for how far to print encounter, 1 yr back as default.
  1. W ! S %DT="AEP",%DT("A")="Print Dietetics Encounter since Date: "
  1. S %DT("B")="T-365",%DT(0)="-T" D ^%DT K %DT Q:X["^"!$D(DTOUT)
  1. S FHET=Y
  1. D MONUM^FHOMUTL I FHNUM="" Q
  1. ;
  1. L0 K IOP S %ZIS="MQ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
  1. I $D(IO("Q")) S FHPGM="Q0^FHASP",FHLST="FHDFN^DFN^PID^ADM^WARD^FHNUM" D EN2^FH D KILL^XUSCLEAN G P0
  1. U IO D Q0 D ^%ZISC K %ZIS,IOP G FHASP
  1. Q0 ; Print Profile
  1. D NOW^%DTC S NOW=%,DT=NOW\1 S FHU=$S($D(^FH(119.9,1,3)):$P(^(3),"^",1),1:"E")
  1. S Y=^DPT(DFN,0),NAM=$P(Y,"^",1),SEX=$P(Y,"^",2),DOB=$P(Y,"^",3)
  1. S AGE="" I DOB'="" S AGE=$E(NOW,1,3)-$E(DOB,1,3)-($E(NOW,4,7)<$E(DOB,4,7))
  1. S LN="",$P(LN,"-",80)="",ANS="",PG=0,S1=$S(IOST?1"C".E:IOSL-2,1:IOSL-7) D HEAD
  1. W !!,"Status: " I WARD="" W "Outpatient"
  1. E S DTP=$P(^DGPM(ADM,0),"^",1) D DTP^FH W "Inpatient admitted ",DTP D ^FHASP2
  1. S RC="",ASE=$O(^FHPT(FHDFN,"S",0)) I ASE S Y=^(ASE,0),RC=$P(Y,"^",2),DTP=$P(Y,"^",1)
  1. ;get problem and additional problem for the last assessment on file.
  1. S (FHADPROB,FHPROB)=""
  1. S ASN=$O(^FHPT(FHDFN,"N",0)) I ASN D
  1. .S (FHADPROB,FHPROB)=""
  1. .I $D(^FHPT(FHDFN,"N",ASN,3)) S FHPROB=$P(^(3),U,4)
  1. .I $D(^FHPT(FHDFN,"N",ASN,"DI")) S FHADPROB=$P(^("DI"),U,3)
  1. W !!,"Problem: ",FHPROB,!,"Additional Problem: ",FHADPROB
  1. W !!,"Nutrition Status: " I RC W ?20,$P($G(^FH(115.4,RC,0)),"^",2) D DTP^FH W " (",$E(DTP,1,9),")"
  1. D ALG^FHCLN W !!,"Allergies: " S ALG=$S(ALG="":"None on file",1:ALG) D LNE^FHDMP
  1. W !!?29,"Nutrition Assessments"
  1. I ASN'>0 W !!?5,"No assessments on file." G Q1
  1. W !!,"Recent Assessments:"
  1. 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
  1. S Y=^FHPT(FHDFN,"N",ASN,0)
  1. 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)
  1. S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_" cm"
  1. ;
  1. S (FHHT,FHWWT,FHX1,FHX2,FHDVT)=""
  1. 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)
  1. S:'FHDVT FHDVT=$P(X,"^",1)
  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"
  1. W !!,"Vitals Height: " W:FHX2'="" FHX2 W:FHX1'="" " (",FHX1,")"
  1. K FHX2,FHX1
  1. S (FHX1,FHX2)=""
  1. I FHWWT'="" S FHX1=FHWWT_" lbs",FHX2=+$J(FHWWT/2.2,0,1)_" kg"
  1. W ?40,"Vitals Wt: " W:FHWWT'="" FHX2," (",FHX1,")"
  1. I WGT S X1=WGT_" lbs",X2=+$J(WGT/2.2,0,1)_" kg"
  1. W !,"Last Wt: " W:WGT X2," (",X1,")"
  1. I UWGT S X1=UWGT_" lbs",X2=+$J(UWGT/2.2,0,1)_" kg"
  1. W !,"Usual Wt: " W:UWGT X2," (",X1,")" W ?40,"Last Wt/Usual Wt: " W:UWGT $J(WGT/UWGT*100,3,0),"%"
  1. S X1=IBW_" lbs",X2=+$J(IBW/2.2,0,1)_" kg"
  1. W !,"Target Wt: " W:IBW X2," (",X1,")" W ?40,"Last Wt/TBW: " W:IBW $J(WGT/IBW*100,3,0),"%"
  1. S BMI=""
  1. I FHWWT,FHHT S A2=FHHT*.0254,BMI=+$J(FHWWT/2.2/(A2*A2),0,1)
  1. W !,"Body Mass Index: ",BMI
  1. S DTP=FHDVT D:DTP'="" DTP^FH W ?40,"Date Taken: ",DTP
  1. I XD W !!?5,"Nutrition Class: " W ?20,$P($G(^FH(115.3,XD,0)),"^",1)
  1. Q1 S PX=0 D LAB^FHASM4 S PX=$S(WARD="":0,1:1) D DRUG^FHASM4
  1. W !!?34,"Medications" S N1=0
  1. F N2=0:0 S N2=$O(PSCNS(N2)) Q:N2="" S FHCN3="" F S FHCN3=$O(PSCNS(N2,FHCN3)) Q:FHCN3="" D
  1. .D:$Y'<S1 HF Q:ANS="^" W:'N1 ! W !?5,FHCN3 S N1=N1+1
  1. Q:ANS="^"
  1. I 'N1 W !!?5,"No current medications in selected drug classes."
  1. W !!?32,"Laboratory Data"
  1. S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" D:$Y'<S1 HF Q:ANS="^" D LAB
  1. Q:ANS="^"
  1. I 'N1 W !!?5,"No selected laboratory data available last ",$S($D(^FH(119.9,1,3)):$P(^(3),"^",2),1:90)," days."
  1. G ^FHASP1
  1. LAB S X1=$P(LRTST(K),"^",7) Q:X1="" S DTP=X1\1 D DTP^FH
  1. I 'N1 W !?5,"Test",?30,"Result units",?51,"Ref. range",?67,"Date",!
  1. S N1=N1+1
  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
  1. HF ; Do Header and Footer
  1. D FOOT Q:ANS="^" D HEAD
  1. Q
  1. W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1,DTP=DT D DTP^FH
  1. W !,LN,!,DTP,?31,"NUTRITION PROFILE",?73,"Page ",PG,!,LN
  1. W !,NAM,?40,$S(SEX="M":"Male",SEX="F":"Female",1:""),?73,"Age ",AGE,! Q
  1. D PAUSE Q:IOST?1"C".E
  1. F KK=1:1:IOSL-$Y-6 W !
  1. D SITE^FH W !,LN,!,NAM W ?(80-$L(SITE)\2),SITE,?67,"VAF 10-9034"
  1. W ! W:PID'="" PID
  1. 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)"
  1. W !,LN,! Q
  1. PAUSE ; Pause For Scroll
  1. 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
  1. Q
  1. KIL ; Final variable kill
  1. G KILL^XUSCLEAN