PRCB0B ;WISC/PLT-utility recalculate fcp balance ; 12/12/94 8:56 AM
V ;;5.1;IFCAP;**145**;Oct 20, 2000;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
QUIT ;invalid entry
;
;prca=station #,prcb=fcp #, prcc=running balance fy (2-digit), prcd=quarter #
;total committed, obligated, ceiling txn amount
FCP(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=fiscal bal (unobligated)
; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
N PRCRI,PRCE,PRCF,PRCG,PRCH,PRCJ,PRCT,PRCACP
N A,B,C,D
S PRCC=$P($$YEAR^PRC0C(PRCC),"^",2) F A=1:1:3 S PRCT(A)=""
S PRCB=$P(PRCB," ")
S PRCE=$P($$QTRDATE^PRC0D(PRCC,PRCD),"^",7)_"-"_PRCA_"-"_PRCB_"-",PRCH=PRCE_"~"
F S PRCE=$O(^PRCS(410,"RB",PRCE)),PRCRI(410)=0 QUIT:PRCE]PRCH!'PRCE W:'$D(ZTQUEUED) !,PRCE D
. F S PRCRI(410)=$O(^PRCS(410,"RB",PRCE,PRCRI(410))) 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
.. S PRCACP=$P($G(^PRCS(410,PRCRI(410),4)),"^",14)
.. 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
.. I PRCG="C" S PRCT(3)=PRCT(3)+$J($P(A,"^",3),0,2) QUIT
.. 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
.. ;txn from option: enter fcp adjustment data or post issue book
.. 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
.. QUIT
S A=PRCT(3)-PRCT(1),B=PRCT(3)-PRCT(2)
QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
;
; see fcp comments
PO(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=betgetary bal (unobligated)
; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
N PRCRI,PRCE,PRCF,PRCT
N A,B,C,D
S PRCB=$P(PRCB," "),PRCC=+$$YEAR^PRC0C(PRCC) F A=1:1:3 S PRCT(A)=""
S PRCE=$$QTRDATE^PRC0D(PRCC,PRCD)
S A=$P(PRCE,"^",8)+100,A=$$DATE^PRC0C(A,"H")
S PRCG=$$QTRDATE^PRC0D(+A,$P(A,"^",2))
S PRCE=$P(PRCE,"^",7)-1,PRCG=$P(PRCG,"^",7)-1
F S PRCE=$O(^PRC(442,"AB",PRCE)) Q:PRCE>PRCG!'PRCE D
. S PRCRI(442)=0
. 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)
.. S PRCT(1)=PRCT(1)+$P(PRCF,"^",16),PRCT(2)=PRCT(2)+$P(PRCF,"^",16)
.. QUIT
. QUIT
S A=PRCT(3)-PRCT(1),B=PRCT(3)-PRCT(2)
QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
;
; see fcp comments
REC(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=betgetary bal (unobligated)
; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
N PRCRI,PRCE,PRCF,PRCT
N A,B,C,D
S PRCC=$P($$YEAR^PRC0C(PRCC),"^",2) F A=1:1:3 S PRCT(A)=""
S PRCB=$P(PRCB," "),PRCE=PRCA_"-"_PRCC_"-"_PRCD_"-"_PRCB
S PRCRI(417)=0
F S PRCRI(417)=$O(^PRCS(417,"C",PRCE,PRCRI(417))) QUIT:'PRCRI(417) S PRCF=$G(^PRCS(417,PRCRI(417),0)) D
. S A=$P(PRCF,"^",20)
. N TYPE,OBL,CUTOFF S TYPE=$P(PRCF,"^",17),OBL=$P(PRCF,"^",18),CUTOFF=$P($G(^PRCS(417,PRCRI(417),1)),"^")
. I CUTOFF'=1 S PRCT(1)=PRCT(1)+A
. I CUTOFF=1,TYPE'="CC",$E(OBL,4,7)'?4A S PRCT(1)=PRCT(1)+A
. S PRCT(2)=PRCT(2)+A
. QUIT
S A=PRCT(3)-PRCT(1),B=PRCT(3)-PRCT(2)
QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB0B 3419 printed Oct 16, 2024@18:00:53 Page 2
PRCB0B ;WISC/PLT-utility recalculate fcp balance ; 12/12/94 8:56 AM
V ;;5.1;IFCAP;**145**;Oct 20, 2000;Build 3
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ;prca=station #,prcb=fcp #, prcc=running balance fy (2-digit), prcd=quarter #
+5 ;total committed, obligated, ceiling txn amount
FCP(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=fiscal bal (unobligated)
+1 ; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
+2 NEW PRCRI,PRCE,PRCF,PRCG,PRCH,PRCJ,PRCT,PRCACP
+3 NEW A,B,C,D
+4 SET PRCC=$PIECE($$YEAR^PRC0C(PRCC),"^",2)
FOR A=1:1:3
SET PRCT(A)=""
+5 SET PRCB=$PIECE(PRCB," ")
+6 SET PRCE=$PIECE($$QTRDATE^PRC0D(PRCC,PRCD),"^",7)_"-"_PRCA_"-"_PRCB_"-"
SET PRCH=PRCE_"~"
+7 FOR
SET PRCE=$ORDER(^PRCS(410,"RB",PRCE))
SET PRCRI(410)=0
if PRCE]PRCH!'PRCE
QUIT
if '$DATA(ZTQUEUED)
WRITE !,PRCE
Begin DoDot:1
+8 FOR
SET PRCRI(410)=$ORDER(^PRCS(410,"RB",PRCE,PRCRI(410)))
if 'PRCRI(410)
QUIT
SET PRCF=$GET(^PRCS(410,PRCRI(410),0))
SET PRCG=$PIECE(PRCF,"^",2)
SET PRCF=$PIECE(PRCF,"^",4)
IF PRCG'="CA"
SET A=$GET(^(4))
SET B=$GET(^(7))
Begin DoDot:2
+9 SET PRCACP=$PIECE($GET(^PRCS(410,PRCRI(410),4)),"^",14)
+10 IF PRCG="O"
if $PIECE(B,"^",6)]""
SET PRCT(1)=PRCT(1)+$JUSTIFY($PIECE(A,"^",8),0,2)
if $PIECE(A,"^",10)]""
SET PRCT(2)=PRCT(2)+$JUSTIFY($PIECE(A,"^",3),0,2)
QUIT
+11 IF PRCG="C"
SET PRCT(3)=PRCT(3)+$JUSTIFY($PIECE(A,"^",3),0,2)
QUIT
+12 IF PRCG="A"
IF PRCF=1
if $PIECE(B,"^",6)]""
SET PRCT(1)=PRCT(1)+$JUSTIFY($PIECE(A,"^",8),0,2)
if $PIECE(A,"^",10)]""
SET PRCT(2)=PRCT(2)+$JUSTIFY($PIECE(A,"^",3),0,2)
QUIT
+13 ;txn from option: enter fcp adjustment data or post issue book
+14 IF PRCG="A"
SET PRCT(1)=PRCT(1)+$JUSTIFY($PIECE(A,"^",8),0,2)
if PRCACP'="Y"
SET PRCT(2)=PRCT(2)+$JUSTIFY($PIECE(A,"^",3),0,2)
QUIT
+15 QUIT
End DoDot:2
End DoDot:1
+16 SET A=PRCT(3)-PRCT(1)
SET B=PRCT(3)-PRCT(2)
+17 QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
+18 ;
+19 ; see fcp comments
PO(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=betgetary bal (unobligated)
+1 ; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
+2 NEW PRCRI,PRCE,PRCF,PRCT
+3 NEW A,B,C,D
+4 SET PRCB=$PIECE(PRCB," ")
SET PRCC=+$$YEAR^PRC0C(PRCC)
FOR A=1:1:3
SET PRCT(A)=""
+5 SET PRCE=$$QTRDATE^PRC0D(PRCC,PRCD)
+6 SET A=$PIECE(PRCE,"^",8)+100
SET A=$$DATE^PRC0C(A,"H")
+7 SET PRCG=$$QTRDATE^PRC0D(+A,$PIECE(A,"^",2))
+8 SET PRCE=$PIECE(PRCE,"^",7)-1
SET PRCG=$PIECE(PRCG,"^",7)-1
+9 FOR
SET PRCE=$ORDER(^PRC(442,"AB",PRCE))
if PRCE>PRCG!'PRCE
QUIT
Begin DoDot:1
+10 SET PRCRI(442)=0
+11 FOR
SET PRCRI(442)=$ORDER(^PRC(442,"AB",PRCE,PRCRI(442)))
if 'PRCRI(442)
QUIT
SET PRCF=$GET(^PRC(442,PRCRI(442),0))
IF $PIECE(PRCF,"^",12)=""
IF +PRCF=PRCA
IF +$PIECE(PRCF,"^",3)=+PRCB
if $PIECE($GET(^(12)),"^",2)]""&($GET(^(7))-45)
Begin DoDot:2
+12 SET PRCT(1)=PRCT(1)+$PIECE(PRCF,"^",16)
SET PRCT(2)=PRCT(2)+$PIECE(PRCF,"^",16)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 SET A=PRCT(3)-PRCT(1)
SET B=PRCT(3)-PRCT(2)
+16 QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
+17 ;
+18 ; see fcp comments
REC(PRCA,PRCB,PRCC,PRCD) ;EF value: 1^=fcp bal (uncommited), 2^=betgetary bal (unobligated)
+1 ; 3^=total commited amt, 4^=total obligated amt, 5^=total ceiling amt
+2 NEW PRCRI,PRCE,PRCF,PRCT
+3 NEW A,B,C,D
+4 SET PRCC=$PIECE($$YEAR^PRC0C(PRCC),"^",2)
FOR A=1:1:3
SET PRCT(A)=""
+5 SET PRCB=$PIECE(PRCB," ")
SET PRCE=PRCA_"-"_PRCC_"-"_PRCD_"-"_PRCB
+6 SET PRCRI(417)=0
+7 FOR
SET PRCRI(417)=$ORDER(^PRCS(417,"C",PRCE,PRCRI(417)))
if 'PRCRI(417)
QUIT
SET PRCF=$GET(^PRCS(417,PRCRI(417),0))
Begin DoDot:1
+8 SET A=$PIECE(PRCF,"^",20)
+9 NEW TYPE,OBL,CUTOFF
SET TYPE=$PIECE(PRCF,"^",17)
SET OBL=$PIECE(PRCF,"^",18)
SET CUTOFF=$PIECE($GET(^PRCS(417,PRCRI(417),1)),"^")
+10 IF CUTOFF'=1
SET PRCT(1)=PRCT(1)+A
+11 IF CUTOFF=1
IF TYPE'="CC"
IF $EXTRACT(OBL,4,7)'?4A
SET PRCT(1)=PRCT(1)+A
+12 SET PRCT(2)=PRCT(2)+A
+13 QUIT
End DoDot:1
+14 SET A=PRCT(3)-PRCT(1)
SET B=PRCT(3)-PRCT(2)
+15 QUIT A_"^"_B_"^"_PRCT(1)_"^"_PRCT(2)_"^"_PRCT(3)
+16 ;
