PRCFAV.m

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 ---PRCFAV   1880     printed  Mar 13, 2025@21:07:27                                                                                                                                                                                                      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