Merge lp:~jontai/openvista-gtm-integration/bug571450 into lp:openvista-gtm-integration

Proposed by Jon Tai
Status: Merged
Merged at revision: not available
Proposed branch: lp:~jontai/openvista-gtm-integration/bug571450
Merge into: lp:openvista-gtm-integration
Diff against target: 13839 lines (+13628/-202)
2 files modified
kids/MSC_GTM_INTEG_15.KID (+13422/-0)
mumps/ZTMGRSET.m (+206/-202)
To merge this branch: bzr merge lp:~jontai/openvista-gtm-integration/bug571450
Reviewer Review Type Date Requested Status
jeff.apple Approve
Review via email: mp+24371@code.launchpad.net
To post a comment you must log in.
Revision history for this message
jeff.apple (jeff-apple) wrote :

The KIDS build files are almost impossible to review as-is, so I don't know what to do there.
As for the new ZTMGRSET, KIDS has done that *really* annoying thing it does where it modifies your code and replaces spaces with tabs. As a result, that, too, is really difficult to review. Is there a way to view that ignores whitespace changes?

Revision history for this message
Jon Tai (jontai) wrote :

Sorry about that. If you have a checkout of the branch handy, do a

bzr diff --diff-options=-urw mumps/ZTMGRSET.m -r 129..130

Revision history for this message
jeff.apple (jeff-apple) wrote :

Heh. That bzr command fails in Windows, by the way, other than in Cygwin. I've run into it before. Just FYI, bzr delegates some of it's functions, like diff, to the system utilities, like "diff -w", that do not exist in Windows.

This looks fine.

review: Approve

Preview Diff

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

Subscribers

People subscribed via source and target branches