AUKD ; KILLS DICs and GLOBALS [ 08/17/88 4:55 PM ]
;
NOTES ; This routine deletes FileMan dictionaries, and optionally their
; globals, TEMPLATES and AUTHORITIES, by a range of dictionary
; numbers, or if called from another routine, by a predefined
; set of dictionaries. The assumptions made by this routine
; are that ^UTILITY, ^DIC, and ^DD are not UCI TRANSLATED.
; Any other globals may be translated, but the KILLs will
; take place in the current UCI only.
;
; This routine can be called from another routine by setting the
; variables AUKDLO, AUKDHI, AUKDDEL, AUKDTMP and then D EN1^AUKD,
; or by creating the array ^UTILITY("AUDSET",$J) and then D EN2^AUKD.
;
; The array ^UTILITY("AUDSET",$J) is subscripted by the file numbers
; and has a value of 'v1^v2' where v1 applies to the data global,
; and v2 applies to the TEMPLATES attached to the file. The
; allowable values of v1 and v2 are 'S' for save, 'D' for delete,
; 'A' for ask.
;
; This routine will execute ^AURESID to delete any residual entries
; in ^DD if dictionaries are deleted by a range of numbers.
;
BEGIN S DUZ(0)="@",U="^"
W !!,"This program deletes FileMan dictionaries, and optionally their"
W !,"globals, TEMPLATES and AUTHORITIES, by a range of dictionary numbers.",!!
;
LO R !,"Enter first dictionary number to be deleted: ",AUKDLO G:AUKDLO'=+AUKDLO EOJ
HI W !,"Enter last dictionary number to be deleted: ",AUKDLO,"//" R AUKDHI S:AUKDHI="" AUKDHI=AUKDLO G:AUKDHI'=+AUKDHI!(AUKDHI<AUKDLO) EOJ
DEL R !!,"Data globals? [D]elete, [A]sk, [S]ave S//",AUKDDEL G:"DAS"'[AUKDDEL DEL
S:AUKDDEL="" AUKDDEL="S"
;
TMP W !!,"TEMPLATES and AUTHORITIES? [D]elete, [A]sk, [S]ave "_AUKDDEL_"//" R AUKDTMP G:"DAS"'[AUKDTMP TMP
S:AUKDTMP="" AUKDTMP=AUKDDEL
;
EN1 ;
I '$D(AUKDLO)!('$D(AUKDHI)) W !!,"AUKDLO and/or AUKDHI does not exist!" G EOJ
S DUZ(0)="@",U="^"
S:'$D(AUKDDEL) AUKDDEL="A"
S:AUKDDEL="K" AUKDDEL="S" ;***** BACKWARD COMPATABLE *****
I "DAS"'[AUKDDEL W !!,"Invalid AUKDDEL --->",AUKDDEL,"<---" G EOJ
S:'$D(AUKDTMP) AUKDTMP="A"
S:AUKDTMP="K" AUKDTMP="S" ;***** UPWARD COMPATABLE *****
I "DAS"'[AUKDTMP W !!,"Invalid AUDKTMP --->",AUKDTMP,"<---" G EOJ
S AUDSLO=AUKDLO,AUDSHI=AUKDHI D EN1^%AUDSET
S AUKDFILE=(AUKDLO-.00000001) F AUKDL=0:0 S AUKDFILE=$O(^DD(AUKDFILE)) Q:AUKDFILE>AUKDHI!(AUKDFILE'=+AUKDFILE) I '$D(^UTILITY("AUDSET",$J,AUKDFILE)) D CHECKDD
I '$D(^UTILITY("AUDSET",$J)) W !!,"No dictionaries were selected." G EOJ
S AUKDFILE=0 F AUKDL=0:0 S AUKDFILE=$O(^UTILITY("AUDSET",$J,AUKDFILE)) Q:AUKDFILE="" S ^(AUKDFILE)=AUKDDEL_U_AUKDTMP
G EN2
;
CHECKDD ; CHECK ^DD FOR DANGLING ENTRIES
Q:$D(^DD(AUKDFILE,0,"UP"))
W "." S ^UTILITY("AUDSET",$J,AUKDFILE)=""
Q
;
EN2 ;
I '$D(^UTILITY("AUDSET",$J)) W !!,"^UTILITY(""AUDSET"",$J) is not defined!" G EOJ
I $O(^UTILITY("AUDSET",$J,""))<2 W !!,"*** Don't mess with files less than 2!! ***",*7 K AUKDLO,AUKDHI G EOJ
S DUZ(0)="@",U="^"
S (AUKDFILE,AUKDFLG)=0 F AUKDL=0:0 S AUKDFILE=$O(^UTILITY("AUDSET",$J,AUKDFILE)) Q:AUKDFILE="" S AUKDX=^(AUKDFILE) D CHKVAL
I AUKDFLG W !!,"One or more invalid GLOBAL^TEMPLATE disposition values encountered!" G EOJ
K AUKDDEL,AUKDERR,AUKDFLG,AUKDTMP,AUKDX
D ^%AUKD2
S AUKDFLG=0 D CONFIRM
G:AUKDFLG EOJ
K AUKDASK,AUKDFLG,AUKDX,AUKDY
D ^%AUKD3
W !!,"Resetting ^DIC(0) <WAIT>" S (AUKDC,AUKDFILE)=0,AUKDLAST="" F AUKDL=0:0 S AUKDFILE=$O(^DIC(AUKDFILE)) Q:AUKDFILE'=+AUKDFILE S AUKDC=AUKDC+1,AUKDLAST=AUKDFILE
S $P(^DIC(0),U,3)=AUKDLAST,$P(^DIC(0),U,4)=AUKDC
G EOJ
;
CHKVAL ; CHECK G^T VALUES
S AUKDERR=0
I AUKDX'?1U1"^"1U S AUKDERR=1
;***** "K" TO "S" ADDED TO FOLLOWING LINE FOR UPWARD COMPABILITY *****
I 'AUKDERR S AUKDDEL=$P(AUKDX,U,1),AUKDTMP=$P(AUKDX,U,2) S:AUKDDEL="K" AUKDDEL="S" S:AUKDTMP="K" AUKDTMP="S" S:"ADS"'[AUKDDEL AUKDERR=1 S:"ADS"'[AUKDTMP AUKDERR=1
I AUKDERR S AUKDFLG=1 W !,"Invalid value ",AUKDFILE,"=",AUKDX
Q
;
CONFIRM ; SHOW AND ASK
I '$D(^UTILITY("AUDSET",$J)) S AUKDFLG=1 Q
W !!," NUMBER",?14,"NAME",?45,"G^T",?50,"DATA GLOBAL",!
S (AUKDFILE,AUKDASK)=0 F AUKDL=0:0 S AUKDFILE=$O(^UTILITY("AUDSET",$J,AUKDFILE)) Q:AUKDFILE="" S AUKDX=^(AUKDFILE) S:$E(AUKDX,1,3)["A" AUKDASK=1 D LIST
W !!,"The above list of dictionaries will be deleted in UCI ",AUKDUCI,". Data"
W !,"globals, TEMPLATES and AUTHORITIES, will be kept, deleted, or asked depending"
W !,"on flag. '?' in G position indicates invalid data global."
W !!,"[S]ave, [D]elete, [A]sk. Globals to be deleted are also marked"
W !," by '*' in position 1."
R !!,"[C]ontinue, [S]top, [M]odify? C//",AUKDX S:AUKDX="^" AUKDX="S"
I $E(AUKDX)="S" S AUKDFLG=1 Q
I $E(AUKDX)="M" D MODIFY G CONFIRM
Q:'AUKDASK
W ! S AUKDFILE="" F AUKDL=0:0 S AUKDFILE=$O(^UTILITY("AUDSET",$J,AUKDFILE)) Q:AUKDFILE="" S AUKDX=^(AUKDFILE) D:$E(AUKDX,1,3)["A" ASK
G CONFIRM
;
LIST ; LIST FILE INFO
W !,$S($P(AUKDX,U,1)="D":"*",1:" "),AUKDFILE,?14,$E($P(^DIC(AUKDFILE,0),U,1),1,30),?45,$E(AUKDX,1,3),?50,$S($P(AUKDX,U,3)="":"<NONE>",1:$P(AUKDX,U,3))
Q
;
MODIFY ;
R !!,"Which file? ",AUKDFILE I '$D(^UTILITY("AUDSET",$J,AUKDFILE)) W *7 G MODIFY
R !," Delete file from list of files to be deleted (Y/N) N//",AUKDY
I $E(AUKDY)="Y" K ^UTILITY("AUDSET",$J,AUKDFILE) Q
S $P(^UTILITY("AUDSET",$J,AUKDFILE),U,2)="A",$P(^(AUKDFILE),U,1)=$S($P(^(AUKDFILE),U,1)="?":"?",1:"A")
W ! S AUKDX=^(AUKDFILE) D ASK
Q
;
ASK ;
G:$P(AUKDX,U,1)'="A" ASK2
W !,"Do you want to delete the data global for ",AUKDFILE," ",$P(^DIC(AUKDFILE,0),U,1)," (Y/N) N//" R AUKDY
I $E(AUKDY)="Y" S $P(^UTILITY("AUDSET",$J,AUKDFILE),U,1)="D"
E S $P(^UTILITY("AUDSET",$J,AUKDFILE),U,1)="S"
ASK2 Q:$P(AUKDX,U,2)'="A"
W !,"Do you want to delete the TEMPLATES and AUTHORITIES for ",AUKDFILE," ",$P(^DIC(AUKDFILE,0),U,1)," (Y/N) N//" R AUKDY
I $E(AUKDY)="Y" S $P(^UTILITY("AUDSET",$J,AUKDFILE),U,2)="D"
E S $P(^UTILITY("AUDSET",$J,AUKDFILE),U,2)="S"
Q
;
EOJ ;
I $D(AUKDLO),$D(AUKDHI),AUKDLO=+AUKDLO,AUKDHI=+AUKDHI,AUKDHI>AUKDLO S AURLO=AUKDLO,AURHI=AUKDHI D EN1^AURESID
I $D(^UTILITY("AUKD",$J)) W !,"Restoring saved ^DD nodes. <WAIT>" S FROM="^UTILITY(""AUKD"",$J,",TO="^DD(" D ^%AUGXFR
K ^UTILITY("AUDSET",$J),^UTILITY("AUKD",$J)
K AUKDASK,AUKDC,AUKDDEL,AUKDERR,AUKDFILE,AUKDFLD,AUKDFLG,AUKDG,AUKDHI,AUKDL,AUKDLAST,AUKDLO,AUKDNDIC,AUKDTMP,AUKDUCI,AUKDX,AUKDY
K FROM,TO
W !!,"DONE",!!
Q
AUKD ; KILLS DICs and GLOBALS [ 08/17/88 4:55 PM ]
+1 ;
NOTES ; This routine deletes FileMan dictionaries, and optionally their
+1 ; globals, TEMPLATES and AUTHORITIES, by a range of dictionary
+2 ; numbers, or if called from another routine, by a predefined
+3 ; set of dictionaries. The assumptions made by this routine
+4 ; are that ^UTILITY, ^DIC, and ^DD are not UCI TRANSLATED.
+5 ; Any other globals may be translated, but the KILLs will
+6 ; take place in the current UCI only.
+7 ;
+8 ; This routine can be called from another routine by setting the
+9 ; variables AUKDLO, AUKDHI, AUKDDEL, AUKDTMP and then D EN1^AUKD,
+10 ; or by creating the array ^UTILITY("AUDSET",$J) and then D EN2^AUKD.
+11 ;
+12 ; The array ^UTILITY("AUDSET",$J) is subscripted by the file numbers
+13 ; and has a value of 'v1^v2' where v1 applies to the data global,
+14 ; and v2 applies to the TEMPLATES attached to the file. The
+15 ; allowable values of v1 and v2 are 'S' for save, 'D' for delete,
+16 ; 'A' for ask.
+17 ;
+18 ; This routine will execute ^AURESID to delete any residual entries
+19 ; in ^DD if dictionaries are deleted by a range of numbers.
+20 ;
BEGIN SET DUZ(0)="@"
SET U="^"
+1 WRITE !!,"This program deletes FileMan dictionaries, and optionally their"
+2 WRITE !,"globals, TEMPLATES and AUTHORITIES, by a range of dictionary numbers.",!!
+3 ;
LO READ !,"Enter first dictionary number to be deleted: ",AUKDLO
IF AUKDLO'=+AUKDLO
GOTO EOJ
HI WRITE !,"Enter last dictionary number to be deleted: ",AUKDLO,"//"
READ AUKDHI
IF AUKDHI=""
SET AUKDHI=AUKDLO
IF AUKDHI'=+AUKDHI!(AUKDHI<AUKDLO)
GOTO EOJ
DEL READ !!,"Data globals? [D]elete, [A]sk, [S]ave S//",AUKDDEL
IF "DAS"'[AUKDDEL
GOTO DEL
+1 IF AUKDDEL=""
SET AUKDDEL="S"
+2 ;
TMP WRITE !!,"TEMPLATES and AUTHORITIES? [D]elete, [A]sk, [S]ave "_AUKDDEL_"//"
READ AUKDTMP
IF "DAS"'[AUKDTMP
GOTO TMP
+1 IF AUKDTMP=""
SET AUKDTMP=AUKDDEL
+2 ;
EN1 ;
+1 IF '$DATA(AUKDLO)!('$DATA(AUKDHI))
WRITE !!,"AUKDLO and/or AUKDHI does not exist!"
GOTO EOJ
+2 SET DUZ(0)="@"
SET U="^"
+3 IF '$DATA(AUKDDEL)
SET AUKDDEL="A"
+4 ;***** BACKWARD COMPATABLE *****
IF AUKDDEL="K"
SET AUKDDEL="S"
+5 IF "DAS"'[AUKDDEL
WRITE !!,"Invalid AUKDDEL --->",AUKDDEL,"<---"
GOTO EOJ
+6 IF '$DATA(AUKDTMP)
SET AUKDTMP="A"
+7 ;***** UPWARD COMPATABLE *****
IF AUKDTMP="K"
SET AUKDTMP="S"
+8 IF "DAS"'[AUKDTMP
WRITE !!,"Invalid AUDKTMP --->",AUKDTMP,"<---"
GOTO EOJ
+9 SET AUDSLO=AUKDLO
SET AUDSHI=AUKDHI
DO EN1^%AUDSET
+10 SET AUKDFILE=(AUKDLO-.00000001)
FOR AUKDL=0:0
SET AUKDFILE=$ORDER(^DD(AUKDFILE))
IF AUKDFILE>AUKDHI!(AUKDFILE'=+AUKDFILE)
QUIT
IF '$DATA(^UTILITY("AUDSET",$JOB,AUKDFILE))
DO CHECKDD
+11 IF '$DATA(^UTILITY("AUDSET",$JOB))
WRITE !!,"No dictionaries were selected."
GOTO EOJ
+12 SET AUKDFILE=0
FOR AUKDL=0:0
SET AUKDFILE=$ORDER(^UTILITY("AUDSET",$JOB,AUKDFILE))
IF AUKDFILE=""
QUIT
SET ^(AUKDFILE)=AUKDDEL_U_AUKDTMP
+13 GOTO EN2
+14 ;
CHECKDD ; CHECK ^DD FOR DANGLING ENTRIES
+1 IF $DATA(^DD(AUKDFILE,0,"UP"))
QUIT
+2 WRITE "."
SET ^UTILITY("AUDSET",$JOB,AUKDFILE)=""
+3 QUIT
+4 ;
EN2 ;
+1 IF '$DATA(^UTILITY("AUDSET",$JOB))
WRITE !!,"^UTILITY(""AUDSET"",$J) is not defined!"
GOTO EOJ
+2 IF $ORDER(^UTILITY("AUDSET",$JOB,""))<2
WRITE !!,"*** Don't mess with files less than 2!! ***",*7
KILL AUKDLO,AUKDHI
GOTO EOJ
+3 SET DUZ(0)="@"
SET U="^"
+4 SET (AUKDFILE,AUKDFLG)=0
FOR AUKDL=0:0
SET AUKDFILE=$ORDER(^UTILITY("AUDSET",$JOB,AUKDFILE))
IF AUKDFILE=""
QUIT
SET AUKDX=^(AUKDFILE)
DO CHKVAL
+5 IF AUKDFLG
WRITE !!,"One or more invalid GLOBAL^TEMPLATE disposition values encountered!"
GOTO EOJ
+6 KILL AUKDDEL,AUKDERR,AUKDFLG,AUKDTMP,AUKDX
+7 DO ^%AUKD2
+8 SET AUKDFLG=0
DO CONFIRM
+9 IF AUKDFLG
GOTO EOJ
+10 KILL AUKDASK,AUKDFLG,AUKDX,AUKDY
+11 DO ^%AUKD3
+12 WRITE !!,"Resetting ^DIC(0) <WAIT>"
SET (AUKDC,AUKDFILE)=0
SET AUKDLAST=""
FOR AUKDL=0:0
SET AUKDFILE=$ORDER(^DIC(AUKDFILE))
IF AUKDFILE'=+AUKDFILE
QUIT
SET AUKDC=AUKDC+1
SET AUKDLAST=AUKDFILE
+13 SET $PIECE(^DIC(0),U,3)=AUKDLAST
SET $PIECE(^DIC(0),U,4)=AUKDC
+14 GOTO EOJ
+15 ;
CHKVAL ; CHECK G^T VALUES
+1 SET AUKDERR=0
+2 IF AUKDX'?1U1"^"1U
SET AUKDERR=1
+3 ;***** "K" TO "S" ADDED TO FOLLOWING LINE FOR UPWARD COMPABILITY *****
+4 IF 'AUKDERR
SET AUKDDEL=$PIECE(AUKDX,U,1)
SET AUKDTMP=$PIECE(AUKDX,U,2)
IF AUKDDEL="K"
SET AUKDDEL="S"
IF AUKDTMP="K"
SET AUKDTMP="S"
IF "ADS"'[AUKDDEL
SET AUKDERR=1
IF "ADS"'[AUKDTMP
SET AUKDERR=1
+5 IF AUKDERR
SET AUKDFLG=1
WRITE !,"Invalid value ",AUKDFILE,"=",AUKDX
+6 QUIT
+7 ;
CONFIRM ; SHOW AND ASK
+1 IF '$DATA(^UTILITY("AUDSET",$JOB))
SET AUKDFLG=1
QUIT
+2 WRITE !!," NUMBER",?14,"NAME",?45,"G^T",?50,"DATA GLOBAL",!
+3 SET (AUKDFILE,AUKDASK)=0
FOR AUKDL=0:0
SET AUKDFILE=$ORDER(^UTILITY("AUDSET",$JOB,AUKDFILE))
IF AUKDFILE=""
QUIT
SET AUKDX=^(AUKDFILE)
IF $EXTRACT(AUKDX,1,3)["A"
SET AUKDASK=1
DO LIST
+4 WRITE !!,"The above list of dictionaries will be deleted in UCI ",AUKDUCI,". Data"
+5 WRITE !,"globals, TEMPLATES and AUTHORITIES, will be kept, deleted, or asked depending"
+6 WRITE !,"on flag. '?' in G position indicates invalid data global."
+7 WRITE !!,"[S]ave, [D]elete, [A]sk. Globals to be deleted are also marked"
+8 WRITE !," by '*' in position 1."
+9 READ !!,"[C]ontinue, [S]top, [M]odify? C//",AUKDX
IF AUKDX="^"
SET AUKDX="S"
+10 IF $EXTRACT(AUKDX)="S"
SET AUKDFLG=1
QUIT
+11 IF $EXTRACT(AUKDX)="M"
DO MODIFY
GOTO CONFIRM
+12 IF 'AUKDASK
QUIT
+13 WRITE !
SET AUKDFILE=""
FOR AUKDL=0:0
SET AUKDFILE=$ORDER(^UTILITY("AUDSET",$JOB,AUKDFILE))
IF AUKDFILE=""
QUIT
SET AUKDX=^(AUKDFILE)
IF $EXTRACT(AUKDX,1,3)["A"
DO ASK
+14 GOTO CONFIRM
+15 ;
LIST ; LIST FILE INFO
+1 WRITE !,$SELECT($PIECE(AUKDX,U,1)="D":"*",1:" "),AUKDFILE,?14,$EXTRACT($PIECE(^DIC(AUKDFILE,0),U,1),1,30),?45,$EXTRACT(AUKDX,1,3),?50,$SELECT($PIECE(AUKDX,U,3)="":"<NONE>",1:$PIECE(AUKDX,U,3))
+2 QUIT
+3 ;
MODIFY ;
+1 READ !!,"Which file? ",AUKDFILE
IF '$DATA(^UTILITY("AUDSET",$JOB,AUKDFILE))
WRITE *7
GOTO MODIFY
+2 READ !," Delete file from list of files to be deleted (Y/N) N//",AUKDY
+3 IF $EXTRACT(AUKDY)="Y"
KILL ^UTILITY("AUDSET",$JOB,AUKDFILE)
QUIT
+4 SET $PIECE(^UTILITY("AUDSET",$JOB,AUKDFILE),U,2)="A"
SET $PIECE(^(AUKDFILE),U,1)=$SELECT($PIECE(^(AUKDFILE),U,1)="?":"?",1:"A")
+5 WRITE !
SET AUKDX=^(AUKDFILE)
DO ASK
+6 QUIT
+7 ;
ASK ;
+1 IF $PIECE(AUKDX,U,1)'="A"
GOTO ASK2
+2 WRITE !,"Do you want to delete the data global for ",AUKDFILE," ",$PIECE(^DIC(AUKDFILE,0),U,1)," (Y/N) N//"
READ AUKDY
+3 IF $EXTRACT(AUKDY)="Y"
SET $PIECE(^UTILITY("AUDSET",$JOB,AUKDFILE),U,1)="D"
+4 IF '$TEST
SET $PIECE(^UTILITY("AUDSET",$JOB,AUKDFILE),U,1)="S"
ASK2 IF $PIECE(AUKDX,U,2)'="A"
QUIT
+1 WRITE !,"Do you want to delete the TEMPLATES and AUTHORITIES for ",AUKDFILE," ",$PIECE(^DIC(AUKDFILE,0),U,1)," (Y/N) N//"
READ AUKDY
+2 IF $EXTRACT(AUKDY)="Y"
SET $PIECE(^UTILITY("AUDSET",$JOB,AUKDFILE),U,2)="D"
+3 IF '$TEST
SET $PIECE(^UTILITY("AUDSET",$JOB,AUKDFILE),U,2)="S"
+4 QUIT
+5 ;
EOJ ;
+1 IF $DATA(AUKDLO)
IF $DATA(AUKDHI)
IF AUKDLO=+AUKDLO
IF AUKDHI=+AUKDHI
IF AUKDHI>AUKDLO
SET AURLO=AUKDLO
SET AURHI=AUKDHI
DO EN1^AURESID
+2 IF $DATA(^UTILITY("AUKD",$JOB))
WRITE !,"Restoring saved ^DD nodes. <WAIT>"
SET FROM="^UTILITY(""AUKD"",$J,"
SET TO="^DD("
DO ^%AUGXFR
+3 KILL ^UTILITY("AUDSET",$JOB),^UTILITY("AUKD",$JOB)
+4 KILL AUKDASK,AUKDC,AUKDDEL,AUKDERR,AUKDFILE,AUKDFLD,AUKDFLG,AUKDG,AUKDHI,AUKDL,AUKDLAST,AUKDLO,AUKDNDIC,AUKDTMP,AUKDUCI,AUKDX,AUKDY
+5 KILL FROM,TO
+6 WRITE !!,"DONE",!!
+7 QUIT
