PRCFFMOM ;WOIFO/SJG/AS-ROUTINE TO PROCESS AMENDMENT OBLIGATIONS ;3/8/05
V ;;5.1;IFCAP;**81,180**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*180 Added check for Delivery Date change to send document
; to FMS
;
D ^PRCFSITE Q:'% ; ask station
D OUT1 ; kill variables
;
; prompt for signature (E-Sig code for amendment)
S MESSAGE=""
D ESIG^PRCUESIG(DUZ,.MESSAGE)
I MESSAGE<1 D G OUT1 ; exit if bad response
. I (MESSAGE=0)!(MESSAGE=-3) W !,$C(7)," SIGNATURE CODE FAILURE " R X:3 ;3 TRIES or NO SIG ON FILE
. I (MESSAGE=-1)!(MESSAGE=-2) Q ;ARROWED OUT or TIMED OUT
;
START ; get PO#
K PRCFA
K DIC("A")
S D="E"
S DIC=443.6
S 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)"
S DIC("A")="Select Purchase Order Number: "
S DIC(0)="AEQZ"
D IX^DIC
K DIC("S"),DIC("A")
K FSO
G:+Y<0 OUT1
S FLG=0
S PO=Y,PO(0)=Y(0)
S PRCFA("PODA")=+Y
S PRCFPODA=+Y
I '$D(^PRC(443.6,+PO,6)) D NOA G OUT1 ; PO has no amendments
I $P(^PRC(443.6,+PO,6,0),"^",4)<0 D NOA G OUT1 ; PO has no amendments
I '$$VERIFY^PRCHES5(PRCFPODA) D MSG1 G OUT1 ; tampered PO
;
; get amendment #
AMEND S DIC="^PRC(443.6,"_+PO_",6,"
S DIC("A")="Select AMENDMENT: "
S DIC(0)="AEMNZQ"
D ^DIC
K DIC("A")
G:Y<0 OUT1
S PO(6)=Y(0)
S PO(6,1)=^PRC(443.6,+PO,6,+Y,1)
S PRCFA("AMEND#")=+Y
S PRCFAA=+Y
;
DESC ; verify amendment is complete
I $$CHKAMEN^PRCFFU(+PO,PRCFAA) W !,?15,"Return Amendment to A&MM.",! G START
I $P($G(PO(6,1)),U,2)="" D G START
. W ! D EN^DDIOL("This amendment is still awaiting signature by A&MM!")
. W !
;
; set up variables used in this option
S PRCFA("RETRAN")=0
S D0=+PO
S D1=+Y
S PRCHPO=PRCFPODA
S PRCHAM=PRCFAA
D ^PRCHSF3 ; sets up PRCH("AM") array
D ^PRCHDAM ; display amendment info
D DT442^PRCFFUD1(PRCFPODA,PO(0),443.6,PRCFA("AMEND#")) ; set up PRC array
RETRAN ; Entry point for rebuild/transmit
S PRCFA("MOD")="M^1^Modification Entry"
;
; check amendment record for availability
L +^PRC(443.6,PRCFPODA):1
I $T=0 D G OUT1
. W $C(7),!
. D EN^DDIOL("This amendment is being obligated by another user!")
;
I 'PRCFA("RETRAN"),$O(^PRC(443.6,PRCFPODA,6,PRCFAA,3,"AC",32,0)) N P2237 S P2237=$P(^PRC(443.6,PRCFPODA,0),U,12) I P2237>0 I '$$VERIFY^PRCSC2(P2237) D MSG1 G OUT1 ; tampered PO
;
I PRCFA("RETRAN") D DT442^PRCFFUD1(PRCFPODA,PO(0),442,PRCFA("AMEND#"))
;
I $G(PRCRGS)<1 D OVCOM^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D POFAIL^PRCFFU10,MSG G OUT1
;
S PCP=+$P(PO(0),U,3)
S $P(PCP,U,2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),U,12),1:"")
APP W !
D OKAM^PRCFFU I 'Y!($D(DIRUT)) G AMEND ; ask OK to amend?
D SC^PRCFFUA1 ; display FCP, cost ctr, PO/Req#
D CPBAL^PRCFFUA1 ; display cost & balances
D GET^PRCFFUA1 ; display amended (BOC) info
S FATAL=0
D OK^PRCFFUA ; ask if above BOC info is correct
S SAVEY=Y
I Y D S Y=SAVEY K SAVEY I FATAL=1 D MSG10^PRCFFUA3 G APP1
. D GETBOC^PRCFFUA4
. D CHKBOC^PRCFFUA4
I 'Y!($D(DIRUT)) D I FISCEDIT G RETRAN
.S FISCEDIT=0
.I $D(DIRUT) D MSG9^PRCFFUA3 Q
.I 'Y D MSG8^PRCFFUA3,POAM^PRCFFUA Q
.Q
D KILL^PRCFFUA
APP1 I FATAL=1 G:PRCFA("RETRAN")=0 START Q:PRCFA("RETRAN")=1
I $D(^PRC(443.6,+PO,6)),$P(PO(6,1),"^",5)'="" D I 'Y!($D(DIRUT)) G OUT1
. W !
. D OKAPP^PRCFFU ; amendment approved, ask 'continue?'
PRT W !
D OKPRT^PRCFFU S:Y FLG=1 ; print amendment
S PRCFA("AMEND#")=PRCFAA
S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
S PRCFA("IDES")="Purchase Order Amendment Obligation"
S PRCFA("MP")=$P(PO(0),U,2)
S PRCFA("PODA")=PRCFPODA
S PRCFA("REF")=$P(PO(0),U)
; the following line commented out in PRC*5*179
; S PRCFA("SFC")=$P(PO(0),U,19)
S PRCFA("SYS")="FMS"
S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",1:"MO")
I $D(GECSDATA),$E($G(GECSDATA(2100.1,GECSDATA,.01,"E")),1,3)="AR-" S PRCFA("TT")="AR"
PRT1 I PRCFA("MP")=2&(PRCFA("TT")="SO") D G:ACCEDIT=1 PRT1
. W !
. D EN^PRCFFU16(+PO)
PRT11 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G PRT2
. D RETRANM^PRCFFMO2
. S Y=PRCFA("OBLDATE")
S Y=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("AMENDT"))
PRT2 D D^PRCFQ
S %DT="AEX"
S %DT("A")="Select Obligation Processing Date: "
S %DT("B")=Y
W !
D ^%DT
K %DT
I Y<0 D MSG H 3 G OUT1
S PRCFA("OBLDATE")=Y
S EXIT=0
D ENM^PRCFFMO2
I EXIT D MSG,KILL^PRCFFMO2 H 3 G OUT1
I PRC("RBDT")'<$P(^PRC(420,PRC("SITE"),0),"^",9),$P($$DATE^PRC0C(PRCFA("OBLDATE"),"I"),U,1,2)'=$P($$DATE^PRC0C(PRC("RBDT"),"I"),U,1,2) D MSG1^PRCFFUD G PRT11
D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
EDIT ; Get budget/accounting elements
N PARAM
S PARAM=+$P(PO(0),U,3)_"^"_PRC("FY")_"^"_PRCFA("BBFY")
S PRCFMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
S IDFLAG="I"
S XRBLD=0
I PRCFA("RETRAN")=1 D EN^PRCFFUB ; if selected transaction to rebuild is a 'X' decrease or cancel, set XRBLD=1, set to 2 if it is the 'E'
;
; determine the correct transaction type if this is not an MO document
I PRCFA("TT")'="MO",XRBLD=0 D I "^AR^SO^"'[("^"_$P(PRCFA("TT"),":",1)) D MSG,OUT1 Q
. N PRCFATT S PRCFATT=PRCFA("TT")
. D SOAR^PRC0E(PRCFA("PODA"),.PRCFATT,1) ; ask SO or AR, if appropriate
. S PRCFA("TT")=PRCFATT K PRCFATT
;
I PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^")="AR",PRCFA("TT")="AR" D
. I $P(PRCFA("GECS"),"^",2)="E" S PRCFA("MOD")="E^0^Original Document"
. I $P(PRCFA("GECS"),"^",2)="M" S PRCFA("MOD")="M^1^Modification Document"
;
I PRCFA("TT")="AR",XRBLD=0 D I "EM"'[X D MSG,OUT1 Q
. S X="M"
. I PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^",2)="E" S X="E"
. D SC^PRC0A("",.Y,"Label document action as: ","AOM^E:Original Document;M:Modification Document",X)
. I $E(Y)="E" S PRCFA("MOD")="E^0^Original Document"
. I $E(Y)="M" S PRCFA("MOD")="M^1^Modification Document"
. S X=$E(Y)
. K Y
;
; check to see if transaction type or document type changed
S X=0
I XRBLD=0,$G(PRCFA("RETRAN"))=1,"^SO^AR"[("^"_$E(PRCFA("TT"),1,2)),$P(PRCFA("GECS"),"^",1,2)'=($E(PRCFA("TT"),1,2)_"^"_$E(PRCFA("MOD"))) D I X="^" D MSG,PAUSE^PRCFFERU G OUT1
. S PRCFA("SIS")=$$GETTXNS^PRCFFERT(PO,PRCFA("AMEND#"),2) ; get other txns for this amendment
. S X=$$NEWCHK^PRCFFERT(PRCFA("TT"),$E(PRCFA("MOD"),1),PRCFA("SIS")) ; does selected txn exist?
. I X=0 S PRCFA("RETRAN")=2 ; txn doesn't exist, create
. I X'=0 S X=$$SWITCH^PRCFFERT(X,2,.GECSDATA) ; replace current GECSDATA values with values belonging to selected txn-- returns '^' if not switched
;
GO ; Prompt user for for final go-ahead for approval
D GO^PRCFFU
I 'Y!($D(DIRUT)) D MSG,OUT1 Q
ESIG W !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
D SIG^PRCFFU4
I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") H 3 G OUT1
S DA=PRCFA("PODA")
D REMOVE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"))
S MESSAGE="" ; value not used but variable is needed by next call
D ENCODE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"),DUZ,.MESSAGE)
;
D DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
S PRCOAMT=+^PRC(442,PRCFA("PODA"),0)
S $P(PRCOAMT,"^",2)=+$P(^PRC(442,PRCFA("PODA"),0),"^",3)
S $P(PRCOAMT,"^",3)=PRC("FYQDT")
S $P(PRCOAMT,"^",5)=-$P(^PRC(442,PRCFA("PODA"),0),"^",$P(PRCFMO,"^",12)="N"+15)
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 G TRANS1
TRANS W !!,"...copying amendment information back to Purchase Order file...",! D WAIT^DICD
S ERFLAG=""
S PRCFA("DLVDATE")=$P(^PRC(442,PRCFA("PODA"),0),"^",10)
D CHECK^PRCHAMYA(PRCFA("PODA"),PRCFA("AMEND#"),.ERFLAG)
I ERFLAG W !!,"...ERROR IN COPYING AMENDMENT INFORMATION BACK TO PURCHASE ORDER FILE..." G OUT1
TRANS1 D DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
; transmit amendment from IFCAP to DynaMed **81**
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 D
. ; No DynaMed interface if rebuild/retransmit
. I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 Q
. D ENT^PRCVPOU(PRCFA("PODA"),PRCFA("AMEND#"))
S PRCFA("OLDPODA")=PRCFA("PODA")
S PRCFA("OLDREF")=PRCFA("REF")
I PRCFA("RETRAN")>0 I XRBLD=1!(XRBLD=2) D GO^PRCFFUB H 3 Q ; if rebuilding a 'dependent' transaction, finish work here
D LIST^PRCFFU7(PRCFA("PODA"),PRCFA("AMEND#"))
I $P(^PRC(442,PRCFA("PODA"),0),U,20),($P(^PRC(442,PRCFA("PODA"),0),U,10)'=$P(^PRC(442,PRCFA("PODA"),0),U,20)) D ;PRC*5.1*180 Check for Del Date change, if so, send doc to FMS
. S PRCFA("MOMREQ")=1,PRCFA("MOMNOTREQ")=0,PRCFA("ZERO")="" ;PRC*5.1*180 reset flag to send doc
I $G(PRCFA("RETRAN"))<1 D AMEND^PRCFFUD ; create entry in 410
I PRCFA("AUTHE") D FCP^PRCFFU11,PRINT G START
I 'PRCFA("MOMREQ") D MSG^PRCFFU8 G PRINT ; skip FMS transmit,fiscal updates
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D SETPO^PRCFFERT
I $G(PRCFA("ACCEDIT"))=1 D TAG33^PRCFFU9
TRANS2 K PO
D ^PRCFFM1M
L -^PRC(443.6,PRCFA("PODA"))
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D OUT1^PRCFFM1M G START
QUIT
;
PRINT ; Print out copy of Purchase Order Amendment
G:'FLG OUT1
S PRCHQ="^PRCHPAM"
S PRCHQ("DEST")="S8"
S D0=PRCFA("PODA")
S D1=PRCFA("AMEND#")
D ^PRCHQUE
OUT1 K FATAL,FLG,%,%Y,DIC,I,J,K,P,PRCFA,PRCFAA,PRCFPODA,PRCFCHG,X,XRBLD,Y,Z
Q
; Message processing
NOA D NOA^PRCFFM3M Q
MSG D MSG^PRCFFM3M Q
MSG1 D MSG1^PRCFFM3M Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFMOM 9268 printed Dec 13, 2024@02:03:31 Page 2
PRCFFMOM ;WOIFO/SJG/AS-ROUTINE TO PROCESS AMENDMENT OBLIGATIONS ;3/8/05
V ;;5.1;IFCAP;**81,180**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*180 Added check for Delivery Date change to send document
+4 ; to FMS
+5 ;
+6 ; ask station
DO ^PRCFSITE
if '%
QUIT
+7 ; kill variables
DO OUT1
+8 ;
+9 ; prompt for signature (E-Sig code for amendment)
+10 SET MESSAGE=""
+11 DO ESIG^PRCUESIG(DUZ,.MESSAGE)
+12 ; exit if bad response
IF MESSAGE<1
Begin DoDot:1
+13 ;3 TRIES or NO SIG ON FILE
IF (MESSAGE=0)!(MESSAGE=-3)
WRITE !,$CHAR(7)," SIGNATURE CODE FAILURE "
READ X:3
+14 ;ARROWED OUT or TIMED OUT
IF (MESSAGE=-1)!(MESSAGE=-2)
QUIT
End DoDot:1
GOTO OUT1
+15 ;
START ; get PO#
+1 KILL PRCFA
+2 KILL DIC("A")
+3 SET D="E"
+4 SET DIC=443.6
+5 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)"
+6 SET DIC("A")="Select Purchase Order Number: "
+7 SET DIC(0)="AEQZ"
+8 DO IX^DIC
+9 KILL DIC("S"),DIC("A")
+10 KILL FSO
+11 if +Y<0
GOTO OUT1
+12 SET FLG=0
+13 SET PO=Y
SET PO(0)=Y(0)
+14 SET PRCFA("PODA")=+Y
+15 SET PRCFPODA=+Y
+16 ; PO has no amendments
IF '$DATA(^PRC(443.6,+PO,6))
DO NOA
GOTO OUT1
+17 ; PO has no amendments
IF $PIECE(^PRC(443.6,+PO,6,0),"^",4)<0
DO NOA
GOTO OUT1
+18 ; tampered PO
IF '$$VERIFY^PRCHES5(PRCFPODA)
DO MSG1
GOTO OUT1
+19 ;
+20 ; get amendment #
AMEND SET DIC="^PRC(443.6,"_+PO_",6,"
+1 SET DIC("A")="Select AMENDMENT: "
+2 SET DIC(0)="AEMNZQ"
+3 DO ^DIC
+4 KILL DIC("A")
+5 if Y<0
GOTO OUT1
+6 SET PO(6)=Y(0)
+7 SET PO(6,1)=^PRC(443.6,+PO,6,+Y,1)
+8 SET PRCFA("AMEND#")=+Y
+9 SET PRCFAA=+Y
+10 ;
DESC ; verify amendment is complete
+1 IF $$CHKAMEN^PRCFFU(+PO,PRCFAA)
WRITE !,?15,"Return Amendment to A&MM.",!
GOTO START
+2 IF $PIECE($GET(PO(6,1)),U,2)=""
Begin DoDot:1
+3 WRITE !
DO EN^DDIOL("This amendment is still awaiting signature by A&MM!")
+4 WRITE !
End DoDot:1
GOTO START
+5 ;
+6 ; set up variables used in this option
+7 SET PRCFA("RETRAN")=0
+8 SET D0=+PO
+9 SET D1=+Y
+10 SET PRCHPO=PRCFPODA
+11 SET PRCHAM=PRCFAA
+12 ; sets up PRCH("AM") array
DO ^PRCHSF3
+13 ; display amendment info
DO ^PRCHDAM
+14 ; set up PRC array
DO DT442^PRCFFUD1(PRCFPODA,PO(0),443.6,PRCFA("AMEND#"))
RETRAN ; Entry point for rebuild/transmit
+1 SET PRCFA("MOD")="M^1^Modification Entry"
+2 ;
+3 ; check amendment record for availability
+4 LOCK +^PRC(443.6,PRCFPODA):1
+5 IF $TEST=0
Begin DoDot:1
+6 WRITE $CHAR(7),!
+7 DO EN^DDIOL("This amendment is being obligated by another user!")
End DoDot:1
GOTO OUT1
+8 ;
+9 ; tampered PO
IF 'PRCFA("RETRAN")
IF $ORDER(^PRC(443.6,PRCFPODA,6,PRCFAA,3,"AC",32,0))
NEW P2237
SET P2237=$PIECE(^PRC(443.6,PRCFPODA,0),U,12)
IF P2237>0
IF '$$VERIFY^PRCSC2(P2237)
DO MSG1
GOTO OUT1
+10 ;
+11 IF PRCFA("RETRAN")
DO DT442^PRCFFUD1(PRCFPODA,PO(0),442,PRCFA("AMEND#"))
+12 ;
+13 IF $GET(PRCRGS)<1
DO OVCOM^PRCFFU10
IF PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2)
DO POFAIL^PRCFFU10
DO MSG
GOTO OUT1
+14 ;
+15 SET PCP=+$PIECE(PO(0),U,3)
+16 SET $PIECE(PCP,U,2)=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+PCP,0)):$PIECE(^(0),U,12),1:"")
APP WRITE !
+1 ; ask OK to amend?
DO OKAM^PRCFFU
IF 'Y!($DATA(DIRUT))
GOTO AMEND
+2 ; display FCP, cost ctr, PO/Req#
DO SC^PRCFFUA1
+3 ; display cost & balances
DO CPBAL^PRCFFUA1
+4 ; display amended (BOC) info
DO GET^PRCFFUA1
+5 SET FATAL=0
+6 ; ask if above BOC info is correct
DO OK^PRCFFUA
+7 SET SAVEY=Y
+8 IF Y
Begin DoDot:1
+9 DO GETBOC^PRCFFUA4
+10 DO CHKBOC^PRCFFUA4
End DoDot:1
SET Y=SAVEY
KILL SAVEY
IF FATAL=1
DO MSG10^PRCFFUA3
GOTO APP1
+11 IF 'Y!($DATA(DIRUT))
Begin DoDot:1
+12 SET FISCEDIT=0
+13 IF $DATA(DIRUT)
DO MSG9^PRCFFUA3
QUIT
+14 IF 'Y
DO MSG8^PRCFFUA3
DO POAM^PRCFFUA
QUIT
+15 QUIT
End DoDot:1
IF FISCEDIT
GOTO RETRAN
+16 DO KILL^PRCFFUA
APP1 IF FATAL=1
if PRCFA("RETRAN")=0
GOTO START
if PRCFA("RETRAN")=1
QUIT
+1 IF $DATA(^PRC(443.6,+PO,6))
IF $PIECE(PO(6,1),"^",5)'=""
Begin DoDot:1
+2 WRITE !
+3 ; amendment approved, ask 'continue?'
DO OKAPP^PRCFFU
End DoDot:1
IF 'Y!($DATA(DIRUT))
GOTO OUT1
PRT WRITE !
+1 ; print amendment
DO OKPRT^PRCFFU
if Y
SET FLG=1
+2 SET PRCFA("AMEND#")=PRCFAA
+3 SET PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
+4 SET PRCFA("IDES")="Purchase Order Amendment Obligation"
+5 SET PRCFA("MP")=$PIECE(PO(0),U,2)
+6 SET PRCFA("PODA")=PRCFPODA
+7 SET PRCFA("REF")=$PIECE(PO(0),U)
+8 ; the following line commented out in PRC*5*179
+9 ; S PRCFA("SFC")=$P(PO(0),U,19)
+10 SET PRCFA("SYS")="FMS"
+11 SET PRCFA("TT")=$SELECT(PRCFA("MP")=2:"SO",1:"MO")
+12 IF $DATA(GECSDATA)
IF $EXTRACT($GET(GECSDATA(2100.1,GECSDATA,.01,"E")),1,3)="AR-"
SET PRCFA("TT")="AR"
PRT1 IF PRCFA("MP")=2&(PRCFA("TT")="SO")
Begin DoDot:1
+1 WRITE !
+2 DO EN^PRCFFU16(+PO)
End DoDot:1
if ACCEDIT=1
GOTO PRT1
PRT11 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
Begin DoDot:1
+1 DO RETRANM^PRCFFMO2
+2 SET Y=PRCFA("OBLDATE")
End DoDot:1
GOTO PRT2
+3 SET Y=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("AMENDT"))
PRT2 DO D^PRCFQ
+1 SET %DT="AEX"
+2 SET %DT("A")="Select Obligation Processing Date: "
+3 SET %DT("B")=Y
+4 WRITE !
+5 DO ^%DT
+6 KILL %DT
+7 IF Y<0
DO MSG
HANG 3
GOTO OUT1
+8 SET PRCFA("OBLDATE")=Y
+9 SET EXIT=0
+10 DO ENM^PRCFFMO2
+11 IF EXIT
DO MSG
DO KILL^PRCFFMO2
HANG 3
GOTO OUT1
+12 IF PRC("RBDT")'<$PIECE(^PRC(420,PRC("SITE"),0),"^",9)
IF $PIECE($$DATE^PRC0C(PRCFA("OBLDATE"),"I"),U,1,2)'=$PIECE($$DATE^PRC0C(PRC("RBDT"),"I"),U,1,2)
DO MSG1^PRCFFUD
GOTO PRT11
+13 DO GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
EDIT ; Get budget/accounting elements
+1 NEW PARAM
+2 SET PARAM=+$PIECE(PO(0),U,3)_"^"_PRC("FY")_"^"_PRCFA("BBFY")
+3 SET PRCFMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
+4 SET IDFLAG="I"
+5 SET XRBLD=0
+6 ; if selected transaction to rebuild is a 'X' decrease or cancel, set XRBLD=1, set to 2 if it is the 'E'
IF PRCFA("RETRAN")=1
DO EN^PRCFFUB
+7 ;
+8 ; determine the correct transaction type if this is not an MO document
+9 IF PRCFA("TT")'="MO"
IF XRBLD=0
Begin DoDot:1
+10 NEW PRCFATT
SET PRCFATT=PRCFA("TT")
+11 ; ask SO or AR, if appropriate
DO SOAR^PRC0E(PRCFA("PODA"),.PRCFATT,1)
+12 SET PRCFA("TT")=PRCFATT
KILL PRCFATT
End DoDot:1
IF "^AR^SO^"'[("^"_$PIECE(PRCFA("TT"),":",1))
DO MSG
DO OUT1
QUIT
+13 ;
+14 IF PRCFA("RETRAN")=1
IF $PIECE(PRCFA("GECS"),"^")="AR"
IF PRCFA("TT")="AR"
Begin DoDot:1
+15 IF $PIECE(PRCFA("GECS"),"^",2)="E"
SET PRCFA("MOD")="E^0^Original Document"
+16 IF $PIECE(PRCFA("GECS"),"^",2)="M"
SET PRCFA("MOD")="M^1^Modification Document"
End DoDot:1
+17 ;
+18 IF PRCFA("TT")="AR"
IF XRBLD=0
Begin DoDot:1
+19 SET X="M"
+20 IF PRCFA("RETRAN")=1
IF $PIECE(PRCFA("GECS"),"^",2)="E"
SET X="E"
+21 DO SC^PRC0A("",.Y,"Label document action as: ","AOM^E:Original Document;M:Modification Document",X)
+22 IF $EXTRACT(Y)="E"
SET PRCFA("MOD")="E^0^Original Document"
+23 IF $EXTRACT(Y)="M"
SET PRCFA("MOD")="M^1^Modification Document"
+24 SET X=$EXTRACT(Y)
+25 KILL Y
End DoDot:1
IF "EM"'[X
DO MSG
DO OUT1
QUIT
+26 ;
+27 ; check to see if transaction type or document type changed
+28 SET X=0
+29 IF XRBLD=0
IF $GET(PRCFA("RETRAN"))=1
IF "^SO^AR"[("^"_$EXTRACT(PRCFA("TT"),1,2))
IF $PIECE(PRCFA("GECS"),"^",1,2)'=($EXTRACT(PRCFA("TT"),1,2)_"^"_$EXTRACT(PRCFA("MOD")))
Begin DoDot:1
+30 ; get other txns for this amendment
SET PRCFA("SIS")=$$GETTXNS^PRCFFERT(PO,PRCFA("AMEND#"),2)
+31 ; does selected txn exist?
SET X=$$NEWCHK^PRCFFERT(PRCFA("TT"),$EXTRACT(PRCFA("MOD"),1),PRCFA("SIS"))
+32 ; txn doesn't exist, create
IF X=0
SET PRCFA("RETRAN")=2
+33 ; replace current GECSDATA values with values belonging to selected txn-- returns '^' if not switched
IF X'=0
SET X=$$SWITCH^PRCFFERT(X,2,.GECSDATA)
End DoDot:1
IF X="^"
DO MSG
DO PAUSE^PRCFFERU
GOTO OUT1
+34 ;
GO ; Prompt user for for final go-ahead for approval
+1 DO GO^PRCFFU
+2 IF 'Y!($DATA(DIRUT))
DO MSG
DO OUT1
QUIT
ESIG WRITE !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
+1 DO SIG^PRCFFU4
+2 IF $DATA(PRCFA("SIGFAIL"))
KILL PRCFA("SIGFAIL")
HANG 3
GOTO OUT1
+3 SET DA=PRCFA("PODA")
+4 DO REMOVE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"))
+5 ; value not used but variable is needed by next call
SET MESSAGE=""
+6 DO ENCODE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"),DUZ,.MESSAGE)
+7 ;
+8 DO DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
+9 SET PRCOAMT=+^PRC(442,PRCFA("PODA"),0)
+10 SET $PIECE(PRCOAMT,"^",2)=+$PIECE(^PRC(442,PRCFA("PODA"),0),"^",3)
+11 SET $PIECE(PRCOAMT,"^",3)=PRC("FYQDT")
+12 SET $PIECE(PRCOAMT,"^",5)=-$PIECE(^PRC(442,PRCFA("PODA"),0),"^",$PIECE(PRCFMO,"^",12)="N"+15)
+13 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")>0
GOTO TRANS1
TRANS WRITE !!,"...copying amendment information back to Purchase Order file...",!
DO WAIT^DICD
+1 SET ERFLAG=""
+2 SET PRCFA("DLVDATE")=$PIECE(^PRC(442,PRCFA("PODA"),0),"^",10)
+3 DO CHECK^PRCHAMYA(PRCFA("PODA"),PRCFA("AMEND#"),.ERFLAG)
+4 IF ERFLAG
WRITE !!,"...ERROR IN COPYING AMENDMENT INFORMATION BACK TO PURCHASE ORDER FILE..."
GOTO OUT1
TRANS1 DO DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
+1 ; transmit amendment from IFCAP to DynaMed **81**
+2 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
Begin DoDot:1
+3 ; No DynaMed interface if rebuild/retransmit
+4 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")>0
QUIT
+5 DO ENT^PRCVPOU(PRCFA("PODA"),PRCFA("AMEND#"))
End DoDot:1
+6 SET PRCFA("OLDPODA")=PRCFA("PODA")
+7 SET PRCFA("OLDREF")=PRCFA("REF")
+8 ; if rebuilding a 'dependent' transaction, finish work here
IF PRCFA("RETRAN")>0
IF XRBLD=1!(XRBLD=2)
DO GO^PRCFFUB
HANG 3
QUIT
+9 DO LIST^PRCFFU7(PRCFA("PODA"),PRCFA("AMEND#"))
+10 ;PRC*5.1*180 Check for Del Date change, if so, send doc to FMS
IF $PIECE(^PRC(442,PRCFA("PODA"),0),U,20)
IF ($PIECE(^PRC(442,PRCFA("PODA"),0),U,10)'=$PIECE(^PRC(442,PRCFA("PODA"),0),U,20))
Begin DoDot:1
+11 ;PRC*5.1*180 reset flag to send doc
SET PRCFA("MOMREQ")=1
SET PRCFA("MOMNOTREQ")=0
SET PRCFA("ZERO")=""
End DoDot:1
+12 ; create entry in 410
IF $GET(PRCFA("RETRAN"))<1
DO AMEND^PRCFFUD
+13 IF PRCFA("AUTHE")
DO FCP^PRCFFU11
DO PRINT
GOTO START
+14 ; skip FMS transmit,fiscal updates
IF 'PRCFA("MOMREQ")
DO MSG^PRCFFU8
GOTO PRINT
+15 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
DO SETPO^PRCFFERT
+16 IF $GET(PRCFA("ACCEDIT"))=1
DO TAG33^PRCFFU9
TRANS2 KILL PO
+1 DO ^PRCFFM1M
+2 LOCK -^PRC(443.6,PRCFA("PODA"))
+3 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=0
DO OUT1^PRCFFM1M
GOTO START
+4 QUIT
+5 ;
PRINT ; Print out copy of Purchase Order Amendment
+1 if 'FLG
GOTO OUT1
+2 SET PRCHQ="^PRCHPAM"
+3 SET PRCHQ("DEST")="S8"
+4 SET D0=PRCFA("PODA")
+5 SET D1=PRCFA("AMEND#")
+6 DO ^PRCHQUE
OUT1 KILL FATAL,FLG,%,%Y,DIC,I,J,K,P,PRCFA,PRCFAA,PRCFPODA,PRCFCHG,X,XRBLD,Y,Z
+1 QUIT
+2 ; Message processing
NOA DO NOA^PRCFFM3M
QUIT
MSG DO MSG^PRCFFM3M
QUIT
MSG1 DO MSG1^PRCFFM3M
QUIT
