source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAWI0.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1PRCPAWI0 ;WISC/RFJ-adjust inventory level - issue adjustment ;11 Mar 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 ; called from prcpawa0 for type 1 issue book adjustment
8ISUEBOOK ; issue book adjustment
9 N PRCPDA,PRCPPVNO
10 S PRCPPVNO=+$O(^PRC(440,"AC","S",0))_";PRC(440," I '$D(^PRC(440,+PRCPPVNO,0)) W !!,"THERE IS NOT A VENDOR IN THE VENDOR FILE (#440) DESIGNATED AS A SUPPLY WHSE." Q
11 F S PRCPDA=$$SELECTIB^PRCPWPLM(0) Q:PRCPDA'>0 D
12 . L +^PRCS(410,PRCPDA):5 I '$T D SHOWWHO^PRCPULOC(410,PRCPDA,0) Q
13 . D ADD^PRCPULOC(410,PRCPDA,0,"Adjust Issue Book")
14 . N %,DISTRPT,OTHERPT,TRANNO,VOUCHER
15 . S TRANNO=$P($G(^PRCS(410,PRCPDA,0)),"^")
16 . I TRANNO="" W !,"CANNOT FIND THE TRANSACTION NUMBER FOR THIS ISSUE BOOK." D UNLOCK Q
17 . S %=$G(^PRCS(410,PRCPDA,445))
18 . I '$P(%,"^",2) W !,"THIS ISSUE BOOK HAS NOT BEEN POSTED (NO FMS LINE NUMBER) AND CANNOT BE ADJUSTED." D UNLOCK Q
19 . S VOUCHER=$P(%,"^")
20 . I VOUCHER="" W !,"THIS ISSUE BOOK DOES NOT HAVE A REFERENCE VOUCHER NUMBER AND CANNOT BE ADJUSTED." D UNLOCK Q
21 . W !!,">> Reference Voucher Number: ",VOUCHER
22 . S (DISTRPT,OTHERPT)=+$P(^PRCS(410,PRCPDA,0),"^",6)
23 . I DISTRPT D
24 . . W !!,">> Distribution to: ",$$INVNAME^PRCPUX1(DISTRPT)," inventory point."
25 . . S %=$G(^PRCP(445,DISTRPT,0))
26 . . I $P(%,"^",2)'="Y" W !,"NOTE: Primary is NOT keeping a PERPETUAL INVENTORY." S DISTRPT=0
27 . . I $P(%,"^",6)'="Y" W !,"NOTE: Primary is NOT keeping a DETAILED TRANSACTION REGISTER." S DISTRPT=0
28 . . I $P(%,"^",16)="N" W !,"NOTE: Primary set up so it will NOT be updated by the warehouse." S DISTRPT=0
29 . . I 'DISTRPT W !,">> PRIMARY inventory point will NOT be updated."
30 . ; get line adjustments
31 . D LINEADJ
32 . I '$O(^TMP($J,"PRCPAWI0","PROCESS",0)) W !!?10,">> NO LINE ITEMS HAVE BEEN SELECTED <<" D UNLOCK Q
33 . ; get whse and buyer fcp data
34 . N PRCPPBFY,PRCPPFCP,PRCPPSTA,PRCPWBFY,PRCPWFCP,PRCPWSTA
35 . D IVDATA^PRCPSFIU(PRCPDA,PRCP("I"))
36 . S XP="READY TO PROCESS ISSUE BOOK ADJUSTMENTS",XH="Enter YES to PROCESS the ISSUE BOOK adjustments, NO to exit."
37 . W !! I $$YN^PRCPUYN(1)'=1 D UNLOCK Q
38 . D ISUECONT^PRCPAWI1
39 . D UNLOCK
40 ;
41Q K ^TMP($J,"PRCPAWI0")
42 Q
43 ;
44 ;
45UNLOCK ; unlock issue book lock
46 D CLEAR^PRCPULOC(410,PRCPDA,0)
47 L -^PRCS(410,PRCPDA)
48 Q
49 ;
50 ;
51LINEITEM() ; select line item
52 N DA,DIC,X,Y
53 S DIC="^PRCS(410,"_PRCPDA_",""IT"",",DA(1)=PRCPDA,DIC(0)="QEAMZ",DIC("A")="Select LINE ITEM Number: "
54 S DIC("W")="S %=$G(^PRCS(410,PRCPDA,""IT"",Y,445)) W ?7,""IM#: "",$P(^PRCS(410,PRCPDA,""IT"",Y,0),U,5),?20,"" QTY POSTED: ""_+$P(%,U,3),?40,"" INV VALUE: "",$J(+$P(%,U,4),0,2),?60,"" SELL VALUE: "",$J(+$P(%,U,5),0,2)"
55 D ^DIC
56 Q +Y
57 ;
58 ;
59LINEADJ ; enter line adjustment
60 N INVVALUE,ITEMDA,ITEMDATA,LINEDA,LINEDATA,POSTDATA,QTY,REASON,SELVALUE
61 K ^TMP($J,"PRCPAWI0")
62 F W ! S LINEDA=$$LINEITEM Q:LINEDA'>0 D
63 . S LINEDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)),ITEMDA=+$P(LINEDATA,"^",5) I 'ITEMDA W !,"MISSING ITEM MASTER NUMBER." Q
64 . D SHOWDATA^PRCPAWA0(PRCP("I"),ITEMDA)
65 . W !!,"======================= I S S U E B O O K D A T A ======================="
66 . S POSTDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
67 . W !?5,"QUANTITY ORDERED: ",+$P(LINEDATA,"^",2)
68 . W !?5,"QUANTITY POSTED : ",+$P(POSTDATA,"^",3)
69 . W !?5,"INVENTORY VALUE : ",$J(+$P(POSTDATA,"^",4),0,2)
70 . W !?5,"SELLING VALUE : ",$J(+$P(POSTDATA,"^",5),0,2),!
71 . I $P(POSTDATA,"^")=""!('$P(POSTDATA,"^",3)&('$P(POSTDATA,"^",4))&('$P(POSTDATA,"^",5))) W !,"THIS LINE ITEM HAS NOT BEEN POSTED AND CANNOT BE ADJUSTED." Q
72 . ; enter adjustment
73 . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)) I ITEMDATA="" W !,"THIS ITEM IS NOT STORED IN THE INVENTORY POINT." Q
74 . ; line item already selected
75 . I $D(^TMP($J,"PRCPAWI0","PROCESS",LINEDA)) S XP=" THIS ITEM WAS PREVIOUSLY SELECTED DURING THIS SELECTION PROCESS.",XP(1)=" OK TO REMOVE THIS ADJUSTMENT SO YOU CAN ENTER A NEW ONE" W !! I $$YN^PRCPUYN(1)'=1 Q
76 . K ^TMP($J,"PRCPAWI0","PROCESS",LINEDA)
77 . W !!,"**************** E N T E R A D J U S T M E N T D A T A ****************",!
78 . S QTY=$$QTY^PRCPAWU0(-$P(POSTDATA,"^",3),0) I QTY["^" Q
79 . S INVVALUE=$$VALUE^PRCPAWU0(-$P(POSTDATA,"^",4),99999.99," ISSUE BOOK INVENTORY","") I INVVALUE["^" Q
80 . S SELVALUE=$$VALUE^PRCPAWU0(-$P(POSTDATA,"^",5),99999.99," ISSUE BOOK SELLING","") I SELVALUE["^" Q
81 . I 'QTY,'INVVALUE,'SELVALUE W !!?10,">> EITHER QUANTITY OR VALUE NEEDS TO BE ENTERED FOR AN ADJUSTMENT <<" Q
82 . W ! S REASON=$$REASON^PRCPAWU0("ISSUE BOOK adjustment") I REASON["^" Q
83 . S ^TMP($J,"PRCPAWI0","PROCESS",LINEDA)=QTY_"^"_SELVALUE_"^"_INVVALUE_"^^^"_REASON_"^"_ITEMDA
84 Q
Note: See TracBrowser for help on using the repository browser.