HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;02/29/2012
;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137,139,143,147,155,158**;Oct 13, 1995;Build 14
;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"))
TRY I (LINK]""),(QUEUE]"") D
.L -^HLB("QUEUE","OUT",LINK,QUEUE)
.I $$IFSHUT^HLOTLNK($P(LINK,":")) S QUEUE="" Q
.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)
..Q:$$IFSHUT^HLOTLNK($P(LINK,":"))
..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)
..Q:$$IFSHUT^HLOTLNK($P(LINK,":"))
..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"))
;
;** P147 START CJM
I $L(QUEUE),($R(100)>$$GETPRTY^HLOQUE(QUE("QUEUE"),QUE("LINK"))) G TRY
;** P148 END CJM
;
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) ;
N TO
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
ZB3 ;
;
S $ETRAP="Q:$QUIT """" Q"
;
D END
D LINKDOWN(.HLCSTATE)
;
;return to the Process Manager error trap
D UNWIND^%ZTER
Q:$QUIT "" Q
;
DOWORK(QUEUE) ;sends the messages on the queue
ZB0 ;
N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOCLNT"
N MSGIEN,DEQUE,SUCCESS,MSGCOUNT,MAXIMUM
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
S MAXIMUM=$$GETPRTY^HLOQUE(QUEUE("QUEUE"),QUEUE("LINK"))*2
F S MSGIEN=$O(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN)) D Q:'SUCCESS Q:MSGCOUNT>MAXIMUM Q:$$STOPPED^HLOQUE("OUT",QUEUE("QUEUE")) Q:$$IFSHUT^HLOTLNK($P(QUEUE("LINK"),":"))
.S:'MSGIEN SUCCESS=0
ZB4 .;
.Q:'SUCCESS
.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"))
;
ZB5 ;
END ;
;** P155 START
I HLCSTATE("LINK","SINGLE THREADED"),HLCSTATE("CONNECTED") D CLOSE^HLOT(.HLCSTATE)
;** P155 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) ;
ZB25 ;
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") D Q 1 ;the message was already transmitted
ZB20 .;**P143 START CJM
.;**P143 END CJM
;
;**P143 START CJM
I HLMSTATE("ACK BY")]"",HLMSTATE("STATUS")]"",$G(^HLB(MSGIEN,"TRIES"))>1 Q 1 ;The app ack was already returned, so don't keep transmitting
;**P143 END CJM
;
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)
..I $P(MSA,FS,3)'=HLMSTATE("ID") D Q
ZB21 ...;
..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
..;**P158 START CJM - allow "AA" in place of "CA"
..I '(ACKCODE="CA"),'(ACKCODE="AA") D
...S $P(UPDATE,"^",3)="ER",$P(UPDATE,"^",4)=1
ZB22 ...;
...;
..I (ACKCODE="CA")!(ACKCODE="AA"),HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=1
..I ($P(UPDATE,"^",3)="ER") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
..;
..;if it's from a sequence queue, timestamp the queue
..I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
...L +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200
...I $P($G(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
...I ACKCODE="CA" D
....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"))
ZB23 ....;
...;if the message wasn't accepted, need to notify without waiting
...S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$P(UPDATE,"^",2)
...L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
..;
..;does the app need 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)=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 indicator
.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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOCLNT 9248 printed Oct 16, 2024@17:59:22 Page 2
HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;02/29/2012
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137,139,143,147,155,158**;Oct 13, 1995;Build 14
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;GET WORK function for the process running under the Process Manager
GETWORK(QUE) ;
+1 ;Input:
+2 ; QUE - (pass by reference) These subscripts are used:
+3 ; ("LINK") - <link name>_":"_<port> last obtained
+4 ; ("QUEUE") - name of the queue last obtained
+5 ;Output:
+6 ; Function returns 1 if success, 0 if no more work
+7 ; QUE - updated to identify next queue of messages to process.
+8 ; ("LINK") - <link name>_":"_<port>
+9 ; ("QUEUE") - the named queue on the link
+10 ; ("DOWN") - =1 means that the last OPEN attempt failed
+11 ;
+12 NEW LINK,QUEUE
+13 SET LINK=$GET(QUE("LINK"))
SET QUEUE=$GET(QUE("QUEUE"))
TRY IF (LINK]"")
IF (QUEUE]"")
Begin DoDot:1
+1 LOCK -^HLB("QUEUE","OUT",LINK,QUEUE)
+2 IF $$IFSHUT^HLOTLNK($PIECE(LINK,":"))
SET QUEUE=""
QUIT
+3 IF '$$CNNCTD(LINK)
IF $$FAILING(.LINK)
SET QUEUE=""
QUIT
+4 FOR
SET QUEUE=$ORDER(^HLB("QUEUE","OUT",LINK,QUEUE))
if (QUEUE="")
QUIT
IF '$$STOPPED^HLOQUE("OUT",QUEUE)
LOCK +^HLB("QUEUE","OUT",LINK,QUEUE):0
if $TEST
QUIT
End DoDot:1
+5 IF (LINK]"")
IF (QUEUE="")
Begin DoDot:1
+6 FOR
SET LINK=$ORDER(^HLB("QUEUE","OUT",LINK))
if LINK=""
QUIT
Begin DoDot:2
+7 if $$IFSHUT^HLOTLNK($PIECE(LINK,"
QUIT
+8 IF '$$CNNCTD(LINK)
IF $$FAILING(.LINK)
QUIT
+9 SET QUEUE=""
FOR
SET QUEUE=$ORDER(^HLB("QUEUE","OUT",LINK,QUEUE))
if (QUEUE="")
QUIT
IF '$$STOPPED^HLOQUE("OUT",QUEUE)
LOCK +^HLB("QUEUE","OUT",LINK,QUEUE):0
if $TEST
QUIT
End DoDot:2
if $LENGTH(QUEUE)
QUIT
End DoDot:1
+10 IF LINK=""
Begin DoDot:1
+11 FOR
SET LINK=$ORDER(^HLB("QUEUE","OUT",LINK))
if LINK=""
QUIT
Begin DoDot:2
+12 if $$IFSHUT^HLOTLNK($PIECE(LINK,"
QUIT
+13 IF '$$CNNCTD(LINK)
IF $$FAILING(.LINK)
QUIT
+14 SET QUEUE=""
FOR
SET QUEUE=$ORDER(^HLB("QUEUE","OUT",LINK,QUEUE))
if (QUEUE="")
QUIT
IF '$$STOPPED^HLOQUE("OUT",QUEUE)
LOCK +^HLB("QUEUE","OUT",LINK,QUEUE):0
if $TEST
QUIT
End DoDot:2
if $LENGTH(QUEUE)
QUIT
End DoDot:1
+15 SET QUE("LINK")=LINK
SET QUE("QUEUE")=QUEUE
SET QUE("DOWN")=$GET(LINK("DOWN"))
+16 ;
+17 ;** P147 START CJM
+18 IF $LENGTH(QUEUE)
IF ($RANDOM(100)>$$GETPRTY^HLOQUE(QUE("QUEUE"),QUE("LINK")))
GOTO TRY
+19 ;** P148 END CJM
+20 ;
+21 if $LENGTH(QUEUE)
QUIT 1
+22 if $GET(HLCSTATE("CONNECTED"))
DO CLOSE^HLOT(.HLCSTATE)
+23 QUIT 0
+24 ;
FAILING(LINK) ;
+1 ;Returns 1 if the link has failed in the last 30 seconds, 0 otherwise
+2 ;Also returns LINK("DOWN")=1 if the link was failing > 30 seconds ago, not yet known if its up
+3 ;
+4 NEW LASTTIME,SET
+5 SET LINK("DOWN")=0
+6 SET LASTTIME=$GET(^HLB("QUEUE","OUT",LINK))
+7 SET SET=$SELECT(LASTTIME]"":1,1:0)
+8 IF SET
Begin DoDot:1
+9 IF $$HDIFF^XLFDT($HOROLOG,LASTTIME,2)>30
SET ^HLB("QUEUE","OUT",LINK)=""
SET SET=0
SET LINK("DOWN")=1
End DoDot:1
+10 IF $DATA(^HLTMP("FAILING LINKS",LINK))
SET LINK("DOWN")=1
+11 QUIT SET
+12 ;
LINKDOWN(HLCSTATE) ;
+1 NEW TO
+2 if $GET(HLCSTATE("CONNECTED"))
DO CLOSE^HLOT(.HLCSTATE)
+3 IF $DATA(HLCSTATE("LINK","NAME"))
IF $DATA(HLCSTATE("LINK","PORT"))
Begin DoDot:1
+4 SET TO=HLCSTATE("LINK","NAME")_":"_HLCSTATE("LINK","PORT")
+5 SET ^HLB("QUEUE","OUT",TO)=$HOROLOG
+6 if '$DATA(^HLTMP("FAILING LINKS",TO))
SET ^HLTMP("FAILING LINKS",TO)=$HOROLOG
End DoDot:1
+7 QUIT
+8 ;
ERROR ;error trap
ZB3 ;
+1 ;
+2 SET $ETRAP="Q:$QUIT """" Q"
+3 ;
+4 DO END
+5 DO LINKDOWN(.HLCSTATE)
+6 ;
+7 ;return to the Process Manager error trap
+8 DO UNWIND^%ZTER
+9 if $QUIT
QUIT ""
QUIT
+10 ;
DOWORK(QUEUE) ;sends the messages on the queue
ZB0 ;
+1 NEW $ETRAP,$ESTACK
SET $ETRAP="G ERROR^HLOCLNT"
+2 NEW MSGIEN,DEQUE,SUCCESS,MSGCOUNT,MAXIMUM
+3 SET DEQUE=0
+4 SET SUCCESS=1
+5 ;
+6 ;
+7 IF '$$CNNCTD(QUEUE("LINK"))
IF '$$CONNECT^HLOCLNT1($PIECE(QUEUE("LINK"),":"),$PIECE(QUEUE("LINK"),":",2),30,.HLCSTATE)
QUIT
+8 SET (MSGCOUNT,MSGIEN)=0
+9 SET MAXIMUM=$$GETPRTY^HLOQUE(QUEUE("QUEUE"),QUEUE("LINK"))*2
+10 FOR
SET MSGIEN=$ORDER(^HLB("QUEUE","OUT",QUEUE("LINK"),QUEUE("QUEUE"),MSGIEN))
Begin DoDot:1
+11 if 'MSGIEN
SET SUCCESS=0
ZB4 ;
+1 if 'SUCCESS
QUIT
+2 NEW UPDATE
+3 SET ^HLB(MSGIEN,"TRIES")=$GET(^HLB(MSGIEN,"TRIES"))+1
+4 SET SUCCESS=0
+5 if $$TRANSMIT(.HLCSTATE,MSGIEN,.UPDATE)
SET SUCCESS=1
+6 if ('SUCCESS)!('$DATA(UPDATE))
QUIT
+7 DO DEQUE(.UPDATE)
+8 SET MSGCOUNT=MSGCOUNT+1
+9 if HLCSTATE("COUNTS")>4
DO SAVECNTS^HLOSTAT(.HLCSTATE)
+10 ;
+11 ;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
+12 IF $GET(QUEUE("DOWN"))!$$FAILING(QUEUE("LINK"))
IF '$$IFSHUT^HLOTLNK(QUEUE("LINK"))
SET QUEUE("DOWN")=0
SET ^HLB("QUEUE","OUT",QUEUE("LINK"))=""
KILL ^HLTMP("FAILING LINKS",QUEUE("LINK"))
End DoDot:1
if 'SUCCESS
QUIT
if MSGCOUNT>MAXIMUM
QUIT
if $$STOPPED^HLOQUE("OUT",QUEUE("QUEUE"))
QUIT
if $$IFSHUT^HLOTLNK($PIECE(QUEUE("LINK"),"
QUIT
+13 ;
ZB5 ;
END ;
+1 ;** P155 START
+2 IF HLCSTATE("LINK","SINGLE THREADED")
IF HLCSTATE("CONNECTED")
DO CLOSE^HLOT(.HLCSTATE)
+3 ;** P155 END
+4 ;
+5 DO DEQUE()
+6 DO SAVECNTS^HLOSTAT(.HLCSTATE)
+7 QUIT
CNNCTD(LINK) ;
+1 ;Connected to LINK? HLCSTATE must be defined, LINK=<link name>:<port>
+2 ;
+3 IF ($GET(HLCSTATE("LINK","NAME"))=$PIECE(LINK,":"))
IF ($GET(HLCSTATE("LINK","PORT"))=$PIECE(LINK,":",2))
IF $GET(HLCSTATE("CONNECTED"))
QUIT 1
+4 QUIT 0
+5 ;
DEQUE(UPDATE) ;
ZB25 ;
+1 IF $DATA(UPDATE)
SET DEQUE=DEQUE+1
SET DEQUE(+UPDATE)=$PIECE(UPDATE,"^",2,99)
if $GET(UPDATE("MSA"))]""
SET DEQUE(+UPDATE,"MSA")=UPDATE("MSA")
if $GET(UPDATE("ACTION"))]""
SET DEQUE(+UPDATE,"ACTION")=UPDATE("ACTION")
+2 IF '$DATA(UPDATE)!(DEQUE>15)
Begin DoDot:1
+3 NEW MSGIEN
SET MSGIEN=0
+4 FOR
SET MSGIEN=$ORDER(DEQUE(MSGIEN))
if 'MSGIEN
QUIT
Begin DoDot:2
+5 NEW NODE,TIME
+6 DO DEQUE^HLOQUE(QUEUE("LINK"),QUEUE("QUEUE"),"OUT",MSGIEN)
+7 SET TIME=$PIECE(DEQUE(MSGIEN),"^")
+8 if 'TIME
QUIT
+9 SET NODE=QUEUE("LINK")_"^"_QUEUE("QUEUE")_"^"_$PIECE(DEQUE(MSGIEN),"^",2,99)
+10 SET ^HLTMP("CLIENT UPDATES",$JOB,TIME,MSGIEN)=NODE
+11 if $GET(DEQUE(MSGIEN,"MSA"))]""
SET ^HLTMP("CLIENT UPDATES",$JOB,TIME,MSGIEN,"MSA")=DEQUE(MSGIEN,"MSA")
+12 if $GET(DEQUE(MSGIEN,"ACTION"))]""
SET ^HLTMP("CLIENT UPDATES",$JOB,TIME,MSGIEN,"ACTION")=DEQUE(MSGIEN,"ACTION")
End DoDot:2
+13 KILL DEQUE
SET DEQUE=0
End DoDot:1
+14 QUIT
+15 ;
TRANSMIT(HLCSTATE,MSGIEN,UPDATE) ;
+1 ;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.
+2 ;Input:
+3 ; HLCSTATE (pass by reference)
+4 ; MSGIEN - ien, file 778, of message to be transmitted
+5 ;Output:
+6 ; Function returns 1 on success, 0 on failure
+7 ; UPDATE - (pass by reference) to contain updates needed for message
+8 ;
+9 NEW HLMSTATE,MSA,HDR,SUCCESS
+10 ;
+11 SET SUCCESS=0
+12 SET HLCSTATE("ATTEMPT")=0
+13 ;
+14 ;start saving updates needed after the message is transmitted
+15 SET UPDATE=MSGIEN
+16 ;returns 1 so the message will be removed from the queue
if '$$GETMSG^HLOCLNT2(MSGIEN,.HLMSTATE)
QUIT 1
+17 ;the message was already transmitted
IF HLMSTATE("DT/TM")
IF HLMSTATE("STATUS","ACCEPTED")!(HLMSTATE("HDR","ACCEPT ACK TYPE")="NE")
Begin DoDot:1
ZB20 ;**P143 START CJM
+1 ;**P143 END CJM
End DoDot:1
QUIT 1
+2 ;
+3 ;**P143 START CJM
+4 ;The app ack was already returned, so don't keep transmitting
IF HLMSTATE("ACK BY")]""
IF HLMSTATE("STATUS")]""
IF $GET(^HLB(MSGIEN,"TRIES"))>1
QUIT 1
+5 ;**P143 END CJM
+6 ;
+7 SET UPDATE=UPDATE_"^"_$$NOW^XLFDT
RETRY Begin DoDot:1
+1 SET HLCSTATE("ATTEMPT")=HLCSTATE("ATTEMPT")+1
+2 IF 'HLCSTATE("CONNECTED")
DO OPEN^HLOT(.HLCSTATE)
if 'HLCSTATE("CONNECTED")
QUIT
+3 ;
+4 ;try to send the message
+5 ;
+6 ;
+7 if '$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE)
QUIT
+8 ;does the message need an accept ack?
+9 IF HLMSTATE("HDR","ACCEPT ACK TYPE")="AL"
Begin DoDot:2
+10 NEW FS
+11 if '$$READACK^HLOCLNT1(.HLCSTATE,.HDR,.MSA)
QUIT
+12 ;does the MSA refer to the correct control id?
+13 SET FS=$EXTRACT(HDR(1),4)
+14 IF $PIECE(MSA,FS,3)'=HLMSTATE("ID")
Begin DoDot:3
ZB21 ;
End DoDot:3
QUIT
+1 NEW ACKID,ACKCODE
+2 SET ACKCODE=$PIECE(MSA,FS,2)
+3 SET ACKID=$SELECT($EXTRACT(HDR(1),1,3)="MSH":$PIECE(HDR(2),FS,5),1:$PIECE(HDR(2),FS,6))
+4 SET $PIECE(UPDATE,"^",5)=1
+5 SET UPDATE("MSA")=ACKID_"^"_MSA
+6 ;**P158 START CJM - allow "AA" in place of "CA"
+7 IF '(ACKCODE="CA")
IF '(ACKCODE="AA")
Begin DoDot:3
+8 SET $PIECE(UPDATE,"^",3)="ER"
SET $PIECE(UPDATE,"^",4)=1
ZB22 ;
+1 ;
End DoDot:3
+2 IF (ACKCODE="CA")!(ACKCODE="AA")
IF HLMSTATE("HDR","APP ACK TYPE")="NE"
SET $PIECE(UPDATE,"^",3)="SU"
SET $PIECE(UPDATE,"^",4)=1
+3 ;errors need the application for xref
IF ($PIECE(UPDATE,"^",3)="ER")
SET $PIECE(UPDATE,"^",6)=$PIECE(HLMSTATE("HDR",1),FS,5)
+4 ;
+5 ;if it's from a sequence queue, timestamp the queue
+6 IF $LENGTH($GET(HLMSTATE("STATUS","SEQUENCE QUEUE")))
Begin DoDot:3
+7 LOCK +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200
+8 IF $PIECE($GET(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN
LOCK -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
QUIT
+9 IF ACKCODE="CA"
Begin DoDot:4
+10 SET $PIECE(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$$FMADD^XLFDT($PIECE(UPDATE,"^",2),,,$$TIMEOUT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN)))
LOCK -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
ZB23 ;
End DoDot:4
+1 ;if the message wasn't accepted, need to notify without waiting
+2 SET $PIECE(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$PIECE(UPDATE,"^",2)
+3 LOCK -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
End DoDot:3
+4 ;
+5 ;does the app need notification of accept ack?
+6 SET UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE")
+7 ;
+8 SET SUCCESS=1
End DoDot:2
+9 ;accept ack wasn't requested
IF '$TEST
Begin DoDot:2
+10 SET SUCCESS=1
+11 IF HLMSTATE("HDR","APP ACK TYPE")="NE"
SET $PIECE(UPDATE,"^",3)="SU"
SET $PIECE(UPDATE,"^",4)=1
End DoDot:2
End DoDot:1
+12 ;
+13 IF 'SUCCESS
IF 'HLCSTATE("CONNECTED")
IF (HLCSTATE("ATTEMPT")<2)
GOTO RETRY
+14 IF SUCCESS
Begin DoDot:1
+15 DO COUNT^HLOSTAT(.HLCSTATE,HLMSTATE("HDR","RECEIVING APPLICATION"),HLMSTATE("HDR","SENDING APPLICATION"),$SELECT(HLMSTATE("BATCH"):"BATCH",1:HLMSTATE("HDR","MESSAGE TYPE")_"~"_HLMSTATE("HDR","EVENT")))
+16 ;if this is an ack to a message need to purge the original message, so store its ien with the purge indicator
+17 if $GET(HLMSTATE("ACK TO IEN"))
SET $PIECE(UPDATE,"^",4)=$PIECE(UPDATE,"^",4)_"-"_HLMSTATE("ACK TO IEN")
End DoDot:1
+18 IF ('HLCSTATE("CONNECTED"))!('SUCCESS)
DO LINKDOWN(.HLCSTATE)
+19 QUIT SUCCESS
