source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC1.m@ 824

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1PRCVRC1 ;WOIFO/BMM - silently build RIL for DynaMed ; 3/24/05 2:43pm
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;^XTMP format for incoming DM data is set:
6 ;^XTMP("PRCVRE*ID",0)=termination date^entry date^ Transmit message
7 ;to DynaMed for updates^date/time of this XTMP node built (debugging)
8 ;^XTMP("PRCVRE*ID",0,"ERR")=Error message flag
9 ;^XTMP("PRCVRE*ID",1)=Item counter/last item entered^FCP^CC^
10 ;Order Control Code^Site Number^Date/Time message created^DUZ^
11 ;Entered By Last Name^Entered by First Name
12 ;^XTMP("PRCVRE*ID",1,n)=item #^quantity^vendor #^cost^Date Needed^
13 ;DynaMed Document Number^NIF #^BOC
14 ;^XTMP("PRCVRE*ID",1,n,"ERR")=error message
15 ;
16 ;need to validate the NIF# and BOC but not save to a file in IFCAP.
17 ;send a message back to DM if validation fails
18 ;
19 ;pseudocode
20 ;calling routine sends PRCVRE_message ID as parameter
21 ;get information from ^XTMP
22 ; validate NIF# and BOC, send back alerts if necessary
23 ;look up the information on Item and Vendor that we need
24 ;silently create the RIL in 410.3
25 ; first create 410.3 record using Entry Number (site-FY-qtr-
26 ; fcp-cc-txn#),
27 ;if error - make ERR node for item in ^XTMP, he needs error code,
28 ; severity, fields involved. if error is IFCAP (FileMan API) and
29 ; not DM, send Vic an err at top level (1-node in XTMP) and he'll
30 ; reject entire msg. else if FileMan API error is item-level then
31 ; add to item-level ERR node
32 ;
33 ;summary info
34 ;PRCVEF - error flag, set if any errors found with detail line
35 ;PRCVLN1 - summary info line for record
36 ;PRCVCTR - #detail line records
37 ;PRCVDUZ - user DUZ
38 ;PRCVIEN - new ien for RIL being created
39 ;PRCVGL - global (first) subscript for ^XTMP
40 ;PRCVMID - message id from PRCVGL (ID from comments above)
41 ;PRCVFN, PRCVLN - user first and last name
42 ;PRCVFCP - FCP
43 ;PRCVHF - flag to prevent adding the header to the RIL if errors
44 ;PRCVCC - CC
45 ;PRCVOCC - Order Control Code
46 ;PRCVST - site
47 ;PRCVDT - date/time message created
48 ;PRCVQTR - fiscal quarter
49 ;PRCVFY - fiscal year
50 ;PRCVSTR - becomes the RIL#, ST-FY-QTR-FCP-CC-TN
51 ;PRCVTN - transaction#
52 ;PRCVAS - data for Audit File #414.02,
53 ; PRCVAS=DN-ITM-VN-DUZ-STR-DT-$$NOW^XLFDT
54 ;PRCVAH - header data for Audit File, DUZ-LN-FN-STR-DT-$$NOW
55 ;
56 ;detail info
57 ;PRCVMC - count of detail messages that get posted to 410.3. used
58 ; to determine if any detail records were posted at all (if not
59 ; then header is deleted and no RIL is created)
60 ;PRCVA - array of values to add a detail record to 410.3
61 ;PRCVDTL - each detail info line w/data below
62 ;PRCVEL - counter for going through the detail records
63 ;PRCVNIF - NIF #
64 ;PRCVBOC - budget object code
65 ;PRCVLF - flag to prevent adding a line item to the RIL if errors
66 ;PRCVVN - vendor name
67 ;PRCVCST - item unit cost
68 ;PRCVQTY - quantity
69 ;PRCVITM - item #
70 ;PRCVDN - DynaMed document number
71 ;PRCVDTN - date needed
72 ;PRCVDR - date/time RIL is created
73 ;
74 Q
75 ;
76EN(PRCVGL) ;entry point
77 Q:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
78 N PRCVA,PRCVAH,PRCVAS,PRCVBOC,PRCVCC,PRCVCST,PRCVCTR,PRCVDR
79 N PRCVDT,PRCVDTL,PRCVDN,PRCVDTN,PRCVDUZ,PRCVEF,PRCVEL,PRCVFCP
80 N PRCVFN,PRCVFY,PRCVHF,PRCVITM,PRCVIEN,PRCVLN,PRCVLN1,PRCVMID
81 N PRCVMC,PRCVNIF,PRCVOCC,PRCVQTR,PRCVQTY,PRCVST,PRCVSTR,PRCVVN
82 N PRCVVNM,PRCVTC,PRCVTN
83 S (PRCVAH,PRCVAS,PRCVVNM,PRCVBOC,PRCVCC,PRCVFN,PRCVDR)=""
84 S (PRCVCST,PRCVTC,PRCVDUZ,PRCVDT)=0,(PRCVDTL,PRCVDTN,PRCVA)=""
85 S (PRCVEL,PRCVITM,PRCVLN,PRCVLN1)="",(PRCVFCP,PRCVFY,PRCVST)=0
86 S (PRCVOCC,PRCVSTR,PRCVIEN)="",(PRCVNIF,PRCVQTR,PRCVQTY)=0
87 S (PRCVCTR,PRCVMC,PRCVVN,PRCVTC,PRCVTN,PRCVIEN,PRCVHF)=0
88 D:'$D(U) DT^DICRW
89 ;check for existence of ^XTMP global, else quit
90 I '$D(^XTMP(PRCVGL,0)) G EXIT
91 ;get header and summary data on records, quit if undef
92 S PRCVLN1=$G(^XTMP(PRCVGL,1))
93 I PRCVLN1="" D G EXIT
94 . D SENDMSG^PRCVRC2(2,PRCVGL,"",1)
95 ;get message id - not needed for now
96 ;S PRCVMID=$P(PRCVGL,"*",2)
97 ;get data for other fields from ^XTMP
98 S PRCVCTR=$P(PRCVLN1,U)+1
99 I +PRCVCTR=1!(PRCVCTR'=+PRCVCTR) D S PRCVHF=1
100 . D SENDMSG^PRCVRC2(1,PRCVGL,"",1)
101 S PRCVDUZ=$P(PRCVLN1,U,7)
102 S PRCVST=$P(PRCVLN1,U,5)
103 S PRCVFCP=$P(PRCVLN1,U,2)
104 I '$$CHKFCP^PRCVRC2(PRCVFCP,PRCVST) D S PRCVHF=1
105 . D SENDMSG^PRCVRC2(25,PRCVGL,"",2)
106 S PRCVCC=$P(PRCVLN1,U,3)
107 ;check FCP and CC
108 I '$$VALIDCC^PRCSECP(PRCVST,PRCVFCP,PRCVCC) D S PRCVHF=1
109 . D SENDMSG^PRCVRC2(3,PRCVGL,"",3)
110 ;S PRCVOCC=$O(PRCVLN1,U,4) not needed
111 ;Date/time message created
112 S PRCVDT=$P(PRCVLN1,U,6)
113 ;check that PRCVDT is not in future
114 I '$$CHKDT^PRCVRC2(PRCVDT) D S PRCVHF=1
115 . D SENDMSG^PRCVRC2(4,PRCVGL,"",6)
116 ;get date/time RIL created (now)
117 S PRCVDR=$$NOW^XLFDT
118 K PRCVA S PRCVA(410.3,"+1,",8)=PRCVDT
119 S PRCVA(410.3,"+1,",4)=PRCVDR
120 ;make Entry Number - in 410.3 not 410.31 multiple
121 S PRCVQTR=$$GETQTR^PRCVRC2(PRCVDT)
122 I 'PRCVQTR D SENDMSG^PRCVRC2(5,PRCVGL,"",6) S PRCVHF=1
123 S PRCVFY=$$GETFY^PRCVRC2(PRCVDT)
124 I 'PRCVFY D SENDMSG^PRCVRC2(6,PRCVGL,"",6) S PRCVHF=1
125 S PRCVSTR=PRCVST_"-"_PRCVFY_"-"_PRCVQTR_"-"_PRCVFCP_"-"_PRCVCC
126 S PRCVTN=$$GETTXN^PRCVRC2(PRCVSTR)
127 I PRCVTN=0 D SENDMSG^PRCVRC2(7,PRCVGL,"",1) S PRCVHF=1
128 S PRCVSTR=PRCVSTR_"-"_PRCVTN
129 S PRCVA(410.3,"+1,",.01)=PRCVSTR
130 ;validate DUZ
131 S PRCVDUZ=$P(PRCVLN1,U,7)
132 I '$$CHKDUZ^PRCVRC2(PRCVDUZ) D S PRCVHF=1
133 . D SENDMSG^PRCVRC2(8,PRCVGL,"",7)
134 ;create new RIL entry, new IEN in PRCVIEN(1)
135 I 'PRCVHF D
136 . D UPDATE^DIE("","PRCVA","PRCVIEN")
137 . S PRCVIEN=$G(PRCVIEN(1))
138 I PRCVHF K PRCVA
139 ;user info- convert last name, first name to uppercase
140 S PRCVLN=$$MAKECAP^PRCVRC2($P(PRCVLN1,U,8))
141 S PRCVFN=$$MAKECAP^PRCVRC2($P(PRCVLN1,U,9))
142 ;create header values string for Audit file
143 S PRCVAH=PRCVDUZ_"^"_$E(PRCVLN_","_PRCVFN,1,35)_"^"_PRCVSTR
144 S PRCVAH=PRCVAH_"^"_PRCVDR_"^"_PRCVDT
145 ;
146 ;get detail records. this is done inside loop to get all XTMP
147 ;nodes for this FCP/CC
148 S PRCVEL=1
149D1 S PRCVEL=PRCVEL+1,PRCVEF=0,PRCVAS=""
150 G:PRCVEL>PRCVCTR EXIT
151 S (PRCVDTL,PRCVVN)="" K PRCVA
152 ;if no detail node then skip
153 G:'$D(^XTMP(PRCVGL,2,PRCVEL-1)) D1
154 ;detail info string
155 S PRCVDTL=$G(^XTMP(PRCVGL,2,PRCVEL-1))
156 ;get DynaMed doc id
157 S PRCVDN=$P(PRCVDTL,U,6)
158 I PRCVDN="" D S PRCVEF=1
159 . D SENDMSG^PRCVRC2(24,PRCVGL,PRCVEL-1,1)
160 I $D(^PRCV(414.02,"B",PRCVDN)) D S PRCVEF=1
161 . D SENDMSG^PRCVRC2(22,PRCVGL,PRCVEL-1,6)
162 S PRCVA(410.31,"+1,"_PRCVIEN_",",6)=PRCVDN
163 ;Item
164 S PRCVITM=$P(PRCVDTL,U)
165 I '$$CHKITM^PRCVRC2(PRCVITM) D S PRCVEF=1
166 . D SENDMSG^PRCVRC2(9,PRCVGL,PRCVEL-1,1)
167 S PRCVA(410.31,"+1,"_PRCVIEN_",",.01)=PRCVITM
168 ;Quantity
169 S PRCVQTY=$P(PRCVDTL,U,2)
170 I PRCVQTY'=+PRCVQTY D S PRCVEF=1
171 . D SENDMSG^PRCVRC2(10,PRCVGL,PRCVEL-1,2)
172 S PRCVA(410.31,"+1,"_PRCVIEN_",",1)=PRCVQTY
173 ;Est. Item Unit Cost
174 S PRCVCST=$P(PRCVDTL,U,4)
175 I '(PRCVCST?.N.1".".2N) D S PRCVEF=1
176 . D SENDMSG^PRCVRC2(11,PRCVGL,PRCVEL-1,4)
177 S PRCVA(410.31,"+1,"_PRCVIEN_",",3)=PRCVCST
178 ;Date Needed
179 S PRCVDTN=$P(PRCVDTL,U,5)
180 ;check that date needed is today or in future
181 I '$$CHKDTN^PRCVRC2(PRCVDTN) D S PRCVEF=1
182 . D SENDMSG^PRCVRC2(12,PRCVGL,PRCVEL-1,5)
183 S PRCVA(410.31,"+1,"_PRCVIEN_",",7)=PRCVDTN
184 ;Vendor # (pointer to 440)
185 S PRCVVN=$P(PRCVDTL,U,3)
186 I '$$CHKVEND^PRCVRC2(PRCVVN) D S PRCVEF=1
187 . D SENDMSG^PRCVRC2(13,PRCVGL,PRCVEL-1,3)
188 ;check that vendor and item relate
189 I '$$CHKVI^PRCVRC2(PRCVVN,PRCVITM) D S PRCVEF=1
190 . D SENDMSG^PRCVRC2(14,PRCVGL,PRCVEL-1,3)
191 S PRCVA(410.31,"+1,"_PRCVIEN_",",4)=PRCVVN
192 ;Vendor name
193 S PRCVVNM=$$GET1^DIQ(440,PRCVVN_",",.01)
194 I PRCVVNM="" D S PRCVEF=1
195 . D SENDMSG^PRCVRC2(15,PRCVGL,PRCVEL-1,3)
196 S PRCVA(410.31,"+1,"_PRCVIEN_",",2)=PRCVVNM
197 ;create string to add entry to Audit file 414.02
198 S PRCVAS=PRCVDN_"^"_PRCVITM_"^"_PRCVVN_"^"_PRCVAH_"^"_PRCVDTN
199 ;add item record to 410.3 (if no errors)
200 I 'PRCVEF D
201 . D UPDATE^DIE("","PRCVA")
202 . I $D(^TMP("DIERR",$J)) D Q
203 . . D SENDMSG^PRCVRC2(16,PRCVGL,PRCVEL-1,6)
204 . S PRCVMC=PRCVMC+1
205 . ;add new item entry to DM Audit file
206 . D ADDAUD^PRCVRC2(PRCVAS)
207 . ;accumulate total cost
208 . S PRCVTC=PRCVTC+(PRCVCST*PRCVQTY)
209 ;
210 S PRCVNIF=$P(PRCVDTL,U,7)
211 ;validate NIF#
212 I '$$CHKNIF^PRCVRC2(PRCVITM,PRCVNIF) D
213 . D SENDMSG^PRCVRC2(17,PRCVGL,PRCVEL-1,7)
214 S PRCVBOC=$P(PRCVDTL,U,8)
215 ;validate BOC
216 I '$$CHKBOC^PRCVRC2(PRCVITM,PRCVBOC) D
217 . D SENDMSG^PRCVRC2(18,PRCVGL,PRCVEL-1,8)
218 ;validate site/FCP/CC/BOC combination
219 I '$$VALIDBOC^PRCSECP(PRCVST,PRCVFCP,PRCVCC,PRCVBOC) D
220 . D SENDMSG^PRCVRC2(19,PRCVGL,PRCVEL-1,8)
221D2 G D1
222 ;
223EXIT ;
224 ;add total cost to entry
225 I PRCVHF=0 D
226 . K PRCVA S PRCVA(410.3,PRCVIEN_",",2)=PRCVTC
227 . D UPDATE^DIE("","PRCVA")
228 ;if no detail records added to RIL then kill it
229 I PRCVMC=0,PRCVIEN>0 S DIK="^PRCS(410.3,",DA=PRCVIEN D ^DIK
230 ;kill vars
231 K PRCVA,PRCVBOC,PRCVCC,PRCVCST,PRCVCTR,PRCVDR,PRCVDT,PRCVDTL
232 K PRCVDTN,PRCVDUZ,PRCVEF,PRCVEL,PRCVFCP,PRCVFN,PRCVFY,PRCVHF
233 K PRCVITM,PRCVLN,PRCVLN1,PRCVMID,PRCVNIF,PRCVOCC,PRCVQTR
234 K PRCVQTY,PRCVST,PRCVSTR,PRCVVN,PRCVVNM,PRCVTC,PRCVTN
235 Q
236 ;
Note: See TracBrowser for help on using the repository browser.