source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m@ 1742

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

initial load of FOIAVistA 6/30/08 version

File size: 9.4 KB
Line 
1HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;10/17/2007 09:37
2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133,122**;Oct 13,1995;Build 14
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;Sender
5 ;Request connection, send outbound message(s) delimited by MLLP
6 ;Input : HLDP=Logical Link to use
7 ; Set up error trap
8 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
9 N HLMSG,HLPORT,HLRETRY,HLRETMG,HLTCPO,POP
10 ;HLRETRY=number of retranmission for this link,HLRETMG=alert sent
11 S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
12 ;
13 ; patch 122
14 ; patch 133
15 ; set IO(0) to the null device
16 I $G(^%ZOSF("OS"))]"",^%ZOSF("OS")'["GT.M" D
17 . S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
18 . O IO(0) U IO(0)
19 ;
20 ;persistent conection, open connection first, HLPORT=open port
21 I $G(HLTCPLNK)["Y" F Q:$$OPEN G EXIT:$$STOP^HLCSTCP H 1
22 F D QUE Q:$$STOP^HLCSTCP D:'HLMSG Q:$G(HLCSOUT)
23 . ;no messages to send
24 . D MON^HLCSTCP("Idle") H 3
25 . ;persistent connection, no retention
26 . Q:$G(HLTCPLNK)["Y"
27 . D MON^HLCSTCP("Retention")
28 . N % I 0
29 . ;if message comes in or ask to stop
30 . F %=1:1:HLTCPRET H 1 I $$STOP^HLCSTCP!$O(^HLMA("AC","O",HLDP,0)) Q
31 . E S HLCSOUT=2 Q
32 . Q:$$STOP^HLCSTCP
33 . D MON^HLCSTCP("Idle")
34 ;Close port
35 I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
36EXIT Q
37 ;
38QUE ; -- Check "OUT" queue for processing IF there is a message do it
39 ; and then check the link if it open or not
40 N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
41 N HLTMBUF
42 D MON^HLCSTCP("CheckOut")
43 ;HLMSG=next msg, set at tag DONE
44 I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
45 ;
46 S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
47 ;don't have message text or MSH, kill x-ref and decrement 'to send'
48 ;
49 ; patch HL*1.6*122: MPI-client/server
50 ; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
51 I 'HLI!'HLJ D Q
52 . F L +^HLMA("AC","O",HLDP,HLMSG):10 Q:$T H 1
53 . K ^HLMA("AC","O",HLDP,HLMSG)
54 . L -^HLMA("AC","O",HLDP,HLMSG)
55 . D LLCNT^HLCSTCP(HLDP,3,1)
56 . S HLMSG=0
57 ;
58 ;update msg status to 'being transmitted'; if cancelled decrement link and quit
59 I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
60 ;number of retransmissions for message
61 S HLRETRM=+$P(^HLMA(HLMSG,"P"),U,5)
62 ;retries exceeded, HLRETRA:action i=ignore, r=restart, s=shutdown
63 ;quit if restart or shutdown, link is going down
64 I HLRETRY>HLDRETR D Q:"I"'[HLRETRA
65 . D MON^HLCSTCP("Error")
66 . ;only 1 alert per link up time, don't send if restart
67 . D:'HLRETMG&(HLRETRA'="R")
68 .. ;send alert
69 .. N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,Z
70 .. ;get mailgroup from file 869.3
71 .. S HLRETMG=1,Z=$P($$PARAM^HLCS2,U,8) Q:Z=""
72 .. 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.")
73 .. D SETUP^XQALERT
74 . ;quit if action is ignore
75 . Q:"I"[HLRETRA
76 . ;this will shutdown this link
77 . S HLCSOUT=1
78 . ;action is shutdown, set shutdown flag so LM won't restart
79 . S:HLRETRA="S" $P(^HLCS(870,HLDP,0),U,15)=1
80 . D STATUS^HLTF0(HLMSG,4,103,"LLP Exceeded Retry Param")
81 I '$$OPEN Q
82 D MON^HLCSTCP("Send")
83 ; -- data passed in global array, success=1
84 I $$WRITE(HLMSG)<0 Q
85 S (HLTCP,HLTCPI)=HLMSG,HLRETRY=HLRETRY+1,HLRETRM=HLRETRM+1
86 ;update status to awaiting response, decrement link if cancelled
87 I '$$CHKMSG(1.7) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
88 ;set transmission count, get ACKTIMEOUT override
89 S $P(^HLMA(HLMSG,"P"),U,5)=HLRETRM I $P(^("P"),U,7) S HLN("ACKTIME")=+$P(^("P"),U,7)
90 ;get header of message just sent
91 K HLJ M HLJ=^HLMA(HLMSG,"MSH")
92 ;first component of sending app.
93 S HLN("ECH")=$$P^HLTPCK2(.HLJ,2),HLN("SAN")=$P($$P^HLTPCK2(.HLJ,3),$E(HLN("ECH")))
94 ;msg type, msg. id, commit ack, and app. ack parameter
95 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)
96 ;MSA segment, message is a response, can't have an a. ack.
97 S Z=$$MSA^HLTP3(+^HLMA(HLMSG,0)) I Z]"" S:HLN("ACAT")="" HLN("ACAT")="NE" S HLN("APAT")="NE"
98 ;for batch/file with commit ack, reset c. ack and a. ack variables
99 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)
100 ;get event protocol
101 S HLN("EID")=+$P(^HLMA(HLMSG,0),U,8),X=$G(^ORD(101,HLN("EID"),770))
102 ;set link counter to msg sent
103 D LLCNT^HLCSTCP(HLDP,4)
104 ;commit and app. ack is never, update status to complete and hang UNI-DIRECTIONAL WAIT
105 I HLN("ACAT")="NE",HLN("APAT")="NE" D Q
106 .D DONE(3)
107 .;
108 .;
109 .H $G(HLDWAIT)
110 ;
111 ;do structure is to stack error
112 D
113 . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
114 . ;HL*1.6*87: Read acknowledgement.
115 . ;Loop to re-read from buffer when receiving incorrect ack.
116 . F D Q:'+$G(HLREREAD)
117 .. S HLREREAD=1
118 .. ;override ack timeout
119 .. I $G(HLN("ACKTIME")) N HLDBACK S HLDBACK=HLN("ACKTIME")
120 .. ;check for response, quit if no-response, msg will be resent
121 .. ;HLRESP=ien 773^ien 772 for response message
122 .. S HLRESP=$$READ^HLCSTCP1()
123 .. ;if no response, decrement counter and quit
124 .. I 'HLRESP D Q
125 ...D LLCNT^HLCSTCP(HLDP,4,1)
126 ...S HLREREAD="0^No Response"
127 ...;check if the port needs to be closed and re-opened before the next re-transmission attempt
128 ...I $G(HLDRETRY("CLOSE")) D CLOSE^%ZISTCP K HLPORT
129 .. ;X 0=re-read msg, 1=commit ack, 3=app ack success, 4=error
130 .. S X=$$RSP^HLTP31(HLRESP,.HLN)
131 .. ;X=0, re-read msg. Incorrect ack (bad MSH,MSA,msg id,or sending app)
132 .. Q:'X
133 .. ;commit ack - done
134 .. I X=1 D S HLREREAD="0^Commit Ack" Q
135 ... ;don't need app. ack, set status to complete
136 ... I "NE"[HLN("APAT") D Q
137 ....D DONE(3)
138 ....;
139 ... ;response is deferred, set status to awaiting ack
140 ... D DONE(2)
141 ...;
142 .. ;Error, HLRESLT=error number^error message from HLTP3
143 .. I X=4 D Q
144 ... D DONE(4,+$G(HLRESLT),$P($G(HLRESLT),U,2))
145 ...;
146 ... S HLREREAD="0^Error"
147 .. ;app ack was successful
148 .. D DONE(3) S HLREREAD="0^App Ack"
149 ..;
150 Q
151 ;
152DCSEND ;direct connect
153 ; Set up error trap
154 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
155 ; patch HL*1.6*122
156 N HLTMBUF
157 ;override ack timeout
158 I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
159 I $$WRITE(HLMSG)<0 D:$G(HLERROR)]"" Q ;HL*1.6*77
160 . D STATUS^HLTF0(HLMSG,4,$P(HLERROR,"^"),$P(HLERROR,"^",2),1) ;HL*1.6*77
161 . D LLCNT^HLCSTCP(HLDP,3,1)
162 D LLCNT^HLCSTCP(HLDP,4)
163 ;do structure is to stack error
164 D
165 . N $ETRAP,$ESTACK S $ETRAP="D RDERR^HLCSTCP2"
166 . ;HLRESP=ien 773^ien 772 for response message
167 . S HLRESP=$$READ^HLCSTCP1()
168 ;
169 D DONE(3):$G(HLRESP),DONE(4,108,$S($G(HLERROR)]"":$P(HLERROR,"^",2),1:"No response")):'$G(HLRESP)
170 I $G(HLERROR)']"" D
171 .D MON^HLCSTCP("Idle")
172 .I '$G(HLRESP) S HLERROR="108^No response"
173 ;Close port
174 I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
175 Q
176 ;
177DONE(ST,ERR,ERRMSG) ;set status to complete
178 ;ST=status, ERR=error ien, ERRMSG=error msg
179 D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
180 ;
181 D DEQUE^HLCSREP(HLDP,"O",HLMSG)
182 ;
183 ;check for more msg.
184 I $G(HLPRIO)'="I" S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0
185 Q
186 ;
187CHKMSG(HLI) ;check status of message and update if not cancelled
188 ;input: HLI=new status, HLMSG=ien of msg in 773
189 ;returns 1=msg was updated, 0=msg has been canceled
190 N X
191 ;
192 ; New HL*1.6*77 code starting here...
193 I '$D(^HLMA(HLMSG,"P")) D Q 0
194 . S HLERROR="2^Missing status field"
195 . D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
196 .;
197 . D DEQUE^HLCSREP(HLDP,"O",HLMSG)
198 ;
199 ; End of HL*1.6*77
200 ;
201 ;get status, quit if msg was cancelled
202 ;
203 S X=+^HLMA(HLMSG,"P") Q:X=3 0
204 ;
205 ;update status if it is different
206 I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
207 ;
208 Q 1
209 ;
210WRITE(HLDA) ; write message in HL7 format
211 ; HLDA - ien of message in 773
212 ; - start block $C(11)
213 ; - end block $C(28)
214 ; - record separator $C(13)
215 ;Output(s): 1 - Successful
216 ; -1 - Unsuccessful
217 ;
218 N HLDA2,HLAR,HLI,LINENO,X,CRCOUNT
219 S CRCOUNT=0
220 ;set error trap, used when called from HLTP3
221 ;
222 ; New HL*1.6*77 code starts here...
223 N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
224 I $G(^HLMA(HLDA,0))'>0 D Q -1
225 . S HLERROR="2^Message Text pointer missing"
226 S HLDA2=+$G(^HLMA(HLDA,0))
227 ; End of HL*1.6*77 modifications...
228 ;
229 Q:'$G(^HLMA(HLDA,0)) -1 ;HL*1.6*77
230 ; header is in ^HLMA(, message is in ^HL(772,
231 S LINENO=1,HLI=0,HLAR="^HLMA(HLDA,""MSH"")"
232 U IO
233 D W $C(13) S HLAR="^HL(772,HLDA2,""IN"")",HLI=0 D
234 . F S HLI=$O(@HLAR@(HLI)) Q:'HLI S X=$G(^(HLI,0)) D
235 .. ;first line, need start block char.
236 .. S:LINENO=1 X=$C(11)_X
237 .. ; HL*1.6*122
238 .. ; I X]"" W X,!
239 .. N LENGTH
240 .. S LENGTH=$L(X)
241 .. ; buffer should be limited to 512
242 .. I LENGTH>512 D
243 ... N X1
244 ... F Q:LENGTH<512 D
245 .... S X1=$E(X,1,512),X=$E(X,513,999999)
246 .... S LENGTH=$L(X)
247 .... W X1,@IOF
248 .. ;
249 .. ; @IOF (! or #) for flush character
250 .. I X]"" W X,@IOF S CRCOUNT=0
251 .. ;send CR
252 .. I X="" W $C(13) S CRCOUNT=CRCOUNT+1
253 .. ; prevent from maxstring error
254 .. I CRCOUNT>200 W @IOF S CRCOUNT=0
255 .. S LINENO=LINENO+1
256 ; Sends end block for this message
257 S X=$C(28)_$C(13)
258 ; U IO W X,!
259 U IO W X,@IOF
260 ;switch to null device
261 I $G(IO(0))'="",$G(IO(0))'=IO U IO(0)
262 Q 1
263 ;
264OPEN() ; -- Open TCP/IP device (Client)
265 ;HLPORT=port, defined only if port is open
266 ;HLPORTA=number of attempted opens
267 I $D(HLPORT) S IO=HLPORT D Q 1
268 . U IO
269 . I HLOS["OpenM" X "U IO:(::""-M"")" ;use packet mode on Cache'
270 N HLDOM,HLI,HLIP,HLPORTA
271 G OPENA^HLCSTCP3
272 ;
273RDERR D RDERR^HLCSTCP4 Q
274ERROR D ERROR^HLCSTCP4 Q
275 ;
276CC(X) ;cleanup and close
277 D MON^HLCSTCP(X)
278 I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
279 H 2
280 Q
Note: See TracBrowser for help on using the repository browser.