Routine: PRCFRET

PRCFRET ;WISC/SJG-RETURN PO AND AMENDMENTS TO SUPPLY ;7/24/00  23:08

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ; No top level entry

 QUIT

EN1 ; Return Purchase Order to Supply

 QUIT

EN2 ; Return Purchase Order Amendment to Supply

 D ^PRCFSITE Q:'%  D OUT1

 K FAIL D ES2 I $D(FAIL) K FAIL G OUT1

START K DIC("A") S D="E",DIC("S")="I +^(0)=PRC(""SITE"") S FSO=$O(^PRC(443.6,""D"",+Y,0)) I FSO=26!(FSO=31)!(FSO=36)!(FSO=45)!(FSO=71)",DIC("A")="Select Purchase Order Number: ",DIC=443.6,DIC(0)="AEQZ"

 D IX^DIC K DIC("S"),DIC("A"),FSO G:+Y<0 OUT1

 S FLG=0,PO(0)=Y(0),PO=Y,PRCFPODA=+Y,PRCFA("PODA")=+Y

 I '$D(^PRC(443.6,+PO,6)) D NOA G START

 I $P(^PRC(443.6,+PO,6,0),"^",4)<0 D NOA G START

 I '$$VERIFY^PRCHES5(PRCFPODA) W !!,"This Purchase Order has been tampered with.  Please notify IFCAP APPLICATION COORDINATOR." G OUT1

AMEND S DIC="^PRC(443.6,"_+PO_",6,",DIC("A")="Select AMENDMENT: ",DIC(0)="AEMNZQ" D ^DIC K DIC("A") I Y<0 D MSG G START

 S PO(6)=Y(0),PO(6,1)=^PRC(443.6,+PO,6,+Y,1),PRCFA("AMEND#")=+Y,PRCFAA=+Y

 I $P($G(^PRC(443.6,+PO,6,PRCFAA,1)),U,2)="" D MSG2 G START

 W ! D READ I 'Y!($D(DIRUT))  D MSG G START

 I Y D

 .D REMOVE^PRCHES10(+PO,PRCFAA) I Y=-1 W !,"INCOMPLETE RECORD" G OUT1

 .N DA S DIE="^PRC(443.6,"_+PO_",6,",DA=PRCFAA,DR="15///TODAY+7" D ^DIE

 .N SUBINFO S SUBINFO="443.67^15^"_PRCFAA

 .D GENDIQ^PRCFFU7(443.6,+PO,50,"IEN",SUBINFO)

 .S AUTODEL=$G(PRCTMP(443.67,PRCFAA,15,"E"))

 .D BULLET^PRCFACS3(+PO,PRCFAA,AUTODEL)

.Q

 G START

ES2 ; E-Sig code for amendment

 N MESSAGE S MESSAGE=""

 D ESIG^PRCUESIG(DUZ,.MESSAGE)

 G:(MESSAGE=0)!(MESSAGE=-3) FAIL ;3 TRIES or NO SIG ON FILE

 G:(MESSAGE=-1)!(MESSAGE=-2) FAIL1 ;ARROWED OUT or TIMED OUT

READ ; Reader

 S DIR(0)="Y",DIR("A",1)="Are you sure that you do not want to obligate this Purchase Order",DIR("A")="Amendment",DIR("B")="YES"

 S DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."

 S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to return this Purchase Order to",DIR("?",2)="Supply, unobligated.",DIR("?",3)=" "

 D ^DIR K DIR

OUT1 K FLG,%,%Y,DIC,I,J,K,P,PO,PRCFA,PRCFAA,PRCFPODA,PRCFCHG,X,Y,Z

NOA ; Message Processing for No Amendment

 W !! S X="NO AMENDMENT EXISTS FOR THIS ORDER - PLEASE CHECK WITH SUPPLY.  OPTION IS BEING ABORTED.*" D MSG^PRCFQ W ! Q

MSG ; Message Processing for exit

 W !! S X="No further processing is being taken on this amendment obligation.*" D MSG^PRCFQ W ! Q

MSG2 ; Message Processing for amendments still in Supply

 W !! S X="This Purchase Order Amendment is still awaiting signature by Supply.*" D MSG^PRCFQ W ! Q

 ; E-SIG Message Processing

FAIL S FAIL="" W !,$C(7),"   SIGNATURE CODE FAILURE " R X:3 Q

FAIL1 S FAIL="" Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFRET   2755     printed  Feb 18, 2025@23:30:44                                                                                                                                                                                                     Page 2

PRCFRET   ;WISC/SJG-RETURN PO AND AMENDMENTS TO SUPPLY ;7/24/00  23:08

 +1       ;;5.1;IFCAP;;Oct 20, 2000

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ; No top level entry

 +5        QUIT

EN1       ; Return Purchase Order to Supply

 +1        QUIT

EN2       ; Return Purchase Order Amendment to Supply

 +1        DO ^PRCFSITE

           if '%

               QUIT

           DO OUT1

 +2        KILL FAIL

           DO ES2

           IF $DATA(FAIL)

               KILL FAIL

               GOTO OUT1

START      KILL DIC("A")

           SET D="E"

           SET DIC("S")="I +^(0)=PRC(""SITE"") S FSO=$O(^PRC(443.6,""D"",+Y,0)) I FSO=26!(FSO=31)!(FSO=36)!(FSO=45)!(FSO=71)"

           SET DIC("A")="Select Purchase Order Number: "

           SET DIC=443.6

           SET DIC(0)="AEQZ"

 +1        DO IX^DIC

           KILL DIC("S"),DIC("A"),FSO

           if +Y<0

               GOTO OUT1

 +2        SET FLG=0

           SET PO(0)=Y(0)

           SET PO=Y

           SET PRCFPODA=+Y

           SET PRCFA("PODA")=+Y

 +3        IF '$DATA(^PRC(443.6,+PO,6))

               DO NOA

               GOTO START

 +4        IF $PIECE(^PRC(443.6,+PO,6,0),"^",4)<0

               DO NOA

               GOTO START

 +5        IF '$$VERIFY^PRCHES5(PRCFPODA)

               WRITE !!,"This Purchase Order has been tampered with.  Please notify IFCAP APPLICATION COORDINATOR."

               GOTO OUT1

AMEND      SET DIC="^PRC(443.6,"_+PO_",6,"

           SET DIC("A")="Select AMENDMENT: "

           SET DIC(0)="AEMNZQ"

           DO ^DIC

           KILL DIC("A")

           IF Y<0

               DO MSG

               GOTO START

 +1        SET PO(6)=Y(0)

           SET PO(6,1)=^PRC(443.6,+PO,6,+Y,1)

           SET PRCFA("AMEND#")=+Y

           SET PRCFAA=+Y

 +2        IF $PIECE($GET(^PRC(443.6,+PO,6,PRCFAA,1)),U,2)=""

               DO MSG2

               GOTO START

 +3        WRITE !

           DO READ

           IF 'Y!($DATA(DIRUT))

               DO MSG

               GOTO START

 +4        IF Y

               Begin DoDot:1

 +5                DO REMOVE^PRCHES10(+PO,PRCFAA)

                   IF Y=-1

                       WRITE !,"INCOMPLETE RECORD"

                       GOTO OUT1

 +6                NEW DA

                   SET DIE="^PRC(443.6,"_+PO_",6,"

                   SET DA=PRCFAA

                   SET DR="15///TODAY+7"

                   DO ^DIE

 +7                NEW SUBINFO

                   SET SUBINFO="443.67^15^"_PRCFAA

 +8                DO GENDIQ^PRCFFU7(443.6,+PO,50,"IEN",SUBINFO)

 +9                SET AUTODEL=$GET(PRCTMP(443.67,PRCFAA,15,"E"))

 +10               DO BULLET^PRCFACS3(+PO,PRCFAA,AUTODEL)

 +11               QUIT

               End DoDot:1

 +12       GOTO START

ES2       ; E-Sig code for amendment

 +1        NEW MESSAGE

           SET MESSAGE=""

 +2        DO ESIG^PRCUESIG(DUZ,.MESSAGE)

 +3       ;3 TRIES or NO SIG ON FILE

           if (MESSAGE=0)!(MESSAGE=-3)

               GOTO FAIL

 +4       ;ARROWED OUT or TIMED OUT

           if (MESSAGE=-1)!(MESSAGE=-2)

               GOTO FAIL1

 +5        QUIT

READ      ; Reader

 +1        SET DIR(0)="Y"

           SET DIR("A",1)="Are you sure that you do not want to obligate this Purchase Order"

           SET DIR("A")="Amendment"

           SET DIR("B")="YES"

 +2        SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."

 +3        SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to return this Purchase Order to"

           SET DIR("?",2)="Supply, unobligated."

           SET DIR("?",3)=" "

 +4        DO ^DIR

           KILL DIR

 +5        QUIT

OUT1       KILL FLG,%,%Y,DIC,I,J,K,P,PO,PRCFA,PRCFAA,PRCFPODA,PRCFCHG,X,Y,Z

 +1        QUIT

NOA       ; Message Processing for No Amendment

 +1        WRITE !!

           SET X="NO AMENDMENT EXISTS FOR THIS ORDER - PLEASE CHECK WITH SUPPLY.  OPTION IS BEING ABORTED.*"

           DO MSG^PRCFQ

           WRITE !

           QUIT

MSG       ; Message Processing for exit

 +1        WRITE !!

           SET X="No further processing is being taken on this amendment obligation.*"

           DO MSG^PRCFQ

           WRITE !

           QUIT

MSG2      ; Message Processing for amendments still in Supply

 +1        WRITE !!

           SET X="This Purchase Order Amendment is still awaiting signature by Supply.*"

           DO MSG^PRCFQ

           WRITE !

           QUIT

 +2       ; E-SIG Message Processing

FAIL       SET FAIL=""

           WRITE !,$CHAR(7),"   SIGNATURE CODE FAILURE "

           READ X:3

           QUIT

FAIL1      SET FAIL=""

           QUIT

PRCFRET.m