HLTP31 ;SFIRMFO/RSD - Cont. Transaction Processor for TCP ;07/08/2009 15:33
;;1.6;HEALTH LEVEL SEVEN;**57,58,66,109,120,145,163**;Oct 13, 1995;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
Q
RSP(X,HLN) ;process response msg. X=ien in 773^msg. ien in 772
;HLN=HL array for original message
;HLMTIEN=ien in 772, HLMTIENS=ien in 773
;returns - 0=resend msg, 1=commit ack, 3=app ack success, 4=error
;set error trap
N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
N HLERR,HLHDR,HLMSA,HLMTIEN,HLMTIENS,HLQUIT,HLNODE,HLNEXT,HLRESLTA
D INIT^HLTP3A ;patch HL*1.6*109: hltp3 routine split
;Quit processing if error with header
I $G(HLRESLT) D EXIT Q 0
;must have MSA segment
I '$L(HLMSA) D RSPER(4,108,"Missing MSA segment") Q 0
;msg. id in MSA must match original msg. id, if not reject
I $P(HLMSA,HL("FS"),2)'=HLN("MID") D RSPER(4,108,"Incorrect msg. Id") Q 0
;rec. app. must match sending app. of original message.
I HL("RAN")'=HLN("SAN") D RSPER(4,108,"Incorrect sending app.") Q 0
;get ack code
S HL("ACKCD")=$P(HLMSA,HL("FS"))
;update LL, rec. 1 msg
D LLCNT^HLCSTCP(HLDP,1)
;commit ack
I $E(HL("ACKCD"))="C" D Q X
. ;update LL, processed 1 msg
. D LLCNT^HLCSTCP(HLDP,2)
. ;received an error ack, return NAK
. S:$E(HL("ACKCD"),2)'="A" HLRESLT=102_U_$P(HLMSA,HL("FS"),3)
. D RSPER(3) S X=$S($E(HL("ACKCD"),2)="A":1,1:4)
;app. ack, received an error ack, NAK
S:$E(HL("ACKCD"),2)'="A" HLRESLT=102_U_$P(HLMSA,HL("FS"),3)
;Set special HL variables
S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101,"
;process ack
D
. N HLTCP ;Newed variable to update status in 772.
. ; patch HL*1.6*145
. ; time: starts to process the incoming message
. I $G(HLMTIENS) S $P(^HLMA(+HLMTIENS,"S"),"^",6)=$$NOW^XLFDT
. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
. ; time: ends processing the incoming message
. I $G(HLMTIENS) S $P(^HLMA(+HLMTIENS,"S"),"^",7)=$$NOW^XLFDT
;update LL, processed 1 msg
D LLCNT^HLCSTCP(HLDP,2)
;process ack successfully
D RSPER(3)
;HLRESELT is defined for errors
Q $S($G(HLRESLT):4,1:3)
;
RSPER(HLST,HLER,HLERM) ;HLST=status, HLER=error type, HLERM=error msg.
D STATUS^HLTF0(HLMTIENS,HLST,$G(HLER),$G(HLERM),1)
S:$G(HLER) HLRESLT=HLER_U_HLERM
D EXIT
Q
EXIT ;unlock
;**109**
;I $G(HLMTIENS) L -^HLMA(HLMTIENS)
Q
;
SETINQUE ;
;**HL*1.6*109***
;Called from HLTP3 for message that utilize enhanced mode - NOT original mode
;Sets the incoming message on the in queue.
;Does not use the listener, instead, arranges multiple in-queues
;by using the sending link.
;
N HLI,HLINST,HLDOMAIN,HLLINK
;
;Override value of logical link based on sending facility to create
;a queue (^HLMA("AC","I",llnk ien,msg ien)) different than that of the
;listener
S HLINST=$P(HL("SFN"),$E(HL("ECH")))
S HLDOMAIN=$P(HL("SFN"),$E(HL("ECH")),2)
;
; patch HL*1.6*120 start
; assume the format is <domain>:<port #>
; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
; check for IPV6 address with delimiter of "]:" and process accordingly
;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
I HLDOMAIN["]" D
. S HL("PORT")=$P(HLDOMAIN,"]:",2)
. S HLDOMAIN=$E($P(HLDOMAIN,"]"),2,99)
. S HLDOMAIN=$$FORCEIP6^XLFIPV(HLDOMAIN)
E I HLDOMAIN[":" D
. S HL("PORT")=$P(HLDOMAIN,":",2)
. S HLDOMAIN=$P(HLDOMAIN,":")
S HL("DOMAIN")=HLDOMAIN
; change from lower case to upper case
S HLDOMAIN=$$UP^XLFSTR(HLDOMAIN)
; if first piece of domain is "HL7." or "MPI.", remove it
I ($E(HLDOMAIN,1,4)="HL7.")!($E(HLDOMAIN,1,4)="MPI.") D
. S HLDOMAIN=$P(HLDOMAIN,".",2,99)
; patch HL*1.6*120 end
;
I HLDOMAIN]"" D ;logical link lookup by domain
. D LINK^HLUTIL3(HLDOMAIN,.HLI,"D")
. S HLLINK=$O(HLI(0)) ;client link for sending facility
;logical link lookup by station number
I $G(HLLINK)']"",HLINST]"" D
. D LINK^HLUTIL3(HLINST,.HLI,"I")
. S HLLINK=$O(HLI(0)) ;client link for sending facility
;
; patch HL*1.6*120 start
;logical link lookup by DNS domain
I $G(HLLINK)']"",HL("DOMAIN")]"" D
. I $D(^HLCS(870,"DNS",HL("DOMAIN"))) D Q
.. S HLLINK=+$O(^HLCS(870,"DNS",HL("DOMAIN"),0))
. I $D(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")))) D Q
.. S HLLINK=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")),0))
. I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")))) D
.. S HLLINK=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")),0))
;
;logical link lookup by ip address
I $G(HLLINK)']"",HL("DOMAIN") D
. S HLLINK=$O(^HLCS(870,"IP",HL("DOMAIN"),0))
; patch HL*1.6*120 end
;
; find the logical link of the subscriber protocol
; then set the link field of this message to the link
I $G(HL("EIDS")),$P(^ORD(101,HL("EIDS"),770),"^",7) S HLLINK=$P(^ORD(101,HL("EIDS"),770),"^",7)
;
; patch HL*1.6*145 start
F L +^HLMA(HLMTIENS,0):10 Q:$T H 1
N COUNT
F COUNT=1:1:15 Q:($G(^HLMA(HLMTIENS,0))]"") H COUNT
I $L($G(HLLINK)) D
.D ENQUE^HLCSREP(HLLINK,"I",HLMTIENS)
.; move message from listener queue to client link queue
.S HLDP("HLLINK")=HLLINK
.D LLCNT^HLCSTCP(HLDP,1,1)
.D LLCNT^HLCSTCP(HLLINK,1)
.S $P(^HLMA(HLMTIENS,0),"^",17)=HLLINK
E D
.D ENQUE^HLCSREP(HLDP,"I",HLMTIENS)
.S $P(^HLMA(HLMTIENS,0),"^",17)=HLDP
S HLDP("SETINQUE")=1
L -^HLMA(HLMTIENS,0)
; patch HL*1.6*145 end
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTP31 5448 printed Sep 23, 2025@19:36:08 Page 2
HLTP31 ;SFIRMFO/RSD - Cont. Transaction Processor for TCP ;07/08/2009 15:33
+1 ;;1.6;HEALTH LEVEL SEVEN;**57,58,66,109,120,145,163**;Oct 13, 1995;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
RSP(X,HLN) ;process response msg. X=ien in 773^msg. ien in 772
+1 ;HLN=HL array for original message
+2 ;HLMTIEN=ien in 772, HLMTIENS=ien in 773
+3 ;returns - 0=resend msg, 1=commit ack, 3=app ack success, 4=error
+4 ;set error trap
+5 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^HLTP3"
+6 NEW HLERR,HLHDR,HLMSA,HLMTIEN,HLMTIENS,HLQUIT,HLNODE,HLNEXT,HLRESLTA
+7 ;patch HL*1.6*109: hltp3 routine split
DO INIT^HLTP3A
+8 ;Quit processing if error with header
+9 IF $GET(HLRESLT)
DO EXIT
QUIT 0
+10 ;must have MSA segment
+11 IF '$LENGTH(HLMSA)
DO RSPER(4,108,"Missing MSA segment")
QUIT 0
+12 ;msg. id in MSA must match original msg. id, if not reject
+13 IF $PIECE(HLMSA,HL("FS"),2)'=HLN("MID")
DO RSPER(4,108,"Incorrect msg. Id")
QUIT 0
+14 ;rec. app. must match sending app. of original message.
+15 IF HL("RAN")'=HLN("SAN")
DO RSPER(4,108,"Incorrect sending app.")
QUIT 0
+16 ;get ack code
+17 SET HL("ACKCD")=$PIECE(HLMSA,HL("FS"))
+18 ;update LL, rec. 1 msg
+19 DO LLCNT^HLCSTCP(HLDP,1)
+20 ;commit ack
+21 IF $EXTRACT(HL("ACKCD"))="C"
Begin DoDot:1
+22 ;update LL, processed 1 msg
+23 DO LLCNT^HLCSTCP(HLDP,2)
+24 ;received an error ack, return NAK
+25 if $EXTRACT(HL("ACKCD"),2)'="A"
SET HLRESLT=102_U_$PIECE(HLMSA,HL("FS"),3)
+26 DO RSPER(3)
SET X=$SELECT($EXTRACT(HL("ACKCD"),2)="A":1,1:4)
End DoDot:1
QUIT X
+27 ;app. ack, received an error ack, NAK
+28 if $EXTRACT(HL("ACKCD"),2)'="A"
SET HLRESLT=102_U_$PIECE(HLMSA,HL("FS"),3)
+29 ;Set special HL variables
+30 SET HLQUIT=0
SET HLNODE=""
SET HLNEXT="D HLNEXT^HLCSUTL"
+31 ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
+32 NEW HLORNODD
SET HLORNOD=HL("EIDS")_";ORD(101,"
+33 ;process ack
+34 Begin DoDot:1
+35 ;Newed variable to update status in 772.
NEW HLTCP
+36 ; patch HL*1.6*145
+37 ; time: starts to process the incoming message
+38 IF $GET(HLMTIENS)
SET $PIECE(^HLMA(+HLMTIENS,"S"),"^",6)=$$NOW^XLFDT
+39 DO PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
+40 ; time: ends processing the incoming message
+41 IF $GET(HLMTIENS)
SET $PIECE(^HLMA(+HLMTIENS,"S"),"^",7)=$$NOW^XLFDT
End DoDot:1
+42 ;update LL, processed 1 msg
+43 DO LLCNT^HLCSTCP(HLDP,2)
+44 ;process ack successfully
+45 DO RSPER(3)
+46 ;HLRESELT is defined for errors
+47 QUIT $SELECT($GET(HLRESLT):4,1:3)
+48 ;
RSPER(HLST,HLER,HLERM) ;HLST=status, HLER=error type, HLERM=error msg.
+1 DO STATUS^HLTF0(HLMTIENS,HLST,$GET(HLER),$GET(HLERM),1)
+2 if $GET(HLER)
SET HLRESLT=HLER_U_HLERM
+3 DO EXIT
+4 QUIT
EXIT ;unlock
+1 ;**109**
+2 ;I $G(HLMTIENS) L -^HLMA(HLMTIENS)
+3 QUIT
+4 ;
SETINQUE ;
+1 ;**HL*1.6*109***
+2 ;Called from HLTP3 for message that utilize enhanced mode - NOT original mode
+3 ;Sets the incoming message on the in queue.
+4 ;Does not use the listener, instead, arranges multiple in-queues
+5 ;by using the sending link.
+6 ;
+7 NEW HLI,HLINST,HLDOMAIN,HLLINK
+8 ;
+9 ;Override value of logical link based on sending facility to create
+10 ;a queue (^HLMA("AC","I",llnk ien,msg ien)) different than that of the
+11 ;listener
+12 SET HLINST=$PIECE(HL("SFN"),$EXTRACT(HL("ECH")))
+13 SET HLDOMAIN=$PIECE(HL("SFN"),$EXTRACT(HL("ECH")),2)
+14 ;
+15 ; patch HL*1.6*120 start
+16 ; assume the format is <domain>:<port #>
+17 ; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
+18 ; check for IPV6 address with delimiter of "]:" and process accordingly
+19 ;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
+20 IF HLDOMAIN["]"
Begin DoDot:1
+21 SET HL("PORT")=$PIECE(HLDOMAIN,"]:",2)
+22 SET HLDOMAIN=$EXTRACT($PIECE(HLDOMAIN,"]"),2,99)
+23 SET HLDOMAIN=$$FORCEIP6^XLFIPV(HLDOMAIN)
End DoDot:1
+24 IF '$TEST
IF HLDOMAIN[":"
Begin DoDot:1
+25 SET HL("PORT")=$PIECE(HLDOMAIN,":",2)
+26 SET HLDOMAIN=$PIECE(HLDOMAIN,":")
End DoDot:1
+27 SET HL("DOMAIN")=HLDOMAIN
+28 ; change from lower case to upper case
+29 SET HLDOMAIN=$$UP^XLFSTR(HLDOMAIN)
+30 ; if first piece of domain is "HL7." or "MPI.", remove it
+31 IF ($EXTRACT(HLDOMAIN,1,4)="HL7.")!($EXTRACT(HLDOMAIN,1,4)="MPI.")
Begin DoDot:1
+32 SET HLDOMAIN=$PIECE(HLDOMAIN,".",2,99)
End DoDot:1
+33 ; patch HL*1.6*120 end
+34 ;
+35 ;logical link lookup by domain
IF HLDOMAIN]""
Begin DoDot:1
+36 DO LINK^HLUTIL3(HLDOMAIN,.HLI,"D")
+37 ;client link for sending facility
SET HLLINK=$ORDER(HLI(0))
End DoDot:1
+38 ;logical link lookup by station number
+39 IF $GET(HLLINK)']""
IF HLINST]""
Begin DoDot:1
+40 DO LINK^HLUTIL3(HLINST,.HLI,"I")
+41 ;client link for sending facility
SET HLLINK=$ORDER(HLI(0))
End DoDot:1
+42 ;
+43 ; patch HL*1.6*120 start
+44 ;logical link lookup by DNS domain
+45 IF $GET(HLLINK)']""
IF HL("DOMAIN")]""
Begin DoDot:1
+46 IF $DATA(^HLCS(870,"DNS",HL("DOMAIN")))
Begin DoDot:2
+47 SET HLLINK=+$ORDER(^HLCS(870,"DNS",HL("DOMAIN"),0))
End DoDot:2
QUIT
+48 IF $DATA(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN"))))
Begin DoDot:2
+49 SET HLLINK=+$ORDER(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")),0))
End DoDot:2
QUIT
+50 IF $DATA(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN"))))
Begin DoDot:2
+51 SET HLLINK=+$ORDER(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")),0))
End DoDot:2
End DoDot:1
+52 ;
+53 ;logical link lookup by ip address
+54 IF $GET(HLLINK)']""
IF HL("DOMAIN")
Begin DoDot:1
+55 SET HLLINK=$ORDER(^HLCS(870,"IP",HL("DOMAIN"),0))
End DoDot:1
+56 ; patch HL*1.6*120 end
+57 ;
+58 ; find the logical link of the subscriber protocol
+59 ; then set the link field of this message to the link
+60 IF $GET(HL("EIDS"))
IF $PIECE(^ORD(101,HL("EIDS"),770),"^",7)
SET HLLINK=$PIECE(^ORD(101,HL("EIDS"),770),"^",7)
+61 ;
+62 ; patch HL*1.6*145 start
+63 FOR
LOCK +^HLMA(HLMTIENS,0):10
if $TEST
QUIT
HANG 1
+64 NEW COUNT
+65 FOR COUNT=1:1:15
if ($GET(^HLMA(HLMTIENS,0))]"")
QUIT
HANG COUNT
+66 IF $LENGTH($GET(HLLINK))
Begin DoDot:1
+67 DO ENQUE^HLCSREP(HLLINK,"I",HLMTIENS)
+68 ; move message from listener queue to client link queue
+69 SET HLDP("HLLINK")=HLLINK
+70 DO LLCNT^HLCSTCP(HLDP,1,1)
+71 DO LLCNT^HLCSTCP(HLLINK,1)
+72 SET $PIECE(^HLMA(HLMTIENS,0),"^",17)=HLLINK
End DoDot:1
+73 IF '$TEST
Begin DoDot:1
+74 DO ENQUE^HLCSREP(HLDP,"I",HLMTIENS)
+75 SET $PIECE(^HLMA(HLMTIENS,0),"^",17)=HLDP
End DoDot:1
+76 SET HLDP("SETINQUE")=1
+77 LOCK -^HLMA(HLMTIENS,0)
+78 ; patch HL*1.6*145 end
+79 QUIT
