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

LEXLK2.m

Go to the documentation of this file. 
  1. LEXLK2 ;ISL/KER - Look Up - Expression Attributes ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**6,19,80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^LEX(757.13)        N/A
  1.  ;               
  1.  ; External References
  1.  ;    ^DIR                ICR  10026
  1.  ;               
  1. GET(Y) ; Build list in array LEX
  1.  N LEXSPC,LEXSPCR,LEXSTR,LEXDIS,LEXMC,LEXMCE,LEXEXP
  1.  S $E(LEXSPC,42)=" "
  1.  K LEX
  1.  ; PCH 6  add MD and CLC
  1.  D MC,SY,LV,MD,DEF,STY,CLC,SRC
  1.  K LEXC,LEXCODE,LEXCT,LEXDEF,LEXDIS,LEXEXP,LEXF
  1.  K LEXFORM,LEXMC,LEXMCE,LEXNOM,LEXSCP,LEXSO,LEXSPC,LEXSPCR
  1.  K LEXSR,LEXSRC,LEXSTR
  1.  Q
  1. MC ;    Major Concept
  1.  N LEXMEX
  1.  S LEXMC=+^LEX(757.01,+Y,1)
  1.  S LEXMCE=+Y
  1.  S LEXMEX=+^LEX(757,LEXMC,0)
  1.  D BL,BL
  1.  S LEXSTR="TERMS:" D TL,BL
  1.  S LEXSTR="  Concept:  "_$E(^LEX(757.01,LEXMEX,0),1,66) D TL
  1.  S LEXDIS=$$T(+Y) S LEXSTR="            "_LEXDIS D TL
  1.  Q
  1. SY ;    Synonyms
  1.  N LEXEXP
  1.  S LEXEXP=0
  1.  F  S LEXEXP=$O(^LEX(757.01,"AMC",+LEXMC,LEXEXP)) Q:+LEXEXP=0  D
  1.  .I $P(^LEX(757.01,LEXEXP,1),U,2)=2 D
  1.  ..S LEXDIS=$$T(LEXEXP) D BL
  1.  ..S LEXSTR="  Synonym:  "_$E(^LEX(757.01,LEXEXP,0),1,66) D TL
  1.  ..S LEXSTR="            "_LEXDIS D TL
  1.  Q
  1. LV ;    Lexical Variants
  1.  N LEXEXP
  1.  S LEXEXP=0
  1.  F  S LEXEXP=$O(^LEX(757.01,"AMC",+LEXMC,LEXEXP)) Q:+LEXEXP=0  D
  1.  .I $P(^LEX(757.01,LEXEXP,1),U,2)=3 D
  1.  ..S LEXDIS=$$T(LEXEXP) D BL
  1.  ..S LEXSTR="  Variant:  "_$E(^LEX(757.01,LEXEXP,0),1,66) D TL
  1.  ..S LEXSTR="            "_LEXDIS D TL
  1.  Q
  1. MD ;    Modifiers/Descendants    PCH 6  added
  1.  Q:'$D(^LEX(757.01,"APAR",LEXMCE))
  1.  D BL
  1.  N LEXCHD,LEXORD,LEXSTR,LEXNO,LEXE,LEXCT,LEXTY,LEXL
  1.  S (LEXCHD,LEXCT)=0
  1.  S LEXSTR="  Modified/Descendant Terms" D TL,BL
  1.  F  S LEXCHD=$O(^LEX(757.01,"APAR",LEXMCE,LEXCHD)) Q:+LEXCHD=0  D
  1.  .S LEXE=$P($G(^LEX(757.01,LEXCHD,0)),"^") Q:'$L(LEXE)
  1.  .S LEXTY=+$P($G(^LEX(757.01,LEXCHD,1)),"^",2) Q:LEXTY=0
  1.  .S LEXCT=LEXCT+1
  1.  .S LEXORD=+$P($G(^LEX(757.01,LEXCHD,1)),"^",10)
  1.  .S LEXNO=$S(LEXORD>0:LEXORD,1:(9999+LEXCT))
  1.  .S LEXL(LEXTY,LEXNO)=LEXE
  1.  S LEXTY=0 F  S LEXTY=$O(LEXL(LEXTY)) Q:+LEXTY=0  D
  1.  .S LEXNO=0 F  S LEXNO=$O(LEXL(LEXTY,LEXNO)) Q:+LEXNO=0  D
  1.  ..S LEXSTR="            "_LEXL(LEXTY,LEXNO) D TL
  1.  Q
  1. DEF ;    Definition
  1.  D BL
  1.  I $D(^LEX(757.01,+Y,3)) D  D BL
  1.  .S LEXSTR="DEFINITION:" D TL,BL
  1.  .N LEXDEF S LEXDEF=0
  1.  .F  S LEXDEF=$O(^LEX(757.01,+Y,3,LEXDEF)) Q:+LEXDEF=0  D
  1.  ..S LEXSTR="  "_^LEX(757.01,+Y,3,LEXDEF,0) D TL
  1.  Q
  1. STY ;    Semantic Classes/Types
  1.  S LEXSTR="SEMANTICS:" D TL,BL
  1.  S LEXSTR="  CLASS                                 TYPE" D TL,BL
  1.  N LEXC,LEXT,LEXCT,LEXTT S LEXC="",LEXT=0
  1.  F  S LEXC=$O(^LEX(757.1,"AMCC",LEXMC,LEXC)) Q:LEXC=""  D
  1.  .S LEXCT=$E($P(^LEX(757.11,+$O(^LEX(757.11,"B",LEXC,0)),0),U,2),1,38)
  1.  .S LEXSTR="  "_LEXCT
  1.  .S LEXT=0
  1.  .F  S LEXT=$O(^LEX(757.1,"AMCC",LEXMC,LEXC,LEXT)) Q:+LEXT=0  D
  1.  ..S LEXTT=$E($P(^LEX(757.12,+$P(^LEX(757.1,LEXT,0),U,3),0),U,2),1,38)
  1.  ..S LEXSPCR=$E(LEXSPC,1,(40-$L(LEXSTR)))
  1.  ..S LEXSTR=LEXSTR_LEXSPCR_LEXTT D TL S LEXSTR=""
  1.  Q
  1. CLC ;    Clinical Class   PCH 6  added
  1.  N LEXCL,LEXGP,LEXSTR,LEXFM,LEXIND,LEXP,LEXMEM,LEXT,LEXTC
  1.  S LEXCL=+$P($G(^LEX(757.01,+Y,1)),"^",11)
  1.  S:LEXCL=0 LEXCL=+$P($G(^LEX(757.01,LEXMCE,1)),"^",11)
  1.  Q:LEXCL=0  Q:'$D(^LEX(757.13,LEXCL,0))
  1.  S LEXGP=$G(^LEX(757.13,LEXCL,5)) Q:'$L(LEXGP)
  1.  D BL
  1.  S LEXSTR="SOURCE CATEGORY:  "_LEXGP D TL,BL
  1.  S LEXFM=$P($G(^LEX(757.13,LEXCL,3)),"^") Q:'$L(LEXFM)
  1.  S LEXIND="  "
  1.  F LEXP=1:1:$L(LEXFM,"~") D
  1.  .S LEXMEM=+$P(LEXFM,"~",LEXP) Q:LEXMEM=0  Q:'$D(^LEX(757.13,LEXMEM,0))
  1.  .S LEXT=$P($G(^LEX(757.13,LEXMEM,0)),"^") Q:LEXT=""
  1.  .S LEXTC=$P($G(^LEX(757.13,LEXMEM,0)),"^",2)
  1.  .S LEXIND=LEXIND_"  "
  1.  .S LEXSTR=LEXIND_LEXT D TL
  1.  Q
  1. SRC ;    Classification Systems/Codes
  1.  N LEXSR,LEXSO,LEXSPC
  1.  K LEXSRC
  1.  S LEXSO=0
  1.  F  S LEXSO=$O(^LEX(757.02,"AMC",LEXMC,LEXSO)) Q:+LEXSO=0  D
  1.  .Q:$P(^LEX(757.02,LEXSO,0),"^",6)=1
  1.  .S LEXNOM=$P(^LEX(757.03,+$P(^LEX(757.02,LEXSO,0),U,3),0),U,2)
  1.  .S LEXSR=$P(^LEX(757.03,+$P(^LEX(757.02,LEXSO,0),U,3),0),U,3)
  1.  .S $E(LEXSPC,16)=" "
  1.  .S LEXSPC=$E(LEXSPC,1,$L(LEXSPC)-$L(LEXNOM))
  1.  .S LEXSR=LEXNOM_LEXSPC_LEXSR
  1.  .S LEXCODE=$P(^LEX(757.02,LEXSO,0),U,2)
  1.  .S LEXSRC(LEXSR,LEXCODE)=""
  1.  I $D(LEXSRC) D  K LEXSRC
  1.  .D BL S LEXSTR="CLASSIFICATION SYSTEMS/CODES:" D TL,BL
  1.  .S LEXSR=""
  1.  .F  S LEXSR=$O(LEXSRC(LEXSR)) Q:LEXSR=""  D
  1.  ..D BL S LEXSTR="  "_LEXSR D TL
  1.  ..S (LEXSTR,LEXCODE)=""
  1.  ..F  S LEXCODE=$O(LEXSRC(LEXSR,LEXCODE)) Q:LEXCODE=""  D
  1.  ...S LEXSTR=LEXSTR_"/"_LEXCODE
  1.  ..S:$E(LEXSTR)="/" LEXSTR=$E(LEXSTR,2,$L(LEXSTR))
  1.  ..S LEXSTR="                  "_LEXSTR
  1.  ..D:$L(LEXSTR)>18 TL
  1.  Q
  1. T(X) ; Get Term Type
  1.  N LEXSCP,LEXF
  1.  S LEXF="",LEXFORM="",LEXEXP=+X,X=""
  1.  S LEXSCP=$P(^LEX(757.01,LEXEXP,1),U,3)
  1.  S LEXSCP=$S(LEXSCP="D":"Directly Linked to Concept",LEXSCP="I":"Indirectly Linked (via Synonym)",LEXSCP="B":"Broader View of Concept",LEXSCP="N":"Narrower View of Concept",LEXSCP="O":"Other View of Concept",1:"")
  1.  S LEXF=$P(^LEX(757.01,LEXEXP,1),U,4) S:+LEXF=0 LEXF=""
  1.  S:+LEXF>0 LEXF=$P($G(^LEX(757.014,+LEXF,0)),U,2)
  1.  S X=LEXSCP_"/"_LEXF S:$P(X,"/",2)="" X=$P(X,"/",1)
  1.  S:$E(X)="/" X=$E(X,2,$L(X))
  1.  K LEXSCP,LEXF
  1.  Q X
  1. TL ; Create a Text Line
  1.  Q:'$L($G(LEXSTR))
  1.  N LEXC
  1.  S LEXC=+$G(LEX(0)),LEXC=LEXC+1
  1.  S LEX(LEXC)=LEXSTR
  1.  S LEX(0)=LEXC
  1.  Q
  1. BL ; Create a Blank Line
  1.  N LEXC
  1.  S LEXC=+$G(LEX(0)),LEXC=LEXC+1
  1.  S LEX(LEXC)="",LEX(0)=LEXC
  1.  Q
  1. LIST ; List the contents of the LEX array
  1.  Q:'$G(LEX(0))  N LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
  1.  S (LEXLN,LEXLC)=0,LEXCONT=""
  1.  F  Q:LEXLN=LEX(0)!(LEXCONT["^")  D  Q:LEXLN=LEX(0)!(LEXCONT["^")
  1.  .S LEXB=LEXLN+1,LEXE=LEXB+(IOSL-3)
  1.  .F LEXCL=LEXB:1:LEXE D
  1.  ..I $D(LEX(LEXCL)) W !,LEX(LEXCL) S LEXLN=LEXCL,LEXLC=LEXLC+1
  1.  .I LEXLN'=LEX(0) D CONT Q
  1.  W !
  1.  S LEXLC=LEXLC+1
  1.  I LEXLC=(IOSL-3) D CONT
  1.  K LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
  1.  Q
  1. CONT ; Continue listing - Press <Return> to Continue
  1.  W ! N X,Y S DIR(0)="E" D ^DIR S LEXLC=0,LEXCONT=X
  1.  K DIR,DTOUT,DUOUT,DIRUT,DIROUT W !
  1.  Q