source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFOOR1.m@ 1710

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

initial load of WorldVistAEHR

File size: 3.5 KB
RevLine 
[613]1PRCFOOR1 ;WISC@ALTOONA/CTB-SNAPSHOT OF CP BALANCES ;9/29/94 8:40 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;;THIS ROUTINE WILL RECALCULATE ALL CP BALANCES FOR THE CURRENT FY,
5 ;;THEN TAKE A SNAPSHOT OF THE BALANCE FOR THE CURRENT QUARTER
6 ;;AND STORE THE BALANCE IN 420. IT WILL THEN ZERO OUT ALL QUARTERS
7 ;;IN THE CURRENT FY - EXCEPT FOR THE CURRENT QUARTER.
8 ;;
9 ;RECALCULATE ALL CONTROL POINTS
10 S X="Beginning recalculation of balances for ALL Fund Control Points." D MSG^PRCFQ
11 D ALLCP^PRCBRCP
12 S X="< Recalculation complete>*" D MSG^PRCFQ
13X S X=DT D FYQ^PRCFSITE
14STA W !! S X="Beginning process to record existing Fund Control Point balances in file 420.99. (Snapshot)" D MSG^PRCFQ
15 F PRC("SITE")=0:0 S PRC("SITE")=$O(^PRC(420,PRC("SITE"))) Q:+PRC("SITE")=0 W !,PRC("SITE") D CP
16 S X="< Snapshot complete>*" D MSG^PRCFQ
17ZERO W !! S X="Beginning process to 'zero' out previous quarter balances.*" D MSG^PRCFQ
18 N PRCRI S PRCRI(420.99)=0
19 F S PRCRI(420.99)=$O(^PRCU(420.99,PRCRI(420.99))) Q:'PRCRI(420.99) S DA=PRCRI(420.99) D XF
20 S X="< Process complete>*" D MSG^PRCFQ
21GPF W !! S X="Beginning process to summarize General Post Fund Control Points" D MSG^PRCFQ
22 ;CREATE RECORD FOR GENERAL POST FUND SUMMARY CONTROL POINT
23 ;SUMMARIZE, BY STATION, GPF BALANCES
24 ;SET BALANCES
25 ;ZERO CURRENT QUARTER
26 S XDA=0 F S XDA=$O(^PRCU(420.99,XDA)) Q:'XDA I $P(^(XDA,0),"^",11)=1 D GPF1(XDA)
27 S SITE=0
28 F S SITE=$O(GPFBAL(SITE)) Q:'SITE D GPF2(SITE,GPFBAL(SITE))
29 K PRC
30 S X="< Process complete>*" D MSG^PRCFQ
31 QUIT
32GPF2(SITE,AMT) ;SET BALANCE TO GPF SUMMARY CONTROL POINT
33 S PRC("CP")=$O(^PRC(420,SITE,1,"C","GPFS FMS CONVERSION",0))
34 I PRC("CP")="" QUIT
35 S PRC("CP")=$P(^PRC(420,SITE,1,PRC("CP"),0)," ")
36 S STRING=SITE_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
37 S X=STRING,DIC=420.99,DIC(0)="M" D ^DIC Q:+Y<0
38 S $P(^PRCU(420.99,+Y,0),"^",3)=AMT
39 D CONV^PRCSREC2(STRING,-AMT,"FMS CONVERSION ADJUSTMENT")
40 QUIT
41GPF1(XDA) ;ZERO BALANCE IN EXISTING GPF CONTROL POINTS
42 N BAL,SITE,NODE,ID,AMT,STRING
43 S SITE=$P(^PRCU(420.99,XDA,0),"-"),BAL=$P(^(0),"^",3),GPFBAL(SITE)=$G(GPFBAL(SITE))+BAL
44 ;ZERO CURRENT QUARTER FOR GPF CP
45 S NODE=$G(^PRCU(420.99,XDA,0)) Q:NODE=""
46 S ID=$P(NODE,"^"),AMT=+$P(NODE,"^",3)
47 Q:AMT=0
48 S STRING=ID,$P(STRING,"-",3)=PRC("QTR") D CONV^PRCSREC2(STRING,+AMT,"FMS CONVERSION ADJUSTMENT")
49 S $P(^PRCU(420.99,XDA,0),"^",3)=0
50 W "."
51 QUIT
52XF ;
53 N NODE,ID,QTR,I,STRING
54 S NODE=$G(^PRCU(420.99,DA,0)) Q:NODE=""
55 S ID=$P(NODE,"^"),QTR(1)=$P(NODE,"^",4),QTR(2)=$P(NODE,"^",5),QTR(3)=$P(NODE,"^",6)
56 F I=1:1:3 Q:'$D(QTR(I)) I +QTR(I)'=0 S STRING=ID,$P(STRING,"-",3)=I D CONV^PRCSREC2(STRING,+QTR(I),"FMS CONVERSION ADJUSTMENT")
57 W "."
58 QUIT
59CP F PRC("CPN")=0:0 S PRC("CPN")=$O(^PRC(420,PRC("SITE"),1,PRC("CPN"))),PRC("CP")="" Q:+PRC("CPN")=0!(PRC("CPN")=9999) I $D(^(PRC("CPN"),0)) S PRC("CP")=$P(^(0)," ") Q:PRC("CP")="" D QTR
60 Q
61QTR ;
62 NEW SNAP,DIC,DLAYGO,AMT,DATE,Y,DA,DR,DIE,TYPE,QTRBAL
63 S TYPE=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",12)
64 S X=$G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0))
65 S SNAP=$P(X,"^",PRC("QTR")+5),SNAP=0 ;mod for conversion 3 only
66 I PRC("QTR")>1 F I=1:1:(PRC("QTR")-1) S QTRBAL(I)=$P(X,"^",I+5)
67 S (DIC,DLAYGO)=420.99,DIC(0)="MNL",AMT=X,X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP"),DATE=DT D ^DIC
68 I Y<0 S FAIL="" QUIT
69 S DA=+Y,$P(^PRCU(420.99,DA,0),"^",2)=DATE,$P(^(0),"^",3)=SNAP,$P(^(0),"^",4)=$G(QTRBAL(1)),$P(^(0),"^",5)=$G(QTRBAL(2)),$P(^(0),"^",6)=$G(QTRBAL(3))
70 S $P(^PRCU(420.99,DA,0),"^",11)=+TYPE,$P(^(0),"^",7)=PRC("QTR")
71 W "." QUIT
Note: See TracBrowser for help on using the repository browser.