- XPDR ;SFISC/RSD - Routine File Edit ;09/17/96 10:05
- ;;8.0;KERNEL;**1,2,44,393,547,713,738**;Jul 10, 1995;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- Q
- UPDT ;update routine file
- N DIR,DIRUT,XPD,XPDI,XPDJ,XPDN,XPDGTM,X,X1,Y,Y1,% W !
- ;p738 change 8 to 16
- W ! S DIR(0)="FO^1:16^K:X'?.1""-""1U.15UNP X",DIR("A")="Routine Namespace",DIR("?")="Enter 1 to 16 characters, precede with ""-"" to exclude namespace"
- ;XPDN(0=excluded names or 1=include names, namespace)=""
- F D ^DIR Q:$D(DIRUT) S X=$E(Y,$L(Y))="*",%=$E(Y)="-",XPDN('%,$E(Y,%+1,$L(Y)-X))=""
- Q:'$D(XPDN)!$D(DTOUT)!$D(DUOUT)
- W !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
- S (X,Y)="",(X1,Y1)=1
- F D W !?11,X,?35,Y Q:'X1&'Y1
- .S:X1 X=$O(XPDN(1,X)),X1=X]"" S:Y1 Y=$O(XPDN(0,Y)),Y1=Y]""
- K DIR S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
- Q:'Y!$D(DIRUT) W !
- S DIR(0)="Y",DIR("A")="Want me to clean up the Routine File before updating",DIR("?")="YES means you want to go through the Routine file and delete any routine name that no longer exists on the system."
- D ^DIR Q:$D(DIRUT)
- D WAIT^DICD,DELRTN:Y
- ;if GTM, create temporary list in %ZR
- S XPDGTM=$G(^%ZOSF("OS"))["GT.M" I XPDGTM D SILENT^%RSEL("*")
- ;loop thru include list XPDN(1,XPDI)
- S XPDI="" F S XPDI=$O(XPDN(1,XPDI)) Q:XPDI="" S XPDJ=XPDI D
- . I 'XPDGTM D:$D(^$R(XPDJ)) UPDT1(XPDJ) F S XPDJ=$O(^$R(XPDJ)) Q:XPDJ=""!($P(XPDJ,XPDI)]"") D UPDT1(XPDJ)
- . I XPDGTM D:$D(%ZR(XPDJ)) UPDT1(XPDJ) F S XPDJ=$O(%ZR(XPDJ)) Q:XPDJ=""!($P(XPDJ,XPDI)]"") D UPDT1(XPDJ)
- . Q
- W " ...Done.",!
- Q
- ;
- UPDT1(XPDRT) ;check routine XPDRT
- ;if name XPDRT is in the exclude list, XPDN(0,XPDRT) or in Routine file, quit
- Q:$D(XPDN(0,XPDRT))!$O(^DIC(9.8,"B",XPDRT,0))
- ;check if XPDRT is refered in the namespace by checking the subscript
- ;before XPDRT, if sub exist and $P(XPDRT,sub)="" then it is part of the
- ;namespace, quit
- S %=$O(XPDN(0,XPDRT),-1) I $L(%),$P(XPDRT,%)="" Q
- N XPD S XPD(9.8,"+1,",.01)=XPDRT,XPD(9.8,"+1,",1)="R"
- D ADD^DICA("","XPD")
- Q
- ;
- VER ;verify Routine file
- N DIR,DIRUT,X,Y
- W !,"I will delete all local entries in the Routine File in which",!,"the Routine no longer exist on this system!",!
- S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
- Q:'Y!$D(DIRUT) D DELRTN
- W " ...Done.",!
- Q
- DELRTN ;delete routine file entries
- N DA,DIK,X,Y
- W !,"Routines listed as National will not be deleted!"
- S DIK="^DIC(9.8,",DA=0
- F S DA=$O(^DIC(9.8,DA)) Q:'DA S Y=$G(^(DA,0)) D ;p713
- . I $P(Y,U,2)="R",$G(^DIC(9.8,DA,6))<2 S X=$P(Y,U) X ^%ZOSF("TEST") E D ^DIK
- . Q
- Q
- PURGE ;purge file
- N DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z
- S DIR("?")="Enter the file you want to purge the data from.",DIR(0)="SM^B:Build;I:Install;ALL:Build & Install",DIR("A")="Purge from what file(s)"
- D ^DIR Q:$D(DIRUT)
- S XPDF=$S(Y="I":9.7,1:9.6) S:Y="ALL" XPDF(1)=9.7
- K DIR S DIR("?")="Enter the number of Versions to keep in the file, for each package",DIR(0)="N^0:100:0",DIR("A")="Versions to Retain",DIR("B")=1
- D ^DIR Q:$D(DIRUT) S XPDN=Y
- K DIR
- S DIR(0)="FO^3:30",DIR("?")="^D PURGEH^XPDR",DIR("A")="Package Name",DIR("B")="ALL"
- F D ^DIR Q:$D(DIRUT) S XPD(X)="" Q:X="ALL" K DIR("B") S DIR("A")="Another Package Name"
- Q:'$D(XPD)
- ;if they want all, make sure all is the only one
- I $D(XPD("ALL")) K XPD S XPD("ALL")=""
- ;XPDF(1) is defined if doing both files, do purge twice
- K ^TMP($J) D PURGE1(XPDF),PURGE1($G(XPDF(1))):$D(XPDF(1))
- I '$D(^TMP($J)) W !!,"No match found" Q
- K XPD,DIR
- S DIR(0)="E",$P(XPDUL,"-",IOM)=""
- ;if ALL, reset XPDF to next file and Do, then reset back to 9.6
- D I $D(XPDF(1)) D ^DIR I Y S XPDF=XPDF(1) D S XPDF=9.6
- .S XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS),XPDPG=1,Y=1
- .W @IOF D HDR
- .;loop thru ^TMP($J,file,package) & show list, quit if user "^"
- .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D Q:'Y
- ..S Z=@XPD W $P(Z,"^"),$S($P(Z,"^",3):" (duplicates)",1:""),! Q:$Y<(IOSL-4)
- ..D ^DIR Q:'Y
- ..S XPDPG=XPDPG+1 W @IOF D HDR
- S DIR(0)="Y",DIR("A")="OK to DELETE these entries",DIR("B")="NO"
- W !! D ^DIR
- I $D(DIRUT)!'Y W !!,"Nothing Purged" Q
- ;loop thru and delete
- D I $D(XPDF(1)) S XPDF=XPDF(1) D
- .S DIK="^XPD("_XPDF_",",XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS)
- .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D
- ..S XPDI=@XPD F XPDJ=2:1 S DA=$P(XPDI,"^",XPDJ) Q:'DA D ^DIK
- Q
- ;
- PURGE1(XPDF) ;XPDF=file #
- N XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z
- W "."
- ;if All, loop thru B x-ref
- I $D(XPD("ALL")) D
- .S XPDI=""
- .F S XPDI=$O(^XPD(XPDF,"B",XPDI)) Q:XPDI="" D
- ..S X=$$PKG^XPDUTL(XPDI) D PURGE2(X)
- ..W "."
- E S XPDI="" F S XPDI=$O(XPD(XPDI)) Q:XPDI="" D
- .D PURGE2(XPDI)
- .W "."
- ;loop thru each package, XPDP=package name
- S XPDP="" F S XPDP=$O(^TMP($J,XPDF,XPDP)) Q:XPDP="" D
- .S XPDV="",XPDL=XPDN
- .;the last is the most recent, XPDN = number to retain, XPDV=version
- .;XPDS=type (T/V/Z)
- .F S XPDV=$O(^TMP($J,XPDF,XPDP,XPDV),-1),XPDS="" Q:'XPDV!'XPDL F S XPDS=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS),-1) Q:XPDS=""!'XPDL D
- ..S Y="" F S Y=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y),-1) Q:Y=""!'XPDL D
- ...I $D(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y))#2 K ^(Y) S XPDL=XPDL-1 Q
- ...S Z="" F S Z=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y,Z),-1) Q:Z=""!'XPDL K ^(Z) S XPDL=XPDL-1
- Q
- ;
- PURGE2(XPDX) ;XPDX=package name
- ;XPDFL=1 this is not a patch, quit when we find a patch during loop
- S XPDS=XPDX,XPDL=$L(XPDX),XPDFL=XPDX'["*"
- ;loop and find matches
- D F S XPDS=$O(^XPD(XPDF,"B",XPDS)) Q:XPDS=""!($E(XPDS,1,XPDL)'=XPDX)!($S(XPDFL:XPDS["*",1:0)) D
- .S Y=$O(^XPD(XPDF,"B",XPDS,0)) Q:'Y
- .Q:'$D(^XPD(XPDF,Y,0)) S Z=^(0),Y=XPDS_"^"_Y
- .;can't delete Installs that status isn't 'Install Completed'
- .I XPDF=9.7 Q:$P(Z,U,9)<3
- .S XPDV=$$VER^XPDUTL(XPDS)
- .;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs
- .I XPDS["*" D Q
- ..I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*Z",0,+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
- ..I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*T",+$P(XPDV,"T",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
- ..I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*V",+$P(XPDV,"V",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
- ..S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2))
- .;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs
- .I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
- .;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs
- .I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$P(XPDV,"T",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
- .I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$P(XPDV,"V",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
- Q
- PURGEH ;executable help from DIR call at PURGE+8
- W:$E(DIR("A"),1)="P" !,"Enter 'ALL' to purge all packages, or"
- W !,"Enter the name of the Package you want to Purge.",!," i.e. KERNEL 8.0 will purge version 8.0Tx and 8.0Vx",!," XU*8.0 will purge all patches for 8.0",!
- N DIR,X,Y
- S DIR(0)="Y",DIR("A")="Want to see the "_$S(XPDF=9.7:"Install File",$D(XPDF(1)):"Build & Install Files",1:"Build File")_" List",DIR("B")="Y"
- D ^DIR Q:'Y!$D(DIRUT)
- D PURGEH1("^XPD(9.6,"):XPDF=9.6,PURGEH1("^XPD(9.7,"):XPDF=9.7!$D(XPDF(1))
- Q
- ;
- DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien
- ;returns Y=DA^dup DA^dup DA...
- N Y S Y=""
- F S Z1=$O(^XPD(XPDF,"B",Z,Z1)) Q:'Z1 S Y=Y_"^"_Z1
- Q Y
- ;
- PURGEH1(DIC) ;
- W !!,$S(DIC[9.6:"BUILD ",1:"INSTALL ")_"File"
- S DIC(0)="QE",X="??" D ^DIC
- Q
- ;
- HDR W !,"Package(s) in ",$S(XPDF=9.7:"INSTALL",1:"BUILD")," File, "
- I XPDN W "Retain last ",$S(XPDN=1:"version",1:XPDN_" versions")
- E W "Don't retain any versions"
- W ?70,"PAGE ",XPDPG,!,XPDUL,!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDR 7891 printed Feb 18, 2025@23:30:52 Page 2
- XPDR ;SFISC/RSD - Routine File Edit ;09/17/96 10:05
- +1 ;;8.0;KERNEL;**1,2,44,393,547,713,738**;Jul 10, 1995;Build 5
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 QUIT
- UPDT ;update routine file
- +1 NEW DIR,DIRUT,XPD,XPDI,XPDJ,XPDN,XPDGTM,X,X1,Y,Y1,%
- WRITE !
- +2 ;p738 change 8 to 16
- +3 WRITE !
- SET DIR(0)="FO^1:16^K:X'?.1""-""1U.15UNP X"
- SET DIR("A")="Routine Namespace"
- SET DIR("?")="Enter 1 to 16 characters, precede with ""-"" to exclude namespace"
- +4 ;XPDN(0=excluded names or 1=include names, namespace)=""
- +5 FOR
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET X=$EXTRACT(Y,$LENGTH(Y))="*"
- SET %=$EXTRACT(Y)="-"
- SET XPDN('%,$EXTRACT(Y,%+1,$LENGTH(Y)-X))=""
- +6 if '$DATA(XPDN)!$DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +7 WRITE !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
- +8 SET (X,Y)=""
- SET (X1,Y1)=1
- +9 FOR
- Begin DoDot:1
- +10 if X1
- SET X=$ORDER(XPDN(1,X))
- SET X1=X]""
- if Y1
- SET Y=$ORDER(XPDN(0,Y))
- SET Y1=Y]""
- End DoDot:1
- WRITE !?11,X,?35,Y
- if 'X1&'Y1
- QUIT
- +11 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="OK to continue"
- SET DIR("B")="YES"
- DO ^DIR
- +12 if 'Y!$DATA(DIRUT)
- QUIT
- WRITE !
- +13 SET DIR(0)="Y"
- SET DIR("A")="Want me to clean up the Routine File before updating"
- SET DIR("?")="YES means you want to go through the Routine file and delete any routine name that no longer exists on the system."
- +14 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +15 DO WAIT^DICD
- if Y
- DO DELRTN
- +16 ;if GTM, create temporary list in %ZR
- +17 SET XPDGTM=$GET(^%ZOSF("OS"))["GT.M"
- IF XPDGTM
- DO SILENT^%RSEL("*")
- +18 ;loop thru include list XPDN(1,XPDI)
- +19 SET XPDI=""
- FOR
- SET XPDI=$ORDER(XPDN(1,XPDI))
- if XPDI=""
- QUIT
- SET XPDJ=XPDI
- Begin DoDot:1
- +20 IF 'XPDGTM
- if $DATA(^$RANDOM(XPDJ))
- DO UPDT1(XPDJ)
- FOR
- SET XPDJ=$ORDER(^$RANDOM(XPDJ))
- if XPDJ=""!($PIECE(XPDJ,XPDI)]"")
- QUIT
- DO UPDT1(XPDJ)
- +21 IF XPDGTM
- if $DATA(%ZR(XPDJ))
- DO UPDT1(XPDJ)
- FOR
- SET XPDJ=$ORDER(%ZR(XPDJ))
- if XPDJ=""!($PIECE(XPDJ,XPDI)]"")
- QUIT
- DO UPDT1(XPDJ)
- +22 QUIT
- End DoDot:1
- +23 WRITE " ...Done.",!
- +24 QUIT
- +25 ;
- UPDT1(XPDRT) ;check routine XPDRT
- +1 ;if name XPDRT is in the exclude list, XPDN(0,XPDRT) or in Routine file, quit
- +2 if $DATA(XPDN(0,XPDRT))!$ORDER(^DIC(9.8,"B",XPDRT,0))
- QUIT
- +3 ;check if XPDRT is refered in the namespace by checking the subscript
- +4 ;before XPDRT, if sub exist and $P(XPDRT,sub)="" then it is part of the
- +5 ;namespace, quit
- +6 SET %=$ORDER(XPDN(0,XPDRT),-1)
- IF $LENGTH(%)
- IF $PIECE(XPDRT,%)=""
- QUIT
- +7 NEW XPD
- SET XPD(9.8,"+1,",.01)=XPDRT
- SET XPD(9.8,"+1,",1)="R"
- +8 DO ADD^DICA("","XPD")
- +9 QUIT
- +10 ;
- VER ;verify Routine file
- +1 NEW DIR,DIRUT,X,Y
- +2 WRITE !,"I will delete all local entries in the Routine File in which",!,"the Routine no longer exist on this system!",!
- +3 SET DIR(0)="Y"
- SET DIR("A")="OK to continue"
- SET DIR("B")="YES"
- DO ^DIR
- +4 if 'Y!$DATA(DIRUT)
- QUIT
- DO DELRTN
- +5 WRITE " ...Done.",!
- +6 QUIT
- DELRTN ;delete routine file entries
- +1 NEW DA,DIK,X,Y
- +2 WRITE !,"Routines listed as National will not be deleted!"
- +3 SET DIK="^DIC(9.8,"
- SET DA=0
- +4 ;p713
- FOR
- SET DA=$ORDER(^DIC(9.8,DA))
- if 'DA
- QUIT
- SET Y=$GET(^(DA,0))
- Begin DoDot:1
- +5 IF $PIECE(Y,U,2)="R"
- IF $GET(^DIC(9.8,DA,6))<2
- SET X=$PIECE(Y,U)
- XECUTE ^%ZOSF("TEST")
- IF '$TEST
- DO ^DIK
- +6 QUIT
- End DoDot:1
- +7 QUIT
- PURGE ;purge file
- +1 NEW DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z
- +2 SET DIR("?")="Enter the file you want to purge the data from."
- SET DIR(0)="SM^B:Build;I:Install;ALL:Build & Install"
- SET DIR("A")="Purge from what file(s)"
- +3 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +4 SET XPDF=$SELECT(Y="I":9.7,1:9.6)
- if Y="ALL"
- SET XPDF(1)=9.7
- +5 KILL DIR
- SET DIR("?")="Enter the number of Versions to keep in the file, for each package"
- SET DIR(0)="N^0:100:0"
- SET DIR("A")="Versions to Retain"
- SET DIR("B")=1
- +6 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET XPDN=Y
- +7 KILL DIR
- +8 SET DIR(0)="FO^3:30"
- SET DIR("?")="^D PURGEH^XPDR"
- SET DIR("A")="Package Name"
- SET DIR("B")="ALL"
- +9 FOR
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET XPD(X)=""
- if X="ALL"
- QUIT
- KILL DIR("B")
- SET DIR("A")="Another Package Name"
- +10 if '$DATA(XPD)
- QUIT
- +11 ;if they want all, make sure all is the only one
- +12 IF $DATA(XPD("ALL"))
- KILL XPD
- SET XPD("ALL")=""
- +13 ;XPDF(1) is defined if doing both files, do purge twice
- +14 KILL ^TMP($JOB)
- DO PURGE1(XPDF)
- if $DATA(XPDF(1))
- DO PURGE1($GET(XPDF(1)))
- +15 IF '$DATA(^TMP($JOB))
- WRITE !!,"No match found"
- QUIT
- +16 KILL XPD,DIR
- +17 SET DIR(0)="E"
- SET $PIECE(XPDUL,"-",IOM)=""
- +18 ;if ALL, reset XPDF to next file and Do, then reset back to 9.6
- +19 Begin DoDot:1
- +20 SET XPD="^TMP("_$JOB_","_XPDF
- SET XPDS=XPD_","
- SET XPD=XPD_")"
- SET XPDL=$LENGTH(XPDS)
- SET XPDPG=1
- SET Y=1
- +21 WRITE @IOF
- DO HDR
- +22 ;loop thru ^TMP($J,file,package) & show list, quit if user "^"
- +23 FOR
- SET XPD=$QUERY(@XPD)
- if XPD=""!($EXTRACT(XPD,1,XPDL)'=XPDS)
- QUIT
- Begin DoDot:2
- +24 SET Z=@XPD
- WRITE $PIECE(Z,"^"),$SELECT($PIECE(Z,"^",3):" (duplicates)",1:""),!
- if $Y<(IOSL-4)
- QUIT
- +25 DO ^DIR
- if 'Y
- QUIT
- +26 SET XPDPG=XPDPG+1
- WRITE @IOF
- DO HDR
- End DoDot:2
- if 'Y
- QUIT
- End DoDot:1
- IF $DATA(XPDF(1))
- DO ^DIR
- IF Y
- SET XPDF=XPDF(1)
- Begin DoDot:1
- End DoDot:1
- SET XPDF=9.6
- +27 SET DIR(0)="Y"
- SET DIR("A")="OK to DELETE these entries"
- SET DIR("B")="NO"
- +28 WRITE !!
- DO ^DIR
- +29 IF $DATA(DIRUT)!'Y
- WRITE !!,"Nothing Purged"
- QUIT
- +30 ;loop thru and delete
- +31 Begin DoDot:1
- +32 SET DIK="^XPD("_XPDF_","
- SET XPD="^TMP("_$JOB_","_XPDF
- SET XPDS=XPD_","
- SET XPD=XPD_")"
- SET XPDL=$LENGTH(XPDS)
- +33 FOR
- SET XPD=$QUERY(@XPD)
- if XPD=""!($EXTRACT(XPD,1,XPDL)'=XPDS)
- QUIT
- Begin DoDot:2
- +34 SET XPDI=@XPD
- FOR XPDJ=2:1
- SET DA=$PIECE(XPDI,"^",XPDJ)
- if 'DA
- QUIT
- DO ^DIK
- End DoDot:2
- End DoDot:1
- IF $DATA(XPDF(1))
- SET XPDF=XPDF(1)
- Begin DoDot:1
- End DoDot:1
- +35 QUIT
- +36 ;
- PURGE1(XPDF) ;XPDF=file #
- +1 NEW XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z
- +2 WRITE "."
- +3 ;if All, loop thru B x-ref
- +4 IF $DATA(XPD("ALL"))
- Begin DoDot:1
- +5 SET XPDI=""
- +6 FOR
- SET XPDI=$ORDER(^XPD(XPDF,"B",XPDI))
- if XPDI=""
- QUIT
- Begin DoDot:2
- +7 SET X=$$PKG^XPDUTL(XPDI)
- DO PURGE2(X)
- +8 WRITE "."
- End DoDot:2
- End DoDot:1
- +9 IF '$TEST
- SET XPDI=""
- FOR
- SET XPDI=$ORDER(XPD(XPDI))
- if XPDI=""
- QUIT
- Begin DoDot:1
- +10 DO PURGE2(XPDI)
- +11 WRITE "."
- End DoDot:1
- +12 ;loop thru each package, XPDP=package name
- +13 SET XPDP=""
- FOR
- SET XPDP=$ORDER(^TMP($JOB,XPDF,XPDP))
- if XPDP=""
- QUIT
- Begin DoDot:1
- +14 SET XPDV=""
- SET XPDL=XPDN
- +15 ;the last is the most recent, XPDN = number to retain, XPDV=version
- +16 ;XPDS=type (T/V/Z)
- +17 FOR
- SET XPDV=$ORDER(^TMP($JOB,XPDF,XPDP,XPDV),-1)
- SET XPDS=""
- if 'XPDV!'XPDL
- QUIT
- FOR
- SET XPDS=$ORDER(^TMP($JOB,XPDF,XPDP,XPDV,XPDS),-1)
- if XPDS=""!'XPDL
- QUIT
- Begin DoDot:2
- +18 SET Y=""
- FOR
- SET Y=$ORDER(^TMP($JOB,XPDF,XPDP,XPDV,XPDS,Y),-1)
- if Y=""!'XPDL
- QUIT
- Begin DoDot:3
- +19 IF $DATA(^TMP($JOB,XPDF,XPDP,XPDV,XPDS,Y))#2
- KILL ^(Y)
- SET XPDL=XPDL-1
- QUIT
- +20 SET Z=""
- FOR
- SET Z=$ORDER(^TMP($JOB,XPDF,XPDP,XPDV,XPDS,Y,Z),-1)
- if Z=""!'XPDL
- QUIT
- KILL ^(Z)
- SET XPDL=XPDL-1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
- +22 ;
- PURGE2(XPDX) ;XPDX=package name
- +1 ;XPDFL=1 this is not a patch, quit when we find a patch during loop
- +2 SET XPDS=XPDX
- SET XPDL=$LENGTH(XPDX)
- SET XPDFL=XPDX'["*"
- +3 ;loop and find matches
- +4 Begin DoDot:1
- +5 SET Y=$ORDER(^XPD(XPDF,"B",XPDS,0))
- if 'Y
- QUIT
- +6 if '$DATA(^XPD(XPDF,Y,0))
- QUIT
- SET Z=^(0)
- SET Y=XPDS_"^"_Y
- +7 ;can't delete Installs that status isn't 'Install Completed'
- +8 IF XPDF=9.7
- if $PIECE(Z,U,9)<3
- QUIT
- +9 SET XPDV=$$VER^XPDUTL(XPDS)
- +10 ;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs
- +11 IF XPDS["*"
- Begin DoDot:2
- +12 IF XPDV?1.2N1"."1.2N
- SET ^TMP($JOB,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*Z",0,+$PIECE(XPDS,"*",3))=Y_$$DUP(XPDS,$PIECE(Y,"^",2))
- QUIT
- +13 IF XPDV["T"
- SET ^TMP($JOB,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*T",+$PIECE(XPDV,"T",2),+$PIECE(XPDS,"*",3))=Y_$$DUP(XPDS,$PIECE(Y,"^",2))
- QUIT
- +14 IF XPDV["V"
- SET ^TMP($JOB,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*V",+$PIECE(XPDV,"V",2),+$PIECE(XPDS,"*",3))=Y_$$DUP(XPDS,$PIECE(Y,"^",2))
- QUIT
- +15 SET ^TMP($JOB,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$PIECE(XPDS,"*",3))=Y_$$DUP(XPDS,$PIECE(Y,"^",2))
- End DoDot:2
- QUIT
- +16 ;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs
- +17 IF XPDV?1.2N1"."1.2N
- SET ^TMP($JOB,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$PIECE(Y,"^",2))
- QUIT
- +18 ;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs
- +19 IF XPDV["T"
- SET ^TMP($JOB,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$PIECE(XPDV,"T",2))=Y_$$DUP(XPDS,$PIECE(Y,"^",2))
- QUIT
- +20 IF XPDV["V"
- SET ^TMP($JOB,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$PIECE(XPDV,"V",2))=Y_$$DUP(XPDS,$PIECE(Y,"^",2))
- QUIT
- End DoDot:1
- FOR
- SET XPDS=$ORDER(^XPD(XPDF,"B",XPDS))
- if XPDS=""!($EXTRACT(XPDS,1,XPDL)'=XPDX)!($SELECT(XPDFL
- QUIT
- Begin DoDot:1
- End DoDot:1
- +21 QUIT
- PURGEH ;executable help from DIR call at PURGE+8
- +1 if $EXTRACT(DIR("A"),1)="P"
- WRITE !,"Enter 'ALL' to purge all packages, or"
- +2 WRITE !,"Enter the name of the Package you want to Purge.",!," i.e. KERNEL 8.0 will purge version 8.0Tx and 8.0Vx",!," XU*8.0 will purge all patches for 8.0",!
- +3 NEW DIR,X,Y
- +4 SET DIR(0)="Y"
- SET DIR("A")="Want to see the "_$SELECT(XPDF=9.7:"Install File",$DATA(XPDF(1)):"Build & Install Files",1:"Build File")_" List"
- SET DIR("B")="Y"
- +5 DO ^DIR
- if 'Y!$DATA(DIRUT)
- QUIT
- +6 if XPDF=9.6
- DO PURGEH1("^XPD(9.6,")
- if XPDF=9.7!$DATA(XPDF(1))
- DO PURGEH1("^XPD(9.7,")
- +7 QUIT
- +8 ;
- DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien
- +1 ;returns Y=DA^dup DA^dup DA...
- +2 NEW Y
- SET Y=""
- +3 FOR
- SET Z1=$ORDER(^XPD(XPDF,"B",Z,Z1))
- if 'Z1
- QUIT
- SET Y=Y_"^"_Z1
- +4 QUIT Y
- +5 ;
- PURGEH1(DIC) ;
- +1 WRITE !!,$SELECT(DIC[9.6:"BUILD ",1:"INSTALL ")_"File"
- +2 SET DIC(0)="QE"
- SET X="??"
- DO ^DIC
- +3 QUIT
- +4 ;
- HDR WRITE !,"Package(s) in ",$SELECT(XPDF=9.7:"INSTALL",1:"BUILD")," File, "
- +1 IF XPDN
- WRITE "Retain last ",$SELECT(XPDN=1:"version",1:XPDN_" versions")
- +2 IF '$TEST
- WRITE "Don't retain any versions"
- +3 WRITE ?70,"PAGE ",XPDPG,!,XPDUL,!
- +4 QUIT
