source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFMOM.m@ 1258

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

initial load of WorldVistAEHR
File size: 8.4 KB
Line 
1PRCFFMOM ;WOIFO/SJG/AS-ROUTINE TO PROCESS AMENDMENT OBLIGATIONS ;3/8/05
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCFSITE Q:'% ; ask station
5 D OUT1 ; kill variables
6 ;
7 ; prompt for signature (E-Sig code for amendment)
8 S MESSAGE=""
9 D ESIG^PRCUESIG(DUZ,.MESSAGE)
10 I MESSAGE<1 D G OUT1 ; exit if bad response
11 . I (MESSAGE=0)!(MESSAGE=-3) W !,$C(7)," SIGNATURE CODE FAILURE " R X:3 ;3 TRIES or NO SIG ON FILE
12 . I (MESSAGE=-1)!(MESSAGE=-2) Q ;ARROWED OUT or TIMED OUT
13 ;
14START ; get PO#
15 K PRCFA
16 K DIC("A")
17 S D="E"
18 S DIC=443.6
19 S DIC("S")="I +^(0)=PRC(""SITE"") S FSO=$O(^PRC(443.6,""D"",+Y,0)) I FSO=26!(FSO=31)!(FSO=36)!(FSO=45)!(FSO=71)"
20 S DIC("A")="Select Purchase Order Number: "
21 S DIC(0)="AEQZ"
22 D IX^DIC
23 K DIC("S"),DIC("A")
24 K FSO
25 G:+Y<0 OUT1
26 S FLG=0
27 S PO=Y,PO(0)=Y(0)
28 S PRCFA("PODA")=+Y
29 S PRCFPODA=+Y
30 I '$D(^PRC(443.6,+PO,6)) D NOA G OUT1 ; PO has no amendments
31 I $P(^PRC(443.6,+PO,6,0),"^",4)<0 D NOA G OUT1 ; PO has no amendments
32 I '$$VERIFY^PRCHES5(PRCFPODA) D MSG1 G OUT1 ; tampered PO
33 ;
34 ; get amendment #
35AMEND S DIC="^PRC(443.6,"_+PO_",6,"
36 S DIC("A")="Select AMENDMENT: "
37 S DIC(0)="AEMNZQ"
38 D ^DIC
39 K DIC("A")
40 G:Y<0 OUT1
41 S PO(6)=Y(0)
42 S PO(6,1)=^PRC(443.6,+PO,6,+Y,1)
43 S PRCFA("AMEND#")=+Y
44 S PRCFAA=+Y
45 ;
46DESC ; verify amendment is complete
47 I $$CHKAMEN^PRCFFU(+PO,PRCFAA) W !,?15,"Return Amendment to A&MM.",! G START
48 I $P($G(PO(6,1)),U,2)="" D G START
49 . W ! D EN^DDIOL("This amendment is still awaiting signature by A&MM!")
50 . W !
51 ;
52 ; set up variables used in this option
53 S PRCFA("RETRAN")=0
54 S D0=+PO
55 S D1=+Y
56 S PRCHPO=PRCFPODA
57 S PRCHAM=PRCFAA
58 D ^PRCHSF3 ; sets up PRCH("AM") array
59 D ^PRCHDAM ; display amendment info
60 D DT442^PRCFFUD1(PRCFPODA,PO(0),443.6,PRCFA("AMEND#")) ; set up PRC array
61RETRAN ; Entry point for rebuild/transmit
62 S PRCFA("MOD")="M^1^Modification Entry"
63 ;
64 ; check amendment record for availability
65 L +^PRC(443.6,PRCFPODA):1
66 I $T=0 D G OUT1
67 . W $C(7),!
68 . D EN^DDIOL("This amendment is being obligated by another user!")
69 ;
70 I 'PRCFA("RETRAN"),$O(^PRC(443.6,PRCFPODA,6,PRCFAA,3,"AC",32,0)) N P2237 S P2237=$P(^PRC(443.6,PRCFPODA,0),U,12) I P2237>0 I '$$VERIFY^PRCSC2(P2237) D MSG1 G OUT1 ; tampered PO
71 ;
72 I PRCFA("RETRAN") D DT442^PRCFFUD1(PRCFPODA,PO(0),442,PRCFA("AMEND#"))
73 ;
74 I $G(PRCRGS)<1 D OVCOM^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D POFAIL^PRCFFU10,MSG G OUT1
75 ;
76 S PCP=+$P(PO(0),U,3)
77 S $P(PCP,U,2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),U,12),1:"")
78APP W !
79 D OKAM^PRCFFU I 'Y!($D(DIRUT)) G AMEND ; ask OK to amend?
80 D SC^PRCFFUA1 ; display FCP, cost ctr, PO/Req#
81 D CPBAL^PRCFFUA1 ; display cost & balances
82 D GET^PRCFFUA1 ; display amended (BOC) info
83 S FATAL=0
84 D OK^PRCFFUA ; ask if above BOC info is correct
85 S SAVEY=Y
86 I Y D S Y=SAVEY K SAVEY I FATAL=1 D MSG10^PRCFFUA3 G APP1
87 . D GETBOC^PRCFFUA4
88 . D CHKBOC^PRCFFUA4
89 I 'Y!($D(DIRUT)) D I FISCEDIT G RETRAN
90 .S FISCEDIT=0
91 .I $D(DIRUT) D MSG9^PRCFFUA3 Q
92 .I 'Y D MSG8^PRCFFUA3,POAM^PRCFFUA Q
93 .Q
94 D KILL^PRCFFUA
95APP1 I FATAL=1 G:PRCFA("RETRAN")=0 START Q:PRCFA("RETRAN")=1
96 I $D(^PRC(443.6,+PO,6)),$P(PO(6,1),"^",5)'="" D I 'Y!($D(DIRUT)) G OUT1
97 . W !
98 . D OKAPP^PRCFFU ; amendment approved, ask 'continue?'
99PRT W !
100 D OKPRT^PRCFFU S:Y FLG=1 ; print amendment
101 S PRCFA("AMEND#")=PRCFAA
102 S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
103 S PRCFA("IDES")="Purchase Order Amendment Obligation"
104 S PRCFA("MP")=$P(PO(0),U,2)
105 S PRCFA("PODA")=PRCFPODA
106 S PRCFA("REF")=$P(PO(0),U)
107 ; the following line commented out in PRC*5*179
108 ; S PRCFA("SFC")=$P(PO(0),U,19)
109 S PRCFA("SYS")="FMS"
110 S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",1:"MO")
111 I $D(GECSDATA),$E($G(GECSDATA(2100.1,GECSDATA,.01,"E")),1,3)="AR-" S PRCFA("TT")="AR"
112PRT1 I PRCFA("MP")=2&(PRCFA("TT")="SO") D G:ACCEDIT=1 PRT1
113 . W !
114 . D EN^PRCFFU16(+PO)
115PRT11 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G PRT2
116 . D RETRANM^PRCFFMO2
117 . S Y=PRCFA("OBLDATE")
118 S Y=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("AMENDT"))
119PRT2 D D^PRCFQ
120 S %DT="AEX"
121 S %DT("A")="Select Obligation Processing Date: "
122 S %DT("B")=Y
123 W !
124 D ^%DT
125 K %DT
126 I Y<0 D MSG H 3 G OUT1
127 S PRCFA("OBLDATE")=Y
128 S EXIT=0
129 D ENM^PRCFFMO2
130 I EXIT D MSG,KILL^PRCFFMO2 H 3 G OUT1
131 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 PRT11
132 D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
133EDIT ; Get budget/accounting elements
134 N PARAM
135 S PARAM=+$P(PO(0),U,3)_"^"_PRC("FY")_"^"_PRCFA("BBFY")
136 S PRCFMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
137 S IDFLAG="I"
138 S XRBLD=0
139 I PRCFA("RETRAN")=1 D EN^PRCFFUB ; if selected transaction to rebuild is a 'X' decrease or cancel, set XRBLD=1, set to 2 if it is the 'E'
140 ;
141 ; determine the correct transaction type if this is not an MO document
142 I PRCFA("TT")'="MO",XRBLD=0 D I "^AR^SO^"'[("^"_$P(PRCFA("TT"),":",1)) D MSG,OUT1 Q
143 . N PRCFATT S PRCFATT=PRCFA("TT")
144 . D SOAR^PRC0E(PRCFA("PODA"),.PRCFATT,1) ; ask SO or AR, if appropriate
145 . S PRCFA("TT")=PRCFATT K PRCFATT
146 ;
147 I PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^")="AR",PRCFA("TT")="AR" D
148 . I $P(PRCFA("GECS"),"^",2)="E" S PRCFA("MOD")="E^0^Original Document"
149 . I $P(PRCFA("GECS"),"^",2)="M" S PRCFA("MOD")="M^1^Modification Document"
150 ;
151 I PRCFA("TT")="AR",XRBLD=0 D I "EM"'[X D MSG,OUT1 Q
152 . S X="M"
153 . I PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^",2)="E" S X="E"
154 . D SC^PRC0A("",.Y,"Label document action as: ","AOM^E:Original Document;M:Modification Document",X)
155 . I $E(Y)="E" S PRCFA("MOD")="E^0^Original Document"
156 . I $E(Y)="M" S PRCFA("MOD")="M^1^Modification Document"
157 . S X=$E(Y)
158 . K Y
159 ;
160 ; check to see if transaction type or document type changed
161 S X=0
162 I XRBLD=0,$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 G OUT1
163 . S PRCFA("SIS")=$$GETTXNS^PRCFFERT(PO,PRCFA("AMEND#"),2) ; get other txns for this amendment
164 . S X=$$NEWCHK^PRCFFERT(PRCFA("TT"),$E(PRCFA("MOD"),1),PRCFA("SIS")) ; does selected txn exist?
165 . I X=0 S PRCFA("RETRAN")=2 ; txn doesn't exist, create
166 . I X'=0 S X=$$SWITCH^PRCFFERT(X,2,.GECSDATA) ; replace current GECSDATA values with values belonging to selected txn-- returns '^' if not switched
167 ;
168GO ; Prompt user for for final go-ahead for approval
169 D GO^PRCFFU
170 I 'Y!($D(DIRUT)) D MSG,OUT1 Q
171ESIG W !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
172 D SIG^PRCFFU4
173 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") H 3 G OUT1
174 S DA=PRCFA("PODA")
175 D REMOVE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"))
176 S MESSAGE="" ; value not used but variable is needed by next call
177 D ENCODE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"),DUZ,.MESSAGE)
178 ;
179 D DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
180 S PRCOAMT=+^PRC(442,PRCFA("PODA"),0)
181 S $P(PRCOAMT,"^",2)=+$P(^PRC(442,PRCFA("PODA"),0),"^",3)
182 S $P(PRCOAMT,"^",3)=PRC("FYQDT")
183 S $P(PRCOAMT,"^",5)=-$P(^PRC(442,PRCFA("PODA"),0),"^",$P(PRCFMO,"^",12)="N"+15)
184 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 G TRANS1
185TRANS W !!,"...copying amendment information back to Purchase Order file...",! D WAIT^DICD
186 S ERFLAG=""
187 S PRCFA("DLVDATE")=$P(^PRC(442,PRCFA("PODA"),0),"^",10)
188 D CHECK^PRCHAMYA(PRCFA("PODA"),PRCFA("AMEND#"),.ERFLAG)
189 I ERFLAG W !!,"...ERROR IN COPYING AMENDMENT INFORMATION BACK TO PURCHASE ORDER FILE..." G OUT1
190TRANS1 D DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
191 ; transmit amendment from IFCAP to DynaMed **81**
192 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 D
193 . ; No DynaMed interface if rebuild/retransmit
194 . I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 Q
195 . D ENT^PRCVPOU(PRCFA("PODA"),PRCFA("AMEND#"))
196 S PRCFA("OLDPODA")=PRCFA("PODA")
197 S PRCFA("OLDREF")=PRCFA("REF")
198 I PRCFA("RETRAN")>0 I XRBLD=1!(XRBLD=2) D GO^PRCFFUB H 3 Q ; if rebuilding a 'dependent' transaction, finish work here
199 D LIST^PRCFFU7(PRCFA("PODA"),PRCFA("AMEND#"))
200 I $G(PRCFA("RETRAN"))<1 D AMEND^PRCFFUD ; create entry in 410
201 I PRCFA("AUTHE") D FCP^PRCFFU11,PRINT G START
202 I 'PRCFA("MOMREQ") D MSG^PRCFFU8 G PRINT ; skip FMS transmit,fiscal upadtes
203 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D SETPO^PRCFFERT
204 I $G(PRCFA("ACCEDIT"))=1 D TAG33^PRCFFU9
205TRANS2 K PO
206 D ^PRCFFM1M
207 L -^PRC(443.6,PRCFA("PODA"))
208 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D OUT1^PRCFFM1M G START
209 QUIT
210 ;
211PRINT ; Print out copy of Purchase Order Amendment
212 G:'FLG OUT1
213 S PRCHQ="^PRCHPAM"
214 S PRCHQ("DEST")="S8"
215 S D0=PRCFA("PODA")
216 S D1=PRCFA("AMEND#")
217 D ^PRCHQUE
218OUT1 K FATAL,FLG,%,%Y,DIC,I,J,K,P,PRCFA,PRCFAA,PRCFPODA,PRCFCHG,X,XRBLD,Y,Z
219 Q
220 ; Message processing
221NOA D NOA^PRCFFM3M Q
222MSG D MSG^PRCFFM3M Q
223MSG1 D MSG1^PRCFFM3M Q
Note: See TracBrowser for help on using the repository browser.