- 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 Mar 13, 2025@21:04:56 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 ;
