source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFDA.m@ 1552

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

initial load of WorldVistAEHR
File size: 8.2 KB
Line 
1PRCFDA ;WISC@ALTOONA/CTB-PROCESS PAYMENT IN ACCTG ;2/9/96 15:58 [2/1/99 2:26pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N PRCFCIDA,PRCFFLG K ^TMP("PRCFDA",$J,"LIQ")
5 Q:$D(PRCFA("ERROR PROCESSING")) S PRCF("X")="AS" D ^PRCFSITE Q:'%
6 S DIC("S")="S ZX=^(0),ZX2=$G(^(2)) I $P(ZX2,U)=15,$P(ZX,U,15)]"""""
7 S DIC=421.5,DIC(0)="AEMNZ" D ^DIC K DIC,ZX2,ZX
8 I Y<1!$D(DTOUT)!$D(DUOUT) K PRC,C,PRCRI,X,Y,% G:$$NUMSTA>1&'$D(DTOUT)&'$D(DUOUT) PRCFDA K DTOUT,DUOUT Q
9EN S (PRCF("CIDA"),PRCFDICA)=+Y,PRC("SITE")=$P(^PRCF(421.5,PRCF("CIDA"),1),U,2)
10 G:$D(PRCFA("ERROR PROCESSING")) B
11 L +^PRCF(421.5,PRCF("CIDA")):5 E W !,"This invoice is being edited by someone else, please try later!" G EX^PRCFDA2
12 S:$P($G(^PRCF(421.5,PRCF("CIDA"),1)),U,7)]"" PRCFA("ERROR PROCESSING")=2
13 I '$D(PRCFA("ERROR PROCESSING")),$$CLSD1358^PRCFDE2($P(Y(0),U,7),1) D G:%'=1 EX^PRCFDA2
14 . W ! S %A="Do you wish to continue processing this invoice now"
15 . S %B="",%=2 D ^PRCFYN
16 S DIR(0)="YA",DIR("A")="Do you wish to view current information for this invoice? "
17 S DIR("B")="NO" D ^DIR K DIR I $D(DIRUT)!$D(DIROUT)!$D(DUOUT) G EX^PRCFDA2
18 I Y=1 D I Y'=1!$D(DIRUT)!$D(DIROUT)!$D(DUOUT) G EX^PRCFDA2
19 . N PRCRI,RECORD,RECORD1,DR,DIQ,DA,DIC,DIR
20 . S DA=PRCF("CIDA"),DIC="^PRCF(421.5,",DIQ(0)="C",PRCF("VIEW")="" W @IOF
21 . D EN^DIQ K PRCF("VIEW")
22 . S DIR(0)="YA",DIR("A")="Is this the correct invoice? ",DIR("B")="YES" D ^DIR
23B I $P(^PRCF(421.5,PRCF("CIDA"),0),U,6)="X" D G:Y<0 EX^PRCFDA2
24 . S %A="This invoice is flagged as MONEY MANAGEMENT EXEMPT. Return to Voucher Audit for review/correction"
25 . S %B="",%=1 D ^PRCFYN Q:%=2
26 . I %=1 S X=0 D STATUS^PRCFDE1
27 . S Y=-1 Q
28 ;GET AMOUNT CERTIFIED
29 S PRCFD("CAMT")=$P(^PRCF(421.5,PRCF("CIDA"),0),U,15)
30 S PRCF("PODA")=$P(^PRCF(421.5,PRCF("CIDA"),0),U,7)
31 I PRCF("PODA")]"" D
32 . S PRCFD("PAYMENT")="",PRCFA("PODA")=PRCF("PODA")
33 . S PRCFA("REF")=$P($G(^PRCF(421.5,PRCF("CIDA"),2)),U,2)
34 . S PRCFA("LIQAMT")=PRCFD("CAMT")/100
35 . S PRCFX("SITE")=PRC("SITE"),PRCFX("PER")=PRC("PER")
36 . S PRCFX("FY")=PRC("FY"),PRCFX("PARAM")=PRC("PARAM")
37 . D:'$D(PRCFA("ERROR PROCESSING")) ^PRCEFIS4 I '$D(PRC("SITE")) D
38 . . S PRC("SITE")=PRCFX("SITE"),PRC("PER")=PRCFX("PER")
39 . . S PRC("FY")=PRCFX("FY"),PRC("PARAM")=PRCFX("PARAM")
40 . . Q
41 . K PO,PODA,PRCFD("PAYMENT"),PRCFA("PODA"),PRCFA("REF"),PRCFA("LIQAMT")
42 . ; Build table of FMS Line Nos. & Obligation Amts. by BOCs:
43 . K PRCFX N BOC,FMSLN,IEN S BOC=""
44 . F S BOC=$O(^PRC(442,PRCF("PODA"),22,"B",BOC)) Q:BOC="" S IEN="" D
45 . . I BOC>0 F S IEN=$O(^PRC(442,PRCF("PODA"),22,"B",BOC,IEN)) Q:IEN="" D
46 . . . S FMSLN=$P($G(^PRC(442,PRCF("PODA"),22,IEN,0)),U,2,3)
47 . . . S PRCFX("SA",BOC,IEN)=FMSLN
48 . . . Q
49 . . Q
50 . S PRCFX("SHBOC")=+$G(^PRC(442,PRCF("PODA"),23))
51 . S PRCFX("SHAMT")=+$P(^PRC(442,PRCF("PODA"),0),U,13)
52 . I PRCFX("SHBOC") S I="" F S I=$O(PRCFX("SA",PRCFX("SHBOC"),I)) Q:I="" I $P(PRCFX("SA",PRCFX("SHBOC"),I),U,2)=991 S $P(PRCFX("SA",PRCFX("SHBOC"),I),U,3)=PRCFX("SHAMT")
53 . Q
54 S PRCF("CAMT")=$P(^PRCF(421.5,PRCF("CIDA"),0),U,15)
55 D SUMM
56BOC ; Ask for BOC
57 N CNT,CNT1,PRCFEEE,PRCFEX,PRCFEXIT,PRCFN,PRCFNO
58 S PRCFNO="",CNT1=0
59 F S PRCFNO=$O(PRCFX("SA",PRCFNO)) Q:PRCFNO="" S CNT1=CNT1+1,BOC=PRCFNO
60 I CNT1=1 D ASK2^PRCFDA2 Q:$D(DIRUT) S DA=$G(PRCFNUM) G:$G(PRCFEXIT)&($G(PRCFFLG)) DOC G:'$G(PRCFFLG) EXIT
61 I CNT1<1 W !!?5,"There are no BOCs on this obligation, processing terminated." G EX^PRCFDA2
62 I CNT1>1 D ASK^PRCFDA2 Q:$D(DIRUT) S DA=$G(PRCFNUM) G:$G(PRCFEX)&($G(PRCFFLG)) DOC G:'$G(PRCFFLG) EXIT
63 I $G(PRCFCIDA)']"",($G(PRCF("CIDA"))']"") W !!?15,"Exiting." Q
64 I $G(PRCF("CIDA"))']"" S PRCF("CIDA")=PRCFCIDA
65 I '$D(^PRCF(421.5,PRCF("CIDA"),5,0)) S ^PRCF(421.5,PRCF("CIDA"),5,0)="^"_$P(^DD(421.5,41,0),U,2)
66 I '$D(^PRCF(421.5,PRCF("CIDA"),5,$G(PRCFNUM),0)) D
67 . S ^PRCF(421.5,PRCF("CIDA"),5,"B",BOC,PRCFNUM)=""
68 . S $P(^PRCF(421.5,PRCF("CIDA"),5,0),U,3)=PRCFNUM
69 . S $P(^PRCF(421.5,PRCF("CIDA"),5,0),U,4)=$P(^PRCF(421.5,PRCF("CIDA"),5,0),U,4)+1
70 . S ^PRCF(421.5,PRCF("CIDA"),5,PRCFNUM,0)=BOC
71 S DA(1)=PRCF("CIDA")
72 S DIE="^PRCF(421.5,"_DA(1)_",5,"
73 S DR=".01///^S X=BOC;4///^S X=$P(PRCFX(""SA"",BOC,PRCFNUM),U,2)"
74 ; if one BOC has goods/serv and shipping, stuff corrected amt in
75 ; accouting line amount
76 I CNT1=1 D
77 . S PRCFEEE=0 S PRCFEEE=$O(PRCFX("SA",BOC,PRCFEEE)) I PRCFEEE]"",($O(PRCFX("SA",BOC,PRCFEEE))]"") D
78 . . I $P(PRCFX("SA",BOC,PRCFNUM),U,2)'=991 S PRCFN=PRCF("CAMT")-$P(^PRCF(421.5,PRCF("CIDA"),0),U,14)
79 . . I $P(PRCFX("SA",BOC,PRCFNUM),U,2)=991 S PRCFN=$P(^PRCF(421.5,PRCF("CIDA"),0),U,14)
80 . . S DR=DR_";1///^S X=$G(PRCFN)/100"
81 . . Q
82 . Q
83 D ^DIE I $D(Y)!$D(DTOUT) G OT
84 K DA,DIE,DR
85EDIT ; edit the FMS line entry in 421.5
86 S DA=PRCFNUM
87 S DA(1)=PRCF("CIDA")
88 S DIE="^PRCF(421.5,"_DA(1)_",5,"
89 S PRCFA("LNO")=+$P(PRCFX("SA",BOC,PRCFNUM),U,2)
90 W !,"FMS Line # ",PRCFA("LNO")
91 S PRCFA("AMT")=$FN($P(PRCFX("SA",BOC,PRCFNUM),U),"",2)
92 W !,"OBLIGATION AMOUNT: ",PRCFA("AMT")
93 S DR="1//^S X=$S($G(PRCF(""CAMT""))/100>PRCFA(""AMT""):PRCFA(""AMT""),1:$G(PRCF(""CAMT""))/100)"
94 D ^DIE K DR I $D(Y)!$D(DTOUT) G OT
95 S X=$FN(X,"",2)
96 S PRCFA("LAMT")=X
97 D DISC^PRCFDT
98 I PRCFA("LIQ")>PRCFA("AMT") W !,"Warning - Computed Liquidation amt of $",$FN(PRCFA("LIQ"),"",2)," exceeds",!?5,"total obligated amt of $",$FN(PRCFA("AMT"),"",2)," for BOC ",BOC," on ",$P($G(^PRCF(421.5,PRCF("CIDA"),1)),U,3),"."
99 I PRCFA("LIQ")'=PRCFA("AMT") S DR="2////@" D ^DIE K DR
100 S DR="2//^S X=$G(PRCFA(""LIQ""))" D ^DIE K DR I $D(Y)!$D(DTOUT) G OT
101 S PRCFA("LIQ")=X,PRCFA("PF")=""
102 I +PRCFA("AMT")=+PRCFA("LIQ") S PRCFA("PF")="F"
103 I +PRCFA("AMT")>+PRCFA("LIQ") S PRCFA("PF")="P"
104 S DR="3//^S X=$G(PRCFA(""PF""))" D ^DIE K DR I $D(Y)!$D(DTOUT) G OT
105 D SUM^PRCFDT I '$G(OK) W !!?2,"****WARNING**** - Certified Invoice total $",$FN(PRCF("CAMT")/100,"",2)," does not match sum of",!,"Line Amounts: $",$FN(PRCF("TAMT"),"",2)
106 I '$G(OK) W !?7,"If you believe that the Total Invoice Amount Certified for",!,"payment is incorrect, the invoice should be returned to voucher audit",!,"for review." G BOC
107 I +PRCF("TAMT")=0 W !?2,"There are no Line Amounts - FMS will not accept this!"
108 G DOC
109DOC ;PROCESS FMS DOC
110 I '$$OBLIG^PRCFDT(.PRC10DA) D G EX^PRCFDA2
111 . I '$D(PRCF("PO")) S PRCF("PO")=$P($G(^PRC(442,PRCF("PODA"),0)),U,1)
112 . S X=" An original FMS SO or MO document could not be found for "
113 . S X=X_PRCF("PO")_".*" D MSG^PRCFQ
114 . S X=" Please review obligation history for this Purchase Order.*"
115 . D MSG^PRCFQ,PAUSE^PRCFDPVU
116 . Q
117 ;D AUTOACCR^PRCFDA4 G:$D(Y)!$D(DTOUT) EX^PRCFDA2 ;per Lyford SOAR
118 K %A,%B S %A="OK to process this payment to FMS",%B="",%=2
119 D ^PRCFYN G OT:%<1
120 I %=2,($G(PRCFFLG)=2) G OT
121 I %=2 G BOC
122 G ^PRCFDA2
123SUMM ; Display Accounting Summary - Entry Point from Input Template
124 D:$D(PRCFX("SA"))
125 . N BOC,I,J,SHIP,SUBTOT
126 . W !,"Unliquidated obligation amounts and BOCs on this order are:"
127 . I $G(PRCUNLIQ)]"" D
128 . . S SUBTOT=PRCUNLIQ
129 . . S BOC=$O(PRCFX("SA",0)) S BOC=$P($G(^PRCD(420.2,+BOC,0)),U)
130 . . W:$G(SUBTOT)]"" !,$J("$"_$FN(SUBTOT,",",2),10) S SUBTOT=0
131 . . W:$G(BOC)]"" ?12,BOC
132 . . Q
133 . I $G(PRCUNLIQ)']"" S I="",SUBTOT=0 F S I=$O(PRCFX("SA",I)) Q:I="" D
134 . . S J="" F S J=$O(PRCFX("SA",I,J)) Q:J="" D
135 . . . S SUBTOT=SUBTOT+$P(PRCFX("SA",I,J),U)
136 . . . S BOC=$P($G(^PRCD(420.2,+I,0)),U),SHIP=$P(PRCFX("SA",I,J),U,3)
137 . . W:I !,$J("$"_$FN(SUBTOT,",",2),10) S SUBTOT=0
138 . . S:SHIP BOC=$E(BOC,1,30) W ?12,BOC
139 . . W:SHIP ?40," **(Includes $",$FN(PRCFX("SHAMT"),",",2)
140 . . W:SHIP " shipping.)"
141 . . Q
142 . K PRCUNLIQ
143 . W !,"Total Invoice Amount Certified for Payment=$"
144 . W $J(PRCF("CAMT")/100,0,2)
145 . Q
146 Q
147OT D UNP K ^TMP("PRCFDA",$J,"LIQ")
148 S X=" <Option Terminated.>*" D MSG^PRCFQ G EX^PRCFDA2
149NUMSTA() ;Determine number of unique stations in IFCAP system
150 N X,I S X="",I=0
151 F S X=$O(^PRC(411,"B",X)) Q:X'?1.N S I=I+1
152 Q I
153EXIT ; IF NO fms line BOC chosen,display message and exit
154 W ! D G EX^PRCFDA2
155 . S X=" Edit exited abnormally. Action terminated.*" D MSG^PRCFQ
156 . S %A="Do you want to return this invoice to Voucher Audit"
157 . S %B="",%=2 D ^PRCFYN I %=1 S X=10 D STATUS^PRCFDE1
158 . Q
159 Q
160UNP ; Check for posted liquidation amounts and unpost
161 S X=$G(^TMP("PRCFDA",$J,"LIQ"))
162 Q:X="" N DA,DIK,LAMT,PO,PRCFA,ZX1
163 S LAMT=$P(X,U,1),PRCFA("PODA")=$P(X,U,2),ZX1=$P(X,U,3),DA=$P(X,U,4)
164 S DIK="^PRC(424," D ^DIK
165 D POST^PRCH58LQ(.PRCFA,.LAMT,.PO)
166 W !!,"Liquidation # ",ZX1," for ",$FN(LAMT,",",2)," has been deleted and unposted."
167 Q
Note: See TracBrowser for help on using the repository browser.