- 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 Jan 18, 2025@03:17:42 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