PRCPWPL1 ;WISC/RFJ-whse post issue book (substitute) ;13 Jan 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
SUBST ; substitute item
D FULL^VALM1
S VALMBCK="R"
N CONV,DATA,DIR,DR,INVDATA,ITEMDA,LINEDA,VENDDATA,NEWLINE,QTYORD,STATUS,SUBACCT,SUBITEM,UNITCOST,VENDOR,X
K X S X(1)="This option will allow you to CANCEL and SUBSTITUTE a line item on the issue book. Once a line item is cancelled, the oustanding quantity will be set to zero and the due-ins and due-outs will be cancelled."
D DISPLAY^PRCPUX2(5,75,.X)
F W ! S LINEDA=$$LINEITEM^PRCPWPL0 Q:LINEDA<1 D
. S DATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I DATA="" W !,"CANNOT FIND LINE ITEM." Q
. S STATUS=$P(DATA,"^",14)
. I STATUS'="" W !,"ITEM IS CANCELLED",$S(STATUS["S":" AND SUBSTITUTED WITH LINE #(S): "_$P(STATUS,",",2,99),1:"")
. S ITEMDA=+$P(DATA,"^",5) I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) W !,"ITEM IS NOT STORED IN THE INVENTORY POINT." Q
. F W ! S SUBITEM=$$SUBITEM Q:SUBITEM<1 D Q:SUBITEM
. . S INVDATA=$G(^PRCP(445,PRCPINPT,1,SUBITEM,0))
. . I INVDATA="" W !,"SUBSTITUTE ITEM IS NOT STORED IN THE WAREHOUSE INVENTORY POINT." S SUBITEM=0 Q
. . S VENDDATA=$G(^PRC(441,SUBITEM,2,+PRCPPVNO,0))
. . I VENDDATA="" W !,"WAREHOUSE IS NOT ESTABLISHED AS A VENDOR FOR THIS ITEM." S SUBITEM=0 Q
. I SUBITEM<1 Q
. S UNITCOST=$P(INVDATA,"^",22) S:$P(INVDATA,"^",15)>UNITCOST UNITCOST=$P(INVDATA,"^",15) S:$P(VENDDATA,"^",2)>UNITCOST UNITCOST=$P(VENDDATA,"^",2) S UNITCOST=$J(UNITCOST,0,2)
. W !!,SUBITEM,?5,$E($$DESCR^PRCPUX1(PRCPINPT,SUBITEM),1,30)," ",$$NSN^PRCPUX1(SUBITEM)
. W !?5,"UNIT/ISSUE : ",$$UNIT^PRCPUX1(PRCPINPT,SUBITEM,"/")
. W !?5,"UNIT/PURCHASE : ",$$UNITVAL^PRCPUX1($P(VENDDATA,"^",8),$P(VENDDATA,"^",7),"/")
. W !?5,"AVERAGE COST : ",$J(+$P(INVDATA,"^",22),0,2)
. W !?5,"LAST COST : ",$J(+$P(INVDATA,"^",15),0,2)
. W !?5,"CHARGE UNITCOST: ",UNITCOST
. W !
. W !?5,"QTY ON-HAND : ",+$P(INVDATA,"^",7)
. S DIR(0)="NA^0:99999:0",DIR("A")=" QUANTITY ORDERED: "
. S DIR("A",1)="Enter the quantity ordered for this item."
. W ! D ^DIR K DIR S QTYORD=+Y
. S XP="ARE YOU SURE YOU WANT TO CANCEL AND SUBSTITUTE THIS ITEM",XH="Enter YES to CANCEL and SUBSTITUTE this line item."
. W ! I $$YN^PRCPUYN(1)'=1 Q
. I $E(STATUS)'="C" W !!,"cancelling original ordered item..." D CANCELIT^PRCPWPL2
. F NEWLINE=$P(^PRCS(410,PRCPDA,"IT",0),"^",3)+1:1 Q:'$D(^PRCS(410,PRCPDA,"IT",NEWLINE,0))
. W !!,"adding a NEW line item (#",NEWLINE,") as a substitute item..."
. S SUBACCT=$E($P($G(^PRCD(420.2,+$$SUBACCT^PRCPU441(SUBITEM),0)),"^"),1,30)
. S DR="2///"_QTYORD_";3///"_$P(VENDDATA,"^",7)_";4//"_SUBACCT_";5///"_SUBITEM_";7//"_$S('UNITCOST:"",1:"/"_UNITCOST)
. D NEWLINE(DR)
. ;
. ; update cancelled item
. S STATUS=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",14) I STATUS'["S" S STATUS=STATUS_"S"
. S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",14)=STATUS_", "_NEWLINE
. I $D(^PRCP(445,PRCPINPT,1,SUBITEM,0)) W !?5,"... incrementing due-outs@warehouse by ",QTYORD D SETOUT^PRCPUDUE(PRCPINPT,SUBITEM,QTYORD)
. I $D(^PRCP(445,PRCPPRIM,1,SUBITEM,0)) D
. . S VENDOR=$$GETVEN^PRCPUVEN(PRCPPRIM,SUBITEM,PRCPPVNO,1),CONV=$P(VENDOR,"^",4)
. . W !?5,"... incrementing due-ins @primary by ",QTYORD*CONV W:CONV>1 " (convfact: ",CONV,")"
. . D ADDUPD^PRCPUTRA(PRCPPRIM,SUBITEM,PRCPDA,QTYORD*CONV_"^"_$P(VENDOR,"^",2)_"^"_$P(VENDOR,"^",3)_"^"_CONV)
D REBUILD^PRCPWPLB
Q
;
;
SUBITEM() ; select substitute item
N DIC,DA,X,Y
I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) Q 0
I '$D(^PRCP(445,PRCPINPT,1,ITEMDA,4,0)) S ^(0)="^445.122PI^^"
S DIC="^PRCP(445,"_PRCPINPT_",1,"_ITEMDA_",4,",DA(1)=PRCPINPT,DA=ITEMDA,DIC(0)="QEAM"
S DIC("W")="N %,Z S %=$G(^PRC(441,+Y,0)),Z=$G(^PRCP(445,PRCPINPT,1,+Y,0)) W ?7,"" "",$P(%,U,5),?32,$E($P($G(^PRCP(445,PRCPINPT,1,+Y,6)),U),1,20),?55,"" QTY ON-HAND: "",$P(Z,U,7)"
D ^DIC
Q +Y
;
;
NEWLINE(DR) ; set new line item in issue book
N %,C,D0,DA,DD,DDH,DI,DIC,DIE,DLAYGO,DQ,I,PRCS,X,Y
S DIC="^PRCS(410,"_PRCPDA_",""IT"",",DIC(0)="L",DLAYGO=410,DA(1)=PRCPDA,X=NEWLINE
S DIE("NO^")=""
I DR'="" S DIC("DR")=DR
D FILE^DICN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPL1 4304 printed Sep 23, 2025@19:52:44 Page 2
PRCPWPL1 ;WISC/RFJ-whse post issue book (substitute) ;13 Jan 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
SUBST ; substitute item
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 NEW CONV,DATA,DIR,DR,INVDATA,ITEMDA,LINEDA,VENDDATA,NEWLINE,QTYORD,STATUS,SUBACCT,SUBITEM,UNITCOST,VENDOR,X
+4 KILL X
SET X(1)="This option will allow you to CANCEL and SUBSTITUTE a line item on the issue book. Once a line item is cancelled, the oustanding quantity will be set to zero and the due-ins and due-outs will be cancelled."
+5 DO DISPLAY^PRCPUX2(5,75,.X)
+6 FOR
WRITE !
SET LINEDA=$$LINEITEM^PRCPWPL0
if LINEDA<1
QUIT
Begin DoDot:1
+7 SET DATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
IF DATA=""
WRITE !,"CANNOT FIND LINE ITEM."
QUIT
+8 SET STATUS=$PIECE(DATA,"^",14)
+9 IF STATUS'=""
WRITE !,"ITEM IS CANCELLED",$SELECT(STATUS["S":" AND SUBSTITUTED WITH LINE #(S): "_$PIECE(STATUS,",",2,99),1:"")
+10 SET ITEMDA=+$PIECE(DATA,"^",5)
IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
WRITE !,"ITEM IS NOT STORED IN THE INVENTORY POINT."
QUIT
+11 FOR
WRITE !
SET SUBITEM=$$SUBITEM
if SUBITEM<1
QUIT
Begin DoDot:2
+12 SET INVDATA=$GET(^PRCP(445,PRCPINPT,1,SUBITEM,0))
+13 IF INVDATA=""
WRITE !,"SUBSTITUTE ITEM IS NOT STORED IN THE WAREHOUSE INVENTORY POINT."
SET SUBITEM=0
QUIT
+14 SET VENDDATA=$GET(^PRC(441,SUBITEM,2,+PRCPPVNO,0))
+15 IF VENDDATA=""
WRITE !,"WAREHOUSE IS NOT ESTABLISHED AS A VENDOR FOR THIS ITEM."
SET SUBITEM=0
QUIT
End DoDot:2
if SUBITEM
QUIT
+16 IF SUBITEM<1
QUIT
+17 SET UNITCOST=$PIECE(INVDATA,"^",22)
if $PIECE(INVDATA,"^",15)>UNITCOST
SET UNITCOST=$PIECE(INVDATA,"^",15)
if $PIECE(VENDDATA,"^",2)>UNITCOST
SET UNITCOST=$PIECE(VENDDATA,"^",2)
SET UNITCOST=$JUSTIFY(UNITCOST,0,2)
+18 WRITE !!,SUBITEM,?5,$EXTRACT($$DESCR^PRCPUX1(PRCPINPT,SUBITEM),1,30)," ",$$NSN^PRCPUX1(SUBITEM)
+19 WRITE !?5,"UNIT/ISSUE : ",$$UNIT^PRCPUX1(PRCPINPT,SUBITEM,"/")
+20 WRITE !?5,"UNIT/PURCHASE : ",$$UNITVAL^PRCPUX1($PIECE(VENDDATA,"^",8),$PIECE(VENDDATA,"^",7),"/")
+21 WRITE !?5,"AVERAGE COST : ",$JUSTIFY(+$PIECE(INVDATA,"^",22),0,2)
+22 WRITE !?5,"LAST COST : ",$JUSTIFY(+$PIECE(INVDATA,"^",15),0,2)
+23 WRITE !?5,"CHARGE UNITCOST: ",UNITCOST
+24 WRITE !
+25 WRITE !?5,"QTY ON-HAND : ",+$PIECE(INVDATA,"^",7)
+26 SET DIR(0)="NA^0:99999:0"
SET DIR("A")=" QUANTITY ORDERED: "
+27 SET DIR("A",1)="Enter the quantity ordered for this item."
+28 WRITE !
DO ^DIR
KILL DIR
SET QTYORD=+Y
+29 SET XP="ARE YOU SURE YOU WANT TO CANCEL AND SUBSTITUTE THIS ITEM"
SET XH="Enter YES to CANCEL and SUBSTITUTE this line item."
+30 WRITE !
IF $$YN^PRCPUYN(1)'=1
QUIT
+31 IF $EXTRACT(STATUS)'="C"
WRITE !!,"cancelling original ordered item..."
DO CANCELIT^PRCPWPL2
+32 FOR NEWLINE=$PIECE(^PRCS(410,PRCPDA,"IT",0),"^",3)+1:1
if '$DATA(^PRCS(410,PRCPDA,"IT",NEWLINE,0))
QUIT
+33 WRITE !!,"adding a NEW line item (#",NEWLINE,") as a substitute item..."
+34 SET SUBACCT=$EXTRACT($PIECE($GET(^PRCD(420.2,+$$SUBACCT^PRCPU441(SUBITEM),0)),"^"),1,30)
+35 SET DR="2///"_QTYORD_";3///"_$PIECE(VENDDATA,"^",7)_";4//"_SUBACCT_";5///"_SUBITEM_";7//"_$SELECT('UNITCOST:"",1:"/"_UNITCOST)
+36 DO NEWLINE(DR)
+37 ;
+38 ; update cancelled item
+39 SET STATUS=$PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",14)
IF STATUS'["S"
SET STATUS=STATUS_"S"
+40 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",14)=STATUS_", "_NEWLINE
+41 IF $DATA(^PRCP(445,PRCPINPT,1,SUBITEM,0))
WRITE !?5,"... incrementing due-outs@warehouse by ",QTYORD
DO SETOUT^PRCPUDUE(PRCPINPT,SUBITEM,QTYORD)
+42 IF $DATA(^PRCP(445,PRCPPRIM,1,SUBITEM,0))
Begin DoDot:2
+43 SET VENDOR=$$GETVEN^PRCPUVEN(PRCPPRIM,SUBITEM,PRCPPVNO,1)
SET CONV=$PIECE(VENDOR,"^",4)
+44 WRITE !?5,"... incrementing due-ins @primary by ",QTYORD*CONV
if CONV>1
WRITE " (convfact: ",CONV,")"
+45 DO ADDUPD^PRCPUTRA(PRCPPRIM,SUBITEM,PRCPDA,QTYORD*CONV_"^"_$PIECE(VENDOR,"^",2)_"^"_$PIECE(VENDOR,"^",3)_"^"_CONV)
End DoDot:2
End DoDot:1
+46 DO REBUILD^PRCPWPLB
+47 QUIT
+48 ;
+49 ;
SUBITEM() ; select substitute item
+1 NEW DIC,DA,X,Y
+2 IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
QUIT 0
+3 IF '$DATA(^PRCP(445,PRCPINPT,1,ITEMDA,4,0))
SET ^(0)="^445.122PI^^"
+4 SET DIC="^PRCP(445,"_PRCPINPT_",1,"_ITEMDA_",4,"
SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET DIC(0)="QEAM"
+5 SET DIC("W")="N %,Z S %=$G(^PRC(441,+Y,0)),Z=$G(^PRCP(445,PRCPINPT,1,+Y,0)) W ?7,"" "",$P(%,U,5),?32,$E($P($G(^PRCP(445,PRCPINPT,1,+Y,6)),U),1,20),?55,"" QTY ON-HAND: "",$P(Z,U,7)"
+6 DO ^DIC
+7 QUIT +Y
+8 ;
+9 ;
NEWLINE(DR) ; set new line item in issue book
+1 NEW %,C,D0,DA,DD,DDH,DI,DIC,DIE,DLAYGO,DQ,I,PRCS,X,Y
+2 SET DIC="^PRCS(410,"_PRCPDA_",""IT"","
SET DIC(0)="L"
SET DLAYGO=410
SET DA(1)=PRCPDA
SET X=NEWLINE
+3 SET DIE("NO^")=""
+4 IF DR'=""
SET DIC("DR")=DR
+5 DO FILE^DICN
+6 QUIT
