PRCFAV ;WISC@ALTOONA/CTB-ROUTINE TO PROCESS ADJUSTMENT VOUCHERS ;4/30/93 2:48 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCFSITE Q:'%
K FAIL D ES I $D(FAIL) K FAIL G OUT1
K DIC("A") S D="C",DIC("S")="I +$P(^(0),U)=PRC(""SITE"")",DIC("A")="Select Purchase Order Number: ",DIC=442,DIC(0)="AEQZ"
D IX^DIC K DIC("S"),DIC("A") G:+Y<0 OUT1
S PO(0)=Y(0),PO=Y,PRCFPODA=+Y,PRCFA("PODA")=+Y
I '$D(^PRC(442,+PO,6)) D NOA G OUT1
I $P(^PRC(442,+PO,6,0),"^",4)<0 D NOA G OUT1
S DIC="^PRC(442,"_+PO_",6,",DIC("A")="Select ADJUSTMENT VOUCHER",DIC(0)="AEMNZQ" D ^DIC K DIC("A") G:Y<0 OUT1 S PO(6)=Y(0),PO(6,1)=^PRC(442,+PO,6,+Y,1),PRCFA("AV")=+Y
I $P(PO(6,1),"^",5)'="" S %A="This Adjustment Voucher has already been processed by Fiscal,",%A(1)="ARE YOU SURE YOU WISH TO CONTINUE",%B="",%=2 D ^PRCFYN I %'=1 G OUT1
W ! S %A="Do you need to process a code sheet for this Adjustment Voucher",%B="",%=1 D ^PRCFYN Q:%<1 G:%=2 OUT D AM^PRCFAC
AGAIN S PRCFA("PODA")=PRCFPODA W ! S %A="Do you need to enter an additional code sheet",%B="",%=2 D ^PRCFYN I %'=1 G OUT D AM^PRCFAC G AGAIN
OUT ;D Q15 S $P(^PRC(442,PRCFA("PODA"),6,PRCFA("AV"),1),"^",5)=+PRC("PER"),$P(^(1),"^",6)=X
S $P(^PRC(442,PRCFA("PODA"),6,PRCFA("AV"),1),"^",5)=+PRC("PER") D Q15
S PRCHQ="^PRCHPAM",PRCHQ("DEST")="S8",D0=PRCFA("PODA"),D1=PRCFA("AV") D ^PRCHQUE
OUT1 K P,DIC,PRCFA,PRCFPODA Q
Q
NOA W !,$C(7),"No Adjustment Vouchers are entered for this order, please check with Supply. ",!,?20,"Option is being aborted." R X:3 Q
ES ;
ES1 K FAIL
N MESSAGE S MESSAGE=""
D ESIG^PRCUESIG(DUZ,.MESSAGE)
G FAIL1:MESSAGE=-1!(MESSAGE=-2)!(MESSAGE=-3),FAIL:MESSAGE=0
Q
FAIL S FAIL="" W $C(7)," SIGNATURE CODE FAILURE " R X:3 Q
FAIL1 S FAIL="" Q
Q15 S MESSAGE=""
D ENCODE^PRCHES7(PRCF("PODA"),PRCFA("AV"),DUZ,.MESSAGE)
K MESSAGE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAV 1880 printed Nov 22, 2024@17:12:45 Page 2
PRCFAV ;WISC@ALTOONA/CTB-ROUTINE TO PROCESS ADJUSTMENT VOUCHERS ;4/30/93 2:48 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 DO ^PRCFSITE
if '%
QUIT
+3 KILL FAIL
DO ES
IF $DATA(FAIL)
KILL FAIL
GOTO OUT1
+4 KILL DIC("A")
SET D="C"
SET DIC("S")="I +$P(^(0),U)=PRC(""SITE"")"
SET DIC("A")="Select Purchase Order Number: "
SET DIC=442
SET DIC(0)="AEQZ"
+5 DO IX^DIC
KILL DIC("S"),DIC("A")
if +Y<0
GOTO OUT1
+6 SET PO(0)=Y(0)
SET PO=Y
SET PRCFPODA=+Y
SET PRCFA("PODA")=+Y
+7 IF '$DATA(^PRC(442,+PO,6))
DO NOA
GOTO OUT1
+8 IF $PIECE(^PRC(442,+PO,6,0),"^",4)<0
DO NOA
GOTO OUT1
+9 SET DIC="^PRC(442,"_+PO_",6,"
SET DIC("A")="Select ADJUSTMENT VOUCHER"
SET DIC(0)="AEMNZQ"
DO ^DIC
KILL DIC("A")
if Y<0
GOTO OUT1
SET PO(6)=Y(0)
SET PO(6,1)=^PRC(442,+PO,6,+Y,1)
SET PRCFA("AV")=+Y
+10 IF $PIECE(PO(6,1),"^",5)'=""
SET %A="This Adjustment Voucher has already been processed by Fiscal,"
SET %A(1)="ARE YOU SURE YOU WISH TO CONTINUE"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
GOTO OUT1
+11 WRITE !
SET %A="Do you need to process a code sheet for this Adjustment Voucher"
SET %B=""
SET %=1
DO ^PRCFYN
if %<1
QUIT
if %=2
GOTO OUT
DO AM^PRCFAC
AGAIN SET PRCFA("PODA")=PRCFPODA
WRITE !
SET %A="Do you need to enter an additional code sheet"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
GOTO OUT
DO AM^PRCFAC
GOTO AGAIN
OUT ;D Q15 S $P(^PRC(442,PRCFA("PODA"),6,PRCFA("AV"),1),"^",5)=+PRC("PER"),$P(^(1),"^",6)=X
+1 SET $PIECE(^PRC(442,PRCFA("PODA"),6,PRCFA("AV"),1),"^",5)=+PRC("PER")
DO Q15
+2 SET PRCHQ="^PRCHPAM"
SET PRCHQ("DEST")="S8"
SET D0=PRCFA("PODA")
SET D1=PRCFA("AV")
DO ^PRCHQUE
OUT1 KILL P,DIC,PRCFA,PRCFPODA
QUIT
+1 QUIT
NOA WRITE !,$CHAR(7),"No Adjustment Vouchers are entered for this order, please check with Supply. ",!,?20,"Option is being aborted."
READ X:3
QUIT
ES ;
ES1 KILL FAIL
+1 NEW MESSAGE
SET MESSAGE=""
+2 DO ESIG^PRCUESIG(DUZ,.MESSAGE)
+3 if MESSAGE=-1!(MESSAGE=-2)!(MESSAGE=-3)
GOTO FAIL1
if MESSAGE=0
GOTO FAIL
+4 QUIT
FAIL SET FAIL=""
WRITE $CHAR(7)," SIGNATURE CODE FAILURE "
READ X:3
QUIT
FAIL1 SET FAIL=""
QUIT
Q15 SET MESSAGE=""
+1 DO ENCODE^PRCHES7(PRCF("PODA"),PRCFA("AV"),DUZ,.MESSAGE)
+2 KILL MESSAGE
+3 QUIT
