AMQQTX0 ; IHS/CMI/THL - SAVE OR RESTORE A TAXONOMY GROUP ;
;;2.0;IHS PCC SUITE;**11,13,14**;MAY 14, 2009;Build 12
;-----
NAME I $D(AMQQXX) G EXIT
S (%,X)=""
F S X=$O(^UTILITY("AMQQ TAX",$J,AMQQURGN,X)) Q:X="" S %=%+1 I %=2 Q
I %<2 G EXIT
W !!,"Want to save this ",AMQQTNAR," group for future use"
S %=2
D YN^DICN
S:$D(DTOUT) %Y=U
K DTOUT
I %=0 W !!,"This group will be saved as a taxonomy for future use when entered as a value",!,"using the ""[Name of Group"" syntax." G NAME
I $E(%Y)=U S AMQQQUIT="" G EXIT
I "nN"[$E(%Y) G EXIT
D RNAME
EXIT K X,AMQQTGNO,ATXFLG,%,%Y,A,B,I,N,T,Z
Q
;
RNAME R !,"Group name: ",X:DTIME E S X=U
I X=U S AMQQQUIT="" Q
I X="" Q
I X["(ST)" W !!,"The (ST) is Q-Man's designation for a ""Standard Taxonomy"".",!,"You may not create a standard taxonomy. Please select another name.",!,*7 G RNAME
S ATXFLG=""
S DIC="^ATXAX("
S DIC(0)="EQL"
S DLAYGO=9002226
D ^DIC
K DIC,DLAYGO
I Y=-1 G RNAME
I '$P(Y,U,3),DUZ'=$P(^ATXAX(+Y,0),U,5) W !!,X," already exists and cannot be overwritten except by its creator",!!,*7 G RNAME
I '$P(Y,U,3),$P(^ATXAX(+Y,0),U,22) W !!,X," is READ ONLY and cannot be overwritten",!!,*7 G RNAME
I '$P(Y,U,3) D OWRITE Q:$D(AMQQQUIT) I "Nn"[$E(%Y) G RNAME
S (AMQQTDFN,AMQQTGNO)=+Y
S DIE="^ATXAX("
S DA=AMQQTGNO
S DR=".05////"_DUZ_";.08////0;.09////"_DT_";.12////"_AMQQLINK_";.13////"_(AMQQTAXT=2)_";.15////"_+$P($G(@(AMQQTLOK_"0)")),U,2)_";1101;5101" D ^DIE
I AMQQTAXT=2 D RSTUFF G OEXIT
D STUFF
I $D(DTOUT) K DTOUT S AMQQQUIT="" Q
Q
;
OWRITE S AMQQTGNA=$P(Y,U,2),AMQQTGNO=+Y
W !!,X," already exists. Want to overwrite" S %=2 D YN^DICN
I $D(DTOUT) K DTOUT S %Y=U
I %Y=U S AMQQQUIT="" G OEXIT
I "Nn"[$E(%Y) G OEXIT
S DA=+Y
S DIK="^ATXAX("
D ^DIK
K DIK,DA
S ATXFLG=""
S DIC="^ATXAX("
S DIC(0)="L"
S DINUM=AMQQTGNO
S X=AMQQTGNA
S DIADD=1
S DIC("DR")=".01;.02;"
S DLAYGO=9002226
D ^DIC
S %Y="Y"
OEXIT K DIC,DIADD,AMQQTGNA,DLAYGO
Q
;
STUFF S X=""
F I=1:1 S X=$O(^UTILITY("AMQQ TAX",$J,AMQQURGN,X)) Q:X="" S ^ATXAX(AMQQTGNO,21,I,0)=X,^ATXAX(AMQQTGNO,21,"B",$E(X,1,30),I)="",^ATXAX(AMQQTGNO,21,"AA",X,X)=""
G ST1
RSTUFF S X=""
F I=1:1 S X=$O(@AMQQHILO@(X)) Q:X="" S S=$$SYS(X,$G(AMQQTGBL)),Y=$P(@AMQQHILO@(X),U,1),^ATXAX(AMQQTGNO,21,I,0)=X_U_Y_U_S,^ATXAX(AMQQTGNO,21,"AA",X,Y)="",^ATXAX(AMQQTGNO,21,"B",$E(X,1,30),I)=""
ST1 S I=I-1
S ^ATXAX(AMQQTGNO,21,0)="^9002226.02101^"_I_U_I
S DA=AMQQTGNO,DIK="^ATXAX(" D IX^DIK
K DA,DIK
K X,Y,Z,I
Q
SYS(C,G) ;EP GET SYSTEM FOR THIS CODE IF ICD9, ICD0
I G'="^ICD9",G'="^ICD0" Q ""
S C=$$STRIP^XLFSTR(C," ")
NEW T
I G="^ICD9" S T=$P($$ICDDX^ICDEX(C,DT),U,20) Q $S(T>0:T,1:"")
I G="^ICD0" S T=$P($$ICDOP^ICDEX(C,DT,,"E"),U,15) Q $S(T>0:T,1:"")
Q ""
;
RESTORE ; ENTRY POINT FROM AMQQTX SUBROUTINES
N AMQQTGNO,AMQQTGIT
S X=$E(X,2,99)
S AMQQB=($E(X,$L(X))="]")
I AMQQB S X=$E(X,1,$L(X)-1)
S DIC("S")="I $P(^(0),U,12)=AMQQLINK"
S DIC="^ATXAX("
S DIC(0)="EQ"
I $D(AMQQNECO)!$D(AMQQDF) S DIC(0)=$S($D(AMQQECHO):"MQEZ",$D(AMQQDF):"MO",1:"")
E I $D(AMQQXX) S DIC(0)="EQS"
D ^DIC
K DIC
I Y=-1 Q
I Y'=-1,'AMQQB,'$D(AMQQDF) W "]"
REST ;EP;TO RESTORE VALUES FROM A TAXONOMY
Q:$G(Y)<1
Q:'$D(^ATXAX(+Y,0)) S AMQQTAXN=$P(^(0),U)_U_+Y
K AMQQSHNO,AMQQB S AMQQTGIT="" I AMQQTAXT'=2 D
.I AMQQLINK=302 S AMQQTGIT="S X=$P(^AUTTHF(X,0),U)"
.E I $D(^AMQQ(1,AMQQLINK,4,1,1)) S AMQQTGIT=^(1)
I AMQQTAXT=2 D RES1 I 1
E S AMQQTGNO="" F S AMQQTGNO=$O(^ATXAX(+Y,21,"AA",AMQQTGNO)) Q:AMQQTGNO="" S ^UTILITY("AMQQ TAX",$J,AMQQURGN,AMQQTGNO)="" I '$D(AMQQXX),'$D(AMQQDF) D SHOW
K AMQQTJMP
I '$D(AMQQDF) W:'$D(ZTQUEUED) !! K AMQQSHNO,Z,T
S AMQQTGFG=""
Q
;
SHOW Q:$D(AMQQSHOW)
I '$D(AMQQSHNO) S AMQQSHNO=0 W !!,"Members of ",X," Taxonomy =>",!
N %,X,Z
S Z=AMQQTGNO
I $D(AMQQTJMP) W "." Q
I AMQQTAXT'=2 S X=AMQQTGNO X AMQQTGIT S Z=X
W !
S AMQQSHNO=AMQQSHNO+1
I AMQQSHNO>1,AMQQSHNO#(IOSL-4)=1 D Q:$D(AMQQTJMP)
.R "<>",%:DTIME
.I $E(%)=U W !,"OK" S AMQQTJMP="" Q
W $P(Z,U,1) ;,?20,$P(^ICDS(+$P(Z,U,2),0),U,1)
Q
;
RES1 S %=""
F S %=$O(^ATXAX(+Y,21,"AA",%)) Q:%="" S A=$O(^(%,"")) D RES2
K A,B,AMQQTGNO,N
Q
;
RES2 S AMQQTGNO=%
S @AMQQHILO@(%)=A
I %'=A S AMQQTGNO=%_"- "_A
S B=$O(@AMQQTGBL@("BA",%,""))
I B S ^UTILITY("AMQQ TAX",$J,AMQQURGN,+B)="" I '$D(AMQQXX),'$D(AMQQDF) D SHOW
;K AMQQTJMP
S N=%
F S N=$O(@AMQQTGBL@("BA",N)) Q:N="" Q:N]A S B=$O(^(N,"")) I B S ^UTILITY("AMQQ TAX",$J,AMQQURGN,B)=""
Q
;
AMQQTX0 ; IHS/CMI/THL - SAVE OR RESTORE A TAXONOMY GROUP ;
+1 ;;2.0;IHS PCC SUITE;**11,13,14**;MAY 14, 2009;Build 12
+2 ;-----
NAME IF $DATA(AMQQXX)
GOTO EXIT
+1 SET (%,X)=""
+2 FOR
SET X=$ORDER(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,X))
IF X=""
QUIT
SET %=%+1
IF %=2
QUIT
+3 IF %<2
GOTO EXIT
+4 WRITE !!,"Want to save this ",AMQQTNAR," group for future use"
+5 SET %=2
+6 DO YN^DICN
+7 IF $DATA(DTOUT)
SET %Y=U
+8 KILL DTOUT
+9 IF %=0
WRITE !!,"This group will be saved as a taxonomy for future use when entered as a value",!,"using the ""[Name of Group"" syntax."
GOTO NAME
+10 IF $EXTRACT(%Y)=U
SET AMQQQUIT=""
GOTO EXIT
+11 IF "nN"[$EXTRACT(%Y)
GOTO EXIT
+12 DO RNAME
EXIT KILL X,AMQQTGNO,ATXFLG,%,%Y,A,B,I,N,T,Z
+1 QUIT
+2 ;
RNAME READ !,"Group name: ",X:DTIME
IF '$TEST
SET X=U
+1 IF X=U
SET AMQQQUIT=""
QUIT
+2 IF X=""
QUIT
+3 IF X["(ST)"
WRITE !!,"The (ST) is Q-Man's designation for a ""Standard Taxonomy"".",!,"You may not create a standard taxonomy. Please select another name.",!,*7
GOTO RNAME
+4 SET ATXFLG=""
+5 SET DIC="^ATXAX("
+6 SET DIC(0)="EQL"
+7 SET DLAYGO=9002226
+8 DO ^DIC
+9 KILL DIC,DLAYGO
+10 IF Y=-1
GOTO RNAME
+11 IF '$PIECE(Y,U,3)
IF DUZ'=$PIECE(^ATXAX(+Y,0),U,5)
WRITE !!,X," already exists and cannot be overwritten except by its creator",!!,*7
GOTO RNAME
+12 IF '$PIECE(Y,U,3)
IF $PIECE(^ATXAX(+Y,0),U,22)
WRITE !!,X," is READ ONLY and cannot be overwritten",!!,*7
GOTO RNAME
+13 IF '$PIECE(Y,U,3)
DO OWRITE
IF $DATA(AMQQQUIT)
QUIT
IF "Nn"[$EXTRACT(%Y)
GOTO RNAME
+14 SET (AMQQTDFN,AMQQTGNO)=+Y
+15 SET DIE="^ATXAX("
+16 SET DA=AMQQTGNO
+17 SET DR=".05////"_DUZ_";.08////0;.09////"_DT_";.12////"_AMQQLINK_";.13////"_(AMQQTAXT=2)_";.15////"_+$PIECE($GET(@(AMQQTLOK_"0)")),U,2)_";1101;5101"
DO ^DIE
+18 IF AMQQTAXT=2
DO RSTUFF
GOTO OEXIT
+19 DO STUFF
+20 IF $DATA(DTOUT)
KILL DTOUT
SET AMQQQUIT=""
QUIT
+21 QUIT
+22 ;
OWRITE SET AMQQTGNA=$PIECE(Y,U,2)
SET AMQQTGNO=+Y
+1 WRITE !!,X," already exists. Want to overwrite"
SET %=2
DO YN^DICN
+2 IF $DATA(DTOUT)
KILL DTOUT
SET %Y=U
+3 IF %Y=U
SET AMQQQUIT=""
GOTO OEXIT
+4 IF "Nn"[$EXTRACT(%Y)
GOTO OEXIT
+5 SET DA=+Y
+6 SET DIK="^ATXAX("
+7 DO ^DIK
+8 KILL DIK,DA
+9 SET ATXFLG=""
+10 SET DIC="^ATXAX("
+11 SET DIC(0)="L"
+12 SET DINUM=AMQQTGNO
+13 SET X=AMQQTGNA
+14 SET DIADD=1
+15 SET DIC("DR")=".01;.02;"
+16 SET DLAYGO=9002226
+17 DO ^DIC
+18 SET %Y="Y"
OEXIT KILL DIC,DIADD,AMQQTGNA,DLAYGO
+1 QUIT
+2 ;
STUFF SET X=""
+1 FOR I=1:1
SET X=$ORDER(^UTILITY("AMQQ TAX",$JOB,AMQQURGN,X))
IF X=""
QUIT
SET ^ATXAX(AMQQTGNO,21,I,0)=X
SET ^ATXAX(AMQQTGNO,21,"B",$EXTRACT(X,1,30),I)=""
SET ^ATXAX(AMQQTGNO,21,"AA",X,X)=""
+2 GOTO ST1
RSTUFF SET X=""
+1 FOR I=1:1
SET X=$ORDER(@AMQQHILO@(X))
IF X=""
QUIT
SET S=$$SYS(X,$GET(AMQQTGBL))
SET Y=$PIECE(@AMQQHILO@(X),U,1)
SET ^ATXAX(AMQQTGNO,21,I,0)=X_U_Y_U_S
SET ^ATXAX(AMQQTGNO,21,"AA",X,Y)=""
SET ^ATXAX(AMQQTGNO,21,"B",$EXTRACT(X,1,30),I)=""
ST1 SET I=I-1
+1 SET ^ATXAX(AMQQTGNO,21,0)="^9002226.02101^"_I_U_I
+2 SET DA=AMQQTGNO
SET DIK="^ATXAX("
DO IX^DIK
+3 KILL DA,DIK
+4 KILL X,Y,Z,I
+5 QUIT
SYS(C,G) ;EP GET SYSTEM FOR THIS CODE IF ICD9, ICD0
+1 IF G'="^ICD9"
IF G'="^ICD0"
QUIT ""
+2 SET C=$$STRIP^XLFSTR(C," ")
+3 NEW T
+4 IF G="^ICD9"
SET T=$PIECE($$ICDDX^ICDEX(C,DT),U,20)
QUIT $SELECT(T>0:T,1:"")
+5 IF G="^ICD0"
SET T=$PIECE($$ICDOP^ICDEX(C,DT,,"E"),U,15)
QUIT $SELECT(T>0:T,1:"")
+6 QUIT ""
+7 ;
RESTORE ; ENTRY POINT FROM AMQQTX SUBROUTINES
+1 NEW AMQQTGNO,AMQQTGIT
+2 SET X=$EXTRACT(X,2,99)
+3 SET AMQQB=($EXTRACT(X,$LENGTH(X))="]")
+4 IF AMQQB
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+5 SET DIC("S")="I $P(^(0),U,12)=AMQQLINK"
+6 SET DIC="^ATXAX("
+7 SET DIC(0)="EQ"
+8 IF $DATA(AMQQNECO)!$DATA(AMQQDF)
SET DIC(0)=$SELECT($DATA(AMQQECHO):"MQEZ",$DATA(AMQQDF):"MO",1:"")
+9 IF '$TEST
IF $DATA(AMQQXX)
SET DIC(0)="EQS"
+10 DO ^DIC
+11 KILL DIC
+12 IF Y=-1
QUIT
+13 IF Y'=-1
IF 'AMQQB
IF '$DATA(AMQQDF)
WRITE "]"
REST ;EP;TO RESTORE VALUES FROM A TAXONOMY
+1 IF $GET(Y)<1
QUIT
+2 IF '$DATA(^ATXAX(+Y,0))
QUIT
SET AMQQTAXN=$PIECE(^(0),U)_U_+Y
+3 KILL AMQQSHNO,AMQQB
SET AMQQTGIT=""
IF AMQQTAXT'=2
Begin DoDot:1
+4 IF AMQQLINK=302
SET AMQQTGIT="S X=$P(^AUTTHF(X,0),U)"
+5 IF '$TEST
IF $DATA(^AMQQ(1,AMQQLINK,4,1,1))
SET AMQQTGIT=^(1)
End DoDot:1
+6 IF AMQQTAXT=2
DO RES1
IF 1
+7 IF '$TEST
SET AMQQTGNO=""
FOR
SET AMQQTGNO=$ORDER(^ATXAX(+Y,21,"AA",AMQQTGNO))
IF AMQQTGNO=""
QUIT
SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN,AMQQTGNO)=""
IF '$DATA(AMQQXX)
IF '$DATA(AMQQDF)
DO SHOW
+8 KILL AMQQTJMP
+9 IF '$DATA(AMQQDF)
IF '$DATA(ZTQUEUED)
WRITE !!
KILL AMQQSHNO,Z,T
+10 SET AMQQTGFG=""
+11 QUIT
+12 ;
SHOW IF $DATA(AMQQSHOW)
QUIT
+1 IF '$DATA(AMQQSHNO)
SET AMQQSHNO=0
WRITE !!,"Members of ",X," Taxonomy =>",!
+2 NEW %,X,Z
+3 SET Z=AMQQTGNO
+4 IF $DATA(AMQQTJMP)
WRITE "."
QUIT
+5 IF AMQQTAXT'=2
SET X=AMQQTGNO
XECUTE AMQQTGIT
SET Z=X
+6 WRITE !
+7 SET AMQQSHNO=AMQQSHNO+1
+8 IF AMQQSHNO>1
IF AMQQSHNO#(IOSL-4)=1
Begin DoDot:1
+9 READ "<>",%:DTIME
+10 IF $EXTRACT(%)=U
WRITE !,"OK"
SET AMQQTJMP=""
QUIT
End DoDot:1
IF $DATA(AMQQTJMP)
QUIT
+11 ;,?20,$P(^ICDS(+$P(Z,U,2),0),U,1)
WRITE $PIECE(Z,U,1)
+12 QUIT
+13 ;
RES1 SET %=""
+1 FOR
SET %=$ORDER(^ATXAX(+Y,21,"AA",%))
IF %=""
QUIT
SET A=$ORDER(^(%,""))
DO RES2
+2 KILL A,B,AMQQTGNO,N
+3 QUIT
+4 ;
RES2 SET AMQQTGNO=%
+1 SET @AMQQHILO@(%)=A
+2 IF %'=A
SET AMQQTGNO=%_"- "_A
+3 SET B=$ORDER(@AMQQTGBL@("BA",%,""))
+4 IF B
SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN,+B)=""
IF '$DATA(AMQQXX)
IF '$DATA(AMQQDF)
DO SHOW
+5 ;K AMQQTJMP
+6 SET N=%
+7 FOR
SET N=$ORDER(@AMQQTGBL@("BA",N))
IF N=""
QUIT
IF N]A
QUIT
SET B=$ORDER(^(N,""))
IF B
SET ^UTILITY("AMQQ TAX",$JOB,AMQQURGN,B)=""
+8 QUIT
+9 ;
