- PRCFACA ;WISC@ALTOONA/CTB-ROUTINE TO PROCESS AMENDMENTS ;5/6/93 10:22 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ^PRCFSITE Q:'% D OUT1
- K FAIL D ES I $D(FAIL) K FAIL G OUT1
- K DIC("A") S D="C",DIC("S")="I $D(^(7)),+^(7)>0,+^(0)=PRC(""SITE"") S FSO=$S($D(^PRCD(442.3,+^(7),0)):$P(^(0),U,3),1:"""") I FSO=26!(FSO=31)!(FSO=36)!(FSO=45)!(FSO=41)",DIC("A")="Select Purchase Order Number: ",DIC=442,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(442,+PO,6)) D NOA G OUT1
- I $P(^PRC(442,+PO,6,0),"^",4)<0 D NOA G OUT1
- AMEND S DIC="^PRC(442,"_+PO_",6,",DIC("A")="Select AMENDMENT: ",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("AMEND#")=+Y,PRCFAA=+Y
- S D0=+PO,D1=+Y D ^PRCHDSP
- ;S D0=+PO,D1=+Y D ^PRCHDAM
- APP W !!,"Ready to Approve ?" S %=2 D YN^DICN G:%=-1!(%=2) AMEND I %=0 W !,"ANSWER YES OR NO" G APP
- W ! I $P(PO(6,1),"^",5)'="" S %A="THIS AMENDMENT HAS ALREADY BEEN APPROVED BY FISCAL,",%A(1)="ARE YOU SURE YOU WISH TO CONTINUE",%B="" S %=2 D ^PRCFYN I %'=1 G OUT1
- PRT W !!,"Would you like to print this amendment ?" S %=2 D YN^DICN G:%=-1 OUT1 S:%=1 FLG=1 I %=0 W !,"ANSWER YES OR NO" G PRT
- W ! S %A="DO YOU NEED TO PROCESS A CODE SHEET FOR THIS AMENDMENT",%B="" S %=1 D ^PRCFYN Q:%<1 G:%=2 OUT D AM^PRCFAC
- AGAIN S PRCFA("PODA")=PRCFPODA,PRCFA("AMEND#")=PRCFAA W ! S %A="DO YOU NEED TO ENTER AN ADDITIONAL CODE SHEET",%B="" S %=2 D ^PRCFYN I %'=1 G OUT
- D AM^PRCFAC G AGAIN
- OUT D Q15
- G:'FLG OUT1 S PRCHQ="^PRCHPAM",PRCHQ("DEST")="S8",D0=PRCFA("PODA"),D1=PRCFA("AMEND#") D ^PRCHQUE
- OUT1 K FLG,%,%Y,DIC,I,J,K,P,PRCFA,PRCFAA,PRCFPODA,X,Y,Z Q
- Q
- NOA W !,$C(7),"NO AMENDMENT EXISTS FOR THIS ORDER, PLEASE CHECK WITH SUPPLY. ",!,?20,"OPTION IS BEING ABORTED." Q
- ES ;
- ES1 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
- Q
- FAIL S FAIL="" W !,$C(7)," SIGNATURE CODE FAILURE " R X:3 Q
- FAIL1 S FAIL="" Q
- Q15 S DA=PRCFA("PODA")
- S MESSAGE=""
- D REMOVE^PRCHES7(PRCFA("PODA"),PRCFA("AMEND#"))
- D ENCODE^PRCHES7(PRCFA("PODA"),PRCFA("AMEND#"),DUZ,.MESSAGE)
- K MESSAGE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACA 2314 printed Mar 13, 2025@21:06:46 Page 2
- PRCFACA ;WISC@ALTOONA/CTB-ROUTINE TO PROCESS AMENDMENTS ;5/6/93 10:22 AM
- 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
- DO OUT1
- +3 KILL FAIL
- DO ES
- IF $DATA(FAIL)
- KILL FAIL
- GOTO OUT1
- +4 KILL DIC("A")
- SET D="C"
- SET DIC("S")="I $D(^(7)),+^(7)>0,+^(0)=PRC(""SITE"") S FSO=$S($D(^PRCD(442.3,+^(7),0)):$P(^(0),U,3),1:"""") I FSO=26!(FSO=31)!(FSO=36)!(FSO=45)!(FSO=41)"
- SET DIC("A")="Select Purchase Order Number: "
- SET DIC=442
- SET DIC(0)="AEQZ"
- +5 DO IX^DIC
- KILL DIC("S"),DIC("A"),FSO
- if +Y<0
- GOTO OUT1
- +6 SET FLG=0
- 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
- AMEND SET DIC="^PRC(442,"_+PO_",6,"
- SET DIC("A")="Select AMENDMENT: "
- 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("AMEND#")=+Y
- SET PRCFAA=+Y
- +1 SET D0=+PO
- SET D1=+Y
- DO ^PRCHDSP
- +2 ;S D0=+PO,D1=+Y D ^PRCHDAM
- APP WRITE !!,"Ready to Approve ?"
- SET %=2
- DO YN^DICN
- if %=-1!(%=2)
- GOTO AMEND
- IF %=0
- WRITE !,"ANSWER YES OR NO"
- GOTO APP
- +1 WRITE !
- IF $PIECE(PO(6,1),"^",5)'=""
- SET %A="THIS AMENDMENT HAS ALREADY BEEN APPROVED BY FISCAL,"
- SET %A(1)="ARE YOU SURE YOU WISH TO CONTINUE"
- SET %B=""
- SET %=2
- DO ^PRCFYN
- IF %'=1
- GOTO OUT1
- PRT WRITE !!,"Would you like to print this amendment ?"
- SET %=2
- DO YN^DICN
- if %=-1
- GOTO OUT1
- if %=1
- SET FLG=1
- IF %=0
- WRITE !,"ANSWER YES OR NO"
- GOTO PRT
- +1 WRITE !
- SET %A="DO YOU NEED TO PROCESS A CODE SHEET FOR THIS AMENDMENT"
- SET %B=""
- SET %=1
- DO ^PRCFYN
- if %<1
- QUIT
- if %=2
- GOTO OUT
- DO AM^PRCFAC
- AGAIN SET PRCFA("PODA")=PRCFPODA
- SET PRCFA("AMEND#")=PRCFAA
- WRITE !
- SET %A="DO YOU NEED TO ENTER AN ADDITIONAL CODE SHEET"
- SET %B=""
- SET %=2
- DO ^PRCFYN
- IF %'=1
- GOTO OUT
- +1 DO AM^PRCFAC
- GOTO AGAIN
- OUT DO Q15
- +1 if 'FLG
- GOTO OUT1
- SET PRCHQ="^PRCHPAM"
- SET PRCHQ("DEST")="S8"
- SET D0=PRCFA("PODA")
- SET D1=PRCFA("AMEND#")
- DO ^PRCHQUE
- OUT1 KILL FLG,%,%Y,DIC,I,J,K,P,PRCFA,PRCFAA,PRCFPODA,X,Y,Z
- QUIT
- +1 QUIT
- NOA WRITE !,$CHAR(7),"NO AMENDMENT EXISTS FOR THIS ORDER, PLEASE CHECK WITH SUPPLY. ",!,?20,"OPTION IS BEING ABORTED."
- QUIT
- ES ;
- ES1 NEW MESSAGE
- SET MESSAGE=""
- +1 DO ESIG^PRCUESIG(DUZ,.MESSAGE)
- +2 ;3 TRIES or NO SIG ON FILE
- if (MESSAGE=0)!(MESSAGE=-3)
- GOTO FAIL
- +3 ;ARROWED OUT or TIMED OUT
- if (MESSAGE=-1)!(MESSAGE=-2)
- GOTO FAIL1
- +4 QUIT
- FAIL SET FAIL=""
- WRITE !,$CHAR(7)," SIGNATURE CODE FAILURE "
- READ X:3
- QUIT
- FAIL1 SET FAIL=""
- QUIT
- Q15 SET DA=PRCFA("PODA")
- +1 SET MESSAGE=""
- +2 DO REMOVE^PRCHES7(PRCFA("PODA"),PRCFA("AMEND#"))
- +3 DO ENCODE^PRCHES7(PRCFA("PODA"),PRCFA("AMEND#"),DUZ,.MESSAGE)
- +4 KILL MESSAGE
- +5 QUIT
