source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSEZ.m@ 623

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1PRCSEZ ;SF-ISC/LJP/CTB-COMPUTATIONS FOR 2237S ; 03/24/94 10:17 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4TRANK Q:X']"" S Z(X)=-X G A
5TRANS Q:X']"" S Z(X)=X
6A D EN Q:'$D(Z)!'$D(Z("CPB"))!'$D(Z("TT")) ;G:$D(PRCHOBL)!(Z("TT")="A") A1 G:Z("TT")=""!(Z("SER")="") EX
7A1 I Z("TT")="O" D:$G(Z("SER"))]"" 1 G ST
8 I Z("TT")="A" S Z(X)=-Z(X) D 3 D:Z("FT")'=1 4 G ST
9 I Z("TT")="CA" D 3,4 G ST
10 Q
11TRANK1 Q:X']"" S Z(X)=-X G B
12TRANS1 Q:X']"" S Z(X)=X
13B D EN Q:'$D(Z)!('$D(Z("CPB")))!'$D(Z("TT")) ;G:$D(PRCHOBL)!(Z("TT")="A") B1 G:Z("TT")=""!(Z("OB")="") EX
14B1 I Z("TT")="O" D 2 G ST
15 I Z("TT")="A" S Z(X)=-Z(X) D 4 G ST
16 I Z("TT")="C" D 3,4 G ST
17 Q
18EN G:'$D(^PRCS(410,DA,0)) EX1 S Z=^(0) G:$P(Z,U)=$P(Z,U,3) EX1 G:'$D(^(4)) EX1 S Z(4)=^(4),Z("OB")=$P(Z(4),U,5),Z("FIS")=$P(Z(4),U,10) G:'$D(^(7)) EX1 S Z(7)=^(7),Z("SER")=$P(Z(7),U,6),Z("GPF")=$P(Z(7),U,9)
19 S Z("ST")=+Z,Z("CP")=+$P(Z,"-",4),Z("FY")=$P(Z,"-",2),Z("QT")=$P(Z,"-",3)
20 I $P(Z,U,11) S Z("QT")=$$DATE^PRC0C($P(Z,U,11),"I"),Z("FY")=$E(Z("QT"),3,4),Z("QT")=$P(Z("QT"),U,2)
21 S Z("AMT")=X,Z("TT")=$P(Z,U,2),Z("FT")=$P(Z,U,4),Z("SPC")=Z("QT")+1,Z("FPC")=Z("QT")+5
22 D ARFY
23 QUIT
24 ;
25 ;add new comm/obl record if not defined
26ARFY ;
27 ;P182--Commented out following line. TEMPREQ no longer used as of P140
28 ;Q:$D(TEMPREQ)
29 S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,0)) ^(0)="^420.06A^^"
30 I '$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)) S ^(0)=Z("FY")_"^0^0^0^0^0^0^0^0",$P(^(0),U,3,4)=Z("FY")_U_($P(^PRC(420,Z("ST"),1,Z("CP"),4,0),U,4)+1),^PRC(420,Z("ST"),1,Z("CP"),4,"B",Z("FY"),Z("FY"))=""
31 S Z("CPB")=^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)
32 S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)) ^(1)="^0^0^0^0" S Z("SCPB")=^(1)
33 I '$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),2)) D
34 . S ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),2)=$$SUBALL
35 . QUIT
36 QUIT
37 ;
38SUBALL() ;EV get fms allowance account
39 N A,B
40 S (A,B)=""
41 I $D(^PRC(420,Z("ST"),1,Z("CP"),0)) S $P(A,"^",1)=$P(^(0)," "),$P(A,"^",2)=$P($P(^(0),"^")," ",2,999),$P(A,"^",3)=$P(^(0),"^",2),B=$G(^(5))
42 S $P(A,"^",4)=$P(B,"^",5),$P(A,"^",5)=$P(B,"^",2)
43 S $P(A,"^",6)=$P(B,"^",3),$P(A,"^",7)=$P(B,"^",4)
44 S $P(A,"^",8)=$P(B,"^",6)
45 I $P(A,"^",3) S B=^PRCD(420.3,$P(A,"^",3),0),$P(A,"^",9)=$P(B,"^",3),$P(A,"^",10)=$P(B,"^",7)
46 QUIT A
47 ;
48 ;A=station #, B=fiscal year (not bbfy), C=fcp #
49ACC(A,B,C) ;EF-retrieve fcp fiscal year fms suballowance data
50 N Z
51 S Z=$G(^PRC(420,+A,1,+C,4,B,2))
52 I Z="" S Z("ST")=+A,Z("FY")=B,Z("CP")=+C,Z=$$SUBALL
53 QUIT Z
54 ;
551 S $P(Z("CPB"),U,Z("SPC"))=$P(Z("CPB"),U,Z("SPC"))-$J(Z(X),0,2),$P(Z("SCPB"),U,Z("SPC"))=$P(Z("SCPB"),U,Z("SPC"))-$J(Z(X),0,2)
56 Q
572 S $P(Z("CPB"),U,Z("FPC"))=$P(Z("CPB"),U,Z("FPC"))-$J(Z(X),0,2) ; Q:Z("FT")'=1 Q:'$D(Z(58)) S $P(Z(58),U,2)=$P(Z(58),U,2)-$J(Z(X),0,2)
58 Q
593 G ADD ;I Z("TT")'="A" G ADD
60 ;I Z("TT")="A",Z("FT")="" G ADD
61 ;I Z("FT")=1,Z("TT")="A",Z("SER")]"" G ADD
62 Q
63ADD S $P(Z("CPB"),U,Z("SPC"))=$P(Z("CPB"),U,Z("SPC"))+$J(Z(X),0,2),$P(Z("SCPB"),U,Z("SPC"))=$P(Z("SCPB"),U,Z("SPC"))+$J(Z(X),0,2) ; Q:Z("FT")'=1 ; Q:'$D(Z(58)) S $P(Z(58),U,1)=$P(Z(58),U,1)+$J(Z(X),0,2),$P(Z(58),U,3)=$P(Z(58),U,3)+$J(Z(X),0,2)
64 Q
654 G ADD1 ;I Z("TT")'="A" G ADD1
66 ;I Z("TT")="A",Z("FT")="" G ADD1
67 ;I Z("FT")=1,Z("TT")="A" I Z("FIS")]"" G ADD1
68 Q
69ADD1 S $P(Z("CPB"),U,Z("FPC"))=$P(Z("CPB"),U,Z("FPC"))+$J(Z(X),0,2) ; Q:Z("FT")'=1 Q:'$D(Z(58)) S $P(Z(58),U,2)=$P(Z(58),U,2)+$J(Z(X),0,2)
70 Q
71ST S ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)=Z("CPB"),^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)=Z("SCPB") ; Q:Z("FT")'=1 I $D(Z(58)) S ^PRC(442,Z("PO"),8)=Z(58)
72EX ;
73EX1 K Z QUIT
74 ;
75 ;PRCA data ^1=station #, ^2=fcp #, ^3=fy, ^4=QTR #, ^5=$amount (- for credit)
76 ;PRCB=O if obligated balance, C if commited (and sub fcp)
77EBAL(PRCA,PRCB) ;edit fcp (subfcp) commited/obligated balance without file 410
78 N Z,A,B
79 S Z("ST")=+PRCA,Z("CP")=+$P(PRCA,"^",2),Z("FY")=$P(PRCA,"^",3)
80 S Z("QT")=$P(PRCA,"^",4),Z("AMT")=+$P(PRCA,"^",5),X=Z("AMT"),Z(X)=X
81 S Z("SPC")=Z("QT")+1,Z("FPC")=Z("QT")+5
82 D ARFY Q:'$D(Z("CPB"))
83 D:PRCB="O" 2,ST D:PRCB="C" 1,ST
84 QUIT
85 ;
Note: See TracBrowser for help on using the repository browser.