Merge lp:~jontai/openvista-gtm-integration/phase1-alpha2-release-prep into lp:openvista-gtm-integration

Proposed by Jon Tai
Status: Merged
Merged at revision: not available
Proposed branch: lp:~jontai/openvista-gtm-integration/phase1-alpha2-release-prep
Merge into: lp:openvista-gtm-integration
Diff against target: None lines
To merge this branch: bzr merge lp:~jontai/openvista-gtm-integration/phase1-alpha2-release-prep
Reviewer Review Type Date Requested Status
OpenVista/GT.M Integration Team Pending
Review via email: mp+7197@code.launchpad.net
To post a comment you must log in.

Preview Diff

[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1=== added file 'ChangeLog'
2--- ChangeLog 1970-01-01 00:00:00 +0000
3+++ ChangeLog 2009-06-08 17:00:39 +0000
4@@ -0,0 +1,187 @@
5+0.8.1
6+===
7+
8+ 55 Jonathan Tai 2009-06-08 [merge]
9+ Prep for 0.8.1 (phase 1 alpha 2) release
10+
11+ 54 Jonathan Tai 2009-06-05 [merge]
12+ Merge bug 384019 - ERROR SETTING RIGHT MARGIN TO ZERO
13+
14+ 53 Jonathan Tai 2009-06-03 [merge]
15+ Merge bug 383367 - ovimport creates temporary directory in routines directory when importing routines from tmp directory
16+
17+ 52 Jonathan Tai 2009-06-02 [merge]
18+ Merge bug 378919 - System status routine
19+
20+ 51 Jonathan Tai 2009-06-02 [merge]
21+ Merge bug 381117 - GT.M/Unix version of ORDER^%ZOSV out of sync with Cache version
22+
23+ 50 Jonathan Tai 2009-06-02 [merge]
24+ Merge bug 380753 - HFS device always busy
25+
26+ 49 Jonathan Tai 2009-06-01 [merge]
27+ Merge bug 381113 - ZISFGUX is not necessary
28+
29+ 48 Jonathan Tai 2009-05-29 [merge]
30+ Merge bug 381424 - Printing from CPRS only Prints Header
31+
32+ 47 Jonathan Tai 2009-05-21 [merge]
33+ Merge bug 370652 - UNLOCK^MSCZJOBU doesn't need a second argument
34+
35+ 46 Jeff Apple 2009-05-20 [merge]
36+ Merge bug378746
37+ correct return codes and error messages
38+
39+ 45 Jonathan Tai 2009-05-20 [merge]
40+ Merge bug 378140 - gtmsignal is installed with incorrect owner
41+
42+ 44 Jeff Apple 2009-05-19
43+ Fix spelling error in help
44+
45+ 43 Jonathan Tai 2009-05-13 [merge]
46+ Merge bug 375029 - ovimport doesn't create group-writable routine files if source files aren't group-writable
47+
48+
49+0.8
50+===
51+
52+ 42 Jonathan Tai 2009-05-01 [merge]
53+ Merge Joel's build
54+
55+ 41 Jonathan Tai 2009-05-01 [merge]
56+ Add routines present in Joel's build, but missing from bzr
57+
58+ 40 Jeff Apple 2009-05-01 [merge]
59+ Merge changes under bug 368789
60+
61+ 39 Jeff Apple 2009-04-29 [merge]
62+ Merge bug323482
63+ Fix compile errors
64+
65+ 38 Jonathan Tai 2009-04-29 [merge]
66+ Merge bug 369369 - ovimport imports globals.zwr into routines directory when the zip files are extracted into the same directory
67+
68+ 37 Jonathan Tai 2009-04-28 [merge]
69+ Merge bug 326193 - System Status/Job Exam not working in GTM
70+
71+ 36 Jonathan Tai 2009-04-27 [merge]
72+ Merge bug 365395 - ovimport routine copy performance
73+
74+ 35 Jonathan Tai 2009-04-25 [merge]
75+ Merge bug 366576 - Unable to remove openvista-webdav-config package if removing httpd
76+
77+ 34 Jeff Apple 2009-04-24
78+ Add author in comment
79+
80+ 33 Jeff Apple 2009-04-24 [merge]
81+ Merge bug 332088
82+ lpr printing from gtm in unix
83+
84+ 32 Jeff Apple 2009-04-24 [merge]
85+ Merge bug355710
86+ Unprotected SSVN in XPDR
87+
88+ 31 Jeff Apple 2009-04-24 [merge]
89+ Merge bug 333538
90+ Error Trap display intermittent problems - fixed
91+
92+ 30 Jonathan Tai 2009-04-23 [merge]
93+ Merge bug 365777 - Tied account script to run MSCOVCI
94+
95+ 29 Jonathan Tai 2009-04-23 [merge]
96+ Merge bug 365404 - bash completion should skip over lost+found directory
97+
98+ 28 Jonathan Tai 2009-04-23 [merge]
99+ Merge bug 365393 - ovinstanceadd should create "images" symlink pointing to webdav root
100+
101+ 27 Jonathan Tai 2009-04-22 [merge]
102+ Merge bug 365370 - libopenvista.so needs to have textrel_shlib_t
103+
104+ 26 Jeff Apple 2009-04-23 [merge]
105+ Add missing TCPIP and library changes
106+
107+ 25 Jonathan Tai 2009-04-22 [merge]
108+ Merge bug 363162 - Send M errors back instead of disconnecting clients
109+
110+ 24 Jonathan Tai 2009-04-21 [merge]
111+ Merge release-packaging branch: new COPYING and README files, new build script, adds a -V flag to all commands that displays AGPL info, new ovswitchjournals utility, new openvista-webdav-config package to automatically configure webdav; adds webdav support to ovinstanceadd/ovinstancedel
112+
113+ 23 Jonathan Tai 2009-04-20 [merge]
114+ Merge bug 326435 - Linux commands should come with man pages
115+
116+ 22 Jeff Apple 2009-04-18 [merge]
117+ Merge bug 357216
118+ Set $ZTRAP so that an error doesn't just hang
119+
120+ 21 Jonathan Tai 2009-04-18 [merge]
121+ Merge bug 363215 - ovrestore doesn't set permissions properly
122+
123+ 20 Jonathan Tai 2009-04-18 [merge]
124+ Merge bug 361519 - Provide startup/shutdown hooks
125+
126+ 19 Jeff Apple 2009-04-17 [merge]
127+ Merged bug 360615
128+ Enhance DEL^ZOSV2GTM to fix bugs and for more intelligent deletion
129+
130+ 18 Jeff Apple 2009-04-17 [merge]
131+ Merged bug 359421
132+ Shut down HL7 listener when TaskMan tells it to
133+
134+ 17 Jeff Apple 2009-04-17 [merge]
135+ Merged changes for bug 359318 and bug 318003
136+ Set var so GETPEER^ZOSVGUX will work
137+ Use C callouts to keep listening socket open
138+
139+ 16 Jeff Apple 2009-04-17 [merge]
140+ Merge bug 322031
141+ Make VistaLink work with GT.M
142+
143+ 15 Jonathan Tai 2009-04-17 [merge]
144+ Merge bug 362001 - Utility to restore backups
145+
146+ 14 Jonathan Tai 2009-04-15 [merge]
147+ Merge bug 361512 - Run mupip backup and routine consistency check in parallel
148+
149+ 13 Jonathan Tai 2009-04-15 [merge]
150+ Merge scripts-work branch into mainline.
151+
152+ 12 Jeff Apple 2009-04-14 [merge]
153+ Merge bug 360710 - Enhance ZTMGRSET to better handle a $ZROutine search path
154+
155+ 11 Jeff Apple 2009-04-14 [merge]
156+ Merge bug 360290 - Enhance RTNDIR^ZOSVGUX() to handle more forms of $ZROutines
157+
158+ 10 Jeff Apple 2009-04-13 [merge]
159+ Merge for bug 322986 - logging when dropping to programmer mode
160+
161+ 9 Jeff Apple 2009-04-13 [merge]
162+ Merged branch bug359418
163+ Allow GTM to run a multithreaded HL7 server
164+
165+ 8 Jeff Apple 2009-04-13
166+ Comments
167+
168+ 7 Jeff Apple 2009-04-13 [merge]
169+ Merge from bug321745
170+ Decrease polling ttime on socket reads for GTM
171+
172+ 6 Jeff Apple 2009-04-10
173+ Unmodified sources
174+
175+ 5 Jeff Apple 2009-04-10 [merge]
176+ Merged branch bug336102 : Check for error on HL7 socket read
177+
178+ 4 Jonathan Tai 2009-04-06 [merge]
179+ Merge gtm-packaging branch into mainline. This branch includes the zprompt work and some script and packaging fixes
180+
181+ 3 Jonathan Tai 2009-02-25 [merge]
182+ Merge xc-packaging branch into mainline. This branch includes the tcpip work and the PAM auth work.
183+
184+ 2 Jonathan Tai 2009-02-12 [merge]
185+ Merge scripts+packaging branch into mainline to lay the foundation for other work.
186+
187+ 1 Jon 2009-01-16
188+ Initial import into bzr.
189+
190+ Created directory structure; added README and COPYING files.
191+
192
193=== modified file 'NEWS'
194--- NEWS 2009-04-18 08:46:59 +0000
195+++ NEWS 2009-06-05 19:50:04 +0000
196@@ -1,3 +1,9 @@
197+0.8.1
198+===
199+
200+This release fixes bugs in ovimport, gtmsignal, the HFS device, and other
201+kernel routines. A new %SS system status routine was added.
202+
203
204 0.8
205 ===
206
207=== added file 'docs/release-checklist.txt'
208--- docs/release-checklist.txt 1970-01-01 00:00:00 +0000
209+++ docs/release-checklist.txt 2009-06-08 16:58:39 +0000
210@@ -0,0 +1,11 @@
211+Release Checklist
212+===
213+
214+ [ ] Branch mainline after all "real" changes are in
215+ [ ] Create new KIDS build, copy to kids directory and bzr add it
216+ [ ] Bump revision numbers in all scripts
217+ [ ] Bump revision numbers in any updated RPM spec files
218+ [ ] Update NEWS
219+ [ ] Update ChangeLog (include future merge of release prep branch into mainline)
220+ [ ] Merge release prep branch into mainline
221+
222
223=== added file 'kids/MSC_GTM_INTEG_2.KID'
224--- kids/MSC_GTM_INTEG_2.KID 1970-01-01 00:00:00 +0000
225+++ kids/MSC_GTM_INTEG_2.KID 2009-06-08 16:54:50 +0000
226@@ -0,0 +1,11858 @@
227+KIDS Distribution saved on Jun 08, 2009@09:49:02
228+VERSION 2 GTM
229+**KIDS**:MSC GTM INTEGRATION*1.0*2^
230+
231+**INSTALL NAME**
232+MSC GTM INTEGRATION*1.0*2
233+"BLD",7026,0)
234+MSC GTM INTEGRATION*1.0*2^^0^3090608^y
235+"BLD",7026,1,0)
236+^^1^1^3090605^
237+"BLD",7026,1,1,0)
238+SYSTEM STATUS AND JOBEXAM FOR GT.M
239+"BLD",7026,4,0)
240+^9.64PA^^
241+"BLD",7026,6.3)
242+36
243+"BLD",7026,"INIT")
244+POSTGTM^ZTMGRSET
245+"BLD",7026,"KRN",0)
246+^9.67PA^8989.52^19
247+"BLD",7026,"KRN",.4,0)
248+.4
249+"BLD",7026,"KRN",.401,0)
250+.401
251+"BLD",7026,"KRN",.402,0)
252+.402
253+"BLD",7026,"KRN",.403,0)
254+.403
255+"BLD",7026,"KRN",.403,"NM",0)
256+^9.68A^2^2
257+"BLD",7026,"KRN",.403,"NM",1,0)
258+MSCZJOBEXAM FILE #3.081^3.081^0
259+"BLD",7026,"KRN",.403,"NM",2,0)
260+MSCZLOCK FILE #3.081^3.081^0
261+"BLD",7026,"KRN",.403,"NM","B","MSCZJOBEXAM FILE #3.081",1)
262+
263+"BLD",7026,"KRN",.403,"NM","B","MSCZLOCK FILE #3.081",2)
264+
265+"BLD",7026,"KRN",.5,0)
266+.5
267+"BLD",7026,"KRN",.84,0)
268+.84
269+"BLD",7026,"KRN",3.6,0)
270+3.6
271+"BLD",7026,"KRN",3.8,0)
272+3.8
273+"BLD",7026,"KRN",9.2,0)
274+9.2
275+"BLD",7026,"KRN",9.2,"NM",0)
276+^9.68A^^
277+"BLD",7026,"KRN",9.8,0)
278+9.8
279+"BLD",7026,"KRN",9.8,"NM",0)
280+^9.68A^49^41
281+"BLD",7026,"KRN",9.8,"NM",1,0)
282+MSCZJOB^^0^B11312416
283+"BLD",7026,"KRN",9.8,"NM",4,0)
284+MSCZJOBU^^0^B2386063
285+"BLD",7026,"KRN",9.8,"NM",5,0)
286+ZIS4GTM^^0^B18512871
287+"BLD",7026,"KRN",9.8,"NM",7,0)
288+XTER1A^^0^B29100251
289+"BLD",7026,"KRN",9.8,"NM",8,0)
290+ZU^^0^B9857255
291+"BLD",7026,"KRN",9.8,"NM",11,0)
292+ZCD^^0^B16830436
293+"BLD",7026,"KRN",9.8,"NM",13,0)
294+ZOSV2GTM^^0^B6700455
295+"BLD",7026,"KRN",9.8,"NM",14,0)
296+ZOSFGUX^^0^B22118461
297+"BLD",7026,"KRN",9.8,"NM",15,0)
298+ZISHGUX^^0^B36911880
299+"BLD",7026,"KRN",9.8,"NM",16,0)
300+HLCSTCP1^^0^B29662559
301+"BLD",7026,"KRN",9.8,"NM",17,0)
302+HLCSTCP^^0^B32434118
303+"BLD",7026,"KRN",9.8,"NM",18,0)
304+HLCSLNCH^^0^B37355917
305+"BLD",7026,"KRN",9.8,"NM",19,0)
306+XOBVLL^^0^B18012967
307+"BLD",7026,"KRN",9.8,"NM",20,0)
308+XOBVRH^^0^B13028891
309+"BLD",7026,"KRN",9.8,"NM",21,0)
310+XOBVSKT^^0^B19755798
311+"BLD",7026,"KRN",9.8,"NM",22,0)
312+XOBVTCPL^^0^B13502099
313+"BLD",7026,"KRN",9.8,"NM",23,0)
314+XWBTCPM^^0^B56922128
315+"BLD",7026,"KRN",9.8,"NM",24,0)
316+ZTMGRSET^^0^B54320203
317+"BLD",7026,"KRN",9.8,"NM",25,0)
318+ZISTCPS^^0^B18299533
319+"BLD",7026,"KRN",9.8,"NM",26,0)
320+XPDR^^0^B52133395
321+"BLD",7026,"KRN",9.8,"NM",27,0)
322+ZISFGUX^^1^
323+"BLD",7026,"KRN",9.8,"NM",28,0)
324+ZTER^^0^B39678986
325+"BLD",7026,"KRN",9.8,"NM",29,0)
326+ZSTARTGUX^^0^B140233
327+"BLD",7026,"KRN",9.8,"NM",31,0)
328+MSCXUS3A^^0^B8005003
329+"BLD",7026,"KRN",9.8,"NM",32,0)
330+RORHL7A^^0^B35660209
331+"BLD",7026,"KRN",9.8,"NM",33,0)
332+ZOSVGUX^^0^B1197142
333+"BLD",7026,"KRN",9.8,"NM",34,0)
334+DGMSTAPI^^0^B48539163
335+"BLD",7026,"KRN",9.8,"NM",35,0)
336+GMRCA2^^0^B10634
337+"BLD",7026,"KRN",9.8,"NM",36,0)
338+MAGDMEDL^^0^B3132920
339+"BLD",7026,"KRN",9.8,"NM",37,0)
340+PRCSEA^^0^B66865498
341+"BLD",7026,"KRN",9.8,"NM",38,0)
342+PSBOMH1^^0^B71152392
343+"BLD",7026,"KRN",9.8,"NM",39,0)
344+PSBRPC2^^0^B44967923
345+"BLD",7026,"KRN",9.8,"NM",40,0)
346+PXRMTMED^^0^B9970277
347+"BLD",7026,"KRN",9.8,"NM",41,0)
348+VALMW3^^0^B21033865
349+"BLD",7026,"KRN",9.8,"NM",42,0)
350+XQALSUR1^^0^B29675685
351+"BLD",7026,"KRN",9.8,"NM",43,0)
352+XUMF5AU^^0^B76801793
353+"BLD",7026,"KRN",9.8,"NM",44,0)
354+ZSTOPGUX^^0^B148072
355+"BLD",7026,"KRN",9.8,"NM",46,0)
356+MSCZJOBS^^0^B3252583
357+"BLD",7026,"KRN",9.8,"NM",47,0)
358+ZOSVONT^^0^B23474671
359+"BLD",7026,"KRN",9.8,"NM",48,0)
360+ZISFGTM^^0^B9317180
361+"BLD",7026,"KRN",9.8,"NM",49,0)
362+ZSSGUX^^0^B47435
363+"BLD",7026,"KRN",9.8,"NM","B","DGMSTAPI",34)
364+
365+"BLD",7026,"KRN",9.8,"NM","B","GMRCA2",35)
366+
367+"BLD",7026,"KRN",9.8,"NM","B","HLCSLNCH",18)
368+
369+"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP",17)
370+
371+"BLD",7026,"KRN",9.8,"NM","B","HLCSTCP1",16)
372+
373+"BLD",7026,"KRN",9.8,"NM","B","MAGDMEDL",36)
374+
375+"BLD",7026,"KRN",9.8,"NM","B","MSCXUS3A",31)
376+
377+"BLD",7026,"KRN",9.8,"NM","B","MSCZJOB",1)
378+
379+"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBS",46)
380+
381+"BLD",7026,"KRN",9.8,"NM","B","MSCZJOBU",4)
382+
383+"BLD",7026,"KRN",9.8,"NM","B","PRCSEA",37)
384+
385+"BLD",7026,"KRN",9.8,"NM","B","PSBOMH1",38)
386+
387+"BLD",7026,"KRN",9.8,"NM","B","PSBRPC2",39)
388+
389+"BLD",7026,"KRN",9.8,"NM","B","PXRMTMED",40)
390+
391+"BLD",7026,"KRN",9.8,"NM","B","RORHL7A",32)
392+
393+"BLD",7026,"KRN",9.8,"NM","B","VALMW3",41)
394+
395+"BLD",7026,"KRN",9.8,"NM","B","XOBVLL",19)
396+
397+"BLD",7026,"KRN",9.8,"NM","B","XOBVRH",20)
398+
399+"BLD",7026,"KRN",9.8,"NM","B","XOBVSKT",21)
400+
401+"BLD",7026,"KRN",9.8,"NM","B","XOBVTCPL",22)
402+
403+"BLD",7026,"KRN",9.8,"NM","B","XPDR",26)
404+
405+"BLD",7026,"KRN",9.8,"NM","B","XQALSUR1",42)
406+
407+"BLD",7026,"KRN",9.8,"NM","B","XTER1A",7)
408+
409+"BLD",7026,"KRN",9.8,"NM","B","XUMF5AU",43)
410+
411+"BLD",7026,"KRN",9.8,"NM","B","XWBTCPM",23)
412+
413+"BLD",7026,"KRN",9.8,"NM","B","ZCD",11)
414+
415+"BLD",7026,"KRN",9.8,"NM","B","ZIS4GTM",5)
416+
417+"BLD",7026,"KRN",9.8,"NM","B","ZISFGTM",48)
418+
419+"BLD",7026,"KRN",9.8,"NM","B","ZISFGUX",27)
420+
421+"BLD",7026,"KRN",9.8,"NM","B","ZISHGUX",15)
422+
423+"BLD",7026,"KRN",9.8,"NM","B","ZISTCPS",25)
424+
425+"BLD",7026,"KRN",9.8,"NM","B","ZOSFGUX",14)
426+
427+"BLD",7026,"KRN",9.8,"NM","B","ZOSV2GTM",13)
428+
429+"BLD",7026,"KRN",9.8,"NM","B","ZOSVGUX",33)
430+
431+"BLD",7026,"KRN",9.8,"NM","B","ZOSVONT",47)
432+
433+"BLD",7026,"KRN",9.8,"NM","B","ZSSGUX",49)
434+
435+"BLD",7026,"KRN",9.8,"NM","B","ZSTARTGUX",29)
436+
437+"BLD",7026,"KRN",9.8,"NM","B","ZSTOPGUX",44)
438+
439+"BLD",7026,"KRN",9.8,"NM","B","ZTER",28)
440+
441+"BLD",7026,"KRN",9.8,"NM","B","ZTMGRSET",24)
442+
443+"BLD",7026,"KRN",9.8,"NM","B","ZU",8)
444+
445+"BLD",7026,"KRN",19,0)
446+19
447+"BLD",7026,"KRN",19,"NM",0)
448+^9.68A^2^2
449+"BLD",7026,"KRN",19,"NM",1,0)
450+MSCZJOB^^0
451+"BLD",7026,"KRN",19,"NM",2,0)
452+MSCZLOCK^^0
453+"BLD",7026,"KRN",19,"NM","B","MSCZJOB",1)
454+
455+"BLD",7026,"KRN",19,"NM","B","MSCZLOCK",2)
456+
457+"BLD",7026,"KRN",19.1,0)
458+19.1
459+"BLD",7026,"KRN",101,0)
460+101
461+"BLD",7026,"KRN",409.61,0)
462+409.61
463+"BLD",7026,"KRN",771,0)
464+771
465+"BLD",7026,"KRN",870,0)
466+870
467+"BLD",7026,"KRN",8989.51,0)
468+8989.51
469+"BLD",7026,"KRN",8989.52,0)
470+8989.52
471+"BLD",7026,"KRN",8994,0)
472+8994
473+"BLD",7026,"KRN","B",.4,.4)
474+
475+"BLD",7026,"KRN","B",.401,.401)
476+
477+"BLD",7026,"KRN","B",.402,.402)
478+
479+"BLD",7026,"KRN","B",.403,.403)
480+
481+"BLD",7026,"KRN","B",.5,.5)
482+
483+"BLD",7026,"KRN","B",.84,.84)
484+
485+"BLD",7026,"KRN","B",3.6,3.6)
486+
487+"BLD",7026,"KRN","B",3.8,3.8)
488+
489+"BLD",7026,"KRN","B",9.2,9.2)
490+
491+"BLD",7026,"KRN","B",9.8,9.8)
492+
493+"BLD",7026,"KRN","B",19,19)
494+
495+"BLD",7026,"KRN","B",19.1,19.1)
496+
497+"BLD",7026,"KRN","B",101,101)
498+
499+"BLD",7026,"KRN","B",409.61,409.61)
500+
501+"BLD",7026,"KRN","B",771,771)
502+
503+"BLD",7026,"KRN","B",870,870)
504+
505+"BLD",7026,"KRN","B",8989.51,8989.51)
506+
507+"BLD",7026,"KRN","B",8989.52,8989.52)
508+
509+"BLD",7026,"KRN","B",8994,8994)
510+
511+"BLD",7026,"MSC")
512+/home/jsher/MSC_GTM_INTEG_2.KID
513+"BLD",7026,"MSCOM")
514+VERSION 2 GTM
515+"BLD",7026,"PRE")
516+MSCGUX53
517+"INIT")
518+POSTGTM^ZTMGRSET
519+"KRN",.403,121,-1)
520+0^1
521+"KRN",.403,121,0)
522+MSCZJOBEXAM^ ^@^^3070530.1755^^^3.081^0^1^1
523+"KRN",.403,121,12)
524+
525+"KRN",.403,121,21)
526+
527+"KRN",.403,121,40,0)
528+^.4031I^3^3
529+"KRN",.403,121,40,1,0)
530+1^^1,1^^^1^17,80
531+"KRN",.403,121,40,1,1)
532+Page 1
533+"KRN",.403,121,40,1,40,0)
534+^.4032IP^433^2
535+"KRN",.403,121,40,1,40,432,0)
536+MSCZJOBEXAM^4^3,2^e
537+"KRN",.403,121,40,1,40,432,2)
538+13^^u^^1
539+"KRN",.403,121,40,1,40,432,"COMP MUL")
540+D COMPMUL^MSCZJOB
541+"KRN",.403,121,40,1,40,432,"COMP MUL PTR")
542+
543+"KRN",.403,121,40,1,40,433,0)
544+MSCZJOBEXAM HDR^1^1,2^d
545+"KRN",.403,121,40,2,0)
546+2^^1,1^^^1^18,79
547+"KRN",.403,121,40,2,1)
548+Page 2
549+"KRN",.403,121,40,2,40,0)
550+^.4032IP^437^3
551+"KRN",.403,121,40,2,40,434,0)
552+MSCZJOBEXAM 2^1^1,1^e
553+"KRN",.403,121,40,2,40,435,0)
554+MSCZJOBVARS^3^8,3^e
555+"KRN",.403,121,40,2,40,435,2)
556+9^^f^^1
557+"KRN",.403,121,40,2,40,435,"COMP MUL")
558+D COMPVARS^MSCZJOB
559+"KRN",.403,121,40,2,40,437,0)
560+MSCZJOBSTACK^4^3,3^e
561+"KRN",.403,121,40,2,40,437,2)
562+3^
563+"KRN",.403,121,40,2,40,437,"COMP MUL")
564+D COMPSTK^MSCZJOB
565+"KRN",.403,121,40,3,0)
566+3^^4,4^^^1^15,70
567+"KRN",.403,121,40,3,1)
568+Page 3
569+"KRN",.403,121,40,3,40,0)
570+^.4032IP^436^1
571+"KRN",.403,121,40,3,40,436,0)
572+MSCZJOBLOCKS^1^2,3^e
573+"KRN",.403,121,40,3,40,436,2)
574+6^
575+"KRN",.403,121,40,3,40,436,"COMP MUL")
576+D COMPLKS^MSCZJOB
577+"KRN",.403,121,21400)
578+1
579+"KRN",.403,122,-1)
580+0^2
581+"KRN",.403,122,0)
582+MSCZLOCK^ ^@^^3070530.1755^^^3.081^0^1^1
583+"KRN",.403,122,40,0)
584+^.4031I^1^1
585+"KRN",.403,122,40,1,0)
586+1^^1,1^^^0^17,80
587+"KRN",.403,122,40,1,1)
588+Page 1
589+"KRN",.403,122,40,1,40,0)
590+^.4032IP^439^2
591+"KRN",.403,122,40,1,40,438,0)
592+MSCZLOCKEXAM^4^3,2^e
593+"KRN",.403,122,40,1,40,438,2)
594+13^^u^^1
595+"KRN",.403,122,40,1,40,438,"COMP MUL")
596+D COMPLK^MSCZJOB
597+"KRN",.403,122,40,1,40,439,0)
598+MSCZJOBLOCK HDR^1^1,1^d
599+"KRN",.404,432,0)
600+MSCZJOBEXAM^3.081
601+"KRN",.404,432,40,0)
602+^.4044I^5^5
603+"KRN",.404,432,40,1,0)
604+1^^2^^JOB NUMBER
605+"KRN",.404,432,40,1,2)
606+1,2^6
607+"KRN",.404,432,40,1,3)
608+!M
609+"KRN",.404,432,40,1,3.1)
610+S Y=$$JOB^MSCZJOB(D0) S:Y=$J Y=Y_"*"
611+"KRN",.404,432,40,1,4)
612+^^^2
613+"KRN",.404,432,40,1,10)
614+S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U)
615+"KRN",.404,432,40,1,20)
616+F
617+"KRN",.404,432,40,2,0)
618+2^^2^^DEVICE
619+"KRN",.404,432,40,2,2)
620+1,9^23
621+"KRN",.404,432,40,2,3)
622+!M
623+"KRN",.404,432,40,2,3.1)
624+S Y=$$DEV^MSCZJOB(D0)
625+"KRN",.404,432,40,2,4)
626+^^^1
627+"KRN",.404,432,40,2,20)
628+F
629+"KRN",.404,432,40,3,0)
630+4^^2^^NAMESPACE
631+"KRN",.404,432,40,3,2)
632+1,48^11
633+"KRN",.404,432,40,3,3)
634+!M
635+"KRN",.404,432,40,3,3.1)
636+S Y=$$NSP^MSCZJOB(D0)
637+"KRN",.404,432,40,3,4)
638+^^^1
639+"KRN",.404,432,40,3,20)
640+F
641+"KRN",.404,432,40,4,0)
642+5^^2^^ROUTINE
643+"KRN",.404,432,40,4,2)
644+1,60^18
645+"KRN",.404,432,40,4,3)
646+!M
647+"KRN",.404,432,40,4,3.1)
648+S Y=$$ROUTINE^MSCZJOB(D0)
649+"KRN",.404,432,40,4,4)
650+^^^1
651+"KRN",.404,432,40,4,20)
652+F^U
653+"KRN",.404,432,40,5,0)
654+3^^2^^USER
655+"KRN",.404,432,40,5,2)
656+1,33^14
657+"KRN",.404,432,40,5,3)
658+!M
659+"KRN",.404,432,40,5,3.1)
660+S Y=$$USER^MSCZJOB(D0)
661+"KRN",.404,432,40,5,4)
662+^^^1
663+"KRN",.404,432,40,5,20)
664+F
665+"KRN",.404,433,0)
666+MSCZJOBEXAM HDR^3.081^
667+"KRN",.404,433,40,0)
668+^.4044I^2^2
669+"KRN",.404,433,40,1,0)
670+1^Process Device User Namespace Routine ^1
671+"KRN",.404,433,40,1,2)
672+^^2,1
673+"KRN",.404,433,40,2,0)
674+2^!M^1
675+"KRN",.404,433,40,2,.1)
676+S Y=$$GET1^DIQ(8989.3,1,.01)
677+"KRN",.404,433,40,2,2)
678+^^1,28
679+"KRN",.404,434,0)
680+MSCZJOBEXAM 2^3.081
681+"KRN",.404,434,40,0)
682+^.4044I^7^7
683+"KRN",.404,434,40,1,0)
684+1^Job^2^^JOB NUMBER
685+"KRN",.404,434,40,1,2)
686+2,8^6^2,3
687+"KRN",.404,434,40,1,3)
688+!M
689+"KRN",.404,434,40,1,3.1)
690+S Y=$$JOB^MSCZJOB(MSCJOBD0)
691+"KRN",.404,434,40,1,20)
692+N
693+"KRN",.404,434,40,2,0)
694+2^NSpace^2^^NAMESPACE
695+"KRN",.404,434,40,2,2)
696+2,24^11^2,16
697+"KRN",.404,434,40,2,3)
698+!M
699+"KRN",.404,434,40,2,3.1)
700+S Y=$$NSP^MSCZJOB(MSCJOBD0)
701+"KRN",.404,434,40,2,4)
702+^^^2
703+"KRN",.404,434,40,2,20)
704+F
705+"KRN",.404,434,40,3,0)
706+3^Routine^2
707+"KRN",.404,434,40,3,2)
708+2,46^16^2,37
709+"KRN",.404,434,40,3,3)
710+!M
711+"KRN",.404,434,40,3,3.1)
712+S Y=$$ROUTINE^MSCZJOB(MSCJOBD0)
713+"KRN",.404,434,40,3,4)
714+^^^2
715+"KRN",.404,434,40,3,20)
716+F^U
717+"KRN",.404,434,40,4,0)
718+4^^2^^USER
719+"KRN",.404,434,40,4,2)
720+2,63^14
721+"KRN",.404,434,40,4,3)
722+!M
723+"KRN",.404,434,40,4,3.1)
724+S Y=$$USER^MSCZJOB(MSCJOBD0)
725+"KRN",.404,434,40,4,4)
726+^^^2
727+"KRN",.404,434,40,4,20)
728+F
729+"KRN",.404,434,40,5,0)
730+5^Device^2^^DEVICE
731+"KRN",.404,434,40,5,2)
732+3,24^38^3,16
733+"KRN",.404,434,40,5,3)
734+!M
735+"KRN",.404,434,40,5,3.1)
736+S Y=$$DEV^MSCZJOB(MSCJOBD0)
737+"KRN",.404,434,40,5,4)
738+^^^1
739+"KRN",.404,434,40,5,20)
740+F^U
741+"KRN",.404,434,40,6,0)
742+4.4^LOCKs^2^^LOCKS
743+"KRN",.404,434,40,6,2)
744+3,10^3^3,3
745+"KRN",.404,434,40,6,3)
746+!M
747+"KRN",.404,434,40,6,3.1)
748+S Y=$$LOCKS^MSCZJOB
749+"KRN",.404,434,40,6,10)
750+S DDSSTACK=3
751+"KRN",.404,434,40,6,20)
752+N
753+"KRN",.404,434,40,7,0)
754+6^KILL JOB?^2^^KILL
755+"KRN",.404,434,40,7,2)
756+3,74^3^3,63
757+"KRN",.404,434,40,7,13)
758+N X,Y I DDSEXT="YES" D KILL^MSCZJOB(MSCJOBID)
759+"KRN",.404,434,40,7,20)
760+Y
761+"KRN",.404,435,0)
762+MSCZJOBVARS^3.081
763+"KRN",.404,435,40,0)
764+^.4044I^3^3
765+"KRN",.404,435,40,1,0)
766+1^^2^^VARIABLE NAME
767+"KRN",.404,435,40,1,2)
768+1,1^24
769+"KRN",.404,435,40,1,3)
770+!M
771+"KRN",.404,435,40,1,3.1)
772+S Y=$P(@MSC@(MSCJOBID,"V",D0),"=")
773+"KRN",.404,435,40,1,4)
774+^^^2
775+"KRN",.404,435,40,1,20)
776+F
777+"KRN",.404,435,40,2,0)
778+2^^2^^VALUE OF VARIABLE
779+"KRN",.404,435,40,2,2)
780+1,28^48
781+"KRN",.404,435,40,2,3)
782+!M
783+"KRN",.404,435,40,2,3.1)
784+S Y=$P(@MSC@(MSCJOBID,"V",D0),"=",2,999)
785+"KRN",.404,435,40,2,4)
786+^^^2
787+"KRN",.404,435,40,2,20)
788+F^U
789+"KRN",.404,435,40,3,0)
790+1.5^=^1
791+"KRN",.404,435,40,3,2)
792+^^1,26
793+"KRN",.404,436,0)
794+MSCZJOBLOCKS^3.081^
795+"KRN",.404,436,40,0)
796+^.4044I^2^2
797+"KRN",.404,436,40,1,0)
798+1^^2^^LOCKS
799+"KRN",.404,436,40,1,2)
800+2,1^47
801+"KRN",.404,436,40,1,3)
802+!M
803+"KRN",.404,436,40,1,3.1)
804+S Y=@MSC@(MSCJOBID,"L",D0)
805+"KRN",.404,436,40,1,4)
806+^^^2
807+"KRN",.404,436,40,1,20)
808+F^U
809+"KRN",.404,436,40,2,0)
810+2^UNLOCK?^2^^UNLOCK
811+"KRN",.404,436,40,2,2)
812+2,58^3^2,49^1
813+"KRN",.404,436,40,2,13)
814+I DDSEXT="YES" D UNLOCK^MSCZJOB(D0)
815+"KRN",.404,436,40,2,20)
816+Y
817+"KRN",.404,437,0)
818+MSCZJOBSTACK^3.081
819+"KRN",.404,437,40,0)
820+^.4044I^1^1
821+"KRN",.404,437,40,1,0)
822+1^^2^^STACK
823+"KRN",.404,437,40,1,2)
824+2,1^75
825+"KRN",.404,437,40,1,3)
826+!M
827+"KRN",.404,437,40,1,3.1)
828+S Y=$$STACK^MSCZJOB(D0)
829+"KRN",.404,437,40,1,4)
830+^^^2
831+"KRN",.404,437,40,1,20)
832+F^U
833+"KRN",.404,438,0)
834+MSCZLOCKEXAM^3.081
835+"KRN",.404,438,40,0)
836+^.4044I^5^5
837+"KRN",.404,438,40,1,0)
838+1^^2^^JOB NUMBER
839+"KRN",.404,438,40,1,2)
840+1,2^6
841+"KRN",.404,438,40,1,3)
842+!M
843+"KRN",.404,438,40,1,3.1)
844+S Y=$P($G(MSCZLK(D0)),U,5) S:Y=$J Y=Y_"*"
845+"KRN",.404,438,40,1,4)
846+^^^2
847+"KRN",.404,438,40,1,10)
848+S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U)
849+"KRN",.404,438,40,1,20)
850+F
851+"KRN",.404,438,40,2,0)
852+2^^2^^LOCK
853+"KRN",.404,438,40,2,2)
854+1,9^23
855+"KRN",.404,438,40,2,3)
856+!M
857+"KRN",.404,438,40,2,3.1)
858+S Y=$TR($P($G(MSCZLK(D0)),U),"~")
859+"KRN",.404,438,40,2,4)
860+^^^1
861+"KRN",.404,438,40,2,20)
862+F
863+"KRN",.404,438,40,3,0)
864+4^^2^^ROUTINE
865+"KRN",.404,438,40,3,2)
866+1,48^25
867+"KRN",.404,438,40,3,3)
868+!M
869+"KRN",.404,438,40,3,3.1)
870+S Y=$TR($P($G(MSCZLK(D0)),U,3),$C(126),U)
871+"KRN",.404,438,40,3,4)
872+^^^1
873+"KRN",.404,438,40,3,20)
874+F^U
875+"KRN",.404,438,40,4,0)
876+5^^2^^UNLOCK
877+"KRN",.404,438,40,4,2)
878+1,76^3
879+"KRN",.404,438,40,4,3)
880+!M
881+"KRN",.404,438,40,4,4)
882+^^^0
883+"KRN",.404,438,40,4,13)
884+I DDSEXT="YES" D UNL^MSCZJOB(D0)
885+"KRN",.404,438,40,4,20)
886+Y^U
887+"KRN",.404,438,40,5,0)
888+3^^2^^USER
889+"KRN",.404,438,40,5,2)
890+1,33^14
891+"KRN",.404,438,40,5,3)
892+!M
893+"KRN",.404,438,40,5,3.1)
894+S Y=$P($G(MSCZLK(D0)),U,2)
895+"KRN",.404,438,40,5,4)
896+^^^1
897+"KRN",.404,438,40,5,20)
898+F
899+"KRN",.404,439,0)
900+MSCZJOBLOCK HDR^3.081
901+"KRN",.404,439,40,0)
902+^.4044I^2^2
903+"KRN",.404,439,40,1,0)
904+1^Process Lock User Routine Unlock^1
905+"KRN",.404,439,40,1,2)
906+^^2,1
907+"KRN",.404,439,40,2,0)
908+2^!M^1
909+"KRN",.404,439,40,2,.1)
910+S Y=$$GET1^DIQ(8989.3,1,.01)
911+"KRN",.404,439,40,2,2)
912+^^1,28
913+"KRN",19,14339,-1)
914+0^1
915+"KRN",19,14339,0)
916+MSCZJOB^JOB EXAMINE^^R^^^^^^^^
917+"KRN",19,14339,1,0)
918+^^1^1^3070623^
919+"KRN",19,14339,1,1,0)
920+DESIGNED FOR GT.M
921+"KRN",19,14339,25)
922+MSCZJOB
923+"KRN",19,14339,"U")
924+JOB EXAMINE
925+"KRN",19,14340,-1)
926+0^2
927+"KRN",19,14340,0)
928+MSCZLOCK^LOCK EXAMINE^^R^^^^^^^^
929+"KRN",19,14340,1,0)
930+^^1^1^3070623^
931+"KRN",19,14340,1,1,0)
932+DESIGNED FOR GT.M
933+"KRN",19,14340,25)
934+LOCK^MSCZJOB
935+"KRN",19,14340,"U")
936+LOCK EXAMINE
937+"MBREQ")
938+0
939+"ORD",0,9.8)
940+9.8;;1;RTNF^XPDTA;RTNE^XPDTA
941+"ORD",0,9.8,0)
942+ROUTINE
943+"ORD",8,.403)
944+.403;8;;;EDEOUT^DIFROMSO(.403,DA,"",XPDA);FPRE^DIFROMSI(.403,"",XPDA);EPRE^DIFROMSI(.403,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.403,DA,"",XPDA);DEL^DIFROMSK(.403,"",%)
945+"ORD",8,.403,0)
946+FORM
947+"ORD",18,19)
948+19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
949+"ORD",18,19,0)
950+OPTION
951+"PRE")
952+MSCGUX53
953+"QUES","XPF1",0)
954+Y
955+"QUES","XPF1","??")
956+^D REP^XPDH
957+"QUES","XPF1","A")
958+Shall I write over your |FLAG| File
959+"QUES","XPF1","B")
960+YES
961+"QUES","XPF1","M")
962+D XPF1^XPDIQ
963+"QUES","XPF2",0)
964+Y
965+"QUES","XPF2","??")
966+^D DTA^XPDH
967+"QUES","XPF2","A")
968+Want my data |FLAG| yours
969+"QUES","XPF2","B")
970+YES
971+"QUES","XPF2","M")
972+D XPF2^XPDIQ
973+"QUES","XPI1",0)
974+YO
975+"QUES","XPI1","??")
976+^D INHIBIT^XPDH
977+"QUES","XPI1","A")
978+Want KIDS to INHIBIT LOGONs during the install
979+"QUES","XPI1","B")
980+NO
981+"QUES","XPI1","M")
982+D XPI1^XPDIQ
983+"QUES","XPM1",0)
984+PO^VA(200,:EM
985+"QUES","XPM1","??")
986+^D MG^XPDH
987+"QUES","XPM1","A")
988+Enter the Coordinator for Mail Group '|FLAG|'
989+"QUES","XPM1","B")
990+
991+"QUES","XPM1","M")
992+D XPM1^XPDIQ
993+"QUES","XPO1",0)
994+Y
995+"QUES","XPO1","??")
996+^D MENU^XPDH
997+"QUES","XPO1","A")
998+Want KIDS to Rebuild Menu Trees Upon Completion of Install
999+"QUES","XPO1","B")
1000+NO
1001+"QUES","XPO1","M")
1002+D XPO1^XPDIQ
1003+"QUES","XPZ1",0)
1004+Y
1005+"QUES","XPZ1","??")
1006+^D OPT^XPDH
1007+"QUES","XPZ1","A")
1008+Want to DISABLE Scheduled Options, Menu Options, and Protocols
1009+"QUES","XPZ1","B")
1010+NO
1011+"QUES","XPZ1","M")
1012+D XPZ1^XPDIQ
1013+"QUES","XPZ2",0)
1014+Y
1015+"QUES","XPZ2","??")
1016+^D RTN^XPDH
1017+"QUES","XPZ2","A")
1018+Want to MOVE routines to other CPUs
1019+"QUES","XPZ2","B")
1020+NO
1021+"QUES","XPZ2","M")
1022+D XPZ2^XPDIQ
1023+"RTN")
1024+42
1025+"RTN","DGMSTAPI")
1026+0^34^B48539163
1027+"RTN","DGMSTAPI",1,0)
1028+DGMSTAPI ;ALB/SCK,MSC/JDA - API's for Military Sexual Trauma ;29APR2009
1029+"RTN","DGMSTAPI",2,0)
1030+ ;;5.3;Registration;**195,243,308,353,379,443,700,JDA**;Aug 13, 1993
1031+"RTN","DGMSTAPI",3,0)
1032+ Q
1033+"RTN","DGMSTAPI",4,0)
1034+ ;
1035+"RTN","DGMSTAPI",5,0)
1036+GETSTAT(DFN,DGDATE) ; Retrieves the current MST status for a patient
1037+"RTN","DGMSTAPI",6,0)
1038+ ;
1039+"RTN","DGMSTAPI",7,0)
1040+ ; Input
1041+"RTN","DGMSTAPI",8,0)
1042+ ; DFN - IEN of patient in the PATIENT File (#2)
1043+"RTN","DGMSTAPI",9,0)
1044+ ; DGDATE - Date for status lookup [OPTIONAL]
1045+"RTN","DGMSTAPI",10,0)
1046+ ;
1047+"RTN","DGMSTAPI",11,0)
1048+ ; Output
1049+"RTN","DGMSTAPI",12,0)
1050+ ; DGMST - Format will depend on result of lookup
1051+"RTN","DGMSTAPI",13,0)
1052+ ;
1053+"RTN","DGMSTAPI",14,0)
1054+ ; If an entry is found then:
1055+"RTN","DGMSTAPI",15,0)
1056+ ; DGMST returns a 7 piece data string, caret(^)-delimited:
1057+"RTN","DGMSTAPI",16,0)
1058+ ; $P(1) = IEN of entry in MST HISTORY File (#29.11)
1059+"RTN","DGMSTAPI",17,0)
1060+ ; $P(2) = Internal value of MST Status ("Y,N,D,U")
1061+"RTN","DGMSTAPI",18,0)
1062+ ; $P(3) = Date of status change
1063+"RTN","DGMSTAPI",19,0)
1064+ ; $P(4) = IEN of provider making determination, file (#200)
1065+"RTN","DGMSTAPI",20,0)
1066+ ; $P(5) = IEN of user who entered status, file (#200)
1067+"RTN","DGMSTAPI",21,0)
1068+ ; $P(6) = External format of MST Status
1069+"RTN","DGMSTAPI",22,0)
1070+ ; $P(7) = IEN pointer of the INSTITUTION file (#4)
1071+"RTN","DGMSTAPI",23,0)
1072+ ;
1073+"RTN","DGMSTAPI",24,0)
1074+ ; If no MST History is found, then:
1075+"RTN","DGMSTAPI",25,0)
1076+ ; DGMST = 0^U
1077+"RTN","DGMSTAPI",26,0)
1078+ ; "U" = (Unknown)
1079+"RTN","DGMSTAPI",27,0)
1080+ ; If an error occured in the GETS^DIQ lookup, then:
1081+"RTN","DGMSTAPI",28,0)
1082+ ; DGMST = -1^^Error Code IEN
1083+"RTN","DGMSTAPI",29,0)
1084+ ; (returned by GETS^DIQ call)
1085+"RTN","DGMSTAPI",30,0)
1086+ ;
1087+"RTN","DGMSTAPI",31,0)
1088+ ; Get most recent MST status entry for the patient from file using
1089+"RTN","DGMSTAPI",32,0)
1090+ ; reverse $Order on the "APDT" x-ref.
1091+"RTN","DGMSTAPI",33,0)
1092+ ;
1093+"RTN","DGMSTAPI",34,0)
1094+ N DGMST,DGIEN,DGFDA,DGMSG
1095+"RTN","DGMSTAPI",35,0)
1096+ S DFN=$G(DFN)
1097+"RTN","DGMSTAPI",36,0)
1098+ I '+DFN!('$D(^DPT(DFN,0))) D G STATQ
1099+"RTN","DGMSTAPI",37,0)
1100+ . S DGMST="-1"
1101+"RTN","DGMSTAPI",38,0)
1102+ I '$D(^DGMS(29.11,"APDT",DFN)) D G STATQ
1103+"RTN","DGMSTAPI",39,0)
1104+ .S DGMST="0^U"
1105+"RTN","DGMSTAPI",40,0)
1106+ S DGDATE=$S(+$G(DGDATE)>0:DGDATE,1:$$NOW^XLFDT)
1107+"RTN","DGMSTAPI",41,0)
1108+ I '$D(^DGMS(29.11,"APDT",DFN,DGDATE)) S DGDATE=$$DATE(DFN,DGDATE)
1109+"RTN","DGMSTAPI",42,0)
1110+ I '+DGDATE D G STATQ
1111+"RTN","DGMSTAPI",43,0)
1112+ . S DGMST="0^U"
1113+"RTN","DGMSTAPI",44,0)
1114+ S DGIEN=""
1115+"RTN","DGMSTAPI",45,0)
1116+ S DGIEN=+$O(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1)
1117+"RTN","DGMSTAPI",46,0)
1118+ ;
1119+"RTN","DGMSTAPI",47,0)
1120+ ; Check for valid ien, if entry missing, return Unknown
1121+"RTN","DGMSTAPI",48,0)
1122+ I +DGIEN'>0 D G STATQ
1123+"RTN","DGMSTAPI",49,0)
1124+ . S DGMST="0^U"
1125+"RTN","DGMSTAPI",50,0)
1126+ ;
1127+"RTN","DGMSTAPI",51,0)
1128+ ; Retrieve data
1129+"RTN","DGMSTAPI",52,0)
1130+ D GETS^DIQ(29.11,+DGIEN_",","*","IE","DGFDA","DGMSG")
1131+"RTN","DGMSTAPI",53,0)
1132+ ; check for errors
1133+"RTN","DGMSTAPI",54,0)
1134+ I $D(DGMSG) D G STATQ
1135+"RTN","DGMSTAPI",55,0)
1136+ .S DGMST="-1^^"_$G(DGMSG("DIERR",1))
1137+"RTN","DGMSTAPI",56,0)
1138+ ;
1139+"RTN","DGMSTAPI",57,0)
1140+ S DGMST=DGIEN_U_$G(DGFDA(29.11,+DGIEN_",",3,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",.01,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",4,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",5,"I"))
1141+"RTN","DGMSTAPI",58,0)
1142+ S DGMST=DGMST_U_$G(DGFDA(29.11,+DGIEN_",",3,"E"))
1143+"RTN","DGMSTAPI",59,0)
1144+ S DGMST=DGMST_U_$S($G(DGFDA(29.11,+DGIEN_",",6,"I"))]"":$G(DGFDA(29.11,+DGIEN_",",6,"I")),1:$$SITE)
1145+"RTN","DGMSTAPI",60,0)
1146+ ;
1147+"RTN","DGMSTAPI",61,0)
1148+STATQ Q $G(DGMST)
1149+"RTN","DGMSTAPI",62,0)
1150+ ;
1151+"RTN","DGMSTAPI",63,0)
1152+NEWSTAT(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGXMIT) ; MST HISTORY (#29.11) filer
1153+"RTN","DGMSTAPI",64,0)
1154+ ; Callpoint to create a new MST HISTORY FILE (#29.11) entry.
1155+"RTN","DGMSTAPI",65,0)
1156+ ; Will also queue HL7 message for HEC database updates.
1157+"RTN","DGMSTAPI",66,0)
1158+ ;
1159+"RTN","DGMSTAPI",67,0)
1160+ ; Input
1161+"RTN","DGMSTAPI",68,0)
1162+ ; DFN - Patients DFN
1163+"RTN","DGMSTAPI",69,0)
1164+ ; DGSTAT - MST Status code, "Y,N,D,U"
1165+"RTN","DGMSTAPI",70,0)
1166+ ; DGDATE - Date of MST status change [default=NOW]
1167+"RTN","DGMSTAPI",71,0)
1168+ ; DGPROV - IEN of Provider making determination, file (#200)
1169+"RTN","DGMSTAPI",72,0)
1170+ ; DGSITE - IEN pointer of the INSTITUTION file (#4)
1171+"RTN","DGMSTAPI",73,0)
1172+ ; DGXMIT - HL7 transmit flag [OPTIONAL]
1173+"RTN","DGMSTAPI",74,0)
1174+ ; 0=don't queue a message
1175+"RTN","DGMSTAPI",75,0)
1176+ ; 1=queue a message [default])
1177+"RTN","DGMSTAPI",76,0)
1178+ ;
1179+"RTN","DGMSTAPI",77,0)
1180+ ; Output
1181+"RTN","DGMSTAPI",78,0)
1182+ ; DGRSLT - Returns IEN of file (#29.11) entry if successful
1183+"RTN","DGMSTAPI",79,0)
1184+ ;
1185+"RTN","DGMSTAPI",80,0)
1186+ ; If no patient was defined, then:
1187+"RTN","DGMSTAPI",81,0)
1188+ ; DGRSLT = -1^No patient defined
1189+"RTN","DGMSTAPI",82,0)
1190+ ;
1191+"RTN","DGMSTAPI",83,0)
1192+ ; If an error occured in the GETS^DIQ lookup, then:
1193+"RTN","DGMSTAPI",84,0)
1194+ ; DGMST = -1^^Error Code IEN
1195+"RTN","DGMSTAPI",85,0)
1196+ ; (returned by GETS^DIQ call)
1197+"RTN","DGMSTAPI",86,0)
1198+ ;
1199+"RTN","DGMSTAPI",87,0)
1200+ N DGFDA,DGMSG,DGERR,DGRSLT,MSTIEN
1201+"RTN","DGMSTAPI",88,0)
1202+ S DFN=$G(DFN)
1203+"RTN","DGMSTAPI",89,0)
1204+ I DFN']""!('$D(^DPT(DFN,0))) D G NEWQ
1205+"RTN","DGMSTAPI",90,0)
1206+ . S DGRSLT="-1^No patient defined"
1207+"RTN","DGMSTAPI",91,0)
1208+ ;
1209+"RTN","DGMSTAPI",92,0)
1210+ S DGSTAT=$S($G(DGSTAT)]"":DGSTAT,1:"U")
1211+"RTN","DGMSTAPI",93,0)
1212+ S DGDATE=$G(DGDATE)
1213+"RTN","DGMSTAPI",94,0)
1214+ S DGPROV=$G(DGPROV)
1215+"RTN","DGMSTAPI",95,0)
1216+ S DGSITE=$G(DGSITE)
1217+"RTN","DGMSTAPI",96,0)
1218+ S DGXMIT=$S($G(DGXMIT)=0:DGXMIT,1:1)
1219+"RTN","DGMSTAPI",97,0)
1220+ S DGDATE=$S(+DGDATE>0:DGDATE,1:$$NOW^XLFDT)
1221+"RTN","DGMSTAPI",98,0)
1222+ S DGSITE=$S(+DGSITE>0:DGSITE,1:$$SITE)
1223+"RTN","DGMSTAPI",99,0)
1224+ ;
1225+"RTN","DGMSTAPI",100,0)
1226+ I '$$CHANGE(DFN,DGSTAT,DGDATE) D G NEWQ
1227+"RTN","DGMSTAPI",101,0)
1228+ . S DGRSLT="0"
1229+"RTN","DGMSTAPI",102,0)
1230+ ;
1231+"RTN","DGMSTAPI",103,0)
1232+ I '$$VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,.DGERR) D G NEWQ
1233+"RTN","DGMSTAPI",104,0)
1234+ . S DGRSLT="-1^"_DGERR
1235+"RTN","DGMSTAPI",105,0)
1236+ ;
1237+"RTN","DGMSTAPI",106,0)
1238+ S DGFDA(1,29.11,"+1,",.01)=DGDATE
1239+"RTN","DGMSTAPI",107,0)
1240+ S DGFDA(1,29.11,"+1,",2)=DFN
1241+"RTN","DGMSTAPI",108,0)
1242+ S DGFDA(1,29.11,"+1,",3)=DGSTAT
1243+"RTN","DGMSTAPI",109,0)
1244+ S DGFDA(1,29.11,"+1,",4)=DGPROV
1245+"RTN","DGMSTAPI",110,0)
1246+ S DGFDA(1,29.11,"+1,",5)=DUZ
1247+"RTN","DGMSTAPI",111,0)
1248+ S DGFDA(1,29.11,"+1,",6)=DGSITE
1249+"RTN","DGMSTAPI",112,0)
1250+ ;
1251+"RTN","DGMSTAPI",113,0)
1252+ D UPDATE^DIE("","DGFDA(1)","MSTIEN","DGERR")
1253+"RTN","DGMSTAPI",114,0)
1254+ I $D(DGERR) D G NEWQ
1255+"RTN","DGMSTAPI",115,0)
1256+ . S DGRSLT="-1^"_$G(DGERR("DIERR",1))
1257+"RTN","DGMSTAPI",116,0)
1258+ ;
1259+"RTN","DGMSTAPI",117,0)
1260+ S DGRSLT=+MSTIEN(1)
1261+"RTN","DGMSTAPI",118,0)
1262+ ;
1263+"RTN","DGMSTAPI",119,0)
1264+ ; Callpoint to queue an entry that will trigger a HEC
1265+"RTN","DGMSTAPI",120,0)
1266+ ; Enrollment Full Data Transmission (ORF/ORU~ZO7) HL7 message.
1267+"RTN","DGMSTAPI",121,0)
1268+ ; The HL7 message will contain the following three MST data elments
1269+"RTN","DGMSTAPI",122,0)
1270+ ; as part of the VA-Specific Eligibility ZEL segment:
1271+"RTN","DGMSTAPI",123,0)
1272+ ; (23) - MST STATUS
1273+"RTN","DGMSTAPI",124,0)
1274+ ; (24) - DATE MST STATUS CHANGED
1275+"RTN","DGMSTAPI",125,0)
1276+ ; (25) - SITE DETERMINING MST STATUS
1277+"RTN","DGMSTAPI",126,0)
1278+ ;
1279+"RTN","DGMSTAPI",127,0)
1280+ I DGXMIT D
1281+"RTN","DGMSTAPI",128,0)
1282+ . D SEND^DGMSTL1(DFN,"Z07")
1283+"RTN","DGMSTAPI",129,0)
1284+ ;
1285+"RTN","DGMSTAPI",130,0)
1286+NEWQ Q $G(DGRSLT)
1287+"RTN","DGMSTAPI",131,0)
1288+ ;
1289+"RTN","DGMSTAPI",132,0)
1290+DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in.
1291+"RTN","DGMSTAPI",133,0)
1292+ ; This call is not to be used except from inside the DG MST List
1293+"RTN","DGMSTAPI",134,0)
1294+ ; Manager interface.
1295+"RTN","DGMSTAPI",135,0)
1296+ ;
1297+"RTN","DGMSTAPI",136,0)
1298+ ; Input
1299+"RTN","DGMSTAPI",137,0)
1300+ ; MSTIEN - IEN of the entry in the MST HISTORY File (#29.11)
1301+"RTN","DGMSTAPI",138,0)
1302+ ;
1303+"RTN","DGMSTAPI",139,0)
1304+ ; Output
1305+"RTN","DGMSTAPI",140,0)
1306+ ; If no IEN passed in, return -1
1307+"RTN","DGMSTAPI",141,0)
1308+ ; otherwise return 1
1309+"RTN","DGMSTAPI",142,0)
1310+ ;
1311+"RTN","DGMSTAPI",143,0)
1312+ Q:'$G(MSTIEN) "-1^No entry to delete"
1313+"RTN","DGMSTAPI",144,0)
1314+ ;
1315+"RTN","DGMSTAPI",145,0)
1316+ N DA,XD
1317+"RTN","DGMSTAPI",146,0)
1318+ S DA=+$G(MSTIEN)
1319+"RTN","DGMSTAPI",147,0)
1320+ S DIK="^DGMS(29.11,"
1321+"RTN","DGMSTAPI",148,0)
1322+ D ^DIK K DIK
1323+"RTN","DGMSTAPI",149,0)
1324+ Q 1
1325+"RTN","DGMSTAPI",150,0)
1326+ ;
1327+"RTN","DGMSTAPI",151,0)
1328+NAME(DA) ; Returns name from the VA NEW PERSON File using DIQ call
1329+"RTN","DGMSTAPI",152,0)
1330+ ;
1331+"RTN","DGMSTAPI",153,0)
1332+ N DGNAME,DGPROV,DIQ,DR,DIC
1333+"RTN","DGMSTAPI",154,0)
1334+ I $G(DA)="" G NAMEQ
1335+"RTN","DGMSTAPI",155,0)
1336+ S DIC=200,DR=".01",DIQ="DGPROV"
1337+"RTN","DGMSTAPI",156,0)
1338+ D EN^DIQ1
1339+"RTN","DGMSTAPI",157,0)
1340+ S DGNAME=$G(DGPROV(200,DA,.01))
1341+"RTN","DGMSTAPI",158,0)
1342+NAMEQ Q $G(DGNAME)
1343+"RTN","DGMSTAPI",159,0)
1344+ ;
1345+"RTN","DGMSTAPI",160,0)
1346+CHANGE(DFN,DGSTAT,DGDATE) ;Did the Status OR Date change?
1347+"RTN","DGMSTAPI",161,0)
1348+ ; Input
1349+"RTN","DGMSTAPI",162,0)
1350+ ; DFN - Patients DFN
1351+"RTN","DGMSTAPI",163,0)
1352+ ; DGSTAT - MST Status code, "Y,N,D,U"
1353+"RTN","DGMSTAPI",164,0)
1354+ ; DGDATE - Date of MST Status Change (FM format)
1355+"RTN","DGMSTAPI",165,0)
1356+ ;
1357+"RTN","DGMSTAPI",166,0)
1358+ ; Output
1359+"RTN","DGMSTAPI",167,0)
1360+ ; Returns 0 if no status change
1361+"RTN","DGMSTAPI",168,0)
1362+ ; 1 if status changed
1363+"RTN","DGMSTAPI",169,0)
1364+ ;
1365+"RTN","DGMSTAPI",170,0)
1366+ N DGCHG,DGMST
1367+"RTN","DGMSTAPI",171,0)
1368+ S DGCHG=0
1369+"RTN","DGMSTAPI",172,0)
1370+ I +$G(DFN)'>0!('$D(^DPT(DFN,0))) G CHNGQ
1371+"RTN","DGMSTAPI",173,0)
1372+ S DGSTAT=$G(DGSTAT)
1373+"RTN","DGMSTAPI",174,0)
1374+ I DGSTAT'?1A!("YNDU"'[DGSTAT) G CHNGQ
1375+"RTN","DGMSTAPI",175,0)
1376+ S DGDATE=$G(DGDATE)
1377+"RTN","DGMSTAPI",176,0)
1378+ I DGDATE="" G CHNGQ
1379+"RTN","DGMSTAPI",177,0)
1380+ S DGMST=$$GETSTAT(DFN),DGMST=$G(DGMST)
1381+"RTN","DGMSTAPI",178,0)
1382+ I +DGMST<1!($P(DGMST,U,2)'=$G(DGSTAT))!($P(DGMST,U,3)'=$G(DGDATE)) S DGCHG=1
1383+"RTN","DGMSTAPI",179,0)
1384+CHNGQ Q DGCHG
1385+"RTN","DGMSTAPI",180,0)
1386+ ;
1387+"RTN","DGMSTAPI",181,0)
1388+SITE(DGSITE) ;Convert a station number into a pointer to the
1389+"RTN","DGMSTAPI",182,0)
1390+ ; INSTITUTION file (#4). If called with a null parameter then
1391+"RTN","DGMSTAPI",183,0)
1392+ ; the pointer to the INSTITUTION file (#4) of the primary site
1393+"RTN","DGMSTAPI",184,0)
1394+ ; will be returned.
1395+"RTN","DGMSTAPI",185,0)
1396+ ;
1397+"RTN","DGMSTAPI",186,0)
1398+ ; Input
1399+"RTN","DGMSTAPI",187,0)
1400+ ; DGSITE - Station number (optional)
1401+"RTN","DGMSTAPI",188,0)
1402+ ;
1403+"RTN","DGMSTAPI",189,0)
1404+ ; Output
1405+"RTN","DGMSTAPI",190,0)
1406+ ; Return Site IEN to INSTITUTION file (#4)
1407+"RTN","DGMSTAPI",191,0)
1408+ ;
1409+"RTN","DGMSTAPI",192,0)
1410+ S DGSITE=$G(DGSITE)
1411+"RTN","DGMSTAPI",193,0)
1412+ I DGSITE]"",$D(^DIC(4,"D",DGSITE)) D
1413+"RTN","DGMSTAPI",194,0)
1414+ . S DGSITE=$O(^DIC(4,"D",DGSITE,0))
1415+"RTN","DGMSTAPI",195,0)
1416+ E D
1417+"RTN","DGMSTAPI",196,0)
1418+ . S DGSITE=$P($$SITE^VASITE,U)
1419+"RTN","DGMSTAPI",197,0)
1420+ I +DGSITE'>0 S DGSITE=""
1421+"RTN","DGMSTAPI",198,0)
1422+ Q DGSITE
1423+"RTN","DGMSTAPI",199,0)
1424+ ;
1425+"RTN","DGMSTAPI",200,0)
1426+DATE(DFN,DGDT) ;Determine 'current' MST date
1427+"RTN","DGMSTAPI",201,0)
1428+ ;
1429+"RTN","DGMSTAPI",202,0)
1430+ ; Input
1431+"RTN","DGMSTAPI",203,0)
1432+ ; DFN - Patient's DFN
1433+"RTN","DGMSTAPI",204,0)
1434+ ; DGDT - FileMan format date
1435+"RTN","DGMSTAPI",205,0)
1436+ ;
1437+"RTN","DGMSTAPI",206,0)
1438+ ; Output
1439+"RTN","DGMSTAPI",207,0)
1440+ ; Return MST effective date
1441+"RTN","DGMSTAPI",208,0)
1442+ ;
1443+"RTN","DGMSTAPI",209,0)
1444+ N DGMSTDT
1445+"RTN","DGMSTAPI",210,0)
1446+ S DFN=$G(DFN)
1447+"RTN","DGMSTAPI",211,0)
1448+ I '+DFN D G DATEQ
1449+"RTN","DGMSTAPI",212,0)
1450+ . S DGMSTDT=""
1451+"RTN","DGMSTAPI",213,0)
1452+ S DGDT=$S(+$G(DGDT)>0:DGDT,1:$$NOW^XLFDT)
1453+"RTN","DGMSTAPI",214,0)
1454+ I $P(DGDT,".",2)="" S DGDT=DGDT_".999999"
1455+"RTN","DGMSTAPI",215,0)
1456+ S DGMSTDT=$O(^DGMS(29.11,"APDT",DFN,DGDT),-1)
1457+"RTN","DGMSTAPI",216,0)
1458+DATEQ Q DGMSTDT
1459+"RTN","DGMSTAPI",217,0)
1460+ ;
1461+"RTN","DGMSTAPI",218,0)
1462+VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGERR) ;Validate fields before filing
1463+"RTN","DGMSTAPI",219,0)
1464+ ; Input:
1465+"RTN","DGMSTAPI",220,0)
1466+ ; DFN - [REQUIRED] - ien of Patient
1467+"RTN","DGMSTAPI",221,0)
1468+ ; DGSTAT - [REQUIRED] - MST Status code, "Y,N,D,U"
1469+"RTN","DGMSTAPI",222,0)
1470+ ; DGDATE - [REQUIRED] - Date of MST status change[FileMan Internal]
1471+"RTN","DGMSTAPI",223,0)
1472+ ; DGPROV - [optional] - IEN of Provider making determination
1473+"RTN","DGMSTAPI",224,0)
1474+ ; DGSITE - [optional] - IEN pointer of the INSTITUTION file
1475+"RTN","DGMSTAPI",225,0)
1476+ ; DGERR - [optional] - error parameter passed by reference
1477+"RTN","DGMSTAPI",226,0)
1478+ ; Output:
1479+"RTN","DGMSTAPI",227,0)
1480+ ; Function Value - Returns 1 - if validation checks passed
1481+"RTN","DGMSTAPI",228,0)
1482+ ; 0 - if validation checks failed
1483+"RTN","DGMSTAPI",229,0)
1484+ ; DGERR - an error message if validation checks fail
1485+"RTN","DGMSTAPI",230,0)
1486+ ; init variables
1487+"RTN","DGMSTAPI",231,0)
1488+ N I,DGFILE,DGFLD,DGMSG,DGSTR,DGVAL,DGVAR,DGX,VALID
1489+"RTN","DGMSTAPI",232,0)
1490+ S DGFILE=29.11,VALID=1,DGMSG=" IS REQUIRED"
1491+"RTN","DGMSTAPI",233,0)
1492+ ; Quit DO block if invalid condition found
1493+"RTN","DGMSTAPI",234,0)
1494+ ; Check for [REQUIRED] fields
1495+"RTN","DGMSTAPI",235,0)
1496+ D
1497+"RTN","DGMSTAPI",236,0)
1498+ . I DFN="" D MSG(DGFILE,2,DGMSG,.DGERR) Q ;pat ien
1499+"RTN","DGMSTAPI",237,0)
1500+ . I DGSTAT="" D MSG(DGFILE,3,DGMSG,.DGERR) Q ;mst status code
1501+"RTN","DGMSTAPI",238,0)
1502+ . I DGDATE="" D MSG(DGFILE,.01,DGMSG,.DGERR) Q ;dt chg status
1503+"RTN","DGMSTAPI",239,0)
1504+ .;
1505+"RTN","DGMSTAPI",240,0)
1506+ .; Check for valid FIELD values
1507+"RTN","DGMSTAPI",241,0)
1508+ . S DGMSG=" IS NOT VALID"
1509+"RTN","DGMSTAPI",242,0)
1510+ .; need to strip off the 'seconds' to pass the CHK^DIE() call...
1511+"RTN","DGMSTAPI",243,0)
1512+ . I DGDATE["." N DGSECS S DGSECS=$E($P(DGDATE,".",2),5,6) I DGSECS'="" I DGSECS<0!(DGSECS>60) D MSG(DGFILE,.01,DGMSG,.DGERR) Q
1513+"RTN","DGMSTAPI",244,0)
1514+ . N DGDATEX S DGDATEX=DGDATE
1515+"RTN","DGMSTAPI",245,0)
1516+ . I DGDATEX["." S DGDATEX=$P(DGDATEX,".")_"."_$E($P(DGDATEX,".",2),1,4)
1517+"RTN","DGMSTAPI",246,0)
1518+ . I $E($P(DGDATEX,".",2),1,4)="0000" S DGDATEX=$P(DGDATEX,".")_".1"
1519+"RTN","DGMSTAPI",247,0)
1520+ . S DGSTR=".01;DGDATEX^2;DFN^3;DGSTAT^4;DGPROV^5;DUZ^6;DGSITE"
1521+"RTN","DGMSTAPI",248,0)
1522+ .;
1523+"RTN","DGMSTAPI",249,0)
1524+ . F I=1:1:$L(DGSTR,U) S DGX=$P(DGSTR,U,I) Q:DGX="" D Q:'VALID
1525+"RTN","DGMSTAPI",250,0)
1526+ .. S DGFLD=$P(DGX,";"),DGVAR=$P(DGX,";",2),DGVAL=@DGVAR
1527+"RTN","DGMSTAPI",251,0)
1528+ .. Q:DGVAL=""
1529+"RTN","DGMSTAPI",252,0)
1530+ .. S VALID=$$TESTVAL(DGFILE,DGFLD,DGVAL)
1531+"RTN","DGMSTAPI",253,0)
1532+ .. D:'VALID MSG(DGFILE,DGFLD,DGMSG,.DGERR)
1533+"RTN","DGMSTAPI",254,0)
1534+ Q VALID
1535+"RTN","DGMSTAPI",255,0)
1536+ ;
1537+"RTN","DGMSTAPI",256,0)
1538+MSG(DGFIL,DGFLD,DGMSG,DGERR) ; error message setup
1539+"RTN","DGMSTAPI",257,0)
1540+ ; Input:
1541+"RTN","DGMSTAPI",258,0)
1542+ ; DGFIL - file number
1543+"RTN","DGMSTAPI",259,0)
1544+ ; DGFLD - field number of file
1545+"RTN","DGMSTAPI",260,0)
1546+ ; DGMSG - message type verbiage - " IS REQUIRED" or " IS NOT VALID"
1547+"RTN","DGMSTAPI",261,0)
1548+ ; DGERR - error parameter passed by reference
1549+"RTN","DGMSTAPI",262,0)
1550+ ; Output:
1551+"RTN","DGMSTAPI",263,0)
1552+ ; DGERR - error message
1553+"RTN","DGMSTAPI",264,0)
1554+ S DGERR=$$GET1^DID(DGFIL,DGFLD,,"LABEL")_DGMSG
1555+"RTN","DGMSTAPI",265,0)
1556+ Q
1557+"RTN","DGMSTAPI",266,0)
1558+ ;
1559+"RTN","DGMSTAPI",267,0)
1560+TESTVAL(DGFIL,DGFLD,DGVAL) ; Determine if a field value is valid.
1561+"RTN","DGMSTAPI",268,0)
1562+ ; Input:
1563+"RTN","DGMSTAPI",269,0)
1564+ ; DGFIL - file number
1565+"RTN","DGMSTAPI",270,0)
1566+ ; DGFLD - field number of file
1567+"RTN","DGMSTAPI",271,0)
1568+ ; DGVAL - field value to be validated
1569+"RTN","DGMSTAPI",272,0)
1570+ ; Output:
1571+"RTN","DGMSTAPI",273,0)
1572+ ; Function value: Returns 1 if field is valid
1573+"RTN","DGMSTAPI",274,0)
1574+ ; 0 if validation fails
1575+"RTN","DGMSTAPI",275,0)
1576+ N DGVALEX,DGRSLT,VALID
1577+"RTN","DGMSTAPI",276,0)
1578+ S VALID=1
1579+"RTN","DGMSTAPI",277,0)
1580+ I DGVAL'="" D
1581+"RTN","DGMSTAPI",278,0)
1582+ . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
1583+"RTN","DGMSTAPI",279,0)
1584+ . I DGVALEX="" S VALID=0 Q ; no external value, not valid
1585+"RTN","DGMSTAPI",280,0)
1586+ . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'="POINTER" D
1587+"RTN","DGMSTAPI",281,0)
1588+ .. D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0
1589+"RTN","DGMSTAPI",282,0)
1590+ Q VALID
1591+"RTN","GMRCA2")
1592+0^35^B10634
1593+"RTN","GMRCA2",1,0)
1594+GMRCA2 ;SLC/KCM,DLT,MSC/JDA - Select prompt for processing actions ;27APR2009
1595+"RTN","GMRCA2",2,0)
1596+ ;;3.0;CONSULT/REQUEST TRACKING;**1,4,MSC**;DEC 27, 1997
1597+"RTN","GMRCA2",3,0)
1598+SELECT(GMRCO) ; Select the consult to process
1599+"RTN","GMRCA2",4,0)
1600+ ;This utility checks the GMRCO variable against the selection list
1601+"RTN","GMRCA2",5,0)
1602+ ; Input variable used:
1603+"RTN","GMRCA2",6,0)
1604+ ; BLK, LNCT, GMRCO
1605+"RTN","GMRCA2",7,0)
1606+ ; GMRC("NMBR")
1607+"RTN","GMRCA2",8,0)
1608+ ; Output variables returned:
1609+"RTN","GMRCA2",9,0)
1610+ ; GMRCQUT=1 if no consult was selected
1611+"RTN","GMRCA2",10,0)
1612+ ; GMRCQUT is not defined on return when selection made
1613+"RTN","GMRCA2",11,0)
1614+ ; GMRCO= consult selected from list
1615+"RTN","GMRCA2",12,0)
1616+START
1617+"RTN","GMRCA2",13,0)
1618+ K GMRCQUT,GMRCSEL
1619+"RTN","GMRCA2",14,0)
1620+ N GMRCAGN
1621+"RTN","GMRCA2",15,0)
1622+ I '$L($G(GMRCO)) D Q:$D(GMRCQUT) G:$D(GMRCAGN) START
1623+"RTN","GMRCA2",16,0)
1624+ .;use the highlighted number if defined
1625+"RTN","GMRCA2",17,0)
1626+ .I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR")
1627+"RTN","GMRCA2",18,0)
1628+ .I '$D(GMRCSEL),$D(LNCT),LNCT=1 S GMRCSEL=LNCT
1629+"RTN","GMRCA2",19,0)
1630+ .I $S('+$G(GMRCSEL):1,+GMRCSEL<1:1,+GMRCSEL>BLK:1,GMRCSEL="":1,1:0) K GMRCSEL D:+$G(GMRC("NMBR")) AGAIN^GMRCSLMV(GMRC("NMBR")) K GMRC("NMBR")
1631+"RTN","GMRCA2",20,0)
1632+ .I '+$G(GMRCSEL) D SEL I $S($D(DTOUT):1,$D(DIROUT):1,$D(GMRCQUT):1,'+GMRCSEL:1,1:0) K GMRCSEL S GMRCQUT=1 Q
1633+"RTN","GMRCA2",21,0)
1634+ .I $S(+GMRCSEL<1:1,GMRCSEL>BLK:1,1:0) W !,"Select a consult listed in the number range 1 to "_BLK S GMRCAGN=1 Q
1635+"RTN","GMRCA2",22,0)
1636+ .S GMRCO=$O(^TMP("GMRCR",$J,"CS","AD",GMRCSEL,GMRCSEL,0))
1637+"RTN","GMRCA2",23,0)
1638+ .I '+GMRCO D
1639+"RTN","GMRCA2",24,0)
1640+ .. S GMRCQUT=1
1641+"RTN","GMRCA2",25,0)
1642+ .. W !,$C(7),"Select a consult by entering its listed number between 1 and "_LNCT_"."
1643+"RTN","GMRCA2",26,0)
1644+ .. K GMRCO,GMRCSEL
1645+"RTN","GMRCA2",27,0)
1646+ . Q
1647+"RTN","GMRCA2",28,0)
1648+ Q
1649+"RTN","GMRCA2",29,0)
1650+ ;
1651+"RTN","GMRCA2",30,0)
1652+SEL ;Select order number(s) exit: GMRCSEL
1653+"RTN","GMRCA2",31,0)
1654+ I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR") Q
1655+"RTN","GMRCA2",32,0)
1656+ I '$D(^TMP("GMRCR",$J,"CS","AD")) W !,"No orders to select.",! S GMRCQUT=1,GMRCSEL="" Q
1657+"RTN","GMRCA2",33,0)
1658+ I '$O(^TMP("GMRCR",$J,"CS","AD")),BLK=1 S GMRCSEL=BLK Q
1659+"RTN","GMRCA2",34,0)
1660+ S GMRCSEL="" W !,"CHOOSE No. 1-",BLK,": " R X:DTIME S:X="^^" DIROUT=1 I '$T!(X["^") S (DTOUT,GMRCQUT)=1 Q
1661+"RTN","GMRCA2",35,0)
1662+ I X["?" D SELHELP G SEL
1663+"RTN","GMRCA2",36,0)
1664+ I X="" S GMRCQUT=1 Q
1665+"RTN","GMRCA2",37,0)
1666+ I X'?.3N W $C(7)," ?? Enter the number from the far left of the list." G SEL
1667+"RTN","GMRCA2",38,0)
1668+ I $S(X>BLK:1,X<1:1,1:0) D SELHELP G SEL
1669+"RTN","GMRCA2",39,0)
1670+ S GMRCSEL=X
1671+"RTN","GMRCA2",40,0)
1672+ Q
1673+"RTN","GMRCA2",41,0)
1674+SELHELP ;Help to select a valid entry
1675+"RTN","GMRCA2",42,0)
1676+ W !,"Select a request by typing the number from the left column and pressing <ENTER>.",!
1677+"RTN","GMRCA2",43,0)
1678+ Q
1679+"RTN","GMRCA2",44,0)
1680+UP ;Convert lower to upper case entry: X exit: X
1681+"RTN","GMRCA2",45,0)
1682+ F %=1:1:$L(X) I $E(X,%)?1L S X=$E(X,1,%-1)_$C($A(X,%)-32)_$E(X,%+1,99)
1683+"RTN","GMRCA2",46,0)
1684+ Q
1685+"RTN","HLCSLNCH")
1686+0^18^B37355917
1687+"RTN","HLCSLNCH",1,0)
1688+HLCSLNCH ;ALB/MTC/JC MSC/JDA - START AND STOP THE LLP ;13APR2009
1689+"RTN","HLCSLNCH",2,0)
1690+ ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,MSC**;Oct 13, 1995
1691+"RTN","HLCSLNCH",3,0)
1692+ ;
1693+"RTN","HLCSLNCH",4,0)
1694+ ;This program is callable from a menu
1695+"RTN","HLCSLNCH",5,0)
1696+ ;It allows the user to Start and Stop the Lower Layer
1697+"RTN","HLCSLNCH",6,0)
1698+ ;Protocol in the Background or in the foreground
1699+"RTN","HLCSLNCH",7,0)
1700+ ;
1701+"RTN","HLCSLNCH",8,0)
1702+ ;Required or Optional INPUT PARAMETERS
1703+"RTN","HLCSLNCH",9,0)
1704+ ; None
1705+"RTN","HLCSLNCH",10,0)
1706+ ;
1707+"RTN","HLCSLNCH",11,0)
1708+ ;
1709+"RTN","HLCSLNCH",12,0)
1710+ ;Output variables
1711+"RTN","HLCSLNCH",13,0)
1712+ ; HLDP=IEN of Logical Link in file #870
1713+"RTN","HLCSLNCH",14,0)
1714+ ;(optional)HLTRACE=if SET it launches the LLP in the Foreground
1715+"RTN","HLCSLNCH",15,0)
1716+ ;(optional) ZTSK=if defined LLP was launched in the
1717+"RTN","HLCSLNCH",16,0)
1718+ ;background
1719+"RTN","HLCSLNCH",17,0)
1720+ ;
1721+"RTN","HLCSLNCH",18,0)
1722+ ;
1723+"RTN","HLCSLNCH",19,0)
1724+START ; Start up the lower level protocol
1725+"RTN","HLCSLNCH",20,0)
1726+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE
1727+"RTN","HLCSLNCH",21,0)
1728+ N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC
1729+"RTN","HLCSLNCH",22,0)
1730+ W !!,"This option is used to launch the lower level protocol for the"
1731+"RTN","HLCSLNCH",23,0)
1732+ W !,"appropriate device. Please select the node with which you want"
1733+"RTN","HLCSLNCH",24,0)
1734+ W !,"to communicate",!
1735+"RTN","HLCSLNCH",25,0)
1736+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
1737+"RTN","HLCSLNCH",26,0)
1738+ S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
1739+"RTN","HLCSLNCH",27,0)
1740+ ;-- check if parameter have been setup
1741+"RTN","HLCSLNCH",28,0)
1742+ ;-- check for LLP type
1743+"RTN","HLCSLNCH",29,0)
1744+ I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
1745+"RTN","HLCSLNCH",30,0)
1746+ ;-- get TCP information
1747+"RTN","HLCSLNCH",31,0)
1748+ S HLPARM4=$G(^HLCS(870,HLDP,400))
1749+"RTN","HLCSLNCH",32,0)
1750+ ;-- get routine (background job for LLP)
1751+"RTN","HLCSLNCH",33,0)
1752+ S HLBGR=$G(^HLCS(869.1,HLTYPTR,100))
1753+"RTN","HLCSLNCH",34,0)
1754+ ;-- get environment check routine (HLQUIT should be defined in fails)
1755+"RTN","HLCSLNCH",35,0)
1756+ S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
1757+"RTN","HLCSLNCH",36,0)
1758+ ;
1759+"RTN","HLCSLNCH",37,0)
1760+ I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ
1761+"RTN","HLCSLNCH",38,0)
1762+ ;
1763+"RTN","HLCSLNCH",39,0)
1764+ ;-- execute environment check routine if HLQUIT is defined then terminate
1765+"RTN","HLCSLNCH",40,0)
1766+ I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
1767+"RTN","HLCSLNCH",41,0)
1768+ ;Multi-Servers, only enable the link if not OpenM
1769+"RTN","HLCSLNCH",42,0)
1770+ I $P(HLPARM4,U,3)="M",$$NOTMULTI D G STARTQ
1771+"RTN","HLCSLNCH",43,0)
1772+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP."
1773+"RTN","HLCSLNCH",44,0)
1774+ . Q
1775+"RTN","HLCSLNCH",45,0)
1776+ ;
1777+"RTN","HLCSLNCH",46,0)
1778+ I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error"
1779+"RTN","HLCSLNCH",47,0)
1780+ I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
1781+"RTN","HLCSLNCH",48,0)
1782+ I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
1783+"RTN","HLCSLNCH",49,0)
1784+ I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ
1785+"RTN","HLCSLNCH",50,0)
1786+ . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
1787+"RTN","HLCSLNCH",51,0)
1788+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D G STARTQ
1789+"RTN","HLCSLNCH",52,0)
1790+ .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
1791+"RTN","HLCSLNCH",53,0)
1792+ .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
1793+"RTN","HLCSLNCH",54,0)
1794+ .N HLJ,X
1795+"RTN","HLCSLNCH",55,0)
1796+ .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
1797+"RTN","HLCSLNCH",56,0)
1798+ .L +^HLCS(870,HLDP,0):2
1799+"RTN","HLCSLNCH",57,0)
1800+ .E W !,$C(7),"Unable to enable this LLP !" Q
1801+"RTN","HLCSLNCH",58,0)
1802+ .S X="HLJ(870,"""_HLDP_","")"
1803+"RTN","HLCSLNCH",59,0)
1804+ .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0
1805+"RTN","HLCSLNCH",60,0)
1806+ .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109
1807+"RTN","HLCSLNCH",61,0)
1808+ .L -^HLCS(870,HLDP,0)
1809+"RTN","HLCSLNCH",62,0)
1810+ .W !,"This LLP has been enabled!"
1811+"RTN","HLCSLNCH",63,0)
1812+ .Q
1813+"RTN","HLCSLNCH",64,0)
1814+ I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",!
1815+"RTN","HLCSLNCH",65,0)
1816+ ;
1817+"RTN","HLCSLNCH",66,0)
1818+ W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
1819+"RTN","HLCSLNCH",67,0)
1820+ S DIR("A")="Method for running the receiver"
1821+"RTN","HLCSLNCH",68,0)
1822+ S DIR("B")="B"
1823+"RTN","HLCSLNCH",69,0)
1824+ S DIR("?",1)="Enter F for Foreground (and trace)"
1825+"RTN","HLCSLNCH",70,0)
1826+ S DIR("?",2)=" B for Background (normal) or"
1827+"RTN","HLCSLNCH",71,0)
1828+ S DIR("?")=" Q to quit without starting the receiver"
1829+"RTN","HLCSLNCH",72,0)
1830+ D ^DIR K DIR
1831+"RTN","HLCSLNCH",73,0)
1832+ Q:(Y=U)!(Y="Q")
1833+"RTN","HLCSLNCH",74,0)
1834+ ;
1835+"RTN","HLCSLNCH",75,0)
1836+ S HLX=$G(^HLCS(870,HLDP,0))
1837+"RTN","HLCSLNCH",76,0)
1838+ ;-- foreground
1839+"RTN","HLCSLNCH",77,0)
1840+ I Y="F" S HLTRACE=1 D G STARTQ
1841+"RTN","HLCSLNCH",78,0)
1842+ . X HLBGR
1843+"RTN","HLCSLNCH",79,0)
1844+ ;-- background
1845+"RTN","HLCSLNCH",80,0)
1846+ I Y="B" D G STARTQ
1847+"RTN","HLCSLNCH",81,0)
1848+ . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H
1849+"RTN","HLCSLNCH",82,0)
1850+ . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
1851+"RTN","HLCSLNCH",83,0)
1852+ . D ^%ZTLOAD
1853+"RTN","HLCSLNCH",84,0)
1854+ . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
1855+"RTN","HLCSLNCH",85,0)
1856+ ;
1857+"RTN","HLCSLNCH",86,0)
1858+ Q
1859+"RTN","HLCSLNCH",87,0)
1860+ ;
1861+"RTN","HLCSLNCH",88,0)
1862+ ;
1863+"RTN","HLCSLNCH",89,0)
1864+STARTQ ;
1865+"RTN","HLCSLNCH",90,0)
1866+ I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running."
1867+"RTN","HLCSLNCH",91,0)
1868+ Q
1869+"RTN","HLCSLNCH",92,0)
1870+ ;
1871+"RTN","HLCSLNCH",93,0)
1872+STOP ; Shut down a lower level protocol..
1873+"RTN","HLCSLNCH",94,0)
1874+ N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y
1875+"RTN","HLCSLNCH",95,0)
1876+ W !!,"This option is used to shut down the lower level protocol for the"
1877+"RTN","HLCSLNCH",96,0)
1878+ W !,"appropriate device. Please select the link which you would"
1879+"RTN","HLCSLNCH",97,0)
1880+ W !,"like to shutdown.",!
1881+"RTN","HLCSLNCH",98,0)
1882+ S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
1883+"RTN","HLCSLNCH",99,0)
1884+ S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
1885+"RTN","HLCSLNCH",100,0)
1886+ I $P(HLPARM4,U,3)="M",$$NOTMULTI D Q
1887+"RTN","HLCSLNCH",101,0)
1888+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP."
1889+"RTN","HLCSLNCH",102,0)
1890+ . Q
1891+"RTN","HLCSLNCH",103,0)
1892+ ;
1893+"RTN","HLCSLNCH",104,0)
1894+ I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q
1895+"RTN","HLCSLNCH",105,0)
1896+ I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"."
1897+"RTN","HLCSLNCH",106,0)
1898+STP1 ;
1899+"RTN","HLCSLNCH",107,0)
1900+ W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR
1901+"RTN","HLCSLNCH",108,0)
1902+ I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q
1903+"RTN","HLCSLNCH",109,0)
1904+S ;
1905+"RTN","HLCSLNCH",110,0)
1906+ F L +^HLCS(870,HLDP,0):2 Q:$T
1907+"RTN","HLCSLNCH",111,0)
1908+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown
1909+"RTN","HLCSLNCH",112,0)
1910+ S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
1911+"RTN","HLCSLNCH",113,0)
1912+ I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
1913+"RTN","HLCSLNCH",114,0)
1914+ D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
1915+"RTN","HLCSLNCH",115,0)
1916+ I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
1917+"RTN","HLCSLNCH",116,0)
1918+ . ;pass task number to stop listener
1919+"RTN","HLCSLNCH",117,0)
1920+ . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
1921+"RTN","HLCSLNCH",118,0)
1922+ . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
1923+"RTN","HLCSLNCH",119,0)
1924+ . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
1925+"RTN","HLCSLNCH",120,0)
1926+ . U IO W "**STOP**"
1927+"RTN","HLCSLNCH",121,0)
1928+ . W !
1929+"RTN","HLCSLNCH",122,0)
1930+ . D CLOSE^%ZISTCP
1931+"RTN","HLCSLNCH",123,0)
1932+ L -^HLCS(870,HLDP,0)
1933+"RTN","HLCSLNCH",124,0)
1934+ W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
1935+"RTN","HLCSLNCH",125,0)
1936+ Q
1937+"RTN","HLCSLNCH",126,0)
1938+ ;
1939+"RTN","HLCSLNCH",127,0)
1940+NOTMULTI() ; Returns 1 if implementation can't run multithreaded listener
1941+"RTN","HLCSLNCH",128,0)
1942+ Q:^%ZOSF("OS")["GT.M" 0
1943+"RTN","HLCSLNCH",129,0)
1944+ Q $S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS")
1945+"RTN","HLCSLNCH",130,0)
1946+STOPQ Q
1947+"RTN","HLCSTCP")
1948+0^17^B32434118
1949+"RTN","HLCSTCP",1,0)
1950+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE MSC/JDA - (TCP/IP) MLLP ;13APR2009
1951+"RTN","HLCSTCP",2,0)
1952+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,MSC**;Oct 13, 1995
1953+"RTN","HLCSTCP",3,0)
1954+ ;
1955+"RTN","HLCSTCP",4,0)
1956+ ; This is an implementation of the HL7 Minimal Lower Layer Protocol
1957+"RTN","HLCSTCP",5,0)
1958+ ;
1959+"RTN","HLCSTCP",6,0)
1960+ ;taskman entry/startup option, HLDP defined in menu entry,
1961+"RTN","HLCSTCP",7,0)
1962+ Q:'$D(HLDP)
1963+"RTN","HLCSTCP",8,0)
1964+ N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
1965+"RTN","HLCSTCP",9,0)
1966+ ;HLCSOUT= 1-error
1967+"RTN","HLCSTCP",10,0)
1968+ I '$$INIT D EXITS("Init Error") Q
1969+"RTN","HLCSTCP",11,0)
1970+ ; Start the client
1971+"RTN","HLCSTCP",12,0)
1972+ I $G(HLTCPCS)="C" D Q
1973+"RTN","HLCSTCP",13,0)
1974+ . ; identify process for ^%SY
1975+"RTN","HLCSTCP",14,0)
1976+ . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
1977+"RTN","HLCSTCP",15,0)
1978+ . D ST1
1979+"RTN","HLCSTCP",16,0)
1980+ . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
1981+"RTN","HLCSTCP",17,0)
1982+ . I $G(HLCSOUT)=1 D MON("Error") H 1 Q
1983+"RTN","HLCSTCP",18,0)
1984+ . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
1985+"RTN","HLCSTCP",19,0)
1986+ . D EXITS("Shutdown")
1987+"RTN","HLCSTCP",20,0)
1988+ ;
1989+"RTN","HLCSTCP",21,0)
1990+ ; identify process for ^%SY
1991+"RTN","HLCSTCP",22,0)
1992+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
1993+"RTN","HLCSTCP",23,0)
1994+ ;HLCSFAIL=1 port failed to open
1995+"RTN","HLCSTCP",24,0)
1996+ S HLCSFAIL=1
1997+"RTN","HLCSTCP",25,0)
1998+ ;single threaded listener
1999+"RTN","HLCSTCP",26,0)
2000+ I $G(HLTCPCS)="S" D Q
2001+"RTN","HLCSTCP",27,0)
2002+ . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")","S ZISQUIT=$$STOP^HLCSTCP()")
2003+"RTN","HLCSTCP",28,0)
2004+ . ;couldn't open listener port
2005+"RTN","HLCSTCP",29,0)
2006+ . I HLCSFAIL D EXITS("Openfail") Q
2007+"RTN","HLCSTCP",30,0)
2008+ ;
2009+"RTN","HLCSTCP",31,0)
2010+ ;multi-threaded listener (OpenM or GT.M)
2011+"RTN","HLCSTCP",32,0)
2012+ I $G(HLTCPCS)="M",(^%ZOSF("OS")["OpenM")!(^%ZOSF("OS")["GT.M") D Q
2013+"RTN","HLCSTCP",33,0)
2014+ . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
2015+"RTN","HLCSTCP",34,0)
2016+ Q
2017+"RTN","HLCSTCP",35,0)
2018+ ;
2019+"RTN","HLCSTCP",36,0)
2020+SERVER(HLDP) ; single server using Taskman
2021+"RTN","HLCSTCP",37,0)
2022+ S HLCSFAIL=0
2023+"RTN","HLCSTCP",38,0)
2024+ I '$$INIT D EXITS("Init error") Q
2025+"RTN","HLCSTCP",39,0)
2026+ D ^HLCSTCP1
2027+"RTN","HLCSTCP",40,0)
2028+ I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
2029+"RTN","HLCSTCP",41,0)
2030+ Q:$G(HLCSOUT)=1
2031+"RTN","HLCSTCP",42,0)
2032+ D MON("Idle")
2033+"RTN","HLCSTCP",43,0)
2034+ Q
2035+"RTN","HLCSTCP",44,0)
2036+ ;
2037+"RTN","HLCSTCP",45,0)
2038+SERVERS(HLDP) ; Multi-threaded server using Taskman
2039+"RTN","HLCSTCP",46,0)
2040+ I '$$INIT D EXITS("Init error") Q
2041+"RTN","HLCSTCP",47,0)
2042+ G LISTEN
2043+"RTN","HLCSTCP",48,0)
2044+ ;
2045+"RTN","HLCSTCP",49,0)
2046+ ;multiple process servers, called from an external utility
2047+"RTN","HLCSTCP",50,0)
2048+MSM ;MSM entry point, called from User-Defined Services
2049+"RTN","HLCSTCP",51,0)
2050+ ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
2051+"RTN","HLCSTCP",52,0)
2052+ ;HL7 Multi-Threaded SERVER
2053+"RTN","HLCSTCP",53,0)
2054+ S (IO,IO(0))=$P
2055+"RTN","HLCSTCP",54,0)
2056+ G LISTEN
2057+"RTN","HLCSTCP",55,0)
2058+ ;
2059+"RTN","HLCSTCP",56,0)
2060+CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
2061+"RTN","HLCSTCP",57,0)
2062+ ;listener, % = HLDP
2063+"RTN","HLCSTCP",58,0)
2064+ I $G(%)="" D ^%ZTER Q
2065+"RTN","HLCSTCP",59,0)
2066+ S (IO,IO(0))="SYS$NET",HLDP=%
2067+"RTN","HLCSTCP",60,0)
2068+ ; **Cache'/VMS specific code**
2069+"RTN","HLCSTCP",61,0)
2070+ O IO::5 E D MON("Openfail") Q
2071+"RTN","HLCSTCP",62,0)
2072+ X "U IO:(::""-M"")" ;Packet mode like DSM
2073+"RTN","HLCSTCP",63,0)
2074+ D LISTEN C IO Q
2075+"RTN","HLCSTCP",64,0)
2076+ ;
2077+"RTN","HLCSTCP",65,0)
2078+EN ;vms ucx entry point, called from HLSEVEN.COM file,
2079+"RTN","HLCSTCP",66,0)
2080+ ;listener, % = device^HLDP
2081+"RTN","HLCSTCP",67,0)
2082+ I $G(%)="" D ^%ZTER Q
2083+"RTN","HLCSTCP",68,0)
2084+ S (IO,IO(0))="SYS$NET",HLDP=$P(%,"^",2)
2085+"RTN","HLCSTCP",69,0)
2086+ ; **VMS specific code, need to share device**
2087+"RTN","HLCSTCP",70,0)
2088+ X "O IO:(TCPDEV):60" E D MON("Openfail") Q
2089+"RTN","HLCSTCP",71,0)
2090+LISTEN ;
2091+"RTN","HLCSTCP",72,0)
2092+ N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
2093+"RTN","HLCSTCP",73,0)
2094+ I '$$INIT D ^%ZTER Q
2095+"RTN","HLCSTCP",74,0)
2096+ ; identify process for ^%SY
2097+"RTN","HLCSTCP",75,0)
2098+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
2099+"RTN","HLCSTCP",76,0)
2100+ ;HLLSTN used to identify a listener to tag MON
2101+"RTN","HLCSTCP",77,0)
2102+ S HLLSTN=1
2103+"RTN","HLCSTCP",78,0)
2104+ ;increment job count, run server
2105+"RTN","HLCSTCP",79,0)
2106+ D UPDT(1),^HLCSTCP1,EXITM
2107+"RTN","HLCSTCP",80,0)
2108+ Q
2109+"RTN","HLCSTCP",81,0)
2110+ ;
2111+"RTN","HLCSTCP",82,0)
2112+DCOPEN(HLDP) ;open direct connect - called from HLMA2
2113+"RTN","HLCSTCP",83,0)
2114+ Q:'$$INIT 0
2115+"RTN","HLCSTCP",84,0)
2116+ Q:HLTCPADD=""!(HLTCPORT="") 0
2117+"RTN","HLCSTCP",85,0)
2118+ Q:'$$OPEN^HLCSTCP2 0
2119+"RTN","HLCSTCP",86,0)
2120+ Q 1
2121+"RTN","HLCSTCP",87,0)
2122+ ;
2123+"RTN","HLCSTCP",88,0)
2124+INIT() ; Initialize Variables
2125+"RTN","HLCSTCP",89,0)
2126+ ; HLDP should be set to the IEN or name of Logical Link, file 870
2127+"RTN","HLCSTCP",90,0)
2128+ S HLOS=$P($G(^%ZOSF("OS")),"^")
2129+"RTN","HLCSTCP",91,0)
2130+ N DA,DIQUIET,DR,TMP,X,Y
2131+"RTN","HLCSTCP",92,0)
2132+ S DIQUIET=1
2133+"RTN","HLCSTCP",93,0)
2134+ D DT^DICRW
2135+"RTN","HLCSTCP",94,0)
2136+ I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
2137+"RTN","HLCSTCP",95,0)
2138+ S DA=HLDP
2139+"RTN","HLCSTCP",96,0)
2140+ S DR="200.02;200.021;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05"
2141+"RTN","HLCSTCP",97,0)
2142+ D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
2143+"RTN","HLCSTCP",98,0)
2144+ ;
2145+"RTN","HLCSTCP",99,0)
2146+ I $D(TMP("DIERR")) QUIT 0
2147+"RTN","HLCSTCP",100,0)
2148+ ; -- re-transmit attempts
2149+"RTN","HLCSTCP",101,0)
2150+ S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
2151+"RTN","HLCSTCP",102,0)
2152+ ; -- exceed re-transmit action
2153+"RTN","HLCSTCP",103,0)
2154+ S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
2155+"RTN","HLCSTCP",104,0)
2156+ ; -- block size
2157+"RTN","HLCSTCP",105,0)
2158+ S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
2159+"RTN","HLCSTCP",106,0)
2160+ ; -- read timeout
2161+"RTN","HLCSTCP",107,0)
2162+ S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
2163+"RTN","HLCSTCP",108,0)
2164+ ; -- ack timeout
2165+"RTN","HLCSTCP",109,0)
2166+ S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
2167+"RTN","HLCSTCP",110,0)
2168+ ; -- uni-directional wait
2169+"RTN","HLCSTCP",111,0)
2170+ S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
2171+"RTN","HLCSTCP",112,0)
2172+ ; -- tcp address
2173+"RTN","HLCSTCP",113,0)
2174+ S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
2175+"RTN","HLCSTCP",114,0)
2176+ ; -- tcp port
2177+"RTN","HLCSTCP",115,0)
2178+ S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
2179+"RTN","HLCSTCP",116,0)
2180+ ; -- tcp/ip service type
2181+"RTN","HLCSTCP",117,0)
2182+ S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
2183+"RTN","HLCSTCP",118,0)
2184+ ; -- link persistence
2185+"RTN","HLCSTCP",119,0)
2186+ S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
2187+"RTN","HLCSTCP",120,0)
2188+ ; -- retention
2189+"RTN","HLCSTCP",121,0)
2190+ S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
2191+"RTN","HLCSTCP",122,0)
2192+ ;
2193+"RTN","HLCSTCP",123,0)
2194+ ; -- set defaults in case something's not set
2195+"RTN","HLCSTCP",124,0)
2196+ S:HLDREAD=0 HLDREAD=10
2197+"RTN","HLCSTCP",125,0)
2198+ S:HLDBACK=0 HLDBACK=60
2199+"RTN","HLCSTCP",126,0)
2200+ S:HLDBSIZE=0 HLDBSIZE=245
2201+"RTN","HLCSTCP",127,0)
2202+ S:HLDRETR=0 HLDRETR=5
2203+"RTN","HLCSTCP",128,0)
2204+ S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
2205+"RTN","HLCSTCP",129,0)
2206+ ;
2207+"RTN","HLCSTCP",130,0)
2208+ Q 1
2209+"RTN","HLCSTCP",131,0)
2210+ ;
2211+"RTN","HLCSTCP",132,0)
2212+ST1 ;record startup in 870 for single server
2213+"RTN","HLCSTCP",133,0)
2214+ ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
2215+"RTN","HLCSTCP",134,0)
2216+ ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
2217+"RTN","HLCSTCP",135,0)
2218+ N HLJ,X
2219+"RTN","HLCSTCP",136,0)
2220+ F L +^HLCS(870,HLDP,0):2 Q:$T
2221+"RTN","HLCSTCP",137,0)
2222+ S X="HLJ(870,"""_HLDP_","")"
2223+"RTN","HLCSTCP",138,0)
2224+ S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
2225+"RTN","HLCSTCP",139,0)
2226+ I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
2227+"RTN","HLCSTCP",140,0)
2228+ E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
2229+"RTN","HLCSTCP",141,0)
2230+ I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
2231+"RTN","HLCSTCP",142,0)
2232+ S:$G(ZTSK) @X@(11)=ZTSK
2233+"RTN","HLCSTCP",143,0)
2234+ D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
2235+"RTN","HLCSTCP",144,0)
2236+ L -^HLCS(870,HLDP,0)
2237+"RTN","HLCSTCP",145,0)
2238+ Q
2239+"RTN","HLCSTCP",146,0)
2240+ ;
2241+"RTN","HLCSTCP",147,0)
2242+MON(Y) ;Display current state & check for shutdown
2243+"RTN","HLCSTCP",148,0)
2244+ ;don't display for multiple server
2245+"RTN","HLCSTCP",149,0)
2246+ Q:$G(HLLSTN)
2247+"RTN","HLCSTCP",150,0)
2248+ F L +^HLCS(870,HLDP,0):2 Q:$T
2249+"RTN","HLCSTCP",151,0)
2250+ S $P(^HLCS(870,HLDP,0),U,5)=Y
2251+"RTN","HLCSTCP",152,0)
2252+ L -^HLCS(870,HLDP,0)
2253+"RTN","HLCSTCP",153,0)
2254+ Q:'$D(HLTRACE)
2255+"RTN","HLCSTCP",154,0)
2256+ N X U IO(0)
2257+"RTN","HLCSTCP",155,0)
2258+ W !,"IN State: ",Y
2259+"RTN","HLCSTCP",156,0)
2260+ I '$$STOP D
2261+"RTN","HLCSTCP",157,0)
2262+ . R !,"Type Q to Quit: ",X#1:1
2263+"RTN","HLCSTCP",158,0)
2264+ . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
2265+"RTN","HLCSTCP",159,0)
2266+ U IO
2267+"RTN","HLCSTCP",160,0)
2268+ Q
2269+"RTN","HLCSTCP",161,0)
2270+UPDT(Y) ;update job count for multiple servers,X=1 increment
2271+"RTN","HLCSTCP",162,0)
2272+ N HLJ,X
2273+"RTN","HLCSTCP",163,0)
2274+ F L +^HLCS(870,HLDP,0):2 Q:$T
2275+"RTN","HLCSTCP",164,0)
2276+ S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
2277+"RTN","HLCSTCP",165,0)
2278+ ;if incrementing, set the Device Type field to Multi-Server
2279+"RTN","HLCSTCP",166,0)
2280+ I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
2281+"RTN","HLCSTCP",167,0)
2282+ L -^HLCS(870,HLDP,0)
2283+"RTN","HLCSTCP",168,0)
2284+ Q
2285+"RTN","HLCSTCP",169,0)
2286+STOP() ;stop flag set
2287+"RTN","HLCSTCP",170,0)
2288+ N X
2289+"RTN","HLCSTCP",171,0)
2290+ F L +^HLCS(870,HLDP,0):2 Q:$T
2291+"RTN","HLCSTCP",172,0)
2292+ S X=+$P(^HLCS(870,HLDP,0),U,15)
2293+"RTN","HLCSTCP",173,0)
2294+ L -^HLCS(870,HLDP,0)
2295+"RTN","HLCSTCP",174,0)
2296+ Q X
2297+"RTN","HLCSTCP",175,0)
2298+ ;
2299+"RTN","HLCSTCP",176,0)
2300+LLCNT(DP,Y,Z) ;update Logical Link counters
2301+"RTN","HLCSTCP",177,0)
2302+ ;DP=ien of Logical Link in file 870
2303+"RTN","HLCSTCP",178,0)
2304+ ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
2305+"RTN","HLCSTCP",179,0)
2306+ ;Z: ""=add to counter, 1=subtract from counter
2307+"RTN","HLCSTCP",180,0)
2308+ Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
2309+"RTN","HLCSTCP",181,0)
2310+ N P,X
2311+"RTN","HLCSTCP",182,0)
2312+ S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
2313+"RTN","HLCSTCP",183,0)
2314+ F L +^HLCS(870,DP,P):2 Q:$T
2315+"RTN","HLCSTCP",184,0)
2316+ S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
2317+"RTN","HLCSTCP",185,0)
2318+ L -^HLCS(870,DP,P)
2319+"RTN","HLCSTCP",186,0)
2320+ Q
2321+"RTN","HLCSTCP",187,0)
2322+SDFLD ; set Shutdown? field to yes
2323+"RTN","HLCSTCP",188,0)
2324+ Q:'$G(HLDP)
2325+"RTN","HLCSTCP",189,0)
2326+ N HLJ,X
2327+"RTN","HLCSTCP",190,0)
2328+ F L +^HLCS(870,HLDP,0):2 Q:$T
2329+"RTN","HLCSTCP",191,0)
2330+ ;14=Shutdown LLP?
2331+"RTN","HLCSTCP",192,0)
2332+ S HLJ(870,HLDP_",",14)=1
2333+"RTN","HLCSTCP",193,0)
2334+ D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
2335+"RTN","HLCSTCP",194,0)
2336+ L -^HLCS(870,HLDP,0)
2337+"RTN","HLCSTCP",195,0)
2338+ Q
2339+"RTN","HLCSTCP",196,0)
2340+ ;
2341+"RTN","HLCSTCP",197,0)
2342+EXITS(Y) ; Single service shutdown and cleans up
2343+"RTN","HLCSTCP",198,0)
2344+ N HLJ,X
2345+"RTN","HLCSTCP",199,0)
2346+ F L +^HLCS(870,HLDP,0):2 Q:$T
2347+"RTN","HLCSTCP",200,0)
2348+ ;4=status,10=Time Stopped,9=Time Started,11=Task Number
2349+"RTN","HLCSTCP",201,0)
2350+ S X="HLJ(870,"""_HLDP_","")"
2351+"RTN","HLCSTCP",202,0)
2352+ S @X@(4)=Y,@X@(11)="@"
2353+"RTN","HLCSTCP",203,0)
2354+ S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
2355+"RTN","HLCSTCP",204,0)
2356+ D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
2357+"RTN","HLCSTCP",205,0)
2358+ L -^HLCS(870,HLDP,0)
2359+"RTN","HLCSTCP",206,0)
2360+ I $D(ZTQUEUED) S ZTREQ="@"
2361+"RTN","HLCSTCP",207,0)
2362+ Q
2363+"RTN","HLCSTCP",208,0)
2364+ ;
2365+"RTN","HLCSTCP",209,0)
2366+EXITM ;Multiple service shutdown and clean up
2367+"RTN","HLCSTCP",210,0)
2368+ D UPDT(0)
2369+"RTN","HLCSTCP",211,0)
2370+ I $D(ZTQUEUED) S ZTREQ="@"
2371+"RTN","HLCSTCP",212,0)
2372+ Q
2373+"RTN","HLCSTCP1")
2374+0^16^B29662559
2375+"RTN","HLCSTCP1",1,0)
2376+HLCSTCP1 ;SFIRMFO/RSD MSC/JDA - BI-DIRECTIONAL TCP ;13APR2009
2377+"RTN","HLCSTCP1",2,0)
2378+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,MSC**;JUL 17,1995
2379+"RTN","HLCSTCP1",3,0)
2380+ ;Receiver
2381+"RTN","HLCSTCP1",4,0)
2382+ ;connection is initiated by sender and listener accepts connection
2383+"RTN","HLCSTCP1",5,0)
2384+ ;and calls this routine
2385+"RTN","HLCSTCP1",6,0)
2386+ ;
2387+"RTN","HLCSTCP1",7,0)
2388+ N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1"
2389+"RTN","HLCSTCP1",8,0)
2390+ N HLMIEN,HLASTMSG
2391+"RTN","HLCSTCP1",9,0)
2392+ D MON^HLCSTCP("Open")
2393+"RTN","HLCSTCP1",10,0)
2394+ K ^TMP("HLCSTCP",$J,0)
2395+"RTN","HLCSTCP1",11,0)
2396+ S HLMIEN=0,HLASTMSG=""
2397+"RTN","HLCSTCP1",12,0)
2398+ F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3
2399+"RTN","HLCSTCP1",13,0)
2400+ . S HLMIEN=$$READ
2401+"RTN","HLCSTCP1",14,0)
2402+ . Q:'HLMIEN
2403+"RTN","HLCSTCP1",15,0)
2404+ . D PROCESS
2405+"RTN","HLCSTCP1",16,0)
2406+ Q
2407+"RTN","HLCSTCP1",17,0)
2408+ ;
2409+"RTN","HLCSTCP1",18,0)
2410+PROCESS ;check message and reply
2411+"RTN","HLCSTCP1",19,0)
2412+ ;HLDP=LL in 870, update monitor, received msg.
2413+"RTN","HLCSTCP1",20,0)
2414+ N HLTCP,HLTCPI,HLTCPO
2415+"RTN","HLCSTCP1",21,0)
2416+ S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN
2417+"RTN","HLCSTCP1",22,0)
2418+ ;update monitor, msg. received
2419+"RTN","HLCSTCP1",23,0)
2420+ D LLCNT^HLCSTCP(HLDP,1)
2421+"RTN","HLCSTCP1",24,0)
2422+ D NEW^HLTP3(HLMIEN)
2423+"RTN","HLCSTCP1",25,0)
2424+ ;update monitor, msg. processed
2425+"RTN","HLCSTCP1",26,0)
2426+ D LLCNT^HLCSTCP(HLDP,2)
2427+"RTN","HLCSTCP1",27,0)
2428+ Q
2429+"RTN","HLCSTCP1",28,0)
2430+ ;
2431+"RTN","HLCSTCP1",29,0)
2432+READ() ;read 1 message, returns ien in 773^ien in 772 for message
2433+"RTN","HLCSTCP1",30,0)
2434+ D MON^HLCSTCP("Reading")
2435+"RTN","HLCSTCP1",31,0)
2436+ N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X
2437+"RTN","HLCSTCP1",32,0)
2438+ ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator
2439+"RTN","HLCSTCP1",33,0)
2440+ S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13)
2441+"RTN","HLCSTCP1",34,0)
2442+ ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772
2443+"RTN","HLCSTCP1",35,0)
2444+ ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack
2445+"RTN","HLCSTCP1",36,0)
2446+ S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK
2447+"RTN","HLCSTCP1",37,0)
2448+ K ^TMP("HLCSTCP",$J,0)
2449+"RTN","HLCSTCP1",38,0)
2450+ F D RDBLK Q:HLRDOUT
2451+"RTN","HLCSTCP1",39,0)
2452+ ;save any excess for next time
2453+"RTN","HLCSTCP1",40,0)
2454+ S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX
2455+"RTN","HLCSTCP1",41,0)
2456+ I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0
2457+"RTN","HLCSTCP1",42,0)
2458+ Q HLIND1
2459+"RTN","HLCSTCP1",43,0)
2460+ ;
2461+"RTN","HLCSTCP1",44,0)
2462+RDBLK S HLDB=HLDBSIZE-$L(HLX)
2463+"RTN","HLCSTCP1",45,0)
2464+ U IO D:$D ERROR R X#HLDB:HLDREAD ; MSC/JDA added check against $d
2465+"RTN","HLCSTCP1",46,0)
2466+ ; timedout or error, check ack timeout, clean up
2467+"RTN","HLCSTCP1",47,0)
2468+ I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
2469+"RTN","HLCSTCP1",48,0)
2470+ ;data stream: <sb>dddd<cr><eb><cr>
2471+"RTN","HLCSTCP1",49,0)
2472+ ;add incoming line to what wasn't processed in last read
2473+"RTN","HLCSTCP1",50,0)
2474+ S HLX=$G(HLX)_X
2475+"RTN","HLCSTCP1",51,0)
2476+ ; look for segment= <CR>
2477+"RTN","HLCSTCP1",52,0)
2478+ F Q:HLX'[HLRS D Q:HLRDOUT
2479+"RTN","HLCSTCP1",53,0)
2480+ . ; Get the first piece, save the rest of the line
2481+"RTN","HLCSTCP1",54,0)
2482+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999)
2483+"RTN","HLCSTCP1",55,0)
2484+ . ; check for start block, Quit if no ien
2485+"RTN","HLCSTCP1",56,0)
2486+ . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q
2487+"RTN","HLCSTCP1",57,0)
2488+ .. D:HLMSG(HLINE,0)[HLDSTRT
2489+"RTN","HLCSTCP1",58,0)
2490+ ... S X=$L(HLMSG(HLINE,0),HLDSTRT)
2491+"RTN","HLCSTCP1",59,0)
2492+ ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X)
2493+"RTN","HLCSTCP1",60,0)
2494+ ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2)
2495+"RTN","HLCSTCP1",61,0)
2496+ ... D RESET:(HLINE>1)
2497+"RTN","HLCSTCP1",62,0)
2498+ .. ;ping message
2499+"RTN","HLCSTCP1",63,0)
2500+ .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q
2501+"RTN","HLCSTCP1",64,0)
2502+ .. ; get next ien to store
2503+"RTN","HLCSTCP1",65,0)
2504+ .. D MIEN
2505+"RTN","HLCSTCP1",66,0)
2506+ .. K HLMSG
2507+"RTN","HLCSTCP1",67,0)
2508+ .. S (HLINE,HLHDR)=0
2509+"RTN","HLCSTCP1",68,0)
2510+ . ; check for end block; HLMSG(HLINE) = <eb><cr>
2511+"RTN","HLCSTCP1",69,0)
2512+ . I HLMSG(HLINE,0)[HLDEND D
2513+"RTN","HLCSTCP1",70,0)
2514+ .. ;no msg. ien
2515+"RTN","HLCSTCP1",71,0)
2516+ .. Q:'HLIND1
2517+"RTN","HLCSTCP1",72,0)
2518+ .. ; Kill just the last line
2519+"RTN","HLCSTCP1",73,0)
2520+ .. K HLMSG(HLINE,0) S HLINE=HLINE-1
2521+"RTN","HLCSTCP1",74,0)
2522+ .. ; move into 772
2523+"RTN","HLCSTCP1",75,0)
2524+ .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")")
2525+"RTN","HLCSTCP1",76,0)
2526+ .. ;mark that end block has been received
2527+"RTN","HLCSTCP1",77,0)
2528+ .. ;HLIND1=ien in 773^ien in 772^1 if end block was received
2529+"RTN","HLCSTCP1",78,0)
2530+ .. S $P(HLIND1,U,3)=1
2531+"RTN","HLCSTCP1",79,0)
2532+ .. ;reset variables for next message
2533+"RTN","HLCSTCP1",80,0)
2534+ .. D CLEAN
2535+"RTN","HLCSTCP1",81,0)
2536+ . ;add blank line for carriage return
2537+"RTN","HLCSTCP1",82,0)
2538+ . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)=""
2539+"RTN","HLCSTCP1",83,0)
2540+ Q:HLRDOUT
2541+"RTN","HLCSTCP1",84,0)
2542+ ;If the line is long and no <CR> move it into the array.
2543+"RTN","HLCSTCP1",85,0)
2544+ I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q
2545+"RTN","HLCSTCP1",86,0)
2546+ . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX=""
2547+"RTN","HLCSTCP1",87,0)
2548+ ;have start block but no record seperator
2549+"RTN","HLCSTCP1",88,0)
2550+ I HLX[HLDSTRT D Q
2551+"RTN","HLCSTCP1",89,0)
2552+ . ;check for more than 1 start block
2553+"RTN","HLCSTCP1",90,0)
2554+ . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X)
2555+"RTN","HLCSTCP1",91,0)
2556+ . S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1
2557+"RTN","HLCSTCP1",92,0)
2558+ . D RESET:(HLHDR&(HLINE>1))
2559+"RTN","HLCSTCP1",93,0)
2560+ ;if no ien, then we don't have start block, reset
2561+"RTN","HLCSTCP1",94,0)
2562+ I 'HLIND1 D CLEAN Q
2563+"RTN","HLCSTCP1",95,0)
2564+ ; big message-merge from local to global every 100 lines
2565+"RTN","HLCSTCP1",96,0)
2566+ I (HLINE-$O(HLMSG(0)))>100 D
2567+"RTN","HLCSTCP1",97,0)
2568+ . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG
2569+"RTN","HLCSTCP1",98,0)
2570+ . ; reset working array
2571+"RTN","HLCSTCP1",99,0)
2572+ . K HLMSG
2573+"RTN","HLCSTCP1",100,0)
2574+ Q
2575+"RTN","HLCSTCP1",101,0)
2576+ ;
2577+"RTN","HLCSTCP1",102,0)
2578+SAVE(SRC,DEST) ;save into global & set top node
2579+"RTN","HLCSTCP1",103,0)
2580+ ;SRC=source array (passed by ref.), DEST=destination global
2581+"RTN","HLCSTCP1",104,0)
2582+ M @DEST=SRC
2583+"RTN","HLCSTCP1",105,0)
2584+ S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
2585+"RTN","HLCSTCP1",106,0)
2586+ Q
2587+"RTN","HLCSTCP1",107,0)
2588+ ;
2589+"RTN","HLCSTCP1",108,0)
2590+DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files.
2591+"RTN","HLCSTCP1",109,0)
2592+ N DIK,DA
2593+"RTN","HLCSTCP1",110,0)
2594+ S DA=+HLMAMT,DIK="^HLMA("
2595+"RTN","HLCSTCP1",111,0)
2596+ D ^DIK
2597+"RTN","HLCSTCP1",112,0)
2598+ S DA=$P(HLMAMT,U,2),DIK="^HL(772,"
2599+"RTN","HLCSTCP1",113,0)
2600+ D ^DIK
2601+"RTN","HLCSTCP1",114,0)
2602+ Q
2603+"RTN","HLCSTCP1",115,0)
2604+MIEN ; sets HLIND1=ien in 773^ien in 772 for message
2605+"RTN","HLCSTCP1",116,0)
2606+ N HLMID,X
2607+"RTN","HLCSTCP1",117,0)
2608+ I HLIND1 D
2609+"RTN","HLCSTCP1",118,0)
2610+ . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
2611+"RTN","HLCSTCP1",119,0)
2612+ . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
2613+"RTN","HLCSTCP1",120,0)
2614+ ;msg. id is 10th of MSH & 11th for BSH or FSH
2615+"RTN","HLCSTCP1",121,0)
2616+ S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
2617+"RTN","HLCSTCP1",122,0)
2618+ ;if HLIND1 is set, kill old message, use HLIND1 for new
2619+"RTN","HLCSTCP1",123,0)
2620+ ;message, it means we never got end block for 1st msg.
2621+"RTN","HLCSTCP1",124,0)
2622+ I HLIND1 D Q
2623+"RTN","HLCSTCP1",125,0)
2624+ . ;get pointer to 772, kill header
2625+"RTN","HLCSTCP1",126,0)
2626+ . K ^HLMA(+HLIND1,"MSH")
2627+"RTN","HLCSTCP1",127,0)
2628+ . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
2629+"RTN","HLCSTCP1",128,0)
2630+ . S X=$$MAID^HLTF(+HLIND1,HLMID)
2631+"RTN","HLCSTCP1",129,0)
2632+ . D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
2633+"RTN","HLCSTCP1",130,0)
2634+ . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
2635+"RTN","HLCSTCP1",131,0)
2636+ D TCP^HLTF(.HLMID,.X,.HLDT)
2637+"RTN","HLCSTCP1",132,0)
2638+ I 'X D Q
2639+"RTN","HLCSTCP1",133,0)
2640+ . ;error - record and reset array
2641+"RTN","HLCSTCP1",134,0)
2642+ . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
2643+"RTN","HLCSTCP1",135,0)
2644+ . D CLEAN K HLLSTN
2645+"RTN","HLCSTCP1",136,0)
2646+ . ;error 100=LLP Could not Enqueue the Message, reset array
2647+"RTN","HLCSTCP1",137,0)
2648+ . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
2649+"RTN","HLCSTCP1",138,0)
2650+ ;HLIND1=ien in 773^ien in 772
2651+"RTN","HLCSTCP1",139,0)
2652+ S HLIND1=X_U_+$G(^HLMA(X,0))
2653+"RTN","HLCSTCP1",140,0)
2654+ ;save MSH into 773
2655+"RTN","HLCSTCP1",141,0)
2656+ D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
2657+"RTN","HLCSTCP1",142,0)
2658+ Q
2659+"RTN","HLCSTCP1",143,0)
2660+ ;
2661+"RTN","HLCSTCP1",144,0)
2662+PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
2663+"RTN","HLCSTCP1",145,0)
2664+ N FS,I,L,L1,L2,X,Y
2665+"RTN","HLCSTCP1",146,0)
2666+ S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
2667+"RTN","HLCSTCP1",147,0)
2668+ F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0))
2669+"RTN","HLCSTCP1",148,0)
2670+ . S:L1=1 L=L+1
2671+"RTN","HLCSTCP1",149,0)
2672+ . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
2673+"RTN","HLCSTCP1",150,0)
2674+ . S L2=Y,Y=L
2675+"RTN","HLCSTCP1",151,0)
2676+ Q X
2677+"RTN","HLCSTCP1",152,0)
2678+ ;
2679+"RTN","HLCSTCP1",153,0)
2680+PING ;process PING message
2681+"RTN","HLCSTCP1",154,0)
2682+ S X=HLMSG(1,0)
2683+"RTN","HLCSTCP1",155,0)
2684+ I X[HLDEND U IO W X,!
2685+"RTN","HLCSTCP1",156,0)
2686+CLEAN ;reset var. for next message
2687+"RTN","HLCSTCP1",157,0)
2688+ K HLMSG
2689+"RTN","HLCSTCP1",158,0)
2690+ S HLINE=0,HLRDOUT=1
2691+"RTN","HLCSTCP1",159,0)
2692+ Q
2693+"RTN","HLCSTCP1",160,0)
2694+ ;
2695+"RTN","HLCSTCP1",161,0)
2696+ERROR ; Error trap for disconnect error and return back to the read loop.
2697+"RTN","HLCSTCP1",162,0)
2698+ S $ETRAP="D UNWIND^%ZTER"
2699+"RTN","HLCSTCP1",163,0)
2700+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
2701+"RTN","HLCSTCP1",164,0)
2702+ I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
2703+"RTN","HLCSTCP1",165,0)
2704+ S HLCSOUT=1 D ^%ZTER,CC("Error")
2705+"RTN","HLCSTCP1",166,0)
2706+ D UNWIND^%ZTER
2707+"RTN","HLCSTCP1",167,0)
2708+ Q
2709+"RTN","HLCSTCP1",168,0)
2710+ ;
2711+"RTN","HLCSTCP1",169,0)
2712+CC(X) ;cleanup and close
2713+"RTN","HLCSTCP1",170,0)
2714+ D MON^HLCSTCP(X)
2715+"RTN","HLCSTCP1",171,0)
2716+ H 2
2717+"RTN","HLCSTCP1",172,0)
2718+ Q
2719+"RTN","HLCSTCP1",173,0)
2720+RESET ;reset info as a result of no end block
2721+"RTN","HLCSTCP1",174,0)
2722+ N %
2723+"RTN","HLCSTCP1",175,0)
2724+ S HLMSG(1,0)=HLMSG(HLINE,0)
2725+"RTN","HLCSTCP1",176,0)
2726+ F %=2:1:HLINE K HLMSG(%,0)
2727+"RTN","HLCSTCP1",177,0)
2728+ S HLINE=1
2729+"RTN","HLCSTCP1",178,0)
2730+ Q
2731+"RTN","MAGDMEDL")
2732+0^36^B3132920
2733+"RTN","MAGDMEDL",1,0)
2734+MAGDMEDL ;WOIFO/LB,MSC/JDA - Routine to look up entries in the Medicine files ;27APR2009
2735+"RTN","MAGDMEDL",2,0)
2736+ ;;3.0;IMAGING;**MSC**;Mar 01, 2002
2737+"RTN","MAGDMEDL",3,0)
2738+ ;; +---------------------------------------------------------------+
2739+"RTN","MAGDMEDL",4,0)
2740+ ;; | Property of the US Government. |
2741+"RTN","MAGDMEDL",5,0)
2742+ ;; | No permission to copy or redistribute this software is given. |
2743+"RTN","MAGDMEDL",6,0)
2744+ ;; | Use of unreleased versions of this software requires the user |
2745+"RTN","MAGDMEDL",7,0)
2746+ ;; | to execute a written test agreement with the VistA Imaging |
2747+"RTN","MAGDMEDL",8,0)
2748+ ;; | Development Office of the Department of Veterans Affairs, |
2749+"RTN","MAGDMEDL",9,0)
2750+ ;; | telephone (301) 734-0100. |
2751+"RTN","MAGDMEDL",10,0)
2752+ ;; | |
2753+"RTN","MAGDMEDL",11,0)
2754+ ;; | The Food and Drug Administration classifies this software as |
2755+"RTN","MAGDMEDL",12,0)
2756+ ;; | a medical device. As such, it may not be changed in any way. |
2757+"RTN","MAGDMEDL",13,0)
2758+ ;; | Modifications to this software may result in an adulterated |
2759+"RTN","MAGDMEDL",14,0)
2760+ ;; | medical device under 21CFR820, the use of which is considered |
2761+"RTN","MAGDMEDL",15,0)
2762+ ;; | to be a violation of US Federal Statutes. |
2763+"RTN","MAGDMEDL",16,0)
2764+ ;; +---------------------------------------------------------------+
2765+"RTN","MAGDMEDL",17,0)
2766+ ;;
2767+"RTN","MAGDMEDL",18,0)
2768+ Q
2769+"RTN","MAGDMEDL",19,0)
2770+SELECT(ITEM,ARRAY) ;
2771+"RTN","MAGDMEDL",20,0)
2772+ ;
2773+"RTN","MAGDMEDL",21,0)
2774+SELECT2
2775+"RTN","MAGDMEDL",22,0)
2776+ N CNT,DIR,DIROUT,DIRUT,ENTRY
2777+"RTN","MAGDMEDL",23,0)
2778+ S CNT=+ARRAY
2779+"RTN","MAGDMEDL",24,0)
2780+ I 'CNT Q 0
2781+"RTN","MAGDMEDL",25,0)
2782+ S DIR(0)="NO^1:"_CNT,DIR("A")="Select a Medicine Procedure"
2783+"RTN","MAGDMEDL",26,0)
2784+ S DIR("T")=600 D ^DIR
2785+"RTN","MAGDMEDL",27,0)
2786+ I $D(DIRUT)!($D(DIROUT)) Q 0
2787+"RTN","MAGDMEDL",28,0)
2788+ S ENTRY=+Y
2789+"RTN","MAGDMEDL",29,0)
2790+ I '$D(ARRAY(ENTRY)) D G SELECT2
2791+"RTN","MAGDMEDL",30,0)
2792+ . W !,"Please select an entry or use '^' to exit"
2793+"RTN","MAGDMEDL",31,0)
2794+ W !,"You have selected ",$P(ARRAY(ENTRY),"^"),"."
2795+"RTN","MAGDMEDL",32,0)
2796+ Q $P(ARRAY(ENTRY),"^",2)
2797+"RTN","MAGDMEDL",33,0)
2798+ ;
2799+"RTN","MAGDMEDL",34,0)
2800+LOOP(ARRAY,MAGPAT,SUB,CASEDT) ;
2801+"RTN","MAGDMEDL",35,0)
2802+ ; MAGPAT = patient's dfn
2803+"RTN","MAGDMEDL",36,0)
2804+ ; SUB = Medicine specialty
2805+"RTN","MAGDMEDL",37,0)
2806+ ; CASEDT = case date
2807+"RTN","MAGDMEDL",38,0)
2808+ ; array(0)= 1 or 0 ^ # entries found ^ message text
2809+"RTN","MAGDMEDL",39,0)
2810+ ; array(#)= formatted out dislay without delimeters
2811+"RTN","MAGDMEDL",40,0)
2812+ ; array(#,1) = internal stored values
2813+"RTN","MAGDMEDL",41,0)
2814+ ; Variable MAGDIMG
2815+"RTN","MAGDMEDL",42,0)
2816+ S ARRAY(0)="0^^No entries found"
2817+"RTN","MAGDMEDL",43,0)
2818+ Q:'MAGPAT
2819+"RTN","MAGDMEDL",44,0)
2820+ Q:'$D(MAGMC)#10 ;Array should be available.
2821+"RTN","MAGDMEDL",45,0)
2822+ N BEG,CDT,CNT,DATA,DIOCM,EN,END,IMG,IMAGEPTR,MAGDIMG,PATIENT,PATNME,PRCNM,SSN,THEDT,X1,X2,X
2823+"RTN","MAGDMEDL",46,0)
2824+ N IEN,II,IOUT,MAGMC,MEDFILE
2825+"RTN","MAGDMEDL",47,0)
2826+ Q:'$$FIND1^DIC(2,,"A",MAGPAT,"","")
2827+"RTN","MAGDMEDL",48,0)
2828+ S PATNME=$P(^DPT(MAGPAT,0),"^"),SSN=$P(^(0),"^",9)
2829+"RTN","MAGDMEDL",49,0)
2830+ S PATIENT=PATNME_" "_SSN
2831+"RTN","MAGDMEDL",50,0)
2832+ I 'CASEDT S CASEDT=DT
2833+"RTN","MAGDMEDL",51,0)
2834+ S X1=CASEDT,X2=-3 D C^%DTC S BEG=X
2835+"RTN","MAGDMEDL",52,0)
2836+ S END=CASEDT+.9999
2837+"RTN","MAGDMEDL",53,0)
2838+ S CNT=0,CDT=BEG-.001
2839+"RTN","MAGDMEDL",54,0)
2840+ F S CDT=$O(MAGMC(MAGPAT,SUB,CDT)) Q:'CDT!(CDT>END) D
2841+"RTN","MAGDMEDL",55,0)
2842+ . S EN=0 F S EN=$O(MAGMC(MAGPAT,SUB,CDT,EN)) Q:'EN D
2843+"RTN","MAGDMEDL",56,0)
2844+ . . S DATA=MAGMC(MAGPAT,SUB,CDT,EN)
2845+"RTN","MAGDMEDL",57,0)
2846+ . . S PRCNM=$P(DATA,"^",2),PRC=SUB
2847+"RTN","MAGDMEDL",58,0)
2848+ . . S THEDT=$P(DATA,"^"),IEN=$P(DATA,"^",5)
2849+"RTN","MAGDMEDL",59,0)
2850+ . . I $D(MAGMC(MAGPAT,SUB,CDT,EN,2005)) S (IOUT,II)=0 D
2851+"RTN","MAGDMEDL",60,0)
2852+ . . . F S II=$O(MAGMC(MAGPAT,SUB,CDT,EN,2005,II)) Q:'II!IOUT D
2853+"RTN","MAGDMEDL",61,0)
2854+ . . . . S IMAGEPTR=MAGMC(MAGPAT,SUB,CDT,EN,2005,II)
2855+"RTN","MAGDMEDL",62,0)
2856+ . . . . I '$D(^MAG(2005,IMAGEPTR)) S IMAGEPTR="" Q
2857+"RTN","MAGDMEDL",63,0)
2858+ . . . . I '$D(^MAG(2005,IMAGEPTR,"PACS")) S IMAGEPTR="",IOUT=1
2859+"RTN","MAGDMEDL",64,0)
2860+ . . S MEDFILE=$P(DATA,"^",4),MEDFILE=$P(MEDFILE,"MCAR(",2)
2861+"RTN","MAGDMEDL",65,0)
2862+ . . S DICOM="" D DICOMID^MAGDMEDI(.DICOM,MEDFILE,IEN,PRC,MAGPAT)
2863+"RTN","MAGDMEDL",66,0)
2864+ . . I DICOM'="" D
2865+"RTN","MAGDMEDL",67,0)
2866+ . . . S DICOM=$P(DICOM,":",2)
2867+"RTN","MAGDMEDL",68,0)
2868+ . . . S CNT=CNT+1
2869+"RTN","MAGDMEDL",69,0)
2870+ . . . S ARRAY(CNT)=DICOM_" "_PRCNM_", "_THEDT_" "_PATIENT
2871+"RTN","MAGDMEDL",70,0)
2872+ . . . S ARRAY(CNT,1)=DICOM_"^"_PATNME_"^"_SSN_"^"_EN_"^"_PRCNM_"^"_PRC_"^"_$G(IMAGEPTR)_"^"_MEDFILE
2873+"RTN","MAGDMEDL",71,0)
2874+ I CNT S ARRAY(0)="1^"_CNT_"^Medicine file entries for "_PATIENT
2875+"RTN","MAGDMEDL",72,0)
2876+ Q
2877+"RTN","MAGDMEDL",73,0)
2878+DISPLAY(ARRAY) ;
2879+"RTN","MAGDMEDL",74,0)
2880+ ; Call routine needs to pass array in the following sequence
2881+"RTN","MAGDMEDL",75,0)
2882+ ; ARRAY(0)= 1 or 0 ^ #entries ^ message
2883+"RTN","MAGDMEDL",76,0)
2884+ ; ARRAY(#)= Formatted output to be displayed.
2885+"RTN","MAGDMEDL",77,0)
2886+ ; Will set the RES variable for selected entry.
2887+"RTN","MAGDMEDL",78,0)
2888+ I '$D(ARRAY(0)) Q 0
2889+"RTN","MAGDMEDL",79,0)
2890+ ; If only one entry return the subscript variable.
2891+"RTN","MAGDMEDL",80,0)
2892+ I $P(ARRAY(0),"^",2)=1 Q 1
2893+"RTN","MAGDMEDL",81,0)
2894+ I $P(ARRAY(0),"^")'=1 Q 0
2895+"RTN","MAGDMEDL",82,0)
2896+ N ENTRY,ITEM,ITEMS,MSG,OUT,OUTPUT,RES
2897+"RTN","MAGDMEDL",83,0)
2898+ S RES=0,MSG=$P(ARRAY(0),"^",3)
2899+"RTN","MAGDMEDL",84,0)
2900+ S IOF="#,$C(27,91,72,27,91,74,8,8,8,8)",IO=0,IOSL=24,POP=0
2901+"RTN","MAGDMEDL",85,0)
2902+ D HEAD
2903+"RTN","MAGDMEDL",86,0)
2904+ S (ENTRY,OUT)=0,ITEMS=$P(ARRAY(0),"^",2)
2905+"RTN","MAGDMEDL",87,0)
2906+ F S ENTRY=$O(ARRAY(ENTRY)) Q:'ENTRY!OUT D
2907+"RTN","MAGDMEDL",88,0)
2908+ . S OUTPUT=$G(ARRAY(ENTRY))
2909+"RTN","MAGDMEDL",89,0)
2910+ . D:$Y+3>IOSL HEAD D LINE
2911+"RTN","MAGDMEDL",90,0)
2912+ . D:$Y+3>IOSL ASKQ
2913+"RTN","MAGDMEDL",91,0)
2914+ I 'OUT D ASKQ S RES=ITEM
2915+"RTN","MAGDMEDL",92,0)
2916+ Q RES
2917+"RTN","MAGDMEDL",93,0)
2918+HEAD ;
2919+"RTN","MAGDMEDL",94,0)
2920+ W:$Y+3>IOSL @IOF W !,MSG
2921+"RTN","MAGDMEDL",95,0)
2922+ Q
2923+"RTN","MAGDMEDL",96,0)
2924+LINE ;
2925+"RTN","MAGDMEDL",97,0)
2926+ W !,ENTRY,".) "_OUTPUT
2927+"RTN","MAGDMEDL",98,0)
2928+ Q
2929+"RTN","MAGDMEDL",99,0)
2930+ASKQ ;
2931+"RTN","MAGDMEDL",100,0)
2932+ N X,Y,DIR
2933+"RTN","MAGDMEDL",101,0)
2934+ S DIR(0)="L^1:"_$S('ENTRY:ITEMS,1:ENTRY)
2935+"RTN","MAGDMEDL",102,0)
2936+ S DIR("T")=600,DIR("A")="Select an entry: " D ^DIR
2937+"RTN","MAGDMEDL",103,0)
2938+ S ITEM=+Y
2939+"RTN","MAGDMEDL",104,0)
2940+ Q:$D(DIRUT)!($D(DIROUT))
2941+"RTN","MAGDMEDL",105,0)
2942+ Q:'ITEM
2943+"RTN","MAGDMEDL",106,0)
2944+ I '$D(ARRAY(ITEM)) W !,"Please select an entry or '^' to exit" G ASKQ
2945+"RTN","MAGDMEDL",107,0)
2946+ W !,"You have selected ",$P($G(ARRAY(ITEM)),"^")
2947+"RTN","MAGDMEDL",108,0)
2948+ S OUT=1
2949+"RTN","MAGDMEDL",109,0)
2950+ Q
2951+"RTN","MAGDMEDL",110,0)
2952+ASKMORE() ;
2953+"RTN","MAGDMEDL",111,0)
2954+ N DIR,DATE,X,XX,Y
2955+"RTN","MAGDMEDL",112,0)
2956+ Q:'$D(MAGPAT)
2957+"RTN","MAGDMEDL",113,0)
2958+ Q:'$D(SUB)
2959+"RTN","MAGDMEDL",114,0)
2960+ S DIR(0)="Y",DIR("B")="NO"
2961+"RTN","MAGDMEDL",115,0)
2962+ S DIR("A")="Search further"
2963+"RTN","MAGDMEDL",116,0)
2964+ D ^DIR K DIR
2965+"RTN","MAGDMEDL",117,0)
2966+ I 'Y Q 0
2967+"RTN","MAGDMEDL",118,0)
2968+ W !,"Search will include 3 days prior to the day specified."
2969+"RTN","MAGDMEDL",119,0)
2970+ S DIR(0)="D^::EXP" D ^DIR
2971+"RTN","MAGDMEDL",120,0)
2972+ ; Y2K compliance all calls to %DT must have either past or future date
2973+"RTN","MAGDMEDL",121,0)
2974+ I 'Y Q 0
2975+"RTN","MAGDMEDL",122,0)
2976+ S DATE=Y
2977+"RTN","MAGDMEDL",123,0)
2978+ D LOOP(.XX,MAGPAT,SUB,DATE)
2979+"RTN","MAGDMEDL",124,0)
2980+ I $D(XX(0)),$P(XX(0),"^")=0 D Q 0
2981+"RTN","MAGDMEDL",125,0)
2982+ . W "No entries found."
2983+"RTN","MAGDMEDL",126,0)
2984+ Q 1
2985+"RTN","MSCGUX53")
2986+0^^B360592
2987+"RTN","MSCGUX53",1,0)
2988+MSCGUX53 ;MSC/JDS - ENVIRONMENT CHECK ; ; 29 Apr 2009 1:47 PM
2989+"RTN","MSCGUX53",2,0)
2990+ ;;**MSC**;
2991+"RTN","MSCGUX53",3,0)
2992+ I $G(^%ZOSF("OS"))'["GT.M" Q ;Not GTM
2993+"RTN","MSCGUX53",4,0)
2994+ I $P($ZV,"V",2)<5.3 D MESS^XPDUL("GT.M version must be 5.3 or Greater") S XPDABORT=2
2995+"RTN","MSCGUX53",5,0)
2996+
2997+"RTN","MSCGUX53",6,0)
2998+
2999+"RTN","MSCGUX53",7,0)
3000+
3001+"RTN","MSCXUS3A")
3002+0^31^B8005003
3003+"RTN","MSCXUS3A",1,0)
3004+MSCXUS3A ;SF-ISC/STAFF MSC/JDS - CHANGE UCI'S ;30APR2009
3005+"RTN","MSCXUS3A",2,0)
3006+ ;;8.0;KERNEL;**13,282,MSC**;Jul 10, 1995
3007+"RTN","MSCXUS3A",3,0)
3008+ Q
3009+"RTN","MSCXUS3A",4,0)
3010+ ;PICK A UCI TO SWITCH TO
3011+"RTN","MSCXUS3A",5,0)
3012+SWITCH ;Allow users that have the UCI fIeld In there NP fIle to swItch UCI's.
3013+"RTN","MSCXUS3A",6,0)
3014+ W !!,"Switch UCI's optIon.",!
3015+"RTN","MSCXUS3A",7,0)
3016+ ;I $$PROGMODE^%ZOSV() W !,$C(7),"No switching UCI's In Programmer Mode." Q
3017+"RTN","MSCXUS3A",8,0)
3018+ N DIR,X,Y,PGM,%UCI,DEF,L,USERNAME
3019+"RTN","MSCXUS3A",9,0)
3020+ S DEF="ZU" ;DEF is default routine to swItch to.
3021+"RTN","MSCXUS3A",10,0)
3022+UCI Q:'$G(DUZ) S USERNAME=$P($G(^VA(200,DUZ,0)),U) Q:USERNAME=""
3023+"RTN","MSCXUS3A",11,0)
3024+ S DIR(0)="S^"_$$NSP(USERNAME) I DIR(0)'[";" W "YOU AREN'T A USER IN ANY OTHER NAMESPACE" Q
3025+"RTN","MSCXUS3A",12,0)
3026+ S DIR("A")="Select NAMESPACE"
3027+"RTN","MSCXUS3A",13,0)
3028+ D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) Q
3029+"RTN","MSCXUS3A",14,0)
3030+SAME I X="" Q ;Didn't select anythIng.
3031+"RTN","MSCXUS3A",15,0)
3032+ ;D PM
3033+"RTN","MSCXUS3A",16,0)
3034+ S (X,%UCI)=Y(0) X ^%ZOSF("UCICHECK") I 0[Y G BAD
3035+"RTN","MSCXUS3A",17,0)
3036+ K XQY0 S Y=$O(^[%UCI]VA(200,"B",USERNAME,0))
3037+"RTN","MSCXUS3A",18,0)
3038+ I Y S DIR=$P($G(^[%UCI]VA(200,Y,201)),U)
3039+"RTN","MSCXUS3A",19,0)
3040+ I DIR,$P($G(^[%UCI]DIC(19,DIR,0)),U,4)="M" S DUZ=Y,XQY=DIR,(DEF,PGM)="%MSCXUCI" G NXT
3041+"RTN","MSCXUS3A",20,0)
3042+BAD W !,"UCI not found!" D SHOW G UCI
3043+"RTN","MSCXUS3A",21,0)
3044+ ;
3045+"RTN","MSCXUS3A",22,0)
3046+NXT ;Here we go.
3047+"RTN","MSCXUS3A",23,0)
3048+ D C^XUSCLEAN K ^XUTL("XQ",$J),^XUTL($J),^TMP($J),^UTILITY($J)
3049+"RTN","MSCXUS3A",24,0)
3050+ K DA G GO^%MSCXUCI
3051+"RTN","MSCXUS3A",25,0)
3052+ ;
3053+"RTN","MSCXUS3A",26,0)
3054+ ;
3055+"RTN","MSCXUS3A",27,0)
3056+SHOW W ! S I=0,UC="",X=$S($D(^VA(200,DUZ,201)):+^(201),1:0)
3057+"RTN","MSCXUS3A",28,0)
3058+ W !,"Enter ^ to return to your current menu, or select from:"
3059+"RTN","MSCXUS3A",29,0)
3060+ F I=0:0 S I=$O(^VA(200,DUZ,.2,I)) Q:I'>0 D
3061+"RTN","MSCXUS3A",30,0)
3062+ . W !,?5 S UC=$G(^VA(200,DUZ,.2,I,0)),X=$P(UC,U,1),UC=$P(UC,U,2,99)
3063+"RTN","MSCXUS3A",31,0)
3064+ . I UC'[":" W I
3065+"RTN","MSCXUS3A",32,0)
3066+ . D PM W ?10,X X ^%ZOSF("UCICHECK") I 0[Y W " -- Not currently a valId UCI!",$C(7) Q
3067+"RTN","MSCXUS3A",33,0)
3068+ . W:UC]"" ":"_UC
3069+"RTN","MSCXUS3A",34,0)
3070+ . Q
3071+"RTN","MSCXUS3A",35,0)
3072+ Q
3073+"RTN","MSCXUS3A",36,0)
3074+ ;
3075+"RTN","MSCXUS3A",37,0)
3076+PM I X="PROD"!(X="MGR") S X=^%ZOSF(X)
3077+"RTN","MSCXUS3A",38,0)
3078+ Q
3079+"RTN","MSCXUS3A",39,0)
3080+ ;
3081+"RTN","MSCXUS3A",40,0)
3082+ ;
3083+"RTN","MSCXUS3A",41,0)
3084+ ;
3085+"RTN","MSCXUS3A",42,0)
3086+NSP(USERNAME) ;LIST OTHER NAMESPACES WHERE THIS USER IS
3087+"RTN","MSCXUS3A",43,0)
3088+ N X,L,I,Y
3089+"RTN","MSCXUS3A",44,0)
3090+ X ^%ZOSF("UCI") S Y=$P(Y,",") I ^%ZOSF("OS")["GT.M" G GTMNSP
3091+"RTN","MSCXUS3A",45,0)
3092+ f I=1:1:$zu(90,0) s L($zu(90,2,0,I))="" ;***CACHE-SPECIFIC FROM %NSP
3093+"RTN","MSCXUS3A",46,0)
3094+ S (I,L,X)="" F S I=$O(L(I)) Q:I="" I I'=Y D ;NOT THE CURRENT ONE
3095+"RTN","MSCXUS3A",47,0)
3096+ .N DUZ S DUZ=$O(^[I]VA(200,"B",USERNAME,0)) Q:'DUZ
3097+"RTN","MSCXUS3A",48,0)
3098+ .I $P($G(^[I]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE
3099+"RTN","MSCXUS3A",49,0)
3100+ .S L=L+1,X=X_L_":"_I_";"
3101+"RTN","MSCXUS3A",50,0)
3102+ Q X
3103+"RTN","MSCXUS3A",51,0)
3104+GTMNSP ;
3105+"RTN","MSCXUS3A",52,0)
3106+ N CURRENT S CURRENT=Y
3107+"RTN","MSCXUS3A",53,0)
3108+ D LIST^ZCD()
3109+"RTN","MSCXUS3A",54,0)
3110+ S (I,L,X)="" F S I=$O(Y(I)) Q:'I S A=Y(I) I A'=CURRENT D ;NOT THE CURRENT ONE
3111+"RTN","MSCXUS3A",55,0)
3112+ .S A=$P($ZG,"/"_$$CURRENT^ZCD_"/")_"/"_A_"/"_$P($ZG,"/"_$$CURRENT^ZCD_"/",2)
3113+"RTN","MSCXUS3A",56,0)
3114+ .N DUZ S DUZ=$O(^[A]VA(200,"B",USERNAME,0)) Q:'DUZ
3115+"RTN","MSCXUS3A",57,0)
3116+ .I $P($G(^[A]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE
3117+"RTN","MSCXUS3A",58,0)
3118+ .S L=L+1,X=X_L_":"_A_";"
3119+"RTN","MSCXUS3A",59,0)
3120+ Q X
3121+"RTN","MSCZJOB")
3122+0^1^B11312416
3123+"RTN","MSCZJOB",1,0)
3124+MSCZJOB ;GFT,JDS/MSC;1 MAY 2009
3125+"RTN","MSCZJOB",2,0)
3126+ ;;8.0;KERNEL;**MSC**
3127+"RTN","MSCZJOB",3,0)
3128+ W !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3129+"RTN","MSCZJOB",4,0)
3130+ N MSC
3131+"RTN","MSCZJOB",5,0)
3132+DDS ;
3133+"RTN","MSCZJOB",6,0)
3134+ S DDSFILE=3.081,DR="[MSCZJOBEXAM]",DDSPARM="S"
3135+"RTN","MSCZJOB",7,0)
3136+ D ^DDS Q
3137+"RTN","MSCZJOB",8,0)
3138+ ;
3139+"RTN","MSCZJOB",9,0)
3140+UNLOCK(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
3141+"RTN","MSCZJOB",10,0)
3142+ N X,R S R=$G(@MSC@(MSCJOBID,"L",D0)) I R'["^" Q ;CAN'T SEE IT
3143+"RTN","MSCZJOB",11,0)
3144+ S R=$P(R," ",2),X="L "_R D ^DIM Q:'$D(X)
3145+"RTN","MSCZJOB",12,0)
3146+ D UNLOCK^MSCZJOBU(R)
3147+"RTN","MSCZJOB",13,0)
3148+ Q
3149+"RTN","MSCZJOB",14,0)
3150+ ;
3151+"RTN","MSCZJOB",15,0)
3152+KILL(J) ;FROM FIELD
3153+"RTN","MSCZJOB",16,0)
3154+ D KILL^MSCZJOBU(J)
3155+"RTN","MSCZJOB",17,0)
3156+ Q
3157+"RTN","MSCZJOB",18,0)
3158+ ;
3159+"RTN","MSCZJOB",19,0)
3160+COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK
3161+"RTN","MSCZJOB",20,0)
3162+ N X,D0,J
3163+"RTN","MSCZJOB",21,0)
3164+ S MSC="^TMP(""MSCZJOB"")" D POLL
3165+"RTN","MSCZJOB",22,0)
3166+ F D0=0:0 S D0=$O(MSCZJOB(D0)) Q:'D0 D
3167+"RTN","MSCZJOB",23,0)
3168+ .S MSCZJOB(D0)=MSCZJOB(D0)_U_$$DEV(D0)_U_$$USER(D0)_U_$$NSP(D0)_U_U_U_U_U_$$ROUTINE(D0)
3169+"RTN","MSCZJOB",24,0)
3170+ .S X=MSCZJOB(D0) X DICMX
3171+"RTN","MSCZJOB",25,0)
3172+ Q
3173+"RTN","MSCZJOB",26,0)
3174+JOB(D0) Q $P(MSCZJOB(D0),U) ;***
3175+"RTN","MSCZJOB",27,0)
3176+DEV(D0) Q $$FIND(D0,"I","$PRINCIPAL")
3177+"RTN","MSCZJOB",28,0)
3178+NSP(D0) N N D Q N
3179+"RTN","MSCZJOB",29,0)
3180+ .N L,P S N=$$FIND(D0,"I","$ZGBLDIR"),L=$L(N,"/") I L<2 Q
3181+"RTN","MSCZJOB",30,0)
3182+ .F L=L-1:-1:2 S P=$P(N,"/",L) I P'[".",P'["globals" Q
3183+"RTN","MSCZJOB",31,0)
3184+ .S P=1 I $P(N,"/")="" S P=2
3185+"RTN","MSCZJOB",32,0)
3186+ .S N=$P(N,"/",P,L)
3187+"RTN","MSCZJOB",33,0)
3188+USER(D0) Q $P($G(^VA(200,+$$FIND(D0,"V","DUZ"),0)),U)
3189+"RTN","MSCZJOB",34,0)
3190+ROUTINE(D0) Q $$FIND(D0,"V","%ZPOS")
3191+"RTN","MSCZJOB",35,0)
3192+ ;
3193+"RTN","MSCZJOB",36,0)
3194+FIND(D0,ARR,KEY) N I,J,X S X="",J=+MSCZJOB(D0)
3195+"RTN","MSCZJOB",37,0)
3196+ F I=0:0 S I=$O(@MSC@(J,ARR,I)) Q:'I I $P(^(I),KEY_"=")="" S X=$TR($P(^(I),"=",2),"""") Q
3197+"RTN","MSCZJOB",38,0)
3198+ Q X
3199+"RTN","MSCZJOB",39,0)
3200+ ;
3201+"RTN","MSCZJOB",40,0)
3202+COMPSTK ;COMPUTED MULTIPLE FOR MSCZJOBSTACK BLOCK
3203+"RTN","MSCZJOB",41,0)
3204+ S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1
3205+"RTN","MSCZJOB",42,0)
3206+ N D0,J S J=MSCJOBID
3207+"RTN","MSCZJOB",43,0)
3208+ F D0=1:1:$O(@MSC@(J,"S",""),-1) S X="" X DICMX
3209+"RTN","MSCZJOB",44,0)
3210+ Q
3211+"RTN","MSCZJOB",45,0)
3212+ ;
3213+"RTN","MSCZJOB",46,0)
3214+STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0))
3215+"RTN","MSCZJOB",47,0)
3216+ Q X
3217+"RTN","MSCZJOB",48,0)
3218+ ;
3219+"RTN","MSCZJOB",49,0)
3220+COMPVARS ;COMPUTED MULTIPLE FOR MSCZJOBVARS BLOCK
3221+"RTN","MSCZJOB",50,0)
3222+ S MSC="^TMP(""MSCZJOB"")" K @MSC@(MSCJOBID) D POLL1
3223+"RTN","MSCZJOB",51,0)
3224+ N D0,J S J=MSCJOBID
3225+"RTN","MSCZJOB",52,0)
3226+ F D0=1:1:$O(@MSC@(J,"V",""),-1) S X="" X DICMX
3227+"RTN","MSCZJOB",53,0)
3228+ Q
3229+"RTN","MSCZJOB",54,0)
3230+ ;
3231+"RTN","MSCZJOB",55,0)
3232+COMPLKS ;COMPUTED MULTIPLE FOR MSCZJOBLOCKS BLOCK
3233+"RTN","MSCZJOB",56,0)
3234+ S MSC="^TMP(""MSCZJOB"")" D POLL1
3235+"RTN","MSCZJOB",57,0)
3236+ N D0
3237+"RTN","MSCZJOB",58,0)
3238+ F D0=1:1:$$LOCKS S X="" X DICMX
3239+"RTN","MSCZJOB",59,0)
3240+ Q
3241+"RTN","MSCZJOB",60,0)
3242+ ;
3243+"RTN","MSCZJOB",61,0)
3244+LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1)
3245+"RTN","MSCZJOB",62,0)
3246+ ;
3247+"RTN","MSCZJOB",63,0)
3248+POLL K MSCZJOB ;D HLP^DDSUTL(" POLLING JOBS.....")
3249+"RTN","MSCZJOB",64,0)
3250+ I $G(^%ZOSF("OS"))["GT.M" D
3251+"RTN","MSCZJOB",65,0)
3252+ .K @MSC
3253+"RTN","MSCZJOB",66,0)
3254+ .D INTRPT^MSCZJOBU("*") ;SETS UP ^TMP
3255+"RTN","MSCZJOB",67,0)
3256+ .N MSCA,I D PIDS^MSCZJOBU(.MSCA)
3257+"RTN","MSCZJOB",68,0)
3258+ .S MSCA="" F I=1:1 S MSCA=$O(MSCA(MSCA)) Q:'MSCA S MSCZJOB(I)=MSCA ;SETS UP LOCAL ARRAY
3259+"RTN","MSCZJOB",69,0)
3260+ .H 1 ;WAIT FOR POLLING
3261+"RTN","MSCZJOB",70,0)
3262+ D TEST
3263+"RTN","MSCZJOB",71,0)
3264+ Q
3265+"RTN","MSCZJOB",72,0)
3266+ ;
3267+"RTN","MSCZJOB",73,0)
3268+POLL1 Q:'$G(MSCJOBID)
3269+"RTN","MSCZJOB",74,0)
3270+ I $G(^%ZOSF("OS"))["GT.M" D
3271+"RTN","MSCZJOB",75,0)
3272+ .K @MSC@(MSCJOBID)
3273+"RTN","MSCZJOB",76,0)
3274+ .D INTRPT^MSCZJOBU(MSCJOBID) ;SETS UP ^TMP(MSCZJOB)
3275+"RTN","MSCZJOB",77,0)
3276+ .H 1 ;WAIT FOR POLLING
3277+"RTN","MSCZJOB",78,0)
3278+ D TEST
3279+"RTN","MSCZJOB",79,0)
3280+ Q
3281+"RTN","MSCZJOB",80,0)
3282+ ;
3283+"RTN","MSCZJOB",81,0)
3284+TEST Q
3285+"RTN","MSCZJOB",82,0)
3286+COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK
3287+"RTN","MSCZJOB",83,0)
3288+ N X,D0,J
3289+"RTN","MSCZJOB",84,0)
3290+ S MSC="^TMP(""MSCZJOB"")" D POLL S D0=0
3291+"RTN","MSCZJOB",85,0)
3292+ F K=0:0 S K=$O(MSCZJOB(K)) Q:'K D
3293+"RTN","MSCZJOB",86,0)
3294+ .F J=0:0 S J=$O(^TMP("MSCZJOB",MSCZJOB(K),"L",J)) Q:'J S A=$TR(^(J),U,"~") D
3295+"RTN","MSCZJOB",87,0)
3296+ ..S D0=D0+1,MSCZLK(D0)=$P(A,"LOCK ",2,9)_U_$$USER(K)_U_$TR($$ROUTINE(K),U,"~")_"^^"_MSCZJOB(K)
3297+"RTN","MSCZJOB",88,0)
3298+ ..S X=MSCZLK(D0) X DICMX
3299+"RTN","MSCZJOB",89,0)
3300+ Q
3301+"RTN","MSCZJOB",90,0)
3302+LOCK ;
3303+"RTN","MSCZJOB",91,0)
3304+ S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S"
3305+"RTN","MSCZJOB",92,0)
3306+ D ^DDS Q
3307+"RTN","MSCZJOB",93,0)
3308+UNL(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK
3309+"RTN","MSCZJOB",94,0)
3310+ N X,R S R=$P($G(MSCZLK(D0)),U),P=$P($G(MSCZLK(D0)),U,5) ;I R'["^" Q ;CAN'T SEE IT
3311+"RTN","MSCZJOB",95,0)
3312+ S R=$P(R,"~",2),R="^"_$S(R'["(":$P(R," "),1:$P(R,")")_")"),X="L "_R D ^DIM Q:'$D(X) ;GOOD SYNTAX?
3313+"RTN","MSCZJOB",96,0)
3314+ D UNLOCK^MSCZJOBU(R)
3315+"RTN","MSCZJOBS")
3316+0^46^B3252583
3317+"RTN","MSCZJOBS",1,0)
3318+MSCZJOBS ;JKT/MSC - OpenVista System status ;27MAY2009
3319+"RTN","MSCZJOBS",2,0)
3320+ ;;8.0;KERNEL;**MSC**
3321+"RTN","MSCZJOBS",3,0)
3322+ ;
3323+"RTN","MSCZJOBS",4,0)
3324+ALL D SS() Q
3325+"RTN","MSCZJOBS",5,0)
3326+THIS D SS(1) Q
3327+"RTN","MSCZJOBS",6,0)
3328+ ;
3329+"RTN","MSCZJOBS",7,0)
3330+SS(THIS) ;Print GT.M mumps processes
3331+"RTN","MSCZJOBS",8,0)
3332+ ; If THIS is true, only print processes associated with the current
3333+"RTN","MSCZJOBS",9,0)
3334+ ; OpenVista instance
3335+"RTN","MSCZJOBS",10,0)
3336+ ;
3337+"RTN","MSCZJOBS",11,0)
3338+ Q:$G(^%ZOSF("OS"))'["GT.M"
3339+"RTN","MSCZJOBS",12,0)
3340+ ;
3341+"RTN","MSCZJOBS",13,0)
3342+ D INTRPT^MSCZJOBU("*") H .5
3343+"RTN","MSCZJOBS",14,0)
3344+ ;
3345+"RTN","MSCZJOBS",15,0)
3346+ N DATETIME S DATETIME=$$HTE^XLFDT($H)
3347+"RTN","MSCZJOBS",16,0)
3348+ W #!,?22,"OpenVista System Status"
3349+"RTN","MSCZJOBS",17,0)
3350+ W !,?(34-($L(DATETIME)/2)\1),DATETIME
3351+"RTN","MSCZJOBS",18,0)
3352+ W !!,?1,"Process",?12,"Device",?30,"Instance",?42,"Routine",?56,"User"
3353+"RTN","MSCZJOBS",19,0)
3354+ ;
3355+"RTN","MSCZJOBS",20,0)
3356+ N PID S PID=""
3357+"RTN","MSCZJOBS",21,0)
3358+ D PIDS^MSCZJOBU(.PID)
3359+"RTN","MSCZJOBS",22,0)
3360+ F S PID=$O(PID(PID)) Q:PID="" D
3361+"RTN","MSCZJOBS",23,0)
3362+ . I $G(THIS) Q:$$INSTANCE(PID)'=$$CURRENT^ZCD()
3363+"RTN","MSCZJOBS",24,0)
3364+ . W !,$$PID(PID)
3365+"RTN","MSCZJOBS",25,0)
3366+ . W ?12,$$DEVICE(PID)
3367+"RTN","MSCZJOBS",26,0)
3368+ . W ?30,$$INSTANCE(PID)
3369+"RTN","MSCZJOBS",27,0)
3370+ . W ?42,$$ROUTINE(PID)
3371+"RTN","MSCZJOBS",28,0)
3372+ . W ?56,$$USER(PID)
3373+"RTN","MSCZJOBS",29,0)
3374+ ;
3375+"RTN","MSCZJOBS",30,0)
3376+ W !! ZSY "uptime"
3377+"RTN","MSCZJOBS",31,0)
3378+ Q
3379+"RTN","MSCZJOBS",32,0)
3380+ ;
3381+"RTN","MSCZJOBS",33,0)
3382+PID(PID) ;Return process ID formatted for display
3383+"RTN","MSCZJOBS",34,0)
3384+ Q $J(PID,8)_$S($J=PID:"*",1:"")
3385+"RTN","MSCZJOBS",35,0)
3386+ ;
3387+"RTN","MSCZJOBS",36,0)
3388+DEVICE(PID) ;Return device
3389+"RTN","MSCZJOBS",37,0)
3390+ Q $$FIND("^TMP(""MSCZJOB"")",PID,"I","$PRINCIPAL")
3391+"RTN","MSCZJOBS",38,0)
3392+ ;
3393+"RTN","MSCZJOBS",39,0)
3394+INSTANCE(PID) ;Return name of OpenVista instance
3395+"RTN","MSCZJOBS",40,0)
3396+ N ZG S ZG=$$FIND("^TMP(""MSCZJOB"")",PID,"I","$ZGBLDIR")
3397+"RTN","MSCZJOBS",41,0)
3398+ Q $P(ZG,"/",$L(ZG,"/")-2)
3399+"RTN","MSCZJOBS",42,0)
3400+ ;
3401+"RTN","MSCZJOBS",43,0)
3402+ROUTINE(PID) ;Return routine
3403+"RTN","MSCZJOBS",44,0)
3404+ Q $P($$FIND("^TMP(""MSCZJOB"")",PID,"V","%ZPOS"),"^",2)
3405+"RTN","MSCZJOBS",45,0)
3406+ ;
3407+"RTN","MSCZJOBS",46,0)
3408+USER(PID) ;Return OpenVista user
3409+"RTN","MSCZJOBS",47,0)
3410+ N DUZ S DUZ=+$$FIND("^TMP(""MSCZJOB"")",PID,"V","DUZ")
3411+"RTN","MSCZJOBS",48,0)
3412+ ; FIXME: this code is looking up the name of the person in *this*
3413+"RTN","MSCZJOBS",49,0)
3414+ ; instance, which assumes that ^VA(200) is the same across databases
3415+"RTN","MSCZJOBS",50,0)
3416+ Q $P($G(^VA(200,DUZ,0)),"^")
3417+"RTN","MSCZJOBS",51,0)
3418+ ;
3419+"RTN","MSCZJOBS",52,0)
3420+FIND(NODE,PID,ARR,KEY) ;Return the value of a key in one of the ZSHOW arrays
3421+"RTN","MSCZJOBS",53,0)
3422+ N I,X S I="",X=""
3423+"RTN","MSCZJOBS",54,0)
3424+ F S I=$O(@NODE@(PID,ARR,I)) Q:'I I $P(^(I),KEY_"=")="" S X=$TR($P(^(I),"=",2),"""") Q
3425+"RTN","MSCZJOBS",55,0)
3426+ Q X
3427+"RTN","MSCZJOBU")
3428+0^4^B2386063
3429+"RTN","MSCZJOBU",1,0)
3430+MSCZJOBU ;RHL,JDS,JKT/MSC;20MAY2009
3431+"RTN","MSCZJOBU",2,0)
3432+ ;;8.0;KERNEL;**MSC**
3433+"RTN","MSCZJOBU",3,0)
3434+ ;
3435+"RTN","MSCZJOBU",4,0)
3436+ ; JOB EXAM UTILITIES FOR GT.M
3437+"RTN","MSCZJOBU",5,0)
3438+ Q
3439+"RTN","MSCZJOBU",6,0)
3440+PIDS(XARY) ; GET ARRAY OF ALL MUMPS PROCESS
3441+"RTN","MSCZJOBU",7,0)
3442+ ; XARY PASSED BY REFERENCE
3443+"RTN","MSCZJOBU",8,0)
3444+ ; RETURNS XARY(PID)=""
3445+"RTN","MSCZJOBU",9,0)
3446+ ; NOTE: Unix PID=$J for all mumps processes.
3447+"RTN","MSCZJOBU",10,0)
3448+ ;
3449+"RTN","MSCZJOBU",11,0)
3450+ N DEV
3451+"RTN","MSCZJOBU",12,0)
3452+ S DEV="psdev"
3453+"RTN","MSCZJOBU",13,0)
3454+ OPEN DEV:(COMM="ps -o pid= -C mumps")::"PIPE" U DEV
3455+"RTN","MSCZJOBU",14,0)
3456+ ;
3457+"RTN","MSCZJOBU",15,0)
3458+ N %I S %I=$I
3459+"RTN","MSCZJOBU",16,0)
3460+ N %J ; $JOB
3461+"RTN","MSCZJOBU",17,0)
3462+ F U DEV R %J U %I Q:%J="" D
3463+"RTN","MSCZJOBU",18,0)
3464+ . F Q:$E(%J,1)'=" " S %J=$E(%J,2,999) ; strip leading spaces
3465+"RTN","MSCZJOBU",19,0)
3466+ . S XARY(%J)=""
3467+"RTN","MSCZJOBU",20,0)
3468+ ;
3469+"RTN","MSCZJOBU",21,0)
3470+ C DEV
3471+"RTN","MSCZJOBU",22,0)
3472+ Q
3473+"RTN","MSCZJOBU",23,0)
3474+ ;
3475+"RTN","MSCZJOBU",24,0)
3476+INTRPT(PID) ; SEND mupip intrpt to process with PID
3477+"RTN","MSCZJOBU",25,0)
3478+ ; WHICH CAUSES THE $ZINTERRUPT CODE TO BE EXECUTED.
3479+"RTN","MSCZJOBU",26,0)
3480+ ; PID PASSED BY VALUE
3481+"RTN","MSCZJOBU",27,0)
3482+ ; PID CAN BE A SINGLE PID, I.E. $J
3483+"RTN","MSCZJOBU",28,0)
3484+ ; PID CAN BE A "*" WHICH SENDS AN INTERRUPT TO ALL MUMPS PROCESSES
3485+"RTN","MSCZJOBU",29,0)
3486+ ;
3487+"RTN","MSCZJOBU",30,0)
3488+ Q:$G(PID)'?1N.N&($G(PID)'="*")
3489+"RTN","MSCZJOBU",31,0)
3490+ ;
3491+"RTN","MSCZJOBU",32,0)
3492+ N CMD,DEV
3493+"RTN","MSCZJOBU",33,0)
3494+ S CMD="gtmsignal -q "_$S(PID="*":"-a",1:PID)
3495+"RTN","MSCZJOBU",34,0)
3496+ S DEV="gtmsignaldev"
3497+"RTN","MSCZJOBU",35,0)
3498+ OPEN DEV:(COMM=CMD)::"PIPE" U DEV C DEV
3499+"RTN","MSCZJOBU",36,0)
3500+ Q
3501+"RTN","MSCZJOBU",37,0)
3502+ ;
3503+"RTN","MSCZJOBU",38,0)
3504+KILL(PID) ; Send mupip stop to process with PID
3505+"RTN","MSCZJOBU",39,0)
3506+ ; PID PASSED BY VALUE
3507+"RTN","MSCZJOBU",40,0)
3508+ ; PID CAN BE A SINGLE PID, I.E. $J
3509+"RTN","MSCZJOBU",41,0)
3510+ ;
3511+"RTN","MSCZJOBU",42,0)
3512+ Q:$G(PID)'?1N.N
3513+"RTN","MSCZJOBU",43,0)
3514+ ;
3515+"RTN","MSCZJOBU",44,0)
3516+ N DEV
3517+"RTN","MSCZJOBU",45,0)
3518+ S DEV="gtmsignaldev"
3519+"RTN","MSCZJOBU",46,0)
3520+ OPEN DEV:(COMM="gtmsignal -q -s "_PID)::"PIPE" U DEV C DEV
3521+"RTN","MSCZJOBU",47,0)
3522+ Q
3523+"RTN","MSCZJOBU",48,0)
3524+ ;
3525+"RTN","MSCZJOBU",49,0)
3526+UNLOCK(NODE) ; Use lke to remove lock on NODE.
3527+"RTN","MSCZJOBU",50,0)
3528+ N CMD,DEV
3529+"RTN","MSCZJOBU",51,0)
3530+ S CMD="lke clear -lock="""_NODE_""" -nointeractive -output=/dev/null"
3531+"RTN","MSCZJOBU",52,0)
3532+ S DEV="lkedev"
3533+"RTN","MSCZJOBU",53,0)
3534+ OPEN DEV:(COMM=CMD)::"PIPE" U DEV C DEV
3535+"RTN","MSCZJOBU",54,0)
3536+ Q
3537+"RTN","PRCSEA")
3538+0^37^B66865498
3539+"RTN","PRCSEA",1,0)
3540+PRCSEA ;WISC/SAW/DXH/BM/SC/DAP,MSC/JDA - CONTROL POINT ACTIVITY EDITS ;27APR2009
3541+"RTN","PRCSEA",2,0)
3542+V ;;5.1;IFCAP;**81,MSC**;Oct 20, 2000
3543+"RTN","PRCSEA",3,0)
3544+ ;Per VHA Directive 10-93-142, this routine should not be modified.
3545+"RTN","PRCSEA",4,0)
3546+ ;
3547+"RTN","PRCSEA",5,0)
3548+ ;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code
3549+"RTN","PRCSEA",6,0)
3550+ ;to update Audit file (#414.02), and send update message to
3551+"RTN","PRCSEA",7,0)
3552+ ;DynaMed thru a call to rtn PRCVTCA.
3553+"RTN","PRCSEA",8,0)
3554+ ;
3555+"RTN","PRCSEA",9,0)
3556+ENRS ;ENTER REQ
3557+"RTN","PRCSEA",10,0)
3558+ S PRCSK=1,X3="H"
3559+"RTN","PRCSEA",11,0)
3560+ D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197
3561+"RTN","PRCSEA",12,0)
3562+ G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered
3563+"RTN","PRCSEA",13,0)
3564+ D W6 ; display help on transaction# format
3565+"RTN","PRCSEA",14,0)
3566+ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="AELQ",D="H"
3567+"RTN","PRCSEA",15,0)
3568+ S DIC("A")="Select TRANSACTION: "
3569+"RTN","PRCSEA",16,0)
3570+ S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match
3571+"RTN","PRCSEA",17,0)
3572+ D ^PRCSDIC ; lookup & preliminary validity checking
3573+"RTN","PRCSEA",18,0)
3574+ K DLAYGO,DIC("A"),DIC("S")
3575+"RTN","PRCSEA",19,0)
3576+ G:Y<0 EXIT
3577+"RTN","PRCSEA",20,0)
3578+ I $P(Y,U,3)'=1 W $C(7)," Must be a new entry." G ENRS0
3579+"RTN","PRCSEA",21,0)
3580+ ;*81 Check site parameter to see if issue books are allowed
3581+"RTN","PRCSEA",22,0)
3582+ D CKPRM^PRCSEB
3583+"RTN","PRCSEA",23,0)
3584+ W !!,PRCVY,!
3585+"RTN","PRCSEA",24,0)
3586+ S (PDA,T1,DA)=+Y
3587+"RTN","PRCSEA",25,0)
3588+ L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0
3589+"RTN","PRCSEA",26,0)
3590+ S T(2)=$P(Y,U,2)
3591+"RTN","PRCSEA",27,0)
3592+ D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410)
3593+"RTN","PRCSEA",28,0)
3594+ S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by)
3595+"RTN","PRCSEA",29,0)
3596+ S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default
3597+"RTN","PRCSEA",30,0)
3598+ I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP,^PRCS(410,"AO",PRCSIP,DA)="" ; PRCSIP was set up in PRCSUT & is inventory distribution point
3599+"RTN","PRCSEA",31,0)
3600+ S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM
3601+"RTN","PRCSEA",32,0)
3602+ I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
3603+"RTN","PRCSEA",33,0)
3604+TYPE ;
3605+"RTN","PRCSEA",34,0)
3606+ W !!,"This transaction is assigned temporary transaction number: ",T(2)
3607+"RTN","PRCSEA",35,0)
3608+ S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ"
3609+"RTN","PRCSEA",36,0)
3610+ S DIC("S")=PRCVX ; only allow selection of 2237's
3611+"RTN","PRCSEA",37,0)
3612+ D ^DIC
3613+"RTN","PRCSEA",38,0)
3614+ S DA=PDA
3615+"RTN","PRCSEA",39,0)
3616+ ;if user didn't enter a form type, go ask whether to backout and act
3617+"RTN","PRCSEA",40,0)
3618+ ;accordingly: go let them re-enter a form type or exit
3619+"RTN","PRCSEA",41,0)
3620+ I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT
3621+"RTN","PRCSEA",42,0)
3622+ ;
3623+"RTN","PRCSEA",43,0)
3624+ I Y<2 W "??" G TYPE
3625+"RTN","PRCSEA",44,0)
3626+ K PRCVX,PRCVY
3627+"RTN","PRCSEA",45,0)
3628+ S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y ; form type
3629+"RTN","PRCSEA",46,0)
3630+ ; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes',
3631+"RTN","PRCSEA",47,0)
3632+ ; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated.
3633+"RTN","PRCSEA",48,0)
3634+ S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
3635+"RTN","PRCSEA",49,0)
3636+ K PRCSERR ; flag denoting item info is missing
3637+"RTN","PRCSEA",50,0)
3638+ S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
3639+"RTN","PRCSEA",51,0)
3640+ S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
3641+"RTN","PRCSEA",52,0)
3642+EN1 K DTOUT,DUOUT,Y
3643+"RTN","PRCSEA",53,0)
3644+ D ^DIE
3645+"RTN","PRCSEA",54,0)
3646+ S DA=PDA
3647+"RTN","PRCSEA",55,0)
3648+ I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT
3649+"RTN","PRCSEA",56,0)
3650+ D RL^PRCSUT1 ; sets up 'IT' & '10' nodes
3651+"RTN","PRCSEA",57,0)
3652+ D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item')
3653+"RTN","PRCSEA",58,0)
3654+ D DOR ; populate date of request field if it is nil
3655+"RTN","PRCSEA",59,0)
3656+ L -^PRCS(410,DA)
3657+"RTN","PRCSEA",60,0)
3658+ S T="enter" D W5 G EXIT:%'=1
3659+"RTN","PRCSEA",61,0)
3660+ W !! K PRCS("SUB")
3661+"RTN","PRCSEA",62,0)
3662+ G ENRS
3663+"RTN","PRCSEA",63,0)
3664+ ;
3665+"RTN","PRCSEA",64,0)
3666+EDRS ;EDIT REQ
3667+"RTN","PRCSEA",65,0)
3668+ ; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn
3669+"RTN","PRCSEA",66,0)
3670+ ; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197
3671+"RTN","PRCSEA",67,0)
3672+ ; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user
3673+"RTN","PRCSEA",68,0)
3674+ D W6 ; format doc for txn#
3675+"RTN","PRCSEA",69,0)
3676+ S X3="H" S DIC="^PRCS(410,",DIC(0)="AEQ",D="H"
3677+"RTN","PRCSEA",70,0)
3678+ S DIC("A")="Select TRANSACTION: "
3679+"RTN","PRCSEA",71,0)
3680+ S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)'=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored & cannot be a 1358
3681+"RTN","PRCSEA",72,0)
3682+ D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S")
3683+"RTN","PRCSEA",73,0)
3684+ S (PDA,DA,T1)=+Y
3685+"RTN","PRCSEA",74,0)
3686+ L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS
3687+"RTN","PRCSEA",75,0)
3688+ ; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option
3689+"RTN","PRCSEA",76,0)
3690+ ; D EN2B^PRCSUT3
3691+"RTN","PRCSEA",77,0)
3692+ S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5)
3693+"RTN","PRCSEA",78,0)
3694+ S PRC("CP")=$P(^PRCS(410,PDA,3),"^")
3695+"RTN","PRCSEA",79,0)
3696+ I $P(^PRCS(410,PDA,0),"^",6)="" D ; prc*5*197
3697+"RTN","PRCSEA",80,0)
3698+ . N PRCSIP D IP^PRCSUT
3699+"RTN","PRCSEA",81,0)
3700+ . I $D(PRCSIP) S $P(^PRC(410,DA,0),U,6)=PRCSIP
3701+"RTN","PRCSEA",82,0)
3702+ S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM
3703+"RTN","PRCSEA",83,0)
3704+ ;*81 Check site parameter to see if Issue Books are allowed
3705+"RTN","PRCSEA",84,0)
3706+ D CKPRM
3707+"RTN","PRCSEA",85,0)
3708+ I PRCVD=1 S PRCVZ=1
3709+"RTN","PRCSEA",86,0)
3710+ I PRCVD'=1 S PRCVZ=0
3711+"RTN","PRCSEA",87,0)
3712+ W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),!
3713+"RTN","PRCSEA",88,0)
3714+ I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." S T="edit" D W5 G:%'=1 EXIT W !! K PRCS("SUB") G EDRS
3715+"RTN","PRCSEA",89,0)
3716+ ;
3717+"RTN","PRCSEA",90,0)
3718+ S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
3719+"RTN","PRCSEA",91,0)
3720+ ;P182--Modified next 3 lines to use new templates if supply fund FCP
3721+"RTN","PRCSEA",92,0)
3722+ S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
3723+"RTN","PRCSEA",93,0)
3724+ED1 K DTOUT,DUOUT,Y
3725+"RTN","PRCSEA",94,0)
3726+ D ^DIE
3727+"RTN","PRCSEA",95,0)
3728+ S DA=PDA
3729+"RTN","PRCSEA",96,0)
3730+ I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT
3731+"RTN","PRCSEA",97,0)
3732+ D RL^PRCSUT1
3733+"RTN","PRCSEA",98,0)
3734+ D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1
3735+"RTN","PRCSEA",99,0)
3736+ K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ
3737+"RTN","PRCSEA",100,0)
3738+ L -^PRCS(410,DA)
3739+"RTN","PRCSEA",101,0)
3740+ S T="edit" D W5 G EXIT:%'=1
3741+"RTN","PRCSEA",102,0)
3742+ W !! K PRCS("SUB")
3743+"RTN","PRCSEA",103,0)
3744+ G EDRS
3745+"RTN","PRCSEA",104,0)
3746+ ;
3747+"RTN","PRCSEA",105,0)
3748+CT ;CANCEL A (PERMANENT) TRANS
3749+"RTN","PRCSEA",106,0)
3750+ D EN3^PRCSUT
3751+"RTN","PRCSEA",107,0)
3752+ G W2:'$D(PRC("SITE")),EXIT:Y<0
3753+"RTN","PRCSEA",108,0)
3754+ S DIC="^PRCS(410,",DIC(0)="AEMQ"
3755+"RTN","PRCSEA",109,0)
3756+ ;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
3757+"RTN","PRCSEA",110,0)
3758+ S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
3759+"RTN","PRCSEA",111,0)
3760+ S DIC("A")="Select TRANSACTION: "
3761+"RTN","PRCSEA",112,0)
3762+ D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A")
3763+"RTN","PRCSEA",113,0)
3764+CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1
3765+"RTN","PRCSEA",114,0)
3766+ S DA=+Y
3767+"RTN","PRCSEA",115,0)
3768+ L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT
3769+"RTN","PRCSEA",116,0)
3770+ S T=$P(^PRCS(410,DA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0
3771+"RTN","PRCSEA",117,0)
3772+ K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),DA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
3773+"RTN","PRCSEA",118,0)
3774+ K ZX
3775+"RTN","PRCSEA",119,0)
3776+ I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
3777+"RTN","PRCSEA",120,0)
3778+ I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX
3779+"RTN","PRCSEA",121,0)
3780+ I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,DA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1)
3781+"RTN","PRCSEA",122,0)
3782+ D ERS410^PRC0G(DA_"^C")
3783+"RTN","PRCSEA",123,0)
3784+ W !,"Enter comments for this cancellation",!
3785+"RTN","PRCSEA",124,0)
3786+ S DIE=DIC,DR=60
3787+"RTN","PRCSEA",125,0)
3788+ D ^DIE
3789+"RTN","PRCSEA",126,0)
3790+ ;PRC*5.1*81 if DM trx, update Audit file and send msg to DM
3791+"RTN","PRCSEA",127,0)
3792+ D EN^PRCVTCA(DA)
3793+"RTN","PRCSEA",128,0)
3794+ L -^PRCS(410,DA)
3795+"RTN","PRCSEA",129,0)
3796+ I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK
3797+"RTN","PRCSEA",130,0)
3798+ S T="cancel" D W4 G EXIT:%'=1
3799+"RTN","PRCSEA",131,0)
3800+ W !! G CT
3801+"RTN","PRCSEA",132,0)
3802+ ;
3803+"RTN","PRCSEA",133,0)
3804+DT ;DELETE A (TEMPORARY) TRANS
3805+"RTN","PRCSEA",134,0)
3806+ S X3="H"
3807+"RTN","PRCSEA",135,0)
3808+ D W6 ; format doc for txn#
3809+"RTN","PRCSEA",136,0)
3810+ S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H"
3811+"RTN","PRCSEA",137,0)
3812+ S DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))"
3813+"RTN","PRCSEA",138,0)
3814+ D ^PRCSDIC G EXIT:Y<0
3815+"RTN","PRCSEA",139,0)
3816+ K DIC("S"),DIC("A")
3817+"RTN","PRCSEA",140,0)
3818+ S DA=+Y
3819+"RTN","PRCSEA",141,0)
3820+ L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT
3821+"RTN","PRCSEA",142,0)
3822+DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1
3823+"RTN","PRCSEA",143,0)
3824+ ;The following line was commented out in patch 182; should NOT manually
3825+"RTN","PRCSEA",144,0)
3826+ ;change or reset last assigned IEN # in node zero.
3827+"RTN","PRCSEA",145,0)
3828+ ;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC
3829+"RTN","PRCSEA",146,0)
3830+ S DIK=DIC
3831+"RTN","PRCSEA",147,0)
3832+ W !,"Okay....."
3833+"RTN","PRCSEA",148,0)
3834+ D ^DIK K DIK
3835+"RTN","PRCSEA",149,0)
3836+ L -^PRCS(410,DA)
3837+"RTN","PRCSEA",150,0)
3838+ ;The following line was commented out in patch 182; should NOT manually
3839+"RTN","PRCSEA",151,0)
3840+ ;change or reset last assigned IEN # in node zero.
3841+"RTN","PRCSEA",152,0)
3842+ ;S $P(^PRCS(410,0),U,3)=PRCSDA
3843+"RTN","PRCSEA",153,0)
3844+ K PRCSDA
3845+"RTN","PRCSEA",154,0)
3846+ W "It's deleted"
3847+"RTN","PRCSEA",155,0)
3848+ S T="delete" D W4 G EXIT:%'=1
3849+"RTN","PRCSEA",156,0)
3850+ W !! G DT
3851+"RTN","PRCSEA",157,0)
3852+ ;
3853+"RTN","PRCSEA",158,0)
3854+ ;
3855+"RTN","PRCSEA",159,0)
3856+DOR ; Date of Request
3857+"RTN","PRCSEA",160,0)
3858+ I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q
3859+"RTN","PRCSEA",161,0)
3860+ S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y
3861+"RTN","PRCSEA",162,0)
3862+ Q
3863+"RTN","PRCSEA",163,0)
3864+FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed
3865+"RTN","PRCSEA",164,0)
3866+ D CKPRM
3867+"RTN","PRCSEA",165,0)
3868+ I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option."
3869+"RTN","PRCSEA",166,0)
3870+ I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option."
3871+"RTN","PRCSEA",167,0)
3872+ W !,PRCVY1,!
3873+"RTN","PRCSEA",168,0)
3874+ W !,"Please enter another form type",!
3875+"RTN","PRCSEA",169,0)
3876+ S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ"
3877+"RTN","PRCSEA",170,0)
3878+ S DIC("S")=PRCVX1
3879+"RTN","PRCSEA",171,0)
3880+ D ^DIC
3881+"RTN","PRCSEA",172,0)
3882+ S:Y=-1 Y=2
3883+"RTN","PRCSEA",173,0)
3884+ S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y
3885+"RTN","PRCSEA",174,0)
3886+ K DIC,PRCVX1,PRCVY1,PRCVD
3887+"RTN","PRCSEA",175,0)
3888+ Q
3889+"RTN","PRCSEA",176,0)
3890+ ;
3891+"RTN","PRCSEA",177,0)
3892+ ;Allow user the option of re entering a form type. If they decline,
3893+"RTN","PRCSEA",178,0)
3894+ ;kill off the transaction and return 1; else return 0
3895+"RTN","PRCSEA",179,0)
3896+BACKOUT(TRNNAME,TRNDA) ;
3897+"RTN","PRCSEA",180,0)
3898+ N DIK,Y,%,DA
3899+"RTN","PRCSEA",181,0)
3900+ F D Q:%'=0
3901+"RTN","PRCSEA",182,0)
3902+ . W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7)
3903+"RTN","PRCSEA",183,0)
3904+ . W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN
3905+"RTN","PRCSEA",184,0)
3906+ . Q
3907+"RTN","PRCSEA",185,0)
3908+ I %=2 Q 0
3909+"RTN","PRCSEA",186,0)
3910+ S DIK="^PRCS(410,",DA=TRNDA
3911+"RTN","PRCSEA",187,0)
3912+ D ^DIK
3913+"RTN","PRCSEA",188,0)
3914+ Q 1
3915+"RTN","PRCSEA",189,0)
3916+ ;
3917+"RTN","PRCSEA",190,0)
3918+W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT
3919+"RTN","PRCSEA",191,0)
3920+W3 Q ; can this subroutine be deleted? commented out in patch PRC*5*140
3921+"RTN","PRCSEA",192,0)
3922+ W !!,"This transaction is assigned temporary transaction number: ",X Q
3923+"RTN","PRCSEA",193,0)
3924+W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q
3925+"RTN","PRCSEA",194,0)
3926+W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q
3927+"RTN","PRCSEA",195,0)
3928+W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q
3929+"RTN","PRCSEA",196,0)
3930+ ;*81 Site parameter pull
3931+"RTN","PRCSEA",197,0)
3932+CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
3933+"RTN","PRCSEA",198,0)
3934+ Q
3935+"RTN","PRCSEA",199,0)
3936+ ;
3937+"RTN","PRCSEA",200,0)
3938+EXIT K %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ
3939+"RTN","PRCSEA",201,0)
3940+ I $D(PRCSERR) K PRCSERR
3941+"RTN","PRCSEA",202,0)
3942+ Q
3943+"RTN","PSBOMH1")
3944+0^38^B71152392
3945+"RTN","PSBOMH1",1,0)
3946+PSBOMH1 ;BIRMINGHAM/EFC,MSC/JDA - MAH ;27APR2009
3947+"RTN","PSBOMH1",2,0)
3948+ ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,MSC**;Mar 2004
3949+"RTN","PSBOMH1",3,0)
3950+ ;
3951+"RTN","PSBOMH1",4,0)
3952+ ; Reference/IA
3953+"RTN","PSBOMH1",5,0)
3954+ ; ^DILF/2054
3955+"RTN","PSBOMH1",6,0)
3956+ ; File 200/10060
3957+"RTN","PSBOMH1",7,0)
3958+ ;
3959+"RTN","PSBOMH1",8,0)
3960+EN ;
3961+"RTN","PSBOMH1",9,0)
3962+ ; Load administrations
3963+"RTN","PSBOMH1",10,0)
3964+ S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT
3965+"RTN","PSBOMH1",11,0)
3966+ K PSBTSA
3967+"RTN","PSBOMH1",12,0)
3968+ F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D
3969+"RTN","PSBOMH1",13,0)
3970+ .F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN)
3971+"RTN","PSBOMH1",14,0)
3972+ ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt
3973+"RTN","PSBOMH1",15,0)
3974+ ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven
3975+"RTN","PSBOMH1",16,0)
3976+ ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1)
3977+"RTN","PSBOMH1",17,0)
3978+ ..; Continuous
3979+"RTN","PSBOMH1",18,0)
3980+ ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C"
3981+"RTN","PSBOMH1",19,0)
3982+ ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1))
3983+"RTN","PSBOMH1",20,0)
3984+ ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBMR) D D CLEAN^PSBVT Q ;chck IV audit
3985+"RTN","PSBOMH1",21,0)
3986+ ....S PSBSIEN=PSBIEN
3987+"RTN","PSBOMH1",22,0)
3988+ ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1))
3989+"RTN","PSBOMH1",23,0)
3990+ ....S PSBIEN=PSBSIEN K PSBSIEN
3991+"RTN","PSBOMH1",24,0)
3992+ ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X)
3993+"RTN","PSBOMH1",25,0)
3994+ ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT
3995+"RTN","PSBOMH1",26,0)
3996+ ....I X="" K PSBAUD Q
3997+"RTN","PSBOMH1",27,0)
3998+ ....I '$D(PSBAUD(X)) K PSBAUD Q
3999+"RTN","PSBOMH1",28,0)
4000+ ....S PSBS=$P(PSBAUD(X),U,3)
4001+"RTN","PSBOMH1",29,0)
4002+ ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q
4003+"RTN","PSBOMH1",30,0)
4004+ ....I PSBS="NOT GIVEN" Q
4005+"RTN","PSBOMH1",31,0)
4006+ ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION")
4007+"RTN","PSBOMH1",32,0)
4008+ ....D PSBSTIV^PSBOMH2
4009+"RTN","PSBOMH1",33,0)
4010+ ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN
4011+"RTN","PSBOMH1",34,0)
4012+ ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
4013+"RTN","PSBOMH1",35,0)
4014+ ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
4015+"RTN","PSBOMH1",36,0)
4016+ ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
4017+"RTN","PSBOMH1",37,0)
4018+ ....D PSBOUT($P((X),"^",1),$P((X),"^",2))
4019+"RTN","PSBOMH1",38,0)
4020+ ....K PSBAUD
4021+"RTN","PSBOMH1",39,0)
4022+ ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
4023+"RTN","PSBOMH1",40,0)
4024+ ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
4025+"RTN","PSBOMH1",41,0)
4026+ ...I PSBINIT="" S PSBINIT=99
4027+"RTN","PSBOMH1",42,0)
4028+ ...;get instrc info - audt log
4029+"RTN","PSBOMH1",43,0)
4030+ ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
4031+"RTN","PSBOMH1",44,0)
4032+ ....D INSTR^PSBOMH
4033+"RTN","PSBOMH1",45,0)
4034+ ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
4035+"RTN","PSBOMH1",46,0)
4036+ ...I PSBINIT[99 S PSBINIT=""
4037+"RTN","PSBOMH1",47,0)
4038+ ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A")
4039+"RTN","PSBOMH1",48,0)
4040+ ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B")
4041+"RTN","PSBOMH1",49,0)
4042+ ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D
4043+"RTN","PSBOMH1",50,0)
4044+ ....D DDAUD
4045+"RTN","PSBOMH1",51,0)
4046+ ....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D
4047+"RTN","PSBOMH1",52,0)
4048+ .....S PSBS=$P(PSBTAR(I),U,3)
4049+"RTN","PSBOMH1",53,0)
4050+ .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given
4051+"RTN","PSBOMH1",54,0)
4052+ .....I PSBS="NOT GIVEN" Q
4053+"RTN","PSBOMH1",55,0)
4054+ .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION")
4055+"RTN","PSBOMH1",56,0)
4056+ .....D PSBCTAR^PSBOMH2
4057+"RTN","PSBOMH1",57,0)
4058+ .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN
4059+"RTN","PSBOMH1",58,0)
4060+ ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1
4061+"RTN","PSBOMH1",59,0)
4062+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X
4063+"RTN","PSBOMH1",60,0)
4064+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y
4065+"RTN","PSBOMH1",61,0)
4066+ ...D PSBOUT($P((X),"^",1),$P((X),"^",2))
4067+"RTN","PSBOMH1",62,0)
4068+ ...Q
4069+"RTN","PSBOMH1",63,0)
4070+ ..; 1-Time On Call or PRN
4071+"RTN","PSBOMH1",64,0)
4072+ ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C"
4073+"RTN","PSBOMH1",65,0)
4074+ ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q
4075+"RTN","PSBOMH1",66,0)
4076+ ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
4077+"RTN","PSBOMH1",67,0)
4078+ ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
4079+"RTN","PSBOMH1",68,0)
4080+ ...I PSBINIT="" S PSBINIT=99
4081+"RTN","PSBOMH1",69,0)
4082+ ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)=""
4083+"RTN","PSBOMH1",70,0)
4084+ ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D
4085+"RTN","PSBOMH1",71,0)
4086+ ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0)
4087+"RTN","PSBOMH1",72,0)
4088+ ....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q
4089+"RTN","PSBOMH1",73,0)
4090+ ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
4091+"RTN","PSBOMH1",74,0)
4092+ ....D INSTR^PSBOMH
4093+"RTN","PSBOMH1",75,0)
4094+ ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
4095+"RTN","PSBOMH1",76,0)
4096+ ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT)
4097+"RTN","PSBOMH1",77,0)
4098+ ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2=""
4099+"RTN","PSBOMH1",78,0)
4100+ ...I PSBINIT[99 S PSBINIT=""
4101+"RTN","PSBOMH1",79,0)
4102+ ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P"
4103+"RTN","PSBOMH1",80,0)
4104+ ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: <No PRN Results On File>"
4105+"RTN","PSBOMH1",81,0)
4106+ ....E D
4107+"RTN","PSBOMH1",82,0)
4108+ .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL")
4109+"RTN","PSBOMH1",83,0)
4110+ .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME")
4111+"RTN","PSBOMH1",84,0)
4112+ .....I PSBINIT="" S PSBINIT=99
4113+"RTN","PSBOMH1",85,0)
4114+ .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
4115+"RTN","PSBOMH1",86,0)
4116+ ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
4117+"RTN","PSBOMH1",87,0)
4118+ ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)=""
4119+"RTN","PSBOMH1",88,0)
4120+ .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D
4121+"RTN","PSBOMH1",89,0)
4122+ ......D:$D(^PSB(53.79,PSBIEN,.9,0))
4123+"RTN","PSBOMH1",90,0)
4124+ .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1
4125+"RTN","PSBOMH1",91,0)
4126+ ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2))
4127+"RTN","PSBOMH1",92,0)
4128+ .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
4129+"RTN","PSBOMH1",93,0)
4130+ .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1
4131+"RTN","PSBOMH1",94,0)
4132+ .....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22)
4133+"RTN","PSBOMH1",95,0)
4134+ .....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24)
4135+"RTN","PSBOMH1",96,0)
4136+ .....I PSBINIT[99 S PSBINIT=""
4137+"RTN","PSBOMH1",97,0)
4138+ ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK)))
4139+"RTN","PSBOMH1",98,0)
4140+ ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1
4141+"RTN","PSBOMH1",99,0)
4142+ ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1
4143+"RTN","PSBOMH1",100,0)
4144+ ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1
4145+"RTN","PSBOMH1",101,0)
4146+ ...I $G(PSBLINE2)]"" D
4147+"RTN","PSBOMH1",102,0)
4148+ ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW
4149+"RTN","PSBOMH1",103,0)
4150+ ....I $L(PSBLINE2)>90 D
4151+"RTN","PSBOMH1",104,0)
4152+ .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90)
4153+"RTN","PSBOMH1",105,0)
4154+ .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161)
4155+"RTN","PSBOMH1",106,0)
4156+ .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW
4157+"RTN","PSBOMH1",107,0)
4158+ .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW
4159+"RTN","PSBOMH1",108,0)
4160+ Q
4161+"RTN","PSBOMH1",109,0)
4162+ ;
4163+"RTN","PSBOMH1",110,0)
4164+DDAUD ; audits for dispen drugs
4165+"RTN","PSBOMH1",111,0)
4166+ ;
4167+"RTN","PSBOMH1",112,0)
4168+ M PSBMLA=^PSB(53.79,PSBIEN)
4169+"RTN","PSBOMH1",113,0)
4170+ S PSBGA="" I $D(PSBMLA(.9,0)) D
4171+"RTN","PSBOMH1",114,0)
4172+ .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
4173+"RTN","PSBOMH1",115,0)
4174+ ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
4175+"RTN","PSBOMH1",116,0)
4176+ ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6)
4177+"RTN","PSBOMH1",117,0)
4178+ ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
4179+"RTN","PSBOMH1",118,0)
4180+ ..S PSBGA=1
4181+"RTN","PSBOMH1",119,0)
4182+ .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
4183+"RTN","PSBOMH1",120,0)
4184+ ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
4185+"RTN","PSBOMH1",121,0)
4186+ ..S PSBGA=1
4187+"RTN","PSBOMH1",122,0)
4188+ I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
4189+"RTN","PSBOMH1",123,0)
4190+ S PSBQRY="PSBTMP",PSBCNT=1 F S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
4191+"RTN","PSBOMH1",124,0)
4192+ .I PSBPQRY="PSBTMP" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action
4193+"RTN","PSBOMH1",125,0)
4194+ .I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment
4195+"RTN","PSBOMH1",126,0)
4196+ .I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) D Q
4197+"RTN","PSBOMH1",127,0)
4198+ ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q
4199+"RTN","PSBOMH1",128,0)
4200+ .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
4201+"RTN","PSBOMH1",129,0)
4202+ Q
4203+"RTN","PSBOMH1",130,0)
4204+ ;
4205+"RTN","PSBOMH1",131,0)
4206+PSBOUT(PSBTET,PSBOT1) ;
4207+"RTN","PSBOMH1",132,0)
4208+ I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1)
4209+"RTN","PSBOMH1",133,0)
4210+ S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
4211+"RTN","PSBOMH1",134,0)
4212+ S PSBXA1=0
4213+"RTN","PSBOMH1",135,0)
4214+ F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*"
4215+"RTN","PSBOMH1",136,0)
4216+ .I $L(PSBXA1)<4 D
4217+"RTN","PSBOMH1",137,0)
4218+ ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D
4219+"RTN","PSBOMH1",138,0)
4220+ ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
4221+"RTN","PSBOMH1",139,0)
4222+ ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D
4223+"RTN","PSBOMH1",140,0)
4224+ ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y
4225+"RTN","PSBOMH1",141,0)
4226+ ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD
4227+"RTN","PSBOMH1",142,0)
4228+ I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D
4229+"RTN","PSBOMH1",143,0)
4230+ .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
4231+"RTN","PSBOMH1",144,0)
4232+ I $G(PSBNAME)="" D
4233+"RTN","PSBOMH1",145,0)
4234+ . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1)
4235+"RTN","PSBOMH1",146,0)
4236+ I $G(PSBOT1)]""&($G(PSBNAME)]"") S ^TMP("PSB",$J,"LEGEND",PSBOT1,PSBNAME)="" ;MSC
4237+"RTN","PSBOMH1",147,0)
4238+ Q
4239+"RTN","PSBOMH1",148,0)
4240+ ;
4241+"RTN","PSBRPC2")
4242+0^39^B44967923
4243+"RTN","PSBRPC2",1,0)
4244+PSBRPC2 ;BIRMINGHAM/EFC,MSC/JDA - BCMA RPC BROKER CALLS ;27APR2009
4245+"RTN","PSBRPC2",2,0)
4246+ ;;3.0;BAR CODE MED ADMIN;**6,3,16,MSC**;Mar 2004
4247+"RTN","PSBRPC2",3,0)
4248+ ;
4249+"RTN","PSBRPC2",4,0)
4250+ ; Reference/IA
4251+"RTN","PSBRPC2",5,0)
4252+ ; File 50/221
4253+"RTN","PSBRPC2",6,0)
4254+ ; File 52.6/436
4255+"RTN","PSBRPC2",7,0)
4256+ ; File 52.7/437
4257+"RTN","PSBRPC2",8,0)
4258+ ; File 200/10060
4259+"RTN","PSBRPC2",9,0)
4260+ ;
4261+"RTN","PSBRPC2",10,0)
4262+GETOHIST(RESULTS,DFN,PSBORD) ;
4263+"RTN","PSBRPC2",11,0)
4264+ S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0
4265+"RTN","PSBRPC2",12,0)
4266+ S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File"
4267+"RTN","PSBRPC2",13,0)
4268+ D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=%
4269+"RTN","PSBRPC2",14,0)
4270+ D EN^PSBPOIV(DFN,PSBORD)
4271+"RTN","PSBRPC2",15,0)
4272+ S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D
4273+"RTN","PSBRPC2",16,0)
4274+ .S PSBUIDS=^TMP("PSBAR",$J,PSBUID)
4275+"RTN","PSBRPC2",17,0)
4276+ .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order
4277+"RTN","PSBRPC2",18,0)
4278+ .I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" S PSBOSTS="E" Q ; only want the infusing bag on an expired order
4279+"RTN","PSBRPC2",19,0)
4280+ .I $P(PSBUIDS,U,2)'="" D Q ; get orders from med log (53.79)
4281+"RTN","PSBRPC2",20,0)
4282+ ..S PSBMLOR=$P(PSBUIDS,U,4),PSBIEN=$O(^PSB(53.79,"AUID",DFN,PSBMLOR,PSBUID,""))
4283+"RTN","PSBRPC2",21,0)
4284+ ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
4285+"RTN","PSBRPC2",22,0)
4286+ ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
4287+"RTN","PSBRPC2",23,0)
4288+ ..I PSBLASTS="M",$P(PSBUIDS,U,8)'="" Q
4289+"RTN","PSBRPC2",24,0)
4290+ ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
4291+"RTN","PSBRPC2",25,0)
4292+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
4293+"RTN","PSBRPC2",26,0)
4294+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
4295+"RTN","PSBRPC2",27,0)
4296+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
4297+"RTN","PSBRPC2",28,0)
4298+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
4299+"RTN","PSBRPC2",29,0)
4300+ .I $P(PSBUIDS,U,1)="I" Q ; IV parameters say bag is invalid
4301+"RTN","PSBRPC2",30,0)
4302+ .I $P(PSBUIDS,U,8)'="",$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; label has been reprinted/distroyed etc. - bag is not infusing or stopped
4303+"RTN","PSBRPC2",31,0)
4304+ .S PSB=PSB+1,^TMP("PSB",$J,PSB)=$P(PSBUIDS,U,5)_U_PSBUID_U_U_PSBNOW_U_"A"
4305+"RTN","PSBRPC2",32,0)
4306+ .S PSBUIDP=$P(PSBUIDS,U,10,999)
4307+"RTN","PSBRPC2",33,0)
4308+ .F Y=3:1 S PSBMEDTY=$P(PSBUIDP,U,Y) Q:PSBMEDTY="" D
4309+"RTN","PSBRPC2",34,0)
4310+ ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBUIDS,U,5))
4311+"RTN","PSBRPC2",35,0)
4312+ ..I $P(PSBMEDTY,";",1)="ADD" F Z=1:1 S PSBAD=$G(PSBADA(Z)) Q:PSBAD="" I $P(PSBADA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBADA(Z) Q
4313+"RTN","PSBRPC2",36,0)
4314+ ..I $P(PSBMEDTY,";",1)="SOL" F Z=1:1 S PSBSOL=$G(PSBSOLA(Z)) Q:PSBSOL="" I $P(PSBSOLA(Z),U,2)=$P(PSBMEDTY,";",2) S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBSOLA(Z) Q
4315+"RTN","PSBRPC2",37,0)
4316+ .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
4317+"RTN","PSBRPC2",38,0)
4318+ .S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
4319+"RTN","PSBRPC2",39,0)
4320+ F II=1:1 S I=$P(PSBONXS,U,II) Q:I="" D ; get ward stocks
4321+"RTN","PSBRPC2",40,0)
4322+ .S PSBUID="" F S PSBUID=$O(^PSB(53.79,"AUID",DFN,I,PSBUID)) Q:PSBUID="" D
4323+"RTN","PSBRPC2",41,0)
4324+ ..I PSBUID'["WS" Q ; not a ward stock
4325+"RTN","PSBRPC2",42,0)
4326+ ..S PSBIEN=$O(^PSB(53.79,"AUID",DFN,I,PSBUID,""))
4327+"RTN","PSBRPC2",43,0)
4328+ ..S PSBLADT=$P(^PSB(53.79,PSBIEN,0),U,6)
4329+"RTN","PSBRPC2",44,0)
4330+ ..S PSBLASTS=$P(^PSB(53.79,PSBIEN,0),U,9)
4331+"RTN","PSBRPC2",45,0)
4332+ ..I PSBOSTS="D",PSBLASTS'="I",PSBLASTS'="S" Q ; want "not completed" on DC'ed orders
4333+"RTN","PSBRPC2",46,0)
4334+ ..I (PSBOSTS="A"),(PSBOSP<PSBNOWZ),PSBLASTS'="I",PSBLASTS'="S" Q
4335+"RTN","PSBRPC2",47,0)
4336+ ..S PSBINJS=$P(^PSB(53.79,PSBIEN,.1),U,6)
4337+"RTN","PSBRPC2",48,0)
4338+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)=PSBORD_U_PSBUID_U_PSBIEN_U_PSBLADT_U_PSBLASTS_U_PSBINJS
4339+"RTN","PSBRPC2",49,0)
4340+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.6,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="ADD^"_^PSB(53.79,PSBIEN,.6,PSBL,0)
4341+"RTN","PSBRPC2",50,0)
4342+ ..F PSBL=1:1 Q:'$D(^PSB(53.79,PSBIEN,.7,PSBL,0)) S PSB=PSB+1,^TMP("PSB",$J,PSB)="SOL^"_^PSB(53.79,PSBIEN,.7,PSBL,0)
4343+"RTN","PSBRPC2",51,0)
4344+ ..S PSB=PSB+1,^TMP("PSB",$J,PSB)="END"
4345+"RTN","PSBRPC2",52,0)
4346+ S ^TMP("PSB",$J,0)=PSB
4347+"RTN","PSBRPC2",53,0)
4348+ K ^TMP("PSBAR",$J)
4349+"RTN","PSBRPC2",54,0)
4350+ Q
4351+"RTN","PSBRPC2",55,0)
4352+ ;
4353+"RTN","PSBRPC2",56,0)
4354+BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
4355+"RTN","PSBRPC2",57,0)
4356+ I '$G(DFN)!PSBUID S DFN=+PSBUID ;**GFT/MSC
4357+"RTN","PSBRPC2",58,0)
4358+ S (PSBIEN,X)="" F S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X="" S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
4359+"RTN","PSBRPC2",59,0)
4360+ I PSBIEN'>0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q
4361+"RTN","PSBRPC2",60,0)
4362+ M PSBMLA=^PSB(53.79,PSBIEN)
4363+"RTN","PSBRPC2",61,0)
4364+ S X=$P(^PSB(53.79,PSBIEN,0),U,9)
4365+"RTN","PSBRPC2",62,0)
4366+ S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION")
4367+"RTN","PSBRPC2",63,0)
4368+ ; comments
4369+"RTN","PSBRPC2",64,0)
4370+ S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1)
4371+"RTN","PSBRPC2",65,0)
4372+ ; audit
4373+"RTN","PSBRPC2",66,0)
4374+ S PSBGA="" I $D(PSBMLA(.9,0)) D
4375+"RTN","PSBRPC2",67,0)
4376+ .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q
4377+"RTN","PSBRPC2",68,0)
4378+ ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE)
4379+"RTN","PSBRPC2",69,0)
4380+ ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2)
4381+"RTN","PSBRPC2",70,0)
4382+ ..S PSBGA=1
4383+"RTN","PSBRPC2",71,0)
4384+ .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D
4385+"RTN","PSBRPC2",72,0)
4386+ ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2)
4387+"RTN","PSBRPC2",73,0)
4388+ ..S PSBGA=1
4389+"RTN","PSBRPC2",74,0)
4390+ I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC
4391+"RTN","PSBRPC2",75,0)
4392+ S PSBQRY="PSBTMP",PSBCNT=1 F S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action
4393+"RTN","PSBRPC2",76,0)
4394+ .I PSBPQRY="PSBTMP" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action
4395+"RTN","PSBRPC2",77,0)
4396+ .I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment
4397+"RTN","PSBRPC2",78,0)
4398+ .I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q
4399+"RTN","PSBRPC2",79,0)
4400+ .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1
4401+"RTN","PSBRPC2",80,0)
4402+ S RESULTS(0)=PSBCNT-1
4403+"RTN","PSBRPC2",81,0)
4404+ K PSBMLA,PSBIEN,PSBTMP,PSBQRY
4405+"RTN","PSBRPC2",82,0)
4406+ Q
4407+"RTN","PSBRPC2",83,0)
4408+ ;
4409+"RTN","PSBRPC2",84,0)
4410+INITIAL(PSBDUZ) ;
4411+"RTN","PSBRPC2",85,0)
4412+ Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
4413+"RTN","PSBRPC2",86,0)
4414+SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
4415+"RTN","PSBRPC2",87,0)
4416+ ;
4417+"RTN","PSBRPC2",88,0)
4418+ ; RPC: PSB SCANMED
4419+"RTN","PSBRPC2",89,0)
4420+ ;
4421+"RTN","PSBRPC2",90,0)
4422+ ; Description:
4423+"RTN","PSBRPC2",91,0)
4424+ ; Does a lookup on file 50 returns -1 on invalid lookup or
4425+"RTN","PSBRPC2",92,0)
4426+ ; IEN^DrugName on success
4427+"RTN","PSBRPC2",93,0)
4428+ ;
4429+"RTN","PSBRPC2",94,0)
4430+ D NOW^%DTC S PSBDT=%
4431+"RTN","PSBRPC2",95,0)
4432+ S PSBCNT=0
4433+"RTN","PSBRPC2",96,0)
4434+ I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40)
4435+"RTN","PSBRPC2",97,0)
4436+ S RESULTS(PSBCNT)=1
4437+"RTN","PSBRPC2",98,0)
4438+ S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup"
4439+"RTN","PSBRPC2",99,0)
4440+ I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11)
4441+"RTN","PSBRPC2",100,0)
4442+ I PSBTAB="UDTAB" D Q
4443+"RTN","PSBRPC2",101,0)
4444+ .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")
4445+"RTN","PSBRPC2",102,0)
4446+ .I X<1 Q
4447+"RTN","PSBRPC2",103,0)
4448+ .E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01)
4449+"RTN","PSBRPC2",104,0)
4450+ ;
4451+"RTN","PSBRPC2",105,0)
4452+ ; IV/IVPB ward stock scan
4453+"RTN","PSBRPC2",106,0)
4454+ ;
4455+"RTN","PSBRPC2",107,0)
4456+ S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q
4457+"RTN","PSBRPC2",108,0)
4458+ S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I")
4459+"RTN","PSBRPC2",109,0)
4460+ I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D
4461+"RTN","PSBRPC2",110,0)
4462+ .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
4463+"RTN","PSBRPC2",111,0)
4464+ .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
4465+"RTN","PSBRPC2",112,0)
4466+ I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D
4467+"RTN","PSBRPC2",113,0)
4468+ .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
4469+"RTN","PSBRPC2",114,0)
4470+ .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
4471+"RTN","PSBRPC2",115,0)
4472+ ;
4473+"RTN","PSBRPC2",116,0)
4474+ I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1
4475+"RTN","PSBRPC2",117,0)
4476+ Q
4477+"RTN","PSBRPC2",118,0)
4478+ ;
4479+"RTN","PXRMTMED")
4480+0^40^B9970277
4481+"RTN","PXRMTMED",1,0)
4482+PXRMTMED ; SLC/PKR/PJH,MSC/JDA - Edit a reminder term. ;27APR2009
4483+"RTN","PXRMTMED",2,0)
4484+ ;;2.0;CLINICAL REMINDERS;**1,MSC**;Feb 04, 2005
4485+"RTN","PXRMTMED",3,0)
4486+ ;
4487+"RTN","PXRMTMED",4,0)
4488+ ;=======================================================
4489+"RTN","PXRMTMED",5,0)
4490+ N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y
4491+"RTN","PXRMTMED",6,0)
4492+GETNAME ;Get the name of the term to edit.
4493+"RTN","PXRMTMED",7,0)
4494+ K DA,DIC,DLAYGO,DTOUT,DUOUT,Y
4495+"RTN","PXRMTMED",8,0)
4496+ S DIC="^PXRMD(811.5,"
4497+"RTN","PXRMTMED",9,0)
4498+ S DIC(0)="AEMQL"
4499+"RTN","PXRMTMED",10,0)
4500+ S DIC("A")="Select Reminder Term: "
4501+"RTN","PXRMTMED",11,0)
4502+ S DLAYGO=811.5
4503+"RTN","PXRMTMED",12,0)
4504+ ;Set the starting place for additions.
4505+"RTN","PXRMTMED",13,0)
4506+ D SETSTART^PXRMCOPY(DIC)
4507+"RTN","PXRMTMED",14,0)
4508+ W !
4509+"RTN","PXRMTMED",15,0)
4510+ D ^DIC
4511+"RTN","PXRMTMED",16,0)
4512+ I ($D(DTOUT))!($D(DUOUT)) Q
4513+"RTN","PXRMTMED",17,0)
4514+ I Y=-1 G END
4515+"RTN","PXRMTMED",18,0)
4516+ S DA=$P(Y,U,1)
4517+"RTN","PXRMTMED",19,0)
4518+ S CS1=$$FILE^PXRMEXCS(811.5,DA)
4519+"RTN","PXRMTMED",20,0)
4520+ D EDIT(DIC,DA)
4521+"RTN","PXRMTMED",21,0)
4522+ I $G(DA)="" G GETNAME
4523+"RTN","PXRMTMED",22,0)
4524+ S CS2=$$FILE^PXRMEXCS(811.5,DA)
4525+"RTN","PXRMTMED",23,0)
4526+ I CS2=0 G GETNAME
4527+"RTN","PXRMTMED",24,0)
4528+ I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA)
4529+"RTN","PXRMTMED",25,0)
4530+ G GETNAME
4531+"RTN","PXRMTMED",26,0)
4532+END ;
4533+"RTN","PXRMTMED",27,0)
4534+ Q
4535+"RTN","PXRMTMED",28,0)
4536+ ;
4537+"RTN","PXRMTMED",29,0)
4538+ ;=======================================================
4539+"RTN","PXRMTMED",30,0)
4540+EDIT(ROOT,DA) ;
4541+"RTN","PXRMTMED",31,0)
4542+ N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y
4543+"RTN","PXRMTMED",32,0)
4544+ ;PXRMTMD is set by a xref on the .01 as a flag that the entire
4545+"RTN","PXRMTMED",33,0)
4546+ ;entry is being deleted.
4547+"RTN","PXRMTMED",34,0)
4548+ S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1)
4549+"RTN","PXRMTMED",35,0)
4550+ S DIE=ROOT
4551+"RTN","PXRMTMED",36,0)
4552+ I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D
4553+"RTN","PXRMTMED",37,0)
4554+ . S DR=".01"
4555+"RTN","PXRMTMED",38,0)
4556+ . D ^DIE
4557+"RTN","PXRMTMED",39,0)
4558+ . I $G(DA)'="" D CLASS(DA,DIE)
4559+"RTN","PXRMTMED",40,0)
4560+ I $G(DA)="" Q
4561+"RTN","PXRMTMED",41,0)
4562+ S TCONT=1
4563+"RTN","PXRMTMED",42,0)
4564+ F D FINDING(DIE,DA) Q:TCONT=0
4565+"RTN","PXRMTMED",43,0)
4566+ Q
4567+"RTN","PXRMTMED",44,0)
4568+ ;
4569+"RTN","PXRMTMED",45,0)
4570+ ;=======================================================
4571+"RTN","PXRMTMED",46,0)
4572+FINDING(DIE,DA,LIST) ;
4573+"RTN","PXRMTMED",47,0)
4574+ N CFIEN,GLOB,IEN,LIST,NODE,WPIEN
4575+"RTN","PXRMTMED",48,0)
4576+ N DEF,DEF1,DEF2,STATUS
4577+"RTN","PXRMTMED",49,0)
4578+ S STATUS=0
4579+"RTN","PXRMTMED",50,0)
4580+ D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)
4581+"RTN","PXRMTMED",51,0)
4582+ S NODE="^PXRMD(811.5)"
4583+"RTN","PXRMTMED",52,0)
4584+ D LIST^PXRMREDT(NODE,DA,.LIST)
4585+"RTN","PXRMTMED",53,0)
4586+ D DSPALL^PXRMREDF("T",NODE,DA,.LIST)
4587+"RTN","PXRMTMED",54,0)
4588+ S DA(1)=DA
4589+"RTN","PXRMTMED",55,0)
4590+ S IEN=DA
4591+"RTN","PXRMTMED",56,0)
4592+ S DIC=DIE_DA(1)_",20,"
4593+"RTN","PXRMTMED",57,0)
4594+ S DIC(0)="QEAL"
4595+"RTN","PXRMTMED",58,0)
4596+ S DIC("A")="Select Finding: "
4597+"RTN","PXRMTMED",59,0)
4598+ D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q
4599+"RTN","PXRMTMED",60,0)
4600+ S DIE=DIC
4601+"RTN","PXRMTMED",61,0)
4602+ S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
4603+"RTN","PXRMTMED",62,0)
4604+ I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D
4605+"RTN","PXRMTMED",63,0)
4606+ .I $D(^PXRMD(811.4,CFIEN,1))>0 D
4607+"RTN","PXRMTMED",64,0)
4608+ ..W !!,"Computed Finding Description:" S WPIEN=0
4609+"RTN","PXRMTMED",65,0)
4610+ ..F S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0 D
4611+"RTN","PXRMTMED",66,0)
4612+ ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
4613+"RTN","PXRMTMED",67,0)
4614+ .E W !!,"No description defined for this computed finding"
4615+"RTN","PXRMTMED",68,0)
4616+ .W !
4617+"RTN","PXRMTMED",69,0)
4618+ W !,"Editing Finding Number: "_$G(DA)
4619+"RTN","PXRMTMED",70,0)
4620+ ;Finding record fields
4621+"RTN","PXRMTMED",71,0)
4622+ S DR=".01;9;12;17"
4623+"RTN","PXRMTMED",72,0)
4624+ S DR=DR_";14;15;18"
4625+"RTN","PXRMTMED",73,0)
4626+ I GLOB="PXRMD(811.4," S DR=DR_";26"
4627+"RTN","PXRMTMED",74,0)
4628+ ;Taxonomy - use inactive problems
4629+"RTN","PXRMTMED",75,0)
4630+ I GLOB="PXD(811.2," S DR=DR_";10",STATUS=1
4631+"RTN","PXRMTMED",76,0)
4632+ ;Health Factor - within category rank
4633+"RTN","PXRMTMED",77,0)
4634+ I GLOB="AUTTHF(" S DR=DR_";11"
4635+"RTN","PXRMTMED",78,0)
4636+ ;Mental Health - scale
4637+"RTN","PXRMTMED",79,0)
4638+ I GLOB="YTT(601," S DR=DR_";13"
4639+"RTN","PXRMTMED",80,0)
4640+ I GLOB="RAMIS(71,"!(GLOB="ORD(101.43,") S DR=DR_";16",STATUS=1
4641+"RTN","PXRMTMED",81,0)
4642+ ;Rx Type
4643+"RTN","PXRMTMED",82,0)
4644+ I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16",STATUS=1
4645+"RTN","PXRMTMED",83,0)
4646+ ;Condition
4647+"RTN","PXRMTMED",84,0)
4648+ ;
4649+"RTN","PXRMTMED",85,0)
4650+ ;Edit finding record
4651+"RTN","PXRMTMED",86,0)
4652+ D ^DIE
4653+"RTN","PXRMTMED",87,0)
4654+ I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T")
4655+"RTN","PXRMTMED",88,0)
4656+ S $P(^PXRMD(811.5,IEN,20,0),U,3)=0
4657+"RTN","PXRMTMED",89,0)
4658+ Q
4659+"RTN","PXRMTMED",90,0)
4660+ ;
4661+"RTN","PXRMTMED",91,0)
4662+ ;=======================================================
4663+"RTN","PXRMTMED",92,0)
4664+CLASS(DA,DIE) ;
4665+"RTN","PXRMTMED",93,0)
4666+ F D Q:RESULT'=0
4667+"RTN","PXRMTMED",94,0)
4668+ . N DR,RESULT,X,Y
4669+"RTN","PXRMTMED",95,0)
4670+ . W !
4671+"RTN","PXRMTMED",96,0)
4672+ . S DR="100" D ^DIE I $D(Y) Q
4673+"RTN","PXRMTMED",97,0)
4674+ . ;Sponsor
4675+"RTN","PXRMTMED",98,0)
4676+ . S DR="101" D ^DIE I $D(Y) Q
4677+"RTN","PXRMTMED",99,0)
4678+ . ;Make sure Class and Sponsor Class are in synch.
4679+"RTN","PXRMTMED",100,0)
4680+ . S RESULT=$$VSPONSOR^PXRMINTR(X)
4681+"RTN","PXRMTMED",101,0)
4682+ . Q
4683+"RTN","PXRMTMED",102,0)
4684+ ;Review date, Usage
4685+"RTN","PXRMTMED",103,0)
4686+ S DR="102;1" D ^DIE I $D(Y) Q
4687+"RTN","PXRMTMED",104,0)
4688+ Q
4689+"RTN","PXRMTMED",105,0)
4690+ ;
4691+"RTN","RORHL7A")
4692+0^32^B35660209
4693+"RTN","RORHL7A",1,0)
4694+RORHL7A ;HCIOFO/SG MSC/JDS- HL7 UTILITIES ;30APR2009
4695+"RTN","RORHL7A",2,0)
4696+ ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
4697+"RTN","RORHL7A",3,0)
4698+ ;
4699+"RTN","RORHL7A",4,0)
4700+ Q
4701+"RTN","RORHL7A",5,0)
4702+ ;
4703+"RTN","RORHL7A",6,0)
4704+ ;***** ADDS THE SEGMENT TO THE HL7 MESSAGE BUFFER
4705+"RTN","RORHL7A",7,0)
4706+ ;
4707+"RTN","RORHL7A",8,0)
4708+ ; SEG Complete HL7 segment
4709+"RTN","RORHL7A",9,0)
4710+ ;
4711+"RTN","RORHL7A",10,0)
4712+ ; The ADDSEGC^RORHL7A procedure adds the HL7 segment to the HL7
4713+"RTN","RORHL7A",11,0)
4714+ ; message buffer defined by the ROREXT("HL7BUF") parameter
4715+"RTN","RORHL7A",12,0)
4716+ ; (the ^TMP("HLS",$J), by default). The <TAB>, <CR> and <LF>
4717+"RTN","RORHL7A",13,0)
4718+ ; characters are replaced with spaces. Long segments are split
4719+"RTN","RORHL7A",14,0)
4720+ ; among sub-nodes of the main segment node in the destination
4721+"RTN","RORHL7A",15,0)
4722+ ; buffer.
4723+"RTN","RORHL7A",16,0)
4724+ ;
4725+"RTN","RORHL7A",17,0)
4726+ ; The RORHL array and some nodes of the ROREXT array must be
4727+"RTN","RORHL7A",18,0)
4728+ ; initialized (either by the $$INIT^RORHL7 or manually) before
4729+"RTN","RORHL7A",19,0)
4730+ ; calling this procedure.
4731+"RTN","RORHL7A",20,0)
4732+ ;
4733+"RTN","RORHL7A",21,0)
4734+ADDSEGC(SEG) ;
4735+"RTN","RORHL7A",22,0)
4736+ N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL
4737+"RTN","RORHL7A",23,0)
4738+ S NODE=ROREXT("HL7BUF"),PTR=$G(ROREXT("HL7PTR"))+1
4739+"RTN","RORHL7A",24,0)
4740+ S HLFS=RORHL("FS"),HLECH=RORHL("ECH")
4741+"RTN","RORHL7A",25,0)
4742+ Q:$P(SEG,HLFS)="" ; Segment Name
4743+"RTN","RORHL7A",26,0)
4744+ ;--- Assign the Set ID if necessary
4745+"RTN","RORHL7A",27,0)
4746+ S SID=$$SETID($P(SEG,HLFS))
4747+"RTN","RORHL7A",28,0)
4748+ S:SID>0 $P(SEG,HLFS,2)=SID
4749+"RTN","RORHL7A",29,0)
4750+ ;--- Remove empty trailing fields
4751+"RTN","RORHL7A",30,0)
4752+ S I2=$L(SEG,HLFS)
4753+"RTN","RORHL7A",31,0)
4754+ F I1=I2:-1:1 Q:$TR($P(SEG,HLFS,I1),HLECH)'=""
4755+"RTN","RORHL7A",32,0)
4756+ S:I1<I2 $P(SEG,HLFS,I1+1,I2)=""
4757+"RTN","RORHL7A",33,0)
4758+ ;--- Store the segment
4759+"RTN","RORHL7A",34,0)
4760+ S SL=$L(SEG),MAXLEN=245 K @NODE@(PTR)
4761+"RTN","RORHL7A",35,0)
4762+ S @NODE@(PTR)=$TR($E(SEG,1,MAXLEN),$C(9,10,13)," ")
4763+"RTN","RORHL7A",36,0)
4764+ S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+SL+1
4765+"RTN","RORHL7A",37,0)
4766+ ;--- Split the segment into sub-nodes if necessary
4767+"RTN","RORHL7A",38,0)
4768+ D:SL>MAXLEN
4769+"RTN","RORHL7A",39,0)
4770+ . S I2=MAXLEN
4771+"RTN","RORHL7A",40,0)
4772+ . F PTR1=1:1 S I1=I2+1,I2=I1+MAXLEN-1 Q:I1>SL D
4773+"RTN","RORHL7A",41,0)
4774+ . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13)," ")
4775+"RTN","RORHL7A",42,0)
4776+ ;--- Save the pointer
4777+"RTN","RORHL7A",43,0)
4778+ S ROREXT("HL7PTR")=PTR
4779+"RTN","RORHL7A",44,0)
4780+ Q
4781+"RTN","RORHL7A",45,0)
4782+ ;
4783+"RTN","RORHL7A",46,0)
4784+ ;***** ASSEMBLES THE SEGMENT AND ADDS IT TO THE HL7 MESSAGE BUFFER
4785+"RTN","RORHL7A",47,0)
4786+ ;
4787+"RTN","RORHL7A",48,0)
4788+ ; .FIELDS Reference to a local variable where the HL7
4789+"RTN","RORHL7A",49,0)
4790+ ; fields are stored
4791+"RTN","RORHL7A",50,0)
4792+ ;
4793+"RTN","RORHL7A",51,0)
4794+ ; FIELDS(
4795+"RTN","RORHL7A",52,0)
4796+ ; 0) Segment name
4797+"RTN","RORHL7A",53,0)
4798+ ; I, Field value
4799+"RTN","RORHL7A",54,0)
4800+ ; i) Continuation of the value if it is
4801+"RTN","RORHL7A",55,0)
4802+ ; ... longer than than 245 characters
4803+"RTN","RORHL7A",56,0)
4804+ ;
4805+"RTN","RORHL7A",57,0)
4806+ ; The ADDSEGF^RORHL7A procedure assembles the HL7 segment from
4807+"RTN","RORHL7A",58,0)
4808+ ; provided field values and adds it to the HL7 message buffer
4809+"RTN","RORHL7A",59,0)
4810+ ; defined by the ROREXT("HL7BUF") node (the ^TMP("HLS",$J), by
4811+"RTN","RORHL7A",60,0)
4812+ ; default). The <TAB>, <CR> and <LF> characters are replaced with
4813+"RTN","RORHL7A",61,0)
4814+ ; spaces. Long segments are split among sub-nodes of the main
4815+"RTN","RORHL7A",62,0)
4816+ ; segment node in the destination buffer.
4817+"RTN","RORHL7A",63,0)
4818+ ;
4819+"RTN","RORHL7A",64,0)
4820+ ; The RORHL array and some nodes of the ROREXT array must be
4821+"RTN","RORHL7A",65,0)
4822+ ; initialized (either by the $$INIT^RORHL7 or manually) before
4823+"RTN","RORHL7A",66,0)
4824+ ; calling this procedure.
4825+"RTN","RORHL7A",67,0)
4826+ ;
4827+"RTN","RORHL7A",68,0)
4828+ADDSEGF(FIELDS) ;
4829+"RTN","RORHL7A",69,0)
4830+ ; RORBUF Temporary buffer for the segment construction
4831+"RTN","RORHL7A",70,0)
4832+ ; RORIS Current continuation subscript in the HL7 buffer
4833+"RTN","RORHL7A",71,0)
4834+ ; RORNODE Closed root of the HL7 message buffer
4835+"RTN","RORHL7A",72,0)
4836+ ; RORPTR Current subscript in the HL7 message buffer
4837+"RTN","RORHL7A",73,0)
4838+ ; RORSL Number of characters that can be appended to the
4839+"RTN","RORHL7A",74,0)
4840+ ; RORBUF before it has to be emptied into the HL7
4841+"RTN","RORHL7A",75,0)
4842+ ; message buffer
4843+"RTN","RORHL7A",76,0)
4844+ ;
4845+"RTN","RORHL7A",77,0)
4846+ N FLD,I,LASTFLD,RORBUF,RORIS,RORNODE,RORPTR,RORSL
4847+"RTN","RORHL7A",78,0)
4848+ Q:$G(FIELDS(0))="" ; Segment Name
4849+"RTN","RORHL7A",79,0)
4850+ S RORNODE=ROREXT("HL7BUF"),RORPTR=$G(ROREXT("HL7PTR"))+1
4851+"RTN","RORHL7A",80,0)
4852+ S HLFS=RORHL("FS"),HLECH=RORHL("ECH")
4853+"RTN","RORHL7A",81,0)
4854+ ;--- Assign the Set ID if necessary
4855+"RTN","RORHL7A",82,0)
4856+ S I=$$SETID(FIELDS(0))
4857+"RTN","RORHL7A",83,0)
4858+ S:I>0 FIELDS(1)=I
4859+"RTN","RORHL7A",84,0)
4860+ ;--- Remove empty trailing fields
4861+"RTN","RORHL7A",85,0)
4862+ S I=$NA(FIELDS)
4863+"RTN","RORHL7A",86,0)
4864+ N A,CNT F S I=$Q(@I) Q:I="" S CNT=$G(CNT)+1,A(CNT)=I I $TR(@I,HLECH)'="" K A,CNT
4865+"RTN","RORHL7A",87,0)
4866+ F I=1:1 Q:'$D(A(I)) K @A(I)
4867+"RTN","RORHL7A",88,0)
4868+ ;--- Initialize construction variables
4869+"RTN","RORHL7A",89,0)
4870+ S RORBUF=FIELDS(0),I=$L(RORBUF)
4871+"RTN","RORHL7A",90,0)
4872+ S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+I+1
4873+"RTN","RORHL7A",91,0)
4874+ S RORIS=0,RORSL=245-I
4875+"RTN","RORHL7A",92,0)
4876+ ;--- Append the fields and store the segment
4877+"RTN","RORHL7A",93,0)
4878+ S LASTFLD=+$O(FIELDS(" "),-1)
4879+"RTN","RORHL7A",94,0)
4880+ F FLD=1:1:LASTFLD D
4881+"RTN","RORHL7A",95,0)
4882+ . D APPEND(HLFS_$G(FIELDS(FLD)))
4883+"RTN","RORHL7A",96,0)
4884+ . ;--- Process the field continuation nodes
4885+"RTN","RORHL7A",97,0)
4886+ . S I=""
4887+"RTN","RORHL7A",98,0)
4888+ . F S I=$O(FIELDS(FLD,I)) Q:I="" D APPEND(FIELDS(FLD,I))
4889+"RTN","RORHL7A",99,0)
4890+ ;--- Flush the buffer if necessary
4891+"RTN","RORHL7A",100,0)
4892+ D:RORBUF'=""
4893+"RTN","RORHL7A",101,0)
4894+ . I 'RORIS S @RORNODE@(RORPTR)=RORBUF Q
4895+"RTN","RORHL7A",102,0)
4896+ . S @RORNODE@(RORPTR,RORIS)=RORBUF
4897+"RTN","RORHL7A",103,0)
4898+ S ROREXT("HL7PTR")=RORPTR
4899+"RTN","RORHL7A",104,0)
4900+ Q
4901+"RTN","RORHL7A",105,0)
4902+ ;
4903+"RTN","RORHL7A",106,0)
4904+ ;***** APPENDS THE FIELD VALUE TO THE HL7 SEGMENT
4905+"RTN","RORHL7A",107,0)
4906+ ;
4907+"RTN","RORHL7A",108,0)
4908+ ; VAL Value of the field (or its part)
4909+"RTN","RORHL7A",109,0)
4910+ ;
4911+"RTN","RORHL7A",110,0)
4912+ ; This is an internal function. Do not call it directly.
4913+"RTN","RORHL7A",111,0)
4914+ ;
4915+"RTN","RORHL7A",112,0)
4916+APPEND(VAL) ;
4917+"RTN","RORHL7A",113,0)
4918+ N BASE,L
4919+"RTN","RORHL7A",114,0)
4920+ S VAL=$TR(VAL,$C(9,10,13)," "),L=$L(VAL)
4921+"RTN","RORHL7A",115,0)
4922+ S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+L
4923+"RTN","RORHL7A",116,0)
4924+ I L'>RORSL S RORBUF=RORBUF_VAL,RORSL=RORSL-L Q
4925+"RTN","RORHL7A",117,0)
4926+ ;---
4927+"RTN","RORHL7A",118,0)
4928+ S RORBUF=RORBUF_$E(VAL,1,RORSL),L=L-RORSL
4929+"RTN","RORHL7A",119,0)
4930+ S BASE=1
4931+"RTN","RORHL7A",120,0)
4932+ F D Q:L'>0
4933+"RTN","RORHL7A",121,0)
4934+ . I 'RORIS S @RORNODE@(RORPTR)=RORBUF
4935+"RTN","RORHL7A",122,0)
4936+ . E S @RORNODE@(RORPTR,RORIS)=RORBUF
4937+"RTN","RORHL7A",123,0)
4938+ . S BASE=BASE+RORSL,RORIS=RORIS+1,RORSL=245
4939+"RTN","RORHL7A",124,0)
4940+ . S RORBUF=$E(VAL,BASE,BASE+RORSL-1),L=L-RORSL
4941+"RTN","RORHL7A",125,0)
4942+ S RORSL=-L
4943+"RTN","RORHL7A",126,0)
4944+ Q
4945+"RTN","RORHL7A",127,0)
4946+ ;
4947+"RTN","RORHL7A",128,0)
4948+ ;***** RETURNS THE BHS SEGMENT
4949+"RTN","RORHL7A",129,0)
4950+ ;
4951+"RTN","RORHL7A",130,0)
4952+ ; BID Batch message ID
4953+"RTN","RORHL7A",131,0)
4954+ ;
4955+"RTN","RORHL7A",132,0)
4956+ ; [BDT] Batch message creation time in internal FileMan
4957+"RTN","RORHL7A",133,0)
4958+ ; format (NOW by default)
4959+"RTN","RORHL7A",134,0)
4960+ ;
4961+"RTN","RORHL7A",135,0)
4962+ ; [COMMENT] Optional comment
4963+"RTN","RORHL7A",136,0)
4964+ ;
4965+"RTN","RORHL7A",137,0)
4966+ ; The RORHL local variable must be initialized by the $$INIT^RORHL7
4967+"RTN","RORHL7A",138,0)
4968+ ; function before calling this entry point.
4969+"RTN","RORHL7A",139,0)
4970+ ;
4971+"RTN","RORHL7A",140,0)
4972+BHS(BID,BDT,COMMENT) ;
4973+"RTN","RORHL7A",141,0)
4974+ N CS,SEG,TMP
4975+"RTN","RORHL7A",142,0)
4976+ D BHS^HLFNC3(.RORHL,BID,.SEG)
4977+"RTN","RORHL7A",143,0)
4978+ Q:$G(SEG)="" ""
4979+"RTN","RORHL7A",144,0)
4980+ S HLFS=RORHL("FS"),HLECH=RORHL("ECH"),CS=$E(HLECH,1)
4981+"RTN","RORHL7A",145,0)
4982+ ;--- Post-processing
4983+"RTN","RORHL7A",146,0)
4984+ S SEG=SEG_$G(SEG(1))
4985+"RTN","RORHL7A",147,0)
4986+ S:$G(BDT)'>0 BDT=$$NOW^XLFDT
4987+"RTN","RORHL7A",148,0)
4988+ S TMP=$E($P($$SITE^VASITE,U,3),1,3)
4989+"RTN","RORHL7A",149,0)
4990+ S $P(SEG,HLFS,4)=TMP_CS_$G(^XMB("NETNAME"))_CS_"DNS"
4991+"RTN","RORHL7A",150,0)
4992+ S $P(SEG,HLFS,5)="ROR AAC"
4993+"RTN","RORHL7A",151,0)
4994+ S $P(SEG,HLFS,7)=$$FMTHL7^XLFDT(BDT)
4995+"RTN","RORHL7A",152,0)
4996+ S TMP=$P(SEG,HLFS,9)
4997+"RTN","RORHL7A",153,0)
4998+ S $P(TMP,CS,3)=$P(TMP,CS,3)_$E(HLECH,2)_$G(RORHL("ETN"))
4999+"RTN","RORHL7A",154,0)
5000+ S $P(SEG,HLFS,9)=TMP
The diff has been truncated for viewing.

Subscribers

People subscribed via source and target branches