Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHITX

PRCHITX.m

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