- 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
