source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXLK2.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.4 KB
RevLine 
[613]1LEXLK2 ;ISL/FJF-Look Up - Expression Attributes ;09-10-01
2 ;;2.0;LEXICON UTILITY;**6,19**;Sep 23, 1996;Build 1
3 ;
4GET(Y) ; Build list in array LEX
5 N LEXSPC,LEXSPCR,LEXSTR,LEXDIS,LEXMC,LEXMCE,LEXEXP
6 S $E(LEXSPC,42)=" "
7 K LEX
8 ; PCH 6 add MD and CLC
9 D MC,SY,LV,MD,DEF,STY,CLC,SRC
10 K LEXC,LEXCODE,LEXCT,LEXDEF,LEXDIS,LEXEXP,LEXF
11 K LEXFORM,LEXMC,LEXMCE,LEXNOM,LEXSCP,LEXSO,LEXSPC,LEXSPCR
12 K LEXSR,LEXSRC,LEXSTR
13 Q
14MC ; Major Concept
15 N LEXMEX
16 S LEXMC=+^LEX(757.01,+Y,1)
17 S LEXMCE=+Y
18 S LEXMEX=+^LEX(757,LEXMC,0)
19 D BL,BL
20 S LEXSTR="TERMS:" D TL,BL
21 S LEXSTR=" Concept: "_$E(^LEX(757.01,LEXMEX,0),1,66) D TL
22 S LEXDIS=$$T(+Y) S LEXSTR=" "_LEXDIS D TL
23 Q
24SY ; Synonyms
25 N LEXEXP
26 S LEXEXP=0
27 F S LEXEXP=$O(^LEX(757.01,"AMC",+LEXMC,LEXEXP)) Q:+LEXEXP=0 D
28 .I $P(^LEX(757.01,LEXEXP,1),U,2)=2 D
29 ..S LEXDIS=$$T(LEXEXP) D BL
30 ..S LEXSTR=" Synonym: "_$E(^LEX(757.01,LEXEXP,0),1,66) D TL
31 ..S LEXSTR=" "_LEXDIS D TL
32 Q
33LV ; Lexical Variants
34 N LEXEXP
35 S LEXEXP=0
36 F S LEXEXP=$O(^LEX(757.01,"AMC",+LEXMC,LEXEXP)) Q:+LEXEXP=0 D
37 .I $P(^LEX(757.01,LEXEXP,1),U,2)=3 D
38 ..S LEXDIS=$$T(LEXEXP) D BL
39 ..S LEXSTR=" Variant: "_$E(^LEX(757.01,LEXEXP,0),1,66) D TL
40 ..S LEXSTR=" "_LEXDIS D TL
41 Q
42MD ; Modifiers/Descendants PCH 6 added
43 Q:'$D(^LEX(757.01,"APAR",LEXMCE))
44 D BL
45 N LEXCHD,LEXORD,LEXSTR,LEXNO,LEXE,LEXCT,LEXTY,LEXL
46 S (LEXCHD,LEXCT)=0
47 S LEXSTR=" Modified/Descendant Terms" D TL,BL
48 F S LEXCHD=$O(^LEX(757.01,"APAR",LEXMCE,LEXCHD)) Q:+LEXCHD=0 D
49 .S LEXE=$P($G(^LEX(757.01,LEXCHD,0)),"^") Q:'$L(LEXE)
50 .S LEXTY=+$P($G(^LEX(757.01,LEXCHD,1)),"^",2) Q:LEXTY=0
51 .S LEXCT=LEXCT+1
52 .S LEXORD=+$P($G(^LEX(757.01,LEXCHD,1)),"^",10)
53 .S LEXNO=$S(LEXORD>0:LEXORD,1:(9999+LEXCT))
54 .S LEXL(LEXTY,LEXNO)=LEXE
55 S LEXTY=0 F S LEXTY=$O(LEXL(LEXTY)) Q:+LEXTY=0 D
56 .S LEXNO=0 F S LEXNO=$O(LEXL(LEXTY,LEXNO)) Q:+LEXNO=0 D
57 ..S LEXSTR=" "_LEXL(LEXTY,LEXNO) D TL
58 Q
59DEF ; Definition
60 D BL
61 I $D(^LEX(757.01,+Y,3)) D D BL
62 .S LEXSTR="DEFINITION:" D TL,BL
63 .N LEXDEF S LEXDEF=0
64 .F S LEXDEF=$O(^LEX(757.01,+Y,3,LEXDEF)) Q:+LEXDEF=0 D
65 ..S LEXSTR=" "_^LEX(757.01,+Y,3,LEXDEF,0) D TL
66 Q
67STY ; Semantic Classes/Types
68 S LEXSTR="SEMANTICS:" D TL,BL
69 S LEXSTR=" CLASS TYPE" D TL,BL
70 N LEXC,LEXT,LEXCT,LEXTT S LEXC="",LEXT=0
71 F S LEXC=$O(^LEX(757.1,"AMCC",LEXMC,LEXC)) Q:LEXC="" D
72 .S LEXCT=$E($P(^LEX(757.11,+$O(^LEX(757.11,"B",LEXC,0)),0),U,2),1,38)
73 .S LEXSTR=" "_LEXCT
74 .S LEXT=0
75 .F S LEXT=$O(^LEX(757.1,"AMCC",LEXMC,LEXC,LEXT)) Q:+LEXT=0 D
76 ..S LEXTT=$E($P(^LEX(757.12,+$P(^LEX(757.1,LEXT,0),U,3),0),U,2),1,38)
77 ..S LEXSPCR=$E(LEXSPC,1,(40-$L(LEXSTR)))
78 ..S LEXSTR=LEXSTR_LEXSPCR_LEXTT D TL S LEXSTR=""
79 Q
80CLC ; Clinical Class PCH 6 added
81 N LEXCL,LEXGP,LEXSTR,LEXFM,LEXIND,LEXP,LEXMEM,LEXT,LEXTC
82 S LEXCL=+$P($G(^LEX(757.01,+Y,1)),"^",11)
83 S:LEXCL=0 LEXCL=+$P($G(^LEX(757.01,LEXMCE,1)),"^",11)
84 Q:LEXCL=0 Q:'$D(^LEX(757.13,LEXCL,0))
85 S LEXGP=$G(^LEX(757.13,LEXCL,5)) Q:'$L(LEXGP)
86 D BL
87 S LEXSTR="SOURCE CATEGORY: "_LEXGP D TL,BL
88 S LEXFM=$P($G(^LEX(757.13,LEXCL,3)),"^") Q:'$L(LEXFM)
89 S LEXIND=" "
90 F LEXP=1:1:$L(LEXFM,"~") D
91 .S LEXMEM=+$P(LEXFM,"~",LEXP) Q:LEXMEM=0 Q:'$D(^LEX(757.13,LEXMEM,0))
92 .S LEXT=$P($G(^LEX(757.13,LEXMEM,0)),"^") Q:LEXT=""
93 .S LEXTC=$P($G(^LEX(757.13,LEXMEM,0)),"^",2)
94 .S LEXIND=LEXIND_" "
95 .S LEXSTR=LEXIND_LEXT D TL
96 Q
97SRC ; Classification Systems/Codes
98 N LEXSR,LEXSO,LEXSPC
99 K LEXSRC
100 S LEXSO=0
101 F S LEXSO=$O(^LEX(757.02,"AMC",LEXMC,LEXSO)) Q:+LEXSO=0 D
102 .Q:$P(^LEX(757.02,LEXSO,0),"^",6)=1
103 .S LEXNOM=$P(^LEX(757.03,+$P(^LEX(757.02,LEXSO,0),U,3),0),U,2)
104 .S LEXSR=$P(^LEX(757.03,+$P(^LEX(757.02,LEXSO,0),U,3),0),U,3)
105 .S $E(LEXSPC,16)=" "
106 .S LEXSPC=$E(LEXSPC,1,$L(LEXSPC)-$L(LEXNOM))
107 .S LEXSR=LEXNOM_LEXSPC_LEXSR
108 .S LEXCODE=$P(^LEX(757.02,LEXSO,0),U,2)
109 .S LEXSRC(LEXSR,LEXCODE)=""
110 I $D(LEXSRC) D K LEXSRC
111 .D BL S LEXSTR="CLASSIFICATION SYSTEMS/CODES:" D TL,BL
112 .S LEXSR=""
113 .F S LEXSR=$O(LEXSRC(LEXSR)) Q:LEXSR="" D
114 ..D BL S LEXSTR=" "_LEXSR D TL
115 ..S (LEXSTR,LEXCODE)=""
116 ..F S LEXCODE=$O(LEXSRC(LEXSR,LEXCODE)) Q:LEXCODE="" D
117 ...S LEXSTR=LEXSTR_"/"_LEXCODE
118 ..S:$E(LEXSTR)="/" LEXSTR=$E(LEXSTR,2,$L(LEXSTR))
119 ..S LEXSTR=" "_LEXSTR
120 ..D:$L(LEXSTR)>18 TL
121 Q
122T(X) ; Get Term Type
123 N LEXSCP,LEXF
124 S LEXF="",LEXFORM="",LEXEXP=+X,X=""
125 S LEXSCP=$P(^LEX(757.01,LEXEXP,1),U,3)
126 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:"")
127 S LEXF=$P(^LEX(757.01,LEXEXP,1),U,4) S:+LEXF=0 LEXF=""
128 S:+LEXF>0 LEXF=$P($G(^LEX(757.014,+LEXF,0)),U,2)
129 S X=LEXSCP_"/"_LEXF S:$P(X,"/",2)="" X=$P(X,"/",1)
130 S:$E(X)="/" X=$E(X,2,$L(X))
131 K LEXSCP,LEXF
132 Q X
133TL ; Create a Text Line
134 Q:'$L($G(LEXSTR))
135 N LEXC
136 S LEXC=+$G(LEX(0)),LEXC=LEXC+1
137 S LEX(LEXC)=LEXSTR
138 S LEX(0)=LEXC
139 Q
140BL ; Create a Blank Line
141 N LEXC
142 S LEXC=+$G(LEX(0)),LEXC=LEXC+1
143 S LEX(LEXC)="",LEX(0)=LEXC
144 Q
145LIST ; List the contents of the LEX array
146 Q:'$G(LEX(0)) N LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
147 S (LEXLN,LEXLC)=0,LEXCONT=""
148 F Q:LEXLN=LEX(0)!(LEXCONT["^") D Q:LEXLN=LEX(0)!(LEXCONT["^")
149 .S LEXB=LEXLN+1,LEXE=LEXB+(IOSL-3)
150 .F LEXCL=LEXB:1:LEXE D
151 ..I $D(LEX(LEXCL)) W !,LEX(LEXCL) S LEXLN=LEXCL,LEXLC=LEXLC+1
152 .I LEXLN'=LEX(0) D CONT Q
153 W !
154 S LEXLC=LEXLC+1
155 I LEXLC=(IOSL-3) D CONT
156 K LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
157 Q
158CONT ; Continue listing - Press <Return> to Continue
159 W ! N X,Y S DIR(0)="E" D ^DIR S LEXLC=0,LEXCONT=X
160 K DIR,DTOUT,DUOUT,DIRUT,DIROUT W !
161 Q
Note: See TracBrowser for help on using the repository browser.