source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVIMF.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1PRCVIMF ;WOIFO/DST - DynaMed ITEM update HL7 messaging interface; 03/07/05
2 ;;5.1;IFCAP;**81**;Oct 20,2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6 ;
7EN(PRCVIN) ;Entry point for API Call
8 ;
9 N PRCVSEG,PRCVFLD,PRCVFS,PRCVCS,PRCVRS,PRCVI,PRCVN,PRCVCON
10 N PRCVDT1,PRCVDUZ,PRCVND0,PRCVND2,PRCVND3,PRCVSTN,PRCVUP,PRCVERR
11 N PRCVDP,PRCVPRO
12 K HLA
13 ;
14 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 Q
15 I $D(PRCVIN)=0 Q
16 S PRCVN=0
17 D HDRBLD
18 I $G(PRCVERR) D FIN Q
19 D MSGBLD
20 ;
21 S PRCVDP=""
22 D GENERATE^HLMA(PRCVPRO,"LM",1,.PRCVDP)
23 I +$P(PRCVDP,U,2) S PRCVERR(1)="Error generating message through VistA HL7 package for ITEM Update with ITEM # "_PRCVIN D CLIFP
24 D FIN
25 ;
26 Q
27 ;
28HDRBLD ;Generate message header, MFI Segment
29 ;
30 K HL S PRCVPRO="PRCV_IFCAP_05_EV_ITEM_UPD"
31 D INIT^HLFNC2(PRCVPRO,.HL)
32 I $G(HL) S PRCVERR(1)="Error generating message through VistA HL7 package for ITEM Update involving ITEM # "_PRCVIN D CLIFP Q
33 S PRCVCS=$E(HL("ECH")),PRCVRS=$E(HL("ECH"),2),PRCVFS=HL("FS")
34 ;
35 ;PRCVDT Transaction Date/Time w/offset
36 D NOW^%DTC
37 S PRCVDT=$$FMTHL7^XLFDT(%)
38 ;
39 ;Build MFI Segment
40 S PRCVN=PRCVN+1
41 S HLA("HLS",PRCVN)="MFI"_PRCVFS_"OME"_PRCVFS_"441"_PRCVCS_"ITEM MASTER"_PRCVFS_"UPD"_PRCVFS_PRCVDT_PRCVFS_PRCVFS_"AL"
42 ;
43 Q
44 ;
45MSGBLD ; Build Message Body
46 ; PRCVFLD - Field
47 ;
48 ; ITEM short description
49 S PRCVND0=^TMP("PRCVIT",$J,PRCVIN,0)
50 S PRCVFLD=$$CONV^PRCVUTSC($P(PRCVND0,U,2),"C",HLFS_HLECH)
51 ; Station Number
52 S PRCVSTN=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
53 ;
54 ; MFE segment
55 ;
56 S PRCVN=PRCVN+1
57 S HLA("HLS",PRCVN)="MFE"_PRCVFS_"MUP"_PRCVFS_PRCVIN_PRCVFS_PRCVDT_PRCVFS_PRCVIN_PRCVCS_PRCVFLD_PRCVCS_PRCVSTN_PRCVFS_"CE"
58 ;
59 ; ZIT segment
60 ;
61 N PRCVN1,PRCVNM
62 S PRCVN=PRCVN+1
63 S PRCVN1=1
64 S PRCVND3=$G(^TMP("PRCVIT",$J,PRCVIN,3))
65 ; Case/Cart Tray/instrument kit
66 S HLA("HLS",PRCVN)="ZIT"_PRCVFS_PRCVSTN_PRCVFS_$P(PRCVND0,U,6)_PRCVFS
67 ; Description (Word Processing field)
68 I $D(^TMP("PRCVIT",$J,PRCVIN,1)) D
69 . S PRCVFLD=$$CONV^PRCVUTSC(^TMP("PRCVIT",$J,PRCVIN,1,1),"C",HLFS_HLECH)
70 . S HLA("HLS",PRCVN,PRCVN1)=PRCVFLD
71 . S PRCVI=1
72 . F S PRCVI=$O(^TMP("PRCVIT",$J,PRCVIN,1,PRCVI)) Q:'PRCVI D
73 .. S PRCVN1=PRCVN1+1
74 .. S HLA("HLS",PRCVN,PRCVN1)=PRCVRS_$$CONV^PRCVUTSC(^TMP("PRCVIT",$J,PRCVIN,1,PRCVI),"C",HLFS_HLECH)
75 .. Q
76 . Q
77 S PRCVSEG=PRCVFS
78 ; FSC
79 S PRCVSEG=PRCVSEG_$P(PRCVND0,U,3)_PRCVFS
80 ; National Stock Number
81 S PRCVSEG=PRCVSEG_$P(PRCVND0,U,5)_PRCVFS
82 ; National Stock Number Verified Date
83 I $P(PRCVND3,U,6)'="" S PRCVSEG=PRCVSEG_$$FMTHL7^XLFDT($P(PRCVND3,U,6))
84 S PRCVSEG=PRCVSEG_PRCVFS
85 ; Hazardous Material
86 S PRCVSEG=PRCVSEG_$P(PRCVND0,U,14)_PRCVFS
87 S PRCVFLD=""
88 ; Last Vendor Ordered
89 I $P(PRCVND0,U,4)'="" S PRCVFLD=$P(PRCVND0,U,4)_PRCVCS_$P(^PRC(440,$P(PRCVND0,U,4),0),U)_PRCVCS_PRCVSTN
90 S PRCVSEG=PRCVSEG_PRCVFLD_PRCVFS
91 ; Mandatory Source
92 S PRCVFLD=""
93 I $P(PRCVND0,U,7)'="" S PRCVFLD=$P(PRCVND0,U,7)_PRCVCS_$P(^PRC(440,$P(PRCVND0,U,7),0),U)_PRCVCS_PRCVSTN
94 S PRCVSEG=PRCVSEG_PRCVFLD_PRCVFS
95 ; Budget Object Code
96 S PRCVSEG=PRCVSEG_$P(PRCVND0,U,9)_PRCVFS
97 ; Created/Inactivated By
98 S PRCVDUZ=$P(PRCVND0,U,10)
99 S PRCVDT1=""
100 I PRCVDUZ]"" D
101 . I $P(PRCVND0,U,8)]"" S PRCVDT1=$$FMTHL7^XLFDT($P(PRCVND0,U,8))
102 . S PRCVNM("FILE")=200,PRCVNM("FIELD")=.01,PRCVNM("IENS")=PRCVDUZ_","
103 . S PRCVFLD=$P($$HLNAME^XLFNAME(.PRCVNM," ","^"),"^",1,2)
104 . S PRCVFLD=PRCVDUZ_PRCVCS_$P(PRCVFLD,"^")_PRCVCS_$P(PRCVFLD,"^",2)_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVSTN_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVDT1
105 . I ($P(PRCVND3,U)]"")!($P(PRCVND3,U,3)]"") D
106 .. S PRCVDUZ=$P(PRCVND3,U,3)
107 .. S PRCVDT1=""
108 .. S PRCVSEG=PRCVSEG_PRCVFLD_PRCVRS
109 .. I $P(PRCVND3,U,2)]"" S PRCVDT1=$$FMTHL7^XLFDT($P(PRCVND3,U,2))
110 .. S PRCVNM("FILE")=200,PRCVNM("FIELD")=.01,PRCVNM("IENS")=PRCVDUZ_","
111 .. S PRCVFLD=$P($$HLNAME^XLFNAME(.PRCVNM," ","^"),"^",1,2)
112 .. S PRCVFLD=PRCVDUZ_PRCVCS_$P(PRCVFLD,"^")_PRCVCS_$P(PRCVFLD,"^",2)_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVSTN_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVDT1
113 .. Q
114 . S PRCVSEG=PRCVSEG_PRCVFLD
115 . Q
116 S PRCVSEG=PRCVSEG_PRCVFS
117 ; Replacement Item
118 I $P(PRCVND3,U,4)>0 D
119 . S PRCVFLD=$$CONV^PRCVUTSC($P(^PRC(441,$P(PRCVND3,U,4),0),U,2),"C",HLFS_HLECH)
120 . S PRCVFLD=$P(PRCVND3,U,4)_PRCVCS_PRCVFLD_PRCVCS_PRCVSTN
121 . S PRCVSEG=PRCVSEG_PRCVFLD
122 . Q
123 S PRCVSEG=PRCVSEG_PRCVFS
124 ; MFG Part No.
125 S PRCVSEG=PRCVSEG_$P(PRCVND3,U,5)_PRCVFS
126 ; Food Group
127 S PRCVSEG=PRCVSEG_$P(PRCVND3,U,7)_PRCVFS
128 ; Stock Keeping Unit - SKU (required field in DynaMed)
129 S PRCVFLD=$P(PRCVND3,U,8)
130 ; If no SKU in IFCAP, set default to "EACH"
131 I PRCVFLD']"" S PRCVFLD=$O(^PRCD(420.5,"C","EACH",0))
132 S PRCVFLD=$P(^PRCD(420.5,PRCVFLD,0),U)_PRCVCS_$P(^PRCD(420.5,PRCVFLD,0),U,2)_PRCVCS_"IFCAP"
133 S PRCVSEG=PRCVSEG_PRCVFLD_PRCVFS
134 ; Drug Type Code
135 S PRCVSEG=PRCVSEG_$P(PRCVND3,U,9)_PRCVFS
136 ; Reusable Item Indicator
137 S PRCVSEG=PRCVSEG_$P(PRCVND0,U,11)_PRCVFS
138 ; Standard Industrial Classification Code - SIC Code
139 S PRCVSEG=PRCVSEG_$P(PRCVND3,U,10)_PRCVFS
140 ;
141 S PRCVN1=PRCVN1+1
142 S HLA("HLS",PRCVN,PRCVN1)=PRCVSEG
143 ; Pre_NIF_Long Description (Word Processing field)
144 S PRCVFLD=""
145 I $D(^TMP("PRCVIT",$J,PRCVIN,6)) D
146 . S PRCVN1=PRCVN1+1
147 . S PRCVFLD=$$CONV^PRCVUTSC(^TMP("PRCVIT",$J,PRCVIN,6,1),"C",HLFS_HLECH)
148 . S HLA("HLS",PRCVN,PRCVN1)=PRCVFLD
149 . S PRCVI=1
150 . F S PRCVI=$O(^TMP("PRCVIT",$J,PRCVIN,6,PRCVI)) Q:'PRCVI D
151 .. S PRCVN1=PRCVN1+1
152 .. S HLA("HLS",PRCVN,PRCVN1)=PRCVRS_$$CONV^PRCVUTSC(^TMP("PRCVIT",$J,PRCVIN,6,PRCVI),"C",HLFS_HLECH)
153 .. Q
154 . Q
155 S HLA("HLS",PRCVN,PRCVN1)=HLA("HLS",PRCVN,PRCVN1)_PRCVFS
156 ; NIF Item Number
157 ; Last part of ZIT Segment
158 I $P($G(PRCVND0),U,13) D
159 . S PRCVN1=PRCVN1+1
160 . S HLA("HLS",PRCVN,PRCVN1)=$P(PRCVND0,U,13)
161 . Q
162 ;
163 ; ZCP segments
164 ;
165 S PRCVSEG=""
166 S PRCVI=0
167 F S PRCVI=$O(^TMP("PRCVIT",$J,PRCVIN,4,PRCVI)) Q:'PRCVI D
168 . S PRCVSEG=^TMP("PRCVIT",$J,PRCVIN,4,PRCVI)
169 . S PRCVSEG=$P(PRCVSEG,U)_PRCVFS_$P(PRCVSEG,U,2)_PRCVFS_$P(PRCVSEG,U,3)
170 . I $P(PRCVSEG,"|",3)]"" S PRCVSEG=PRCVSEG_PRCVCS_$P(^PRC(440,$P(PRCVSEG,"|",3),0),U)_PRCVCS_PRCVSTN
171 . S PRCVN=PRCVN+1
172 . S HLA("HLS",PRCVN)="ZCP"_PRCVFS_PRCVSEG
173 . Q
174 I $D(^TMP("PRCVIT",$J,PRCVIN,2)) D
175 . S PRCVI=0
176 . F S PRCVI=$O(^TMP("PRCVIT",$J,PRCVIN,2,PRCVI)) Q:'PRCVI D ZVI
177 . Q
178 ;
179 Q
180 ;
181 ; Clean trailing BAR "|" - not used for now
182BAR ;
183 ; N PRCVL,PRCVL1
184 ; S PRCVI=2
185 ; F S PRCVI=$O(HLA("HLS",PRCVI)) Q:'PRCVI D
186 ; . S PRCVL=$L(HLA("HLS",PRCVI))
187 ; . F PRCVL1=PRCVL:-1 Q:PRCVL1<0 D
188 ; .. I $E(HLA("HLS",PRCVI),PRCVL1)'="|" S PRCVL1=0 Q
189 ; .. S HLA("HLS",PRCVI)=$E(HLA("HLS",PRCVI),1,PRCVL1-1)
190 ; .. Q
191 ; . Q
192 Q
193 ;
194ZVI ; ZVI segment
195 ;
196 ; Vendor
197 S PRCVSEG=""
198 S PRCVND2=^TMP("PRCVIT",$J,PRCVIN,2,PRCVI)
199 S PRCVSEG="ZVI"_PRCVFS_$P(PRCVND2,U)_PRCVCS_$P(^PRC(440,$P(PRCVND2,U),0),U)_PRCVCS_PRCVSTN
200 ; Vendor Stock Number
201 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,4)
202 ; National Drug Code
203 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,5)
204 ; Contract
205 S PRCVSEG=PRCVSEG_PRCVFS
206 I $P(PRCVND2,U,3)]"" D
207 . S PRCVCON=$G(^PRC(440,$P(PRCVND2,U),4,$P(PRCVND2,U,3),0))
208 . S PRCVSEG=PRCVSEG_$P(PRCVCON,U)_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_PRCVCS_$$FMTHL7^XLFDT($P(PRCVCON,U,2))
209 . Q
210 ; Unit Cost
211 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,2)_PRCVCS_"USD"
212 ; Date of Unit Price
213 S PRCVSEG=PRCVSEG_PRCVFS
214 I $P(PRCVND2,U,6)]"" S PRCVSEG=PRCVSEG_$$FMTHL7^XLFDT($P(PRCVND2,U,6))
215 ; Unit of Purchase - required field in DynaMed
216 S PRCVSEG=PRCVSEG_PRCVFS
217 ; If no Unit of Purchase in IFCAP, set default to "EACH"
218 I $P(PRCVND2,U,7)="" S $P(PRCVND2,U,7)=$O(^PRCD(420.5,"C","EACH",0))
219 S PRCVUP=^PRCD(420.5,$P(PRCVND2,U,7),0)
220 S PRCVSEG=PRCVSEG_$P(PRCVUP,U)_PRCVCS_$P(PRCVUP,U,2)_PRCVCS_"IFCAP"
221 ; Packaging Multiple
222 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,8)
223 ; Unit of Conversion Factor
224 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,10)
225 ; Required Order Multiple
226 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,11)
227 ; Minimum Order Quantity
228 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,12)
229 ; Maximum Order Quantity
230 S PRCVSEG=PRCVSEG_PRCVFS_$P(PRCVND2,U,9)
231 ;
232 S PRCVN=PRCVN+1
233 S HLA("HLS",PRCVN)=PRCVSEG
234 Q
235 ;
236 ;
237MFKPROC ;Process MFK^M01 response message
238 ;
239 ;Uses HLNEXT twice to bypass the MSH segment and go directly to the MSA segment
240 N VAL
241 X HLNEXT
242 X HLNEXT
243 S VAL=$$FLD^HLCSUTL(HLNODE,2)
244 I VAL'="AA" D ERROR
245 D FIN
246 Q
247 ;
248ERROR ;Process ERR Segments
249 N N,PRCVERM,PRCVIT
250 S PRCVERC=0 F N=1:1 X HLNEXT Q:HLQUIT'>0 D
251 . S VAL=$$FLD^HLCSUTL(HLNODE,1)
252 . I VAL="MFA" S PRCVIT=$P($$FLD^HLCSUTL(HLNODE,6),U)
253 . I VAL="ERR" D
254 .. S PRCVERC=PRCVERC+1
255 .. S PRCVERM=$$FLD^HLCSUTL(HLNODE,6)
256 .. S PRCVERR(PRCVERC)="Unable to update item in DynaMed during an ITEM Update to the Inventory System the following error(s) occurred:"
257 .. S PRCVERC=PRCVERC+1
258 .. S PRCVERR(PRCVERC)=$P(PRCVERM,U,2)
259 .. Q
260 . Q
261 ;
262 D CLIFP
263 Q
264 ;
265CLIFP ;Call partner app w/ mail message for users on error
266 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
267 S XMSUB="Item Number: "_PRCVIT_" - Inventory System ITEM Update Errors "_$$HTE^XLFDT($H)
268 S XMDUZ="IFCAP/COTS Inventory Interface"
269 S XMTEXT="PRCVERR("
270 S XMY("G.PRCV Item Vendor Edits")=""
271 D ^XMD
272 Q
273 ;
274FIN ;Clean up variables
275 K ^TMP("PRCVIT",$J)
276 K PRCVI,PRCVN,PRCVDP,PRCVPRO,HL,HLA,PRCVCS,PRCVRS,PRCVFS,PRCVDT,%
277 K VAL,PRCVERC,PRCVERM,PRCVERR
278 ;
279 Q
Note: See TracBrowser for help on using the repository browser.