LEXLK2 ;ISL/KER - Look Up - Expression Attributes ;05/23/2017
;;2.0;LEXICON UTILITY;**6,19,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.13) N/A
;
; External References
; ^DIR ICR 10026
;
GET(Y) ; Build list in array LEX
N LEXSPC,LEXSPCR,LEXSTR,LEXDIS,LEXMC,LEXMCE,LEXEXP,LEXAI
S $E(LEXSPC,42)=" " S LEXMC=+($G(^LEX(757.01,+($G(Y)),1))),LEXMCE=+($G(Y)),LEXMEX=+($G(^LEX(757,+LEXMC,0)))
K LEX
; PCH 6 add MD and CLC
D MC,SY,FS,LV,MD,DEF,STY,CLC,SRC,SUB
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,LEXA,LEXI S LEXMC=+($G(^LEX(757.01,+($G(Y)),1))),LEXMCE=+($G(Y)),LEXMEX=+($G(^LEX(757,+LEXMC,0)))
S LEXAI(+LEXMEX)="" D BL,BL S LEXSTR="TERMS:" D TL,BL S LEXA(1)=$G(^LEX(757.01,LEXMEX,0)) D PR^LEXU(.LEXA,64)
S LEXSTR=" Concept:" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(1)) D TL
S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(LEXI)) D TL
S LEXDIS=$$T(+LEXMEX) S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(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
. . N LEXA,LEXSTR,LEXI S LEXAI(+LEXEXP)="" S LEXA(1)=$G(^LEX(757.01,LEXEXP,0)) D PR^LEXU(.LEXA,64) D BL
. . S LEXSTR=" Synonym:" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(1)) D TL
. . S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . . S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(LEXI)) D TL
. . S LEXDIS=$$T(+LEXEXP) S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(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
. . N LEXA,LEXSTR,LEXI S LEXAI(+LEXEXP)="" S LEXA(1)=$G(^LEX(757.01,LEXEXP,0)) D PR^LEXU(.LEXA,64) D BL
. . S LEXSTR=" Variant:" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(1)) D TL
. . S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . . S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(LEXI)) D TL
. . S LEXDIS=$$T(+LEXEXP) S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_LEXDIS D TL
Q
FS ; Fully Specified
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)=8 D
. . N LEXA,LEXSTR,LEXI S LEXAI(+LEXEXP)="" S LEXA(1)=$G(^LEX(757.01,LEXEXP,0)) D PR^LEXU(.LEXA,64) D BL
. . S LEXSTR=" Specified:" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(1)) D TL
. . S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . . S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXA(LEXI)) D TL
. . S LEXDIS=$$T(+LEXEXP) S LEXSTR="" S LEXSTR=LEXSTR_$J(" ",(14-$L(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
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,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:LEXSR[" Edition" LEXSR=$P(LEXSR," Edition",1)_" Ed"_$P(LEXSR," Edition",2,299)
. S $P(LEXSPC," ",16)=" ",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
SUB ;
Q:$O(LEXAI(0))'>0
N LEXEIEN,LEXAS S LEXEIEN=0 F S LEXEIEN=$O(LEXAI(LEXEIEN)) Q:+LEXEIEN'>0 D
. N LEXSIEN S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.21,"B",+LEXEIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
. . N LEXSUB,LEXSUN S LEXSUB=$P($G(^LEX(757.21,+LEXSIEN,0)),"^",2),LEXSUN=$$MIX^LEXXM($P($G(^LEXT(757.2,+LEXSUB,0)),"^",1))
. . S LEXAS(+LEXSUB)=LEXSUN
I +($O(LEXAS(0)))>0 D
. N LEXSTR,LEXS S LEXSTR="SUBSETS:" D BL S LEXS=0 F S LEXS=$O(LEXAS(LEXS)) Q:+LEXS'>0 D
. . S LEXSTR=LEXSTR_$J(" ",(14-$L(LEXSTR)))_$G(LEXAS(+LEXS)) D TL S LEXSTR=""
D BL
Q
T(X) ; Get Term Type
N LEXSCP,LEXF,LEXFL,LEXTY,LEXTN
S LEXF="",LEXFORM="",LEXEXP=+X,X=""
S LEXTY=$P(^LEX(757.01,LEXEXP,1),U,2)
S LEXTN=$S(LEXTY=1:"Concept",LEXTY=8:"Fully Specified Name",1:"Synonym")
S LEXFL=$P(^LEX(757.01,LEXEXP,1),U,5)
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 LEXSCP="",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))
S:LEXTY>1&(LEXFL>0)&($l(LEXTN)) X="Retired "_LEXTN
K LEXSCP,LEXF
Q X
TM(X,Y) ; Trim Character
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
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
; Device
DEV ; Select a device
N %ZIS,LEXE,LEXCF,LEXCONT,LEXDNC,LEXEOP,LEXI,LEXLC,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK
S %ZIS("A")="Device: ",ZTRTN="DSPI^LEXLK2",ZTDESC="Display Lexicon Entry"
S ZTIO=ION,ZTDTH=$H,%ZIS="Q",ZTSAVE("LEX(")="" W ! D ^%ZIS I POP S LEXEXIT=1 Q
S ZTIO=ION I $D(IO("Q")) D QUE,^%ZISC,HOME^%ZIS Q
D NOQUE Q
NOQUE ; Do not que task
W:$L($G(IOF)) @IOF W:IOST["P-" !,"< Not queued, printing code lookup >",! U:IOST["P-" IO D @ZTRTN,^%ZISC,HOME^%ZIS Q
QUE ; Task queued to print user defaults
K IO("Q") D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued",1:"Request Cancelled"),! H 2 Q
Q
;
DSPI ; Display
Q:'$D(LEX) N LEXEXIT,LEXI,LEXIS S (LEXI,LEXEXIT)=0
W:'$D(ZTQUEUED)&($G(IOST)'["P-")&($L($G(IOF))) @IOF W:$O(LEX(0))'>0 !,"Text not Found"
U:IOST["P-" IO G:$O(LEX(0))'>0 DSPQ N LEXCONT,LEXI,LEXLC,LEXEOP,LEXCF
S LEXCONT="",(LEXCF,LEXIS,LEXLC,LEXI)=0,LEXEOP=+($G(IOSL))
S:LEXEOP=0 LEXEOP=24 F S LEXI=$O(LEX(LEXI)) Q:+LEXI=0!(LEXCONT["^") Q:+($G(LEXEXIT))>0 D Q:+($G(LEXEXIT))>0
. I '$L($$TM($G(LEX(LEXI)))),'$L($$TM($G(LEX((LEXI+1))))) Q
. S:$G(LEX(LEXI))["TERMS:" LEXIS=1 Q:LEXIS'>0
. W !,$G(LEX(LEXI)) S LEXCF=0 D LF Q:+($G(LEXEXIT))>0 Q:LEXCONT["^"
S:$D(ZTQUEUED) ZTREQ="@" I +($G(LEXEXIT))>0 K LEX Q
D:'LEXCF EOP K LEX W ! W:$G(IOST)["P-"&($L($G(IOF))) @IOF
DSPQ ; Quit Display
Q
LF ; Line Feed
S LEXLC=LEXLC+1 D:IOST["P-"&(LEXLC>(LEXEOP-5)) EOP D:IOST'["P-"&(LEXLC>(LEXEOP-4)) EOP
Q
EOP ; End of Page
S LEXCF=1 S LEXLC=0 W:'$D(LEXCAP)&(IOST["P-")&($L($G(IOF))) @IOF Q:IOST["P-" S LEXCONT=$$CONT2
Q
CONT2(X) ; Ask to Continue
Q:$D(LEXCAP) "" Q:+($G(LEXEXIT))>0 "^^" N DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y S DIR(0)="EAO",DIR("A")=" Enter RETURN to continue or '^' to exit: "
S DIR("PRE")="S:X[""?"" X=""??"" S:X[""^"" X=""^""",(DIR("?"),DIR("??"))="^D CONTH^LEXLK2"
W ! D ^DIR S:X["^^"!($D(DTOUT)) X="^^",LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:$D(DIROUT)!($D(DIRUT))!($D(DUOUT))!($D(DTOUT)) "^"
Q:X["^^" "^^" Q:X["^" "^"
Q ""
CONTH ; Ask to Continue Help
W:'$D(LEXCAP) !," Enter either RETURN or '^'."
Q
CONT ; Continue listing - Press <Return> to Continue
W ! N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y S DIR(0)="E" D ^DIR
S LEXLC=0,LEXCONT=X K DIR,DTOUT,DUOUT,DIRUT,DIROUT W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXLK2 10682 printed Dec 13, 2024@02:08:10 Page 2
LEXLK2 ;ISL/KER - Look Up - Expression Attributes ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**6,19,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.13) N/A
+5 ;
+6 ; External References
+7 ; ^DIR ICR 10026
+8 ;
GET(Y) ; Build list in array LEX
+1 NEW LEXSPC,LEXSPCR,LEXSTR,LEXDIS,LEXMC,LEXMCE,LEXEXP,LEXAI
+2 SET $EXTRACT(LEXSPC,42)=" "
SET LEXMC=+($GET(^LEX(757.01,+($GET(Y)),1)))
SET LEXMCE=+($GET(Y))
SET LEXMEX=+($GET(^LEX(757,+LEXMC,0)))
+3 KILL LEX
+4 ; PCH 6 add MD and CLC
+5 DO MC
DO SY
DO FS
DO LV
DO MD
DO DEF
DO STY
DO CLC
DO SRC
DO SUB
+6 KILL LEXC,LEXCODE,LEXCT,LEXDEF,LEXDIS,LEXEXP,LEXF
+7 KILL LEXFORM,LEXMC,LEXMCE,LEXNOM,LEXSCP,LEXSO,LEXSPC,LEXSPCR
+8 KILL LEXSR,LEXSRC,LEXSTR
+9 QUIT
MC ; Major Concept
+1 NEW LEXMEX,LEXA,LEXI
SET LEXMC=+($GET(^LEX(757.01,+($GET(Y)),1)))
SET LEXMCE=+($GET(Y))
SET LEXMEX=+($GET(^LEX(757,+LEXMC,0)))
+2 SET LEXAI(+LEXMEX)=""
DO BL
DO BL
SET LEXSTR="TERMS:"
DO TL
DO BL
SET LEXA(1)=$GET(^LEX(757.01,LEXMEX,0))
DO PR^LEXU(.LEXA,64)
+3 SET LEXSTR=" Concept:"
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(1))
DO TL
+4 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+5 SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(LEXI))
DO TL
End DoDot:1
+6 SET LEXDIS=$$T(+LEXMEX)
SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_LEXDIS
DO TL
+7 QUIT
SY ; Synonyms
+1 NEW LEXEXP
SET LEXEXP=0
FOR
SET LEXEXP=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEXP))
if +LEXEXP=0
QUIT
Begin DoDot:1
+2 IF $PIECE(^LEX(757.01,LEXEXP,1),U,2)=2
Begin DoDot:2
+3 NEW LEXA,LEXSTR,LEXI
SET LEXAI(+LEXEXP)=""
SET LEXA(1)=$GET(^LEX(757.01,LEXEXP,0))
DO PR^LEXU(.LEXA,64)
DO BL
+4 SET LEXSTR=" Synonym:"
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(1))
DO TL
+5 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+6 SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(LEXI))
DO TL
End DoDot:3
+7 SET LEXDIS=$$T(+LEXEXP)
SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_LEXDIS
DO TL
End DoDot:2
End DoDot:1
+8 QUIT
LV ; Lexical Variants
+1 NEW LEXEXP
SET LEXEXP=0
FOR
SET LEXEXP=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEXP))
if +LEXEXP=0
QUIT
Begin DoDot:1
+2 IF $PIECE(^LEX(757.01,LEXEXP,1),U,2)=3
Begin DoDot:2
+3 NEW LEXA,LEXSTR,LEXI
SET LEXAI(+LEXEXP)=""
SET LEXA(1)=$GET(^LEX(757.01,LEXEXP,0))
DO PR^LEXU(.LEXA,64)
DO BL
+4 SET LEXSTR=" Variant:"
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(1))
DO TL
+5 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+6 SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(LEXI))
DO TL
End DoDot:3
+7 SET LEXDIS=$$T(+LEXEXP)
SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_LEXDIS
DO TL
End DoDot:2
End DoDot:1
+8 QUIT
FS ; Fully Specified
+1 NEW LEXEXP
SET LEXEXP=0
FOR
SET LEXEXP=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEXP))
if +LEXEXP=0
QUIT
Begin DoDot:1
+2 IF $PIECE(^LEX(757.01,LEXEXP,1),U,2)=8
Begin DoDot:2
+3 NEW LEXA,LEXSTR,LEXI
SET LEXAI(+LEXEXP)=""
SET LEXA(1)=$GET(^LEX(757.01,LEXEXP,0))
DO PR^LEXU(.LEXA,64)
DO BL
+4 SET LEXSTR=" Specified:"
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(1))
DO TL
+5 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+6 SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXA(LEXI))
DO TL
End DoDot:3
+7 SET LEXDIS=$$T(+LEXEXP)
SET LEXSTR=""
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_LEXDIS
DO TL
End DoDot:2
End DoDot:1
+8 QUIT
MD ; Modifiers/Descendants PCH 6 added
+1 if '$DATA(^LEX(757.01,"APAR",LEXMCE))
QUIT
+2 DO BL
+3 NEW LEXCHD,LEXORD,LEXSTR,LEXNO,LEXE,LEXCT,LEXTY,LEXL
+4 SET (LEXCHD,LEXCT)=0
+5 SET LEXSTR=" Modified/Descendant Terms"
DO TL
DO BL
+6 FOR
SET LEXCHD=$ORDER(^LEX(757.01,"APAR",LEXMCE,LEXCHD))
if +LEXCHD=0
QUIT
Begin DoDot:1
+7 SET LEXE=$PIECE($GET(^LEX(757.01,LEXCHD,0)),"^")
if '$LENGTH(LEXE)
QUIT
+8 SET LEXTY=+$PIECE($GET(^LEX(757.01,LEXCHD,1)),"^",2)
if LEXTY=0
QUIT
+9 SET LEXCT=LEXCT+1
+10 SET LEXORD=+$PIECE($GET(^LEX(757.01,LEXCHD,1)),"^",10)
+11 SET LEXNO=$SELECT(LEXORD>0:LEXORD,1:(9999+LEXCT))
+12 SET LEXL(LEXTY,LEXNO)=LEXE
End DoDot:1
+13 SET LEXTY=0
FOR
SET LEXTY=$ORDER(LEXL(LEXTY))
if +LEXTY=0
QUIT
Begin DoDot:1
+14 SET LEXNO=0
FOR
SET LEXNO=$ORDER(LEXL(LEXTY,LEXNO))
if +LEXNO=0
QUIT
Begin DoDot:2
+15 SET LEXSTR=" "_LEXL(LEXTY,LEXNO)
DO TL
End DoDot:2
End DoDot:1
+16 QUIT
DEF ; Definition
+1 DO BL
+2 IF $DATA(^LEX(757.01,+Y,3))
Begin DoDot:1
+3 SET LEXSTR="DEFINITION:"
DO TL
DO BL
+4 NEW LEXDEF
SET LEXDEF=0
+5 FOR
SET LEXDEF=$ORDER(^LEX(757.01,+Y,3,LEXDEF))
if +LEXDEF=0
QUIT
Begin DoDot:2
+6 SET LEXSTR=" "_^LEX(757.01,+Y,3,LEXDEF,0)
DO TL
End DoDot:2
End DoDot:1
DO BL
+7 QUIT
STY ; Semantic Classes/Types
+1 SET LEXSTR="SEMANTICS:"
DO TL
DO BL
+2 SET LEXSTR=" CLASS TYPE"
DO TL
+3 NEW LEXC,LEXT,LEXCT,LEXTT
SET LEXC=""
SET LEXT=0
+4 FOR
SET LEXC=$ORDER(^LEX(757.1,"AMCC",LEXMC,LEXC))
if LEXC=""
QUIT
Begin DoDot:1
+5 SET LEXCT=$EXTRACT($PIECE(^LEX(757.11,+$ORDER(^LEX(757.11,"B",LEXC,0)),0),U,2),1,38)
+6 SET LEXSTR=" "_LEXCT
SET LEXT=0
FOR
SET LEXT=$ORDER(^LEX(757.1,"AMCC",LEXMC,LEXC,LEXT))
if +LEXT=0
QUIT
Begin DoDot:2
+7 SET LEXTT=$EXTRACT($PIECE(^LEX(757.12,+$PIECE(^LEX(757.1,LEXT,0),U,3),0),U,2),1,38)
+8 SET LEXSPCR=$EXTRACT(LEXSPC,1,(40-$LENGTH(LEXSTR)))
+9 SET LEXSTR=LEXSTR_LEXSPCR_LEXTT
DO TL
SET LEXSTR=""
End DoDot:2
End DoDot:1
+10 QUIT
CLC ; Clinical Class PCH 6 added
+1 NEW LEXCL,LEXGP,LEXSTR,LEXFM,LEXIND,LEXP,LEXMEM,LEXT,LEXTC
+2 SET LEXCL=+$PIECE($GET(^LEX(757.01,+Y,1)),"^",11)
+3 if LEXCL=0
SET LEXCL=+$PIECE($GET(^LEX(757.01,LEXMCE,1)),"^",11)
+4 if LEXCL=0
QUIT
if '$DATA(^LEX(757.13,LEXCL,0))
QUIT
+5 SET LEXGP=$GET(^LEX(757.13,LEXCL,5))
if '$LENGTH(LEXGP)
QUIT
+6 DO BL
SET LEXSTR="SOURCE CATEGORY: "_LEXGP
DO TL
DO BL
+7 SET LEXFM=$PIECE($GET(^LEX(757.13,LEXCL,3)),"^")
if '$LENGTH(LEXFM)
QUIT
+8 SET LEXIND=" "
+9 FOR LEXP=1:1:$LENGTH(LEXFM,"~")
Begin DoDot:1
+10 SET LEXMEM=+$PIECE(LEXFM,"~",LEXP)
if LEXMEM=0
QUIT
if '$DATA(^LEX(757.13,LEXMEM,0))
QUIT
+11 SET LEXT=$PIECE($GET(^LEX(757.13,LEXMEM,0)),"^")
if LEXT=""
QUIT
+12 SET LEXTC=$PIECE($GET(^LEX(757.13,LEXMEM,0)),"^",2)
+13 SET LEXIND=LEXIND_" "
+14 SET LEXSTR=LEXIND_LEXT
DO TL
End DoDot:1
+15 QUIT
SRC ; Classification Systems/Codes
+1 NEW LEXSR,LEXSO,LEXSPC
+2 KILL LEXSRC
+3 SET LEXSO=0
+4 FOR
SET LEXSO=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSO))
if +LEXSO=0
QUIT
Begin DoDot:1
+5 if $PIECE(^LEX(757.02,LEXSO,0),"^",6)=1
QUIT
+6 SET LEXNOM=$PIECE(^LEX(757.03,+$PIECE(^LEX(757.02,LEXSO,0),U,3),0),U,2)
+7 SET LEXSR=$PIECE(^LEX(757.03,+$PIECE(^LEX(757.02,LEXSO,0),U,3),0),U,3)
+8 if LEXSR[" Edition"
SET LEXSR=$PIECE(LEXSR," Edition",1)_" Ed"_$PIECE(LEXSR," Edition",2,299)
+9 SET $PIECE(LEXSPC," ",16)=" "
SET LEXSPC=$EXTRACT(LEXSPC,1,$LENGTH(LEXSPC)-$LENGTH(LEXNOM))
+10 SET LEXSR=LEXNOM_LEXSPC_LEXSR
+11 SET LEXCODE=$PIECE(^LEX(757.02,LEXSO,0),U,2)
+12 SET LEXSRC(LEXSR,LEXCODE)=""
End DoDot:1
+13 IF $DATA(LEXSRC)
Begin DoDot:1
+14 DO BL
SET LEXSTR="CLASSIFICATION SYSTEMS/CODES:"
DO TL
DO BL
+15 SET LEXSR=""
FOR
SET LEXSR=$ORDER(LEXSRC(LEXSR))
if LEXSR=""
QUIT
Begin DoDot:2
+16 DO BL
SET LEXSTR=" "_LEXSR
DO TL
+17 SET (LEXSTR,LEXCODE)=""
+18 FOR
SET LEXCODE=$ORDER(LEXSRC(LEXSR,LEXCODE))
if LEXCODE=""
QUIT
Begin DoDot:3
+19 SET LEXSTR=LEXSTR_"/"_LEXCODE
End DoDot:3
+20 if $EXTRACT(LEXSTR)="/"
SET LEXSTR=$EXTRACT(LEXSTR,2,$LENGTH(LEXSTR))
+21 SET LEXSTR=" "_LEXSTR
+22 if $LENGTH(LEXSTR)>18
DO TL
End DoDot:2
End DoDot:1
KILL LEXSRC
+23 QUIT
SUB ;
+1 if $ORDER(LEXAI(0))'>0
QUIT
+2 NEW LEXEIEN,LEXAS
SET LEXEIEN=0
FOR
SET LEXEIEN=$ORDER(LEXAI(LEXEIEN))
if +LEXEIEN'>0
QUIT
Begin DoDot:1
+3 NEW LEXSIEN
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.21,"B",+LEXEIEN,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:2
+4 NEW LEXSUB,LEXSUN
SET LEXSUB=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
SET LEXSUN=$$MIX^LEXXM($PIECE($GET(^LEXT(757.2,+LEXSUB,0)),"^",1))
+5 SET LEXAS(+LEXSUB)=LEXSUN
End DoDot:2
End DoDot:1
+6 IF +($ORDER(LEXAS(0)))>0
Begin DoDot:1
+7 NEW LEXSTR,LEXS
SET LEXSTR="SUBSETS:"
DO BL
SET LEXS=0
FOR
SET LEXS=$ORDER(LEXAS(LEXS))
if +LEXS'>0
QUIT
Begin DoDot:2
+8 SET LEXSTR=LEXSTR_$JUSTIFY(" ",(14-$LENGTH(LEXSTR)))_$GET(LEXAS(+LEXS))
DO TL
SET LEXSTR=""
End DoDot:2
End DoDot:1
+9 DO BL
+10 QUIT
T(X) ; Get Term Type
+1 NEW LEXSCP,LEXF,LEXFL,LEXTY,LEXTN
+2 SET LEXF=""
SET LEXFORM=""
SET LEXEXP=+X
SET X=""
+3 SET LEXTY=$PIECE(^LEX(757.01,LEXEXP,1),U,2)
+4 SET LEXTN=$SELECT(LEXTY=1:"Concept",LEXTY=8:"Fully Specified Name",1:"Synonym")
+5 SET LEXFL=$PIECE(^LEX(757.01,LEXEXP,1),U,5)
+6 SET LEXSCP=$PIECE(^LEX(757.01,LEXEXP,1),U,3)
+7 SET LEXSCP=$SELECT(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:"")
+8 SET LEXSCP=""
SET LEXF=$PIECE(^LEX(757.01,LEXEXP,1),U,4)
if +LEXF=0
SET LEXF=""
+9 if +LEXF>0
SET LEXF=$PIECE($GET(^LEX(757.014,+LEXF,0)),U,2)
+10 SET X=LEXSCP_"/"_LEXF
if $PIECE(X,"/",2)=""
SET X=$PIECE(X,"/",1)
+11 if $EXTRACT(X)="/"
SET X=$EXTRACT(X,2,$LENGTH(X))
+12
*** ERROR ***
if LEXTY>1&(LEXFL>0)&($l(LEXTN))
SET X="Retired "_LEXTN
+13 KILL LEXSCP,LEXF
+14 QUIT X
TM(X,Y) ; Trim Character
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
TL ; Create a Text Line
+1 if '$LENGTH($GET(LEXSTR))
QUIT
+2 NEW LEXC
+3 SET LEXC=+$GET(LEX(0))
SET LEXC=LEXC+1
+4 SET LEX(LEXC)=LEXSTR
+5 SET LEX(0)=LEXC
+6 QUIT
BL ; Create a Blank Line
+1 NEW LEXC
+2 SET LEXC=+$GET(LEX(0))
SET LEXC=LEXC+1
+3 SET LEX(LEXC)=""
SET LEX(0)=LEXC
+4 QUIT
LIST ; List the contents of the LEX array
+1 if '$GET(LEX(0))
QUIT
NEW LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
+2 SET (LEXLN,LEXLC)=0
SET LEXCONT=""
+3 FOR
if LEXLN=LEX(0)!(LEXCONT["^")
QUIT
Begin DoDot:1
+4 SET LEXB=LEXLN+1
SET LEXE=LEXB+(IOSL-3)
+5 FOR LEXCL=LEXB:1:LEXE
Begin DoDot:2
+6 IF $DATA(LEX(LEXCL))
WRITE !,LEX(LEXCL)
SET LEXLN=LEXCL
SET LEXLC=LEXLC+1
End DoDot:2
+7 IF LEXLN'=LEX(0)
DO CONT
QUIT
End DoDot:1
if LEXLN=LEX(0)!(LEXCONT["^")
QUIT
+8 WRITE !
SET LEXLC=LEXLC+1
IF LEXLC=(IOSL-3)
DO CONT
+9 KILL LEXLC,LEXLN,LEXCONT,LEXCL,LEXE,LEXB
+10 QUIT
+11 ; Device
DEV ; Select a device
+1 NEW %ZIS,LEXE,LEXCF,LEXCONT,LEXDNC,LEXEOP,LEXI,LEXLC,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK
+2 SET %ZIS("A")="Device: "
SET ZTRTN="DSPI^LEXLK2"
SET ZTDESC="Display Lexicon Entry"
+3 SET ZTIO=ION
SET ZTDTH=$HOROLOG
SET %ZIS="Q"
SET ZTSAVE("LEX(")=""
WRITE !
DO ^%ZIS
IF POP
SET LEXEXIT=1
QUIT
+4 SET ZTIO=ION
IF $DATA(IO("Q"))
DO QUE
DO ^%ZISC
DO HOME^%ZIS
QUIT
+5 DO NOQUE
QUIT
NOQUE ; Do not que task
+1 if $LENGTH($GET(IOF))
WRITE @IOF
if IOST["P-"
WRITE !,"< Not queued, printing code lookup >",!
if IOST["P-"
USE IO
DO @ZTRTN
DO ^%ZISC
DO HOME^%ZIS
QUIT
QUE ; Task queued to print user defaults
+1 KILL IO("Q")
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued",1:"Request Cancelled"),!
HANG 2
QUIT
+2 QUIT
+3 ;
DSPI ; Display
+1 if '$DATA(LEX)
QUIT
NEW LEXEXIT,LEXI,LEXIS
SET (LEXI,LEXEXIT)=0
+2 if '$DATA(ZTQUEUED)&($GET(IOST)'["P-")&($LENGTH($GET(IOF)))
WRITE @IOF
if $ORDER(LEX(0))'>0
WRITE !,"Text not Found"
+3 if IOST["P-"
USE IO
if $ORDER(LEX(0))'>0
GOTO DSPQ
NEW LEXCONT,LEXI,LEXLC,LEXEOP,LEXCF
+4 SET LEXCONT=""
SET (LEXCF,LEXIS,LEXLC,LEXI)=0
SET LEXEOP=+($GET(IOSL))
+5 if LEXEOP=0
SET LEXEOP=24
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI=0!(LEXCONT["^")
QUIT
if +($GET(LEXEXIT))>0
QUIT
Begin DoDot:1
+6 IF '$LENGTH($$TM($GET(LEX(LEXI))))
IF '$LENGTH($$TM($GET(LEX((LEXI+1)))))
QUIT
+7 if $GET(LEX(LEXI))["TERMS
SET LEXIS=1
if LEXIS'>0
QUIT
+8 WRITE !,$GET(LEX(LEXI))
SET LEXCF=0
DO LF
if +($GET(LEXEXIT))>0
QUIT
if LEXCONT["^"
QUIT
End DoDot:1
if +($GET(LEXEXIT))>0
QUIT
+9 if $DATA(ZTQUEUED)
SET ZTREQ="@"
IF +($GET(LEXEXIT))>0
KILL LEX
QUIT
+10 if 'LEXCF
DO EOP
KILL LEX
WRITE !
if $GET(IOST)["P-"&($LENGTH($GET(IOF)))
WRITE @IOF
DSPQ ; Quit Display
+1 QUIT
LF ; Line Feed
+1 SET LEXLC=LEXLC+1
if IOST["P-"&(LEXLC>(LEXEOP-5))
DO EOP
if IOST'["P-"&(LEXLC>(LEXEOP-4))
DO EOP
+2 QUIT
EOP ; End of Page
+1 SET LEXCF=1
SET LEXLC=0
if '$DATA(LEXCAP)&(IOST["P-")&($LENGTH($GET(IOF)))
WRITE @IOF
if IOST["P-"
QUIT
SET LEXCONT=$$CONT2
+2 QUIT
CONT2(X) ; Ask to Continue
+1 if $DATA(LEXCAP)
QUIT ""
if +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y
SET DIR(0)="EAO"
SET DIR("A")=" Enter RETURN to continue or '^' to exit: "
+2 SET DIR("PRE")="S:X[""?"" X=""??"" S:X[""^"" X=""^"""
SET (DIR("?"),DIR("??"))="^D CONTH^LEXLK2"
+3 WRITE !
DO ^DIR
if X["^^"!($DATA(DTOUT))
SET X="^^"
SET LEXEXIT=1
if X["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
if $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!($DATA(DTOUT))
QUIT "^"
+4 if X["^^"
QUIT "^^"
if X["^"
QUIT "^"
+5 QUIT ""
CONTH ; Ask to Continue Help
+1 if '$DATA(LEXCAP)
WRITE !," Enter either RETURN or '^'."
+2 QUIT
CONT ; Continue listing - Press <Return> to Continue
+1 WRITE !
NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
SET DIR(0)="E"
DO ^DIR
+2 SET LEXLC=0
SET LEXCONT=X
KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT
WRITE !
+3 QUIT
