VistA-WorldVistAEHR/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m

HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;03/22/2007
 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
 ;Per VHA Directive 2004-038, this routine should not be modified.
 ;
 ;GET WORK function for the process running under the Process Manager
GETWORK(QUE) ;
 ;Input:
 ;  QUE - (pass by reference) These subscripts are used:
 ;    ("LINK")  - <link name>_":"_<port> last obtained
 ;    ("QUEUE") - name of the queue last obtained
 ;Output:
 ;  Function returns 1 if success, 0 if no more work
 ;  QUE -  updated to identify next queue of messages to process.
 ;    ("LINK") - <link name>_":"_<port>
 ;    ("QUEUE") - the named queue on the link
 ;    ("DOWN") - =1 means that the last OPEN attempt failed
 ;
 N LINK,QUEUE
 S LINK=$G(QUE("LINK")),QUEUE=$G(QUE("QUEUE"))
 I (LINK]""),(QUEUE]"") D
 .L -^HLB("QUEUE","OUT",LINK,QUEUE)
 .I '$$CNNCTD(LINK),$$FAILING(.LINK) S QUEUE="" Q
 .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
 I (LINK]""),(QUEUE="") D
 .F  S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK=""  D  Q:$L(QUEUE)
 ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
 ..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
 I LINK="" D
 .F  S LINK=$O(^HLB("QUEUE","OUT",LINK)) Q:LINK=""  D  Q:$L(QUEUE)
 ..I '$$CNNCTD(LINK),$$FAILING(.LINK) Q
 ..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
 S QUE("LINK")=LINK,QUE("QUEUE")=QUEUE,QUE("DOWN")=$G(LINK("DOWN"))
 Q:$L(QUEUE) 1
 D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
 Q 0
 ;
FAILING(LINK) ;
 ;Returns 1 if the link has failed in the last 30 seconds, 0 otherwise
 ;Also returns LINK("DOWN")=1 if the link was failing > 30 seconds ago, not yet known if its up
 ;
 N LASTTIME,SET
 S LINK("DOWN")=0
 S LASTTIME=$G(^HLB("QUEUE","OUT",LINK))
 S SET=$S(LASTTIME]"":1,1:0)
 I SET D
 .I $$HDIFF^XLFDT($H,LASTTIME,2)>30 S ^HLB("QUEUE","OUT",LINK)="",SET=0,LINK("DOWN")=1
 I $D(^HLTMP("FAILING LINKS",LINK)) S LINK("DOWN")=1
 Q SET
 ;
LINKDOWN(HLCSTATE) ;
 D:$G(HLCSTATE("CONNECTED")) CLOSE^HLOT(.HLCSTATE)
 I $D(HLCSTATE("LINK","NAME")),$D(HLCSTATE("LINK","PORT")) D
 .S TO=HLCSTATE("LINK","NAME")_":"_HLCSTATE("LINK","PORT")
 .S ^HLB("QUEUE","OUT",TO)=$H
 .S:'$D(^HLTMP("FAILING LINKS",TO)) ^HLTMP("FAILING LINKS",TO)=$H
 Q
 ;
ERROR ;error trap
 S $ETRAP="Q:$QUIT """" Q"
 N HOUR
 S HOUR=$E($$NOW^XLFDT,1,10)
 S ^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2))=$G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))+1
 D END
 D LINKDOWN(.HLCSTATE)
 ;
 I ($ECODE["TOOMANYFILES")!($ECODE["EDITED") Q:$QUIT "" Q
 ;while debugging quit on all errors - this will return the process to the Process Manager error trap
 I $G(^HLTMP("LOG ALL ERRORS")) Q:$QUIT "" Q
 ;
 ;don't log some common errors
 I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
 .;
 E  D
 .;but do log all the others
 .D ^%ZTER
 ;
 ;a lot of errors of the same type may indicate an endless loop
 ;return to the Process Manager error trap
 I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
 ;
 ;resume execution of the process manager executing the client
 D UNWIND^%ZTER
 Q
 ;
DOWORK(QUEUE) ;sends the messages on the queue
 N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOCLNT"
 N MSGIEN,DEQUE,SUCCESS,MSGCOUNT
 S DEQUE=0
 S SUCCESS=1
 ;
 I '$$CNNCTD(QUEUE("LINK")),'$$CONNECT^HLOCLNT1($P(QUEUE("LINK"),":"),$P(QUEUE("LINK"),":",2),30,.HLCSTATE) Q
 ;
 S (MSGCOUNT,MSGIEN)=0
 F  S MSGIEN=$O(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN)) Q:'MSGIEN  D  Q:'SUCCESS  Q:MSGCOUNT>1000
 .N UPDATE
 .S ^HLB(MSGIEN,"TRIES")=$G(^HLB(MSGIEN,"TRIES"))+1
 .S SUCCESS=0
 .S:$$TRANSMIT(.HLCSTATE,MSGIEN,.UPDATE) SUCCESS=1
 .Q:('SUCCESS)!('$D(UPDATE))
 .D DEQUE(.UPDATE)
 .S MSGCOUNT=MSGCOUNT+1
 .D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
 .;
 .;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
 .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"))
 ;
END D DEQUE()
 D SAVECNTS^HLOSTAT(.HLCSTATE)
 Q
CNNCTD(LINK) ;
 ;Connected to LINK?  HLCSTATE must be defined, LINK=<link name>:<port>
 ;
 I ($G(HLCSTATE("LINK","NAME"))=$P(LINK,":")),($G(HLCSTATE("LINK","PORT"))=$P(LINK,":",2)),$G(HLCSTATE("CONNECTED")) Q 1
 Q 0
 ;
DEQUE(UPDATE) ;
 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")
 I '$D(UPDATE)!(DEQUE>15) D
 .N MSGIEN S MSGIEN=0
 .F  S MSGIEN=$O(DEQUE(MSGIEN)) Q:'MSGIEN  D
 ..N NODE,TIME
 ..D DEQUE^HLOQUE(QUEUE("LINK"),QUEUE("QUEUE"),"OUT",MSGIEN)
 ..S TIME=$P(DEQUE(MSGIEN),"^")
 ..Q:'TIME
 ..S NODE=QUEUE("LINK")_"^"_QUEUE("QUEUE")_"^"_$P(DEQUE(MSGIEN),"^",2,99)
 ..S ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN)=NODE
 ..S:$G(DEQUE(MSGIEN,"MSA"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"MSA")=DEQUE(MSGIEN,"MSA")
 ..S:$G(DEQUE(MSGIEN,"ACTION"))]"" ^HLTMP("CLIENT UPDATES",$J,TIME,MSGIEN,"ACTION")=DEQUE(MSGIEN,"ACTION")
 .K DEQUE S DEQUE=0
 Q
 ;
TRANSMIT(HLCSTATE,MSGIEN,UPDATE) ;
 ;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.
 ;Input:
 ;   HLCSTATE (pass by reference)
 ;   MSGIEN - ien, file 778, of message to be transmitted
 ;Output:
 ;  Function returns 1 on success, 0 on failure
 ;  UPDATE - (pass by reference) to contain updates needed for message
 ;
 N HLMSTATE,MSA,HDR,SUCCESS
 ;
 S SUCCESS=0
 S HLCSTATE("ATTEMPT")=0
 ;
 ;start saving updates needed after the message is transmitted
 S UPDATE=MSGIEN
 Q:'$$GETMSG^HLOCLNT2(MSGIEN,.HLMSTATE) 1  ;returns 1 so the message will be removed from the queue
 I HLMSTATE("DT/TM"),HLMSTATE("STATUS","ACCEPTED")!(HLMSTATE("HDR","ACCEPT ACK TYPE")="NE") Q 1  ;the message was already transmitted
 ;
 S UPDATE=UPDATE_"^"_$$NOW^XLFDT
RETRY D
 .S HLCSTATE("ATTEMPT")=HLCSTATE("ATTEMPT")+1
 .I 'HLCSTATE("CONNECTED") D OPEN^HLOT(.HLCSTATE) Q:'HLCSTATE("CONNECTED")
 .;
 .;try to send the message
 .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE)
 .;does the message need an accept ack?
 .I HLMSTATE("HDR","ACCEPT ACK TYPE")="AL" D
 ..N FS
 ..Q:'$$READACK^HLOCLNT1(.HLCSTATE,.HDR,.MSA)
 ..;does the MSA refer to the correct control id?
 ..S FS=$E(HDR(1),4)
 ..Q:$P(MSA,FS,3)'=HLMSTATE("ID")
 ..N ACKID,ACKCODE
 ..S ACKCODE=$P(MSA,FS,2)
 ..S ACKID=$S($E(HDR(1),1,3)="MSH":$P(HDR(2),FS,5),1:$P(HDR(2),FS,6))
 ..S $P(UPDATE,"^",5)=1
 ..S UPDATE("MSA")=ACKID_"^"_MSA
 ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="SE",$P(UPDATE,"^",4)=2
 ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1)
 ..I ($P(UPDATE,"^",3)="SE") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
 ..;
 ..;did the app request notification of accept ack?
 ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE")
 ..S SUCCESS=1
 .E  D  ;accept ack wasn't requested
 ..S SUCCESS=1
 ..I HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):2,1:1)
 ;
 I 'SUCCESS,'HLCSTATE("CONNECTED"),(HLCSTATE("ATTEMPT")<2) G RETRY
 I SUCCESS D
 .D COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$S(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
 .;if this is an ack to a message need to purge the original message, so store its ien with the purge date
 .S:$G(HLMSTATE("ACK TO IEN")) $P(UPDATE,"^",4)=$P(UPDATE,"^",4)_"-"_HLMSTATE("ACK TO IEN")
 I ('HLCSTATE("CONNECTED"))!('SUCCESS) D LINKDOWN(.HLCSTATE)
 Q SUCCESS