LEXU7 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757, SACC 1.3
; ^LEX(757.001, 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.1, SACC 1.3
; ^LEX(757.11, SACC 1.3
; ^LEX(757.12, SACC 1.3
;
; External References
; $$CODEN^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$PERIOD^ICDEX ICR 5747
; $$STATCHK^ICDEX ICR 5747
; PERIOD^ICPTAPIU ICR 1997
; $$CODEN^ICPTCOD ICR 1995
; $$CPT^ICPTCOD ICR 1995
; $$DT^XLFDT ICR 10103
;
IENS(X,LEX,CDT) ; Get Lexicon/National File IENS for a Code
;
; Input
;
; X Code
; LEX Local Array passed by .reference
; CDT Versioning Date (default TODAY)
;
; Output
;
; $$IENS Number of Entries found
;
; LEX Local Array
;
; LEX(0) 3 Piece "^" delimited string
;
; 1 Number of Entries found
; 2 Code
; 3 Date used
;
; LEX(#,757) 2 Piece "^" delimited string
;
; 1 IEN to file #757
; 2 IEN to file #757.01
;
; LEX(#,757.001) 3 Piece "^" delimited string
;
; 1 IEN to file #757.001
; 2 Originating Value
; 3 Frequency
;
; LEX(#,757.01) 8 Piece "^" delimited string
;
; 1 IEN to file #757.01
; 2 Expression Type
; 3 Expression Form
; 4 Expression Deactivation Flag
; 5 External Expression Type
; 6 External Expression Form
; 7 External Deactivation Flag
; 8 Expression
;
; LEX(#,757.01,7,CD) 5 Piece "^" delimited string
;
; Where CD is a Designation Code
;
; 1 IEN of sub-file #757.118
; 2 Pointer to file #757.03
; 3 Pointer to file #757.018
; 4 Coding System nomenclature
; 5 Name of SNOMED CT Hierarchy
;
; LEX(#,757.02) 5 Piece "^" delimited string
;
; 1 IEN to file #757.02
; 2 Code
; 3 Initial Activation Date
; 4 Status
; 5 Status Effective Date
;
; LEX(#,757.02,4,EFF) 2 Piece "^" delimited string
;
; Where EFF is the effective date for a Status
;
; 1 IEN of sub-file #757.28
; 2 Status (1=Active, 0=Inactive)
;
; LEX(#,757.03) 3 Piece "^" delimited string
;
; 1 IEN to file #757.03
; 2 Source Abbreviation
; 3 Source Nomenclature
;
; LEX(#,757.1,#) 6 Piece "^" delimited string (multiple)
;
; 1 IEN to file #757.1
; 2 IEN to file #757
; 3 IEN to file #757.11
; 4 IEN to file #757.12
; 5 Semantic Class (external)
; 6 Semantic Type (external)
;
; LEX(#,"VA",SR) 6 Piece "^" delimited string (multiple)
;
; Where SR is a pointer to the CODING SYSTEM file 757.03
;
; 1 Variable Pointer to a VA National File
; 2 Code from VA file
; 3 Coding System Nomenclature
; 4 Initial Activation Date in the VA file
; 5 Status in the VA file
; 6 Status Effective Date in the VA file
;
; Example
;
; ARY(0)="2^250.01^3150101"
; ARY(1,757)="7006^33586"
; ARY(1,757.001)="7006^4^4"
; ARY(1,757.01)="33586^1^1^^Major Concept^Major Concept^^
; Diabetes Mellitus Type I"
; ARY(1,757.02)="316386^250.01^2781001^0^3041001"
; ARY(1,757.02,4,2781001)="1^1"
; ARY(1,757.02,4,3041001)="2^0"
; ARY(1,757.03)="1^ICD^ICD-9-CM"
; ARY(1,757.1,1)="10167^7006^6^47^Diseases/Pathologic
; Processes^Disease or Syndrome"
; ARY(1,"VA",1)="851;ICD9(^250.01^ICD-9-CM^2781001^1^2781001"
; ARY(2,757)="182207^331780"
; ARY(2,757.001)="182207^4^4"
; ARY(2,757.01)="331780^1^1^^Major Concept^Major Concept^^
; Diabetes Mellitus without mention of
; Complication, type i [Juvenile type], not
; stated as Uncontrolled"
; ARY(2,757.02)="327553^250.01^3041001^1^3041001"
; ARY(2,757.02,4,3041001)="1^1"
; ARY(2,757.02,4,3151001)="2^0"
; ARY(2,757.03)="1^ICD^ICD-9-CM"
; ARY(2,757.1,1)="259374^182207^6^47^Diseases/Pathologic
; Processes^Disease or Syndrome"
; ARY(2,"VA",1)="851;ICD9(^250.01^ICD-9-CM^2781001^1^2781001"
;
N LEXCD,LEXCDT,LEXSIEN K LEX S LEXCD=$G(X),LEXCDT=$G(CDT) Q:'$L(LEXCD) 0 Q:'$D(^LEX(757.02,"CODE",(LEXCD_" "))) 0
S:LEXCDT'?7N LEXCDT=$$DT^XLFDT Q:$O(^LEX(757.02,"CODE",(LEXCD_" "),0))'>0 0
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXCD_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXE,LEXEF,LEXEX,LEXH,LEXHI,LEXI,LEXIA,LEXLEX,LEXMC,LEXND,LEXSDO,LEXSMIEN,LEXSR,LEXST S LEXSDO=""
. S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0 S LEXEX=+LEXND,LEXSR=$P(LEXND,"^",3)
. S LEXMC=$P(LEXND,"^",4)
. I +LEXSR=3!(+LEXSR=4) D
. . N LEXA,LEXEFF,LEXIA,LEXP,LEXSTA S LEXP=$$CODEN^ICPTCOD(LEXCD) Q:+LEXP'>0
. . S LEXSDO=+LEXP_";ICPT("_"^"_LEXCD_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2)
. . S LEXP=$$CPT^ICPTCOD(LEXCD,LEXCDT) S LEXSTA=$P(LEXP,"^",7)
. . S:LEXSTA>0 LEXEFF=$P(LEXP,"^",9) S:LEXSTA'>0 LEXEFF=$P(LEXP,"^",8)
. . D PERIOD^ICPTAPIU(LEXCD,.LEXA) S LEXIA=$O(LEXA(0))
. . S:LEXSTA?1N&(LEXEFF?7N) LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
. I +LEXSR=1!(+LEXSR=30) D
. . N LEXA,LEXE,LEXEFF,LEXIA,LEXP,LEXS,LEXSTA S LEXSDO="",LEXP=$$CODEN^ICDEX(LEXCD,80)
. . Q:+LEXP'>0 S LEXS=$$CSI^ICDEX(80,+LEXP) Q:LEXS'=LEXSR S LEXSDO=+LEXP_";ICD9("_"^"_LEXCD
. . S LEXSDO=LEXSDO_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2),LEXP=$$STATCHK^ICDEX(LEXCD,LEXCDT,LEXSR)
. . S LEXSTA=$P(LEXP,"^",1),LEXEFF=$P(LEXP,"^",3) S:+LEXSTA<0 LEXSTA=0,LEXEFF=""
. . S LEXE=$$PERIOD^ICDEX(LEXCD,.LEXA,LEXSR) S LEXIA=$O(LEXA(0))
. . S:LEXSTA?1N&(LEXEFF?7N) LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
. I +LEXSR=2!(+LEXSR=31) D
. . N LEXA,LEXE,LEXEFF,LEXIA,LEXP,LEXS,LEXSTA S LEXSDO="",LEXP=$$CODEN^ICDEX(LEXCD,80.1)
. . Q:+LEXP'>0 S LEXS=$$CSI^ICDEX(80.1,+LEXP) Q:LEXS'=LEXSR S LEXSDO=+LEXP_";ICD0("_"^"_LEXCD
. . S LEXSDO=LEXSDO_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2),LEXP=$$STATCHK^ICDEX(LEXCD,LEXCDT,LEXSR)
. . S LEXSTA=$P(LEXP,"^",1),LEXEFF=$P(LEXP,"^",3),LEXE=$$PERIOD^ICDEX(LEXCD,.LEXA,LEXSR),LEXIA=$O(LEXA(0))
. . S:LEXSTA?1N&(LEXEFF?7N) LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
. S LEXHI=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXCDT+.0001)),-1),LEXHI=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXHI," "),-1)
. S LEXHI=$G(^LEX(757.02,+LEXSIEN,4,+LEXHI,0)),LEXST=$P(LEXHI,"^",2),LEXEF=$P(LEXHI,"^",1)
. S LEXHI=$O(^LEX(757.02,+LEXSIEN,4,"B",0)),LEXHI=$O(^LEX(757.02,+LEXSIEN,4,+LEXHI)),LEXHI=$G(^LEX(757.02,+LEXSIEN,4,+LEXHI,0))
. S (LEXIA,LEXE)="" F S LEXE=$O(^LEX(757.02,+LEXSIEN,4,"B",LEXE)) Q:(LEXE'?7N)!($L(LEXIA)) D Q:$L(LEXIA)
. . N LEXH S LEXH=" " F S LEXH=$O(^LEX(757.02,+LEXSIEN,4,"B",LEXE,LEXH),-1) Q:+LEXH'>0 D Q:$L(LEXIA)
. . . N LEXND,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,4,+LEXH,0))
. . . S LEXST=$P(LEXND,"^",2) S:LEXST?1N&(+LEXST>0)&('$L(LEXIA)) LEXIA=LEXE
. S LEXLEX=LEXEX_"^"_LEXSIEN_"^"_LEXCD_"^"_LEXSR_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2)_"^"_LEXIA_"^"_LEXST_"^"_LEXEF
. S LEXI=$O(LEX(" "),-1)+1
. ; Save IENs for:
. ; Major Concept Map
. S LEX(+LEXI,757)=LEXMC_"^"_+($G(^LEX(757,+LEXMC,0)))
. ; Frequency
. S LEX(+LEXI,757.001)=LEXMC_"^"_$P($G(^LEX(757.001,+LEXMC,0)),"^",2)_"^"_$P($G(^LEX(757.001,+LEXMC,0)),"^",3)
. ; Expression
. S LEX(+LEXI,757.01)=LEXEX I $D(^LEX(757.01,+LEXEX,0)) D
. . N LEXT,LEXTE,LEXF,LEXFE,LEXD,LEXDE,LEXE
. . S LEXT=$P($G(^LEX(757.01,+LEXEX,1)),"^",2) S:$L(LEXT) $P(LEX(+LEXI,757.01),"^",2)=LEXT
. . S LEXF=$P($G(^LEX(757.01,+LEXEX,1)),"^",4) S:$L(LEXF) $P(LEX(+LEXI,757.01),"^",3)=LEXF
. . S LEXD=$P($G(^LEX(757.01,+LEXEX,1)),"^",5) S:$L(LEXF) $P(LEX(+LEXI,757.01),"^",4)=LEXD
. . S LEXTE=$$MIX^LEXXM($P($G(^LEX(757.011,+LEXT,0)),"^",1)) S:$L(LEXTE) $P(LEX(+LEXI,757.01),"^",5)=LEXTE
. . S LEXFE=$$MIX^LEXXM($P($G(^LEX(757.014,+LEXF,0)),"^",2)) S:$L(LEXFE) $P(LEX(+LEXI,757.01),"^",6)=LEXFE
. . S LEXDE=$S(LEXD>0:"Deactivated",1:"") S:$L(LEXDE) $P(LEX(+LEXI,757.01),"^",7)=LEXDE
. . S LEXE=$G(^LEX(757.01,+LEXEX,0)) S:$L(LEXE) $P(LEX(+LEXI,757.01),"^",8)=LEXE
. S LEXE=0 F S LEXE=$O(^LEX(757.01,+LEXEX,7,LEXE)) Q:+LEXE'>0 D
. . N LEXND,LEXDC,LEXCS,LEXHI,LEXCSE,LEXHIE,LEXHIA,LEXO S LEXND=$G(^LEX(757.01,+LEXEX,7,LEXE,0)),LEXDC=$P(LEXND,"^",1) Q:'$L(LEXDC)
. . S LEXCS=$P(LEXND,"^",2) Q:'$L(LEXCS) S LEXCSE=$P($G(^LEX(757.03,+LEXCS,0)),"^",2),LEXHI=$P(LEXND,"^",3)
. . S LEXHIE=$G(^LEX(757.018,+LEXHI,0)),LEXHIA=$P(LEXHIE,"^",2),LEXHIE=$P(LEXHIE,"^",1),LEXO=LEXE
. . S:$L(LEXCS) $P(LEXO,"^",2)=LEXCS S:$L(LEXHI) $P(LEXO,"^",3)=LEXHI S:$L(LEXCSE) $P(LEXO,"^",4)=LEXCSE
. . S:$L(LEXHIE) $P(LEXO,"^",5)=LEXHIE S:$L(LEXHIA) $P(LEXO,"^",6)=LEXHIA S LEX(+LEXI,757.01,7,LEXDC)=LEXO
. ; Code
. S LEX(+LEXI,757.02)=LEXSIEN_"^"_LEXCD_"^"_LEXIA_"^"_LEXST_"^"_LEXEF
. S LEXE=0 F S LEXE=$O(^LEX(757.02,+LEXSIEN,4,LEXE)) Q:+LEXE'>0 D
. . N LEXND,LEXEF,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,4,+LEXE,0)),LEXEF=$P(LEXND,"^",1),LEXST=$P(LEXND,"^",2)
. . Q:LEXEF'?7N Q:LEXST'?1N S LEX(+LEXI,757.02,4,LEXEF)=LEXE_"^"_LEXST
. ; Coding System
. S LEX(+LEXI,757.03)=LEXSR_"^"_$E($P($G(^LEX(757.03,+LEXSR,0)),"^",1),1,3)_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2)
. ; Semantic Map
. S LEXSMIEN=0 F S LEXSMIEN=$O(^LEX(757.1,"B",+LEXMC,LEXSMIEN)) Q:+LEXSMIEN'>0 D
. . N LEXND,LEXTI,LEXTE,LEXCI,LEXCE,LEXS,LEXMC S LEXND=$G(^LEX(757.1,+LEXSMIEN,0))
. . S LEXMC=$P(LEXND,"^",1),LEXCI=$P(LEXND,"^",2),LEXTI=$P(LEXND,"^",3)
. . S LEXCE=$P($G(^LEX(757.11,+LEXCI,0)),"^",2),LEXTE=$P($G(^LEX(757.12,+LEXTI,0)),"^",2),LEXS=$O(LEX(+LEXI,757.1," "),-1)+1
. . S LEX(+LEXI,757.1,+LEXS)=+LEXSMIEN_"^"_LEXMC_"^"_LEXCI_"^"_LEXTI_"^"_LEXCE_"^"_LEXTE
. S:$L($G(LEXCD)) $P(LEX(0),"^",2)=$G(LEXCD) S:$G(LEXCDT)?7N $P(LEX(0),"^",3)=$G(LEXCDT)
. ; VA File
. S:$L($G(LEXSDO)) LEX(+LEXI,"VA",LEXSR)=LEXSDO
. S LEX(0)=LEXI S:$L($G(LEXCD)) $P(LEX(0),"^",2)=LEXCD S:$G(LEXCDT)?7N $P(LEX(0),"^",3)=LEXCDT
Q +($G(LEX(0)))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXU7 10692 printed Oct 16, 2024@18:10:37 Page 2
LEXU7 ;ISL/KER - Miscellaneous Lexicon Utilities ;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.001, SACC 1.3
+6 ; ^LEX(757.01, SACC 1.3
+7 ; ^LEX(757.018 SACC 1.3
+8 ; ^LEX(757.02, SACC 1.3
+9 ; ^LEX(757.03, SACC 1.3
+10 ; ^LEX(757.1, SACC 1.3
+11 ; ^LEX(757.11, SACC 1.3
+12 ; ^LEX(757.12, SACC 1.3
+13 ;
+14 ; External References
+15 ; $$CODEN^ICDEX ICR 5747
+16 ; $$CSI^ICDEX ICR 5747
+17 ; $$PERIOD^ICDEX ICR 5747
+18 ; $$STATCHK^ICDEX ICR 5747
+19 ; PERIOD^ICPTAPIU ICR 1997
+20 ; $$CODEN^ICPTCOD ICR 1995
+21 ; $$CPT^ICPTCOD ICR 1995
+22 ; $$DT^XLFDT ICR 10103
+23 ;
IENS(X,LEX,CDT) ; Get Lexicon/National File IENS for a Code
+1 ;
+2 ; Input
+3 ;
+4 ; X Code
+5 ; LEX Local Array passed by .reference
+6 ; CDT Versioning Date (default TODAY)
+7 ;
+8 ; Output
+9 ;
+10 ; $$IENS Number of Entries found
+11 ;
+12 ; LEX Local Array
+13 ;
+14 ; LEX(0) 3 Piece "^" delimited string
+15 ;
+16 ; 1 Number of Entries found
+17 ; 2 Code
+18 ; 3 Date used
+19 ;
+20 ; LEX(#,757) 2 Piece "^" delimited string
+21 ;
+22 ; 1 IEN to file #757
+23 ; 2 IEN to file #757.01
+24 ;
+25 ; LEX(#,757.001) 3 Piece "^" delimited string
+26 ;
+27 ; 1 IEN to file #757.001
+28 ; 2 Originating Value
+29 ; 3 Frequency
+30 ;
+31 ; LEX(#,757.01) 8 Piece "^" delimited string
+32 ;
+33 ; 1 IEN to file #757.01
+34 ; 2 Expression Type
+35 ; 3 Expression Form
+36 ; 4 Expression Deactivation Flag
+37 ; 5 External Expression Type
+38 ; 6 External Expression Form
+39 ; 7 External Deactivation Flag
+40 ; 8 Expression
+41 ;
+42 ; LEX(#,757.01,7,CD) 5 Piece "^" delimited string
+43 ;
+44 ; Where CD is a Designation Code
+45 ;
+46 ; 1 IEN of sub-file #757.118
+47 ; 2 Pointer to file #757.03
+48 ; 3 Pointer to file #757.018
+49 ; 4 Coding System nomenclature
+50 ; 5 Name of SNOMED CT Hierarchy
+51 ;
+52 ; LEX(#,757.02) 5 Piece "^" delimited string
+53 ;
+54 ; 1 IEN to file #757.02
+55 ; 2 Code
+56 ; 3 Initial Activation Date
+57 ; 4 Status
+58 ; 5 Status Effective Date
+59 ;
+60 ; LEX(#,757.02,4,EFF) 2 Piece "^" delimited string
+61 ;
+62 ; Where EFF is the effective date for a Status
+63 ;
+64 ; 1 IEN of sub-file #757.28
+65 ; 2 Status (1=Active, 0=Inactive)
+66 ;
+67 ; LEX(#,757.03) 3 Piece "^" delimited string
+68 ;
+69 ; 1 IEN to file #757.03
+70 ; 2 Source Abbreviation
+71 ; 3 Source Nomenclature
+72 ;
+73 ; LEX(#,757.1,#) 6 Piece "^" delimited string (multiple)
+74 ;
+75 ; 1 IEN to file #757.1
+76 ; 2 IEN to file #757
+77 ; 3 IEN to file #757.11
+78 ; 4 IEN to file #757.12
+79 ; 5 Semantic Class (external)
+80 ; 6 Semantic Type (external)
+81 ;
+82 ; LEX(#,"VA",SR) 6 Piece "^" delimited string (multiple)
+83 ;
+84 ; Where SR is a pointer to the CODING SYSTEM file 757.03
+85 ;
+86 ; 1 Variable Pointer to a VA National File
+87 ; 2 Code from VA file
+88 ; 3 Coding System Nomenclature
+89 ; 4 Initial Activation Date in the VA file
+90 ; 5 Status in the VA file
+91 ; 6 Status Effective Date in the VA file
+92 ;
+93 ; Example
+94 ;
+95 ; ARY(0)="2^250.01^3150101"
+96 ; ARY(1,757)="7006^33586"
+97 ; ARY(1,757.001)="7006^4^4"
+98 ; ARY(1,757.01)="33586^1^1^^Major Concept^Major Concept^^
+99 ; Diabetes Mellitus Type I"
+100 ; ARY(1,757.02)="316386^250.01^2781001^0^3041001"
+101 ; ARY(1,757.02,4,2781001)="1^1"
+102 ; ARY(1,757.02,4,3041001)="2^0"
+103 ; ARY(1,757.03)="1^ICD^ICD-9-CM"
+104 ; ARY(1,757.1,1)="10167^7006^6^47^Diseases/Pathologic
+105 ; Processes^Disease or Syndrome"
+106 ; ARY(1,"VA",1)="851;ICD9(^250.01^ICD-9-CM^2781001^1^2781001"
+107 ; ARY(2,757)="182207^331780"
+108 ; ARY(2,757.001)="182207^4^4"
+109 ; ARY(2,757.01)="331780^1^1^^Major Concept^Major Concept^^
+110 ; Diabetes Mellitus without mention of
+111 ; Complication, type i [Juvenile type], not
+112 ; stated as Uncontrolled"
+113 ; ARY(2,757.02)="327553^250.01^3041001^1^3041001"
+114 ; ARY(2,757.02,4,3041001)="1^1"
+115 ; ARY(2,757.02,4,3151001)="2^0"
+116 ; ARY(2,757.03)="1^ICD^ICD-9-CM"
+117 ; ARY(2,757.1,1)="259374^182207^6^47^Diseases/Pathologic
+118 ; Processes^Disease or Syndrome"
+119 ; ARY(2,"VA",1)="851;ICD9(^250.01^ICD-9-CM^2781001^1^2781001"
+120 ;
+121 NEW LEXCD,LEXCDT,LEXSIEN
KILL LEX
SET LEXCD=$GET(X)
SET LEXCDT=$GET(CDT)
if '$LENGTH(LEXCD)
QUIT 0
if '$DATA(^LEX(757.02,"CODE",(LEXCD_" ")))
QUIT 0
+122 if LEXCDT'?7N
SET LEXCDT=$$DT^XLFDT
if $ORDER(^LEX(757.02,"CODE",(LEXCD_" "),0))'>0
QUIT 0
+123 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXCD_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+124 NEW LEXE,LEXEF,LEXEX,LEXH,LEXHI,LEXI,LEXIA,LEXLEX,LEXMC,LEXND,LEXSDO,LEXSMIEN,LEXSR,LEXST
SET LEXSDO=""
+125 SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
if $PIECE(LEXND,"^",5)'>0
QUIT
SET LEXEX=+LEXND
SET LEXSR=$PIECE(LEXND,"^",3)
+126 SET LEXMC=$PIECE(LEXND,"^",4)
+127 IF +LEXSR=3!(+LEXSR=4)
Begin DoDot:2
+128 NEW LEXA,LEXEFF,LEXIA,LEXP,LEXSTA
SET LEXP=$$CODEN^ICPTCOD(LEXCD)
if +LEXP'>0
QUIT
+129 SET LEXSDO=+LEXP_";ICPT("_"^"_LEXCD_"^"_$PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",2)
+130 SET LEXP=$$CPT^ICPTCOD(LEXCD,LEXCDT)
SET LEXSTA=$PIECE(LEXP,"^",7)
+131 if LEXSTA>0
SET LEXEFF=$PIECE(LEXP,"^",9)
if LEXSTA'>0
SET LEXEFF=$PIECE(LEXP,"^",8)
+132 DO PERIOD^ICPTAPIU(LEXCD,.LEXA)
SET LEXIA=$ORDER(LEXA(0))
+133 if LEXSTA?1N&(LEXEFF?7N)
SET LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
End DoDot:2
+134 IF +LEXSR=1!(+LEXSR=30)
Begin DoDot:2
+135 NEW LEXA,LEXE,LEXEFF,LEXIA,LEXP,LEXS,LEXSTA
SET LEXSDO=""
SET LEXP=$$CODEN^ICDEX(LEXCD,80)
+136 if +LEXP'>0
QUIT
SET LEXS=$$CSI^ICDEX(80,+LEXP)
if LEXS'=LEXSR
QUIT
SET LEXSDO=+LEXP_";ICD9("_"^"_LEXCD
+137 SET LEXSDO=LEXSDO_"^"_$PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",2)
SET LEXP=$$STATCHK^ICDEX(LEXCD,LEXCDT,LEXSR)
+138 SET LEXSTA=$PIECE(LEXP,"^",1)
SET LEXEFF=$PIECE(LEXP,"^",3)
if +LEXSTA<0
SET LEXSTA=0
SET LEXEFF=""
+139 SET LEXE=$$PERIOD^ICDEX(LEXCD,.LEXA,LEXSR)
SET LEXIA=$ORDER(LEXA(0))
+140 if LEXSTA?1N&(LEXEFF?7N)
SET LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
End DoDot:2
+141 IF +LEXSR=2!(+LEXSR=31)
Begin DoDot:2
+142 NEW LEXA,LEXE,LEXEFF,LEXIA,LEXP,LEXS,LEXSTA
SET LEXSDO=""
SET LEXP=$$CODEN^ICDEX(LEXCD,80.1)
+143 if +LEXP'>0
QUIT
SET LEXS=$$CSI^ICDEX(80.1,+LEXP)
if LEXS'=LEXSR
QUIT
SET LEXSDO=+LEXP_";ICD0("_"^"_LEXCD
+144 SET LEXSDO=LEXSDO_"^"_$PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",2)
SET LEXP=$$STATCHK^ICDEX(LEXCD,LEXCDT,LEXSR)
+145 SET LEXSTA=$PIECE(LEXP,"^",1)
SET LEXEFF=$PIECE(LEXP,"^",3)
SET LEXE=$$PERIOD^ICDEX(LEXCD,.LEXA,LEXSR)
SET LEXIA=$ORDER(LEXA(0))
+146 if LEXSTA?1N&(LEXEFF?7N)
SET LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
End DoDot:2
+147 SET LEXHI=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",(LEXCDT+.0001)),-1)
SET LEXHI=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXHI," "),-1)
+148 SET LEXHI=$GET(^LEX(757.02,+LEXSIEN,4,+LEXHI,0))
SET LEXST=$PIECE(LEXHI,"^",2)
SET LEXEF=$PIECE(LEXHI,"^",1)
+149 SET LEXHI=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",0))
SET LEXHI=$ORDER(^LEX(757.02,+LEXSIEN,4,+LEXHI))
SET LEXHI=$GET(^LEX(757.02,+LEXSIEN,4,+LEXHI,0))
+150 SET (LEXIA,LEXE)=""
FOR
SET LEXE=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",LEXE))
if (LEXE'?7N)!($LENGTH(LEXIA))
QUIT
Begin DoDot:2
+151 NEW LEXH
SET LEXH=" "
FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",LEXE,LEXH),-1)
if +LEXH'>0
QUIT
Begin DoDot:3
+152 NEW LEXND,LEXST
SET LEXND=$GET(^LEX(757.02,+LEXSIEN,4,+LEXH,0))
+153 SET LEXST=$PIECE(LEXND,"^",2)
if LEXST?1N&(+LEXST>0)&('$LENGTH(LEXIA))
SET LEXIA=LEXE
End DoDot:3
if $LENGTH(LEXIA)
QUIT
End DoDot:2
if $LENGTH(LEXIA)
QUIT
+154 SET LEXLEX=LEXEX_"^"_LEXSIEN_"^"_LEXCD_"^"_LEXSR_"^"_$PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",2)_"^"_LEXIA_"^"_LEXST_"^"_LEXEF
+155 SET LEXI=$ORDER(LEX(" "),-1)+1
+156 ; Save IENs for:
+157 ; Major Concept Map
+158 SET LEX(+LEXI,757)=LEXMC_"^"_+($GET(^LEX(757,+LEXMC,0)))
+159 ; Frequency
+160 SET LEX(+LEXI,757.001)=LEXMC_"^"_$PIECE($GET(^LEX(757.001,+LEXMC,0)),"^",2)_"^"_$PIECE($GET(^LEX(757.001,+LEXMC,0)),"^",3)
+161 ; Expression
+162 SET LEX(+LEXI,757.01)=LEXEX
IF $DATA(^LEX(757.01,+LEXEX,0))
Begin DoDot:2
+163 NEW LEXT,LEXTE,LEXF,LEXFE,LEXD,LEXDE,LEXE
+164 SET LEXT=$PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",2)
if $LENGTH(LEXT)
SET $PIECE(LEX(+LEXI,757.01),"^",2)=LEXT
+165 SET LEXF=$PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",4)
if $LENGTH(LEXF)
SET $PIECE(LEX(+LEXI,757.01),"^",3)=LEXF
+166 SET LEXD=$PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",5)
if $LENGTH(LEXF)
SET $PIECE(LEX(+LEXI,757.01),"^",4)=LEXD
+167 SET LEXTE=$$MIX^LEXXM($PIECE($GET(^LEX(757.011,+LEXT,0)),"^",1))
if $LENGTH(LEXTE)
SET $PIECE(LEX(+LEXI,757.01),"^",5)=LEXTE
+168 SET LEXFE=$$MIX^LEXXM($PIECE($GET(^LEX(757.014,+LEXF,0)),"^",2))
if $LENGTH(LEXFE)
SET $PIECE(LEX(+LEXI,757.01),"^",6)=LEXFE
+169 SET LEXDE=$SELECT(LEXD>0:"Deactivated",1:"")
if $LENGTH(LEXDE)
SET $PIECE(LEX(+LEXI,757.01),"^",7)=LEXDE
+170 SET LEXE=$GET(^LEX(757.01,+LEXEX,0))
if $LENGTH(LEXE)
SET $PIECE(LEX(+LEXI,757.01),"^",8)=LEXE
End DoDot:2
+171 SET LEXE=0
FOR
SET LEXE=$ORDER(^LEX(757.01,+LEXEX,7,LEXE))
if +LEXE'>0
QUIT
Begin DoDot:2
+172 NEW LEXND,LEXDC,LEXCS,LEXHI,LEXCSE,LEXHIE,LEXHIA,LEXO
SET LEXND=$GET(^LEX(757.01,+LEXEX,7,LEXE,0))
SET LEXDC=$PIECE(LEXND,"^",1)
if '$LENGTH(LEXDC)
QUIT
+173 SET LEXCS=$PIECE(LEXND,"^",2)
if '$LENGTH(LEXCS)
QUIT
SET LEXCSE=$PIECE($GET(^LEX(757.03,+LEXCS,0)),"^",2)
SET LEXHI=$PIECE(LEXND,"^",3)
+174 SET LEXHIE=$GET(^LEX(757.018,+LEXHI,0))
SET LEXHIA=$PIECE(LEXHIE,"^",2)
SET LEXHIE=$PIECE(LEXHIE,"^",1)
SET LEXO=LEXE
+175 if $LENGTH(LEXCS)
SET $PIECE(LEXO,"^",2)=LEXCS
if $LENGTH(LEXHI)
SET $PIECE(LEXO,"^",3)=LEXHI
if $LENGTH(LEXCSE)
SET $PIECE(LEXO,"^",4)=LEXCSE
+176 if $LENGTH(LEXHIE)
SET $PIECE(LEXO,"^",5)=LEXHIE
if $LENGTH(LEXHIA)
SET $PIECE(LEXO,"^",6)=LEXHIA
SET LEX(+LEXI,757.01,7,LEXDC)=LEXO
End DoDot:2
+177 ; Code
+178 SET LEX(+LEXI,757.02)=LEXSIEN_"^"_LEXCD_"^"_LEXIA_"^"_LEXST_"^"_LEXEF
+179 SET LEXE=0
FOR
SET LEXE=$ORDER(^LEX(757.02,+LEXSIEN,4,LEXE))
if +LEXE'>0
QUIT
Begin DoDot:2
+180 NEW LEXND,LEXEF,LEXST
SET LEXND=$GET(^LEX(757.02,+LEXSIEN,4,+LEXE,0))
SET LEXEF=$PIECE(LEXND,"^",1)
SET LEXST=$PIECE(LEXND,"^",2)
+181 if LEXEF'?7N
QUIT
if LEXST'?1N
QUIT
SET LEX(+LEXI,757.02,4,LEXEF)=LEXE_"^"_LEXST
End DoDot:2
+182 ; Coding System
+183 SET LEX(+LEXI,757.03)=LEXSR_"^"_$EXTRACT($PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",1),1,3)_"^"_$PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",2)
+184 ; Semantic Map
+185 SET LEXSMIEN=0
FOR
SET LEXSMIEN=$ORDER(^LEX(757.1,"B",+LEXMC,LEXSMIEN))
if +LEXSMIEN'>0
QUIT
Begin DoDot:2
+186 NEW LEXND,LEXTI,LEXTE,LEXCI,LEXCE,LEXS,LEXMC
SET LEXND=$GET(^LEX(757.1,+LEXSMIEN,0))
+187 SET LEXMC=$PIECE(LEXND,"^",1)
SET LEXCI=$PIECE(LEXND,"^",2)
SET LEXTI=$PIECE(LEXND,"^",3)
+188 SET LEXCE=$PIECE($GET(^LEX(757.11,+LEXCI,0)),"^",2)
SET LEXTE=$PIECE($GET(^LEX(757.12,+LEXTI,0)),"^",2)
SET LEXS=$ORDER(LEX(+LEXI,757.1," "),-1)+1
+189 SET LEX(+LEXI,757.1,+LEXS)=+LEXSMIEN_"^"_LEXMC_"^"_LEXCI_"^"_LEXTI_"^"_LEXCE_"^"_LEXTE
End DoDot:2
+190 if $LENGTH($GET(LEXCD))
SET $PIECE(LEX(0),"^",2)=$GET(LEXCD)
if $GET(LEXCDT)?7N
SET $PIECE(LEX(0),"^",3)=$GET(LEXCDT)
+191 ; VA File
+192 if $LENGTH($GET(LEXSDO))
SET LEX(+LEXI,"VA",LEXSR)=LEXSDO
+193 SET LEX(0)=LEXI
if $LENGTH($GET(LEXCD))
SET $PIECE(LEX(0),"^",2)=LEXCD
if $GET(LEXCDT)?7N
SET $PIECE(LEX(0),"^",3)=LEXCDT
End DoDot:1
+194 QUIT +($GET(LEX(0)))
