XQABTMP.m

XQABTMP ;ISC-SF.SEA/JLI - temporary routine for clean up ;04/16/96  10:49 [ 04/02/2003   8:29 AM ]

 ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003

 ;;8.0;KERNEL;**28**;Jul 10, 1995

 ;This routine can be used to remove Packages from Alpha/Beta testing

 N DA,DIC,DIK,DIR,DIRUT,DIROUT,X,XQ1,XQ2,XQ3,XQ4,XQA,XQDA,XQID,Y

 S DIC="^XTV(8989.3,1,""ABPKG"",",DIC(0)="AEMQZ"

 ;don't allow if there is an address, this can be used to only show

 ;you local packages that you want to remove.

 ;S DIC("S")="I $P(^(0),U,3)="""""

 D ^DIC K DIC Q:Y<0

 S XQDA=+Y,DIR(0)="Y",DIR("A")="You want to remove "_Y(0,0)_" from Alpha/Beta Testing"

 D ^DIR Q:'Y!$D(DIRUT)

 D RMVTEST W !,"Done.",!

 Q

 ;

RMVTEST D GETDATA

 S DIK="^XTV(8989.3,1,""ABPKG"",",DA(1)=1,DA=XQDA

 D ^DIK

 I $O(^XTV(8989.3,1,"ABPKG",0))'>0 K ^XTV(8989.3,1,"ABOPT")

 Q

 ;

GETDATA ;

 F XQ1=0:0 S XQ1=$O(^XTV(8989.3,1,"ABPKG",XQDA,1,XQ1)) Q:XQ1'>0  S XQID=$P(^(XQ1,0),U),XQID(XQID)="" D CHECK

 Q

 ;

CHECK S XQA=$E(XQID,1,$L(XQID)-1)_$C($A($E(XQID,$L(XQID)))-1)_"z"

 F XQ2=0:0 S XQA=$O(^DIC(19,"B",XQA)) Q:XQA=""!($E(XQA,1,$L(XQID))'=XQID)  I $E(XQA,$L(XQID)+1)'="Z" D CHK2

 Q

 ;

CHK2 F XQ3=0:0 S XQ3=$O(^XTV(8989.3,1,"ABPKG",XQDA,1,XQ1,1,XQ3)) Q:XQ3'>0  S XQ4=$P(^(XQ3,0),U) Q:$E(XQA,1,$L(XQ4))=XQ4

 I XQ3'>0 F XQ4=0:0 S XQ4=$O(^DIC(19,"B",XQA,XQ4)) Q:XQ4'>0  K ^XTV(8989.3,1,"ABOPT",XQ4,0)

 Q

XQABTMP   ;ISC-SF.SEA/JLI - temporary routine for clean up ;04/16/96  10:49 [ 04/02/2003   8:29 AM ]

 +1       ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003

 +2       ;;8.0;KERNEL;**28**;Jul 10, 1995

 +3       ;This routine can be used to remove Packages from Alpha/Beta testing

 +4        NEW DA,DIC,DIK,DIR,DIRUT,DIROUT,X,XQ1,XQ2,XQ3,XQ4,XQA,XQDA,XQID,Y

 +5        SET DIC="^XTV(8989.3,1,""ABPKG"","

           SET DIC(0)="AEMQZ"

 +6       ;don't allow if there is an address, this can be used to only show

 +7       ;you local packages that you want to remove.

 +8       ;S DIC("S")="I $P(^(0),U,3)="""""

 +9        DO ^DIC

           KILL DIC

           IF Y<0

               QUIT 

 +10       SET XQDA=+Y

           SET DIR(0)="Y"

           SET DIR("A")="You want to remove "_Y(0,0)_" from Alpha/Beta Testing"

 +11       DO ^DIR

           IF 'Y!$DATA(DIRUT)

               QUIT 

 +12       DO RMVTEST

           WRITE !,"Done.",!

 +13       QUIT 

 +14      ;

RMVTEST    DO GETDATA

 +1        SET DIK="^XTV(8989.3,1,""ABPKG"","

           SET DA(1)=1

           SET DA=XQDA

 +2        DO ^DIK

 +3        IF $ORDER(^XTV(8989.3,1,"ABPKG",0))'>0

               KILL ^XTV(8989.3,1,"ABOPT")

 +4        QUIT 

 +5       ;

GETDATA   ;

 +1        FOR XQ1=0:0

               SET XQ1=$ORDER(^XTV(8989.3,1,"ABPKG",XQDA,1,XQ1))

               IF XQ1'>0

                   QUIT 

               SET XQID=$PIECE(^(XQ1,0),U)

               SET XQID(XQID)=""

               DO CHECK

 +2        QUIT 

 +3       ;

CHECK      SET XQA=$EXTRACT(XQID,1,$LENGTH(XQID)-1)_$CHAR($ASCII($EXTRACT(XQID,$LENGTH(XQID)))-1)_"z"

 +1        FOR XQ2=0:0

               SET XQA=$ORDER(^DIC(19,"B",XQA))

               IF XQA=""!($EXTRACT(XQA,1,$LENGTH(XQID))'=XQID)

                   QUIT 

               IF $EXTRACT(XQA,$LENGTH(XQID)+1)'="Z"

                   DO CHK2

 +2        QUIT 

 +3       ;

CHK2       FOR XQ3=0:0

               SET XQ3=$ORDER(^XTV(8989.3,1,"ABPKG",XQDA,1,XQ1,1,XQ3))

               IF XQ3'>0

                   QUIT 

               SET XQ4=$PIECE(^(XQ3,0),U)

               IF $EXTRACT(XQA,1,$LENGTH(XQ4))=XQ4

                   QUIT 

 +1        IF XQ3'>0

               FOR XQ4=0:0

                   SET XQ4=$ORDER(^DIC(19,"B",XQA,XQ4))

                   IF XQ4'>0

                       QUIT 

                   KILL ^XTV(8989.3,1,"ABOPT",XQ4,0)

 +2        QUIT