source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB0B.m@ 810

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

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1PRCB0B ;WISC/PLT-utility recalculate fcp balance ; 12/12/94 8:56 AM
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 ;
6 ;prca=station #,prcb=fcp #, prcc=running balance fy (2-digit), prcd=quarter #
7 ;total committed, obligated, ceiling txn amount
8FCP(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=fiscal bal (unobligated)
9 ; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
10 N PRCRI,PRCE,PRCF,PRCG,PRCH,PRCJ,PRCT,PRCACP
11 N A,B,C,D
12 S PRCC=$P($$YEAR^PRC0C(PRCC),"^",2) F A=1:1:3 S PRCT(A)=""
13 S PRCB=$P(PRCB," ")
14 S PRCE=$P($$QTRDATE^PRC0D(PRCC,PRCD),"^",7)_"-"_PRCA_"-"_PRCB_"-",PRCH=PRCE_"~"
15 F S PRCE=$O(^PRCS(410,"RB",PRCE)) QUIT:PRCE]PRCH!'PRCE W:'$D(ZTQUEUED) !,PRCE S PRCRI(410)=$O(^(PRCE,"")) QUIT:'PRCRI(410) S PRCF=$G(^PRCS(410,PRCRI(410),0)),PRCG=$P(PRCF,"^",2),PRCF=$P(PRCF,"^",4) I PRCG'="CA" S A=$G(^(4)),B=$G(^(7)) D
16 . S PRCACP=$P($G(^PRCS(410,PRCRI(410),4)),"^",14)
17 . I PRCG="O" S:$P(B,"^",6)]"" PRCT(1)=PRCT(1)+$J($P(A,"^",8),0,2) S:$P(A,"^",10)]"" PRCT(2)=PRCT(2)+$J($P(A,"^",3),0,2) QUIT
18 . I PRCG="C" S PRCT(3)=PRCT(3)+$J($P(A,"^",3),0,2) QUIT
19 . I PRCG="A",PRCF=1 S:$P(B,"^",6)]"" PRCT(1)=PRCT(1)+$J($P(A,"^",8),0,2) S:$P(A,"^",10)]"" PRCT(2)=PRCT(2)+$J($P(A,"^",3),0,2) QUIT
20 . ;txn from option: enter fcp adjustment data or post issue book
21 . I PRCG="A" S PRCT(1)=PRCT(1)+$J($P(A,"^",8),0,2) S:PRCACP'="Y" PRCT(2)=PRCT(2)+$J($P(A,"^",3),0,2) QUIT
22 . QUIT
23 S A=PRCT(3)-PRCT(1),B=PRCT(3)-PRCT(2)
24 QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
25 ;
26 ; see fcp comments
27PO(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=betgetary bal (unobligated)
28 ; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
29 N PRCRI,PRCE,PRCF,PRCT
30 N A,B,C,D
31 S PRCB=$P(PRCB," "),PRCC=+$$YEAR^PRC0C(PRCC) F A=1:1:3 S PRCT(A)=""
32 S PRCE=$$QTRDATE^PRC0D(PRCC,PRCD)
33 S A=$P(PRCE,"^",8)+100,A=$$DATE^PRC0C(A,"H")
34 S PRCG=$$QTRDATE^PRC0D(+A,$P(A,"^",2))
35 S PRCE=$P(PRCE,"^",7)-1,PRCG=$P(PRCG,"^",7)-1
36 F S PRCE=$O(^PRC(442,"AB",PRCE)) Q:PRCE>PRCG!'PRCE D
37 . S PRCRI(442)=0
38 . F S PRCRI(442)=$O(^PRC(442,"AB",PRCE,PRCRI(442))) QUIT:'PRCRI(442) S PRCF=$G(^PRC(442,PRCRI(442),0)) I $P(PRCF,"^",12)="",+PRCF=PRCA,+$P(PRCF,"^",3)=+PRCB D:$P($G(^(12)),"^",2)]""&($G(^(7))-45)
39 .. S PRCT(1)=PRCT(1)+$P(PRCF,"^",16),PRCT(2)=PRCT(2)+$P(PRCF,"^",16)
40 .. QUIT
41 . QUIT
42 S A=PRCT(3)-PRCT(1),B=PRCT(3)-PRCT(2)
43 QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
44 ;
45 ; see fcp comments
46REC(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=betgetary bal (unobligated)
47 ; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
48 N PRCRI,PRCE,PRCF,PRCT
49 N A,B,C,D
50 S PRCC=$P($$YEAR^PRC0C(PRCC),"^",2) F A=1:1:3 S PRCT(A)=""
51 S PRCB=$P(PRCB," "),PRCE=PRCA_"-"_PRCC_"-"_PRCD_"-"_PRCB
52 S PRCRI(417)=0
53 F S PRCRI(417)=$O(^PRCS(417,"C",PRCE,PRCRI(417))) QUIT:'PRCRI(417) S PRCF=$G(^PRCS(417,PRCRI(417),0)) D
54 . S A=$P(PRCF,"^",20)
55 . N TYPE,OBL,CUTOFF S TYPE=$P(PRCF,"^",17),OBL=$P(PRCF,"^",18),CUTOFF=$P($G(^PRCS(417,PRCRI(417),1)),"^")
56 . I CUTOFF'=1 S PRCT(1)=PRCT(1)+A
57 . I CUTOFF=1,TYPE'="CC",$E(OBL,4,7)'?4A S PRCT(1)=PRCT(1)+A
58 . S PRCT(2)=PRCT(2)+A
59 . QUIT
60 S A=PRCT(3)-PRCT(1),B=PRCT(3)-PRCT(2)
61 QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
62 ;
Note: See TracBrowser for help on using the repository browser.