« back to all changes in this revision
Viewing changes to kids/OR_30_1502_6.KID
- browse files at revision 57
- compare with another revision
- download diff
- download tarball
- view history from revision 57
- Committer: Jonathan Tai
- Date: 2010-07-21 07:39:07 UTC
- Revision ID: jon.tai@medsphere.com-20100721073907-6swd9zhzxongtra5
OpenVista 1.5 Service Pack 5
Installed the following builds (in order):
LR*5.2*1501
MSCPSBCOA*0.9*2
LR*5.2*1500
OR*3.0*1500
PSJ*5.0*1500
PSB*3.0*1500
OR*3.0*1503
RA*5.0*1502
MSCF*1.5*1501
RA*5.0*1501
MSCO*1.5*1505
PSJ*5.0*1501
OR*3.0*1502
MSCF*1.5*1502
From these files:
LR_52_1501.KID
MSCPSBCOA0_9_2.KID
LR_52_1500_REVD.KID
OR_30_1500.KID
PSJ_50_1500.KID
psb_3_1500a.kid
OR_30_1503.KID
RA_50_1502.KID
MSCF_15_1501.KID
RA_50_1501.KID
MSCO_15_1505.KID
PSJ_50_1501.KID
OR_30_1502_6.KID
MSCF_15_1502.KID
After all KIDS builds were installed, FileMan 1039 routines were imported from MSCFILEMAN 1039.RSA and ^DINIT was run.
Installed the following builds (in order):
LR*5.2*1501
MSCPSBCOA*0.9*2
LR*5.2*1500
OR*3.0*1500
PSJ*5.0*1500
PSB*3.0*1500
OR*3.0*1503
RA*5.0*1502
MSCF*1.5*1501
RA*5.0*1501
MSCO*1.5*1505
PSJ*5.0*1501
OR*3.0*1502
MSCF*1.5*1502
From these files:
LR_52_1501.KID
MSCPSBCOA0_9_2.KID
LR_52_1500_REVD.KID
OR_30_1500.KID
PSJ_50_1500.KID
psb_3_1500a.kid
OR_30_1503.KID
RA_50_1502.KID
MSCF_15_1501.KID
RA_50_1501.KID
MSCO_15_1505.KID
PSJ_50_1501.KID
OR_30_1502_6.KID
MSCF_15_1502.KID
After all KIDS builds were installed, FileMan 1039 routines were imported from MSCFILEMAN 1039.RSA and ^DINIT was run.
- files added:
- kids/LR_52_1500_REVD.KID
- files modified:
- globals/%.zwr
added
removed
kids/OR_30_1502_6.KID
1
KIDS Distribution saved on Jul 06, 2010@12:05:47
2
LEADING ZEROS
3
**KIDS**:OR*3.0*1502^
4
5
**INSTALL NAME**
6
OR*3.0*1502
7
"BLD",6952,0)
8
OR*3.0*1502^^0^3100706^n
9
"BLD",6952,1,0)
10
^^1^1^3100610^
11
"BLD",6952,1,1,0)
12
Put leading zero on decimal numeric values in order text
13
"BLD",6952,4,0)
14
^9.64PA^^
15
"BLD",6952,6.3)
16
12
17
"BLD",6952,"KRN",0)
18
^9.67PA^8989.52^19
19
"BLD",6952,"KRN",.4,0)
20
.4
21
"BLD",6952,"KRN",.401,0)
22
.401
23
"BLD",6952,"KRN",.402,0)
24
.402
25
"BLD",6952,"KRN",.403,0)
26
.403
27
"BLD",6952,"KRN",.5,0)
28
.5
29
"BLD",6952,"KRN",.84,0)
30
.84
31
"BLD",6952,"KRN",3.6,0)
32
3.6
33
"BLD",6952,"KRN",3.8,0)
34
3.8
35
"BLD",6952,"KRN",9.2,0)
36
9.2
37
"BLD",6952,"KRN",9.8,0)
38
9.8
39
"BLD",6952,"KRN",9.8,"NM",0)
40
^9.68A^5^5
41
"BLD",6952,"KRN",9.8,"NM",1,0)
42
ORCD^^0^B57002790
43
"BLD",6952,"KRN",9.8,"NM",2,0)
44
ORWPS^^0^B95265151
45
"BLD",6952,"KRN",9.8,"NM",3,0)
46
ORCSAVE^^0^B77428216
47
"BLD",6952,"KRN",9.8,"NM",4,0)
48
PSGOE4^^0^B26687646
49
"BLD",6952,"KRN",9.8,"NM",5,0)
50
PSJHL4A^^0^B37291448
51
"BLD",6952,"KRN",9.8,"NM","B","ORCD",1)
52
53
"BLD",6952,"KRN",9.8,"NM","B","ORCSAVE",3)
54
55
"BLD",6952,"KRN",9.8,"NM","B","ORWPS",2)
56
57
"BLD",6952,"KRN",9.8,"NM","B","PSGOE4",4)
58
59
"BLD",6952,"KRN",9.8,"NM","B","PSJHL4A",5)
60
61
"BLD",6952,"KRN",19,0)
62
19
63
"BLD",6952,"KRN",19.1,0)
64
19.1
65
"BLD",6952,"KRN",101,0)
66
101
67
"BLD",6952,"KRN",409.61,0)
68
409.61
69
"BLD",6952,"KRN",771,0)
70
771
71
"BLD",6952,"KRN",870,0)
72
870
73
"BLD",6952,"KRN",8989.51,0)
74
8989.51
75
"BLD",6952,"KRN",8989.52,0)
76
8989.52
77
"BLD",6952,"KRN",8994,0)
78
8994
79
"BLD",6952,"KRN","B",.4,.4)
80
81
"BLD",6952,"KRN","B",.401,.401)
82
83
"BLD",6952,"KRN","B",.402,.402)
84
85
"BLD",6952,"KRN","B",.403,.403)
86
87
"BLD",6952,"KRN","B",.5,.5)
88
89
"BLD",6952,"KRN","B",.84,.84)
90
91
"BLD",6952,"KRN","B",3.6,3.6)
92
93
"BLD",6952,"KRN","B",3.8,3.8)
94
95
"BLD",6952,"KRN","B",9.2,9.2)
96
97
"BLD",6952,"KRN","B",9.8,9.8)
98
99
"BLD",6952,"KRN","B",19,19)
100
101
"BLD",6952,"KRN","B",19.1,19.1)
102
103
"BLD",6952,"KRN","B",101,101)
104
105
"BLD",6952,"KRN","B",409.61,409.61)
106
107
"BLD",6952,"KRN","B",771,771)
108
109
"BLD",6952,"KRN","B",870,870)
110
111
"BLD",6952,"KRN","B",8989.51,8989.51)
112
113
"BLD",6952,"KRN","B",8989.52,8989.52)
114
115
"BLD",6952,"KRN","B",8994,8994)
116
117
"BLD",6952,"MSC")
118
C:\KIDSBUILD\OR_30_1502_6.KID
119
"BLD",6952,"MSCOM")
120
LEADING ZEROS
121
"MBREQ")
122
0
123
"QUES","XPF1",0)
124
Y
125
"QUES","XPF1","??")
126
^D REP^XPDH
127
"QUES","XPF1","A")
128
Shall I write over your |FLAG| File
129
"QUES","XPF1","B")
130
YES
131
"QUES","XPF1","M")
132
D XPF1^XPDIQ
133
"QUES","XPF2",0)
134
Y
135
"QUES","XPF2","??")
136
^D DTA^XPDH
137
"QUES","XPF2","A")
138
Want my data |FLAG| yours
139
"QUES","XPF2","B")
140
YES
141
"QUES","XPF2","M")
142
D XPF2^XPDIQ
143
"QUES","XPI1",0)
144
YO
145
"QUES","XPI1","??")
146
^D INHIBIT^XPDH
147
"QUES","XPI1","A")
148
Want KIDS to INHIBIT LOGONs during the install
149
"QUES","XPI1","B")
150
NO
151
"QUES","XPI1","M")
152
D XPI1^XPDIQ
153
"QUES","XPM1",0)
154
PO^VA(200,:EM
155
"QUES","XPM1","??")
156
^D MG^XPDH
157
"QUES","XPM1","A")
158
Enter the Coordinator for Mail Group '|FLAG|'
159
"QUES","XPM1","B")
160
161
"QUES","XPM1","M")
162
D XPM1^XPDIQ
163
"QUES","XPO1",0)
164
Y
165
"QUES","XPO1","??")
166
^D MENU^XPDH
167
"QUES","XPO1","A")
168
Want KIDS to Rebuild Menu Trees Upon Completion of Install
169
"QUES","XPO1","B")
170
NO
171
"QUES","XPO1","M")
172
D XPO1^XPDIQ
173
"QUES","XPZ1",0)
174
Y
175
"QUES","XPZ1","??")
176
^D OPT^XPDH
177
"QUES","XPZ1","A")
178
Want to DISABLE Scheduled Options, Menu Options, and Protocols
179
"QUES","XPZ1","B")
180
NO
181
"QUES","XPZ1","M")
182
D XPZ1^XPDIQ
183
"QUES","XPZ2",0)
184
Y
185
"QUES","XPZ2","??")
186
^D RTN^XPDH
187
"QUES","XPZ2","A")
188
Want to MOVE routines to other CPUs
189
"QUES","XPZ2","B")
190
NO
191
"QUES","XPZ2","M")
192
D XPZ2^XPDIQ
193
"RTN")
194
5
195
"RTN","ORCD")
196
0^1^B57002790
197
"RTN","ORCD",1,0)
198
ORCD ; SLC/MKB - Order Dialog utilities ; 29 Jun 2010 3:16 PM
199
"RTN","ORCD",2,0)
200
;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,38,68,94,161,141,195,215,1502**;Dec 17,1997
201
"RTN","ORCD",3,0)
202
INPT() ; -- Return 1 or 0, if patient/order sheet = inpatient
203
"RTN","ORCD",4,0)
204
N Y S Y=$S($G(ORWARD):1,$G(^DPT(+ORVP,.105)):1,1:0)
205
"RTN","ORCD",5,0)
206
I $G(OREVENT) D ;override if delayed order
207
"RTN","ORCD",6,0)
208
. N X,X0 S X=$$EVT^OREVNTX(+OREVENT),X0=$G(^ORD(100.5,+X,0))
209
"RTN","ORCD",7,0)
210
. I $P(X0,U,12) S X0=$G(^ORD(100.5,$P(X0,U,12),0)) ;use parent
211
"RTN","ORCD",8,0)
212
. S X=$P(X0,U,2) Q:X="M" Q:X="O" ;M/O keep current inpt status
213
"RTN","ORCD",9,0)
214
. S Y=$S(X="A":1,X="T":1,1:0)
215
"RTN","ORCD",10,0)
216
. I X="D",$P(X0,U,7)=41 S Y=1 ;From ASIH = Inpt
217
"RTN","ORCD",11,0)
218
. I X="T",$P(X0,U,7),$P(X0,U,7)<4 S Y=0 ;pass = Outpt
219
"RTN","ORCD",12,0)
220
Q Y
221
"RTN","ORCD",13,0)
222
;
223
"RTN","ORCD",14,0)
224
EXT(P,I,F) ; -- Returns external value of ORDIALOG(Prompt,Instance)
225
"RTN","ORCD",15,0)
226
N TYPE,PARAM,FNUM,IENS,X,Y,J,Z
227
"RTN","ORCD",16,0)
228
S TYPE=$E($G(ORDIALOG(P,0))),PARAM=$P($G(ORDIALOG(P,0)),U,2)
229
"RTN","ORCD",17,0)
230
S X=$G(ORDIALOG(P,I)) I X="" Q ""
231
"RTN","ORCD",18,0)
232
I "FNW"[TYPE Q $S(TYPE="W":X,X?1"."1N.E:0_X,1:X) ;MSC JDS put in leading 0 on decimals
233
"RTN","ORCD",19,0)
234
I TYPE="Y" Q $S(X:"YES",X=0:"NO",1:"")
235
"RTN","ORCD",20,0)
236
I TYPE="D" S:'$L($G(F)) F=1 Q $$FMTE^XLFDT(X,F)
237
"RTN","ORCD",21,0)
238
I TYPE="R" Q $$FTDATE(X,$G(F)) ; DAY@TIME
239
"RTN","ORCD",22,0)
240
I TYPE="P" D Q Y
241
"RTN","ORCD",23,0)
242
. S PARAM=$P(PARAM,":"),FNUM=$S(PARAM:+PARAM,1:+$P(@(U_PARAM_"0)"),U,2))
243
"RTN","ORCD",24,0)
244
. S IENS=+X_",",J=$L(PARAM,",") I J>2 F S J=J-2 Q:J'>0 S Z=$P(PARAM,",",J),IENS=IENS_$S(Z:Z,1:+$P(Z,"(",2))_","
245
"RTN","ORCD",25,0)
246
. S:'+$G(F) F=.01 S Y=$$GET1^DIQ(FNUM,IENS,+F)
247
"RTN","ORCD",26,0)
248
. I Y="",F'=.01 S Y=$$GET1^DIQ(FNUM,IENS,.01)
249
"RTN","ORCD",27,0)
250
I TYPE="S" F J=1:1:$L(PARAM,";") S Z=$P(PARAM,";",J) I $P(Z,":")=X S Y=$S(+$G(F):X,1:$P(Z,":",2)) Q
251
"RTN","ORCD",28,0)
252
; MSC/REC 3/25/09 -- External value of Mode of Transport was not being returned
253
"RTN","ORCD",29,0)
254
I $G(ORNMSP)="RA",TYPE="S",$P(ORDIALOG(P),U,2)="MODE" D
255
"RTN","ORCD",30,0)
256
. N MSCMOT
257
"RTN","ORCD",31,0)
258
. S MSCMOT=$O(^MSC(21475.1,"C",X,0)) I $G(MSCMOT) S Y=$P($G(^MSC(21475.1,MSCMOT,0)),U) Q
259
"RTN","ORCD",32,0)
260
. ;if no mscmot, check for lowercase abbreviation
261
"RTN","ORCD",33,0)
262
. S MSCMOT=$O(^MSC(21475.1,"C",$$LOW^XLFSTR(X),0)) I $G(MSCMOT) S Y=$P($G(^MSC(21475.1,MSCMOT,0)),U) Q
263
"RTN","ORCD",34,0)
264
Q $G(Y)
265
"RTN","ORCD",35,0)
266
;
267
"RTN","ORCD",36,0)
268
FTDATE(X,F) ; -- Returns free text form of date (i.e. TODAY)
269
"RTN","ORCD",37,0)
270
N D,T,P,Y I X="" Q ""
271
"RTN","ORCD",38,0)
272
S X=$$UP^XLFSTR(X),D=$P(X,"@"),T=$P(X,"@",2) ; D=date,T=time parts
273
"RTN","ORCD",39,0)
274
I "NOW"[X Q "NOW"
275
"RTN","ORCD",40,0)
276
I "NOON"[X Q "NOON"
277
"RTN","ORCD",41,0)
278
I $E("MIDNIGHT",1,$L(X))=X Q "MIDNIGHT"
279
"RTN","ORCD",42,0)
280
I (X="AM")!(X="NEXT") Q X_" Lab collection"
281
"RTN","ORCD",43,0)
282
I (X="NEXTA")!(X="CLOSEST") Q $S(X="NEXTA":"NEXT",1:X)_" administration time"
283
"RTN","ORCD",44,0)
284
I $E(D)'="T",$E(D)'="V",($E(D)'="N"!($E(D,1,3)="NOV")) D Q $$FMTE^XLFDT(X,F)
285
"RTN","ORCD",45,0)
286
. N %DT S %DT="TX" D ^%DT S:Y>0 X=Y S:'$G(F) F=1
287
"RTN","ORCD",46,0)
288
S P=$S(D["+":"+",D["-":"-",1:"")
289
"RTN","ORCD",47,0)
290
I P="" S Y=$S($E(D)="T":"TODAY",$E(D)="V":"NEXT VISIT",1:"NOW")
291
"RTN","ORCD",48,0)
292
FTD1 E D
293
"RTN","ORCD",49,0)
294
. N OFFSET,NUM,UNIT
295
"RTN","ORCD",50,0)
296
. S OFFSET=$P(D,P,2),NUM=+OFFSET,UNIT=$E($P(OFFSET,NUM,2)) ; +/-#D
297
"RTN","ORCD",51,0)
298
. I $E(D)="T",NUM=1,UNIT=""!(UNIT="D") S Y=$S(P="+":"TOMORROW",1:"YESTERDAY") Q
299
"RTN","ORCD",52,0)
300
. S Y=NUM_" "_$S(UNIT="'":"MINUTE",UNIT="H":"HOUR",UNIT="W":"WEEK",UNIT="M":"MONTH",1:"DAY")
301
"RTN","ORCD",53,0)
302
. S:NUM>1 Y=Y_"S" ; plural
303
"RTN","ORCD",54,0)
304
. S:$E(D)="N" Y=Y_" "_$S(P="+":"FROM NOW",1:"AGO")
305
"RTN","ORCD",55,0)
306
. S:$E(D)="T" Y=Y_" "_$S(P="+":"FROM TODAY",1:"AGO")
307
"RTN","ORCD",56,0)
308
. S:$E(D)="V" Y=Y_" "_$S(P="+":"AFTER",1:"BEFORE")_" NEXT VISIT"
309
"RTN","ORCD",57,0)
310
I $L(T) S Y=Y_"@"_$$TIME(T)
311
"RTN","ORCD",58,0)
312
Q Y
313
"RTN","ORCD",59,0)
314
;
315
"RTN","ORCD",60,0)
316
FTDHELP ; -- Displays ??-help for R-type prompts
317
"RTN","ORCD",61,0)
318
G R^ORCDLGH
319
"RTN","ORCD",62,0)
320
Q
321
"RTN","ORCD",63,0)
322
;
323
"RTN","ORCD",64,0)
324
FTDCOMP(X1,X2,OPER) ; -- Compares free text dates from prompts X1 & X2
325
"RTN","ORCD",65,0)
326
; Returns 1 or 0, IF $$VAL(X1)<OPER>$$VAL(X2) is true
327
"RTN","ORCD",66,0)
328
N X,Y,Y1,Y2,Z,%DT
329
"RTN","ORCD",67,0)
330
S X=$$VAL(X1),%DT="TX" D ^%DT S Y1=Y ; Y'>0 ??
331
"RTN","ORCD",68,0)
332
S X=$$VAL(X2),%DT="TX" D ^%DT S Y2=Y ; Y'>0 ??
333
"RTN","ORCD",69,0)
334
S Z="I "_Y1_OPER_Y2 X Z
335
"RTN","ORCD",70,0)
336
Q $T
337
"RTN","ORCD",71,0)
338
;
339
"RTN","ORCD",72,0)
340
TIME(X) ; -- Returns 00:00 PM formatted time
341
"RTN","ORCD",73,0)
342
N Y,Z,%DT
343
"RTN","ORCD",74,0)
344
I "NOON"[X Q X
345
"RTN","ORCD",75,0)
346
I "MIDNIGHT"[X Q "MIDNIGHT"
347
"RTN","ORCD",76,0)
348
I X?1U,"BNE"[X Q $S(X="B":"BREAKFAST",X="N":"NOON",X="E":"EVENING",1:"")
349
"RTN","ORCD",77,0)
350
S X="T@"_X,%DT="TX" D ^%DT I Y'>0 Q ""
351
"RTN","ORCD",78,0)
352
S Z=$$FMTE^XLFDT(Y,"2P"),Z=$P(Z," ",2)_$$UP^XLFSTR($P(Z," ",3))
353
"RTN","ORCD",79,0)
354
Q Z
355
"RTN","ORCD",80,0)
356
;
357
"RTN","ORCD",81,0)
358
VAL(TEXT,INST) ; -- Returns internal form of TEXT's current value
359
"RTN","ORCD",82,0)
360
N I,X S X="" S:'$G(INST) INST=1
361
"RTN","ORCD",83,0)
362
I '$D(ORDIALOG("B",TEXT)) S I=$O(ORDIALOG("B",TEXT)) Q:$E(I,1,$L(TEXT))'=TEXT X S TEXT=I ; partial match
363
"RTN","ORCD",84,0)
364
S X=$P($G(ORDIALOG("B",TEXT)),U,2) ; ptr
365
"RTN","ORCD",85,0)
366
I X?1"."1N.E S X=0_X ;JDS/MSC
367
"RTN","ORCD",86,0)
368
Q $G(ORDIALOG(X,INST))
369
"RTN","ORCD",87,0)
370
;
371
"RTN","ORCD",88,0)
372
ORDMSG(OI) ; -- Display order message for orderable OI
373
"RTN","ORCD",89,0)
374
Q:'$O(^ORD(101.43,OI,8,0)) ; no order message
375
"RTN","ORCD",90,0)
376
N I S I=0 W !
377
"RTN","ORCD",91,0)
378
F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 W !,$G(^(I,0))
379
"RTN","ORCD",92,0)
380
W ! Q
381
"RTN","ORCD",93,0)
382
;
383
"RTN","ORCD",94,0)
384
PTR(NAME) ; -- Returns pointer to Dialog file for prompt NAME
385
"RTN","ORCD",95,0)
386
Q +$O(^ORD(101.41,"AB",$E(NAME,1,63),0))
387
"RTN","ORCD",96,0)
388
;
389
"RTN","ORCD",97,0)
390
NMSP(PKG) ; -- Returns package namespace from pointer
391
"RTN","ORCD",98,0)
392
N Y S Y=$$GET1^DIQ(9.4,+PKG_",",1)
393
"RTN","ORCD",99,0)
394
S:$E(Y,1,2)="PS" Y="PS" S:Y="GMRV" Y="OR"
395
"RTN","ORCD",100,0)
396
Q Y
397
"RTN","ORCD",101,0)
398
;
399
"RTN","ORCD",102,0)
400
GETQDLG(QIFN) ; -- define ORDIALOG(PROMPT) for quick order QIFN
401
"RTN","ORCD",103,0)
402
S ORDIALOG=$$DEFDLG(QIFN) Q:'ORDIALOG
403
"RTN","ORCD",104,0)
404
D GETDLG(ORDIALOG),GETORDER("^ORD(101.41,"_QIFN_",6)")
405
"RTN","ORCD",105,0)
406
X:$D(^ORD(101.41,QIFN,3)) ^(3) ; entry action for quick order
407
"RTN","ORCD",106,0)
408
Q
409
"RTN","ORCD",107,0)
410
;
411
"RTN","ORCD",108,0)
412
DEFDLG(QDLG) ; -- Returns default dialog for QDLG
413
"RTN","ORCD",109,0)
414
N DG,DLG,TOP S DG=+$P($G(^ORD(101.41,+QDLG,0)),U,5)
415
"RTN","ORCD",110,0)
416
S DLG=+$P($G(^ORD(100.98,DG,0)),U,4) ; default dialog
417
"RTN","ORCD",111,0)
418
I 'DLG S TOP=+$O(^ORD(100.98,"AD",DG,0)),DLG=+$P($G(^ORD(100.98,TOP,0)),U,4)
419
"RTN","ORCD",112,0)
420
Q DLG
421
"RTN","ORCD",113,0)
422
;
423
"RTN","ORCD",114,0)
424
GETDLG(IFN) ; -- define ORDIALOG(PROMPT) for dialog IFN
425
"RTN","ORCD",115,0)
426
N SEQ,DA,ITEM,PTR,PROMPT,TEXT,INDEX,HELP,XHELP,SCREEN,ORD,INPUTXFM,LKP
427
"RTN","ORCD",116,0)
428
S SEQ=0 K ^TMP("ORWORD",$J)
429
"RTN","ORCD",117,0)
430
F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D
431
"RTN","ORCD",118,0)
432
. S ITEM=$G(^ORD(101.41,IFN,10,DA,0)),INPUTXFM=$G(^(.1)),HELP=$G(^(1)),SCREEN=$G(^(4)),XHELP=$G(^(6))
433
"RTN","ORCD",119,0)
434
. S PTR=$P(ITEM,U,2),TEXT=$P(ITEM,U,4),INDEX=$P(ITEM,U,10) Q:'PTR
435
"RTN","ORCD",120,0)
436
. S:'$L(TEXT) TEXT=$P(^ORD(101.41,PTR,0),U,2) K ORD
437
"RTN","ORCD",121,0)
438
. S PROMPT=$G(^ORD(101.41,PTR,1)),ORD=DA_U_$P(PROMPT,U,3)
439
"RTN","ORCD",122,0)
440
. S ORD(0)=$P(PROMPT,U)_$S($P(PROMPT,U)="S":"M",1:"")_U_$P(PROMPT,U,2)_$S($L(INPUTXFM):U_INPUTXFM,1:"")
441
"RTN","ORCD",123,0)
442
. S ORD("A")=TEXT S:$L($P(ITEM,U,13)) ORD("TTL")=$P(ITEM,U,13)
443
"RTN","ORCD",124,0)
444
. I $P(ITEM,U,7) S ORD("MAX")=$P(ITEM,U,12),ORD("MORE")=$P(ITEM,U,14) ; fields for multiples
445
"RTN","ORCD",125,0)
446
. I $L(HELP) S LKP=$P(HELP,U,2),HELP=$P(HELP,U) S:$L(HELP) ORD("?")=HELP S:$L(LKP) ORD("LKP")=$S($L(LKP,";")>1:$TR(LKP,";","^"),1:U_LKP)
447
"RTN","ORCD",126,0)
448
. S:$L(XHELP) ORD("??")=U_XHELP
449
"RTN","ORCD",127,0)
450
. S:$L(INDEX) ORD("D")=INDEX
451
"RTN","ORCD",128,0)
452
. S:$L(SCREEN) ORD("S")=SCREEN
453
"RTN","ORCD",129,0)
454
. S ORDIALOG("B",$$UP^XLFSTR($P(TEXT,":")))=SEQ_U_PTR
455
"RTN","ORCD",130,0)
456
. M ORDIALOG(PTR)=ORD
457
"RTN","ORCD",131,0)
458
Q
459
"RTN","ORCD",132,0)
460
;
461
"RTN","ORCD",133,0)
462
GETDLG1(IFN) ; -- basic ORDIALOG(PROMPT) for dialog IFN
463
"RTN","ORCD",134,0)
464
N SEQ,DA,PROMPT,PTR,WINCTRL
465
"RTN","ORCD",135,0)
466
K ^TMP("ORWORD",$J) S SEQ=0
467
"RTN","ORCD",136,0)
468
F S SEQ=$O(^ORD(101.41,IFN,10,"B",SEQ)) Q:SEQ'>0 S DA=0 F S DA=$O(^ORD(101.41,IFN,10,"B",SEQ,DA)) Q:'DA D
469
"RTN","ORCD",137,0)
470
. S PTR=$P($G(^ORD(101.41,IFN,10,DA,0)),U,2) Q:'PTR
471
"RTN","ORCD",138,0)
472
. S WINCTRL=$P($G(^ORD(101.41,IFN,10,DA,"W")),U)
473
"RTN","ORCD",139,0)
474
. S PROMPT=$G(^ORD(101.41,PTR,1)) Q:'$L(PROMPT)
475
"RTN","ORCD",140,0)
476
. S ORDIALOG(PTR)=DA_U_$P(PROMPT,U,3)_U_WINCTRL
477
"RTN","ORCD",141,0)
478
. S ORDIALOG(PTR,0)=$P(PROMPT,U,1,2)
479
"RTN","ORCD",142,0)
480
Q
481
"RTN","ORCD",143,0)
482
;
483
"RTN","ORCD",144,0)
484
GETORDER(ROOT,ARRAY) ; -- retrieve order values from RESPONSES in ARRAY()
485
"RTN","ORCD",145,0)
486
N ORI,ID,PTR,INST,TYPE,DA,X,ORTXT S:'$L($G(ARRAY)) ARRAY="ORDIALOG"
487
"RTN","ORCD",146,0)
488
I +ROOT=ROOT S ROOT="^OR(100,"_ROOT_",4.5)" ; assume Orders file IFN
489
"RTN","ORCD",147,0)
490
S ORI=0 F S ORI=$O(@ROOT@(ORI)) Q:ORI'>0 S ID=$G(@ROOT@(ORI,0)) D
491
"RTN","ORCD",148,0)
492
. S DA=$P(ID,U),PTR=$P(ID,U,2),INST=$P(ID,U,3) S:'INST INST=1
493
"RTN","ORCD",149,0)
494
. S:'PTR PTR=$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) Q:'PTR
495
"RTN","ORCD",150,0)
496
. Q:'$D(ORDIALOG(PTR)) S TYPE=$E($G(ORDIALOG(PTR,0))) Q:'$L(TYPE)
497
"RTN","ORCD",151,0)
498
. I TYPE'="W" S X=$G(@ROOT@(ORI,1)) S:$L(X) @ARRAY@(PTR,INST)=X Q
499
"RTN","ORCD",152,0)
500
. D RESTXT ;resolve objects
501
"RTN","ORCD",153,0)
502
. I ARRAY="ORDIALOG" M ^TMP("ORWORD",$J,PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)="^TMP(""ORWORD"","_$J_","_PTR_","_INST_")"
503
"RTN","ORCD",154,0)
504
. I ARRAY'="ORDIALOG" M @ARRAY@(PTR,INST)=@ORTXT S @ARRAY@(PTR,INST)=$NA(@ARRAY@(PTR,INST))
505
"RTN","ORCD",155,0)
506
. K @ORTXT
507
"RTN","ORCD",156,0)
508
Q
509
"RTN","ORCD",157,0)
510
;
511
"RTN","ORCD",158,0)
512
RESTXT ; -- resolve objects in text [from GETORDER+8]
513
"RTN","ORCD",159,0)
514
I $$BROKER^XWBLIB!($G(ORTYPE)="Z") M ^TMP("ORX",$J)=@ROOT@(ORI,2) S ORTXT=$NA(^TMP("ORX",$J)) Q ;return text unresolved
515
"RTN","ORCD",160,0)
516
N ARRAY,PTR,INST
517
"RTN","ORCD",161,0)
518
D BLRPLT^TIUSRVD(.ORTXT,,+$G(ORVP),,$NA(@ROOT@(ORI,2)))
519
"RTN","ORCD",162,0)
520
Q
521
"RTN","ORCD",163,0)
522
;
523
"RTN","ORCD",164,0)
524
DUP(PROMPT,CURRENT) ; -- Compare CURRENT instance of PROMPT for duplicates
525
"RTN","ORCD",165,0)
526
N X,Y,I
527
"RTN","ORCD",166,0)
528
S X=ORDIALOG(PROMPT,CURRENT),Y=0
529
"RTN","ORCD",167,0)
530
S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 I I'=CURRENT,$P(ORDIALOG(PROMPT,I),U)=$P(ORDIALOG(PROMPT,CURRENT),U) S Y=1 Q
531
"RTN","ORCD",168,0)
532
Q Y
533
"RTN","ORCD",169,0)
534
;
535
"RTN","ORCD",170,0)
536
LIST ; -- Show contents of ORDIALOG(PROMPT,"LIST")
537
"RTN","ORCD",171,0)
538
N NUM S NUM=$G(ORDIALOG(PROMPT,"LIST")) Q:'NUM
539
"RTN","ORCD",172,0)
540
W !,"Choose from"_$S('$P(NUM,U,2):" (or enter another):",1:":")
541
"RTN","ORCD",173,0)
542
LIST1 N I,DONE,CNT S (I,CNT,DONE)=0
543
"RTN","ORCD",174,0)
544
F S I=$O(ORDIALOG(PROMPT,"LIST",I)) Q:I'>0 D Q:DONE
545
"RTN","ORCD",175,0)
546
. S CNT=CNT+1 I CNT>(IOSL-2) S CNT=0 I '$$MORE S DONE=1 Q
547
"RTN","ORCD",176,0)
548
. W !,$J(I,6)_" "_$P(ORDIALOG(PROMPT,"LIST",I),U,2)
549
"RTN","ORCD",177,0)
550
Q
551
"RTN","ORCD",178,0)
552
;
553
"RTN","ORCD",179,0)
554
SETLIST ; -- Show allowable set of codes
555
"RTN","ORCD",180,0)
556
W !,"Choose from:"
557
"RTN","ORCD",181,0)
558
SETLST1 N I,X F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I $L(X) D
559
"RTN","ORCD",182,0)
560
. W !,?5,$P(X,":"),?15,$P(X,":",2)
561
"RTN","ORCD",183,0)
562
Q
563
"RTN","ORCD",184,0)
564
;
565
"RTN","ORCD",185,0)
566
MORE() ; -- show more?
567
"RTN","ORCD",186,0)
568
N X,Y,DIR
569
"RTN","ORCD",187,0)
570
S DIR(0)="EA",DIR("A")=" press <return> to continue or ^ to exit ..."
571
"RTN","ORCD",188,0)
572
D ^DIR
573
"RTN","ORCD",189,0)
574
Q +Y
575
"RTN","ORCD",190,0)
576
;
577
"RTN","ORCD",191,0)
578
FIRST(P,I) ; -- Returns 1 or 0, if current instance I is first of multiple
579
"RTN","ORCD",192,0)
580
Q '$O(ORDIALOG(P,I),-1)
581
"RTN","ORCD",193,0)
582
;
583
"RTN","ORCD",194,0)
584
RECALL(P,I) ; -- Returns first value for prompt P, instance I
585
"RTN","ORCD",195,0)
586
N Y S:'$G(I) I=1 S Y=$G(^TMP("ORECALL",$J,+ORDIALOG,P,I))
587
"RTN","ORCD",196,0)
588
Q Y
589
"RTN","ORCSAVE")
590
0^3^B77428216
591
"RTN","ORCSAVE",1,0)
592
ORCSAVE ;SLC/MKB/JDL-Save ; 02 Jul 2010 8:37 AM
593
"RTN","ORCSAVE",2,0)
594
;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,56,70,73,92,94,116,141,163,187,190,195,MSC.1502**;Dec 17, 1997
595
"RTN","ORCSAVE",3,0)
596
;MSC/MGH Changes put in for the transfer to IP and transfer to OP order statuses
597
"RTN","ORCSAVE",4,0)
598
NEW(ORDIALOG,ORDG,ORPKG,ORCAT,OREVENT,ORDUZ,ORLOG) ; -- New order
599
"RTN","ORCSAVE",5,0)
600
; Returns ORIFN = [new] order number, if created/saved
601
"RTN","ORCSAVE",6,0)
602
D EN
603
"RTN","ORCSAVE",7,0)
604
Q
605
"RTN","ORCSAVE",8,0)
606
;
607
"RTN","ORCSAVE",9,0)
608
XX ; -- save new/unreleased edited order into Orders file
609
"RTN","ORCSAVE",10,0)
610
; Requires: ORDIALOG() = array of dialog values
611
"RTN","ORCSAVE",11,0)
612
; ORIFN = IFN of original order that was edited
613
"RTN","ORCSAVE",12,0)
614
;
615
"RTN","ORCSAVE",13,0)
616
N OLDIFN S ORIFN=+ORIFN,OLDIFN=0
617
"RTN","ORCSAVE",14,0)
618
I $S($P(^OR(100,ORIFN,3),U,3)=11:0,$P(^(3),U,3)'=10:1,$P(^(8,1,0),U,4)=2:0,1:1) S OLDIFN=ORIFN K ORIFN ; create new order if released or delayed&signed
619
"RTN","ORCSAVE",15,0)
620
D EN Q:'ORIFN S:'$G(ORDA) ORDA=1
621
"RTN","ORCSAVE",16,0)
622
I $G(OLDIFN) D ;save links between orders
623
"RTN","ORCSAVE",17,0)
624
. S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=1
625
"RTN","ORCSAVE",18,0)
626
. S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
627
"RTN","ORCSAVE",19,0)
628
I $D(^OR(100,+OLDIFN,0)) D
629
"RTN","ORCSAVE",20,0)
630
. Q:'$G(OREVTDF)
631
"RTN","ORCSAVE",21,0)
632
. N OLDEVT,OLDSTS,LSTACT,PATID,NOW,WHEN
633
"RTN","ORCSAVE",22,0)
634
. S (OLDEVT,OLDSTS,LSTACT)=0
635
"RTN","ORCSAVE",23,0)
636
. S NOW=$$NOW^XLFDT
637
"RTN","ORCSAVE",24,0)
638
. S OLDEVT=$P(^(0),U,17),OLDSTS=$P(^(3),U,3)
639
"RTN","ORCSAVE",25,0)
640
. ; Active status = 6 from #100.01
641
"RTN","ORCSAVE",26,0)
642
. I (OLDEVT>0),OLDSTS=6 D
643
"RTN","ORCSAVE",27,0)
644
. . S $P(^OR(100,+ORIFN,0),U,17)=OLDEVT
645
"RTN","ORCSAVE",28,0)
646
. . S $P(^OR(100,+ORIFN,3),U,3)=11
647
"RTN","ORCSAVE",29,0)
648
. . S LSTACT=$P($G(^OR(100,+ORIFN,3)),U,7)
649
"RTN","ORCSAVE",30,0)
650
. . I $D(^OR(100,+ORIFN,8,LSTACT,0)) D
651
"RTN","ORCSAVE",31,0)
652
. . . S $P(^OR(100,+ORIFN,8,LSTACT,0),U,15)=11
653
"RTN","ORCSAVE",32,0)
654
. . . S PATID=$P(^OR(100,+ORIFN,0),U,2)
655
"RTN","ORCSAVE",33,0)
656
. . . S WHEN=$P(^OR(100,+ORIFN,8,LSTACT,0),U)
657
"RTN","ORCSAVE",34,0)
658
. . . S ^OR(100,"AC",PATID,9999999-WHEN,+ORIFN,LSTACT)=""
659
"RTN","ORCSAVE",35,0)
660
Q
661
"RTN","ORCSAVE",36,0)
662
;
663
"RTN","ORCSAVE",37,0)
664
RN ; -- save new/unreleased renewal order into Orders file
665
"RTN","ORCSAVE",38,0)
666
; Requires: ORDIALOG() = array of new dialog values
667
"RTN","ORCSAVE",39,0)
668
; ORIFN = IFN of original order that was renewed
669
"RTN","ORCSAVE",40,0)
670
;
671
"RTN","ORCSAVE",41,0)
672
N OLDIFN S OLDIFN=+ORIFN K ORIFN
673
"RTN","ORCSAVE",42,0)
674
D EN Q:'ORIFN S:'$G(ORDA) ORDA=1
675
"RTN","ORCSAVE",43,0)
676
S $P(^OR(100,ORIFN,3),U,5)=OLDIFN,$P(^(3),U,11)=2
677
"RTN","ORCSAVE",44,0)
678
S $P(^OR(100,OLDIFN,3),U,6)=ORIFN S:$D(^(5)) ^OR(100,ORIFN,5)=^OR(100,OLDIFN,5)
679
"RTN","ORCSAVE",45,0)
680
Q
681
"RTN","ORCSAVE",46,0)
682
;
683
"RTN","ORCSAVE",47,0)
684
EN ; -- save new/unreleased order in ORDIALOG() into Orders file
685
"RTN","ORCSAVE",48,0)
686
; Requires: ORVP, ORNP [and ORL, ORTS, ORAPPT if available]
687
"RTN","ORCSAVE",49,0)
688
; If defined: ORCAT,ORPKG,ORDG,ORLOG,ORDUZ,OREVENT,ORDCNTRL,ORSRC
689
"RTN","ORCSAVE",50,0)
690
; (else use values from ORDIALOG and current state)
691
"RTN","ORCSAVE",51,0)
692
;
693
"RTN","ORCSAVE",52,0)
694
N PKG,NOW,NODE,CNT,CDL,I,X,STS,SIGNREQD,LOC,TRSPEC,NATR,CATG,DG,LOG,USR,TYPE
695
"RTN","ORCSAVE",53,0)
696
Q:'$G(ORVP) Q:'$G(ORDIALOG) Q:'$D(^ORD(101.41,+ORDIALOG,0))
697
"RTN","ORCSAVE",54,0)
698
S NOW=$$NOW^XLFDT,SIGNREQD=+$P(^ORD(101.41,+ORDIALOG,0),U,6)
699
"RTN","ORCSAVE",55,0)
700
S CATG=$S($L($G(ORCAT)):ORCAT,1:$S($$INPT^ORCD:"I",1:"O"))
701
"RTN","ORCSAVE",56,0)
702
S PKG=$S($G(ORPKG):ORPKG,1:$P(^ORD(101.41,+ORDIALOG,0),U,7))
703
"RTN","ORCSAVE",57,0)
704
I $G(ORIFN),$D(^OR(100,ORIFN,0)) S STS=$P(^(3),U,3) G EN2 ; unrel order
705
"RTN","ORCSAVE",58,0)
706
S DG=$S($G(ORDG):+ORDG,1:$P(^ORD(101.41,+ORDIALOG,0),U,5))
707
"RTN","ORCSAVE",59,0)
708
I $G(OREVENT),$$GET1^DIQ(9.4,+PKG_",",1)'="PSO",'$G(DGPMT) S LOC="",TRSPEC="" ;195
709
"RTN","ORCSAVE",60,0)
710
E S LOC=$G(ORL),TRSPEC=$G(ORTS)
711
"RTN","ORCSAVE",61,0)
712
S TYPE=$S("^B^C^X^P^0^"[(U_$G(ORSRC)_U):ORSRC,$G(ORDCNTRL)="SN":"P",1:0)
713
"RTN","ORCSAVE",62,0)
714
S LOG=$S($G(ORLOG):ORLOG,1:+$E(NOW,1,12)),USR=$S($G(ORDUZ):ORDUZ,1:DUZ)
715
"RTN","ORCSAVE",63,0)
716
S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
717
"RTN","ORCSAVE",64,0)
718
S STS=$S($G(OREVENT):10,1:11),ORIFN=$$NEXTIFN Q:'ORIFN
719
"RTN","ORCSAVE",65,0)
720
EN1 S ^OR(100,ORIFN,0)=ORIFN_U_ORVP_U_U_$G(ORNP)_U_+ORDIALOG_";ORD(101.41,^"_USR_U_LOG_U_U_U_LOC_U_DG_U_CATG_U_TRSPEC_U_PKG_U_U_SIGNREQD_U_$G(OREVENT)_U_$G(ORAPPT)
721
"RTN","ORCSAVE",66,0)
722
S ^OR(100,ORIFN,3)=LOG_"^90^"_STS_U_$S($G(ORIT):ORIT_";ORD(101.41,",1:"")_U_$G(ORDIALOG("PREV"))_"^^1^^^^"_TYPE
723
"RTN","ORCSAVE",67,0)
724
S ^OR(100,ORIFN,8,0)="^100.008DA^1^1",^OR(100,ORIFN,8,1,0)=LOG_"^NW^"_$G(ORNP)_U_$S(SIGNREQD:2,1:3)_"^^^^^^^^"_NATR_U_USR_"^1^"_STS,^OR(100,ORIFN,8,"C","NW",1)=""
725
"RTN","ORCSAVE",68,0)
726
S ^OR(100,"AF",LOG,ORIFN,1)=""
727
"RTN","ORCSAVE",69,0)
728
S ^OR(100,"ACT",ORVP,9999999-LOG,+DG,ORIFN,1)=""
729
"RTN","ORCSAVE",70,0)
730
S:STS'=10 ^OR(100,"AC",ORVP,9999999-LOG,ORIFN,1)=""
731
"RTN","ORCSAVE",71,0)
732
S:SIGNREQD ^OR(100,"AS",ORVP,9999999-LOG,ORIFN,1)=""
733
"RTN","ORCSAVE",72,0)
734
S:$G(OREVENT) ^OR(100,"AEVNT",ORVP,OREVENT,ORIFN)=""
735
"RTN","ORCSAVE",73,0)
736
EN2 S ORIFN=+ORIFN D RESPONSE ; save responses
737
"RTN","ORCSAVE",74,0)
738
I $P(^OR(100,ORIFN,0),"^",5) D ;Copy orders PKI fix
739
"RTN","ORCSAVE",75,0)
740
. N OI
741
"RTN","ORCSAVE",76,0)
742
. S OI=+$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=+$G(^OR(100,ORIFN,4.5,OI,1)) Q:'OI
743
"RTN","ORCSAVE",77,0)
744
. I PKG'=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",0)) Q
745
"RTN","ORCSAVE",78,0)
746
. D PKI^ORWDPS1(.ORY,OI,CATG,+ORVP,$$GET^XPAR("ALL^USR.`"_DUZ,"ORWOR PKI USE",1,"Q"))
747
"RTN","ORCSAVE",79,0)
748
. I $E($G(ORY))=2 S ORDEA=ORY
749
"RTN","ORCSAVE",80,0)
750
K ^OR(100,ORIFN,8,1,.1) D ORDTEXT^ORCSAVE1(ORIFN_";1") ; order text
751
"RTN","ORCSAVE",81,0)
752
S NODE=$G(^OR(100,ORIFN,0)) D S ^OR(100,ORIFN,0)=NODE
753
"RTN","ORCSAVE",82,0)
754
. S $P(NODE,U,4)=$G(ORNP) ; COST?
755
"RTN","ORCSAVE",83,0)
756
. S I=$O(^OR(100,ORIFN,4.5,"ID","LOCATION",0))
757
"RTN","ORCSAVE",84,0)
758
. I I,$P(NODE,U,10) S X=+$G(^OR(100,ORIFN,4.5,+I,1)) S:X $P(NODE,U,10)=X_";SC(" ;reset Loc if prev value
759
"RTN","ORCSAVE",85,0)
760
. S I=$O(^OR(100,ORIFN,4.5,"ID","CLASS",0))
761
"RTN","ORCSAVE",86,0)
762
. I I S X=$G(^OR(100,ORIFN,4.5,+I,1)) S:"^I^O^"[(U_X_U) $P(NODE,U,12)=X
763
"RTN","ORCSAVE",87,0)
764
S $P(^OR(100,ORIFN,3),U)=NOW
765
"RTN","ORCSAVE",88,0)
766
K ^OR(100,ORIFN,9) I $G(ORCHECK) D ; save order checks
767
"RTN","ORCSAVE",89,0)
768
. S (CNT,CDL)=0 F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL'>0 S I=0 D
769
"RTN","ORCSAVE",90,0)
770
. . F S I=$O(ORCHECK("NEW",CDL,I)) Q:I'>0 S X=ORCHECK("NEW",CDL,I) D
771
"RTN","ORCSAVE",91,0)
772
. . . S CNT=CNT+1,^OR(100,ORIFN,9,"B",+X,CNT)=""
773
"RTN","ORCSAVE",92,0)
774
. . . S ^OR(100,ORIFN,9,CNT,0)=$P(X,U,1,2),^(1)=$E($P(X,U,3),1,245)
775
"RTN","ORCSAVE",93,0)
776
. S:CNT ^OR(100,ORIFN,9,0)="^100.09PA^"_CNT_U_CNT
777
"RTN","ORCSAVE",94,0)
778
;MSC/MGH Changes added here for the transfer to IP and OP functionality on home meds
779
"RTN","ORCSAVE",95,0)
780
I $G(TYPE)="X",$G(^TMP("MSCPSHMX",$J)) S MSCIEN=+^($J) K ^($J) D
781
"RTN","ORCSAVE",96,0)
782
.S MSCSTAT="TRANSFER TO "_$P($G(^OR(100,ORIFN,0)),U,12)_"P",MSCSTAT=$O(^ORD(100.01,"B",MSCSTAT,0)) Q:'MSCSTAT
783
"RTN","ORCSAVE",97,0)
784
.D STATUS^ORCSAVE2(MSCIEN,MSCSTAT)
785
"RTN","ORCSAVE",98,0)
786
;End of mods
787
"RTN","ORCSAVE",99,0)
788
K ORDEA
789
"RTN","ORCSAVE",100,0)
790
ENQ Q
791
"RTN","ORCSAVE",101,0)
792
;
793
"RTN","ORCSAVE",102,0)
794
NEXTIFN() ; -- Returns next available ORIFN
795
"RTN","ORCSAVE",103,0)
796
N I,HDR,LAST,TOTAL,DA
797
"RTN","ORCSAVE",104,0)
798
F I=1:1:10 L +^OR(100,0):1 Q:$T H 2
799
"RTN","ORCSAVE",105,0)
800
I '$T Q "^"
801
"RTN","ORCSAVE",106,0)
802
S HDR=$G(^OR(100,0)),TOTAL=+$P(HDR,U,4),LAST=$O(^OR(100,"?"),-1)
803
"RTN","ORCSAVE",107,0)
804
S I=LAST\1 F I=(I+1):1 Q:'$D(^OR(100,I,0))
805
"RTN","ORCSAVE",108,0)
806
S DA=I,^OR(100,DA,0)=DA,$P(HDR,U,3,4)=DA_U_(TOTAL+1)
807
"RTN","ORCSAVE",109,0)
808
S ^OR(100,0)=HDR L -^OR(100,0)
809
"RTN","ORCSAVE",110,0)
810
Q DA
811
"RTN","ORCSAVE",111,0)
812
;
813
"RTN","ORCSAVE",112,0)
814
RESPONSE ; -- Save responses in ORDIALOG() into ^OR(100,ORIFN,4.5)
815
"RTN","ORCSAVE",113,0)
816
N PROMPT,CNT,ITM,TYPE,INST,VALUE,I,START,PAT,X
817
"RTN","ORCSAVE",114,0)
818
S PAT=$P(^OR(100,ORIFN,0),U,2),START=$P(^(0),U,8) K ^(4.5)
819
"RTN","ORCSAVE",115,0)
820
S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D
821
"RTN","ORCSAVE",116,0)
822
. S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
823
"RTN","ORCSAVE",117,0)
824
. S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
825
"RTN","ORCSAVE",118,0)
826
. S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D
827
"RTN","ORCSAVE",119,0)
828
. . S VALUE=$G(ORDIALOG(PROMPT,INST)) Q:VALUE="" S CNT=CNT+1
829
"RTN","ORCSAVE",120,0)
830
. . S ^OR(100,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
831
"RTN","ORCSAVE",121,0)
832
. . S:$L($P(ITM,U,2)) ^OR(100,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""
833
"RTN","ORCSAVE",122,0)
834
. . S:TYPE'="W" ^OR(100,ORIFN,4.5,CNT,1)=$S("FN"'[TYPE:"",$E($P($G(^DIC(9.4,+$G(PKG),0)),U,2),1,2)'="PS":"",VALUE?1"."1N.E:0,1:"")_VALUE
835
"RTN","ORCSAVE",123,0)
836
. . M:TYPE="W" ^OR(100,ORIFN,4.5,CNT,2)=@VALUE ; array root
837
"RTN","ORCSAVE",124,0)
838
S ^OR(100,ORIFN,4.5,0)="^100.045A^"_CNT_U_CNT
839
"RTN","ORCSAVE",125,0)
840
R1 ; [Reset] Orderables
841
"RTN","ORCSAVE",126,0)
842
I $D(^OR(100,ORIFN,.1)) S I=0 F S I=$O(^OR(100,ORIFN,.1,I)) Q:I'>0 S X=$G(^(I,0)) I X,PAT,START K ^OR(100,"AOI",X,PAT,9999999-START,ORIFN) ; kill xref
843
"RTN","ORCSAVE",127,0)
844
K ^OR(100,ORIFN,.1) I $D(^OR(100,ORIFN,4.5,"ID","ORDERABLE")) D
845
"RTN","ORCSAVE",128,0)
846
. S (I,CNT)=0
847
"RTN","ORCSAVE",129,0)
848
. F S I=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",I)) Q:I'>0 D
849
"RTN","ORCSAVE",130,0)
850
. . S X=$G(^OR(100,ORIFN,4.5,I,1)) Q:'X
851
"RTN","ORCSAVE",131,0)
852
. . S CNT=CNT+1,^OR(100,ORIFN,.1,CNT,0)=X,^OR(100,ORIFN,.1,"B",X,CNT)=""
853
"RTN","ORCSAVE",132,0)
854
. . I PAT,START S ^OR(100,"AOI",X,PAT,9999999-START,ORIFN)=""
855
"RTN","ORCSAVE",133,0)
856
. S ^OR(100,ORIFN,.1,0)="^100.001PA^"_CNT_U_CNT
857
"RTN","ORCSAVE",134,0)
858
Q
859
"RTN","ORCSAVE",135,0)
860
;
861
"RTN","ORCSAVE",136,0)
862
RESUME(IFN) ; -- add Response nodes for RESUME tray service
863
"RTN","ORCSAVE",137,0)
864
; S ^OR(100,+IFN,4.5,<next>,0)=DT_"^^^RESUME",^(1)=1
865
"RTN","ORCSAVE",138,0)
866
;
867
"RTN","ORCSAVE",139,0)
868
N X,Y,DA,DIC
869
"RTN","ORCSAVE",140,0)
870
S DIC="^OR(100,"_+IFN_",4.5,",DIC(0)="LX",DA(1)=+IFN,X=DT
871
"RTN","ORCSAVE",141,0)
872
S DIC("DR")=".04///RESUME",DIC("P")=$P(^DD(100,4.5,0),U,2)
873
"RTN","ORCSAVE",142,0)
874
D ^DIC S:Y ^OR(100,+IFN,4.5,+Y,1)=1
875
"RTN","ORCSAVE",143,0)
876
Q
877
"RTN","ORCSAVE",144,0)
878
;
879
"RTN","ORCSAVE",145,0)
880
PROVIDER(ORDER,PROV) ; -- Change PROVider assigned to ORDER
881
"RTN","ORCSAVE",146,0)
882
Q:'$G(ORDER) Q:'$G(PROV)
883
"RTN","ORCSAVE",147,0)
884
N ORACT S ORACT=+$P(ORDER,";",2) S:'ORACT ORACT=1
885
"RTN","ORCSAVE",148,0)
886
S $P(^OR(100,+ORDER,8,ORACT,0),U,3)=PROV
887
"RTN","ORCSAVE",149,0)
888
S:ORACT=1 $P(^OR(100,+ORDER,0),U,4)=PROV
889
"RTN","ORCSAVE",150,0)
890
Q
891
"RTN","ORCSAVE",151,0)
892
;
893
"RTN","ORCSAVE",152,0)
894
ACTION(CODE,DA,PROV,REASON,WHEN,WHO) ; -- save new action
895
"RTN","ORCSAVE",153,0)
896
N NEXT,TOTAL,HDR,LAST,X,PAT,DGRP,SIG,NATR,TXT S DA=+DA
897
"RTN","ORCSAVE",154,0)
898
Q:'$D(^OR(100,DA,0)) 0 Q:$G(CODE)'?2U 0
899
"RTN","ORCSAVE",155,0)
900
S:'$G(WHEN) WHEN=+$E($$NOW^XLFDT,1,12) S:'$G(WHO) WHO=DUZ
901
"RTN","ORCSAVE",156,0)
902
S NATR=+$O(^ORD(100.02,"C","E",0)) ;assume Elec Entered until changed
903
"RTN","ORCSAVE",157,0)
904
S PAT=$P(^OR(100,DA,0),U,2),DGRP=$P(^(0),U,11),SIG=$P(^(0),U,16),X=+$P($G(^(3)),U,7),HDR=$G(^(8,0))
905
"RTN","ORCSAVE",158,0)
906
S:X'>0 X=1 S TXT=$P($G(^OR(100,DA,8,X,0)),U,14) ;current actn's txt ptr
907
"RTN","ORCSAVE",159,0)
908
S:HDR="" HDR="^100.008DA^^" S TOTAL=+$P(HDR,U,4)
909
"RTN","ORCSAVE",160,0)
910
S LAST=$O(^OR(100,DA,8,"C",CODE,"?"),-1) I LAST D
911
"RTN","ORCSAVE",161,0)
912
. S X=$G(^OR(100,DA,8,LAST,0)) Q:$P(X,U,15)'=11 Q:$P(X,U,4)'=2
913
"RTN","ORCSAVE",162,0)
914
. S NEXT=LAST I PAT,$P(X,U) D ; kill old xref entries
915
"RTN","ORCSAVE",163,0)
916
. . K:DGRP ^OR(100,"ACT",PAT,(9999999-$P(X,U)),DGRP,DA,NEXT)
917
"RTN","ORCSAVE",164,0)
918
. . K ^OR(100,"AC",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AS",PAT,(9999999-$P(X,U)),DA,NEXT),^OR(100,"AF",$P(X,U),DA,NEXT)
919
"RTN","ORCSAVE",165,0)
920
S:'$G(NEXT) NEXT=$O(^OR(100,DA,8,"?"),-1)+1,TOTAL=TOTAL+1
921
"RTN","ORCSAVE",166,0)
922
S ^OR(100,DA,8,NEXT,0)=WHEN_U_CODE_U_$G(PROV)_U_$S(SIG:2,1:3)_"^^^^^^^^"_NATR_U_WHO_U_TXT_"^11",^OR(100,DA,8,"C",CODE,NEXT)=""
923
"RTN","ORCSAVE",167,0)
924
S ^OR(100,"AF",WHEN,DA,NEXT)=""
925
"RTN","ORCSAVE",168,0)
926
I PAT,DGRP S ^OR(100,"ACT",PAT,9999999-WHEN,DGRP,DA,NEXT)=""
927
"RTN","ORCSAVE",169,0)
928
I PAT S ^OR(100,"AC",PAT,9999999-WHEN,DA,NEXT)=""
929
"RTN","ORCSAVE",170,0)
930
I SIG S ^OR(100,"AS",PAT,9999999-WHEN,DA,NEXT)=""
931
"RTN","ORCSAVE",171,0)
932
S:$L($G(REASON)) ^OR(100,DA,8,NEXT,1)=REASON
933
"RTN","ORCSAVE",172,0)
934
S $P(HDR,U,3,4)=NEXT_U_TOTAL,^OR(100,DA,8,0)=HDR
935
"RTN","ORCSAVE",173,0)
936
Q NEXT
937
"RTN","ORCSAVE",174,0)
938
;
939
"RTN","ORCSAVE",175,0)
940
SET(DLG) ; -- Create new parent for order set ORDIALOG
941
"RTN","ORCSAVE",176,0)
942
; Returns ORPIFN = ifn of new parent order for set
943
"RTN","ORCSAVE",177,0)
944
;
945
"RTN","ORCSAVE",178,0)
946
Q:'$G(ORVP) Q:'$G(DLG) N OR0,PKG,NOW,CATG,STS,ORLOC,TRSPEC,X
947
"RTN","ORCSAVE",179,0)
948
S OR0=$G(^ORD(101.41,DLG,0)) Q:OR0="" S ORPIFN=$$NEXTIFN Q:'ORPIFN
949
"RTN","ORCSAVE",180,0)
950
S PKG=$O(^DIC(9.4,"C","OR",0)),CATG=$S($$INPT^ORCD:"I",1:"O"),STS=$S($G(OREVENT):10,1:11),NOW=$S($G(ORSLOG):ORSLOG,1:+$E($$NOW^XLFDT,1,12))
951
"RTN","ORCSAVE",181,0)
952
I $G(OREVENT) S ORLOC="",TRSPEC=""
953
"RTN","ORCSAVE",182,0)
954
S ^OR(100,ORPIFN,0)=ORPIFN_U_ORVP_U_U_$G(ORNP)_U_DLG_";ORD(101.41,^"_DUZ_U_NOW_U_U_U_ORLOC_U_U_CATG_U_TRSPEC_U_PKG_"^^^"_$G(OREVENT),^(3)=NOW_"^90^"_STS_U_$S($G(ORIT):ORIT_"ORD(101.41,",1:"")_"^^^1^^^^0^^"_+$P(OR0,U,6)
955
"RTN","ORCSAVE",183,0)
956
S ^OR(100,ORPIFN,8,0)="^100.008DA^1^1",^(1,0)=NOW_"^NW^"_$G(ORNP)_"^^^^^^^^^^"_DUZ_"^^"_STS,^OR(100,ORPIFN,8,"C","NW",1)="",^OR(100,"AF",NOW,ORPIFN,1)=""
957
"RTN","ORCSAVE",184,0)
958
S ^OR(100,"ACT",ORVP,9999999-NOW,ORPIFN,1)=""
959
"RTN","ORCSAVE",185,0)
960
S:STS=11 ^OR(100,"AC",ORVP,9999999-NOW,ORPIFN,1)=""
961
"RTN","ORCSAVE",186,0)
962
; AEVNT ??
963
"RTN","ORCSAVE",187,0)
964
S ^OR(100,ORPIFN,1,0)="^100.011^1^1",^(1,0)=$P(OR0,U,2) ; Order text
965
"RTN","ORCSAVE",188,0)
966
Q
967
"RTN","ORWPS")
968
0^2^B95265151
969
"RTN","ORWPS",1,0)
970
ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab -show meds;30 JUNE 2009 ; 01 Jul 2010 1:41 PM
971
"RTN","ORWPS",2,0)
972
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,MSC,1502**;Dec 17, 1997;Build 7
973
"RTN","ORWPS",3,0)
974
COVER(LST,DFN) ; retrieve meds for cover sheet
975
"RTN","ORWPS",4,0)
976
K ^TMP("PS",$J)
977
"RTN","ORWPS",5,0)
978
D OCL^PSOORRL(DFN,"","") ;DBIA #2400
979
"RTN","ORWPS",6,0)
980
N ILST,ITMP,X S ILST=0
981
"RTN","ORWPS",7,0)
982
S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
983
"RTN","ORWPS",8,0)
984
. S X=^TMP("PS",$J,ITMP,0)
985
"RTN","ORWPS",9,0)
986
. I '$L($P(X,U,2)) S X="??" ; show something if drug empty
987
"RTN","ORWPS",10,0)
988
. I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
989
"RTN","ORWPS",11,0)
990
. E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)
991
"RTN","ORWPS",12,0)
992
. I $P(X,U)["N" N MSC S MSC=$P($G(^OR(100,+$P(X,U,8),3)),U,3) I (MSC>21399)!(MSC=3) S $P(LST(ILST),U,4)=$P($G(^ORD(100.01,+MSC,0)),U)
993
"RTN","ORWPS",13,0)
994
K ^TMP("PS",$J)
995
"RTN","ORWPS",14,0)
996
Q
997
"RTN","ORWPS",15,0)
998
DT(X) ; -- Returns FM date for X
999
"RTN","ORWPS",16,0)
1000
N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
1001
"RTN","ORWPS",17,0)
1002
Q Y
1003
"RTN","ORWPS",18,0)
1004
;
1005
"RTN","ORWPS",19,0)
1006
ACTIVE(LST,DFN) ; retrieve active inpatient & outpatient meds
1007
"RTN","ORWPS",20,0)
1008
K ^TMP("PS",$J)
1009
"RTN","ORWPS",21,0)
1010
K ^TMP("ORACT",$J)
1011
"RTN","ORWPS",22,0)
1012
N BEG,END,CTX
1013
"RTN","ORWPS",23,0)
1014
S (BEG,END,CTX)=""
1015
"RTN","ORWPS",24,0)
1016
S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
1017
"RTN","ORWPS",25,0)
1018
I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
1019
"RTN","ORWPS",26,0)
1020
S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
1021
"RTN","ORWPS",27,0)
1022
S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2))
1023
"RTN","ORWPS",28,0)
1024
D OCL^PSOORRL(DFN,BEG,END) ;DBIA #2400
1025
"RTN","ORWPS",29,0)
1026
N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0
1027
"RTN","ORWPS",30,0)
1028
S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP),-1) Q:'ITMP D
1029
"RTN","ORWPS",31,0)
1030
. K INSTRUCT,COMMENTS,REASON,MEDREC,MSCOA ;msc/rec - Added MEDREC to this line. 10/30/08
1031
"RTN","ORWPS",32,0)
1032
. K ^TMP("ORACT",$J,"COMMENTS")
1033
"RTN","ORWPS",33,0)
1034
. S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
1035
"RTN","ORWPS",34,0)
1036
. S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0)
1037
"RTN","ORWPS",35,0)
1038
. ;
1039
"RTN","ORWPS",36,0)
1040
ORDER .I +$P(FIELDS,"^",8) D
1041
"RTN","ORWPS",37,0)
1042
..N N,IFN,OI,NODE S NODE=^TMP("PS",$J,ITMP,0),IFN=+$P(FIELDS,"^",8) D GFT S N=$P(NODE,"^",2)
1043
"RTN","ORWPS",38,0)
1044
..F J=0:0 S J=$O(^OR(100,IFN,4.5,J)) Q:'J I $P($G(^(J,0)),U,4)="ORDERABLE" S OI=+$G(^(1)) Q
1045
"RTN","ORWPS",39,0)
1046
..I $G(OI) F J=0:0 S J=$O(^ORD(101.43,OI,2,J)) Q:'J I $G(^(J,0))?1U.E S N=N_" [GEQ: "_$P(^(0),U)_"]" Q ;***GFT/MSC
1047
"RTN","ORWPS",40,0)
1048
..I $D(^OR(100,IFN,8,"C","XX")) S N="*"_N ;dan testing
1049
"RTN","ORWPS",41,0)
1050
..S $P(^TMP("PS",$J,ITMP,0),"^",2)=N
1051
"RTN","ORWPS",42,0)
1052
..N MSC S MSC=$P($G(^OR(100,IFN,3)),U,3) I (MSC>21399)!(MSC=3) S ($P(FIELDS,U,9),$P(^TMP("PS",$J,ITMP,0),U,9))=$P($G(^ORD(100.01,+MSC,0)),U)
1053
"RTN","ORWPS",43,0)
1054
. S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
1055
"RTN","ORWPS",44,0)
1056
. I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP"
1057
"RTN","ORWPS",45,0)
1058
. N LOC,LOCEX S (LOC,LOCEX)=""
1059
"RTN","ORWPS",46,0)
1060
. I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0))
1061
"RTN","ORWPS",47,0)
1062
. S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW
1063
"RTN","ORWPS",48,0)
1064
. ;
1065
"RTN","ORWPS",49,0)
1066
. I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med
1067
"RTN","ORWPS",50,0)
1068
. I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV"
1069
"RTN","ORWPS",51,0)
1070
. I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV"
1071
"RTN","ORWPS",52,0)
1072
. I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP)
1073
"RTN","ORWPS",53,0)
1074
. I TYPE="OP" D OPINST(.INSTRUCT,ITMP)
1075
"RTN","ORWPS",54,0)
1076
. I TYPE="IV" D IVINST(.INSTRUCT,ITMP)
1077
"RTN","ORWPS",55,0)
1078
. I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP),NVMEDREC(.MEDREC,ITMP),NVOA(ITMP) ; msc/rec - Add NVMEDREC call to this line 10/30/08
1079
"RTN","ORWPS",56,0)
1080
. I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO")
1081
"RTN","ORWPS",57,0)
1082
. M COMMENTS=@COMMENTS
1083
"RTN","ORWPS",58,0)
1084
. I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1)
1085
"RTN","ORWPS",59,0)
1086
. S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT)
1087
"RTN","ORWPS",60,0)
1088
. I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS
1089
"RTN","ORWPS",61,0)
1090
. E S LST($$NXT)="~"_TYPE_U_FIELDS
1091
"RTN","ORWPS",62,0)
1092
. ;msc/rec 1/21/09 - Add order action for home meds to return array
1093
"RTN","ORWPS",63,0)
1094
. I $G(MSCOA)]"" S $P(LST(ILST),U,30)=MSCOA
1095
"RTN","ORWPS",64,0)
1096
. K MSCOA
1097
"RTN","ORWPS",65,0)
1098
. S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J)
1099
"RTN","ORWPS",66,0)
1100
. S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J)
1101
"RTN","ORWPS",67,0)
1102
. S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J)
1103
"RTN","ORWPS",68,0)
1104
. ;msc/rec - Add new Med Rec fields to display on MEDS tab 10/30/08
1105
"RTN","ORWPS",69,0)
1106
. S J=0 F S J=$O(MEDREC(J)) Q:'J S LST($$NXT)="t"_MEDREC(J)
1107
"RTN","ORWPS",70,0)
1108
K ^TMP("PS",$J)
1109
"RTN","ORWPS",71,0)
1110
K ^TMP("ORACT",$J)
1111
"RTN","ORWPS",72,0)
1112
Q
1113
"RTN","ORWPS",73,0)
1114
NXT() ; increment ILST
1115
"RTN","ORWPS",74,0)
1116
S ILST=ILST+1
1117
"RTN","ORWPS",75,0)
1118
Q ILST
1119
"RTN","ORWPS",76,0)
1120
;
1121
"RTN","ORWPS",77,0)
1122
;
1123
"RTN","ORWPS",78,0)
1124
GFT I $P(NODE,U,2)="" N GFT S GFT=$P($G(^PS(50.7,+$G(^PSRX(+NODE,"OR1")),0)),U) I GFT]"" S $P(NODE,U,2)=GFT ;look at PHARMACY ORDERABLE ITEM if no DRUG
1125
"RTN","ORWPS",79,0)
1126
Q
1127
"RTN","ORWPS",80,0)
1128
;
1129
"RTN","ORWPS",81,0)
1130
UDINST(Y,INDEX) ; assembles instructions for a unit dose order
1131
"RTN","ORWPS",82,0)
1132
N I,X,RST
1133
"RTN","ORWPS",83,0)
1134
S X=^TMP("PS",$J,INDEX,0)
1135
"RTN","ORWPS",84,0)
1136
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
1137
"RTN","ORWPS",85,0)
1138
S @RST@(1)=" "_$P(X,U,2),@RST=1
1139
"RTN","ORWPS",86,0)
1140
S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
1141
"RTN","ORWPS",87,0)
1142
I $L(X) S @RST=2,@RST@(2)=$S(X?1"."1N.E:0_X,1:X) ;JDS/MSC
1143
"RTN","ORWPS",88,0)
1144
E S @RST=1 D SETMULT(.RST,INDEX,"SIG")
1145
"RTN","ORWPS",89,0)
1146
S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2)
1147
"RTN","ORWPS",90,0)
1148
D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH")
1149
"RTN","ORWPS",91,0)
1150
F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
1151
"RTN","ORWPS",92,0)
1152
M Y=@RST K @RST
1153
"RTN","ORWPS",93,0)
1154
Q
1155
"RTN","ORWPS",94,0)
1156
OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription
1157
"RTN","ORWPS",95,0)
1158
N I,X,RST
1159
"RTN","ORWPS",96,0)
1160
S X=^TMP("PS",$J,INDEX,0)
1161
"RTN","ORWPS",97,0)
1162
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
1163
"RTN","ORWPS",98,0)
1164
S @RST@(1)=" "_$P(X,U,2),@RST=1
1165
"RTN","ORWPS",99,0)
1166
I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12)
1167
"RTN","ORWPS",100,0)
1168
I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days"
1169
"RTN","ORWPS",101,0)
1170
D SETMULT(RST,INDEX,"SIG")
1171
"RTN","ORWPS",102,0)
1172
I @RST=1 D
1173
"RTN","ORWPS",103,0)
1174
. D SETMULT(RST,INDEX,"SIO")
1175
"RTN","ORWPS",104,0)
1176
. D SETMULT(RST,INDEX,"MDR")
1177
"RTN","ORWPS",105,0)
1178
. D SETMULT(RST,INDEX,"SCH")
1179
"RTN","ORWPS",106,0)
1180
S @RST@(2)="\ Sig: "_$G(@RST@(2))
1181
"RTN","ORWPS",107,0)
1182
F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
1183
"RTN","ORWPS",108,0)
1184
M Y=@RST K @RST
1185
"RTN","ORWPS",109,0)
1186
Q
1187
"RTN","ORWPS",110,0)
1188
IVINST(Y,INDEX) ; assembles instructions for an IV order
1189
"RTN","ORWPS",111,0)
1190
N SOLN1,I,RST,IVDUR
1191
"RTN","ORWPS",112,0)
1192
S IVDUR=""
1193
"RTN","ORWPS",113,0)
1194
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
1195
"RTN","ORWPS",114,0)
1196
S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1
1197
"RTN","ORWPS",115,0)
1198
D SETMULT(RST,INDEX,"B")
1199
"RTN","ORWPS",116,0)
1200
; msc/rec 9/9/08 - modified next line so "in" is only added to IV's with additives and solutions
1201
"RTN","ORWPS",117,0)
1202
I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)),$G(SOLN1)>1 S @RST@(SOLN1)="in "_@RST@(SOLN1)
1203
"RTN","ORWPS",118,0)
1204
S SOLN1=@RST+1
1205
"RTN","ORWPS",119,0)
1206
D SETMULT(RST,INDEX,"SCH") S:$D(@RST@(SOLN1)) @RST@(SOLN1)=" "_@RST@(SOLN1)
1207
"RTN","ORWPS",120,0)
1208
F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ")
1209
"RTN","ORWPS",121,0)
1210
I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999)
1211
"RTN","ORWPS",122,0)
1212
S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3)
1213
"RTN","ORWPS",123,0)
1214
S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0))
1215
"RTN","ORWPS",124,0)
1216
I $L(IVDUR) D
1217
"RTN","ORWPS",125,0)
1218
. N DURU,DURV S DURU="",DURV=0
1219
"RTN","ORWPS",126,0)
1220
. S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
1221
"RTN","ORWPS",127,0)
1222
. I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
1223
"RTN","ORWPS",128,0)
1224
. I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
1225
"RTN","ORWPS",129,0)
1226
. I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
1227
"RTN","ORWPS",130,0)
1228
. I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
1229
"RTN","ORWPS",131,0)
1230
. S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
1231
"RTN","ORWPS",132,0)
1232
M Y=@RST K @RST
1233
"RTN","ORWPS",133,0)
1234
Q
1235
"RTN","ORWPS",134,0)
1236
NVINST(Y,INDEX) ; assembles instructions for a non-VA med
1237
"RTN","ORWPS",135,0)
1238
N I,X,RST
1239
"RTN","ORWPS",136,0)
1240
S X=^TMP("PS",$J,INDEX,0)
1241
"RTN","ORWPS",137,0)
1242
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
1243
"RTN","ORWPS",138,0)
1244
S @RST@(1)=" "_$P(X,U,2),@RST=1
1245
"RTN","ORWPS",139,0)
1246
D SETMULT(RST,INDEX,"SIG")
1247
"RTN","ORWPS",140,0)
1248
I @RST=1 D
1249
"RTN","ORWPS",141,0)
1250
. D SETMULT(RST,INDEX,"SIO")
1251
"RTN","ORWPS",142,0)
1252
. D SETMULT(RST,INDEX,"MDR")
1253
"RTN","ORWPS",143,0)
1254
. D SETMULT(RST,INDEX,"SCH")
1255
"RTN","ORWPS",144,0)
1256
S @RST@(2)="\ "_$G(@RST@(2))
1257
"RTN","ORWPS",145,0)
1258
F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
1259
"RTN","ORWPS",146,0)
1260
M Y=@RST K @RST
1261
"RTN","ORWPS",147,0)
1262
Q
1263
"RTN","ORWPS",148,0)
1264
NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med
1265
"RTN","ORWPS",149,0)
1266
N ORI,J,X,ORN,ORA
1267
"RTN","ORWPS",150,0)
1268
S ORI=0 K ORR
1269
"RTN","ORWPS",151,0)
1270
S X=^TMP("PS",$J,INDEX,0)
1271
"RTN","ORWPS",152,0)
1272
S ORN=+$P(X,U,8)
1273
"RTN","ORWPS",153,0)
1274
I $D(^OR(100,ORN,0)) D
1275
"RTN","ORWPS",154,0)
1276
.S NVSDT=$P(^OR(100,ORN,0),U,8)
1277
"RTN","ORWPS",155,0)
1278
.D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D
1279
"RTN","ORWPS",156,0)
1280
..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J)
1281
"RTN","ORWPS",157,0)
1282
Q
1283
"RTN","ORWPS",158,0)
1284
NVMEDREC(Y,INDEX) ; assemble Med Rec Fields
1285
"RTN","ORWPS",159,0)
1286
N I,II,III,X
1287
"RTN","ORWPS",160,0)
1288
S III=0
1289
"RTN","ORWPS",161,0)
1290
Q:'$D(^TMP("PS",$J,INDEX,"MREC"))
1291
"RTN","ORWPS",162,0)
1292
S I=0 F S I=$O(^TMP("PS",$J,INDEX,"MREC",I)) Q:'I D
1293
"RTN","ORWPS",163,0)
1294
. S X=^(I,0),III=III+1
1295
"RTN","ORWPS",164,0)
1296
. S MEDREC(III)=$P(X,U)_" "_$P(X,U,2)_" "_$P(X,U,3)
1297
"RTN","ORWPS",165,0)
1298
. S II=0 F S II=$O(^TMP("PS",$J,INDEX,"MREC",I,II)) Q:'II D
1299
"RTN","ORWPS",166,0)
1300
. . S III=III+1,MEDREC(III)=^(II)
1301
"RTN","ORWPS",167,0)
1302
Q
1303
"RTN","ORWPS",168,0)
1304
NVOA(INDEX) ;
1305
"RTN","ORWPS",169,0)
1306
; msc/rec 1/21/09 - grab order action for home med from file 100
1307
"RTN","ORWPS",170,0)
1308
N MSCOR
1309
"RTN","ORWPS",171,0)
1310
S MSCOR=$P(^TMP("PS",$J,INDEX,0),U,8) Q:'MSCOR
1311
"RTN","ORWPS",172,0)
1312
Q:'$D(^OR(100,MSCOR,8,1,0))
1313
"RTN","ORWPS",173,0)
1314
S MSCOA=$P(^OR(100,MSCOR,8,1,0),U,2)
1315
"RTN","ORWPS",174,0)
1316
I MSCOA'="VA" K MSCOA
1317
"RTN","ORWPS",175,0)
1318
;
1319
"RTN","ORWPS",176,0)
1320
Q
1321
"RTN","ORWPS",177,0)
1322
SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y
1323
"RTN","ORWPS",178,0)
1324
N I,X,J
1325
"RTN","ORWPS",179,0)
1326
S J=$G(@Y)
1327
"RTN","ORWPS",180,0)
1328
S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D
1329
"RTN","ORWPS",181,0)
1330
. I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2)
1331
"RTN","ORWPS",182,0)
1332
. N K F K=1:1:$L(X,U) I $P(X,U,K)?1"."1N.E S $P(X,U,K)=0_$P(X,U,K)
1333
"RTN","ORWPS",183,0)
1334
. S J=J+1,@Y@(J)=X
1335
"RTN","ORWPS",184,0)
1336
S @Y=J
1337
"RTN","ORWPS",185,0)
1338
Q
1339
"RTN","ORWPS",186,0)
1340
COMPRESS(Y) ; concatenate Y subscripts into smallest possible number
1341
"RTN","ORWPS",187,0)
1342
N I,J,X S J=1,X(J)=""
1343
"RTN","ORWPS",188,0)
1344
S I=0 F S I=$O(Y(I)) Q:'I D
1345
"RTN","ORWPS",189,0)
1346
. I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)=""
1347
"RTN","ORWPS",190,0)
1348
. S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I)
1349
"RTN","ORWPS",191,0)
1350
K Y M Y=X
1351
"RTN","ORWPS",192,0)
1352
Q
1353
"RTN","ORWPS",193,0)
1354
DETAIL(ROOT,DFN,ID) ; -- show details for a med order
1355
"RTN","ORWPS",194,0)
1356
K ^TMP("ORXPND",$J)
1357
"RTN","ORWPS",195,0)
1358
N LCNT,ORVP
1359
"RTN","ORWPS",196,0)
1360
S LCNT=0,ORVP=DFN_";DPT("
1361
"RTN","ORWPS",197,0)
1362
D MEDS^ORCXPND1
1363
"RTN","ORWPS",198,0)
1364
S ROOT=$NA(^TMP("ORXPND",$J))
1365
"RTN","ORWPS",199,0)
1366
Q
1367
"RTN","ORWPS",200,0)
1368
MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV)
1369
"RTN","ORWPS",201,0)
1370
N ORPSID,HPIV,ISIV,CKPKG,ORPHMID
1371
"RTN","ORWPS",202,0)
1372
S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),(HPIV,ISIV)=0
1373
"RTN","ORWPS",203,0)
1374
S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT
1375
"RTN","ORWPS",204,0)
1376
S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number
1377
"RTN","ORWPS",205,0)
1378
S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
1379
"RTN","ORWPS",206,0)
1380
S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
1381
"RTN","ORWPS",207,0)
1382
S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
1383
"RTN","ORWPS",208,0)
1384
;if the order is pending or the order has no pharmacy #
1385
"RTN","ORWPS",209,0)
1386
;or the order is not in the Display Group IV MEDICATION
1387
"RTN","ORWPS",210,0)
1388
; then use the Orderable item number to get the MAH.
1389
"RTN","ORWPS",211,0)
1390
I (ORPHMID["P")!(ORPHMID="") D Q
1391
"RTN","ORWPS",212,0)
1392
. I '$L($T(HISTORY^PSBMLHS)) D Q
1393
"RTN","ORWPS",213,0)
1394
. . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
1395
"RTN","ORWPS",214,0)
1396
. D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
1397
"RTN","ORWPS",215,0)
1398
; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MAH
1399
"RTN","ORWPS",216,0)
1400
I $P($G(^OR(100,+ORIFN,0)),U,11)=ISIV!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV) D Q
1401
"RTN","ORWPS",217,0)
1402
. I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
1403
"RTN","ORWPS",218,0)
1404
. I CKPKG D
1405
"RTN","ORWPS",219,0)
1406
. . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955
1407
"RTN","ORWPS",220,0)
1408
. . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order."
1409
"RTN","ORWPS",221,0)
1410
I '$L($T(HISTORY^PSBMLHS)) D Q
1411
"RTN","ORWPS",222,0)
1412
. S @ORROOT@(0)="This report is only available using BCMA version 2.0."
1413
"RTN","ORWPS",223,0)
1414
D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
1415
"RTN","ORWPS",224,0)
1416
Q
1417
"RTN","ORWPS",225,0)
1418
;
1419
"RTN","ORWPS",226,0)
1420
REASON(ORY) ; -- Return Non-VA Med Statement/Reasons
1421
"RTN","ORWPS",227,0)
1422
N ORE
1423
"RTN","ORWPS",228,0)
1424
D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
1425
"RTN","ORWPS",229,0)
1426
Q
1427
"RTN","PSGOE4")
1428
0^4^B26687646
1429
"RTN","PSGOE4",1,0)
1430
PSGOE4 ;BIR/CML3-REGULAR ORDER ENTRY ;06 Feb 2001 4:31 PM
1431
"RTN","PSGOE4",2,0)
1432
;;5.0; INPATIENT MEDICATIONS ;**2,50,64,58,111,1502**;16 DEC 97
1433
"RTN","PSGOE4",3,0)
1434
;
1435
"RTN","PSGOE4",4,0)
1436
; Reference to ^PS(51.2 is supported by DBIA 2178.
1437
"RTN","PSGOE4",5,0)
1438
;
1439
"RTN","PSGOE4",6,0)
1440
;K PSGOES S PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),PSGPR=$S($D(PSJOERR):PSJORPV,1:PSGOEPR),(PSGSD,PSGFD,PSGSM,PSGHSM,PSGUD,PSGSI,PSGOROE1,PSGNEFD,PSGMRN)=""
1441
"RTN","PSGOE4",7,0)
1442
K PSGOES S PSGMR=$S($P(PSGNEDFD,"^",2):$P(PSGNEDFD,"^",2),1:PSGOEDMR),PSGSCH=$P(PSGNEDFD,"^",4),PSGPR=PSGOEPR,(PSGSD,PSGFD,PSGSM,PSGHSM,PSGUD,PSGSI,PSGOROE1,PSGNEFD,PSGMRN)=""
1443
"RTN","PSGOE4",8,0)
1444
S:PSGMR PSGMRN=$S('$P(PSGNEDFD,"^",2):"ORAL",'$D(^PS(51.2,PSGMR,0)):PSGMR,$P(^(0),"^")]"":$P(^(0),"^"),1:PSGMR) I PSGPR S PSGPRN=$P($G(^VA(200,PSGPR,0)),"^") S:PSGPRN="" PSGPRN=PSGPR
1445
"RTN","PSGOE4",9,0)
1446
S PSGST=$S($P(PSGNEDFD,"^",3)]"":$P(PSGNEDFD,"^",3),1:"C"),PSGSTN=$$ENSTN^PSGMI(PSGST),F1=53.1 K PSGFOK S PSGFOK(2)=""
1447
"RTN","PSGOE4",10,0)
1448
S:$P(PSJSYSU,";",4) PSGFOK(2)="" K ^PS(53.45,PSJSYSP,1),^(2) I PSGDRG S ^(2,0)="^53.4502P^"_PSGDRG_"^1",^(1,0)=PSGDRG,^PS(53.45,PSJSYSP,2,"B",PSGDRG,1)=""
1449
"RTN","PSGOE4",11,0)
1450
;I '$D(PSJOERR) S PSJNOO=$S($P(PSJSYSU,";",2):"E",1:"W"),PSJNOON=$S(PSJNOO="E":"PROVIDER ENTERED",1:"WRITTEN")
1451
"RTN","PSGOE4",12,0)
1452
;
1453
"RTN","PSGOE4",13,0)
1454
109 ; dosage ordered
1455
"RTN","PSGOE4",14,0)
1456
I $P(PSJSYSU,";",4) D GETDOSE^PSJDOSE(PSGDRG) G:PSGOROE1 DONE G:'$G(PSGOE3) 3
1457
"RTN","PSGOE4",15,0)
1458
W !,"DOSAGE ORDERED: ",$S(PSGDO]"":PSGDO_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
1459
"RTN","PSGOE4",16,0)
1460
I X="" S X=PSGDO ;I X="" W $C(7)," (Required)" G 109
1461
"RTN","PSGOE4",17,0)
1462
S PSGF2=109 I X="@" S PSGDO="" ;W $C(7)," (Required)" G 109
1463
"RTN","PSGOE4",18,0)
1464
I X="@" D DEL G:%'=1 109 S (PSGDO,PSGFOK(109),PSGUD)="" G 3
1465
"RTN","PSGOE4",19,0)
1466
I X?1."?" D ENHLP^PSGOEM(53.1,109) G 109
1467
"RTN","PSGOE4",20,0)
1468
I $E(X)="^" D FF G:Y>0 @Y G 109
1469
"RTN","PSGOE4",21,0)
1470
I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
1471
"RTN","PSGOE4",22,0)
1472
I $S(X="":0,X?.E1C.E:1,$L(X)>20:1,X="":1,X["^":1,X?1.P:1,1:X=+X) W $C(7)," ",$S(X?1.P!(X=""):"(Required)",1:"??") D ENHLP^PSGOEM(53.1,109) G 109
1473
"RTN","PSGOE4",23,0)
1474
S PSGDO=$S(X?1"."1N.E:0,1:"")_X,PSGFOK(109)=""
1475
"RTN","PSGOE4",24,0)
1476
;
1477
"RTN","PSGOE4",25,0)
1478
13 ; units per dose
1479
"RTN","PSGOE4",26,0)
1480
;/** NO LONGER USE WITH POE
1481
"RTN","PSGOE4",27,0)
1482
Q:$G(PSGOE3)
1483
"RTN","PSGOE4",28,0)
1484
G:'$P(PSJSYSU,";",4) 3 I $D(PSGFOK(13)) S PSGFOK(13)=1 D 2^PSGOE42 S PSGFOK(13)="" G 3
1485
"RTN","PSGOE4",29,0)
1486
;
1487
"RTN","PSGOE4",30,0)
1488
A13 ;
1489
"RTN","PSGOE4",31,0)
1490
W !,"UNITS PER DOSE: ",$S(PSGUD:PSGUD_"// ",1:"") R X:DTIME I X="^"!'$T S PSGOROE1=1 G DONE
1491
"RTN","PSGOE4",32,0)
1492
I X="" W:'PSGUD " (1)" G S13
1493
"RTN","PSGOE4",33,0)
1494
S PSGF2=13 I X="@",'PSGUD W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,13) G A13
1495
"RTN","PSGOE4",34,0)
1496
I X="@" D DEL G:%'=1 13 S PSGUD="" G S13
1497
"RTN","PSGOE4",35,0)
1498
I X?1."?" D ENHLP^PSGOEM(53.1,13) G A13
1499
"RTN","PSGOE4",36,0)
1500
I $E(X)="^" D FF G:Y>0 @Y G A13
1501
"RTN","PSGOE4",37,0)
1502
I X?1.2N1"/"1.2N S X=+$J(+X/$P(X,"/",2),0,2) W " ("_$E("0",X<1)_X_")"
1503
"RTN","PSGOE4",38,0)
1504
I $S($L(X)>12:1,X'=+X:1,X>50:1,X<0:1,1:X?.N1"."3.N) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,13) G 13
1505
"RTN","PSGOE4",39,0)
1506
S PSGUD=X W:'X " (1)"
1507
"RTN","PSGOE4",40,0)
1508
;
1509
"RTN","PSGOE4",41,0)
1510
S13 ;
1511
"RTN","PSGOE4",42,0)
1512
S PSGFOK(13)="" I PSGDRG S $P(^PS(53.45,PSJSYSP,2,1,0),"^",2)=PSGUD
1513
"RTN","PSGOE4",43,0)
1514
;
1515
"RTN","PSGOE4",44,0)
1516
3 ; med route
1517
"RTN","PSGOE4",45,0)
1518
W !,"MED ROUTE: ",$S(PSGMR:PSGMRN_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
1519
"RTN","PSGOE4",46,0)
1520
I X="",PSGMR S X=PSGMRN I PSGMR'=PSGMRN,$D(^PS(51.2,PSGMR,0)) W " "_$P(^(0),"^",3) S PSGFOK(3)="" G 7
1521
"RTN","PSGOE4",47,0)
1522
S PSGF2=3 I $S(X="@":1,X]"":0,1:'PSGMR) W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,2) G 3
1523
"RTN","PSGOE4",48,0)
1524
I X?1."?" D ENHLP^PSGOEM(53.1,3)
1525
"RTN","PSGOE4",49,0)
1526
I $E(X)="^" D FF G:Y>0 @Y G 3
1527
"RTN","PSGOE4",50,0)
1528
K DIC S DIC="^PS(51.2,",DIC(0)="EMQZ",DIC("S")="I $P(^(0),""^"",4)" D ^DIC K DIC I Y'>0 G 3
1529
"RTN","PSGOE4",51,0)
1530
S PSGMR=+Y,PSGMRN=$P(Y(0),"^") S PSGFOK(3)=""
1531
"RTN","PSGOE4",52,0)
1532
;
1533
"RTN","PSGOE4",53,0)
1534
7 ; schedule type
1535
"RTN","PSGOE4",54,0)
1536
Q:$G(PSGOE3)
1537
"RTN","PSGOE4",55,0)
1538
W !,"SCHEDULE TYPE: "_$S(PSGSTN]"":PSGSTN_"// ",1:"") R X:DTIME S X=$TR(X,"coprocf","COPROCF") I X="^"!'$T S PSGOROE1=1 W $C(7) G DONE
1539
"RTN","PSGOE4",56,0)
1540
I X="" S:PSGST="OC" PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" W " "_PSGSTN S PSGFOK(7)="" S $P(PSGNEDFD,"^",3)=PSGST G:PSGST="OC" 8^PSGOE41 G 26
1541
"RTN","PSGOE4",57,0)
1542
S PSGF2=7 I X="@"!(X?1."?") W:X="@" $C(7)," ?? (Required)" S:X="@" X="?" D ENHLP^PSGOEM(53.1,7) G 7
1543
"RTN","PSGOE4",58,0)
1544
I $E(X)="^" D FF G:Y>0 @Y G 7
1545
"RTN","PSGOE4",59,0)
1546
I X="OC"!(X="R") S PSGST=X,$P(PSGNEDFD,"^",3)=X,PSGSTN=$S(X="R":"FILL on REQUEST",1:"ON CALL") W " "_PSGSTN S PSGFOK(7)="" G:X="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
1547
"RTN","PSGOE4",60,0)
1548
F Y="C^CONTINUOUS","O^ONE TIME","OC^ON CALL","P^PRN","R^FILL on REQUEST" I $P($P(Y,"^",2),X)="" W $P($P(Y,"^",2),X,2) S PSGST=$P(Y,"^"),PSGSTN=$P(Y,"^",2),$P(PSGNEDFD,"^",3)=PSGST Q
1549
"RTN","PSGOE4",61,0)
1550
E W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,7) G 7
1551
"RTN","PSGOE4",62,0)
1552
I PSGST="OC"!(PSGST="R") S PSGFOK(7)="" G:PSGST="R" 26 S PSGSCH=PSGSTN,(PSGS0Y,PSGS0XT)="" G 8^PSGOE41
1553
"RTN","PSGOE4",63,0)
1554
S PSGFOK(7)=""
1555
"RTN","PSGOE4",64,0)
1556
;
1557
"RTN","PSGOE4",65,0)
1558
26 ; schedule
1559
"RTN","PSGOE4",66,0)
1560
W !,"SCHEDULE: ",$S(PSGSCH]"":PSGSCH_"// ",1:"") R X:DTIME I X="^"!'$T W:'$T $C(7) S PSGOROE1=1 G DONE
1561
"RTN","PSGOE4",67,0)
1562
;*S PSGF2=26 S:X="" X=PSGSCH I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
1563
"RTN","PSGOE4",68,0)
1564
S PSGF2=26 S:X="" X=PSGSCH,PSGSCH="" I "@"[X W $C(7)," (Required)" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
1565
"RTN","PSGOE4",69,0)
1566
I X?1."?" D ENHLP^PSGOEM(53.1,26) G 26
1567
"RTN","PSGOE4",70,0)
1568
I $E(X)="^" D FF G:Y>0 @Y G 26
1569
"RTN","PSGOE4",71,0)
1570
N PSJSLUP S PSJSLUP=1 D EN^PSGS0 I '$D(X) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.1,26) G 26
1571
"RTN","PSGOE4",72,0)
1572
S PSGSCH=X,$P(PSGNEDFD,"^",4)=X,PSGFOK(26)="" I PSGS0XT="O" S $P(PSGNEDFD,"^",3)="O",PSGST="O",PSGSTN=$$ENSTN^PSGMI(PSGST)
1573
"RTN","PSGOE4",73,0)
1574
I $G(PSGOE3) D Q
1575
"RTN","PSGOE4",74,0)
1576
. S PSGSCH=X,PSGST=$S(PSGS0XT="O":"O",PSGST="R":"R",X["PRN":"P",X="ON CALL":"OC",PSGST]"":PSGST,1:"C"),PSGFOK(26)=""
1577
"RTN","PSGOE4",75,0)
1578
. S $P(PSGNEDFD,"^",3)=PSGST S:PSGSCH=""!(X?1." ") PSGSCH="PRN"
1579
"RTN","PSGOE4",76,0)
1580
. S PSGSTN=$$ENSTN^PSGMI(PSGST)
1581
"RTN","PSGOE4",77,0)
1582
;***
1583
"RTN","PSGOE4",78,0)
1584
;Q:$G(PSGOE3)
1585
"RTN","PSGOE4",79,0)
1586
;
1587
"RTN","PSGOE4",80,0)
1588
G ^PSGOE41
1589
"RTN","PSGOE4",81,0)
1590
;
1591
"RTN","PSGOE4",82,0)
1592
DONE ;
1593
"RTN","PSGOE4",83,0)
1594
I PSGOROE1 K Y W $C(7)," ...order not entered..."
1595
"RTN","PSGOE4",84,0)
1596
K F,F0,F1,PSGF2,F3,PSG,PSGSD,SDT Q
1597
"RTN","PSGOE4",85,0)
1598
;
1599
"RTN","PSGOE4",86,0)
1600
FF ; up-arrow to another field
1601
"RTN","PSGOE4",87,0)
1602
D ENFF^PSGOEM I Y>0,Y'=109,Y'=13,Y'=3,Y'=7,Y'=26 S:Y=2 FB=PSGF2_"^PSGOE4" S Y=Y_"^PSGOE4"_$S("^39^8^10^25^"[("^"_Y_"^"):1,1:2)
1603
"RTN","PSGOE4",88,0)
1604
Q
1605
"RTN","PSGOE4",89,0)
1606
;
1607
"RTN","PSGOE4",90,0)
1608
DEL ; delete entry
1609
"RTN","PSGOE4",91,0)
1610
W !?3,"SURE YOU WANT TO DELETE" S %=0 D YN^DICN I %'=1 W $C(7)," <NOTHING DELETED>"
1611
"RTN","PSGOE4",92,0)
1612
Q
1613
"RTN","PSJHL4A")
1614
0^5^B37291448
1615
"RTN","PSJHL4A",1,0)
1616
PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ; 06 Jul 2010 12:05 PM
1617
"RTN","PSJHL4A",2,0)
1618
;;5.0; INPATIENT MEDICATIONS ;**105,111,154,1502**;16 DEC 97
1619
"RTN","PSJHL4A",3,0)
1620
;
1621
"RTN","PSJHL4A",4,0)
1622
; Reference to ^PS(52.6 is supported by DBIA# 1231.
1623
"RTN","PSJHL4A",5,0)
1624
; Reference to ^PS(52.7 is supported by DBIA# 2173.
1625
"RTN","PSJHL4A",6,0)
1626
; Reference to ^PS(55 is supported by DBIA# 2191.
1627
"RTN","PSJHL4A",7,0)
1628
; Reference to ^PS(59.7 supported by DBIA #2181.
1629
"RTN","PSJHL4A",8,0)
1630
;
1631
"RTN","PSJHL4A",9,0)
1632
RXC ; IV order
1633
"RTN","PSJHL4A",10,0)
1634
S APPL=FIELD(1)
1635
"RTN","PSJHL4A",11,0)
1636
I APPL["B" S SOLCNT=SOLCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S VOLUME=$S(FIELD(3)?1".".N:0_FIELD(3),1:+FIELD(3))_" ML" D I '$D(^TMP("PSJNVO",$J,"SOL",SOLCNT,0)) D SOLSRCH
1637
"RTN","PSJHL4A",12,0)
1638
.S SOLUTION="" F S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) Q:'SOLUTION S INACT=$G(^PS(52.7,SOLUTION,"I")) I 'INACT!(INACT>DT) I VOLUME=$P(^PS(52.7,SOLUTION,0),U,3) D
1639
"RTN","PSJHL4A",13,0)
1640
..S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
1641
"RTN","PSJHL4A",14,0)
1642
..S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
1643
"RTN","PSJHL4A",15,0)
1644
I $G(INFRT)]"" S X=INFRT D ENI^PSJHLU S INFRT=$G(X)
1645
"RTN","PSJHL4A",16,0)
1646
S FIELD(3)=$S($G(FIELD(3))?1".".N:0_$G(FIELD(3)),1:$G(FIELD(3)))
1647
"RTN","PSJHL4A",17,0)
1648
I APPL="A" S ADCNT=ADCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S STRENGTH=FIELD(3)_" "_$P($G(FIELD(4)),"^",5) D I '$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q
1649
"RTN","PSJHL4A",18,0)
1650
.S ADDITIVE="" F S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE S INACT=$G(^PS(52.6,ADDITIVE,"I")) I 'INACT!(INACT>DT) Q:$G(^PS(52.6,ADDITIVE,0))']"" D Q:ADDITIVE
1651
"RTN","PSJHL4A",19,0)
1652
..I $G(PSITEM)="" S PSITEM=PTR
1653
"RTN","PSJHL4A",20,0)
1654
..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT
1655
"RTN","PSJHL4A",21,0)
1656
..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH
1657
"RTN","PSJHL4A",22,0)
1658
Q
1659
"RTN","PSJHL4A",23,0)
1660
;
1661
"RTN","PSJHL4A",24,0)
1662
RXO ;
1663
"RTN","PSJHL4A",25,0)
1664
I $O(PSJMSG(II,0)) D
1665
"RTN","PSJHL4A",26,0)
1666
.K SEGMENT
1667
"RTN","PSJHL4A",27,0)
1668
.N KK,JJ,XX
1669
"RTN","PSJHL4A",28,0)
1670
.S SEGMENT(1)=$G(PSJMSG(II))
1671
"RTN","PSJHL4A",29,0)
1672
.S KK=1,JJ="" F S JJ=$O(PSJMSG(II,JJ)) Q:'JJ S KK=KK+1,SEGMENT(KK)=$G(PSJMSG(II,JJ))
1673
"RTN","PSJHL4A",30,0)
1674
.S KK=1,JJ=0
1675
"RTN","PSJHL4A",31,0)
1676
.F Q:'$D(SEGMENT(KK)) D
1677
"RTN","PSJHL4A",32,0)
1678
..I SEGMENT(KK)["|" S FIELD(JJ)=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(FIELD(JJ))+2,$L(SEGMENT(KK))),JJ=JJ+1 Q
1679
"RTN","PSJHL4A",33,0)
1680
..I SEGMENT(KK)'["|" S FIELD(JJ)=SEGMENT(KK),KK=KK+1 Q:'$D(SEGMENT(KK)) D
1681
"RTN","PSJHL4A",34,0)
1682
...S XX=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(X)+2,$L(SEGMENT(KK))),FIELD(JJ)=FIELD(JJ)_XX,JJ=JJ+1
1683
"RTN","PSJHL4A",35,0)
1684
S APPL="",PSITEM=$S($P(FIELD(1),"^",5)="IV":"",1:$P(FIELD(1),"^",4))
1685
"RTN","PSJHL4A",36,0)
1686
S:$P(FIELD(1),"^",6)="ORD" PSITEM=""
1687
"RTN","PSJHL4A",37,0)
1688
S:$P(FIELD(1),"^",5)="IV" IVTYP="A",SCHTYP="C",INFRT=$G(FIELD(2))
1689
"RTN","PSJHL4A",38,0)
1690
S DISPENSE=$P($G(FIELD(10)),"^",4)
1691
"RTN","PSJHL4A",39,0)
1692
S IVLIMIT=$P($G(PSJMSG(II)),"^",3)
1693
"RTN","PSJHL4A",40,0)
1694
Q
1695
"RTN","PSJHL4A",41,0)
1696
;
1697
"RTN","PSJHL4A",42,0)
1698
OBX ;
1699
"RTN","PSJHL4A",43,0)
1700
S OBXFL=1,OCNARR=FIELD(5),OCPROV=CLERK,OCCNT=OCCNT+1
1701
"RTN","PSJHL4A",44,0)
1702
S ^TMP("PSJNVO",$J,10,0)=OCCNT
1703
"RTN","PSJHL4A",45,0)
1704
S ^TMP("PSJNVO",$J,10,OCCNT,0)=OCNARR
1705
"RTN","PSJHL4A",46,0)
1706
S ^TMP("PSJNVO",$J,10,OCCNT,1)=$P($G(^VA(200,+OCPROV,0)),"^")
1707
"RTN","PSJHL4A",47,0)
1708
Q
1709
"RTN","PSJHL4A",48,0)
1710
;
1711
"RTN","PSJHL4A",49,0)
1712
NTE ;
1713
"RTN","PSJHL4A",50,0)
1714
S TEXT=$S((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN")
1715
"RTN","PSJHL4A",51,0)
1716
S @TEXT@(1)=$G(FIELD(3))
1717
"RTN","PSJHL4A",52,0)
1718
S K=1,J="" F S J=$O(PSJMSG(II,J)) Q:'J S K=K+1,@TEXT@(K)=$G(PSJMSG(II,J))
1719
"RTN","PSJHL4A",53,0)
1720
D:$D(OCRSN)
1721
"RTN","PSJHL4A",54,0)
1722
.S QQ=0 F S QQ=$O(OCRSN(QQ)) Q:'QQ S ^TMP("PSJNVO",$J,10,OCCNT,2,QQ,0)=OCRSN(QQ)
1723
"RTN","PSJHL4A",55,0)
1724
S OBXFL=0
1725
"RTN","PSJHL4A",56,0)
1726
Q
1727
"RTN","PSJHL4A",57,0)
1728
;
1729
"RTN","PSJHL4A",58,0)
1730
ZRX ;
1731
"RTN","PSJHL4A",59,0)
1732
N ND,ND2,CHK,FOLOR,STDT
1733
"RTN","PSJHL4A",60,0)
1734
S PREON=$G(FIELD(1)),ROC=$G(FIELD(3))
1735
"RTN","PSJHL4A",61,0)
1736
S ND=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,0)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$G(^PS(55,PSJHLDFN,5,+PREON,0)))
1737
"RTN","PSJHL4A",62,0)
1738
S ND2=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,2)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$G(^PS(55,PSJHLDFN,5,+PREON,2)))
1739
"RTN","PSJHL4A",63,0)
1740
I 'ND I ROC'="N" S PSREASON="Invalid Pharmacy order number" D ERROR^PSJHL9 Q
1741
"RTN","PSJHL4A",64,0)
1742
I ND I ROC="R" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Duplicate Renewal Request" D ERROR^PSJHL9 Q
1743
"RTN","PSJHL4A",65,0)
1744
I ND I ROC="R" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "AE"'[CHK S PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed" D ERROR^PSJHL9 Q
1745
"RTN","PSJHL4A",66,0)
1746
I $G(CHK)="E" I PREON'["V" D NOW^%DTC S X1=+$E(%,1,12),X2=-4 D C^%DTC S STDT=$S(PREON["V":$P(ND,U,3),1:$P(ND2,U,4)) I STDT'>X S PSREASON="Pharmacy orders expired longer than 4 days may not be renewed" D ERROR^PSJHL9 Q
1747
"RTN","PSJHL4A",67,0)
1748
I ND I ROC="E" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Pharmacy orders may only be edited ONCE" D ERROR^PSJHL9 Q
1749
"RTN","PSJHL4A",68,0)
1750
I ND I ROC="E" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "DEHO"[CHK N CHKRTN S CHKRTN=CHK_"^PSJHL6" D @CHKRTN S PSREASON=PSREASON_" orders may not be edited" D ERROR^PSJHL9 Q
1751
"RTN","PSJHL4A",69,0)
1752
D:ROC'="R" VALID^PSJHL9 Q:QFLG
1753
"RTN","PSJHL4A",70,0)
1754
I $G(PSITEM)="",$D(^TMP("PSJNVO",$J,"SOL",1,0)) S PSITEM=$P($G(^PS(52.7,+^TMP("PSJNVO",$J,"SOL",1,0),0)),"^",11)
1755
"RTN","PSJHL4A",71,0)
1756
I PRIORITY="ZD" D VALID^PSJHL10 S QFLG=1 Q
1757
"RTN","PSJHL4A",72,0)
1758
I (PREON]"")&(ROC="E") D EDITCK^PSJHL5 Q:QFLG
1759
"RTN","PSJHL4A",73,0)
1760
D NVO^PSJHL9
1761
"RTN","PSJHL4A",74,0)
1762
I (PREON]"")&(ROC="R") D RENEW^PSJHL7 Q
1763
"RTN","PSJHL4A",75,0)
1764
I (PREON]"")&(ROC="E") D EDIT^PSJHL5
1765
"RTN","PSJHL4A",76,0)
1766
Q
1767
"RTN","PSJHL4A",77,0)
1768
;
1769
"RTN","PSJHL4A",78,0)
1770
SOLSRCH ;Find solution
1771
"RTN","PSJHL4A",79,0)
1772
N SSSS,SEG,ON,ROC,SOL,SOL2
1773
"RTN","PSJHL4A",80,0)
1774
F SSSS=II:0 S SSSS=$O(PSJMSG(SSSS)) Q:'SSSS I $P(PSJMSG(SSSS),"|")="ZRX" D Q
1775
"RTN","PSJHL4A",81,0)
1776
.S SEG=$G(PSJMSG(SSSS)),ON=$P(SEG,"|",2),ROC=$P(SEG,"|",4)
1777
"RTN","PSJHL4A",82,0)
1778
I $G(ROC)'="N" F SOL=0:0 S SOL=$O(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL)) Q:'SOL S SOL2=$G(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0)) I $D(^PS(52.7,"AOI",PTR,+SOL2))&($P(SOL2,U,2)=VOLUME) S SOLUTION=+SOL2 D SET Q
1779
"RTN","PSJHL4A",83,0)
1780
I 'SOLUTION S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) D SET
1781
"RTN","PSJHL4A",84,0)
1782
Q
1783
"RTN","PSJHL4A",85,0)
1784
SET ;Set solution tmp nodes
1785
"RTN","PSJHL4A",86,0)
1786
Q:'+SOLUTION
1787
"RTN","PSJHL4A",87,0)
1788
S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
1789
"RTN","PSJHL4A",88,0)
1790
S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
1791
"RTN","PSJHL4A",89,0)
1792
Q
1793
"RTN","PSJHL4A",90,0)
1794
;
1795
"RTN","PSJHL4A",91,0)
1796
SNDTSTW(PRIO,PSJSCHED,WARD) ; Test to determine if mail message should be sent.
1797
"RTN","PSJHL4A",92,0)
1798
N SNPRIO,SNSCHD,SNOPT
1799
"RTN","PSJHL4A",93,0)
1800
S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
1801
"RTN","PSJHL4A",94,0)
1802
S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
1803
"RTN","PSJHL4A",95,0)
1804
S SNOPT=$P($G(^PS(59.6,WARD,0)),"^",32)
1805
"RTN","PSJHL4A",96,0)
1806
S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
1807
"RTN","PSJHL4A",97,0)
1808
Q:SNOPT="" 0
1809
"RTN","PSJHL4A",98,0)
1810
Q:SNOPT[SNPRIO 0
1811
"RTN","PSJHL4A",99,0)
1812
Q:SNOPT[SNSCHD 0
1813
"RTN","PSJHL4A",100,0)
1814
Q 1
1815
"RTN","PSJHL4A",101,0)
1816
;
1817
"RTN","PSJHL4A",102,0)
1818
SNDTSTP(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
1819
"RTN","PSJHL4A",103,0)
1820
N SNPRIO,SNSCHD,SNOPT
1821
"RTN","PSJHL4A",104,0)
1822
S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
1823
"RTN","PSJHL4A",105,0)
1824
S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
1825
"RTN","PSJHL4A",106,0)
1826
S SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
1827
"RTN","PSJHL4A",107,0)
1828
Q:SNOPT="" 0
1829
"RTN","PSJHL4A",108,0)
1830
Q:SNOPT[SNPRIO 0
1831
"RTN","PSJHL4A",109,0)
1832
Q:SNOPT[SNSCHD 0
1833
"RTN","PSJHL4A",110,0)
1834
Q 1
1835
"RTN","PSJHL4A",111,0)
1836
;
1837
"RTN","PSJHL4A",112,0)
1838
SNDTSTA(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
1839
"RTN","PSJHL4A",113,0)
1840
N SNPRIO,SNSCHD,SNOPT
1841
"RTN","PSJHL4A",114,0)
1842
S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
1843
"RTN","PSJHL4A",115,0)
1844
S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
1845
"RTN","PSJHL4A",116,0)
1846
S SNOPT=$P($G(^PS(59.7,1,27)),"^",2)
1847
"RTN","PSJHL4A",117,0)
1848
S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
1849
"RTN","PSJHL4A",118,0)
1850
Q:SNOPT="" 0
1851
"RTN","PSJHL4A",119,0)
1852
Q:SNOPT[SNPRIO 0
1853
"RTN","PSJHL4A",120,0)
1854
Q:SNOPT[SNSCHD 0
1855
"RTN","PSJHL4A",121,0)
1856
Q 1
1857
"VER")
1858
8.0^22.0
1859
**END**
1860
**END**
Loggerhead is a web-based interface for Breezy
Version: 2.0.1