PRCPEIPS ;WISC/RFJ-procurement sources edit ;01 Dec 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
SOURCES(INVPT,ITEMDA) ; check/update procurement sources invpt itemda
I '$D(^PRCP(445,+INVPT,1,+ITEMDA,0)) Q
;
N %,DATA,DIC,MANSRCE,TYPE,UP,UR,VENDA,VENDATA,VENDOR,Y
S TYPE=$P($G(^PRCP(445,+INVPT,0)),"^",3)
S IOP="HOME" D ^%ZIS K IOP W @IOF
;
; add procurement sources which should be there
W !!?5,"...adding ",$S(TYPE="S":"inventory points",1:"vendors from item master file")," as procurement sources"
; for warehouse and primaries
I TYPE'="S" D
. S DIC="^PRC(440,"
. S VENDA=0 F S VENDA=$O(^PRC(441,ITEMDA,2,VENDA)) Q:'VENDA I '$$GETVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",1) S Y=VENDA D SCREEN^PRCPUMAN(INVPT,ITEMDA,0) I $T D
. . W !?15,$P($G(^PRC(440,VENDA,0)),"^")," added" D ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,","","","")
. . I $Y>(IOSL-2) D R^PRCPUREP W @IOF
; secondaries
I TYPE="S" D
. S DIC="^PRCP(445,"
. S VENDA=0 F S VENDA=$O(^PRCP(445,"AB",INVPT,VENDA)) Q:'VENDA I '$$GETVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRCP(445,",1),$P($G(^PRCP(445,VENDA,0)),"^",3)="P",$D(^(2,INVPT,0)),$D(^PRCP(445,VENDA,1,ITEMDA,0)) D
. . W !?15,$P(^PRCP(445,VENDA,0),"^")," added" D ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRCP(445,","","","")
. . I $Y>(IOSL-2) D R^PRCPUREP W @IOF
I $Y>(IOSL-2) D R^PRCPUREP W @IOF
;
; check procurement sources
W !!?5,"...checking currently stored procurement sources"
S VENDA=0 F S VENDA=$O(^PRCP(445,INVPT,1,ITEMDA,5,VENDA)) Q:'VENDA S DATA=^(VENDA,0) I DATA'="" D
. S VENDOR=$$VENNAME^PRCPUX1($P(DATA,"^")),DIC=$S($P(DATA,"^")["PRCP(445":"^PRCP(445,",1:"^PRC(440,")
. I $Y>(IOSL-6) D R^PRCPUREP W @IOF
. W !?15,VENDOR S Y=+$P(DATA,"^") D SCREEN^PRCPUMAN(INVPT,ITEMDA,0)
. I '$T W " deleted" D DELVEN^PRCPUVEN(INVPT,ITEMDA,VENDA) Q
. ;
. ; update data
. ; secondaries
. I TYPE="S" D Q
. . S VENDATA=$G(^PRCP(445,+$P(DATA,"^"),1,ITEMDA,0)),UP=$$UNITVAL^PRCPUX1($P(VENDATA,"^",14),$P(VENDATA,"^",5)," per ")
. . S UR=$$UNITVAL^PRCPUX1($P(DATA,"^",3),$P(DATA,"^",2)," per ")
. . W !?25,"UNIT per PURCHASE: ",UP,!?25,"UNIT per RECEIPT: ",UR
. . I UP'=UR,UP'["?" S $P(DATA,"^",3)=$P(VENDATA,"^",14),$P(DATA,"^",2)=$P(VENDATA,"^",5) W !?25,"*** UNIT per RECEIPT changed to UNIT per PURCHASE ***"
. . I '$P(DATA,"^",4) S %=$P(^PRCP(445,INVPT,1,ITEMDA,0),"^",14) S:'% %=1 S $P(DATA,"^",4)=($P(DATA,"^",3)/%)\1 S:'$P(DATA,"^",4) $P(DATA,"^",4)=1
. . W !?25,"CONVERSION FACTOR: ",$P(DATA,"^",4)
. . S ^PRCP(445,INVPT,1,ITEMDA,5,VENDA,0)=DATA
. ;
. ; for primary and warehouse
. S VENDATA=$G(^PRC(441,ITEMDA,2,+$P(DATA,"^"),0)),UP=$$UNITVAL^PRCPUX1($P(VENDATA,"^",8),$P(VENDATA,"^",7)," per ")
. S UR=$$UNITVAL^PRCPUX1($P(DATA,"^",3),$P(DATA,"^",2)," per ")
. W ?54,"LAST COST: ",$J($P(VENDATA,"^",2),0,3),!?25,"UNIT per PURCHASE: ",UP,!?25,"UNIT per RECEIPT : ",UR
. I UP'=UR,UP'["?" S $P(DATA,"^",3)=$P(VENDATA,"^",8),$P(DATA,"^",2)=$P(VENDATA,"^",7) W !?25,"*** UNIT per RECEIPT changed to UNIT per PURCHASE ***"
. I '$P(DATA,"^",4) S %=$P($G(^PRCP(445,INVPT,1,ITEMDA,0)),"^",14) S:'% %=1 S $P(DATA,"^",4)=($P(DATA,"^",3)/%)\1 S:'$P(DATA,"^",4) $P(DATA,"^",4)=1
. W !?25,"CONVERSION FACTOR: ",$P(DATA,"^",4)
. S ^PRCP(445,INVPT,1,ITEMDA,5,VENDA,0)=DATA
I $Y>(IOSL-3) D R^PRCPUREP W @IOF
;
; check mandatory source
W !!?5,"...checking mandatory source in the inventory point"
S MANSRCE=+$$MANDSRCE^PRCPU441(ITEMDA)
I TYPE="W",MANSRCE'=$O(^PRC(440,"AC","S",0)) D
. W !,"ITEM IS NOT SET UP AS POSTED STOCK. THE MANDATORY SOURCE IN THE ITEM MASTER",!,"FILE DOES NOT EQUAL THE WAREHOUSE VENDOR."
. D SETMAN^PRCPEIPU(INVPT,ITEMDA,"")
I TYPE="P",MANSRCE D SETMAN^PRCPEIPU(INVPT,ITEMDA,MANSRCE_";PRC(440,")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEIPS 3947 printed Nov 22, 2024@17:23:41 Page 2
PRCPEIPS ;WISC/RFJ-procurement sources edit ;01 Dec 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
SOURCES(INVPT,ITEMDA) ; check/update procurement sources invpt itemda
+1 IF '$DATA(^PRCP(445,+INVPT,1,+ITEMDA,0))
QUIT
+2 ;
+3 NEW %,DATA,DIC,MANSRCE,TYPE,UP,UR,VENDA,VENDATA,VENDOR,Y
+4 SET TYPE=$PIECE($GET(^PRCP(445,+INVPT,0)),"^",3)
+5 SET IOP="HOME"
DO ^%ZIS
KILL IOP
WRITE @IOF
+6 ;
+7 ; add procurement sources which should be there
+8 WRITE !!?5,"...adding ",$SELECT(TYPE="S":"inventory points",1:"vendors from item master file")," as procurement sources"
+9 ; for warehouse and primaries
+10 IF TYPE'="S"
Begin DoDot:1
+11 SET DIC="^PRC(440,"
+12 SET VENDA=0
FOR
SET VENDA=$ORDER(^PRC(441,ITEMDA,2,VENDA))
if 'VENDA
QUIT
IF '$$GETVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,",1)
SET Y=VENDA
DO SCREEN^PRCPUMAN(INVPT,ITEMDA,0)
IF $TEST
Begin DoDot:2
+13 WRITE !?15,$PIECE($GET(^PRC(440,VENDA,0)),"^")," added"
DO ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRC(440,","","","")
+14 IF $Y>(IOSL-2)
DO R^PRCPUREP
WRITE @IOF
End DoDot:2
End DoDot:1
+15 ; secondaries
+16 IF TYPE="S"
Begin DoDot:1
+17 SET DIC="^PRCP(445,"
+18 SET VENDA=0
FOR
SET VENDA=$ORDER(^PRCP(445,"AB",INVPT,VENDA))
if 'VENDA
QUIT
IF '$$GETVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRCP(445,",1)
IF $PIECE($GET(^PRCP(445,VENDA,0)),"^",3)="P"
IF $DATA(^(2,INVPT,0))
IF $DATA(^PRCP(445,VENDA,1,ITEMDA,0))
Begin DoDot:2
+19 WRITE !?15,$PIECE(^PRCP(445,VENDA,0),"^")," added"
DO ADDVEN^PRCPUVEN(INVPT,ITEMDA,VENDA_";PRCP(445,","","","")
+20 IF $Y>(IOSL-2)
DO R^PRCPUREP
WRITE @IOF
End DoDot:2
End DoDot:1
+21 IF $Y>(IOSL-2)
DO R^PRCPUREP
WRITE @IOF
+22 ;
+23 ; check procurement sources
+24 WRITE !!?5,"...checking currently stored procurement sources"
+25 SET VENDA=0
FOR
SET VENDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA,5,VENDA))
if 'VENDA
QUIT
SET DATA=^(VENDA,0)
IF DATA'=""
Begin DoDot:1
+26 SET VENDOR=$$VENNAME^PRCPUX1($PIECE(DATA,"^"))
SET DIC=$SELECT($PIECE(DATA,"^")["PRCP(445":"^PRCP(445,",1:"^PRC(440,")
+27 IF $Y>(IOSL-6)
DO R^PRCPUREP
WRITE @IOF
+28 WRITE !?15,VENDOR
SET Y=+$PIECE(DATA,"^")
DO SCREEN^PRCPUMAN(INVPT,ITEMDA,0)
+29 IF '$TEST
WRITE " deleted"
DO DELVEN^PRCPUVEN(INVPT,ITEMDA,VENDA)
QUIT
+30 ;
+31 ; update data
+32 ; secondaries
+33 IF TYPE="S"
Begin DoDot:2
+34 SET VENDATA=$GET(^PRCP(445,+$PIECE(DATA,"^"),1,ITEMDA,0))
SET UP=$$UNITVAL^PRCPUX1($PIECE(VENDATA,"^",14),$PIECE(VENDATA,"^",5)," per ")
+35 SET UR=$$UNITVAL^PRCPUX1($PIECE(DATA,"^",3),$PIECE(DATA,"^",2)," per ")
+36 WRITE !?25,"UNIT per PURCHASE: ",UP,!?25,"UNIT per RECEIPT: ",UR
+37 IF UP'=UR
IF UP'["?"
SET $PIECE(DATA,"^",3)=$PIECE(VENDATA,"^",14)
SET $PIECE(DATA,"^",2)=$PIECE(VENDATA,"^",5)
WRITE !?25,"*** UNIT per RECEIPT changed to UNIT per PURCHASE ***"
+38 IF '$PIECE(DATA,"^",4)
SET %=$PIECE(^PRCP(445,INVPT,1,ITEMDA,0),"^",14)
if '%
SET %=1
SET $PIECE(DATA,"^",4)=($PIECE(DATA,"^",3)/%)\1
if '$PIECE(DATA,"^",4)
SET $PIECE(DATA,"^",4)=1
+39 WRITE !?25,"CONVERSION FACTOR: ",$PIECE(DATA,"^",4)
+40 SET ^PRCP(445,INVPT,1,ITEMDA,5,VENDA,0)=DATA
End DoDot:2
QUIT
+41 ;
+42 ; for primary and warehouse
+43 SET VENDATA=$GET(^PRC(441,ITEMDA,2,+$PIECE(DATA,"^"),0))
SET UP=$$UNITVAL^PRCPUX1($PIECE(VENDATA,"^",8),$PIECE(VENDATA,"^",7)," per ")
+44 SET UR=$$UNITVAL^PRCPUX1($PIECE(DATA,"^",3),$PIECE(DATA,"^",2)," per ")
+45 WRITE ?54,"LAST COST: ",$JUSTIFY($PIECE(VENDATA,"^",2),0,3),!?25,"UNIT per PURCHASE: ",UP,!?25,"UNIT per RECEIPT : ",UR
+46 IF UP'=UR
IF UP'["?"
SET $PIECE(DATA,"^",3)=$PIECE(VENDATA,"^",8)
SET $PIECE(DATA,"^",2)=$PIECE(VENDATA,"^",7)
WRITE !?25,"*** UNIT per RECEIPT changed to UNIT per PURCHASE ***"
+47 IF '$PIECE(DATA,"^",4)
SET %=$PIECE($GET(^PRCP(445,INVPT,1,ITEMDA,0)),"^",14)
if '%
SET %=1
SET $PIECE(DATA,"^",4)=($PIECE(DATA,"^",3)/%)\1
if '$PIECE(DATA,"^",4)
SET $PIECE(DATA,"^",4)=1
+48 WRITE !?25,"CONVERSION FACTOR: ",$PIECE(DATA,"^",4)
+49 SET ^PRCP(445,INVPT,1,ITEMDA,5,VENDA,0)=DATA
End DoDot:1
+50 IF $Y>(IOSL-3)
DO R^PRCPUREP
WRITE @IOF
+51 ;
+52 ; check mandatory source
+53 WRITE !!?5,"...checking mandatory source in the inventory point"
+54 SET MANSRCE=+$$MANDSRCE^PRCPU441(ITEMDA)
+55 IF TYPE="W"
IF MANSRCE'=$ORDER(^PRC(440,"AC","S",0))
Begin DoDot:1
+56 WRITE !,"ITEM IS NOT SET UP AS POSTED STOCK. THE MANDATORY SOURCE IN THE ITEM MASTER",!,"FILE DOES NOT EQUAL THE WAREHOUSE VENDOR."
+57 DO SETMAN^PRCPEIPU(INVPT,ITEMDA,"")
End DoDot:1
+58 IF TYPE="P"
IF MANSRCE
DO SETMAN^PRCPEIPU(INVPT,ITEMDA,MANSRCE_";PRC(440,")
+59 QUIT
