source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHLO1A.m@ 1005

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

initial load of WorldVistAEHR
File size: 7.7 KB
Line 
1PRCHLO1A ;WOIFO/RLL-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 12/19/05 11:17am
2V ;;5.1;IFCAP;**83**;; Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; Continuation of PRCHLO1. This program builds the extracts for
5 ; the Master PO Table and the associated multiples
6POMAST ; PoMaster Table
7 Q
8PODISCW ; Write PO Discount table data
9 N GPOID,GPOND
10 S GPOID=0,GPOND=""
11 F S GPOID=$O(^TMP($J,"PODISC",GPOID)) Q:GPOID="" D
12 . F S GPOND=$O(^TMP($J,"PODISC",GPOID,GPOND)) Q:GPOND="" D
13 . . W $G(^TMP($J,"PODISC",GPOID,GPOND))
14 . . W !
15 . . Q
16 . Q
17 W !
18 Q
19PODISC ;
20 ;PoDiscount Table 442.03A (multiple)
21 ; ^PRC(442,POID,3,0)=^442.03A
22 N CKDS,PPO,PPOVAL,CKDS1,V1,V2,V3,V4,V5,V6
23 S CKDS=$G(^PRC(442,POID,3,0)),PPO=0
24 S CKDS1=$P(CKDS,U,3)
25 I +CKDS1>0 D ; Contains at least one discount, create rec.
26 . D LPPODIS
27 . Q
28 Q
29PO2237 ; 2237RefNum Table
30 N CK2237,PPO,PPOVAL,CK2237A,PPV4E1,PPV4E2
31 S CK2237=$G(^PRC(442,POID,13,0)),PPO=0
32 S CK2237A=$P(CK2237,U,3)
33 I +CK2237A>0 D ; Contains at least one 2237#, create rec
34 . D LP2237
35 Q
36POBOC ; PoBoc Table
37 N CKBS,PPO,PPOVAL,PPOVAL1,CKBS1
38 S CKBS=$G(^PRC(442,POID,22,0)),PPO=0
39 S CKBS1=$P(CKBS,U,3)
40 I +CKBS1>0 D ; Contains at lease one BOC, create rec.
41 . D LPPOBC
42 Q
43POAMT ; PO Amount table (multiple)
44 N POAMT,POAMT1,POAMT2,POAMT3,POAMT4,V1,V2,V3
45 N V1E,V1E1,V1E2,V2E,V2E1,V2E2,VE,VE1,VE2
46 S POAMT=$G(^PRC(442,POID,9,0))
47 S POAMT1=$P(POAMT,U,3)
48 I +POAMT1>0 D
49 . S POAMT2=0
50 . F S POAMT2=$O(^PRC(442,POID,9,POAMT2)) Q:POAMT2="" D
51 . . Q:+POAMT2<0
52 . . S POAMT3=$G(^PRC(442,POID,9,POAMT2,0))
53 . . Q:POAMT3=""
54 . . ; For V1-V3, Get the node, $P the data, pad with "^" delimiters
55 . . ; get external value for TypeCode
56 . . S VE=$P(POAMT3,U,2)
57 . . I VE'="" S VE1=$G(^PRCD(420.6,+VE,0)),VE2=$P(VE1,U,1)
58 . . I VE="" S VE2=""
59 . . ; get external value for CompStatus Business
60 . . S V1E=$P(POAMT3,U,4)
61 . . I V1E'="" S V1E1=$G(^PRCD(420.6,+V1E,0)),V1E2=$P(V1E1,U,1)
62 . . I V1E="" S V1E2=""
63 . . ;
64 . . S V1=$P(POAMT3,U,1)_U_VE2_U_V1E2_U
65 . . ; Get external value for PrefProgram
66 . . S V2E=$P(POAMT3,U,5)
67 . . I V2E'="" S V2E1=$G(^PRCD(420.6,+V2E,0)),V2E2=$P(V2E1,U,1)
68 . . I V2E="" S V2E2=""
69 . . S V2=V2E2_U_$P(POAMT3,U,3),V3=V1_V2
70 . . S POAMT4=PPOKEY_U_POAMT2_U_V3
71 . . I +POAMT2>0 S ^TMP($J,"POAMT",POID,POAMT2,0)=POAMT4
72 . . D PAMBCD ; Po Amount Breakout code
73 . . Q
74 . Q
75 Q
76PAMBCD ; PO Amount Breakout code
77 N PAMBC,PAMBC1,PAMBC2,PAMBC3,PAMBC4,VBCE,VBCE1,VBCE2
78 S PAMBC=0,PAMBC1=0,PAMBC2=0,PAMBC3=0
79 S PAMBC=$G(^PRC(442,POID,9,POAMT2,1,0))
80 S PAMBC1=$P(PAMBC,U,3)
81 I +PAMBC1>0 D
82 . F S PAMBC2=$O(^PRC(442,POID,9,POAMT2,1,PAMBC2)) Q:PAMBC2="" D
83 . . Q:+PAMBC2<0
84 . . S PAMBC3=$G(^PRC(442,POID,9,POAMT2,1,PAMBC2,0))
85 . . ;
86 . . ; get external value for breakout code
87 . . S VBCE=$P(PAMBC3,U,1)
88 . . I VBCE'="" S VBCE1=$G(^PRCD(420.6,+VBCE,0)),VBCE2=$P(VBCE1,U,1)
89 . . I VBCE="" S VBCE2=""
90 . . S PAMBC4=PPOKEY_U_POAMT2_U_PAMBC2_U_VBCE2
91 . . I +PAMBC2>0 S ^TMP($J,"POBKCOD",POID,POAMT2,PAMBC2,0)=PAMBC4
92 . . Q
93 . Q
94 Q
95POAMMD ; PO Amendment Table (multiple)
96 N POAMD,POAMD1,POAMD2,POAMD3,POAMD3A,POAMD4,V1,V2,V3,V2E,V2E1,V2E2
97 N V3E,V3E1,V3E2,V1E,V1E1,V1E2
98 S POAMD=$G(^PRC(442,POID,6,0))
99 S POAMD1=$P(POAMD,U,3)
100 I +POAMD1>1 D
101 . S POAMD2=0
102 . F S POAMD2=$O(^PRC(442,POID,6,POAMD2)) Q:POAMD2="" D
103 . . Q:+POAMD<0
104 . . S POAMD3=$G(^PRC(442,POID,6,POAMD2,0))
105 . . S POAMD3A=$G(^PRC(442,POID,6,POAMD2,1))
106 . . ; V1-V3, $Get the data, $P the values, pad with "^" delimiters
107 . . ; get external date for EffectiveDate
108 . . S V1E=$P(POAMD3,U,2),V1E1=$P(V1E,".",1)
109 . . I V1E'="" S V1E2=$$FMTE^XLFDT(V1E1)
110 . . I V1E="" S V1E2=""
111 . . S V1=$P(POAMD3,U,1)_U_V1E2_U_$P(POAMD3,U,3)_U
112 . . ; get external value for pAPPMaUthorizedBuyer
113 . . S V2E=$P(POAMD3A,U,1)
114 . . I V2E'="" S V2E1=$G(^VA(200,+V2E,0)),V2E2=$P(V2E1,U,1)
115 . . I V2E="" S V2E2=""
116 . . ; get external value for AmendmentAdjustment
117 . . S V3E=$P(POAMD3A,U,4)
118 . . I V3E'="" S V3E1=$G(^PRCD(442.3,+V3E,0)),V3E2=$P(V3E1,U,1)
119 . . I V3E="" S V3E2=""
120 . . S V2=V2E2_U_V3E2,V3=V1_V2
121 . . S POAMD4=PPOKEY_U_POAMD2_U_V3
122 . . I +POAMD2>0 S ^TMP($J,"POAMMD",POID,POAMD2,0)=POAMD4
123 . . D POAMCH ; Check for Amendment Changes
124 . . D POAMDS ; Check for Amendment Description
125 . . Q
126 . Q
127 Q
128POAMCH ; PO Amendment Changes Table (mulitple)
129 N POAMC,POAMC1,POAMC2,POAMC3,POAMC4,POAMC5,POAMC6
130 S POAMC=$G(^PRC(442,POID,6,POAMD2,3,0))
131 S POAMC1=$P(POAMC,U,3)
132 I +POAMC1>1 D
133 . S POAMC2=0
134 . F S POAMC2=$O(^PRC(442,POID,6,POAMD2,3,POAMC2)) Q:POAMC2="" D
135 . . S POAMC3=$G(^PRC(442,POID,6,POAMD2,3,POAMC2,0))
136 . . S POAMC4=$P(POAMC3,U,1),POAMC5=$P(POAMC3,U,2)
137 . . S POAMC6=PPOKEY_U_POAMD2_U_POAMC2_U_POAMC4_U_POAMC5
138 . . I +POAMC2>0 S ^TMP($J,"POAMMDCH",POID,POAMD2,POAMC2,0)=POAMC6
139 . . Q
140 . Q
141 Q
142POAMDS ; PO Amendment Description Table
143 N POADD,POADD1,POADD2,POADD3,POADD4
144 S POADD=$G(^PRC(442,POID,6,POAMD2,2,0))
145 I $D(POADD) D
146 . S POADD1=0
147 . F S POADD1=$O(^PRC(442,POID,6,POAMD2,2,POADD1)) Q:POADD1="" D
148 . . S POADD2=$G(^PRC(442,POID,6,POAMD2,2,POADD1,0)) ; mult
149 . . S POADD3=PPOKEY_U_POAMD2_U_POADD1_U_POADD2
150 . . Q:+POADD1>1 ; Get the 1st "1"
151 . . I +POAMD2>0 S ^TMP($J,"POAMMDDES",POID,POAMD2,POADD1,0)=POADD3
152 . . Q
153 . Q
154 Q
155POCMTS ; PocommentsTable
156 N POCMTS,POCMTS1
157 S POCMTS=$G(^PRC(442,POID,4,1,0)) ; 1st line
158 S POCMTS1=$E(POCMTS,1,175) ; Get the 1st 175 Chars
159 ; Get the 1st 175 Char of 1st comment only
160 I POCMTS'="" S ^TMP($J,"POCOMMENTS",POID)=PPOKEY_U_1_U_POCMTS1
161 Q
162PORMKS ; PoRemarks Table
163 N PORMKS,PORMKS1
164 S PORMKS=$G(^PRC(442,POID,16,1,0)) ; 1st Line, 1st Comment
165 S PORMKS1=$E(PORMKS,1,175) ; Get the 1st 175 Chars
166 ; gET 1st 175 Characters of 1st remark
167 I PORMKS'="" S ^TMP($J,"POREMARKS",POID)=PPOKEY_U_1_U_PORMKS1
168 Q
169LPPODIS ; Loop on PO Discount
170 I CKDS1>0 D
171 . F S PPO=$O(^PRC(442,POID,3,PPO)) Q:PPO="" D
172 . . S PPOVAL=$G(^PRC(442,POID,3,PPO,0))
173 . . S V1=$P(PPOVAL,U,1)_U_$P(PPOVAL,U,2)_U ; disc itm & %$tot
174 . . S V2=$P(PPOVAL,U,3)_U_$P(PPOVAL,U,4)_U ; DiscAmt & ItmCt
175 . . S V3=$P(PPOVAL,U,5)_U_$P(PPOVAL,U,6) ; contract & lineItem
176 . . S V4=V1_V2_V3 ; all data
177 . . S PPOVAL1=PPOKEY_U_PPO_U_V4
178 . . S ^TMP($J,"PODISC",POID,PPO)=PPOVAL1
179 . . Q
180 . Q
181 Q
182LPPOBC ; Loop PoBoc Table
183 F S PPO=$O(^PRC(442,POID,22,PPO)) Q:PPO="" D
184 . Q:PPO="B" ; don't want B index
185 . S PPOVAL=$G(^PRC(442,POID,22,PPO,0))
186 . S PPOVAL1=$P(PPOVAL,U,1)_U_$P(PPOVAL,U,2)
187 . S PPOVAL2=PPOKEY_U_PPO_U_PPOVAL1
188 . S ^TMP($J,"POBOC",POID,PPO)=PPOVAL2
189 . Q
190 Q
191LP2237 ; Loop 2237
192 N PPOVAL,PPV1,PPV2,PPV3,PPV4,PPV5,PPV6,PPV7,PPVALL,POKEY,PPOVAL2
193 N PPV1E,PPV1E1,PPV2E,PPV2E1,PPV4E1,PPV4E2,PPV7E,PPV7E1,PPV7E2
194 N PPV3E,PPV3E1
195 F S PPO=$O(^PRC(442,POID,13,PPO)) Q:PPO="" D
196 . S PPOVAL=$G(^PRC(442,POID,13,PPO,0))
197 . S PPV1=$P(PPOVAL,U,1),PPV2=$P(PPOVAL,U,2),PPV3=$P(PPOVAL,U,4)
198 . ; external value for 2237 PPV1
199 . I PPV1'="" S PPV1E=$G(^PRCS(410,+PPV1,0)),PPV1E1=$P(PPV1E,U,1)
200 . I PPV1="" S PPV1E1=""
201 . ; exeternal value for AccountableOfficer PPV2
202 . I PPV2'="" S PPV2E=$G(^VA(200,+PPV2,0)),PPV2E1=$P(PPV2E,U,1)
203 . I PPV2="" S PPV2E1=""
204 . ; ext. date value for Date Signed
205 . I PPV3'="" S PPV3E=$P(PPV3,".",1),PPV3E1=$$FMTE^XLFDT(PPV3E)
206 . I PPV3="" S PPV3E1=""
207 . S PPV4=$P(PPOVAL,U,5),PPV5=$P(PPOVAL,U,9),PPV6=$P(PPOVAL,U,10)
208 . ; external for Purchasing agent PPV4
209 . ;
210 . I PPV4'="" S PPV4E1=$G(^VA(200,+PPV4,0)),PPV4E2=$P(PPV4E1,U,1)
211 . I PPV4="" S PPV4E2=""
212 . ; get external value for InvDistPoint
213 . S PPV7E=$P(PPOVAL,U,11)
214 . I PPV7E'="" S PPV7E1=$G(^PRCP(445,+PPV7E,0)),PPV7E2=$P(PPV7E1,U,1)
215 . I PPV7E="" S PPV7E2=""
216 . S PPV7=PPV7E2
217 . S PPVALL=PPV1E1_U_PPV2E1_U_PPV3E1_U_PPV4E2_U_PPV5_U_PPV6_U_PPV7
218 . ;
219 . S PPOVAL2=PPOKEY_U_PPO_U_PPVALL
220 . S ^TMP($J,"PO2237",POID,PPO)=PPOVAL2
221 . Q
222 Q
223PODISCH ; PO Discount Header File
224 ; Header file for PO Discount Multiple
225 W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
226 W "DiscountIdNum^DiscountItem^PercentDollarAmount^"
227 W "DiscountAmount^ItemCount^Contract^LineItem",!
228 Q
Note: See TracBrowser for help on using the repository browser.