HLTP31 ;SFIRMFO/RSD - Cont. Transaction Processor for TCP ;01/26/2006 15:50
;;1.6;HEALTH LEVEL SEVEN;**57,58,66,109,120**;Oct 13, 1995;Build 12
;
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.
. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
;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 #>
I HLDOMAIN[":" 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)
;
I $L($G(HLLINK)) D
.D ENQUE^HLCSREP(HLLINK,"I",HLMTIENS)
E D
.D ENQUE^HLCSREP(HLDP,"I",HLMTIENS)
Q
HLTP31 ;SFIRMFO/RSD - Cont. Transaction Processor for TCP ;01/26/2006 15:50
+1 ;;1.6;HEALTH LEVEL SEVEN;**57,58,66,109,120**;Oct 13, 1995;Build 12
+2 ;
+3 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 DO PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
End DoDot:1
+37 ;update LL, processed 1 msg
+38 DO LLCNT^HLCSTCP(HLDP,2)
+39 ;process ack successfully
+40 DO RSPER(3)
+41 ;HLRESELT is defined for errors
+42 QUIT $SELECT($GET(HLRESLT):4,1:3)
+43 ;
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 IF HLDOMAIN[":"
SET HL("PORT")=$PIECE(HLDOMAIN,":",2)
+18 SET HLDOMAIN=$PIECE(HLDOMAIN,":")
+19 SET HL("DOMAIN")=HLDOMAIN
+20 ; change from lower case to upper case
+21 SET HLDOMAIN=$$UP^XLFSTR(HLDOMAIN)
+22 ; if first piece of domain is "HL7." or "MPI.", remove it
+23 IF ($EXTRACT(HLDOMAIN,1,4)="HL7.")!($EXTRACT(HLDOMAIN,1,4)="MPI.")
Begin DoDot:1
+24 SET HLDOMAIN=$PIECE(HLDOMAIN,".",2,99)
End DoDot:1
+25 ; patch HL*1.6*120 end
+26 ;
+27 ;logical link lookup by domain
IF HLDOMAIN]""
Begin DoDot:1
+28 DO LINK^HLUTIL3(HLDOMAIN,.HLI,"D")
+29 ;client link for sending facility
SET HLLINK=$ORDER(HLI(0))
End DoDot:1
+30 ;logical link lookup by station number
+31 IF $GET(HLLINK)']""
IF HLINST]""
Begin DoDot:1
+32 DO LINK^HLUTIL3(HLINST,.HLI,"I")
+33 ;client link for sending facility
SET HLLINK=$ORDER(HLI(0))
End DoDot:1
+34 ;
+35 ; patch HL*1.6*120 start
+36 ;logical link lookup by DNS domain
+37 IF $GET(HLLINK)']""
IF HL("DOMAIN")]""
Begin DoDot:1
+38 IF $DATA(^HLCS(870,"DNS",HL("DOMAIN")))
Begin DoDot:2
+39 SET HLLINK=+$ORDER(^HLCS(870,"DNS",HL("DOMAIN"),0))
End DoDot:2
QUIT
+40 IF $DATA(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN"))))
Begin DoDot:2
+41 SET HLLINK=+$ORDER(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")),0))
End DoDot:2
QUIT
+42 IF $DATA(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN"))))
Begin DoDot:2
+43 SET HLLINK=+$ORDER(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")),0))
End DoDot:2
End DoDot:1
+44 ;
+45 ;logical link lookup by ip address
+46 IF $GET(HLLINK)']""
IF HL("DOMAIN")
Begin DoDot:1
+47 SET HLLINK=$ORDER(^HLCS(870,"IP",HL("DOMAIN"),0))
End DoDot:1
+48 ; patch HL*1.6*120 end
+49 ;
+50 ; find the logical link of the subscriber protocol
+51 ; then set the link field of this message to the link
+52 IF $GET(HL("EIDS"))
IF $PIECE(^ORD(101,HL("EIDS"),770),"^",7)
SET HLLINK=$PIECE(^ORD(101,HL("EIDS"),770),"^",7)
+53 ;
+54 IF $LENGTH($GET(HLLINK))
Begin DoDot:1
+55 DO ENQUE^HLCSREP(HLLINK,"I",HLMTIENS)
End DoDot:1
+56 IF '$TEST
Begin DoDot:1
+57 DO ENQUE^HLCSREP(HLDP,"I",HLMTIENS)
End DoDot:1
+58 QUIT
