Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCESOE

PRCESOE.m

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