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

LEXU5.m

Go to the documentation of this file.
  1. LEXU5 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.001) N/A
  1. ; ^TMP("LEXSCH") SACC 2.3.2.5.1
  1. ; ^TMP("LEXTKN") SACC 2.3.2.5.1
  1. ; ^UTILITY($J ICR 10011
  1. ;
  1. ; External References
  1. ; ^DIWP ICR 10011
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMADD^XLFDT ICR 10103
  1. ; $$FMDIFF^XLFDT ICR 10103
  1. ; $$FMTE^XLFDT ICR 10103
  1. ; $$GET1^DIQ ICR 2056
  1. ; ^DIC ICR 10006
  1. ;
  1. IMPDATE(SYS) ; Get the Implementation Date for a Coding System
  1. ;
  1. ; Input
  1. ;
  1. ; SYS Coding System Abbreviation (757.03,.01)
  1. ; or pointer to file 757.03
  1. ;
  1. ; Output
  1. ;
  1. ; $$IMPDATE Implementation Date in FileMan format
  1. ;
  1. N FRMT,CSIEN,IMPDATE S FRMT="I" S CSIEN=$$CSYSIEN^LEXTRAN($G(SYS)) I +CSIEN<0 Q CSIEN
  1. S CSIEN=$P(CSIEN,U,2) S IMPDATE=$$GET1^DIQ(757.03,CSIEN,11,FRMT)
  1. Q IMPDATE
  1. CSYS(SYS) ; Get Coding System Info
  1. ;
  1. ; Input
  1. ;
  1. ; SYS Coding System Abbreviation (757.03,.01)
  1. ; or pointer to file 757.03
  1. ;
  1. ; Output
  1. ;
  1. ; A 13 piece caret (^) delimited string
  1. ;
  1. ; 1 IEN
  1. ; 2 SAB (3 character source abbreviation)
  1. ; 3 Source Abbreviation (3-7 char) (#.01)
  1. ; 4 Nomenclature (2-11 char) (#1)
  1. ; 5 Source Title (2-52 char) (#2)
  1. ; 6 Source (2-50 char) (#3)
  1. ; 7 Entries (numeric) (#4)
  1. ; 8 Unique Entries (numeric) (#5)
  1. ; 9 Inactive Version (1-20 char) (#6)
  1. ; 10 HL7 Coding System (2-40 char) (#7)
  1. ; 11 SDO Version Date (date) (757.08 #.01)
  1. ; 12 SDO Version Id (1-40 char) (757.08 #1)
  1. ; 13 Implementation Date (date) (#11)
  1. ; 14 Lookup Threshold (#12)
  1. ;
  1. N LEXSYS,LEXOUT,LEXND,LEXIEN,LEXEFF,LEXVER,LEXIMP,LEXTHR
  1. S LEXSYS=$G(SYS) Q:'$L(LEXSYS) "-1^Coding System missing"
  1. S LEXIEN=$$SIEN(LEXSYS)
  1. Q:+LEXIEN'>0!('$D(^LEX(757.03,+LEXIEN,0))) "-1^Coding System not found"
  1. S LEXSYS=$$SMNEM(+LEXIEN)
  1. S LEXND=$G(^LEX(757.03,+LEXIEN,0))
  1. Q:$L(LEXND)'>3 "-1^Invalid Coding System HUH"
  1. S $P(LEXND,"^",8)=$P(LEXND,"^",8)
  1. S LEXEFF=$O(^LEX(757.03,LEXIEN,1,"B"," "),-1)
  1. S LEXVER=$O(^LEX(757.03,LEXIEN,1,"B",+LEXEFF),-1)
  1. S LEXVER=$P($G(^LEX(757.03,LEXIEN,1,+LEXVER,0)),"^",2)
  1. S LEXIMP=$P($G(^LEX(757.03,LEXIEN,2)),"^",1)
  1. S LEXTHR=$P($G(^LEX(757.03,LEXIEN,2)),"^",2)
  1. S LEXOUT=LEXIEN_"^"_$E(LEXND,1,3)_"^"_LEXND_"^"_LEXEFF_"^"_LEXVER_"^"_LEXIMP_"^"_LEXTHR
  1. Q LEXOUT
  1. SIEN(MNEM) ; Return code system IEN for mnemonic
  1. Q:'$L($G(MNEM)) "-1"
  1. Q:$D(^LEX(757.03,"ASAB",MNEM)) $O(^LEX(757.03,"ASAB",MNEM,""))
  1. Q:$D(^LEX(757.03,"B",MNEM)) $O(^LEX(757.03,"B",MNEM,""))
  1. Q:$D(^LEX(757.03,"B",$E(MNEM,1,3))) $O(^LEX(757.03,"B",$E(MNEM,1,3),""))
  1. Q:$D(^LEX(757.03,"C",MNEM)) $O(^LEX(757.03,"C",MNEM,""))
  1. Q:MNEM?1N.N&($D(^LEX(757.03,+MNEM,0))) +MNEM
  1. Q "-1"
  1. SMNEM(SIEN) ; Return code system mnemonic for IEN
  1. I '$D(^LEX(757.03,+($G(SIEN)),0)) Q ""
  1. Q $P(^LEX(757.03,SIEN,0),"^")
  1. PR(LEX,X) ; Parse Array into Specified String Lengths
  1. ;
  1. ; Input
  1. ;
  1. ; .LEX(n) Local Array of Text passed by reference
  1. ; X Length of the Text strings in the output
  1. ;
  1. ;
  1. ; Output
  1. ;
  1. ; LEX Number of lines in array LEX(n)
  1. ; LEX(n) Local Array of Text in the specified string
  1. ; Lengths
  1. ;
  1. N %,D,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,LEXI,LEXLEN,LEXC,Z K ^UTILITY($J,"W") Q:'$D(LEX) D PRMN(.LEX,500)
  1. S LEXLEN=+($G(X)) S:+LEXLEN'>0 LEXLEN=79 S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0
  1. S DIWL=1,DIWF="C"_+LEXLEN S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI=0 S X=$G(LEX(LEXI)) D ^DIWP
  1. K LEX S (LEXC,LEXI)=0 F S LEXI=$O(^UTILITY($J,"W",1,LEXI)) Q:+LEXI=0 D
  1. . S LEX(LEXI)=$$TM($G(^UTILITY($J,"W",1,LEXI,0))," "),LEXC=LEXC+1
  1. S:$L(LEXC) LEX=LEXC K ^UTILITY($J,"W")
  1. Q
  1. PRMN(LEX,X) ; Parse Minimum Character Length (DIWP Work-Around)
  1. N LEXI,LEXL,LEXN,LEXMX K LEXN S LEXL=0,LEXMX=+($G(X)) S:LEXMX'>0 LEXMX=500
  1. F S LEXL=$O(LEX(LEXL)) Q:+LEXL'>0 D
  1. . N LEXTX S LEXTX=$$TM($G(LEX(LEXL))) Q:'$L(LEXTX)
  1. . I $L(LEXTX)<LEXMX D Q
  1. . . N LEXC S LEXC=+($O(LEXN(" "),-1))+1,LEXN(+LEXC)=LEXTX S LEXTX=""
  1. . F Q:'$L($$TM(LEXTX)) D Q:'$L($$TM(LEXTX))
  1. . . N LEXC,LEXREM,LEXSTO,LEXPSN Q:'$L(LEXTX)
  1. . . I $L(LEXTX)<LEXMX D Q
  1. . . . N LEXC S LEXC=+($O(LEXN(" "),-1))+1,LEXN(+LEXC)=LEXTX S LEXTX=""
  1. . . I $L(LEXTX)'<LEXMX D
  1. . . . F LEXPSN=(LEXMX-1):-1 Q:$E(LEXTX,LEXPSN)=" "
  1. . . . S LEXSTO=$$TM($E(LEXTX,1,LEXPSN)),LEXREM=$$TM($E(LEXTX,LEXPSN,$L(LEXTX)))
  1. . . . S LEXC=+($O(LEXN(" "),-1))+1,LEXN(+LEXC)=LEXSTO
  1. . . . S LEXTX=LEXREM
  1. K LEX S LEXI=0 F S LEXI=$O(LEXN(LEXI)) Q:+LEXI'>0 S LEX(LEXI)=$G(LEXN(LEXI))
  1. Q
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" " F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X
  1. SUBSETS(CODE,SRC,LEX) ; Get Subsets for a Code
  1. ;
  1. ; Input
  1. ;
  1. ; CODE This is a valid classification code from one of
  1. ; the coding systems in the Lexicon (see the CODING
  1. ; SYSTEMS file 757.03)
  1. ;
  1. ; SRC This is coding system for which the code belongs.
  1. ; It can either be the Source Abbreviation (SAB)
  1. ; found in the .01 field of the CODING SYSTEMS file
  1. ; #757.03 or a pointer to the CODING SYSTEMS file
  1. ; #757.03
  1. ;
  1. ; Output
  1. ;
  1. ; $$SUBSETS Subset Identifiers
  1. ;
  1. ; 2 or more (variable) Piece "^" delimited string
  1. ;
  1. ; 1 Number of Subsets found
  1. ; 2 Subset Identifier #1
  1. ; 3 Subset Identifier #2
  1. ; 4 Subset Identifier #n
  1. ;
  1. ; Example:
  1. ;
  1. ; $$SUBSETS^LEXU(205365003,56)
  1. ;
  1. ; "4^CLF^DIS^PLS^SCT^"
  1. ;
  1. ; 4 Subsets found including CLF, DIS, PLS and SCT
  1. ;
  1. ; OR
  1. ;
  1. ; -1 ^ Error Message
  1. ;
  1. ; LEX Optional array passed by Reference
  1. ;
  1. ; LEX(<sub>) = 4 Piece "^" delimited string
  1. ;
  1. ; 1 Subset Name
  1. ; 2 Subset Definition IEN file 757.2
  1. ; 3 Subset IEN file 757.21
  1. ; 4 Expression IEN file 757.01
  1. ;
  1. ; Where <sub> is a three character identifier of a
  1. ; subset.
  1. ;
  1. ; Example of the LEX array:
  1. ;
  1. ; $$SUBSETS^LEXU(205365003,56,.ARY)
  1. ;
  1. ; ARY("CLF")="Clinical Findings^7000039^70071537^7301845"
  1. ; ARY("DIS")="Disorder^7000002^7150923^7301845"
  1. ; ARY("PLS")="PL Standard^7000038^70175664^7301845"
  1. ; ARY("SCT")="SNOMED CT^7000037^7457760^7301845"
  1. ;
  1. K LEX N LEXIENS,LEXEX,LEXMC,LEXIEN,LEXSO,LEXSIEN,LEXSRC,LEXFND S LEXSO=$G(CODE)
  1. Q:'$L(LEXSO) "-1^Code Missing" Q:'$L($G(SRC)) "-1^Coding System Missing"
  1. S LEXFND=0,LEXSRC="" S:$G(SRC)?1N.N&($D(^LEX(757.03,+($G(SRC)),0))) LEXSRC=+($G(SRC))
  1. S:$G(SRC)'?1N.N&($L($G(SRC))=3)&($D(^LEX(757.03,"ASAB",$G(SRC)))) LEXSRC=$O(^LEX(757.03,"ASAB",$G(SRC),0))
  1. Q:'$D(^LEX(757.03,+LEXSRC,0)) "-1^Invalid Coding System" S LEXMC="",LEXSIEN=0
  1. F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D Q:LEXMC>0
  1. . N LEXND,LEXEF,LEXHS,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",3)'=LEXSRC Q:$P(LEXND,"^",5)'>0
  1. . S LEXEF=$O(^LEX(757.02,+LEXSIEN,4,"B"," "),-1) Q:LEXEF'?7N
  1. . S LEXHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1) Q:+LEXHS'>0
  1. . S LEXST=$G(^LEX(757.02,+LEXSIEN,4,+LEXHS,0)) Q:$P(LEXST,"^",2)'>0
  1. . S LEXMC=$P(LEXND,"^",4)
  1. Q:+LEXMC'>0 "-1^Code not Found" S LEXEX=+($G(^LEX(757,+LEXMC,0))) I $D(^LEX(757.21,"B",+LEXEX)) D Q $G(LEXFND)
  1. . S LEXIEN=LEXEX,LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.21,"B",+LEXEX,LEXSIEN)) Q:LEXSIEN'>0 D
  1. . . N LEXND,LEXSI,LEXSA,LEXSF,LEXSTR
  1. . . S LEXSI=$P($G(^LEX(757.21,+LEXSIEN,0)),"^",2),LEXND=$G(^LEXT(757.2,+LEXSI,0))
  1. . . S LEXSA=$P(LEXND,"^",2),LEXSF=$$MIX^LEXXM($P(LEXND,"^",1))
  1. . . S:$L(LEXSA)=3&($L(LEXSF)) LEX(LEXSA)=LEXSF_"^"_LEXSI_"^"_LEXSIEN_"^"_LEXIEN
  1. . . S LEXSTR="",LEXFND=0,LEXSA="" F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) D
  1. . . . S LEXFND=+($G(LEXFND))+1 S LEXSTR=LEXSTR_"^"_LEXSA
  1. . . S:+LEXFND>0&($L($TR(LEXSTR,"^",""))) LEXFND=+LEXFND_LEXSTR_"^"
  1. S LEXIEN=0 F S LEXIEN=$O(^LEX(757.01,"AMC",LEXMC,LEXIEN)) Q:+LEXIEN'>0 D
  1. . Q:$P($G(^LEX(757.01,+LEXIEN,1)),"^",5)>0 S LEXIENS(LEXIEN)=""
  1. Q:$O(LEXIENS(0))'>0 "-1^Code not Found" S LEXIEN=0 F S LEXIEN=$O(LEXIENS(LEXIEN)) Q:+LEXIEN'>0 D
  1. . Q:'$D(^LEX(757.21,"B",LEXIEN)) S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.21,"B",LEXIEN,LEXSIEN)) Q:LEXSIEN'>0 D
  1. . . N LEXND,LEXSI,LEXSA,LEXSF S LEXSI=$P($G(^LEX(757.21,+LEXSIEN,0)),"^",2),LEXND=$G(^LEXT(757.2,+LEXSI,0))
  1. . . S LEXSA=$P(LEXND,"^",2),LEXSF=$$MIX^LEXXM($P(LEXND,"^",1))
  1. . . S:$L(LEXSA)=3&($L(LEXSF)) LEX(LEXSA)=LEXSF_"^"_LEXSI_"^"_LEXSIEN_"^"_LEXIEN
  1. . . S LEXFND=0,LEXSA="" F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) S LEXFND=+($G(LEXFND))+1
  1. . . S LEXSTR="",LEXFND=0,LEXSA="" F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) D
  1. . . . S LEXFND=+($G(LEXFND))+1 S LEXSTR=LEXSTR_"^"_LEXSA
  1. . . S:+LEXFND>0&($L($TR(LEXSTR,"^",""))) LEXFND=+LEXFND_LEXSTR_"^"
  1. Q $G(LEXFND)