source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOESE.m@ 1211

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

initial load of WorldVistAEHR
File size: 6.3 KB
RevLine 
[613]1PRCOESE ;WISC/DJM-IFCAP EDI POA Server Interface ; [8/31/98 1:55pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4SERV N A,AA,AC,ACD,B,CC,CU,CU1,CU2,C1L,DA,DC,DIE,DR,EE,ERR,FOB,G,G1,I,IT
5 N KD,KP,L,LINE,LN,MPN,M1,N,N1,N1L,N2,N2L,N3,N3L,PC,PN,PO,PO1,PPM,PPT
6 N PRC,PRCNO,PRCOI,PU,QT,QTFLG,RP,S1,UC,UC1,UC2,UNIT,UP,UPN,VP,V1,V2
7 N X,X1,X2,PRCTC,PRCX,RECORD,STATION,STCK,VENDOR
8 K ERR
9 ;
10 ;If QTFLG=1, processing stops because the error is serious
11 ;
12 S (QTFLG,LN)=0
13 F S LN=$O(^PRCF(423.6,PRCDA,1,LN)) QUIT:'LN G:QTFLG>0 S1 D MAIN
14 ;
15 QUIT
16 ;
17MAIN ;Start processing the POA segments
18 ;
19 S LINE=^(LN,0)
20 I LINE["$" D S1 QUIT ;End of this record. Stop and process any errors.
21 ;
22 S A=$P(LINE,U)
23 S AA="SEG"_$S(A="ISM":"1",A="HE":"2",A="VE":"3",A="AC":"4",A="ST":"5",A="IT":"6",A="DE":"7",A="AK":"8",A="CO":"9",1:"10")
24 ;
25 D @AA ;Process segment
26 ;
27 QUIT
28 ;
29SEG1 S B=$P(LINE,U,4)
30 G:B'="POA" SEG10
31 S CC=$P(LINE,U,7)
32 F Q:$A(CC,$L(CC))'=32 S CC=$E(CC,1,$L(CC)-1)
33 S CC=$E(CC,1,3)_"-"_$E(CC,4,$L(CC))
34 S ERR(CC,0)=""
35 S STATION=$P(LINE,U,3)
36 S STCK=$O(^PRC(411,"B",STATION,0))
37 I STCK'>0 S ERR("STATION")=STATION,QTFLG=1 Q
38 S PO=$O(^PRC(442,"B",CC,0))
39 S:PO="" ERR(CC,0)="*",QTFLG=1
40 Q:QTFLG>0
41 S PO1=$G(^PRC(442,PO,1))
42 S:PO1="" ERR(CC,0)="*",QTFLG=1
43 Q:QTFLG>0
44 S PPM=$P(PO1,U,10)
45 D BUL^PRCOESE1
46 ;
47 ; GATHER DATA FROM CONTROL SEGMENT.
48 ;
49 S PRCTC=$P(LINE,U,4)
50 S X1=$E($P(LINE,U,5),1,4)-1700_"0101"
51 S X2=$E($P(LINE,U,5),5,7)-1
52 D C^%DTC
53 S PRCX=X_"."_$P(LINE,U,6)
54 ;
55 QUIT ;Exit the SEG1 sub routine
56 ;
57SEG2 QUIT
58 ;
59SEG3 ; GET DATA FROM "VE" SEGMENT.
60 S VENDOR=$P(LINE,U,2)
61 ;
62 ; NOW LETS FIND THE PROPER RECORD IN FILE 443.75.
63 ;
64 ;Austin did not provide the Vendor_Id. Use the PO to get it.
65 I VENDOR="" D QUIT:QTFLG=1
66 . N PO,IEN
67 . S PO=CC ;PO number
68 . S IEN=$O(^PRC(442,"B",PO,"")) ;Get IEN
69 . S VENDOR=$P($G(^PRC(442,IEN,1)),U) ;Internal_Vendor_Number
70 . S VENDOR=$P($G(^PRC(440,VENDOR,3)),U,3) ;Vendor_Id
71 . I VENDOR'="" QUIT ;Vendor_Id (yes)
72 . S $P(ERR("VENDOR"),U)="*",QTFLG=1 ;Vendor_Id (no)
73 . ;
74 S RECORD=$O(^PRC(443.75,"AO","PHA",CC,VENDOR,0))
75 I RECORD="" S $P(ERR("RECORD"),U)="*",QTFLG=1
76 ;
77 QUIT ;Exit the SEG3 sub routine
78 ;
79SEG4 S ERR(CC,"AC")=""
80 I $P(LINE,U,3)]"" D ;
81 . S FOB=$G(^PRC(442,PO,1))
82 . S:FOB="" ERR(CC,"AC")="*"
83 . S:$P(FOB,U,6)="" ERR(CC,"AC")="*"
84 . I $P(FOB,U,6)'=$P(LINE,U,3) S $P(ERR(CC,"AC"),U,2)="*"
85 . Q
86 . ;
87 I $P(LINE,U,3)="" D ;
88 . S FOB=$G(^PRC(442,PO,1))
89 . S:$P(FOB,U,6)'="" $P(ERR(CC,"AC"),U,3)="*"
90 . Q
91 . ;
92 S KP=$P(LINE,U,5)
93 S KD=$P(LINE,U,6)
94 S (EE,G1,PC)=""
95 S AC=$G(^PRC(442,PO,5,0))
96 S:AC="" $P(ERR(CC,"AC"),U,4)="*"
97 S:$P(AC,U,4)'>0 $P(ERR(CC,"AC"),U,4)="*"
98 Q:$P(ERR(CC,"AC"),U,4)]""
99 F ACD=1:1:$P(AC,U,4) D ;
100 . S PPT(ACD)=$G(^PRC(442,PO,5,ACD,0))
101 . I +$P(PPT(ACD),U)=$P(PPT(ACD),U) S EE=$S(EE]"":EE_"^"_ACD,1:ACD)
102 . Q
103 . ;
104 I EE]"" D ;
105 . S G=$P(EE,U)
106 . S PC=$P(PPT(ACD),U)/100
107 . S G1=$P(PPT(ACD),U,2)
108 . Q
109 . ;
110 I KP]"",PC'>0 S $P(ERR(CC,"AC"),U,7)="*"
111 I EE]"",KP]"",KP'=PC S $P(ERR(CC,"AC"),U,5)="*"
112 I KD]"",G1="" S $P(ERR(CC,"AC"),U,8)="*"
113 I EE]"",KD]"",KD'=G1 S $P(ERR(CC,"AC"),U,6)="*"
114 I KP="",PC>0 S $P(ERR(CC,"AC"),U,9)="*"
115 I KD="",G1>0 S $P(ERR(CC,"AC"),U,10)="*"
116 ;
117 QUIT ;Exit the SEG4 sub routine
118 ;
119SEG5 QUIT
120 ;
121SEG6 ;Process the "IT" segment from Austin
122 S B=$P(LINE,U,2) ;item line number
123 I B'>0 S $P(ERR(CC,.5),U,13)="*" Q
124 S ERR(CC,B)=""
125 S IT=$O(^PRC(442,PO,2,"B",B,0))
126 S:IT="" $P(ERR(CC,B),U,2)="*"
127 Q:IT=""
128 S IT=$G(^PRC(442,PO,2,IT,0))
129 S:IT="" $P(ERR(CC,B),U,2)="*"
130 Q:IT=""
131 S VP=$P(IT,U,6)
132 S:VP="" $P(ERR(CC,B),U,3)="*"
133 S:$E(VP,1)="#" VP=$E(VP,2,99)
134 S:VP'=$P(LINE,U,5) $P(ERR(CC,B),U,9)="*"
135 S QT=$P(IT,U,2)
136 S:QT="" $P(ERR(CC,B),U,5)="*"
137 S QT=QT\1+(QT#1>0)_"00"
138 S:QT'=$P(LINE,U,8) $P(ERR(CC,B),U,10)="*"
139 S PN=$P(LINE,U,6) ;Product number
140 I PN]"" D ;
141 . S RP=$P(IT,U,5)
142 . S:RP="" $P(ERR(CC,B),U,8)="*"
143 . I RP]"" D ;
144 . . S MPN=$G(^PRC(441,RP,3))
145 . . S:MPN="" $P(ERR(CC,B),U,8)="*"
146 . . I MPN]"" D ;
147 . . . S MPN=$P(MPN,U,5)
148 . . . S:$E(MPN,1)="#" MPN=$E(MPN,2,99)
149 . . . S:MPN'=PN $P(ERR(CC,B),U,8)="*"
150 . . . Q
151 . . Q
152 . Q
153 . ;
154 S DC=$P(LINE,U,7) ;Get the National drug code
155 I DC]"" D
156 . S N=$P(IT,U,15)
157 . S:N="" $P(ERR(CC,B),U,4)="*"
158 . I N]"" D
159 . . S N1=$P(N,"-")
160 . . S N2=$P(N,"-",2)
161 . . S N3=$P(N,"-",3)
162 . . S N1="000000"_N1
163 . . S N1L=$L(N1)
164 . . S N1=$E(N1,N1L-5,N1L)
165 . . S N2="0000"_N2
166 . . S N2L=$L(N2)
167 . . S N2=$E(N2,N2L-3,N2L)
168 . . S N3="00"_N3
169 . . S N3L=$L(N3)
170 . . S N3=$E(N3,N3L-1,N3L)
171 . . S N=N1_N2_N3
172 . . S:N'=DC $P(ERR(CC,B),U,4)="*"
173 . . Q
174 . Q
175 . ;
176 S UC=$P(LINE,U,10) ;Get the unit cost
177 S UC1=$E(UC,1,$L(UC)-4)
178 S UC2=$E(UC,$L(UC)-3,99)
179 S UC1=$E(UC1+1000000,2,7)
180 I UC2="0000" S UC=UC1_UC2 G S6B
181 S UC2="."_UC2
182 S UC2=$E($E(UC2+.005,2,3)_"0000",1,4)
183 S UC=UC1_UC2
184S6B S CU=$P(IT,U,9)
185 S:CU="" $P(ERR(CC,B),U,7)="*"
186 G:CU="" S6A
187 I CU]"",CU="N/C" D G S6A
188 . S CU="0000000000"
189 . S:UC'=CU $P(ERR(CC,B),U,12)="*"
190 . Q
191 . ;
192 S CU1=$P(CU,".")
193 S CU2=$P(CU,".",2)
194 S CU1="000000"_CU1
195 S C1L=$L(CU1)
196 S CU1=$E(CU1,C1L-5,C1L)
197 S CU2=CU2_"0000"
198 S CU2=$E(CU2,1,4)
199 S CU=CU1_CU2
200 S:UC'=CU $P(ERR(CC,B),U,12)="*"
201S6A S PU=$P(LINE,U,9) ;Get the unit of purchase
202 S UP=$P(IT,U,3)
203 S:UP="" $P(ERR(CC,B),U,6)="*"
204 I UP]"" D ;
205 . S UPN=$G(^PRCD(420.5,UP,0))
206 . S:UPN="" $P(ERR(CC,B),U,6)="*"
207 . I UPN]"" S UNIT=$P(UPN,U) S:UNIT'=PU $P(ERR(CC,B),U,11)="*"
208 . Q
209 . ;
210 S DA(1)=PO
211 S DIE="^PRC(442,DA(1),2,"
212 S DR="12///@;12.5///@;13///@;13.5///@"
213 S DA=B
214 D ^DIE
215 S PRC(1,443.75,"?+1,",.01)=$P($G(^PRC(443.75,RECORD,0)),U)
216 S PRC(1,443.75,"?+1,",23)=PRCTC
217 S PRC(1,443.75,"?+1,",24)=PRCX
218 I $G(ERR(CC,B))]"" D ;
219 . S PRC(1,443.75,"?+1,",19)="E"
220 . S PRC(1,443.75,"?+1,",20)=ERR(CC,B)
221 . Q
222 . ;
223 D UPDATE^DIE("","PRC(1)")
224 ;
225 QUIT ;Exit the SEG6 sub routine
226 ;
227SEG7 QUIT
228 ;
229SEG8 K DIE,DA,DR
230 S B=$P(LINE,U,2)
231 I B'>0 S $P(ERR(CC,.5),U,13)="*" Q
232 S B=$O(^PRC(442,PO,2,"B",B,0))
233 I B'>0 S $P(ERR(CC,B),U,2)="*" Q
234 S DA(1)=PO
235 S DA=B
236 S DIE="^PRC(442,DA(1),2,"
237 I $P($G(ERR(CC,B)),U,2)="" D ;
238 . S V1=$P(LINE,U,3)
239 . S V2=$P(LINE,U,4)
240 . S:$P(^PRC(442,PO,2,B,2),U,9)="" DR="12///^S X=V1;12.5///^S X=V2"
241 . S:'$D(DR) DR="13///^S X=V1;13.5///^S X=V2"
242 . D ^DIE
243 . Q
244 . ;
245 QUIT ;Exit the SEG8 sub routine
246 ;
247SEG9 QUIT
248 ;
249SEG10 S ERR("SEG")=A,QTFLG=1
250 ;
251 QUIT ;Exit the SEG10 sub routine
252 ;
253S1 D ^PRCOESE1
254 ;
255 QUIT
Note: See TracBrowser for help on using the repository browser.