LEXINF3 ;ISL/KER - Information - Term ;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
;
TERM(IEN,CDT,ARY,OUT) ; Information about a Term
;
; Input
;
; IEN Expression IEN (file 757.01)
; CDT Date used to determine status, default TODAY
; 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:
;
; MC Major Concept
; FS Fully Specified Term
; 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","B",<source>,n)=""
; ARY("SR",n,"I")= 4 piece "^" delimited string
;
; 1 Source Abbreviation
; 2 Source Nomenclature
; 3 Source Title
; 4 Pointer to CODING SYSTEMS file #757.03
;
N LEXEFF,LEXD,LEXDISP,LEXEIEN,LEXMIEN,LEXST,LEXSYS,LEXTYPE K ARY S LEXDISP=$G(OUT),LEXEIEN=$G(IEN),LEXD=$G(CDT) S:LEXD'?7N LEXD=$$DT^XLFDT
S LEXMIEN=$P($G(^LEX(757.01,+LEXEIEN,1)),"^",1) I '$D(^LEX(757.01,+LEXEIEN,0)) K ARY Q
D CO(LEXEIEN,LEXD,.ARY),EX(LEXEIEN,.ARY),SB(LEXEIEN,.ARY) D:+($G(LEXDISP))>0&($O(ARY("MC",0))>0) TERM^LEXINF5(.ARY)
Q
CO(X,CDT,ARY) ; Codes CO
N LEXCODE,LEXEF,LEXEIEN,LEXHS,LEXIEN,LEXINIT,LEXND,LEXNOM,LEXSAB,LEXSEQ,LEXSIEN,LEXSO,LEXSRC,LEXST,LEXTMP,LEXTTL
K ARY("CO"),ARY("SR") S LEXEIEN=$G(X),LEXMIEN=+($G(^LEX(757.01,+LEXEIEN,1))) Q:+LEXMIEN'>0 S LEXD=$G(CDT) S:LEXD'?7N LEXD=$$DT^XLFDT
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"AMC",LEXMIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXCODE,LEXEF,LEXHS,LEXIEN,LEXINIT,LEXND,LEXNOM,LEXSAB,LEXSRC,LEXST,LEXTMP,LEXTTL S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0
. S LEXIEN=+LEXND Q:LEXIEN'>0 S LEXEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXD+.0001)),-1),LEXHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1)
. S LEXST=$P($G(^LEX(757.02,+LEXSIEN,4,+LEXHS,0)),"^",2) Q:LEXST'>0 S LEXCODE=$P(LEXND,"^",2) Q:'$L(LEXCODE) S LEXSRC=$P(LEXND,"^",3) Q:LEXSRC'>0
. S LEXSAB=$P($G(^LEX(757.03,+LEXSRC,0)),"^",1) Q:$L(LEXSAB)'=3 S LEXNOM=$P($G(^LEX(757.03,+LEXSRC,0)),"^",2) Q:'$L(LEXNOM)
. S LEXTTL=$P($G(^LEX(757.03,+LEXSRC,0)),"^",3) Q:'$L(LEXTTL) S LEXTMP=$$STATCHK^LEXSRC2(LEXCODE,LEXD,,LEXSAB),LEXINIT=$P(LEXTMP,"^",4)
. S LEXSO(LEXCODE,LEXSRC)=LEXSIEN_"^"_LEXIEN_"^"_LEXST_"^"_LEXEF_"^"_LEXSAB_"^"_LEXNOM_"^"_LEXTTL_"^"_LEXINIT
S LEXCODE="" F S LEXCODE=$O(LEXSO(LEXCODE)) Q:'$L(LEXCODE) S LEXSRC=0 F S LEXSRC=$O(LEXSO(LEXCODE,LEXSRC)) Q:+LEXSRC'>0 D
. N LEXEF,LEXEIEN,LEXINIT,LEXND,LEXNOM,LEXSAB,LEXSEQ,LEXSIEN,LEXST,LEXTTL S LEXND=$G(LEXSO(LEXCODE,LEXSRC))
. S LEXSIEN=+LEXND Q:LEXSIEN'>0 S LEXEIEN=$P(LEXND,"^",2) Q:LEXEIEN'>0 S LEXST=$P(LEXND,"^",3) Q:LEXST'?1N
. S LEXEF=$P(LEXND,"^",4) Q:LEXEF'?7N S LEXSAB=$P(LEXND,"^",5) Q:$L(LEXSAB)'=3 S LEXNOM=$P(LEXND,"^",6) Q:'$L(LEXNOM)
. S LEXTTL=$P(LEXND,"^",7) Q:'$L(LEXTTL) S LEXINIT=$P(LEXND,"^",7) S:LEXINIT'?7N LEXINIT="" S:LEXEF?7N&(LEXINIT'?7N) LEXINIT=LEXEF
. S LEXSEQ=$O(ARY("CO"," "),-1)+1 S ARY("CO")="Code",ARY("CO",LEXSEQ)=LEXCODE,ARY("CO",LEXSEQ,"I")=+LEXST_"^"_LEXEF_"^"_LEXINIT_"^"_LEXSIEN_"^"_LEXNOM_"^"_LEXSRC
. D:LEXSRC=3!(LEXSRC=4) MD(LEXCODE,LEXCDT,LEXSEQ,.ARY)
. D:"^1^2^3^4^30^31^"[("^"_LEXSRC_"^") VA(LEXCODE,LEXSRC,LEXD,LEXSEQ,.ARY) S ARY("CO","B",LEXSRC,LEXSEQ)="" I '$D(ARY("SR","B",LEXSRC)) D
. . N LEXSEQ S ARY("SR")="Source",LEXSEQ=$O(ARY("SR"," "),-1)+1 S ARY("SR",LEXSEQ)=LEXSAB S ARY("SR",LEXSEQ,"I")=LEXSAB_"^"_LEXNOM_"^"_LEXTTL_"^"_LEXSRC
. . S ARY("SR","B",LEXSRC,LEXSEQ)=""
. D MP(LEXCODE,LEXSRC,LEXD,.ARY) D:LEXSRC=30 OR(LEXCODE,LEXSRC,LEXD,.ARY) D:LEXSRC=30 DC(LEXCODE,LEXD,.ARY) D:LEXSRC=31 CP(LEXCODE,LEXD,.ARY)
Q
MD(X,Y,IEN,ARY) ; Modifiers CO/MD
N LEXCODE,LEXCDT,LEXCPT,LEXENT,LEXO,LEXST,LEXEF,LEXDS,LEXIE
S LEXCODE=$G(X),LEXCDT=$G(Y) Q:$L(LEXCODE)'=5 S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXENT=$G(IEN) Q:LEXENT'>0 D MODA^ICPTMOD(LEXCODE,LEXCDT,.LEXCPT)
S LEXO="" F S LEXO=$O(LEXCPT("A",LEXO)) Q:'$L(LEXO) D
. N LEXND,LEXIE,LEXDS,LEXAR,LEXIR,LEXEF,LEXSEQ
. S LEXEF="",LEXND=$G(LEXCPT("A",LEXO))
. S LEXIE=+($P(LEXND,"^",1)) Q:'$D(^DIC(81.3,+LEXIE,0)) Q:$P($G(^DIC(81.3,+LEXIE,0)),"^",1)'=LEXO
. S LEXDS=$P(LEXND,"^",2) Q:'$L(LEXDS)
. S LEXAR=$P(LEXND,"^",6),LEXIR=$P(LEXND,"^",7)
. S:LEXAR?7N&('$L(LEXIR)) LEXST=1,LEXEF=LEXAR
. S:LEXAR?7N&(LEXIR?7N)&(LEXIR'<LEXAR) LEXST=0,LEXEF=LEXIR
. S:LEXAR?7N&(LEXIR?7N)&(LEXIR<LEXAR) LEXST=1,LEXEF=LEXAR
. Q:LEXEF'?7N
. S LEXSEQ=$O(ARY("CO",LEXENT,"MD"," "),-1)+1
. S ARY("CO",LEXENT,"MD")="Code Modifiers"
. S ARY("CO",LEXENT,"MD",LEXSEQ)=LEXO
. S ARY("CO",LEXENT,"MD",LEXSEQ,"I")=LEXST_"^"_LEXEF_"^"_LEXDS_"^"_LEXIE
Q
VA(X,Y,D,I,ARY) ; VA File CO/VA
N LEXCODE,LEXSRC,LEXCDT,LEXENT,LEXTMP,LEXIEN,LEXSTA,LEXEFF,LEXFI,LEXRT
S LEXCODE=$G(X),LEXSRC=+($G(Y)),LEXCDT=$G(D),LEXENT=$G(I) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
Q:'$L(LEXCODE) Q:'$D(^LEX(757.02,"CODE",(LEXCODE_" "))) Q:LEXSRC'>0 Q:'$D(^LEX(757.03,+LEXSRC,0))
Q:"^1^2^3^4^30^31^"'[("^"_LEXSRC_"^") Q:+($G(LEXENT))'>0
S:LEXSRC=1 LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC),LEXFI=80,LEXRT="^ICD9("
S:LEXSRC=30 LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC),LEXFI=80,LEXRT="^ICD9("
S:LEXSRC=2 LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC),LEXFI=80.1,LEXRT="^ICD0("
S:LEXSRC=31 LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC),LEXFI=80.1,LEXRT="^ICD0("
I LEXSRC=3!(LEXSRC=4) D Q:'$L($G(LEXTMP))
. S LEXTMP=$$STATCHK^ICPTAPIU(LEXCODE,LEXCDT) S LEXIEN=$P(LEXTMP,"^",2) I LEXIEN'>0 K LEXTMP Q
. N LEXD S LEXD=$$CPT^ICPTCOD(LEXIEN,LEXCDT,1) Q:+LEXD'>0 S LEXFI=81,LEXRT="^ICPT("
. S LEXTMP=+($P(LEXD,"^",7))_"^"_LEXIEN_"^"_$P(LEXD,"^",6)
I $L(LEXTMP) D
. S LEXSTA=$P(LEXTMP,"^",1) Q:"^1^0^"'[("^"_LEXSTA_"^")
. S LEXIEN=$P(LEXTMP,"^",2) Q:+LEXIEN'>0 Q:'$D(@(LEXRT_+LEXIEN_",0)"))
. S LEXEFF=$P(LEXTMP,"^",3) S:LEXEFF'?7N LEXEFF=""
. S LEXTMP=LEXSTA_"^"_LEXEFF_"^"_LEXFI_"^"_LEXIEN S:$L($TR($G(LEXRT),"^","")) LEXTMP=LEXTMP_";"_$TR($G(LEXRT),"^","")
. S ARY("CO",+LEXENT,"VA")=LEXTMP
Q
EX(X,ARY) ; Expressions MC/FS/SY/LV
N LEXEIEN,LEXEX,LEXEXP,LEXMC,LEXMIEN,LEXND,LEXSEQ,LEXSTA,LEXSTAT,LEXTN,LEXTS,LEXTY
K ARY("MC"),ARY("LV"),ARY("FS"),ARY("SY") S LEXEIEN=$G(X),LEXMIEN=+($G(^LEX(757.01,+LEXEIEN,1))) Q:+LEXMIEN'>0
S LEXMIEN=+($G(^LEX(757.01,+LEXEIEN,1))) Q:'$D(^LEX(757,+LEXMIEN,0))
Q:'$D(^LEX(757.01,"AMC",+LEXMIEN))
S LEXEX=0 F S LEXEX=$O(^LEX(757.01,"AMC",LEXMIEN,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)
. D SK(LEXTS,LEXSEQ,+LEXEX,.ARY)
. D NG(LEXTS,LEXSEQ,+LEXEX,.ARY)
Q
DS(X,Y,IEN,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(IEN) 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,IEN,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(IEN) 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,IEN,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(IEN) 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
OR(X,Y,CDT,ARY) ; Orphan Text OR
N LEXD,LEXCODE,LEXEIEN,LEXEXP,LEXND,LEXSEQ,LEXSIEN,LEXSRC,LEXSTA,LEXSTAT,LEXSYS,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 LEXD=$G(CDT) S:LEXD'?7N LEXD=$$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",(LEXD+.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
MP(X,Y,CDT,ARY) ; Mappings MP
N LEXD,LEXCODE,LEXSRC,LEXSYS,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 LEXD=$G(CDT) S:LEXD'?7N LEXD=$$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,(LEXD+.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)
. S LEXMNOM=$P($G(^LEX(757.03,+LEXMTSY,0)),"^",2),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
. S $P(LEXSTR,"^",7)=LEXMSSY S ARY("MP")="Mapping",LEXSEQ=$O(ARY("MP"," "),-1)+1,ARY("MP",LEXSEQ)=LEXMCODE
. S ARY("MP",LEXSEQ,"I")=LEXSTR
Q
SB(X,ARY) ; Subsets SB
N LEXIENS,LEXEX,LEXMC,LEXDA,LEXIEN,LEXSO,LEXSIEN,LEXSRC,LEXSYS
S LEXEX=+($G(X)),LEXMC=+($P($G(^LEX(757.01,+LEXEX,1)),"^",1)),LEXDA=+($P($G(^LEX(757.01,+LEXEX,1)),"^",5))
Q:+LEXEX'>0 Q:+LEXMC'>0 Q:LEXDA'?1N Q:+LEXDA>0
S LEXEX=+($G(^LEX(757,+LEXMC,0))) I $D(^LEX(757.21,"B",+LEXEX)) D Q
. N LEXIEN,LEXSIEN 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
DC(X,CDT,ARY) ; Diagnostic Categories DC
D DC^LEXINF2($G(X),$G(CDT),.ARY)
Q
CP(X,CDT,ARY) ; Character Positions CP
D CP^LEXINF2($G(X),$G(CDT),.ARY)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXINF3 17850 printed Oct 16, 2024@18:08:48 Page 2
LEXINF3 ;ISL/KER - Information - Term ;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 ;
TERM(IEN,CDT,ARY,OUT) ; Information about a Term
+1 ;
+2 ; Input
+3 ;
+4 ; IEN Expression IEN (file 757.01)
+5 ; CDT Date used to determine status, default TODAY
+6 ; OUT Output/Display ARY (Optional)
+7 ; 0 Do not Display (default)
+8 ; 1 Display
+9 ; Output
+10 ;
+11 ; ARY
+12 ;
+13 ; Code
+14 ;
+15 ; ARY("CO")="Code"
+16 ; ARY("CO",n)=<code>
+17 ; ARY("CO","B",<code>,n)=""
+18 ; ARY("CO",n,"I")= 6 piece "^" delimited string
+19 ;
+20 ; 1 Status
+21 ; 2 Effective Date
+22 ; 3 Initial Activation Date
+23 ; 4 Pointer to CODES file #757.02
+24 ; 5 Coding System Nomenclature
+25 ; 6 Coding System
+26 ;
+27 ; ARY("CO",n,"MD")="Code Modifiers"
+28 ; ARY("CO",n,"MD",n)=<modifier>
+29 ; ARY("CO",n,"MD",n,"I")= 4 piece "^" delimited string
+30 ;
+31 ; 1 Status
+32 ; 2 Effective Date
+33 ; 3 Modifier Name
+34 ; 4 Pointer to CPT MODIFIER file #81.3
+35 ;
+36 ; ARY("CO",n,"VA")= 4 piece "^" delimited string
+37 ;
+38 ; 1 Status
+39 ; 2 Effective Date
+40 ; 3 VA File Number
+41 ; 4 Variable Pointer to VA File
+42 ;
+43 ; Diagnostic Categories (ICD-10-CM only)
+44 ;
+45 ; ARY("DC")="Diagnostic Categories"
+46 ; ARY("DC",1)=<category>
+47 ; ARY("DC",1,"I")= 4 piece "^" delimited string
+48 ;
+49 ; 1 Status
+50 ; 2 Effective Date
+51 ; 3 Category Name
+52 ; 4 Pointer to CHARACTER POSITIONS file #757.033
+53 ;
+54 ; Procedure Characters Positions (ICD-10-PCS only)
+55 ;
+56 ; Where n is a character position number 1-7
+57 ;
+58 ; ARY("CP")="Procedure Characters"
+59 ; ARY("CP","I")=<code>
+60 ; ARY("CP",n)=<character position 1-n>
+61 ; ARY("CP",n,"I")= 4 piece "^" delimited string
+62 ;
+63 ; 1 Status
+64 ; 2 Effective Date
+65 ; 3 Name
+66 ; 4 Pointer to CHARACTER POSITIONS file #757.033
+67 ;
+68 ; Terms
+69 ;
+70 ; Subscript SUB can be:
+71 ;
+72 ; MC Major Concept
+73 ; FS Fully Specified Term
+74 ; SY Synonyms
+75 ; LV Lexical Variants
+76 ; OR Orphan Text
+77 ;
+78 ; ARY(SUB)=type
+79 ; ARY(SUB,n)=<expression>
+80 ; ARY(SUB,n,"I")= 4 piece "^" delimited string
+81 ;
+82 ; 1 Status
+83 ; 2 Type
+84 ; 3 Current/Retired
+85 ; 4 Pointer to EXPRESSIONS file #757.01
+86 ;
+87 ; ARY(SUB,n,"ID")="Designation ID"
+88 ; ARY(SUB,n,"ID",n)<designation ID>
+89 ; ARY(SUB,n,"ID",n,"I")= 4 piece "^" delimited string
+90 ;
+91 ; 1 Status
+92 ; 2 Coding System
+93 ; 3 Hierarchy
+94 ; 4 Pointer to DESIGNATION CODE subfile #757.118
+95 ;
+96 ; ARY(SUB,n,"SK")="Supplemental Keywords"
+97 ; ARY(SUB,n,"SK",n)=<keyword>
+98 ; ARY(SUB,n,"SK",n,"I")= 4 piece "^" delimited string
+99 ;
+100 ; 1 Status
+101 ; 2 Not used
+102 ; 3 Not used
+103 ; 4 Pointer to SUPPLEMENTAL subfile #757.18
+104 ;
+105 ; Mappings
+106 ;
+107 ; ARY("MP")="Mapping"
+108 ; ARY("MP",n)=<map to target code>
+109 ; ARY("MP",n,"I")= 6 piece "^" delimited string
+110 ;
+111 ; 1 Status
+112 ; 2 Effective
+113 ; 3 Coding System
+114 ; 4 Pointer to MAPPINGS file #757.33
+115 ; 5 Match (full/partial)
+116 ; 6 Source Code
+117 ; 7 Source Coding System
+118 ;
+119 ; Subsets
+120 ;
+121 ; ARY("SB")="Subsets"
+122 ; ARY("SB",n)=<subset>
+123 ; ARY("SB",n,"I")= 5 piece "^" delimited string
+124 ;
+125 ; 1 Status
+126 ; 2 Pointer to SUBSET file #757.21
+127 ; 3 Pointer to EXPRESSION file #757.01
+128 ; 4 Pointer to SUBSET DEFINITION file #757.2
+129 ; 5 Subset ID
+130 ;
+131 ; Source
+132 ;
+133 ; ARY("SR")="Source"
+134 ; ARY("SR",n)=<source abbreviation>
+135 ; ARY("SR","B",<source>,n)=""
+136 ; ARY("SR",n,"I")= 4 piece "^" delimited string
+137 ;
+138 ; 1 Source Abbreviation
+139 ; 2 Source Nomenclature
+140 ; 3 Source Title
+141 ; 4 Pointer to CODING SYSTEMS file #757.03
+142 ;
+143 NEW LEXEFF,LEXD,LEXDISP,LEXEIEN,LEXMIEN,LEXST,LEXSYS,LEXTYPE
KILL ARY
SET LEXDISP=$GET(OUT)
SET LEXEIEN=$GET(IEN)
SET LEXD=$GET(CDT)
if LEXD'?7N
SET LEXD=$$DT^XLFDT
+144 SET LEXMIEN=$PIECE($GET(^LEX(757.01,+LEXEIEN,1)),"^",1)
IF '$DATA(^LEX(757.01,+LEXEIEN,0))
KILL ARY
QUIT
+145 DO CO(LEXEIEN,LEXD,.ARY)
DO EX(LEXEIEN,.ARY)
DO SB(LEXEIEN,.ARY)
if +($GET(LEXDISP))>0&($ORDER(ARY("MC",0))>0)
DO TERM^LEXINF5(.ARY)
+146 QUIT
CO(X,CDT,ARY) ; Codes CO
+1 NEW LEXCODE,LEXEF,LEXEIEN,LEXHS,LEXIEN,LEXINIT,LEXND,LEXNOM,LEXSAB,LEXSEQ,LEXSIEN,LEXSO,LEXSRC,LEXST,LEXTMP,LEXTTL
+2 KILL ARY("CO"),ARY("SR")
SET LEXEIEN=$GET(X)
SET LEXMIEN=+($GET(^LEX(757.01,+LEXEIEN,1)))
if +LEXMIEN'>0
QUIT
SET LEXD=$GET(CDT)
if LEXD'?7N
SET LEXD=$$DT^XLFDT
+3 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"AMC",LEXMIEN,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+4 NEW LEXCODE,LEXEF,LEXHS,LEXIEN,LEXINIT,LEXND,LEXNOM,LEXSAB,LEXSRC,LEXST,LEXTMP,LEXTTL
SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
if $PIECE(LEXND,"^",5)'>0
QUIT
+5 SET LEXIEN=+LEXND
if LEXIEN'>0
QUIT
SET LEXEF=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",(LEXD+.0001)),-1)
SET LEXHS=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1)
+6 SET LEXST=$PIECE($GET(^LEX(757.02,+LEXSIEN,4,+LEXHS,0)),"^",2)
if LEXST'>0
QUIT
SET LEXCODE=$PIECE(LEXND,"^",2)
if '$LENGTH(LEXCODE)
QUIT
SET LEXSRC=$PIECE(LEXND,"^",3)
if LEXSRC'>0
QUIT
+7 SET LEXSAB=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",1)
if $LENGTH(LEXSAB)'=3
QUIT
SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",2)
if '$LENGTH(LEXNOM)
QUIT
+8 SET LEXTTL=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),"^",3)
if '$LENGTH(LEXTTL)
QUIT
SET LEXTMP=$$STATCHK^LEXSRC2(LEXCODE,LEXD,,LEXSAB)
SET LEXINIT=$PIECE(LEXTMP,"^",4)
+9 SET LEXSO(LEXCODE,LEXSRC)=LEXSIEN_"^"_LEXIEN_"^"_LEXST_"^"_LEXEF_"^"_LEXSAB_"^"_LEXNOM_"^"_LEXTTL_"^"_LEXINIT
End DoDot:1
+10 SET LEXCODE=""
FOR
SET LEXCODE=$ORDER(LEXSO(LEXCODE))
if '$LENGTH(LEXCODE)
QUIT
SET LEXSRC=0
FOR
SET LEXSRC=$ORDER(LEXSO(LEXCODE,LEXSRC))
if +LEXSRC'>0
QUIT
Begin DoDot:1
+11 NEW LEXEF,LEXEIEN,LEXINIT,LEXND,LEXNOM,LEXSAB,LEXSEQ,LEXSIEN,LEXST,LEXTTL
SET LEXND=$GET(LEXSO(LEXCODE,LEXSRC))
+12 SET LEXSIEN=+LEXND
if LEXSIEN'>0
QUIT
SET LEXEIEN=$PIECE(LEXND,"^",2)
if LEXEIEN'>0
QUIT
SET LEXST=$PIECE(LEXND,"^",3)
if LEXST'?1N
QUIT
+13 SET LEXEF=$PIECE(LEXND,"^",4)
if LEXEF'?7N
QUIT
SET LEXSAB=$PIECE(LEXND,"^",5)
if $LENGTH(LEXSAB)'=3
QUIT
SET LEXNOM=$PIECE(LEXND,"^",6)
if '$LENGTH(LEXNOM)
QUIT
+14 SET LEXTTL=$PIECE(LEXND,"^",7)
if '$LENGTH(LEXTTL)
QUIT
SET LEXINIT=$PIECE(LEXND,"^",7)
if LEXINIT'?7N
SET LEXINIT=""
if LEXEF?7N&(LEXINIT'?7N)
SET LEXINIT=LEXEF
+15 SET LEXSEQ=$ORDER(ARY("CO"," "),-1)+1
SET ARY("CO")="Code"
SET ARY("CO",LEXSEQ)=LEXCODE
SET ARY("CO",LEXSEQ,"I")=+LEXST_"^"_LEXEF_"^"_LEXINIT_"^"_LEXSIEN_"^"_LEXNOM_"^"_LEXSRC
+16 if LEXSRC=3!(LEXSRC=4)
DO MD(LEXCODE,LEXCDT,LEXSEQ,.ARY)
+17 if "^1^2^3^4^30^31^"[("^"_LEXSRC_"^")
DO VA(LEXCODE,LEXSRC,LEXD,LEXSEQ,.ARY)
SET ARY("CO","B",LEXSRC,LEXSEQ)=""
IF '$DATA(ARY("SR","B",LEXSRC))
Begin DoDot:2
+18 NEW LEXSEQ
SET ARY("SR")="Source"
SET LEXSEQ=$ORDER(ARY("SR"," "),-1)+1
SET ARY("SR",LEXSEQ)=LEXSAB
SET ARY("SR",LEXSEQ,"I")=LEXSAB_"^"_LEXNOM_"^"_LEXTTL_"^"_LEXSRC
+19 SET ARY("SR","B",LEXSRC,LEXSEQ)=""
End DoDot:2
+20 DO MP(LEXCODE,LEXSRC,LEXD,.ARY)
if LEXSRC=30
DO OR(LEXCODE,LEXSRC,LEXD,.ARY)
if LEXSRC=30
DO DC(LEXCODE,LEXD,.ARY)
if LEXSRC=31
DO CP(LEXCODE,LEXD,.ARY)
End DoDot:1
+21 QUIT
MD(X,Y,IEN,ARY) ; Modifiers CO/MD
+1 NEW LEXCODE,LEXCDT,LEXCPT,LEXENT,LEXO,LEXST,LEXEF,LEXDS,LEXIE
+2 SET LEXCODE=$GET(X)
SET LEXCDT=$GET(Y)
if $LENGTH(LEXCODE)'=5
QUIT
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+3 SET LEXENT=$GET(IEN)
if LEXENT'>0
QUIT
DO MODA^ICPTMOD(LEXCODE,LEXCDT,.LEXCPT)
+4 SET LEXO=""
FOR
SET LEXO=$ORDER(LEXCPT("A",LEXO))
if '$LENGTH(LEXO)
QUIT
Begin DoDot:1
+5 NEW LEXND,LEXIE,LEXDS,LEXAR,LEXIR,LEXEF,LEXSEQ
+6 SET LEXEF=""
SET LEXND=$GET(LEXCPT("A",LEXO))
+7 SET LEXIE=+($PIECE(LEXND,"^",1))
if '$DATA(^DIC(81.3,+LEXIE,0))
QUIT
if $PIECE($GET(^DIC(81.3,+LEXIE,0)),"^",1)'=LEXO
QUIT
+8 SET LEXDS=$PIECE(LEXND,"^",2)
if '$LENGTH(LEXDS)
QUIT
+9 SET LEXAR=$PIECE(LEXND,"^",6)
SET LEXIR=$PIECE(LEXND,"^",7)
+10 if LEXAR?7N&('$LENGTH(LEXIR))
SET LEXST=1
SET LEXEF=LEXAR
+11 if LEXAR?7N&(LEXIR?7N)&(LEXIR'<LEXAR)
SET LEXST=0
SET LEXEF=LEXIR
+12 if LEXAR?7N&(LEXIR?7N)&(LEXIR<LEXAR)
SET LEXST=1
SET LEXEF=LEXAR
+13 if LEXEF'?7N
QUIT
+14 SET LEXSEQ=$ORDER(ARY("CO",LEXENT,"MD"," "),-1)+1
+15 SET ARY("CO",LEXENT,"MD")="Code Modifiers"
+16 SET ARY("CO",LEXENT,"MD",LEXSEQ)=LEXO
+17 SET ARY("CO",LEXENT,"MD",LEXSEQ,"I")=LEXST_"^"_LEXEF_"^"_LEXDS_"^"_LEXIE
End DoDot:1
+18 QUIT
VA(X,Y,D,I,ARY) ; VA File CO/VA
+1 NEW LEXCODE,LEXSRC,LEXCDT,LEXENT,LEXTMP,LEXIEN,LEXSTA,LEXEFF,LEXFI,LEXRT
+2 SET LEXCODE=$GET(X)
SET LEXSRC=+($GET(Y))
SET LEXCDT=$GET(D)
SET LEXENT=$GET(I)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+3 if '$LENGTH(LEXCODE)
QUIT
if '$DATA(^LEX(757.02,"CODE",(LEXCODE_" ")))
QUIT
if LEXSRC'>0
QUIT
if '$DATA(^LEX(757.03,+LEXSRC,0))
QUIT
+4 if "^1^2^3^4^30^31^"'[("^"_LEXSRC_"^")
QUIT
if +($GET(LEXENT))'>0
QUIT
+5 if LEXSRC=1
SET LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC)
SET LEXFI=80
SET LEXRT="^ICD9("
+6 if LEXSRC=30
SET LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC)
SET LEXFI=80
SET LEXRT="^ICD9("
+7 if LEXSRC=2
SET LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC)
SET LEXFI=80.1
SET LEXRT="^ICD0("
+8 if LEXSRC=31
SET LEXTMP=$$STATCHK^ICDEX(LEXCODE,LEXCDT,LEXSRC)
SET LEXFI=80.1
SET LEXRT="^ICD0("
+9 IF LEXSRC=3!(LEXSRC=4)
Begin DoDot:1
+10 SET LEXTMP=$$STATCHK^ICPTAPIU(LEXCODE,LEXCDT)
SET LEXIEN=$PIECE(LEXTMP,"^",2)
IF LEXIEN'>0
KILL LEXTMP
QUIT
+11 NEW LEXD
SET LEXD=$$CPT^ICPTCOD(LEXIEN,LEXCDT,1)
if +LEXD'>0
QUIT
SET LEXFI=81
SET LEXRT="^ICPT("
+12 SET LEXTMP=+($PIECE(LEXD,"^",7))_"^"_LEXIEN_"^"_$PIECE(LEXD,"^",6)
End DoDot:1
if '$LENGTH($GET(LEXTMP))
QUIT
+13 IF $LENGTH(LEXTMP)
Begin DoDot:1
+14 SET LEXSTA=$PIECE(LEXTMP,"^",1)
if "^1^0^"'[("^"_LEXSTA_"^")
QUIT
+15 SET LEXIEN=$PIECE(LEXTMP,"^",2)
if +LEXIEN'>0
QUIT
if '$DATA(@(LEXRT_+LEXIEN_",0)"))
QUIT
+16 SET LEXEFF=$PIECE(LEXTMP,"^",3)
if LEXEFF'?7N
SET LEXEFF=""
+17 SET LEXTMP=LEXSTA_"^"_LEXEFF_"^"_LEXFI_"^"_LEXIEN
if $LENGTH($TRANSLATE($GET(LEXRT),"^",""))
SET LEXTMP=LEXTMP_";"_$TRANSLATE($GET(LEXRT),"^","")
+18 SET ARY("CO",+LEXENT,"VA")=LEXTMP
End DoDot:1
+19 QUIT
EX(X,ARY) ; Expressions MC/FS/SY/LV
+1 NEW LEXEIEN,LEXEX,LEXEXP,LEXMC,LEXMIEN,LEXND,LEXSEQ,LEXSTA,LEXSTAT,LEXTN,LEXTS,LEXTY
+2 KILL ARY("MC"),ARY("LV"),ARY("FS"),ARY("SY")
SET LEXEIEN=$GET(X)
SET LEXMIEN=+($GET(^LEX(757.01,+LEXEIEN,1)))
if +LEXMIEN'>0
QUIT
+3 SET LEXMIEN=+($GET(^LEX(757.01,+LEXEIEN,1)))
if '$DATA(^LEX(757,+LEXMIEN,0))
QUIT
+4 if '$DATA(^LEX(757.01,"AMC",+LEXMIEN))
QUIT
+5 SET LEXEX=0
FOR
SET LEXEX=$ORDER(^LEX(757.01,"AMC",LEXMIEN,LEXEX))
if +LEXEX'>0
QUIT
Begin DoDot:1
+6 NEW LEXEXP,LEXND,LEXSEQ,LEXSTA,LEXSTAT,LEXTN,LEXTS,LEXTY
SET LEXEXP=$GET(^LEX(757.01,+LEXEX,0))
+7 if '$LENGTH(LEXEXP)
QUIT
SET LEXND=$GET(^LEX(757.01,+LEXEX,1))
SET LEXSTA=$PIECE(LEXND,"^",5)
+8 SET LEXSTA=$SELECT(LEXSTA=1:0,1:1)
SET LEXTY=$PIECE(LEXND,"^",2)
SET LEXSTAT=$SELECT(LEXSTA'>0:"Retired",1:"Current")
+9 SET LEXTN=$SELECT(LEXTY=1:"Major Concept",LEXTY=3:"Variant",LEXTY=8:"Fully Specified Name",1:"Synonym")
+10 SET LEXTS=$SELECT(LEXTY=1:"MC",LEXTY=3:"LV",LEXTY=8:"FS",1:"SY")
+11 SET LEXSEQ=$ORDER(ARY(LEXTS," "),-1)+1
SET ARY(LEXTS,LEXSEQ)=LEXEXP
SET ARY(LEXTS)=LEXTN
+12 SET ARY(LEXTS,LEXSEQ,"I")=LEXSTA_"^"_LEXTN_"^"_$SELECT(LEXSTA'>0:"Retired",1:"Current")_"^"_+LEXEX
+13 DO DS(LEXTS,LEXSEQ,+LEXEX,.ARY)
+14 DO SK(LEXTS,LEXSEQ,+LEXEX,.ARY)
+15 DO NG(LEXTS,LEXSEQ,+LEXEX,.ARY)
End DoDot:1
+16 QUIT
DS(X,Y,IEN,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(IEN)
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,IEN,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(IEN)
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,IEN,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(IEN)
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
OR(X,Y,CDT,ARY) ; Orphan Text OR
+1 NEW LEXD,LEXCODE,LEXEIEN,LEXEXP,LEXND,LEXSEQ,LEXSIEN,LEXSRC,LEXSTA,LEXSTAT,LEXSYS,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 LEXD=$GET(CDT)
if LEXD'?7N
SET LEXD=$$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",(LEXD+.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
MP(X,Y,CDT,ARY) ; Mappings MP
+1 NEW LEXD,LEXCODE,LEXSRC,LEXSYS,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 LEXD=$GET(CDT)
if LEXD'?7N
SET LEXD=$$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,(LEXD+.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
SET LEXMTSY=$PIECE($GET(^LEX(757.32,+LEXMDEF,2)),"^",2)
+13 SET LEXMNOM=$PIECE($GET(^LEX(757.03,+LEXMTSY,0)),"^",2)
SET LEXSTR=+LEXST
SET $PIECE(LEXSTR,"^",2)=LEXEF
if $LENGTH(LEXMNOM)
SET $PIECE(LEXSTR,"^",3)=LEXMNOM
+14 if +LEXMIEN>0
SET $PIECE(LEXSTR,"^",4)=+LEXMIEN
if $LENGTH(LEXMMAT)
SET $PIECE(LEXSTR,"^",5)=LEXMMAT
SET $PIECE(LEXSTR,"^",6)=LEXCODE
+15 SET $PIECE(LEXSTR,"^",7)=LEXMSSY
SET ARY("MP")="Mapping"
SET LEXSEQ=$ORDER(ARY("MP"," "),-1)+1
SET ARY("MP",LEXSEQ)=LEXMCODE
+16 SET ARY("MP",LEXSEQ,"I")=LEXSTR
End DoDot:1
+17 QUIT
SB(X,ARY) ; Subsets SB
+1 NEW LEXIENS,LEXEX,LEXMC,LEXDA,LEXIEN,LEXSO,LEXSIEN,LEXSRC,LEXSYS
+2 SET LEXEX=+($GET(X))
SET LEXMC=+($PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",1))
SET LEXDA=+($PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",5))
+3 if +LEXEX'>0
QUIT
if +LEXMC'>0
QUIT
if LEXDA'?1N
QUIT
if +LEXDA>0
QUIT
+4 SET LEXEX=+($GET(^LEX(757,+LEXMC,0)))
IF $DATA(^LEX(757.21,"B",+LEXEX))
Begin DoDot:1
+5 NEW LEXIEN,LEXSIEN
SET LEXIEN=LEXEX
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.21,"B",+LEXEX,LEXSIEN))
if LEXSIEN'>0
QUIT
Begin DoDot:2
+6 NEW LEXND,LEXSI,LEXSA,LEXSF,LEXSTR,LEXSEQ
+7 SET LEXSI=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
SET LEXND=$GET(^LEXT(757.2,+LEXSI,0))
+8 SET LEXSA=$PIECE(LEXND,"^",2)
SET LEXSF=$$MIX^LEXXM($PIECE(LEXND,"^",1))
+9 SET LEXSTR=+($GET(LEXST))
if +LEXSIEN>0
SET $PIECE(LEXSTR,"^",2)=+LEXSIEN
if +LEXEX>0
SET $PIECE(LEXSTR,"^",3)=+LEXEX
+10 if +LEXSI>0
SET $PIECE(LEXSTR,"^",4)=+LEXSI
if $LENGTH(LEXSA)
SET $PIECE(LEXSTR,"^",5)=LEXSA
SET ARY("SB")="Subsets"
+11 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
+12 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+13 if $PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)>0
QUIT
SET LEXIENS(LEXIEN)=""
End DoDot:1
+14 if $ORDER(LEXIENS(0))'>0
QUIT
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(LEXIENS(LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+15 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
+16 NEW LEXND,LEXSI,LEXSA,LEXSF,LEXSTR,LEXSEQ
+17 SET LEXSI=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
SET LEXND=$GET(^LEXT(757.2,+LEXSI,0))
+18 SET LEXSA=$PIECE(LEXND,"^",2)
SET LEXSF=$$MIX^LEXXM($PIECE(LEXND,"^",1))
+19 SET LEXSTR=+($GET(LEXST))
if +LEXSIEN>0
SET $PIECE(LEXSTR,"^",2)=+LEXSIEN
if +LEXIEN>0
SET $PIECE(LEXSTR,"^",3)=+LEXIEN
+20 if +LEXSI>0
SET $PIECE(LEXSTR,"^",4)=+LEXSI
if $LENGTH(LEXSA)
SET $PIECE(LEXSTR,"^",5)=LEXSA
SET ARY("SB")="Subsets"
+21 SET LEXSEQ=$ORDER(ARY("SB"," "),-1)+1
SET ARY("SB",LEXSEQ)=LEXSF
SET ARY("SB",LEXSEQ,"I")=LEXSTR
End DoDot:2
End DoDot:1
+22 QUIT
DC(X,CDT,ARY) ; Diagnostic Categories DC
+1 DO DC^LEXINF2($GET(X),$GET(CDT),.ARY)
+2 QUIT
CP(X,CDT,ARY) ; Character Positions CP
+1 DO CP^LEXINF2($GET(X),$GET(CDT),.ARY)
+2 QUIT
