TMGXPDR   ;TMG/kst/Altered version of XPDR ;03/25/06
         ;;1.0;TMG-LIB;**1**;7/25/05
 
 ;"TMGXPDR -- a custom version of XPDR
 ;"K. Toppenberg, MD 7-25-05
 
XPDR    ;SFISC/RSD - Routine File Edit ;09/17/96  10:05
        ;;8.0;KERNEL;**1,2,44**;Jul 10, 1995
        Q
 
UPDT        ;update routine file
        new DIR,DIRUT,XPD,XPDI,XPDJ
        new XPDN  ;"array of included (1 node) and excluded (0 node) namespaces
        new X,X1,Y,Y1,%
        new addCount set addCount=0
 
        write !!
        write "** ROUTINE File Updater **",!
        write "(Allows addition of selected routines to ROUTINE file)",!
        write "-----------------------------------------------------------",!
        write !
        write "Enter namespace of routines to add (e.g. TIU), or",!
        write "routines to exclude from addition (e.g. -TIU)",!!
 
        set DIR(0)="FO^1:9^K:X'?.1""-""1U.7UNP X"
        set DIR("A")="Routine Namespace ([ENTER] if done)"
        set DIR("?")="Enter 1 to 8 characters, preceed with ""-"" to exclude namespace"
 
        ;"XPDN(0=excluded names or 1=include names, namespace)=""
        for  do  quit:$data(DIRUT)
        . do ^DIR
        . quit:$data(DIRUT)
        . set X=($extract(Y,$L(Y))="*")
        . set %=($extract(Y)="-")
        . set XPDN('%,$extract(Y,%+1,$length(Y)-X))=""
 
        if ('$data(XPDN))!($data(DTOUT))!($data(DUOUT)) write ! goto UPDTQ
        ;"quit:'$data(XPDN)!$data(DTOUT)!$data(DUOUT)
        write !!,"NAMESPACE  INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
        set (X,Y)=""
        set (X1,Y1)=1
        for  do  write !?11,X,?35,Y quit:'X1&'Y1
        . set:X1 X=$O(XPDN(1,X)),X1=X]""
        . set:Y1 Y=$O(XPDN(0,Y)),Y1=Y]""
 
        kill DIR
        set DIR(0)="Y"
        set DIR("A")="OK to continue"
        set DIR("B")="YES"
        do ^DIR
 
        quit:'Y!$data(DIRUT)
        write !
        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 throught the Routine file and delete any routine name that no longer exists on the system."
        do ^DIR
 
        quit:$data(DIRUT)
        do WAIT^DICD
        write !
        do DELRTN:Y
 
        ;"----------------------------------------------------------------------------
        ;"Replacement code for below...
        new XPDArray
        merge XPDArray=XPDN(1)  ;"node 1=>included namespaces
        ;"ensure that all entries end with "*" (e.g. "TMG*" not "TMG")
        set XPDI=$order(XPDArray(""))
        if XPDI'="" for  do  quit:XPDI=""
        . new node set node=XPDI
        . set XPDI=$order(XPDArray(node))
        . if ($extract(node,$length(node))'="*") do
        . . kill XPDArray(node)
        . . set XPDArray(node_"*")=""
 
        do NOINT^%RSEL("XPDArray")  ;"creates %ZR - an array of existing routines matching input request
        set XPDJ=""
        for  do  quit:XPDJ=""
        . set XPDJ=$order(%ZR(XPDJ))
        . if XPDJ="" quit
        . if $data(XPDN(0,XPDJ)) quit ;"if name XPDJ is in the exclude list, skip
        . if $order(^DIC(9.8,"B",XPDJ,0)) quit  ;"if name XPDJ is already in Routine file, skip
        . ;"check if XPDJ is refered in the EXCLUDED namespace by checking the subscript before XPDJ
        . set %=$order(XPDN(0,XPDJ),-1)
        . ;"if sub exist and $piece(XPDJ,sub)="" then it is part of the namespace, quit
        . if ($length(%)>0)&($piece(XPDJ,%)="") quit
        . ;"Add routine to ROUTINE file
        . new XPD
        . set XPD(9.8,"+1,",.01)=XPDJ
        . set XPD(9.8,"+1,",1)="R"
        . do ADD^DICA("","XPD")
        . write "Added: ",XPDJ,!
        . set addCount=addCount+1
UPDTQ
        write "    ...Done.",!
        if addCount=0 write "ROUTINE file already up to date.  No additions needed.",!
        else  write addCount," entries added to ROUTINE file.",!
        write "Leaving ROUTINE File Updater.",!
        quit
 
        ;"----------------------------------------------------------------------------
 
        ;"loop thru include list XPDN(1,*), i.e. included nodes-->requested namespaces
        ;"Goal: to consider each requested namespace...
 
        ;"Pseudocode:
        ;"          loop  (through all requested namespaces)
        ;"            XPDI = currently considered namespace
        ;"            loop (through all available routines--starting at XPDI)
        ;"              XPDJ is current routine name being considered -- from all available routines
        ;"              if current routine name (XPDJ) is in exclude list, skip
        ;"              if current routine name (XPDJ) is already in the ROUTINE file, then skip
        ;"              ... (to be completed)
 
        ;set XPDI=""
        ;for  do  quit:XPDI=""
        ;. set XPDI=$order(XPDN(1,XPDI))
        ;. quit:XPDI=""
        ;. set XPDJ=XPDI
        ;. if '$data(^$routine(XPDJ)) quit
        ;. for  set XPDJ=$order(^$routine(XPDJ)) quit:(XPDJ="")!($piece(XPDJ,XPDI)]"")  do
        ;. . if $data(XPDN(0,XPDJ)) quit ;"if name XPDJ is in the exclude list, XPDN(0,XPDJ) quit
        ;. . if $order(^DIC(9.8,"B",XPDJ,0)) quit  ;"if name XPDJ is in Routine file, quit
        ;. . ;"check if XPDJ is refered in the EXCLUDED namespace by checking the subscript before XPDJ
        ;. . set %=$order(XPDN(0,XPDJ),-1)
        ;. . ;"if sub exist and $piece(XPDJ,sub)="" then it is part of the namespace, quit
        ;. . if ($length(%)>0)&($piece(XPDJ,%)="") quit ;"e.g $piece("TMGTEST",
        ;. . new XPD
        ;. . set XPD(9.8,"+1,",.01)=XPDJ
        ;. . set XPD(9.8,"+1,",1)="R"
        ;. . do ADD^DICA("","XPD")
        ;write "    ...Done.",!
        ;quit
 
VER        ;verify Routine file
        N DIR,DIRUT,X,Y
        W !,"I will delete all 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,Y,count,max,delNum
        S DIK="^DIC(9.8,",DA=0,count=0,max=0,delNum=0
 ;"        F  S DA=$O(^DIC(9.8,DA)) Q:'DA  S Y=$G(^(DA,0)) I $P(Y,U,2)="R",$T(^@$P(Y,U))="" D ^DIK
        do INIT^XPDID
        for  set DA=$order(^DIC(9.8,DA)) quit:'DA  set max=max+1
        if max=0 set max=1
        set XPDIDTOT=max
        do TITLE^XPDID("Scanning for Entries to Remove...")
        set DA=0
        write !,"Starting search...",!
        for  set DA=$order(^DIC(9.8,DA)) quit:'DA  do
        . set count=count+1
        . if count#50=0 do UPDATE^XPDID(count)
        . set Y=$G(^(DA,0))
        . if ($piece(Y,U,2)="R")&($text(^@$piece(Y,U))="") do
        . . write "Removing: ",$piece(Y,U),!
        . . set delNum=delNum+1
        . . do ^DIK
        write !
        if delNum>0 do
        . new temp
        . write "Done scanning.  ",delNum," Entries removed.",!
        . read "Please press [ENTER] to continue.",temp:$get(DTIME,3600),!
        do EXIT^XPDID()
        quit
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