source: FOIAVistA/trunk/r/DIETETICS-FH/FHOMRO1.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1FHOMRO1 ;Hines OIFO/RTK RECURRING MEALS ORDER EDIT ;2/04/03 14:05
2 ;;5.5;DIETETICS;**1,2,5**;Jan 28, 2005;Build 53
3 ;
4 S FHDIET="" F FHDX=1:1:5 S FHDIETX(FHDX)=""
5 S FHMSG1="R" D ^FHOMDPA I FHDFN="" Q
6 I '$D(^FHPT(FHDFN,0)) W !!,"UNKNOWN SELECTION !" Q
7 D NOW^%DTC S X1=$E(%,1,7),X2=-1 D C^%DTC S FHNOW=X D CHECK
8 I FHEXST=1 D ORDEDT,END Q
9 D ORDER,END Q
10ORDEDT ;
11 W !!,"This person has an existing outpatient diet order."
12 K DIR S DIR(0)="SBO^E:Edit;O:New Order"
13 S DIR("A")="Edit the existing diet or order another one" D ^DIR
14 Q:$D(DIRUT)
15 I Y="O" D ORDER Q
16 I Y="E" D EDIT Q
17 Q
18ORDER ;
19 W ! D OUTLOC^FHOMUTL I FHLOC="" D EXMSG^FHOMUTL Q
20 W ! D RMBED^FHOMUTL
21DIETORD ;
22 I $P($G(^FH(119.6,FHLOC,1)),U,4)="Y" D MULTDT D:FHDIETX(1)="" EXMSG^FHOMUTL Q:FHDIETX(1)="" D DATE Q
23 D DIETLST^FHOMUTL I FHDEF="" W !!,"NO DEFAULT OUTPATIENT DIET SET!!",! Q
24 S FHDEF=$P($G(^FH(111,FHDEF,0)),U,1)
25 K DIC S DIC="^FH(111,",DIC("A")="Select DIET NAME: ",DIC(0)="AEMQZ"
26 S DIC("B")=FHDEF,DIC("S")="I $D(FHDIETS(+Y))" D ^DIC
27 I $D(DUOUT) D EXMSG^FHOMUTL Q
28 I Y=-1 D EXMSG^FHOMUTL Q
29 S FHDIET=+Y
30DATE ;
31 K DIR S DIR("A")="Select Start Date: ",DIR(0)="DAO^DT" D ^DIR
32 I $D(DIRUT) D EXMSG^FHOMUTL Q
33 S (FHOSTDT,STDT)=Y S Y=STDT D DD^%DT W " ",Y
34 S FHMAX=$P($G(^FH(119.6,FHLOC,1)),U,2) I FHMAX="" S FHMAX=999
35 D NOW^%DTC S FHTODAY=$E(%,1,7),X1=FHTODAY,X2=FHMAX D C^%DTC S FHCUT=X
36 K DIR S DIR("A")="Select End Date: ",DIR(0)="DAO^"_STDT_":"_FHCUT D ^DIR
37 I $D(DIRUT) D EXMSG^FHOMUTL Q
38 S ENDT=Y S Y=ENDT D DD^%DT W " ",Y
39DAYS ;
40 S FHIFLG=0 D SHDAYS
41 K DIR S DIR("A")="Select Days of Week: ",DIR(0)="FAO"
42 D ^DIR I $D(DIRUT) D EXMSG^FHOMUTL Q
43 S FHDAYS=Y D DAYCHK I FHIFLG=1 D DAYS Q
44 K DIR S DIR("A")="Select MEAL: "
45 S DIR(0)="SAO^B:Breakfast;N:Noon;E:Evening"
46 D ^DIR I $D(DIRUT) D EXMSG^FHOMUTL Q
47 S FHMEAL=Y W !
48 I STDT=DT S X=DT D H^%DTC I FHDAYS[$E("XMTWRFS",%Y+1) D CHECKSM I FHSMYES=1 D MSG1 S X1=STDT,X2=1 D C^%DTC S STDT=X I X>ENDT Q
49 K DIR S DIR("A")="Is this correct?: ",DIR(0)="YA",DIR("B")="Y" D ^DIR
50 S CONT=Y I CONT'=1 D EXMSG^FHOMUTL Q
51 S STDTMP=STDT,FHTDTMP=FHTODAY I STDT=DT D CHK1^FHOMRO2
52 D SETNODE,UPD100
53 I FHSETFLG=0 W !!!?5,"No meals ordered!",! Q
54 S FHMSG1="R" D OKMSG^FHOMUTL
55 S FHLTFLG=0 I STDTMP=FHTDTMP D CHK2^FHOMRO2
56 I FHLTFLG=1 F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHTODAY,FHRNUM)) Q:FHRNUM'>0 D
57 .I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL Q
58 .I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
59 .S FHEL="L",FHRMDT=FHTODAY D ORD^FHOMRE1
60 Q
61SETNODE ;
62 S FHMPNUM=$O(^FHPT(FHDFN,"OP","C",""),-1),FHADSFF=0 I FHMPNUM="" S FHMPNUM=0
63 S FHMPNUM=FHMPNUM+1,FHSETFLG=0
64 K ODAYS S CCC=0,X1=STDT,X2=-1 D C^%DTC S STDT=X
65 S ENDL=0 F Q:ENDL=1 D
66 .S CCC=CCC+1,X1=STDT,X2=1 D C^%DTC S STDT=X
67 .I STDT>ENDT S ENDL=1 Q
68 .S X=STDT D DOW^%DTC
69 .I FHDAYS[$E("XMTWRFS",Y+1) S ODAYS(STDT)=STDT D SET
70 .Q
71 S FHACT="O",FHOPTY="R" D SETORX^FHOMRO2 ;creates RM events
72 I $G(FHDPATT)="",FHDIET'="@" S FHDPATT=FHDIET_"^^^^"
73 D SOSFFP^FHOMRO2 ;created diet related SO's, SF's, FP's
74 D SOEVNT^FHSPED ;creates so events
75 D SFEVNT^FHNO7 ;creates sf events
76 Q
77SET ;
78 S FHPREVML=0 D PREV I FHPREVML=1 Q
79 S FHSETFLG=1
80 ;I $O(^FHPT(FHDFN,"OP","B",STDT,FHRNUM)) Q:FHRNUM'>0 D
81 D CPRSO^FHSPED ;check previous SO
82 D CPRSF^FHNO7 ;check previous SF
83 S Y=STDT K DIC,DO S DA(1)=FHDFN,DIC="^FHPT("_DA(1)_",""OP"","
84 S DIC(0)="L" ;,DIC("P")=$P(^DD(115,16,0),U,2),X=+Y,DINUM=X
85 D FILE^DICN I Y=-1 Q
86 K DIE S DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"","
87 S FHORN=$S($G(FHORN)="":"",1:FHORN),DA=+Y
88 S DR="1////^S X=FHDIET;2////^S X=FHLOC;2.5////^S X=FHRMBD;3////^S X=FHMEAL;5////^S X=FHMPNUM;6////^S X=FHDIETX(1);7////^S X=FHDIETX(2);8////^S X=FHDIETX(3);9////^S X=FHDIETX(4);10////^S X=FHDIETX(5);.05////^S X=FHORN;24.5////^S X=DUZ" D ^DIE
89 S ADM=DA
90 D PPRSO^FHSPED ;process previous SO automatically to the new Recurring meal entry.
91 D PPRSF^FHNO7 ;process previous SF automatically.
92 Q
93MULTDT ;
94 S FHDPATT="",FHDIET="@" F FHDX=1:1:5 S FHDIETX(FHDX)="@"
95 D ^FHOMRO3 I $O(FHDI(0))="" F FHDX=1:1:5 S FHDIETX(FHDX)="" Q
96 S FHDX=0 F FHD0=0:0 S FHD0=$O(FHDI(FHD0)) Q:FHD0="" S FHDX=FHDX+1,FHDIETX(FHDX)=$P(FHDI(FHD0),"^",1),FHDPATT=FHDPATT_FHDIETX(FHDX)_"^"
97 Q
98SHDAYS ;
99 W !!," Mon Tues Wed Thur Fri Sat Sun"
100 W !," M T W R F S X"
101 W !!,"Enter string of characters for desired days of week: e.g., MWF",!
102 Q
103DAYCHK ;
104 S X=FHDAYS D TR^FH S FHDAYS=X
105 S X1="" F K=1:1 S Z=$E(FHDAYS,K) Q:Z=""!(FHIFLG=1) D
106 .I X1[Z S FHIFLG=1 Q
107 .I "MTWRFSX"'[Z S FHIFLG=1 Q
108 .S X1=X1_Z Q
109 I FHIFLG=1 W !!,"Please enter the desired days of the week.",!
110 Q
111PREV ;
112 F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",STDT,FHRNUM)) Q:FHRNUM'>0!(FHPREVML=1) D
113 .I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,4)'=FHMEAL Q
114 .I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)="C" Q
115 .D PATNAME^FHOMUTL S FHPREDT=$$FMTE^XLFDT(STDT,"P") I $G(FHHL7)'=1 D
116 ..W !!?3,FHPTNM," ALREADY HAS A "
117 ..W $S(FHMEAL="B":"BREAKFAST",FHMEAL="N":"NOON",1:"EVENING")
118 ..W " MEAL ORDERED FOR ",FHPREDT
119 .S FHPREVML=1
120 Q
121CHECK ;
122 S FHEXST=0 I $O(^FHPT(FHDFN,"OP","B",FHNOW)) D
123 .F FHRMDT=FHNOW:0 S FHRMDT=$O(^FHPT(FHDFN,"OP","B",FHRMDT)) Q:FHRMDT'>0 F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM)) Q:FHRNUM'>0 I $P($G(^FHPT(FHDFN,"OP",FHRNUM,0)),U,15)'="C" S FHEXST=1
124 Q
125CHECKSM ; Check if the OP has an existing SM for this date/meal
126 S FHSMYES=0
127 F FHZ=DT:0 S FHZ=$O(^FHPT(FHDFN,"SM","B",FHZ)) Q:FHZ'>0 D
128 .I $P($G(^FHPT(FHDFN,"SM",FHZ,0)),U,9)'=FHMEAL Q
129 .I $P($G(^FHPT(FHDFN,"SM",FHZ,0)),U,2)="C" Q
130 .I $P($G(^FHPT(FHDFN,"SM",FHZ,0)),U,2)="D" Q
131 .S FHSMYES=1
132 Q
133MSG1 ;
134 W !!,"This patient already has a Special Meal ordered for "
135 S DTP=DT D DTP^FH W DTP," "
136 W $S(FHMEAL="B":"Breakfast",FHMEAL="N":"Noon",1:"Evening"),! H 1 Q
137 ;
138END ;Kill local variables before exiting
139 D KILL^FHOMRO2
140 Q
141 ;
142EDIT ;
143 D NOW^%DTC S STDT=$E(%,1,7),FHDTRLE=%
144 D DISP^FHOMRR1
145EDT1 K DIR S DIR(0)="NAO^1:"_NUM,DIR("A")="Edit Which Order? " D ^DIR
146 Q:$D(DIRUT)
147 S ORDNUM=Y,Y=$P(FHLIST(ORDNUM),U,2) D DD^%DT W !,Y,!
148 S DA=$P(FHLIST(ORDNUM),U,1),DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"","
149 I $P($G(^FHPT(FHDFN,"OP",DA,0)),U,15)="C" W !!?3,"The selected order has been cancelled!",! D EDT1 Q
150 S FHLPT=$P($G(^FHPT(FHDFN,"OP",DA,0)),U,3),FHMEAL=$P($G(^FHPT(FHDFN,"OP",DA,0)),U,4)
151 D OUTLOC I FHLOC="" D UPXMSG^FHOMUTL Q
152 I $P($G(^FH(119.6,FHLOC,1)),U,4)="Y" D MULTDT D:FHDIETX(1)="" UPXMSG^FHOMUTL Q:FHDIETX(1)="" S FHDIET="@" D SETEDT Q
153 D DIETLST^FHOMUTL I FHDEF="" W !!,"NO DEFAULT OUTPATIENT DIET SET!!",! Q
154 S FHDEF2=$P($G(^FHPT(FHDFN,"OP",DA,0)),U,2) I FHDEF2'="" S FHDEF=$P($G(^FH(111,FHDEF2,0)),U,1)
155 K DIC S DIC="^FH(111,",DIC("A")="Select DIET NAME: ",DIC(0)="AEMQZ"
156 S DIC("B")=FHDEF,DIC("S")="I FHSPDTS[$P(^(0),U)" D ^DIC
157 I $D(DUOUT) D UPXMSG^FHOMUTL Q
158 I Y=-1 D UPXMSG^FHOMUTL Q
159 S FHDIET=+Y F FHDX=1:1:5 S FHDIETX(FHDX)="@"
160SETEDT ;
161 W ! S FHZDA=DA,DR="2////^S X=FHLOC;1////^S X=FHDIET;6////^S X=FHDIETX(1);7////^S X=FHDIETX(2);8////^S X=FHDIETX(3);9////^S X=FHDIETX(4);10////^S X=FHDIETX(5);25////^S X=FHDTRLE;24.5////^S X=DUZ"
162 D ^DIE,UPDMSG^FHOMUTL,ED100
163 Q
164OUTLOC ;Prompt for outpatient location - screen for ONLY Outpatient Locations
165 S FHLOC="",FHOUT="O"
166 K DIC S DIC="^FH(119.6,",DIC(0)="AEQZ",DIC("B")=FHLPT
167 S DIC("A")="Select OUTPATIENT LOCATION: "
168 S DIC("S")="I $P(^(0),U,3)=FHOUT" D ^DIC
169 Q:$D(DUOUT) I Y=-1 Q
170 S FHLOC=+Y I '$D(^FH(119.6,FHLOC,"L")) S FHLOC="" W !!,"The selected location does not have an Associated Hospital Location."
171 Q
172UPD100 ;Backdoor message to update file #100 with a new RM order
173 Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
174 Q:'DFN K MSG D MSHOM^FHOMUTL ;Sets MSG(1), MSG(2) & MSG(3) for OM
175 K N1 S FHODAYS=""
176 F N=1:1:7 S FH1=$E(FHDAYS,N) Q:FH1="" S M=$F("MTWRFSX",FH1)-1,N1(M)=""
177 F N=0:0 S N=$O(N1(N)) Q:N'>0 S FHODAYS=FHODAYS_"~QJ"_N
178 S FHODAYS=$E(FHODAYS,2,999)
179 S FHOMEAL=$S(FHMEAL="B":1,FHMEAL="N":3,FHMEAL="E":5,1:"")
180 I FHDIET'="@" S FHODNM=$P($G(^FH(111,FHDIET,0)),U,1)
181 S FHOSTDT=$$FMTHL7^XLFDT(FHOSTDT),FHOENDT=$$FMTHL7^XLFDT(ENDT)
182 S FHOTDAY=$$FMTHL7^XLFDT(FHTODAY)
183 S FILL="R;"_FHMPNUM_";"_FHOSTDT_";"_ENDT_";"_FHDAYS_";"_FHMEAL
184 S MSG(4)="ORC|SN||"_FILL_"^FH||||^"_FHODAYS_"^^"_FHOSTDT_"^"_FHOENDT_"||||||||"_FHOTDAY
185 I FHDIET'="@" S MSG(5)="ODS|D|"_FHOMEAL_"|^^^"_FHDIET_"^"_FHODNM_"^99FHD|"
186 I FHDIET="@" D
187 .F N=0:0 S N=$O(FHDIETX(N)) Q:N'>0 Q:FHDIETX(N)="" S FHODNM=$P($G(^FH(111,FHDIETX(N),0)),U,1),MSG(N+4)="ODS|D|"_FHOMEAL_"|^^^"_FHDIETX(N)_"^"_FHODNM_"^99FHD|"
188 D EVSEND^FHWOR
189 Q
190ED100 ;Backdoor message to update file #100 with an edited RM order
191 Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
192 Q:'DFN K MSG D MSHOM^FHOMUTL ;Sets MSG(1), MSG(2) & MSG(3) for OM
193 S (FHOSTDT,FHOENDT)=$P($G(^FHPT(FHDFN,"OP",FHZDA,0)),U,1)
194 S FHOSTDT=$$FMTHL7^XLFDT(FHOSTDT),FHOENDT=$$FMTHL7^XLFDT(FHOENDT)
195 S FILL="RMEDIT;"_FHZDA,FHORN=$P($G(^FHPT(FHDFN,"OP",FHZDA,0)),U,12)
196 S FHODNM=$P($G(^FH(111,FHDIET,0)),U,1)
197 S FHOMEAL=$S(FHMEAL="B":1,FHMEAL="N":3,FHMEAL="E":5,1:"")
198 S MSG(4)="ORC|XX|"_FHORN_"^OR|"_FILL_"^FH||||^^^"_FHOSTDT_"^"_FHOENDT_"||||||||"
199 S MSG(5)="ODS|D|"_FHOMEAL_"|^^^"_FHDIET_"^"_FHODNM_"^99FHD|"
200 D EVSEND^FHWOR
201 Q
Note: See TracBrowser for help on using the repository browser.