source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOEDI1.m@ 1154

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

initial load of WorldVistAEHR
File size: 7.6 KB
RevLine 
[613]1PRCOEDI1 ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/27/98 11:11am]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5S1 ; SET 'AJX3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
6 ; ACTUALLY WILL SET 'AJ' X-REF.
7 ;
8 S Z0=$P($G(^PRC(443.75,DA,0)),U,7) ;FIELD 6
9 S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
10 S:Z1=1&(Z0>0) ^PRC(443.75,"AJ",Z1,X,Z0,DA)=""
11 K Z0,Z1
12 Q
13 ;
14K1 ; KILL 'AJX3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
15 ; ACTUALLY WILL KILL 'AJ' X-REF.
16 ;
17 S Z0=$P($G(^PRC(443.75,DA,0)),U,7) ;FIELD 6
18 S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
19 K:Z1=1&(Z0>0) ^PRC(443.75,"AJ",Z1,X,Z0,DA)
20 K Z0,Z1
21 Q
22 ;
23S2 ; SET 'AJ1X3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
24 ; ACTUALLY WILL SET 'AJ1' X-REF.
25 ;
26 S Z0=$G(^PRC(443.75,DA,0))
27 S Z055=$P(Z0,U,11) ;FIELD 5.5
28 S Z0=$P(Z0,U,7) ;FIELD 6
29 S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
30 S:Z1=1&(Z0>0)&(Z055>0) ^PRC(443.75,"AJ1",Z1,Z055,X,Z0,DA)=""
31 K Z0,Z055,Z1
32 Q
33 ;
34K2 ; KILL 'AJ1X3' X-REF -- CALLED FROM FIELD 3. LEVEL 1
35 ; ACTUALLY WILL KILL 'AJ1' X-REF.
36 ;
37 S Z0=$G(^PRC(443.75,DA,0))
38 S Z055=$P(Z0,U,11) ;FIELD 5.5
39 S Z0=$P(Z0,U,7) ;FIELD 6
40 S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
41 K:Z1=1&(Z0>0)&(Z055>0) ^PRC(443.75,"AJ1",Z1,Z055,X,Z0,DA)
42 K Z0,Z055,Z1
43 Q
44 ;
45S3 ; SET 'AJ1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 1
46 ; ACTUALLY WILL SET 'AJ1' X-REF.
47 ;
48 S Z0=$G(^PRC(443.75,DA,0))
49 S Z03=$P(Z0,U,4) ;FIELD 3
50 S Z0=$P(Z0,U,7) ;FIELD 6
51 S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
52 S:Z1=1&(Z03]"")&(Z0>0) ^PRC(443.75,"AJ1",Z1,X,Z03,Z0,DA)=""
53 K Z0,Z03,Z1
54 Q
55 ;
56K3 ; KILL 'AJ1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 1
57 ; ACTUALLY WILL KILL 'AJ1' X-REF.
58 ;
59 S Z0=$G(^PRC(443.75,DA,0))
60 S Z03=$P(Z0,U,4) ;FIELD 3
61 S Z0=$P(Z0,U,7) ;FIELD 6
62 S Z1=$P($G(^PRC(443.75,DA,1)),U,17) ;FIELD 25
63 K:Z1=1&(Z03]"")&(Z0>0) ^PRC(443.75,"AJ1",Z1,X,Z03,Z0,DA)
64 K Z0,Z03,Z1
65 Q
66 ;
67S4 ; SET 'AL1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 2
68 ; ACTUALLY WILL SET 'AL1' X-REF.
69 ;
70 N Z0,Z1,Z4,Z7,Z19,Z110
71 S Z1=$G(^PRC(443.75,DA,1))
72 S Z19=$P(Z1,U) ;FIELD 9
73 S Z110=$P(Z1,U,2) ;FIELD 10
74 S Z1=$P(Z1,U,17) ;FIELD 25
75 I Z1=2&(Z19]"")&(Z110>0) D
76 . S ^PRC(443.75,"AL1",Z1,X,Z19,Z110,DA)=""
77 . ;
78 . ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL.
79 . ;
80 . S Z0=$G(^PRC(443.75,DA,0))
81 . S Z4=$P(Z0,U,4) ;FIELD 3
82 . S Z7=$P(Z0,U,7) ;FIELD 6
83 . K:Z4]""&(Z7>0) ^PRC(443.75,"AJ1",1,X,Z4,Z7,DA)
84 . Q
85 Q
86 ;
87K4 ; KILL 'AL1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 2
88 ; ACTUALLY WILL KILL 'AL1' X-REF.
89 ;
90 N Z1,Z19,Z110
91 S Z1=$G(^PRC(443.75,DA,1))
92 S Z19=$P(Z1,U) ;FIELD 9
93 S Z110=$P(Z1,U,2) ;FIELD 10
94 S Z1=$P(Z1,U,17) ;FIELD 25
95 I Z1=2&(Z19]"")&(Z110>0) D
96 . K ^PRC(443.75,"AL1",Z1,X,Z19,Z110,DA)
97 . ;
98 . ; CAN'T RESTORE TO LOWER LEVEL BECAUSE SENDER IS BEING REMOVED.
99 . Q
100 Q
101 ;
102S5 ; SET 'AM1X55' X-REF -- CALLED FROM FIELD 5.5. LEVEL 3
103 ; ACTUALLY WILL SET 'AM1' X-REF.
104 ;
105 N Z1,Z19,Z110,Z123,Z124
106 S Z1=$G(^PRC(443.75,DA,1))
107 S Z19=$P(Z1,U) ;FIELD 9
108 S Z123=$P(Z1,U,15) ;FIELD 23
109 S Z110=$P(Z1,U,2) ;FIELD 10
110 S Z124=$P(Z1,U,16) ;FIELD 24
111 S Z1=$P(Z1,U,17) ;FIELD 25
112 I Z1=3&(Z123]"")&(Z124>0) D
113 . S ^PRC(443.75,"AM1",Z1,X,Z123,Z124,DA)=""
114 . ;
115 . ; WENT UP A LEVEL -- NEED TO REMOVER SENDER FROM LOWER LEVEL.
116 . ;
117 . K:Z19]""&(Z110>0) ^PRC(443.75,"AL1",2,X,Z19,Z110,DA)
118 . Q
119 Q
120 ;
121K5 ; KILL 'AM1X55' X-REF -- CALLED FROM FIELD 5.5 LEVEL 3
122 ; ACTUALLY WILL KILL 'AM1' X-REF.
123 ;
124 N Z1,Z123,Z124
125 S Z1=$G(^PRC(443.75,DA,1))
126 S Z123=$P(Z1,U,15) ;FIELD 23
127 S Z124=$P(Z1,U,16) ;FIELD 24
128 S Z1=$P(Z1,U,17) ;FIELD 25
129 I Z1=3&(Z123]"")&(Z124>0) D
130 . K ^PRC(443.75,"AM1",Z1,X,Z123,Z124,DA)
131 . ;
132 . ; CAN'T RESTORE TO LOWER LEVEL BECAUSE SENDER IS BEING REMOVED.
133 . ;
134 . Q
135 Q
136 ;
137S6 ; SET 'AJX25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
138 ; ACTUALLY WILL SET 'AJ' X-REF.
139 ;
140 N Z0,Z03
141 S Z0=$G(^PRC(443.75,DA,0))
142 S Z03=$P(Z0,U,4) ;FIELD 3
143 S Z0=$P(Z0,U,7) ;FIELD 6
144 S:X=1&(Z0>0)&(Z03]"") ^PRC(443.75,"AJ",X,Z03,Z0,DA)=""
145 Q
146 ;
147K6 ; KILL 'AJX25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
148 ; ACTUALLY WILL KILL 'AJ' X-REF.
149 ;
150 N Z0,Z03
151 S Z0=$G(^PRC(443.75,DA,0))
152 S Z03=$P(Z0,U,4) ;FIELD 3
153 S Z0=$P(Z0,U,7) ;FIELD 6
154 K:Z0>0&(Z03]"") ^PRC(443.75,"AJ",X,Z03,Z0,DA)
155 Q
156 ;
157S7 ; SET 'AJ1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
158 ; ACTUALLY WILL SET 'AJ1' X-REF.
159 ;
160 N Z0,Z03,Z055
161 S Z0=$G(^PRC(443.75,DA,0))
162 S Z03=$P(Z0,U,4) ;FIELD 3
163 S Z055=$P(Z0,U,11) ;FIELD 5.5
164 S Z0=$P(Z0,U,7) ;FIELD 6
165 S:X=1&(Z03]"")&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",X,Z055,Z03,Z0,DA)=""
166 Q
167 ;
168K7 ; KILL 'AJ1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 1
169 ; ACTUALLY WILL KILL 'AJ1' X-REF.
170 ;
171 N Z0,Z03,Z055
172 S Z0=$G(^PRC(443.75,DA,0))
173 S Z03=$P(Z0,U,4) ;FIELD 3
174 S Z055=$P(Z0,U,11) ;FIELD 5.5
175 S Z0=$P(Z0,U,7) ;FIELD 6
176 K:Z03]""&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",X,Z055,Z03,Z0,DA)
177 Q
178 ;
179S8 ; SET 'ALX25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
180 ; ACTUALLY WILL SET 'AL' X-REF.
181 ;
182 N Z0,Z03,Z1,Z19
183 S Z1=$G(^PRC(443.75,DA,1))
184 S Z19=$P(Z1,U) ;FIELD 9
185 S Z1=$P(Z1,U,2) ;FIELD 10
186 I X=2&(Z1>0)&(Z19]"") D
187 . S ^PRC(443.75,"AL",X,Z19,Z1,DA)=""
188 . ;
189 . ; WENT UP A LEVEL -- NEED TO REMOVE LOWER LEVEL.
190 . ;
191 . S Z0=$G(^PRC(443.75,DA,0))
192 . S Z03=$P(Z0,U,4) ;FIELD 3
193 . S Z0=$P(Z0,U,7) ;FIELD 6
194 . K:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)
195 . Q
196 Q
197 ;
198K8 ; KILL 'ALX25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
199 ; ACTUALLY WILL KILL 'AL' X-REF.
200 ;
201 N Z0,Z03,Z1,Z19
202 S Z1=$G(^PRC(443.75,DA,1))
203 S Z19=$P(Z1,U) ;FIELD 9
204 S Z1=$P(Z1,U,2) ;FIELD 10
205 I Z1>0&(Z19]"") D
206 . K ^PRC(443.75,"AL",X,Z19,Z1,DA)
207 . ;
208 . ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
209 . ;
210 . S Z0=$G(^PRC(443.75,DA,0))
211 . S Z03=$P(Z0,U,4) ;FIELD 3
212 . S Z0=$P(Z0,U,7) ;FIELD 6
213 . S:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)=""
214 . Q
215 Q
216 ;
217S9 ; SET 'AL1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
218 ; ACTUALLY WILL SET 'AL1' X-REF.
219 ;
220 N Z0,Z03,Z055,Z1,Z19
221 S Z0=$G(^PRC(443.75,DA,0))
222 S Z055=$P(Z0,U,11) ;FIELD 5.5
223 S Z1=$G(^PRC(443.75,DA,1))
224 S Z19=$P(Z1,U) ;FIELD 9
225 S Z1=$P(Z1,U,2) ;FIELD 10
226 I X=2&(Z055>0)&(Z19]"")&(Z1>0) D
227 . S ^PRC(443.75,"AL1",X,Z055,Z19,Z1,DA)=""
228 . ;
229 . ; WENT UP A LEVEL -- NEED TO REMOVE SENDER FROM LOWER LEVEL
230 . ;
231 . S Z03=$P(Z0,U,4) ;FIELD 3
232 . S Z0=$P(Z0,U,7) ;FIELD 6
233 . K:Z03]""&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)
234 . Q
235 Q
236 ;
237K9 ; KILL 'AL1X25' X-REF -- CALLED FROM FIELD 25. LEVEL 2
238 ; ACTUALLY WILL KILL 'AL1' X-REF.
239 ;
240 N Z0,Z03,Z055,Z1,Z19
241 S Z0=$G(^PRC(443.75,DA,0))
242 S Z055=$P(Z0,U,11) ;FIELD 5.5
243 S Z1=$G(^PRC(443.75,DA,1))
244 S Z19=$P(Z1,U) ;FIELD 9
245 S Z1=$P(Z1,U,2) ;FIELD 10
246 I Z055>0&(Z19]"")&(Z1>0) D
247 . K ^PRC(443.75,"AL1",X,Z055,Z19,Z1,DA)
248 . ;
249 . ; NOW LETS RESTORE 'AJ1' X-REF FOR THIS RECORD.
250 . ;
251 . S Z03=$P(Z0,U,4) ;FIELD 3
252 . S Z0=$P(Z0,U,7) ;FIELD 6
253 . S:Z03]""&(Z055>0)&(Z0>0) ^PRC(443.75,"AJ1",1,Z055,Z03,Z0,DA)=""
254 . Q
255 Q
256 ;
257S10 ; SET 'ALX9' X-REF -- CALLED FROM FIELD 9. LEVEL 2
258 ; ACTUALLY WILL SET 'AL' X-REF.
259 ;
260 N Z0,Z03,Z1,Z110,Z125
261 S Z1=$G(^PRC(443.75,DA,1))
262 S Z110=$P(Z1,U,2) ;FIELD 10
263 S Z125=$P(Z1,U,17) ;FIELD 25
264 I Z110>0&(Z125=2) D
265 . S ^PRC(443.75,"AL",Z125,X,Z110,DA)=""
266 . ;
267 . ; WENT UP A LEVEL -- NEED TO REMOVE LOWER LEVEL.
268 . ;
269 . S Z0=$G(^PRC(443.75,DA,0))
270 . S Z03=$P(Z0,U,4) ;FIELD 3
271 . S Z0=$P(Z0,U,7) ;FIELD 6
272 . K:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)
273 . Q
274 Q
275 ;
276K10 ; KILL 'ALX9' X-REF -- CALLED FROM FIELD 9. LEVEL 2
277 ; ACTUALLY WILL KILL 'AL' X-REF.
278 ;
279 N Z0,Z03,Z1,Z110,Z125
280 S Z1=$G(^PRC(443.75,DA,1))
281 S Z110=$P(Z1,U,2) ;FIELD 10
282 S Z125=$P(Z1,U,17) ;FIELD 25
283 I Z110>0&(Z125=2) D
284 . K ^PRC(443.75,"AL",Z125,X,Z110,DA)
285 . ;
286 . ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
287 . ;
288 . S Z0=$G(^PRC(443.75,DA,0))
289 . S Z03=$P(Z0,U,4) ;FIELD 3
290 . S Z0=$P(Z0,U,7) ;FIELD 6
291 . S:Z03]""&(Z0>0) ^PRC(443.75,"AJ",1,Z03,Z0,DA)=""
292 . Q
293 Q
Note: See TracBrowser for help on using the repository browser.