PRCHRET ;WISC/AKS-PULL AMENDMENTS BACK TO SUPPLY ;7/19/95 13:56
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
PULL ;Return Purchase Order Amendment to Supply
D ^PRCFSITE Q:'%
D KILL
ASKPO ;Ask for purchase order and validate it.
K DIC("A") S D="E"
S DIC("S")="I +^(0)=PRC(""SITE"") S FSTAT=$O(^PRC(443.6,""D"",+Y,0)) I FSTAT=26!(FSTAT=31)!(FSTAT=36)!(FSTAT=45)!(FSTAT=71)"
S DIC("A")="Select Purchase Order Number: ",DIC=443.6,DIC(0)="AEQZ"
D IX^DIC K DIC,FSTAT,D G:+Y<0 KILL
S FLG=0,NODE0=Y(0),PO=Y,PRCFPODA=+Y,PRCFA("PODA")=+Y
I '$D(^PRC(443.6,+PO,6)) D G ASKPO
.W !! S X="NO AMENDMENT EXISTS FOR THIS ORDER . OPTION IS BEING ABORTED." D MSG^PRCFQ W !
I '$$VERIFY^PRCHES5(PRCFPODA) D G KILL
.W !!,"This Purchase Order has been tampered with. Please notify IFCAP APPLICATION COORDINATOR."
S AMEND=$O(^PRC(443.6,+PO,6,0)) I +AMEND'>0 D NOSIGN G ASKPO
S AMEND1=$G(^PRC(443.6,+PO,6,+AMEND,1)) I $P(AMEND1,U,2)="" D NOSIGN G ASKPO
S PRCFA("AMEND#")=+AMEND,PRCFAA=+AMEND
W ! D READ I 'Y!($D(DIRUT)) D NOPROC K DIRUT G ASKPO
I Y D
.D REMOVE^PRCHES10(+PO,PRCFAA) I Y=-1 W !,"INCOMPLETE RECORD" G KILL
.N DA,DIE,DR
.S DIE="^PRC(443.6,"_+PO_",6,",DA=PRCFAA,DR="15///TODAY+7" D ^DIE
.Q
W !! G ASKPO
READ ; Reader
S DIR(0)="Y",DIR("A")="Amendment",DIR("B")="YES"
S DIR("A",1)="Are you sure you want to pull back this Purchase Order"
S DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to pull back this Purchase Order to"
S DIR("?",2)="Supply.",DIR("?",3)=" "
D ^DIR K DIR
Q
NOAMEND ;No amendment to pull
W !! S X="NO AMENDMENT EXISTS FOR THIS ORDER . OPTION IS BEING ABORTED ." D MSG^PRCFQ W !
Q
NOSIGN ; Message Processing for amendments still in Supply
W !! S X="This Purchase Order Amendment is already in Supply.*" D MSG^PRCFQ W !
Q
NOPROC ; Message Processing for exit
W !! S X="No further processing is being taken on this amendment obligation.*" D MSG^PRCFQ W !
Q
KILL ;Kill local variables
K FLG,%,PO,PRCFA,PRCFAA,PRCFPODA,X,Y,NODE0,AMEND,AMEND1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRET 2138 printed Sep 23, 2025@19:46:19 Page 2
PRCHRET ;WISC/AKS-PULL AMENDMENTS BACK TO SUPPLY ;7/19/95 13:56
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
PULL ;Return Purchase Order Amendment to Supply
+1 DO ^PRCFSITE
if '%
QUIT
+2 DO KILL
ASKPO ;Ask for purchase order and validate it.
+1 KILL DIC("A")
SET D="E"
+2 SET DIC("S")="I +^(0)=PRC(""SITE"") S FSTAT=$O(^PRC(443.6,""D"",+Y,0)) I FSTAT=26!(FSTAT=31)!(FSTAT=36)!(FSTAT=45)!(FSTAT=71)"
+3 SET DIC("A")="Select Purchase Order Number: "
SET DIC=443.6
SET DIC(0)="AEQZ"
+4 DO IX^DIC
KILL DIC,FSTAT,D
if +Y<0
GOTO KILL
+5 SET FLG=0
SET NODE0=Y(0)
SET PO=Y
SET PRCFPODA=+Y
SET PRCFA("PODA")=+Y
+6 IF '$DATA(^PRC(443.6,+PO,6))
Begin DoDot:1
+7 WRITE !!
SET X="NO AMENDMENT EXISTS FOR THIS ORDER . OPTION IS BEING ABORTED."
DO MSG^PRCFQ
WRITE !
End DoDot:1
GOTO ASKPO
+8 IF '$$VERIFY^PRCHES5(PRCFPODA)
Begin DoDot:1
+9 WRITE !!,"This Purchase Order has been tampered with. Please notify IFCAP APPLICATION COORDINATOR."
End DoDot:1
GOTO KILL
+10 SET AMEND=$ORDER(^PRC(443.6,+PO,6,0))
IF +AMEND'>0
DO NOSIGN
GOTO ASKPO
+11 SET AMEND1=$GET(^PRC(443.6,+PO,6,+AMEND,1))
IF $PIECE(AMEND1,U,2)=""
DO NOSIGN
GOTO ASKPO
+12 SET PRCFA("AMEND#")=+AMEND
SET PRCFAA=+AMEND
+13 WRITE !
DO READ
IF 'Y!($DATA(DIRUT))
DO NOPROC
KILL DIRUT
GOTO ASKPO
+14 IF Y
Begin DoDot:1
+15 DO REMOVE^PRCHES10(+PO,PRCFAA)
IF Y=-1
WRITE !,"INCOMPLETE RECORD"
GOTO KILL
+16 NEW DA,DIE,DR
+17 SET DIE="^PRC(443.6,"_+PO_",6,"
SET DA=PRCFAA
SET DR="15///TODAY+7"
DO ^DIE
+18 QUIT
End DoDot:1
+19 WRITE !!
GOTO ASKPO
READ ; Reader
+1 SET DIR(0)="Y"
SET DIR("A")="Amendment"
SET DIR("B")="YES"
+2 SET DIR("A",1)="Are you sure you want to pull back this Purchase Order"
+3 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
+4 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to pull back this Purchase Order to"
+5 SET DIR("?",2)="Supply."
SET DIR("?",3)=" "
+6 DO ^DIR
KILL DIR
+7 QUIT
NOAMEND ;No amendment to pull
+1 WRITE !!
SET X="NO AMENDMENT EXISTS FOR THIS ORDER . OPTION IS BEING ABORTED ."
DO MSG^PRCFQ
WRITE !
+2 QUIT
NOSIGN ; Message Processing for amendments still in Supply
+1 WRITE !!
SET X="This Purchase Order Amendment is already in Supply.*"
DO MSG^PRCFQ
WRITE !
+2 QUIT
NOPROC ; Message Processing for exit
+1 WRITE !!
SET X="No further processing is being taken on this amendment obligation.*"
DO MSG^PRCFQ
WRITE !
+2 QUIT
KILL ;Kill local variables
+1 KILL FLG,%,PO,PRCFA,PRCFAA,PRCFPODA,X,Y,NODE0,AMEND,AMEND1
+2 QUIT
