source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1D.m@ 1365

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

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1PRCB1D ;WISC/PLT-RESET FCP YEARLY FMS ACCOUNTING ELEMENT AND BBFY ACT CODE ; 03/14/94 2:06 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6EN N PRCRI,PRC,PRCZ,PRCDD,PRCDI,PRCQT,PRCB,PRCB1,PRCD,PRCD1,PRCSTU
7 N A,B,C,X,Y
8 F S PRCQT=1 D LG1 QUIT:PRCQT["^" D Q:PRCQT["^"&($G(PRCSTU)<2)
9 . F S PRCQT=2 D LG2 QUIT:PRCQT["^"
10 . QUIT
11EXIT QUIT
12 ;
13LG1 K PRC S PRCDI="420;^PRC(420,;" D
14 . S PRCSTU=0,PRCRI(411)=0 F S PRCRI(411)=$O(^PRC(411,PRCRI(411))) Q:'PRCRI(411) S:$D(^PRC(420,PRCRI(411),2,DUZ)) PRCSTU=PRCSTU+1_"^"_PRCRI(411)
15 I 'PRCSTU D EN^DDIOL("Station access is not allowed") S PRCQT="^" G LG1X
16 I +PRCSTU=1 S PRC("SITE")=$P(^PRC(420,+$P(PRCSTU,"^",2),0),"^") D EN^DDIOL("STATION: "_PRC("SITE")) G LG1E
17 S X("S")="I $D(^PRC(420,+Y,2,DUZ))"
18 D LOOKUP^PRC0B(.X,.Y,PRCDI,"ACEFNO","Select Station: ")
19 S:X=""!(X["^") PRCQT="^"
20 S PRC("SITE")=$P(Y,"^",2)
21LG1E S PRCRI(420)=+PRC("SITE"),PRCDI=PRCDI_PRCRI(420)_";"
22LG1X QUIT
23 ;
24LG2 ;
25 S $P(PRCDI,"~",2)="420.01;"_$P($P(PRCDI,"~"),";",2)_PRCRI(420)_",1,;"
26Q2 K PRCZ D EN^DDIOL($TR($J("",78)," ","-")) S X("S")="I ^(0)-9999"
27 D LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQS","Select Fund Control Point: ")
28 I Y<0!(X="") S PRCQT="^" QUIT
29 K X S PRCRI(420.01)=+Y,PRC("CP")=$P($P(Y,"^")," ")
30 S PRCDI=PRCDI_PRCRI(420.01)_";"
31 ;
32Q3 S E="O^2:4^K:X'?2N&(X'?4N) X",Y(1)="Enter a 2 or 4 digit year."
33 D FT^PRC0A(.X,.Y,"For Budget Fiscal Year",E,"")
34 G:X["^"!(X="") Q2
35 S PRC("FY")=$P($$YEAR^PRC0C(Y),"^",2),PRCRI(420.06)=PRC("FY")
36 S PRCD=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2))
37 ;I PRCD="" D EN^DDIOL(" The yearly FMS accounting elements are not in file yet.") G Q3
38 D DIS(PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY"))
39Q4 D YN^PRC0A(.X,.Y,"Reset the fiscal year "_PRC("FY")_" Suballowance Account","O","NO")
40 G:X["^"!(X="")!(Y<1) Q2
41 S PRCZ(4)=Y
42Q5 ;D SC^PRC0A(.X,.Y,"Select FMS SA-doc ACT code","OM^A:for suballowance account NOT in FMS yet;C:for suballowance account is in FMS","")
43 ;G:X["^"!(X="") Q2
44 S Y="C"
45 S PRCZ(5)=Y
46Q6 D YN^PRC0A(.X,.Y,"Ready to File","O","NO")
47 G:X["^"!(X="")!'Y Q2
48 I '$P(PRCB1,"^",11) D EN^DDIOL("BBFY missing in FCP set up") G Q2
49 S A=$$FUND^PRC0C($P(PRCB1,"^",10),$P(PRCB1,"^",11))
50 I 'A D EN^DDIOL("Fund code "_$P(PRCB1,"^",10)_" with beginning year "_$P(PRCB1,"^",11)_" is not in fund file (420.14)") G Q2
51 S PRC("BBFY")=$$BBFY^PRCSUT(PRCRI(420),PRC("FY"),PRCRI(420.01),1)
52 I $G(PRCZ(4))=1 D G:'$G(PRC("BBFY")) Q2
53 . S:$P(PRCD1,"^",10)="" $P(PRCD1,"^",10)=$P(PRCB1,"^",10) S A=$$FUND^PRC0C($P(PRCD1,"^",10),PRC("BBFY"))
54 . I 'A D EN^DDIOL("Fund code "_$P(PRCD1,"^",10)_" with beginning year "_PRC("BBFY")_" is not in fund file (420.14).") K PRC("BBFY")
55 . QUIT
56 S PRCLOCK=$P($P(PRCDI,"~",2),";",2)_PRCRI(420.01)_","
57 D ICLOCK^PRC0B(PRCLOCK,.Y)
58 I 'Y D EN^DDIOL("This FCP File is in use, please try later!") G Q2
59 D FILE D DCLOCK^PRC0B(PRCLOCK)
60 G Q2
61 ;
62FILE ;filing
63 I $G(PRCZ(4))=1 D
64 . ;delete old entry in file 420.141
65 . S C=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
66 . S A=$$FMSACC^PRC0D(PRC("SITE"),C)
67 . S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
68 . I B D DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)
69 . ;reset fiscal yearly accounting elements
70 . D:'$D(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06))) EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_PRCRI(420.06)_"^1^0","C")
71 . S ^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2)=PRCB
72 ;add new entry if action code is 'C', delete if code is A
73 S C=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
74 S A=$$FMSACC^PRC0D(PRC("SITE"),C)
75 S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
76 I $G(PRCZ(5))="A",B D DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)
77 I $G(PRCZ(5))="C",'B S B=$$A420D141^PRC0F(A,PRCRI(420.01))
78 QUIT
79 ;
80 ;PRCA data ^1=station, ^2=control point, ^3=fiscal year
81DIS(PRCA) ;display fms accounting data
82 D ;get acc element from fcp
83 . N Z
84 . S Z("ST")=PRCRI(420),Z("CP")=PRCRI(420.01)
85 . S PRCB=$$SUBALL^PRCSEZ
86 . QUIT
87 S PRCD=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2))
88 S PRCB1=$$ACC(PRCB),PRCD1=$$ACC(PRCD)
89 S A=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),5)),"^",8),$P(PRCB1,"^",11)=+$$DATE^PRC0C(A,"F")
90 S $P(PRCD1,"^",11)=PRC("FY")
91 W !,"CURRENT FCP ACCOUNTING ELEMENTS",?40,"FISCAL YEAR FCP ACCOUNTING ELEMENTS"
92 S B=0 F A=11,10,9,4:1:8 S B=B+1,C=$P("BBFY~FUND~APPROPRI~A/O~PROGRAM~FCP/PRJ~OBJECT CLASS~JOB","~",B) W !,$J(C,12),": ",$P(PRCB1,"^",A) S:C="BBFY" C="FISCAL YEAR" W ?40,$J(C,12),": ",$P(PRCD1,"^",A)
93 QUIT
94 ;
95ACC(A) ;get external format of prca
96 S:$P(A,"^",4) $P(A,"^",4)=$$NP^PRC0B("^PRCD(420.15,$P(A,""^"",4),",0,1)
97 S:$P(A,"^",5) $P(A,"^",5)=$$NP^PRC0B("^PRCD(420.13,$P(A,""^"",5),",0,1)
98 S:$P(A,"^",6) $P(A,"^",6)=$$NP^PRC0B("^PRCD(420.131,$P(A,""^"",6),",0,1)
99 S:$P(A,"^",7) $P(A,"^",7)=$$NP^PRC0B("^PRCD(420.132,$P(A,""^"",7),",0,1)
100 S:$P(A,"^",8) $P(A,"^",8)=$$NP^PRC0B("^PRCD(420.133,$P(A,""^"",8),",0,1)
101 QUIT A
102 ;
Note: See TracBrowser for help on using the repository browser.