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
