source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTP4.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1HLTP4 ;SFIRMFO/RSD - Transaction Processor for TCP ;01/26/2006 14:06
2 ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,91,109,116,117,125,120**;Oct 13, 1995;Build 12
3GENACK ;called from HLMA1
4 ;Entry point to generate an acknowledgement message
5 ;for TCP
6 ;INPUT:
7 ; HLMTIENS=original msg. ien #773
8 ; HLEID=original msg. event protocol
9 ; HLEIDS=original msg. subscriber protocol
10 ; HLMTIENA=ien of ack in 772, for batch only
11 ; Note: if the HLP(...) array exists, it will be "honored" by
12 ; UPDATE^HLTF0 below. This includes the HLP("NAMESPACE")
13 ; variable. - HL*1.6*91
14 ;
15 ;OUTPUT: HLTCP=ien of response
16 N HLDT,HLDT1,HLQ,HLOGLINK,HLMIDA,HLMTIEN,HLREC,HLSAN,HLTYPE,X
17 ;Extract data from original message and store in separate variables
18 ;reverse sending and receiving application from original msg.
19 S X=$G(^HLMA(HLMTIENS,0)),HLREC=$P(X,U,11),HLSAN=$P(X,U,12),HLOGLINK=$G(HLTCPO)
20 ;HLMTIENA defined, create msg in 773
21 I $G(HLMTIENA) S HLDT=+$G(^HL(772,HLMTIENA,0)),HLMTIENA=$$MA^HLTF(HLMTIENA,.HLMIDA)
22 ;create message in 772 & 773, HLMTIENA=new msg ien #773
23 I '$G(HLMTIENA) D TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
24 ;
25 ;**109**
26 ;lock new record
27 ;F L +^HLMA(HLMTIENA):1 Q:$T H 1
28 ;
29 ;HLMTIEN=ien in 772
30 S HLTCP=HLMTIENA,HLMTIEN=+^HLMA(HLMTIENA,0),HLDT1=$$HLDATE^HLFNC(HLDT),(HLTYPE,HLP("MSGTYPE"))=$E(HLARYTYP,2)
31 ;
32 ;**** HL*1.6*116 ****
33 ;no open link, check dynamic routing of ack
34 S X=$G(^ORD(101,HLEIDS,770)),HLP("MTYPE")=$P(X,U,11),HLP("EVENT")=$P(X,U,4)
35 ;
36 ; patch HL*1.6*125- change from $G to $D
37 I '$D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK
38 .K HLL("LINKS")
39 .I 'HLOGLINK D
40 .. S HLOGLINK=$P(X,U,7)
41 .. Q:HLOGLINK
42 .. N DOMAIN,SFAC,MSH,FS,CS,HLI,INST
43 .. S MSH=$G(^HLMA(HLMTIENS,"MSH",1,0))
44 .. Q:'$L(MSH)
45 .. S FS=$E(MSH,4)
46 .. Q:'$L(FS)
47 .. S CS=$E(MSH,5)
48 .. Q:'$L(CS)
49 .. S DOMAIN=$P($P(MSH,FS,4),CS,2)
50 .. ;
51 .. ; patch HL*1.6*120 start
52 .. ; assume the format is <domain>:<port #>
53 .. I DOMAIN[":" S HLP("PORT")=$P(DOMAIN,":",2)
54 .. S DOMAIN=$P(DOMAIN,":")
55 .. S HLP("DNS-DOMAIN")=DOMAIN
56 .. ;
57 .. ; if first piece of domain is "HL7." or "MPI.", remove it
58 .. I ($E(DOMAIN,1,4)="HL7.")!($E(DOMAIN,1,4)="MPI.") D
59 ... S DOMAIN=$P(DOMAIN,".",2,99)
60 .. ;
61 .. ; lookup Mailman domain
62 .. I $L(DOMAIN) D
63 ... D LINK^HLUTIL3(DOMAIN,.HLI,"D")
64 ... S HLOGLINK=$O(HLI(0))
65 .. Q:HLOGLINK
66 .. S INST=$P($P(MSH,FS,4),CS,1)
67 .. I $L(INST) D
68 .. .D LINK^HLUTIL3(INST,.HLI,"I")
69 ... S HLOGLINK=$O(HLI(0))
70 .. Q:HLOGLINK
71 .. ;
72 .. ; check DNS domain and ip address
73 .. I $L(HLP("DNS-DOMAIN")) D
74 ... ;
75 ... ; match DNS domain
76 ... I $D(^HLCS(870,"DNS",HLP("DNS-DOMAIN"))) D
77 .... S HLOGLINK=+$O(^HLCS(870,"DNS",HLP("DNS-DOMAIN"),0))
78 ... Q:HLOGLINK
79 ... ;
80 ... I $D(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN")))) D
81 .... S HLOGLINK=+$O(^HLCS(870,"DNS",$$UP^XLFSTR(HLP("DNS-DOMAIN")),0))
82 ... Q:HLOGLINK
83 ... ;
84 ... I $D(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN")))) D
85 .... S HLOGLINK=+$O(^HLCS(870,"DNS",$$LOW^XLFSTR(HLP("DNS-DOMAIN")),0))
86 ... Q:HLOGLINK
87 ... ;
88 ... ; match ip address
89 ... I $D(^HLCS(870,"IP",HLP("DNS-DOMAIN"))) D
90 .... S HLOGLINK=+$O(^HLCS(870,"IP",HLP("DNS-DOMAIN"),0))
91 .. ;
92 ; patch HL*1.6*116 and patch HL*1.6*120 end
93 ;
94 ;** HL*1.6*117 **
95 ; patch HL*1.6*125- change from $G to $D
96 I $D(HLL("SET FOR APP ACK")) D Q:'HLOGLINK
97 .N I
98 .S I=$O(HLL("LINKS",0))
99 .I 'I S HLOGLINK="" Q
100 .S HLOGLINK=$P(HLL("LINKS",I),"^",2) Q:HLOGLINK=""
101 .I +HLOGLINK'=HLOGLINK S HLOGLINK=$O(^HLCS(870,"B",HLOGLINK,0))
102 ;**END HL*1.6*117 **
103 ;
104 S:$P(X,U,5) HLP("MTYPE_EVENT")=$P(X,U,5)
105 ;HLTCPI=initial message
106 S:$G(HLTCPI) HLP("HLTCPI")=HLTCPI
107 ;Update zero node of Message Admin file #773
108 D UPDATE^HLTF0(HLTCP,,"O",HLEIDS,HLREC,HLSAN,"I",HLMTIENS,HLOGLINK,.HLP)
109 ;
110 ;Update status to Being Generated
111 D STATUS^HLTF0(HLTCP,8)
112 ;
113 ;**109**
114 ;tcp link is open, don't need x-ref, msg will be sent over link
115 ;I $G(HLTCPO) K ^HLMA("AC","O",HLOGLINK,HLTCP)
116 ;
117 ;update zero node of Message Text file #772
118 D
119 . N HLTCP D UPDATE^HLTF0(HLMTIEN,,"O",HLEID)
120 ;
121 ;Execute entry action for subscriber protocol
122 I HLENROU]"" X HLENROU
123 S HLQ=""""
124 ;Check that local/global array exists and store in Message Text file
125 ; if pre-compiled
126 I HLFORMAT D I (+$G(HLRESLTA)) D STATUS^HLTF0(HLMTIENA,4,+HLRESLTA) G ERR
127 . I $E(HLARYTYP)="G" D
128 .. I $O(^TMP("HLA",$J,0))']"" S HLRESLTA="8^"_$G(^HL(771.7,8,0)) Q
129 .. D MERGE^HLTF1("G",HLMTIEN,"HLA")
130 . I $E(HLARYTYP)="L" D
131 .. I $O(HLA("HLA",0))']"" S HLRESLTA="8^"_$G(^HL(771.7,8,0)) Q
132 .. D MERGE^HLTF1("L",HLMTIEN,"HLA")
133 ;If array is not pre-compiled, call message generation routine
134 I 'HLFORMAT N HLERR D I $D(HLERR) S HLRESLTA="9^"_HLERR D STATUS^HLTF0(HLMTIENA,4,9,HLERR) G ERR
135 .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_")"
136 .X HLP("GROUTINE")
137 ;
138 ;create header for message in 773
139 I (HLTYPE="M") D HEADER^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
140 I (HLTYPE'="M") D BHSHDR^HLCSHDR1(HLTCP,HLREC,.HLRESLT)
141 ;if error set status to ERROR DURING TRANSMISSION
142 I ($G(HLRESLT)'="") D STATUS^HLTF0(HLTCP,4,12,HLRESLT) G ERR
143 ;set header, HLHDR in 773
144 K HLQ S X=HLTCP_",",HLQ(773,X,200)="HLHDR"
145 D FILE^HLDIE("","HLQ","","GENACK","HLTP4") ;HL*1.6*109
146 ;D FILE^DIE("","HLQ")
147 ;update status of 773 to PENDING TRANSMISSION
148 D STATUS^HLTF0(HLTCP,1)
149 ;Execute exit action for subscriber protocol
150 X:HLEXROU]"" HLEXROU
151 ;
152 ;**109**
153 ;tcp link is NOT open, need x-ref
154 I '$G(HLTCPO) D ENQUE^HLCSREP(HLOGLINK,"O",HLTCP)
155 ;
156EXIT ;**109**
157 ;L -^HLMA(HLMTIENA)
158 Q
159ERR D EXIT S HLTCP=""
160 S:$G(HLRESLT) HLRESLTA=$G(HLRESLTA)_"^"_HLRESLT
161 Q
162ACK(HLTACK,HLMG) ;build response based on original msg header
163 ;for Bi-directional TCP
164 ;INPUT:
165 ; HLTACK=type of ack. CA,CR, or AR
166 ; HLMG=text for MSA segment
167 ; HLMTIENS=original msg. ien #773
168 ; HL(array) from original header
169 ;RETURNS: HLTCP=ien of response msg. in 773
170 N HLDT,HLDT1,HLQ,HLFS,HLHDR,HLMIDA,HLMTIEN,HLMTIENA,HLP,HLREC,HLSAN,X
171 ;quit if we don't have enough to make a msg.
172 I $G(HL("ECH"))=""!($G(HL("FS"))="")!($G(HL("TYPE"))="") Q
173 ;Extract data from original message and store in separate variables
174 ;reverse sending and receiving application from original msg.
175 S HLFS=HL("FS"),HLREC=$G(HL("SAN")),HLSAN=$G(HL("RAN"))
176 ;create message in 772 & 773, HLMTIENA=new msg ien #773
177 D TCP^HLTF(.HLMIDA,.HLMTIENA,.HLDT)
178 ;lock new record
179 ;**109**
180 ;F L +^HLMA(HLMTIENA):1 Q:$T H 1
181 ;
182 ;HLMTIEN=ien in 772
183 S HLTCP=HLMTIENA,HLMTIEN=+^HLMA(HLMTIENA,0),HLDT1=$$FMTHL7^XLFDT(HLDT)
184 ;get 'msgtype'=B or M, message type and event type
185 S HLP("MSGTYPE")=$E(HL("TYPE")),HLP("MTYPE")=$G(HL("MTP")),HLP("EVENT")=$G(HL("ETP")),HLP("HLTCPI")=HLMTIENS
186 S:$G(HL("MTP_ETP")) HLP("MTYPE_EVENT")=$G(HL("MTP_ETP"))
187 ; HL*1.6*117 start
188 ; change the order of when updates are done on file 773
189 ;Update zero node of Message Admin file #773
190 ;D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
191 ;
192 ;don't need x-ref, msg will be sent back over open tcp link
193 ;**109**
194 ;D LLCNT^HLCSTCP(HLDP,3)
195 ;K ^HLMA("AC","O",HLDP,HLTCP)
196 ;
197 ;Update status to Being Generated
198 ;D STATUS^HLTF0(HLTCP,8)
199 ; HL*1.6*117 end
200 ;update zero node of Message Text file #772
201 D
202 . N HLTCP D UPDATE^HLTF0(HLMTIEN,,"O")
203 ;
204 ;build MSA segment
205 K HLA
206 S HLA("HLS",1)="MSA"_HLFS_HLTACK_HLFS_$G(HL("MID"))
207 S:$G(HLMG)]"" HLA("HLS",1)=HLA("HLS",1)_HLFS_HLMG
208 ;update file 772 with msg text
209 D MERGE^HLTF1("L",HLMTIEN,"HLS")
210 D HDR
211 ;update file 773 with msg header
212 K HLQ S HLQ(773,HLTCP_",",200)="HLHDR"
213 D FILE^HLDIE("","HLQ","","ACK","HLTP4") ; HL*1.6*109
214 ;D FILE^DIE("","HLQ")
215 ; HL*1.6*117 start
216 ; finally commit updates to 773 that will affect behavior of messaging
217 ;Update status to Being Generated
218 D STATUS^HLTF0(HLTCP,8)
219 ;Update zero node of Message Admin file #773
220 D UPDATE^HLTF0(HLTCP,,"O",,HLREC,HLSAN,"I",HLMTIENS,HLDP,.HLP)
221 ; update message sent count
222 D LLCNT^HLCSTCP(HLDP,3)
223 ; HL*1.6*117 end
224 G EXIT
225 ;
226HDR ; build header for commit ack
227 K HLHDR
228 S HLHDR(1)=HL("TYPE")_HLFS_HL("ECH")_HLFS_HLSAN_HLFS_$G(HL("RFN"))_HLFS_HLREC_HLFS_$G(HL("SFN"))_HLFS_HLDT1_HLFS_HLFS
229 I HLP("MSGTYPE")="M" S HLHDR(1)=HLHDR(1)_"ACK"_HLFS_HLMIDA_HLFS_$G(HL("PID"))_HLFS_$G(HL("VER")) Q
230 ;batch
231 S X=$E(HL("ECH"))
232 S HLHDR(1)=HLHDR(1)_X_$G(HL("PID"))_X_"ACK"_HLFS_HLTACK_HLFS_HLMIDA_HLFS_$G(HL("MID"))
233 Q
Note: See TracBrowser for help on using the repository browser.