source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXLK2.m@ 1458

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