ACRFSHFT ;IHS/OIRM/DSD/THL,AEF - SHIFT ACCOUNTS; [ 11/02/2001 2:46 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;UTILITY TO SHIFT FINANCIAL ACCOUNTS
EN ;EP;
D EN1
EXIT K ACR,ACRSADA
Q
EN1 ;
AL ;SELECT ACCOUNT LEVEL
S DIR(0)="SO^1:Delete a Financial Account(s);2:Move a Financial Account"
S DIR("A")="Which one"
W !
D DIR^ACRFDIC
Q:$D(ACROUT)!$D(ACRQUIT)!'$D(Y)
Q:'ACRY
I Y=1 S ACRDEL=""
E K ACRDEL
S DIR(0)="SO^1:Department Account(s);2:Sub-Allowance(s);3:Allowance(s)"
S:$D(ACRDEL) DIR(0)=DIR(0)_";4:Appropriation(s)"
S DIR("A")="Which Account Level"
W !
D DIR^ACRFDIC
Q:$D(ACROUT)!$D(ACRQUIT)!'$D(Y)
Q:'ACRY
S ACRAL=ACRY ; SET ACCOUNT LEVEL VARIABLE
ID ;SELECT ID NO(S) TO SHIFT
S DIR(0)="LO^"_$S(ACRY=1:$O(^ACRLOCB(0)),ACRY=2:$O(^ACRALC(0)),ACRY=3:$O(^ACRALW(0)),1:$O(^ACRAPP(0)))_":"_$S(ACRY=1:$P(^ACRLOCB(0),U,3),ACRY=2:$P(^ACRALC(0),U,3),ACRY=3:$P(^ACRALW(0),U,3),1:$P(^ACRAPP(0),U,3))
S DIR("A")="Which ID NO(s)"
W !
D DIR^ACRFDIC
Q:$D(ACROUT)!$D(ACRQUIT)!'$D(Y)
Q:'ACRY
S ACRID=ACRY ; SET ID NO(S) VARIABLE
D:'$D(ACRDEL) TO
D WARN
Q
TO ;SELECT ACCOUNT TO SHIFT TO
S DIC(0)="AENQZ"
S DIC=$S(ACRAL=1:"^ACRALC(",ACRAL=2:"^ACRALW(",1:"^ACRAPP(")
S DIC("A")="Which "_$S(ACRAL=1:"Sub-Allowance",ACRAL=2:"Allowance",1:"Appropration")_": "
W !!,"Select the ",$S(ACRAL=1:"Sub-Allowance",ACRAL=2:"Allowance",1:"Appropration")," to move selected ",$S(ACRAL=1:"Department Account(s)",ACRAL=2:"Sub-Allowance(s)",1:"Allowance(s)")," to: "
W !
D DIC^ACRFDIC
I $D(ACROUT)!$D(ACRQUIT)!'$D(Y) S ACRQUIT="" Q
I Y<1 S ACRQUIT="" Q
S ACRTO=+Y ; SET ID NO VARIABLE OF ACCOUNT TO MOVE TO
Q
DEPT ;
F ACRI=1:1 S ACRLBDA=$P(ACRID,",",ACRI) Q:ACRLBDA="" D:$D(^ACRLOCB(ACRLBDA,0))
.I $D(ACRDEL) D Q
..I $D(^ACROBL("D",ACRLBDA)) D Q
...W *7,*7
...W !!,"Department Account ID NO. ",@ACRON,ACRLBDA,@ACROF," has dependent documents."
...W !,"It cannot be deleted."
...H 1
..I '$D(^ACROBL("D",ACRLBDA)) D Q
...I $D(^ACRLOCB("NEXTFY",ACRLBDA)) S DA=$O(^(ACRLBDA,0)) D:DA
....S DIE="^ACRLOCB("
....S DR=".06///@;.07///@"
....D DIE^ACRFDIC
...S DA=ACRLBDA
...S DIK="^ACRLOCB("
...D DIK^ACRFDIC
.S DA=ACRLBDA
.S DIE="^ACRLOCB("
.S DR=".04////"_ACRTO
.D DIE^ACRFDIC
.D CRQ
Q
SALW ;
F ACRI=1:1 S ACRSADA=$P(ACRID,",",ACRI) Q:ACRSADA="" I $D(^ACRALC(ACRSADA,0)) D
.I $D(ACRDEL) D Q
..I $D(^ACRLOCB("M",ACRSADA))!$D(^ACROBL("C",ACRSADA)) D Q
...W *7,*7
...W !!,"Sub-Allowance ID NO. ",@ACRON,ACRSADA,@ACROF," has dependent Department Accounts."
...W !,"It cannot be deleted."
...H 1
..I '$D(^ACRLOCB("M",ACRSADA))&'$D(^ACROBL("C",ACRSADA)) D Q
...I $D(^ACRALC("NEXTFY",ACRSADA)) S DA=$O(^(ACRSADA,0)) D:DA
....S DIE="^ACRALC("
....S DR=".06///@;.07///@"
....D DIE^ACRFDIC
...S DA=ACRSADA
...S DIK="^ACRALC("
...D DIK^ACRFDIC
.S DA=ACRSADA
.S DIE="^ACRALC("
.S DR=".03////"_ACRTO
.D DIE^ACRFDIC
.D CLB
Q
ALLW ;
F ACRI=1:1 S ACRALDA=$P(ACRID,",",ACRI) Q:ACRALDA="" I $D(^ACRALW(ACRALDA,0)) D
.I $D(ACRDEL) D Q
..I $D(^ACRALC("M",ACRALDA))!$D(^ACROBL("LOT",ACRALDA)) D Q
...W *7,*7
...W !!,"Allowance ID NO. ",@ACRON,ACRALDA,@ACROF," has dependent Sub-Allowances."
...W !,"It cannot be deleted."
...H 1
..I '$D(^ACRALC("M",ACRALDA))&'$D(^ACROBL("LOT",ACRALDA)) D Q
...I $D(^ACRALW("NEXTFY",ACRALDA)) S DA=$O(^(ACRALDA,0)) D:DA
....S DIE="^ACRALW("
....S DR=".06///@;.07///@"
....D DIE^ACRFDIC
...S DA=ACRALDA
...S DIK="^ACRALW("
...D DIK^ACRFDIC
.S DA=ACRALDA
.S DIE="^ACRALW("
.S DR=".02////"_ACRTO
.D DIE^ACRFDIC
.D CSA
Q
APPR ;DELETE APPROPRIATIONS
F ACRI=1:1 S ACRAPPDA=$P(ACRID,",",ACRI) Q:ACRAPPDA="" I $D(^ACRAPP(ACRAPPDA,0)) D
.I $D(ACRDEL) D Q
..I $D(^ACRALW("M",ACRAPPDA))!$D(^ACROBL("PROP",ACRAPPDA)) D Q
...W *7,*7
...W !!,"Allowance ID NO. ",@ACRON,ACRAPPDA,@ACROF," has dependent Sub-Allowances."
...W !,"It cannot be deleted."
...H 1
..I '$D(^ACRALW("M",ACRAPPDA))&'$D(^ACROBL("PROP",ACRAPPDA)) D Q
...I $D(^ACRAPP("NEXTFY",ACRAPPDA)) S DA=$O(^(ACRAPPDA,0)) D:DA
....S DIE="^ACRAPP("
....S DR=".06///@;.07///@"
....D DIE^ACRFDIC
...S DA=ACRAPPDA
...S DIK="^ACRAPP("
...D DIK^ACRFDIC
Q
WARN Q:$D(ACRQUIT)
D W1
S DIR(0)="YO"
S DIR("A")="Are you ABSOLUTELY CERTAIN this is what you want to do."
S DIR("B")="NO"
W !
D DIR^ACRFDIC
Q:$D(ACROUT)!$D(ACRQUIT)
Q:Y'=1
W !
D:$E($G(IOST),1,2)="C-" WAIT^DICD
I ACRAL=1 D DEPT Q
I ACRAL=2 D SALW Q
I ACRAL=3 D ALLW Q
I ACRAL=4 D APPR Q
Q
W1 W !!,"You have chosen to ",$S('$D(ACRDEL):"move ",1:"delete ")
W !,$S(ACRAL=1:"Department Account(s)",ACRAL=2:"Sub-Allowance(s)",ACRAL=3:"Allowance(s)",1:"Appropriation(s)"),": ",ACRID
W:'$D(ACRDEL) !," to ",$S(ACRAL=1:"Sub-Allowance",ACRAL=2:"Allowance",1:"Appropration")," ID NO: ",ACRTO
Q
P D PAUSE^ACRFWARN
Q
CSA ;CHANGE SUB-ALLOWANCE
S ACRSADA=0
F S ACRSADA=$O(^ACRALC("M",ACRALDA,ACRSADA)) Q:'ACRSADA D:$D(ACRALC(ACRSADA,0))
.S DA=ACRSADA
.S DIE="^ACRALC("
.S DR=".02////"_ACRTO_";.03////"_ACRALDA
.D DIE^ACRFDIC
.D CLB
Q
CLB ;CHANGE DEPARTMENT ACCOUNT
S ACRLBDA=0
F S ACRLBDA=$O(^ACRLOCB("M",ACRSADA,ACRLBDA)) Q:'ACRLBDA D:$D(^ACRLOCB(ACRLBDA,0))
.S DA=ACRLBDA
.S DIE="^ACRLOCB("
.S DR=".04////"_ACRSADA
.D DIE^ACRFDIC
.D CRQ
Q
CRQ ;CHANGE REQUEST
S ACRDOCDA=0
F S ACRDOCDA=$O(^ACROBL("D",ACRLBDA,ACRDOCDA)) Q:'ACRDOCDA D
.S DA=ACRDOCDA
.S DIE="^ACROBL("
.S DR=".03////"_ACRLBDA
.D DIE^ACRFDIC
CSUP ;CHANGE SUPPLY/ITEM FILE
S ACRSSDA=0
F S ACRSSDA=$O(^ACRSS("F",ACRLBDA,ACRSSDA)) Q:'ACRSSDA D
.S DA=ACRSSDA
.S DIE="^ACRSS("
.S DR=".06////"_ACRLBDA
.D DIE^ACRFDIC
Q
ACRFSHFT ;IHS/OIRM/DSD/THL,AEF - SHIFT ACCOUNTS; [ 11/02/2001 2:46 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;UTILITY TO SHIFT FINANCIAL ACCOUNTS
EN ;EP;
+1 DO EN1
EXIT KILL ACR,ACRSADA
+1 QUIT
EN1 ;
AL ;SELECT ACCOUNT LEVEL
+1 SET DIR(0)="SO^1:Delete a Financial Account(s);2:Move a Financial Account"
+2 SET DIR("A")="Which one"
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF $DATA(ACROUT)!$DATA(ACRQUIT)!'$DATA(Y)
QUIT
+6 IF 'ACRY
QUIT
+7 IF Y=1
SET ACRDEL=""
+8 IF '$TEST
KILL ACRDEL
+9 SET DIR(0)="SO^1:Department Account(s);2:Sub-Allowance(s);3:Allowance(s)"
+10 IF $DATA(ACRDEL)
SET DIR(0)=DIR(0)_";4:Appropriation(s)"
+11 SET DIR("A")="Which Account Level"
+12 WRITE !
+13 DO DIR^ACRFDIC
+14 IF $DATA(ACROUT)!$DATA(ACRQUIT)!'$DATA(Y)
QUIT
+15 IF 'ACRY
QUIT
+16 ; SET ACCOUNT LEVEL VARIABLE
SET ACRAL=ACRY
ID ;SELECT ID NO(S) TO SHIFT
+1 SET DIR(0)="LO^"_$SELECT(ACRY=1:$ORDER(^ACRLOCB(0)),ACRY=2:$ORDER(^ACRALC(0)),ACRY=3:$ORDER(^ACRALW(0)),1:$ORDER(^ACRAPP(0)))_":"_$SELECT(ACRY=1:$PIECE(^ACRLOCB(0),U,3),ACRY=2:$PIECE(^ACRALC(0),U,3),ACRY=3:$PIECE(^ACRALW(0),U,3),1:...
... $PIECE(^ACRAPP(0),U,3))
+2 SET DIR("A")="Which ID NO(s)"
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF $DATA(ACROUT)!$DATA(ACRQUIT)!'$DATA(Y)
QUIT
+6 IF 'ACRY
QUIT
+7 ; SET ID NO(S) VARIABLE
SET ACRID=ACRY
+8 IF '$DATA(ACRDEL)
DO TO
+9 DO WARN
+10 QUIT
TO ;SELECT ACCOUNT TO SHIFT TO
+1 SET DIC(0)="AENQZ"
+2 SET DIC=$SELECT(ACRAL=1:"^ACRALC(",ACRAL=2:"^ACRALW(",1:"^ACRAPP(")
+3 SET DIC("A")="Which "_$SELECT(ACRAL=1:"Sub-Allowance",ACRAL=2:"Allowance",1:"Appropration")_": "
+4 WRITE !!,"Select the ",$SELECT(ACRAL=1:"Sub-Allowance",ACRAL=2:"Allowance",1:"Appropration")," to move selected ",$SELECT(ACRAL=1:"Department Account(s)",ACRAL=2:"Sub-Allowance(s)",1:"Allowance(s)")," to: "
+5 WRITE !
+6 DO DIC^ACRFDIC
+7 IF $DATA(ACROUT)!$DATA(ACRQUIT)!'$DATA(Y)
SET ACRQUIT=""
QUIT
+8 IF Y<1
SET ACRQUIT=""
QUIT
+9 ; SET ID NO VARIABLE OF ACCOUNT TO MOVE TO
SET ACRTO=+Y
+10 QUIT
DEPT ;
+1 FOR ACRI=1:1
SET ACRLBDA=$PIECE(ACRID,",",ACRI)
IF ACRLBDA=""
QUIT
IF $DATA(^ACRLOCB(ACRLBDA,0))
Begin DoDot:1
+2 IF $DATA(ACRDEL)
Begin DoDot:2
+3 IF $DATA(^ACROBL("D",ACRLBDA))
Begin DoDot:3
+4 WRITE *7,*7
+5 WRITE !!,"Department Account ID NO. ",@ACRON,ACRLBDA,@ACROF," has dependent documents."
+6 WRITE !,"It cannot be deleted."
+7 HANG 1
End DoDot:3
QUIT
+8 IF '$DATA(^ACROBL("D",ACRLBDA))
Begin DoDot:3
+9 IF $DATA(^ACRLOCB("NEXTFY",ACRLBDA))
SET DA=$ORDER(^(ACRLBDA,0))
IF DA
Begin DoDot:4
+10 SET DIE="^ACRLOCB("
+11 SET DR=".06///@;.07///@"
+12 DO DIE^ACRFDIC
End DoDot:4
+13 SET DA=ACRLBDA
+14 SET DIK="^ACRLOCB("
+15 DO DIK^ACRFDIC
End DoDot:3
QUIT
End DoDot:2
QUIT
+16 SET DA=ACRLBDA
+17 SET DIE="^ACRLOCB("
+18 SET DR=".04////"_ACRTO
+19 DO DIE^ACRFDIC
+20 DO CRQ
End DoDot:1
+21 QUIT
SALW ;
+1 FOR ACRI=1:1
SET ACRSADA=$PIECE(ACRID,",",ACRI)
IF ACRSADA=""
QUIT
IF $DATA(^ACRALC(ACRSADA,0))
Begin DoDot:1
+2 IF $DATA(ACRDEL)
Begin DoDot:2
+3 IF $DATA(^ACRLOCB("M",ACRSADA))!$DATA(^ACROBL("C",ACRSADA))
Begin DoDot:3
+4 WRITE *7,*7
+5 WRITE !!,"Sub-Allowance ID NO. ",@ACRON,ACRSADA,@ACROF," has dependent Department Accounts."
+6 WRITE !,"It cannot be deleted."
+7 HANG 1
End DoDot:3
QUIT
+8 IF '$DATA(^ACRLOCB("M",ACRSADA))&'$DATA(^ACROBL("C",ACRSADA))
Begin DoDot:3
+9 IF $DATA(^ACRALC("NEXTFY",ACRSADA))
SET DA=$ORDER(^(ACRSADA,0))
IF DA
Begin DoDot:4
+10 SET DIE="^ACRALC("
+11 SET DR=".06///@;.07///@"
+12 DO DIE^ACRFDIC
End DoDot:4
+13 SET DA=ACRSADA
+14 SET DIK="^ACRALC("
+15 DO DIK^ACRFDIC
End DoDot:3
QUIT
End DoDot:2
QUIT
+16 SET DA=ACRSADA
+17 SET DIE="^ACRALC("
+18 SET DR=".03////"_ACRTO
+19 DO DIE^ACRFDIC
+20 DO CLB
End DoDot:1
+21 QUIT
ALLW ;
+1 FOR ACRI=1:1
SET ACRALDA=$PIECE(ACRID,",",ACRI)
IF ACRALDA=""
QUIT
IF $DATA(^ACRALW(ACRALDA,0))
Begin DoDot:1
+2 IF $DATA(ACRDEL)
Begin DoDot:2
+3 IF $DATA(^ACRALC("M",ACRALDA))!$DATA(^ACROBL("LOT",ACRALDA))
Begin DoDot:3
+4 WRITE *7,*7
+5 WRITE !!,"Allowance ID NO. ",@ACRON,ACRALDA,@ACROF," has dependent Sub-Allowances."
+6 WRITE !,"It cannot be deleted."
+7 HANG 1
End DoDot:3
QUIT
+8 IF '$DATA(^ACRALC("M",ACRALDA))&'$DATA(^ACROBL("LOT",ACRALDA))
Begin DoDot:3
+9 IF $DATA(^ACRALW("NEXTFY",ACRALDA))
SET DA=$ORDER(^(ACRALDA,0))
IF DA
Begin DoDot:4
+10 SET DIE="^ACRALW("
+11 SET DR=".06///@;.07///@"
+12 DO DIE^ACRFDIC
End DoDot:4
+13 SET DA=ACRALDA
+14 SET DIK="^ACRALW("
+15 DO DIK^ACRFDIC
End DoDot:3
QUIT
End DoDot:2
QUIT
+16 SET DA=ACRALDA
+17 SET DIE="^ACRALW("
+18 SET DR=".02////"_ACRTO
+19 DO DIE^ACRFDIC
+20 DO CSA
End DoDot:1
+21 QUIT
APPR ;DELETE APPROPRIATIONS
+1 FOR ACRI=1:1
SET ACRAPPDA=$PIECE(ACRID,",",ACRI)
IF ACRAPPDA=""
QUIT
IF $DATA(^ACRAPP(ACRAPPDA,0))
Begin DoDot:1
+2 IF $DATA(ACRDEL)
Begin DoDot:2
+3 IF $DATA(^ACRALW("M",ACRAPPDA))!$DATA(^ACROBL("PROP",ACRAPPDA))
Begin DoDot:3
+4 WRITE *7,*7
+5 WRITE !!,"Allowance ID NO. ",@ACRON,ACRAPPDA,@ACROF," has dependent Sub-Allowances."
+6 WRITE !,"It cannot be deleted."
+7 HANG 1
End DoDot:3
QUIT
+8 IF '$DATA(^ACRALW("M",ACRAPPDA))&'$DATA(^ACROBL("PROP",ACRAPPDA))
Begin DoDot:3
+9 IF $DATA(^ACRAPP("NEXTFY",ACRAPPDA))
SET DA=$ORDER(^(ACRAPPDA,0))
IF DA
Begin DoDot:4
+10 SET DIE="^ACRAPP("
+11 SET DR=".06///@;.07///@"
+12 DO DIE^ACRFDIC
End DoDot:4
+13 SET DA=ACRAPPDA
+14 SET DIK="^ACRAPP("
+15 DO DIK^ACRFDIC
End DoDot:3
QUIT
End DoDot:2
QUIT
End DoDot:1
+16 QUIT
WARN IF $DATA(ACRQUIT)
QUIT
+1 DO W1
+2 SET DIR(0)="YO"
+3 SET DIR("A")="Are you ABSOLUTELY CERTAIN this is what you want to do."
+4 SET DIR("B")="NO"
+5 WRITE !
+6 DO DIR^ACRFDIC
+7 IF $DATA(ACROUT)!$DATA(ACRQUIT)
QUIT
+8 IF Y'=1
QUIT
+9 WRITE !
+10 IF $EXTRACT($GET(IOST),1,2)="C-"
DO WAIT^DICD
+11 IF ACRAL=1
DO DEPT
QUIT
+12 IF ACRAL=2
DO SALW
QUIT
+13 IF ACRAL=3
DO ALLW
QUIT
+14 IF ACRAL=4
DO APPR
QUIT
+15 QUIT
W1 WRITE !!,"You have chosen to ",$SELECT('$DATA(ACRDEL):"move ",1:"delete ")
+1 WRITE !,$SELECT(ACRAL=1:"Department Account(s)",ACRAL=2:"Sub-Allowance(s)",ACRAL=3:"Allowance(s)",1:"Appropriation(s)"),": ",ACRID
+2 IF '$DATA(ACRDEL)
WRITE !," to ",$SELECT(ACRAL=1:"Sub-Allowance",ACRAL=2:"Allowance",1:"Appropration")," ID NO: ",ACRTO
+3 QUIT
P DO PAUSE^ACRFWARN
+1 QUIT
CSA ;CHANGE SUB-ALLOWANCE
+1 SET ACRSADA=0
+2 FOR
SET ACRSADA=$ORDER(^ACRALC("M",ACRALDA,ACRSADA))
IF 'ACRSADA
QUIT
IF $DATA(ACRALC(ACRSADA,0))
Begin DoDot:1
+3 SET DA=ACRSADA
+4 SET DIE="^ACRALC("
+5 SET DR=".02////"_ACRTO_";.03////"_ACRALDA
+6 DO DIE^ACRFDIC
+7 DO CLB
End DoDot:1
+8 QUIT
CLB ;CHANGE DEPARTMENT ACCOUNT
+1 SET ACRLBDA=0
+2 FOR
SET ACRLBDA=$ORDER(^ACRLOCB("M",ACRSADA,ACRLBDA))
IF 'ACRLBDA
QUIT
IF $DATA(^ACRLOCB(ACRLBDA,0))
Begin DoDot:1
+3 SET DA=ACRLBDA
+4 SET DIE="^ACRLOCB("
+5 SET DR=".04////"_ACRSADA
+6 DO DIE^ACRFDIC
+7 DO CRQ
End DoDot:1
+8 QUIT
CRQ ;CHANGE REQUEST
+1 SET ACRDOCDA=0
+2 FOR
SET ACRDOCDA=$ORDER(^ACROBL("D",ACRLBDA,ACRDOCDA))
IF 'ACRDOCDA
QUIT
Begin DoDot:1
+3 SET DA=ACRDOCDA
+4 SET DIE="^ACROBL("
+5 SET DR=".03////"_ACRLBDA
+6 DO DIE^ACRFDIC
End DoDot:1
CSUP ;CHANGE SUPPLY/ITEM FILE
+1 SET ACRSSDA=0
+2 FOR
SET ACRSSDA=$ORDER(^ACRSS("F",ACRLBDA,ACRSSDA))
IF 'ACRSSDA
QUIT
Begin DoDot:1
+3 SET DA=ACRSSDA
+4 SET DIE="^ACRSS("
+5 SET DR=".06////"_ACRLBDA
+6 DO DIE^ACRFDIC
End DoDot:1
+7 QUIT
