- 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 Feb 18, 2025@23:44:08 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 ;
