Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPAWI0

PRCPAWI0.m

Go to the documentation of this file.
  1. PRCPAWI0 ;WISC/RFJ-adjust inventory level - issue adjustment ;11 Mar 94
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. ; called from prcpawa0 for type 1 issue book adjustment
  1. ISUEBOOK ; issue book adjustment
  1. N PRCPDA,PRCPPVNO
  1. 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
  1. F S PRCPDA=$$SELECTIB^PRCPWPLM(0) Q:PRCPDA'>0 D
  1. . L +^PRCS(410,PRCPDA):5 I '$T D SHOWWHO^PRCPULOC(410,PRCPDA,0) Q
  1. . D ADD^PRCPULOC(410,PRCPDA,0,"Adjust Issue Book")
  1. . N %,DISTRPT,OTHERPT,TRANNO,VOUCHER
  1. . S TRANNO=$P($G(^PRCS(410,PRCPDA,0)),"^")
  1. . I TRANNO="" W !,"CANNOT FIND THE TRANSACTION NUMBER FOR THIS ISSUE BOOK." D UNLOCK Q
  1. . S %=$G(^PRCS(410,PRCPDA,445))
  1. . I '$P(%,"^",2) W !,"THIS ISSUE BOOK HAS NOT BEEN POSTED (NO FMS LINE NUMBER) AND CANNOT BE ADJUSTED." D UNLOCK Q
  1. . S VOUCHER=$P(%,"^")
  1. . I VOUCHER="" W !,"THIS ISSUE BOOK DOES NOT HAVE A REFERENCE VOUCHER NUMBER AND CANNOT BE ADJUSTED." D UNLOCK Q
  1. . W !!,">> Reference Voucher Number: ",VOUCHER
  1. . S (DISTRPT,OTHERPT)=+$P(^PRCS(410,PRCPDA,0),"^",6)
  1. . I DISTRPT D
  1. . . W !!,">> Distribution to: ",$$INVNAME^PRCPUX1(DISTRPT)," inventory point."
  1. . . S %=$G(^PRCP(445,DISTRPT,0))
  1. . . I $P(%,"^",2)'="Y" W !,"NOTE: Primary is NOT keeping a PERPETUAL INVENTORY." S DISTRPT=0
  1. . . I $P(%,"^",6)'="Y" W !,"NOTE: Primary is NOT keeping a DETAILED TRANSACTION REGISTER." S DISTRPT=0
  1. . . I $P(%,"^",16)="N" W !,"NOTE: Primary set up so it will NOT be updated by the warehouse." S DISTRPT=0
  1. . . I 'DISTRPT W !,">> PRIMARY inventory point will NOT be updated."
  1. . ; get line adjustments
  1. . D LINEADJ
  1. . I '$O(^TMP($J,"PRCPAWI0","PROCESS",0)) W !!?10,">> NO LINE ITEMS HAVE BEEN SELECTED <<" D UNLOCK Q
  1. . ; get whse and buyer fcp data
  1. . N PRCPPBFY,PRCPPFCP,PRCPPSTA,PRCPWBFY,PRCPWFCP,PRCPWSTA
  1. . D IVDATA^PRCPSFIU(PRCPDA,PRCP("I"))
  1. . S XP="READY TO PROCESS ISSUE BOOK ADJUSTMENTS",XH="Enter YES to PROCESS the ISSUE BOOK adjustments, NO to exit."
  1. . W !! I $$YN^PRCPUYN(1)'=1 D UNLOCK Q
  1. . D ISUECONT^PRCPAWI1
  1. . D UNLOCK
  1. ;
  1. Q K ^TMP($J,"PRCPAWI0")
  1. Q
  1. ;
  1. ;
  1. UNLOCK ; unlock issue book lock
  1. D CLEAR^PRCPULOC(410,PRCPDA,0)
  1. L -^PRCS(410,PRCPDA)
  1. Q
  1. ;
  1. ;
  1. LINEITEM() ; select line item
  1. N DA,DIC,X,Y
  1. S DIC="^PRCS(410,"_PRCPDA_",""IT"",",DA(1)=PRCPDA,DIC(0)="QEAMZ",DIC("A")="Select LINE ITEM Number: "
  1. 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)"
  1. D ^DIC
  1. Q +Y
  1. ;
  1. ;
  1. LINEADJ ; enter line adjustment
  1. N INVVALUE,ITEMDA,ITEMDATA,LINEDA,LINEDATA,POSTDATA,QTY,REASON,SELVALUE
  1. K ^TMP($J,"PRCPAWI0")
  1. F W ! S LINEDA=$$LINEITEM Q:LINEDA'>0 D
  1. . S LINEDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)),ITEMDA=+$P(LINEDATA,"^",5) I 'ITEMDA W !,"MISSING ITEM MASTER NUMBER." Q
  1. . D SHOWDATA^PRCPAWA0(PRCP("I"),ITEMDA)
  1. . W !!,"======================= I S S U E B O O K D A T A ======================="
  1. . S POSTDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
  1. . W !?5,"QUANTITY ORDERED: ",+$P(LINEDATA,"^",2)
  1. . W !?5,"QUANTITY POSTED : ",+$P(POSTDATA,"^",3)
  1. . W !?5,"INVENTORY VALUE : ",$J(+$P(POSTDATA,"^",4),0,2)
  1. . W !?5,"SELLING VALUE : ",$J(+$P(POSTDATA,"^",5),0,2),!
  1. . 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
  1. . ; enter adjustment
  1. . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)) I ITEMDATA="" W !,"THIS ITEM IS NOT STORED IN THE INVENTORY POINT." Q
  1. . ; line item already selected
  1. . 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
  1. . K ^TMP($J,"PRCPAWI0","PROCESS",LINEDA)
  1. . W !!,"**************** E N T E R A D J U S T M E N T D A T A ****************",!
  1. . S QTY=$$QTY^PRCPAWU0(-$P(POSTDATA,"^",3),0) I QTY["^" Q
  1. . S INVVALUE=$$VALUE^PRCPAWU0(-$P(POSTDATA,"^",4),99999.99," ISSUE BOOK INVENTORY","") I INVVALUE["^" Q
  1. . S SELVALUE=$$VALUE^PRCPAWU0(-$P(POSTDATA,"^",5),99999.99," ISSUE BOOK SELLING","") I SELVALUE["^" Q
  1. . I 'QTY,'INVVALUE,'SELVALUE W !!?10,">> EITHER QUANTITY OR VALUE NEEDS TO BE ENTERED FOR AN ADJUSTMENT <<" Q
  1. . W ! S REASON=$$REASON^PRCPAWU0("ISSUE BOOK adjustment") I REASON["^" Q
  1. . S ^TMP($J,"PRCPAWI0","PROCESS",LINEDA)=QTY_"^"_SELVALUE_"^"_INVVALUE_"^^^"_REASON_"^"_ITEMDA
  1. Q