HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;07/29/2009 14:51
;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122,140,142,145**;Oct 13, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
NEW(X) ;process new msg. ien in 773^ien in 772
;HLMTIENS=ien in #773; HLMTIEN=ien in #772
;HLHDRO=original header; HLHDR=response header
;set error trap
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
N HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT
S HLRESLT=""
D INIT^HLTP3A
;error with header, return commit/app reject
I $G(HLRESLT) D Q
. ;set status & unlock record
. D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
. ;quit if no commit or app ack
. I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" Q
. S X=$S($G(HL("ACAT"))="AL":"CR",1:"AR")
. ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4
. D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP)
. ;write ack back
. S X=$$WRITE^HLCSTCP2(HLTCP)
. ;update counter to sent
. D LLCNT^HLCSTCP(HLDP,4)
. ;update status of ack
. D STATUS^HLTF0(HLTCP,3,,,1)
;
;check for duplicate msg., use rec. app and msg. id x-ref
; patch HL*1.6*142 start
; HL("HDR FLDS:3-6") extracted from field 3 to field 6 of header
; defined in HLDIE routine
; I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS)
I ($G(HL("MID"))]""),($G(HL("HDR FLDS:3-6"))]"") D Q:'$D(HLMTIENS)
. S X=$O(^HLMA("AH-NEW",HL("HDR FLDS:3-6"),HL("MID"),0))
. ; patch HL*1.6*142 end
. ;HLASTMSG=last ien received during this connection
. ;if no duplicate, save msg. ien and quit
. I X=HLMTIENS!'X S HLASTMSG=HLMTIENS Q
. N MSH,OIENS
. S (OIENS,Y)=X D S Y=HLMTIENS D
.. ;combine MSH into single string
.. S MSH(Y)="",I=0 F S I=$O(^HLMA(Y,"MSH",I)) Q:'I S MSH(Y)=MSH(Y)_$G(^(I,0))
.; patch 117 & 125, check if identical
.I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q
.;
. ;msg is duplicate, set status
. D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT
. ;msg was resent, ignore it.
. I HLASTMSG=HLMTIENS K HLMTIENS Q
. ;find original response and send back
. S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS))
. ; patch HL*1.6*142 start
. ; the original msg may need to be updated again if 1st time
. ; update failed
. S HLASTMSG("OIENS")=OIENS
. ;
. ; the original message and its commit ACK were purged, OIENS is
. ; duplicate and needs to create its own commit ACK (happened
. ; between MPI and VIE in 9/2008), the OIENS will be processed
. ; by the application routine again.
. I $G(HL("ACAT"))="AL",'$G(HL("ACK")),'HLASTRSP D
.. N HLTCP,HLMTIENS
.. S HLMTIENS=OIENS
.. D ACK^HLTP4("CA")
.. D LLCNT^HLCSTCP(HLDP,3,1) ; decreament and will be added later
.. S HLASTRSP=HLTCP
. ; patch HL*1.6*142 end
;
; patch HL*1.6*145 start
; Quit if this is application ack to application ack
I $G(HL("ACK")) D Q
. N HLERRMG,X
. S HLERRMG="Received application acknowledgement to an application acknowledgement"
. ;msg is a resend, HLASTRSP=ien of original response (commit ACK)
. I $G(HLASTRSP) D
.. S HLTCP=HLASTRSP
.. D STATUS^HLTF0(HLTCP,8)
.. S ^HLMA(+HLTCP,"S")=$$NOW^XLFDT
.. D LLCNT^HLCSTCP(HLDP,3)
. E D Q:'$G(HLTCP)
.. ;Send CR and update status of original and current ack messages
.. D ACK^HLTP4("CR",HLERRMG)
. ;
. ; write commit ACK (original commit ACK)
. S X=$$WRITE^HLCSTCP2(HLTCP)
. D STATUS^HLTF0(HLTCP,3,,"'Reject' commit ACK: "_HLERRMG,1)
. S ^HLMA(+HLTCP,"S")=$$NOW^XLFDT
. D LLCNT^HLCSTCP(HLDP,4)
. S HLTCP=""
. ; D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
. D STATUS^HLTF0(HL("MTIENS"),3,,,1)
. D STATUS^HLTF0(HLMTIENS,4,,HLERRMG,1)
. ;unlock record
. D EXIT
; patch HL*1.6*145 end
;
; enhance ack., send commit, quit if not an ack, msg will be
; processed by filer
I $G(HL("ACAT"))="AL" D Q:'$G(HL("MTIENS"))
. ;msg is a resend, HLASTRSP=ien of original response (commit ACK)
.I $G(HLASTRSP) D
..S HLTCP=HLASTRSP
..D LLCNT^HLCSTCP(HLDP,3)
. E D Q:'$G(HLTCP)
..D ACK^HLTP4("CA") ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4
. ;
. ; write commit ACK (original commit ACK)
. S X=$$WRITE^HLCSTCP2(HLTCP)
. ; patch HL*1.6*142
. ; D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP)
. D LLCNT^HLCSTCP(HLDP,4)
. I '$G(HLASTRSP) D
.. D STATUS^HLTF0(HLTCP,3,,,1)
. S HLTCP=""
. ;if not an ack, set status to awaiting processing **109** and put on in queue
. I '$G(HL("MTIENS")),'$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
. ;
. ; patch HL*1.6*142 start
. ;if the original msg failed to en-queue and update status
. ; it may happen when COTS disconnect the listener during
. ; writing the commit ACK
. ; deal with a non-application ACK duplicate message
. I '$G(HL("MTIENS")),$G(HLASTRSP) D
.. N STATUS
.. S STATUS=+$G(^HLMA(HLASTRSP,"P"))
.. I STATUS,(STATUS'=3) D
... ; update the original messsage, ien=HLASTMSG("OIENS")
... D STATUS^HLTF0(HLASTMSG("OIENS"),9)
... D EXIT
... N HLMTIENS
... S HLMTIENS=HLASTMSG("OIENS")
... D SETINQUE^HLTP31
... D STATUS^HLTF0(HLASTRSP,3,,,1)
. ; patch HL*1.6*142 end
;
;enhance ack., no commit & no app ack
I $G(HL("ACAT"))="NE",$G(HL("APAT"))="NE" D Q
. ;set status to awaiting processing, **109** and put on in queue
. I '$G(HLASTRSP) D STATUS^HLTF0(HLMTIENS,9),EXIT,SETINQUE^HLTP31
;
; patch HL*1.6*120 start
;resending old response, msg is a resend
; do not re-send duplicate when $G(HL("ACAT"))="AL"
; the following resend is for original mode application ACK
I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK
; patch HL*1.6*120 end
;
; patch HL*1.6*142 start
; to handle duplicate when the original message encountered
; a write error of commit ACK
; quit if duplicate
; Q:$G(HLASTRSP)
S HLASTRSP("FLAG")=0
I $G(HLASTRSP),$G(HL("ACAT"))="AL" D
. I +$G(^HLMA(+$G(HLASTRSP),"P")),(+$P($G(^HLMA(+$G(HLASTRSP),"P")),"^")'=3) D
.. S HLASTRSP("FLAG")=1
; don't quit if this is duplicate application ACK msg with accept
; ACK type="AL", and its original commit ACK is not done.
I $G(HLASTRSP),('HLASTRSP("FLAG")) Q
;
; if duplicate, change ien to orginal msg ien
I $G(HLASTRSP) D
. S HLMTIENS=+$G(HLASTMSG("OIENS"))
. S HLMTIEN=+$G(^HLMA(HLMTIENS,0))
; patch HL*1.6*142 end
;
CONT ;continue processing an enhance ack msg. called from DEFACK
;Set special HL variables for processing rtn
S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
;
; message is an acknowledgement, HLMSA=ack code^id^text
I ($G(HLMSA)]"") D Q
. ;X=1 if ack ok, 0=reject of error
. S X=$E(HLMSA,2)="A"
. ;Update status of original message and remove it from the queue
. D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1)
. ; patch HL*1.6*142
. ; time: original message receives the application ACK
. S $P(^HLMA(HL("MTIENS"),"S"),"^",5)=$$NOW^XLFDT
. D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
. D
.. N HLTCP ;variable to update status in file #772.
..;
..;**108**
.. N TEMP
.. S TEMP=HLMTIENS
.. N HLMTIENS
.. S HLMTIENS=TEMP
..;**END 108**
..;
.. ; patch HL*1.6*142 start
.. ; time: starts to process the incoming message
.. S $P(^HLMA(HLMTIENS,"S"),"^",6)=$$NOW^XLFDT
.. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
.. ; time: ends processing the incoming message
.. S $P(^HLMA(HLMTIENS,"S"),"^",7)=$$NOW^XLFDT
. ; if duplicate, and the original msg failed to
. ; complete the processing
. I $G(HLASTRSP) D STATUS^HLTF0(HLASTRSP,3,,,1)
. ; patch HL*1.6*142 end
. ;update status of incoming & unlock
. D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT
;
;get entry action, exit action and processing routine
K HLHDR,HLLD0,HLLD1,HLMSA
I HL("EIDS")="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN**
D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN)
S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)),HLPROU=$G(HLN(771))
;quit if no processing routine,update status and quit
I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) D STATUS^HLTF0(HLMTIENS,3,,,1),EXIT Q
;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101,"
;Execute entry action of client protocol
X:HLENROU]"" HLENROU K HLENROU,HLDONE1
;
; patch HL*1.6*142 start
; time: starts to process the incoming message
S $P(^HLMA(HLMTIENS,"S"),"^",6)=$$NOW^XLFDT
;Execute processing routine
X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR
; time: ends processing the incoming message
S $P(^HLMA(HLMTIENS,"S"),"^",7)=$$NOW^XLFDT
; if duplicate, and the original msg failed to
; complete the processing
I $G(HLASTRSP) D STATUS^HLTF0(HLASTRSP,3,,,1)
; patch HL*1.6*142 end
;update status of incoming to complete & unlock
D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT
;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK
ACK I $G(HLTCPO),$G(HLTCP) D Q
. D LLCNT^HLCSTCP(HLDP,3)
. ;write ack back over open tcp link
. S X=$$WRITE^HLCSTCP2(HLTCP)
. ;update status of ack to complete
. D:'$G(HLASTRSP) STATUS^HLTF0(HLTCP,3,,,1)
. D LLCNT^HLCSTCP(HLDP,4)
Q
;
DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN
;HLDP=logical link, X=ien in file 773
;
; patch HL*1.6*120 start
; clean non-Kernel variables
D
. ; protect variables defined in STARTIN^HLCSIN
. N HLFLG,HLEXIT,HLPTRFLR
. ; protect variables defined in DEFACK^HLCSIN
. N HLXX,HLD0,HLPCT
. ; protect input parameters of this sub-routine
. N HLDP,X
. D KILL^XUSCLEAN
; patch HL*1.6*120 end
;
;set error trap
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
N HLERR ;patch HL*1.6*109
Q:'$G(HLDP)!'$G(X) Q:'$G(^HLMA(X,0))
Q:'$D(^HLMA("AC","I",HLDP,X))
;
N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")=""""""
S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14)
S:$P(X,U,15) HL("MTP_ETP")=$P(X,U,15)
S:HL("SAP") HL("SAN")=$P($G(^HL(771,HL("SAP"),0)),U) S:HL("RAP") HL("RAN")=$P($G(^HL(771,HL("RAP"),0)),U)
S:HL("MTP") HL("MTN")=$P($G(^HL(771.2,HL("MTP"),0)),U) S:HL("ETP") HL("ETN")=$P($G(^HL(779.001,HL("ETP"),0)),U)
S:$G(HL("MTP_ETP")) HL("MTN_ETN")=$P($G(^HL(779.005,HL("MTP_ETP"),0)),U)
S HL("EID")=$P($G(^HL(772,HLMTIEN,0)),U,10)
M HLHDRO=^HLMA(HLMTIENS,"MSH")
; if no header quit
Q:'$O(HLHDRO(0))
;
S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7)
;
; quit if ien of #772 is not defined
Q:'HLMTIEN
; quit if field separator is not defined
Q:HL("FS")=""
;
S X=$$P^HLTPCK2(.HLHDRO,1)
;
; patch HL*1.6*120 start
I X="MSH" D
. S HL("PID")=$$P^HLTPCK2(.HLHDRO,11),HL("VER")=$$P^HLTPCK2(.HLHDRO,12),HL("APAT")=$$P^HLTPCK2(.HLHDRO,16),HL("CC")=$$P^HLTPCK2(.HLHDRO,17)
. ;
. ; 2nd component is Processing mode
. S HL("PMOD")=$P(HL("PID"),$E(HL("ECH"),1),2)
. ; first component is Processing id
. S HL("PID")=$P(HL("PID"),$E(HL("ECH"),1))
;
I X'="MSH" D
. S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4)
. ;
. ; original code incorrectly treats repetition separator as
. ; subcomponent separator
. I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D
.. S HL("SUB-COMPONENT")=$E(HL("ECH"),2)
. ; if subcomponent separator is correctly applied
. I $E(HL("ECH"),4)]"",X[$E(HL("ECH"),4) D
.. S HL("SUB-COMPONENT")=$E(HL("ECH"),4)
. ;
. I $D(HL("SUB-COMPONENT")),HL("PID")[HL("SUB-COMPONENT") D
.. ; 2nd sub-component is Processing mode
.. S HL("PMOD")=$P(HL("PID"),HL("SUB-COMPONENT"),2)
.. ; first sub-component is Processing id
.. S HL("PID")=$P(HL("PID"),HL("SUB-COMPONENT"))
. ; patch HL*1.6*120 end
. ;
. Q:$$P^HLTPCK2(.HLHDRO,10)=""
. ;HLMSA=ack code^id^text
. S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2)
;
; quit if this is a commit ack
I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q
;
;** HL*1.6*117 **
K HLL("SET FOR APP ACK"),HLL("LINKS")
;
D CONT
Q
;
MSA(Y) ;Y=ien in 772, returns MSA segment
;ack code^msg being ack id^text
; patch HL*1.6*122
; for HL7 v2.5 and beyond with MSA as 3rd segment
N X,SUBIEN,DATA,DONE
S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
Q:X]"" X
;
S DONE=0
S SUBIEN=1
F S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN D Q:DONE
. S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D
.. S DONE=1
.. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN
.. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
; patch HL*1.6*122 end
;
Q X
;
ERROR ;error trap
D ^%ZTER
I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
; release locks created by inbound filer
; patch HL*1.6*140
; L -^HLMA("AC","I",+$G(HLXX))
L -^HLMA("IN-FILER","AC","I",+$G(HLXX))
G UNWIND^%ZTER
;
;
EXIT ;unlock
I $G(HLMTIENS) L -^HLMA(HLMTIENS)
Q
;
ONAC(IEN773) ;
;Returns 1 if the message is on the "AC","I" xref
;Returns 0 otherwise
;
N LINK
S LINK=$P($G(^HLMA(IEN773,0)),"^",17)
Q:'LINK 0
Q $D(^HLMA("AC","I",LINK,IEN773))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTP3 13938 printed Sep 23, 2025@19:36:07 Page 2
HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;07/29/2009 14:51
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122,140,142,145**;Oct 13, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
NEW(X) ;process new msg. ien in 773^ien in 772
+1 ;HLMTIENS=ien in #773; HLMTIEN=ien in #772
+2 ;HLHDRO=original header; HLHDR=response header
+3 ;set error trap
+4 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLTP3"
+5 NEW HL,HLEID,HLEIDS,HLERR,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLQUIT,HLNODE,HLNEXT,HLRESLTA,HLDONE1,HLASTRSP,HLRESLT
+6 SET HLRESLT=""
+7 DO INIT^HLTP3A
+8 ;error with header, return commit/app reject
+9 IF $GET(HLRESLT)
Begin DoDot:1
+10 ;set status & unlock record
+11 DO STATUS^HLTF0(HLMTIENS,4,,,1)
DO EXIT
+12 ;quit if no commit or app ack
+13 IF $GET(HL("ACAT"))="NE"
IF $GET(HL("APAT"))="NE"
QUIT
+14 SET X=$SELECT($GET(HL("ACAT"))="AL":"CR",1:"AR")
+15 ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4
+16 DO ACK^HLTP4(X,$PIECE(HLRESLT,U,2))
if '$GET(HLTCP)
QUIT
+17 ;write ack back
+18 SET X=$$WRITE^HLCSTCP2(HLTCP)
+19 ;update counter to sent
+20 DO LLCNT^HLCSTCP(HLDP,4)
+21 ;update status of ack
+22 DO STATUS^HLTF0(HLTCP,3,,,1)
End DoDot:1
QUIT
+23 ;
+24 ;check for duplicate msg., use rec. app and msg. id x-ref
+25 ; patch HL*1.6*142 start
+26 ; HL("HDR FLDS:3-6") extracted from field 3 to field 6 of header
+27 ; defined in HLDIE routine
+28 ; I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS)
+29 IF ($GET(HL("MID"))]"")
IF ($GET(HL("HDR FLDS:3-6"))]"")
Begin DoDot:1
+30 SET X=$ORDER(^HLMA("AH-NEW",HL("HDR FLDS:3-6"),HL("MID"),0))
+31 ; patch HL*1.6*142 end
+32 ;HLASTMSG=last ien received during this connection
+33 ;if no duplicate, save msg. ien and quit
+34 IF X=HLMTIENS!'X
SET HLASTMSG=HLMTIENS
QUIT
+35 NEW MSH,OIENS
+36 SET (OIENS,Y)=X
Begin DoDot:2
+37 ;combine MSH into single string
+38 SET MSH(Y)=""
SET I=0
FOR
SET I=$ORDER(^HLMA(Y,"MSH",I))
if 'I
QUIT
SET MSH(Y)=MSH(Y)_$GET(^(I,0))
End DoDot:2
SET Y=HLMTIENS
Begin DoDot:2
End DoDot:2
+39 ; patch 117 & 125, check if identical
+40 IF MSH(HLMTIENS)'=MSH(OIENS)
SET HLASTMSG=HLMTIENS
QUIT
+41 ;
+42 ;msg is duplicate, set status
+43 DO STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1)
DO EXIT
+44 ;msg was resent, ignore it.
+45 IF HLASTMSG=HLMTIENS
KILL HLMTIENS
QUIT
+46 ;find original response and send back
+47 SET HLASTRSP=$ORDER(^HLMA("AF",OIENS,OIENS))
+48 ; patch HL*1.6*142 start
+49 ; the original msg may need to be updated again if 1st time
+50 ; update failed
+51 SET HLASTMSG("OIENS")=OIENS
+52 ;
+53 ; the original message and its commit ACK were purged, OIENS is
+54 ; duplicate and needs to create its own commit ACK (happened
+55 ; between MPI and VIE in 9/2008), the OIENS will be processed
+56 ; by the application routine again.
+57 IF $GET(HL("ACAT"))="AL"
IF '$GET(HL("ACK"))
IF 'HLASTRSP
Begin DoDot:2
+58 NEW HLTCP,HLMTIENS
+59 SET HLMTIENS=OIENS
+60 DO ACK^HLTP4("CA")
+61 ; decreament and will be added later
DO LLCNT^HLCSTCP(HLDP,3,1)
+62 SET HLASTRSP=HLTCP
End DoDot:2
+63 ; patch HL*1.6*142 end
End DoDot:1
if '$DATA(HLMTIENS)
QUIT
+64 ;
+65 ; patch HL*1.6*145 start
+66 ; Quit if this is application ack to application ack
+67 IF $GET(HL("ACK"))
Begin DoDot:1
+68 NEW HLERRMG,X
+69 SET HLERRMG="Received application acknowledgement to an application acknowledgement"
+70 ;msg is a resend, HLASTRSP=ien of original response (commit ACK)
+71 IF $GET(HLASTRSP)
Begin DoDot:2
+72 SET HLTCP=HLASTRSP
+73 DO STATUS^HLTF0(HLTCP,8)
+74 SET ^HLMA(+HLTCP,"S")=$$NOW^XLFDT
+75 DO LLCNT^HLCSTCP(HLDP,3)
End DoDot:2
+76 IF '$TEST
Begin DoDot:2
+77 ;Send CR and update status of original and current ack messages
+78 DO ACK^HLTP4("CR",HLERRMG)
End DoDot:2
if '$GET(HLTCP)
QUIT
+79 ;
+80 ; write commit ACK (original commit ACK)
+81 SET X=$$WRITE^HLCSTCP2(HLTCP)
+82 DO STATUS^HLTF0(HLTCP,3,,"'Reject' commit ACK: "_HLERRMG,1)
+83 SET ^HLMA(+HLTCP,"S")=$$NOW^XLFDT
+84 DO LLCNT^HLCSTCP(HLDP,4)
+85 SET HLTCP=""
+86 ; D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
+87 DO STATUS^HLTF0(HL("MTIENS"),3,,,1)
+88 DO STATUS^HLTF0(HLMTIENS,4,,HLERRMG,1)
+89 ;unlock record
+90 DO EXIT
End DoDot:1
QUIT
+91 ; patch HL*1.6*145 end
+92 ;
+93 ; enhance ack., send commit, quit if not an ack, msg will be
+94 ; processed by filer
+95 IF $GET(HL("ACAT"))="AL"
Begin DoDot:1
+96 ;msg is a resend, HLASTRSP=ien of original response (commit ACK)
+97 IF $GET(HLASTRSP)
Begin DoDot:2
+98 SET HLTCP=HLASTRSP
+99 DO LLCNT^HLCSTCP(HLDP,3)
End DoDot:2
+100 IF '$TEST
Begin DoDot:2
+101 ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4
DO ACK^HLTP4("CA")
End DoDot:2
if '$GET(HLTCP)
QUIT
+102 ;
+103 ; write commit ACK (original commit ACK)
+104 SET X=$$WRITE^HLCSTCP2(HLTCP)
+105 ; patch HL*1.6*142
+106 ; D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP)
+107 DO LLCNT^HLCSTCP(HLDP,4)
+108 IF '$GET(HLASTRSP)
Begin DoDot:2
+109 DO STATUS^HLTF0(HLTCP,3,,,1)
End DoDot:2
+110 SET HLTCP=""
+111 ;if not an ack, set status to awaiting processing **109** and put on in queue
+112 IF '$GET(HL("MTIENS"))
IF '$GET(HLASTRSP)
DO STATUS^HLTF0(HLMTIENS,9)
DO EXIT
DO SETINQUE^HLTP31
+113 ;
+114 ; patch HL*1.6*142 start
+115 ;if the original msg failed to en-queue and update status
+116 ; it may happen when COTS disconnect the listener during
+117 ; writing the commit ACK
+118 ; deal with a non-application ACK duplicate message
+119 IF '$GET(HL("MTIENS"))
IF $GET(HLASTRSP)
Begin DoDot:2
+120 NEW STATUS
+121 SET STATUS=+$GET(^HLMA(HLASTRSP,"P"))
+122 IF STATUS
IF (STATUS'=3)
Begin DoDot:3
+123 ; update the original messsage, ien=HLASTMSG("OIENS")
+124 DO STATUS^HLTF0(HLASTMSG("OIENS"),9)
+125 DO EXIT
+126 NEW HLMTIENS
+127 SET HLMTIENS=HLASTMSG("OIENS")
+128 DO SETINQUE^HLTP31
+129 DO STATUS^HLTF0(HLASTRSP,3,,,1)
End DoDot:3
End DoDot:2
+130 ; patch HL*1.6*142 end
End DoDot:1
if '$GET(HL("MTIENS"))
QUIT
+131 ;
+132 ;enhance ack., no commit & no app ack
+133 IF $GET(HL("ACAT"))="NE"
IF $GET(HL("APAT"))="NE"
Begin DoDot:1
+134 ;set status to awaiting processing, **109** and put on in queue
+135 IF '$GET(HLASTRSP)
DO STATUS^HLTF0(HLMTIENS,9)
DO EXIT
DO SETINQUE^HLTP31
End DoDot:1
QUIT
+136 ;
+137 ; patch HL*1.6*120 start
+138 ;resending old response, msg is a resend
+139 ; do not re-send duplicate when $G(HL("ACAT"))="AL"
+140 ; the following resend is for original mode application ACK
+141 IF $GET(HLASTRSP)
IF $GET(HL("ACAT"))'="AL"
SET HLTCP=HLASTRSP
GOTO ACK
+142 ; patch HL*1.6*120 end
+143 ;
+144 ; patch HL*1.6*142 start
+145 ; to handle duplicate when the original message encountered
+146 ; a write error of commit ACK
+147 ; quit if duplicate
+148 ; Q:$G(HLASTRSP)
+149 SET HLASTRSP("FLAG")=0
+150 IF $GET(HLASTRSP)
IF $GET(HL("ACAT"))="AL"
Begin DoDot:1
+151 IF +$GET(^HLMA(+$GET(HLASTRSP),"P"))
IF (+$PIECE($GET(^HLMA(+$GET(HLASTRSP),"P")),"^")'=3)
Begin DoDot:2
+152 SET HLASTRSP("FLAG")=1
End DoDot:2
End DoDot:1
+153 ; don't quit if this is duplicate application ACK msg with accept
+154 ; ACK type="AL", and its original commit ACK is not done.
+155 IF $GET(HLASTRSP)
IF ('HLASTRSP("FLAG"))
QUIT
+156 ;
+157 ; if duplicate, change ien to orginal msg ien
+158 IF $GET(HLASTRSP)
Begin DoDot:1
+159 SET HLMTIENS=+$GET(HLASTMSG("OIENS"))
+160 SET HLMTIEN=+$GET(^HLMA(HLMTIENS,0))
End DoDot:1
+161 ; patch HL*1.6*142 end
+162 ;
CONT ;continue processing an enhance ack msg. called from DEFACK
+1 ;Set special HL variables for processing rtn
+2 SET HLQUIT=0
SET HLNODE=""
SET HLNEXT="D HLNEXT^HLCSUTL"
+3 ;
+4 ; message is an acknowledgement, HLMSA=ack code^id^text
+5 IF ($GET(HLMSA)]"")
Begin DoDot:1
+6 ;X=1 if ack ok, 0=reject of error
+7 SET X=$EXTRACT(HLMSA,2)="A"
+8 ;Update status of original message and remove it from the queue
+9 DO STATUS^HLTF0(HL("MTIENS"),$SELECT(X:3,1:4),"",$SELECT(X:"",1:$PIECE(HLMSA,HL("FS"),3)),1)
+10 ; patch HL*1.6*142
+11 ; time: original message receives the application ACK
+12 SET $PIECE(^HLMA(HL("MTIENS"),"S"),"^",5)=$$NOW^XLFDT
+13 DO DEQUE^HLCSREP($PIECE($GET(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
+14 Begin DoDot:2
+15 ;variable to update status in file #772.
NEW HLTCP
+16 ;
+17 ;**108**
+18 NEW TEMP
+19 SET TEMP=HLMTIENS
+20 NEW HLMTIENS
+21 SET HLMTIENS=TEMP
+22 ;**END 108**
+23 ;
+24 ; patch HL*1.6*142 start
+25 ; time: starts to process the incoming message
+26 SET $PIECE(^HLMA(HLMTIENS,"S"),"^",6)=$$NOW^XLFDT
+27 DO PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
+28 ; time: ends processing the incoming message
+29 SET $PIECE(^HLMA(HLMTIENS,"S"),"^",7)=$$NOW^XLFDT
End DoDot:2
+30 ; if duplicate, and the original msg failed to
+31 ; complete the processing
+32 IF $GET(HLASTRSP)
DO STATUS^HLTF0(HLASTRSP,3,,,1)
+33 ; patch HL*1.6*142 end
+34 ;update status of incoming & unlock
+35 DO STATUS^HLTF0(HLMTIENS,$SELECT($GET(HLRESLT):4,1:3),$SELECT($GET(HLRESLT):+$GET(HLRESLT),1:""),$SELECT($GET(HLRESLT):$PIECE(HLRESLT,U,2),1:""),1)
DO EXIT
End DoDot:1
QUIT
+36 ;
+37 ;get entry action, exit action and processing routine
+38 KILL HLHDR,HLLD0,HLLD1,HLMSA
+39 ;**CIRN**
IF HL("EIDS")=""
IF $GET(HLEIDS)]""
SET HL("EIDS")=HLEIDS
+40 DO EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN)
+41 SET HLENROU=$GET(HLN(20))
SET HLEXROU=$GET(HLN(15))
SET HLPROU=$GET(HLN(771))
+42 ;quit if no processing routine,update status and quit
+43 IF HLPROU']""
SET HLRESLT="10^"_$GET(^HL(771.7,10,0))
DO STATUS^HLTF0(HLMTIENS,3,,,1)
DO EXIT
QUIT
+44 ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
+45 NEW HLORNODD
SET HLORNOD=HL("EIDS")_";ORD(101,"
+46 ;Execute entry action of client protocol
+47 if HLENROU]""
XECUTE HLENROU
KILL HLENROU,HLDONE1
+48 ;
+49 ; patch HL*1.6*142 start
+50 ; time: starts to process the incoming message
+51 SET $PIECE(^HLMA(HLMTIENS,"S"),"^",6)=$$NOW^XLFDT
+52 ;Execute processing routine
+53 XECUTE HLPROU
SET HLRESLT=0
if ($DATA(HLERR))
SET HLRESLT="9^"_HLERR
+54 ; time: ends processing the incoming message
+55 SET $PIECE(^HLMA(HLMTIENS,"S"),"^",7)=$$NOW^XLFDT
+56 ; if duplicate, and the original msg failed to
+57 ; complete the processing
+58 IF $GET(HLASTRSP)
DO STATUS^HLTF0(HLASTRSP,3,,,1)
+59 ; patch HL*1.6*142 end
+60 ;update status of incoming to complete & unlock
+61 DO STATUS^HLTF0(HLMTIENS,$SELECT(HLRESLT:4,1:3),$SELECT(HLRESLT:+HLRESLT,1:""),$SELECT(HLRESLT:$PIECE(HLRESLT,U,2),1:""),1,$SELECT($GET(HLERR("SKIP_EVENT"))=1:1,1:0))
DO EXIT
+62 ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK
ACK IF $GET(HLTCPO)
IF $GET(HLTCP)
Begin DoDot:1
+1 DO LLCNT^HLCSTCP(HLDP,3)
+2 ;write ack back over open tcp link
+3 SET X=$$WRITE^HLCSTCP2(HLTCP)
+4 ;update status of ack to complete
+5 if '$GET(HLASTRSP)
DO STATUS^HLTF0(HLTCP,3,,,1)
+6 DO LLCNT^HLCSTCP(HLDP,4)
End DoDot:1
QUIT
+7 QUIT
+8 ;
DEFACK(HLDP,X) ;process the deferred application ack, called from HLCSIN
+1 ;HLDP=logical link, X=ien in file 773
+2 ;
+3 ; patch HL*1.6*120 start
+4 ; clean non-Kernel variables
+5 Begin DoDot:1
+6 ; protect variables defined in STARTIN^HLCSIN
+7 NEW HLFLG,HLEXIT,HLPTRFLR
+8 ; protect variables defined in DEFACK^HLCSIN
+9 NEW HLXX,HLD0,HLPCT
+10 ; protect input parameters of this sub-routine
+11 NEW HLDP,X
+12 DO KILL^XUSCLEAN
End DoDot:1
+13 ; patch HL*1.6*120 end
+14 ;
+15 ;set error trap
+16 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLTP3"
+17 ;patch HL*1.6*109
NEW HLERR
+18 if '$GET(HLDP)!'$GET(X)
QUIT
if '$GET(^HLMA(X,0))
QUIT
+19 if '$DATA(^HLMA("AC","I",HLDP,X))
QUIT
+20 ;
+21 NEW HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
+22 SET HLMTIENS=X
SET X=^HLMA(HLMTIENS,0)
SET HLMTIEN=+$PIECE(X,U)
SET HL("MID")=$PIECE(X,U,2)
SET HL("MTIENS")=$PIECE(X,U,10)
SET HL("LL")=$PIECE(X,U,7)
SET HLTCP=""
SET HL("Q")=""""""
+23 SET HL("EIDS")=$PIECE(X,U,8)
SET HL("SAP")=$PIECE(X,U,11)
SET HL("RAP")=$PIECE(X,U,12)
SET HL("MTP")=$PIECE(X,U,13)
SET HL("ETP")=$PIECE(X,U,14)
+24 if $PIECE(X,U,15)
SET HL("MTP_ETP")=$PIECE(X,U,15)
+25 if HL("SAP")
SET HL("SAN")=$PIECE($GET(^HL(771,HL("SAP"),0)),U)
if HL("RAP")
SET HL("RAN")=$PIECE($GET(^HL(771,HL("RAP"),0)),U)
+26 if HL("MTP")
SET HL("MTN")=$PIECE($GET(^HL(771.2,HL("MTP"),0)),U)
if HL("ETP")
SET HL("ETN")=$PIECE($GET(^HL(779.001,HL("ETP"),0)),U)
+27 if $GET(HL("MTP_ETP"))
SET HL("MTN_ETN")=$PIECE($GET(^HL(779.005,HL("MTP_ETP"),0)),U)
+28 SET HL("EID")=$PIECE($GET(^HL(772,HLMTIEN,0)),U,10)
+29 MERGE HLHDRO=^HLMA(HLMTIENS,"MSH")
+30 ; if no header quit
+31 if '$ORDER(HLHDRO(0))
QUIT
+32 ;
+33 SET HL("FS")=$EXTRACT(HLHDRO(1,0),4)
SET HL("ECH")=$$P^HLTPCK2(.HLHDRO,2)
SET HL("SFN")=$$P^HLTPCK2(.HLHDRO,4)
SET HL("RFN")=$$P^HLTPCK2(.HLHDRO,6)
SET HL("DTM")=$$P^HLTPCK2(.HLHDRO,7)
+34 ;
+35 ; quit if ien of #772 is not defined
+36 if 'HLMTIEN
QUIT
+37 ; quit if field separator is not defined
+38 if HL("FS")=""
QUIT
+39 ;
+40 SET X=$$P^HLTPCK2(.HLHDRO,1)
+41 ;
+42 ; patch HL*1.6*120 start
+43 IF X="MSH"
Begin DoDot:1
+44 SET HL("PID")=$$P^HLTPCK2(.HLHDRO,11)
SET HL("VER")=$$P^HLTPCK2(.HLHDRO,12)
SET HL("APAT")=$$P^HLTPCK2(.HLHDRO,16)
SET HL("CC")=$$P^HLTPCK2(.HLHDRO,17)
+45 ;
+46 ; 2nd component is Processing mode
+47 SET HL("PMOD")=$PIECE(HL("PID"),$EXTRACT(HL("ECH"),1),2)
+48 ; first component is Processing id
+49 SET HL("PID")=$PIECE(HL("PID"),$EXTRACT(HL("ECH"),1))
End DoDot:1
+50 ;
+51 IF X'="MSH"
Begin DoDot:1
+52 SET X=$$P^HLTPCK2(.HLHDRO,9)
SET Z=$EXTRACT(HL("ECH"))
SET HL("PID")=$PIECE(X,Z,2)
SET HL("VER")=$PIECE(X,Z,4)
+53 ;
+54 ; original code incorrectly treats repetition separator as
+55 ; subcomponent separator
+56 IF $EXTRACT(HL("ECH"),2)]""
IF X[$EXTRACT(HL("ECH"),2)
Begin DoDot:2
+57 SET HL("SUB-COMPONENT")=$EXTRACT(HL("ECH"),2)
End DoDot:2
+58 ; if subcomponent separator is correctly applied
+59 IF $EXTRACT(HL("ECH"),4)]""
IF X[$EXTRACT(HL("ECH"),4)
Begin DoDot:2
+60 SET HL("SUB-COMPONENT")=$EXTRACT(HL("ECH"),4)
End DoDot:2
+61 ;
+62 IF $DATA(HL("SUB-COMPONENT"))
IF HL("PID")[HL("SUB-COMPONENT")
Begin DoDot:2
+63 ; 2nd sub-component is Processing mode
+64 SET HL("PMOD")=$PIECE(HL("PID"),HL("SUB-COMPONENT"),2)
+65 ; first sub-component is Processing id
+66 SET HL("PID")=$PIECE(HL("PID"),HL("SUB-COMPONENT"))
End DoDot:2
+67 ; patch HL*1.6*120 end
+68 ;
+69 if $$P^HLTPCK2(.HLHDRO,10)=""
QUIT
+70 ;HLMSA=ack code^id^text
+71 SET HLMSA=$PIECE($$P^HLTPCK2(.HLHDRO,10),$EXTRACT(HL("ECH")),1)
SET $PIECE(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12)
SET $PIECE(HLMSA,HL("FS"),3)=$PIECE($$P^HLTPCK2(.HLHDRO,10),$EXTRACT(HL("ECH")),2)
SET HL("MSAID")=$PIECE(HLMSA,HL("FS"),2)
End DoDot:1
+72 ;
+73 ; quit if this is a commit ack
+74 IF $PIECE($GET(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA"
IF $EXTRACT($PIECE($GET(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C"
QUIT
+75 ;
+76 ;** HL*1.6*117 **
+77 KILL HLL("SET FOR APP ACK"),HLL("LINKS")
+78 ;
+79 DO CONT
+80 QUIT
+81 ;
MSA(Y) ;Y=ien in 772, returns MSA segment
+1 ;ack code^msg being ack id^text
+2 ; patch HL*1.6*122
+3 ; for HL7 v2.5 and beyond with MSA as 3rd segment
+4 NEW X,SUBIEN,DATA,DONE
+5 SET X=$GET(^HL(772,Y,"IN",1,0))
SET X=$SELECT($EXTRACT(X,1,3)="MSA":$EXTRACT(X,5,999),1:"")
+6 if X]""
QUIT X
+7 ;
+8 SET DONE=0
+9 SET SUBIEN=1
+10 FOR
SET SUBIEN=$ORDER(^HL(772,Y,"IN",SUBIEN))
if 'SUBIEN
QUIT
Begin DoDot:1
+11 SET DATA=$GET(^HL(772,Y,"IN",SUBIEN,0))
IF DATA=""
Begin DoDot:2
+12 SET DONE=1
+13 SET SUBIEN=$ORDER(^HL(772,Y,"IN",SUBIEN))
if 'SUBIEN
QUIT
+14 SET X=$GET(^HL(772,Y,"IN",SUBIEN,0))
SET X=$SELECT($EXTRACT(X,1,3)="MSA":$EXTRACT(X,5,999),1:"")
End DoDot:2
End DoDot:1
if DONE
QUIT
+15 ; patch HL*1.6*122 end
+16 ;
+17 QUIT X
+18 ;
ERROR ;error trap
+1 DO ^%ZTER
+2 IF $GET(HLMTIENS)
IF $DATA(^HLMA(HLMTIENS,0))
DO STATUS^HLTF0(HLMTIENS,4,,,1)
DO EXIT
+3 ; release locks created by inbound filer
+4 ; patch HL*1.6*140
+5 ; L -^HLMA("AC","I",+$G(HLXX))
+6 LOCK -^HLMA("IN-FILER","AC","I",+$GET(HLXX))
+7 GOTO UNWIND^%ZTER
+8 ;
+9 ;
EXIT ;unlock
+1 IF $GET(HLMTIENS)
LOCK -^HLMA(HLMTIENS)
+2 QUIT
+3 ;
ONAC(IEN773) ;
+1 ;Returns 1 if the message is on the "AC","I" xref
+2 ;Returns 0 otherwise
+3 ;
+4 NEW LINK
+5 SET LINK=$PIECE($GET(^HLMA(IEN773,0)),"^",17)
+6 if 'LINK
QUIT 0
+7 QUIT $DATA(^HLMA("AC","I",LINK,IEN773))
