- 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 Feb 18, 2025@23:35:08 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
