XBPKDEL1 ; IHS/ADC/GTH - DELETE RETIRED AND REPLACED PACKAGES ; [ 10/29/2002 7:42 AM ]
;;3.0;IHS/VA UTILITIES;**8,9**;FEB 07, 1997
; XB*3*8 - IHS/ASDST/GTH - 12-07-00 - New routine with patch 8.
; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Use $GLOBAL.
;
; DECERT subroutine processes a list of retired/replaced
; packages, and gives the user the opportunity to delete all
; the package components, the routines, and globals, in the
; namspace of the package.
;
Q Q
; -------------------------------------------------------------
DECERT ;EP - Delete de-certified packages.
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 @IOF,!!,"You'll be given the opportunity to delete the following packages,",!,"Routines, and Globals in the indicated namespace, in 3 steps."
L1 ;
W !,"NAMESPACE--DESCRIPTION----------------------------RTNS-----GBLS------"
;
NEW C,G,L,R
;
F C=1:1 S L=$T(KILLEM+C),L=$P(L,";",3) Q:L="###" D
. W !,$P(L,"^",1),?11,$P(L,"^",2),?50,$J($$RSEL^ZIBRSEL($P(L,"^",1)_"*"),4),?59,$J($$CG($P(L,"^",1)),4)
. I $Y>(IOSL-3),$$DIR^XBDIR("E","Press RETURN for the rest of the list") W @IOF
.Q
;
Q:$G(XBLIST)
;
I '$$DIR^XBDIR("Y","Are you sure you want to continue","NO",$G(DTIME,300)) Q
;
W !!,"There will be 3 steps:"
W !?10,"1) Delete package via call to XBPKDEL;"
W !?10,"2) Delete Routines (not asked if 0 routines);"
W !?10,"3) Delete Globals (not asked if 0 globals)."
W !,"Of course, your wisdom will be questioned if you do this w/o a full b/u...",!
;
Q:'$$DIR^XBDIR("E")
;
F C=1:1 S L=$T(KILLEM+C),L=$P(L,";",3) Q:L="###" D Q:$G(XBPKSTP)
. W !!,$P(L,"^",1),?11,$P(L,"^",2)
. S XBPKEY=1,XBPKNSP=$P(L,"^",1)
. D DEL(XBPKNSP)
. Q:$G(XBPKSTP)
. D RTNS(XBPKNSP)
. Q:$G(XBPKSTP)
. D GBLS(XBPKNSP)
. Q:$G(XBPKSTP)
.Q
;
D EOJ^XBPKDEL
Q
;
; -------------------------------------------------------------
DEL(XBPKNSP) ;
W !,"Deleting the ",XBPKNSP," package components via call to XBPKDEL"
NEW C,G,L,R
S XBPKRUN=""
D ^XBPKDEL
Q
; -------------------------------------------------------------
RTNS(XBPKNSP) ;
NEW C,G,L,R,XB
S XB=$$RSEL^ZIBRSEL(XBPKNSP_"*")
Q:'XB
I '$$DIR^XBDIR("Y","Delete "_XB_" routines in the "_XBPKNSP_" namespace","NO","","If you answer 'YES', the routines will be deleted") S:X=U XBPKSTP=1 Q
W !,"Deleting ",XB," ",XBPKNSP," routines",!
S X=""
F S X=$O(^TMP("ZIBRSEL",$J,X)) Q:X="" W X,$J("",10-$L(X)) X ^%ZOSF("DEL")
KILL ^TMP("ZIBRSEL",$J)
Q
; -------------------------------------------------------------
GBLS(XBPKNSP) ;
NEW C,G,L,R,XB
S XB=$$CG(XBPKNSP)
Q:'XB
I '$$DIR^XBDIR("Y","Delete "_XB_" globals in the "_XBPKNSP_" namespace","NO","","If you answer 'YES', the globals will be deleted") S:X=U XBPKSTP=1 Q
W !,"Kill'ing ",$$CG(XBPKNSP)," ",XBPKNSP," globals",!
S G="^"_XBPKNSP,L=$L(XBPKNSP)
;I '$$KILLOK^ZIBGCHAR(G) KILL @G ;IHS/SET/GTH XB*3*9 10/29/2002
I '$$KILLOK^ZIBGCHAR(XBPKNSP) KILL @G ;IHS/SET/GTH XB*3*9 10/29/2002
;F S G=$O(@G) Q:'($E(G,1,L)=XBPKNSP) S G="^"_G W G,$J("",10-$L(G)) D ;IHS/SET/GTH XB*3*9 10/29/2002
F S G=$O(^$G(G)) Q:'($E(G,2,L+1)=XBPKNSP) W G,$J("",10-$L(G)) D ;IHS/SET/GTH XB*3*9 10/29/2002
. I '$$KILLOK^ZIBGCHAR($E(G,2,$L(G))) KILL @G Q
. W !,"<KILL UNSUCCESSFUL>: ",$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($E(G,2,$L(G))))
.Q
Q
; -------------------------------------------------------------
CG(N) ; Count the globals in the N namespace.
NEW C,G,L,R
S C=0,G="^"_N,L=$L(N)
I $D(@G) S C=1
;F S G=$O(@G) Q:'($E(G,1,L)=N) S G="^"_G,C=C+1 ;IHS/SET/GTH XB*3*9 10/29/2002
F S G=$O(^$G(G)) Q:'($E(G,2,L+1)=N) S C=C+1 ;IHS/SET/GTH XB*3*9 10/29/2002
Q C
; -------------------------------------------------------------
LIST ;EP - List retired/replaced packages.
NEW XBLIST
S XBLIST=1
W @IOF
D L1
Q
; -------------------------------------------------------------
KILLEM ; Add the packages to be deleted, below: Namespace^Description
;;AAPC^Ambulatory Patient Care Data Entry
;;ACI^Injury Report
;;ACHA^Community Health Nursing
;;ADB^Diabetic Tracking System
;;AMAL^Malpractice Claims
;;APCM^PCC Table Maintenance
;;AMCP^Women's Health/Pap Smear
;;AMR^Management Status
;;AMS^Management Referral
;;APCQ^PCC Quality Assurance
;;APCG^Family Genetic Linkage
;;APCR^PCC Register
;;APCS^PCC Surveillance
;;APCT^PCC Clinic Training
;;APHR^Physician Tracking
;;ATA^Original Time and Attendance
;;ALP^Mainframe to RPMS data insertion
;;BRB^Institutional Review Board
;;###
;
XBPKDEL1 ; IHS/ADC/GTH - DELETE RETIRED AND REPLACED PACKAGES ; [ 10/29/2002 7:42 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**8,9**;FEB 07, 1997
+2 ; XB*3*8 - IHS/ASDST/GTH - 12-07-00 - New routine with patch 8.
+3 ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Use $GLOBAL.
+4 ;
+5 ; DECERT subroutine processes a list of retired/replaced
+6 ; packages, and gives the user the opportunity to delete all
+7 ; the package components, the routines, and globals, in the
+8 ; namspace of the package.
+9 ;
Q QUIT
+1 ; -------------------------------------------------------------
DECERT ;EP - Delete de-certified packages.
+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 ;
+4 WRITE @IOF,!!,"You'll be given the opportunity to delete the following packages,",!,"Routines, and Globals in the indicated namespace, in 3 steps."
L1 ;
+1 WRITE !,"NAMESPACE--DESCRIPTION----------------------------RTNS-----GBLS------"
+2 ;
+3 NEW C,G,L,R
+4 ;
+5 FOR C=1:1
SET L=$TEXT(KILLEM+C)
SET L=$PIECE(L,";",3)
IF L="###"
QUIT
Begin DoDot:1
+6 WRITE !,$PIECE(L,"^",1),?11,$PIECE(L,"^",2),?50,$JUSTIFY($$RSEL^ZIBRSEL($PIECE(L,"^",1)_"*"),4),?59,$JUSTIFY($$CG($PIECE(L,"^",1)),4)
+7 IF $Y>(IOSL-3)
IF $$DIR^XBDIR("E","Press RETURN for the rest of the list")
WRITE @IOF
+8 QUIT
End DoDot:1
+9 ;
+10 IF $GET(XBLIST)
QUIT
+11 ;
+12 IF '$$DIR^XBDIR("Y","Are you sure you want to continue","NO",$GET(DTIME,300))
QUIT
+13 ;
+14 WRITE !!,"There will be 3 steps:"
+15 WRITE !?10,"1) Delete package via call to XBPKDEL;"
+16 WRITE !?10,"2) Delete Routines (not asked if 0 routines);"
+17 WRITE !?10,"3) Delete Globals (not asked if 0 globals)."
+18 WRITE !,"Of course, your wisdom will be questioned if you do this w/o a full b/u...",!
+19 ;
+20 IF '$$DIR^XBDIR("E")
QUIT
+21 ;
+22 FOR C=1:1
SET L=$TEXT(KILLEM+C)
SET L=$PIECE(L,";",3)
IF L="###"
QUIT
Begin DoDot:1
+23 WRITE !!,$PIECE(L,"^",1),?11,$PIECE(L,"^",2)
+24 SET XBPKEY=1
SET XBPKNSP=$PIECE(L,"^",1)
+25 DO DEL(XBPKNSP)
+26 IF $GET(XBPKSTP)
QUIT
+27 DO RTNS(XBPKNSP)
+28 IF $GET(XBPKSTP)
QUIT
+29 DO GBLS(XBPKNSP)
+30 IF $GET(XBPKSTP)
QUIT
+31 QUIT
End DoDot:1
IF $GET(XBPKSTP)
QUIT
+32 ;
+33 DO EOJ^XBPKDEL
+34 QUIT
+35 ;
+36 ; -------------------------------------------------------------
DEL(XBPKNSP) ;
+1 WRITE !,"Deleting the ",XBPKNSP," package components via call to XBPKDEL"
+2 NEW C,G,L,R
+3 SET XBPKRUN=""
+4 DO ^XBPKDEL
+5 QUIT
+6 ; -------------------------------------------------------------
RTNS(XBPKNSP) ;
+1 NEW C,G,L,R,XB
+2 SET XB=$$RSEL^ZIBRSEL(XBPKNSP_"*")
+3 IF 'XB
QUIT
+4 IF '$$DIR^XBDIR("Y","Delete "_XB_" routines in the "_XBPKNSP_" namespace","NO","","If you answer 'YES', the routines will be deleted")
IF X=U
SET XBPKSTP=1
QUIT
+5 WRITE !,"Deleting ",XB," ",XBPKNSP," routines",!
+6 SET X=""
+7 FOR
SET X=$ORDER(^TMP("ZIBRSEL",$JOB,X))
IF X=""
QUIT
WRITE X,$JUSTIFY("",10-$LENGTH(X))
XECUTE ^%ZOSF("DEL")
+8 KILL ^TMP("ZIBRSEL",$JOB)
+9 QUIT
+10 ; -------------------------------------------------------------
GBLS(XBPKNSP) ;
+1 NEW C,G,L,R,XB
+2 SET XB=$$CG(XBPKNSP)
+3 IF 'XB
QUIT
+4 IF '$$DIR^XBDIR("Y","Delete "_XB_" globals in the "_XBPKNSP_" namespace","NO","","If you answer 'YES', the globals will be deleted")
IF X=U
SET XBPKSTP=1
QUIT
+5 WRITE !,"Kill'ing ",$$CG(XBPKNSP)," ",XBPKNSP," globals",!
+6 SET G="^"_XBPKNSP
SET L=$LENGTH(XBPKNSP)
+7 ;I '$$KILLOK^ZIBGCHAR(G) KILL @G ;IHS/SET/GTH XB*3*9 10/29/2002
+8 ;IHS/SET/GTH XB*3*9 10/29/2002
IF '$$KILLOK^ZIBGCHAR(XBPKNSP)
KILL @G
+9 ;F S G=$O(@G) Q:'($E(G,1,L)=XBPKNSP) S G="^"_G W G,$J("",10-$L(G)) D ;IHS/SET/GTH XB*3*9 10/29/2002
+10 ;IHS/SET/GTH XB*3*9 10/29/2002
FOR
SET G=$ORDER(^$GET(G))
IF '($EXTRACT(G,2,L+1)=XBPKNSP)
QUIT
WRITE G,$JUSTIFY("",10-$LENGTH(G))
Begin DoDot:1
+11 IF '$$KILLOK^ZIBGCHAR($EXTRACT(G,2,$LENGTH(G)))
KILL @G
QUIT
+12 WRITE !,"<KILL UNSUCCESSFUL>: ",$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($EXTRACT(G,2,$LENGTH(G))))
+13 QUIT
End DoDot:1
+14 QUIT
+15 ; -------------------------------------------------------------
CG(N) ; Count the globals in the N namespace.
+1 NEW C,G,L,R
+2 SET C=0
SET G="^"_N
SET L=$LENGTH(N)
+3 IF $DATA(@G)
SET C=1
+4 ;F S G=$O(@G) Q:'($E(G,1,L)=N) S G="^"_G,C=C+1 ;IHS/SET/GTH XB*3*9 10/29/2002
+5 ;IHS/SET/GTH XB*3*9 10/29/2002
FOR
SET G=$ORDER(^$GET(G))
IF '($EXTRACT(G,2,L+1)=N)
QUIT
SET C=C+1
+6 QUIT C
+7 ; -------------------------------------------------------------
LIST ;EP - List retired/replaced packages.
+1 NEW XBLIST
+2 SET XBLIST=1
+3 WRITE @IOF
+4 DO L1
+5 QUIT
+6 ; -------------------------------------------------------------
KILLEM ; Add the packages to be deleted, below: Namespace^Description
+1 ;;AAPC^Ambulatory Patient Care Data Entry
+2 ;;ACI^Injury Report
+3 ;;ACHA^Community Health Nursing
+4 ;;ADB^Diabetic Tracking System
+5 ;;AMAL^Malpractice Claims
+6 ;;APCM^PCC Table Maintenance
+7 ;;AMCP^Women's Health/Pap Smear
+8 ;;AMR^Management Status
+9 ;;AMS^Management Referral
+10 ;;APCQ^PCC Quality Assurance
+11 ;;APCG^Family Genetic Linkage
+12 ;;APCR^PCC Register
+13 ;;APCS^PCC Surveillance
+14 ;;APCT^PCC Clinic Training
+15 ;;APHR^Physician Tracking
+16 ;;ATA^Original Time and Attendance
+17 ;;ALP^Mainframe to RPMS data insertion
+18 ;;BRB^Institutional Review Board
+19 ;;###
+20 ;
