source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCESOE.m@ 1582

PRCESOE ;WISC/CLH/CTB/SJG-1358 OBLIGATION ; 08/22/94  5:11 PM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 K PRC,PRCF,Y
 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
 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
 . D OUT
 ;
OUT 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