source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m@ 615

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

initial load of WorldVistAEHR
File size: 7.4 KB
Line 
1HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;04/16/08 14:20
2 ;;1.6;HEALTH LEVEL SEVEN;**109,122,140**;Oct 13,1995;Build 5
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6 ; RDERR & ERROR moved from HLCSTCP2 on 12/2/2003 - LJA
7 ;
8RDERR ; Error during read process, decrement counter
9 D LLCNT^HLCSTCP(HLDP,4,1)
10ERROR ; Error trap
11 ; OPEN ERROR-retry.
12 ; WRITE ERROR (SERVER DISCONNECT)-close channel, retry
13 ;
14 ;**109**
15 ;I $G(HLMSG) L -^HLMA(HLMSG)
16 ;
17 ; patch HL*1.6*122 start
18 N STOP
19 S STOP=0
20 I $G(HLDP) S STOP=$$STOP^HLCSTCP
21 ; patch HL*1.6*140
22 S $ETRAP="D HALT^ZU" ;RWF
23 S HLTCP("$ZA\8192#2")=""
24 I (^%ZOSF("OS")["OpenM") D
25 . S HLTCP("$ZA")=$ZA
26 . ; For TCP devices $ZA\8192#2: the device is currently in the
27 . ; Connected state talking to a remote host.
28 . S HLTCP("$ZA\8192#2")=$ZA\8192#2
29 ;
30 S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
31 ; 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
32 I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D G:STOP H2^XUSCLEAN Q
33 . D CC^HLCSTCP2("Op-err")
34 . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
35 . I STOP D Q
36 .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')")
37 . I 'STOP D UNWIND^%ZTER
38 ; patch HL*1.6*140 start
39 ; I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
40 I $$EC^%ZOSV["WRITE" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
41 . ; S:$G(HLPRIO)="I" HLERROR="108^Write Error"
42 . I $G(HLPRIO)="I" D Q
43 .. S HLERROR="108^Write Error"
44 .. D CC^HLCSTCP2("Wr-err")
45 .. D UNWIND^%ZTER
46 . ;
47 . I STOP D Q
48 .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Wr-err')")
49 . E D Q
50 .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Wr-err") Q
51 .. E D Q
52 ... D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')")
53 ... D UNWIND^%ZTER
54 ;
55 ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
56 ; I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
57 I $$EC^%ZOSV["READ" D G:STOP!(HLTCP("$ZA\8192#2")) H2^XUSCLEAN Q
58 . ; S:$G(HLPRIO)="I" HLERROR="108^Read Error"
59 . I $G(HLPRIO)="I" D Q
60 .. S HLERROR="108^Read Error"
61 .. D CC^HLCSTCP2("Rd-err")
62 .. D UNWIND^%ZTER
63 . ;
64 . I STOP D Q
65 .. D ^%ZTER,CC^HLCSTCP2("Shutdown: (with 'Rd-err')")
66 . E D Q
67 .. I HLTCP("$ZA\8192#2") D ^%ZTER,CC^HLCSTCP2("Rd-err") Q
68 .. E D Q
69 ... D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')")
70 ... D UNWIND^%ZTER
71 ;
72 ; S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
73 ; S:$G(HLPRIO)="I" HLERROR="9^Error"
74 D ^%ZTER
75 I $G(HLPRIO)="I" D Q
76 . S HLERROR="9^Error"
77 . D CC^HLCSTCP2("Error")
78 . D UNWIND^%ZTER
79 ;
80 I STOP D Q
81 . D CC^HLCSTCP2("Shutdown: (with 'Error')")
82 . D H2^XUSCLEAN
83 ;
84 D CC^HLCSTCP2("Error")
85 ; patch HL*1.6*122 end
86 D H2^XUSCLEAN
87 ; patch HL*1.6*140 end
88 Q
89 ;
90PROXY ; set DUZ for application proxy user
91 ;
92 ; removed the execution: patch 122 TEST v2
93 Q
94 ;
95 ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
96 ;; S DUZ=HLDUZ
97 ;; D DUZ^XUP(DUZ)
98 ;; Q
99 ;
100HLDUZ ; compare DUZ and set DUZ to application proxy user
101 ;
102 ; removed the execution: patch 122 TEST v2
103 Q
104 ;
105 ;; I '$G(HLDUZ) D PROXY
106 ;
107HLDUZ2 ; compare DUZ and HLDUZ
108 I $G(DUZ)'=HLDUZ D
109 . S DUZ=HLDUZ
110 . D DUZ^XUP(DUZ)
111 Q
112 ;
113CLEANVAR ; clean variables for server, called from HLCSTCP1
114 ;
115 ; clean variables except Kernel related variables
116 ; protect variables defined in HLCSTCP
117 N HLDP
118 N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS
119 N HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLZRULE
120 ;
121 ; protect variables defined in LISTEN^HLCSTCP
122 ; N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT
123 ; N HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
124 N HLLSTN
125 ;
126 ; protect variables defined in CACHEVMS^HLCSTCP and EN^HLCSTCP
127 N %
128 ; protect variables defined in this routine HLCSTCP1
129 N $ETRAP,$ESTACK
130 N HLMIEN,HLASTMSG
131 N HLTMBUF
132 N HLDUZ,DUZ
133 ; Kernel variables for single listener
134 N ZISOS,ZRULE
135 ;
136 D KILL^XUSCLEAN
137 Q
138MIEN ; sets HLIND1=ien in 773^ien in 772 for message
139 N HLMID,X
140 I HLIND1 D
141 . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0
142 . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0
143 ;msg. id is 10th of MSH & 11th for BSH or FSH
144 S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X)
145 ;if HLIND1 is set, kill old message, use HLIND1 for new
146 ;message, it means we never got end block for 1st msg.
147 I HLIND1 D Q
148 . ;get pointer to 772, kill header
149 . ;
150 . ; patch HL*1.6*122: MPI-client/server
151 . F L +^HLMA(+HLIND1):10 Q:$T H 1
152 . K ^HLMA(+HLIND1,"MSH")
153 . L -^HLMA(+HLIND1)
154 . ;
155 . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
156 . S X=$$MAID^HLTF(+HLIND1,HLMID)
157 . D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
158 . S:$P(HLIND1,U,3) $P(HLIND1,U,3)=""
159 D TCP^HLTF(.HLMID,.X,.HLDT)
160 S HLBUFF("IEN773")=X
161 I 'X D Q
162 . ;error - record and reset array
163 . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server
164 . D CLEAN^HLCSTCP1 K HLLSTN
165 . ;error 100=LLP could not en-queue the message, reset array
166 . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30
167 ;HLIND1=ien in 773^ien in 772
168 S HLIND1=X_U_+$G(^HLMA(X,0))
169 S HLBUFF("HLIND1")=HLIND1
170 ;save MSH into 773
171 D SAVE^HLCSTCP1(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")")
172 Q
173 ;
174PMSH(MSH,P) ;get piece P from MSH array (passed by ref.)
175 N FS,I,L,L1,L2,X,Y
176 S FS=$E(MSH(1,0),4),(L2,Y)=0,X=""
177 F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0))
178 . S:L1=1 L=L+1
179 . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y))
180 . S L2=Y,Y=L
181 Q X
182 ;
183ERROR1 ;
184 ; moved from ERROR^HLCSTCP1
185 ; Error trap for disconnect error and return back to the read loop.
186 ; patch HL*1.6*122 start
187 ; patch HL*1.6*140
188 ; S $ETRAP="D HALT^ZU" ;RWF
189 S $ETRAP="H 1 D HALT^ZU" ;RWF
190 I (^%ZOSF("OS")["OpenM") D
191 . S HLTCP("$ZA")=$ZA
192 . ; For TCP devices $ZA\8192#2: the device is currently in the
193 . ; Connected state talking to a remote host.
194 . S HLTCP("$ZA\8192#2")=$ZA\8192#2
195 . I HLTCP("$ZA\8192#2")=0 D
196 .. ; decrement counter of multi-listener
197 .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP
198 .. ; process terminated
199 .. D H2^XUSCLEAN
200 ; patch HL*1.6*140
201 ;S $ETRAP="D UNWIND^%ZTER" ;RWF
202 ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
203 I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D Q
204 . ; if it is not a multi-listener
205 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err")
206 . D UNWIND^%ZTER
207 I $$EC^%ZOSV["READ" D Q
208 . ; if it is not a multi-listener
209 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
210 . D UNWIND^%ZTER
211 ;
212 ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
213 I $$EC^%ZOSV["WRITE" D Q
214 . ; if it is not a multi-listener
215 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err")
216 . D UNWIND^%ZTER
217 ;
218 ; for GT.M
219 I $ECODE["UREAD" D Q
220 . ; if it is not a multi-listener
221 . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
222 . D UNWIND^%ZTER
223 ;
224 ; S HLCSOUT=1 D ^%ZTER,CC("Error")
225 S HLCSOUT=1
226 D ^%ZTER
227 ; if it is not a multi-listener
228 I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error")
229 ; patch HL*1.6*122 end
230 ;
231 D UNWIND^%ZTER
232 Q
233 ;
234CLRMCNTR ;
235 ; clear the counter to set as "0 server" for multi-listener
236 ; HL*1.6*122 start
237 Q:'$G(HLDP)
238 Q:'$D(^HLCS(870,"E","M",HLDP))
239 S $P(^HLCS(870,HLDP,0),"^",4)="MS"
240 S $P(^HLCS(870,HLDP,0),U,5)="0 server"
241 Q
242 ;
243CREATUSR ;
244 ; patch HL*1.6*122 TEST v2: DUZ code removed
245 ; create application proxy users for listeners and incoming filer
246 ;; N HLTEMP
247 ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")
248 Q
Note: See TracBrowser for help on using the repository browser.