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

HLTP31.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1. RSP(X,HLN) ;process response msg. X=ien in 773^msg. ien in 772
  1.  ;HLN=HL array for original message
  1.  ;HLMTIEN=ien in 772,  HLMTIENS=ien in 773
  1.  ;returns - 0=resend msg, 1=commit ack, 3=app ack success, 4=error
  1.  ;set error trap
  1.  N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
  1.  N HLERR,HLHDR,HLMSA,HLMTIEN,HLMTIENS,HLQUIT,HLNODE,HLNEXT,HLRESLTA
  1.  D INIT^HLTP3A  ;patch HL*1.6*109: hltp3 routine split
  1.  ;Quit processing if error with header
  1.  I $G(HLRESLT) D EXIT Q 0
  1.  ;must have MSA segment
  1.  I '$L(HLMSA) D RSPER(4,108,"Missing MSA segment") Q 0
  1.  ;msg. id in MSA must match original msg. id, if not reject
  1.  I $P(HLMSA,HL("FS"),2)'=HLN("MID") D RSPER(4,108,"Incorrect msg. Id") Q 0
  1.  ;rec. app. must match sending app. of original message.
  1.  I HL("RAN")'=HLN("SAN") D RSPER(4,108,"Incorrect sending app.") Q 0
  1.  ;get ack code
  1.  S HL("ACKCD")=$P(HLMSA,HL("FS"))
  1.  ;update LL, rec. 1 msg
  1.  D LLCNT^HLCSTCP(HLDP,1)
  1.  ;commit ack
  1.  I $E(HL("ACKCD"))="C" D  Q X
  1.  . ;update LL, processed 1 msg
  1.  . D LLCNT^HLCSTCP(HLDP,2)
  1.  . ;received an error ack, return NAK
  1.  . S:$E(HL("ACKCD"),2)'="A" HLRESLT=102_U_$P(HLMSA,HL("FS"),3)
  1.  . D RSPER(3) S X=$S($E(HL("ACKCD"),2)="A":1,1:4)
  1.  ;app. ack, received an error ack, NAK
  1.  S:$E(HL("ACKCD"),2)'="A" HLRESLT=102_U_$P(HLMSA,HL("FS"),3)
  1.  ;Set special HL variables
  1.  S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
  1.  ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
  1.  N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101,"
  1.  ;process ack
  1.  D
  1.  . N HLTCP ;Newed variable to update status in 772.
  1.  . D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
  1.  ;update LL, processed 1 msg
  1.  D LLCNT^HLCSTCP(HLDP,2)
  1.  ;process ack successfully
  1.  D RSPER(3)
  1.  ;HLRESELT is defined for errors
  1.  Q $S($G(HLRESLT):4,1:3)
  1.  ;
  1. RSPER(HLST,HLER,HLERM) ;HLST=status, HLER=error type, HLERM=error msg.
  1.  D STATUS^HLTF0(HLMTIENS,HLST,$G(HLER),$G(HLERM),1)
  1.  S:$G(HLER) HLRESLT=HLER_U_HLERM
  1.  D EXIT
  1.  Q
  1. EXIT ;unlock
  1.  ;**109**
  1.  ;I $G(HLMTIENS) L -^HLMA(HLMTIENS)
  1.  Q
  1.  ;
  1. SETINQUE ;
  1.  ;**HL*1.6*109***
  1.  ;Called from HLTP3 for message that utilize enhanced mode - NOT original mode
  1.  ;Sets the incoming message on the in queue.
  1.  ;Does not use the listener, instead, arranges multiple in-queues
  1.  ;by using the sending link.
  1.  ;
  1.  N HLI,HLINST,HLDOMAIN,HLLINK
  1.  ;
  1.  ;Override value of logical link based on sending facility to create
  1.  ;a queue (^HLMA("AC","I",llnk ien,msg ien)) different than that of the 
  1.  ;listener
  1.  S HLINST=$P(HL("SFN"),$E(HL("ECH")))
  1.  S HLDOMAIN=$P(HL("SFN"),$E(HL("ECH")),2)
  1.  ;
  1.  ; patch HL*1.6*120 start
  1.  ; assume the format is <domain>:<port #>
  1.  I HLDOMAIN[":" S HL("PORT")=$P(HLDOMAIN,":",2)
  1.  S HLDOMAIN=$P(HLDOMAIN,":")
  1.  S HL("DOMAIN")=HLDOMAIN
  1.  ; change from lower case to upper case
  1.  S HLDOMAIN=$$UP^XLFSTR(HLDOMAIN)
  1.  ; if first piece of domain is "HL7." or "MPI.", remove it
  1.  I ($E(HLDOMAIN,1,4)="HL7.")!($E(HLDOMAIN,1,4)="MPI.") D
  1.  . S HLDOMAIN=$P(HLDOMAIN,".",2,99)
  1.  ; patch HL*1.6*120 end
  1.  ;
  1.  I HLDOMAIN]"" D    ;logical link lookup by domain
  1.  . D LINK^HLUTIL3(HLDOMAIN,.HLI,"D")
  1.  . S HLLINK=$O(HLI(0)) ;client link for sending facility
  1.  ;logical link lookup by station number
  1.  I $G(HLLINK)']"",HLINST]"" D
  1.  . D LINK^HLUTIL3(HLINST,.HLI,"I")
  1.  . S HLLINK=$O(HLI(0)) ;client link for sending facility
  1.  ;
  1.  ; patch HL*1.6*120 start
  1.  ;logical link lookup by DNS domain
  1.  I $G(HLLINK)']"",HL("DOMAIN")]"" D
  1.  . I $D(^HLCS(870,"DNS",HL("DOMAIN"))) D  Q
  1.  .. S HLLINK=+$O(^HLCS(870,"DNS",HL("DOMAIN"),0))
  1.  . I $D(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")))) D  Q
  1.  .. S HLLINK=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")),0))
  1.  . I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")))) D
  1.  .. S HLLINK=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")),0))
  1.  ;
  1.  ;logical link lookup by ip address
  1.  I $G(HLLINK)']"",HL("DOMAIN") D
  1.  . S HLLINK=$O(^HLCS(870,"IP",HL("DOMAIN"),0))
  1.  ; patch HL*1.6*120 end
  1.  ;
  1.  ; find the logical link of the subscriber protocol
  1.  ; then set the link field of this message to the link
  1.  I $G(HL("EIDS")),$P(^ORD(101,HL("EIDS"),770),"^",7) S HLLINK=$P(^ORD(101,HL("EIDS"),770),"^",7)
  1.  ;
  1.  I $L($G(HLLINK)) D
  1.  .D ENQUE^HLCSREP(HLLINK,"I",HLMTIENS)
  1.  E  D
  1.  .D ENQUE^HLCSREP(HLDP,"I",HLMTIENS)
  1.  Q