LEXQVSE ;ISL/TJH - Query - VA Extension SNOMED CT - Extract ;01/25/2021
;;2.0;LEXICON UTILITY;**133**;Sep 23, 1996;Build 3
;
; Global Variables
; ^LEX(757.01, SACC 1.3
; ^LEX(757.018, SACC 1.3
; ^LEX(757.02, SACC 1.3
; ^LEX(757.32, SACC 1.3
; ^LEX(757.33, SACC 1.3
; ^TMP("LEXQVSEO",$J) SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXIIEN Include IENs flag
;
EN ; Main Entry Point
N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0 K ^TMP("LEXQVSEO",$J)
N LEXAD,LEXEDT,LEXCDT,LEXEXIT,LEXTEST S LEXEXIT=0,LEXCDT="" W !
F S LEXCDT=$$AD^LEXQM,LEXAD=LEXCDT Q:'$L(LEXCDT) S LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2) Q:LEXCDT'?7N D LOOK Q:LEXCDT'?7N Q:+LEXEXIT>0
K ^TMP("LEXQVSEO",$J)
Q
IEN ; Display with IENs
N LEXIIEN S LEXIIEN=1 D EN
Q
LOOK ; SNOMED CT Lookup Loop
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
N LEXSCT,LEXSCTC,LEXEEN,LEXEFF,LEXEXP,LEXIDT,LEXSEN,LEXSTA
F S LEXSCT=$$SCT^LEXQVSEA S:LEXSCT="^^" LEXEXIT=1 Q:LEXSCT="^"!(LEXSCT="^^") D LOOK2 Q:LEXSCT="^"!(LEXSCT="^^")
Q
LOOK2 ; Needs LEXCDT and LEXSCT
; Needs
; LEXCDT FileMan date
; LEXEXIT Exit Flag (0)
; LEXSCT SNOMED CT = SIEN^CODE^STA^EFF^EIEN^EXP
K LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXLDT,LEXELDT
N LEXAD,LEXCOD,LEXEDT,LEXSIEN,LEXEIEN,LEXLDT,LEXELDT,LEXINC,LEXFA,LEXCLEN,LEXLLEN,LEXTLEN,LEXLEN
S:$E($G(LEXCDT),1,7)?7N LEXAD=$$UP^XLFSTR($$FMTE^XLFDT($E(LEXCDT,1,7)))_"^"_$E(LEXCDT,1,7) Q:'$L($G(LEXAD))
S:$E($G(LEXCDT),1,7)?7N LEXEDT=$$FMTE^XLFDT($E(LEXCDT,1,7),"5Z") Q:'$L($G(LEXEDT))
S LEXCLEN=18,LEXLLEN=LEXCLEN+7,LEXTLEN=(78-(LEXLLEN+2)),LEXLEN=LEXCLEN_"^"_LEXLLEN_"^"_LEXTLEN
S LEXSEN=+($G(LEXSCT)),LEXCOD=$P(LEXSCT,"^",2) Q:'$L(LEXCOD)
S LEXSTA=$P(LEXSCT,"^",3),LEXEFF=$P(LEXSCT,"^",4),(LEXFA,LEXIDT)=$P(LEXSCT,"^",5)
S LEXEEN=$P(LEXSCT,"^",6),LEXEXP=$P(LEXSCT,"^",7),LEXLDT=+($G(LEXCDT))
Q:+LEXSEN'>0 Q:+LEXEEN'>0 Q:LEXLDT'?7N S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
D EN^LEXQVSE2
Q
;
NA(X,Y) ; Next Activation File 757.02 ACT index
;
; Input
;
; X Code
; Y CSV Date (default TODAY)
;
N LEXCOD,LEXCDT,LEXNA S LEXCOD=$G(X),LEXCDT=$G(Y) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
S LEXNA=$O(^LEX(757.02,"ACT",(LEXCOD_" "),3,(LEXCDT-.001))) S X="" S:LEXNA?7N X=LEXNA
Q X
PF(X) ; Preference File 757.02, Field 4 0;5
S X=+($G(X)) S X=$P($G(^LEX(757.02,+X,0)),"^",5),X=$S(X>0:"Preferred Term",1:"")
Q X
TY(X) ; Type File 757.01, Field 2 1;2
S X=+($G(X)) S X=$P($G(^LEX(757.02,+X,1)),"^",2) S X=$S(X=1:"Concept",X=8:"Full Name",1:"Synonym")
Q X
DA(X) ; Deactivated File 757.01, Field 9 1;5
S X=+($G(X)) S X=$P($G(^LEX(757.02,+X,1)),"^",5) S X=$S(X>0:"Deactivated Term",1:"")
Q X
DS(X,LEX) ; Designation Code Sub-file 757.118, Fields .01 and 2
;
; Input
;
; X Expression IEN
;
; Output
;
; LEX Array passed by Reference
;
; LEX(#)= Designation Code "^" Hierarchy
;
K LEX N LEXO,LEXIEN S LEXIEN=+($G(X)),LEXO="" F S LEXO=$O(^LEX(757.01,+LEXIEN,7,"C",58,LEXO)) Q:'$L(LEXO) D
. N LEXDI S LEXDI=0 F S LEXDI=$O(^LEX(757.01,+X,7,"C",58,LEXO,LEXDI)) Q:+LEXDI'>0 D
. . N LEXDS,LEXHI,LEXHN,LEXI,LEXT S LEXDS=$G(^LEX(757.01,+X,7,+LEXDI,0))
. . S LEXHI=$P(LEXDS,"^",3) S LEXHN=$S(LEXHI?1N.N:$P($G(^LEX(757.018,+LEXHI,0)),"^",1),1:"")
. . S:$D(LEXIIEN)&(+LEXHI>0) LEXHN=LEXHN_" (IEN "_+LEXHI_")"
. . S LEXT=$P(LEXDS,"^",1) S:$L(LEXHI) LEXT=LEXT_"^"_LEXHN
. . S LEXI=$O(LEX(" "),-1)+1,LEX(+LEXI)=LEXT
Q
IENS(X,LEX) ; Get IENS
;
; Input
;
; X Major Concept Map IEN
;
; Output
;
; LEX Array passed by Reference
;
; LEX(1,#) = Major Concept Expression IEN
; LEX(2,#) = Fully Specified Name Expression IEN
; LEX(3,#) = Synonymous Expression IEN
;
K LEX N LEXMC,LEXEIEN S LEXMC=+($G(X)),LEXEIEN=0 F S LEXEIEN=$O(^LEX(757.01,"AMC",LEXMC,LEXEIEN)) Q:+LEXEIEN'>0 D
. N LEXT,LEXI,LEXN S LEXT=$P($G(^LEX(757.01,+LEXEIEN,1)),"^",2) S LEXN=$S(LEXT=1:1,LEXT=8:2,1:3)
. S LEXI=$O(LEX(LEXN," "),-1)+1 S LEX(LEXN,LEXI)=LEXEIEN
Q
SUBS(X,LEX) ; Get Subsets
;
; Input
;
; X Major Concept Map IEN
;
; Output
;
; LEX Array passed by Reference
;
; LEX(SUB) = 4 Piece "^" delimited string
;
; 1 Subset Name
; 2 Subset Definition IEN file 757.2
; 3 Subset IEN file 757.21
; 4 Expression IEN file 757.01
;
K LEX N LEXIENS,LEXMC,LEXIEN S LEXMC=+($G(X)),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 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:$L(LEXSA)=3&($L(LEXSF)) LEX(LEXSA)=LEXSF_"^"_LEXSI_"^"_LEXSIEN_"^"_LEXIEN
Q
MAPS(X,LEX,LEXD,LEXL) ; Get Mappings
;
; Input
;
; X SNOMED Code
; LEXD Versioning DAte
; LEXL Length of text
;
; Output
;
; LEX Array passed by Reference
;
; LEX(#) = Text
;
N LEXIDT,LEXLEN,LEXISO,LEXMD,LEXTL K LEX S LEXISO=$G(X) Q:'$L(LEXISO)
S LEXIDT=$P($G(LEXD),".",1) S:LEXIDT'?7N LEXIDT=$$DT^XLFDT
S LEXLEN=$G(LEXL) S:+LEXLEN'>0 LEXLEN="18^25^53" S LEXTL=+($P($G(LEXLEN),"^",3))
S LEXMD=0 F S LEXMD=$O(^LEX(757.32,+LEXMD)) Q:+LEXMD'>0 D
. Q:+($P($G(^LEX(757.32,+LEXMD,2)),"^",1))'=58 N LEXO,LEXSRC,LEXTO S LEXSRC=$P($G(^LEX(757.32,+LEXMD,2)),"^",2)
. S LEXTO=+($P($G(^LEX(757.32,+LEXMD,2)),"^",2)) Q:+LEXTO'>0 Q:'$D(^LEX(757.03,+LEXTO,0))
. S LEXO="" F S LEXO=$O(^LEX(757.33,"C",LEXMD,LEXISO,LEXO)) Q:'$L(LEXO) D
. . N LEXC S LEXC="" F S LEXC=$O(^LEX(757.33,"C",LEXMD,LEXISO,LEXO,LEXC)) Q:'$L(LEXC) D
. . . N LEXE S LEXE=0 F S LEXE=$O(^LEX(757.33,"C",LEXMD,LEXISO,LEXO,LEXC,LEXE)) Q:LEXE'>0 D
. . . . N LEXCODE,LEXEF,LEXEIEN,LEXEXP,LEXHI,LEXI,LEXMA,LEXMIEN,LEXN,LEXNOM,LEXSA,LEXSAB,LEXSIEN,LEXST,LEXT
. . . . S LEXMIEN=LEXE,LEXEF=$O(^LEX(757.33,+LEXE,2,"B",(LEXIDT+.00001)),-1)
. . . . S LEXHI=$O(^LEX(757.33,+LEXE,2,"B",+LEXEF," "),-1)
. . . . S LEXST=$P($G(^LEX(757.33,+LEXE,2,+LEXHI,0)),"^",2) Q:LEXST'>0
. . . . S LEXSA=$S(LEXST>0:"",1:"(Inactive Mapping)")
. . . . S LEXMA=$P($G(^LEX(757.33,+LEXE,0)),"^",5)
. . . . S LEXMA=$S(+LEXMA'>0:"(Partial Map)",1:"")
. . . . S LEXCODE=$P($G(^LEX(757.33,+LEXE,0)),"^",3) Q:'$L(LEXCODE)
. . . . S LEXNOM=$P($G(^LEX(757.03,+LEXTO,0)),"^",2) Q:'$L(LEXNOM)
. . . . S LEXSAB=$E($P($G(^LEX(757.03,+LEXTO,0)),"^",1),1,3) Q:$L(LEXSAB)'=3
. . . . S LEXSRC=$$STATCHK^LEXSRC2(LEXCODE,LEXIDT,,LEXSAB)
. . . . S LEXSIEN=$P(LEXSRC,"^",2) Q:+LEXSIEN'>0
. . . . S LEXEIEN=+($G(^LEX(757.02,+LEXSIEN,0)))
. . . . S LEXEXP=$G(^LEX(757.01,+LEXEIEN,0)) Q:'$L(LEXEXP)
. . . . S LEXT=LEXEXP_" ("_LEXNOM_" "_LEXCODE_")"
. . . . S:$L(LEXMA) LEXT=LEXT_" "_LEXMA
. . . . S:$L(LEXSA) LEXT=LEXT_" "_LEXSA
. . . . S:$D(LEXIIEN) LEXT=LEXT_" (IEN "_LEXMIEN_")"
. . . . K LEXN S LEXN(1)=LEXT D PR^LEXU(.LEXN,(+($G(LEXTL))-4))
. . . . S LEXI=0 F S LEXI=$O(LEXN(LEXI)) Q:+LEXI'>0 D
. . . . . N LEXC,LEXT S LEXT=$G(LEXN(LEXI)) Q:'$L(LEXT)
. . . . . S LEXC=$O(LEX(" "),-1)+1 S:LEXI=1 LEX(LEXC)=LEXT S:LEXI>1 LEX(LEXC)=" "_LEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQVSE 8029 printed Sep 23, 2025@19:44:57 Page 2
LEXQVSE ;ISL/TJH - Query - VA Extension SNOMED CT - Extract ;01/25/2021
+1 ;;2.0;LEXICON UTILITY;**133**;Sep 23, 1996;Build 3
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01, SACC 1.3
+5 ; ^LEX(757.018, SACC 1.3
+6 ; ^LEX(757.02, SACC 1.3
+7 ; ^LEX(757.32, SACC 1.3
+8 ; ^LEX(757.33, SACC 1.3
+9 ; ^TMP("LEXQVSEO",$J) SACC 2.3.2.5.1
+10 ;
+11 ; External References
+12 ; $$DT^XLFDT ICR 10103
+13 ; $$FMTE^XLFDT ICR 10103
+14 ; $$UP^XLFSTR ICR 10104
+15 ;
+16 ; Local Variables NEWed or KILLed Elsewhere
+17 ; LEXIIEN Include IENs flag
+18 ;
EN ; Main Entry Point
+1 NEW LEXENV
SET LEXENV=$$EV^LEXQM
if +LEXENV'>0
QUIT
KILL ^TMP("LEXQVSEO",$JOB)
+2 NEW LEXAD,LEXEDT,LEXCDT,LEXEXIT,LEXTEST
SET LEXEXIT=0
SET LEXCDT=""
WRITE !
+3 FOR
SET LEXCDT=$$AD^LEXQM
SET LEXAD=LEXCDT
if '$LENGTH(LEXCDT)
QUIT
SET LEXEDT=$PIECE(LEXCDT,"^",1)
SET LEXCDT=$PIECE(LEXCDT,"^",2)
if LEXCDT'?7N
QUIT
DO LOOK
if LEXCDT'?7N
QUIT
if +LEXEXIT>0
QUIT
+4 KILL ^TMP("LEXQVSEO",$JOB)
+5 QUIT
IEN ; Display with IENs
+1 NEW LEXIIEN
SET LEXIIEN=1
DO EN
+2 QUIT
LOOK ; SNOMED CT Lookup Loop
+1 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET LEXCDT=""
QUIT
+2 NEW LEXSCT,LEXSCTC,LEXEEN,LEXEFF,LEXEXP,LEXIDT,LEXSEN,LEXSTA
+3 FOR
SET LEXSCT=$$SCT^LEXQVSEA
if LEXSCT="^^"
SET LEXEXIT=1
if LEXSCT="^"!(LEXSCT="^^")
QUIT
DO LOOK2
if LEXSCT="^"!(LEXSCT="^^")
QUIT
+4 QUIT
LOOK2 ; Needs LEXCDT and LEXSCT
+1 ; Needs
+2 ; LEXCDT FileMan date
+3 ; LEXEXIT Exit Flag (0)
+4 ; LEXSCT SNOMED CT = SIEN^CODE^STA^EFF^EIEN^EXP
+5 KILL LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXLDT,LEXELDT
+6 NEW LEXAD,LEXCOD,LEXEDT,LEXSIEN,LEXEIEN,LEXLDT,LEXELDT,LEXINC,LEXFA,LEXCLEN,LEXLLEN,LEXTLEN,LEXLEN
+7 if $EXTRACT($GET(LEXCDT),1,7)?7N
SET LEXAD=$$UP^XLFSTR($$FMTE^XLFDT($EXTRACT(LEXCDT,1,7)))_"^"_$EXTRACT(LEXCDT,1,7)
if '$LENGTH($GET(LEXAD))
QUIT
+8 if $EXTRACT($GET(LEXCDT),1,7)?7N
SET LEXEDT=$$FMTE^XLFDT($EXTRACT(LEXCDT,1,7),"5Z")
if '$LENGTH($GET(LEXEDT))
QUIT
+9 SET LEXCLEN=18
SET LEXLLEN=LEXCLEN+7
SET LEXTLEN=(78-(LEXLLEN+2))
SET LEXLEN=LEXCLEN_"^"_LEXLLEN_"^"_LEXTLEN
+10 SET LEXSEN=+($GET(LEXSCT))
SET LEXCOD=$PIECE(LEXSCT,"^",2)
if '$LENGTH(LEXCOD)
QUIT
+11 SET LEXSTA=$PIECE(LEXSCT,"^",3)
SET LEXEFF=$PIECE(LEXSCT,"^",4)
SET (LEXFA,LEXIDT)=$PIECE(LEXSCT,"^",5)
+12 SET LEXEEN=$PIECE(LEXSCT,"^",6)
SET LEXEXP=$PIECE(LEXSCT,"^",7)
SET LEXLDT=+($GET(LEXCDT))
+13 if +LEXSEN'>0
QUIT
if +LEXEEN'>0
QUIT
if LEXLDT'?7N
QUIT
SET LEXELDT=$$SD^LEXQM(LEXLDT)
if '$LENGTH(LEXELDT)
QUIT
+14 DO EN^LEXQVSE2
+15 QUIT
+16 ;
NA(X,Y) ; Next Activation File 757.02 ACT index
+1 ;
+2 ; Input
+3 ;
+4 ; X Code
+5 ; Y CSV Date (default TODAY)
+6 ;
+7 NEW LEXCOD,LEXCDT,LEXNA
SET LEXCOD=$GET(X)
SET LEXCDT=$GET(Y)
if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
+8 SET LEXNA=$ORDER(^LEX(757.02,"ACT",(LEXCOD_" "),3,(LEXCDT-.001)))
SET X=""
if LEXNA?7N
SET X=LEXNA
+9 QUIT X
PF(X) ; Preference File 757.02, Field 4 0;5
+1 SET X=+($GET(X))
SET X=$PIECE($GET(^LEX(757.02,+X,0)),"^",5)
SET X=$SELECT(X>0:"Preferred Term",1:"")
+2 QUIT X
TY(X) ; Type File 757.01, Field 2 1;2
+1 SET X=+($GET(X))
SET X=$PIECE($GET(^LEX(757.02,+X,1)),"^",2)
SET X=$SELECT(X=1:"Concept",X=8:"Full Name",1:"Synonym")
+2 QUIT X
DA(X) ; Deactivated File 757.01, Field 9 1;5
+1 SET X=+($GET(X))
SET X=$PIECE($GET(^LEX(757.02,+X,1)),"^",5)
SET X=$SELECT(X>0:"Deactivated Term",1:"")
+2 QUIT X
DS(X,LEX) ; Designation Code Sub-file 757.118, Fields .01 and 2
+1 ;
+2 ; Input
+3 ;
+4 ; X Expression IEN
+5 ;
+6 ; Output
+7 ;
+8 ; LEX Array passed by Reference
+9 ;
+10 ; LEX(#)= Designation Code "^" Hierarchy
+11 ;
+12 KILL LEX
NEW LEXO,LEXIEN
SET LEXIEN=+($GET(X))
SET LEXO=""
FOR
SET LEXO=$ORDER(^LEX(757.01,+LEXIEN,7,"C",58,LEXO))
if '$LENGTH(LEXO)
QUIT
Begin DoDot:1
+13 NEW LEXDI
SET LEXDI=0
FOR
SET LEXDI=$ORDER(^LEX(757.01,+X,7,"C",58,LEXO,LEXDI))
if +LEXDI'>0
QUIT
Begin DoDot:2
+14 NEW LEXDS,LEXHI,LEXHN,LEXI,LEXT
SET LEXDS=$GET(^LEX(757.01,+X,7,+LEXDI,0))
+15 SET LEXHI=$PIECE(LEXDS,"^",3)
SET LEXHN=$SELECT(LEXHI?1N.N:$PIECE($GET(^LEX(757.018,+LEXHI,0)),"^",1),1:"")
+16 if $DATA(LEXIIEN)&(+LEXHI>0)
SET LEXHN=LEXHN_" (IEN "_+LEXHI_")"
+17 SET LEXT=$PIECE(LEXDS,"^",1)
if $LENGTH(LEXHI)
SET LEXT=LEXT_"^"_LEXHN
+18 SET LEXI=$ORDER(LEX(" "),-1)+1
SET LEX(+LEXI)=LEXT
End DoDot:2
End DoDot:1
+19 QUIT
IENS(X,LEX) ; Get IENS
+1 ;
+2 ; Input
+3 ;
+4 ; X Major Concept Map IEN
+5 ;
+6 ; Output
+7 ;
+8 ; LEX Array passed by Reference
+9 ;
+10 ; LEX(1,#) = Major Concept Expression IEN
+11 ; LEX(2,#) = Fully Specified Name Expression IEN
+12 ; LEX(3,#) = Synonymous Expression IEN
+13 ;
+14 KILL LEX
NEW LEXMC,LEXEIEN
SET LEXMC=+($GET(X))
SET LEXEIEN=0
FOR
SET LEXEIEN=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXEIEN))
if +LEXEIEN'>0
QUIT
Begin DoDot:1
+15 NEW LEXT,LEXI,LEXN
SET LEXT=$PIECE($GET(^LEX(757.01,+LEXEIEN,1)),"^",2)
SET LEXN=$SELECT(LEXT=1:1,LEXT=8:2,1:3)
+16 SET LEXI=$ORDER(LEX(LEXN," "),-1)+1
SET LEX(LEXN,LEXI)=LEXEIEN
End DoDot:1
+17 QUIT
SUBS(X,LEX) ; Get Subsets
+1 ;
+2 ; Input
+3 ;
+4 ; X Major Concept Map IEN
+5 ;
+6 ; Output
+7 ;
+8 ; LEX Array passed by Reference
+9 ;
+10 ; LEX(SUB) = 4 Piece "^" delimited string
+11 ;
+12 ; 1 Subset Name
+13 ; 2 Subset Definition IEN file 757.2
+14 ; 3 Subset IEN file 757.21
+15 ; 4 Expression IEN file 757.01
+16 ;
+17 KILL LEX
NEW LEXIENS,LEXMC,LEXIEN
SET LEXMC=+($GET(X))
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+18 if $PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)>0
QUIT
SET LEXIENS(LEXIEN)=""
End DoDot:1
+19 if $ORDER(LEXIENS(0))'>0
QUIT
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(LEXIENS(LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+20 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
+21 NEW LEXND,LEXSI,LEXSA,LEXSF
SET LEXSI=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
SET LEXND=$GET(^LEXT(757.2,+LEXSI,0))
+22 SET LEXSA=$PIECE(LEXND,"^",2)
SET LEXSF=$$MIX^LEXXM($PIECE(LEXND,"^",1))
+23 if $LENGTH(LEXSA)=3&($LENGTH(LEXSF))
SET LEX(LEXSA)=LEXSF_"^"_LEXSI_"^"_LEXSIEN_"^"_LEXIEN
End DoDot:2
End DoDot:1
+24 QUIT
MAPS(X,LEX,LEXD,LEXL) ; Get Mappings
+1 ;
+2 ; Input
+3 ;
+4 ; X SNOMED Code
+5 ; LEXD Versioning DAte
+6 ; LEXL Length of text
+7 ;
+8 ; Output
+9 ;
+10 ; LEX Array passed by Reference
+11 ;
+12 ; LEX(#) = Text
+13 ;
+14 NEW LEXIDT,LEXLEN,LEXISO,LEXMD,LEXTL
KILL LEX
SET LEXISO=$GET(X)
if '$LENGTH(LEXISO)
QUIT
+15 SET LEXIDT=$PIECE($GET(LEXD),".",1)
if LEXIDT'?7N
SET LEXIDT=$$DT^XLFDT
+16 SET LEXLEN=$GET(LEXL)
if +LEXLEN'>0
SET LEXLEN="18^25^53"
SET LEXTL=+($PIECE($GET(LEXLEN),"^",3))
+17 SET LEXMD=0
FOR
SET LEXMD=$ORDER(^LEX(757.32,+LEXMD))
if +LEXMD'>0
QUIT
Begin DoDot:1
+18 if +($PIECE($GET(^LEX(757.32,+LEXMD,2)),"^",1))'=58
QUIT
NEW LEXO,LEXSRC,LEXTO
SET LEXSRC=$PIECE($GET(^LEX(757.32,+LEXMD,2)),"^",2)
+19 SET LEXTO=+($PIECE($GET(^LEX(757.32,+LEXMD,2)),"^",2))
if +LEXTO'>0
QUIT
if '$DATA(^LEX(757.03,+LEXTO,0))
QUIT
+20 SET LEXO=""
FOR
SET LEXO=$ORDER(^LEX(757.33,"C",LEXMD,LEXISO,LEXO))
if '$LENGTH(LEXO)
QUIT
Begin DoDot:2
+21 NEW LEXC
SET LEXC=""
FOR
SET LEXC=$ORDER(^LEX(757.33,"C",LEXMD,LEXISO,LEXO,LEXC))
if '$LENGTH(LEXC)
QUIT
Begin DoDot:3
+22 NEW LEXE
SET LEXE=0
FOR
SET LEXE=$ORDER(^LEX(757.33,"C",LEXMD,LEXISO,LEXO,LEXC,LEXE))
if LEXE'>0
QUIT
Begin DoDot:4
+23 NEW LEXCODE,LEXEF,LEXEIEN,LEXEXP,LEXHI,LEXI,LEXMA,LEXMIEN,LEXN,LEXNOM,LEXSA,LEXSAB,LEXSIEN,LEXST,LEXT
+24 SET LEXMIEN=LEXE
SET LEXEF=$ORDER(^LEX(757.33,+LEXE,2,"B",(LEXIDT+.00001)),-1)
+25 SET LEXHI=$ORDER(^LEX(757.33,+LEXE,2,"B",+LEXEF," "),-1)
+26 SET LEXST=$PIECE($GET(^LEX(757.33,+LEXE,2,+LEXHI,0)),"^",2)
if LEXST'>0
QUIT
+27 SET LEXSA=$SELECT(LEXST>0:"",1:"(Inactive Mapping)")
+28 SET LEXMA=$PIECE($GET(^LEX(757.33,+LEXE,0)),"^",5)
+29 SET LEXMA=$SELECT(+LEXMA'>0:"(Partial Map)",1:"")
+30 SET LEXCODE=$PIECE($GET(^LEX(757.33,+LEXE,0)),"^",3)
if '$LENGTH(LEXCODE)
QUIT
+31 SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXTO,0)),"^",2)
if '$LENGTH(LEXNOM)
QUIT
+32 SET LEXSAB=$EXTRACT($PIECE($GET(^LEX(757.03,+LEXTO,0)),"^",1),1,3)
if $LENGTH(LEXSAB)'=3
QUIT
+33 SET LEXSRC=$$STATCHK^LEXSRC2(LEXCODE,LEXIDT,,LEXSAB)
+34 SET LEXSIEN=$PIECE(LEXSRC,"^",2)
if +LEXSIEN'>0
QUIT
+35 SET LEXEIEN=+($GET(^LEX(757.02,+LEXSIEN,0)))
+36 SET LEXEXP=$GET(^LEX(757.01,+LEXEIEN,0))
if '$LENGTH(LEXEXP)
QUIT
+37 SET LEXT=LEXEXP_" ("_LEXNOM_" "_LEXCODE_")"
+38 if $LENGTH(LEXMA)
SET LEXT=LEXT_" "_LEXMA
+39 if $LENGTH(LEXSA)
SET LEXT=LEXT_" "_LEXSA
+40 if $DATA(LEXIIEN)
SET LEXT=LEXT_" (IEN "_LEXMIEN_")"
+41 KILL LEXN
SET LEXN(1)=LEXT
DO PR^LEXU(.LEXN,(+($GET(LEXTL))-4))
+42 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXN(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:5
+43 NEW LEXC,LEXT
SET LEXT=$GET(LEXN(LEXI))
if '$LENGTH(LEXT)
QUIT
+44 SET LEXC=$ORDER(LEX(" "),-1)+1
if LEXI=1
SET LEX(LEXC)=LEXT
if LEXI>1
SET LEX(LEXC)=" "_LEXT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+45 QUIT
