source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHITX.m@ 1006

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

initial load of WorldVistAEHR

File size: 9.5 KB
Line 
1PRCHITX ;WOIFO/LKG-SELECTING ITEMS USED IN LAST 12 MONTHS ;1/27/05 10:56
2 ;;5.1;IFCAP;**75**;OCT 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D EN^DDIOL("^PRCHITX is not a valid entry point.")
5 Q
6 ;Output
7 ;^TMP($J,"I",Item#,0)=PO_Date^PO#^FCP^FSC^NSN^Mf_Part#^Station#^Stakeholder
8 ;^TMP($J,"I",Item#,1)=Vendor_ID^UOP^Pkg_Mult^Stock#^NDC^Contract#
9 ;^TMP($J,"V",Vendor#)=Vendor_Name^TIN^POC^Phone#^Accnt#
10IN ;Entry point
11 N PRCA,PRCB,PRCDT,PRCFILE,PRCI,PRCJ,PRCPODT,PRCSTAT,PRCITM,PRCDATE,PRCCNT,PRCTRANS,PRCX,PRCY,PRCV,X,X1,X2 K ^TMP($J)
12 S PRCA=0,PRCCNT=0,PRCDT=$$ONEYRAGO,X1=PRCDT,X2=-1 D C^%DTC S PRCDT=X
13 ;Purchase Orders
14 S PRCX=PRCDT
15 F S PRCX=$O(^PRC(442,"AB",PRCX)) Q:PRCX="" D
16 . S PRCA=""
17 . F S PRCA=$O(^PRC(442,"AB",PRCX,PRCA)) Q:+PRCA'=PRCA D
18 . . S PRCPODT=$$GETPODT(PRCA) I '$$DATEGTR(PRCPODT,PRCDT) Q
19 . . Q:'$$MOPOK(PRCA)
20 . . S PRCSTAT=$$GETSTAT(PRCA) Q:'$$STATUSOK(PRCSTAT)
21 . . S PRCB=0
22 . . F S PRCB=$O(^PRC(442,PRCA,2,PRCB)) Q:+PRCB'=PRCB D
23 . . . S PRCITM=$$GETITMID(PRCA,PRCB) Q:PRCITM=""
24 . . . Q:'$$ITEMACT(PRCITM) Q:$$NIFITEM(PRCITM)
25 . . . S PRCDATE=$P($G(^TMP($J,"I",PRCITM,0)),"^") Q:'$$DATEGTR(PRCPODT,PRCDATE)
26 . . . S:'$D(^TMP($J,"I",PRCITM)) PRCCNT=PRCCNT+1
27 . . . S ^TMP($J,"I",PRCITM,0)=PRCPODT_"^"_$$GETPONUM(PRCA)_"^"_$$GETFCP(PRCA)_"^"_$$GETFSC(PRCA,PRCB)_"^"_$$GETNSN(PRCA,PRCB)_"^"_$$GETMPNUM(PRCITM)
28 . . . S ^TMP($J,"I",PRCITM,1)=$$GETVENDR(PRCA)_"^"_$$GETUOP(PRCA,PRCB)_"^"_$$GETPKGM(PRCA,PRCB)_"^"_$$GETSTKNO(PRCA,PRCB)_"^"_$$GETNDC(PRCA,PRCB)_"^"_$$GETCONTR(PRCA,PRCB)
29 S ^TMP($J,"I")=PRCCNT
30 ;Reusable Items
31 S PRCITM=0
32 F S PRCITM=$O(^PRC(441,PRCITM)) Q:+PRCITM'=PRCITM D
33 . Q:$D(^TMP($J,"I",PRCITM)) Q:'$$ITEMACT(PRCITM) Q:'$$REUSABLE(PRCITM) Q:$$NIFITEM(PRCITM)
34 . S PRCCNT=PRCCNT+1,^TMP($J,"I",PRCITM,0)="^^"_$$FCP(PRCITM)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
35 . S PRCI=$$LASTVDR(PRCITM) S:PRCI="" PRCI=$$VDRLSTD(PRCITM)
36 . I PRCI>0 D
37 . . I $P($G(^PRC(440,PRCI,10)),"^",5),$P($G(^PRC(440,PRCI,9)),"^")>0 S PRCV=$P(^(9),"^") I $P($G(^PRC(440,PRCV,10)),"^",5)'=1,$D(^PRC(441,PRCITM,2,PRCV)) S PRCI=PRCV
38 . . S ^TMP($J,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
39 S ^TMP($J,"I")=PRCCNT
40 ;Inventory Transactions
41 S PRCX="",PRCITM="",PRCA="",PRCTRANS=";A;RC;R;U;C;S;E;"_$S(PRCPHYS="Y":"P;",1:"")
42 F S PRCX=$O(^PRCP(445.2,"AD",PRCX)) Q:PRCX="" D
43 . F S PRCITM=$O(^PRCP(445.2,"AD",PRCX,PRCITM)) Q:PRCITM="" D
44 . . Q:$D(^TMP($J,"I",PRCITM)) Q:'$$ITEMACT(PRCITM) Q:$$NIFITEM(PRCITM)
45 . . S PRCA=""
46 . . F S PRCA=$O(^PRCP(445.2,"AD",PRCX,PRCITM,PRCA)) Q:PRCA="" D Q:$D(^TMP($J,"I",PRCITM))
47 . . . S PRCY=$G(^PRCP(445.2,PRCA,0)) Q:PRCY=""
48 . . . Q:PRCTRANS'[(";"_$P(PRCY,"^",4)_";")
49 . . . Q:'$$DATEGTR($P(PRCY,"^",17),PRCDT)
50 . . . S PRCCNT=PRCCNT+1,^TMP($J,"I",PRCITM,0)="^^"_$$FCPINV(PRCA)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
51 . . . S PRCI=$$LASTVDR(PRCITM) S:PRCI="" PRCI=$$INVVNDR(PRCA) S:PRCI="" PRCI=$$VDRLSTD(PRCITM)
52 . . . I PRCI>0 D
53 . . . . I $P($G(^PRC(440,PRCI,10)),"^",5),$P($G(^PRC(440,PRCI,9)),"^")>0 S PRCV=$P(^(9),"^") I $P($G(^PRC(440,PRCV,10)),"^",5)'=1,$D(^PRC(441,PRCITM,2,PRCV)) S PRCI=PRCV
54 . . . . S ^TMP($J,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
55 S ^TMP($J,"I")=PRCCNT
56 ;Case carts and instrument kits - processing items
57 F PRCFILE=445.7,445.8 S PRCJ=0 F S PRCJ=$O(^PRCP(PRCFILE,"B",PRCJ)) Q:PRCJ="" D
58 . Q:'$$ITEMACT(PRCJ) Q:$$NIFITEM(PRCJ)
59 . S PRCITM=0 F S PRCITM=$O(^PRCP(PRCFILE,PRCJ,1,PRCITM)) Q:+PRCITM'=PRCITM D
60 . . Q:$D(^TMP($J,"I",PRCITM)) Q:'$$ITEMACT(PRCITM) Q:$$NIFITEM(PRCITM)
61 . . S PRCCNT=PRCCNT+1,^TMP($J,"I",PRCITM,0)="^^"_$$FCP(PRCITM)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
62 . . S PRCI=$$LASTVDR(PRCITM) S:PRCI="" PRCI=$$VDRLSTD(PRCITM) S:PRCI>0 ^TMP($J,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
63 S ^TMP($J,"I")=PRCCNT
64 ;Compiling vendor info
65 S PRCI="",PRCCNT=0
66 F S PRCI=$O(^TMP($J,"I",PRCI)) Q:PRCI="" D
67 . S X=$P($G(^TMP($J,"I",PRCI,1)),"^") Q:X=""
68 . S:'$D(^TMP($J,"V",X)) ^TMP($J,"V",X)=$$GETVNAME(X)_"^"_$$GETTIN(X)_"^"_$$GETPOC(X)_"^"_$$GETPHONE(X)_"^"_$$ACCNT(X),PRCCNT=PRCCNT+1
69 S ^TMP($J,"V")=PRCCNT
70 Q
71ONEYRAGO() ;Returns FileMan date of one year ago
72 N X S:'$D(DT) DT=$$DT^XLFDT S X=$E(DT,1,3)-1_$E(DT,4,7)
73 Q X
74DATEGTR(X,Y) ;Tests if first date is greater than second
75 I X>Y Q 1
76 Q 0
77GETPONUM(PRCDA) ;Returns PO Number
78 N X S X=$P($G(^PRC(442,PRCDA,0)),"^")
79 Q X
80GETSTAT(PRCDA) ;Returns Supply Status Order
81 N X S X=$P($G(^PRC(442,PRCDA,7)),"^") I X="" Q X
82 S X=$P($G(^PRCD(442.3,X,0)),"^",2)
83 Q X
84STATUSOK(X) ;Checks if Supply Status Order value okay for selection
85 I ";;1;5;6;45;"[(";"_X_";") Q 0
86 Q 1
87GETPODT(PRCDA) ;Returns P.O. Date in FileMan date format
88 Q $P($G(^PRC(442,PRCDA,1)),"^",15)
89GETFCP(PRCDA) ;Returns Fund Control Point
90 Q $P($G(^PRC(442,PRCDA,0)),"^",3)
91MOPOK(PRCDA) ;Checks Method of Processing
92 N X S X=$P($G(^PRC(442,PRCDA,0)),"^",2) I X="" Q 0
93 S X=$P($G(^PRCD(442.5,X,0)),"^",2) I X="" Q 0
94 I ";IS;1358;TA;OTA;AR;"[(";"_X_";") Q 0
95 Q 1
96GETVENDR(PRCDA) ;Returns Vendor ID
97 N X S X=$P($G(^PRC(442,PRCDA,1)),"^")
98 Q X
99GETITMID(PRCDA,PRCDA1) ;Returns Item Master File Ien
100 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",5)
101 Q X
102GETUOP(PRCDA,PRCDA1) ;Returns Unit of Purchase
103 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",3) I X="" Q X
104 S X=$P($G(^PRCD(420.5,X,0)),"^")
105 Q X
106GETPKGM(PRCDA,PRCDA1) ;Returns Packaging Multiple
107 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",12)
108 Q X
109GETFSC(PRCDA,PRCDA1) ;Returns Federal Supply Classification
110 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,2)),"^",3)
111 I X="" S X=$E($P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",13),1,4)
112 Q X
113GETNSN(PRCDA,PRCDA1) ;Returns National Stock Number
114 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",13)
115 Q X
116GETSTKNO(PRCDA,PRCDA1) ;Returns Vendor Stock Number
117 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",6)
118 Q X
119GETNDC(PRCDA,PRCDA1) ;Returns National Drug Code
120 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",15)
121 Q X
122GETCONTR(PRCDA,PRCDA1) ;Returns Contract/BOA #
123 N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,2)),"^",2)
124 Q X
125ITEMACT(X) ;Checks if item is active
126 I '$D(^PRC(441,X)) Q 0
127 I $P($G(^PRC(441,X,3)),"^")=1 Q 0
128 Q 1
129GETMPNUM(X) ;Returns Manufacturer Part Number
130 S X=$P($G(^PRC(441,X,3)),"^",5)
131 Q X
132GETSDESC(X) ;Returns Item Short Description
133 S X=$P($G(^PRC(441,X,0)),"^",2)
134 Q X
135GETVNAME(X) ;Returns Vendor Name
136 S X=$P($G(^PRC(440,X,0)),"^")
137 Q X
138GETTIN(X) ;Returns Tax ID Number or Social Security Number
139 S X=$P($G(^PRC(440,X,3)),"^",8)
140 Q X
141GETPOC(X) ;Returns Vendor Point of Contact
142 S X=$P($G(^PRC(440,X,0)),"^",9)
143 Q X
144GETPHONE(X) ;Returns Vendor's Phone Number
145 S X=$P($G(^PRC(440,X,0)),"^",10)
146 Q X
147REUSABLE(PRCDA) ;Returns 1 if item is reusable or 0 if not
148 N X S X=$P($G(^PRC(441,PRCDA,0)),"^",13) S X=$S(X="y":1,1:0)
149 Q X
150LASTVDR(PRCDA) ;Returns vendor ID
151 N X S X=$P($G(^PRC(441,PRCDA,0)),"^",4)
152 Q X
153CONTRACT(PRCDA,PRCDA1) ;Returns Contract #
154 N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",3)
155 S X=$S(X>0:$P($G(^PRC(440,PRCDA1,4,X,0)),"^"),1:"")
156 Q X
157STKNO(PRCDA,PRCDA1) ;Returns vendor stock #
158 N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",4)
159 Q X
160UOP(PRCDA,PRCDA1) ;Returns Unit of Purchase
161 N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",7)
162 I X'="" S X=$P($G(^PRCD(420.5,X,0)),"^")
163 Q X
164PKGMULT(PRCDA,PRCDA1) ;Returns Packaging Multiple
165 N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",8)
166 Q X
167NDC(PRCDA,PRCDA1) ;Returns NDC
168 N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",5)
169 Q X
170FSC(PRCDA) ;Returns Federal Supply Classification
171 N X S X=$P($G(^PRC(441,PRCDA,0)),"^",3)
172 I X="" S X=$E($P($G(^PRC(441,PRCDA,0)),"^",5),1,4)
173 Q X
174NSN(PRCDA) ;Returns National Stock Number
175 N X S X=$P($G(^PRC(441,PRCDA,0)),"^",5)
176 Q X
177FCP(PRCDA) ;Returns FCP
178 N X,PRCA,PRCB,PRCX,PRCI S PRCI=0,PRCX=""
179 F S PRCI=$O(^PRC(441,PRCDA,4,PRCI)) Q:+PRCI'=PRCI D Q:PRCX'=""
180 . S X=$P($G(^PRC(441,PRCDA,4,PRCI,0)),"^") Q:X=""
181 . S PRCA=+$E(X,1,3),PRCB=+$E(X,4,99)
182 . Q:$P($G(^PRC(420,PRCA,1,PRCB,0)),"^",19)
183 . S PRCX=$P($G(^PRC(420,PRCA,1,PRCB,0)),"^")
184 Q PRCX
185DATE(X) ;Processes date in VA FileMan format and returns date as 'DD-MON-YYYY'
186 Q:$P(X,".")'?7N ""
187 N Y,Z
188 S Y=X#100,Y=$S(Y>0:$E(100+Y,2,3)_"-",1:"")
189 S Z=$P("JAN;FEB;MAR;APR;MAY;JUN;JUL;AUG;SEP;OCT;NOV;DEC",";",X#10000\100) S:Z'="" Z=Z_"-"
190 S X=Y_Z_(X\10000+1700)
191 Q X
192GETSTATN() ;Returns station number of VistA installation
193 N X
194 S X=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
195 Q X
196NIFITEM(X) ;Checks if item already has NIF Item #
197 N Y S Y=0
198 I X>0 S:+$P($G(^PRC(441,X,0)),"^",15)>0 Y=1
199 Q Y
200ACCNT(X) ;Returns vendor account number
201 N Y S Y=""
202 S:X>0 Y=$P($G(^PRC(440,X,2)),"^")
203 Q Y
204VDRLSTD(X) ;Returns vendor with highest ID from item's VENDOR multiple
205 N Y S Y=""
206 S:X>0 Y=$O(^PRC(441,X,2,"B",""),-1)
207 Q Y
208INVVNDR(PRCX) ;Returns inv's mandatory/requested source of item on trxn
209 N Y,PRCINV,PRCY,PRCZ S Y="" Q:PRCX'>0 Y
210 S PRCZ=$G(^PRCP(445.2,PRCX,0)),PRCY=$P(PRCZ,"^",5) Q:PRCY'>0 Y
211 S PRCINV=$P(PRCZ,"^"),PRCZ="" S:PRCINV>0 PRCZ=$P($G(^PRCP(445,PRCINV,1,PRCY,0)),"^",12)
212 I $P(PRCZ,";",2)="PRC(440," S PRCZ=$P(PRCZ,";") S:PRCZ>0 Y=$S($P($G(^PRC(440,PRCZ,0)),"^",11)'="S":PRCZ,1:"")
213 Q Y
214FCPINV(PRCX) ;Get FCP for Inv Transaction
215 N Y S Y="" Q:PRCX'>0 Y
216 N PRCINV S PRCINV=$P($G(^PRCP(445.2,PRCX,0)),"^")
217 I PRCINV>0 D
218 . N PRCSTA,PRCDA S PRCDA="",PRCSTA=$P($G(^PRCP(445,PRCINV,0)),"-")
219 . S:PRCSTA'="" PRCDA=$O(^PRC(420,"AE",PRCSTA,PRCINV,""))
220 . S:PRCDA>0 Y=$P($G(^PRC(420,PRCSTA,1,PRCDA,0)),"^")
221 Q Y
Note: See TracBrowser for help on using the repository browser.