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