PRCSEZ ;SF-ISC/LJP/CTB-COMPUTATIONS FOR 2237S ; 03/24/94 10:17 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
TRANK Q:X']"" S Z(X)=-X G A
TRANS Q:X']"" S Z(X)=X
A D EN Q:'$D(Z)!'$D(Z("CPB"))!'$D(Z("TT")) ;G:$D(PRCHOBL)!(Z("TT")="A") A1 G:Z("TT")=""!(Z("SER")="") EX
A1 I Z("TT")="O" D:$G(Z("SER"))]"" 1 G ST
I Z("TT")="A" S Z(X)=-Z(X) D 3 D:Z("FT")'=1 4 G ST
I Z("TT")="CA" D 3,4 G ST
Q
TRANK1 Q:X']"" S Z(X)=-X G B
TRANS1 Q:X']"" S Z(X)=X
B D EN Q:'$D(Z)!('$D(Z("CPB")))!'$D(Z("TT")) ;G:$D(PRCHOBL)!(Z("TT")="A") B1 G:Z("TT")=""!(Z("OB")="") EX
B1 I Z("TT")="O" D 2 G ST
I Z("TT")="A" S Z(X)=-Z(X) D 4 G ST
I Z("TT")="C" D 3,4 G ST
Q
EN 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)
S Z("ST")=+Z,Z("CP")=+$P(Z,"-",4),Z("FY")=$P(Z,"-",2),Z("QT")=$P(Z,"-",3)
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)
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
D ARFY
QUIT
;
;add new comm/obl record if not defined
ARFY ;
;P182--Commented out following line. TEMPREQ no longer used as of P140
;Q:$D(TEMPREQ)
S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,0)) ^(0)="^420.06A^^"
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"))=""
S Z("CPB")=^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)
S:'$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)) ^(1)="^0^0^0^0" S Z("SCPB")=^(1)
I '$D(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),2)) D
. S ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),2)=$$SUBALL
. QUIT
QUIT
;
SUBALL() ;EV get fms allowance account
N A,B
S (A,B)=""
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))
S $P(A,"^",4)=$P(B,"^",5),$P(A,"^",5)=$P(B,"^",2)
S $P(A,"^",6)=$P(B,"^",3),$P(A,"^",7)=$P(B,"^",4)
S $P(A,"^",8)=$P(B,"^",6)
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)
QUIT A
;
;A=station #, B=fiscal year (not bbfy), C=fcp #
ACC(A,B,C) ;EF-retrieve fcp fiscal year fms suballowance data
N Z
S Z=$G(^PRC(420,+A,1,+C,4,B,2))
I Z="" S Z("ST")=+A,Z("FY")=B,Z("CP")=+C,Z=$$SUBALL
QUIT Z
;
1 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
2 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)
Q
3 G ADD ;I Z("TT")'="A" G ADD
;I Z("TT")="A",Z("FT")="" G ADD
;I Z("FT")=1,Z("TT")="A",Z("SER")]"" G ADD
Q
ADD 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)
Q
4 G ADD1 ;I Z("TT")'="A" G ADD1
;I Z("TT")="A",Z("FT")="" G ADD1
;I Z("FT")=1,Z("TT")="A" I Z("FIS")]"" G ADD1
Q
ADD1 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)
Q
ST 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)
EX ;
EX1 K Z QUIT
;
;PRCA data ^1=station #, ^2=fcp #, ^3=fy, ^4=QTR #, ^5=$amount (- for credit)
;PRCB=O if obligated balance, C if commited (and sub fcp)
EBAL(PRCA,PRCB) ;edit fcp (subfcp) commited/obligated balance without file 410
N Z,A,B
S Z("ST")=+PRCA,Z("CP")=+$P(PRCA,"^",2),Z("FY")=$P(PRCA,"^",3)
S Z("QT")=$P(PRCA,"^",4),Z("AMT")=+$P(PRCA,"^",5),X=Z("AMT"),Z(X)=X
S Z("SPC")=Z("QT")+1,Z("FPC")=Z("QT")+5
D ARFY Q:'$D(Z("CPB"))
D:PRCB="O" 2,ST D:PRCB="C" 1,ST
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEZ 4112 printed Dec 13, 2024@02:17:46 Page 2
PRCSEZ ;SF-ISC/LJP/CTB-COMPUTATIONS FOR 2237S ; 03/24/94 10:17 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
TRANK if X']""
QUIT
SET Z(X)=-X
GOTO A
TRANS if X']""
QUIT
SET Z(X)=X
A ;G:$D(PRCHOBL)!(Z("TT")="A") A1 G:Z("TT")=""!(Z("SER")="") EX
DO EN
if '$DATA(Z)!'$DATA(Z("CPB"))!'$DATA(Z("TT"))
QUIT
A1 IF Z("TT")="O"
if $GET(Z("SER"))]""
DO 1
GOTO ST
+1 IF Z("TT")="A"
SET Z(X)=-Z(X)
DO 3
if Z("FT")'=1
DO 4
GOTO ST
+2 IF Z("TT")="CA"
DO 3
DO 4
GOTO ST
+3 QUIT
TRANK1 if X']""
QUIT
SET Z(X)=-X
GOTO B
TRANS1 if X']""
QUIT
SET Z(X)=X
B ;G:$D(PRCHOBL)!(Z("TT")="A") B1 G:Z("TT")=""!(Z("OB")="") EX
DO EN
if '$DATA(Z)!('$DATA(Z("CPB")))!'$DATA(Z("TT"))
QUIT
B1 IF Z("TT")="O"
DO 2
GOTO ST
+1 IF Z("TT")="A"
SET Z(X)=-Z(X)
DO 4
GOTO ST
+2 IF Z("TT")="C"
DO 3
DO 4
GOTO ST
+3 QUIT
EN if '$DATA(^PRCS(410,DA,0))
GOTO EX1
SET Z=^(0)
if $PIECE(Z,U)=$PIECE(Z,U,3)
GOTO EX1
if '$DATA(^(4))
GOTO EX1
SET Z(4)=^(4)
SET Z("OB")=$PIECE(Z(4),U,5)
SET Z("FIS")=$PIECE(Z(4),U,10)
if '$DATA(^(7))
GOTO EX1
SET Z(7)=^(7)
SET Z("SER")=$PIECE(Z(7),U,6)
SET Z("GPF")=$PIECE(Z(7),U,9)
+1 SET Z("ST")=+Z
SET Z("CP")=+$PIECE(Z,"-",4)
SET Z("FY")=$PIECE(Z,"-",2)
SET Z("QT")=$PIECE(Z,"-",3)
+2 IF $PIECE(Z,U,11)
SET Z("QT")=$$DATE^PRC0C($PIECE(Z,U,11),"I")
SET Z("FY")=$EXTRACT(Z("QT"),3,4)
SET Z("QT")=$PIECE(Z("QT"),U,2)
+3 SET Z("AMT")=X
SET Z("TT")=$PIECE(Z,U,2)
SET Z("FT")=$PIECE(Z,U,4)
SET Z("SPC")=Z("QT")+1
SET Z("FPC")=Z("QT")+5
+4 DO ARFY
+5 QUIT
+6 ;
+7 ;add new comm/obl record if not defined
ARFY ;
+1 ;P182--Commented out following line. TEMPREQ no longer used as of P140
+2 ;Q:$D(TEMPREQ)
+3 if '$DATA(^PRC(420,Z("ST"),1,Z("CP"),4,0))
SET ^(0)="^420.06A^^"
+4 IF '$DATA(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0))
SET ^(0)=Z("FY")_"^0^0^0^0^0^0^0^0"
SET $PIECE(^(0),U,3,4)=Z("FY")_U_($PIECE(^PRC(420,Z("ST"),1,Z("CP"),4,0),U,4)+1)
SET ^PRC(420,Z("ST"),1,Z("CP"),4,"B",Z("FY"),Z("FY"))=""
+5 SET Z("CPB")=^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)
+6 if '$DATA(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1))
SET ^(1)="^0^0^0^0"
SET Z("SCPB")=^(1)
+7 IF '$DATA(^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),2))
Begin DoDot:1
+8 SET ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),2)=$$SUBALL
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
SUBALL() ;EV get fms allowance account
+1 NEW A,B
+2 SET (A,B)=""
+3 IF $DATA(^PRC(420,Z("ST"),1,Z("CP"),0))
SET $PIECE(A,"^",1)=$PIECE(^(0)," ")
SET $PIECE(A,"^",2)=$PIECE($PIECE(^(0),"^")," ",2,999)
SET $PIECE(A,"^",3)=$PIECE(^(0),"^",2)
SET B=$GET(^(5))
+4 SET $PIECE(A,"^",4)=$PIECE(B,"^",5)
SET $PIECE(A,"^",5)=$PIECE(B,"^",2)
+5 SET $PIECE(A,"^",6)=$PIECE(B,"^",3)
SET $PIECE(A,"^",7)=$PIECE(B,"^",4)
+6 SET $PIECE(A,"^",8)=$PIECE(B,"^",6)
+7 IF $PIECE(A,"^",3)
SET B=^PRCD(420.3,$PIECE(A,"^",3),0)
SET $PIECE(A,"^",9)=$PIECE(B,"^",3)
SET $PIECE(A,"^",10)=$PIECE(B,"^",7)
+8 QUIT A
+9 ;
+10 ;A=station #, B=fiscal year (not bbfy), C=fcp #
ACC(A,B,C) ;EF-retrieve fcp fiscal year fms suballowance data
+1 NEW Z
+2 SET Z=$GET(^PRC(420,+A,1,+C,4,B,2))
+3 IF Z=""
SET Z("ST")=+A
SET Z("FY")=B
SET Z("CP")=+C
SET Z=$$SUBALL
+4 QUIT Z
+5 ;
1 SET $PIECE(Z("CPB"),U,Z("SPC"))=$PIECE(Z("CPB"),U,Z("SPC"))-$JUSTIFY(Z(X),0,2)
SET $PIECE(Z("SCPB"),U,Z("SPC"))=$PIECE(Z("SCPB"),U,Z("SPC"))-$JUSTIFY(Z(X),0,2)
+1 QUIT
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)
SET $PIECE(Z("CPB"),U,Z("FPC"))=$PIECE(Z("CPB"),U,Z("FPC"))-$JUSTIFY(Z(X),0,2)
+1 QUIT
3 ;I Z("TT")'="A" G ADD
GOTO ADD
+1 ;I Z("TT")="A",Z("FT")="" G ADD
+2 ;I Z("FT")=1,Z("TT")="A",Z("SER")]"" G ADD
+3 QUIT
ADD ; 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)
SET $PIECE(Z("CPB"),U,Z("SPC"))=$PIECE(Z("CPB"),U,Z("SPC"))+$JUSTIFY(Z(X),0,2)
SET $PIECE(Z("SCPB"),U,Z("SPC"))=$PIECE(Z("SCPB"),U,Z("SPC"))+$JUSTIFY(Z(X),0,2)
+1 QUIT
4 ;I Z("TT")'="A" G ADD1
GOTO ADD1
+1 ;I Z("TT")="A",Z("FT")="" G ADD1
+2 ;I Z("FT")=1,Z("TT")="A" I Z("FIS")]"" G ADD1
+3 QUIT
ADD1 ; Q:Z("FT")'=1 Q:'$D(Z(58)) S $P(Z(58),U,2)=$P(Z(58),U,2)+$J(Z(X),0,2)
SET $PIECE(Z("CPB"),U,Z("FPC"))=$PIECE(Z("CPB"),U,Z("FPC"))+$JUSTIFY(Z(X),0,2)
+1 QUIT
ST ; Q:Z("FT")'=1 I $D(Z(58)) S ^PRC(442,Z("PO"),8)=Z(58)
SET ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),0)=Z("CPB")
SET ^PRC(420,Z("ST"),1,Z("CP"),4,Z("FY"),1)=Z("SCPB")
EX ;
EX1 KILL Z
QUIT
+1 ;
+2 ;PRCA data ^1=station #, ^2=fcp #, ^3=fy, ^4=QTR #, ^5=$amount (- for credit)
+3 ;PRCB=O if obligated balance, C if commited (and sub fcp)
EBAL(PRCA,PRCB) ;edit fcp (subfcp) commited/obligated balance without file 410
+1 NEW Z,A,B
+2 SET Z("ST")=+PRCA
SET Z("CP")=+$PIECE(PRCA,"^",2)
SET Z("FY")=$PIECE(PRCA,"^",3)
+3 SET Z("QT")=$PIECE(PRCA,"^",4)
SET Z("AMT")=+$PIECE(PRCA,"^",5)
SET X=Z("AMT")
SET Z(X)=X
+4 SET Z("SPC")=Z("QT")+1
SET Z("FPC")=Z("QT")+5
+5 DO ARFY
if '$DATA(Z("CPB"))
QUIT
+6 if PRCB="O"
DO 2
DO ST
if PRCB="C"
DO 1
DO ST
+7 QUIT
+8 ;
