- 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 Mar 13, 2025@21:12:41 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
