74 lines
4.1 KiB
Mathematica
74 lines
4.1 KiB
Mathematica
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
|