source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTP31.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1HLTP31 ;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
5RSP(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 ;
49RSPER(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
54EXIT ;unlock
55 ;**109**
56 ;I $G(HLMTIENS) L -^HLMA(HLMTIENS)
57 Q
58 ;
59SETINQUE ;
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
Note: See TracBrowser for help on using the repository browser.