PRCESOM ;WISC/SJG/ASU - CONTINUATION OF 1358 ADJUST OBLIAGTION PRCEADJ1 ;4/27/94 2:13 PM
V ;;5.1;IFCAP;**148,153,180**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*180 RGB 10/22/12 Added switch PRCE424 coming from 1358 processing
;to insure new entry check (EN1^PRCSUT3) uses file 424, not file 410.
;
N TI,PRCFASYS,IOINLOW,IOINHI,IOINORM,DIR,AMT,OLDTT,CS,HASH,DIE,DR,LAUTH,LBAL,TAUTH,TBAL,DLAYGO
D SCREEN
S PRC("CP")=$P(TRNODE(0),"-",4)
S PRC("RBDT")=$P(TRNODE(0),U,11)
I $G(PRCRGS)<1 D OVCOM1^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D REQFAIL^PRCFFU10,MSG G OUT
; PRC*5.1*148 start
; if Obligator is a requestor, violation to segregation of duties
I $P($G(TRNODE(7)),"^",1)=DUZ D S Y=0 D MSG G OUT
. W !!,"You are the CP Clerk (Requestor) on this 1358 transaction."
. W !,"Per Segregation of Duties, the CP Clerk (Requestor)"
. W " is not permitted to "
. W $S($G(PRCFA("RETRAN")):"Rebuild/Retransmit",1:"Obligate")," the 1358."
. I '$G(PRCFA("RETRAN")) Q
. W ! D EN^DDIOL(" ** Press RETURN to continue **")
. R X:DTIME Q
; if Obligator is a approver, violation to segregation of duties
I $P($G(TRNODE(7)),"^",3)=DUZ D S Y=0 D MSG G OUT
. W !!,"You are the Approver on this 1358 transaction."
. W !,"Per Segregation of Duties, the Approver is not permitted to "
. W $S($G(PRCFA("RETRAN")):"Rebuild/Retransmit",1:"Obligate")," the 1358."
. I '$G(PRCFA("RETRAN")) Q
. W ! D EN^DDIOL(" ** Press RETURN to continue **")
. R X:DTIME Q
; PRC*5.1*148 end
;
D OKAY2^PRCFFU ; ask 'OK to continue?'
I 'Y!($D(DIRUT)) D MSG G OUT
S AMT=$P(TRNODE(4),U,8)
K F I=7,9 S AMT(I)=$P(TRNODE(3),"^",I) S:AMT(I)<0 AMT(I)=-AMT(I) S AMT(I)=AMT(I)*100
S PRC("CP")=$P(TRNODE(0),"-",4)
S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
S PRCFA("MOD")="M^1^Modification Entry"
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^",2)="E" S PRCFA("MOD")="E^0^Original Document"
S PRCFA("MP")=$P(PO(0),U,2)
S PRCFA("PATNUM")=$P($P(PO(0),U),"-",2)
S PRCFA("PODA")=PODA
S PRCFA("REF")=$P(PO(0),U)
; S PRCFA("SFC")=$P(PO(0),U,19)
S PRCFA("SYS")="FMS"
S PRCFA("TT")="SO"
I $D(GECSDATA),$G(GECSDATA(2100.1,GECSDATA,.01,"E"))[("AR-") S PRCFA("TT")="AR"
EDIT ;
I $G(PRCFA("ACCEDIT"))=1 D TAG33^PRCFFU9 ; sets PRCFA("PPT") & PRCFA("MOMREQ")
I $G(PRCFA("RETRAN"))=1 D TAG33^PRCFFU9 ; sets PRCFA("PPT") & PRCFA("MOMREQ")
;
; Compare adjustment to original 1358
N RETURN,ERFLAG,IDFLAG,TYPE
S RETURN=$$COMP^PRCFFU6(PRC442,PRC410,.RETURN)
S ERFLAG=$P(RETURN,U,1)
S IDFLAG=$P(RETURN,U,2)
S TYPE=$P(RETURN,U,2)
I ERFLAG D Q
. W !!," Cannot continue...one or more of the following fields have changed..."
. N LOOP S LOOP=""
. F S LOOP=$O(PRCFA("CHG",LOOP)) Q:LOOP="" I PRCFA("CHG",LOOP)]"" W !,?5,PRCFA("CHG",LOOP)
. K PRCFA("CHG")
. W !!," Please be sure that the VENDOR, FUND CONTROL POINT, BOC, and COST CENTER",!," fields are the same as the original 1358 obligation!"
. D MSG
. D EN^DDIOL(" ** Press RETURN to continue **")
. R X:DTIME
. D OUT
. Q
;
DT I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G DT1
. D RETRANM^PRCESOE2 ; get account & obligation processing dates
. S Y=PRCFA("OBLDATE")
S Y=PRC("RBDT") I Y<DT!'Y D NOW^%DTC S Y=X
DT1 D D^PRCFQ ; convert date to external format
S %DT="AEX"
S %DT("A")="Select Obligation Processing Date: "
S %DT("B")=Y
W ! D ^%DT
K %DT
I Y<0 D MSG,OUT H 3 Q
S PRCFA("OBLDATE")=Y
S EXIT=0
D ENM^PRCESOE2
I EXIT D H 3 Q
. D MSG
. D OUT
. D KILL^PRCESOE2
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 DT
D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
;
D I "^SO^AR^"'[("^"_$P(PRCFA("TT"),":",1)) D MSG S Y=1 G OUT
. 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("TT")="AR" D I "EM"'[X D MSG S Y=1 G OUT
. N Y
. D SC^PRC0A("",.Y,"Label document action as: ","AOM^E:Original Entry;M:Modification Entry","M")
. I $E(Y)="E" S PRCFA("MOD")="E^0^Original Entry"
. I $E(Y)="M" S PRCFA("MOD")="M^1^Modification Entry"
. S X=$E(Y)
. K Y
S X=0
I $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 S Y=1 G OUT
. S PRCFA("SIS")=$$GETTXNS^PRCFFERT(PO,PRC410,21) ; get other FMS txns for this adjustment
. S X=$$NEWCHK^PRCFFERT(PRCFA("TT"),$E(PRCFA("MOD")),PRCFA("SIS")) ; if selected txn exists, X will be DOCID
. I X=0 S PRCFA("RETRAN")=2 ; selected txn doesn't exist, create
. I X'=0 S X=$$SWITCH^PRCFFERT(X,21,.GECSDATA) ; is selected txn available?
;
GO ; Prompt use for final go-ahead for the document creation
D GO^PRCFFU
I 'Y!($D(DIRUT)) D MSG,OUT Q
;
ESIG ; Enter the Electronic Signature and away it goes!
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 D MSG,OUT Q
;
; Check fund/year dictionary for FMS required fields
D EDIT^PRCFFU ; sets up PRCFMO array for req'd fields
;
D EDIT410^PRCFFUD(OB,"O") ; edit running balance qtr & status in 410
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D SET1358^PRCFFERT ; do rebuild
;
STACK ; Create entry in GECS Stack File
D STACK^PRCFFU(1) ; CTL,BAT,DOC segments, (1) creates batch# for FMS doc
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 G SEGS
;
UPDATE ; Update records in 442 and 410
W !!,"...updating obligation balances....please hold...",!!
D POADJ^PRCH58OB(.PO,PODA,.TRNODE,AMT)
D POADJ^PRCS58OB(.PRC,PODA,TRDA,AMT)
D:AMT>0 BULC^PRCH58(PODA)
D UPDATE^PRCFFU6(PRC442,PRC410) ; update node 22 of file 442
;
SEGS ; Use TMP($J to store remaining segments to be built
K ^TMP($J,"PRCMO")
N FMSINT S FMSINT=+PO
S FMSMOD=$P(PRCFA("MOD"),U,1)
D NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD) ; build segments
;
; Transfer nodes from TMP($J, into GECS Stack File
N LOOP S LOOP=0
F S LOOP=$O(^TMP($J,"PRCMO",GECSFMS("DA"),LOOP)) Q:'LOOP D SETCS^GECSSTAA(GECSFMS("DA"),^(LOOP))
K ^TMP($J,"PRCMO")
;
TRANS ; Mark the document as queued for transmission
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
N P2 S P2=+PO
S $P(P2,"/",4)=+TRDA
S $P(P2,"/",5)=$P(PRCFA("ACCPD"),U)
S $P(P2,"/",6)=PRCFA("OBLDATE")
D SETPARAM^GECSSDCT(GECSFMS("DA"),P2) ; save P2 as node 26 of 2100.1
;
POBAL ; Enter Obligation Data into Purchase Order Record
; Log transaction into node 10 of file 442
D EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PODATE,PRCFA("PATNUM"))
;
; Continue processing if this is not a rebuild
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 G OUT
Z S (X,Z)=$P(PO(0),U)
S %=1,PRCE424=1 D EN1^PRCSUT3 K PRCE424 ;PRC*5.1*180
I $D(MSG),MSG'="" W !!,MSG K MSG Q ;PRC*5.1*180
S DLAYGO=424
S DIC="^PRC(424,"
S DIC(0)="L"
D FILE^DICN
I Y<0 W !,"ERROR IN CREATING 424 RECORD",$C(7),!! Q
;
S DIE="^PRC(424,"
S DA(1358)=+Y
D NOW^%DTC
S TI=%
S DA=DA(1358)
S DR=".02///^S X=PODA;.03///^S X=""A"";.06///^S X=$P(TRNODE(4),U,8);.07///^S X=TI;.08////^S X=DUZ;1.1////^S X=""ADJUSTMENT OBLIGATION"";.15////^S X=TRDA"
D ^DIE W "...adjustment completed..."
;
;Generate 1358 transaction message to OLCS. Messages will be generated
;upon obligation of a new 1358 or an adjustment. Messages will not be
;sent for a rebuild or retransmission to FMS. (PRC*5.1*153)
I $G(PRCFA("RETRAN"))=0 D OLCSMSG^PRCFDO
;
G OUT
Q
;
SCREEN ;COMPARISON SCREEN
N CEILING,LAUTH,TAUTH,TBAL,LBAL,IOINHI,IOINLOW,IOINORM
D HILO^PRCFQ
S CEILING=$P(PO(8),U)
W @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$P(TRNODE(0),"^")
W IOINLOW," 1358 # ",IOINHI,$P(PO(0),"^")
W !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$FN(CEILING,"P,",2)
S TBAL=$P(PO(8),U,3)
S TAUTH=CEILING-TBAL
W !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$J($FN(TAUTH,"P,",2),12)
S LBAL=$P(PO(8),U,2),LAUTH=CEILING-LBAL
W ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$J($FN(LAUTH,",P",2),12)
W !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$J($FN(TBAL,"P,",2),12)
W ?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$J($FN(LBAL,"P,",2),12),!!
W IOINLOW,"Amount of Adjustment: ",IOINHI,$J($P(TRNODE(4),"^",8),0,2),!!,IOINORM
Q
MSG W !
S X="No further processing is being taken on this 1358 adjustment obligation. It has NOT been obligated.*"
D MSG^PRCFQ
Q
OUT K DIRUT,DTOUT,DUOUT,DIROUT
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCESOM 8643 printed Dec 13, 2024@02:01:36 Page 2
PRCESOM ;WISC/SJG/ASU - CONTINUATION OF 1358 ADJUST OBLIAGTION PRCEADJ1 ;4/27/94 2:13 PM
V ;;5.1;IFCAP;**148,153,180**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*180 RGB 10/22/12 Added switch PRCE424 coming from 1358 processing
+4 ;to insure new entry check (EN1^PRCSUT3) uses file 424, not file 410.
+5 ;
+6 NEW TI,PRCFASYS,IOINLOW,IOINHI,IOINORM,DIR,AMT,OLDTT,CS,HASH,DIE,DR,LAUTH,LBAL,TAUTH,TBAL,DLAYGO
+7 DO SCREEN
+8 SET PRC("CP")=$PIECE(TRNODE(0),"-",4)
+9 SET PRC("RBDT")=$PIECE(TRNODE(0),U,11)
+10 IF $GET(PRCRGS)<1
DO OVCOM1^PRCFFU10
IF PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2)
DO REQFAIL^PRCFFU10
DO MSG
GOTO OUT
+11 ; PRC*5.1*148 start
+12 ; if Obligator is a requestor, violation to segregation of duties
+13 IF $PIECE($GET(TRNODE(7)),"^",1)=DUZ
Begin DoDot:1
+14 WRITE !!,"You are the CP Clerk (Requestor) on this 1358 transaction."
+15 WRITE !,"Per Segregation of Duties, the CP Clerk (Requestor)"
+16 WRITE " is not permitted to "
+17 WRITE $SELECT($GET(PRCFA("RETRAN")):"Rebuild/Retransmit",1:"Obligate")," the 1358."
+18 IF '$GET(PRCFA("RETRAN"))
QUIT
+19 WRITE !
DO EN^DDIOL(" ** Press RETURN to continue **")
+20 READ X:DTIME
QUIT
End DoDot:1
SET Y=0
DO MSG
GOTO OUT
+21 ; if Obligator is a approver, violation to segregation of duties
+22 IF $PIECE($GET(TRNODE(7)),"^",3)=DUZ
Begin DoDot:1
+23 WRITE !!,"You are the Approver on this 1358 transaction."
+24 WRITE !,"Per Segregation of Duties, the Approver is not permitted to "
+25 WRITE $SELECT($GET(PRCFA("RETRAN")):"Rebuild/Retransmit",1:"Obligate")," the 1358."
+26 IF '$GET(PRCFA("RETRAN"))
QUIT
+27 WRITE !
DO EN^DDIOL(" ** Press RETURN to continue **")
+28 READ X:DTIME
QUIT
End DoDot:1
SET Y=0
DO MSG
GOTO OUT
+29 ; PRC*5.1*148 end
+30 ;
+31 ; ask 'OK to continue?'
DO OKAY2^PRCFFU
+32 IF 'Y!($DATA(DIRUT))
DO MSG
GOTO OUT
+33 SET AMT=$PIECE(TRNODE(4),U,8)
K FOR I=7,9
SET AMT(I)=$PIECE(TRNODE(3),"^",I)
if AMT(I)<0
SET AMT(I)=-AMT(I)
SET AMT(I)=AMT(I)*100
+1 SET PRC("CP")=$PIECE(TRNODE(0),"-",4)
+2 SET PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
+3 SET PRCFA("MOD")="M^1^Modification Entry"
+4 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
IF $PIECE(PRCFA("GECS"),"^",2)="E"
SET PRCFA("MOD")="E^0^Original Document"
+5 SET PRCFA("MP")=$PIECE(PO(0),U,2)
+6 SET PRCFA("PATNUM")=$PIECE($PIECE(PO(0),U),"-",2)
+7 SET PRCFA("PODA")=PODA
+8 SET PRCFA("REF")=$PIECE(PO(0),U)
+9 ; S PRCFA("SFC")=$P(PO(0),U,19)
+10 SET PRCFA("SYS")="FMS"
+11 SET PRCFA("TT")="SO"
+12 IF $DATA(GECSDATA)
IF $GET(GECSDATA(2100.1,GECSDATA,.01,"E"))[("AR-")
SET PRCFA("TT")="AR"
EDIT ;
+1 ; sets PRCFA("PPT") & PRCFA("MOMREQ")
IF $GET(PRCFA("ACCEDIT"))=1
DO TAG33^PRCFFU9
+2 ; sets PRCFA("PPT") & PRCFA("MOMREQ")
IF $GET(PRCFA("RETRAN"))=1
DO TAG33^PRCFFU9
+3 ;
+4 ; Compare adjustment to original 1358
+5 NEW RETURN,ERFLAG,IDFLAG,TYPE
+6 SET RETURN=$$COMP^PRCFFU6(PRC442,PRC410,.RETURN)
+7 SET ERFLAG=$PIECE(RETURN,U,1)
+8 SET IDFLAG=$PIECE(RETURN,U,2)
+9 SET TYPE=$PIECE(RETURN,U,2)
+10 IF ERFLAG
Begin DoDot:1
+11 WRITE !!," Cannot continue...one or more of the following fields have changed..."
+12 NEW LOOP
SET LOOP=""
+13 FOR
SET LOOP=$ORDER(PRCFA("CHG",LOOP))
if LOOP=""
QUIT
IF PRCFA("CHG",LOOP)]""
WRITE !,?5,PRCFA("CHG",LOOP)
+14 KILL PRCFA("CHG")
+15 WRITE !!," Please be sure that the VENDOR, FUND CONTROL POINT, BOC, and COST CENTER",!," fields are the same as the original 1358 obligation!"
+16 DO MSG
+17 DO EN^DDIOL(" ** Press RETURN to continue **")
+18 READ X:DTIME
+19 DO OUT
+20 QUIT
End DoDot:1
QUIT
+21 ;
DT IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
Begin DoDot:1
+1 ; get account & obligation processing dates
DO RETRANM^PRCESOE2
+2 SET Y=PRCFA("OBLDATE")
End DoDot:1
GOTO DT1
+3 SET Y=PRC("RBDT")
IF Y<DT!'Y
DO NOW^%DTC
SET Y=X
DT1 ; convert date to external format
DO D^PRCFQ
+1 SET %DT="AEX"
+2 SET %DT("A")="Select Obligation Processing Date: "
+3 SET %DT("B")=Y
+4 WRITE !
DO ^%DT
+5 KILL %DT
+6 IF Y<0
DO MSG
DO OUT
HANG 3
QUIT
+7 SET PRCFA("OBLDATE")=Y
+8 SET EXIT=0
+9 DO ENM^PRCESOE2
+10 IF EXIT
Begin DoDot:1
+11 DO MSG
+12 DO OUT
+13 DO KILL^PRCESOE2
End DoDot:1
HANG 3
QUIT
+14 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 DT
+15 DO GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
+16 ;
+17 Begin DoDot:1
+18 NEW PRCFATT
SET PRCFATT=PRCFA("TT")
+19 ; ask SO or AR, if appropriate
DO SOAR^PRC0E(PRCFA("PODA"),.PRCFATT,1)
+20 SET PRCFA("TT")=PRCFATT
KILL PRCFATT
End DoDot:1
IF "^SO^AR^"'[("^"_$PIECE(PRCFA("TT"),":",1))
DO MSG
SET Y=1
GOTO OUT
+21 ;
+22 IF PRCFA("TT")="AR"
Begin DoDot:1
+23 NEW Y
+24 DO SC^PRC0A("",.Y,"Label document action as: ","AOM^E:Original Entry;M:Modification Entry","M")
+25 IF $EXTRACT(Y)="E"
SET PRCFA("MOD")="E^0^Original Entry"
+26 IF $EXTRACT(Y)="M"
SET PRCFA("MOD")="M^1^Modification Entry"
+27 SET X=$EXTRACT(Y)
+28 KILL Y
End DoDot:1
IF "EM"'[X
DO MSG
SET Y=1
GOTO OUT
+29 SET X=0
+30 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
+31 ; get other FMS txns for this adjustment
SET PRCFA("SIS")=$$GETTXNS^PRCFFERT(PO,PRC410,21)
+32 ; if selected txn exists, X will be DOCID
SET X=$$NEWCHK^PRCFFERT(PRCFA("TT"),$EXTRACT(PRCFA("MOD")),PRCFA("SIS"))
+33 ; selected txn doesn't exist, create
IF X=0
SET PRCFA("RETRAN")=2
+34 ; is selected txn available?
IF X'=0
SET X=$$SWITCH^PRCFFERT(X,21,.GECSDATA)
End DoDot:1
IF X="^"
DO MSG
DO PAUSE^PRCFFERU
SET Y=1
GOTO OUT
+35 ;
GO ; Prompt use for final go-ahead for the document creation
+1 DO GO^PRCFFU
+2 IF 'Y!($DATA(DIRUT))
DO MSG
DO OUT
QUIT
+3 ;
ESIG ; Enter the Electronic Signature and away it goes!
+1 WRITE !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
+2 DO SIG^PRCFFU4
+3 IF $DATA(PRCFA("SIGFAIL"))
KILL PRCFA("SIGFAIL")
HANG 3
DO MSG
DO OUT
QUIT
+4 ;
+5 ; Check fund/year dictionary for FMS required fields
+6 ; sets up PRCFMO array for req'd fields
DO EDIT^PRCFFU
+7 ;
+8 ; edit running balance qtr & status in 410
DO EDIT410^PRCFFUD(OB,"O")
+9 ; do rebuild
IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
DO SET1358^PRCFFERT
+10 ;
STACK ; Create entry in GECS Stack File
+1 ; CTL,BAT,DOC segments, (1) creates batch# for FMS doc
DO STACK^PRCFFU(1)
+2 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")>0
GOTO SEGS
+3 ;
UPDATE ; Update records in 442 and 410
+1 WRITE !!,"...updating obligation balances....please hold...",!!
+2 DO POADJ^PRCH58OB(.PO,PODA,.TRNODE,AMT)
+3 DO POADJ^PRCS58OB(.PRC,PODA,TRDA,AMT)
+4 if AMT>0
DO BULC^PRCH58(PODA)
+5 ; update node 22 of file 442
DO UPDATE^PRCFFU6(PRC442,PRC410)
+6 ;
SEGS ; Use TMP($J to store remaining segments to be built
+1 KILL ^TMP($JOB,"PRCMO")
+2 NEW FMSINT
SET FMSINT=+PO
+3 SET FMSMOD=$PIECE(PRCFA("MOD"),U,1)
+4 ; build segments
DO NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD)
+5 ;
+6 ; Transfer nodes from TMP($J, into GECS Stack File
+7 NEW LOOP
SET LOOP=0
+8 FOR
SET LOOP=$ORDER(^TMP($JOB,"PRCMO",GECSFMS("DA"),LOOP))
if 'LOOP
QUIT
DO SETCS^GECSSTAA(GECSFMS("DA"),^(LOOP))
+9 KILL ^TMP($JOB,"PRCMO")
+10 ;
TRANS ; Mark the document as queued for transmission
+1 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+2 NEW P2
SET P2=+PO
+3 SET $PIECE(P2,"/",4)=+TRDA
+4 SET $PIECE(P2,"/",5)=$PIECE(PRCFA("ACCPD"),U)
+5 SET $PIECE(P2,"/",6)=PRCFA("OBLDATE")
+6 ; save P2 as node 26 of 2100.1
DO SETPARAM^GECSSDCT(GECSFMS("DA"),P2)
+7 ;
POBAL ; Enter Obligation Data into Purchase Order Record
+1 ; Log transaction into node 10 of file 442
+2 DO EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PODATE,PRCFA("PATNUM"))
+3 ;
+4 ; Continue processing if this is not a rebuild
+5 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")>0
GOTO OUT
Z SET (X,Z)=$PIECE(PO(0),U)
+1 ;PRC*5.1*180
SET %=1
SET PRCE424=1
DO EN1^PRCSUT3
KILL PRCE424
+2 ;PRC*5.1*180
IF $DATA(MSG)
IF MSG'=""
WRITE !!,MSG
KILL MSG
QUIT
+3 SET DLAYGO=424
+4 SET DIC="^PRC(424,"
+5 SET DIC(0)="L"
+6 DO FILE^DICN
+7 IF Y<0
WRITE !,"ERROR IN CREATING 424 RECORD",$CHAR(7),!!
QUIT
+8 ;
+9 SET DIE="^PRC(424,"
+10 SET DA(1358)=+Y
+11 DO NOW^%DTC
+12 SET TI=%
+13 SET DA=DA(1358)
+14 SET DR=".02///^S X=PODA;.03///^S X=""A"";.06///^S X=$P(TRNODE(4),U,8);.07///^S X=TI;.08////^S X=DUZ;1.1////^S X=""ADJUSTMENT OBLIGATION"";.15////^S X=TRDA"
+15 DO ^DIE
WRITE "...adjustment completed..."
+16 ;
+17 ;Generate 1358 transaction message to OLCS. Messages will be generated
+18 ;upon obligation of a new 1358 or an adjustment. Messages will not be
+19 ;sent for a rebuild or retransmission to FMS. (PRC*5.1*153)
+20 IF $GET(PRCFA("RETRAN"))=0
DO OLCSMSG^PRCFDO
+21 ;
+22 GOTO OUT
+23 QUIT
+24 ;
SCREEN ;COMPARISON SCREEN
+1 NEW CEILING,LAUTH,TAUTH,TBAL,LBAL,IOINHI,IOINLOW,IOINORM
+2 DO HILO^PRCFQ
+3 SET CEILING=$PIECE(PO(8),U)
+4 WRITE @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$PIECE(TRNODE(0),"^")
+5 WRITE IOINLOW," 1358 # ",IOINHI,$PIECE(PO(0),"^")
+6 WRITE !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$FNUMBER(CEILING,"P,",2)
+7 SET TBAL=$PIECE(PO(8),U,3)
+8 SET TAUTH=CEILING-TBAL
+9 WRITE !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$JUSTIFY($FNUMBER(TAUTH,"P,",2),12)
+10 SET LBAL=$PIECE(PO(8),U,2)
SET LAUTH=CEILING-LBAL
+11 WRITE ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$JUSTIFY($FNUMBER(LAUTH,",P",2),12)
+12 WRITE !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$JUSTIFY($FNUMBER(TBAL,"P,",2),12)
+13 WRITE ?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$JUSTIFY($FNUMBER(LBAL,"P,",2),12),!!
+14 WRITE IOINLOW,"Amount of Adjustment: ",IOINHI,$JUSTIFY($PIECE(TRNODE(4),"^",8),0,2),!!,IOINORM
+15 QUIT
MSG WRITE !
+1 SET X="No further processing is being taken on this 1358 adjustment obligation. It has NOT been obligated.*"
+2 DO MSG^PRCFQ
+3 QUIT
OUT KILL DIRUT,DTOUT,DUOUT,DIROUT
+1 QUIT
