PRCESOE ;WISC/CLH/CTB/SJG/ASU - 1358 OBLIGATION ; 08/22/94 5:11 PM
V ;;5.1;IFCAP;**148,153,161,176**;Oct 20, 2000;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
K PRC,PRCF,Y
N PRCFSC,PRCREVSW S PRCFSC=1 ;PRC*5.1*148 ENTERED FROM 1358 OBLIGATE
D OUT
S PRCF("X")="AB"
D ^PRCFSITE Q:'%
D LOOKUP G:Y<0 OUT
D K1A^PRCFFUZ
S (OB,DA)=+Y ; ien for file 410
S PRCFA("RETRAN")=0
SC ; Entry point for rebuild/retransmit
D NODE^PRCS58OB(DA,.TRNODE) ; set file 410 values into TRNODE array
S PRCFA("TRDA")=OB
D SCREEN^PRCEOB1 W !
D VENCONO^PRCFFU15(OB) ; display vendor & contract info, if exists
; PRC*5.1*148 start
; if Obligator is a requestor, violation to segregation of duties
I $P($G(TRNODE(7)),"^",1)=DUZ D 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(PRCFSC):"Obligate",1:"Rebuild/Retransmit")," the 1358."
. I $G(PRCFSC) 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 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(PRCFSC):"Obligate",1:"Rebuild/Retransmit")," the 1358."
. I $G(PRCFSC) Q
. W ! D EN^DDIOL(" ** Press RETURN to continue **")
. R X:DTIME Q
; PRC*5.1*148 end
;PRC*5.1*161 adds logic that will allow the user to display the 1358 for
; compliance review prior to obligating
REV S PRC("CP")=$P(TRNODE(3),U,3),PRCREVSW=0
W !!,"Would you like to review this request?"
S %=2 D YN^DICN G REV:%=0 I %=1 D
. S HLDZ=Z,HLDN=N,(N,PRCSZ)=DA,PRCSF=1,PRCREVSW=1 D PRF1^PRCSP1
. S DA=PRCSZ,Z=HLDZ,N=HLDN
. K HLDZ,HLDN,X,PRCSF,PRCSZ,PRC("CP"),RECORD,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4
. K %H,%I,DIW,DIWI,DIWT,DIWTC,DIWX,IOHG,IOPAR,IOUPAR,POP,N,Z
I PRCREVSW=1 W !!,"Would you like continue obligating this 1358?" S %=1 D YN^DICN G OUT:%'=1
S FLDCHK=0
D EN^PRCFFU14(OB) ; edit auto accrual info
I ACCEDIT=1 G SC
I FLDCHK=1 D OUT G V
OKAY S PRCFA("IDES")="1358 Obligation"
D OKAY^PRCFFU ; ask 'Is info correct?'
I $D(DIRUT) D MSG H 3 G OUT
S ESIGCHK=1
S FISCEDIT=0
I 'Y D 1358^PRCFFU13 ; edit cost center or boc?
I 'ESIGCHK D MSG H 3 G OUT
I FISCEDIT G SC
S PRC("RBDT")=$P(TRNODE(0),U,11)
S PCP=$P(TRNODE(0),"-",4)
S PQT=$P(TRNODE(0),"-",3)
D CPBAL^PRCFFMO1 ; display control point balance
K PQT,PRCF("NOBAL")
K PRCTMP
I '$P(TRNODE(0),U,11) D
. D ERS410^PRC0G(DA)
. S TRNODE(0)=^PRCS(410,DA,0)
S PRC("FY")=$P(TRNODE(0),"-",2)
S PRC("QTR")=$P(TRNODE(0),"-",3)
S PRC("CP")=$P(TRNODE(0),"-",4)
I $G(PRCRGS)<1 D OVCOM1^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D REQFAIL^PRCFFU10,MSG H 3 G OUT
W ! D OKAY2^PRCFFU ; ask 'OK to continue?'
I 'Y!($D(DTOUT)) D MSG H 3 G OUT
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D G:'$D(DA) OUT
. K DA,X
. S PRCHP("T")=21
. S PRCHP("S")=4
. S PRCHP("A")="1358 Obligation Number"
. S PRCFA(1358)=""
. D EN^PRCHPAT ; ask for obligation #, set up 442 record
. K PRCFA(1358),PRCHP
. I '$D(DA) D MSG3
. Q
VAR I $D(PRCFA("RETRAN")),PRCFA("RETRAN") S DA=POIEN ; 442 ien
D PAT^PRCH58OB(DA,.PODA,.PO,.PATNUM) ; set up parameterized variables
N PRCFDEL,AMT,CS,DA,DIK,TIME,MOD
S PRCFA("BBFY")=$TR($P(TRNODE(3),"^",11)," ")
S PRCFA("MOD")="E^0^Original Entry"
S PRCFA("MP")=$P(PO(0),U,2)
S PRCFA("PATNUM")=$P($P(PO(0),"^"),"-",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"
VAR11 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G VAR2
. D RETRANO^PRCESOE2 ; put date in FMS transaction into PRCFA("OBLDATE")
. S X=PRCFA("OBLDATE")
S X=PRC("RBDT")
I X<DT!'X D NOW^%DTC
VAR2 S Y=X D D^PRCFQ ; convert date to external format
S %DT="AEX"
S %DT("B")=Y
S %DT("A")="Select Obligation Processing Date: "
W ! D ^%DT K %DT
I Y<0 D EXIT G OUT
S PRCFA("OBLDATE")=Y
S EXIT=0
D ENO^PRCESOE2 ; processes PRCFA("OBLDATE"), gets accounting period
I EXIT=1 D EXIT,KILL^PRCESOE2 G OUT
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 S X=PRC("RBDT") G VAR11
;
GO ; Prompt user for final go-ahead for the document creation
D GO^PRCFFU ; ask 'Transmit?'
I 'Y!($D(DIRUT)) G EXIT
;
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")) D G EXIT
. K PRCFA("SIGFAIL")
. D MSG2(ESIGMSG)
. Q
;
D OB1^PRCS58OB(PRCFA("TRDA"),PODA) ; save 442 ien in file 410
D COB^PRCH58OB(PODA,.TRNODE,.PO,PRCFA("TRDA"),X) ; stuff some values into 442
D PODT^PRCS58OB(PRCFA("PODA"),PRCFA("OBLDATE")) ; save PRCFA("OBLDATE") in file 442 as PO DATE
S PRCFA("BBFY")=$$BBFY^PRCFFU5(PRCFA("PODA"))
D GENDIQ^PRCFFU7(442,PRCFA("PODA"),".1;.07;.03;17","IEN","")
D EDIT410^PRCFFUD(PRCFA("TRDA"),"O") ; updates running balance quarter & status in 410
S PRC("CP")=+$P(PO(0),"^",3)
;
EDIT ; Check fund/year dictionary for required FMS fields
D EDIT^PRCFFU ; sets up PRCFMO array to use in building LIN segment
;
S IDFLAG="I" ; flag to FMS indicating a dollar increase
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D SET1358^PRCFFERT ; do rebuild
;
STACK ; Create entry in GECS Stack File
D STACK^PRCFFU(0) ; set up CTL,DOC segs of code sheet, (0) means no batch#
;
SEGS ; Create entry in TMP($J, for remaining segments
K ^TMP($J,"PRCMO")
N FMSINT S FMSINT=+PO
S FMSMOD=$P(PRCFA("MOD"),U,1)
D NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD) ; builds remaining segs
;
; Transfers remaining segs 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 FMS transaction document as queued for transmission
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
N P2 S P2=+PO
S $P(P2,"/",3)=+OB
S $P(P2,"/",5)=$P(PRCFA("ACCPD"),U)
S $P(P2,"/",6)=PRCFA("OBLDATE")
D SETPARAM^GECSSDCT(GECSFMS("DA"),P2)
;
POBAL ; Enter Obligation Data into Purchase Order Record
;
; add FMS document info to node 10 of file 442
D EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PRCFA("OBLDATE"),PRCFA("PATNUM"))
;
; create daily record in file 424
D POST G OUT:'%
;
; continue processing if this is not a rebuild
I $D(PRCFA("RETRAN")),PRCFA("RETRAN") D OUT Q
S X=100
S DA=PRCFA("PODA")
D ENF^PRCHSTAT
S AMT=$P(PO(0),U,7)+$S(+$P(PO(0),U,9)'=0:$P(PO(0),U,9),1:"")
D NOW^PRCFQ
S TIME=X
S X=$P(TRNODE(4),"^",8) ; file 410 transaction amount
S DA=PRCFA("TRDA") ; file 410 ien
D TRANK^PRCSES
S DEL=$S('$D(DEL):"",1:DEL)
D CS^PRCS58OB(OB,AMT,TIME,PATNUM,PODA,DEL,X,.PRC)
W !!,"...updating 1358 Obligation balances...",!
S ^PRC(442,PODA,8)=AMT_"^0^0"
S X=AMT D TRANS1^PRCSES
S X=AMT D W !! G V
. D TRANS^PRCSES
. D BULLET^PRCEFIS1
. ;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 $D(PRCFA("RETRAN")),'PRCFA("RETRAN") D OLCSMSG^PRCFDO
. D OUT
;
OUT I $G(PRCFA("TRDA")) L -^PRCS(410,PRCFA("TRDA")) ;Unlock when exiting option, PRC*5.1*176
D K1B^PRCFFUZ
D K1C^PRCFFUZ
Q
;
EXIT I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D MSG1,KILL^PRCH58OB(PODA)
E D MSG
Q
;
KILL D KILL^PRCH58OB(PODA) G OUT
;
LOOKUP ; Lookup 1358 transaction which is pending fiscal action.
D LOOKUP^PRCESOE1
Q
;
POST ; Post data in file 424
I $D(PRCFA("RETRAN")),'PRCFA("RETRAN") D POST^PRCESOE1
Q
;
; Message processing
MSG D MSG^PRCESOE1 Q
MSG1 D MSG1^PRCESOE1 Q
MSG2(MSG) D MSG2^PRCESOE1(MSG) Q
MSG3 D MSG3^PRCESOE1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCESOE 8064 printed Dec 13, 2024@02:01:34 Page 2
PRCESOE ;WISC/CLH/CTB/SJG/ASU - 1358 OBLIGATION ; 08/22/94 5:11 PM
V ;;5.1;IFCAP;**148,153,161,176**;Oct 20, 2000;Build 11
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 KILL PRC,PRCF,Y
+3 ;PRC*5.1*148 ENTERED FROM 1358 OBLIGATE
NEW PRCFSC,PRCREVSW
SET PRCFSC=1
+4 DO OUT
+5 SET PRCF("X")="AB"
+6 DO ^PRCFSITE
if '%
QUIT
+7 DO LOOKUP
if Y<0
GOTO OUT
+8 DO K1A^PRCFFUZ
+9 ; ien for file 410
SET (OB,DA)=+Y
+10 SET PRCFA("RETRAN")=0
SC ; Entry point for rebuild/retransmit
+1 ; set file 410 values into TRNODE array
DO NODE^PRCS58OB(DA,.TRNODE)
+2 SET PRCFA("TRDA")=OB
+3 DO SCREEN^PRCEOB1
WRITE !
+4 ; display vendor & contract info, if exists
DO VENCONO^PRCFFU15(OB)
+5 ; PRC*5.1*148 start
+6 ; if Obligator is a requestor, violation to segregation of duties
+7 IF $PIECE($GET(TRNODE(7)),"^",1)=DUZ
Begin DoDot:1
+8 WRITE !!,"You are the CP Clerk (Requestor) on this 1358 transaction."
+9 WRITE !,"Per Segregation of Duties, the CP Clerk (Requestor)"
+10 WRITE " is not permitted to "
+11 WRITE $SELECT($GET(PRCFSC):"Obligate",1:"Rebuild/Retransmit")," the 1358."
+12 IF $GET(PRCFSC)
QUIT
+13 WRITE !
DO EN^DDIOL(" ** Press RETURN to continue **")
+14 READ X:DTIME
QUIT
End DoDot:1
GOTO OUT
+15 ; if Obligator is a approver, violation to segregation of duties
+16 IF $PIECE($GET(TRNODE(7)),"^",3)=DUZ
Begin DoDot:1
+17 WRITE !!,"You are the Approver on this 1358 transaction."
+18 WRITE !,"Per Segregation of Duties, the Approver is not permitted to "
+19 WRITE $SELECT($GET(PRCFSC):"Obligate",1:"Rebuild/Retransmit")," the 1358."
+20 IF $GET(PRCFSC)
QUIT
+21 WRITE !
DO EN^DDIOL(" ** Press RETURN to continue **")
+22 READ X:DTIME
QUIT
End DoDot:1
GOTO OUT
+23 ; PRC*5.1*148 end
+24 ;PRC*5.1*161 adds logic that will allow the user to display the 1358 for
+25 ; compliance review prior to obligating
REV SET PRC("CP")=$PIECE(TRNODE(3),U,3)
SET PRCREVSW=0
+1 WRITE !!,"Would you like to review this request?"
+2 SET %=2
DO YN^DICN
if %=0
GOTO REV
IF %=1
Begin DoDot:1
+3 SET HLDZ=Z
SET HLDN=N
SET (N,PRCSZ)=DA
SET PRCSF=1
SET PRCREVSW=1
DO PRF1^PRCSP1
+4 SET DA=PRCSZ
SET Z=HLDZ
SET N=HLDN
+5 KILL HLDZ,HLDN,X,PRCSF,PRCSZ,PRC("CP"),RECORD,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4
+6 KILL %H,%I,DIW,DIWI,DIWT,DIWTC,DIWX,IOHG,IOPAR,IOUPAR,POP,N,Z
End DoDot:1
+7 IF PRCREVSW=1
WRITE !!,"Would you like continue obligating this 1358?"
SET %=1
DO YN^DICN
if %'=1
GOTO OUT
+8 SET FLDCHK=0
+9 ; edit auto accrual info
DO EN^PRCFFU14(OB)
+10 IF ACCEDIT=1
GOTO SC
+11 IF FLDCHK=1
DO OUT
GOTO V
OKAY SET PRCFA("IDES")="1358 Obligation"
+1 ; ask 'Is info correct?'
DO OKAY^PRCFFU
+2 IF $DATA(DIRUT)
DO MSG
HANG 3
GOTO OUT
+3 SET ESIGCHK=1
+4 SET FISCEDIT=0
+5 ; edit cost center or boc?
IF 'Y
DO 1358^PRCFFU13
+6 IF 'ESIGCHK
DO MSG
HANG 3
GOTO OUT
+7 IF FISCEDIT
GOTO SC
+8 SET PRC("RBDT")=$PIECE(TRNODE(0),U,11)
+9 SET PCP=$PIECE(TRNODE(0),"-",4)
+10 SET PQT=$PIECE(TRNODE(0),"-",3)
+11 ; display control point balance
DO CPBAL^PRCFFMO1
+12 KILL PQT,PRCF("NOBAL")
+13 KILL PRCTMP
+14 IF '$PIECE(TRNODE(0),U,11)
Begin DoDot:1
+15 DO ERS410^PRC0G(DA)
+16 SET TRNODE(0)=^PRCS(410,DA,0)
End DoDot:1
+17 SET PRC("FY")=$PIECE(TRNODE(0),"-",2)
+18 SET PRC("QTR")=$PIECE(TRNODE(0),"-",3)
+19 SET PRC("CP")=$PIECE(TRNODE(0),"-",4)
+20 IF $GET(PRCRGS)<1
DO OVCOM1^PRCFFU10
IF PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2)
DO REQFAIL^PRCFFU10
DO MSG
HANG 3
GOTO OUT
+21 ; ask 'OK to continue?'
WRITE !
DO OKAY2^PRCFFU
+22 IF 'Y!($DATA(DTOUT))
DO MSG
HANG 3
GOTO OUT
+23 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=0
Begin DoDot:1
+24 KILL DA,X
+25 SET PRCHP("T")=21
+26 SET PRCHP("S")=4
+27 SET PRCHP("A")="1358 Obligation Number"
+28 SET PRCFA(1358)=""
+29 ; ask for obligation #, set up 442 record
DO EN^PRCHPAT
+30 KILL PRCFA(1358),PRCHP
+31 IF '$DATA(DA)
DO MSG3
+32 QUIT
End DoDot:1
if '$DATA(DA)
GOTO OUT
VAR ; 442 ien
IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")
SET DA=POIEN
+1 ; set up parameterized variables
DO PAT^PRCH58OB(DA,.PODA,.PO,.PATNUM)
+2 NEW PRCFDEL,AMT,CS,DA,DIK,TIME,MOD
+3 SET PRCFA("BBFY")=$TRANSLATE($PIECE(TRNODE(3),"^",11)," ")
+4 SET PRCFA("MOD")="E^0^Original Entry"
+5 SET PRCFA("MP")=$PIECE(PO(0),U,2)
+6 SET PRCFA("PATNUM")=$PIECE($PIECE(PO(0),"^"),"-",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"
VAR11 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
Begin DoDot:1
+1 ; put date in FMS transaction into PRCFA("OBLDATE")
DO RETRANO^PRCESOE2
+2 SET X=PRCFA("OBLDATE")
End DoDot:1
GOTO VAR2
+3 SET X=PRC("RBDT")
+4 IF X<DT!'X
DO NOW^%DTC
VAR2 ; convert date to external format
SET Y=X
DO D^PRCFQ
+1 SET %DT="AEX"
+2 SET %DT("B")=Y
+3 SET %DT("A")="Select Obligation Processing Date: "
+4 WRITE !
DO ^%DT
KILL %DT
+5 IF Y<0
DO EXIT
GOTO OUT
+6 SET PRCFA("OBLDATE")=Y
+7 SET EXIT=0
+8 ; processes PRCFA("OBLDATE"), gets accounting period
DO ENO^PRCESOE2
+9 IF EXIT=1
DO EXIT
DO KILL^PRCESOE2
GOTO OUT
+10 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
SET X=PRC("RBDT")
GOTO VAR11
+11 ;
GO ; Prompt user for final go-ahead for the document creation
+1 ; ask 'Transmit?'
DO GO^PRCFFU
+2 IF 'Y!($DATA(DIRUT))
GOTO EXIT
+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"))
Begin DoDot:1
+4 KILL PRCFA("SIGFAIL")
+5 DO MSG2(ESIGMSG)
+6 QUIT
End DoDot:1
GOTO EXIT
+7 ;
+8 ; save 442 ien in file 410
DO OB1^PRCS58OB(PRCFA("TRDA"),PODA)
+9 ; stuff some values into 442
DO COB^PRCH58OB(PODA,.TRNODE,.PO,PRCFA("TRDA"),X)
+10 ; save PRCFA("OBLDATE") in file 442 as PO DATE
DO PODT^PRCS58OB(PRCFA("PODA"),PRCFA("OBLDATE"))
+11 SET PRCFA("BBFY")=$$BBFY^PRCFFU5(PRCFA("PODA"))
+12 DO GENDIQ^PRCFFU7(442,PRCFA("PODA"),".1;.07;.03;17","IEN","")
+13 ; updates running balance quarter & status in 410
DO EDIT410^PRCFFUD(PRCFA("TRDA"),"O")
+14 SET PRC("CP")=+$PIECE(PO(0),"^",3)
+15 ;
EDIT ; Check fund/year dictionary for required FMS fields
+1 ; sets up PRCFMO array to use in building LIN segment
DO EDIT^PRCFFU
+2 ;
+3 ; flag to FMS indicating a dollar increase
SET IDFLAG="I"
+4 ; do rebuild
IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
DO SET1358^PRCFFERT
+5 ;
STACK ; Create entry in GECS Stack File
+1 ; set up CTL,DOC segs of code sheet, (0) means no batch#
DO STACK^PRCFFU(0)
+2 ;
SEGS ; Create entry in TMP($J, for remaining segments
+1 KILL ^TMP($JOB,"PRCMO")
+2 NEW FMSINT
SET FMSINT=+PO
+3 SET FMSMOD=$PIECE(PRCFA("MOD"),U,1)
+4 ; builds remaining segs
DO NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD)
+5 ;
+6 ; Transfers remaining segs 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 FMS transaction document as queued for transmission
+1 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+2 NEW P2
SET P2=+PO
+3 SET $PIECE(P2,"/",3)=+OB
+4 SET $PIECE(P2,"/",5)=$PIECE(PRCFA("ACCPD"),U)
+5 SET $PIECE(P2,"/",6)=PRCFA("OBLDATE")
+6 DO SETPARAM^GECSSDCT(GECSFMS("DA"),P2)
+7 ;
POBAL ; Enter Obligation Data into Purchase Order Record
+1 ;
+2 ; add FMS document info to node 10 of file 442
+3 DO EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PRCFA("OBLDATE"),PRCFA("PATNUM"))
+4 ;
+5 ; create daily record in file 424
+6 DO POST
if '%
GOTO OUT
+7 ;
+8 ; continue processing if this is not a rebuild
+9 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")
DO OUT
QUIT
+10 SET X=100
+11 SET DA=PRCFA("PODA")
+12 DO ENF^PRCHSTAT
+13 SET AMT=$PIECE(PO(0),U,7)+$SELECT(+$PIECE(PO(0),U,9)'=0:$PIECE(PO(0),U,9),1:"")
+14 DO NOW^PRCFQ
+15 SET TIME=X
+16 ; file 410 transaction amount
SET X=$PIECE(TRNODE(4),"^",8)
+17 ; file 410 ien
SET DA=PRCFA("TRDA")
+18 DO TRANK^PRCSES
+19 SET DEL=$SELECT('$DATA(DEL):"",1:DEL)
+20 DO CS^PRCS58OB(OB,AMT,TIME,PATNUM,PODA,DEL,X,.PRC)
+21 WRITE !!,"...updating 1358 Obligation balances...",!
+22 SET ^PRC(442,PODA,8)=AMT_"^0^0"
+23 SET X=AMT
DO TRANS1^PRCSES
+24 SET X=AMT
Begin DoDot:1
+25 DO TRANS^PRCSES
+26 DO BULLET^PRCEFIS1
+27 ;Generate 1358 transaction message to OLCS. Messages will be generated
+28 ;upon obligation of a new 1358 or an adjustment. Messages will not be
+29 ;sent for a rebuild or retransmission to FMS.(PRC*5.1*153)
+30 IF $DATA(PRCFA("RETRAN"))
IF 'PRCFA("RETRAN")
DO OLCSMSG^PRCFDO
+31 DO OUT
End DoDot:1
WRITE !!
GOTO V
+32 ;
OUT ;Unlock when exiting option, PRC*5.1*176
IF $GET(PRCFA("TRDA"))
LOCK -^PRCS(410,PRCFA("TRDA"))
+1 DO K1B^PRCFFUZ
+2 DO K1C^PRCFFUZ
+3 QUIT
+4 ;
EXIT IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=0
DO MSG1
DO KILL^PRCH58OB(PODA)
+1 IF '$TEST
DO MSG
+2 QUIT
+3 ;
KILL DO KILL^PRCH58OB(PODA)
GOTO OUT
+1 ;
LOOKUP ; Lookup 1358 transaction which is pending fiscal action.
+1 DO LOOKUP^PRCESOE1
+2 QUIT
+3 ;
POST ; Post data in file 424
+1 IF $DATA(PRCFA("RETRAN"))
IF 'PRCFA("RETRAN")
DO POST^PRCESOE1
+2 QUIT
+3 ;
+4 ; Message processing
MSG DO MSG^PRCESOE1
QUIT
MSG1 DO MSG1^PRCESOE1
QUIT
MSG2(MSG) DO MSG2^PRCESOE1(MSG)
QUIT
MSG3 DO MSG3^PRCESOE1
QUIT
