DGVPT1 ;ALB/MRL - DG POST-INIT (OPTION AND ROUTINE CLEAN-UP) ;12 AUG 88@1032
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
OPT ;Delete and Repoint Options
I $S(('$D(DGPACK)#2):1,DGPACK']"":1,1:0) Q
W !!,">>> Deleting/repointing '",DGPACK,"' options in OPTION file as necessary.",!
D VERS^DGVPP:'$D(DGVREL) S DGI=DGPACK F DGJ=0:0 S DGI=$O(^DG(48,DGVREL,"DO","C",DGI)) Q:DGI=""!($E(DGI,1,$L(DGPACK))'=DGPACK) S DGIFN=+$O(^DG(48,DGVREL,"DO","C",DGI,0)) I $D(^DG(48,DGVREL,"DO",DGIFN,0)) S DGDEL=^(0) D DO1
K DA,DGDEL,DGI,DGIFN,DGJ,DGM,DGNOPT,DGOPT,DGPACK,DGREP,DGS,DIC,DIK,DINUM,I,X Q
DO1 W !!?5,DGI,!?5 F I=1:1:$L(DGI) W "-"
S DGOPT=+$O(^DIC(19,"B",$E(DGI,1,30),0)) I $S('DGOPT:1,'$D(^DIC(19,DGOPT,0)):1,1:0) W !?5,"DOES NOT EXIST IN THE 'OPTION' FILE...NOTHING DELETED!" Q
S DGREP=$P(DGDEL,"^",4) G DO2:'DGREP S DGNOPT=+$O(^DIC(19,"B",$E($P(DGDEL,"^",5),1,30),0))
I $S(DGNOPT'>0:1,'$D(^DIC(19,DGNOPT,0)):1,1:0) W !?5,"NEW OPTION (",$P(DGDEL,"^",4),") DOESN'T EXIST IN 'OPTION' FILE...NOTHING REPOINTED!" S DGREP=0
DO2 I '$O(^DIC(19,"AD",DGOPT,0)) W !?5,"NOT ATTACHED TO ANY MENUS AS AN ITEM...NOTHING TO REPOINT OR DELETE!" G DO3
F DGM=0:0 S DGM=$O(^DIC(19,"AD",DGOPT,DGM)) Q:'DGM F DGS=0:0 S DGS=$O(^DIC(19,"AD",DGOPT,DGM,DGS)) Q:'DGS D DO4
DO3 S DA(1)=19,DA=DGOPT,DIK="^DIC(19," D ^DIK W !?5,"'",$P(DGDEL,"^",1),"' REMOVED from OPTION file..." Q
DO4 I $D(^DIC(19,DGM,10,DGS,0)),$P(^(0),"^")=DGOPT W !?5,"REMOVED from '",$P(^DIC(19,+DGM,0),"^",1),"' menu..." S DIK="^DIC(19,"_DGM_",10,",DA(2)=19,DA(1)=DGM,DA=DGS D ^DIK K DIK,DA
Q:'DGREP W !?10,"'",$P(DGDEL,"^",5),"' " I $D(^DIC(19,"AD",DGNOPT,DGM)) W "already EXISTS as an item on this menu..." Q
W "ADDED to menu as a NEW ITEM..." K DD,DO S DA(2)=19,DA(1)=DGM,X=DGNOPT,(DA,DINUM)=DGS,DIC="^DIC(19,"_DGM_",10,",DIC(0)="L" D FILE^DICN K DD,DO,DA,DIC Q
;
DEL ;Delete Obsolete Routines -- run by site after initialization
S DGV=$$REL^DGVPP()
I $O(^DG(48,DGV,"DR",0))="" W !,"No routines listed to remove" G QD
I '$D(^%ZOSF("DEL")) W !,"^%ZOSF(""DEL"") does not exist" G QD
ASK W !,"This routine will permanently remove the routines listed in the PIMS",!,"release notes. WARNING: If any of the listed routines are mapped, they"
W !,"must first be removed from the mapped set to avoid further complications!!",!
W !,"Are you sure you want to continue" S %=2 D YN^DICN G QD:%=-1!(%=2) I '% W !?5,"Respond 'Y'es or 'N'o" G ASK
W !,"Routine deletion starting..." S DGI=0 F DGI1=0:0 S DGI=$O(^DG(48,DGV,"DR",DGI)) Q:'DGI S X=$P(^(DGI,0),"^") X ^%ZOSF("TEST") I $T W !?5,"...removing ",X X ^%ZOSF("DEL")
W !,"Routine deletion completed."
QD K DGI,DGI1,DGV,X Q
DGVPT1 ;ALB/MRL - DG POST-INIT (OPTION AND ROUTINE CLEAN-UP) ;12 AUG 88@1032
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
OPT ;Delete and Repoint Options
+1 IF $SELECT(('$DATA(DGPACK)#2):1,DGPACK']"":1,1:0)
QUIT
+2 WRITE !!,">>> Deleting/repointing '",DGPACK,"' options in OPTION file as necessary.",!
+3 IF '$DATA(DGVREL)
DO VERS^DGVPP
SET DGI=DGPACK
FOR DGJ=0:0
SET DGI=$ORDER(^DG(48,DGVREL,"DO","C",DGI))
IF DGI=""!($EXTRACT(DGI,1,$LENGTH(DGPACK))'=DGPACK)
QUIT
SET DGIFN=+$ORDER(^DG(48,DGVREL,"DO","C",DGI,0))
IF $DATA(^DG(48,DGVREL,"DO",DGIFN,0))
SET DGDEL=^(0)
DO DO1
+4 KILL DA,DGDEL,DGI,DGIFN,DGJ,DGM,DGNOPT,DGOPT,DGPACK,DGREP,DGS,DIC,DIK,DINUM,I,X
QUIT
DO1 WRITE !!?5,DGI,!?5
FOR I=1:1:$LENGTH(DGI)
WRITE "-"
+1 SET DGOPT=+$ORDER(^DIC(19,"B",$EXTRACT(DGI,1,30),0))
IF $SELECT('DGOPT:1,'$DATA(^DIC(19,DGOPT,0)):1,1:0)
WRITE !?5,"DOES NOT EXIST IN THE 'OPTION' FILE...NOTHING DELETED!"
QUIT
+2 SET DGREP=$PIECE(DGDEL,"^",4)
IF 'DGREP
GOTO DO2
SET DGNOPT=+$ORDER(^DIC(19,"B",$EXTRACT($PIECE(DGDEL,"^",5),1,30),0))
+3 IF $SELECT(DGNOPT'>0:1,'$DATA(^DIC(19,DGNOPT,0)):1,1:0)
WRITE !?5,"NEW OPTION (",$PIECE(DGDEL,"^",4),") DOESN'T EXIST IN 'OPTION' FILE...NOTHING REPOINTED!"
SET DGREP=0
DO2 IF '$ORDER(^DIC(19,"AD",DGOPT,0))
WRITE !?5,"NOT ATTACHED TO ANY MENUS AS AN ITEM...NOTHING TO REPOINT OR DELETE!"
GOTO DO3
+1 FOR DGM=0:0
SET DGM=$ORDER(^DIC(19,"AD",DGOPT,DGM))
IF 'DGM
QUIT
FOR DGS=0:0
SET DGS=$ORDER(^DIC(19,"AD",DGOPT,DGM,DGS))
IF 'DGS
QUIT
DO DO4
DO3 SET DA(1)=19
SET DA=DGOPT
SET DIK="^DIC(19,"
DO ^DIK
WRITE !?5,"'",$PIECE(DGDEL,"^",1),"' REMOVED from OPTION file..."
QUIT
DO4 IF $DATA(^DIC(19,DGM,10,DGS,0))
IF $PIECE(^(0),"^")=DGOPT
WRITE !?5,"REMOVED from '",$PIECE(^DIC(19,+DGM,0),"^",1),"' menu..."
SET DIK="^DIC(19,"_DGM_",10,"
SET DA(2)=19
SET DA(1)=DGM
SET DA=DGS
DO ^DIK
KILL DIK,DA
+1 IF 'DGREP
QUIT
WRITE !?10,"'",$PIECE(DGDEL,"^",5),"' "
IF $DATA(^DIC(19,"AD",DGNOPT,DGM))
WRITE "already EXISTS as an item on this menu..."
QUIT
+2 WRITE "ADDED to menu as a NEW ITEM..."
KILL DD,DO
SET DA(2)=19
SET DA(1)=DGM
SET X=DGNOPT
SET (DA,DINUM)=DGS
SET DIC="^DIC(19,"_DGM_",10,"
SET DIC(0)="L"
DO FILE^DICN
KILL DD,DO,DA,DIC
QUIT
+3 ;
DEL ;Delete Obsolete Routines -- run by site after initialization
+1 SET DGV=$$REL^DGVPP()
+2 IF $ORDER(^DG(48,DGV,"DR",0))=""
WRITE !,"No routines listed to remove"
GOTO QD
+3 IF '$DATA(^%ZOSF("DEL"))
WRITE !,"^%ZOSF(""DEL"") does not exist"
GOTO QD
ASK WRITE !,"This routine will permanently remove the routines listed in the PIMS",!,"release notes. WARNING: If any of the listed routines are mapped, they"
+1 WRITE !,"must first be removed from the mapped set to avoid further complications!!",!
+2 WRITE !,"Are you sure you want to continue"
SET %=2
DO YN^DICN
IF %=-1!(%=2)
GOTO QD
IF '%
WRITE !?5,"Respond 'Y'es or 'N'o"
GOTO ASK
+3 WRITE !,"Routine deletion starting..."
SET DGI=0
FOR DGI1=0:0
SET DGI=$ORDER(^DG(48,DGV,"DR",DGI))
IF 'DGI
QUIT
SET X=$PIECE(^(DGI,0),"^")
XECUTE ^%ZOSF("TEST")
IF $TEST
WRITE !?5,"...removing ",X
XECUTE ^%ZOSF("DEL")
+4 WRITE !,"Routine deletion completed."
QD KILL DGI,DGI1,DGV,X
QUIT
