source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM1.m@ 1259

Last change on this file since 1259 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 8.7 KB
Line 
1FHASM1 ; HISC/REL - Nutrition Assessment ;1/25/00 12:08
2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
3 W @IOF,!!?20,"N U T R I T I O N A S S E S S M E N T",!! S X="T",%DT="X" D ^%DT S DT=+Y
4F1 ; Select Patient
5 S FHALL=1 D ^FHOMDPA G KILL^XUSCLEAN:'FHDFN
6 S:DFN'>0 DFN=""
7 I $G(DFN),$P($G(^DPT(DFN,.35)),"^",1) W *7,!!?5," [ Patient has expired. ]" G KILL^XUSCLEAN
8 S (ADM,ASN,FHASK,KNEE,EXT,DTP,FHCAS,FHCASD,FHASS,FHFFC,FHFEC,FHFPC,FHCFRBO,FHCM,FHEF,FHKCAL,FHLOC)="",(FHHWF,FHQUIT)=0
9 S (ADT,SEX,AGE,HGT,HGP,WGT,WGP,DWGT,UWGT,IBW,FRM,AMP,KCAL,PRO,FLD,RC,XD,BMI,BMIP,FHCLI,FHPLXSV)=""
10 S (NOW,NB,TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,FHAPP,FHEDU,DEWGT,WARD,FHSPC)=""
11 S (FHDIPL,FHDIPLD,FHAST,FHDINF,FHDINFD,FHFUD,FHDIST,FHDIDI,FHDITF,FHDIDI,FHDITF,FHDITFDT,FHDITFCM,FHDITFML,FHDITFKC,FHVHGT,FHDVHGT)=""
12 S (TSF,TSFP,SCA,SCAP,ACIR,ACIRP,CCIR,CCIRP,BFAMA,BFAMAP,BMI,BMIP,X1,X2,FHFUDS,EKKG,FHFDC,FHFDCSV)=""
13 S (WCCM,CIBW,CERBO,CENB,PCTB,SEF,CFRB,CFRBO,CPRBO,NWGT,DNWGT,FHYN,FHDINA,FHVWGT,FHDVWGT,FHPL)=""
14 S FHCLI=DUZ
15 K ^TMP("FH",$J) S FHQTALL=0
16 ;get current diet and tf
17 S Y=""
18 I DFN D
19 .F I=0:0 S I=$O(^FHPT("AW",I)) Q:I'>0 I $D(^FHPT("AW",I,FHDFN)) S FHLOC=I Q
20 .I $G(FHLOC),$D(^FH(119.6,FHLOC,0)) S FHCLI=$P($G(^FH(119.6,FHLOC,0)),U,2)
21 .S WARD=$G(^DPT(DFN,.1)) I WARD'="" S ADM=$G(^DPT("CN",WARD,DFN))
22 .D:ADM CUR^FHORD7
23 .S FHDIDI=$S(Y'="":Y,1:"No Order")
24 .W !,"Current Diet: ",FHDIDI
25 .Q:'ADM
26 .S TF=$P(^FHPT(FHDFN,"A",ADM,0),"^",4)
27 .Q:'TF
28 .S FHDITFDT=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,1)
29 .S FHDITFCM=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,5)
30 .S FHDITFML=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,6)
31 .S FHDITFKC=$P($G(^FHPT(FHDFN,"A",ADM,"TF",TF,0)),U,7)
32 .F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 D
33 ..S Y=^(TF2,0),TUN=$P(Y,"^",1)
34 ..I TUN,$D(^FH(118.2,TUN,0)) S FHDITFPR(TUN)=Y
35 .W ?30,"Tubefeeding: " I $D(FHDITFPR) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 W $P($G(^FH(118.2,FHTUN,0)),"^",1) I $O(FHDITFPR(FHTUN))'="" W ", "
36 K Y
37STA ;if pt has Work in Progress assessment, ask user to Edit or Create or Delete Assessment.
38 D PATNAME^FHOMUTL
39 S AGE=FHAGE
40 I $D(^FHPT(FHDFN,"N",0)) D
41 .S FHCAS=$P(^FHPT(FHDFN,"N",0),U,3)
42 .Q:'FHCAS
43 .S FHCASD=$P(^FHPT(FHDFN,"N",FHCAS,0),U,1)
44 .I $D(^FHPT(FHDFN,"N",FHCAS,"DI")) S FHASS=$P($G(^FHPT(FHDFN,"N",FHCAS,"DI")),U,6)
45 .S FHAST=0
46 .F FHA=0:0 S FHA=$O(^FHPT(FHDFN,"N",FHA)) Q:'FHA D
47 ..S FHASSD=$P($G(^FHPT(FHDFN,"N",FHA,"DI")),U,6)
48 ..I (FHASSD="W")!(FHASS="") S FHAST=1
49 ..I $D(^FHPT(FHDFN,"N",FHA,0)),'$D(^FHPT(FHDFN,"N",FHA,"DI")) S FHAST=1
50 I 'FHCAS!(FHAST=0) G CRE
51 D ASK^FHASM2 G:FHQUIT KILL^XUSCLEAN
52 I FHASK="D" S DIK="^FHPT("_FHDFN_",""N"",",DA(1)=FHDFN,DA=FHCAS D ^DIK W ?65,"Deleted..." G F1
53 I FHASK="E" S ADT=FHCAS D SVAR G:SEX=""!(AGE="") P1 G F3A
54CRE ;create new assessment
55 ;D:FHCAS PRTA^FHASM2
56 S FHASK="C"
57 W !!,"Creating new Assessment...",!
58 I (FHSEX="")!(FHAGE="") G P1
59 E S NAM=FHPTNM,SEX=FHSEX,AGE=FHAGE
60 S X="NOW",%DT="XT" D ^%DT S ADT=Y
61 I SEX=""!(AGE="") G P1
62F2 S X="NOW",%DT="XT" D ^%DT S ADT=Y
63F3 I DFN,$D(^FHPT(FHDFN,"N",9999999-ADT)) S ADT=$$FMADD^XLFDT(ADT,,,1) G F3
64F3A ;start here if edit
65 S FHAP=$G(^FH(119.9,1,3)),FHU=$P(FHAP,"^",1),NAM=FHPTNM
66 G:'FHDFN F4 S XX=$O(^FHPT(FHDFN,"N",0)) G:XX="" F4 S XX=$G(^(XX,0)),HGT=$P(XX,"^",4),HGP=$P(XX,"^",5)
67 I HGP'="S" S X1=$S(HGT\12:HGT\12_"'",1:"")_$S(HGT#12:" "_(HGT#12)_"""",1:""),X2=+$J(HGT*2.54,0,0)_"CM",X1=$S(FHU'="M":X1,1:X2)
68F4 ; If Multidivisional site Select Communications Office
69 S FHCOMM="" I $P($G(^FH(119.9,1,0)),U,20)'="N" D I FHCOMM="" Q
70 .K DIC S DIC="^FH(119.73," S DIC(0)="AEMQ" D ^DIC
71 .I Y=-1 Q
72 .S FHCOMM=+Y
73 ;get ht and wt from vitals.
74 I DFN S GMRVSTR="WT" D EN6^GMRVUTL S FHDVWGT=$P(X,"^",1),FHVWGT=$P(X,"^",8),GMRVSTR="HT" D EN6^GMRVUTL S FHVHGT=$P(X,"^",8)
75 I X1="" S (X1,HGT)=FHVHGT
76F4A W !!,"Height: " W:X1'="" X1,"// " R X:DTIME G:'$T!(X["^") KIL I X="",X1'="" S Y0=$J(HGT,0,0),H1=Y0 G F5
77 D TR,HGT I Y<1 D HGP G F4A
78 S:X1'=Y FHHWF=1
79 S HGT=Y,H1=Y0,HGP=Y1
80F5 I FHVWGT'="" S WGT=FHVWGT
81 W !!,"Weight: " W:WGT'="" WGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="",WGT S X=WGT_"#"
82 S:X="a" X="A"
83 I X="A",AGE>39 D A^FHASM2D G:Y<1 F5 S:WGT'=Y FHHWF=1 S WGT=Y,WGP="A" G F6
84 D WGT I Y<1 D WGP W:AGE>39 !,"You may enter an A to calculate weight anthropometrically." G F5
85 S:WGT'=Y FHHWF=1
86 S WGT=Y,WGP=Y1,DWGT=$P(FHDVWGT,".",1)
87F6 G:'FHHWF F7
88 S %DT="AEP",%DT("A")="Date Weight Taken: "
89 I 'DWGT,FHDVWGT S DTP=$E(FHDVWGT,4,5)_"/"_$E(FHDVWGT,6,7)_"/"_$E(FHDVWGT,2,3)
90 I DWGT S DTP=$E(DWGT,4,5)_"/"_$E(DWGT,6,7)_"/"_$E(DWGT,2,3)
91 S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY"
92 S %DT(0)="-T" W ! D ^%DT K %DT G KIL:X["^"!$D(DTOUT),F6:Y<1
93 S DWGT=Y
94 ;
95F7 S:UWGT X=UWGT W !!,"Usual Weight: " W:UWGT'="" UWGT_" lbs","// " R X:DTIME G:'$T!(X["^") KIL I X="" G F8
96 D WGT I Y<1 D WGP G F7
97 S UWGT=Y
98F8 K %DT,A1,K,X,Y G ^FHASM2
99HGT ; Convert Height to inches
100 S A1=+X I 'A1 S Y=-1 Q
101 S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SMK"[$E(X,1) S Y=A1 S:FHU="M" Y=Y/2.54 G H1
102 I """I"[$E(X,1) S Y=A1 G H1
103 I $E(X,1)="C" S Y=A1/2.54 G H1
104 I "'F"'[$E(X,1) S Y=-1 G H2
105 S Y=A1*12 F K=1:1 Q:$E(X,K)?.N
106 I $E(X,K,99)="" G H1
107 S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99)
108 I """I"'[$E(X,1) S Y=-1 G H2
109 S Y=Y+A1
110H1 I X["K" D K^FHASM2D
111H2 I Y<12!(Y>96) S Y=-1
112 S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1=$S(X["K":"K",X["S":"S",1:"") Q
113HGP ; Height Help
114 W !!,"Enter height as: 6' 2"" or 74"" or 74IN or 6FT 2 IN or 30CM"
115 W !,"Add an S if height is stated rather than measured."
116 W !,"Add a K if value is a Knee Height measurement."
117 W !,"Height should be between 12"" and 96"" (8')." Q
118WGT ; Convert Weight to lbs.
119 D TR S A1=+X I 'A1 S Y=-1 Q
120 S X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99) I "SM"[$E(X,1) S Y=A1 S:FHU="M" Y=Y*2.2 G W1
121 I $E(X,1)="O" S Y=A1/16 G W1
122 I $E(X,1)="G" S Y=A1/1000*2.2 G W1
123 I $E(X,1)="K" S Y=A1*2.2 G W1
124 I "L#"'[$E(X,1) S Y=-1 G W1
125 S Y=A1 F K=1:1 Q:$E(X,K)?.N
126 I $E(X,K,99)="" G W1
127 S A1=+$E(X,K,99),X=$P(X,A1,2,99) S:$E(X,1)=" " X=$E(X,2,99)
128 I $E(X,1)'="O" S Y=-1 G W1
129 S Y=A1/16+Y
130W1 I Y<0!(Y>750) S Y=-1
131 S:Y>0 Y0=+$J(Y,0,0),Y=+$J(Y,0,1) S Y1="" S:X["S" Y1="S" Q
132WGP ; Weight help
133 W !!,"Enter Weight as 150# or 150# 6OZ or 800G or 70KG"
134 W !,"Add an S if weight is stated rather than measured."
135 W !,"Enter an A to determine weight anthropometrically."
136 W !,"Weight should be between 0 Lbs and 750 Lbs." Q
137TR ; Translate Lower to Upper Case
138 D TR^FH
139 Q
140KIL ; Final variable kill
141 ;if X not equal ^, update or create nutrition assessment
142 G:$G(FHQUIT) ASKUS
143 I $D(X),X=U G ASKUS
144 D SDAT^FHASM7
145 ;
146 G KILL^XUSCLEAN
147PAT S (FHDFN,DFN,SEX,AGE,PID)="" R !!,"Enter Patient's Name: ",NAM:DTIME G:'$T!(NAM["^") KILL^XUSCLEAN
148 I NAM["?"!(NAM'?.ANP)!(NAM="") W *7,!?5,"Enter Patient's Name to be printed on the report." G PAT
149P1 I SEX="" R !,"Sex: ",SEX:DTIME S:SEX="" SEX="?" G:'$T!(SEX["^") KILL^XUSCLEAN S X=SEX D TR S SEX=X I $P("FEMALE",SEX,1)'="",$P("MALE",SEX,1)'="" W *7," Enter M or F" S SEX="" G P1
150 S SEX=$E(SEX,1)
151P2 I AGE="" R !,"Age: ",AGE:DTIME S:AGE="" AGE="?" G:'$T!(AGE["^") KILL^XUSCLEAN S X=AGE D TR S AGE=X
152 S:AGE["M" AGE=+$J($P(AGE,"M",1)/12,0,2) I AGE'>0!(AGE>124) W !?5,"Enter Age Less Than 124 in Years or Months (followed by M) but Not Both" S AGE="" G P2
153 G F2
154SVAR ;set variables of incomplete assessment.
155 Q:'$D(^FHPT(FHDFN,"N",0))
156 S FHA0=$G(^FHPT(FHDFN,"N",FHCAS,0))
157 S ADT=$P(FHA0,U,1),SEX=$P(FHA0,U,2),AGE=$P(FHA0,U,3),HGT=$P(FHA0,U,4)
158 S HGP=$P(FHA0,U,5),WGT=$P(FHA0,U,6),WGP=$P(FHA0,U,7),DWGT=$P(FHA0,U,8)
159 S UWGT=$P(FHA0,U,9),IBW=$P(FHA0,U,10),FRM=$P(FHA0,U,11),AMP=$P(FHA0,U,12)
160 S KCAL=$P(FHA0,U,16),PRO=$P(FHA0,U,17),FLD=$P(FHA0,U,18),RC=$P(FHA0,U,19)
161 S XD=$P(FHA0,U,20),BMI=$P(FHA0,U,21),BMIP=$P(FHA0,U,22)
162 S NOW=$P(FHA0,U,24),NB=$P(FHA0,U,25)
163 S FHA1=$G(^FHPT(FHDFN,"N",FHCAS,1))
164 S TSF=$P(FHA1,U,1),TSFP=$P(FHA1,U,2),SCA=$P(FHA1,U,3),SCAP=$P(FHA1,U,4),ACIR=$P(FHA1,U,5)
165 S ACIRP=$P(FHA1,U,6),CCIR=$P(FHA1,U,7),CCIRP=$P(FHA1,U,8),BFAMA=$P(FHA1,U,9),BFAMAP=$P(FHA1,U,10)
166 S WCCM=$P(FHA1,U,11),CIBW=$P(FHA1,U,12),CERBO=$P(FHA1,U,13),CENB=$P(FHA1,U,14),PCTB=$P(FHA1,U,15)
167 S SEF=$P(FHA1,U,16),CFRB=$P(FHA1,U,17),CFRBO=$P(FHA1,U,18),CPRBO=$P(FHA1,U,19),EKKG=$P(FHA1,U,20)
168 S FHAPP=$G(^FHPT(FHDFN,"N",FHCAS,2))
169 S FHA3=$G(^FHPT(FHDFN,"N",FHCAS,3))
170 S FHYN=$P(FHA3,U,1),FHFEC=$P(FHA3,U,2),FHFPC=$P(FHA3,U,3),FHDINA=$P(FHA3,U,4),FHEDU=$P(FHA3,U,5)
171 S FHFDCSV=$P(FHA3,U,6),FHPL=$P(FHA3,U,7),FHSPC=$P(FHA3,U,8)
172 S FHADI=$G(^FHPT(FHDFN,"N",FHCAS,"DI"))
173 S FHDIPL=$P(FHADI,U,1),FHDIPLD=$P(FHADI,U,2),FHDINF=$P(FHADI,U,3),FHDINFD=$P(FHADI,U,4)
174 S (FHFUD,FHFUDS)=$P(FHADI,U,5),FHDIST=$P(FHADI,U,6),FHDIDI=$P(FHADI,U,7),FHDITF=$P(FHADI,U,8)
175 Q
176ASKUS R !!,"Do you wish to SAVE this Assessment Y// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN
177 S:X="" X="Y" D TR I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G ASKUS
178 I X'?1"Y".E G KILL^XUSCLEAN
179 D SDAT^FHASM7 G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.