source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPL1.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1PRCPWPL1 ;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 ;
7SUBST ; 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 ;
57SUBITEM() ; 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 ;
67NEWLINE(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
Note: See TracBrowser for help on using the repository browser.