ACRFCALC ;IHS/OIRM/DSD/THL,AEF - SELECTED FINANCIAL CALCULATIONS; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ROUTINE USED TO RECALCULATE ALL FINANCIAL TRANSACTIONS
EN ;EP;TO RECALCULATE DATABASE
D ^XBKVAR
D EN1
EXIT K ACRY,ACRDA,ACRQUIT,DIE,DA,DR,ACR2,ACRREQ,ACROBL,ACRSPT,ACRX,ACR,ACRDA
Q
EN1 W @IOF
W !,"Recalculation of the database can take from several minutes."
W !
S DIR(0)="Y"
S DIR("A")="Sure you want to recalculate"
S DIR("B")="NO"
D DIR^ACRFDIC
I ACRY'=1!$D(ACRQUIT)!$D(ACROUT) D Q
.W !!,"NO RECALCULATION HAS TAKEN PLACE."
.H 2
;SYNCHRONIZE OBLIGATIONS, DISAPPROVAL/CANCELLATIONS
W !!
S ACRX=0
F S ACRX=$O(^ACROBL(ACRX)) Q:'ACRX D
.S X=$G(^ACROBL(ACRX,"APV"))
.S ACR=0
.F S ACR=$O(^ACRSS("J",ACRX,ACR)) Q:'ACR D
..S Y=$G(^ACRSS(ACR,"DT"))
..S Z=Y
..I $E(X)'="A" D
...S:$P(Y,U,9) $P(Y,U,9)=0
...S:$P(Y,U,21) $P(Y,U,21)=0
...I $E(X)="C"!($E(X)="D")!($P(X,U,3)="C")!($P(X,U,3)="D") D
....S $P(Y,U,4)=0,$P(Y,U,7)=0,$P(Y,U,21)=0
....Q:'$D(^ACRAL("E",ACRX))
....S ACRAL=0
....F S ACRAL=$O(^ACRAL("E",ACRX,ACRAL)) Q:'ACRAL I $P($G(^ACRAL(ACRAL,"DT")),U,9) S $P(^("DT"),U,9)="" W "*"
..Q:Z=Y
..W "."
..S ^ACRSS(ACR,"DT")=Y
D ^ACRFCAL1
I $E($G(IOST),1,2)="C-" W !,"Recalculating Requests. Please wait."
D ALBOBL
I $E($G(IOST),1,2)="C-" W !,"Recalculating Sub-Allowances. Please wait."
D ALCOBL
I $E($G(IOST),1,2)="C-" W !,"Recalculating Allowances. Please wait."
D ALLTOBL
I $E($G(IOST),1,2)="C-" W !,"Recalculating Allotments. Please wait."
D APPOBL
I $E($G(IOST),1,2)="C-" W !!,"RECALCULATION COMPLETED" H 2
Q
APPOBL ;RECALCULATES ALL APPROPRIATIONS
S ACRDA=0,DIE="^ACRAPP("
F S ACRDA=$O(^ACRAPP(ACRDA)) Q:'ACRDA D
.S ACR2=0
.S (ACROBL,ACRREQ,ACRSPT)=0
.F S ACR2=$O(^ACROBL("PROP",ACRDA,ACR2)) Q:'ACR2 D
..S ACRREQ=ACRREQ+$G(^ACROBL(ACR2,0))
..S X=$G(^ACROBL(ACR2,"DT"))
..S ACRSPT=ACRSPT+$P(X,U,2)
..S ACROBL=ACROBL+$P(X,U,4)
.L +^ACRAPP(ACRDA,"BA"):4 Q:'$T
.S X=$G(^ACRAPP(ACRDA,"BA"))
.S $P(X,U,2)=ACRREQ
.S $P(X,U,3)=ACRSPT
.S $P(X,U,7)=ACROBL
.S ^ACRAPP(ACRDA,"BA")=X
.L -^ACRAPP(ACRDA,"BA"):0
Q
ALLTOBL ;RECALCULATES ALL ALLOWANCES
S ACRDA=0,DIE="^ACRALW("
F S ACRDA=$O(^ACRALW(ACRDA)) Q:'ACRDA D
.S ACR2=0
.S (ACROBL,ACRREQ,ACRSPT)=0
.F S ACR2=$O(^ACRSS("H",ACRDA,ACR2)) Q:'ACR2 D
..S X=$G(^ACRSS(ACR2,"DT"))
..S ACRREQ=ACRREQ+$P(X,U,4)
..S ACRSPT=ACRSPT+$P(X,U,21)
..S ACROBL=ACROBL+$P(X,U,9)
.L +^ACRALW(ACRDA,"BA"):4 Q:'$T
.S X=$G(^ACRALW(ACRDA,"BA"))
.S $P(X,U,2)=ACRREQ
.S $P(X,U,3)=ACRSPT
.S $P(X,U,7)=ACROBL
.S ^ACRALW(ACRDA,"BA")=X
.L -^ACRALW(ACRDA,"BA"):0
Q
ALCOBL ;RECALCULATES ALL SUB-ALLOWANCES
S ACRDA=0,DIE="^ACRALC("
F S ACRDA=$O(^ACRALC(ACRDA)) Q:'ACRDA D
.S ACR2=0
.S (ACROBL,ACRREQ,ACRSPT)=0
.F S ACR2=$O(^ACRSS("G",ACRDA,ACR2)) Q:'ACR2 D
..S X=$G(^ACRSS(ACR2,"DT"))
..S ACRREQ=ACRREQ+$P(X,U,4)
..S ACRSPT=ACRSPT+$P(X,U,21)
..S ACROBL=ACROBL+$P(X,U,9)
.L +^ACRALC(ACRDA,"BA"):4 Q:'$T
.S X=$G(^ACRALC(ACRDA,"BA"))
.S $P(X,U,2)=ACRREQ
.S $P(X,U,3)=ACRSPT
.S $P(X,U,7)=ACROBL
.S ^ACRALC(ACRDA,"BA")=X
.L -^ACRALC(ACRDA,"BA"):0
Q
ALBOBL ;RECALCULATES ALL DEPARTMENT ACCOUNTS
S ACRDA=0,DIE="^ACRLOCB("
F S ACRDA=$O(^ACRLOCB(ACRDA)) Q:'ACRDA D
.S ACR2=0
.S (ACROBL,ACRREQ,ACRSPT)=0
.F S ACR2=$O(^ACRSS("F",ACRDA,ACR2)) Q:'ACR2 D
..S X=$G(^ACRSS(ACR2,"DT"))
..S ACRREQ=ACRREQ+$P(X,U,4)
..S ACRSPT=ACRSPT+$P(X,U,21)
..S ACROBL=ACROBL+$P(X,U,9)
.L +^ACRLOCB(ACRDA,"BA"):4 Q:'$T
.S X=$G(^ACRLOCB(ACRDA,"BA"))
.S $P(X,U,2)=ACRREQ
.S $P(X,U,3)=ACRSPT
.S $P(X,U,7)=ACROBL
.S ^ACRLOCB(ACRDA,"BA")=X
.L -^ACRLOCB(ACRDA,"BA"):0
Q
ACRFCALC ;IHS/OIRM/DSD/THL,AEF - SELECTED FINANCIAL CALCULATIONS; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;ROUTINE USED TO RECALCULATE ALL FINANCIAL TRANSACTIONS
EN ;EP;TO RECALCULATE DATABASE
+1 DO ^XBKVAR
+2 DO EN1
EXIT KILL ACRY,ACRDA,ACRQUIT,DIE,DA,DR,ACR2,ACRREQ,ACROBL,ACRSPT,ACRX,ACR,ACRDA
+1 QUIT
EN1 WRITE @IOF
+1 WRITE !,"Recalculation of the database can take from several minutes."
+2 WRITE !
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Sure you want to recalculate"
+5 SET DIR("B")="NO"
+6 DO DIR^ACRFDIC
+7 IF ACRY'=1!$DATA(ACRQUIT)!$DATA(ACROUT)
Begin DoDot:1
+8 WRITE !!,"NO RECALCULATION HAS TAKEN PLACE."
+9 HANG 2
End DoDot:1
QUIT
+10 ;SYNCHRONIZE OBLIGATIONS, DISAPPROVAL/CANCELLATIONS
+11 WRITE !!
+12 SET ACRX=0
+13 FOR
SET ACRX=$ORDER(^ACROBL(ACRX))
IF 'ACRX
QUIT
Begin DoDot:1
+14 SET X=$GET(^ACROBL(ACRX,"APV"))
+15 SET ACR=0
+16 FOR
SET ACR=$ORDER(^ACRSS("J",ACRX,ACR))
IF 'ACR
QUIT
Begin DoDot:2
+17 SET Y=$GET(^ACRSS(ACR,"DT"))
+18 SET Z=Y
+19 IF $EXTRACT(X)'="A"
Begin DoDot:3
+20 IF $PIECE(Y,U,9)
SET $PIECE(Y,U,9)=0
+21 IF $PIECE(Y,U,21)
SET $PIECE(Y,U,21)=0
+22 IF $EXTRACT(X)="C"!($EXTRACT(X)="D")!($PIECE(X,U,3)="C")!($PIECE(X,U,3)="D")
Begin DoDot:4
+23 SET $PIECE(Y,U,4)=0
SET $PIECE(Y,U,7)=0
SET $PIECE(Y,U,21)=0
+24 IF '$DATA(^ACRAL("E",ACRX))
QUIT
+25 SET ACRAL=0
+26 FOR
SET ACRAL=$ORDER(^ACRAL("E",ACRX,ACRAL))
IF 'ACRAL
QUIT
IF $PIECE($GET(^ACRAL(ACRAL,"DT")),U,9)
SET $PIECE(^("DT"),U,9)=""
WRITE "*"
End DoDot:4
End DoDot:3
+27 IF Z=Y
QUIT
+28 WRITE "."
+29 SET ^ACRSS(ACR,"DT")=Y
End DoDot:2
End DoDot:1
+30 DO ^ACRFCAL1
+31 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE !,"Recalculating Requests. Please wait."
+32 DO ALBOBL
+33 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE !,"Recalculating Sub-Allowances. Please wait."
+34 DO ALCOBL
+35 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE !,"Recalculating Allowances. Please wait."
+36 DO ALLTOBL
+37 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE !,"Recalculating Allotments. Please wait."
+38 DO APPOBL
+39 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE !!,"RECALCULATION COMPLETED"
HANG 2
+40 QUIT
APPOBL ;RECALCULATES ALL APPROPRIATIONS
+1 SET ACRDA=0
SET DIE="^ACRAPP("
+2 FOR
SET ACRDA=$ORDER(^ACRAPP(ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+3 SET ACR2=0
+4 SET (ACROBL,ACRREQ,ACRSPT)=0
+5 FOR
SET ACR2=$ORDER(^ACROBL("PROP",ACRDA,ACR2))
IF 'ACR2
QUIT
Begin DoDot:2
+6 SET ACRREQ=ACRREQ+$GET(^ACROBL(ACR2,0))
+7 SET X=$GET(^ACROBL(ACR2,"DT"))
+8 SET ACRSPT=ACRSPT+$PIECE(X,U,2)
+9 SET ACROBL=ACROBL+$PIECE(X,U,4)
End DoDot:2
+10 LOCK +^ACRAPP(ACRDA,"BA"):4
IF '$TEST
QUIT
+11 SET X=$GET(^ACRAPP(ACRDA,"BA"))
+12 SET $PIECE(X,U,2)=ACRREQ
+13 SET $PIECE(X,U,3)=ACRSPT
+14 SET $PIECE(X,U,7)=ACROBL
+15 SET ^ACRAPP(ACRDA,"BA")=X
+16 LOCK -^ACRAPP(ACRDA,"BA"):0
End DoDot:1
+17 QUIT
ALLTOBL ;RECALCULATES ALL ALLOWANCES
+1 SET ACRDA=0
SET DIE="^ACRALW("
+2 FOR
SET ACRDA=$ORDER(^ACRALW(ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+3 SET ACR2=0
+4 SET (ACROBL,ACRREQ,ACRSPT)=0
+5 FOR
SET ACR2=$ORDER(^ACRSS("H",ACRDA,ACR2))
IF 'ACR2
QUIT
Begin DoDot:2
+6 SET X=$GET(^ACRSS(ACR2,"DT"))
+7 SET ACRREQ=ACRREQ+$PIECE(X,U,4)
+8 SET ACRSPT=ACRSPT+$PIECE(X,U,21)
+9 SET ACROBL=ACROBL+$PIECE(X,U,9)
End DoDot:2
+10 LOCK +^ACRALW(ACRDA,"BA"):4
IF '$TEST
QUIT
+11 SET X=$GET(^ACRALW(ACRDA,"BA"))
+12 SET $PIECE(X,U,2)=ACRREQ
+13 SET $PIECE(X,U,3)=ACRSPT
+14 SET $PIECE(X,U,7)=ACROBL
+15 SET ^ACRALW(ACRDA,"BA")=X
+16 LOCK -^ACRALW(ACRDA,"BA"):0
End DoDot:1
+17 QUIT
ALCOBL ;RECALCULATES ALL SUB-ALLOWANCES
+1 SET ACRDA=0
SET DIE="^ACRALC("
+2 FOR
SET ACRDA=$ORDER(^ACRALC(ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+3 SET ACR2=0
+4 SET (ACROBL,ACRREQ,ACRSPT)=0
+5 FOR
SET ACR2=$ORDER(^ACRSS("G",ACRDA,ACR2))
IF 'ACR2
QUIT
Begin DoDot:2
+6 SET X=$GET(^ACRSS(ACR2,"DT"))
+7 SET ACRREQ=ACRREQ+$PIECE(X,U,4)
+8 SET ACRSPT=ACRSPT+$PIECE(X,U,21)
+9 SET ACROBL=ACROBL+$PIECE(X,U,9)
End DoDot:2
+10 LOCK +^ACRALC(ACRDA,"BA"):4
IF '$TEST
QUIT
+11 SET X=$GET(^ACRALC(ACRDA,"BA"))
+12 SET $PIECE(X,U,2)=ACRREQ
+13 SET $PIECE(X,U,3)=ACRSPT
+14 SET $PIECE(X,U,7)=ACROBL
+15 SET ^ACRALC(ACRDA,"BA")=X
+16 LOCK -^ACRALC(ACRDA,"BA"):0
End DoDot:1
+17 QUIT
ALBOBL ;RECALCULATES ALL DEPARTMENT ACCOUNTS
+1 SET ACRDA=0
SET DIE="^ACRLOCB("
+2 FOR
SET ACRDA=$ORDER(^ACRLOCB(ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+3 SET ACR2=0
+4 SET (ACROBL,ACRREQ,ACRSPT)=0
+5 FOR
SET ACR2=$ORDER(^ACRSS("F",ACRDA,ACR2))
IF 'ACR2
QUIT
Begin DoDot:2
+6 SET X=$GET(^ACRSS(ACR2,"DT"))
+7 SET ACRREQ=ACRREQ+$PIECE(X,U,4)
+8 SET ACRSPT=ACRSPT+$PIECE(X,U,21)
+9 SET ACROBL=ACROBL+$PIECE(X,U,9)
End DoDot:2
+10 LOCK +^ACRLOCB(ACRDA,"BA"):4
IF '$TEST
QUIT
+11 SET X=$GET(^ACRLOCB(ACRDA,"BA"))
+12 SET $PIECE(X,U,2)=ACRREQ
+13 SET $PIECE(X,U,3)=ACRSPT
+14 SET $PIECE(X,U,7)=ACROBL
+15 SET ^ACRLOCB(ACRDA,"BA")=X
+16 LOCK -^ACRLOCB(ACRDA,"BA"):0
End DoDot:1
+17 QUIT
