AMQQTX.m

AMQQTX ; IHS/CMI/THL - MAKES AD HOC TAXONOMY ;

 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

VAR S AMQQURGN=AMQQURGN+1

 S AMQQTTOT=0

 S AMQQTAX=AMQQURGN

 S AMQQTAXT=$P(^AMQQ(5,AMQQATN,0),U,14)

 S AMQQCTXS=0

 S AMQQTGBL=$P(AMQQTLOK,"(")

 S AMQQHILO="^UTILITY(""AMQQ"",$J,""HILO"")"

 I AMQQTLOK["," S AMQQTGBL=$P(AMQQTLOK,",")_")"

 K AMQQISYS

 I $P(^AMQQ(1,AMQQLINK,0),U,7) S AMQQMULT="",AMQQCTXS=1

 K AMQQTXTR

 I $D(^AMQQ(1,AMQQLINK,4,1,1)) S AMQQTXTR=^(1)

 I '$D(AMQQMULT),$G(AMQQONE)'="" S AMQQTAX=AMQQURGN,AMQQCOMP=";;;"_AMQQTAX_";ALL",^UTILITY("AMQQ TAX",$J,AMQQURGN,"*")="" G EXIT

GET K AMQQSCMP

 I AMQQTAXT=4 S %=^AMQQ(1,AMQQLINK,0),%=$P(%,U,6),%=^DD(+%,$P(%,",",2),0),%=";"_$P(%,U,3),AMQQSSET=%

 D @("EN"_AMQQTAXT_"^AMQQTXG")

 I $D(AMQQQUIT) G EXIT

 I $D(AMQQSCMP) D SCMP G EXIT

 I '$D(^UTILITY("AMQQ TAX",$J,AMQQURGN)) K AMQQTAX S AMQQURGN=AMQQURGN-1 W !! G EXIT

SAVE I AMQQTTOT<2 S %="" F I=0:1 S %=$O(^UTILITY("AMQQ TAX",$J,AMQQURGN,%)) Q:%=""  I I=2 S AMQQTTOT=I Q

 I AMQQTTOT>1 D ^AMQQTX0 I $D(AMQQQUIT) G EXIT

 S AMQQTAX=AMQQURGN

 I $D(AMQQTLFL) K AMQQTLFL G EXIT

 S $P(AMQQCOMP,";",4)=AMQQURGN

EXIT I $G(AMQQTAX)="" K AMQQTAX,AMQQTXGR,AMQQCOMP,AMQQB

 S X=$G(AMQQATNM)

 K AMQQTNAR,AMQQTTX,AMQQTTOT,AMQQTDIC,AMQQTGNO

 K AMQQPOV1,AMQQPOV2,AMQQTLOK,AMQQTGNA,AMQQTGNO,AMQQTAXT,AMQQTXTR,DIPGM,^UTILITY("AMQQ RANGE",$J),^UTILITY("AMQQ DELETE",$J),@AMQQHILO,AMQQTGBL,AMQQSCMP,AMQQSSET,AMQQHILO,%,%Y,A,B,I,Z

 I $D(AMQQDF) S AMQQQUIT=""

 Q

 ;

SCMP ; ENTRY POINT FROM AMQQ0

 I AMQQSCMP'="NULL",AMQQSCMP'="INVERSE" K ^UTILITY("AMQQ TAX",$J,AMQQURGN) S ^(AMQQURGN,"*")=""

 S AMQQCOMP=";;;"_AMQQURGN_";"_AMQQSCMP

 S AMQQTAX=AMQQURGN

 F %="NULL","INVERSE" I AMQQSCMP=% S ^UTILITY("AMQQ TAX",$J,AMQQURGN,$S(%="NULL":"-",1:"--"))="" Q

 Q

 ;

WHATG ; ENTRY POINT FROM AMQQTX SUBROUTINES

 N DIC,DZ,D,A,B

 S DIC="^ATXAX("

 S DIC(0)=""

 S D="B"

 S DIC("S")="I $P(^(0),U,12)=AMQQLINK"

 S DZ="??"

 D DQ^DICQ

 Q

 ;

LIST ; ENTRY POINT FROM AMQQTX SUBROUTINES

 I $O(^UTILITY("AMQQ TAX",$J,AMQQURGN,""))="" W !!,?($D(AMQQZNM)*5),"  You have not made a selection yet...Try again",!! Q

 S %="The following have been selected =>"

 W !!,%,!

 S (%,X)=""

 F I=1:1 S %=$O(^UTILITY("AMQQ TAX",$J,AMQQURGN,%)) Q:%=""  W ! D:'(I#(IOSL-4)) LIST1 Q:X=U  S X=% D

 .I $G(AMQQTTX)="" X:$D(AMQQTXTR) AMQQTXTR W ?5,X Q

 .I $G(AMQQTTX)]"" X AMQQTTX W ?5,X

 S AMQQTTOT=AMQQTTOT+I

 W !!

 Q

 ;

LIST1 W "<>"

 R X:DTIME

 W $C(13),?5,$C(13)

 Q

 ;

SET ; ENTRY POINT FROM AMQQTX SUBROUTINES

 S Y=1

 I $D(AMQQTXEX) W "  (DELETED)" K AMQQTXEX,^UTILITY("AMQQ TAX",$J,AMQQURGN,X) Q

 S ^UTILITY("AMQQ TAX",$J,AMQQURGN,X)=""

 I AMQQTLOK="^PSDRUG(" D DCLASS

 I AMQQTLOK="^AUTTREFT(" D REFT

 Q

 ;

DCLASS ; Handles drug classes

 N AMQQCLAS,I

 I $D(^PSDRUG(X,"ND")) S AMQQCLAS=$P(^("ND"),U,6) I AMQQCLAS

 E  Q

 I '$D(^UTILITY("AMQQ DRUG CLASS",$J,AMQQURGN,AMQQCLAS))

 E  Q

 W !

 S DIR("A")="Do you want meds that are members of the same class as this medication"

 S DIR(0)="Y"

 D ^DIR

 K DIR

 W !

 I Y=1

 E  Q

 S ^UTILITY("AMQQ DRUG CLASS",$J,AMQQURGN,AMQQCLAS)=""

 S I=0

 F  S I=$O(^PSDRUG("VAC",AMQQCLAS,I)) Q:'I  I '$D(^UTILITY("AMQQ TAX",$J,AMQQURGN,I)) S ^(I)=""

 Q

 ;

NULL ; ENTRY POINT FROM AMQQTX SUBROUTINES

 N AMQQNNAM

 S AMQQNNAM=$S($E(AMQQCNAM,$L(AMQQCNAM))="S":$E(AMQQCNAM,1,$L(AMQQCNAM)-1),1:AMQQCNAM)

 I $D(^UTILITY("AMQQ TAX",$J,AMQQURGN)) G N0

 W !,"Do you want me to find all ",AMQQNNAM,"S with no ",AMQQTNAR," entered"

 S %=1

 D YN^DICN

 I $D(DTOUT) S %Y=U

 I $E(%Y)=U S AMQQQUIT="" K DTOUT,DUOUT Q

 I "Yy"[$E(%Y) S AMQQSCMP="NULL" Q

 W !,"Well then..."

N0 I AMQQCTXS W !,"I take it you want me to search for only those ",AMQQNNAM,"S who DO NOT have",!,"any ",AMQQTNAR,"S in this taxonomy" G N1

 W !,"I take it you want me to find only those ",AMQQNNAM,"S whose",!,AMQQTNAR," is NOT in this taxonomy"

N1 S %=1

 D YN^DICN

 I $D(DTOUT) S %Y=U

 I $E(%Y)=U S AMQQQUIT="" Q

 I %Y="" S %Y="Y"

 I "yY"[$E(%Y) S AMQQSCMP="INVERSE"

 W !

 Q

 ;

EN1 ; PROGRAMMER ENTRY POINT FOR TAXONOMY SYSTEM

 N %,A,AMQQ,AMQQA,AMQQATN,AMQQB,AMQQCASE,AMQQCLAS,AMQQCNT,AMQQCOMP,AMQQCTXS,AMQQDF,AMQQDFN,AMQQDONE,AMQQECHO,AMQQHEL1,AMQQHELP,AMQQHILO,AMQQI,AMQQLINK,AMQQLKUP,AMQQLMOR,AMQQMULT,AMQQNDB,AMQQNDBC,AMQQNECO,AMQQNEXT,AMQQNNAM,AMQQNTAX

 N AMQQONE,AMQQPOV1,AMQQPOV2,AMQQQUIT,AMQQR,AMQQSAVE,AMQQSCMP,AMQQSHNO,AMQQSQSJ,AMQQSSET,AMQQSTP,AMQQSUB,AMQQTAXI,AMQQTAXT,AMQQTDIC,AMQQTGBL,AMQQTGFG,AMQQTGNA,AMQQTGNO,AMQQTJMP,AMQQTLFL,AMQQTLOK,AMQQTNAR,AMQQTTOT,AMQQTTX,AMQQTXEX

 I '$D(APCLCRIT) NEW AMQQSQNM

 N AMQQTXGR,AMQQTXTR,AMQQTYP,AMQQVAL,AMQQX,AMQQXX,AMQQXXN,AMQQXXTT,AMQQZNM,B,C,D,DA,DIADD,DIC,DIE,DIK,DINUM,DIPGM,DIR,DLAYGO,DR,DTOUT,DUOUT,DZ,I,N,T,Y,Z,ATXFLG,AMQQATNM

 S AMQQATN=X

 S %=^AMQQ(5,X,0)

 S AMQQTTX=$G(^(3))

 S AMQQLINK=$P(%,U,5)

 S AMQQTNAR=$P(%,U,15)

 S AMQQTDIC=U_$P(%,U,16)

 S AMQQTLOK=U_$P(%,U,18)

 S AMQQATNM=$P(%,U)

 S AMQQURGN=+$G(AMQQURGN)

 K ^UTILITY("AMQQ TAX",$J,AMQQURGN+1)

 I '$G(IOSL) S IOSL=24

 D AMQQTX

 I +$G(AMQQTAX),'$D(^UTILITY("AMQQ TAX",$J,AMQQTAX)) K AMQQTAX

 Q

 ;

REFT ;FIND SPECFIC TYPE OF REFUSAL

 W !!

 N REFT

 S REFT=X

 N AMQQQUIT,X,Y

 F  D REFT1 Q:$D(AMQQQUIT)

 W !!

 Q

REFT1 N GLDA,GL,GLNAM

 S GLDA=$P($G(^AUTTREFT(REFT,0)),U,2)

 S GL=$G(^DIC(+GLDA,0,"GL"))

 S GLNAM=$P($G(^DIC(+GLDA,0)),U)

 S GLN=$S($E(GL,$L(GL))="(":$E(GL,1,$L(GL)-1),1:$E(GL,1,$L(GL)-1)_")")

 Q:GL=""

 N DIC

 S DIC=GL

 S DIC(0)="AEMQZ"

 S DIC("A")="Select "_GLNAM_" refused: "

 S DIC("S")="I $D(^AUPNPREF(""AE"",+GLDA,+Y))"

 D ^DIC

 I Y<1 S AMQQQUIT="" Q

 S ^UTILITY("AMQQ TAX",$J,AMQQURGN,REFT,"REFUSAL",+Y)=""

 S ^UTILITY("AMQQ TAX",$J,AMQQURGN)="REFUSAL"

 Q

AMQQTX    ; IHS/CMI/THL - MAKES AD HOC TAXONOMY ;

 +1       ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58

VAR        SET AMQQURGN=AMQQURGN+1

 +1        SET AMQQTTOT=0

 +2        SET AMQQTAX=AMQQURGN

 +3        SET AMQQTAXT=$PIECE(^AMQQ(5,AMQQATN,0),U,14)

 +4        SET AMQQCTXS=0

 +5        SET AMQQTGBL=$PIECE(AMQQTLOK,"(")

 +6        SET AMQQHILO="^UTILITY(""AMQQ"",$J,""HILO"")"

 +7        IF AMQQTLOK[","

               SET AMQQTGBL=$PIECE(AMQQTLOK,",")_")"

 +8        KILL AMQQISYS

 +9        IF $PIECE(^AMQQ(1,AMQQLINK,0),U,7)

               SET AMQQMULT=""

               SET AMQQCTXS=1

 +10       KILL AMQQTXTR

 +11       IF $DATA(^AMQQ(1,AMQQLINK,4,1,1))

               SET AMQQTXTR=^(1)

 +12       IF '$DATA(AMQQMULT)

               IF $GET(AMQQONE)'=""

                   SET AMQQTAX=AMQQURGN

                   SET AMQQCOMP=";;;"_AMQQTAX_";ALL"

                   SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN,"*")=""

                   GOTO EXIT

GET        KILL AMQQSCMP

 +1        IF AMQQTAXT=4

               SET %=^AMQQ(1,AMQQLINK,0)

               SET %=$PIECE(%,U,6)

               SET %=^DD(+%,$PIECE(%,",",2),0)

               SET %=";"_$PIECE(%,U,3)

               SET AMQQSSET=%

 +2        DO @("EN"_AMQQTAXT_"^AMQQTXG")

 +3        IF $DATA(AMQQQUIT)

               GOTO EXIT

 +4        IF $DATA(AMQQSCMP)

               DO SCMP

               GOTO EXIT

 +5        IF '$DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN))

               KILL AMQQTAX

               SET AMQQURGN=AMQQURGN-1

               WRITE !!

               GOTO EXIT

SAVE       IF AMQQTTOT<2

               SET %=""

               FOR I=0:1

                   SET %=$ORDER(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,%))

                   IF %=""

                       QUIT 

                   IF I=2

                       SET AMQQTTOT=I

                       QUIT 

 +1        IF AMQQTTOT>1

               DO ^AMQQTX0

               IF $DATA(AMQQQUIT)

                   GOTO EXIT

 +2        SET AMQQTAX=AMQQURGN

 +3        IF $DATA(AMQQTLFL)

               KILL AMQQTLFL

               GOTO EXIT

 +4        SET $PIECE(AMQQCOMP,";",4)=AMQQURGN

EXIT       IF $GET(AMQQTAX)=""

               KILL AMQQTAX,AMQQTXGR,AMQQCOMP,AMQQB

 +1        SET X=$GET(AMQQATNM)

 +2        KILL AMQQTNAR,AMQQTTX,AMQQTTOT,AMQQTDIC,AMQQTGNO

 +3        KILL AMQQPOV1,AMQQPOV2,AMQQTLOK,AMQQTGNA,AMQQTGNO,AMQQTAXT,AMQQTXTR,DIPGM,^UTILITY("AMQQ RANGE",$JOB),^UTILITY("AMQQ DELETE",$JOB),@AMQQHILO,AMQQTGBL,AMQQSCMP,AMQQSSET,AMQQHILO,%,%Y,A,B,I,Z

 +4        IF $DATA(AMQQDF)

               SET AMQQQUIT=""

 +5        QUIT 

 +6       ;

SCMP      ; ENTRY POINT FROM AMQQ0

 +1        IF AMQQSCMP'="NULL"

               IF AMQQSCMP'="INVERSE"

                   KILL ^UTILITY("AMQQ TAX",$JOB,AMQQURGN)

                   SET ^(AMQQURGN,"*")=""

 +2        SET AMQQCOMP=";;;"_AMQQURGN_";"_AMQQSCMP

 +3        SET AMQQTAX=AMQQURGN

 +4        FOR %="NULL","INVERSE"

               IF AMQQSCMP=%

                   SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN,$SELECT(%="NULL":"-",1:"--"))=""

                   QUIT 

 +5        QUIT 

 +6       ;

WHATG     ; ENTRY POINT FROM AMQQTX SUBROUTINES

 +1        NEW DIC,DZ,D,A,B

 +2        SET DIC="^ATXAX("

 +3        SET DIC(0)=""

 +4        SET D="B"

 +5        SET DIC("S")="I $P(^(0),U,12)=AMQQLINK"

 +6        SET DZ="??"

 +7        DO DQ^DICQ

 +8        QUIT 

 +9       ;

LIST      ; ENTRY POINT FROM AMQQTX SUBROUTINES

 +1        IF $ORDER(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,""))=""

               WRITE !!,?($DATA(AMQQZNM)*5),"  You have not made a selection yet...Try again",!!

               QUIT 

 +2        SET %="The following have been selected =>"

 +3        WRITE !!,%,!

 +4        SET (%,X)=""

 +5        FOR I=1:1

               SET %=$ORDER(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,%))

               IF %=""

                   QUIT 

               WRITE !

               IF '(I#(IOSL-4))

                   DO LIST1

               IF X=U

                   QUIT 

               SET X=%

               Begin DoDot:1

 +6                IF $GET(AMQQTTX)=""

                       IF $DATA(AMQQTXTR)

                           XECUTE AMQQTXTR

                       WRITE ?5,X

                       QUIT 

 +7                IF $GET(AMQQTTX)]""

                       XECUTE AMQQTTX

                       WRITE ?5,X

               End DoDot:1

 +8        SET AMQQTTOT=AMQQTTOT+I

 +9        WRITE !!

 +10       QUIT 

 +11      ;

LIST1      WRITE "<>"

 +1        READ X:DTIME

 +2        WRITE $CHAR(13),?5,$CHAR(13)

 +3        QUIT 

 +4       ;

SET       ; ENTRY POINT FROM AMQQTX SUBROUTINES

 +1        SET Y=1

 +2        IF $DATA(AMQQTXEX)

               WRITE "  (DELETED)"

               KILL AMQQTXEX,^UTILITY("AMQQ TAX",$JOB,AMQQURGN,X)

               QUIT 

 +3        SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN,X)=""

 +4        IF AMQQTLOK="^PSDRUG("

               DO DCLASS

 +5        IF AMQQTLOK="^AUTTREFT("

               DO REFT

 +6        QUIT 

 +7       ;

DCLASS    ; Handles drug classes

 +1        NEW AMQQCLAS,I

 +2        IF $DATA(^PSDRUG(X,"ND"))

               SET AMQQCLAS=$PIECE(^("ND"),U,6)

               IF AMQQCLAS

 +3       IF '$TEST

               QUIT 

 +4        IF '$DATA(^UTILITY("AMQQ DRUG CLASS",$JOB,AMQQURGN,AMQQCLAS))

 +5       IF '$TEST

               QUIT 

 +6        WRITE !

 +7        SET DIR("A")="Do you want meds that are members of the same class as this medication"

 +8        SET DIR(0)="Y"

 +9        DO ^DIR

 +10       KILL DIR

 +11       WRITE !

 +12       IF Y=1

 +13      IF '$TEST

               QUIT 

 +14       SET ^UTILITY("AMQQ DRUG CLASS",$JOB,AMQQURGN,AMQQCLAS)=""

 +15       SET I=0

 +16       FOR 

               SET I=$ORDER(^PSDRUG("VAC",AMQQCLAS,I))

               IF 'I

                   QUIT 

               IF '$DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,I))

                   SET ^(I)=""

 +17       QUIT 

 +18      ;

NULL      ; ENTRY POINT FROM AMQQTX SUBROUTINES

 +1        NEW AMQQNNAM

 +2        SET AMQQNNAM=$SELECT($EXTRACT(AMQQCNAM,$LENGTH(AMQQCNAM))="S":$EXTRACT(AMQQCNAM,1,$LENGTH(AMQQCNAM)-1),1:AMQQCNAM)

 +3        IF $DATA(^UTILITY("AMQQ TAX",$JOB,AMQQURGN))

               GOTO N0

 +4        WRITE !,"Do you want me to find all ",AMQQNNAM,"S with no ",AMQQTNAR," entered"

 +5        SET %=1

 +6        DO YN^DICN

 +7        IF $DATA(DTOUT)

               SET %Y=U

 +8        IF $EXTRACT(%Y)=U

               SET AMQQQUIT=""

               KILL DTOUT,DUOUT

               QUIT 

 +9        IF "Yy"[$EXTRACT(%Y)

               SET AMQQSCMP="NULL"

               QUIT 

 +10       WRITE !,"Well then..."

N0         IF AMQQCTXS

               WRITE !,"I take it you want me to search for only those ",AMQQNNAM,"S who DO NOT have",!,"any ",AMQQTNAR,"S in this taxonomy"

               GOTO N1

 +1        WRITE !,"I take it you want me to find only those ",AMQQNNAM,"S whose",!,AMQQTNAR," is NOT in this taxonomy"

N1         SET %=1

 +1        DO YN^DICN

 +2        IF $DATA(DTOUT)

               SET %Y=U

 +3        IF $EXTRACT(%Y)=U

               SET AMQQQUIT=""

               QUIT 

 +4        IF %Y=""

               SET %Y="Y"

 +5        IF "yY"[$EXTRACT(%Y)

               SET AMQQSCMP="INVERSE"

 +6        WRITE !

 +7        QUIT 

 +8       ;

EN1       ; PROGRAMMER ENTRY POINT FOR TAXONOMY SYSTEM

 +1        NEW %,A,AMQQ,AMQQA,AMQQATN,AMQQB,AMQQCASE,AMQQCLAS,AMQQCNT,AMQQCOMP,AMQQCTXS,AMQQDF,AMQQDFN,AMQQDONE,AMQQECHO,AMQQHEL1,AMQQHELP,AMQQHILO,AMQQI,AMQQLINK,AMQQLKUP,AMQQLMOR,AMQQMULT,AMQQNDB,AMQQNDBC,AMQQNECO,AMQQNEXT,AMQQNNAM,AMQQNTAX

 +2        NEW AMQQONE,AMQQPOV1,AMQQPOV2,AMQQQUIT,AMQQR,AMQQSAVE,AMQQSCMP,AMQQSHNO,AMQQSQSJ,AMQQSSET,AMQQSTP,AMQQSUB,AMQQTAXI,AMQQTAXT,AMQQTDIC,AMQQTGBL,AMQQTGFG,AMQQTGNA,AMQQTGNO,AMQQTJMP,AMQQTLFL,AMQQTLOK,AMQQTNAR,AMQQTTOT,AMQQTTX,AMQQTXEX

 +3        IF '$DATA(APCLCRIT)

               NEW AMQQSQNM

 +4        NEW AMQQTXGR,AMQQTXTR,AMQQTYP,AMQQVAL,AMQQX,AMQQXX,AMQQXXN,AMQQXXTT,AMQQZNM,B,C,D,DA,DIADD,DIC,DIE,DIK,DINUM,DIPGM,DIR,DLAYGO,DR,DTOUT,DUOUT,DZ,I,N,T,Y,Z,ATXFLG,AMQQATNM

 +5        SET AMQQATN=X

 +6        SET %=^AMQQ(5,X,0)

 +7        SET AMQQTTX=$GET(^(3))

 +8        SET AMQQLINK=$PIECE(%,U,5)

 +9        SET AMQQTNAR=$PIECE(%,U,15)

 +10       SET AMQQTDIC=U_$PIECE(%,U,16)

 +11       SET AMQQTLOK=U_$PIECE(%,U,18)

 +12       SET AMQQATNM=$PIECE(%,U)

 +13       SET AMQQURGN=+$GET(AMQQURGN)

 +14       KILL ^UTILITY("AMQQ TAX",$JOB,AMQQURGN+1)

 +15       IF '$GET(IOSL)

               SET IOSL=24

 +16       DO AMQQTX

 +17       IF +$GET(AMQQTAX)

               IF '$DATA(^UTILITY("AMQQ TAX",$JOB,AMQQTAX))

                   KILL AMQQTAX

 +18       QUIT 

 +19      ;

REFT      ;FIND SPECFIC TYPE OF REFUSAL

 +1        WRITE !!

 +2        NEW REFT

 +3        SET REFT=X

 +4        NEW AMQQQUIT,X,Y

 +5        FOR 

               DO REFT1

               IF $DATA(AMQQQUIT)

                   QUIT 

 +6        WRITE !!

 +7        QUIT 

REFT1      NEW GLDA,GL,GLNAM

 +1        SET GLDA=$PIECE($GET(^AUTTREFT(REFT,0)),U,2)

 +2        SET GL=$GET(^DIC(+GLDA,0,"GL"))

 +3        SET GLNAM=$PIECE($GET(^DIC(+GLDA,0)),U)

 +4        SET GLN=$SELECT($EXTRACT(GL,$LENGTH(GL))="(":$EXTRACT(GL,1,$LENGTH(GL)-1),1:$EXTRACT(GL,1,$LENGTH(GL)-1)_")")

 +5        IF GL=""

               QUIT 

 +6        NEW DIC

 +7        SET DIC=GL

 +8        SET DIC(0)="AEMQZ"

 +9        SET DIC("A")="Select "_GLNAM_" refused: "

 +10       SET DIC("S")="I $D(^AUPNPREF(""AE"",+GLDA,+Y))"

 +11       DO ^DIC

 +12       IF Y<1

               SET AMQQQUIT=""

               QUIT 

 +13       SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN,REFT,"REFUSAL",+Y)=""

 +14       SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN)="REFUSAL"

 +15       QUIT