PRCFOOR1 ;WISC@ALTOONA/CTB-SNAPSHOT OF CP BALANCES ;9/29/94 8:40 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;;THIS ROUTINE WILL RECALCULATE ALL CP BALANCES FOR THE CURRENT FY,
;;THEN TAKE A SNAPSHOT OF THE BALANCE FOR THE CURRENT QUARTER
;;AND STORE THE BALANCE IN 420. IT WILL THEN ZERO OUT ALL QUARTERS
;;IN THE CURRENT FY - EXCEPT FOR THE CURRENT QUARTER.
;;
;RECALCULATE ALL CONTROL POINTS
S X="Beginning recalculation of balances for ALL Fund Control Points." D MSG^PRCFQ
D ALLCP^PRCBRCP
S X="< Recalculation complete>*" D MSG^PRCFQ
X S X=DT D FYQ^PRCFSITE
STA W !! S X="Beginning process to record existing Fund Control Point balances in file 420.99. (Snapshot)" D MSG^PRCFQ
F PRC("SITE")=0:0 S PRC("SITE")=$O(^PRC(420,PRC("SITE"))) Q:+PRC("SITE")=0 W !,PRC("SITE") D CP
S X="< Snapshot complete>*" D MSG^PRCFQ
ZERO W !! S X="Beginning process to 'zero' out previous quarter balances.*" D MSG^PRCFQ
N PRCRI S PRCRI(420.99)=0
F S PRCRI(420.99)=$O(^PRCU(420.99,PRCRI(420.99))) Q:'PRCRI(420.99) S DA=PRCRI(420.99) D XF
S X="< Process complete>*" D MSG^PRCFQ
GPF W !! S X="Beginning process to summarize General Post Fund Control Points" D MSG^PRCFQ
;CREATE RECORD FOR GENERAL POST FUND SUMMARY CONTROL POINT
;SUMMARIZE, BY STATION, GPF BALANCES
;SET BALANCES
;ZERO CURRENT QUARTER
S XDA=0 F S XDA=$O(^PRCU(420.99,XDA)) Q:'XDA I $P(^(XDA,0),"^",11)=1 D GPF1(XDA)
S SITE=0
F S SITE=$O(GPFBAL(SITE)) Q:'SITE D GPF2(SITE,GPFBAL(SITE))
K PRC
S X="< Process complete>*" D MSG^PRCFQ
QUIT
GPF2(SITE,AMT) ;SET BALANCE TO GPF SUMMARY CONTROL POINT
S PRC("CP")=$O(^PRC(420,SITE,1,"C","GPFS FMS CONVERSION",0))
I PRC("CP")="" QUIT
S PRC("CP")=$P(^PRC(420,SITE,1,PRC("CP"),0)," ")
S STRING=SITE_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
S X=STRING,DIC=420.99,DIC(0)="M" D ^DIC Q:+Y<0
S $P(^PRCU(420.99,+Y,0),"^",3)=AMT
D CONV^PRCSREC2(STRING,-AMT,"FMS CONVERSION ADJUSTMENT")
QUIT
GPF1(XDA) ;ZERO BALANCE IN EXISTING GPF CONTROL POINTS
N BAL,SITE,NODE,ID,AMT,STRING
S SITE=$P(^PRCU(420.99,XDA,0),"-"),BAL=$P(^(0),"^",3),GPFBAL(SITE)=$G(GPFBAL(SITE))+BAL
;ZERO CURRENT QUARTER FOR GPF CP
S NODE=$G(^PRCU(420.99,XDA,0)) Q:NODE=""
S ID=$P(NODE,"^"),AMT=+$P(NODE,"^",3)
Q:AMT=0
S STRING=ID,$P(STRING,"-",3)=PRC("QTR") D CONV^PRCSREC2(STRING,+AMT,"FMS CONVERSION ADJUSTMENT")
S $P(^PRCU(420.99,XDA,0),"^",3)=0
W "."
QUIT
XF ;
N NODE,ID,QTR,I,STRING
S NODE=$G(^PRCU(420.99,DA,0)) Q:NODE=""
S ID=$P(NODE,"^"),QTR(1)=$P(NODE,"^",4),QTR(2)=$P(NODE,"^",5),QTR(3)=$P(NODE,"^",6)
F I=1:1:3 Q:'$D(QTR(I)) I +QTR(I)'=0 S STRING=ID,$P(STRING,"-",3)=I D CONV^PRCSREC2(STRING,+QTR(I),"FMS CONVERSION ADJUSTMENT")
W "."
QUIT
CP F PRC("CPN")=0:0 S PRC("CPN")=$O(^PRC(420,PRC("SITE"),1,PRC("CPN"))),PRC("CP")="" Q:+PRC("CPN")=0!(PRC("CPN")=9999) I $D(^(PRC("CPN"),0)) S PRC("CP")=$P(^(0)," ") Q:PRC("CP")="" D QTR
Q
QTR ;
NEW SNAP,DIC,DLAYGO,AMT,DATE,Y,DA,DR,DIE,TYPE,QTRBAL
S TYPE=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",12)
S X=$G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0))
S SNAP=$P(X,"^",PRC("QTR")+5),SNAP=0 ;mod for conversion 3 only
I PRC("QTR")>1 F I=1:1:(PRC("QTR")-1) S QTRBAL(I)=$P(X,"^",I+5)
S (DIC,DLAYGO)=420.99,DIC(0)="MNL",AMT=X,X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP"),DATE=DT D ^DIC
I Y<0 S FAIL="" QUIT
S DA=+Y,$P(^PRCU(420.99,DA,0),"^",2)=DATE,$P(^(0),"^",3)=SNAP,$P(^(0),"^",4)=$G(QTRBAL(1)),$P(^(0),"^",5)=$G(QTRBAL(2)),$P(^(0),"^",6)=$G(QTRBAL(3))
S $P(^PRCU(420.99,DA,0),"^",11)=+TYPE,$P(^(0),"^",7)=PRC("QTR")
W "." QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFOOR1 3650 printed Nov 22, 2024@17:14:15 Page 2
PRCFOOR1 ;WISC@ALTOONA/CTB-SNAPSHOT OF CP BALANCES ;9/29/94 8:40 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;;THIS ROUTINE WILL RECALCULATE ALL CP BALANCES FOR THE CURRENT FY,
+3 ;;THEN TAKE A SNAPSHOT OF THE BALANCE FOR THE CURRENT QUARTER
+4 ;;AND STORE THE BALANCE IN 420. IT WILL THEN ZERO OUT ALL QUARTERS
+5 ;;IN THE CURRENT FY - EXCEPT FOR THE CURRENT QUARTER.
+6 ;;
+7 ;RECALCULATE ALL CONTROL POINTS
+8 SET X="Beginning recalculation of balances for ALL Fund Control Points."
DO MSG^PRCFQ
+9 DO ALLCP^PRCBRCP
+10 SET X="< Recalculation complete>*"
DO MSG^PRCFQ
X SET X=DT
DO FYQ^PRCFSITE
STA WRITE !!
SET X="Beginning process to record existing Fund Control Point balances in file 420.99. (Snapshot)"
DO MSG^PRCFQ
+1 FOR PRC("SITE")=0:0
SET PRC("SITE")=$ORDER(^PRC(420,PRC("SITE")))
if +PRC("SITE")=0
QUIT
WRITE !,PRC("SITE")
DO CP
+2 SET X="< Snapshot complete>*"
DO MSG^PRCFQ
ZERO WRITE !!
SET X="Beginning process to 'zero' out previous quarter balances.*"
DO MSG^PRCFQ
+1 NEW PRCRI
SET PRCRI(420.99)=0
+2 FOR
SET PRCRI(420.99)=$ORDER(^PRCU(420.99,PRCRI(420.99)))
if 'PRCRI(420.99)
QUIT
SET DA=PRCRI(420.99)
DO XF
+3 SET X="< Process complete>*"
DO MSG^PRCFQ
GPF WRITE !!
SET X="Beginning process to summarize General Post Fund Control Points"
DO MSG^PRCFQ
+1 ;CREATE RECORD FOR GENERAL POST FUND SUMMARY CONTROL POINT
+2 ;SUMMARIZE, BY STATION, GPF BALANCES
+3 ;SET BALANCES
+4 ;ZERO CURRENT QUARTER
+5 SET XDA=0
FOR
SET XDA=$ORDER(^PRCU(420.99,XDA))
if 'XDA
QUIT
IF $PIECE(^(XDA,0),"^",11)=1
DO GPF1(XDA)
+6 SET SITE=0
+7 FOR
SET SITE=$ORDER(GPFBAL(SITE))
if 'SITE
QUIT
DO GPF2(SITE,GPFBAL(SITE))
+8 KILL PRC
+9 SET X="< Process complete>*"
DO MSG^PRCFQ
+10 QUIT
GPF2(SITE,AMT) ;SET BALANCE TO GPF SUMMARY CONTROL POINT
+1 SET PRC("CP")=$ORDER(^PRC(420,SITE,1,"C","GPFS FMS CONVERSION",0))
+2 IF PRC("CP")=""
QUIT
+3 SET PRC("CP")=$PIECE(^PRC(420,SITE,1,PRC("CP"),0)," ")
+4 SET STRING=SITE_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
+5 SET X=STRING
SET DIC=420.99
SET DIC(0)="M"
DO ^DIC
if +Y<0
QUIT
+6 SET $PIECE(^PRCU(420.99,+Y,0),"^",3)=AMT
+7 DO CONV^PRCSREC2(STRING,-AMT,"FMS CONVERSION ADJUSTMENT")
+8 QUIT
GPF1(XDA) ;ZERO BALANCE IN EXISTING GPF CONTROL POINTS
+1 NEW BAL,SITE,NODE,ID,AMT,STRING
+2 SET SITE=$PIECE(^PRCU(420.99,XDA,0),"-")
SET BAL=$PIECE(^(0),"^",3)
SET GPFBAL(SITE)=$GET(GPFBAL(SITE))+BAL
+3 ;ZERO CURRENT QUARTER FOR GPF CP
+4 SET NODE=$GET(^PRCU(420.99,XDA,0))
if NODE=""
QUIT
+5 SET ID=$PIECE(NODE,"^")
SET AMT=+$PIECE(NODE,"^",3)
+6 if AMT=0
QUIT
+7 SET STRING=ID
SET $PIECE(STRING,"-",3)=PRC("QTR")
DO CONV^PRCSREC2(STRING,+AMT,"FMS CONVERSION ADJUSTMENT")
+8 SET $PIECE(^PRCU(420.99,XDA,0),"^",3)=0
+9 WRITE "."
+10 QUIT
XF ;
+1 NEW NODE,ID,QTR,I,STRING
+2 SET NODE=$GET(^PRCU(420.99,DA,0))
if NODE=""
QUIT
+3 SET ID=$PIECE(NODE,"^")
SET QTR(1)=$PIECE(NODE,"^",4)
SET QTR(2)=$PIECE(NODE,"^",5)
SET QTR(3)=$PIECE(NODE,"^",6)
+4 FOR I=1:1:3
if '$DATA(QTR(I))
QUIT
IF +QTR(I)'=0
SET STRING=ID
SET $PIECE(STRING,"-",3)=I
DO CONV^PRCSREC2(STRING,+QTR(I),"FMS CONVERSION ADJUSTMENT")
+5 WRITE "."
+6 QUIT
CP FOR PRC("CPN")=0:0
SET PRC("CPN")=$ORDER(^PRC(420,PRC("SITE"),1,PRC("CPN")))
SET PRC("CP")=""
if +PRC("CPN")=0!(PRC("CPN")=9999)
QUIT
IF $DATA(^(PRC("CPN"),0))
SET PRC("CP")=$PIECE(^(0)," ")
if PRC("CP")=""
QUIT
DO QTR
+1 QUIT
QTR ;
+1 NEW SNAP,DIC,DLAYGO,AMT,DATE,Y,DA,DR,DIE,TYPE,QTRBAL
+2 SET TYPE=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",12)
+3 SET X=$GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0))
+4 ;mod for conversion 3 only
SET SNAP=$PIECE(X,"^",PRC("QTR")+5)
SET SNAP=0
+5 IF PRC("QTR")>1
FOR I=1:1:(PRC("QTR")-1)
SET QTRBAL(I)=$PIECE(X,"^",I+5)
+6 SET (DIC,DLAYGO)=420.99
SET DIC(0)="MNL"
SET AMT=X
SET X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")
SET DATE=DT
DO ^DIC
+7 IF Y<0
SET FAIL=""
QUIT
+8 SET DA=+Y
SET $PIECE(^PRCU(420.99,DA,0),"^",2)=DATE
SET $PIECE(^(0),"^",3)=SNAP
SET $PIECE(^(0),"^",4)=$GET(QTRBAL(1))
SET $PIECE(^(0),"^",5)=$GET(QTRBAL(2))
SET $PIECE(^(0),"^",6)=$GET(QTRBAL(3))
+9 SET $PIECE(^PRCU(420.99,DA,0),"^",11)=+TYPE
SET $PIECE(^(0),"^",7)=PRC("QTR")
+10 WRITE "."
QUIT
