source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m@ 782

Last change on this file since 782 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

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