PRCPAWO0 ;WISC/RFJ-adjust inventory level - other 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 3 other adjustment
OTHER ; other adjustment
; select item from the inventory point and ask for input.
N DATA,ITEMDA,ITEMDATA,ORDERNO,PRCPAWN0,PRCPID,QTY,REASON,REASONCD,VALUE,VOUCHER
K ^TMP($J,"PRCPAWO0")
F D Q:'ITEMDA W !!!!!
. W !!," >> Select an item number from the ",PRCP("IN")," inventory point. <<"
. S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") I 'ITEMDA Q
. D SHOWDATA^PRCPAWA0(PRCP("I"),ITEMDA)
. ;
. ; item already selected
. I $D(^TMP($J,"PRCPAWO0","PROCESS",ITEMDA)) 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,"PRCPAWO0","PROCESS",ITEMDA)
. ;
. ; enter adjustment
. S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)) I ITEMDATA="" Q
. 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(ITEMDATA,"^",7),99998) I QTY["^" Q
. S VALUE=$$VALUE^PRCPAWU0(-99999.99,99999.99," INVENTORY","") I VALUE["^" Q
. I 'QTY,'VALUE W !!?10,">> EITHER QUANTITY OR VALUE NEEDS TO BE ENTERED FOR AN ADJUSTMENT <<" Q
. I '$D(VOUCHER) W ! S VOUCHER=$$VOUCHER^PRCPAWU0 I VOUCHER=""!(VOUCHER="^") Q
. W ! S REASONCD=$$REASON I 'REASONCD Q
. W ! S REASON=$$REASON^PRCPAWU0(REASONCD) I REASON["^" Q
. S ^TMP($J,"PRCPAWO0","PROCESS",ITEMDA)=QTY_"^^"_VALUE_"^^"_VOUCHER_"^"_(+REASONCD)_"^"_REASON
;
I ITEMDA["^" D Q Q
I '$O(^TMP($J,"PRCPAWO0","PROCESS",0)) W !!?10,">> NO ITEMS HAVE BEEN SELECTED <<" D Q Q
; get whse fcp data
N PRCPWBFY,PRCPWFCP,PRCPWSTA
D SVDATA^PRCPSFIU(PRCP("I"))
S XP="READY TO PROCESS INVENTORY ADJUSTMENTS",XH="Enter YES to PROCESS the INVENTORY adjustments, NO to exit."
W !! I $$YN^PRCPUYN(1)'=1 D Q Q
;
; process inventory adjustments
S ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPAWO0","PROCESS",ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA) I DATA'="" D
. K PRCPAWN0
. S PRCPAWN0("QTY")=$P(DATA,"^"),PRCPAWN0("INVVAL")=$P(DATA,"^",3),PRCPAWN0("SELVAL")=0,PRCPAWN0("REF")=$P(DATA,"^",5),PRCPAWN0("REASON")="0:"_$P(DATA,"^",7),PRCPAWN0("REASONCODE")=$P(DATA,"^",6),PRCPAWN0("2237PO")=PRC("SITE")
. D ITEM^PRCPUUIW(PRCP("I"),ITEMDA,"A",ORDERNO,.PRCPAWN0)
. K PRCPAWN0
;
; create fms sv document
D SV^PRCPSFSV(PRCP("I"),"A"_ORDERNO,"","")
; create log or isms code sheets
D CODESHTS^PRCPAWC0(PRCP("I"),"A"_ORDERNO)
; print form
D PRINFORM^PRCPAWR0("A"_ORDERNO)
Q K ^TMP($J,"PRCPAWO0")
Q
;
;
REASON() ; enter reason text
N DIR,REASON,X,Y
S REASON=$G(^DISV(+$G(DUZ),"PRCPAWO0","REASON"))
S DIR(0)="SO^1:Transfer of stock to another VAMC Warehouse;2:Sale of stock to OGA;3:Transfer of excess stock to GSA;4:Adjustment of stock valuation;5:Writeoff damaged stock;6:Transfer Transportation expense to stock;7:Inventory Refund"
S DIR("A")=" Select TYPE of ADJUSTMENT"
I REASON'="" S DIR("B")=REASON
W ! D ^DIR K DIR I Y'=1,Y'=2,Y'=3,Y'=4,Y'=5,Y'=6,Y'=7 Q 0
S DIR("A",1)=" >> Enter the reason text which will appear on the transaction register. <<"
D ^DIR
I Y'["^" S ^DISV(DUZ,"PRCPAWO0","REASON")=Y
Q Y_":"_Y(0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWO0 3439 printed Sep 23, 2025@19:48:58 Page 2
PRCPAWO0 ;WISC/RFJ-adjust inventory level - other 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 3 other adjustment
OTHER ; other adjustment
+1 ; select item from the inventory point and ask for input.
+2 NEW DATA,ITEMDA,ITEMDATA,ORDERNO,PRCPAWN0,PRCPID,QTY,REASON,REASONCD,VALUE,VOUCHER
+3 KILL ^TMP($JOB,"PRCPAWO0")
+4 FOR
Begin DoDot:1
+5 WRITE !!," >> Select an item number from the ",PRCP("IN")," inventory point. <<"
+6 SET ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","")
IF 'ITEMDA
QUIT
+7 DO SHOWDATA^PRCPAWA0(PRCP("I"),ITEMDA)
+8 ;
+9 ; item already selected
+10 IF $DATA(^TMP($JOB,"PRCPAWO0","PROCESS",ITEMDA))
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
+11 KILL ^TMP($JOB,"PRCPAWO0","PROCESS",ITEMDA)
+12 ;
+13 ; enter adjustment
+14 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
IF ITEMDATA=""
QUIT
+15 WRITE !!,"**************** E N T E R A D J U S T M E N T D A T A ****************",!
+16 SET QTY=$$QTY^PRCPAWU0(-$PIECE(ITEMDATA,"^",7),99998)
IF QTY["^"
QUIT
+17 SET VALUE=$$VALUE^PRCPAWU0(-99999.99,99999.99," INVENTORY","")
IF VALUE["^"
QUIT
+18 IF 'QTY
IF 'VALUE
WRITE !!?10,">> EITHER QUANTITY OR VALUE NEEDS TO BE ENTERED FOR AN ADJUSTMENT <<"
QUIT
+19 IF '$DATA(VOUCHER)
WRITE !
SET VOUCHER=$$VOUCHER^PRCPAWU0
IF VOUCHER=""!(VOUCHER="^")
QUIT
+20 WRITE !
SET REASONCD=$$REASON
IF 'REASONCD
QUIT
+21 WRITE !
SET REASON=$$REASON^PRCPAWU0(REASONCD)
IF REASON["^"
QUIT
+22 SET ^TMP($JOB,"PRCPAWO0","PROCESS",ITEMDA)=QTY_"^^"_VALUE_"^^"_VOUCHER_"^"_(+REASONCD)_"^"_REASON
End DoDot:1
if 'ITEMDA
QUIT
WRITE !!!!!
+23 ;
+24 IF ITEMDA["^"
DO Q
QUIT
+25 IF '$ORDER(^TMP($JOB,"PRCPAWO0","PROCESS",0))
WRITE !!?10,">> NO ITEMS HAVE BEEN SELECTED <<"
DO Q
QUIT
+26 ; get whse fcp data
+27 NEW PRCPWBFY,PRCPWFCP,PRCPWSTA
+28 DO SVDATA^PRCPSFIU(PRCP("I"))
+29 SET XP="READY TO PROCESS INVENTORY ADJUSTMENTS"
SET XH="Enter YES to PROCESS the INVENTORY adjustments, NO to exit."
+30 WRITE !!
IF $$YN^PRCPUYN(1)'=1
DO Q
QUIT
+31 ;
+32 ; process inventory adjustments
+33 SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCP("I"))
+34 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPAWO0","PROCESS",ITEMDA))
if 'ITEMDA
QUIT
SET DATA=^(ITEMDA)
IF DATA'=""
Begin DoDot:1
+35 KILL PRCPAWN0
+36 SET PRCPAWN0("QTY")=$PIECE(DATA,"^")
SET PRCPAWN0("INVVAL")=$PIECE(DATA,"^",3)
SET PRCPAWN0("SELVAL")=0
SET PRCPAWN0("REF")=$PIECE(DATA,"^",5)
SET PRCPAWN0("REASON")="0:"_$PIECE(DATA,"^",7)
SET PRCPAWN0("REASONCODE")=$PIECE(DATA,"^",6)
SET PRCPAWN0("2237PO")=PRC("SITE")
+37 DO ITEM^PRCPUUIW(PRCP("I"),ITEMDA,"A",ORDERNO,.PRCPAWN0)
+38 KILL PRCPAWN0
End DoDot:1
+39 ;
+40 ; create fms sv document
+41 DO SV^PRCPSFSV(PRCP("I"),"A"_ORDERNO,"","")
+42 ; create log or isms code sheets
+43 DO CODESHTS^PRCPAWC0(PRCP("I"),"A"_ORDERNO)
+44 ; print form
+45 DO PRINFORM^PRCPAWR0("A"_ORDERNO)
Q KILL ^TMP($JOB,"PRCPAWO0")
+1 QUIT
+2 ;
+3 ;
REASON() ; enter reason text
+1 NEW DIR,REASON,X,Y
+2 SET REASON=$GET(^DISV(+$GET(DUZ),"PRCPAWO0","REASON"))
+3 SET DIR(0)="SO^1:Transfer of stock to another VAMC Warehouse;2:Sale of stock to OGA;3:Transfer of excess stock to GSA;4:Adjustment of stock valuation;5:Writeoff damaged stock;6:Transfer Transportation expense to stock;7:Inventory Refund"
+4 SET DIR("A")=" Select TYPE of ADJUSTMENT"
+5 IF REASON'=""
SET DIR("B")=REASON
+6 WRITE !
DO ^DIR
KILL DIR
IF Y'=1
IF Y'=2
IF Y'=3
IF Y'=4
IF Y'=5
IF Y'=6
IF Y'=7
QUIT 0
+7 SET DIR("A",1)=" >> Enter the reason text which will appear on the transaction register. <<"
+8 DO ^DIR
+9 IF Y'["^"
SET ^DISV(DUZ,"PRCPAWO0","REASON")=Y
+10 QUIT Y_":"_Y(0)
