HLTP4 ;SFIRMFO/RSD - Transaction Processor for TCP ;06/24/2008 10:47
;;1.6;HEALTH LEVEL SEVEN;**19,57,59,91,109,116,117,125,120,142,163**;Oct 13, 1995;Build 3
;;Per VA Directive 6402, this routine should not be modified.
GENACK ;called from HLMA1
;Entry point to generate an acknowledgement message
;for TCP
;INPUT:
; HLMTIENS=original msg. ien #773
; HLEID=original msg. event protocol
; HLEIDS=original msg. subscriber protocol
; HLMTIENA=ien of ack in 772, for batch only
; Note: if the HLP(...) array exists, it will be "honored" by
; UPDATE^HLTF0 below. This includes the HLP("NAMESPACE")
; variable. - HL*1.6*91
;
;OUTPUT: HLTCP=ien of response
N HLDT,HLDT1,HLQ,HLOGLINK,HLMIDA,HLMTIEN,HLREC,HLSAN,HLTYPE,X
;Extract data from original message and store in separate variables
;reverse sending and receiving application from original msg.
S X=$G(^HLMA(HLMTIENS,0)),HLREC=$P(X,U,11),HLSAN=$P(X,U,12),HLOGLINK=$G(HLTCPO)
;HLMTIENA defined, create msg in 773
I $G(HLMTIENA) S HLDT=+$G(^HL(772,HLMTIENA,0)),HLMTIENA=$$MA^HLTF(HLMTIENA,.HLMIDA)
;create message in 772 & 773, HLMTIENA=new msg ien #773
I '$G(HLMTIENA) D TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
;
;**109**
;lock new record
;F L +^HLMA(HLMTIENA):1 Q:$T H 1
;
;HLMTIEN=ien in 772
S HLTCP=HLMTIENA,HLMTIEN=+^HLMA(HLMTIENA,0),HLDT1=$$HLDATE^HLFNC(HLDT),(HLTYPE,HLP("MSGTYPE"))=$E(HLARYTYP,2)
;
;**** HL*1.6*116 ****
;no open link, check dynamic routing of ack
S X=$G(^ORD(101,HLEIDS,770)),HLP("MTYPE")=$P(X,U,11),HLP("EVENT")=$P(X,U,4)
;
; patch HL*1.6*125- change from $G to $D
I '$D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK
.K HLL("LINKS")
.I 'HLOGLINK D
.. S HLOGLINK=$P(X,U,7)
.. Q:HLOGLINK
.. N DOMAIN,SFAC,MSH,FS,CS,HLI,INST
.. S MSH=$G(^HLMA(HLMTIENS,"MSH",1,0))
.. Q:'$L(MSH)
.. S FS=$E(MSH,4)
.. Q:'$L(FS)
.. S CS=$E(MSH,5)
.. Q:'$L(CS)
.. S DOMAIN=$P($P(MSH,FS,4),CS,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 DOMAIN["]" D
... S HLP("PORT")=$P(DOMAIN,"]:",2)
... S DOMAIN=$E($P(DOMAIN,"]"),2,99)
... S DOMAIN=$$FORCEIP6^XLFIPV(DOMAIN)
.. E I DOMAIN[":" D
... S HLP("PORT")=$P(DOMAIN,":",2)
... S DOMAIN=$P(DOMAIN,":")
.. S HLP("DNS-DOMAIN")=DOMAIN
.. ;
.. ; if first piece of domain is "HL7." or "MPI.", remove it
.. I ($E(DOMAIN,1,4)="HL7.")!($E(DOMAIN,1,4)="MPI.") D
... S DOMAIN=$P(DOMAIN,".",2,99)
.. ;
.. ; lookup Mailman domain
.. I $L(DOMAIN) D
... D LINK^HLUTIL3(DOMAIN,.HLI,"D")
... S HLOGLINK=$O(HLI(0))
.. Q:HLOGLINK
.. S INST=$P($P(MSH,FS,4),CS,1)
.. I $L(INST) D
.. .D LINK^HLUTIL3(INST,.HLI,"I")
... S HLOGLINK=$O(HLI(0))
.. Q:HLOGLINK
.. ;
.. ; check DNS domain and ip address
.. I $L(HLP("DNS-DOMAIN")) D
... ;
... ; match DNS domain
... I $D(^HLCS(870,"DNS",HLP("DNS-DOMAIN"))) D
.... S HLOGLINK=+$O(^HLCS(870,"DNS",HLP("DNS-DOMAIN"),0))
... Q:HLOGLINK
... ;
... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN")))) D
.... S HLOGLINK=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN")),0))
... Q:HLOGLINK
... ;
... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN")))) D
.... S HLOGLINK=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN")),0))
... Q:HLOGLINK
... ;
... ; match ip address
... I $D(^HLCS(870,"IP",HLP("DNS-DOMAIN"))) D
.... S HLOGLINK=+$O(^HLCS(870,"IP",HLP("DNS-DOMAIN"),0))
.. ;
; patch HL*1.6*116 and patch HL*1.6*120 end
;
;** HL*1.6*117 **
; patch HL*1.6*125- change from $G to $D
I $D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK
.N I
.S I=$O(HLL("LINKS",0))
.I 'I S HLOGLINK="" Q
.S HLOGLINK=$P(HLL("LINKS",I),"^",2) Q:HLOGLINK=""
.I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",HLOGLINK,0))
;**END HL*1.6*117 **
;
S:$P(X,U,5) HLP("MTYPE_EVENT")=$P(X,U,5)
;HLTCPI=initial message
S:$G(HLTCPI) HLP("HLTCPI")=HLTCPI
;Update zero node of Message Admin file #773
D UPDATE^HLTF0(HLTCP,,"O",HLEIDS,HLREC,HLSAN,"I",HLMTIENS,HLOGLINK,.HLP)
;
;Update status to Being Generated
D STATUS^HLTF0(HLTCP,8)
;
;**109**
;tcp link is open, don't need x-ref, msg will be sent over link
;I $G(HLTCPO) K ^HLMA("AC","O",HLOGLINK,HLTCP)
;
;update zero node of Message Text file #772
D
. N HLTCP D UPDATE^HLTF0(HLMTIEN,,"O",HLEID)
;
;Execute entry action for subscriber protocol
I HLENROU]"" X HLENROU
S HLQ=""""
;Check that local/global array exists and store in Message Text file
; if pre-compiled
I HLFORMAT D I (+$G(HLRESLTA)) D STATUS^HLTF0(HLMTIENA,4,+HLRESLTA) G ERR
. I $E(HLARYTYP)="G" D
.. I $O(^TMP("HLA",$J,0))']"" S HLRESLTA="8^"_$G(^HL(771.7,8,0)) Q
.. D MERGE^HLTF1("G",HLMTIEN,"HLA")
. I $E(HLARYTYP)="L" D
.. I $O(HLA("HLA",0))']"" S HLRESLTA="8^"_$G(^HL(771.7,8,0)) Q
.. D MERGE^HLTF1("L",HLMTIEN,"HLA")
;If array is not pre-compiled, call message generation routine
I 'HLFORMAT N HLERR D I $D(HLERR) S HLRESLTA="9^"_HLERR D STATUS^HLTF0(HLMTIENA,4,9,HLERR) G ERR
.S HLP("GROUTINE")=HLP("GROUTINE")_"("_HLMIDA_","_HLMTIENA_","_HLQ_HLARYTYP_HLQ_","_HLSAN_","_$P($G(^HL(771.2,$P(HLN(770),"^",3),0)),"^")_","_$P($G(^HL(779.001,$P(HLN(770),"^",4),0)),"^")_","_HLQ_$TR($P(HLN(770),"^",6),"id","ID")_HLQ_")"
.X HLP("GROUTINE")
;
;create header for message in 773
I (HLTYPE="M") D HEADER^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
I (HLTYPE'="M") D BHSHDR^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
;if error set status to ERROR DURING TRANSMISSION
I ($G(HLRESLT)'="") D STATUS^HLTF0(HLTCP,4,12,HLRESLT) G ERR
;set header, HLHDR in 773
K HLQ S X=HLTCP_",",HLQ(773,X,200)="HLHDR"
D FILE^HLDIE("","HLQ","","GENACK","HLTP4") ;HL*1.6*109
;D FILE^DIE("","HLQ")
;update status of 773 to PENDING TRANSMISSION
D STATUS^HLTF0(HLTCP,1)
;Execute exit action for subscriber protocol
X:HLEXROU]"" HLEXROU
;
;**109**
;tcp link is NOT open, need x-ref
I '$G(HLTCPO) D ENQUE^HLCSREP(HLOGLINK,"O",HLTCP)
;
EXIT ;**109**
;L -^HLMA(HLMTIENA)
Q
ERR D EXIT S HLTCP=""
S:$G(HLRESLT) HLRESLTA=$G(HLRESLTA)_"^"_HLRESLT
Q
ACK(HLTACK,HLMG) ;build response based on original msg header
;for Bi-directional TCP
;INPUT:
; HLTACK=type of ack. CA,CR, or AR
; HLMG=text for MSA segment
; HLMTIENS=original msg. ien #773
; HL(array) from original header
;RETURNS: HLTCP=ien of response msg. in 773
N HLDT,HLDT1,HLQ,HLFS,HLHDR,HLMIDA,HLMTIEN,HLMTIENA,HLP,HLREC,HLSAN,X
;quit if we don't have enough to make a msg.
I $G(HL("ECH"))=""!($G(HL("FS"))="")!($G(HL("TYPE"))="") Q
;Extract data from original message and store in separate variables
;reverse sending and receiving application from original msg.
S HLFS=HL("FS"),HLREC=$G(HL("SAN")),HLSAN=$G(HL("RAN"))
;create message in 772 & 773, HLMTIENA=new msg ien #773
D TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
;lock new record
;**109**
;F L +^HLMA(HLMTIENA):1 Q:$T H 1
;
;HLMTIEN=ien in 772
S HLTCP=HLMTIENA,HLMTIEN=+^HLMA(HLMTIENA,0),HLDT1=$$FMTHL7^XLFDT(HLDT)
;get 'msgtype'=B or M, message type and event type
S HLP("MSGTYPE")=$E(HL("TYPE")),HLP("MTYPE")=$G(HL("MTP")),HLP("EVENT")=$G(HL("ETP")),HLP("HLTCPI")=HLMTIENS
S:$G(HL("MTP_ETP")) HLP("MTYPE_EVENT")=$G(HL("MTP_ETP"))
; HL*1.6*117 start
; change the order of when updates are done on file 773
;Update zero node of Message Admin file #773
;D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
;
;don't need x-ref, msg will be sent back over open tcp link
;**109**
;D LLCNT^HLCSTCP(HLDP,3)
;K ^HLMA("AC","O",HLDP,HLTCP)
;
;Update status to Being Generated
;D STATUS^HLTF0(HLTCP,8)
; HL*1.6*117 end
;update zero node of Message Text file #772
D
. N HLTCP D UPDATE^HLTF0(HLMTIEN,,"O")
;
;build MSA segment
K HLA
S HLA("HLS",1)="MSA"_HLFS_HLTACK_HLFS_$G(HL("MID"))
S:$G(HLMG)]"" HLA("HLS",1)=HLA("HLS",1)_HLFS_HLMG
;update file 772 with msg text
D MERGE^HLTF1("L",HLMTIEN,"HLS")
D HDR
;update file 773 with msg header
K HLQ S HLQ(773,HLTCP_",",200)="HLHDR"
D FILE^HLDIE("","HLQ","","ACK","HLTP4") ; HL*1.6*109
;D FILE^DIE("","HLQ")
; HL*1.6*117 start
; finally commit updates to 773 that will affect behavior of messaging
;Update status to Being Generated
D STATUS^HLTF0(HLTCP,8)
;Update zero node of Message Admin file #773
; patch HL*1.6*142
; update ien of sending application (from HL("RAP") of the incoming msg),
; ien of receiving application (from HL("SAP") of the incoming msg),
; and subscriber protocol
; D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
D UPDATE^HLTF0(HLTCP,,"O",$G(HL("EIDS")),$G(HL("SAP")),$G(HL("RAP")),"I",HLMTIENS,HLDP,.HLP)
; update message sent count
D LLCNT^HLCSTCP(HLDP,3)
; HL*1.6*117 end
G EXIT
;
HDR ; build header for commit ack
K HLHDR
S HLHDR(1)=HL("TYPE")_HLFS_HL("ECH")_HLFS_HLSAN_HLFS_$G(HL("RFN"))_HLFS_HLREC_HLFS_$G(HL("SFN"))_HLFS_HLDT1_HLFS_HLFS
I HLP("MSGTYPE")="M" S HLHDR(1)=HLHDR(1)_"ACK"_HLFS_HLMIDA_HLFS_$G(HL("PID"))_HLFS_$G(HL("VER")) Q
;batch
S X=$E(HL("ECH"))
S HLHDR(1)=HLHDR(1)_X_$G(HL("PID"))_X_"ACK"_HLFS_HLTACK_HLFS_HLMIDA_HLFS_$G(HL("MID"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTP4 9332 printed Dec 13, 2024@02:00:03 Page 2
HLTP4 ;SFIRMFO/RSD - Transaction Processor for TCP ;06/24/2008 10:47
+1 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,91,109,116,117,125,120,142,163**;Oct 13, 1995;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
GENACK ;called from HLMA1
+1 ;Entry point to generate an acknowledgement message
+2 ;for TCP
+3 ;INPUT:
+4 ; HLMTIENS=original msg. ien #773
+5 ; HLEID=original msg. event protocol
+6 ; HLEIDS=original msg. subscriber protocol
+7 ; HLMTIENA=ien of ack in 772, for batch only
+8 ; Note: if the HLP(...) array exists, it will be "honored" by
+9 ; UPDATE^HLTF0 below. This includes the HLP("NAMESPACE")
+10 ; variable. - HL*1.6*91
+11 ;
+12 ;OUTPUT: HLTCP=ien of response
+13 NEW HLDT,HLDT1,HLQ,HLOGLINK,HLMIDA,HLMTIEN,HLREC,HLSAN,HLTYPE,X
+14 ;Extract data from original message and store in separate variables
+15 ;reverse sending and receiving application from original msg.
+16 SET X=$GET(^HLMA(HLMTIENS,0))
SET HLREC=$PIECE(X,U,11)
SET HLSAN=$PIECE(X,U,12)
SET HLOGLINK=$GET(HLTCPO)
+17 ;HLMTIENA defined, create msg in 773
+18 IF $GET(HLMTIENA)
SET HLDT=+$GET(^HL(772,HLMTIENA,0))
SET HLMTIENA=$$MA^HLTF(HLMTIENA,.HLMIDA)
+19 ;create message in 772 & 773, HLMTIENA=new msg ien #773
+20 IF '$GET(HLMTIENA)
DO TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
+21 ;
+22 ;**109**
+23 ;lock new record
+24 ;F L +^HLMA(HLMTIENA):1 Q:$T H 1
+25 ;
+26 ;HLMTIEN=ien in 772
+27 SET HLTCP=HLMTIENA
SET HLMTIEN=+^HLMA(HLMTIENA,0)
SET HLDT1=$$HLDATE^HLFNC(HLDT)
SET (HLTYPE,HLP("MSGTYPE"))=$EXTRACT(HLARYTYP,2)
+28 ;
+29 ;**** HL*1.6*116 ****
+30 ;no open link, check dynamic routing of ack
+31 SET X=$GET(^ORD(101,HLEIDS,770))
SET HLP("MTYPE")=$PIECE(X,U,11)
SET HLP("EVENT")=$PIECE(X,U,4)
+32 ;
+33 ; patch HL*1.6*125- change from $G to $D
+34 IF '$DATA(HLL("SET FOR APP ACK"))
Begin DoDot:1
+35 KILL HLL("LINKS")
+36 IF 'HLOGLINK
Begin DoDot:2
+37 SET HLOGLINK=$PIECE(X,U,7)
+38 if HLOGLINK
QUIT
+39 NEW DOMAIN,SFAC,MSH,FS,CS,HLI,INST
+40 SET MSH=$GET(^HLMA(HLMTIENS,"MSH",1,0))
+41 if '$LENGTH(MSH)
QUIT
+42 SET FS=$EXTRACT(MSH,4)
+43 if '$LENGTH(FS)
QUIT
+44 SET CS=$EXTRACT(MSH,5)
+45 if '$LENGTH(CS)
QUIT
+46 SET DOMAIN=$PIECE($PIECE(MSH,FS,4),CS,2)
+47 ;
+48 ; patch HL*1.6*120 start
+49 ; assume the format is <domain>:<port #>
+50 ; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
+51 ; check for IPV6 address with delimiter of "]:" and process accordingly
+52 ;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
+53 IF DOMAIN["]"
Begin DoDot:3
+54 SET HLP("PORT")=$PIECE(DOMAIN,"]:",2)
+55 SET DOMAIN=$EXTRACT($PIECE(DOMAIN,"]"),2,99)
+56 SET DOMAIN=$$FORCEIP6^XLFIPV(DOMAIN)
End DoDot:3
+57 IF '$TEST
IF DOMAIN[":"
Begin DoDot:3
+58 SET HLP("PORT")=$PIECE(DOMAIN,":",2)
+59 SET DOMAIN=$PIECE(DOMAIN,":")
End DoDot:3
+60 SET HLP("DNS-DOMAIN")=DOMAIN
+61 ;
+62 ; if first piece of domain is "HL7." or "MPI.", remove it
+63 IF ($EXTRACT(DOMAIN,1,4)="HL7.")!($EXTRACT(DOMAIN,1,4)="MPI.")
Begin DoDot:3
+64 SET DOMAIN=$PIECE(DOMAIN,".",2,99)
End DoDot:3
+65 ;
+66 ; lookup Mailman domain
+67 IF $LENGTH(DOMAIN)
Begin DoDot:3
+68 DO LINK^HLUTIL3(DOMAIN,.HLI,"D")
+69 SET HLOGLINK=$ORDER(HLI(0))
End DoDot:3
+70 if HLOGLINK
QUIT
+71 SET INST=$PIECE($PIECE(MSH,FS,4),CS,1)
+72 IF $LENGTH(INST)
Begin DoDot:3
+73 DO LINK^HLUTIL3(INST,.HLI,"I")
+74 SET HLOGLINK=$ORDER(HLI(0))
End DoDot:3
+75 if HLOGLINK
QUIT
+76 ;
+77 ; check DNS domain and ip address
+78 IF $LENGTH(HLP("DNS-DOMAIN"))
Begin DoDot:3
+79 ;
+80 ; match DNS domain
+81 IF $DATA(^HLCS(870,"DNS",HLP("DNS-DOMAIN")))
Begin DoDot:4
+82 SET HLOGLINK=+$ORDER(^HLCS(870,"DNS",HLP("DNS-DOMAIN"),0))
End DoDot:4
+83 if HLOGLINK
QUIT
+84 ;
+85 IF $DATA(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN"))))
Begin DoDot:4
+86 SET HLOGLINK=+$ORDER(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN")),0))
End DoDot:4
+87 if HLOGLINK
QUIT
+88 ;
+89 IF $DATA(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN"))))
Begin DoDot:4
+90 SET HLOGLINK=+$ORDER(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN")),0))
End DoDot:4
+91 if HLOGLINK
QUIT
+92 ;
+93 ; match ip address
+94 IF $DATA(^HLCS(870,"IP",HLP("DNS-DOMAIN")))
Begin DoDot:4
+95 SET HLOGLINK=+$ORDER(^HLCS(870,"IP",HLP("DNS-DOMAIN"),0))
End DoDot:4
End DoDot:3
+96 ;
End DoDot:2
End DoDot:1
if 'HLOGLINK
QUIT
+97 ; patch HL*1.6*116 and patch HL*1.6*120 end
+98 ;
+99 ;** HL*1.6*117 **
+100 ; patch HL*1.6*125- change from $G to $D
+101 IF $DATA(HLL("SET FOR APP ACK"))
Begin DoDot:1
+102 NEW I
+103 SET I=$ORDER(HLL("LINKS",0))
+104 IF 'I
SET HLOGLINK=""
QUIT
+105 SET HLOGLINK=$PIECE(HLL("LINKS",I),"^",2)
if HLOGLINK=""
QUIT
+106 IF +HLOGLINK'=HLOGLINK
SET HLOGLINK=$ORDER(^HLCS(870,"B",HLOGLINK,0))
End DoDot:1
if 'HLOGLINK
QUIT
+107 ;**END HL*1.6*117 **
+108 ;
+109 if $PIECE(X,U,5)
SET HLP("MTYPE_EVENT")=$PIECE(X,U,5)
+110 ;HLTCPI=initial message
+111 if $GET(HLTCPI)
SET HLP("HLTCPI")=HLTCPI
+112 ;Update zero node of Message Admin file #773
+113 DO UPDATE^HLTF0(HLTCP,,"O",HLEIDS,HLREC,HLSAN,"I",HLMTIENS,HLOGLINK,.HLP)
+114 ;
+115 ;Update status to Being Generated
+116 DO STATUS^HLTF0(HLTCP,8)
+117 ;
+118 ;**109**
+119 ;tcp link is open, don't need x-ref, msg will be sent over link
+120 ;I $G(HLTCPO) K ^HLMA("AC","O",HLOGLINK,HLTCP)
+121 ;
+122 ;update zero node of Message Text file #772
+123 Begin DoDot:1
+124 NEW HLTCP
DO UPDATE^HLTF0(HLMTIEN,,"O",HLEID)
End DoDot:1
+125 ;
+126 ;Execute entry action for subscriber protocol
+127 IF HLENROU]""
XECUTE HLENROU
+128 SET HLQ=""""
+129 ;Check that local/global array exists and store in Message Text file
+130 ; if pre-compiled
+131 IF HLFORMAT
Begin DoDot:1
+132 IF $EXTRACT(HLARYTYP)="G"
Begin DoDot:2
+133 IF $ORDER(^TMP("HLA",$JOB,0))']""
SET HLRESLTA="8^"_$GET(^HL(771.7,8,0))
QUIT
+134 DO MERGE^HLTF1("G",HLMTIEN,"HLA")
End DoDot:2
+135 IF $EXTRACT(HLARYTYP)="L"
Begin DoDot:2
+136 IF $ORDER(HLA("HLA",0))']""
SET HLRESLTA="8^"_$GET(^HL(771.7,8,0))
QUIT
+137 DO MERGE^HLTF1("L",HLMTIEN,"HLA")
End DoDot:2
End DoDot:1
IF (+$GET(HLRESLTA))
DO STATUS^HLTF0(HLMTIENA,4,+HLRESLTA)
GOTO ERR
+138 ;If array is not pre-compiled, call message generation routine
+139 IF 'HLFORMAT
NEW HLERR
Begin DoDot:1
+140 SET HLP("GROUTINE")=HLP("GROUTINE")_"("_HLMIDA_","_HLMTIENA_","_HLQ_HLARYTYP_HLQ_","_HLSAN_","_$PIECE($GET(^HL(771.2,$PIECE(HLN(770),"^",3),0)),"^")_","_$PIECE(...
... $GET(^HL(779.001,$PIECE(HLN(770),"^",4),0)),"^")_","_HLQ_$TRANSLATE($PIECE(HLN(770),"^",6),"id","ID")_HLQ_")"
+141 XECUTE HLP("GROUTINE")
End DoDot:1
IF $DATA(HLERR)
SET HLRESLTA="9^"_HLERR
DO STATUS^HLTF0(HLMTIENA,4,9,HLERR)
GOTO ERR
+142 ;
+143 ;create header for message in 773
+144 IF (HLTYPE="M")
DO HEADER^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
+145 IF (HLTYPE'="M")
DO BHSHDR^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
+146 ;if error set status to ERROR DURING TRANSMISSION
+147 IF ($GET(HLRESLT)'="")
DO STATUS^HLTF0(HLTCP,4,12,HLRESLT)
GOTO ERR
+148 ;set header, HLHDR in 773
+149 KILL HLQ
SET X=HLTCP_","
SET HLQ(773,X,200)="HLHDR"
+150 ;HL*1.6*109
DO FILE^HLDIE("","HLQ","","GENACK","HLTP4")
+151 ;D FILE^DIE("","HLQ")
+152 ;update status of 773 to PENDING TRANSMISSION
+153 DO STATUS^HLTF0(HLTCP,1)
+154 ;Execute exit action for subscriber protocol
+155 if HLEXROU]""
XECUTE HLEXROU
+156 ;
+157 ;**109**
+158 ;tcp link is NOT open, need x-ref
+159 IF '$GET(HLTCPO)
DO ENQUE^HLCSREP(HLOGLINK,"O",HLTCP)
+160 ;
EXIT ;**109**
+1 ;L -^HLMA(HLMTIENA)
+2 QUIT
ERR DO EXIT
SET HLTCP=""
+1 if $GET(HLRESLT)
SET HLRESLTA=$GET(HLRESLTA)_"^"_HLRESLT
+2 QUIT
ACK(HLTACK,HLMG) ;build response based on original msg header
+1 ;for Bi-directional TCP
+2 ;INPUT:
+3 ; HLTACK=type of ack. CA,CR, or AR
+4 ; HLMG=text for MSA segment
+5 ; HLMTIENS=original msg. ien #773
+6 ; HL(array) from original header
+7 ;RETURNS: HLTCP=ien of response msg. in 773
+8 NEW HLDT,HLDT1,HLQ,HLFS,HLHDR,HLMIDA,HLMTIEN,HLMTIENA,HLP,HLREC,HLSAN,X
+9 ;quit if we don't have enough to make a msg.
+10 IF $GET(HL("ECH"))=""!($GET(HL("FS"))="")!($GET(HL("TYPE"))="")
QUIT
+11 ;Extract data from original message and store in separate variables
+12 ;reverse sending and receiving application from original msg.
+13 SET HLFS=HL("FS")
SET HLREC=$GET(HL("SAN"))
SET HLSAN=$GET(HL("RAN"))
+14 ;create message in 772 & 773, HLMTIENA=new msg ien #773
+15 DO TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
+16 ;lock new record
+17 ;**109**
+18 ;F L +^HLMA(HLMTIENA):1 Q:$T H 1
+19 ;
+20 ;HLMTIEN=ien in 772
+21 SET HLTCP=HLMTIENA
SET HLMTIEN=+^HLMA(HLMTIENA,0)
SET HLDT1=$$FMTHL7^XLFDT(HLDT)
+22 ;get 'msgtype'=B or M, message type and event type
+23 SET HLP("MSGTYPE")=$EXTRACT(HL("TYPE"))
SET HLP("MTYPE")=$GET(HL("MTP"))
SET HLP("EVENT")=$GET(HL("ETP"))
SET HLP("HLTCPI")=HLMTIENS
+24 if $GET(HL("MTP_ETP"))
SET HLP("MTYPE_EVENT")=$GET(HL("MTP_ETP"))
+25 ; HL*1.6*117 start
+26 ; change the order of when updates are done on file 773
+27 ;Update zero node of Message Admin file #773
+28 ;D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
+29 ;
+30 ;don't need x-ref, msg will be sent back over open tcp link
+31 ;**109**
+32 ;D LLCNT^HLCSTCP(HLDP,3)
+33 ;K ^HLMA("AC","O",HLDP,HLTCP)
+34 ;
+35 ;Update status to Being Generated
+36 ;D STATUS^HLTF0(HLTCP,8)
+37 ; HL*1.6*117 end
+38 ;update zero node of Message Text file #772
+39 Begin DoDot:1
+40 NEW HLTCP
DO UPDATE^HLTF0(HLMTIEN,,"O")
End DoDot:1
+41 ;
+42 ;build MSA segment
+43 KILL HLA
+44 SET HLA("HLS",1)="MSA"_HLFS_HLTACK_HLFS_$GET(HL("MID"))
+45 if $GET(HLMG)]""
SET HLA("HLS",1)=HLA("HLS",1)_HLFS_HLMG
+46 ;update file 772 with msg text
+47 DO MERGE^HLTF1("L",HLMTIEN,"HLS")
+48 DO HDR
+49 ;update file 773 with msg header
+50 KILL HLQ
SET HLQ(773,HLTCP_",",200)="HLHDR"
+51 ; HL*1.6*109
DO FILE^HLDIE("","HLQ","","ACK","HLTP4")
+52 ;D FILE^DIE("","HLQ")
+53 ; HL*1.6*117 start
+54 ; finally commit updates to 773 that will affect behavior of messaging
+55 ;Update status to Being Generated
+56 DO STATUS^HLTF0(HLTCP,8)
+57 ;Update zero node of Message Admin file #773
+58 ; patch HL*1.6*142
+59 ; update ien of sending application (from HL("RAP") of the incoming msg),
+60 ; ien of receiving application (from HL("SAP") of the incoming msg),
+61 ; and subscriber protocol
+62 ; D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
+63 DO UPDATE^HLTF0(HLTCP,,"O",$GET(HL("EIDS")),$GET(HL("SAP")),$GET(HL("RAP")),"I",HLMTIENS,HLDP,.HLP)
+64 ; update message sent count
+65 DO LLCNT^HLCSTCP(HLDP,3)
+66 ; HL*1.6*117 end
+67 GOTO EXIT
+68 ;
HDR ; build header for commit ack
+1 KILL HLHDR
+2 SET HLHDR(1)=HL("TYPE")_HLFS_HL("ECH")_HLFS_HLSAN_HLFS_$GET(HL("RFN"))_HLFS_HLREC_HLFS_$GET(HL("SFN"))_HLFS_HLDT1_HLFS_HLFS
+3 IF HLP("MSGTYPE")="M"
SET HLHDR(1)=HLHDR(1)_"ACK"_HLFS_HLMIDA_HLFS_$GET(HL("PID"))_HLFS_$GET(HL("VER"))
QUIT
+4 ;batch
+5 SET X=$EXTRACT(HL("ECH"))
+6 SET HLHDR(1)=HLHDR(1)_X_$GET(HL("PID"))_X_"ACK"_HLFS_HLTACK_HLFS_HLMIDA_HLFS_$GET(HL("MID"))
+7 QUIT
