source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m@ 613

Last change on this file since 613 was 613, checked in by George Lilly, 14 years ago

initial load of WorldVistAEHR
File size: 9.0 KB
Line 
1HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;04/15/2008 10:58
2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122,140**;Oct 13, 1995;Build 5
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; This is an implementation of the HL7 Minimal Lower Layer Protocol
6 ; taskman entry/startup option, HLDP defined in menu entry.
7 ;
8 Q:'$D(HLDP)
9 ; patch HL*1.6*122 start
10 L +^HLCS("HLTCPLINK",HLDP):5 I '$T D Q
11 . D MON^HLCSTCP("TskLcked")
12 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
13 N HLZRULE
14 ;HLCSOUT= 1-error
15 I '$$INIT D EXITS("Init Error") Q
16 S HLDP("$J")=$J
17 S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
18 ; Start the client
19 I $G(HLTCPCS)="C" D Q
20 . S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP)
21 . I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
22 . S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
23 . ; identify process for ^%SY
24 . ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
25 . D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15))
26 . K HLDP("$J",0)
27 . D ST1
28 . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
29 . ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q
30 . I $G(HLCSOUT)=1 D Q
31 .. D MON("Error") H 1
32 .. L -^HLCS("HLTCPLINK",HLDP)
33 . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
34 . D EXITS("Shutdown")
35 ;
36 S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
37 I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
38 S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
39 ; identify process for ^%SY
40 ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
41 D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
42 K HLDP("$J",0)
43 ; to stop the listener via updated Kernel API, need to pass the
44 ; listener logical link (HLDP)
45 S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP"
46 ;single threaded listener
47 I $G(HLTCPCS)="S" D Q
48 . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE)
49 . I $$STOP D EXITS("Shutdown") Q
50 . D EXITS("Openfail")
51 ;
52 ;multi-threaded listener (for OpenM/NT)
53 I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D Q
54 . L -^HLCS("HLTCPLINK",HLDP)
55 I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q
56 D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE)
57 ; update status of listener
58 I $$STOP D EXITS("Shutdown") Q
59 D EXITS("Openfail")
60 ; HL*1.6*122 end
61 Q
62 ;
63SERVER(HLDP) ; single server using Taskman
64 I '$$INIT D EXITS("Init error") Q
65 D ^HLCSTCP1
66 I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q
67 Q:$G(HLCSOUT)=1
68 D MON("Idle")
69 Q
70 ;
71SERVERS(HLDP) ; Multi-threaded server using Taskman
72 I '$$INIT D EXITS("Init error") Q
73 G LISTEN
74 ;
75 ;multiple process servers, called from an external utility
76MSM ;MSM entry point, called from User-Defined Services
77 ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the
78 ;HL7 Multi-Threaded SERVER
79 S (IO,IO(0))=$P
80 G LISTEN
81 ;
82LISTEN ;
83 N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
84 I '$$INIT D ^%ZTER Q
85 ; patch HL*1.6*122 start
86 S HLDP("$J")=$J
87 S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
88 S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
89 I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
90 S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
91 ; identify process for ^%SY
92 ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
93 D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
94 K HLDP("$J",0)
95 ; patch HL*1.6*122 end
96 ;HLLSTN used to identify a listener to tag MON
97 S HLLSTN=1
98 ;increment job count, run server
99 D UPDT(1),^HLCSTCP1,EXITM
100 Q
101 ;
102DCOPEN(HLDP) ;open direct connect - called from HLMA2
103 Q:'$$INIT 0
104 Q:HLTCPADD=""!(HLTCPORT="") 0
105 Q:'$$OPEN^HLCSTCP2 0
106 Q 1
107 ;
108INIT() ; Initialize Variables
109 ; HLDP should be set to the IEN or name of Logical Link, file 870
110 S HLOS=$P($G(^%ZOSF("OS")),"^")
111 N DA,DIQUIET,DR,TMP,X,Y
112 ; patch HL*1.6*140
113 ; S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character
114 S HLTCPLNK("IOF")=$$FLUSHCHR^%ZISTCP
115 S DIQUIET=1
116 D DT^DICRW
117 I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
118 S DA=HLDP
119 ; patch HL*1.6*122 for field 400.09
120 S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05;400.09"
121 D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
122 ;
123 I $D(TMP("DIERR")) QUIT 0
124 ; -- re-transmit attempts
125 S HLDRETR=+$G(TMP(870,DA_",",200.02,"I"))
126 S HLDRETR("CLOSE")=+$G(TMP(870,DA_",",200.022,"I"))
127 ; -- exceed re-transmit action
128 S HLRETRA=$G(TMP(870,DA_",",200.021,"I"))
129 ; -- block size
130 S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I"))
131 ; -- read timeout
132 S HLDREAD=+$G(TMP(870,DA_",",200.04,"I"))
133 ; -- ack timeout
134 S HLDBACK=+$G(TMP(870,DA_",",200.05,"I"))
135 ; -- uni-directional wait
136 S HLDWAIT=$G(TMP(870,DA_",",200.09,"I"))
137 ; -- tcp address
138 S HLTCPADD=$G(TMP(870,DA_",",400.01,"I"))
139 ; -- tcp port
140 S HLTCPORT=$G(TMP(870,DA_",",400.02,"I"))
141 ; -- tcp/ip service type
142 S HLTCPCS=$G(TMP(870,DA_",",400.03,"I"))
143 ; -- link persistence
144 S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I"))
145 ; -- retention
146 S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
147 ;
148 ; patch HL*1.6*140
149 ; patch HL*1.6*122 for field 400.09
150 ; -- tcp/ip openfail timeout
151 ; S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))
152 S HLTCPLNK("TIMEOUT")=+$G(TMP(870,DA_",",400.09,"I"))
153 ;
154 ; -- set defaults in case something's not set
155 S:HLDREAD=0 HLDREAD=10
156 S:HLDBACK=0 HLDBACK=60
157 ; patch HL*1.6*122
158 ; S:HLDBSIZE=0 HLDBSIZE=245
159 S:HLDBSIZE<245 HLDBSIZE=245
160 S:HLDRETR=0 HLDRETR=5
161 S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
162 ;
163 ; patch HL*1.6*140, the defaut is 30
164 ; patch HL*1.6*122 for field 400.09
165 ; S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5
166 S:(HLTCPLNK("TIMEOUT")<1) HLTCPLNK("TIMEOUT")=30
167 ;
168 Q 1
169 ;
170ST1 ;record startup in 870 for single server
171 ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
172 ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
173 N HLJ,X
174 ; HL*1.6*122 remove unnecessary locks
175 ;F L +^HLCS(870,HLDP,0):2 Q:$T
176 S X="HLJ(870,"""_HLDP_","")"
177 S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
178 I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC")
179 E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"")
180 I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT
181 S:$G(ZTSK) @X@(11)=ZTSK
182 D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
183 ;L -^HLCS(870,HLDP,0)
184 Q
185 ;
186MON(Y) ;Display current state & check for shutdown
187 ;don't display for multiple server
188 Q:$G(HLLSTN)
189 ; HL*1.6*122 remove unnecessary locks
190 ;F L +^HLCS(870,HLDP,0):2 Q:$T
191 S $P(^HLCS(870,HLDP,0),U,5)=Y
192 ;L -^HLCS(870,HLDP,0)
193 Q:'$D(HLTRACE)
194 N X U IO(0)
195 W !,"IN State: ",Y
196 I '$$STOP D
197 . ; patch HL*1.6*122
198 . ; R !,"Type Q to Quit: ",X#1:1
199 . R !,"Type Q to Quit: ",X:1
200 . ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
201 . I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1
202 . ; patch HL*1.6*122 end
203 U IO
204 Q
205UPDT(Y) ;update job count for multiple servers,X=1 increment
206 N HLJ,X
207 ;
208 ; HL*1.6*122 start
209 ; F L +^HLCS(870,HLDP,0):2 Q:$T
210 Q:'$G(HLDP)
211 Q:'$D(^HLCS(870,"E","M",HLDP))
212 F L +^HLCS(870,HLDP,0):10 Q:$T H 1
213 ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
214 S X=+$P(^HLCS(870,HLDP,0),U,5)
215 I X<0 S X=0
216 S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server"
217 ;if incrementing, set the Device Type field to Multi-Server
218 ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP")
219 I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS"
220 ; HL*1.6*122 end
221 ;
222 L -^HLCS(870,HLDP,0)
223 Q
224STOP() ;stop flag set
225 N X
226 F L +^HLCS(870,HLDP,0):2 Q:$T
227 S X=+$P(^HLCS(870,HLDP,0),U,15)
228 L -^HLCS(870,HLDP,0)
229 Q X
230 ;
231LLCNT(DP,Y,Z) ;update Logical Link counters
232 ;DP=ien of Logical Link in file 870
233 ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent
234 ;Z: ""=add to counter, 1=subtract from counter
235 Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y))
236 N P,X
237 S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
238 ; patch HL*1.6*122 start
239 ; F L +^HLCS(870,DP,P):2 Q:$T
240 ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
241 I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
242 I OS'["DSM",OS'["OpenM" D
243 . F L +^HLCS(870,DP,P):10 Q:$T H 1
244 . S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
245 . L -^HLCS(870,DP,P)
246 E D
247 . S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1))
248 ; L -^HLCS(870,DP,P)
249 ; patch HL*1.6*122 end
250 Q
251SDFLD ; set Shutdown? field to yes
252 Q:'$G(HLDP)
253 ; HL*1.6*122 remove unnecessary lock and call to FM
254 S $P(^HLCS(870,HLDP,0),U,15)=1
255 ;N HLJ,X
256 ;F L +^HLCS(870,HLDP,0):2 Q:$T
257 ;14=Shutdown LLP?
258 ;S HLJ(870,HLDP_",",14)=1
259 ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
260 ;L -^HLCS(870,HLDP,0)
261 Q
262 ;
263EXITS(Y) ; shutdown and clean up the listener process for either
264 ; single-threaded or multi-threaded
265 N HLJ,X
266 F L +^HLCS(870,HLDP,0):2 Q:$T
267 ;4=status,10=Time Stopped,9=Time Started,11=Task Number
268 S X="HLJ(870,"""_HLDP_","")"
269 S @X@(4)=Y,@X@(11)="@"
270 S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@"
271 D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109
272 L -^HLCS(870,HLDP,0)
273 I $D(ZTQUEUED) S ZTREQ="@"
274 ; HL*1.6*122
275 L -^HLCS("HLTCPLINK",HLDP)
276 Q
277 ;
278EXITM ;Multiple service shutdown and clean up
279 ; shutdown and clean up a connection spawned by the listener
280 ; process for a multi-threaded listener
281 D UPDT(0)
282 I $D(ZTQUEUED) S ZTREQ="@"
283 Q
Note: See TracBrowser for help on using the repository browser.