source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m@ 619

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

initial load of WorldVistAEHR
File size: 8.6 KB
RevLine 
[613]1HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;08/15/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;GET WORK function for the process running under the Process Manager
6GETWORK(QUE) ;
7 ;Input:
8 ; QUE - (pass by reference) These subscripts are used:
9 ; ("LINK") - <link name>_":"_<port> last obtained
10 ; ("QUEUE") - name of the queue last obtained
11 ;Output:
12 ; Function returns 1 if success, 0 if no more work
13 ; QUE - updated to identify next queue of messages to process.
14 ; ("LINK") - <link name>_":"_<port>
15 ; ("QUEUE") - the named queue on the link
16 ; ("DOWN") - =1 means that the last OPEN attempt failed
17 ;
18 N LINK,QUEUE
19 S LINK=$G(QUE("LINK")),QUEUE=$G(QUE("QUEUE"))
20 I (LINK]""),(QUEUE]"") D
21 .L -^HLB("QUEUE","OUT",LINK,QUEUE)
22 .I '$$CNNCTD(LINK),$$FAILING(.LINK) S QUEUE="" Q
23 .F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T
24 I (LINK]""),(QUEUE="") D
25 .F S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK="" D Q:$L(QUEUE)
26 ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
27 ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T
28 I LINK="" D
29 .F S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK="" D Q:$L(QUEUE)
30 ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
31 ..S QUEUE="" F S QUEUE=$O(^HLB("QUEUE","OUT",LINK,QUEUE)) Q:(QUEUE="") I '$$STOPPED^HLOQUE("OUT",QUEUE) L +^HLB("QUEUE","OUT",LINK,QUEUE):0 Q:$T
32 S QUE("LINK")=LINK,QUE("QUEUE")=QUEUE,QUE("DOWN")=$G(LINK("DOWN"))
33 Q:$L(QUEUE) 1
34 D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
35 Q 0
36 ;
37FAILING(LINK) ;
38 ;Returns 1 if the link has failed in the last 30 seconds, 0 otherwise
39 ;Also returns LINK("DOWN")=1 if the link was failing > 30 seconds ago, not yet known if its up
40 ;
41 N LASTTIME,SET
42 S LINK("DOWN")=0
43 S LASTTIME=$G(^HLB("QUEUE","OUT",LINK))
44 S SET=$S(LASTTIME]"":1,1:0)
45 I SET D
46 .I $$HDIFF^XLFDT($H,LASTTIME,2)>30 S ^HLB("QUEUE","OUT",LINK)="",SET=0,LINK("DOWN")=1
47 I $D(^HLTMP("FAILING LINKS",LINK)) S LINK("DOWN")=1
48 Q SET
49 ;
50LINKDOWN(HLCSTATE) ;
51 D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
52 I $D(HLCSTATE("LINK","NAME")),$D(HLCSTATE("LINK","PORT")) D
53 .S TO=HLCSTATE("LINK","NAME")_":"_HLCSTATE("LINK","PORT")
54 .S ^HLB("QUEUE","OUT",TO)=$H
55 .S:'$D(^HLTMP("FAILING LINKS",TO)) ^HLTMP("FAILING LINKS",TO)=$H
56 Q
57 ;
58ERROR ;error trap
59 S $ETRAP="Q:$QUIT """" Q"
60 N HOUR
61 S HOUR=$E($$NOW^XLFDT,1,10)
62 S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
63 D END
64 D LINKDOWN(.HLCSTATE)
65 ;
66 I ($ECODE["TOOMANYFILES")!($ECODE["EDITED") Q:$QUIT "" Q
67 ;while debugging quit on all errors - this will return the process to the Process Manager error trap
68 I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q
69 ;
70 ;don't log some common errors
71 I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
72 .;
73 E D
74 .;but do log all the others
75 .D ^%ZTER
76 ;
77 ;a lot of errors of the same type may indicate an endless loop
78 ;return to the Process Manager error trap
79 I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
80 ;
81 ;resume execution of the process manager executing the client
82 D UNWIND^%ZTER
83 Q
84 ;
85DOWORK(QUEUE) ;sends the messages on the queue
86 N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOCLNT"
87 N MSGIEN,DEQUE,SUCCESS,MSGCOUNT
88 S DEQUE=0
89 S SUCCESS=1
90 ;
91 I '$$CNNCTD(QUEUE("LINK")),'$$CONNECT^HLOCLNT1($P(QUEUE("LINK"),":"),$P(QUEUE("LINK"),":",2),30,.HLCSTATE) Q
92 ;
93 S (MSGCOUNT,MSGIEN)=0
94 F S MSGIEN=$O(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN D Q:'SUCCESS Q:MSGCOUNT>1000
95 .N UPDATE
96 .S ^HLB(MSGIEN,"TRIES")=$G(^HLB(MSGIEN,"TRIES"))+1
97 .S SUCCESS=0
98 .S:$$TRANSMIT(.HLCSTATE,MSGIEN,.UPDATE) SUCCESS=1
99 .Q:('SUCCESS)!('$D(UPDATE))
100 .D DEQUE(.UPDATE)
101 .S MSGCOUNT=MSGCOUNT+1
102 .D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
103 .;
104 .;if the queue was on the down list, and not since shutdown, mark it as up, since a message has been successfully transmitted across it
105 .I $G(QUEUE("DOWN"))!$$FAILING(QUEUE("LINK")),'$$IFSHUT^HLOTLNK(QUEUE("LINK")) S QUEUE("DOWN")=0,^HLB("QUEUE","OUT",QUEUE("LINK"))="" K ^HLTMP("FAILING LINKS",QUEUE("LINK"))
106 ;
107END D DEQUE()
108 D SAVECNTS^HLOSTAT(.HLCSTATE)
109 Q
110CNNCTD(LINK) ;
111 ;Connected to LINK? HLCSTATE must be defined, LINK=<link name>:<port>
112 ;
113 I ($G(HLCSTATE("LINK","NAME"))=$P(LINK,":")),($G(HLCSTATE("LINK","PORT"))=$P(LINK,":",2)),$G(HLCSTATE("CONNECTED")) Q 1
114 Q 0
115 ;
116DEQUE(UPDATE) ;
117 I $D(UPDATE) S DEQUE=DEQUE+1,DEQUE(+UPDATE)=$P(UPDATE,"^",2,99) S:$G(UPDATE("MSA"))]"" DEQUE(+UPDATE,"MSA")=UPDATE("MSA") S:$G(UPDATE("ACTION"))]"" DEQUE(+UPDATE,"ACTION")=UPDATE("ACTION")
118 I '$D(UPDATE)!(DEQUE>15) D
119 .N MSGIEN S MSGIEN=0
120 .F S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN D
121 ..N NODE,TIME
122 ..D DEQUE^HLOQUE(QUEUE("LINK"),QUEUE("QUEUE"),"OUT",MSGIEN)
123 ..S TIME=$P(DEQUE(MSGIEN),"^")
124 ..Q:'TIME
125 ..S NODE=QUEUE("LINK")_"^"_QUEUE("QUEUE")_"^"_$P(DEQUE(MSGIEN),"^",2,99)
126 ..S ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN)=NODE
127 ..S:$G(DEQUE(MSGIEN,"MSA"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"MSA")=DEQUE(MSGIEN,"MSA")
128 ..S:$G(DEQUE(MSGIEN,"ACTION"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"ACTION")=DEQUE(MSGIEN,"ACTION")
129 .K DEQUE S DEQUE=0
130 Q
131 ;
132TRANSMIT(HLCSTATE,MSGIEN,UPDATE) ;
133 ;Transmits a single message and if a commit ack was requested reads it. Updates file 778 with the result. Queues for the infiler the application accept action if one was requested.
134 ;Input:
135 ; HLCSTATE (pass by reference)
136 ; MSGIEN - ien, file 778, of message to be transmitted
137 ;Output:
138 ; Function returns 1 on success, 0 on failure
139 ; UPDATE - (pass by reference) to contain updates needed for message
140 ;
141 N HLMSTATE,MSA,HDR,SUCCESS
142 ;
143 S SUCCESS=0
144 S HLCSTATE("ATTEMPT")=0
145 ;
146 ;start saving updates needed after the message is transmitted
147 S UPDATE=MSGIEN
148 Q:'$$GETMSG^HLOCLNT2(MSGIEN,.HLMSTATE) 1 ;returns 1 so the message will be removed from the queue
149 I HLMSTATE("DT/TM"),HLMSTATE("STATUS","ACCEPTED")!(HLMSTATE("HDR","ACCEPT ACK TYPE")="NE") Q 1 ;the message was already transmitted
150 ;
151 S UPDATE=UPDATE_"^"_$$NOW^XLFDT
152RETRY D
153 .S HLCSTATE("ATTEMPT")=HLCSTATE("ATTEMPT")+1
154 .I 'HLCSTATE("CONNECTED") D OPEN^HLOT(.HLCSTATE) Q:'HLCSTATE("CONNECTED")
155 .;
156 .;try to send the message
157 .;
158 .;
159 .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE)
160 .;does the message need an accept ack?
161 .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" D
162 ..N FS
163 ..Q:'$$READACK^HLOCLNT1(.HLCSTATE,.HDR,.MSA)
164 ..;does the MSA refer to the correct control id?
165 ..S FS=$E(HDR(1),4)
166 ..Q:$P(MSA,FS,3)'=HLMSTATE("ID")
167 ..N ACKID,ACKCODE
168 ..S ACKCODE=$P(MSA,FS,2)
169 ..S ACKID=$S($E(HDR(1),1,3)="MSH":$P(HDR(2),FS,5),1:$P(HDR(2),FS,6))
170 ..S $P(UPDATE,"^",5)=1
171 ..S UPDATE("MSA")=ACKID_"^"_MSA
172 ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="ER",$P(UPDATE,"^",4)=2
173 ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1)
174 ..I ($P(UPDATE,"^",3)="ER") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
175 ..;
176 ..;if it's from a sequence queue, timestamp the queue
177 ..I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
178 ...L +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200
179 ...I $P($G(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
180 ...I ACKCODE="CA" S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$$FMADD^XLFDT($P(UPDATE,"^",2),,,$$TIMEOUT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))) L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
181 ...;if the message wasn't accepted, need to notify without waiting
182 ...S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$P(UPDATE,"^",2)
183 ...L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
184 ..;
185 ..;does the app need notification of accept ack?
186 ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE")
187 ..;
188 ..S SUCCESS=1
189 .E D ;accept ack wasn't requested
190 ..S SUCCESS=1
191 ..I HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):2,1:1)
192 ;
193 I 'SUCCESS,'HLCSTATE("CONNECTED"),(HLCSTATE("ATTEMPT")<2) G RETRY
194 I SUCCESS D
195 .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
196 .;if this is an ack to a message need to purge the original message, so store its ien with the purge date
197 .S:$G(HLMSTATE("ACK TO IEN")) $P(UPDATE,"^",4)=$P(UPDATE,"^",4)_"-"_HLMSTATE("ACK TO IEN")
198 I ('HLCSTATE("CONNECTED"))!('SUCCESS) D LINKDOWN(.HLCSTATE)
199 Q SUCCESS
Note: See TracBrowser for help on using the repository browser.