- 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
