source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCD3A.m@ 767

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

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1PRCD3A ;WISC/PLT,DGL-Generate FUND FILE & REQUIRED TABLE for a new fical year ; [9/24/98 9:30am]
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 PRCA,PRCB,PRCC,PRCRI,PRCQT
7 N A,B,C,X,Y,Z
8 F S PRCQT=1 D LG1 QUIT:PRCQT["^" D:$P(PRCE,"^",2) LG2 QUIT
9EXIT QUIT
10LG1 S PRCD=1+$$DATE^PRC0C(+$H,"H"),$P(PRCD,"^",2)="NO"
11 S PRCE=PRCD,$P(PRCE,"^",2)=0
12Q1 S Y(1)="ENTER 4-DIGIT BEGINNING BUDGET FISCAL YEAR"
13 D FT^PRC0A(.X,.Y,"For Beginning Budget Fiscal Year","O^4:4^I X'?4N K X",$P(PRCD,"^"))
14 I X=""!(X["^")!'Y S PRCQT="^" G LG1X
15 I PRCD-Y<-1 D EN^DDIOL("It is too early to generate fund/required table for this year.") G Q1
16 I PRCD-Y>1 D EN^DDIOL("It is too late to generate fund/required table for this year.") G Q1
17 S $P(PRCE,"^")=Y
18Q2 S X(1)="Note: All ACTIVE SINGLE-YEAR FUND CONTROL POINTS will be initialized"
19 S X(2)=" to enable the new fiscal year FMS/820 RECORDS to post correctly."
20 D YN^PRC0A(.X,.Y,"Ready to Generate the fund code & Required Table for "_$P(PRCE,"^"),"O","NO")
21 I X=""!(X["^")!'Y S PRCQT="^" G LG1X
22 S $P(PRCE,"^",2)=Y
23LG1X QUIT
24 ;
25LG2 ;
26 D FUND($P(PRCE,"^"))
27 S PRCRI(420)=0,PFLG=0
28 F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420) I PRCRI(420) W !,"Station: ",PRCRI(420) D
29 . S PRCRI(420.01)=0
30 . F S PRCRI(420.01)=$O(^PRC(420,PRCRI(420),1,PRCRI(420.01))) QUIT:PRCRI(420.01)>9998!'PRCRI(420.01) D
31 . . S X=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0))
32 . . I X="" W !,"** No zero node exists for IEN ",PRCRI(420.01) S PFLG=PFLG+1 QUIT
33 . . I PRCRI(420.01)'=(X+0) W !,"** IEN ",PRCRI(420.01)," does not match FCP ",$P(X,U,1) S PFLG=PFLG+1 QUIT
34 . . I '$P(X,U,19) W !,$P(^(0),"^") D FCP(PRCRI(420),$E(PRCE,3,4),PRCRI(420.01))
35 . QUIT
36 I PFLG>0 W !!,"** NOTE: There were ",PFLG," entries with errors.",!," Please contact IRM about these discrepancies.",!," See patch PRC*5*168 documentation for instructions.",!
37 D EN^DDIOL("ALL DONE! ALL DONE! ALL DONE!")
38 QUIT
39 ;
40FCP(PRCA,PRCB,PRCC) ;set entry in file 420.141
41 ;prca=station #, prcb=fiscal year(2-digit), prcc=fcp #
42 N PRCBBFY
43 N A,B,C
44 S PRCBBFY=$$BBFY^PRCSUT(PRCA,PRCB,PRCC,1)
45 S C=$$ACC^PRC0C(PRCA,PRCC_"^"_PRCB_"^"_PRCBBFY)
46 QUIT:$P(C,"^",6)'=$P(C,"^",7)
47 S A=$$FMSACC^PRC0D(PRCA,C)
48 S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
49 I 'B S B=$$A420D141^PRC0F(A,PRCC) D EBAL^PRCSEZ(PRCA_"^"_PRCC_"^"_PRCB_"^1^0","C")
50 QUIT
51 ;
52FUND(PRCA) ;PRCA = BEGINNING BUDGET FISCAL YEAR (4-DIGIT)
53 N PRCRI,PRCLOCK,PRCFUND,PRCBBFY,PRCEBFY
54 D ICLOCK^PRC0B("^PRCD(420.14,")
55 S PRCBBFY=PRCA-1
56 S PRCFUND="" F S PRCFUND=$O(^PRCD(420.14,"UNQ",PRCFUND)) QUIT:PRCFUND="" D
57 . S PRCEBFY="" F S PRCEBFY=$O(^PRCD(420.14,"UNQ",PRCFUND,PRCBBFY,PRCEBFY)) QUIT:'PRCEBFY D
58 .. S PRCRI("420.14A")=0
59 .. F S PRCRI("420.14A")=$O(^PRCD(420.14,"UNQ",PRCFUND,PRCBBFY,PRCEBFY,PRCRI("420.14A"))) QUIT:'PRCRI("420.14A") D AFUND(PRCRI("420.14A"))
60 .. QUIT
61 . QUIT
62 D DCLOCK^PRC0B("^PRCD(420.14,")
63 QUIT
64 ;
65AFUND(PRCRI) ;ADD NEW FUND ENTRY
66 N PRCA,PRCB
67 N A,B,C
68 S PRCA=^PRCD(420.14,PRCRI,0)
69 ;fund with status 'O' not generated
70 S A=$P(PRCA,"^",6),A=$G(^PRCD(420.1999,A,0)) QUIT:$P(A,"^",4)="O"
71 S $P(PRCA,"^",3)=$P(PRCA,"^",3)+1,$P(PRCA,"^",4)=$P(PRCA,"^",4)+1
72 S PRCRI(420.14)=$O(^PRCD(420.14,"UNQ",$P(PRCA,"^"),$P(PRCA,"^",3),$P(PRCA,"^",4),""))
73 D:'PRCRI(420.14)
74 . D EN^DDIOL(PRCRI_" "_$P(PRCA,"^")_" "_$P(PRCA,"^",2)_" "_$P(PRCA,"^",3)_" - "_$P(PRCA,"^",4))
75 . K X S X=$P(PRCA,"^")
76 . S X("DR")="2///"_$P(PRCA,"^",3)_";3///"_$P(PRCA,"^",4)_";4.5///"_$P(PRCA,"^",7)_";4.7///"_$P(PRCA,"^",5)_";5///"_$P(PRCA,"^",6)_";1///"_$P(PRCA,"^",2)
77 . S Y="" D ADD^PRC0B1(.X,.Y,"420.14;^PRCD(420.14,") W " ",$P(Y,"^")
78 . S PRCRI(420.14)=+Y
79 . QUIT
80 D:PRCRI(420.14)&PRCRI REQ(PRCRI,PRCRI(420.14))
81 QUIT
82 ;
83REQ(PRCA,PRCB) ;copy fund required table from fund code RID# PRCA to PRCB
84 N PRCRI,PRCC
85 S PRCRI(420.18)=""
86 F S PRCRI(420.18)=$O(^PRCD(420.18,"B",PRCA,PRCRI(420.18))) QUIT:'PRCRI(420.18) D
87 . S PRCC=$G(^PRCD(420.18,PRCRI(420.18),0)) QUIT:'PRCC
88 . QUIT:$O(^PRCD(420.18,"UNQ",PRCB,$P(PRCC,"^",2),$P(PRCC,"^",3),""))
89 . W !,PRCC
90 . S $P(PRCC,"^",1)=PRCB
91 . W " *** ",PRCC
92 . K X S X=PRCB
93 . S X("DR")="1////"_$P(PRCC,"^",2)_";2////"_$P(PRCC,"^",3)_";3////"_$P(PRCC,"^",4)
94 . S Y="" D ADD^PRC0B1(.X,.Y,"420.18;^PRCD(420.18,") W " ",$P(Y,"^")
95 . QUIT
96 QUIT
Note: See TracBrowser for help on using the repository browser.