- 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 Feb 18, 2025@23:26:28 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