source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAFUT.m@ 1261

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1PRCAFUT ;WASH-ISC@ALTOONA/CLH-FMS Utilities ;10/8/96 10:50 AM
2V ;;4.5;Accounts Receivable;**5,39,64,92,104,169,188,194,220,231**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4CPLK(PRCABN) ;get control point from file 430 and set DR string to edit CP data
5 N DR,X,Y,QUIT,FUND,FTBL,CAT,CATTYP,CATTYPE,CP,BBFY,EBFY,DIC,BGFY,CPTBL,CC,SCC,EXIT,FYERROR
6 K PRCA("EXIT")
7 S PRCA("SITE")=$S($G(PRCABN):$P($P($G(^PRCA(430,PRCABN,0)),"^"),"-"),1:$$SITE^RCMSITE)
8 S CP=$P($G(^PRCA(430,PRCABN,11)),U)
9 S CAT=+$P($G(^PRCA(430,PRCABN,0)),U,2),CATTYP=$P($G(^PRCA(430.2,CAT,0)),U,13)
10 I CAT>39,CAT<45 D G END
11 .S TYPE="09" D CHKELEM,REV Q:$G(PRCA("EXIT"))
12 .S DR="257///^S X=$G(PRCA(""SITE""))"
13 .;I CAT'=42 S DR=DR_";258////1"
14 .D DIE
15 .Q
16 D TYPE Q:$D(PRCA("EXIT"))
17 I CATTYP=2 K PRCA("EXIT") D G END
18 . ;reibursement logic (if there is such a thing)
19 . S DR="203" D DIE K DR I $D(Y) Q
20 . I '$D(FUND) S FUND=$P($G(^PRCA(430,PRCABN,11)),U,17) D I FUND=-1 S PRCA("EXIT")="" Q
21 .. N X,Y,DIC
22 .. S X=FUND,DIC="^PRCD(420.14,",DIC(0)="XMNZ",DIC("B")=FUND D ^DIC
23 .. I +Y<0 D FUND^PRCAFBDU D Q:FUND=-1
24 ... S DIC="^PRCD(420.14,",DIC(0)="AEMNQZ",DIC("A")="FUND: ",DIC("B")=FUND
25 ... D ^DIC
26 ... S:+Y<0 FUND=-1 Q
27 .. S FUND=Y
28 .. S BBFY=$E($P(Y(0),U,3),3,4),EBFY=$E($P(Y(0),U,4),3,4)
29 ..Q
30 .S PRCABN(1)=$O(^PRCA(430,+PRCABN,2,0))
31 .S PRCABN(2)=$G(^PRCA(430,+PRCABN,2,PRCABN(1),0))
32 .S PRCABN(4)=+$G(PRCABN(2))
33 .S X=BBFY D ^%DT S PRCABN(3)=$E(Y,1,3)
34 .K ^PRCA(430,PRCABN,2,PRCABN(1),0)
35 .K ^PRCA(430,PRCABN,2,"B",PRCABN(4),PRCABN(1))
36 .S ^PRCA(430,PRCABN,2,PRCABN(3),0)=PRCABN(2)
37 .S $P(^PRCA(430,PRCABN,2,PRCABN(3),0),"^")=BBFY
38 .S ^PRCA(430,PRCABN,2,"B",BBFY,PRCABN(3))=""
39 .D DOCREQ^PRC0C(+FUND,"REV","FTBL")
40 . I '$D(FTBL) S PRCA("EXIT")=1 D Q
41 .. W !,*7,"FMS REQUIRED FIELDS missing. Edit the IFCAP REQUIRED FIELDS table",!,"for FUND/FY combination."
42 .. Q
43 . S DR="259////^S X=CAT;257////^S X=$G(PRCA(""SITE""));201////^S X=BBFY;202////^S X=$S($G(EBFY)'=BBFY:EBFY,1:"""")"
44 . D DR
45 . Q
46 ;Ask Beginning/end budget fiscal year
47 D FY^PRCAFUT1
48 I $D(FYERROR) S PRCA("EXIT")=1 Q
49 ;S BGFY=$P(^PRCA(430,PRCABN,0),U,10),BGFY=$$FY^RCFN01(BGFY)
50 S DR="250;I '$D(CPTBL) D CPTBL^PRCAFUT;259////^S X=CAT;204////^S X=$P(CPTBL,U);206////^S X=$P(CPTBL,U,3)"
51 S DR=DR_";203////^S X=$P(CPTBL,U,5);201////^S X=$E($P(CPTBL,U,6),3,4)"
52 S DR(1,430,1)="202////^S X=$S($P(CPTBL,U,7)'=$P(CPTBL,U,6):$E($P(CPTBL,U,7),3,4),1:"""")"
53 S DR(1,430,2)="261////^S X=$P(CPTBL,U,10)"
54 S DA=PRCABN D ^DIE K DR
55 I $D(Y) S PRCA("EXIT")=1 Q
56 K DR
57 D FTBL Q:'$D(FTBL)
58 S (X,PRCABN(1))=$E($P(CPTBL,U,6),3,4)
59 D ^%DT S PRCABN(2)=$E(Y,1,3)
60 S PRCABN(3)=$O(^PRCA(430,+PRCABN,2,0))
61 S PRCABN(4)=$G(^PRCA(430,+PRCABN,2,PRCABN(3),0))
62 S PRCABN(5)=$E(PRCABN(4),1,2)
63 K ^PRCA(430,PRCABN,2,PRCABN(3),0)
64 K ^PRCA(430,PRCABN,2,"B",PRCABN(5),PRCABN(3))
65 S ^PRCA(430,PRCABN,2,PRCABN(2),0)=PRCABN(4)
66 S $P(^PRCA(430,PRCABN,2,PRCABN(2),0),"^")=PRCABN(1)
67 S ^PRCA(430,PRCABN,2,"B",PRCABN(1),PRCABN(2))=""
68 S $P(^PRCA(430,PRCABN,2,0),"^",3)=PRCABN(2)
69 Q
70FTBL S FUND=$$FUND^PRC0C($P(CPTBL,U,5),$P(CPTBL,U,6))
71 D DOCREQ^PRC0C(+FUND,"SPE","FTBL")
72 I '$D(FTBL) W !!,*7,"UNABLE TO GET FMS-LINE FUND ACCOUNTING INFORMATION. CHECK CONTROL POINT." H 5 S PRCA("EXIT")=1 Q
73 S DR="257////^S X=$G(PRCA(""SITE""))"
74DR I $$INTEG^RCFN01($G(PRCA("SITE"))) S DR=DR_";260"
75 I $G(FTBL("AO"))="Y" S DR=DR_";204"
76 I $G(FTBL("FCPRJ"))="Y" S DR=DR_";I '$D(CPTBL) D CPTBL^PRCAFUT;206////^S X=$P(CPTBL,U,3)"
77 I $G(FTBL("CC"))="Y" S DR=DR_";251;252////^S X=$G(SCC)"
78 I $G(FTBL("BOC"))="Y" S DR=DR_";253"
79 I $G(FTBL("SBOC"))="Y"!(CAT=20) S DR=DR_";254"
80 I $G(FTBL("JOB"))="Y" S DR=DR_";261"
81 I $G(FTBL("RC"))="Y" S DR=DR_";263"
82 I $G(FTBL("REV"))="Y" D DIE Q:$G(PRCA("EXIT")) D REV Q:$G(PRCA("EXIT"))
83 I $G(FTBL("SREV"))="Y" S DR=$S(DR="":"256",1:DR_";256")
84 I $G(FTBL("OC"))="Y" S DR=$S(DR="":"205",1:DR_";205")
85 I DR'="" D DIE
86 Q
87DIE S DA=PRCABN,DIE="^PRCA(430," D ^DIE
88END I $D(Y) S PRCA("EXIT")=1
89 K DR Q
90 ;
91RECTYP(BN) ;Refund or reimbursement
92 I '$D(BN),'$D(^PRCA(430,BN,0)) Q -1
93 Q $P($G(^PRCA(430,BN,11)),U,10)
94 ;
95REV ;lookup revenue by calling "C" xref
96 N DS,DIC,DIBTDH,HELP,I,IAT,OUT,RV,X,Y
97 S OUT=0,RV=$P($G(^PRCA(430,PRCABN,11)),U,6)
98 F D Q:OUT
99 .W !,"REVENUE SOURCE: "_$S(RV'="":RV_"// ",1:"") R X:DTIME
100 .I $E(X)="?",X?."?" D @($S($L(X)=1:"REVH1",1:"REVH2")) S DIC=347.3,DIC(0)="QE" D ^DIC Q:Y<1 Q
101 .I $E(X)="^",X?."^" S OUT=1,PRCA("EXIT")=1 Q
102 .I X="@" W "?? Required" Q
103 .I X="",RV'="" S OUT=1 Q
104 .I X="",RV="" W "??" D REVH1 Q
105 .I $D(^RC(347.3,"B",X)) D Q
106 ..S DS=$P($G(^RC(347.3,+$O(^RC(347.3,"B",X,0)),0)),U,2),IAT=$P(^(0),U,3)
107 ..W " "_DS W:IAT " INACTIVE" D REVDIE
108 .S DIC="^RC(347.3,",DIC(0)="QE",D="C" D IX^DIC I Y<1 D REVH1 Q
109 .S X=$P(Y,U,2) D REVDIE
110 S DR=""
111 Q
112REVDIE S DA=PRCABN,DIE="^PRCA(430,",DR="255///"_X D ^DIE I $G(X)'="" S OUT=1 Q
113 D REVH1 Q
114REVH1 S HELP("DIHELP",1)=$G(^DD(430,255,3)) D MSG^DIALOG("WH","",70,5,"HELP") Q
115REVH2 D HELP^DIE(430,"",255,"D","HELP"),MSG^DIALOG("WH","",70,8,"HELP") Q
116 ;
117FUND ;get fund
118 N DIC,Y
119 S DIC="^PRCD(420.14,",DIC(0)="EMNQZ"
120 D ^DIC
121 I $D(DUOUT)!$D(DTOUT) S PRCA("EXIT")=1 Q
122 Q:+Y<0
123 S FUND=Y
124 S BBFY=$E($P(Y(0),U,3),3,4),EBFY=$E($P(Y(0),U,4),3,4)
125 Q
126 ;
127DISPLACC ;display account information
128 Q:'$D(PRCABN) NEW DIC,L,FR,TO,FLDS,IOP,X
129 R !!,"Press <RETURN> to continue: ",X:60
130 I X["^" S PRCA("EXIT")="" Q
131 S IOP=IO(0),DIC="^PRCA(430,",FLDS="[PRCA DISP AUDIT2]",(FR,TO)=PRCABN,L=0,BY="@NUMBER" D EN1^DIP
132 Q
133 ;
134CP ;lookup control point
135 N DIC
136 S DIC="^PRC(420,"_$S($D(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,",DIC(0)="EMNQ",X=CP
137 D ^DIC
138 I +Y<0 K X,CP Q
139 S CP=+Y
140 Q
141 ;
142CC ;cost center
143 G CC^PRCAFBDU
144 ;
145BOC ;budget object code
146 G BOC^PRCAFBDU
147 ;
148TYPE ;ask if bill is a refund or reimbursement
149 W !!,"Building FMS Accounting Elements...",!
150 N DIR,Y,TYPE
151 I +$G(CAT)=1 S CAT="02",CATTYPE=2 D CHKELEM Q
152 I +$G(CAT)=10 S CAT=50,CATTYPE=2 D CHKELEM Q
153 D BDTRANS^PRCAFBDU
154 Q:$D(PRCA("EXIT"))
155 S CATTYP=$S(TYPE="01":"1",TYPE="20":"1",1:"2")
156 S CAT=TYPE ; I CAT>2 S CAT=$S(CAT=4:"20",1:"9")
157 D CHKELEM
158 Q
159 ;
160CHKELEM ;check for correct accounting line data
161 N I
162 Q:'$D(^PRCA(430,PRCABN,11))
163 I $G(CATTYP)=1 D Q
164 . F I=6,7 S $P(^PRCA(430,PRCABN,11),U,I)=""
165 . Q
166 Q:$G(TYPE)=10
167 F I=1:1:5,11:1:16,18:1:21 S $P(^PRCA(430,PRCABN,11),U,I)=""
168 S $P(^PRCA(430,PRCABN,11),U,15)="05"
169 Q
170CPTBL ;build CP table
171 S:'$D(BGFY) BGFY=$$FY^RCFN01(DT)
172 S BGFY(1)=$S(BGFY>50:19,1:20)
173 S CPTBL=$$ACC^PRC0C($G(PRCA("SITE")),+CP_U_BGFY_U_BGFY(1)_BGFY)
174 I '$D(CPTBL) S CPTBL=""
175 Q
176 ;
177CPHLP ;executable help for cp prompt
178 N DIC,X,Y
179 S DIC="^PRC(420,"_$S($D(PRCA("SITE")):PRCA("SITE"),1:$$SITE^RCMSITE)_",1,",DIC(0)="EMQ",X="?" D ^DIC
180 Q
181 ;
182FND(BILL) ;Get fund for a bill
183 I '$D(^PRCA(430,BILL,0)) Q -1
184 I $D(^PRCA(430,BILL,11)),$P(^(11),"^",17)'="" Q $P(^(11),"^",17)
185 I $P(^PRCA(430,BILL,0),"^",18)'="" Q $E($P(^(0),"^",18),4,9)
186 Q -1
187 ;
Note: See TracBrowser for help on using the repository browser.