- 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 Feb 18, 2025@23:39:14 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