| [613] | 1 | HLTP31 ;SFIRMFO/RSD - Cont. Transaction Processor for TCP ;01/26/2006 15:50
|
|---|
| 2 | ;;1.6;HEALTH LEVEL SEVEN;**57,58,66,109,120**;Oct 13, 1995;Build 12
|
|---|
| 3 | ;
|
|---|
| 4 | Q
|
|---|
| 5 | RSP(X,HLN) ;process response msg. X=ien in 773^msg. ien in 772
|
|---|
| 6 | ;HLN=HL array for original message
|
|---|
| 7 | ;HLMTIEN=ien in 772, HLMTIENS=ien in 773
|
|---|
| 8 | ;returns - 0=resend msg, 1=commit ack, 3=app ack success, 4=error
|
|---|
| 9 | ;set error trap
|
|---|
| 10 | N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLTP3"
|
|---|
| 11 | N HLERR,HLHDR,HLMSA,HLMTIEN,HLMTIENS,HLQUIT,HLNODE,HLNEXT,HLRESLTA
|
|---|
| 12 | D INIT^HLTP3A ;patch HL*1.6*109: hltp3 routine split
|
|---|
| 13 | ;Quit processing if error with header
|
|---|
| 14 | I $G(HLRESLT) D EXIT Q 0
|
|---|
| 15 | ;must have MSA segment
|
|---|
| 16 | I '$L(HLMSA) D RSPER(4,108,"Missing MSA segment") Q 0
|
|---|
| 17 | ;msg. id in MSA must match original msg. id, if not reject
|
|---|
| 18 | I $P(HLMSA,HL("FS"),2)'=HLN("MID") D RSPER(4,108,"Incorrect msg. Id") Q 0
|
|---|
| 19 | ;rec. app. must match sending app. of original message.
|
|---|
| 20 | I HL("RAN")'=HLN("SAN") D RSPER(4,108,"Incorrect sending app.") Q 0
|
|---|
| 21 | ;get ack code
|
|---|
| 22 | S HL("ACKCD")=$P(HLMSA,HL("FS"))
|
|---|
| 23 | ;update LL, rec. 1 msg
|
|---|
| 24 | D LLCNT^HLCSTCP(HLDP,1)
|
|---|
| 25 | ;commit ack
|
|---|
| 26 | I $E(HL("ACKCD"))="C" D Q X
|
|---|
| 27 | . ;update LL, processed 1 msg
|
|---|
| 28 | . D LLCNT^HLCSTCP(HLDP,2)
|
|---|
| 29 | . ;received an error ack, return NAK
|
|---|
| 30 | . S:$E(HL("ACKCD"),2)'="A" HLRESLT=102_U_$P(HLMSA,HL("FS"),3)
|
|---|
| 31 | . D RSPER(3) S X=$S($E(HL("ACKCD"),2)="A":1,1:4)
|
|---|
| 32 | ;app. ack, received an error ack, NAK
|
|---|
| 33 | S:$E(HL("ACKCD"),2)'="A" HLRESLT=102_U_$P(HLMSA,HL("FS"),3)
|
|---|
| 34 | ;Set special HL variables
|
|---|
| 35 | S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL"
|
|---|
| 36 | ;HLORNOD=subscriber protocol for Fileman auditing, ien;global ref
|
|---|
| 37 | N HLORNODD S HLORNOD=HL("EIDS")_";ORD(101,"
|
|---|
| 38 | ;process ack
|
|---|
| 39 | D
|
|---|
| 40 | . N HLTCP ;Newed variable to update status in 772.
|
|---|
| 41 | . D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
|
|---|
| 42 | ;update LL, processed 1 msg
|
|---|
| 43 | D LLCNT^HLCSTCP(HLDP,2)
|
|---|
| 44 | ;process ack successfully
|
|---|
| 45 | D RSPER(3)
|
|---|
| 46 | ;HLRESELT is defined for errors
|
|---|
| 47 | Q $S($G(HLRESLT):4,1:3)
|
|---|
| 48 | ;
|
|---|
| 49 | RSPER(HLST,HLER,HLERM) ;HLST=status, HLER=error type, HLERM=error msg.
|
|---|
| 50 | D STATUS^HLTF0(HLMTIENS,HLST,$G(HLER),$G(HLERM),1)
|
|---|
| 51 | S:$G(HLER) HLRESLT=HLER_U_HLERM
|
|---|
| 52 | D EXIT
|
|---|
| 53 | Q
|
|---|
| 54 | EXIT ;unlock
|
|---|
| 55 | ;**109**
|
|---|
| 56 | ;I $G(HLMTIENS) L -^HLMA(HLMTIENS)
|
|---|
| 57 | Q
|
|---|
| 58 | ;
|
|---|
| 59 | SETINQUE ;
|
|---|
| 60 | ;**HL*1.6*109***
|
|---|
| 61 | ;Called from HLTP3 for message that utilize enhanced mode - NOT original mode
|
|---|
| 62 | ;Sets the incoming message on the in queue.
|
|---|
| 63 | ;Does not use the listener, instead, arranges multiple in-queues
|
|---|
| 64 | ;by using the sending link.
|
|---|
| 65 | ;
|
|---|
| 66 | N HLI,HLINST,HLDOMAIN,HLLINK
|
|---|
| 67 | ;
|
|---|
| 68 | ;Override value of logical link based on sending facility to create
|
|---|
| 69 | ;a queue (^HLMA("AC","I",llnk ien,msg ien)) different than that of the
|
|---|
| 70 | ;listener
|
|---|
| 71 | S HLINST=$P(HL("SFN"),$E(HL("ECH")))
|
|---|
| 72 | S HLDOMAIN=$P(HL("SFN"),$E(HL("ECH")),2)
|
|---|
| 73 | ;
|
|---|
| 74 | ; patch HL*1.6*120 start
|
|---|
| 75 | ; assume the format is <domain>:<port #>
|
|---|
| 76 | I HLDOMAIN[":" S HL("PORT")=$P(HLDOMAIN,":",2)
|
|---|
| 77 | S HLDOMAIN=$P(HLDOMAIN,":")
|
|---|
| 78 | S HL("DOMAIN")=HLDOMAIN
|
|---|
| 79 | ; change from lower case to upper case
|
|---|
| 80 | S HLDOMAIN=$$UP^XLFSTR(HLDOMAIN)
|
|---|
| 81 | ; if first piece of domain is "HL7." or "MPI.", remove it
|
|---|
| 82 | I ($E(HLDOMAIN,1,4)="HL7.")!($E(HLDOMAIN,1,4)="MPI.") D
|
|---|
| 83 | . S HLDOMAIN=$P(HLDOMAIN,".",2,99)
|
|---|
| 84 | ; patch HL*1.6*120 end
|
|---|
| 85 | ;
|
|---|
| 86 | I HLDOMAIN]"" D ;logical link lookup by domain
|
|---|
| 87 | . D LINK^HLUTIL3(HLDOMAIN,.HLI,"D")
|
|---|
| 88 | . S HLLINK=$O(HLI(0)) ;client link for sending facility
|
|---|
| 89 | ;logical link lookup by station number
|
|---|
| 90 | I $G(HLLINK)']"",HLINST]"" D
|
|---|
| 91 | . D LINK^HLUTIL3(HLINST,.HLI,"I")
|
|---|
| 92 | . S HLLINK=$O(HLI(0)) ;client link for sending facility
|
|---|
| 93 | ;
|
|---|
| 94 | ; patch HL*1.6*120 start
|
|---|
| 95 | ;logical link lookup by DNS domain
|
|---|
| 96 | I $G(HLLINK)']"",HL("DOMAIN")]"" D
|
|---|
| 97 | . I $D(^HLCS(870,"DNS",HL("DOMAIN"))) D Q
|
|---|
| 98 | .. S HLLINK=+$O(^HLCS(870,"DNS",HL("DOMAIN"),0))
|
|---|
| 99 | . I $D(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")))) D Q
|
|---|
| 100 | .. S HLLINK=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(HL("DOMAIN")),0))
|
|---|
| 101 | . I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")))) D
|
|---|
| 102 | .. S HLLINK=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(HL("DOMAIN")),0))
|
|---|
| 103 | ;
|
|---|
| 104 | ;logical link lookup by ip address
|
|---|
| 105 | I $G(HLLINK)']"",HL("DOMAIN") D
|
|---|
| 106 | . S HLLINK=$O(^HLCS(870,"IP",HL("DOMAIN"),0))
|
|---|
| 107 | ; patch HL*1.6*120 end
|
|---|
| 108 | ;
|
|---|
| 109 | ; find the logical link of the subscriber protocol
|
|---|
| 110 | ; then set the link field of this message to the link
|
|---|
| 111 | I $G(HL("EIDS")),$P(^ORD(101,HL("EIDS"),770),"^",7) S HLLINK=$P(^ORD(101,HL("EIDS"),770),"^",7)
|
|---|
| 112 | ;
|
|---|
| 113 | I $L($G(HLLINK)) D
|
|---|
| 114 | .D ENQUE^HLCSREP(HLLINK,"I",HLMTIENS)
|
|---|
| 115 | E D
|
|---|
| 116 | .D ENQUE^HLCSREP(HLDP,"I",HLMTIENS)
|
|---|
| 117 | Q
|
|---|
