PRCPUVEN ;WISC/RFJ-add,update,delete procurement sources ;06 Oct 91
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
ADDVEN(INVPT,ITEMDA,VENDOR,UNITREC,PKGMULT,CONVFACT) ; add procurement source
; vendor=vendorda;prc(440,
; vendor will be added if its not already there.
; data will be updated if not null.
I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
N %,DATA,X,Y
S Y=$O(^PRCP(445,INVPT,1,ITEMDA,5,"B",VENDOR,0))
I 'Y D
. N DA,DIC,D0,DD,DLAYGO,DINUM,X
. S:'$D(^PRCP(445,INVPT,1,ITEMDA,5,0)) ^(0)="^445.07IV^^"
. S DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,",X=VENDOR,DA(1)=ITEMDA,DA(2)=INVPT,DIC(0)="L",DLAYGO=445
. D FILE^DICN
I '$D(^PRCP(445,INVPT,1,ITEMDA,5,+Y,0)) Q
L +^PRCP(445,INVPT,1,ITEMDA,5,+Y)
S DATA=^PRCP(445,INVPT,1,ITEMDA,5,+Y,0)
I UNITREC S $P(DATA,"^",2)=UNITREC
I PKGMULT S $P(DATA,"^",3)=PKGMULT
I CONVFACT S $P(DATA,"^",4)=CONVFACT
S ^PRCP(445,INVPT,1,ITEMDA,5,+Y,0)=DATA
L -^PRCP(445,INVPT,1,ITEMDA,5,+Y)
Q
;
;
DELVEN(INVPT,ITEMDA,VENDORDA) ; delete procurement sources
; vendorda=entryda for procurement source
I '$D(^PRCP(445,INVPT,1,ITEMDA,5,VENDORDA,0)) Q
N %,DA,DIC,DIK,X,Y
S DIK="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,",DA=VENDORDA,DA(1)=ITEMDA,DA(2)=INVPT
D ^DIK
Q
;
;
GETVEN(INVPT,ITEMDA,VENDOR,CONVFACT) ; get procurement source data
; vendor=vendor;prcp(445 or vendor;prc(440
; if 'conv factor, convfact=convfact passed
; returns procsource^unitrec^pkgmult^conv^entryda
S %=+$O(^PRCP(445,INVPT,1,ITEMDA,5,"B",VENDOR,0)),Y=$G(^PRCP(445,INVPT,1,ITEMDA,5,%,0))
I CONVFACT S:'$P(Y,"^",4) $P(Y,"^",4)=CONVFACT
I 'Y Q Y
S $P(Y,"^",5)=%
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUVEN 1721 printed Dec 13, 2024@02:16:31 Page 2
PRCPUVEN ;WISC/RFJ-add,update,delete procurement sources ;06 Oct 91
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ADDVEN(INVPT,ITEMDA,VENDOR,UNITREC,PKGMULT,CONVFACT) ; add procurement source
+1 ; vendor=vendorda;prc(440,
+2 ; vendor will be added if its not already there.
+3 ; data will be updated if not null.
+4 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,0))
QUIT
+5 NEW %,DATA,X,Y
+6 SET Y=$ORDER(^PRCP(445,INVPT,1,ITEMDA,5,"B",VENDOR,0))
+7 IF 'Y
Begin DoDot:1
+8 NEW DA,DIC,D0,DD,DLAYGO,DINUM,X
+9 if '$DATA(^PRCP(445,INVPT,1,ITEMDA,5,0))
SET ^(0)="^445.07IV^^"
+10 SET DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,"
SET X=VENDOR
SET DA(1)=ITEMDA
SET DA(2)=INVPT
SET DIC(0)="L"
SET DLAYGO=445
+11 DO FILE^DICN
End DoDot:1
+12 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,5,+Y,0))
QUIT
+13 LOCK +^PRCP(445,INVPT,1,ITEMDA,5,+Y)
+14 SET DATA=^PRCP(445,INVPT,1,ITEMDA,5,+Y,0)
+15 IF UNITREC
SET $PIECE(DATA,"^",2)=UNITREC
+16 IF PKGMULT
SET $PIECE(DATA,"^",3)=PKGMULT
+17 IF CONVFACT
SET $PIECE(DATA,"^",4)=CONVFACT
+18 SET ^PRCP(445,INVPT,1,ITEMDA,5,+Y,0)=DATA
+19 LOCK -^PRCP(445,INVPT,1,ITEMDA,5,+Y)
+20 QUIT
+21 ;
+22 ;
DELVEN(INVPT,ITEMDA,VENDORDA) ; delete procurement sources
+1 ; vendorda=entryda for procurement source
+2 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,5,VENDORDA,0))
QUIT
+3 NEW %,DA,DIC,DIK,X,Y
+4 SET DIK="^PRCP(445,"_INVPT_",1,"_ITEMDA_",5,"
SET DA=VENDORDA
SET DA(1)=ITEMDA
SET DA(2)=INVPT
+5 DO ^DIK
+6 QUIT
+7 ;
+8 ;
GETVEN(INVPT,ITEMDA,VENDOR,CONVFACT) ; get procurement source data
+1 ; vendor=vendor;prcp(445 or vendor;prc(440
+2 ; if 'conv factor, convfact=convfact passed
+3 ; returns procsource^unitrec^pkgmult^conv^entryda
+4 SET %=+$ORDER(^PRCP(445,INVPT,1,ITEMDA,5,"B",VENDOR,0))
SET Y=$GET(^PRCP(445,INVPT,1,ITEMDA,5,%,0))
+5 IF CONVFACT
if '$PIECE(Y,"^",4)
SET $PIECE(Y,"^",4)=CONVFACT
+6 IF 'Y
QUIT Y
+7 SET $PIECE(Y,"^",5)=%
+8 QUIT Y
