- 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
