source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHASM7.m@ 1445

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

revised back to 6/30/08 version
File size: 8.2 KB
Line 
1FHASM7 ; HISC/REL - KCAL Distribution ;8/18/93 11:05
2 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
3 S PRT=0,(ASN,NB)=""
4E31 S FH7FLG=1 D ^FHASMR1 K FH7FLG
5 R !!,"Do you want to do a NITROGEN BALANCE? NO// ",X:DTIME G:'$T!(X["^") KIL^FHASM1 S:X="" X="N" D TR^FHASM1 I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G E31
6 I $E(X,1)="N" G KIL:'FHDFN,EDU
7E32 R !!,"Enter Protein Intake (gm/24hr): ",X1:DTIME S:X1=U FHQUIT=1 G KIL^FHASM1:'$T!(X1["^"),E35:X1=""
8 I X1'?.N.1".".N!(X1<0)!(X1>200) W !?5,"Enter 0-200 grams of protein intake" G E32
9E33 R !,"Enter Urinary Nitrogen Output (gm/24hr): ",X2:DTIME S:X2=U FHQUIT=1 G KIL^FHASM1:'$T!(X2["^"),E35:X2=""
10 I X2'?.N.1".".N!(X2<0)!(X2>30) W !?5,"Enter 0-30 gms of Urinary Nitrogen output (24 hr UUN)" G E33
11E34 R !,"Enter Insensible Nitrogen Output (gm/24hr): 4// ",X3:DTIME S:X3="" X3=4 S:X3=U FHQUIT=1 G:'$T!(X3["^") KIL^FHASM1
12 I X3'?.N.1".".N!(X3<0)!(X3>10) W !?5,"Insensible Nitrogen output should be between 0-10 grams" G E34
13 S NB=X1/6.25-(X2+X3),NB=$J(NB,0,0) W !,"Nitrogen Balance: ",NB
14E35 G:'FHDFN KIL
15EDU ;
16 W !!,"Did you educate patient on Food/Drug Interactions (Y/N): " W:FHEDU'="" FHEDU_"//" W:FHEDU="" "N//" R X:DTIME
17 G KIL^FHASM1:'$T!(X["^")
18 I X="",FHEDU="" S X="N"
19 I X="",FHEDU'="" S X=FHEDU
20 D TR^FH
21 I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!,"Enter 'Y' for yes or 'N' for no." G EDU
22 S FHEDU=$E(X,1)
23EDC ;food/drug comment.
24 S FHFDC=FHFDCSV
25 W !!,"Food/Drug Comment: ",FHFDCSV,"// " R FHFDC:DTIME I '$T!(FHFDC["^") S FHQUIT=1 G KIL^FHASM1
26 I FHFDC="@" S FHFDCSV="" W " deleted..." G DPL
27 I (FHFDC=""),(FHFDCSV'="") S FHFDC=FHFDCSV
28 I FHFDC["?"!($L(FHFDC)>30) W *7,!,"Enter Food/Drug Comment or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G EDC
29 S FHFDCSV=FHFDC
30 ;adding diagnosis, follow-up date
31DPL ;get diagnosis from Problem List package.
32 D:DFN LIST^GMPLUTL2(.FHPLIST,DFN,"A","")
33 S FHDIACT=0
34 I $D(FHPLIST(0)) S FHDIACT=FHPLIST(0)
35DP1 I FHDIACT D
36 .S FHDCH=""
37 .W !!,"Patient's Diagnosis from Problem List:",!
38 .F FHDLI=0:0 S FHDLI=$O(FHPLIST(FHDLI)) Q:'FHDLI D
39 ..S DTP=$P(FHPLIST(FHDLI),U,6) D DTP^FH
40 ..W !,?6,FHDLI_" ",$P(FHPLIST(FHDLI),U,3)," - Date entered: ",DTP
41 G:'FHDIACT ANF
42 W !!,"Diagnosis: " W:FHDIPL'="" FHDIPL W "// " R FHDCH:DTIME S:FHDCH=U FHQUIT=1 G:'$T!(FHDCH["^") KIL^FHASM1
43 G:FHDCH="" ANF
44 I FHDCH="@" S (FHDIPL,FHDIPLD)="" G ANF
45 I '$D(FHPLIST(FHDCH)) W !!,*7,"Choose a number from the list or Hit Return to accept default!!",! G DP1
46 S FHDIPL=$P(FHPLIST(FHDCH),U,3),FHDIPLD=$P(FHPLIST(FHDCH),U,6)
47ANF ;problem through NFS.
48 S AFDIA=FHDINA
49 W !!,"Problem: ",FHDINA,"// " R AFDIA:DTIME I '$T!(AFDIA["^") S FHQUIT=1 G KIL^FHASM1
50 I AFDIA="@" S FHDINA="" W " deleted..." G DNF
51 I (AFDIA=""),(FHDINA'="") S AFDIA=FHDINA
52 I AFDIA["?"!($L(AFDIA)>30) W *7,!,"Enter patient's Problem or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G ANF
53 S FHDINA=AFDIA
54 ;
55DNF ;aditional problem through NFS.
56 S NFDIA=FHDINF
57 W !!,"Additional Problem: ",FHDINF,"// " R NFDIA:DTIME I '$T!(NFDIA["^") S FHQUIT=1 G KIL^FHASM1
58 I NFDIA="@" S FHDINF="" W " deleted..." G E4
59 I (NFDIA=""),(FHDINF'="") S NFDIA=FHDINF
60 I NFDIA["?"!($L(NFDIA)>30) W *7,!,"Enter Additional Problem of a patient or Hit Return to Accept or @ to Delete and cannot exceed 30 characters!!" G DNF
61 S FHDINF=NFDIA
62 ;
63E4 ;
64 S APP=FHAPP
65 W !!,"Appearance: ",FHAPP,"// " R APP:DTIME I '$T!(APP["^") S FHQUIT=1 G KIL^FHASM1
66 I APP="@" S FHAPP="" W " deleted..." G EC1
67 I (APP=""),(FHAPP'="") S APP=FHAPP
68 I APP["?"!(APP'?.ANP)!($L(APP)>60) W *7,!,"Enter Physical Appearance of patient or Hit Return to Accept or @ to Delete and cannot exceed 60 characters." G E4
69 S FHAPP=APP
70EC1 W ! S DIC="^FH(115.3,",DIC(0)="AEQMZ",DIC("B")=XD D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S XD=$S(Y>0:+Y,1:"")
71E5 W ! S DIC="^FH(115.4,",DIC(0)="AEQMZ",DIC("B")=RC,DIC("S")="I $P(^(0),U,2)'=""""" D ^DIC K DIC G KIL^FHASM1:X["^"!$D(DTOUT) S RC=$S(Y>0:+Y,1:"")
72 W !!,"Comments:" K ^TMP("FH",$J) S DIC="^TMP(""FH"",$J,",DWPK=1
73 I FHASK="E",$D(^FHPT(FHDFN,"N",FHCAS,"X")) M ^TMP("FH",$J)=^FHPT(FHDFN,"N",FHCAS,"X") D EN^DIWE G FDT
74 D EN^DIWE
75FDT ;enter follow-up date.
76 S (FHDD,DTP)=""
77 I $G(RC) D
78 .S X=$P($G(^FH(115.4,RC,0)),U,2) D TR^FH
79 .I X["NORMAL" D
80 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,20)
81 ..S:FHDD DTP="T+"_FHDD
82 ..S:'FHDD DTP="T+11"
83 .I X["MILD" D
84 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,21)
85 ..S:FHDD DTP="T+"_FHDD
86 ..S:'FHDD DTP="T+9"
87 .I X["MODERATE" D
88 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,22)
89 ..S:FHDD DTP="T+"_FHDD
90 ..S:'FHDD DTP="T+7"
91 .I X["SEVERE" D
92 ..S:FHLOC FHDD=$P($G(^FH(119.6,FHLOC,0)),U,23)
93 ..S:FHDD DTP="T+"_FHDD
94 ..S:'FHDD DTP="T+5"
95 K %DT S %DT="AEF",%DT("A")="Enter Follow-up Assessment Date: "
96 I FHFUD'="",FHFUD>DT S DTP=$E(FHFUD,4,5)_"/"_$E(FHFUD,6,7)_"/"_$E(FHFUD,2,3)
97 S:DTP'="" %DT("B")=DTP S:DTP="" %DT("B")="TODAY"
98 S %DT(0)=DT
99 W ! D ^%DT K %DT G KIL^FHASM1:X["^"!$D(DTOUT),FDT:Y<1
100 S FHFUD=Y
101SDAT ;create or update nutrition assessment and file to Progress Notes.
102 G:'$D(FHASK) KILL^XUSCLEAN
103 I '$D(^FHPT(FHDFN,0)) S ^(0)=FHDFN
104 I '$D(^FHPT(FHDFN,"N",0)) S ^FHPT(FHDFN,"N",0)="^115.011D^^"
105 K DIC,DD,DO S DIC="^FHPT(FHDFN,""N"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN
106 I FHASK="E" S ASN=FHCAS D REC^FHASM3 ;re-calculate calorie, protien and fluid requirement.
107 I FHASK="C" S X=ADT,DINUM=9999999-ADT D FILE^DICN S ASN=+Y ;if not an update, create.
108 D NOW^%DTC S NOW=%
109 S A2=HGT*.0254,BMI=+$J(WGT/2.2/(A2*A2),0,1)
110 S Y=ADT_"^"_SEX_"^"_AGE_"^"_HGT_"^"_HGP_"^"_WGT_"^"_WGP_"^"_DWGT_"^"_UWGT_"^"_IBW_"^"_FRM_"^"_AMP_"^^^^"_KCAL_"^"_PRO_"^"_FLD_"^"_RC_"^"_XD_"^"_BMI_"^"_BMIP_"^"_DUZ_"^"_NOW_"^"_NB
111 S ^FHPT(FHDFN,"N",ASN,0)=Y
112 S:'FHFUD FHFUD=DT
113 S FHASN1=TSF_U_TSFP_U_SCA_U_SCAP_U_ACIR_U_ACIRP_U_CCIR_U_CCIRP_U_BFAMA_U_BFAMAP_U_WCCM_U_CIBW_U_CERBO_U_CENB_U_PCTB_U_SEF_U_CFRB_U_CFRBO_U_CPRBO_U_EKKG
114 S ^FHPT(FHDFN,"N",ASN,1)=FHASN1
115 S ^FHPT(FHDFN,"N",ASN,2)=FHAPP
116 S ^FHPT(FHDFN,"N",ASN,3)=FHYN_U_FHFEC_U_FHFPC_U_FHDINA_U_FHEDU_U_FHFDCSV_U_FHPL_U_FHSPC
117 S ^FHPT(FHDFN,"N",ASN,"DI")=FHDIPL_U_FHDIPLD_U_FHDINF_U_FHDINFD_U_FHFUD_U_FHDIST_U_FHDIDI_U_FHDITFDT
118 S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,10)=FHDITFML
119 S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,11)=FHDITFKC
120 S $P(^FHPT(FHDFN,"N",ASN,4),U,1)=FHDITFCM
121 I $D(FHDITFPR),'$D(^FHPT(FHDFN,"N",ASN,"TF")) F FHTUN=0:0 S FHTUN=$O(FHDITFPR(FHTUN)) Q:FHTUN'>0 D
122 .S Y=FHTUN K DIC,DO S DA(2)=FHDFN,DA(1)=ASN
123 .S DIC="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF"","
124 .S DIC(0)="L",DIC("P")=$P(^DD(115.011,67.1,0),U,2),X=+Y
125 .D FILE^DICN I Y=-1 Q
126 .K DIE S DA(2)=FHDFN,DA(1)=ASN,DA=+Y
127 .S FH1=$P(FHDITFPR(FHTUN),U,2),FH2=$P(FHDITFPR(FHTUN),U,3)
128 .S DIE="^FHPT("_DA(2)_",""N"","_DA(1)_",""TF"","
129 .S DR="1////^S X=FH1;2////^S X=FH2" D ^DIE
130 I FHFUDS,(FHFUDS'=FHFUD) K ^FHPT("E",FHFUDS,FHDFN,ASN)
131 I FHFUD S DA(1)=FHDFN,DA=ASN,DIK="^FHPT(DA(1)"_",""N"",",DIK(1)="64^E" D IX^DIK
132 G:'$D(LRTST) E7
133 S N1=0 F K=0:0 S K=$O(LRTST(K)) Q:K="" S ^FHPT(FHDFN,"N",ASN,"L",K,0)=LRTST(K),N1=N1+1
134 I N1,'$D(^FHPT(FHDFN,"N",ASN,"L",0)) S ^(0)="^115.021^^"
135E7 G:'$D(^TMP("FH",$J)) E8
136 S ^FHPT(FHDFN,"N",ASN,"X",0)=^TMP("FH",$J,0)
137 S N1=0 F K=0:0 S K=$O(^TMP("FH",$J,K)) Q:K'>0 S N1=N1+1,^FHPT(FHDFN,"N",ASN,"X",N1,0)=^TMP("FH",$J,K,0)
138E8 S DTE=ADT,S1=1,S2="I",S3=$S('RC:"",1:"Nutrition Status: "_$P(^FH(115.4,RC,0),"^",2))
139 I $G(DFN) D FIL^FHASE3 I 'RC G E9
140 I '$D(^FHPT(FHDFN,"S",0)) S ^(0)="^115.012D^^"
141 K DIC,DD,DO S DIC="^FHPT(FHDFN,""S"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN,X=ADT,DINUM=9999999-ADT D FILE^DICN S ASE=+Y
142 I $G(DFN) D DID^FHDPA S $P(^FHPT(FHDFN,"S",ASE,0),"^",2,3)=RC_"^"_DUZ S:FHWRD $P(^(0),"^",6)=FHWRD
143E9 ;D P0^FHASMR
144E6 R !!,"Save as Work in Progress or Complete or Delete this assessment: W// ",X:DTIME G:'$T!(X["^") KILL^XUSCLEAN
145 S:X="" X="W" D TR^FHASM1
146 I ($E(X)'="W"),($E(X)'="C"),($E(X)'="D") W *7,!," Answer 'W' to file as Work in progress or 'C' to Complete and send to TIU or 'D' to Delete" G E6
147 I $E(X)="D" S DA(1)=FHDFN,DIK="^FHPT(FHDFN,""N"",",DA=ASN D ^DIK W !!,"Deleted...",! G KILL^XUSCLEAN
148 I $E(X)="W" S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W" W !!,"This Assessment has been saved as Work in Progress...",!
149 I $E(X)="C" D
150 .;send assessment to TIU if pt has entry in #2.
151 .I $G(DFN) D ^FHASMR2 K ^TMP($J) I $G(FHOUT) D Q
152 ..W !!,"TIU Progress Note was NOT created!!"
153 ..S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="W"
154 .S $P(^FHPT(FHDFN,"N",ASN,"DI"),U,6)="C"
155 .W !!,"Assessment is completed" W:$G(DFN) " and forwarded to TIU" W "...",!
156KIL G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.