Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLTP4

HLTP4.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. GENACK ;called from HLMA1
  1. ;Entry point to generate an acknowledgement message
  1. ;for TCP
  1. ;INPUT:
  1. ; HLMTIENS=original msg. ien #773
  1. ; HLEID=original msg. event protocol
  1. ; HLEIDS=original msg. subscriber protocol
  1. ; HLMTIENA=ien of ack in 772, for batch only
  1. ; Note: if the HLP(...) array exists, it will be "honored" by
  1. ; UPDATE^HLTF0 below. This includes the HLP("NAMESPACE")
  1. ; variable. - HL*1.6*91
  1. ;
  1. ;OUTPUT: HLTCP=ien of response
  1. N HLDT,HLDT1,HLQ,HLOGLINK,HLMIDA,HLMTIEN,HLREC,HLSAN,HLTYPE,X
  1. ;Extract data from original message and store in separate variables
  1. ;reverse sending and receiving application from original msg.
  1. S X=$G(^HLMA(HLMTIENS,0)),HLREC=$P(X,U,11),HLSAN=$P(X,U,12),HLOGLINK=$G(HLTCPO)
  1. ;HLMTIENA defined, create msg in 773
  1. I $G(HLMTIENA) S HLDT=+$G(^HL(772,HLMTIENA,0)),HLMTIENA=$$MA^HLTF(HLMTIENA,.HLMIDA)
  1. ;create message in 772 & 773, HLMTIENA=new msg ien #773
  1. I '$G(HLMTIENA) D TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
  1. ;
  1. ;**109**
  1. ;lock new record
  1. ;F L +^HLMA(HLMTIENA):1 Q:$T H 1
  1. ;
  1. ;HLMTIEN=ien in 772
  1. S HLTCP=HLMTIENA,HLMTIEN=+^HLMA(HLMTIENA,0),HLDT1=$$HLDATE^HLFNC(HLDT),(HLTYPE,HLP("MSGTYPE"))=$E(HLARYTYP,2)
  1. ;
  1. ;**** HL*1.6*116 ****
  1. ;no open link, check dynamic routing of ack
  1. S X=$G(^ORD(101,HLEIDS,770)),HLP("MTYPE")=$P(X,U,11),HLP("EVENT")=$P(X,U,4)
  1. ;
  1. ; patch HL*1.6*125- change from $G to $D
  1. I '$D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK
  1. .K HLL("LINKS")
  1. .I 'HLOGLINK D
  1. .. S HLOGLINK=$P(X,U,7)
  1. .. Q:HLOGLINK
  1. .. N DOMAIN,SFAC,MSH,FS,CS,HLI,INST
  1. .. S MSH=$G(^HLMA(HLMTIENS,"MSH",1,0))
  1. .. Q:'$L(MSH)
  1. .. S FS=$E(MSH,4)
  1. .. Q:'$L(FS)
  1. .. S CS=$E(MSH,5)
  1. .. Q:'$L(CS)
  1. .. S DOMAIN=$P($P(MSH,FS,4),CS,2)
  1. .. ;
  1. .. ; patch HL*1.6*120 start
  1. .. ; assume the format is <domain>:<port #>
  1. .. ; patch HL*1.6*163 can no longer assume one format for <domain><port> with IPV6
  1. .. ; check for IPV6 address with delimiter of "]:" and process accordingly
  1. .. ;$$FORCEIP6^XLFIPV(IP) API (ICR #5844)
  1. .. I DOMAIN["]" D
  1. ... S HLP("PORT")=$P(DOMAIN,"]:",2)
  1. ... S DOMAIN=$E($P(DOMAIN,"]"),2,99)
  1. ... S DOMAIN=$$FORCEIP6^XLFIPV(DOMAIN)
  1. .. E I DOMAIN[":" D
  1. ... S HLP("PORT")=$P(DOMAIN,":",2)
  1. ... S DOMAIN=$P(DOMAIN,":")
  1. .. S HLP("DNS-DOMAIN")=DOMAIN
  1. .. ;
  1. .. ; if first piece of domain is "HL7." or "MPI.", remove it
  1. .. I ($E(DOMAIN,1,4)="HL7.")!($E(DOMAIN,1,4)="MPI.") D
  1. ... S DOMAIN=$P(DOMAIN,".",2,99)
  1. .. ;
  1. .. ; lookup Mailman domain
  1. .. I $L(DOMAIN) D
  1. ... D LINK^HLUTIL3(DOMAIN,.HLI,"D")
  1. ... S HLOGLINK=$O(HLI(0))
  1. .. Q:HLOGLINK
  1. .. S INST=$P($P(MSH,FS,4),CS,1)
  1. .. I $L(INST) D
  1. .. .D LINK^HLUTIL3(INST,.HLI,"I")
  1. ... S HLOGLINK=$O(HLI(0))
  1. .. Q:HLOGLINK
  1. .. ;
  1. .. ; check DNS domain and ip address
  1. .. I $L(HLP("DNS-DOMAIN")) D
  1. ... ;
  1. ... ; match DNS domain
  1. ... I $D(^HLCS(870,"DNS",HLP("DNS-DOMAIN"))) D
  1. .... S HLOGLINK=+$O(^HLCS(870,"DNS",HLP("DNS-DOMAIN"),0))
  1. ... Q:HLOGLINK
  1. ... ;
  1. ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN")))) D
  1. .... S HLOGLINK=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN")),0))
  1. ... Q:HLOGLINK
  1. ... ;
  1. ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN")))) D
  1. .... S HLOGLINK=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN")),0))
  1. ... Q:HLOGLINK
  1. ... ;
  1. ... ; match ip address
  1. ... I $D(^HLCS(870,"IP",HLP("DNS-DOMAIN"))) D
  1. .... S HLOGLINK=+$O(^HLCS(870,"IP",HLP("DNS-DOMAIN"),0))
  1. .. ;
  1. ; patch HL*1.6*116 and patch HL*1.6*120 end
  1. ;
  1. ;** HL*1.6*117 **
  1. ; patch HL*1.6*125- change from $G to $D
  1. I $D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK
  1. .N I
  1. .S I=$O(HLL("LINKS",0))
  1. .I 'I S HLOGLINK="" Q
  1. .S HLOGLINK=$P(HLL("LINKS",I),"^",2) Q:HLOGLINK=""
  1. .I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",HLOGLINK,0))
  1. ;**END HL*1.6*117 **
  1. ;
  1. S:$P(X,U,5) HLP("MTYPE_EVENT")=$P(X,U,5)
  1. ;HLTCPI=initial message
  1. S:$G(HLTCPI) HLP("HLTCPI")=HLTCPI
  1. ;Update zero node of Message Admin file #773
  1. D UPDATE^HLTF0(HLTCP,,"O",HLEIDS,HLREC,HLSAN,"I",HLMTIENS,HLOGLINK,.HLP)
  1. ;
  1. ;Update status to Being Generated
  1. D STATUS^HLTF0(HLTCP,8)
  1. ;
  1. ;**109**
  1. ;tcp link is open, don't need x-ref, msg will be sent over link
  1. ;I $G(HLTCPO) K ^HLMA("AC","O",HLOGLINK,HLTCP)
  1. ;
  1. ;update zero node of Message Text file #772
  1. D
  1. . N HLTCP D UPDATE^HLTF0(HLMTIEN,,"O",HLEID)
  1. ;
  1. ;Execute entry action for subscriber protocol
  1. I HLENROU]"" X HLENROU
  1. S HLQ=""""
  1. ;Check that local/global array exists and store in Message Text file
  1. ; if pre-compiled
  1. I HLFORMAT D I (+$G(HLRESLTA)) D STATUS^HLTF0(HLMTIENA,4,+HLRESLTA) G ERR
  1. . I $E(HLARYTYP)="G" D
  1. .. I $O(^TMP("HLA",$J,0))']"" S HLRESLTA="8^"_$G(^HL(771.7,8,0)) Q
  1. .. D MERGE^HLTF1("G",HLMTIEN,"HLA")
  1. . I $E(HLARYTYP)="L" D
  1. .. I $O(HLA("HLA",0))']"" S HLRESLTA="8^"_$G(^HL(771.7,8,0)) Q
  1. .. D MERGE^HLTF1("L",HLMTIEN,"HLA")
  1. ;If array is not pre-compiled, call message generation routine
  1. I 'HLFORMAT N HLERR D I $D(HLERR) S HLRESLTA="9^"_HLERR D STATUS^HLTF0(HLMTIENA,4,9,HLERR) G ERR
  1. .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_")"
  1. .X HLP("GROUTINE")
  1. ;
  1. ;create header for message in 773
  1. I (HLTYPE="M") D HEADER^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
  1. I (HLTYPE'="M") D BHSHDR^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
  1. ;if error set status to ERROR DURING TRANSMISSION
  1. I ($G(HLRESLT)'="") D STATUS^HLTF0(HLTCP,4,12,HLRESLT) G ERR
  1. ;set header, HLHDR in 773
  1. K HLQ S X=HLTCP_",",HLQ(773,X,200)="HLHDR"
  1. D FILE^HLDIE("","HLQ","","GENACK","HLTP4") ;HL*1.6*109
  1. ;D FILE^DIE("","HLQ")
  1. ;update status of 773 to PENDING TRANSMISSION
  1. D STATUS^HLTF0(HLTCP,1)
  1. ;Execute exit action for subscriber protocol
  1. X:HLEXROU]"" HLEXROU
  1. ;
  1. ;**109**
  1. ;tcp link is NOT open, need x-ref
  1. I '$G(HLTCPO) D ENQUE^HLCSREP(HLOGLINK,"O",HLTCP)
  1. ;
  1. EXIT ;**109**
  1. ;L -^HLMA(HLMTIENA)
  1. Q
  1. ERR D EXIT S HLTCP=""
  1. S:$G(HLRESLT) HLRESLTA=$G(HLRESLTA)_"^"_HLRESLT
  1. Q
  1. ACK(HLTACK,HLMG) ;build response based on original msg header
  1. ;for Bi-directional TCP
  1. ;INPUT:
  1. ; HLTACK=type of ack. CA,CR, or AR
  1. ; HLMG=text for MSA segment
  1. ; HLMTIENS=original msg. ien #773
  1. ; HL(array) from original header
  1. ;RETURNS: HLTCP=ien of response msg. in 773
  1. N HLDT,HLDT1,HLQ,HLFS,HLHDR,HLMIDA,HLMTIEN,HLMTIENA,HLP,HLREC,HLSAN,X
  1. ;quit if we don't have enough to make a msg.
  1. I $G(HL("ECH"))=""!($G(HL("FS"))="")!($G(HL("TYPE"))="") Q
  1. ;Extract data from original message and store in separate variables
  1. ;reverse sending and receiving application from original msg.
  1. S HLFS=HL("FS"),HLREC=$G(HL("SAN")),HLSAN=$G(HL("RAN"))
  1. ;create message in 772 & 773, HLMTIENA=new msg ien #773
  1. D TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
  1. ;lock new record
  1. ;**109**
  1. ;F L +^HLMA(HLMTIENA):1 Q:$T H 1
  1. ;
  1. ;HLMTIEN=ien in 772
  1. S HLTCP=HLMTIENA,HLMTIEN=+^HLMA(HLMTIENA,0),HLDT1=$$FMTHL7^XLFDT(HLDT)
  1. ;get 'msgtype'=B or M, message type and event type
  1. S HLP("MSGTYPE")=$E(HL("TYPE")),HLP("MTYPE")=$G(HL("MTP")),HLP("EVENT")=$G(HL("ETP")),HLP("HLTCPI")=HLMTIENS
  1. S:$G(HL("MTP_ETP")) HLP("MTYPE_EVENT")=$G(HL("MTP_ETP"))
  1. ; HL*1.6*117 start
  1. ; change the order of when updates are done on file 773
  1. ;Update zero node of Message Admin file #773
  1. ;D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
  1. ;
  1. ;don't need x-ref, msg will be sent back over open tcp link
  1. ;**109**
  1. ;D LLCNT^HLCSTCP(HLDP,3)
  1. ;K ^HLMA("AC","O",HLDP,HLTCP)
  1. ;
  1. ;Update status to Being Generated
  1. ;D STATUS^HLTF0(HLTCP,8)
  1. ; HL*1.6*117 end
  1. ;update zero node of Message Text file #772
  1. D
  1. . N HLTCP D UPDATE^HLTF0(HLMTIEN,,"O")
  1. ;
  1. ;build MSA segment
  1. K HLA
  1. S HLA("HLS",1)="MSA"_HLFS_HLTACK_HLFS_$G(HL("MID"))
  1. S:$G(HLMG)]"" HLA("HLS",1)=HLA("HLS",1)_HLFS_HLMG
  1. ;update file 772 with msg text
  1. D MERGE^HLTF1("L",HLMTIEN,"HLS")
  1. D HDR
  1. ;update file 773 with msg header
  1. K HLQ S HLQ(773,HLTCP_",",200)="HLHDR"
  1. D FILE^HLDIE("","HLQ","","ACK","HLTP4") ; HL*1.6*109
  1. ;D FILE^DIE("","HLQ")
  1. ; HL*1.6*117 start
  1. ; finally commit updates to 773 that will affect behavior of messaging
  1. ;Update status to Being Generated
  1. D STATUS^HLTF0(HLTCP,8)
  1. ;Update zero node of Message Admin file #773
  1. ; patch HL*1.6*142
  1. ; update ien of sending application (from HL("RAP") of the incoming msg),
  1. ; ien of receiving application (from HL("SAP") of the incoming msg),
  1. ; and subscriber protocol
  1. ; D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
  1. D UPDATE^HLTF0(HLTCP,,"O",$G(HL("EIDS")),$G(HL("SAP")),$G(HL("RAP")),"I",HLMTIENS,HLDP,.HLP)
  1. ; update message sent count
  1. D LLCNT^HLCSTCP(HLDP,3)
  1. ; HL*1.6*117 end
  1. G EXIT
  1. ;
  1. HDR ; build header for commit ack
  1. K HLHDR
  1. S HLHDR(1)=HL("TYPE")_HLFS_HL("ECH")_HLFS_HLSAN_HLFS_$G(HL("RFN"))_HLFS_HLREC_HLFS_$G(HL("SFN"))_HLFS_HLDT1_HLFS_HLFS
  1. I HLP("MSGTYPE")="M" S HLHDR(1)=HLHDR(1)_"ACK"_HLFS_HLMIDA_HLFS_$G(HL("PID"))_HLFS_$G(HL("VER")) Q
  1. ;batch
  1. S X=$E(HL("ECH"))
  1. S HLHDR(1)=HLHDR(1)_X_$G(HL("PID"))_X_"ACK"_HLFS_HLTACK_HLFS_HLMIDA_HLFS_$G(HL("MID"))
  1. Q