source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVIBH.m@ 1120

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1PRCVIBH ;WOIFO/DST - Issue Book Processing, from DynaMed to IFCAP ;7/26/05 17:10
2 ;;5.1;IFCAP;**81,86**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; IV - Internal Voucher, SV - Standard Voucher
6 Q
7CRT ; Process Issue Book transactions sent from DynaMed to IFCAP
8 K HLERR
9 N %,PRCVDT,PRCVI,PRCVJ,PRCVK,PRCVIBF,PRCVSUB,PRCVSITE
10 D:'$D(U) DT^DICRW
11 D NOW^%DTC S PRCVDT=%
12 S PRCVSUB="PRCVFMS2;"_HL("MID")
13 K ^TMP(PRCVSUB),^TMP($J,"PRCVIB")
14 F PRCVI=1:1 X HLNEXT Q:HLQUIT'>0 D
15 . S ^TMP($J,"PRCVIB",PRCVI)=HLNODE,PRCVJ=0
16 . F S PRCVJ=$O(HLNODE(PRCVJ)) Q:'PRCVJ S ^TMP($J,"PRCVIB",PRCVI,PRCVJ)=HLNODE(PRCVJ)
17 . Q
18 ;
19MAIN ; Main routine
20 ; Check HL7 message type and message event
21 ; PRCVEA - Error message array
22 ; PRCVTDT - Transaction Date
23 ; PRCVDAC - Document Action
24 N PRCVFS,PRCVRS,PRCVCS,PRCVES,PRCVSS,PRCVCC,PRCVSCC
25 N PRCVEA,PRCVTDT,PRCVBID,PRCVLID,PRCVND,PRCVSEG,PRCVY,X,X1,X2
26 ;
27 S PRCVK=0
28 S PRCVFS=$G(HL("FS")),PRCVCS=$E($G(HL("ECH"))),PRCVRS=$E($G(HL("ECH")),2),PRCVES=$E($G(HL("ECH")),U,3),PRCVSS=$E($G(HL("ECH")),U,4)
29 ;
30HEADER I HL("MTN")'="DFT"!(HL("ETN")'="P03") D Q
31 . D ADDERR("PRCV1"_U_"Wrong Message or Event Type: "_HL("MTN")_U_HL("ETN"))
32 . D GENACK("AR",HL("MID"),PRCVDT,.PRCVEA)
33 . Q
34 ;
35 S X1=$P(PRCVDT,"."),X2=14 D C^%DTC
36 S ^TMP(PRCVSUB,$J,0)=X_U_$P(PRCVDT,".")_"^IB Sent from DynaMed to IFCAP"
37 ;
38 ; Check each segments - EVN,PID,FT1
39 ; PRCVTCD - Transaction Code - "IV" or "SV"
40 ; PRCVSTN - Station Number
41 ;
42START N PREVSEG,PRCVSTN,PRCVDAC,PRCVTDT,PRCVTCD
43 S PRCVSITE=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
44 S PREVSEG=""
45 S PRCVI=0
46 D NOW^%DTC S PRCVDT=%
47 F S PRCVI=$O(^TMP($J,"PRCVIB",PRCVI)) Q:'PRCVI D
48 . S PRCVND=$G(^TMP($J,"PRCVIB",PRCVI))
49 . S PRCVSEG=$P(PRCVND,PRCVFS)
50 . Q:PRCVSEG="MSH"!(PRCVSEG="")
51 . I $$CHKSEQ(PRCVSEG) K ^TMP($J,"PRCVIB") S PRCVI="" Q
52 . S PREVSEG=PRCVSEG
53 . D @PRCVSEG
54 . Q
55 I PRCVSEG'="FT1" D ADDERR("PRCV1"_U_"No Item line for this transaction.")
56 ;
57 ; If errored, send AE ACK, clean up and QUIT
58ERR I $D(PRCVEA)!(PRCVTCD']"") D XTMP("AE"),FIN Q
59OK ; Calling IFCAP and FMS routines for Issue Book and FMS update
60 ;
61 I PRCVTCD="SV" D
62 . I '$$ENT^PRCVFMS2(PRCVSUB) D
63 .. D ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
64 .. D XTMP("AE")
65 .. Q
66 . Q
67 I PRCVTCD="IV" D
68 . S PRCVIBF=$$INIT^PRCVIBF(PRCVSUB)
69 . ; PRCVIBF - return "IEN of 410^Error Code^Error Description"
70 . ; If errored, move ^TMP to ^XTMP and quit
71 . I '+PRCVIBF D Q
72 .. D ADDERR("PRCV3"_U_$P(PRCVIBF,U,2)_"-"_$P(PRCVIBF,U,3))
73 .. D XTMP("AE")
74 .. Q
75 . I '$$ENT^PRCVFMS1(PRCVSUB,+PRCVIBF) D
76 .. D ADDERR("PRCV3"_U_"Error in generating FMS Code Sheet.")
77 .. D XTMP("AE")
78 .. Q
79 . Q
80 ;
81 I '$D(PRCVEA) D GENACK("AA",HL("MID"),PRCVDT)
82 D FIN
83 Q
84 ;
85CHKSEQ(SEG) ; SEG - Segment name
86 N SEGERR,PREV1,PREV2,PRCVER1
87 S SEGERR=0
88 S PREV1=$P($P($T(@(SEG_1)),";;",2),U)
89 S PREV2=$P($P($T(@(SEG_1)),";;",2),U,2)
90 I PREVSEG=PREV1!(PREVSEG=PREV2) Q SEGERR
91 S SEGERR=1
92 S PRCVER1=$P($P($T(@(SEG_1)),";;",2),U,4)_SEG
93 D ADDERR("PRCV1"_U_PRCVER1)
94 Q SEGERR
95 ;
96EVN ; Process EVN segment
97 ;
98 S PRCVSTN=$P(PRCVND,PRCVFS,8)
99 I PRCVSTN']"" D ADDERR("PRCV2"_U_"Station Number is missing.",8)
100 I PRCVSTN'=PRCVSITE D ADDERR("PRCV2"_U_"Invalid Station Number: "_PRCVSTN,8)
101 S PRCVDAC=$P(PRCVND,PRCVFS,5)
102 I "EMX"'[PRCVDAC!(PRCVDAC']"") D ADDERR("PRCV2"_U_"Invalid Document Action: "_PRCVDAC,5)
103 S PRCVTDT=$P(PRCVND,PRCVFS,3)
104 I PRCVTDT']"" D ADDERR("PRCV2"_U_"Transaction Date is missing.",3) Q
105 S PRCVTDT=$$HL7TFM^XLFDT(PRCVTDT,"L",0)
106 I $P(PRCVTDT,".")>PRCVDT D ADDERR("PRCV2"_U_"Invalid Transaction Date: "_PRCVTDT,3)
107 Q
108 ;
109PID ; Process PID segment
110 ;
111 N PRCVDUZ,PRCVFCP1,PRCVFCP2,PRCVBOC,PRCVTERM
112 ;
113 S PRCVBID=$P(PRCVND,PRCVFS,4)
114 I PRCVBID']"" D ADDERR("PRCV2"_U_"Batch ID is missing.",4)
115 S PRCVTCD=$P(PRCVND,PRCVFS,5)
116 I PRCVTCD']"" D ADDERR("PRCV2"_U_"Transaction Code is missing.",5)
117 I PRCVTCD'="IV",(PRCVTCD'="SV") D ADDERR("PRCV2"_U_"Invalid Transaction Code: "_PRCVTCD,5)
118 ; Check User ID, Termination Date and is authorized FCP user
119 S PRCVDUZ=$P(PRCVND,PRCVFS,3)
120 I PRCVDUZ']"" D ADDERR("PRCV2"_U_"User ID is missing.",3)
121 I PRCVDUZ]"" D
122 . I '$$FIND1^DIC(200,"","","`"_PRCVDUZ,"","","PRCVERR") D ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
123 . E D
124 .. S PRCVTERM=$$GET1^DIQ(200,PRCVDUZ_",",9.2,"I")
125 .. I +PRCVTERM>0,(PRCVTERM<DT) D ADDERR("PRCV2"_U_"Invalid User ID: "_PRCVDUZ,3)
126 .. Q
127 .Q
128 S PRCVFCP1=$P(PRCVND,PRCVFS,22)
129 I PRCVFCP1']"" D ADDERR("PRCV2"_U_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point is missing.",22)
130 I '$D(^PRC(420,PRCVSITE,1,+PRCVFCP1)) D ADDERR("PRCV2"_U_"Invalid "_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point.",22)
131 I $D(^PRC(420,PRCVSITE,1,+PRCVFCP1)),$P(^PRC(420,PRCVSITE,1,+PRCVFCP1,0),U,19) D ADDERR("PRCV2"_U_"Inactivated "_$S(PRCVTCD="IV":"Seller's",1:"Warehouse's")_" Fund Control Point.",22)
132 I PRCVTCD="IV" D
133 . S PRCVFCP2=$P(PRCVND,PRCVFS,24)
134 . I PRCVFCP2']"" D ADDERR("PRCV2"_U_"Buyer's Fund Control Point is missing.",24)
135 . E D
136 .. I '$D(^PRC(420,PRCVSITE,1,+PRCVFCP2)) D ADDERR("PRCV2"_U_"Invalid Buyer's Fund Control Point.",24)
137 .. I $D(^PRC(420,PRCVSITE,1,+PRCVFCP2)),$P(^PRC(420,PRCVSITE,1,+PRCVFCP2,0),U,19) D ADDERR("PRCV2"_U_"Inactivated Buyer's Fund Control Point.",24)
138 .. Q
139 . S PRCVCC=$P(PRCVND,PRCVFS,19)
140 . I PRCVCC']"" D ADDERR("PRCV2"_U_"Buyer's Cost Center is missing.",19)
141 . S PRCVSCC=$P(PRCVND,PRCVFS,20)
142 . I PRCVSCC']"" D ADDERR("PRCV2"_U_"Buyer's Sub-cost Center is missing.",20)
143 . I PRCVCC,(PRCVSCC'="") D
144 .. I '$D(^PRCD(420.1,PRCVCC_PRCVSCC)) D ADDERR("PRCV2"_U_"Invalid Buyer's Cost Center. Cost Center not defined in Cost Center file 420.1",19) Q
145 .. I '$D(^PRC(420,PRCVSTN,1,+PRCVFCP2,2,PRCVCC_PRCVSCC)) D ADDERR("PRCV2"_U_"Invalid Buyer's Cost Center. Cost Center not used for this Fund Control Point.",19)
146 .. Q
147 . Q
148 I PRCVDUZ]"",('$D(^PRC(420,PRCVSTN,1,$S(PRCVTCD="IV":+PRCVFCP2,1:+PRCVFCP1),1,PRCVDUZ))) D ADDERR("PRCV2"_U_"Unauthorized User for this FCP.",3)
149 S ^TMP(PRCVSUB,$J,1)=PRCVSTN_U_PRCVBID_U_PRCVTCD_U_PRCVDAC_U_PRCVTDT_U_PRCVDUZ
150 S ^TMP(PRCVSUB,$J,2)=PRCVFCP1_U_$G(PRCVFCP2)_U_$G(PRCVCC)_U_$G(PRCVSCC)
151 Q
152 ;
153FT1 ; Process FT1 segment
154 N PRCVACC,PRCVBOC,PRCVINV,PRCVSAL,PRCVRCD
155 ;
156 S PRCVLID=$P(PRCVND,PRCVFS,3)
157 I 'PRCVLID D ADDERR("PRCV2"_U_"Line ID is missing.",3)
158 S PRCVACC=$P(PRCVND,PRCVFS,9)
159 I 'PRCVACC D ADDERR("PRCV2"_U_"Account Code is missing.",9)
160 I PRCVACC,((PRCVACC'?1N)!("12368"'[PRCVACC)) D ADDERR("PRCV2"_U_"Invalid Account Code: "_PRCVACC,9)
161 I PRCVTCD="IV" D
162 . S PRCVBOC=$P(PRCVND,PRCVFS,10)
163 . I PRCVBOC=2696 D ADDERR("PRCV2"_U_"Invalid Buyer's Budget Object Code: "_PRCVBOC,10)
164 . I 'PRCVBOC D ADDERR("PRCV2"_U_"Budget Object Code is missing.",10)
165 . I '$D(^PRCD(420.1,PRCVCC_PRCVSCC,1,PRCVBOC)) D ADDERR("PRCV2"_U_"Invalid Budget Object Code for this Cost Center: "_PRCVBOC,10)
166 . I $P($G(^PRCD(420.2,PRCVBOC,0)),"^",2)=1 D ADDERR("PRCV2"_U_"Inactivated Budget Object Code: "_PRCVBOC,10)
167 . S PRCVSAL=$P(PRCVND,PRCVFS,13)
168 . I 'PRCVSAL D ADDERR("PRCV2"_U_"Sale Value is missing.",13)
169 . Q
170 S PRCVINV=$P(PRCVND,PRCVFS,12)
171 I 'PRCVINV D ADDERR("PRCV2"_U_"Inventory Value is missing.",12)
172 I PRCVTCD="SV" D
173 . S PRCVRCD=$P(PRCVND,PRCVFS,8)
174 . I PRCVRCD']"" D ADDERR("PRCV2"_U_"Reason Code is missing.",8)
175 . I PRCVRCD'?1N!(PRCVRCD<1)!(PRCVRCD>7) D ADDERR("PRCV2"_U_"Invalid Reason Code: "_PRCVRCD,8)
176 . Q
177 S ^TMP(PRCVSUB,$J,3,0)=PRCVLID
178 S ^TMP(PRCVSUB,$J,3,PRCVLID,0)=PRCVLID_U_PRCVACC_U_$G(PRCVBOC)_U_PRCVINV_U_$G(PRCVSAL)_U_$G(PRCVRCD)
179 Q
180 ;
181GENACK(PRCVAC,PRCVMCID,PRCVDT,PRCVOCCR) ;
182 ;
183 ;PRCVAC - Acknowledgment Code
184 ;PRCVMCID - Message Control ID which you're acknowledging
185 ;PRCVDT - Date/Time of Transaction
186 ;PRCVOCCR - Error message array
187 ;
188 N PRCVFS,PRCVCNT,PRCVCS,PRCVI,PRCVJ,PRCVND,PRCVRES
189 ;
190 S PRCVFS=$G(HL("FS")),PRCVCS=$E($G(HL("ECH"))),PRCVRS=$E($G(HL("ECH")),2),PRCVES=$E($G(HL("ECH")),U,3),PRCVSS=$E($G(HL("ECH")),U,4)
191 S PRCVRES="",PRCVJ=0,PRCVI=1
192 ;
193 ; MSA Segment
194 S HLA("HLA",1)="MSA"_PRCVFS_PRCVAC_PRCVFS_PRCVMCID_PRCVFS_$G(PRCVBID)
195 ;
196 ; ERR Segment
197 I $G(PRCVOCCR)'="" D
198 . F S PRCVJ=$O(PRCVOCCR(PRCVJ)) Q:'PRCVJ D
199 .. S PRCVI=PRCVI+1
200 .. S HLA("HLA",PRCVI)="ERR"_PRCVFS_PRCVOCCR(PRCVJ)
201 .. Q
202 . Q
203 ;
204 D GENACK^HLMA1(HL("EID"),$G(HLMTIENS),HL("EIDS"),"LM",1,PRCVRES)
205 I $P($G(PRCVRES),U,2) D
206 . K XMB,XMZ
207 . S XMB="PRCV HL7 ERROR"
208 . S XMB(1)="PRCVIB"
209 . S XMB(2)="Application Acknowledgement"
210 . S XMB(3)="PRCV_IFCAP_06_SU_IB_PROC"
211 . S XMB(4)=PRCVRES
212 . S XMDUZ="PRCV HL7 Generator"
213 . D ^XMB
214 . K XMB,XMDUZ,XMZ
215 . Q
216 ;
217 K HLA("HLA"),^TMP("HLA",$J)
218 K PRCVAC,X
219 Q
220 ;
221ADDERR(PRCVER,PRCVFD) ;
222 ; PRCVER - Error message
223 ; PRCVFD - Field number, if any
224 ;
225 S PRCVK=PRCVK+1
226 S PRCVEA=PRCVK
227 S:'$G(PRCVLID) PRCVLID=1
228 S:'$G(PRCVFD) PRCVLID="",PRCVFD=""
229 S PRCVEA(PRCVK)=PRCVFS_$G(PRCVSEG)_U_PRCVLID_U_PRCVFD_PRCVFS_"207^Application Internal Error^HL70357"_PRCVFS_"E"_PRCVFS_PRCVER_PRCVFS_PRCVLID
230 Q
231 ;
232XTMP(AC) ; Move ^TMP(PRCVSUB,$j) to ^XTMP
233 ;
234 ; AC - Acknowledgement
235 ;
236 S ^XTMP(PRCVSUB,0)=$$FMADD^XLFDT(PRCVDT,14)_U_PRCVDT_U_"IB Data from DynaMed with error"
237 F PRCVI=1,2 S ^XTMP(PRCVSUB,PRCVI)=^TMP(PRCVSUB,$J,PRCVI)
238 I $D(^TMP(PRCVSUB,$J,3,0)) D
239 . S ^XTMP(PRCVSUB,3,0)=^TMP(PRCVSUB,$J,3,0)
240 . S PRCVI=0
241 . F S PRCVI=$O(^TMP(PRCVSUB,$J,3,PRCVI)) Q:'PRCVI D
242 .. S ^XTMP(PRCVSUB,3,PRCVI)=^TMP(PRCVSUB,$J,3,PRCVI,0)
243 .. Q
244 D GENACK(AC,HL("MID"),PRCVDT,.PRCVEA)
245 S ^XTMP(PRCVSUB,4,0)=PRCVEA
246 S PRCVI=0
247 F S PRCVI=$O(PRCVEA(PRCVI)) Q:'PRCVI D
248 . S ^XTMP(PRCVSUB,4,PRCVI)=PRCVEA(PRCVI)
249 . Q
250 Q
251 ;
252FIN ; Clean up
253 ;
254 ; K ^TMP($J,"PRCVIB")
255 ; K ^TMP(PRCVSUB,$J)
256 K PRCVEA
257 Q
258 ;
259TXT ;
260EVN1 ;;^EVN^^Missing segment ^100^Missing line item info.
261PID1 ;;EVN^^^Missing segment ^100^Missing line item info.
262FT11 ;;PID^FT1^^Missing segment ^100^Missing line item info.
Note: See TracBrowser for help on using the repository browser.