source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCESOM.m@ 1259

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

initial load of WorldVistAEHR
File size: 6.8 KB
RevLine 
[613]1PRCESOM ;WISC/SJG-CONTINUATION OF 1358 ADJUST OBLIAGTION PRCEADJ1 ;4/27/94 2:13 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N TI,PRCFASYS,IOINLOW,IOINHI,IOINORM,DIR,AMT,OLDTT,CS,HASH,DIE,DR,LAUTH,LBAL,TAUTH,TBAL,DLAYGO
5 D SCREEN
6 S PRC("CP")=$P(TRNODE(0),"-",4)
7 S PRC("RBDT")=$P(TRNODE(0),U,11)
8 I $G(PRCRGS)<1 D OVCOM1^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D REQFAIL^PRCFFU10,MSG G OUT
9 ;
10 D OKAY2^PRCFFU ; ask 'OK to continue?'
11 I 'Y!($D(DIRUT)) D MSG G OUT
12 S AMT=$P(TRNODE(4),U,8)
13K 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
14 S PRC("CP")=$P(TRNODE(0),"-",4)
15 S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
16 S PRCFA("MOD")="M^1^Modification Entry"
17 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^",2)="E" S PRCFA("MOD")="E^0^Original Document"
18 S PRCFA("MP")=$P(PO(0),U,2)
19 S PRCFA("PATNUM")=$P($P(PO(0),U),"-",2)
20 S PRCFA("PODA")=PODA
21 S PRCFA("REF")=$P(PO(0),U)
22 ; S PRCFA("SFC")=$P(PO(0),U,19)
23 S PRCFA("SYS")="FMS"
24 S PRCFA("TT")="SO"
25 I $D(GECSDATA),$G(GECSDATA(2100.1,GECSDATA,.01,"E"))[("AR-") S PRCFA("TT")="AR"
26EDIT ;
27 I $G(PRCFA("ACCEDIT"))=1 D TAG33^PRCFFU9 ; sets PRCFA("PPT") & PRCFA("MOMREQ")
28 I $G(PRCFA("RETRAN"))=1 D TAG33^PRCFFU9 ; sets PRCFA("PPT") & PRCFA("MOMREQ")
29 ;
30 ; Compare adjustment to original 1358
31 N RETURN,ERFLAG,IDFLAG,TYPE
32 S RETURN=$$COMP^PRCFFU6(PRC442,PRC410,.RETURN)
33 S ERFLAG=$P(RETURN,U,1)
34 S IDFLAG=$P(RETURN,U,2)
35 S TYPE=$P(RETURN,U,2)
36 I ERFLAG D Q
37 . W !!," Cannot continue...one or more of the following fields have changed..."
38 . N LOOP S LOOP=""
39 . F S LOOP=$O(PRCFA("CHG",LOOP)) Q:LOOP="" I PRCFA("CHG",LOOP)]"" W !,?5,PRCFA("CHG",LOOP)
40 . K PRCFA("CHG")
41 . W !!," Please be sure that the VENDOR, FUND CONTROL POINT, BOC, and COST CENTER",!," fields are the same as the original 1358 obligation!"
42 . D MSG
43 . D EN^DDIOL(" ** Press RETURN to continue **")
44 . R X:DTIME
45 . D OUT
46 . Q
47 ;
48DT I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G DT1
49 . D RETRANM^PRCESOE2 ; get account & obligation processing dates
50 . S Y=PRCFA("OBLDATE")
51 S Y=PRC("RBDT") I Y<DT!'Y D NOW^%DTC S Y=X
52DT1 D D^PRCFQ ; convert date to external format
53 S %DT="AEX"
54 S %DT("A")="Select Obligation Processing Date: "
55 S %DT("B")=Y
56 W ! D ^%DT
57 K %DT
58 I Y<0 D MSG,OUT H 3 Q
59 S PRCFA("OBLDATE")=Y
60 S EXIT=0
61 D ENM^PRCESOE2
62 I EXIT D H 3 Q
63 . D MSG
64 . D OUT
65 . D KILL^PRCESOE2
66 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
67 D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
68 ;
69 D I "^SO^AR^"'[("^"_$P(PRCFA("TT"),":",1)) D MSG S Y=1 G OUT
70 . N PRCFATT S PRCFATT=PRCFA("TT")
71 . D SOAR^PRC0E(PRCFA("PODA"),.PRCFATT,1) ; ask SO or AR, if appropriate
72 . S PRCFA("TT")=PRCFATT K PRCFATT
73 ;
74 I PRCFA("TT")="AR" D I "EM"'[X D MSG S Y=1 G OUT
75 . N Y
76 . D SC^PRC0A("",.Y,"Label document action as: ","AOM^E:Original Entry;M:Modification Entry","M")
77 . I $E(Y)="E" S PRCFA("MOD")="E^0^Original Entry"
78 . I $E(Y)="M" S PRCFA("MOD")="M^1^Modification Entry"
79 . S X=$E(Y)
80 . K Y
81 S X=0
82 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
83 . S PRCFA("SIS")=$$GETTXNS^PRCFFERT(PO,PRC410,21) ; get other FMS txns for this adjustment
84 . S X=$$NEWCHK^PRCFFERT(PRCFA("TT"),$E(PRCFA("MOD")),PRCFA("SIS")) ; if selected txn exists, X will be DOCID
85 . I X=0 S PRCFA("RETRAN")=2 ; selected txn doesn't exist, create
86 . I X'=0 S X=$$SWITCH^PRCFFERT(X,21,.GECSDATA) ; is selected txn available?
87 ;
88GO ; Prompt use for final go-ahead for the document creation
89 D GO^PRCFFU
90 I 'Y!($D(DIRUT)) D MSG,OUT Q
91 ;
92ESIG ; Enter the Electronic Signature and away it goes!
93 W !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
94 D SIG^PRCFFU4
95 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") H 3 D MSG,OUT Q
96 ;
97 ; Check fund/year dictionary for FMS required fields
98 D EDIT^PRCFFU ; sets up PRCFMO array for req'd fields
99 ;
100 D EDIT410^PRCFFUD(OB,"O") ; edit running balance qtr & status in 410
101 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D SET1358^PRCFFERT ; do rebuild
102 ;
103STACK ; Create entry in GECS Stack File
104 D STACK^PRCFFU(1) ; CTL,BAT,DOC segments, (1) creates batch# for FMS doc
105 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 G SEGS
106 ;
107UPDATE ; Update records in 442 and 410
108 W !!,"...updating obligation balances....please hold...",!!
109 D POADJ^PRCH58OB(.PO,PODA,.TRNODE,AMT)
110 D POADJ^PRCS58OB(.PRC,PODA,TRDA,AMT)
111 D:AMT>0 BULC^PRCH58(PODA)
112 D UPDATE^PRCFFU6(PRC442,PRC410) ; update node 22 of file 442
113 ;
114SEGS ; Use TMP($J to store remaining segments to be built
115 K ^TMP($J,"PRCMO")
116 N FMSINT S FMSINT=+PO
117 S FMSMOD=$P(PRCFA("MOD"),U,1)
118 D NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD) ; build segments
119 ;
120 ; Transfer nodes from TMP($J, into GECS Stack File
121 N LOOP S LOOP=0
122 F S LOOP=$O(^TMP($J,"PRCMO",GECSFMS("DA"),LOOP)) Q:'LOOP D SETCS^GECSSTAA(GECSFMS("DA"),^(LOOP))
123 K ^TMP($J,"PRCMO")
124 ;
125TRANS ; Mark the document as queued for transmission
126 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
127 N P2 S P2=+PO
128 S $P(P2,"/",4)=+TRDA
129 S $P(P2,"/",5)=$P(PRCFA("ACCPD"),U)
130 S $P(P2,"/",6)=PRCFA("OBLDATE")
131 D SETPARAM^GECSSDCT(GECSFMS("DA"),P2) ; save P2 as node 26 of 2100.1
132 ;
133POBAL ; Enter Obligation Data into Purchase Order Record
134 ; Log transaction into node 10 of file 442
135 D EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PODATE,PRCFA("PATNUM"))
136 ;
137 ; Continue processing if this is not a rebuild
138 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 G OUT
139Z S (X,Z)=$P(PO(0),U)
140 S %=1
141 D EN1^PRCSUT3
142 S DLAYGO=424
143 S DIC="^PRC(424,"
144 S DIC(0)="L"
145 D FILE^DICN
146 I Y<0 W !,"ERROR IN CREATING 424 RECORD",$C(7),!! Q
147 ;
148 S DIE="^PRC(424,"
149 S DA(1358)=+Y
150 D NOW^%DTC
151 S TI=%
152 S DA=DA(1358)
153 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"
154 D ^DIE W "...adjustment completed..."
155 G OUT
156 Q
157 ;
158SCREEN ;COMPARISON SCREEN
159 N CEILING,LAUTH,TAUTH,TBAL,LBAL,IOINHI,IOINLOW,IOINORM
160 D HILO^PRCFQ
161 S CEILING=$P(PO(8),U)
162 W @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$P(TRNODE(0),"^")
163 W IOINLOW," 1358 # ",IOINHI,$P(PO(0),"^")
164 W !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$FN(CEILING,"P,",2)
165 S TBAL=$P(PO(8),U,3)
166 S TAUTH=CEILING-TBAL
167 W !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$J($FN(TAUTH,"P,",2),12)
168 S LBAL=$P(PO(8),U,2),LAUTH=CEILING-LBAL
169 W ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$J($FN(LAUTH,",P",2),12)
170 W !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$J($FN(TBAL,"P,",2),12)
171 W ?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$J($FN(LBAL,"P,",2),12),!!
172 W IOINLOW,"Amount of Adjustment: ",IOINHI,$J($P(TRNODE(4),"^",8),0,2),!!,IOINORM
173 Q
174MSG W !
175 S X="No further processing is being taken on this 1358 adjustment obligation. It has NOT been obligated.*"
176 D MSG^PRCFQ
177 Q
178OUT K DIRUT,DTOUT,DUOUT,DIROUT
179 QUIT
Note: See TracBrowser for help on using the repository browser.