source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOASUB1.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: 9.4 KB
Line 
1HLOASUB1 ;IRMFO-ALB/CJM - Subscription Registry (continued) ;02/26/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INDEX(IEN,PARMARY) ;
6 ;Allows an application to optionally index its subscriptions.
7 ;so that it can find find them without storing the ien.
8 ;
9 ;Input:
10 ; IEN - ien of the entry
11 ; PARMARY (pass by reference) An array of up to 6 lookup values with
12 ;which to build the index. The format is: PARMARY(1)=<first parameter>,
13 ; up to PARMARY(6)
14 ;Output:
15 ; function returns 1 on success, 0 otherwise
16 ; PARMARY - left undefined
17 ;
18 N OWNER,I,NODE
19 Q:'$G(IEN) 0
20 S OWNER=$P($G(^HLD(779.4,IEN,0)),"^",2)
21 Q:'$L(OWNER) 0
22 D KILLAH(IEN)
23 F I=1:1:6 S:'$L($G(PARMARY(I))) PARMARY(I)=" "
24 D SETAH(IEN,OWNER,.PARMARY)
25 S NODE=""
26 F I=1:1:6 S NODE=NODE_$G(PARMARY(I))_"^"
27 S ^HLD(779.4,IEN,3)=NODE
28 K PARMARY
29 Q 1
30 ;
31SETAH(IEN,OWNER,PARMS) ;
32 Q:'$G(IEN)
33 Q:'$L($G(OWNER))
34 N INDEX
35 S INDEX="^HLD(779.4,""AH"",OWNER,"
36 F I=1:1:6 D
37 .S:'$L($G(PARMS(I))) PARMS(I)=" "
38 .S INDEX=INDEX_""""_PARMS(I)_""","
39 S INDEX=$E(INDEX,1,$L(INDEX)-1)_")"
40 S @INDEX=IEN
41 Q
42 ;
43SETAH1(DA,OWNER,X1,X2,X3,X4,X5,X6) ;
44 Q:'$G(DA)
45 Q:'$L($G(OWNER))
46 N PARMS,I
47 F I=1:1:6 I $L($G(@("X"_I))) S PARMS(I)=@("X"_I)
48 D SETAH(DA,OWNER,.PARMS)
49 Q
50 ;
51KILLAH1(OWNER,LOOKUP1,LOOKUP2,LOOKUP3,LOOKUP4,LOOKUP5,LOOKUP6) ;
52 Q:'$L(OWNER)
53 N I,INDEX
54 S INDEX="^HLD(779.4,""AH"",OWNER"
55 F I=1:1:6 D
56 .S:'$L($G(@("LOOKUP"_I))) @("LOOKUP"_I)=" "
57 .S INDEX=INDEX_","_""""_@("LOOKUP"_I)_""""
58 S INDEX=INDEX_")"
59 K @INDEX
60 Q
61 ;
62KILLAH(IEN) ;kills the AH x~ref on file 779.4 for a particular subscription registry entry=ien
63 Q:'$G(IEN)
64 N OWNER,X1,X2,X3,X4,X5,X6,I,NODE
65 S OWNER=$P($G(^HLD(779.4,IEN,0)),"^",2)
66 Q:'$L(OWNER)
67 S NODE=$G(^HLD(779.4,IEN,3))
68 F I=1:1:6 I $L($P(NODE,"^",I)) S @("X"_I)=$P(NODE,"^",I)
69 D KILLAH1(OWNER,.X1,.X2,.X3,.X4,.X5,.X6)
70 Q
71 ;
72FIND(OWNER,PARMARY) ;
73 ;Allows an application to find a subscription
74 ;list. The application must maintain a private index in order to
75 ;utilize this function, via $$INDEX^HLOASUB()
76 ;
77 ;Input:
78 ; OWNER - owning application name
79 ; PARMARY **pass by reference** an array of up to 6 lookup value with which the index was built. The format is: PARMARY(1)=<first parameter>, PARMARY(2)=<second parameter> If PARMARY(i)=null, the parameter will be ignored
80 ;Output:
81 ; function returns the ien of the subscription list if found, 0 otherwise
82 ; PARMARY - left undefined
83 ;
84 N OK S OK=0
85 ;
86 D
87 .Q:'$D(PARMARY)
88 .Q:'$L($G(OWNER))
89 .N INDEX,I
90 .S INDEX="^HLD(779.4,""AH"",OWNER"
91 .F I=1:1:6 D
92 ..S:'$L($G(PARMARY(I))) PARMARY(I)=" "
93 ..S INDEX=INDEX_","_""""_PARMARY(I)_""""
94 .S INDEX=INDEX_")"
95 .S OK=+$G(@INDEX)
96 K PARMARY
97 Q OK
98 ;
99UPD(FILE,DA,DATA,ERROR) ;File data into an existing record.
100 ; Input:
101 ; FILE - File or sub-file number
102 ; DA - Traditional DA array, with same meaning.
103 ; Pass by reference.
104 ; DATA - Data array to file (pass by reference)
105 ; Format: DATA(<field #>)=<value>
106 ;
107 ; Output:
108 ; Function Value - 0=error and 1=no error
109 ; ERROR - optional error message - if needed, pass by reference
110 ;
111 ; Example: To update a record in subfile 2.0361 in record with ien=353,
112 ; subrecord ien=68, with the field .01 value = 21:
113 ; S DATA(.01)=21,DA=68,DA(1)=353 I $$UPD(2.0361,.DA,.DATA,.ERROR) W !,"DONE"
114 ;
115 N FDA,FIELD,IENS,ERRORS
116 ;
117 ;IENS - Internal Entry Number String defined by FM
118 ;FDA - the FDA array as defined by FM
119 ;
120 I '$G(DA) S ERROR="IEN OF RECORD TO BE UPDATED NOT SPECIFIED" Q 0
121 S IENS=$$IENS^DILF(.DA)
122 S FIELD=0
123 F S FIELD=$O(DATA(FIELD)) Q:'FIELD D
124 .S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
125 D FILE^DIE("","FDA","ERRORS(1)")
126 I +$G(DIERR) D
127 .S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
128 E D
129 .S ERROR=""
130 ;
131 D CLEAN^DILF
132 Q $S(+$G(DIERR):0,1:1)
133 ;
134ADD(FILE,DA,DATA,ERROR,IEN) ;
135 ;Description: Creates a new record and files the data.
136 ; Input:
137 ; FILE - File or sub-file number
138 ; DA - Traditional FileMan DA array with same
139 ; meaning. Pass by reference. Only needed if adding to a
140 ; subfile.
141 ; DATA - Data array to file, pass by reference
142 ; Format: DATA(<field #>)=<value>
143 ; IEN - internal entry number to use (optional)
144 ;
145 ; Output:
146 ; Function Value - If no error then it returns the ien of the created record, else returns NULL.
147 ; DA - returns the ien of the new record, NULL if none created. If needed, pass by reference.
148 ; ERROR - optional error message - if needed, pass by reference
149 ;
150 ; Example: To add a record in subfile 2.0361 in the record with ien=353
151 ; with the field .01 value = 21:
152 ; S DATA(.01)=21,DA(1)=353 I $$ADD(2.0361,.DA,.DATA) W !,"DONE"
153 ;
154 ; Example: If creating a record not in a subfile, would look like this:
155 ; S DATA(.01)=21 I $$ADD(867,,.DATA) W !,"DONE"
156 ;
157 N FDA,FIELD,IENA,IENS,ERRORS
158 ;
159 ;IENS - Internal Entry Number String defined by FM
160 ;IENA - the Internal Entry Number Array defined by FM
161 ;FDA - the FDA array defined by FM
162 ;IEN - the ien of the new record
163 ;
164 S DA="+1"
165 S IENS=$$IENS^DILF(.DA)
166 S FIELD=0
167 F S FIELD=$O(DATA(FIELD)) Q:'FIELD D
168 .S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD))
169 I $G(IEN) S IENA(1)=IEN
170 D UPDATE^DIE("","FDA","IENA","ERRORS(1)")
171 I +$G(DIERR) D
172 .S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1))
173 .S IEN=""
174 E D
175 .S IEN=IENA(1)
176 .S ERROR=""
177 D CLEAN^DILF
178 S DA=IEN
179 Q IEN
180 ;
181DELETE(FILE,DA,ERROR) ;Delete an existing record.
182 N DATA
183 S DATA(.01)="@"
184 Q $$UPD(FILE,.DA,.DATA,.ERROR)
185 Q
186 ;
187STATNUM(IEN) ;
188 ;Description: Given an ien to the Institution file, returns as the function value the station number. If IEN is NOT passed in, it assumes the local site. Returns "" on failure.
189 ;
190 N STATION,RETURN
191 S RETURN=""
192 I $G(IEN) D
193 .Q:'$D(^DIC(4,IEN,0))
194 .S STATION=$P($$NNT^XUAF4(IEN),"^",2)
195 .S RETURN=$S(+STATION:STATION,1:"")
196 E D
197 .S RETURN=$P($$SITE^VASITE(),"^",3)
198 Q RETURN
199 ;
200CHECKWHO(WHO,PARMS,ERROR) ;
201 ;Checks the parameters provided in WHO() (see $$ADD). They must resolve
202 ;the link, receiving app and receiving facility.
203 ;INPUT:
204 ; WHO - (required, pass by reference) - see $$ADD.
205 ;
206 ; WHO("PORT") - if this is valued, it will be used as the remote port
207 ; to connect with rather than the port associated with the link
208 ;Output:
209 ; Function returns 1 if the input is resolved successfully, 0 otherwise
210 ; PARMS - (pass by reference) These subscripts are returned:
211 ; "LINK IEN" - ien of the link
212 ; "LINK NAME" - name of the link
213 ; "RECEIVING APPLICATION" - name of the receiving app
214 ; "RECEIVING FACILITY",1) - component 1
215 ; "RECEIVING FACILITY",2) - component 2
216 ; "RECEIVING FACILITY",3) - component 3
217 ; ERROR - (pass by reference) - if unsuccessful, an error message is returned.
218 ;
219 N OK
220 K ERROR
221 S OK=1
222 S PARMS("LINK IEN")="",PARMS("LINK NAME")=""
223 ;must identify the receiving app
224 ;
225 D
226 .N LEN
227 .S LEN=$L($G(WHO("RECEIVING APPLICATION")))
228 .I 'LEN S OK=0
229 .E I LEN>60 S OK=0
230 .S:'OK ERROR="RECEIVING APPLICATION NOT VALID"
231 .S PARMS("RECEIVING APPLICATION")=$G(WHO("RECEIVING APPLICATION"))
232 ;
233 ;find the station # if Institution ien known
234 S:$G(WHO("INSTITUTION IEN")) WHO("STATION NUMBER")=$$STATNUM^HLOASUB1(WHO("INSTITUTION IEN"))
235 ;
236 ;if destination link specified by name, get its ien
237 I '$G(WHO("FACILITY LINK IEN")),$L($G(WHO("FACILITY LINK NAME"))) S WHO("FACILITY LINK IEN")=$O(^HLCS(870,"B",WHO("FACILITY LINK NAME"),0))
238 ;
239 ;if destination link not specified, find it based on station #
240 I +$G(WHO("STATION NUMBER")),'$G(WHO("FACILITY LINK IEN")) S WHO("FACILITY LINK IEN")=$$FINDLINK^HLOTLNK(WHO("STATION NUMBER"))
241 ;
242 ;if station # not known, find it based on destination link
243 I '$G(WHO("STATION NUMBER")),$G(WHO("FACILITY LINK IEN")) S WHO("STATION NUMBER")=$$STATNUM^HLOTLNK(WHO("FACILITY LINK IEN"))
244 ;
245 S PARMS("RECEIVING FACILITY",1)=$G(WHO("STATION NUMBER"))
246 ;
247 ;if the destination link is known, get the domain
248 S PARMS("RECEIVING FACILITY",2)=$S($G(WHO("FACILITY LINK IEN")):$$DOMAIN^HLOTLNK(WHO("FACILITY LINK IEN")),1:"")
249 ;
250 S PARMS("RECEIVING FACILITY",3)="DNS"
251 ;
252 ;find the link to send over - need name & ien
253 I $G(WHO("IE LINK IEN")) D
254 .S PARMS("LINK IEN")=WHO("IE LINK IEN")
255 .S PARMS("LINK NAME")=$P($G(^HLCS(870,PARMS("LINK IEN"),0)),"^")
256 .I OK,'$L(PARMS("LINK NAME")) S OK=0,ERROR="INTERFACE ENGINE LOGICAL LINK PROVIDED BUT NOT FOUND"
257 E I $L($G(WHO("IE LINK NAME"))) D
258 .S PARMS("LINK NAME")=WHO("IE LINK NAME")
259 .S PARMS("LINK IEN")=$O(^HLCS(870,"B",WHO("IE LINK NAME"),0))
260 .I OK,'PARMS("LINK IEN") S OK=0,ERROR="INTERFACE ENGINE LOGICAL LINK PROVIDED BUT NOT FOUND"
261 E I $G(WHO("FACILITY LINK IEN")) D
262 .S PARMS("LINK IEN")=WHO("FACILITY LINK IEN")
263 .S PARMS("LINK NAME")=$P($G(^HLCS(870,PARMS("LINK IEN"),0)),"^")
264 .I OK,'$L(PARMS("LINK NAME")) S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
265 E I $L($G(WHO("FACILITY LINK NAME"))) D
266 .S PARMS("LINK NAME")=WHO("FACILITY LINK NAME")
267 .S PARMS("LINK IEN")=$O(^HLCS(870,"B",WHO("FACILITY LINK NAME"),0))
268 .I OK,'PARMS("LINK IEN") S OK=0,ERROR="RECEIVING FACILITY LOGICAL LINK NOT FOUND"
269 I OK,(('PARMS("LINK IEN"))!(PARMS("LINK NAME")="")) S OK=0,ERROR="LOGICAL LINK TO TRANSMIT OVER NOT SPECIFIED"
270 ;
271 ;need the station # or domain for msg header
272 I OK,'$L(PARMS("RECEIVING FACILITY",2)),'PARMS("RECEIVING FACILITY",1) S OK=0,ERROR="RECEIVING FACILITY STATION # AND DOMAIN NOT SPECIFIED"
273 ;
274 ;append the port#
275 I '$G(WHO("PORT")) S PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_$$PORT^HLOTLNK($G(WHO("FACILITY LINK IEN")))
276 E S PARMS("RECEIVING FACILITY",2)=PARMS("RECEIVING FACILITY",2)_":"_WHO("PORT")
277 ;
278 Q OK
Note: See TracBrowser for help on using the repository browser.