PRCHITX ;WOIFO/LKG-SELECTING ITEMS USED IN LAST 12 MONTHS ;1/27/05 10:56
;;5.1;IFCAP;**75**;OCT 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D EN^DDIOL("^PRCHITX is not a valid entry point.")
Q
;Output
;^TMP($J,"I",Item#,0)=PO_Date^PO#^FCP^FSC^NSN^Mf_Part#^Station#^Stakeholder
;^TMP($J,"I",Item#,1)=Vendor_ID^UOP^Pkg_Mult^Stock#^NDC^Contract#
;^TMP($J,"V",Vendor#)=Vendor_Name^TIN^POC^Phone#^Accnt#
IN ;Entry point
N PRCA,PRCB,PRCDT,PRCFILE,PRCI,PRCJ,PRCPODT,PRCSTAT,PRCITM,PRCDATE,PRCCNT,PRCTRANS,PRCX,PRCY,PRCV,X,X1,X2 K ^TMP($J)
S PRCA=0,PRCCNT=0,PRCDT=$$ONEYRAGO,X1=PRCDT,X2=-1 D C^%DTC S PRCDT=X
;Purchase Orders
S PRCX=PRCDT
F S PRCX=$O(^PRC(442,"AB",PRCX)) Q:PRCX="" D
. S PRCA=""
. F S PRCA=$O(^PRC(442,"AB",PRCX,PRCA)) Q:+PRCA'=PRCA D
. . S PRCPODT=$$GETPODT(PRCA) I '$$DATEGTR(PRCPODT,PRCDT) Q
. . Q:'$$MOPOK(PRCA)
. . S PRCSTAT=$$GETSTAT(PRCA) Q:'$$STATUSOK(PRCSTAT)
. . S PRCB=0
. . F S PRCB=$O(^PRC(442,PRCA,2,PRCB)) Q:+PRCB'=PRCB D
. . . S PRCITM=$$GETITMID(PRCA,PRCB) Q:PRCITM=""
. . . Q:'$$ITEMACT(PRCITM) Q:$$NIFITEM(PRCITM)
. . . S PRCDATE=$P($G(^TMP($J,"I",PRCITM,0)),"^") Q:'$$DATEGTR(PRCPODT,PRCDATE)
. . . S:'$D(^TMP($J,"I",PRCITM)) PRCCNT=PRCCNT+1
. . . S ^TMP($J,"I",PRCITM,0)=PRCPODT_"^"_$$GETPONUM(PRCA)_"^"_$$GETFCP(PRCA)_"^"_$$GETFSC(PRCA,PRCB)_"^"_$$GETNSN(PRCA,PRCB)_"^"_$$GETMPNUM(PRCITM)
. . . S ^TMP($J,"I",PRCITM,1)=$$GETVENDR(PRCA)_"^"_$$GETUOP(PRCA,PRCB)_"^"_$$GETPKGM(PRCA,PRCB)_"^"_$$GETSTKNO(PRCA,PRCB)_"^"_$$GETNDC(PRCA,PRCB)_"^"_$$GETCONTR(PRCA,PRCB)
S ^TMP($J,"I")=PRCCNT
;Reusable Items
S PRCITM=0
F S PRCITM=$O(^PRC(441,PRCITM)) Q:+PRCITM'=PRCITM D
. Q:$D(^TMP($J,"I",PRCITM)) Q:'$$ITEMACT(PRCITM) Q:'$$REUSABLE(PRCITM) Q:$$NIFITEM(PRCITM)
. S PRCCNT=PRCCNT+1,^TMP($J,"I",PRCITM,0)="^^"_$$FCP(PRCITM)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
. S PRCI=$$LASTVDR(PRCITM) S:PRCI="" PRCI=$$VDRLSTD(PRCITM)
. I PRCI>0 D
. . 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
. . S ^TMP($J,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
S ^TMP($J,"I")=PRCCNT
;Inventory Transactions
S PRCX="",PRCITM="",PRCA="",PRCTRANS=";A;RC;R;U;C;S;E;"_$S(PRCPHYS="Y":"P;",1:"")
F S PRCX=$O(^PRCP(445.2,"AD",PRCX)) Q:PRCX="" D
. F S PRCITM=$O(^PRCP(445.2,"AD",PRCX,PRCITM)) Q:PRCITM="" D
. . Q:$D(^TMP($J,"I",PRCITM)) Q:'$$ITEMACT(PRCITM) Q:$$NIFITEM(PRCITM)
. . S PRCA=""
. . F S PRCA=$O(^PRCP(445.2,"AD",PRCX,PRCITM,PRCA)) Q:PRCA="" D Q:$D(^TMP($J,"I",PRCITM))
. . . S PRCY=$G(^PRCP(445.2,PRCA,0)) Q:PRCY=""
. . . Q:PRCTRANS'[(";"_$P(PRCY,"^",4)_";")
. . . Q:'$$DATEGTR($P(PRCY,"^",17),PRCDT)
. . . S PRCCNT=PRCCNT+1,^TMP($J,"I",PRCITM,0)="^^"_$$FCPINV(PRCA)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
. . . S PRCI=$$LASTVDR(PRCITM) S:PRCI="" PRCI=$$INVVNDR(PRCA) S:PRCI="" PRCI=$$VDRLSTD(PRCITM)
. . . I PRCI>0 D
. . . . 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
. . . . S ^TMP($J,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
S ^TMP($J,"I")=PRCCNT
;Case carts and instrument kits - processing items
F PRCFILE=445.7,445.8 S PRCJ=0 F S PRCJ=$O(^PRCP(PRCFILE,"B",PRCJ)) Q:PRCJ="" D
. Q:'$$ITEMACT(PRCJ) Q:$$NIFITEM(PRCJ)
. S PRCITM=0 F S PRCITM=$O(^PRCP(PRCFILE,PRCJ,1,PRCITM)) Q:+PRCITM'=PRCITM D
. . Q:$D(^TMP($J,"I",PRCITM)) Q:'$$ITEMACT(PRCITM) Q:$$NIFITEM(PRCITM)
. . S PRCCNT=PRCCNT+1,^TMP($J,"I",PRCITM,0)="^^"_$$FCP(PRCITM)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
. . 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)
S ^TMP($J,"I")=PRCCNT
;Compiling vendor info
S PRCI="",PRCCNT=0
F S PRCI=$O(^TMP($J,"I",PRCI)) Q:PRCI="" D
. S X=$P($G(^TMP($J,"I",PRCI,1)),"^") Q:X=""
. S:'$D(^TMP($J,"V",X)) ^TMP($J,"V",X)=$$GETVNAME(X)_"^"_$$GETTIN(X)_"^"_$$GETPOC(X)_"^"_$$GETPHONE(X)_"^"_$$ACCNT(X),PRCCNT=PRCCNT+1
S ^TMP($J,"V")=PRCCNT
Q
ONEYRAGO() ;Returns FileMan date of one year ago
N X S:'$D(DT) DT=$$DT^XLFDT S X=$E(DT,1,3)-1_$E(DT,4,7)
Q X
DATEGTR(X,Y) ;Tests if first date is greater than second
I X>Y Q 1
Q 0
GETPONUM(PRCDA) ;Returns PO Number
N X S X=$P($G(^PRC(442,PRCDA,0)),"^")
Q X
GETSTAT(PRCDA) ;Returns Supply Status Order
N X S X=$P($G(^PRC(442,PRCDA,7)),"^") I X="" Q X
S X=$P($G(^PRCD(442.3,X,0)),"^",2)
Q X
STATUSOK(X) ;Checks if Supply Status Order value okay for selection
I ";;1;5;6;45;"[(";"_X_";") Q 0
Q 1
GETPODT(PRCDA) ;Returns P.O. Date in FileMan date format
Q $P($G(^PRC(442,PRCDA,1)),"^",15)
GETFCP(PRCDA) ;Returns Fund Control Point
Q $P($G(^PRC(442,PRCDA,0)),"^",3)
MOPOK(PRCDA) ;Checks Method of Processing
N X S X=$P($G(^PRC(442,PRCDA,0)),"^",2) I X="" Q 0
S X=$P($G(^PRCD(442.5,X,0)),"^",2) I X="" Q 0
I ";IS;1358;TA;OTA;AR;"[(";"_X_";") Q 0
Q 1
GETVENDR(PRCDA) ;Returns Vendor ID
N X S X=$P($G(^PRC(442,PRCDA,1)),"^")
Q X
GETITMID(PRCDA,PRCDA1) ;Returns Item Master File Ien
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",5)
Q X
GETUOP(PRCDA,PRCDA1) ;Returns Unit of Purchase
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",3) I X="" Q X
S X=$P($G(^PRCD(420.5,X,0)),"^")
Q X
GETPKGM(PRCDA,PRCDA1) ;Returns Packaging Multiple
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",12)
Q X
GETFSC(PRCDA,PRCDA1) ;Returns Federal Supply Classification
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,2)),"^",3)
I X="" S X=$E($P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",13),1,4)
Q X
GETNSN(PRCDA,PRCDA1) ;Returns National Stock Number
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",13)
Q X
GETSTKNO(PRCDA,PRCDA1) ;Returns Vendor Stock Number
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",6)
Q X
GETNDC(PRCDA,PRCDA1) ;Returns National Drug Code
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,0)),"^",15)
Q X
GETCONTR(PRCDA,PRCDA1) ;Returns Contract/BOA #
N X S X=$P($G(^PRC(442,PRCDA,2,PRCDA1,2)),"^",2)
Q X
ITEMACT(X) ;Checks if item is active
I '$D(^PRC(441,X)) Q 0
I $P($G(^PRC(441,X,3)),"^")=1 Q 0
Q 1
GETMPNUM(X) ;Returns Manufacturer Part Number
S X=$P($G(^PRC(441,X,3)),"^",5)
Q X
GETSDESC(X) ;Returns Item Short Description
S X=$P($G(^PRC(441,X,0)),"^",2)
Q X
GETVNAME(X) ;Returns Vendor Name
S X=$P($G(^PRC(440,X,0)),"^")
Q X
GETTIN(X) ;Returns Tax ID Number or Social Security Number
S X=$P($G(^PRC(440,X,3)),"^",8)
Q X
GETPOC(X) ;Returns Vendor Point of Contact
S X=$P($G(^PRC(440,X,0)),"^",9)
Q X
GETPHONE(X) ;Returns Vendor's Phone Number
S X=$P($G(^PRC(440,X,0)),"^",10)
Q X
REUSABLE(PRCDA) ;Returns 1 if item is reusable or 0 if not
N X S X=$P($G(^PRC(441,PRCDA,0)),"^",13) S X=$S(X="y":1,1:0)
Q X
LASTVDR(PRCDA) ;Returns vendor ID
N X S X=$P($G(^PRC(441,PRCDA,0)),"^",4)
Q X
CONTRACT(PRCDA,PRCDA1) ;Returns Contract #
N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",3)
S X=$S(X>0:$P($G(^PRC(440,PRCDA1,4,X,0)),"^"),1:"")
Q X
STKNO(PRCDA,PRCDA1) ;Returns vendor stock #
N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",4)
Q X
UOP(PRCDA,PRCDA1) ;Returns Unit of Purchase
N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",7)
I X'="" S X=$P($G(^PRCD(420.5,X,0)),"^")
Q X
PKGMULT(PRCDA,PRCDA1) ;Returns Packaging Multiple
N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",8)
Q X
NDC(PRCDA,PRCDA1) ;Returns NDC
N X S X=$P($G(^PRC(441,PRCDA,2,PRCDA1,0)),"^",5)
Q X
FSC(PRCDA) ;Returns Federal Supply Classification
N X S X=$P($G(^PRC(441,PRCDA,0)),"^",3)
I X="" S X=$E($P($G(^PRC(441,PRCDA,0)),"^",5),1,4)
Q X
NSN(PRCDA) ;Returns National Stock Number
N X S X=$P($G(^PRC(441,PRCDA,0)),"^",5)
Q X
FCP(PRCDA) ;Returns FCP
N X,PRCA,PRCB,PRCX,PRCI S PRCI=0,PRCX=""
F S PRCI=$O(^PRC(441,PRCDA,4,PRCI)) Q:+PRCI'=PRCI D Q:PRCX'=""
. S X=$P($G(^PRC(441,PRCDA,4,PRCI,0)),"^") Q:X=""
. S PRCA=+$E(X,1,3),PRCB=+$E(X,4,99)
. Q:$P($G(^PRC(420,PRCA,1,PRCB,0)),"^",19)
. S PRCX=$P($G(^PRC(420,PRCA,1,PRCB,0)),"^")
Q PRCX
DATE(X) ;Processes date in VA FileMan format and returns date as 'DD-MON-YYYY'
Q:$P(X,".")'?7N ""
N Y,Z
S Y=X#100,Y=$S(Y>0:$E(100+Y,2,3)_"-",1:"")
S Z=$P("JAN;FEB;MAR;APR;MAY;JUN;JUL;AUG;SEP;OCT;NOV;DEC",";",X#10000\100) S:Z'="" Z=Z_"-"
S X=Y_Z_(X\10000+1700)
Q X
GETSTATN() ;Returns station number of VistA installation
N X
S X=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
Q X
NIFITEM(X) ;Checks if item already has NIF Item #
N Y S Y=0
I X>0 S:+$P($G(^PRC(441,X,0)),"^",15)>0 Y=1
Q Y
ACCNT(X) ;Returns vendor account number
N Y S Y=""
S:X>0 Y=$P($G(^PRC(440,X,2)),"^")
Q Y
VDRLSTD(X) ;Returns vendor with highest ID from item's VENDOR multiple
N Y S Y=""
S:X>0 Y=$O(^PRC(441,X,2,"B",""),-1)
Q Y
INVVNDR(PRCX) ;Returns inv's mandatory/requested source of item on trxn
N Y,PRCINV,PRCY,PRCZ S Y="" Q:PRCX'>0 Y
S PRCZ=$G(^PRCP(445.2,PRCX,0)),PRCY=$P(PRCZ,"^",5) Q:PRCY'>0 Y
S PRCINV=$P(PRCZ,"^"),PRCZ="" S:PRCINV>0 PRCZ=$P($G(^PRCP(445,PRCINV,1,PRCY,0)),"^",12)
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:"")
Q Y
FCPINV(PRCX) ;Get FCP for Inv Transaction
N Y S Y="" Q:PRCX'>0 Y
N PRCINV S PRCINV=$P($G(^PRCP(445.2,PRCX,0)),"^")
I PRCINV>0 D
. N PRCSTA,PRCDA S PRCDA="",PRCSTA=$P($G(^PRCP(445,PRCINV,0)),"-")
. S:PRCSTA'="" PRCDA=$O(^PRC(420,"AE",PRCSTA,PRCINV,""))
. S:PRCDA>0 Y=$P($G(^PRC(420,PRCSTA,1,PRCDA,0)),"^")
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHITX 9915 printed Sep 23, 2025@19:44:10 Page 2
PRCHITX ;WOIFO/LKG-SELECTING ITEMS USED IN LAST 12 MONTHS ;1/27/05 10:56
+1 ;;5.1;IFCAP;**75**;OCT 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO EN^DDIOL("^PRCHITX is not a valid entry point.")
+4 QUIT
+5 ;Output
+6 ;^TMP($J,"I",Item#,0)=PO_Date^PO#^FCP^FSC^NSN^Mf_Part#^Station#^Stakeholder
+7 ;^TMP($J,"I",Item#,1)=Vendor_ID^UOP^Pkg_Mult^Stock#^NDC^Contract#
+8 ;^TMP($J,"V",Vendor#)=Vendor_Name^TIN^POC^Phone#^Accnt#
IN ;Entry point
+1 NEW PRCA,PRCB,PRCDT,PRCFILE,PRCI,PRCJ,PRCPODT,PRCSTAT,PRCITM,PRCDATE,PRCCNT,PRCTRANS,PRCX,PRCY,PRCV,X,X1,X2
KILL ^TMP($JOB)
+2 SET PRCA=0
SET PRCCNT=0
SET PRCDT=$$ONEYRAGO
SET X1=PRCDT
SET X2=-1
DO C^%DTC
SET PRCDT=X
+3 ;Purchase Orders
+4 SET PRCX=PRCDT
+5 FOR
SET PRCX=$ORDER(^PRC(442,"AB",PRCX))
if PRCX=""
QUIT
Begin DoDot:1
+6 SET PRCA=""
+7 FOR
SET PRCA=$ORDER(^PRC(442,"AB",PRCX,PRCA))
if +PRCA'=PRCA
QUIT
Begin DoDot:2
+8 SET PRCPODT=$$GETPODT(PRCA)
IF '$$DATEGTR(PRCPODT,PRCDT)
QUIT
+9 if '$$MOPOK(PRCA)
QUIT
+10 SET PRCSTAT=$$GETSTAT(PRCA)
if '$$STATUSOK(PRCSTAT)
QUIT
+11 SET PRCB=0
+12 FOR
SET PRCB=$ORDER(^PRC(442,PRCA,2,PRCB))
if +PRCB'=PRCB
QUIT
Begin DoDot:3
+13 SET PRCITM=$$GETITMID(PRCA,PRCB)
if PRCITM=""
QUIT
+14 if '$$ITEMACT(PRCITM)
QUIT
if $$NIFITEM(PRCITM)
QUIT
+15 SET PRCDATE=$PIECE($GET(^TMP($JOB,"I",PRCITM,0)),"^")
if '$$DATEGTR(PRCPODT,PRCDATE)
QUIT
+16 if '$DATA(^TMP($JOB,"I",PRCITM))
SET PRCCNT=PRCCNT+1
+17 SET ^TMP($JOB,"I",PRCITM,0)=PRCPODT_"^"_$$GETPONUM(PRCA)_"^"_$$GETFCP(PRCA)_"^"_$$GETFSC(PRCA,PRCB)_"^"_$$GETNSN(PRCA,PRCB)_"^"_$$GETMPNUM(PRCITM)
+18 SET ^TMP($JOB,"I",PRCITM,1)=$$GETVENDR(PRCA)_"^"_$$GETUOP(PRCA,PRCB)_"^"_$$GETPKGM(PRCA,PRCB)_"^"_$$GETSTKNO(PRCA,PRCB)_"^"_$$GETNDC(PRCA,PRCB)_"^"_$$GETCONTR(PRCA,PRCB)
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET ^TMP($JOB,"I")=PRCCNT
+20 ;Reusable Items
+21 SET PRCITM=0
+22 FOR
SET PRCITM=$ORDER(^PRC(441,PRCITM))
if +PRCITM'=PRCITM
QUIT
Begin DoDot:1
+23 if $DATA(^TMP($JOB,"I",PRCITM))
QUIT
if '$$ITEMACT(PRCITM)
QUIT
if '$$REUSABLE(PRCITM)
QUIT
if $$NIFITEM(PRCITM)
QUIT
+24 SET PRCCNT=PRCCNT+1
SET ^TMP($JOB,"I",PRCITM,0)="^^"_$$FCP(PRCITM)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
+25 SET PRCI=$$LASTVDR(PRCITM)
if PRCI=""
SET PRCI=$$VDRLSTD(PRCITM)
+26 IF PRCI>0
Begin DoDot:2
+27 IF $PIECE($GET(^PRC(440,PRCI,10)),"^",5)
IF $PIECE($GET(^PRC(440,PRCI,9)),"^")>0
SET PRCV=$PIECE(^(9),"^")
IF $PIECE($GET(^PRC(440,PRCV,10)),"^",5)'=1
IF $DATA(^PRC(441,PRCITM,2,PRCV))
SET PRCI=PRCV
+28 SET ^TMP($JOB,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
End DoDot:2
End DoDot:1
+29 SET ^TMP($JOB,"I")=PRCCNT
+30 ;Inventory Transactions
+31 SET PRCX=""
SET PRCITM=""
SET PRCA=""
SET PRCTRANS=";A;RC;R;U;C;S;E;"_$SELECT(PRCPHYS="Y":"P;",1:"")
+32 FOR
SET PRCX=$ORDER(^PRCP(445.2,"AD",PRCX))
if PRCX=""
QUIT
Begin DoDot:1
+33 FOR
SET PRCITM=$ORDER(^PRCP(445.2,"AD",PRCX,PRCITM))
if PRCITM=""
QUIT
Begin DoDot:2
+34 if $DATA(^TMP($JOB,"I",PRCITM))
QUIT
if '$$ITEMACT(PRCITM)
QUIT
if $$NIFITEM(PRCITM)
QUIT
+35 SET PRCA=""
+36 FOR
SET PRCA=$ORDER(^PRCP(445.2,"AD",PRCX,PRCITM,PRCA))
if PRCA=""
QUIT
Begin DoDot:3
+37 SET PRCY=$GET(^PRCP(445.2,PRCA,0))
if PRCY=""
QUIT
+38 if PRCTRANS'[(";"_$PIECE(PRCY,"^",4)_";")
QUIT
+39 if '$$DATEGTR($PIECE(PRCY,"^",17),PRCDT)
QUIT
+40 SET PRCCNT=PRCCNT+1
SET ^TMP($JOB,"I",PRCITM,0)="^^"_$$FCPINV(PRCA)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
+41 SET PRCI=$$LASTVDR(PRCITM)
if PRCI=""
SET PRCI=$$INVVNDR(PRCA)
if PRCI=""
SET PRCI=$$VDRLSTD(PRCITM)
+42 IF PRCI>0
Begin DoDot:4
+43 IF $PIECE($GET(^PRC(440,PRCI,10)),"^",5)
IF $PIECE($GET(^PRC(440,PRCI,9)),"^")>0
SET PRCV=$PIECE(^(9),"^")
IF $PIECE($GET(^PRC(440,PRCV,10)),"^",5)'=1
IF $DATA(^PRC(441,PRCITM,2,PRCV))
SET PRCI=PRCV
+44 SET ^TMP($JOB,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
End DoDot:4
End DoDot:3
if $DATA(^TMP($JOB,"I",PRCITM))
QUIT
End DoDot:2
End DoDot:1
+45 SET ^TMP($JOB,"I")=PRCCNT
+46 ;Case carts and instrument kits - processing items
+47 FOR PRCFILE=445.7,445.8
SET PRCJ=0
FOR
SET PRCJ=$ORDER(^PRCP(PRCFILE,"B",PRCJ))
if PRCJ=""
QUIT
Begin DoDot:1
+48 if '$$ITEMACT(PRCJ)
QUIT
if $$NIFITEM(PRCJ)
QUIT
+49 SET PRCITM=0
FOR
SET PRCITM=$ORDER(^PRCP(PRCFILE,PRCJ,1,PRCITM))
if +PRCITM'=PRCITM
QUIT
Begin DoDot:2
+50 if $DATA(^TMP($JOB,"I",PRCITM))
QUIT
if '$$ITEMACT(PRCITM)
QUIT
if $$NIFITEM(PRCITM)
QUIT
+51 SET PRCCNT=PRCCNT+1
SET ^TMP($JOB,"I",PRCITM,0)="^^"_$$FCP(PRCITM)_"^"_$$FSC(PRCITM)_"^"_$$NSN(PRCITM)_"^"_$$GETMPNUM(PRCITM)
+52 SET PRCI=$$LASTVDR(PRCITM)
if PRCI=""
SET PRCI=$$VDRLSTD(PRCITM)
if PRCI>0
SET ^TMP($JOB,"I",PRCITM,1)=PRCI_"^"_$$UOP(PRCITM,PRCI)_"^"_$$PKGMULT(PRCITM,PRCI)_"^"_$$STKNO(PRCITM,PRCI)_"^"_$$NDC(PRCITM,PRCI)_"^"_$$CONTRACT(PRCITM,PRCI)
End DoDot:2
End DoDot:1
+53 SET ^TMP($JOB,"I")=PRCCNT
+54 ;Compiling vendor info
+55 SET PRCI=""
SET PRCCNT=0
+56 FOR
SET PRCI=$ORDER(^TMP($JOB,"I",PRCI))
if PRCI=""
QUIT
Begin DoDot:1
+57 SET X=$PIECE($GET(^TMP($JOB,"I",PRCI,1)),"^")
if X=""
QUIT
+58 if '$DATA(^TMP($JOB,"V",X))
SET ^TMP($JOB,"V",X)=$$GETVNAME(X)_"^"_$$GETTIN(X)_"^"_$$GETPOC(X)_"^"_$$GETPHONE(X)_"^"_$$ACCNT(X)
SET PRCCNT=PRCCNT+1
End DoDot:1
+59 SET ^TMP($JOB,"V")=PRCCNT
+60 QUIT
ONEYRAGO() ;Returns FileMan date of one year ago
+1 NEW X
if '$DATA(DT)
SET DT=$$DT^XLFDT
SET X=$EXTRACT(DT,1,3)-1_$EXTRACT(DT,4,7)
+2 QUIT X
DATEGTR(X,Y) ;Tests if first date is greater than second
+1 IF X>Y
QUIT 1
+2 QUIT 0
GETPONUM(PRCDA) ;Returns PO Number
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,0)),"^")
+2 QUIT X
GETSTAT(PRCDA) ;Returns Supply Status Order
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,7)),"^")
IF X=""
QUIT X
+2 SET X=$PIECE($GET(^PRCD(442.3,X,0)),"^",2)
+3 QUIT X
STATUSOK(X) ;Checks if Supply Status Order value okay for selection
+1 IF ";;1;5;6;45;"[(";"_X_";")
QUIT 0
+2 QUIT 1
GETPODT(PRCDA) ;Returns P.O. Date in FileMan date format
+1 QUIT $PIECE($GET(^PRC(442,PRCDA,1)),"^",15)
GETFCP(PRCDA) ;Returns Fund Control Point
+1 QUIT $PIECE($GET(^PRC(442,PRCDA,0)),"^",3)
MOPOK(PRCDA) ;Checks Method of Processing
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,0)),"^",2)
IF X=""
QUIT 0
+2 SET X=$PIECE($GET(^PRCD(442.5,X,0)),"^",2)
IF X=""
QUIT 0
+3 IF ";IS;1358;TA;OTA;AR;"[(";"_X_";")
QUIT 0
+4 QUIT 1
GETVENDR(PRCDA) ;Returns Vendor ID
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,1)),"^")
+2 QUIT X
GETITMID(PRCDA,PRCDA1) ;Returns Item Master File Ien
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,0)),"^",5)
+2 QUIT X
GETUOP(PRCDA,PRCDA1) ;Returns Unit of Purchase
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,0)),"^",3)
IF X=""
QUIT X
+2 SET X=$PIECE($GET(^PRCD(420.5,X,0)),"^")
+3 QUIT X
GETPKGM(PRCDA,PRCDA1) ;Returns Packaging Multiple
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,0)),"^",12)
+2 QUIT X
GETFSC(PRCDA,PRCDA1) ;Returns Federal Supply Classification
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,2)),"^",3)
+2 IF X=""
SET X=$EXTRACT($PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,0)),"^",13),1,4)
+3 QUIT X
GETNSN(PRCDA,PRCDA1) ;Returns National Stock Number
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,0)),"^",13)
+2 QUIT X
GETSTKNO(PRCDA,PRCDA1) ;Returns Vendor Stock Number
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,0)),"^",6)
+2 QUIT X
GETNDC(PRCDA,PRCDA1) ;Returns National Drug Code
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,0)),"^",15)
+2 QUIT X
GETCONTR(PRCDA,PRCDA1) ;Returns Contract/BOA #
+1 NEW X
SET X=$PIECE($GET(^PRC(442,PRCDA,2,PRCDA1,2)),"^",2)
+2 QUIT X
ITEMACT(X) ;Checks if item is active
+1 IF '$DATA(^PRC(441,X))
QUIT 0
+2 IF $PIECE($GET(^PRC(441,X,3)),"^")=1
QUIT 0
+3 QUIT 1
GETMPNUM(X) ;Returns Manufacturer Part Number
+1 SET X=$PIECE($GET(^PRC(441,X,3)),"^",5)
+2 QUIT X
GETSDESC(X) ;Returns Item Short Description
+1 SET X=$PIECE($GET(^PRC(441,X,0)),"^",2)
+2 QUIT X
GETVNAME(X) ;Returns Vendor Name
+1 SET X=$PIECE($GET(^PRC(440,X,0)),"^")
+2 QUIT X
GETTIN(X) ;Returns Tax ID Number or Social Security Number
+1 SET X=$PIECE($GET(^PRC(440,X,3)),"^",8)
+2 QUIT X
GETPOC(X) ;Returns Vendor Point of Contact
+1 SET X=$PIECE($GET(^PRC(440,X,0)),"^",9)
+2 QUIT X
GETPHONE(X) ;Returns Vendor's Phone Number
+1 SET X=$PIECE($GET(^PRC(440,X,0)),"^",10)
+2 QUIT X
REUSABLE(PRCDA) ;Returns 1 if item is reusable or 0 if not
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,0)),"^",13)
SET X=$SELECT(X="y":1,1:0)
+2 QUIT X
LASTVDR(PRCDA) ;Returns vendor ID
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,0)),"^",4)
+2 QUIT X
CONTRACT(PRCDA,PRCDA1) ;Returns Contract #
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,2,PRCDA1,0)),"^",3)
+2 SET X=$SELECT(X>0:$PIECE($GET(^PRC(440,PRCDA1,4,X,0)),"^"),1:"")
+3 QUIT X
STKNO(PRCDA,PRCDA1) ;Returns vendor stock #
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,2,PRCDA1,0)),"^",4)
+2 QUIT X
UOP(PRCDA,PRCDA1) ;Returns Unit of Purchase
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,2,PRCDA1,0)),"^",7)
+2 IF X'=""
SET X=$PIECE($GET(^PRCD(420.5,X,0)),"^")
+3 QUIT X
PKGMULT(PRCDA,PRCDA1) ;Returns Packaging Multiple
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,2,PRCDA1,0)),"^",8)
+2 QUIT X
NDC(PRCDA,PRCDA1) ;Returns NDC
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,2,PRCDA1,0)),"^",5)
+2 QUIT X
FSC(PRCDA) ;Returns Federal Supply Classification
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,0)),"^",3)
+2 IF X=""
SET X=$EXTRACT($PIECE($GET(^PRC(441,PRCDA,0)),"^",5),1,4)
+3 QUIT X
NSN(PRCDA) ;Returns National Stock Number
+1 NEW X
SET X=$PIECE($GET(^PRC(441,PRCDA,0)),"^",5)
+2 QUIT X
FCP(PRCDA) ;Returns FCP
+1 NEW X,PRCA,PRCB,PRCX,PRCI
SET PRCI=0
SET PRCX=""
+2 FOR
SET PRCI=$ORDER(^PRC(441,PRCDA,4,PRCI))
if +PRCI'=PRCI
QUIT
Begin DoDot:1
+3 SET X=$PIECE($GET(^PRC(441,PRCDA,4,PRCI,0)),"^")
if X=""
QUIT
+4 SET PRCA=+$EXTRACT(X,1,3)
SET PRCB=+$EXTRACT(X,4,99)
+5 if $PIECE($GET(^PRC(420,PRCA,1,PRCB,0)),"^",19)
QUIT
+6 SET PRCX=$PIECE($GET(^PRC(420,PRCA,1,PRCB,0)),"^")
End DoDot:1
if PRCX'=""
QUIT
+7 QUIT PRCX
DATE(X) ;Processes date in VA FileMan format and returns date as 'DD-MON-YYYY'
+1 if $PIECE(X,".")'?7N
QUIT ""
+2 NEW Y,Z
+3 SET Y=X#100
SET Y=$SELECT(Y>0:$EXTRACT(100+Y,2,3)_"-",1:"")
+4 SET Z=$PIECE("JAN;FEB;MAR;APR;MAY;JUN;JUL;AUG;SEP;OCT;NOV;DEC",";",X#10000\100)
if Z'=""
SET Z=Z_"-"
+5 SET X=Y_Z_(X\10000+1700)
+6 QUIT X
GETSTATN() ;Returns station number of VistA installation
+1 NEW X
+2 SET X=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
+3 QUIT X
NIFITEM(X) ;Checks if item already has NIF Item #
+1 NEW Y
SET Y=0
+2 IF X>0
if +$PIECE($GET(^PRC(441,X,0)),"^",15)>0
SET Y=1
+3 QUIT Y
ACCNT(X) ;Returns vendor account number
+1 NEW Y
SET Y=""
+2 if X>0
SET Y=$PIECE($GET(^PRC(440,X,2)),"^")
+3 QUIT Y
VDRLSTD(X) ;Returns vendor with highest ID from item's VENDOR multiple
+1 NEW Y
SET Y=""
+2 if X>0
SET Y=$ORDER(^PRC(441,X,2,"B",""),-1)
+3 QUIT Y
INVVNDR(PRCX) ;Returns inv's mandatory/requested source of item on trxn
+1 NEW Y,PRCINV,PRCY,PRCZ
SET Y=""
if PRCX'>0
QUIT Y
+2 SET PRCZ=$GET(^PRCP(445.2,PRCX,0))
SET PRCY=$PIECE(PRCZ,"^",5)
if PRCY'>0
QUIT Y
+3 SET PRCINV=$PIECE(PRCZ,"^")
SET PRCZ=""
if PRCINV>0
SET PRCZ=$PIECE($GET(^PRCP(445,PRCINV,1,PRCY,0)),"^",12)
+4 IF $PIECE(PRCZ,";",2)="PRC(440,"
SET PRCZ=$PIECE(PRCZ,";")
if PRCZ>0
SET Y=$SELECT($PIECE($GET(^PRC(440,PRCZ,0)),"^",11)'="S":PRCZ,1:"")
+5 QUIT Y
FCPINV(PRCX) ;Get FCP for Inv Transaction
+1 NEW Y
SET Y=""
if PRCX'>0
QUIT Y
+2 NEW PRCINV
SET PRCINV=$PIECE($GET(^PRCP(445.2,PRCX,0)),"^")
+3 IF PRCINV>0
Begin DoDot:1
+4 NEW PRCSTA,PRCDA
SET PRCDA=""
SET PRCSTA=$PIECE($GET(^PRCP(445,PRCINV,0)),"-")
+5 if PRCSTA'=""
SET PRCDA=$ORDER(^PRC(420,"AE",PRCSTA,PRCINV,""))
+6 if PRCDA>0
SET Y=$PIECE($GET(^PRC(420,PRCSTA,1,PRCDA,0)),"^")
End DoDot:1
+7 QUIT Y
