Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMQQTX0

AMQQTX0.m

Go to the documentation of this file. 
  1. AMQQTX0 ; IHS/CMI/THL - SAVE OR RESTORE A TAXONOMY GROUP ;
  1.  ;;2.0;IHS PCC SUITE;**11,13,14**;MAY 14, 2009;Build 12
  1.  ;-----
  1. NAME I $D(AMQQXX) G EXIT
  1.  S (%,X)=""
  1.  F  S X=$O(^UTILITY("AMQQ TAX",$J,AMQQURGN,X)) Q:X=""  S %=%+1 I %=2 Q
  1.  I %<2 G EXIT
  1.  W !!,"Want to save this ",AMQQTNAR," group for future use"
  1.  S %=2
  1.  D YN^DICN
  1.  S:$D(DTOUT) %Y=U
  1.  K DTOUT
  1.  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
  1.  I $E(%Y)=U S AMQQQUIT="" G EXIT
  1.  I "nN"[$E(%Y) G EXIT
  1.  D RNAME
  1. EXIT K X,AMQQTGNO,ATXFLG,%,%Y,A,B,I,N,T,Z
  1.  Q
  1.  ;
  1. RNAME R !,"Group name: ",X:DTIME E  S X=U
  1.  I X=U S AMQQQUIT="" Q
  1.  I X="" Q
  1.  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
  1.  S ATXFLG=""
  1.  S DIC="^ATXAX("
  1.  S DIC(0)="EQL"
  1.  S DLAYGO=9002226
  1.  D ^DIC
  1.  K DIC,DLAYGO
  1.  I Y=-1 G RNAME
  1.  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
  1.  I '$P(Y,U,3),$P(^ATXAX(+Y,0),U,22) W !!,X," is READ ONLY and cannot be overwritten",!!,*7 G RNAME
  1.  I '$P(Y,U,3) D OWRITE Q:$D(AMQQQUIT)  I "Nn"[$E(%Y) G RNAME
  1.  S (AMQQTDFN,AMQQTGNO)=+Y
  1.  S DIE="^ATXAX("
  1.  S DA=AMQQTGNO
  1.  S DR=".05////"_DUZ_";.08////0;.09////"_DT_";.12////"_AMQQLINK_";.13////"_(AMQQTAXT=2)_";.15////"_+$P($G(@(AMQQTLOK_"0)")),U,2)_";1101;5101" D ^DIE
  1.  I AMQQTAXT=2 D RSTUFF G OEXIT
  1.  D STUFF
  1.  I $D(DTOUT) K DTOUT S AMQQQUIT="" Q
  1.  Q
  1.  ;
  1. OWRITE S AMQQTGNA=$P(Y,U,2),AMQQTGNO=+Y
  1.  W !!,X," already exists.  Want to overwrite" S %=2 D YN^DICN
  1.  I $D(DTOUT) K DTOUT S %Y=U
  1.  I %Y=U S AMQQQUIT="" G OEXIT
  1.  I "Nn"[$E(%Y) G OEXIT
  1.  S DA=+Y
  1.  S DIK="^ATXAX("
  1.  D ^DIK
  1.  K DIK,DA
  1.  S ATXFLG=""
  1.  S DIC="^ATXAX("
  1.  S DIC(0)="L"
  1.  S DINUM=AMQQTGNO
  1.  S X=AMQQTGNA
  1.  S DIADD=1
  1.  S DIC("DR")=".01;.02;"
  1.  S DLAYGO=9002226
  1.  D ^DIC
  1.  S %Y="Y"
  1. OEXIT K DIC,DIADD,AMQQTGNA,DLAYGO
  1.  Q
  1.  ;
  1. STUFF S X=""
  1.  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)=""
  1.  G ST1
  1. RSTUFF S X=""
  1.  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)=""
  1. ST1 S I=I-1
  1.  S ^ATXAX(AMQQTGNO,21,0)="^9002226.02101^"_I_U_I
  1.  S DA=AMQQTGNO,DIK="^ATXAX(" D IX^DIK
  1.  K DA,DIK
  1.  K X,Y,Z,I
  1.  Q
  1. SYS(C,G) ;EP GET SYSTEM FOR THIS CODE IF ICD9, ICD0
  1.  I G'="^ICD9",G'="^ICD0" Q ""
  1.  S C=$$STRIP^XLFSTR(C," ")
  1.  NEW T
  1.  I G="^ICD9" S T=$P($$ICDDX^ICDEX(C,DT),U,20) Q $S(T>0:T,1:"")
  1.  I G="^ICD0" S T=$P($$ICDOP^ICDEX(C,DT,,"E"),U,15) Q $S(T>0:T,1:"")
  1.  Q ""
  1.  ;
  1. RESTORE ; ENTRY POINT FROM AMQQTX SUBROUTINES
  1.  N AMQQTGNO,AMQQTGIT
  1.  S X=$E(X,2,99)
  1.  S AMQQB=($E(X,$L(X))="]")
  1.  I AMQQB S X=$E(X,1,$L(X)-1)
  1.  S DIC("S")="I $P(^(0),U,12)=AMQQLINK"
  1.  S DIC="^ATXAX("
  1.  S DIC(0)="EQ"
  1.  I $D(AMQQNECO)!$D(AMQQDF) S DIC(0)=$S($D(AMQQECHO):"MQEZ",$D(AMQQDF):"MO",1:"")
  1.  E  I $D(AMQQXX) S DIC(0)="EQS"
  1.  D ^DIC
  1.  K DIC
  1.  I Y=-1 Q
  1.  I Y'=-1,'AMQQB,'$D(AMQQDF) W "]"
  1. REST ;EP;TO RESTORE VALUES FROM A TAXONOMY
  1.  Q:$G(Y)<1
  1.  Q:'$D(^ATXAX(+Y,0))  S AMQQTAXN=$P(^(0),U)_U_+Y
  1.  K AMQQSHNO,AMQQB S AMQQTGIT="" I AMQQTAXT'=2 D
  1.  .I AMQQLINK=302 S AMQQTGIT="S X=$P(^AUTTHF(X,0),U)"
  1.  .E  I $D(^AMQQ(1,AMQQLINK,4,1,1)) S AMQQTGIT=^(1)
  1.  I AMQQTAXT=2 D RES1 I 1
  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
  1.  K AMQQTJMP
  1.  I '$D(AMQQDF) W:'$D(ZTQUEUED) !! K AMQQSHNO,Z,T
  1.  S AMQQTGFG=""
  1.  Q
  1.  ;
  1. SHOW Q:$D(AMQQSHOW)
  1.  I '$D(AMQQSHNO) S AMQQSHNO=0 W !!,"Members of ",X," Taxonomy =>",!
  1.  N %,X,Z
  1.  S Z=AMQQTGNO
  1.  I $D(AMQQTJMP) W "." Q
  1.  I AMQQTAXT'=2 S X=AMQQTGNO X AMQQTGIT S Z=X
  1.  W !
  1.  S AMQQSHNO=AMQQSHNO+1
  1.  I AMQQSHNO>1,AMQQSHNO#(IOSL-4)=1 D  Q:$D(AMQQTJMP)
  1.  .R "<>",%:DTIME
  1.  .I $E(%)=U W !,"OK" S AMQQTJMP="" Q
  1.  W $P(Z,U,1)  ;,?20,$P(^ICDS(+$P(Z,U,2),0),U,1)
  1.  Q
  1.  ;
  1. RES1 S %=""
  1.  F  S %=$O(^ATXAX(+Y,21,"AA",%)) Q:%=""  S A=$O(^(%,"")) D RES2
  1.  K A,B,AMQQTGNO,N
  1.  Q
  1.  ;
  1. RES2 S AMQQTGNO=%
  1.  S @AMQQHILO@(%)=A
  1.  I %'=A S AMQQTGNO=%_"- "_A
  1.  S B=$O(@AMQQTGBL@("BA",%,""))
  1.  I B S ^UTILITY("AMQQ TAX",$J,AMQQURGN,+B)="" I '$D(AMQQXX),'$D(AMQQDF) D SHOW
  1.  ;K AMQQTJMP
  1.  S N=%
  1.  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)=""
  1.  Q
  1.  ;