- PRCB1B1 ;WISC/PLT-PRCB1B continue ; 05/01/94 4:09 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- QUIT ;invalid entry
- ;
- ;PRCC required data = quarter date
- ;PRC array
- TMEN ;rollover for all single year fcp
- N PRCB,PRCD,PRCE,PRCDI,PRCRICB,PRCLOCK
- N A,B,C
- S A=$$DATE^PRC0C("T","E"),A=$P(A,"^",4)_"/"_$P(A,"^",5)_"/"_$P(A,"^",3)
- I $D(ZTQUEUED) D KILL^%ZTLOAD
- D EN^DDIOL("IFCAP Rollover Fund Control Point Balance List Printed on "_A)
- D EN^DDIOL(" For Budget Fiscal Year: "_$P(PRCC,"^")_" Quarter: "_$P(PRCC,"^",2))
- S B=3 D ICLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",",.B)
- I 'B D EN^DDIOL(" Fund Control Point file in use, try later!") QUIT
- S PRC("BBFY")=+PRCC
- S PRC("CP")=0,PRCOPT=1
- F S PRC("CP")=$O(^PRC(420,+PRC("SITE"),1,PRC("CP"))) Q:PRC("CP")>9998!'PRC("CP") I $P($G(^(PRC("CP"),5)),"^",7)<$P(PRCC,"^",7) S PRCD=$G(^(0)) D:PRCD]""
- . D FCPTRF
- . QUIT
- D DCLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",")
- QUIT
- ;
- FCPTRF ; start rollup
- S PRCAPP=$$APP^PRC0C(PRC("SITE"),PRC("FY"),PRC("CP"))
- I PRCOPT=1,$P(PRCAPP,"^",1)["_/_" QUIT
- I PRCOPT=2,$P(PRCAPP,"^",1)'["_/_" QUIT
- Q:$P(PRCD,"^",20)'=1!$P(PRCD,"^",19)!'$P(PRCD,"^",21)
- S PRCB("AMOUNT")=$P($$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),1),"^",PRC("QTR"))
- Q:PRCB("AMOUNT")'>0
- S PRCE=$G(^PRC(420,+PRC("SITE"),1,+$P(PRCD,"^",21),0))
- Q:+PRCD=+PRCE!'PRCE
- S PRCAPP=$$APP^PRC0C(PRC("SITE"),PRC("FY"),+PRCE)
- I PRCOPT=1,$P(PRCAPP,"^",1)["_/_" QUIT
- I PRCOPT=2,$P(PRCAPP,"^",1)'["_/_" QUIT
- S PRCB("FRCP")=$P(PRCD,"^"),PRCB("TOCP")=$P(PRCE,"^")
- D EN^DDIOL("Roll "_$E(PRCB("FRCP"),1,30)_" to "_$E(PRCB("TOCP"),1,30)_" $"_$FN(PRCB("AMOUNT"),"",2))
- S PRCACF=$$ACC^PRC0C(PRC("SITE"),PRCB("FRCP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
- S PRCACT=$$ACC^PRC0C(PRC("SITE"),PRCB("TOCP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
- I $P(PRCACF,"^")-$P(PRCACT,"^") D EN^DDIOL(" Error: must be in the same A/O!") QUIT
- I $P(PRCACF,"^",9)-$P(PRCACT,"^",9) D EN^DDIOL(" Error: must be in the same fund!") QUIT
- I $P(PRCACF,"^",2)'=$P(PRCACT,"^",2),$P(PRCACF,"^",8)="N" D EN^DDIOL(" Error: fund transfer not allowed") QUIT
- S PRCQT="" D A421
- I PRCQT D EN^DDIOL(" Error: Txn number can not be assigned") QUIT
- S PRCDI="420;^PRC(420,;"_(+PRC("SITE"))_"~420.01;^PRC(420,"_(+PRC("SITE"))_",1,;"_PRC("CP")
- D EDIT^PRC0B(.X,PRCDI,"30///^S X="_$P(PRCC,"^",7),"LS")
- QUIT
- ;
- A421 ;add record in file 421
- S PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY"),PRCB("QTR")=PRC("QTR")
- S PRCB("TDT")=$P($$DATE^PRC0C("T","E"),"^",7),PRCB("RNR")="NR"
- S PRCB("ANAMT")=""
- D POST^PRCBSTF Q:PRCQT
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1B1 2644 printed Jan 18, 2025@03:01:28 Page 2
- PRCB1B1 ;WISC/PLT-PRCB1B continue ; 05/01/94 4:09 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;invalid entry
- QUIT
- +3 ;
- +4 ;PRCC required data = quarter date
- +5 ;PRC array
- TMEN ;rollover for all single year fcp
- +1 NEW PRCB,PRCD,PRCE,PRCDI,PRCRICB,PRCLOCK
- +2 NEW A,B,C
- +3 SET A=$$DATE^PRC0C("T","E")
- SET A=$PIECE(A,"^",4)_"/"_$PIECE(A,"^",5)_"/"_$PIECE(A,"^",3)
- +4 IF $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- +5 DO EN^DDIOL("IFCAP Rollover Fund Control Point Balance List Printed on "_A)
- +6 DO EN^DDIOL(" For Budget Fiscal Year: "_$PIECE(PRCC,"^")_" Quarter: "_$PIECE(PRCC,"^",2))
- +7 SET B=3
- DO ICLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",",.B)
- +8 IF 'B
- DO EN^DDIOL(" Fund Control Point file in use, try later!")
- QUIT
- +9 SET PRC("BBFY")=+PRCC
- +10 SET PRC("CP")=0
- SET PRCOPT=1
- +11 FOR
- SET PRC("CP")=$ORDER(^PRC(420,+PRC("SITE"),1,PRC("CP")))
- if PRC("CP")>9998!'PRC("CP")
- QUIT
- IF $PIECE($GET(^(PRC("CP"),5)),"^",7)<$PIECE(PRCC,"^",7)
- SET PRCD=$GET(^(0))
- if PRCD]""
- Begin DoDot:1
- +12 DO FCPTRF
- +13 QUIT
- End DoDot:1
- +14 DO DCLOCK^PRC0B("^PRC(420,"_(+PRC("SITE"))_",")
- +15 QUIT
- +16 ;
- FCPTRF ; start rollup
- +1 SET PRCAPP=$$APP^PRC0C(PRC("SITE"),PRC("FY"),PRC("CP"))
- +2 IF PRCOPT=1
- IF $PIECE(PRCAPP,"^",1)["_/_"
- QUIT
- +3 IF PRCOPT=2
- IF $PIECE(PRCAPP,"^",1)'["_/_"
- QUIT
- +4 if $PIECE(PRCD,"^",20)'=1!$PIECE(PRCD,"^",19)!'$PIECE(PRCD,"^",21)
- QUIT
- +5 SET PRCB("AMOUNT")=$PIECE($$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),1),"^",PRC("QTR"))
- +6 if PRCB("AMOUNT")'>0
- QUIT
- +7 SET PRCE=$GET(^PRC(420,+PRC("SITE"),1,+$PIECE(PRCD,"^",21),0))
- +8 if +PRCD=+PRCE!'PRCE
- QUIT
- +9 SET PRCAPP=$$APP^PRC0C(PRC("SITE"),PRC("FY"),+PRCE)
- +10 IF PRCOPT=1
- IF $PIECE(PRCAPP,"^",1)["_/_"
- QUIT
- +11 IF PRCOPT=2
- IF $PIECE(PRCAPP,"^",1)'["_/_"
- QUIT
- +12 SET PRCB("FRCP")=$PIECE(PRCD,"^")
- SET PRCB("TOCP")=$PIECE(PRCE,"^")
- +13 DO EN^DDIOL("Roll "_$EXTRACT(PRCB("FRCP"),1,30)_" to "_$EXTRACT(PRCB("TOCP"),1,30)_" $"_$FNUMBER(PRCB("AMOUNT"),"",2))
- +14 SET PRCACF=$$ACC^PRC0C(PRC("SITE"),PRCB("FRCP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
- +15 SET PRCACT=$$ACC^PRC0C(PRC("SITE"),PRCB("TOCP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
- +16 IF $PIECE(PRCACF,"^")-$PIECE(PRCACT,"^")
- DO EN^DDIOL(" Error: must be in the same A/O!")
- QUIT
- +17 IF $PIECE(PRCACF,"^",9)-$PIECE(PRCACT,"^",9)
- DO EN^DDIOL(" Error: must be in the same fund!")
- QUIT
- +18 IF $PIECE(PRCACF,"^",2)'=$PIECE(PRCACT,"^",2)
- IF $PIECE(PRCACF,"^",8)="N"
- DO EN^DDIOL(" Error: fund transfer not allowed")
- QUIT
- +19 SET PRCQT=""
- DO A421
- +20 IF PRCQT
- DO EN^DDIOL(" Error: Txn number can not be assigned")
- QUIT
- +21 SET PRCDI="420;^PRC(420,;"_(+PRC("SITE"))_"~420.01;^PRC(420,"_(+PRC("SITE"))_",1,;"_PRC("CP")
- +22 DO EDIT^PRC0B(.X,PRCDI,"30///^S X="_$PIECE(PRCC,"^",7),"LS")
- +23 QUIT
- +24 ;
- A421 ;add record in file 421
- +1 SET PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY")
- SET PRCB("QTR")=PRC("QTR")
- +2 SET PRCB("TDT")=$PIECE($$DATE^PRC0C("T","E"),"^",7)
- SET PRCB("RNR")="NR"
- +3 SET PRCB("ANAMT")=""
- +4 DO POST^PRCBSTF
- if PRCQT
- QUIT
- +5 QUIT