source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOEDI2.m@ 701

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

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