source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFUD.m@ 1093

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1PRCFFUD ;WISC/SJG-UTILITY FOR CARRY FORWARD ;7/24/00 23:14
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 QUIT
6 ; No top level entry
7 ;
8OBDT() ; Check if obligation processing date is valid for the open quarter
9 N GOFLAG,MOP,STNQTR,PODATE,PRIMARY,SDATE1,SDATE2,SDATE3,SDATE4,SPIECE1,SPIECE2,SPIECE3,SPIECE4,RBQTR,AMDDATE
10 S GOFLAG=0
11 S MOP=$$NP^PRC0B("^PRC(442,"_+PO_",",0,2)
12 S PRIMARY=$$NP^PRC0B("^PRC(442,"_+PO_",",0,12)
13 S STNQTR=$$NP^PRC0B("^PRC(420,"_+PRC("SITE")_",",0,9)
14 ; If obligation is an original entry, use PO date
15 ; If obligation is an amendment, use amendment date
16 I '$D(PRCFA("AMEND#")) S PODATE=$$NP^PRC0B("^PRC(442,"_+PO_",",1,15)
17 I $D(PRCFA("AMEND#")),MOP'=21 D S PODATE=$G(AMDDATE)
18 .; If amendment is initial document, get info from file 443.6
19 .I PRCFA("RETRAN")=0 D Q
20 ..N SUBINFO S SUBINFO="443.67^1^"_PRCFA("AMEND#")
21 ..K PRCTMP(443.67,PRCFA("AMEND#"),1)
22 ..D GENDIQ^PRCFFU7(443.6,PRCFA("PODA"),50,"IEN",SUBINFO)
23 ..S AMDDATE=$G(PRCTMP(443.67,PRCFA("AMEND#"),1,"I"))
24 ..K PRCTMP(443.67,PRCFA("AMEND#"),1)
25 ..Q
26 .; If amendment is rebuild, get info from file 442
27 .I PRCFA("RETRAN")=1 D Q
28 ..N SUBINFO S SUBINFO="442.07^1^"_PRCFA("AMEND#")
29 ..K PRCTMP(442.07,PRCFA("AMEND#"),1)
30 ..D GENDIQ^PRCFFU7(442,PRCFA("PODA"),50,"IEN",SUBINFO)
31 ..S AMDDATE=$G(PRCTMP(442.07,PRCFA("AMEND#"),1,"I"))
32 ..K PRCTMP(442.07,PRCFA("AMEND#"),1)
33 ..Q
34 .Q
35 S SDATE1=$$DATE^PRC0C(PODATE,"I"),SDATE2=$$DATE^PRC0C(PRCFA("OBLDATE"),"I"),SDATE3=$$DATE^PRC0C(STNQTR,"I")
36 S SPIECE1=$P(SDATE1,U,1,2),SPIECE2=$P(SDATE2,U,1,2),SPIECE3=$P(SDATE3,U,1,2)
37 ; Check if transaction is a 1358
38 I MOP=21 D G QUIT
39 .S RBQTR=$$NP^PRC0B("^PRCS(410,"_PRIMARY_",",0,11)
40 .S SDATE4=$$DATE^PRC0C(RBQTR,"I"),SPIECE4=$P(SDATE4,U,1,2)
41 .I SPIECE2=SPIECE4 S GOFLAG=1 Q
42 ; Check if transaction has a 2237 request
43 I $G(PRIMARY)="" D G QUIT
44 .; allow PO/oblig date from current qtr
45 .I SPIECE1=SPIECE2,SPIECE2=SPIECE3 S GOFLAG=1 Q
46 .; allow PO/oblig date for fut qtr if PO date qtr same as oblig qtr
47 .I SPIECE3=SPIECE2,SPIECE2]SPIECE1 S GOFLAG=1 Q
48 .; allow PO/oblig date for fut qtr if oblig qtr later than stn open qtr
49 .I SPIECE2]SPIECE3 S GOFLAG=1 Q
50 I $G(PRIMARY)]"" D G QUIT
51 .; allow PO/oblig date from current qtr
52 .I SPIECE1=SPIECE2,SPIECE2=SPIECE3 S GOFLAG=1 Q
53 .; allow PO/oblig date from future qtr
54 .I SPIECE1=SPIECE2,SPIECE2]SPIECE3 S GOFLAG=1 Q
55 .; allow PO/oblig date from prior qtr if open qtr same as oblig qtr
56 .I SPIECE2=SPIECE3,SPIECE3]SPIECE1 S GOFLAG=1 Q
57QUIT QUIT GOFLAG
58 ;
59NEW410 ; Create an entry in File 410 for any PO that does not have a request
60 Q:$G(PRCFA("RETRAN"))=1
61 W ! D EN^DDIOL("...now creating entry in File 410...")
62 N POAMT,P410,NEW410
63 S POAMT=+$S($P(PRCFMO,"^",12)="N":$P(PO(0),"^",16),1:$P(PO(0),"^",15))
64 S P410=+PRCFA("REF")_U_+$P(PO(0),U,3)_U_"A"_U_2_U_PRCFA("OBLDATE")_U_POAMT_U_$P(PRCFA("REF"),"-",2)_"WR"_U_"ST"_U_+PO
65 S $P(P410,U,10,11)=PRC("FYQDT")_U_PRC("BBFY")
66 D A410^PRC0F(.NEW410,P410) S PRCFA("NEW410")=NEW410
67 QUIT
68 ;
69AMEND ; Create an entry in File 410 for each amendment to a purchase order
70 ; Case 1 - amendment with no cancelled documents
71 Q:$G(PRCFA("RETRAN"))=1
72 N AMDEXT S AMDEXT="-"_$G(PRCFA("AMEND#"))
73 W ! D EN^DDIOL("...now creating entry in File 410 for the amendment...")
74 I '$D(PRCFA("CANCEL")) D Q
75 .N AMDAMT,P410,NEW410 S AMDAMT=$$AMDAMT()
76 .S P410=+PRCFA("REF")_U_+$P(PO(0),U,3)_U_"A"_U_2_U_PRCFA("OBLDATE")_U_AMDAMT_U_$P(PRCFA("REF"),"-",2)_AMDEXT_U_"ST"_U_+PO
77 .S $P(P410,U,10,11)=PRC("FYQDT")_U_PRC("BBFY")
78 .D A410^PRC0F(.NEW410,P410) S PRCFA("NEW410")=NEW410
79 .Q
80 ; Case 2 - amendment types: vendor change, FCP change, PO number change
81 I $D(PRCFA("CANCEL")),'PRCFA("AUTHE") D Q
82 .; First update for the old record
83 .N AMDAMT,POREF,AMDNO,FCP,OLDFCP
84 .S AMDAMT=$$AMDAMT1()
85 .I $G(PRCFA("PO"))=1 S POREF=PRCFA("OLDPODA")_U_PRCFA("OLDREF")
86 .I $G(PRCFA("PO"))="" S POREF=PRCFA("PODA")_U_PRCFA("REF")
87 .I $G(PRCFA("FCP"))=1 D S FCP=+OLDFCP
88 ..N LOOP ; "AC" cross ref sorts changes by field# (1=FCP) and amendment type (30=FCP edit)
89 ..S LOOP=$O(^PRC(442,PRCFA("PODA"),6,PRCFA("AMEND#"),3,"AC",30,1,0))
90 ..I LOOP]"" S OLDFCP=^PRC(442,PRCFA("PODA"),6,PRCFA("AMEND#"),3,LOOP,1,1,0)
91 ..Q
92 .I $G(PRCFA("FCP"))="" S FCP=+$P(PO(0),U,3)
93 .S P410=+$P(POREF,U,2)_U_FCP_U_"A"_U_2_U_PRCFA("OBLDATE")_U_AMDAMT_U_$P($P(POREF,U,2),"-",2)_AMDEXT_U_"ST"_U_+POREF
94 .S $P(P410,U,10,11)=PRC("FYQDT")_U_PRC("BBFY")
95 .D A410^PRC0F(.NEW410,P410)
96 .; Then update for new record
97 .S AMDAMT=-AMDAMT
98 .I $G(PRCFA("PO"))=1 S POREF=PRCFA("NEWPODA")_U_PRCFA("NEWREF"),AMDEXT=""
99 .I $G(PRCFA("PO"))="" S POREF=PRCFA("PODA")_U_PRCFA("REF")
100 .S P410=+$P(POREF,U,2)_U_+$P(PO(0),U,3)_U_"A"_U_2_U_PRCFA("OBLDATE")_U_AMDAMT_U_$P($P(POREF,U,2),"-",2)_AMDEXT_U_"ST"_U_+POREF
101 .S $P(P410,U,10,11)=PRC("FYQDT")_U_PRC("BBFY")
102 .D A410^PRC0F(.NEW410,P410)
103 .Q
104 ; Case 3 - amendments type - cancel by Authority E
105 I $D(PRCFA("CANCEL")),PRCFA("AUTHE") D Q
106 .N AMDAMT S AMDAMT=$$AMDAMT1(),AMDEXT=AMDEXT_"#"
107 .S P410=+PRCFA("REF")_U_+$P(PO(0),U,3)_U_"A"_U_2_U_PRCFA("OBLDATE")_U_AMDAMT_U_$P(PRCFA("REF"),"-",2)_AMDEXT_U_"ST"_U_+PO
108 .S $P(P410,U,10,11)=PRC("FYQDT")_U_PRC("BBFY")
109 .D A410^PRC0F(.NEW410,P410) S PRCFA("NEW410")=NEW410
110 .Q
111 QUIT
112PO ; Updating Running Balance Status Field (#449) in File 410 for
113 ; purchase order
114 Q:$G(PRCFA("RETRAN"))=1
115 Q:$G(PRCTMP(442,+PO,.07,"I"))=""
116 I $G(PRCTMP(442,+PO,.07,"I"))]"" D Q
117 .W !!,"...updating running balance status fields in 410...WITH 2237"
118 .N LOOP S LOOP=0
119 .F S LOOP=$O(^PRC(442,+PO,13,LOOP)) Q:LOOP=""!(LOOP'>0) I LOOP>0 D EDIT410(LOOP,"O")
120 .Q
121 QUIT
122AMD ; Updating Running Balance Status Field (#449) in File 410 for
123 ; purchase order amendment
124 Q:$G(PRCFA("RETRAN"))=1
125 W !!,"...updating running balance status fields in 410...FOR AMENDMENT"
126 D EDIT410(NEW410,"O")
127 QUIT
128 ;
129EDIT410(TRDAIEN,TRSTAT) ; Edit running balance status and running balance quarter fields in 410
130 D ERS410^PRC0G(TRDAIEN_"^"_TRSTAT)
131 QUIT
132 ;
133 ; Message processing
134AMDAMT() ; Get dollar amount for AMENDMENT from amendment multiple
135 N SUBINFO,AMDAMT S SUBINFO="442.07^2^"_PRCFA("AMEND#")
136 D GENDIQ^PRCFFU7(442,PRCFA("PODA"),50,"IEN",SUBINFO)
137 S AMDAMT=$G(PRCTMP(442.07,PRCFA("AMEND#"),2,"E"))
138 Q AMDAMT
139AMDAMT1() ; Get dollar amount for AMENDMENT from zero node
140 N AMDAMT
141 S AMDAMT=-$S($P(PRCFMO,"^",12)="N":$P(PO(0),"^",16),1:$P(PO(0),"^",15))
142 Q AMDAMT
143MSG1 ;
144 K MSG W !
145 S MSG(1)="The Obligation Processing Date is not a valid date for this transaction."
146 S MSG(2)="Please enter a date which matches the requests or p.o. quarter."
147 D EN^DDIOL(.MSG) K MSG W !
148 QUIT
Note: See TracBrowser for help on using the repository browser.