Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXU7

LEXU7.m

Go to the documentation of this file.
  1. LEXU7 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757, SACC 1.3
  1. ; ^LEX(757.001, SACC 1.3
  1. ; ^LEX(757.01, SACC 1.3
  1. ; ^LEX(757.018 SACC 1.3
  1. ; ^LEX(757.02, SACC 1.3
  1. ; ^LEX(757.03, SACC 1.3
  1. ; ^LEX(757.1, SACC 1.3
  1. ; ^LEX(757.11, SACC 1.3
  1. ; ^LEX(757.12, SACC 1.3
  1. ;
  1. ; External References
  1. ; $$CODEN^ICDEX ICR 5747
  1. ; $$CSI^ICDEX ICR 5747
  1. ; $$PERIOD^ICDEX ICR 5747
  1. ; $$STATCHK^ICDEX ICR 5747
  1. ; PERIOD^ICPTAPIU ICR 1997
  1. ; $$CODEN^ICPTCOD ICR 1995
  1. ; $$CPT^ICPTCOD ICR 1995
  1. ; $$DT^XLFDT ICR 10103
  1. ;
  1. IENS(X,LEX,CDT) ; Get Lexicon/National File IENS for a Code
  1. ;
  1. ; Input
  1. ;
  1. ; X Code
  1. ; LEX Local Array passed by .reference
  1. ; CDT Versioning Date (default TODAY)
  1. ;
  1. ; Output
  1. ;
  1. ; $$IENS Number of Entries found
  1. ;
  1. ; LEX Local Array
  1. ;
  1. ; LEX(0) 3 Piece "^" delimited string
  1. ;
  1. ; 1 Number of Entries found
  1. ; 2 Code
  1. ; 3 Date used
  1. ;
  1. ; LEX(#,757) 2 Piece "^" delimited string
  1. ;
  1. ; 1 IEN to file #757
  1. ; 2 IEN to file #757.01
  1. ;
  1. ; LEX(#,757.001) 3 Piece "^" delimited string
  1. ;
  1. ; 1 IEN to file #757.001
  1. ; 2 Originating Value
  1. ; 3 Frequency
  1. ;
  1. ; LEX(#,757.01) 8 Piece "^" delimited string
  1. ;
  1. ; 1 IEN to file #757.01
  1. ; 2 Expression Type
  1. ; 3 Expression Form
  1. ; 4 Expression Deactivation Flag
  1. ; 5 External Expression Type
  1. ; 6 External Expression Form
  1. ; 7 External Deactivation Flag
  1. ; 8 Expression
  1. ;
  1. ; LEX(#,757.01,7,CD) 5 Piece "^" delimited string
  1. ;
  1. ; Where CD is a Designation Code
  1. ;
  1. ; 1 IEN of sub-file #757.118
  1. ; 2 Pointer to file #757.03
  1. ; 3 Pointer to file #757.018
  1. ; 4 Coding System nomenclature
  1. ; 5 Name of SNOMED CT Hierarchy
  1. ;
  1. ; LEX(#,757.02) 5 Piece "^" delimited string
  1. ;
  1. ; 1 IEN to file #757.02
  1. ; 2 Code
  1. ; 3 Initial Activation Date
  1. ; 4 Status
  1. ; 5 Status Effective Date
  1. ;
  1. ; LEX(#,757.02,4,EFF) 2 Piece "^" delimited string
  1. ;
  1. ; Where EFF is the effective date for a Status
  1. ;
  1. ; 1 IEN of sub-file #757.28
  1. ; 2 Status (1=Active, 0=Inactive)
  1. ;
  1. ; LEX(#,757.03) 3 Piece "^" delimited string
  1. ;
  1. ; 1 IEN to file #757.03
  1. ; 2 Source Abbreviation
  1. ; 3 Source Nomenclature
  1. ;
  1. ; LEX(#,757.1,#) 6 Piece "^" delimited string (multiple)
  1. ;
  1. ; 1 IEN to file #757.1
  1. ; 2 IEN to file #757
  1. ; 3 IEN to file #757.11
  1. ; 4 IEN to file #757.12
  1. ; 5 Semantic Class (external)
  1. ; 6 Semantic Type (external)
  1. ;
  1. ; LEX(#,"VA",SR) 6 Piece "^" delimited string (multiple)
  1. ;
  1. ; Where SR is a pointer to the CODING SYSTEM file 757.03
  1. ;
  1. ; 1 Variable Pointer to a VA National File
  1. ; 2 Code from VA file
  1. ; 3 Coding System Nomenclature
  1. ; 4 Initial Activation Date in the VA file
  1. ; 5 Status in the VA file
  1. ; 6 Status Effective Date in the VA file
  1. ;
  1. ; Example
  1. ;
  1. ; ARY(0)="2^250.01^3150101"
  1. ; ARY(1,757)="7006^33586"
  1. ; ARY(1,757.001)="7006^4^4"
  1. ; ARY(1,757.01)="33586^1^1^^Major Concept^Major Concept^^
  1. ; Diabetes Mellitus Type I"
  1. ; ARY(1,757.02)="316386^250.01^2781001^0^3041001"
  1. ; ARY(1,757.02,4,2781001)="1^1"
  1. ; ARY(1,757.02,4,3041001)="2^0"
  1. ; ARY(1,757.03)="1^ICD^ICD-9-CM"
  1. ; ARY(1,757.1,1)="10167^7006^6^47^Diseases/Pathologic
  1. ; Processes^Disease or Syndrome"
  1. ; ARY(1,"VA",1)="851;ICD9(^250.01^ICD-9-CM^2781001^1^2781001"
  1. ; ARY(2,757)="182207^331780"
  1. ; ARY(2,757.001)="182207^4^4"
  1. ; ARY(2,757.01)="331780^1^1^^Major Concept^Major Concept^^
  1. ; Diabetes Mellitus without mention of
  1. ; Complication, type i [Juvenile type], not
  1. ; stated as Uncontrolled"
  1. ; ARY(2,757.02)="327553^250.01^3041001^1^3041001"
  1. ; ARY(2,757.02,4,3041001)="1^1"
  1. ; ARY(2,757.02,4,3151001)="2^0"
  1. ; ARY(2,757.03)="1^ICD^ICD-9-CM"
  1. ; ARY(2,757.1,1)="259374^182207^6^47^Diseases/Pathologic
  1. ; Processes^Disease or Syndrome"
  1. ; ARY(2,"VA",1)="851;ICD9(^250.01^ICD-9-CM^2781001^1^2781001"
  1. ;
  1. 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
  1. S:LEXCDT'?7N LEXCDT=$$DT^XLFDT Q:$O(^LEX(757.02,"CODE",(LEXCD_" "),0))'>0 0
  1. S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXCD_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
  1. . N LEXE,LEXEF,LEXEX,LEXH,LEXHI,LEXI,LEXIA,LEXLEX,LEXMC,LEXND,LEXSDO,LEXSMIEN,LEXSR,LEXST S LEXSDO=""
  1. . S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0 S LEXEX=+LEXND,LEXSR=$P(LEXND,"^",3)
  1. . S LEXMC=$P(LEXND,"^",4)
  1. . I +LEXSR=3!(+LEXSR=4) D
  1. . . N LEXA,LEXEFF,LEXIA,LEXP,LEXSTA S LEXP=$$CODEN^ICPTCOD(LEXCD) Q:+LEXP'>0
  1. . . S LEXSDO=+LEXP_";ICPT("_"^"_LEXCD_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2)
  1. . . S LEXP=$$CPT^ICPTCOD(LEXCD,LEXCDT) S LEXSTA=$P(LEXP,"^",7)
  1. . . S:LEXSTA>0 LEXEFF=$P(LEXP,"^",9) S:LEXSTA'>0 LEXEFF=$P(LEXP,"^",8)
  1. . . D PERIOD^ICPTAPIU(LEXCD,.LEXA) S LEXIA=$O(LEXA(0))
  1. . . S:LEXSTA?1N&(LEXEFF?7N) LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
  1. . I +LEXSR=1!(+LEXSR=30) D
  1. . . N LEXA,LEXE,LEXEFF,LEXIA,LEXP,LEXS,LEXSTA S LEXSDO="",LEXP=$$CODEN^ICDEX(LEXCD,80)
  1. . . Q:+LEXP'>0 S LEXS=$$CSI^ICDEX(80,+LEXP) Q:LEXS'=LEXSR S LEXSDO=+LEXP_";ICD9("_"^"_LEXCD
  1. . . S LEXSDO=LEXSDO_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2),LEXP=$$STATCHK^ICDEX(LEXCD,LEXCDT,LEXSR)
  1. . . S LEXSTA=$P(LEXP,"^",1),LEXEFF=$P(LEXP,"^",3) S:+LEXSTA<0 LEXSTA=0,LEXEFF=""
  1. . . S LEXE=$$PERIOD^ICDEX(LEXCD,.LEXA,LEXSR) S LEXIA=$O(LEXA(0))
  1. . . S:LEXSTA?1N&(LEXEFF?7N) LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
  1. . I +LEXSR=2!(+LEXSR=31) D
  1. . . N LEXA,LEXE,LEXEFF,LEXIA,LEXP,LEXS,LEXSTA S LEXSDO="",LEXP=$$CODEN^ICDEX(LEXCD,80.1)
  1. . . Q:+LEXP'>0 S LEXS=$$CSI^ICDEX(80.1,+LEXP) Q:LEXS'=LEXSR S LEXSDO=+LEXP_";ICD0("_"^"_LEXCD
  1. . . S LEXSDO=LEXSDO_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2),LEXP=$$STATCHK^ICDEX(LEXCD,LEXCDT,LEXSR)
  1. . . S LEXSTA=$P(LEXP,"^",1),LEXEFF=$P(LEXP,"^",3),LEXE=$$PERIOD^ICDEX(LEXCD,.LEXA,LEXSR),LEXIA=$O(LEXA(0))
  1. . . S:LEXSTA?1N&(LEXEFF?7N) LEXSDO=LEXSDO_"^"_LEXIA_"^"_LEXSTA_"^"_LEXEFF
  1. . S LEXHI=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXCDT+.0001)),-1),LEXHI=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXHI," "),-1)
  1. . S LEXHI=$G(^LEX(757.02,+LEXSIEN,4,+LEXHI,0)),LEXST=$P(LEXHI,"^",2),LEXEF=$P(LEXHI,"^",1)
  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))
  1. . S (LEXIA,LEXE)="" F S LEXE=$O(^LEX(757.02,+LEXSIEN,4,"B",LEXE)) Q:(LEXE'?7N)!($L(LEXIA)) D Q:$L(LEXIA)
  1. . . N LEXH S LEXH=" " F S LEXH=$O(^LEX(757.02,+LEXSIEN,4,"B",LEXE,LEXH),-1) Q:+LEXH'>0 D Q:$L(LEXIA)
  1. . . . N LEXND,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,4,+LEXH,0))
  1. . . . S LEXST=$P(LEXND,"^",2) S:LEXST?1N&(+LEXST>0)&('$L(LEXIA)) LEXIA=LEXE
  1. . S LEXLEX=LEXEX_"^"_LEXSIEN_"^"_LEXCD_"^"_LEXSR_"^"_$P($G(^LEX(757.03,+LEXSR,0)),"^",2)_"^"_LEXIA_"^"_LEXST_"^"_LEXEF
  1. . S LEXI=$O(LEX(" "),-1)+1
  1. . ; Save IENs for:
  1. . ; Major Concept Map
  1. . S LEX(+LEXI,757)=LEXMC_"^"_+($G(^LEX(757,+LEXMC,0)))
  1. . ; Frequency
  1. . S LEX(+LEXI,757.001)=LEXMC_"^"_$P($G(^LEX(757.001,+LEXMC,0)),"^",2)_"^"_$P($G(^LEX(757.001,+LEXMC,0)),"^",3)
  1. . ; Expression
  1. . S LEX(+LEXI,757.01)=LEXEX I $D(^LEX(757.01,+LEXEX,0)) D
  1. . . N LEXT,LEXTE,LEXF,LEXFE,LEXD,LEXDE,LEXE
  1. . . S LEXT=$P($G(^LEX(757.01,+LEXEX,1)),"^",2) S:$L(LEXT) $P(LEX(+LEXI,757.01),"^",2)=LEXT
  1. . . S LEXF=$P($G(^LEX(757.01,+LEXEX,1)),"^",4) S:$L(LEXF) $P(LEX(+LEXI,757.01),"^",3)=LEXF
  1. . . S LEXD=$P($G(^LEX(757.01,+LEXEX,1)),"^",5) S:$L(LEXF) $P(LEX(+LEXI,757.01),"^",4)=LEXD
  1. . . S LEXTE=$$MIX^LEXXM($P($G(^LEX(757.011,+LEXT,0)),"^",1)) S:$L(LEXTE) $P(LEX(+LEXI,757.01),"^",5)=LEXTE
  1. . . S LEXFE=$$MIX^LEXXM($P($G(^LEX(757.014,+LEXF,0)),"^",2)) S:$L(LEXFE) $P(LEX(+LEXI,757.01),"^",6)=LEXFE
  1. . . S LEXDE=$S(LEXD>0:"Deactivated",1:"") S:$L(LEXDE) $P(LEX(+LEXI,757.01),"^",7)=LEXDE
  1. . . S LEXE=$G(^LEX(757.01,+LEXEX,0)) S:$L(LEXE) $P(LEX(+LEXI,757.01),"^",8)=LEXE
  1. . S LEXE=0 F S LEXE=$O(^LEX(757.01,+LEXEX,7,LEXE)) Q:+LEXE'>0 D
  1. . . 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)
  1. . . S LEXCS=$P(LEXND,"^",2) Q:'$L(LEXCS) S LEXCSE=$P($G(^LEX(757.03,+LEXCS,0)),"^",2),LEXHI=$P(LEXND,"^",3)
  1. . . S LEXHIE=$G(^LEX(757.018,+LEXHI,0)),LEXHIA=$P(LEXHIE,"^",2),LEXHIE=$P(LEXHIE,"^",1),LEXO=LEXE
  1. . . S:$L(LEXCS) $P(LEXO,"^",2)=LEXCS S:$L(LEXHI) $P(LEXO,"^",3)=LEXHI S:$L(LEXCSE) $P(LEXO,"^",4)=LEXCSE
  1. . . S:$L(LEXHIE) $P(LEXO,"^",5)=LEXHIE S:$L(LEXHIA) $P(LEXO,"^",6)=LEXHIA S LEX(+LEXI,757.01,7,LEXDC)=LEXO
  1. . ; Code
  1. . S LEX(+LEXI,757.02)=LEXSIEN_"^"_LEXCD_"^"_LEXIA_"^"_LEXST_"^"_LEXEF
  1. . S LEXE=0 F S LEXE=$O(^LEX(757.02,+LEXSIEN,4,LEXE)) Q:+LEXE'>0 D
  1. . . N LEXND,LEXEF,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,4,+LEXE,0)),LEXEF=$P(LEXND,"^",1),LEXST=$P(LEXND,"^",2)
  1. . . Q:LEXEF'?7N Q:LEXST'?1N S LEX(+LEXI,757.02,4,LEXEF)=LEXE_"^"_LEXST
  1. . ; Coding System
  1. . 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)
  1. . ; Semantic Map
  1. . S LEXSMIEN=0 F S LEXSMIEN=$O(^LEX(757.1,"B",+LEXMC,LEXSMIEN)) Q:+LEXSMIEN'>0 D
  1. . . N LEXND,LEXTI,LEXTE,LEXCI,LEXCE,LEXS,LEXMC S LEXND=$G(^LEX(757.1,+LEXSMIEN,0))
  1. . . S LEXMC=$P(LEXND,"^",1),LEXCI=$P(LEXND,"^",2),LEXTI=$P(LEXND,"^",3)
  1. . . 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
  1. . . S LEX(+LEXI,757.1,+LEXS)=+LEXSMIEN_"^"_LEXMC_"^"_LEXCI_"^"_LEXTI_"^"_LEXCE_"^"_LEXTE
  1. . S:$L($G(LEXCD)) $P(LEX(0),"^",2)=$G(LEXCD) S:$G(LEXCDT)?7N $P(LEX(0),"^",3)=$G(LEXCDT)
  1. . ; VA File
  1. . S:$L($G(LEXSDO)) LEX(+LEXI,"VA",LEXSR)=LEXSDO
  1. . S LEX(0)=LEXI S:$L($G(LEXCD)) $P(LEX(0),"^",2)=LEXCD S:$G(LEXCDT)?7N $P(LEX(0),"^",3)=LEXCDT
  1. Q +($G(LEX(0)))