source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOEDIS.m@ 1801

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

initial load of WorldVistAEHR
File size: 6.7 KB
RevLine 
[613]1PRCOEDIS ;WISC/DJM-IFCAP X-REF ROUTINE FOR FILE 443.75 ; [8/31/98 1:24pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5S1 ; SET 'AC' X-REF -- CALLED FROM FIELD 1. RFQ
6 N N0
7 S N0=$G(^PRC(443.75,DA,0))
8 I $P(N0,U,4)="RFQ",$P(N0,U,6)]"",$P(N0,U,10)]"" S ^PRC(443.75,"AC",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,10),DA)=""
9 Q
10 ;
11K1 ; KILL 'AC' X-REF -- CALLED FROM FIELD 1. RFQ
12 N N0
13 S N0=$G(^PRC(443.75,DA,0))
14 I $P(N0,U,4)="RFQ",$P(N0,U,6)]"",$P(N0,U,10)]"" K ^PRC(443.75,"AC",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,10),DA)
15 Q
16 ;
17S2 ; SET 'AD' X-REF -- CALLED FROM FIELD 3. RFQ
18 ; ACTUALLY WILL SET 'AC' X-REF.
19 N N0
20 S N0=$G(^PRC(443.75,DA,0))
21 I $P(N0,U,2)]"",$P(N0,U,6)]"",$P(N0,U,10)]"",X="RFQ" S ^PRC(443.75,"AC",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,10),DA)=""
22 Q
23 ;
24K2 ; KILL 'AD' X-REF -- CALLED FROM FIELD 3. RFQ
25 ; ACTUALLY WILL KILL 'AC' X-REF.
26 N N0
27 S N0=$G(^PRC(443.75,DA,0))
28 I $P(N0,U,2)]"",$P(N0,U,6)]"",$P(N0,U,10)]"",X="RFQ" K ^PRC(443.75,"AC",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,10),DA)
29 Q
30 ;
31S3 ; SET 'AE' X-REF -- CALLED FROM FIELD 5. RFQ
32 ; ACTUALLY WILL SET 'AC' X-REF.
33 N N0
34 S N0=$G(^PRC(443.75,DA,0))
35 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,10)]"" S ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,10),DA)=""
36 Q
37 ;
38K3 ; KILL 'AE' X-REF -- CALLED FROM FIELD 5. RFQ
39 ; ACTUALLY WILL KILL 'AC' X-REF.
40 N N0
41 S N0=$G(^PRC(443.75,DA,0))
42 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,10)]"" K ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,10),DA)
43 Q
44 ;
45S4 ; SET 'AF' X-REF -- CALLED FROM FIELD 1. TXT
46 N N0
47 S N0=$G(^PRC(443.75,DA,0))
48 I $P(N0,U,3)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" S ^PRC(443.75,"AF",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,3),DA)=""
49 Q
50 ;
51K4 ; KILL 'AF' X-REF -- CALLED FROM FIELD 1. TXT
52 N N0
53 S N0=$G(^PRC(443.75,DA,0))
54 I $P(N0,U,3)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" K ^PRC(443.75,"AF",$P(N0,U,4),X,$P(N0,U,6),$P(N0,U,3),DA)
55 Q
56 ;
57S5 ; SET 'AG' X-REF -- CALLED FROM FIELD 2. TXT
58 ; ACTUALLY WILL SET 'AF' X-REF.
59 N N0
60 S N0=$G(^PRC(443.75,DA,0))
61 I $P(N0,U,2)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" S ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)=""
62 Q
63 ;
64K5 ; KILL 'AG' X-REF -- CALLED FROM FIELD 2. TXT
65 ; ACTUALLY WILL KILL 'AF' X-REF.
66 N N0
67 S N0=$G(^PRC(443.75,DA,0))
68 I $P(N0,U,2)]"",$P(N0,U,4)="TXT",$P(N0,U,6)]"" K ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)
69 Q
70 ;
71S6 ; SET 'AH' X-REF -- CALLED FROM FIELD 3. TXT
72 ; ACTUALLY WILL SET 'AF' X-REF.
73 N N0
74 S N0=$G(^PRC(443.75,DA,0))
75 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,6)]"",X="TXT" S ^PRC(443.75,"AF",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,3),DA)=""
76 Q
77 ;
78K6 ; KILL 'AH' X-REF -- CALLED FROM FIELD 3. TXT
79 ; ACTUALLY WILL KILL 'AF' X-REF.
80 N N0
81 S N0=$G(^PRC(443.75,DA,0))
82 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,6)]"",X="TXT" K ^PRC(443.75,"AF",X,$P(N0,U,2),$P(N0,U,6),$P(N0,U,3),DA)
83 Q
84 ;
85S7 ; SET 'AI' X-REF -- CALLED FROM FIELD 5. TXT
86 ; ACTUALLY WILL SET 'AF' X-REF.
87 N N0
88 S N0=$G(^PRC(443.75,DA,0))
89 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,4)="TXT" S ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,3),DA)=""
90 Q
91 ;
92K7 ; KILL 'AI' X-REF -- CALLED FROM FIELD 5. TXT
93 ; ACTUALLY WILL KILL 'AF' X-REF.
94 N N0
95 S N0=$G(^PRC(443.75,DA,0))
96 I $P(N0,U,2)]"",$P(N0,U,3)]"",$P(N0,U,4)="TXT" K ^PRC(443.75,"AF",$P(N0,U,4),$P(N0,U,2),X,$P(N0,U,3),X,DA)
97 Q
98 ;
99S8 ; SET 'AN' X-REF -- CALLED FROM FIELD 6.5. RFQ
100 ; ACTUALLY WILL SET 'AC' X-REF.
101 N N0
102 S N0=$G(^PRC(443.75,DA,0))
103 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,6)]"" S ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)=""
104 Q
105 ;
106K8 ; KILL 'AN' X-REF -- CALLED FROM FIELD 6.5. RFQ
107 ; ACTUALLY WILL KILL 'AC' X-REF.
108 N N0
109 S N0=$G(^PRC(443.75,DA,0))
110 I $P(N0,U,2)]"",$P(N0,U,4)="RFQ",$P(N0,U,6)]"" K ^PRC(443.75,"AC",$P(N0,U,4),$P(N0,U,2),$P(N0,U,6),X,DA)
111 Q
112 ;
113S9 ; SET 'AO' X-REF -- CALLED FROM FIELD 1. PHA
114 N N0
115 S N0=$G(^PRC(443.75,DA,0))
116 I $P(N0,U,4)="PHA",$P(N0,U,6)]"" S ^PRC(443.75,"AO",$P(N0,U,4),X,$P(N0,U,6),DA)=""
117 Q
118 ;
119K9 ; KILL 'AO' X-REF -- CALLED FROM FIELD 1. PHA
120 N N0
121 S N0=$G(^PRC(443.75,DA,0))
122 I $P(N0,U,4)="PHA",$P(N0,U,6)]"" K ^PRC(443.75,"AO",$P(N0,U,4),X,$P(N0,U,6),DA)
123 Q
124 ;
125S10 ; SET 'AP' X-REF -- CALLED FROM FIELD 3. PHA
126 ; ACTUALLY WILL SET 'AO' X-REF.
127 N N0
128 S N0=$G(^PRC(443.75,DA,0))
129 I X="PHA",$P(N0,U,2)]"",$P(N0,U,6)]"" S ^PRC(443.75,"AO",X,$P(N0,U,2),$P(N0,U,6),DA)=""
130 Q
131 ;
132K10 ; KILL 'AP' X-REF -- CALLED FROM FIELD 3. PHA
133 ; ACTUALLY WILL KILL 'AO' X-REF.
134 N N0
135 S N0=$G(^PRC(443.75,DA,0))
136 I X="PHA",$P(N0,U,2)]"",$P(N0,U,6)]"" K ^PRC(443.75,"AO",X,$P(N0,U,2),$P(N0,U,6),DA)
137 Q
138 ;
139S11 ; SET 'AQ' X-REF -- CALLED FROM FIELD 5. PHA
140 ; ACTUALLY WILL SET 'AO' X-REF.
141 N N0
142 S N0=$G(^PRC(443.75,DA,0))
143 I $P(N0,U,2)]"",$P(N0,U,4)="PHA" S ^PRC(443.75,"AO",$P(N0,U,4),$P(N0,U,2),X,DA)=""
144 Q
145 ;
146K11 ; KILL 'AQ' X-REF -- CALLED FROM FIELD 5. PHA
147 ; ACTUALLY WILL KILL 'AO' X-REF.
148 N N0
149 S N0=$G(^PRC(443.75,DA,0))
150 I $P(N0,U,2)]"",$P(N0,U,4)="PHA" K ^PRC(443.75,"AO",$P(N0,U,4),$P(N0,U,2),X,DA)
151 Q
152 ;
153S12 ; SET 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.
154 ; CALLED FROM FIELD 10.
155 ;
156 ; SEE IF FIELD 24 IS SET. IF SO DON'T SET THIS X-REF.
157 ;
158 S Z0=$G(^PRC(443.75,DA,1))
159 S Z1=$P(Z0,U)
160 S Z17=$P(Z0,U,17)
161 I Z1]""&(Z17=2) D
162 . S ^PRC(443.75,"AL",Z17,Z1,+$E(X,1,30),DA)=""
163 . ;
164 . ; NOW KILL 'AJ' X-REF FOR THIS RECORD.
165 . ;
166 . S Z0=$G(^PRC(443.75,DA,0))
167 . S Z4=$P(Z0,U,4)
168 . S Z7=$P(Z0,U,7)
169 . ;
170 . ; THE 1 AFTER "AJ" IS THE LEVEL.
171 . ;
172 . K:Z4]""&(Z7>0) ^PRC(443.75,"AJ",1,Z4,+$E(Z7,1,30),DA)
173 . Q
174 K Z0,Z1,Z4,Z7,Z17
175 Q
176 ;
177K12 ; KILL 'AL' X-REF FOR ALL ACCEPTED OR REJECTED TRANSACTIONS.
178 ; CALLED FROM FIELD 10.
179 ;
180 S Z0=$G(^PRC(443.75,DA,1))
181 S Z17=$P(Z0,U,17)
182 S Z1=$P(Z0,U)
183 I Z17=2&(Z1]"") D
184 . K ^PRC(443.75,"AL",2,Z1,+$E(X,1,30),DA)
185 . ;
186 . ; NOW LETS RESTORE 'AJ' X-REF FOR THIS RECORD.
187 . ;
188 . S Z0=$G(^PRC(443.75,DA,0))
189 . S Z4=$P(Z0,U,4)
190 . S Z7=$P(Z0,U,7)
191 . ;
192 . ; THE 1 AFTER "AJ" IS THE LEVEL.
193 . ;
194 . S:Z4]""&(Z7>0) ^PRC(443.75,"AJ",1,Z4,+$E(Z7,1,30),DA)=""
195 . Q
196 K Z0,Z1,Z4,Z7
197 Q
198 ;
199S13 ; SET 'AM' X-REF FOR ALL POA TRANSACTIONS.
200 ; CALLED FROM FIELD 24.
201 ;
202 S Z0=$G(^PRC(443.75,DA,1))
203 S Z1=$P(Z0,U)
204 S Z2=$P(Z0,U,2)
205 S Z15=$P(Z0,U,15)
206 S Z17=$P(Z0,U,17)
207 I Z17=3&(Z15]"") D
208 . S ^PRC(443.75,"AM",3,Z15,+$E(X,1,30),DA)=""
209 . ;
210 . ; NOW KILL 'AL' X-REF FOR THIS RECORD.
211 . ; THE 2 AFTER "AL" IS THE LEVEL.
212 . ;
213 . K:Z1]""&(Z2>0) ^PRC(443.75,"AL",2,Z1,+$E(Z2,1,30),DA)
214 . Q
215 K Z0,Z1,Z2,Z15
216 Q
217 ;
218K13 ; KILL 'AM' X-REF FOR ALL POA TRANSACTIONS.
219 ; CALLED FROM FIELD 24.
220 ;
221 S Z0=$G(^PRC(443.75,DA,1))
222 S Z1=$P(Z0,U)
223 S Z2=$P(Z0,U,2)
224 S Z15=$P(Z0,U,15)
225 S Z17=$P(Z0,U,17)
226 I Z15]""&(Z17=3) D
227 . K ^PRC(443.75,"AM",Z17,Z15,+$E(X,1,30),DA)
228 . ;
229 . ; NOW SET 'AL' X-REF FOR THIS RECORD.
230 . ; THE 2 AFTER "AL" IS THE LEVEL.
231 . ;
232 . S:Z1]""&(Z2>0) ^PRC(443.75,"AL",2,Z1,+$E(Z2,1,30),DA)=""
233 . Q
234 K Z0,Z1,Z2,Z15
235 Q
Note: See TracBrowser for help on using the repository browser.