PRCPAWI0 ;WISC/RFJ-adjust inventory level - issue adjustment ;11 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
; called from prcpawa0 for type 1 issue book adjustment
ISUEBOOK ; issue book adjustment
N PRCPDA,PRCPPVNO
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
F S PRCPDA=$$SELECTIB^PRCPWPLM(0) Q:PRCPDA'>0 D
. L +^PRCS(410,PRCPDA):5 I '$T D SHOWWHO^PRCPULOC(410,PRCPDA,0) Q
. D ADD^PRCPULOC(410,PRCPDA,0,"Adjust Issue Book")
. N %,DISTRPT,OTHERPT,TRANNO,VOUCHER
. S TRANNO=$P($G(^PRCS(410,PRCPDA,0)),"^")
. I TRANNO="" W !,"CANNOT FIND THE TRANSACTION NUMBER FOR THIS ISSUE BOOK." D UNLOCK Q
. S %=$G(^PRCS(410,PRCPDA,445))
. I '$P(%,"^",2) W !,"THIS ISSUE BOOK HAS NOT BEEN POSTED (NO FMS LINE NUMBER) AND CANNOT BE ADJUSTED." D UNLOCK Q
. S VOUCHER=$P(%,"^")
. I VOUCHER="" W !,"THIS ISSUE BOOK DOES NOT HAVE A REFERENCE VOUCHER NUMBER AND CANNOT BE ADJUSTED." D UNLOCK Q
. W !!,">> Reference Voucher Number: ",VOUCHER
. S (DISTRPT,OTHERPT)=+$P(^PRCS(410,PRCPDA,0),"^",6)
. I DISTRPT D
. . W !!,">> Distribution to: ",$$INVNAME^PRCPUX1(DISTRPT)," inventory point."
. . S %=$G(^PRCP(445,DISTRPT,0))
. . I $P(%,"^",2)'="Y" W !,"NOTE: Primary is NOT keeping a PERPETUAL INVENTORY." S DISTRPT=0
. . I $P(%,"^",6)'="Y" W !,"NOTE: Primary is NOT keeping a DETAILED TRANSACTION REGISTER." S DISTRPT=0
. . I $P(%,"^",16)="N" W !,"NOTE: Primary set up so it will NOT be updated by the warehouse." S DISTRPT=0
. . I 'DISTRPT W !,">> PRIMARY inventory point will NOT be updated."
. ; get line adjustments
. D LINEADJ
. I '$O(^TMP($J,"PRCPAWI0","PROCESS",0)) W !!?10,">> NO LINE ITEMS HAVE BEEN SELECTED <<" D UNLOCK Q
. ; get whse and buyer fcp data
. N PRCPPBFY,PRCPPFCP,PRCPPSTA,PRCPWBFY,PRCPWFCP,PRCPWSTA
. D IVDATA^PRCPSFIU(PRCPDA,PRCP("I"))
. S XP="READY TO PROCESS ISSUE BOOK ADJUSTMENTS",XH="Enter YES to PROCESS the ISSUE BOOK adjustments, NO to exit."
. W !! I $$YN^PRCPUYN(1)'=1 D UNLOCK Q
. D ISUECONT^PRCPAWI1
. D UNLOCK
;
Q K ^TMP($J,"PRCPAWI0")
Q
;
;
UNLOCK ; unlock issue book lock
D CLEAR^PRCPULOC(410,PRCPDA,0)
L -^PRCS(410,PRCPDA)
Q
;
;
LINEITEM() ; select line item
N DA,DIC,X,Y
S DIC="^PRCS(410,"_PRCPDA_",""IT"",",DA(1)=PRCPDA,DIC(0)="QEAMZ",DIC("A")="Select LINE ITEM Number: "
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)"
D ^DIC
Q +Y
;
;
LINEADJ ; enter line adjustment
N INVVALUE,ITEMDA,ITEMDATA,LINEDA,LINEDATA,POSTDATA,QTY,REASON,SELVALUE
K ^TMP($J,"PRCPAWI0")
F W ! S LINEDA=$$LINEITEM Q:LINEDA'>0 D
. S LINEDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)),ITEMDA=+$P(LINEDATA,"^",5) I 'ITEMDA W !,"MISSING ITEM MASTER NUMBER." Q
. D SHOWDATA^PRCPAWA0(PRCP("I"),ITEMDA)
. W !!,"======================= I S S U E B O O K D A T A ======================="
. S POSTDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
. W !?5,"QUANTITY ORDERED: ",+$P(LINEDATA,"^",2)
. W !?5,"QUANTITY POSTED : ",+$P(POSTDATA,"^",3)
. W !?5,"INVENTORY VALUE : ",$J(+$P(POSTDATA,"^",4),0,2)
. W !?5,"SELLING VALUE : ",$J(+$P(POSTDATA,"^",5),0,2),!
. 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
. ; enter adjustment
. S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)) I ITEMDATA="" W !,"THIS ITEM IS NOT STORED IN THE INVENTORY POINT." Q
. ; line item already selected
. 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
. K ^TMP($J,"PRCPAWI0","PROCESS",LINEDA)
. W !!,"**************** E N T E R A D J U S T M E N T D A T A ****************",!
. S QTY=$$QTY^PRCPAWU0(-$P(POSTDATA,"^",3),0) I QTY["^" Q
. S INVVALUE=$$VALUE^PRCPAWU0(-$P(POSTDATA,"^",4),99999.99," ISSUE BOOK INVENTORY","") I INVVALUE["^" Q
. S SELVALUE=$$VALUE^PRCPAWU0(-$P(POSTDATA,"^",5),99999.99," ISSUE BOOK SELLING","") I SELVALUE["^" Q
. I 'QTY,'INVVALUE,'SELVALUE W !!?10,">> EITHER QUANTITY OR VALUE NEEDS TO BE ENTERED FOR AN ADJUSTMENT <<" Q
. W ! S REASON=$$REASON^PRCPAWU0("ISSUE BOOK adjustment") I REASON["^" Q
. S ^TMP($J,"PRCPAWI0","PROCESS",LINEDA)=QTY_"^"_SELVALUE_"^"_INVVALUE_"^^^"_REASON_"^"_ITEMDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWI0 4806 printed Sep 23, 2025@19:48:56 Page 2
PRCPAWI0 ;WISC/RFJ-adjust inventory level - issue adjustment ;11 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
+6 ; called from prcpawa0 for type 1 issue book adjustment
ISUEBOOK ; issue book adjustment
+1 NEW PRCPDA,PRCPPVNO
+2 SET PRCPPVNO=+$ORDER(^PRC(440,"AC","S",0))_";PRC(440,"
IF '$DATA(^PRC(440,+PRCPPVNO,0))
WRITE !!,"THERE IS NOT A VENDOR IN THE VENDOR FILE (#440) DESIGNATED AS A SUPPLY WHSE."
QUIT
+3 FOR
SET PRCPDA=$$SELECTIB^PRCPWPLM(0)
if PRCPDA'>0
QUIT
Begin DoDot:1
+4 LOCK +^PRCS(410,PRCPDA):5
IF '$TEST
DO SHOWWHO^PRCPULOC(410,PRCPDA,0)
QUIT
+5 DO ADD^PRCPULOC(410,PRCPDA,0,"Adjust Issue Book")
+6 NEW %,DISTRPT,OTHERPT,TRANNO,VOUCHER
+7 SET TRANNO=$PIECE($GET(^PRCS(410,PRCPDA,0)),"^")
+8 IF TRANNO=""
WRITE !,"CANNOT FIND THE TRANSACTION NUMBER FOR THIS ISSUE BOOK."
DO UNLOCK
QUIT
+9 SET %=$GET(^PRCS(410,PRCPDA,445))
+10 IF '$PIECE(%,"^",2)
WRITE !,"THIS ISSUE BOOK HAS NOT BEEN POSTED (NO FMS LINE NUMBER) AND CANNOT BE ADJUSTED."
DO UNLOCK
QUIT
+11 SET VOUCHER=$PIECE(%,"^")
+12 IF VOUCHER=""
WRITE !,"THIS ISSUE BOOK DOES NOT HAVE A REFERENCE VOUCHER NUMBER AND CANNOT BE ADJUSTED."
DO UNLOCK
QUIT
+13 WRITE !!,">> Reference Voucher Number: ",VOUCHER
+14 SET (DISTRPT,OTHERPT)=+$PIECE(^PRCS(410,PRCPDA,0),"^",6)
+15 IF DISTRPT
Begin DoDot:2
+16 WRITE !!,">> Distribution to: ",$$INVNAME^PRCPUX1(DISTRPT)," inventory point."
+17 SET %=$GET(^PRCP(445,DISTRPT,0))
+18 IF $PIECE(%,"^",2)'="Y"
WRITE !,"NOTE: Primary is NOT keeping a PERPETUAL INVENTORY."
SET DISTRPT=0
+19 IF $PIECE(%,"^",6)'="Y"
WRITE !,"NOTE: Primary is NOT keeping a DETAILED TRANSACTION REGISTER."
SET DISTRPT=0
+20 IF $PIECE(%,"^",16)="N"
WRITE !,"NOTE: Primary set up so it will NOT be updated by the warehouse."
SET DISTRPT=0
+21 IF 'DISTRPT
WRITE !,">> PRIMARY inventory point will NOT be updated."
End DoDot:2
+22 ; get line adjustments
+23 DO LINEADJ
+24 IF '$ORDER(^TMP($JOB,"PRCPAWI0","PROCESS",0))
WRITE !!?10,">> NO LINE ITEMS HAVE BEEN SELECTED <<"
DO UNLOCK
QUIT
+25 ; get whse and buyer fcp data
+26 NEW PRCPPBFY,PRCPPFCP,PRCPPSTA,PRCPWBFY,PRCPWFCP,PRCPWSTA
+27 DO IVDATA^PRCPSFIU(PRCPDA,PRCP("I"))
+28 SET XP="READY TO PROCESS ISSUE BOOK ADJUSTMENTS"
SET XH="Enter YES to PROCESS the ISSUE BOOK adjustments, NO to exit."
+29 WRITE !!
IF $$YN^PRCPUYN(1)'=1
DO UNLOCK
QUIT
+30 DO ISUECONT^PRCPAWI1
+31 DO UNLOCK
End DoDot:1
+32 ;
Q KILL ^TMP($JOB,"PRCPAWI0")
+1 QUIT
+2 ;
+3 ;
UNLOCK ; unlock issue book lock
+1 DO CLEAR^PRCPULOC(410,PRCPDA,0)
+2 LOCK -^PRCS(410,PRCPDA)
+3 QUIT
+4 ;
+5 ;
LINEITEM() ; select line item
+1 NEW DA,DIC,X,Y
+2 SET DIC="^PRCS(410,"_PRCPDA_",""IT"","
SET DA(1)=PRCPDA
SET DIC(0)="QEAMZ"
SET DIC("A")="Select LINE ITEM Number: "
+3 SET 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)"
+4 DO ^DIC
+5 QUIT +Y
+6 ;
+7 ;
LINEADJ ; enter line adjustment
+1 NEW INVVALUE,ITEMDA,ITEMDATA,LINEDA,LINEDATA,POSTDATA,QTY,REASON,SELVALUE
+2 KILL ^TMP($JOB,"PRCPAWI0")
+3 FOR
WRITE !
SET LINEDA=$$LINEITEM
if LINEDA'>0
QUIT
Begin DoDot:1
+4 SET LINEDATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
SET ITEMDA=+$PIECE(LINEDATA,"^",5)
IF 'ITEMDA
WRITE !,"MISSING ITEM MASTER NUMBER."
QUIT
+5 DO SHOWDATA^PRCPAWA0(PRCP("I"),ITEMDA)
+6 WRITE !!,"======================= I S S U E B O O K D A T A ======================="
+7 SET POSTDATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,445))
+8 WRITE !?5,"QUANTITY ORDERED: ",+$PIECE(LINEDATA,"^",2)
+9 WRITE !?5,"QUANTITY POSTED : ",+$PIECE(POSTDATA,"^",3)
+10 WRITE !?5,"INVENTORY VALUE : ",$JUSTIFY(+$PIECE(POSTDATA,"^",4),0,2)
+11 WRITE !?5,"SELLING VALUE : ",$JUSTIFY(+$PIECE(POSTDATA,"^",5),0,2),!
+12 IF $PIECE(POSTDATA,"^")=""!('$PIECE(POSTDATA,"^",3)&('$PIECE(POSTDATA,"^",4))&('$PIECE(POSTDATA,"^",5)))
WRITE !,"THIS LINE ITEM HAS NOT BEEN POSTED AND CANNOT BE ADJUSTED."
QUIT
+13 ; enter adjustment
+14 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
IF ITEMDATA=""
WRITE !,"THIS ITEM IS NOT STORED IN THE INVENTORY POINT."
QUIT
+15 ; line item already selected
+16 IF $DATA(^TMP($JOB,"PRCPAWI0","PROCESS",LINEDA))
SET XP=" THIS ITEM WAS PREVIOUSLY SELECTED DURING THIS SELECTION PROCESS."
SET XP(1)=" OK TO REMOVE THIS ADJUSTMENT SO YOU CAN ENTER A NEW ONE"
WRITE !!
IF $$YN^PRCPUYN(1)'=1
QUIT
+17 KILL ^TMP($JOB,"PRCPAWI0","PROCESS",LINEDA)
+18 WRITE !!,"**************** E N T E R A D J U S T M E N T D A T A ****************",!
+19 SET QTY=$$QTY^PRCPAWU0(-$PIECE(POSTDATA,"^",3),0)
IF QTY["^"
QUIT
+20 SET INVVALUE=$$VALUE^PRCPAWU0(-$PIECE(POSTDATA,"^",4),99999.99," ISSUE BOOK INVENTORY","")
IF INVVALUE["^"
QUIT
+21 SET SELVALUE=$$VALUE^PRCPAWU0(-$PIECE(POSTDATA,"^",5),99999.99," ISSUE BOOK SELLING","")
IF SELVALUE["^"
QUIT
+22 IF 'QTY
IF 'INVVALUE
IF 'SELVALUE
WRITE !!?10,">> EITHER QUANTITY OR VALUE NEEDS TO BE ENTERED FOR AN ADJUSTMENT <<"
QUIT
+23 WRITE !
SET REASON=$$REASON^PRCPAWU0("ISSUE BOOK adjustment")
IF REASON["^"
QUIT
+24 SET ^TMP($JOB,"PRCPAWI0","PROCESS",LINEDA)=QTY_"^"_SELVALUE_"^"_INVVALUE_"^^^"_REASON_"^"_ITEMDA
End DoDot:1
+25 QUIT
