XBPKDEL ; IHS/ADC/GTH - REMOVE OPTIONS, INPUT,SORT,PRINT TEMPLATES, HELP FRAMES, BULLETINS, FUNCTIONS, AND IF INDICATED, SECURITY KEYS FOR A PACKAGE ; [ 12/11/2000 3:13 PM ]
;;3.0;IHS/VA UTILITIES;**8**;FEB 07, 1997
; XB*3*8 - IHS/ASDST/GTH - 12-07-00 - Also delete Forms, Protocols, and List templates. Add support for routine XBPKDEL1.
;
; XBPKNSP must be set to the namespace, e.g. "AICD" if this
; routine is called from a preinit.
;
; If you want security keys deleted, set XBPKEY=1 if this
; routine is called from a preinit.
;
; Call LIST^XBPKDEL to list all namespaced options,
; templates, etc.
;
; Call RUN^XBPKDEL to delete all namespaced options,
; templates, etc.
;
; The RUN and LIST entry points are for programmer use and
; are not to be called from a preinit. Preinit calls
; XBPKDEL directly with variables set as indicated above.
;
START ;
I '$D(^DIC(0)) W !,*7,"Filemanager does not exist in this UCI!" Q
I '$D(XBPKNSP) W !,*7,"Namespace variable does not exist!" Q
S U="^",DUZ(0)="@",XBPKQUIT=XBPKNSP_"{"
I $D(XBPKRUN) S XBPKDOC="This routine"
E S XBPKDOC="The preinit for this package"
D ASK
G:XBPKSTP A
; F XBPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D DELETE ; XB*3*8
F XBPKGLO="^DIBT(","^DIPT(","^SD(409.61,","^DIE(","^DIST(.403,","^DIC(19,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC"",","^ORD(101," D DELETE ; XB*3*8
I $D(XBPKEY) S XBPKGLO="^DIC(19.1," D DELETE ;DELETE SECURITY KEYS WITH THIS NAMESPACE
W !
S %=1 D ENASK^XQ3 ;CALL TO FIX OPTION POINTERS
W !,*7,"Be sure to give users a new primary menu option if one of the menu options",!,"deleted within this namespace had been used as a primary menu option."
A ;
D EOJ
Q
;
ASK ;ASK USER IF WANTS TO CONTINUE
S XBPKSTP=0
; W !!,*7,XBPKDOC," will delete all options, sort, input," ; XB*3*8
; W !,"and print templates, bulletins, functions, " ; XB*3*8
; W $S($D(XBPKEY):"help frames and security keys",1:"and help frames") ; XB*3*8
; W !,"namespaced '",XBPKNSP,"' that are currently in this UCI. " ; XB*3*8
; XB*3*8 begin block
KILL ^UTILITY($J,"W")
NEW DIW,DIWL,DIWR,DIWF,DIWT
S DIWL=1,DIWR=(IOM-10),DIWF="W"
W !!,*7
S X=XBPKDOC
D ^DIWP
S X="will delete all options, templates (sort, input, list, and print), forms, bulletins, functions, protocols, "
D ^DIWP
S X=$S($D(XBPKEY):"help frames and security keys",1:"and help frames")_" namespaced '"_XBPKNSP_"' that are currently in this UCI."
D ^DIWP,^DIWW
KILL ^UTILITY($J,"W")
; XB*3*8 end block
W !,"Do you want to continue"
S %=1
D YN^DICN
I %=0 W !!,"If you answer with a ""NO"" or a ""^"" I will stop package initialization.",! G ASK
I %=2!(%=-1) W:'$D(XBPKRUN) !!,*7,"Package initialization process stopped!" S XBPKSTP=1 KILL DIFQ ;KILLING DIFQ STOPS THE INITIALIZATION PROCESS
W !
Q
;
DELETE ;
W !!,"Now deleting `",XBPKNSP,"' namespaced ",$P(@(XBPKGLO_"0)"),U),"S..."
S XBPKNSPC=XBPKNSP
I $D(@(XBPKGLO_"""B"",XBPKNSPC)")) S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")),DIK=XBPKGLO D ^DIK KILL DIK,DA
; F L=0:0 S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSPC)")) Q:XBPKNSPC=""!(XBPKNSPC]XBPKQUIT) S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")) W !?3,XBPKNSPC S DIK=XBPKGLO D ^DIK KILL DIK,DA ; XB*3*8
F L=0:0 S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSPC)")) Q:XBPKNSPC=""!(XBPKNSPC]XBPKQUIT) S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")) W !?3,XBPKNSPC D S DIK=XBPKGLO D ^DIK KILL DIK,DA ; XB*3*8
. ; XB*3*8 begin block
. ; Delete key from holders
. Q:XBPKGLO'="^DIC(19.1,"
. S XBPKKIEN=DA
. NEW DA
. S XBPKHIEN=0
. F S XBPKHIEN=$O(^XUSEC(XBPKNSPC,XBPKHIEN)) Q:'XBPKHIEN D
.. S DIE="^VA(200,XBPKHIEN,51,",DA(1)=XBPKHIEN,DA=XBPKKIEN,DR=".01///@"
.. D ^DIE
.. Q
. Q
; XB*3*8 end block
Q
;
LIST ; ENTRY POINT FOR LISTING NAMESPACED ITEMS
I '$D(^DIC(0)) W !,*7,"Filemanager does not exist in this UCI!" Q
S U="^",DUZ(0)="@"
W !!,"Utility to list all namespaced items in current UCI",!
D GETNSP
G:XBPKNSP["^"!("^"[XBPKNSP) EOJ
; W !!,"Listing of items in namespace ",XBPKNSP,! ; XB*3*8
W @IOF,!!,"Listing of items in namespace ",XBPKNSP,! ; XB*3*8
W "--------------------------------------",!
S XBPKQUIT=XBPKNSP_"{",XBPKF=0
; F XBPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D LIST2 ; XB*3*8
F XBPKGLO="^DIBT(","^DIPT(","^SD(409.61,","^DIE(","^DIST(.403,","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC"",","^ORD(101," D LIST2 ; XB*3*8
G EOJ
;
LIST2 ;
S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSP)"))
I $P(XBPKNSPC,XBPKNSP)]"" W:XBPKF ! S XBPKF=0 W "NO ",$P(@(XBPKGLO_"0)"),"^",1),"S",! Q
S XBPKF=1
W !,$P(@(XBPKGLO_"0)"),"^",1),"S",!
S XBPKNSPC=XBPKNSP
F Q:$D(DUOUT) S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSPC)")) Q:XBPKNSPC=""!(XBPKNSPC]XBPKQUIT) S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")) W ?3,XBPKNSPC,! I $Y>(IOSL-5) D PAUSE
Q
;
PAUSE ; Screen control for LIST
S Y=$$DIR^XBDIR("E")
; W @IOF ; XB*3*8
W @IOF,! ; XB*3*8
Q
;
RUN ; ENTRY POINT FOR ACQUIRING CONTROL ARGUMENTS AND DOING DELETIONS
I '$D(^DIC(0)) W !,*7,"Filemanager does not exist in this UCI!" Q
I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q
W !!,"Utility to delete all namespaced items in current UCI",!
D GETNSP
G:XBPKNSP["^"!("^"[XBPKNSP) EOJ
D GETKEY
I $D(XBPKEY),XBPKEY="^" G EOJ
S XBPKRUN=""
G XBPKDEL
;
GETNSP ; CODE TO ACQUIRE NAMESPACE
R "Namespace to process: ",XBPKNSP:600,!
Q:("^"[XBPKNSP)!(XBPKNSP["^")
I XBPKNSP["?" W "Enter null line or '^' to quit.",!
I XBPKNSP'?1U1.7UN W "Namespace must begin with an upper-case letter and",!," consist only of upper-case letters and numbers",! G GETNSP
Q
;
GETKEY ; CODE TO ACQUIRE SECURITY KEY FLAG
W "Do you want to delete security keys"
S %=1
D YN^DICN
I %=0 W !!,"If you answer with a ""NO"" security keys will not be deleted.",! G ASK
I %=2!(%=-1) S:%=-1 XBPKEY="^"
E S XBPKEY=""
Q
;
EOJ ;EP - Clean up after this routine or XBPKDEL1 ; XB*3*8
; KILL XBPKF,XBPKGLO,XBPKEY,XBPKSTP,XBPKNSP,XBPKNSPC,XBPKQUIT,XBPKRUN,XBPKDOC,DUOUT,DTOUT ; XB*3*8
KILL XBPKF,XBPKGLO,XBPKHIEN,XBPKKIEN,XBPKEY,XBPKSTP,XBPKNSP,XBPKNSPC,XBPKQUIT,XBPKRUN,XBPKDOC,DUOUT,DTOUT ; XB*3*8
Q
;
XBPKDEL ; IHS/ADC/GTH - REMOVE OPTIONS, INPUT,SORT,PRINT TEMPLATES, HELP FRAMES, BULLETINS, FUNCTIONS, AND IF INDICATED, SECURITY KEYS FOR A PACKAGE ; [ 12/11/2000 3:13 PM ]
+1 ;;3.0;IHS/VA UTILITIES;**8**;FEB 07, 1997
+2 ; XB*3*8 - IHS/ASDST/GTH - 12-07-00 - Also delete Forms, Protocols, and List templates. Add support for routine XBPKDEL1.
+3 ;
+4 ; XBPKNSP must be set to the namespace, e.g. "AICD" if this
+5 ; routine is called from a preinit.
+6 ;
+7 ; If you want security keys deleted, set XBPKEY=1 if this
+8 ; routine is called from a preinit.
+9 ;
+10 ; Call LIST^XBPKDEL to list all namespaced options,
+11 ; templates, etc.
+12 ;
+13 ; Call RUN^XBPKDEL to delete all namespaced options,
+14 ; templates, etc.
+15 ;
+16 ; The RUN and LIST entry points are for programmer use and
+17 ; are not to be called from a preinit. Preinit calls
+18 ; XBPKDEL directly with variables set as indicated above.
+19 ;
START ;
+1 IF '$DATA(^DIC(0))
WRITE !,*7,"Filemanager does not exist in this UCI!"
QUIT
+2 IF '$DATA(XBPKNSP)
WRITE !,*7,"Namespace variable does not exist!"
QUIT
+3 SET U="^"
SET DUZ(0)="@"
SET XBPKQUIT=XBPKNSP_"{"
+4 IF $DATA(XBPKRUN)
SET XBPKDOC="This routine"
+5 IF '$TEST
SET XBPKDOC="The preinit for this package"
+6 DO ASK
+7 IF XBPKSTP
GOTO A
+8 ; F XBPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D DELETE ; XB*3*8
+9 ; XB*3*8
FOR XBPKGLO="^DIBT(","^DIPT(","^SD(409.61,","^DIE(","^DIST(.403,","^DIC(19,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC"",","^ORD(101,"
DO DELETE
+10 ;DELETE SECURITY KEYS WITH THIS NAMESPACE
IF $DATA(XBPKEY)
SET XBPKGLO="^DIC(19.1,"
DO DELETE
+11 WRITE !
+12 ;CALL TO FIX OPTION POINTERS
SET %=1
DO ENASK^XQ3
+13 WRITE !,*7,"Be sure to give users a new primary menu option if one of the menu options",!,"deleted within this namespace had been used as a primary menu option."
A ;
+1 DO EOJ
+2 QUIT
+3 ;
ASK ;ASK USER IF WANTS TO CONTINUE
+1 SET XBPKSTP=0
+2 ; W !!,*7,XBPKDOC," will delete all options, sort, input," ; XB*3*8
+3 ; W !,"and print templates, bulletins, functions, " ; XB*3*8
+4 ; W $S($D(XBPKEY):"help frames and security keys",1:"and help frames") ; XB*3*8
+5 ; W !,"namespaced '",XBPKNSP,"' that are currently in this UCI. " ; XB*3*8
+6 ; XB*3*8 begin block
+7 KILL ^UTILITY($JOB,"W")
+8 NEW DIW,DIWL,DIWR,DIWF,DIWT
+9 SET DIWL=1
SET DIWR=(IOM-10)
SET DIWF="W"
+10 WRITE !!,*7
+11 SET X=XBPKDOC
+12 DO ^DIWP
+13 SET X="will delete all options, templates (sort, input, list, and print), forms, bulletins, functions, protocols, "
+14 DO ^DIWP
+15 SET X=$SELECT($DATA(XBPKEY):"help frames and security keys",1:"and help frames")_" namespaced '"_XBPKNSP_"' that are currently in this UCI."
+16 DO ^DIWP
DO ^DIWW
+17 KILL ^UTILITY($JOB,"W")
+18 ; XB*3*8 end block
+19 WRITE !,"Do you want to continue"
+20 SET %=1
+21 DO YN^DICN
+22 IF %=0
WRITE !!,"If you answer with a ""NO"" or a ""^"" I will stop package initialization.",!
GOTO ASK
+23 ;KILLING DIFQ STOPS THE INITIALIZATION PROCESS
IF %=2!(%=-1)
IF '$DATA(XBPKRUN)
WRITE !!,*7,"Package initialization process stopped!"
SET XBPKSTP=1
KILL DIFQ
+24 WRITE !
+25 QUIT
+26 ;
DELETE ;
+1 WRITE !!,"Now deleting `",XBPKNSP,"' namespaced ",$PIECE(@(XBPKGLO_"0)"),U),"S..."
+2 SET XBPKNSPC=XBPKNSP
+3 IF $DATA(@(XBPKGLO_"""B"",XBPKNSPC)"))
SET DA=$ORDER(@(XBPKGLO_"""B"",XBPKNSPC,"""")"))
SET DIK=XBPKGLO
DO ^DIK
KILL DIK,DA
+4 ; F L=0:0 S XBPKNSPC=$O(@(XBPKGLO_"""B"",XBPKNSPC)")) Q:XBPKNSPC=""!(XBPKNSPC]XBPKQUIT) S DA=$O(@(XBPKGLO_"""B"",XBPKNSPC,"""")")) W !?3,XBPKNSPC S DIK=XBPKGLO D ^DIK KILL DIK,DA ; XB*3*8
+5 ; XB*3*8
FOR L=0:0
SET XBPKNSPC=$ORDER(@(XBPKGLO_"""B"",XBPKNSPC)"))
IF XBPKNSPC=""!(XBPKNSPC]XBPKQUIT)
QUIT
SET DA=$ORDER(@(XBPKGLO_"""B"",XBPKNSPC,"""")"))
WRITE !?3,XBPKNSPC
Begin DoDot:1
+6 ; XB*3*8 begin block
+7 ; Delete key from holders
+8 IF XBPKGLO'="^DIC(19.1,"
QUIT
+9 SET XBPKKIEN=DA
+10 NEW DA
+11 SET XBPKHIEN=0
+12 FOR
SET XBPKHIEN=$ORDER(^XUSEC(XBPKNSPC,XBPKHIEN))
IF 'XBPKHIEN
QUIT
Begin DoDot:2
+13 SET DIE="^VA(200,XBPKHIEN,51,"
SET DA(1)=XBPKHIEN
SET DA=XBPKKIEN
SET DR=".01///@"
+14 DO ^DIE
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
SET DIK=XBPKGLO
DO ^DIK
KILL DIK,DA
+17 ; XB*3*8 end block
+18 QUIT
+19 ;
LIST ; ENTRY POINT FOR LISTING NAMESPACED ITEMS
+1 IF '$DATA(^DIC(0))
WRITE !,*7,"Filemanager does not exist in this UCI!"
QUIT
+2 SET U="^"
SET DUZ(0)="@"
+3 WRITE !!,"Utility to list all namespaced items in current UCI",!
+4 DO GETNSP
+5 IF XBPKNSP["^"!("^"[XBPKNSP)
GOTO EOJ
+6 ; W !!,"Listing of items in namespace ",XBPKNSP,! ; XB*3*8
+7 ; XB*3*8
WRITE @IOF,!!,"Listing of items in namespace ",XBPKNSP,!
+8 WRITE "--------------------------------------",!
+9 SET XBPKQUIT=XBPKNSP_"{"
SET XBPKF=0
+10 ; F XBPKGLO="^DIBT(","^DIPT(","^DIE(","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC""," D LIST2 ; XB*3*8
+11 ; XB*3*8
FOR XBPKGLO="^DIBT(","^DIPT(","^SD(409.61,","^DIE(","^DIST(.403,","^DIC(19,","^DIC(19.1,","^XMB(3.6,","^DIC(9.2,","^DD(""FUNC"",","^ORD(101,"
DO LIST2
+12 GOTO EOJ
+13 ;
LIST2 ;
+1 SET XBPKNSPC=$ORDER(@(XBPKGLO_"""B"",XBPKNSP)"))
+2 IF $PIECE(XBPKNSPC,XBPKNSP)]""
IF XBPKF
WRITE !
SET XBPKF=0
WRITE "NO ",$PIECE(@(XBPKGLO_"0)"),"^",1),"S",!
QUIT
+3 SET XBPKF=1
+4 WRITE !,$PIECE(@(XBPKGLO_"0)"),"^",1),"S",!
+5 SET XBPKNSPC=XBPKNSP
+6 FOR
IF $DATA(DUOUT)
QUIT
SET XBPKNSPC=$ORDER(@(XBPKGLO_"""B"",XBPKNSPC)"))
IF XBPKNSPC=""!(XBPKNSPC]XBPKQUIT)
QUIT
SET DA=$ORDER(@(XBPKGLO_"""B"",XBPKNSPC,"""")"))
WRITE ?3,XBPKNSPC,!
IF $Y>(IOSL-5)
DO PAUSE
+7 QUIT
+8 ;
PAUSE ; Screen control for LIST
+1 SET Y=$$DIR^XBDIR("E")
+2 ; W @IOF ; XB*3*8
+3 ; XB*3*8
WRITE @IOF,!
+4 QUIT
+5 ;
RUN ; ENTRY POINT FOR ACQUIRING CONTROL ARGUMENTS AND DOING DELETIONS
+1 IF '$DATA(^DIC(0))
WRITE !,*7,"Filemanager does not exist in this UCI!"
QUIT
+2 IF $SELECT('$DATA(DUZ(0)):1,DUZ(0)'="@":1,1:0)
WRITE !,"PROGRAMMER ACCESS REQUIRED",!
QUIT
+3 WRITE !!,"Utility to delete all namespaced items in current UCI",!
+4 DO GETNSP
+5 IF XBPKNSP["^"!("^"[XBPKNSP)
GOTO EOJ
+6 DO GETKEY
+7 IF $DATA(XBPKEY)
IF XBPKEY="^"
GOTO EOJ
+8 SET XBPKRUN=""
+9 GOTO XBPKDEL
+10 ;
GETNSP ; CODE TO ACQUIRE NAMESPACE
+1 READ "Namespace to process: ",XBPKNSP:600,!
+2 IF ("^"[XBPKNSP)!(XBPKNSP["^")
QUIT
+3 IF XBPKNSP["?"
WRITE "Enter null line or '^' to quit.",!
+4 IF XBPKNSP'?1U1.7UN
WRITE "Namespace must begin with an upper-case letter and",!," consist only of upper-case letters and numbers",!
GOTO GETNSP
+5 QUIT
+6 ;
GETKEY ; CODE TO ACQUIRE SECURITY KEY FLAG
+1 WRITE "Do you want to delete security keys"
+2 SET %=1
+3 DO YN^DICN
+4 IF %=0
WRITE !!,"If you answer with a ""NO"" security keys will not be deleted.",!
GOTO ASK
+5 IF %=2!(%=-1)
IF %=-1
SET XBPKEY="^"
+6 IF '$TEST
SET XBPKEY=""
+7 QUIT
+8 ;
EOJ ;EP - Clean up after this routine or XBPKDEL1 ; XB*3*8
+1 ; KILL XBPKF,XBPKGLO,XBPKEY,XBPKSTP,XBPKNSP,XBPKNSPC,XBPKQUIT,XBPKRUN,XBPKDOC,DUOUT,DTOUT ; XB*3*8
+2 ; XB*3*8
KILL XBPKF,XBPKGLO,XBPKHIEN,XBPKKIEN,XBPKEY,XBPKSTP,XBPKNSP,XBPKNSPC,XBPKQUIT,XBPKRUN,XBPKDOC,DUOUT,DTOUT
+3 QUIT
+4 ;
