- ACRFNY1 ;IHS/OIRM/DSD/THL,AEF - CREATE FINANCIAL ACCOUNTS FOR THE NEW FISCAL YEAR, ALL ACCOUNTS; [ 11/01/2001 9:44 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- ;;ROUTINE TO CREATE FINANCIAL ACCOUNTS FOR THE NEW FISCAL YEAR
- CREATE ;EP;TO CREATE NEXT FY ACCOUNTS
- S ACR1=0
- F S ACR1=$O(^TMP("ACRAPP",$J,ACR1)) Q:'ACR1 D
- .I '$P(^ACRAPP(ACR1,0),U,6),'$P(^(0),U,7),$P(^(0),U,16)=1 D APPC I 1
- .I '$P(^ACRAPP(ACR1,0),U,6),'$P(^(0),U,7),$P(^(0),U,16)'=1 S ACRAPP=ACR1
- .S ACRAPP=$P(^ACRAPP(ACR1,0),U,7)
- .Q:'$G(ACRAPP)
- .S ACR2=0
- .F S ACR2=$O(^TMP("ACRAPP",$J,ACR1,ACR2)) Q:'ACR2 D
- ..I '$P(^ACRALW(ACR2,0),U,6),'$P(^(0),U,7),$P(^(0),U,16)=1 D ALWC I 1
- ..E I '$P(^ACRALW(ACR2,0),U,6),'$P(^(0),U,7),$P(^(0),U,16)'=1 S ACRALW=ACR2
- ..E S ACRALW=$P(^ACRALW(ACR2,0),U,7)
- ..Q:'$G(ACRALW)
- ..S ACR3=0
- ..F S ACR3=$O(^TMP("ACRAPP",$J,ACR1,ACR2,ACR3)) Q:'ACR3 D
- ...I '$P(^ACRALC(ACR3,0),U,6),'$P(^(0),U,7),$P(^(0),U,16)=1 D ALCC I 1
- ...E I '$P(^ACRALC(ACR3,0),U,6),'$P(^(0),U,7),$P(^(0),U,16)'=1 S ACRALC=ACR3
- ...E S ACRALC=$P(^ACRALC(ACR3,0),U,7)
- ...Q:'$G(ACRALC)
- ...S ACR4=0
- ...F S ACR4=$O(^TMP("ACRAPP",$J,ACR1,ACR2,ACR3,ACR4)) Q:'ACR4 D
- ....I '$P(^ACRLOCB(ACR4,0),U,6),'$P(^(0),U,7),$P(^(0),U,16)=1 D ADAC
- Q
- APPC ;CREATE APPROPRIATION
- S X=0
- S DIC="^ACRAPP("
- S DIC(0)="L"
- D FILE^ACRFDIC
- W !,"NEW APPROPRIATION ",+Y," CREATED FOR APPROPRIATION: ",ACR1
- S (DA,ACRAPP,ACRNEWDA)=+Y
- S ^ACRAPP(ACRNEWDA,0)=^ACRAPP(ACR1,0)
- S $P(^ACRAPP(ACRNEWDA,0),U,2)=ACRAPPDA
- S ^ACRAPP(ACRNEWDA,"DT")=^ACRAPP(ACR1,"DT")
- S ^ACRAPP(ACRNEWDA,"CMT")=$G(^ACRAPP(ACR1,"CMT"))
- S ^ACRAPP(ACRNEWDA,"PURP")=$G(^ACRAPP(ACR1,"PURP"))
- S X=^ACRAPP(ACRNEWDA,"DT")
- S $P(X,U,10)=""
- S $P(X,U,11)=""
- S ^ACRAPP(ACRNEWDA,"DT")=X
- S %X="^ACRAPP("_ACR1_",""SC"","
- S %Y="^ACRAPP("_ACRNEWDA_",""SC"","
- S (ACRDIK,DIK)="^ACRAPP("
- S ACROLD=ACR1
- D DIK
- S ACRTOT=+^ACRAPP(ACRNEWDA,0)
- D APPC1
- S DA=ACR1
- S DIE="^ACRAPP("
- S DR=".06////1;.07////"_ACRNEWDA
- D DIE^ACRFDIC
- S DA=ACRNEWDA
- S DIE="^ACRAPP("
- S DR="10////"_ACRFYNEW_";.15////"_ACR1
- D DIE^ACRFDIC
- Q
- APPC1 ;CALCULATE RECURRING TOTAL
- N ACRX
- S ACRX=0
- F S ACRX=$O(^ACRAPP("ORIG",ACR1,ACRX)) Q:'ACRX I $P(^ACRAPP(ACRX,0),U,6)'=1,$P($G(^ACRAPP(ACRX,"DT")),U,3)="R" S ACRTOT=ACRTOT+^ACRAPP(ACRX,0)
- Q
- ALWC ;CREATE ALLOWANCE
- S X=0
- S DIC="^ACRALW("
- S DIC(0)="L"
- D FILE^ACRFDIC
- W !,"NEW ALLOWANCE ",+Y," CREATED FOR ALLOWANCE: ",ACR2
- S (DA,ACRALW,ACRNEWDA)=+Y
- S ^ACRALW(ACRNEWDA,0)=^ACRALW(ACR2,0)
- S ^ACRALW(ACRNEWDA,"DT")=^ACRALW(ACR2,"DT")
- S $P(^ACRALW(ACRNEWDA,"DT"),U,4)=ACRAPPDA
- S ^ACRALW(ACRNEWDA,"CMT")=$G(^ACRALW(ACR2,"CMT"))
- S ^ACRALW(ACRNEWDA,"PURP")=$G(^ACRALW(ACR2,"PURP"))
- S X=^ACRALW(ACRNEWDA,0)
- S $P(X,U,2)=ACRAPP
- S $P(X,U,10)=""
- S $P(X,U,11)=""
- S ^ACRALW(ACRNEWDA,0)=X
- S %X="^ACRALW("_(ACR2)_",""SC"","
- S %Y="^ACRALW("_ACRNEWDA_",""SC"","
- S (ACRDIK,DIK)="^ACRALW("
- S ACROLD=ACR2
- D DIK
- S ACRTOT=+^ACRALW(ACRNEWDA,0)
- D ALWC1
- S DA=ACR2
- S DIE="^ACRALW("
- S DR=".06////1;.07////"_ACRNEWDA
- D DIE^ACRFDIC
- S DA=ACRNEWDA
- S DIE="^ACRALW("
- S DR="10////"_ACRFYNEW_";.15////"_ACR2
- D DIE^ACRFDIC
- Q
- ALWC1 ;CALCULATE RECURRING TOTAL
- N ACRX
- S ACRX=0
- F S ACRX=$O(^ACRALW("ORIG",ACR2,ACRX)) Q:'ACRX I $P(^ACRALW(ACRX,0),U,6)'=1,$P($G(^ACRALW(ACRX,"DT")),U,3)="R" S ACRTOT=ACRTOT+^ACRALW(ACRX,0)
- Q
- ALCC ;CREATE SUB-ALLOWANCE
- S X=0
- S DIC="^ACRALC("
- S DIC(0)="L"
- D FILE^ACRFDIC
- W !,"NEW SUB-ALLOWANCE ",+Y," CREATED FOR SUB-ALLOWANCE: ",ACR3
- S (DA,ACRALC,ACRNEWDA)=+Y
- S ^ACRALC(ACRNEWDA,0)=^ACRALC(ACR3,0)
- S ^ACRALC(ACRNEWDA,"DT")=^ACRALC(ACR3,"DT")
- S $P(^ACRALC(ACRNEWDA,"DT"),U,4)=ACRAPPDA
- S ^ACRALC(ACRNEWDA,"CMT")=$G(^ACRALC(ACR3,"CMT"))
- S ^ACRALC(ACRNEWDA,"PURP")=$G(^ACRALC(ACR3,"PURP"))
- S X=^ACRALC(ACRNEWDA,0)
- S $P(X,U,2)=ACRAPP
- S $P(X,U,3)=ACRALW
- S $P(X,U,10)=""
- S $P(X,U,11)=""
- S ^ACRALC(ACRNEWDA,0)=X
- S %X="^ACRALC("_(ACR3)_",""SC"","
- S %Y="^ACRALC("_ACRNEWDA_",""SC"","
- S (ACRDIK,DIK)="^ACRALC("
- S ACROLD=ACR3
- D DIK
- S ACRTOT=+^ACRALC(ACRNEWDA,0)
- D ALCC1
- S DA=ACR3
- S DIE="^ACRALC("
- S DR=".06////1;.07////"_ACRNEWDA
- D DIE^ACRFDIC
- S DA=ACRNEWDA
- S DIE="^ACRALC("
- S DR="10////"_ACRFYNEW_";.15////"_ACR3
- D DIE^ACRFDIC
- Q
- ALCC1 ;CALCULATE RECURRING TOTAL
- N ACRX
- S ACRX=0
- F S ACRX=$O(^ACRALC("ORIG",ACR3,ACRX)) Q:'ACRX I $P(^ACRALC(ACRX,0),U,6)'=1,$P($G(^ACRALC(ACRX,"DT")),U,3)="R" S ACRTOT=ACRTOT+^ACRALC(ACRX,0)
- Q
- ADAC ;CREATE DEPARTMENT ACCOUNT
- S X=0
- S DIC="^ACRLOCB("
- S DIC(0)="L"
- D FILE^ACRFDIC
- W !,"NEW DEPARTMENT ACCOUNT ",+Y," CREATED FOR DEPARTMENT ACCOUNT: ",ACR4
- S (DA,ACRDAC,ACRNEWDA)=+Y
- S ^ACRLOCB(ACRNEWDA,0)=^ACRLOCB(ACR4,0)
- S ^ACRLOCB(ACRNEWDA,"DT")=^ACRLOCB(ACR4,"DT")
- S $P(^ACRLOCB(ACRNEWDA,"DT"),U,4)=ACRAPPDA
- S ^ACRLOCB(ACRNEWDA,"CMT")=$G(^ACRLOCB(ACR4,"CMT"))
- S ^ACRLOCB(ACRNEWDA,"PURP")=$G(^ACRLOCB(ACR4,"PURP"))
- S X=^ACRLOCB(ACRNEWDA,0)
- S $P(X,U,2)=ACRAPP
- S $P(X,U,3)=ACRALW
- S $P(X,U,4)=ACRALC
- S $P(X,U,10)=""
- S $P(X,U,11)=""
- S ^ACRLOCB(ACRNEWDA,0)=X
- S %X="^ACRLOCB("_ACR4_",""CC"","
- S %Y="^ACRLOCB("_ACRNEWDA_",""CC"","
- D %XY^%RCR
- S %X="^ACRLOCB("_ACR4_",2,"
- S %Y="^ACRLOCB("_ACRNEWDA_",2,"
- D %XY^%RCR
- S %X="^ACRLOCB("_ACR4_",""SC"","
- S %Y="^ACRLOCB("_ACRNEWDA_",""SC"","
- S (ACRDIK,DIK)="^ACRLOCB("
- S ACROLD=ACR4
- D DIK
- S ACRTOT=+^ACRLOCB(ACRNEWDA,0)
- D ADAC1
- S DA=ACR4
- S DIE="^ACRLOCB("
- S DR=".06////1;.07////"_ACRNEWDA
- D DIE^ACRFDIC
- S DA=ACRNEWDA
- S DIE="^ACRLOCB("
- S DR="10////"_ACRFYNEW_";.15////"_ACR4
- D DIE^ACRFDIC
- Q
- ADAC1 ;CALCULATE RECURRING TOTAL
- N ACRX
- S ACRX=0
- F S ACRX=$O(^ACRLOCB("ORIG",ACR4,ACRX)) Q:'ACRX I $P(^ACRLOCB(ACRX,0),U,6)'=1,$P($G(^ACRLOCB(ACRX,"DT")),U,3)="R" S ACRTOT=ACRTOT+^ACRLOCB(ACRX,0)
- Q
- DIK ;RE-INDEX NEWLY CREATED ACCOUNTS
- D %XY^%RCR
- S DA(1)=ACRNEWDA
- D IX1^ACRFDIC
- I $D(ACRMM) D UP^ACRFNY2
- Q
- ACRFNY1 ;IHS/OIRM/DSD/THL,AEF - CREATE FINANCIAL ACCOUNTS FOR THE NEW FISCAL YEAR, ALL ACCOUNTS; [ 11/01/2001 9:44 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- +2 ;;ROUTINE TO CREATE FINANCIAL ACCOUNTS FOR THE NEW FISCAL YEAR
- CREATE ;EP;TO CREATE NEXT FY ACCOUNTS
- +1 SET ACR1=0
- +2 FOR
- SET ACR1=$ORDER(^TMP("ACRAPP",$JOB,ACR1))
- IF 'ACR1
- QUIT
- Begin DoDot:1
- +3 IF '$PIECE(^ACRAPP(ACR1,0),U,6)
- IF '$PIECE(^(0),U,7)
- IF $PIECE(^(0),U,16)=1
- DO APPC
- IF 1
- +4 IF '$PIECE(^ACRAPP(ACR1,0),U,6)
- IF '$PIECE(^(0),U,7)
- IF $PIECE(^(0),U,16)'=1
- SET ACRAPP=ACR1
- +5 SET ACRAPP=$PIECE(^ACRAPP(ACR1,0),U,7)
- +6 IF '$GET(ACRAPP)
- QUIT
- +7 SET ACR2=0
- +8 FOR
- SET ACR2=$ORDER(^TMP("ACRAPP",$JOB,ACR1,ACR2))
- IF 'ACR2
- QUIT
- Begin DoDot:2
- +9 IF '$PIECE(^ACRALW(ACR2,0),U,6)
- IF '$PIECE(^(0),U,7)
- IF $PIECE(^(0),U,16)=1
- DO ALWC
- IF 1
- +10 IF '$TEST
- IF '$PIECE(^ACRALW(ACR2,0),U,6)
- IF '$PIECE(^(0),U,7)
- IF $PIECE(^(0),U,16)'=1
- SET ACRALW=ACR2
- +11 IF '$TEST
- SET ACRALW=$PIECE(^ACRALW(ACR2,0),U,7)
- +12 IF '$GET(ACRALW)
- QUIT
- +13 SET ACR3=0
- +14 FOR
- SET ACR3=$ORDER(^TMP("ACRAPP",$JOB,ACR1,ACR2,ACR3))
- IF 'ACR3
- QUIT
- Begin DoDot:3
- +15 IF '$PIECE(^ACRALC(ACR3,0),U,6)
- IF '$PIECE(^(0),U,7)
- IF $PIECE(^(0),U,16)=1
- DO ALCC
- IF 1
- +16 IF '$TEST
- IF '$PIECE(^ACRALC(ACR3,0),U,6)
- IF '$PIECE(^(0),U,7)
- IF $PIECE(^(0),U,16)'=1
- SET ACRALC=ACR3
- +17 IF '$TEST
- SET ACRALC=$PIECE(^ACRALC(ACR3,0),U,7)
- +18 IF '$GET(ACRALC)
- QUIT
- +19 SET ACR4=0
- +20 FOR
- SET ACR4=$ORDER(^TMP("ACRAPP",$JOB,ACR1,ACR2,ACR3,ACR4))
- IF 'ACR4
- QUIT
- Begin DoDot:4
- +21 IF '$PIECE(^ACRLOCB(ACR4,0),U,6)
- IF '$PIECE(^(0),U,7)
- IF $PIECE(^(0),U,16)=1
- DO ADAC
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +22 QUIT
- APPC ;CREATE APPROPRIATION
- +1 SET X=0
- +2 SET DIC="^ACRAPP("
- +3 SET DIC(0)="L"
- +4 DO FILE^ACRFDIC
- +5 WRITE !,"NEW APPROPRIATION ",+Y," CREATED FOR APPROPRIATION: ",ACR1
- +6 SET (DA,ACRAPP,ACRNEWDA)=+Y
- +7 SET ^ACRAPP(ACRNEWDA,0)=^ACRAPP(ACR1,0)
- +8 SET $PIECE(^ACRAPP(ACRNEWDA,0),U,2)=ACRAPPDA
- +9 SET ^ACRAPP(ACRNEWDA,"DT")=^ACRAPP(ACR1,"DT")
- +10 SET ^ACRAPP(ACRNEWDA,"CMT")=$GET(^ACRAPP(ACR1,"CMT"))
- +11 SET ^ACRAPP(ACRNEWDA,"PURP")=$GET(^ACRAPP(ACR1,"PURP"))
- +12 SET X=^ACRAPP(ACRNEWDA,"DT")
- +13 SET $PIECE(X,U,10)=""
- +14 SET $PIECE(X,U,11)=""
- +15 SET ^ACRAPP(ACRNEWDA,"DT")=X
- +16 SET %X="^ACRAPP("_ACR1_",""SC"","
- +17 SET %Y="^ACRAPP("_ACRNEWDA_",""SC"","
- +18 SET (ACRDIK,DIK)="^ACRAPP("
- +19 SET ACROLD=ACR1
- +20 DO DIK
- +21 SET ACRTOT=+^ACRAPP(ACRNEWDA,0)
- +22 DO APPC1
- +23 SET DA=ACR1
- +24 SET DIE="^ACRAPP("
- +25 SET DR=".06////1;.07////"_ACRNEWDA
- +26 DO DIE^ACRFDIC
- +27 SET DA=ACRNEWDA
- +28 SET DIE="^ACRAPP("
- +29 SET DR="10////"_ACRFYNEW_";.15////"_ACR1
- +30 DO DIE^ACRFDIC
- +31 QUIT
- APPC1 ;CALCULATE RECURRING TOTAL
- +1 NEW ACRX
- +2 SET ACRX=0
- +3 FOR
- SET ACRX=$ORDER(^ACRAPP("ORIG",ACR1,ACRX))
- IF 'ACRX
- QUIT
- IF $PIECE(^ACRAPP(ACRX,0),U,6)'=1
- IF $PIECE($GET(^ACRAPP(ACRX,"DT")),U,3)="R"
- SET ACRTOT=ACRTOT+^ACRAPP(ACRX,0)
- +4 QUIT
- ALWC ;CREATE ALLOWANCE
- +1 SET X=0
- +2 SET DIC="^ACRALW("
- +3 SET DIC(0)="L"
- +4 DO FILE^ACRFDIC
- +5 WRITE !,"NEW ALLOWANCE ",+Y," CREATED FOR ALLOWANCE: ",ACR2
- +6 SET (DA,ACRALW,ACRNEWDA)=+Y
- +7 SET ^ACRALW(ACRNEWDA,0)=^ACRALW(ACR2,0)
- +8 SET ^ACRALW(ACRNEWDA,"DT")=^ACRALW(ACR2,"DT")
- +9 SET $PIECE(^ACRALW(ACRNEWDA,"DT"),U,4)=ACRAPPDA
- +10 SET ^ACRALW(ACRNEWDA,"CMT")=$GET(^ACRALW(ACR2,"CMT"))
- +11 SET ^ACRALW(ACRNEWDA,"PURP")=$GET(^ACRALW(ACR2,"PURP"))
- +12 SET X=^ACRALW(ACRNEWDA,0)
- +13 SET $PIECE(X,U,2)=ACRAPP
- +14 SET $PIECE(X,U,10)=""
- +15 SET $PIECE(X,U,11)=""
- +16 SET ^ACRALW(ACRNEWDA,0)=X
- +17 SET %X="^ACRALW("_(ACR2)_",""SC"","
- +18 SET %Y="^ACRALW("_ACRNEWDA_",""SC"","
- +19 SET (ACRDIK,DIK)="^ACRALW("
- +20 SET ACROLD=ACR2
- +21 DO DIK
- +22 SET ACRTOT=+^ACRALW(ACRNEWDA,0)
- +23 DO ALWC1
- +24 SET DA=ACR2
- +25 SET DIE="^ACRALW("
- +26 SET DR=".06////1;.07////"_ACRNEWDA
- +27 DO DIE^ACRFDIC
- +28 SET DA=ACRNEWDA
- +29 SET DIE="^ACRALW("
- +30 SET DR="10////"_ACRFYNEW_";.15////"_ACR2
- +31 DO DIE^ACRFDIC
- +32 QUIT
- ALWC1 ;CALCULATE RECURRING TOTAL
- +1 NEW ACRX
- +2 SET ACRX=0
- +3 FOR
- SET ACRX=$ORDER(^ACRALW("ORIG",ACR2,ACRX))
- IF 'ACRX
- QUIT
- IF $PIECE(^ACRALW(ACRX,0),U,6)'=1
- IF $PIECE($GET(^ACRALW(ACRX,"DT")),U,3)="R"
- SET ACRTOT=ACRTOT+^ACRALW(ACRX,0)
- +4 QUIT
- ALCC ;CREATE SUB-ALLOWANCE
- +1 SET X=0
- +2 SET DIC="^ACRALC("
- +3 SET DIC(0)="L"
- +4 DO FILE^ACRFDIC
- +5 WRITE !,"NEW SUB-ALLOWANCE ",+Y," CREATED FOR SUB-ALLOWANCE: ",ACR3
- +6 SET (DA,ACRALC,ACRNEWDA)=+Y
- +7 SET ^ACRALC(ACRNEWDA,0)=^ACRALC(ACR3,0)
- +8 SET ^ACRALC(ACRNEWDA,"DT")=^ACRALC(ACR3,"DT")
- +9 SET $PIECE(^ACRALC(ACRNEWDA,"DT"),U,4)=ACRAPPDA
- +10 SET ^ACRALC(ACRNEWDA,"CMT")=$GET(^ACRALC(ACR3,"CMT"))
- +11 SET ^ACRALC(ACRNEWDA,"PURP")=$GET(^ACRALC(ACR3,"PURP"))
- +12 SET X=^ACRALC(ACRNEWDA,0)
- +13 SET $PIECE(X,U,2)=ACRAPP
- +14 SET $PIECE(X,U,3)=ACRALW
- +15 SET $PIECE(X,U,10)=""
- +16 SET $PIECE(X,U,11)=""
- +17 SET ^ACRALC(ACRNEWDA,0)=X
- +18 SET %X="^ACRALC("_(ACR3)_",""SC"","
- +19 SET %Y="^ACRALC("_ACRNEWDA_",""SC"","
- +20 SET (ACRDIK,DIK)="^ACRALC("
- +21 SET ACROLD=ACR3
- +22 DO DIK
- +23 SET ACRTOT=+^ACRALC(ACRNEWDA,0)
- +24 DO ALCC1
- +25 SET DA=ACR3
- +26 SET DIE="^ACRALC("
- +27 SET DR=".06////1;.07////"_ACRNEWDA
- +28 DO DIE^ACRFDIC
- +29 SET DA=ACRNEWDA
- +30 SET DIE="^ACRALC("
- +31 SET DR="10////"_ACRFYNEW_";.15////"_ACR3
- +32 DO DIE^ACRFDIC
- +33 QUIT
- ALCC1 ;CALCULATE RECURRING TOTAL
- +1 NEW ACRX
- +2 SET ACRX=0
- +3 FOR
- SET ACRX=$ORDER(^ACRALC("ORIG",ACR3,ACRX))
- IF 'ACRX
- QUIT
- IF $PIECE(^ACRALC(ACRX,0),U,6)'=1
- IF $PIECE($GET(^ACRALC(ACRX,"DT")),U,3)="R"
- SET ACRTOT=ACRTOT+^ACRALC(ACRX,0)
- +4 QUIT
- ADAC ;CREATE DEPARTMENT ACCOUNT
- +1 SET X=0
- +2 SET DIC="^ACRLOCB("
- +3 SET DIC(0)="L"
- +4 DO FILE^ACRFDIC
- +5 WRITE !,"NEW DEPARTMENT ACCOUNT ",+Y," CREATED FOR DEPARTMENT ACCOUNT: ",ACR4
- +6 SET (DA,ACRDAC,ACRNEWDA)=+Y
- +7 SET ^ACRLOCB(ACRNEWDA,0)=^ACRLOCB(ACR4,0)
- +8 SET ^ACRLOCB(ACRNEWDA,"DT")=^ACRLOCB(ACR4,"DT")
- +9 SET $PIECE(^ACRLOCB(ACRNEWDA,"DT"),U,4)=ACRAPPDA
- +10 SET ^ACRLOCB(ACRNEWDA,"CMT")=$GET(^ACRLOCB(ACR4,"CMT"))
- +11 SET ^ACRLOCB(ACRNEWDA,"PURP")=$GET(^ACRLOCB(ACR4,"PURP"))
- +12 SET X=^ACRLOCB(ACRNEWDA,0)
- +13 SET $PIECE(X,U,2)=ACRAPP
- +14 SET $PIECE(X,U,3)=ACRALW
- +15 SET $PIECE(X,U,4)=ACRALC
- +16 SET $PIECE(X,U,10)=""
- +17 SET $PIECE(X,U,11)=""
- +18 SET ^ACRLOCB(ACRNEWDA,0)=X
- +19 SET %X="^ACRLOCB("_ACR4_",""CC"","
- +20 SET %Y="^ACRLOCB("_ACRNEWDA_",""CC"","
- +21 DO %XY^%RCR
- +22 SET %X="^ACRLOCB("_ACR4_",2,"
- +23 SET %Y="^ACRLOCB("_ACRNEWDA_",2,"
- +24 DO %XY^%RCR
- +25 SET %X="^ACRLOCB("_ACR4_",""SC"","
- +26 SET %Y="^ACRLOCB("_ACRNEWDA_",""SC"","
- +27 SET (ACRDIK,DIK)="^ACRLOCB("
- +28 SET ACROLD=ACR4
- +29 DO DIK
- +30 SET ACRTOT=+^ACRLOCB(ACRNEWDA,0)
- +31 DO ADAC1
- +32 SET DA=ACR4
- +33 SET DIE="^ACRLOCB("
- +34 SET DR=".06////1;.07////"_ACRNEWDA
- +35 DO DIE^ACRFDIC
- +36 SET DA=ACRNEWDA
- +37 SET DIE="^ACRLOCB("
- +38 SET DR="10////"_ACRFYNEW_";.15////"_ACR4
- +39 DO DIE^ACRFDIC
- +40 QUIT
- ADAC1 ;CALCULATE RECURRING TOTAL
- +1 NEW ACRX
- +2 SET ACRX=0
- +3 FOR
- SET ACRX=$ORDER(^ACRLOCB("ORIG",ACR4,ACRX))
- IF 'ACRX
- QUIT
- IF $PIECE(^ACRLOCB(ACRX,0),U,6)'=1
- IF $PIECE($GET(^ACRLOCB(ACRX,"DT")),U,3)="R"
- SET ACRTOT=ACRTOT+^ACRLOCB(ACRX,0)
- +4 QUIT
- DIK ;RE-INDEX NEWLY CREATED ACCOUNTS
- +1 DO %XY^%RCR
- +2 SET DA(1)=ACRNEWDA
- +3 DO IX1^ACRFDIC
- +4 IF $DATA(ACRMM)
- DO UP^ACRFNY2
- +5 QUIT
