source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCESOE.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1PRCESOE ;WISC/CLH/CTB/SJG-1358 OBLIGATION ; 08/22/94 5:11 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 K PRC,PRCF,Y
5 D OUT
6 S PRCF("X")="AB"
7 D ^PRCFSITE Q:'%
8 D LOOKUP G:Y<0 OUT
9 D K1A^PRCFFUZ
10 S (OB,DA)=+Y ; ien for file 410
11 S PRCFA("RETRAN")=0
12SC ; Entry point for rebuild/retransmit
13 D NODE^PRCS58OB(DA,.TRNODE) ; set file 410 values into TRNODE array
14 S PRCFA("TRDA")=OB
15 D SCREEN^PRCEOB1 W !
16 D VENCONO^PRCFFU15(OB) ; display vendor & contract info, if exists
17 S FLDCHK=0
18 D EN^PRCFFU14(OB) ; edit auto accrual info
19 I ACCEDIT=1 G SC
20 I FLDCHK=1 D OUT G V
21OKAY S PRCFA("IDES")="1358 Obligation"
22 D OKAY^PRCFFU ; ask 'Is info correct?'
23 I $D(DIRUT) D MSG H 3 G OUT
24 S ESIGCHK=1
25 S FISCEDIT=0
26 I 'Y D 1358^PRCFFU13 ; edit cost center or boc?
27 I 'ESIGCHK D MSG H 3 G OUT
28 I FISCEDIT G SC
29 S PRC("RBDT")=$P(TRNODE(0),U,11)
30 S PCP=$P(TRNODE(0),"-",4)
31 S PQT=$P(TRNODE(0),"-",3)
32 D CPBAL^PRCFFMO1 ; display control point balance
33 K PQT,PRCF("NOBAL")
34 K PRCTMP
35 I '$P(TRNODE(0),U,11) D
36 . D ERS410^PRC0G(DA)
37 . S TRNODE(0)=^PRCS(410,DA,0)
38 S PRC("FY")=$P(TRNODE(0),"-",2)
39 S PRC("QTR")=$P(TRNODE(0),"-",3)
40 S PRC("CP")=$P(TRNODE(0),"-",4)
41 I $G(PRCRGS)<1 D OVCOM1^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D REQFAIL^PRCFFU10,MSG H 3 G OUT
42 W ! D OKAY2^PRCFFU ; ask 'OK to continue?'
43 I 'Y!($D(DTOUT)) D MSG H 3 G OUT
44 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D G:'$D(DA) OUT
45 . K DA,X
46 . S PRCHP("T")=21
47 . S PRCHP("S")=4
48 . S PRCHP("A")="1358 Obligation Number"
49 . S PRCFA(1358)=""
50 . D EN^PRCHPAT ; ask for obligation #, set up 442 record
51 . K PRCFA(1358),PRCHP
52 . I '$D(DA) D MSG3
53 . Q
54VAR I $D(PRCFA("RETRAN")),PRCFA("RETRAN") S DA=POIEN ; 442 ien
55 D PAT^PRCH58OB(DA,.PODA,.PO,.PATNUM) ; set up parameterized variables
56 N PRCFDEL,AMT,CS,DA,DIK,TIME,MOD
57 S PRCFA("BBFY")=$TR($P(TRNODE(3),"^",11)," ")
58 S PRCFA("MOD")="E^0^Original Entry"
59 S PRCFA("MP")=$P(PO(0),U,2)
60 S PRCFA("PATNUM")=$P($P(PO(0),"^"),"-",2)
61 S PRCFA("PODA")=PODA
62 S PRCFA("REF")=$P(PO(0),U)
63 ; S PRCFA("SFC")=$P(PO(0),U,19)
64 S PRCFA("SYS")="FMS"
65 S PRCFA("TT")="SO"
66VAR11 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G VAR2
67 . D RETRANO^PRCESOE2 ; put date in FMS transaction into PRCFA("OBLDATE")
68 . S X=PRCFA("OBLDATE")
69 S X=PRC("RBDT")
70 I X<DT!'X D NOW^%DTC
71VAR2 S Y=X D D^PRCFQ ; convert date to external format
72 S %DT="AEX"
73 S %DT("B")=Y
74 S %DT("A")="Select Obligation Processing Date: "
75 W ! D ^%DT K %DT
76 I Y<0 D EXIT G OUT
77 S PRCFA("OBLDATE")=Y
78 S EXIT=0
79 D ENO^PRCESOE2 ; processes PRCFA("OBLDATE"), gets accounting period
80 I EXIT=1 D EXIT,KILL^PRCESOE2 G OUT
81 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
82 ;
83GO ; Prompt user for final go-ahead for the document creation
84 D GO^PRCFFU ; ask 'Transmit?'
85 I 'Y!($D(DIRUT)) G EXIT
86 ;
87ESIG ; Enter the Electronic Signature and away it goes!
88 W !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
89 D SIG^PRCFFU4
90 I $D(PRCFA("SIGFAIL")) D G EXIT
91 . K PRCFA("SIGFAIL")
92 . D MSG2(ESIGMSG)
93 . Q
94 ;
95 D OB1^PRCS58OB(PRCFA("TRDA"),PODA) ; save 442 ien in file 410
96 D COB^PRCH58OB(PODA,.TRNODE,.PO,PRCFA("TRDA"),X) ; stuff some values into 442
97 D PODT^PRCS58OB(PRCFA("PODA"),PRCFA("OBLDATE")) ; save PRCFA("OBLDATE") in file 442 as PO DATE
98 S PRCFA("BBFY")=$$BBFY^PRCFFU5(PRCFA("PODA"))
99 D GENDIQ^PRCFFU7(442,PRCFA("PODA"),".1;.07;.03;17","IEN","")
100 D EDIT410^PRCFFUD(PRCFA("TRDA"),"O") ; updates running balance quarter & status in 410
101 S PRC("CP")=+$P(PO(0),"^",3)
102 ;
103EDIT ; Check fund/year dictionary for required FMS fields
104 D EDIT^PRCFFU ; sets up PRCFMO array to use in building LIN segment
105 ;
106 S IDFLAG="I" ; flag to FMS indicating a dollar increase
107 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D SET1358^PRCFFERT ; do rebuild
108 ;
109STACK ; Create entry in GECS Stack File
110 D STACK^PRCFFU(0) ; set up CTL,DOC segs of code sheet, (0) means no batch#
111 ;
112SEGS ; Create entry in TMP($J, for remaining segments
113 K ^TMP($J,"PRCMO")
114 N FMSINT S FMSINT=+PO
115 S FMSMOD=$P(PRCFA("MOD"),U,1)
116 D NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD) ; builds remaining segs
117 ;
118 ; Transfers remaining segs from TMP($J, into GECS Stack File
119 N LOOP S LOOP=0
120 F S LOOP=$O(^TMP($J,"PRCMO",GECSFMS("DA"),LOOP)) Q:'LOOP D SETCS^GECSSTAA(GECSFMS("DA"),^(LOOP))
121 K ^TMP($J,"PRCMO")
122 ;
123TRANS ; Mark the FMS transaction document as queued for transmission
124 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
125 N P2 S P2=+PO
126 S $P(P2,"/",3)=+OB
127 S $P(P2,"/",5)=$P(PRCFA("ACCPD"),U)
128 S $P(P2,"/",6)=PRCFA("OBLDATE")
129 D SETPARAM^GECSSDCT(GECSFMS("DA"),P2)
130 ;
131POBAL ; Enter Obligation Data into Purchase Order Record
132 ;
133 ; add FMS document info to node 10 of file 442
134 D EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PRCFA("OBLDATE"),PRCFA("PATNUM"))
135 ;
136 ; create daily record in file 424
137 D POST G OUT:'%
138 ;
139 ; continue processing if this is not a rebuild
140 I $D(PRCFA("RETRAN")),PRCFA("RETRAN") D OUT Q
141 S X=100
142 S DA=PRCFA("PODA")
143 D ENF^PRCHSTAT
144 S AMT=$P(PO(0),U,7)+$S(+$P(PO(0),U,9)'=0:$P(PO(0),U,9),1:"")
145 D NOW^PRCFQ
146 S TIME=X
147 S X=$P(TRNODE(4),"^",8) ; file 410 transaction amount
148 S DA=PRCFA("TRDA") ; file 410 ien
149 D TRANK^PRCSES
150 S DEL=$S('$D(DEL):"",1:DEL)
151 D CS^PRCS58OB(OB,AMT,TIME,PATNUM,PODA,DEL,X,.PRC)
152 W !!,"...updating 1358 Obligation balances...",!
153 S ^PRC(442,PODA,8)=AMT_"^0^0"
154 S X=AMT D TRANS1^PRCSES
155 S X=AMT D W !! G V
156 . D TRANS^PRCSES
157 . D BULLET^PRCEFIS1
158 . D OUT
159 ;
160OUT D K1B^PRCFFUZ
161 D K1C^PRCFFUZ
162 Q
163 ;
164EXIT I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D MSG1,KILL^PRCH58OB(PODA)
165 E D MSG
166 Q
167 ;
168KILL D KILL^PRCH58OB(PODA) G OUT
169 ;
170LOOKUP ; Lookup 1358 transaction which is pending fiscal action.
171 D LOOKUP^PRCESOE1
172 Q
173 ;
174POST ; Post data in file 424
175 I $D(PRCFA("RETRAN")),'PRCFA("RETRAN") D POST^PRCESOE1
176 Q
177 ;
178 ; Message processing
179MSG D MSG^PRCESOE1 Q
180MSG1 D MSG1^PRCESOE1 Q
181MSG2(MSG) D MSG2^PRCESOE1(MSG) Q
182MSG3 D MSG3^PRCESOE1 Q
Note: See TracBrowser for help on using the repository browser.