source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1F.m@ 1432

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

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1PRCB1F ;WISC/PLT-IFCAP MONTHLY ACCRUAL ;9/13/96 16:21
2V ;;5.1;IFCAP;**64,72**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6 ;ZTQPARAM=999 if from schedule option
7EN ;monthly accrual
8 N PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCDES,PTCTD
9 N A,B,C
10 ; S PRCQCD=1 ;over lapping days
11 G Q4:$G(ZTQPARAM)=999!$G(ZTQUEUED)
12Q1 ;station
13 S PRCF("X")="AS" D ^PRCFSITE G:'% EXIT
14 S PRCRI(420)=+PRC("SITE"),PRCOPT=1
15Q4 ;accrual for month/year
16 S A=$$DATE^PRC0C("T","E")
17 S PRCTD=$P(A,"^",4)_"/"_$E($P(A,"^",3),3,4)_"^"_$P(A,"^",7)_"^"_$P(A,"^",8)
18 S A=$$DATE^PRC0C($P(A,"^",4)_"/1/"_$P(A,"^",3),"E"),$P(PRCTD,"^",4,6)=$P(A,"^",4)_"/"_$E($P(A,"^",3),3,4)_"^"_$P(A,"^",7)_"^"_$P(A,"^",8)
19 S A=$$DATE^PRC0C($P(A,"^",8)-15,"H")
20 S A=$$DATE^PRC0C($P(A,"^",4)_"/1/"_$P(A,"^",3),"E"),$P(PRCTD,"^",7,9)=$P(A,"^",4)_"/"_$E($P(A,"^",3),3,4)_"^"_$P(A,"^",7)_"^"_$P(A,"^",8)
21 G SCHED:$G(ZTQPARAM)=999!$G(ZTQUEUED)
22 S E="O^4:7^K:X'?1.2N1""/""2N&(X'?1.2N1""/""4N)!(X<1!(X>12)) X",Y(1)="Enter an accrual month/year in format: MM/YY or MM/YYYY. For example: 9/96 or 9/1996"
23 D FT^PRC0A(.X,.Y,"For Accrual Month/Year",E,$P(PRCTD,"^"))
24 G:X["^"!(X="")!(Y'?1.2N1"/"2.4N) EXIT
25 S $P(Y,"/",2)=+$$YEAR^PRC0C($P(Y,"/",2)),$P(Y,"/")=$E(100+Y,2,3)
26 S PRCA=Y,A=$$DATE^PRC0C(PRCA,"E"),$P(PRCA,"^",2,999)=A W " Fiscal Month/Year: ",$P(PRCA,"^",10),"/",$P(PRCA,"^",2)
27 S $P(PRCA,"^",11)=$P(PRCA,"^",8)_"-"_PRC("SITE")
28 I $P(PRCA,"^",9)<$P(PRCTD,"^",9),$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0))<1 D EN^DDIOL("Accrual report for "_$P(PRCA,"^")_" is NOT in file.") G Q4
29 I $P(PRCTD,"^",6)<$P(PRCA,"^",9) D EN^DDIOL("Too early to accrue for "_$P(PRCA,"^")) G Q4
30 S $P(PRCA,"^",12)=0
31Q40 S B="O^1:Compile/Print Monthly Accrual;2:Edit Monthly Accrual;3:Generate/Rebuild FMS SV-Document"
32 K X,Y S Y(1)="^W ""Enter an option number 1 to 3."""
33 D SC^PRC0A(.X,.Y,"Select Number",B,"")
34 S A=Y K X,Y
35 G Q4:A=""!(A["^")
36 S PRCOPT=+A
37 G Q45:PRCOPT=2,Q47:PRCOPT=3
38 I $O(^PRCH(440.6,"ST","N~",0)) D EN^DDIOL("Warning: An unregistered card exists in your file. Contact the P.C. Coordinator.")
39 I $P(PRCA,"^",9)'=$P(PRCTD,"^",6),$P(PRCA,"^",9)'=$P(PRCTD,"^",9) G Q5
40 S PRCRI(440.7)=$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0)) G Q5:'PRCRI(440.7)
41 S A=^PRCH(440.7,PRCRI(440.7),0),B=$P(A,"^",2),B=$E(B,4,5)_"/"_$E(B,6,7)_"/"_$E(B,2,3)_"@"_$E(B,9,10)_":"_($E(B,11)\1)_($E(B,12)\1)
42 D EN^DDIOL("The last compiling date is "_B)
43 D:$P(A,"^",6) EN^DDIOL("Warning: Recompiling will overwrite all edited accrual amounts")
44Q41 D YN^PRC0A(.X,.Y,"Recompile Accrual Report:","O","NO")
45 I X["^" G Q4
46 S $P(PRCA,"^",12)=Y G Q5
47Q45 ;eidt accrual amount
48 I $P(PRCA,"^",9)'=$P(PRCTD,"^",6),$P(PRCA,"^",9)'=$P(PRCTD,"^",9) D EN^DDIOL("It is too late to edit accrual amounts") G Q4
49 S PRCRI(440.7)=$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0))
50 I 'PRCRI(440.7) D EN^DDIOL("You need to select Compile/Print option first") G Q40
51 G Q5
52 ;
53Q47 ;generate sv-document
54 I $P(PRCA,"^",9)'=$P(PRCTD,"^",6),$P(PRCA,"^",9)'=$P(PRCTD,"^",9) D EN^DDIOL("It is too late to generate SV-documents") G Q4
55 S PRCRI(440.7)=$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0))
56 I 'PRCRI(440.7) D EN^DDIOL("You need to select Compile/Print option first") G Q40
57 S A=^PRCH(440.7,PRCRI(440.7),0) D:$P(A,"^",7)]""
58 . N GECSDATA
59 . S A=$P($P(A,"^",7),"/",2),X="SV-"_A D DATA^GECSSGET(X,0)
60 . I '$G(GECSDATA) D EN^DDIOL(PRCPT_" NOT found!") QUIT
61 . S PRCRI(2100.1)=GECSDATA,PRCID=GECSDATA(2100.1,PRCRI(2100.1),.01,"E")
62 . D EN^DDIOL(" "),EN^DDIOL($J("FMS Document: ",15)_PRCID)
63 . D EN^DDIOL($J("Description: ",15)_GECSDATA(2100.1,PRCRI(2100.1),4,"E"))
64 . D EN^DDIOL($J("Status: ",15)_GECSDATA(2100.1,PRCRI(2100.1),3,"E"))
65 . D EN^DDIOL($J("Created: ",15)_GECSDATA(2100.1,PRCRI(2100.1),2,"E"))
66 . QUIT
67 G Q5
68Q5 D YN^PRC0A(.X,.Y,"Ready to "_$P("Compile/Print,Edit,Generate/Rebuild Document",",",PRCOPT),"O","NO")
69 I X["^"!(X="")!'Y G Q4
70 I PRCOPT=1 D ACCR
71 I PRCOPT=2 D EDIT
72 I PRCOPT=3 D
73 . D EN^DDIOL("Generating the monthly accrual FMS SV-Document")
74 . S PRCB=$P(^PRCH(440.7,PRCRI(440.7),0),"^",7)
75 . D SV^PRCB8B(.X,PRCRI(440.7)_"^"_PRCA,$TR(PRCB,"/","^"))
76 . I X>0 D EDIT^PRC0B(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7),"2///^S X=""N"";6////"_X)
77 . QUIT
78 D EN^DDIOL(" "),EN^DDIOL(" ") G Q4
79 ;
80EXIT QUIT
81 ;
82 ;
83ACCR ;start accrual
84 N PRCDUZ
85 S PRCDUZ=DUZ
86 S ZTDESC="IFCAP Monthly Accrual for Month/Year: "_$P(PRCA,"^")
87 S PRCDES=ZTDESC
88 S ZTRTN="TMEN^PRCB1F1" F A="PRCOPT","PRCA","PRCTD","PRCDUZ","PRCDES","DUZ*" S ZTSAVE(A)=""
89 D ^PRCFQ
90 QUIT
91 ;
92EDIT ;edit accrual amount
93 N PRCDI
94 N A,B,X,Y
95 D EDIT^PRC0B(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7),"5///T")
96Q21 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-")) S PRCDI="440.7;^PRCH(440.7,;"_PRCRI(440.7)_";1~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,"
97 D LOOKUP^PRC0B(.X,.Y,PRCDI,"AEMOQ","Select Fund or FCP/PRJ (ACC) Code: ")
98 I Y<0!(X="") K X QUIT
99 K X S PRCRI(440.701)=+Y,PRCAED=$P(Y,"^",3)
100 S PRCDI=";^PRCH(440.7,;"_PRCRI(440.7)_"~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,;"_PRCRI(440.701)
101 S A=^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0),B=$P(A,"^",2)-$P(A,"^",3)
102 D EN^DDIOL("Accrual Account: "_$P(A,"^",1))
103 D EN^DDIOL("Unpaid P.C.O Amount: "_$J($P(A,"^",2),0,2)_" Unreconciled Amount: "_$J($P(A,"^",3),0,2))
104 D EN^DDIOL("Calculated Accrual Amount: "_$J(B,0,2))
105 D EDIT^PRC0B(.X,PRCDI,"4;5;6")
106 G Q21
107 ;
108SCHED ;compiling for all stations
109 S Y=$P(PRCTD,"^",7),$P(Y,"/",2)=+$$YEAR^PRC0C($P(Y,"/",2)),$P(Y,"/")=$E(100+Y,2,3)
110 S PRCA=Y,A=$$DATE^PRC0C(PRCA,"E"),$P(PRCA,"^",2,999)=A
111 S PRCRI(420)=0
112 F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420) S PRC("SITE")=$P($G(^PRC(420,PRCRI(420),0)),"^") I PRC("SITE") S $P(PRCA,"^",11)=$P(PRCA,"^",8)_"-"_PRC("SITE") D
113 . N PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA
114 . N A,B,C
115 . S PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)
116 . D ACCR^PRCB1F1(PRCA,PRCTD)
117 . QUIT
118 QUIT
Note: See TracBrowser for help on using the repository browser.