HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006
;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133**;Oct 13, 1995;Build 13
;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
NEW(X) ;process new msg. ien in 773^msg. ien in 772
;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text
;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 over connection
. S X=$$WRITE^HLCSTCP2(HLTCP)
. ;update counter to sent
. D LLCNT^HLCSTCP(HLDP,4)
. ;update status of ack to complete
. D STATUS^HLTF0(HLTCP,3,,,1)
;
;check for duplicate msg., use rec. app and msg. id x-ref
; patch HL*1.6*120
; I $L($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("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS)
. ;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 as duplicate
. D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT
. ;msg was resent during this connection, ignore it.
. I HLASTMSG=HLMTIENS K HLMTIENS Q
. ;find original response and send back
. S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS))
;
;Quit if this is acknowledgment to acknowledgement message
I $G(HL("ACK")) D Q
. ;Update status of original acknowledgment message to successfully
. D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
. ;unlock record
. D EXIT
;
;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
.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
. S X=$$WRITE^HLCSTCP2(HLTCP)
. D LLCNT^HLCSTCP(HLDP,4),STATUS^HLTF0(HLTCP,3,,,1):'$G(HLASTRSP)
. 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
;
;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
; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK
; do not re-send duplicate message when $G(HL("ACAT"))="AL"
I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK
; quit if duplicate
Q:$G(HLASTRSP)
; patch HL*1.6*120 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 subscriber message and remove it from the out-going queue
. D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1)
. D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
. D
.. N HLTCP ;New variable to update status in file #772.
..;
..;**108**
.. N TEMP
.. S TEMP=HLMTIENS
.. N HLMTIENS
.. S HLMTIENS=TEMP
..;**END 108**
..;
.. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
. ;update status of incoming to complete & 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
;
;Execute processing routine
X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_HLERR
;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 acknowledgment 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 variables except Kernel related 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))
;**109 START**
Q:'$D(^HLMA("AC","I",HLDP,X))
;**109 END**
;
N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
;setup variables
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
;**109**
;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q
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)
;
; patch HL*1.6*109 start
; quit if ien of #772 is not defined
Q:'HLMTIEN
; quit if field separator is not defined
Q:HL("FS")=""
; patch HL*1.6*109 end
;
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 implementation 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)
;
; HL*1.6*108
; 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")
;** END HL*1.6*117 **
;
D CONT
Q
;
MSA(Y) ;Y=ien in 772, returns MSA segment
;ack code^msg being ack id^text
N X
S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
Q X
;
ERROR ;error trap
D ^%ZTER
I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
;*109* release all locks created by inbound filer
L -^HLMA("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))
HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133**;Oct 13, 1995;Build 13
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
NEW(X) ;process new msg. ien in 773^msg. ien in 772
+1 ;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text
+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 over connection
+18 SET X=$$WRITE^HLCSTCP2(HLTCP)
+19 ;update counter to sent
+20 DO LLCNT^HLCSTCP(HLDP,4)
+21 ;update status of ack to complete
+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*120
+26 ; I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D Q:'$D(HLMTIENS)
+27 IF $GET(HL("MID"))]""
IF $GET(HL("RAP"))
SET X=$ORDER(^HLMA("AH",HL("RAP"),HL("MID"),0))
Begin DoDot:1
+28 ;HLASTMSG=last ien received during this connection
+29 ;if no duplicate, save msg. ien and quit
+30 IF X=HLMTIENS!'X
SET HLASTMSG=HLMTIENS
QUIT
+31 NEW MSH,OIENS
+32 SET (OIENS,Y)=X
Begin DoDot:2
+33 ;combine MSH into single string
+34 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
+35 ; patch 117 & 125, check if identical
+36 IF MSH(HLMTIENS)'=MSH(OIENS)
SET HLASTMSG=HLMTIENS
QUIT
+37 ;
+38 ;msg is duplicate, set status as duplicate
+39 DO STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1)
DO EXIT
+40 ;msg was resent during this connection, ignore it.
+41 IF HLASTMSG=HLMTIENS
KILL HLMTIENS
QUIT
+42 ;find original response and send back
+43 SET HLASTRSP=$ORDER(^HLMA("AF",OIENS,OIENS))
End DoDot:1
IF '$DATA(HLMTIENS)
QUIT
+44 ;
+45 ;Quit if this is acknowledgment to acknowledgement message
+46 IF $GET(HL("ACK"))
Begin DoDot:1
+47 ;Update status of original acknowledgment message to successfully
+48 DO STATUS^HLTF0(HL("MTIENS"),3,,,1)
DO STATUS^HLTF0(HLMTIENS,3,,,1)
+49 ;unlock record
+50 DO EXIT
End DoDot:1
QUIT
+51 ;
+52 ;enhance ack., send commit, quit if not an ack, msg will be processed by filer
+53 IF $GET(HL("ACAT"))="AL"
Begin DoDot:1
+54 ;msg is a resend, HLASTRSP=ien of original response
+55 IF $GET(HLASTRSP)
Begin DoDot:2
+56 SET HLTCP=HLASTRSP
+57 DO LLCNT^HLCSTCP(HLDP,3)
End DoDot:2
+58 IF '$TEST
Begin DoDot:2
+59 ;**109** LLCNT^HLCSTCP(HLDP,3) called in ACK^HLTP4
DO ACK^HLTP4("CA")
End DoDot:2
IF '$GET(HLTCP)
QUIT
+60 SET X=$$WRITE^HLCSTCP2(HLTCP)
+61 DO LLCNT^HLCSTCP(HLDP,4)
IF '$GET(HLASTRSP)
DO STATUS^HLTF0(HLTCP,3,,,1)
+62 SET HLTCP=""
+63 ;if not an ack, set status to awaiting processing **109** and put on in queue
+64 IF '$GET(HL("MTIENS"))
IF '$GET(HLASTRSP)
DO STATUS^HLTF0(HLMTIENS,9)
DO EXIT
DO SETINQUE^HLTP31
End DoDot:1
IF '$GET(HL("MTIENS"))
QUIT
+65 ;
+66 ;enhance ack., no commit & no app ack
+67 IF $GET(HL("ACAT"))="NE"
IF $GET(HL("APAT"))="NE"
Begin DoDot:1
+68 ;set status to awaiting processing, **109** and put on in queue
+69 IF '$GET(HLASTRSP)
DO STATUS^HLTF0(HLMTIENS,9)
DO EXIT
DO SETINQUE^HLTP31
End DoDot:1
QUIT
+70 ;
+71 ; patch HL*1.6*120 start
+72 ;resending old response, msg is a resend
+73 ; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK
+74 ; do not re-send duplicate message when $G(HL("ACAT"))="AL"
+75 IF $GET(HLASTRSP)
IF $GET(HL("ACAT"))'="AL"
SET HLTCP=HLASTRSP
GOTO ACK
+76 ; quit if duplicate
+77 IF $GET(HLASTRSP)
QUIT
+78 ; patch HL*1.6*120 end
+79 ;
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 subscriber message and remove it from the out-going queue
+9 DO STATUS^HLTF0(HL("MTIENS"),$SELECT(X:3,1:4),"",$SELECT(X:"",1:$PIECE(HLMSA,HL("FS"),3)),1)
+10 DO DEQUE^HLCSREP($PIECE($GET(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
+11 Begin DoDot:2
+12 ;New variable to update status in file #772.
NEW HLTCP
+13 ;
+14 ;**108**
+15 NEW TEMP
+16 SET TEMP=HLMTIENS
+17 NEW HLMTIENS
+18 SET HLMTIENS=TEMP
+19 ;**END 108**
+20 ;
+21 DO PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
End DoDot:2
+22 ;update status of incoming to complete & unlock
+23 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
+24 ;
+25 ;get entry action, exit action and processing routine
+26 KILL HLHDR,HLLD0,HLLD1,HLMSA
+27 ;**CIRN**
IF HL("EIDS")=""
IF $GET(HLEIDS)]""
SET HL("EIDS")=HLEIDS
+28 DO EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN)
+29 SET HLENROU=$GET(HLN(20))
SET HLEXROU=$GET(HLN(15))
SET HLPROU=$GET(HLN(771))
+30 ;quit if no processing routine,update status and quit
+31 IF HLPROU']""
SET HLRESLT="10^"_$GET(^HL(771.7,10,0))
DO STATUS^HLTF0(HLMTIENS,3,,,1)
DO EXIT
QUIT
+32 ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
+33 NEW HLORNODD
SET HLORNOD=HL("EIDS")_";ORD(101,"
+34 ;Execute entry action of client protocol
+35 IF HLENROU]""
XECUTE HLENROU
KILL HLENROU,HLDONE1
+36 ;
+37 ;Execute processing routine
+38 XECUTE HLPROU
SET HLRESLT=0
IF ($DATA(HLERR))
SET HLRESLT="9^"_HLERR
+39 ;update status of incoming to complete & unlock
+40 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
+41 ;HLTCPO=link open, HLTCP=ien of acknowledgment 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 variables except Kernel related 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 ;**109 START**
+20 IF '$DATA(^HLMA("AC","I",HLDP,X))
QUIT
+21 ;**109 END**
+22 ;
+23 NEW HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
+24 ;setup variables
+25 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")=""""""
+26 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)
+27 IF $PIECE(X,U,15)
SET HL("MTP_ETP")=$PIECE(X,U,15)
+28 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)
+29 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)
+30 IF $GET(HL("MTP_ETP"))
SET HL("MTN_ETN")=$PIECE($GET(^HL(779.005,HL("MTP_ETP"),0)),U)
+31 SET HL("EID")=$PIECE($GET(^HL(772,HLMTIEN,0)),U,10)
+32 MERGE HLHDRO=^HLMA(HLMTIENS,"MSH")
+33 ; if no header quit
+34 ;**109**
+35 ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q
+36 IF '$ORDER(HLHDRO(0))
QUIT
+37 ;
+38 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)
+39 ;
+40 ; patch HL*1.6*109 start
+41 ; quit if ien of #772 is not defined
+42 IF 'HLMTIEN
QUIT
+43 ; quit if field separator is not defined
+44 IF HL("FS")=""
QUIT
+45 ; patch HL*1.6*109 end
+46 ;
+47 SET X=$$P^HLTPCK2(.HLHDRO,1)
+48 ;
+49 ; patch HL*1.6*120 start
+50 IF X="MSH"
Begin DoDot:1
+51 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)
+52 ;
+53 ; 2nd component is Processing mode
+54 SET HL("PMOD")=$PIECE(HL("PID"),$EXTRACT(HL("ECH"),1),2)
+55 ; first component is Processing id
+56 SET HL("PID")=$PIECE(HL("PID"),$EXTRACT(HL("ECH"),1))
End DoDot:1
+57 ;
+58 IF X'="MSH"
Begin DoDot:1
+59 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)
+60 ;
+61 ; original implementation incorrectly treats repetition separator as
+62 ; subcomponent separator
+63 IF $EXTRACT(HL("ECH"),2)]""
IF X[$EXTRACT(HL("ECH"),2)
Begin DoDot:2
+64 SET HL("SUB-COMPONENT")=$EXTRACT(HL("ECH"),2)
End DoDot:2
+65 ; if subcomponent separator is correctly applied
+66 IF $EXTRACT(HL("ECH"),4)]""
IF X[$EXTRACT(HL("ECH"),4)
Begin DoDot:2
+67 SET HL("SUB-COMPONENT")=$EXTRACT(HL("ECH"),4)
End DoDot:2
+68 ;
+69 IF $DATA(HL("SUB-COMPONENT"))
IF HL("PID")[HL("SUB-COMPONENT")
Begin DoDot:2
+70 ; 2nd sub-component is Processing mode
+71 SET HL("PMOD")=$PIECE(HL("PID"),HL("SUB-COMPONENT"),2)
+72 ; first sub-component is Processing id
+73 SET HL("PID")=$PIECE(HL("PID"),HL("SUB-COMPONENT"))
End DoDot:2
+74 ; patch HL*1.6*120 end
+75 ;
+76 IF $$P^HLTPCK2(.HLHDRO,10)=""
QUIT
+77 ;HLMSA=ack code^id^text
+78 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
+79 ;
+80 ; HL*1.6*108
+81 ; quit if this is a commit ack
+82 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
+83 ; **
+84 ;
+85 ;** HL*1.6*117 **
+86 KILL HLL("SET FOR APP ACK"),HLL("LINKS")
+87 ;** END HL*1.6*117 **
+88 ;
+89 DO CONT
+90 QUIT
+91 ;
MSA(Y) ;Y=ien in 772, returns MSA segment
+1 ;ack code^msg being ack id^text
+2 NEW X
+3 SET X=$GET(^HL(772,Y,"IN",1,0))
SET X=$SELECT($EXTRACT(X,1,3)="MSA":$EXTRACT(X,5,999),1:"")
+4 QUIT X
+5 ;
ERROR ;error trap
+1 DO ^%ZTER
+2 IF $GET(HLMTIENS)
IF $DATA(^HLMA(HLMTIENS,0))
DO STATUS^HLTF0(HLMTIENS,4,,,1)
DO EXIT
+3 ;*109* release all locks created by inbound filer
+4 LOCK -^HLMA("AC","I",+$GET(HLXX))
+5 GOTO UNWIND^%ZTER
+6 ;
+7 ;
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))
