LEXINF2 ;ISL/KER - Information - Code ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757 SACC 1.3
; ^LEX(757.01 SACC 1.3
; ^LEX(757.018 SACC 1.3
; ^LEX(757.02 SACC 1.3
; ^LEX(757.03 SACC 1.3
; ^LEX(757.033 SACC 1.3
; ^LEX(757.21 SACC 1.3
; ^LEX(757.32 SACC 1.3
; ^LEX(757.33 SACC 1.3
; ^LEXT(757.2 SACC 1.3
;
; External References
; $$STATCHK^LEXSRC2 ICR 4083
; $$MIX^LEXXM ICR 5781
; $$DT^XLFDT ICR 10103
;
CODE(CODE,SRC,CDT,ARY,OUT) ; Information about a code
;
; Input
;
; CODE Code (file 757.02) (Required)
; SRC Source Abbr. or pointer to file 757.03 (Required)
; CDT Date used to determine status, default TODAY
; .ARY Local Array, passed by reference
; OUT Output/Display ARY (Optional)
; 0 Do not Display (default)
; 1 Display
; Output
;
; ARY
;
; Code
;
; ARY("CO")="Code"
; ARY("CO",n)=<code>
; ARY("CO","B",<code>,n)=""
; ARY("CO",n,"I")= 6 piece "^" delimited string
;
; 1 Status
; 2 Effective Date
; 3 Initial Activation Date
; 4 Pointer to CODES file #757.02
; 5 Coding System Nomenclature
; 6 Coding System
;
; ARY("CO",n,"MD")="Code Modifiers"
; ARY("CO",n,"MD",n)=<modifier>
; ARY("CO",n,"MD",n,"I")= 4 piece "^" delimited string
;
; 1 Status
; 2 Effective Date
; 3 Modifier Name
; 4 Pointer to CPT MODIFIER file #81.3
;
; ARY("CO",n,"VA")= 4 piece "^" delimited string
;
; 1 Status
; 2 Effective Date
; 3 VA File Number
; 4 Variable Pointer to VA File
;
; Diagnostic Categories (ICD-10-CM only)
;
; ARY("DC")="Diagnostic Categories"
; ARY("DC",1)=<category>
; ARY("DC",1,"I")= 4 piece "^" delimited string
;
; 1 Status
; 2 Effective Date
; 3 Category Name
; 4 Pointer to CHARACTER POSITIONS file #757.033
;
; Procedure Characters Positions (ICD-10-PCS only)
;
; Where n is a character position number 1-7
;
; ARY("CP")="Procedure Characters"
; ARY("CP","I")=<code>
; ARY("CP",n)=<character position 1-n>
; ARY("CP",n,"I")= 4 piece "^" delimited string
;
; 1 Status
; 2 Effective Date
; 3 Name
; 4 Pointer to CHARACTER POSITIONS file #757.033
;
; Terms
;
; Subscript SUB can be:
;
; PF Preferred Term
; FS Fully Specified Term
; MC Major Concept
; SY Synonyms
; LV Lexical Variants
; OR Orphan Text
;
; ARY(SUB)=type
; ARY(SUB,n)=<expression>
; ARY(SUB,n,"I")= 4 piece "^" delimited string
;
; 1 Status
; 2 Type
; 3 Current/Retired
; 4 Pointer to EXPRESSIONS file #757.01
;
; ARY(SUB,n,"ID")="Designation ID"
; ARY(SUB,n,"ID",n)<designation ID>
; ARY(SUB,n,"ID",n,"I")= 4 piece "^" delimited string
;
; 1 Status
; 2 Coding System
; 3 Hierarchy
; 4 Pointer to DESIGNATION CODE subfile #757.118
;
; ARY(SUB,n,"SK")="Supplemental Keywords"
; ARY(SUB,n,"SK",n)=<keyword>
; ARY(SUB,n,"SK",n,"I")= 4 piece "^" delimited string
;
; 1 Status
; 2 Not used
; 3 Not used
; 4 Pointer to SUPPLEMENTAL subfile #757.18
;
; Mappings
;
; ARY("MP")="Mapping"
; ARY("MP",n)=<map to target code>
; ARY("MP",n,"I")= 6 piece "^" delimited string
;
; 1 Status
; 2 Effective
; 3 Coding System
; 4 Pointer to MAPPINGS file #757.33
; 5 Match (full/partial)
; 6 Source Code
; 7 Source Coding System
;
; Subsets
;
; ARY("SB")="Subsets"
; ARY("SB",n)=<subset>
; ARY("SB",n,"I")= 5 piece "^" delimited string
;
; 1 Status
; 2 Pointer to SUBSET file #757.21
; 3 Pointer to EXPRESSION file #757.01
; 4 Pointer to SUBSET DEFINITION file #757.2
; 5 Subset ID
;
; Source
;
; ARY("SR")="Source"
; ARY("SR",n)=<source abbreviation>
; ARY("SR",n,"I")= 4 piece "^" delimited string
; ARY("SR","B",<source>,n)=""
;
; 1 Source Abbreviation
; 2 Source Nomenclature
; 3 Source Title
; 4 Pointer to CODING SYSTEMS file #757.03
;
N LEXCDT,LEXEFF,LEXCODE,LEXDISP,LEXEIEN,LEXMIEN,LEXPF,LEXSIEN,LEXSRC,LEXST,LEXSYS,LEXTYPE K ARY S LEXDISP=+($G(OUT))
S LEXCODE=$G(CODE),LEXSRC=$G(SRC),LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S:'$L(LEXSRC)&($L(LEXCODE)) LEXSRC=$$SRC^LEXINF(LEXCODE)
S:$G(SRC)'?1N.N&($L($G(SRC))=3)&($D(^LEX(757.03,"ASAB",$G(SRC)))) LEXSRC=$O(^LEX(757.03,"ASAB",$G(SRC),0))
I '$L(LEXCODE)!(+LEXSRC'>0) K ARY Q
D CO(LEXCODE,LEXSRC,LEXCDT,.ARY) S LEXSIEN=$P($G(ARY("CO",1,"I")),"^",4),LEXMIEN=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",4)
S LEXEIEN=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",1) I LEXSIEN'>0!(LEXMIEN'>0)!(LEXEIEN'>0) K ARY Q
D PF(LEXCODE,.ARY) S LEXPF=$P($G(ARY("PF",1,"I")),"^",4) I LEXPF'>0 K ARY Q
D OT(LEXEIEN,LEXPF,.ARY),SB(LEXCODE,LEXSRC,.ARY),MP(LEXCODE,LEXSRC,LEXCDT,.ARY)
I +($G(LEXDISP))>0 D CODE^LEXINF5(.ARY)
Q
CO(X,Y,CDT,ARY) ; Code CO
N LEXCDT,LEXCODE,LEXEFF,LEXIEN,LEXINIT,LEXNOM,LEXSAB,LEXSRC,LEXST,LEXSTAT,LEXSYS,LEXTTL Q:'$L(X) Q:'$L(Y)
K ARY("CO"),ARY("SR") S LEXCODE=$G(X),LEXSYS=$G(Y),LEXSRC=""
S:$G(LEXSYS)?1N.N&($D(^LEX(757.03,+($G(LEXSYS)),0))) LEXSRC=+($G(LEXSYS))
S:$G(LEXSYS)'?1N.N&($L($G(LEXSYS))=3)&($D(^LEX(757.03,"ASAB",$G(LEXSYS)))) LEXSRC=$O(^LEX(757.03,"ASAB",$G(LEXSYS)))
Q:LEXSRC'?1N.N D SR(LEXSRC) Q:$L($G(LEXSAB))'=3 Q:'$L($G(LEXNOM)) Q:'$L($G(LEXTTL))
S LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT,,LEXSAB)
S LEXST=+LEXSTAT,LEXIEN=$P(LEXSTAT,"^",2),LEXEFF=$P(LEXSTAT,"^",3),LEXINIT=$P(LEXSTAT,"^",4)
S:LEXEFF?7N&(LEXINIT'?7N) LEXINIT=LEXEFF S ARY("CO",1)=LEXCODE
S ARY("CO")="Code",ARY("CO",1,"I")=+LEXSTAT_"^"_LEXEFF_"^"_LEXINIT_"^"_LEXIEN_"^"_LEXNOM_"^"_LEXSRC
S ARY("CO","B",LEXSRC,1)="" D:"^1^2^3^4^30^31^"[("^"_LEXSRC_"^") VA^LEXINF3(LEXCODE,LEXSRC,LEXCDT,1,.ARY)
S ARY("SR")="Source",ARY("SR",1)=LEXSAB,ARY("SR",1,"I")=LEXSAB_"^"_LEXNOM_"^"_LEXTTL_"^"_LEXSRC
S ARY("SR","B",LEXSRC,1)=""
D:LEXSRC=3!(LEXSRC=4) MD^LEXINF3(LEXCODE,LEXCDT,1,.ARY)
D:LEXSRC=30 DC(LEXCODE,LEXCDT,.ARY) D:LEXSRC=31 CP(LEXCODE,LEXCDT,.ARY)
Q
MD(X,Y,I,ARY) ; Modifiers CO/MD
D MD^LEXINF3($G(X),$G(Y),$G(I),.ARY)
Q
VA(X,Y,D,I,ARY) ; VA File CO/VA
D VA^LEXINF3($G(X),$G(Y),$G(D),$G(I),.ARY)
Q
PF(CODE,ARY) ; Preferred Term PF
N LEXCODE,LEXEFF,LEXEIEN,LEXEXP,LEXND,LEXSIEN,LEXSTA,LEXSTAT,LEXTY K ARY("PF") S LEXCODE=$G(CODE) Q:'$L(LEXCODE)
S LEXEFF=$O(^LEX(757.02,"ACT",(LEXCODE_" "),3," "),-1) Q:LEXEFF'?7N
S LEXSIEN=$O(^LEX(757.02,"ACT",(LEXCODE_" "),3,+LEXEFF," "),-1) Q:+LEXSIEN'>0
S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0 S LEXEIEN=+LEXND Q:LEXEIEN'>0
S LEXEXP=$G(^LEX(757.01,+LEXEIEN,0)) Q:'$L(LEXEXP) S LEXND=$G(^LEX(757.01,+LEXEIEN,1))
S LEXSTA=$P(LEXND,"^",5),LEXSTA=$S(LEXSTA=1:0,1:1) S LEXSTAT=$S(LEXSTA'>0:"Retired",1:"Current")
S LEXTY=$P(LEXND,"^",2),LEXTY=$S(LEXTY=1:"Major Concept",LEXTY=3:"Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
S ARY("PF")="Preferred Term",ARY("PF",1)=LEXEXP,ARY("PF",1,"I")=LEXSTA_"^"_LEXTY_"^"_LEXSTAT_"^"_+LEXEIEN
D DS("PF",1,+LEXEIEN,.ARY),SK("PF",1,+LEXEIEN,.ARY),NG("PF",1,+LEXEIEN,.ARY)
Q
OT(X,LEX,ARY) ; Other Terms MC/FS/SY/LV
N LEXEIEN,LEXEX,LEXEXP,LEXMC,LEXND,LEXPF,LEXSEQ,LEXSTA,LEXTN,LEXTS,LEXTY K ARY("FS") S LEXEIEN=$G(X)
Q:LEXEIEN'>0 S LEXMC=+($G(^LEX(757.01,+LEXEIEN,1))) Q:'$D(^LEX(757,+LEXMC,0))
Q:'$D(^LEX(757.01,"AMC",+LEXMC)) S LEXPF=+($G(LEX)) Q:LEXPF'>0 Q:'$D(^LEX(757.01,LEXPF,0))
S LEXEX=0 F S LEXEX=$O(^LEX(757.01,"AMC",LEXMC,LEXEX)) Q:+LEXEX'>0 D
. N LEXEXP,LEXND,LEXSEQ,LEXSTA,LEXSTAT,LEXTN,LEXTS,LEXTY S LEXEXP=$G(^LEX(757.01,+LEXEX,0))
. Q:'$L(LEXEXP) S LEXND=$G(^LEX(757.01,+LEXEX,1)),LEXSTA=$P(LEXND,"^",5)
. S LEXSTA=$S(LEXSTA=1:0,1:1),LEXTY=$P(LEXND,"^",2),LEXSTAT=$S(LEXSTA'>0:"Retired",1:"Current")
. S LEXTN=$S(LEXTY=1:"Major Concept",LEXTY=3:"Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
. S LEXTS=$S(LEXTY=1:"MC",LEXTY=3:"LV",LEXTY=8:"FS",1:"SY")
. S LEXSEQ=$O(ARY(LEXTS," "),-1)+1,ARY(LEXTS,LEXSEQ)=LEXEXP,ARY(LEXTS)=LEXTN
. S ARY(LEXTS,LEXSEQ,"I")=LEXSTA_"^"_LEXTN_"^"_$S(LEXSTA'>0:"Retired",1:"Current")_"^"_+LEXEX
. D DS(LEXTS,LEXSEQ,+LEXEX,.ARY),SK(LEXTS,LEXSEQ,+LEXEX,.ARY),NG(LEXTS,LEXSEQ,+LEXEX,.ARY)
Q
DS(X,Y,LEX,ARY) ; Designation ID ID
N LEXC,LEXDSI,LEXH,LEXHN,LEXIEN,LEXIN,LEXND,LEXS,LEXSB,LEXSEQ,LEXSTA,LEXSYS
S LEXSB=$G(X) Q:'$L(LEXSB) S LEXIN=$G(Y) Q:LEXIN'>0 S LEXIEN=$G(LEX) Q:LEXIEN'>0
S LEXSTA=+($G(ARY(LEXSB,LEXIN,"I"))),LEXDSI=0 F S LEXDSI=$O(^LEX(757.01,+LEXIEN,7,LEXDSI)) Q:+LEXDSI'>0 D
. N LEXC,LEXH,LEXHN,LEXND,LEXS,LEXSEQ,LEXSYS S LEXND=$G(^LEX(757.01,LEXIEN,7,LEXDSI,0))
. S LEXC=$P(LEXND,"^",1) Q:'$L(LEXC) S LEXS=$P(LEXND,"^",2) Q:+LEXS'>0
. S LEXSYS=$P($G(^LEX(757.03,+LEXS,0)),"^",2),LEXH=$P(LEXND,"^",3)
. S LEXHN=$P($G(^LEX(757.018,+LEXH,0)),"^",1),LEXSEQ=$O(ARY(LEXSB,LEXIN,"ID"," "),-1)+1
. S ARY(LEXSB,LEXIN,"ID")="Designation ID"
. S ARY(LEXSB,LEXIN,"ID",LEXSEQ)=LEXC
. S ARY(LEXSB,LEXIN,"ID",LEXSEQ,"I")=LEXSTA_"^"_LEXSYS_"^"_LEXHN_"^"_+LEXDSI
Q
SK(X,Y,LEX,ARY) ; Supplemental Keywords SK
N LEXC,LEXSKI,LEXH,LEXHN,LEXIEN,LEXIN,LEXND,LEXS,LEXSB,LEXSEQ,LEXSTA,LEXSYS
S LEXSB=$G(X) Q:'$L(LEXSB) S LEXIN=$G(Y) Q:LEXIN'>0 S LEXIEN=$G(LEX) Q:LEXIEN'>0
S LEXSTA=+($G(ARY(LEXSB,LEXIN,"I"))),LEXSKI=0 F S LEXSKI=$O(^LEX(757.01,+LEXIEN,5,LEXSKI)) Q:+LEXSKI'>0 D
. N LEXK,LEXH,LEXHN,LEXND,LEXS,LEXSEQ,LEXSYS S LEXND=$G(^LEX(757.01,LEXIEN,5,LEXSKI,0))
. S LEXK=$P(LEXND,"^",1) Q:'$L(LEXK) S LEXSEQ=$O(ARY(LEXSB,LEXIN,"SK"," "),-1)+1
. S ARY(LEXSB,LEXIN,"SK")="Supplemental Keywords"
. S ARY(LEXSB,LEXIN,"SK",LEXSEQ)=LEXK
. S ARY(LEXSB,LEXIN,"SK",LEXSEQ,"I")=LEXSTA_"^^^"_+LEXSKI
Q
NG(X,Y,LEX,ARY) ; Negations NG
N LEXC,LEXNGI,LEXH,LEXHN,LEXIEN,LEXIN,LEXND,LEXS,LEXSB,LEXSEQ,LEXSTA,LEXSYS
S LEXSB=$G(X) Q:'$L(LEXSB) S LEXIN=$G(Y) Q:LEXIN'>0 S LEXIEN=$G(LEX) Q:LEXIEN'>0
S LEXSTA=+($G(ARY(LEXSB,LEXIN,"I"))),LEXNGI=0 F S LEXNGI=$O(^LEX(757.01,+LEXIEN,4,LEXNGI)) Q:+LEXNGI'>0 D
. N LEXK,LEXH,LEXHN,LEXND,LEXS,LEXSEQ,LEXSYS S LEXND=$G(^LEX(757.01,LEXIEN,4,LEXNGI,0))
. S LEXK=$P(LEXND,"^",1) Q:'$L(LEXK) S LEXSEQ=$O(ARY(LEXSB,LEXIN,"NG"," "),-1)+1
. S ARY(LEXSB,LEXIN,"NG")="Negations"
. S ARY(LEXSB,LEXIN,"NG",LEXSEQ)=LEXK
. S ARY(LEXSB,LEXIN,"NG",LEXSEQ,"I")=LEXSTA_"^^^"_+LEXNGI
Q
SR(SRC) ; Source SR
S LEXSAB=$P($G(^LEX(757.03,+($G(SRC)),0)),"^",1) Q:$L(LEXSAB)'=3
S LEXNOM=$P($G(^LEX(757.03,+($G(SRC)),0)),"^",2) Q:'$L(LEXNOM)
S LEXTTL=$P($G(^LEX(757.03,+($G(SRC)),0)),"^",3) Q:'$L(LEXTTL)
Q
OR(X,Y,CDT,ARY) ; Orphan Text OR
N LEXCDT,LEXCODE,LEXEIEN,LEXEXP,LEXND,LEXSEQ,LEXSIEN,LEXSRC,LEXSTA,LEXSTAT,LEXTY K ARY("OR")
S LEXCODE=$G(X),LEXSYS=$G(Y),LEXSRC="" S:$G(LEXSYS)?1N.N&($D(^LEX(757.03,+($G(LEXSYS)),0))) LEXSRC=+($G(LEXSYS))
S:$G(LEXSYS)'?1N.N&($L($G(LEXSYS))=3)&($D(^LEX(757.03,"ASAB",$G(LEXSYS)))) LEXSRC=$O(^LEX(757.03,"ASAB",$G(LEXSYS)))
Q:LEXSRC'?1N.N S LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXCODE_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXEF,LEXEIEN,LEXEXP,LEXHS,LEXND,LEXSEQ,LEXST,LEXSTA,LEXSTAT,LEXTY
. S LEXEF=$O(^LEX(757.02,+LEXSIEN,"4","B",(LEXCDT+.00001)),-1)
. S LEXHS=$O(^LEX(757.02,+LEXSIEN,"4","B",+LEXEF," "),-1)
. S LEXST=$P($G(^LEX(757.02,+LEXSIEN,"4",+LEXHS,0)),"^",2)
. S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)>0 Q:$P(LEXND,"^",3)'=+($G(LEXSRC))
. S LEXEIEN=+LEXND,LEXEXP=$G(^LEX(757.01,+LEXEIEN,0)),LEXND=$G(^LEX(757.01,+LEXEIEN,1)) Q:$P(LEXND,"^",4)'=10
. S LEXTY="VA Derived",LEXSTA=$P(LEXND,"^",5),LEXSTAT="Current" S:LEXSTA>0 LEXSTAT="Retired"
. S:LEXST'>0 LEXSTAT="Inactive"
. S LEXSTA=$S(+($G(LEXST))'>0!(+($G(LEXSTA))>0):"0",1:1)
. S LEXSEQ=$O(ARY("OR"," "),-1)+1,ARY("OR")="Orphan Text",ARY("OR",LEXSEQ)=LEXEXP
. S ARY("OR",LEXSEQ,"I")=LEXSTA_"^"_LEXTY_"^"_LEXSTAT_"^"_+LEXEIEN
Q
SB(X,Y,ARY) ; Subsets SB
K LEX N LEXIENS,LEXEX,LEXMC,LEXIEN,LEXSO,LEXSIEN,LEXSRC,LEXSYS S LEXSO=$G(X) Q:'$L(LEXSO) S LEXSYS=$G(Y) Q:'$L($G(LEXSYS))
S LEXSRC="" S:$G(LEXSYS)?1N.N&($D(^LEX(757.03,+($G(LEXSYS)),0))) LEXSRC=+($G(LEXSYS))
S:$G(LEXSYS)'?1N.N&($L($G(LEXSYS))=3)&($D(^LEX(757.03,"ASAB",$G(LEXSYS)))) LEXSRC=$O(^LEX(757.03,"ASAB",$G(LEXSYS)))
Q:'$D(^LEX(757.03,+LEXSRC,0)) S (LEXST,LEXMC)="",LEXSIEN=0
S LEXEFF=" " F S LEXEFF=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEFF),-1) Q:'$L(LEXEFF) D Q:LEXMC>0
. N LEXSIEN S LEXSIEN=" " F S LEXSIEN=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEFF,LEXSIEN),-1) Q:+LEXSIEN'>0 D Q:LEXMC>0
. . N LEXND,LEXEF,LEXHS S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",3)'=LEXSRC Q:$P(LEXND,"^",5)'>0
. . S LEXEF=$O(^LEX(757.02,+LEXSIEN,"4","B",(LEXCDT+.00001)),-1)
. . S LEXHS=$O(^LEX(757.02,+LEXSIEN,"4","B",+LEXEF," "),-1)
. . S LEXST=$P($G(^LEX(757.02,+LEXSIEN,"4",+LEXHS,0)),"^",2)
. . S LEXMC=$P(LEXND,"^",4)
Q:+LEXMC'>0 Q:LEXST'?1N S LEXEX=+($G(^LEX(757,+LEXMC,0))) I $D(^LEX(757.21,"B",+LEXEX)) D Q
. S LEXIEN=LEXEX,LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.21,"B",+LEXEX,LEXSIEN)) Q:LEXSIEN'>0 D
. . N LEXND,LEXSI,LEXSA,LEXSF,LEXSTR,LEXSEQ
. . S LEXSI=$P($G(^LEX(757.21,+LEXSIEN,0)),"^",2),LEXND=$G(^LEXT(757.2,+LEXSI,0))
. . S LEXSA=$P(LEXND,"^",2),LEXSF=$$MIX^LEXXM($P(LEXND,"^",1))
. . S LEXSTR=+($G(LEXST)) S:+LEXSIEN>0 $P(LEXSTR,"^",2)=+LEXSIEN S:+LEXEX>0 $P(LEXSTR,"^",3)=+LEXEX
. . S:+LEXSI>0 $P(LEXSTR,"^",4)=+LEXSI S:$L(LEXSA) $P(LEXSTR,"^",5)=LEXSA S ARY("SB")="Subsets"
. . S LEXSEQ=$O(ARY("SB"," "),-1)+1 S ARY("SB",LEXSEQ)=LEXSF S ARY("SB",LEXSEQ,"I")=LEXSTR
S LEXIEN=0 F S LEXIEN=$O(^LEX(757.01,"AMC",LEXMC,LEXIEN)) Q:+LEXIEN'>0 D
. Q:$P($G(^LEX(757.01,+LEXIEN,1)),"^",5)>0 S LEXIENS(LEXIEN)=""
Q:$O(LEXIENS(0))'>0 S LEXIEN=0 F S LEXIEN=$O(LEXIENS(LEXIEN)) Q:+LEXIEN'>0 D
. Q:'$D(^LEX(757.21,"B",LEXIEN)) S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.21,"B",LEXIEN,LEXSIEN)) Q:LEXSIEN'>0 D
. . N LEXND,LEXSI,LEXSA,LEXSF,LEXSTR,LEXSEQ
. . S LEXSI=$P($G(^LEX(757.21,+LEXSIEN,0)),"^",2),LEXND=$G(^LEXT(757.2,+LEXSI,0))
. . S LEXSA=$P(LEXND,"^",2),LEXSF=$$MIX^LEXXM($P(LEXND,"^",1))
. . S LEXSTR=+($G(LEXST)) S:+LEXSIEN>0 $P(LEXSTR,"^",2)=+LEXSIEN S:+LEXIEN>0 $P(LEXSTR,"^",3)=+LEXIEN
. . S:+LEXSI>0 $P(LEXSTR,"^",4)=+LEXSI S:$L(LEXSA) $P(LEXSTR,"^",5)=LEXSA S ARY("SB")="Subsets"
. . S LEXSEQ=$O(ARY("SB"," "),-1)+1 S ARY("SB",LEXSEQ)=LEXSF S ARY("SB",LEXSEQ,"I")=LEXSTR
Q
MP(X,Y,CDT,ARY) ; Mappings MP
N LEXCDT,LEXCODE,LEXSRC,LEXTO S LEXCODE=$G(X),LEXSYS=$G(Y) K ARY("MP") Q:'$L(LEXCODE) Q:'$L(LEXSYS)
S LEXSRC="" S:$G(LEXSYS)?1N.N&($D(^LEX(757.03,+($G(LEXSYS)),0))) LEXSRC=+($G(LEXSYS))
S:$G(LEXSYS)'?1N.N&($L($G(LEXSYS))=3)&($D(^LEX(757.03,"ASAB",$G(LEXSYS)))) LEXSRC=$O(^LEX(757.03,"ASAB",$G(LEXSYS)))
Q:'$D(^LEX(757.03,+LEXSRC,0)) Q:LEXCODE="R69."&(LEXSRC=30) S LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXTO="" F S LEXTO=$O(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO)) Q:'$L(LEXTO) D
. N LEXEF,LEXMCODE,LEXMDEF,LEXMIEN,LEXMMAT,LEXMNOM,LEXMSSY,LEXMTSY,LEXND,LEXSEQ,LEXST,LEXSTR
. S LEXEF=$O(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO,(LEXCDT+.0001)),-1) Q:'$L(LEXEF)
. S LEXST=$O(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO,LEXEF," "),-1) Q:'$L(LEXST)
. S LEXMIEN=$O(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO,LEXEF,+LEXST," "),-1) Q:+LEXMIEN'>0
. S LEXND=$G(^LEX(757.33,+LEXMIEN,0)),LEXMCODE=$P(LEXND,"^",3),LEXMMAT=$P(LEXND,"^",5)
. S LEXMMAT=$S(+LEXMMAT>0:"Full",1:"Part") S LEXMDEF=$P(LEXND,"^",4)
. S LEXMSSY=$P($G(^LEX(757.32,+LEXMDEF,2)),"^",1) Q:LEXMSSY'=LEXSRC
. S LEXMTSY=$P($G(^LEX(757.32,+LEXMDEF,2)),"^",2),LEXMNOM=$P($G(^LEX(757.03,+LEXMTSY,0)),"^",2)
. S LEXSTR=+LEXST,$P(LEXSTR,"^",2)=LEXEF S:$L(LEXMNOM) $P(LEXSTR,"^",3)=LEXMNOM
. S:+LEXMIEN>0 $P(LEXSTR,"^",4)=+LEXMIEN S:$L(LEXMMAT) $P(LEXSTR,"^",5)=LEXMMAT
. S $P(LEXSTR,"^",6)=LEXCODE,$P(LEXSTR,"^",7)=LEXMSSY,ARY("MP")="Mapping"
. S LEXSEQ=$O(ARY("MP"," "),-1)+1,ARY("MP",LEXSEQ)=LEXMCODE,ARY("MP",LEXSEQ,"I")=LEXSTR
Q
DC(X,CDT,ARY) ; Diagnostic Categories DC
K ARY("DC") N LEXCDT,LEXCID,LEXCODE,LEXI S LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXCODE=$G(X),LEXCID="10D" F LEXI=1:1 Q:'$L($E(LEXCODE,LEXI)) D
. N LEXCAT,LEXCIEN,LEXEF,LEXHS,LEXSEQ,LEXST,LEXSTR,LEXTD,LEXTH,LEXTX S LEXCID=LEXCID_$E(LEXCODE,LEXI)
. S LEXCIEN=$O(^LEX(757.033,"B",LEXCID,0)) Q:+LEXCIEN'>0 S LEXCAT=$P(LEXCID,"10D",2)
. S LEXEF=$O(^LEX(757.033,+LEXCIEN,1,"B",(LEXCDT+.0001)),-1) S LEXHS=$O(^LEX(757.033,+LEXCIEN,1,"B",+LEXEF," "),-1)
. S LEXST=$P($G(^LEX(757.033,+LEXCIEN,1,+LEXHS,0)),"^",2) S LEXTD=$O(^LEX(757.033,+LEXCIEN,2,"B",(LEXCDT+.0001)),-1)
. S LEXTH=$O(^LEX(757.033,+LEXCIEN,2,"B",+LEXTD," "),-1) S LEXTX=$P($G(^LEX(757.033,+LEXCIEN,2,+LEXTH,1)),"^",1)
. S LEXSTR=LEXST S:LEXEF?7N $P(LEXSTR,"^",2)=LEXEF S:$L(LEXTX) $P(LEXSTR,"^",3)=LEXTX S $P(LEXSTR,"^",4)=+LEXCIEN
. S LEXSEQ=$O(ARY("DC"," "),-1)+1 S ARY("DC",LEXSEQ)=LEXCAT S ARY("DC",LEXSEQ,"I")=LEXSTR
. S ARY("DC")="Diagnostic Categories",ARY("DC","I")=LEXCODE
Q
CP(X,CDT,ARY) ; Character Positions CP
K ARY("CP") N LEXCDT,LEXCID,LEXCODE,LEXI S LEXCDT=$G(CDT) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXCODE=$G(X),LEXCID="10P" F LEXI=1:1 Q:'$L($E(LEXCODE,LEXI)) D
. N LEXCAT,LEXCIEN,LEXEF,LEXHS,LEXSEQ,LEXST,LEXSTR,LEXTD,LEXTH,LEXTX S LEXCID=LEXCID_$E(LEXCODE,LEXI)
. S LEXCIEN=$O(^LEX(757.033,"B",LEXCID,0)) Q:+LEXCIEN'>0 S LEXCAT=$P(LEXCID,"10P",2)
. S LEXEF=$O(^LEX(757.033,+LEXCIEN,1,"B",(LEXCDT+.0001)),-1) S LEXHS=$O(^LEX(757.033,+LEXCIEN,1,"B",+LEXEF," "),-1)
. S LEXST=$P($G(^LEX(757.033,+LEXCIEN,1,+LEXHS,0)),"^",2) S LEXTD=$O(^LEX(757.033,+LEXCIEN,2,"B",(LEXCDT+.0001)),-1)
. S LEXTH=$O(^LEX(757.033,+LEXCIEN,2,"B",+LEXTD," "),-1) S LEXTX=$P($G(^LEX(757.033,+LEXCIEN,2,+LEXTH,1)),"^",1)
. S LEXSTR=LEXST S:LEXEF?7N $P(LEXSTR,"^",2)=LEXEF S:$L(LEXTX) $P(LEXSTR,"^",3)=LEXTX S $P(LEXSTR,"^",4)=+LEXCIEN
. S LEXSEQ=$O(ARY("CP"," "),-1)+1 S ARY("CP",LEXSEQ)=LEXCAT S ARY("CP",LEXSEQ,"I")=LEXSTR
. S ARY("CP")="Procedure Characters",ARY("CP","I")=LEXCODE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXINF2 18809 printed Sep 23, 2025@19:43:58 Page 2
LEXINF2 ;ISL/KER - Information - Code ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757 SACC 1.3
+5 ; ^LEX(757.01 SACC 1.3
+6 ; ^LEX(757.018 SACC 1.3
+7 ; ^LEX(757.02 SACC 1.3
+8 ; ^LEX(757.03 SACC 1.3
+9 ; ^LEX(757.033 SACC 1.3
+10 ; ^LEX(757.21 SACC 1.3
+11 ; ^LEX(757.32 SACC 1.3
+12 ; ^LEX(757.33 SACC 1.3
+13 ; ^LEXT(757.2 SACC 1.3
+14 ;
+15 ; External References
+16 ; $$STATCHK^LEXSRC2 ICR 4083
+17 ; $$MIX^LEXXM ICR 5781
+18 ; $$DT^XLFDT ICR 10103
+19 ;
CODE(CODE,SRC,CDT,ARY,OUT) ; Information about a code
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code (file 757.02) (Required)
+5 ; SRC Source Abbr. or pointer to file 757.03 (Required)
+6 ; CDT Date used to determine status, default TODAY
+7 ; .ARY Local Array, passed by reference
+8 ; OUT Output/Display ARY (Optional)
+9 ; 0 Do not Display (default)
+10 ; 1 Display
+11 ; Output
+12 ;
+13 ; ARY
+14 ;
+15 ; Code
+16 ;
+17 ; ARY("CO")="Code"
+18 ; ARY("CO",n)=<code>
+19 ; ARY("CO","B",<code>,n)=""
+20 ; ARY("CO",n,"I")= 6 piece "^" delimited string
+21 ;
+22 ; 1 Status
+23 ; 2 Effective Date
+24 ; 3 Initial Activation Date
+25 ; 4 Pointer to CODES file #757.02
+26 ; 5 Coding System Nomenclature
+27 ; 6 Coding System
+28 ;
+29 ; ARY("CO",n,"MD")="Code Modifiers"
+30 ; ARY("CO",n,"MD",n)=<modifier>
+31 ; ARY("CO",n,"MD",n,"I")= 4 piece "^" delimited string
+32 ;
+33 ; 1 Status
+34 ; 2 Effective Date
+35 ; 3 Modifier Name
+36 ; 4 Pointer to CPT MODIFIER file #81.3
+37 ;
+38 ; ARY("CO",n,"VA")= 4 piece "^" delimited string
+39 ;
+40 ; 1 Status
+41 ; 2 Effective Date
+42 ; 3 VA File Number
+43 ; 4 Variable Pointer to VA File
+44 ;
+45 ; Diagnostic Categories (ICD-10-CM only)
+46 ;
+47 ; ARY("DC")="Diagnostic Categories"
+48 ; ARY("DC",1)=<category>
+49 ; ARY("DC",1,"I")= 4 piece "^" delimited string
+50 ;
+51 ; 1 Status
+52 ; 2 Effective Date
+53 ; 3 Category Name
+54 ; 4 Pointer to CHARACTER POSITIONS file #757.033
+55 ;
+56 ; Procedure Characters Positions (ICD-10-PCS only)
+57 ;
+58 ; Where n is a character position number 1-7
+59 ;
+60 ; ARY("CP")="Procedure Characters"
+61 ; ARY("CP","I")=<code>
+62 ; ARY("CP",n)=<character position 1-n>
+63 ; ARY("CP",n,"I")= 4 piece "^" delimited string
+64 ;
+65 ; 1 Status
+66 ; 2 Effective Date
+67 ; 3 Name
+68 ; 4 Pointer to CHARACTER POSITIONS file #757.033
+69 ;
+70 ; Terms
+71 ;
+72 ; Subscript SUB can be:
+73 ;
+74 ; PF Preferred Term
+75 ; FS Fully Specified Term
+76 ; MC Major Concept
+77 ; SY Synonyms
+78 ; LV Lexical Variants
+79 ; OR Orphan Text
+80 ;
+81 ; ARY(SUB)=type
+82 ; ARY(SUB,n)=<expression>
+83 ; ARY(SUB,n,"I")= 4 piece "^" delimited string
+84 ;
+85 ; 1 Status
+86 ; 2 Type
+87 ; 3 Current/Retired
+88 ; 4 Pointer to EXPRESSIONS file #757.01
+89 ;
+90 ; ARY(SUB,n,"ID")="Designation ID"
+91 ; ARY(SUB,n,"ID",n)<designation ID>
+92 ; ARY(SUB,n,"ID",n,"I")= 4 piece "^" delimited string
+93 ;
+94 ; 1 Status
+95 ; 2 Coding System
+96 ; 3 Hierarchy
+97 ; 4 Pointer to DESIGNATION CODE subfile #757.118
+98 ;
+99 ; ARY(SUB,n,"SK")="Supplemental Keywords"
+100 ; ARY(SUB,n,"SK",n)=<keyword>
+101 ; ARY(SUB,n,"SK",n,"I")= 4 piece "^" delimited string
+102 ;
+103 ; 1 Status
+104 ; 2 Not used
+105 ; 3 Not used
+106 ; 4 Pointer to SUPPLEMENTAL subfile #757.18
+107 ;
+108 ; Mappings
+109 ;
+110 ; ARY("MP")="Mapping"
+111 ; ARY("MP",n)=<map to target code>
+112 ; ARY("MP",n,"I")= 6 piece "^" delimited string
+113 ;
+114 ; 1 Status
+115 ; 2 Effective
+116 ; 3 Coding System
+117 ; 4 Pointer to MAPPINGS file #757.33
+118 ; 5 Match (full/partial)
+119 ; 6 Source Code
+120 ; 7 Source Coding System
+121 ;
+122 ; Subsets
+123 ;
+124 ; ARY("SB")="Subsets"
+125 ; ARY("SB",n)=<subset>
+126 ; ARY("SB",n,"I")= 5 piece "^" delimited string
+127 ;
+128 ; 1 Status
+129 ; 2 Pointer to SUBSET file #757.21
+130 ; 3 Pointer to EXPRESSION file #757.01
+131 ; 4 Pointer to SUBSET DEFINITION file #757.2
+132 ; 5 Subset ID
+133 ;
+134 ; Source
+135 ;
+136 ; ARY("SR")="Source"
+137 ; ARY("SR",n)=<source abbreviation>
+138 ; ARY("SR",n,"I")= 4 piece "^" delimited string
+139 ; ARY("SR","B",<source>,n)=""
+140 ;
+141 ; 1 Source Abbreviation
+142 ; 2 Source Nomenclature
+143 ; 3 Source Title
+144 ; 4 Pointer to CODING SYSTEMS file #757.03
+145 ;
+146 NEW LEXCDT,LEXEFF,LEXCODE,LEXDISP,LEXEIEN,LEXMIEN,LEXPF,LEXSIEN,LEXSRC,LEXST,LEXSYS,LEXTYPE
KILL ARY
SET LEXDISP=+($GET(OUT))
+147 SET LEXCODE=$GET(CODE)
SET LEXSRC=$GET(SRC)
SET LEXCDT=$GET(CDT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+148 if '$LENGTH(LEXSRC)&($LENGTH(LEXCODE))
SET LEXSRC=$$SRC^LEXINF(LEXCODE)
+149 if $GET(SRC)'?1N.N&($LENGTH($GET(SRC))=3)&($DATA(^LEX(757.03,"ASAB",$GET(SRC))))
SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",$GET(SRC),0))
+150 IF '$LENGTH(LEXCODE)!(+LEXSRC'>0)
KILL ARY
QUIT
+151 DO CO(LEXCODE,LEXSRC,LEXCDT,.ARY)
SET LEXSIEN=$PIECE($GET(ARY("CO",1,"I")),"^",4)
SET LEXMIEN=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",4)
+152 SET LEXEIEN=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",1)
IF LEXSIEN'>0!(LEXMIEN'>0)!(LEXEIEN'>0)
KILL ARY
QUIT
+153 DO PF(LEXCODE,.ARY)
SET LEXPF=$PIECE($GET(ARY("PF",1,"I")),"^",4)
IF LEXPF'>0
KILL ARY
QUIT
+154 DO OT(LEXEIEN,LEXPF,.ARY)
DO SB(LEXCODE,LEXSRC,.ARY)
DO MP(LEXCODE,LEXSRC,LEXCDT,.ARY)
+155 IF +($GET(LEXDISP))>0
DO CODE^LEXINF5(.ARY)
+156 QUIT
CO(X,Y,CDT,ARY) ; Code CO
+1 NEW LEXCDT,LEXCODE,LEXEFF,LEXIEN,LEXINIT,LEXNOM,LEXSAB,LEXSRC,LEXST,LEXSTAT,LEXSYS,LEXTTL
if '$LENGTH(X)
QUIT
if '$LENGTH(Y)
QUIT
+2 KILL ARY("CO"),ARY("SR")
SET LEXCODE=$GET(X)
SET LEXSYS=$GET(Y)
SET LEXSRC=""
+3 if $GET(LEXSYS)?1N.N&($DATA(^LEX(757.03,+($GET(LEXSYS)),0)))
SET LEXSRC=+($GET(LEXSYS))
+4 if $GET(LEXSYS)'?1N.N&($LENGTH($GET(LEXSYS))=3)&($DATA(^LEX(757.03,"ASAB",$GET(LEXSYS))))
SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",$GET(LEXSYS)))
+5 if LEXSRC'?1N.N
QUIT
DO SR(LEXSRC)
if $LENGTH($GET(LEXSAB))'=3
QUIT
if '$LENGTH($GET(LEXNOM))
QUIT
if '$LENGTH($GET(LEXTTL))
QUIT
+6 SET LEXCDT=$GET(CDT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
SET LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXCDT,,LEXSAB)
+7 SET LEXST=+LEXSTAT
SET LEXIEN=$PIECE(LEXSTAT,"^",2)
SET LEXEFF=$PIECE(LEXSTAT,"^",3)
SET LEXINIT=$PIECE(LEXSTAT,"^",4)
+8 if LEXEFF?7N&(LEXINIT'?7N)
SET LEXINIT=LEXEFF
SET ARY("CO",1)=LEXCODE
+9 SET ARY("CO")="Code"
SET ARY("CO",1,"I")=+LEXSTAT_"^"_LEXEFF_"^"_LEXINIT_"^"_LEXIEN_"^"_LEXNOM_"^"_LEXSRC
+10 SET ARY("CO","B",LEXSRC,1)=""
if "^1^2^3^4^30^31^"[("^"_LEXSRC_"^")
DO VA^LEXINF3(LEXCODE,LEXSRC,LEXCDT,1,.ARY)
+11 SET ARY("SR")="Source"
SET ARY("SR",1)=LEXSAB
SET ARY("SR",1,"I")=LEXSAB_"^"_LEXNOM_"^"_LEXTTL_"^"_LEXSRC
+12 SET ARY("SR","B",LEXSRC,1)=""
+13 if LEXSRC=3!(LEXSRC=4)
DO MD^LEXINF3(LEXCODE,LEXCDT,1,.ARY)
+14 if LEXSRC=30
DO DC(LEXCODE,LEXCDT,.ARY)
if LEXSRC=31
DO CP(LEXCODE,LEXCDT,.ARY)
+15 QUIT
MD(X,Y,I,ARY) ; Modifiers CO/MD
+1 DO MD^LEXINF3($GET(X),$GET(Y),$GET(I),.ARY)
+2 QUIT
VA(X,Y,D,I,ARY) ; VA File CO/VA
+1 DO VA^LEXINF3($GET(X),$GET(Y),$GET(D),$GET(I),.ARY)
+2 QUIT
PF(CODE,ARY) ; Preferred Term PF
+1 NEW LEXCODE,LEXEFF,LEXEIEN,LEXEXP,LEXND,LEXSIEN,LEXSTA,LEXSTAT,LEXTY
KILL ARY("PF")
SET LEXCODE=$GET(CODE)
if '$LENGTH(LEXCODE)
QUIT
+2 SET LEXEFF=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),3," "),-1)
if LEXEFF'?7N
QUIT
+3 SET LEXSIEN=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),3,+LEXEFF," "),-1)
if +LEXSIEN'>0
QUIT
+4 SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
if $PIECE(LEXND,"^",5)'>0
QUIT
SET LEXEIEN=+LEXND
if LEXEIEN'>0
QUIT
+5 SET LEXEXP=$GET(^LEX(757.01,+LEXEIEN,0))
if '$LENGTH(LEXEXP)
QUIT
SET LEXND=$GET(^LEX(757.01,+LEXEIEN,1))
+6 SET LEXSTA=$PIECE(LEXND,"^",5)
SET LEXSTA=$SELECT(LEXSTA=1:0,1:1)
SET LEXSTAT=$SELECT(LEXSTA'>0:"Retired",1:"Current")
+7 SET LEXTY=$PIECE(LEXND,"^",2)
SET LEXTY=$SELECT(LEXTY=1:"Major Concept",LEXTY=3:"Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
+8 SET ARY("PF")="Preferred Term"
SET ARY("PF",1)=LEXEXP
SET ARY("PF",1,"I")=LEXSTA_"^"_LEXTY_"^"_LEXSTAT_"^"_+LEXEIEN
+9 DO DS("PF",1,+LEXEIEN,.ARY)
DO SK("PF",1,+LEXEIEN,.ARY)
DO NG("PF",1,+LEXEIEN,.ARY)
+10 QUIT
OT(X,LEX,ARY) ; Other Terms MC/FS/SY/LV
+1 NEW LEXEIEN,LEXEX,LEXEXP,LEXMC,LEXND,LEXPF,LEXSEQ,LEXSTA,LEXTN,LEXTS,LEXTY
KILL ARY("FS")
SET LEXEIEN=$GET(X)
+2 if LEXEIEN'>0
QUIT
SET LEXMC=+($GET(^LEX(757.01,+LEXEIEN,1)))
if '$DATA(^LEX(757,+LEXMC,0))
QUIT
+3 if '$DATA(^LEX(757.01,"AMC",+LEXMC))
QUIT
SET LEXPF=+($GET(LEX))
if LEXPF'>0
QUIT
if '$DATA(^LEX(757.01,LEXPF,0))
QUIT
+4 SET LEXEX=0
FOR
SET LEXEX=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXEX))
if +LEXEX'>0
QUIT
Begin DoDot:1
+5 NEW LEXEXP,LEXND,LEXSEQ,LEXSTA,LEXSTAT,LEXTN,LEXTS,LEXTY
SET LEXEXP=$GET(^LEX(757.01,+LEXEX,0))
+6 if '$LENGTH(LEXEXP)
QUIT
SET LEXND=$GET(^LEX(757.01,+LEXEX,1))
SET LEXSTA=$PIECE(LEXND,"^",5)
+7 SET LEXSTA=$SELECT(LEXSTA=1:0,1:1)
SET LEXTY=$PIECE(LEXND,"^",2)
SET LEXSTAT=$SELECT(LEXSTA'>0:"Retired",1:"Current")
+8 SET LEXTN=$SELECT(LEXTY=1:"Major Concept",LEXTY=3:"Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
+9 SET LEXTS=$SELECT(LEXTY=1:"MC",LEXTY=3:"LV",LEXTY=8:"FS",1:"SY")
+10 SET LEXSEQ=$ORDER(ARY(LEXTS," "),-1)+1
SET ARY(LEXTS,LEXSEQ)=LEXEXP
SET ARY(LEXTS)=LEXTN
+11 SET ARY(LEXTS,LEXSEQ,"I")=LEXSTA_"^"_LEXTN_"^"_$SELECT(LEXSTA'>0:"Retired",1:"Current")_"^"_+LEXEX
+12 DO DS(LEXTS,LEXSEQ,+LEXEX,.ARY)
DO SK(LEXTS,LEXSEQ,+LEXEX,.ARY)
DO NG(LEXTS,LEXSEQ,+LEXEX,.ARY)
End DoDot:1
+13 QUIT
DS(X,Y,LEX,ARY) ; Designation ID ID
+1 NEW LEXC,LEXDSI,LEXH,LEXHN,LEXIEN,LEXIN,LEXND,LEXS,LEXSB,LEXSEQ,LEXSTA,LEXSYS
+2 SET LEXSB=$GET(X)
if '$LENGTH(LEXSB)
QUIT
SET LEXIN=$GET(Y)
if LEXIN'>0
QUIT
SET LEXIEN=$GET(LEX)
if LEXIEN'>0
QUIT
+3 SET LEXSTA=+($GET(ARY(LEXSB,LEXIN,"I")))
SET LEXDSI=0
FOR
SET LEXDSI=$ORDER(^LEX(757.01,+LEXIEN,7,LEXDSI))
if +LEXDSI'>0
QUIT
Begin DoDot:1
+4 NEW LEXC,LEXH,LEXHN,LEXND,LEXS,LEXSEQ,LEXSYS
SET LEXND=$GET(^LEX(757.01,LEXIEN,7,LEXDSI,0))
+5 SET LEXC=$PIECE(LEXND,"^",1)
if '$LENGTH(LEXC)
QUIT
SET LEXS=$PIECE(LEXND,"^",2)
if +LEXS'>0
QUIT
+6 SET LEXSYS=$PIECE($GET(^LEX(757.03,+LEXS,0)),"^",2)
SET LEXH=$PIECE(LEXND,"^",3)
+7 SET LEXHN=$PIECE($GET(^LEX(757.018,+LEXH,0)),"^",1)
SET LEXSEQ=$ORDER(ARY(LEXSB,LEXIN,"ID"," "),-1)+1
+8 SET ARY(LEXSB,LEXIN,"ID")="Designation ID"
+9 SET ARY(LEXSB,LEXIN,"ID",LEXSEQ)=LEXC
+10 SET ARY(LEXSB,LEXIN,"ID",LEXSEQ,"I")=LEXSTA_"^"_LEXSYS_"^"_LEXHN_"^"_+LEXDSI
End DoDot:1
+11 QUIT
SK(X,Y,LEX,ARY) ; Supplemental Keywords SK
+1 NEW LEXC,LEXSKI,LEXH,LEXHN,LEXIEN,LEXIN,LEXND,LEXS,LEXSB,LEXSEQ,LEXSTA,LEXSYS
+2 SET LEXSB=$GET(X)
if '$LENGTH(LEXSB)
QUIT
SET LEXIN=$GET(Y)
if LEXIN'>0
QUIT
SET LEXIEN=$GET(LEX)
if LEXIEN'>0
QUIT
+3 SET LEXSTA=+($GET(ARY(LEXSB,LEXIN,"I")))
SET LEXSKI=0
FOR
SET LEXSKI=$ORDER(^LEX(757.01,+LEXIEN,5,LEXSKI))
if +LEXSKI'>0
QUIT
Begin DoDot:1
+4 NEW LEXK,LEXH,LEXHN,LEXND,LEXS,LEXSEQ,LEXSYS
SET LEXND=$GET(^LEX(757.01,LEXIEN,5,LEXSKI,0))
+5 SET LEXK=$PIECE(LEXND,"^",1)
if '$LENGTH(LEXK)
QUIT
SET LEXSEQ=$ORDER(ARY(LEXSB,LEXIN,"SK"," "),-1)+1
+6 SET ARY(LEXSB,LEXIN,"SK")="Supplemental Keywords"
+7 SET ARY(LEXSB,LEXIN,"SK",LEXSEQ)=LEXK
+8 SET ARY(LEXSB,LEXIN,"SK",LEXSEQ,"I")=LEXSTA_"^^^"_+LEXSKI
End DoDot:1
+9 QUIT
NG(X,Y,LEX,ARY) ; Negations NG
+1 NEW LEXC,LEXNGI,LEXH,LEXHN,LEXIEN,LEXIN,LEXND,LEXS,LEXSB,LEXSEQ,LEXSTA,LEXSYS
+2 SET LEXSB=$GET(X)
if '$LENGTH(LEXSB)
QUIT
SET LEXIN=$GET(Y)
if LEXIN'>0
QUIT
SET LEXIEN=$GET(LEX)
if LEXIEN'>0
QUIT
+3 SET LEXSTA=+($GET(ARY(LEXSB,LEXIN,"I")))
SET LEXNGI=0
FOR
SET LEXNGI=$ORDER(^LEX(757.01,+LEXIEN,4,LEXNGI))
if +LEXNGI'>0
QUIT
Begin DoDot:1
+4 NEW LEXK,LEXH,LEXHN,LEXND,LEXS,LEXSEQ,LEXSYS
SET LEXND=$GET(^LEX(757.01,LEXIEN,4,LEXNGI,0))
+5 SET LEXK=$PIECE(LEXND,"^",1)
if '$LENGTH(LEXK)
QUIT
SET LEXSEQ=$ORDER(ARY(LEXSB,LEXIN,"NG"," "),-1)+1
+6 SET ARY(LEXSB,LEXIN,"NG")="Negations"
+7 SET ARY(LEXSB,LEXIN,"NG",LEXSEQ)=LEXK
+8 SET ARY(LEXSB,LEXIN,"NG",LEXSEQ,"I")=LEXSTA_"^^^"_+LEXNGI
End DoDot:1
+9 QUIT
SR(SRC) ; Source SR
+1 SET LEXSAB=$PIECE($GET(^LEX(757.03,+($GET(SRC)),0)),"^",1)
if $LENGTH(LEXSAB)'=3
QUIT
+2 SET LEXNOM=$PIECE($GET(^LEX(757.03,+($GET(SRC)),0)),"^",2)
if '$LENGTH(LEXNOM)
QUIT
+3 SET LEXTTL=$PIECE($GET(^LEX(757.03,+($GET(SRC)),0)),"^",3)
if '$LENGTH(LEXTTL)
QUIT
+4 QUIT
OR(X,Y,CDT,ARY) ; Orphan Text OR
+1 NEW LEXCDT,LEXCODE,LEXEIEN,LEXEXP,LEXND,LEXSEQ,LEXSIEN,LEXSRC,LEXSTA,LEXSTAT,LEXTY
KILL ARY("OR")
+2 SET LEXCODE=$GET(X)
SET LEXSYS=$GET(Y)
SET LEXSRC=""
if $GET(LEXSYS)?1N.N&($DATA(^LEX(757.03,+($GET(LEXSYS)),0)))
SET LEXSRC=+($GET(LEXSYS))
+3 if $GET(LEXSYS)'?1N.N&($LENGTH($GET(LEXSYS))=3)&($DATA(^LEX(757.03,"ASAB",$GET(LEXSYS))))
SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",$GET(LEXSYS)))
+4 if LEXSRC'?1N.N
QUIT
SET LEXCDT=$GET(CDT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+5 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXCODE_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+6 NEW LEXEF,LEXEIEN,LEXEXP,LEXHS,LEXND,LEXSEQ,LEXST,LEXSTA,LEXSTAT,LEXTY
+7 SET LEXEF=$ORDER(^LEX(757.02,+LEXSIEN,"4","B",(LEXCDT+.00001)),-1)
+8 SET LEXHS=$ORDER(^LEX(757.02,+LEXSIEN,"4","B",+LEXEF," "),-1)
+9 SET LEXST=$PIECE($GET(^LEX(757.02,+LEXSIEN,"4",+LEXHS,0)),"^",2)
+10 SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
if $PIECE(LEXND,"^",5)>0
QUIT
if $PIECE(LEXND,"^",3)'=+($GET(LEXSRC))
QUIT
+11 SET LEXEIEN=+LEXND
SET LEXEXP=$GET(^LEX(757.01,+LEXEIEN,0))
SET LEXND=$GET(^LEX(757.01,+LEXEIEN,1))
if $PIECE(LEXND,"^",4)'=10
QUIT
+12 SET LEXTY="VA Derived"
SET LEXSTA=$PIECE(LEXND,"^",5)
SET LEXSTAT="Current"
if LEXSTA>0
SET LEXSTAT="Retired"
+13 if LEXST'>0
SET LEXSTAT="Inactive"
+14 SET LEXSTA=$SELECT(+($GET(LEXST))'>0!(+($GET(LEXSTA))>0):"0",1:1)
+15 SET LEXSEQ=$ORDER(ARY("OR"," "),-1)+1
SET ARY("OR")="Orphan Text"
SET ARY("OR",LEXSEQ)=LEXEXP
+16 SET ARY("OR",LEXSEQ,"I")=LEXSTA_"^"_LEXTY_"^"_LEXSTAT_"^"_+LEXEIEN
End DoDot:1
+17 QUIT
SB(X,Y,ARY) ; Subsets SB
+1 KILL LEX
NEW LEXIENS,LEXEX,LEXMC,LEXIEN,LEXSO,LEXSIEN,LEXSRC,LEXSYS
SET LEXSO=$GET(X)
if '$LENGTH(LEXSO)
QUIT
SET LEXSYS=$GET(Y)
if '$LENGTH($GET(LEXSYS))
QUIT
+2 SET LEXSRC=""
if $GET(LEXSYS)?1N.N&($DATA(^LEX(757.03,+($GET(LEXSYS)),0)))
SET LEXSRC=+($GET(LEXSYS))
+3 if $GET(LEXSYS)'?1N.N&($LENGTH($GET(LEXSYS))=3)&($DATA(^LEX(757.03,"ASAB",$GET(LEXSYS))))
SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",$GET(LEXSYS)))
+4 if '$DATA(^LEX(757.03,+LEXSRC,0))
QUIT
SET (LEXST,LEXMC)=""
SET LEXSIEN=0
+5 SET LEXEFF=" "
FOR
SET LEXEFF=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEFF),-1)
if '$LENGTH(LEXEFF)
QUIT
Begin DoDot:1
+6 NEW LEXSIEN
SET LEXSIEN=" "
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEFF,LEXSIEN),-1)
if +LEXSIEN'>0
QUIT
Begin DoDot:2
+7 NEW LEXND,LEXEF,LEXHS
SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
if $PIECE(LEXND,"^",3)'=LEXSRC
QUIT
if $PIECE(LEXND,"^",5)'>0
QUIT
+8 SET LEXEF=$ORDER(^LEX(757.02,+LEXSIEN,"4","B",(LEXCDT+.00001)),-1)
+9 SET LEXHS=$ORDER(^LEX(757.02,+LEXSIEN,"4","B",+LEXEF," "),-1)
+10 SET LEXST=$PIECE($GET(^LEX(757.02,+LEXSIEN,"4",+LEXHS,0)),"^",2)
+11 SET LEXMC=$PIECE(LEXND,"^",4)
End DoDot:2
if LEXMC>0
QUIT
End DoDot:1
if LEXMC>0
QUIT
+12 if +LEXMC'>0
QUIT
if LEXST'?1N
QUIT
SET LEXEX=+($GET(^LEX(757,+LEXMC,0)))
IF $DATA(^LEX(757.21,"B",+LEXEX))
Begin DoDot:1
+13 SET LEXIEN=LEXEX
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.21,"B",+LEXEX,LEXSIEN))
if LEXSIEN'>0
QUIT
Begin DoDot:2
+14 NEW LEXND,LEXSI,LEXSA,LEXSF,LEXSTR,LEXSEQ
+15 SET LEXSI=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
SET LEXND=$GET(^LEXT(757.2,+LEXSI,0))
+16 SET LEXSA=$PIECE(LEXND,"^",2)
SET LEXSF=$$MIX^LEXXM($PIECE(LEXND,"^",1))
+17 SET LEXSTR=+($GET(LEXST))
if +LEXSIEN>0
SET $PIECE(LEXSTR,"^",2)=+LEXSIEN
if +LEXEX>0
SET $PIECE(LEXSTR,"^",3)=+LEXEX
+18 if +LEXSI>0
SET $PIECE(LEXSTR,"^",4)=+LEXSI
if $LENGTH(LEXSA)
SET $PIECE(LEXSTR,"^",5)=LEXSA
SET ARY("SB")="Subsets"
+19 SET LEXSEQ=$ORDER(ARY("SB"," "),-1)+1
SET ARY("SB",LEXSEQ)=LEXSF
SET ARY("SB",LEXSEQ,"I")=LEXSTR
End DoDot:2
End DoDot:1
QUIT
+20 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+21 if $PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)>0
QUIT
SET LEXIENS(LEXIEN)=""
End DoDot:1
+22 if $ORDER(LEXIENS(0))'>0
QUIT
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(LEXIENS(LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+23 if '$DATA(^LEX(757.21,"B",LEXIEN))
QUIT
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.21,"B",LEXIEN,LEXSIEN))
if LEXSIEN'>0
QUIT
Begin DoDot:2
+24 NEW LEXND,LEXSI,LEXSA,LEXSF,LEXSTR,LEXSEQ
+25 SET LEXSI=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
SET LEXND=$GET(^LEXT(757.2,+LEXSI,0))
+26 SET LEXSA=$PIECE(LEXND,"^",2)
SET LEXSF=$$MIX^LEXXM($PIECE(LEXND,"^",1))
+27 SET LEXSTR=+($GET(LEXST))
if +LEXSIEN>0
SET $PIECE(LEXSTR,"^",2)=+LEXSIEN
if +LEXIEN>0
SET $PIECE(LEXSTR,"^",3)=+LEXIEN
+28 if +LEXSI>0
SET $PIECE(LEXSTR,"^",4)=+LEXSI
if $LENGTH(LEXSA)
SET $PIECE(LEXSTR,"^",5)=LEXSA
SET ARY("SB")="Subsets"
+29 SET LEXSEQ=$ORDER(ARY("SB"," "),-1)+1
SET ARY("SB",LEXSEQ)=LEXSF
SET ARY("SB",LEXSEQ,"I")=LEXSTR
End DoDot:2
End DoDot:1
+30 QUIT
MP(X,Y,CDT,ARY) ; Mappings MP
+1 NEW LEXCDT,LEXCODE,LEXSRC,LEXTO
SET LEXCODE=$GET(X)
SET LEXSYS=$GET(Y)
KILL ARY("MP")
if '$LENGTH(LEXCODE)
QUIT
if '$LENGTH(LEXSYS)
QUIT
+2 SET LEXSRC=""
if $GET(LEXSYS)?1N.N&($DATA(^LEX(757.03,+($GET(LEXSYS)),0)))
SET LEXSRC=+($GET(LEXSYS))
+3 if $GET(LEXSYS)'?1N.N&($LENGTH($GET(LEXSYS))=3)&($DATA(^LEX(757.03,"ASAB",$GET(LEXSYS))))
SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",$GET(LEXSYS)))
+4 if '$DATA(^LEX(757.03,+LEXSRC,0))
QUIT
if LEXCODE="R69."&(LEXSRC=30)
QUIT
SET LEXCDT=$GET(CDT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+5 SET LEXTO=""
FOR
SET LEXTO=$ORDER(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO))
if '$LENGTH(LEXTO)
QUIT
Begin DoDot:1
+6 NEW LEXEF,LEXMCODE,LEXMDEF,LEXMIEN,LEXMMAT,LEXMNOM,LEXMSSY,LEXMTSY,LEXND,LEXSEQ,LEXST,LEXSTR
+7 SET LEXEF=$ORDER(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO,(LEXCDT+.0001)),-1)
if '$LENGTH(LEXEF)
QUIT
+8 SET LEXST=$ORDER(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO,LEXEF," "),-1)
if '$LENGTH(LEXST)
QUIT
+9 SET LEXMIEN=$ORDER(^LEX(757.33,"ACT",(LEXCODE_" "),LEXTO,LEXEF,+LEXST," "),-1)
if +LEXMIEN'>0
QUIT
+10 SET LEXND=$GET(^LEX(757.33,+LEXMIEN,0))
SET LEXMCODE=$PIECE(LEXND,"^",3)
SET LEXMMAT=$PIECE(LEXND,"^",5)
+11 SET LEXMMAT=$SELECT(+LEXMMAT>0:"Full",1:"Part")
SET LEXMDEF=$PIECE(LEXND,"^",4)
+12 SET LEXMSSY=$PIECE($GET(^LEX(757.32,+LEXMDEF,2)),"^",1)
if LEXMSSY'=LEXSRC
QUIT
+13 SET LEXMTSY=$PIECE($GET(^LEX(757.32,+LEXMDEF,2)),"^",2)
SET LEXMNOM=$PIECE($GET(^LEX(757.03,+LEXMTSY,0)),"^",2)
+14 SET LEXSTR=+LEXST
SET $PIECE(LEXSTR,"^",2)=LEXEF
if $LENGTH(LEXMNOM)
SET $PIECE(LEXSTR,"^",3)=LEXMNOM
+15 if +LEXMIEN>0
SET $PIECE(LEXSTR,"^",4)=+LEXMIEN
if $LENGTH(LEXMMAT)
SET $PIECE(LEXSTR,"^",5)=LEXMMAT
+16 SET $PIECE(LEXSTR,"^",6)=LEXCODE
SET $PIECE(LEXSTR,"^",7)=LEXMSSY
SET ARY("MP")="Mapping"
+17 SET LEXSEQ=$ORDER(ARY("MP"," "),-1)+1
SET ARY("MP",LEXSEQ)=LEXMCODE
SET ARY("MP",LEXSEQ,"I")=LEXSTR
End DoDot:1
+18 QUIT
DC(X,CDT,ARY) ; Diagnostic Categories DC
+1 KILL ARY("DC")
NEW LEXCDT,LEXCID,LEXCODE,LEXI
SET LEXCDT=$GET(CDT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+2 SET LEXCODE=$GET(X)
SET LEXCID="10D"
FOR LEXI=1:1
if '$LENGTH($EXTRACT(LEXCODE,LEXI))
QUIT
Begin DoDot:1
+3 NEW LEXCAT,LEXCIEN,LEXEF,LEXHS,LEXSEQ,LEXST,LEXSTR,LEXTD,LEXTH,LEXTX
SET LEXCID=LEXCID_$EXTRACT(LEXCODE,LEXI)
+4 SET LEXCIEN=$ORDER(^LEX(757.033,"B",LEXCID,0))
if +LEXCIEN'>0
QUIT
SET LEXCAT=$PIECE(LEXCID,"10D",2)
+5 SET LEXEF=$ORDER(^LEX(757.033,+LEXCIEN,1,"B",(LEXCDT+.0001)),-1)
SET LEXHS=$ORDER(^LEX(757.033,+LEXCIEN,1,"B",+LEXEF," "),-1)
+6 SET LEXST=$PIECE($GET(^LEX(757.033,+LEXCIEN,1,+LEXHS,0)),"^",2)
SET LEXTD=$ORDER(^LEX(757.033,+LEXCIEN,2,"B",(LEXCDT+.0001)),-1)
+7 SET LEXTH=$ORDER(^LEX(757.033,+LEXCIEN,2,"B",+LEXTD," "),-1)
SET LEXTX=$PIECE($GET(^LEX(757.033,+LEXCIEN,2,+LEXTH,1)),"^",1)
+8 SET LEXSTR=LEXST
if LEXEF?7N
SET $PIECE(LEXSTR,"^",2)=LEXEF
if $LENGTH(LEXTX)
SET $PIECE(LEXSTR,"^",3)=LEXTX
SET $PIECE(LEXSTR,"^",4)=+LEXCIEN
+9 SET LEXSEQ=$ORDER(ARY("DC"," "),-1)+1
SET ARY("DC",LEXSEQ)=LEXCAT
SET ARY("DC",LEXSEQ,"I")=LEXSTR
+10 SET ARY("DC")="Diagnostic Categories"
SET ARY("DC","I")=LEXCODE
End DoDot:1
+11 QUIT
CP(X,CDT,ARY) ; Character Positions CP
+1 KILL ARY("CP")
NEW LEXCDT,LEXCID,LEXCODE,LEXI
SET LEXCDT=$GET(CDT)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+2 SET LEXCODE=$GET(X)
SET LEXCID="10P"
FOR LEXI=1:1
if '$LENGTH($EXTRACT(LEXCODE,LEXI))
QUIT
Begin DoDot:1
+3 NEW LEXCAT,LEXCIEN,LEXEF,LEXHS,LEXSEQ,LEXST,LEXSTR,LEXTD,LEXTH,LEXTX
SET LEXCID=LEXCID_$EXTRACT(LEXCODE,LEXI)
+4 SET LEXCIEN=$ORDER(^LEX(757.033,"B",LEXCID,0))
if +LEXCIEN'>0
QUIT
SET LEXCAT=$PIECE(LEXCID,"10P",2)
+5 SET LEXEF=$ORDER(^LEX(757.033,+LEXCIEN,1,"B",(LEXCDT+.0001)),-1)
SET LEXHS=$ORDER(^LEX(757.033,+LEXCIEN,1,"B",+LEXEF," "),-1)
+6 SET LEXST=$PIECE($GET(^LEX(757.033,+LEXCIEN,1,+LEXHS,0)),"^",2)
SET LEXTD=$ORDER(^LEX(757.033,+LEXCIEN,2,"B",(LEXCDT+.0001)),-1)
+7 SET LEXTH=$ORDER(^LEX(757.033,+LEXCIEN,2,"B",+LEXTD," "),-1)
SET LEXTX=$PIECE($GET(^LEX(757.033,+LEXCIEN,2,+LEXTH,1)),"^",1)
+8 SET LEXSTR=LEXST
if LEXEF?7N
SET $PIECE(LEXSTR,"^",2)=LEXEF
if $LENGTH(LEXTX)
SET $PIECE(LEXSTR,"^",3)=LEXTX
SET $PIECE(LEXSTR,"^",4)=+LEXCIEN
+9 SET LEXSEQ=$ORDER(ARY("CP"," "),-1)+1
SET ARY("CP",LEXSEQ)=LEXCAT
SET ARY("CP",LEXSEQ,"I")=LEXSTR
+10 SET ARY("CP")="Procedure Characters"
SET ARY("CP","I")=LEXCODE
End DoDot:1
+11 QUIT
