- LEXU5 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
- ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
- ;
- ; Global Variables
- ; ^LEX(757.001) N/A
- ; ^TMP("LEXSCH") SACC 2.3.2.5.1
- ; ^TMP("LEXTKN") SACC 2.3.2.5.1
- ; ^UTILITY($J ICR 10011
- ;
- ; External References
- ; ^DIWP ICR 10011
- ; $$DT^XLFDT ICR 10103
- ; $$FMADD^XLFDT ICR 10103
- ; $$FMDIFF^XLFDT ICR 10103
- ; $$FMTE^XLFDT ICR 10103
- ; $$GET1^DIQ ICR 2056
- ; ^DIC ICR 10006
- ;
- IMPDATE(SYS) ; Get the Implementation Date for a Coding System
- ;
- ; Input
- ;
- ; SYS Coding System Abbreviation (757.03,.01)
- ; or pointer to file 757.03
- ;
- ; Output
- ;
- ; $$IMPDATE Implementation Date in FileMan format
- ;
- N FRMT,CSIEN,IMPDATE S FRMT="I" S CSIEN=$$CSYSIEN^LEXTRAN($G(SYS)) I +CSIEN<0 Q CSIEN
- S CSIEN=$P(CSIEN,U,2) S IMPDATE=$$GET1^DIQ(757.03,CSIEN,11,FRMT)
- Q IMPDATE
- CSYS(SYS) ; Get Coding System Info
- ;
- ; Input
- ;
- ; SYS Coding System Abbreviation (757.03,.01)
- ; or pointer to file 757.03
- ;
- ; Output
- ;
- ; A 13 piece caret (^) delimited string
- ;
- ; 1 IEN
- ; 2 SAB (3 character source abbreviation)
- ; 3 Source Abbreviation (3-7 char) (#.01)
- ; 4 Nomenclature (2-11 char) (#1)
- ; 5 Source Title (2-52 char) (#2)
- ; 6 Source (2-50 char) (#3)
- ; 7 Entries (numeric) (#4)
- ; 8 Unique Entries (numeric) (#5)
- ; 9 Inactive Version (1-20 char) (#6)
- ; 10 HL7 Coding System (2-40 char) (#7)
- ; 11 SDO Version Date (date) (757.08 #.01)
- ; 12 SDO Version Id (1-40 char) (757.08 #1)
- ; 13 Implementation Date (date) (#11)
- ; 14 Lookup Threshold (#12)
- ;
- N LEXSYS,LEXOUT,LEXND,LEXIEN,LEXEFF,LEXVER,LEXIMP,LEXTHR
- S LEXSYS=$G(SYS) Q:'$L(LEXSYS) "-1^Coding System missing"
- S LEXIEN=$$SIEN(LEXSYS)
- Q:+LEXIEN'>0!('$D(^LEX(757.03,+LEXIEN,0))) "-1^Coding System not found"
- S LEXSYS=$$SMNEM(+LEXIEN)
- S LEXND=$G(^LEX(757.03,+LEXIEN,0))
- Q:$L(LEXND)'>3 "-1^Invalid Coding System HUH"
- S $P(LEXND,"^",8)=$P(LEXND,"^",8)
- S LEXEFF=$O(^LEX(757.03,LEXIEN,1,"B"," "),-1)
- S LEXVER=$O(^LEX(757.03,LEXIEN,1,"B",+LEXEFF),-1)
- S LEXVER=$P($G(^LEX(757.03,LEXIEN,1,+LEXVER,0)),"^",2)
- S LEXIMP=$P($G(^LEX(757.03,LEXIEN,2)),"^",1)
- S LEXTHR=$P($G(^LEX(757.03,LEXIEN,2)),"^",2)
- S LEXOUT=LEXIEN_"^"_$E(LEXND,1,3)_"^"_LEXND_"^"_LEXEFF_"^"_LEXVER_"^"_LEXIMP_"^"_LEXTHR
- Q LEXOUT
- SIEN(MNEM) ; Return code system IEN for mnemonic
- Q:'$L($G(MNEM)) "-1"
- Q:$D(^LEX(757.03,"ASAB",MNEM)) $O(^LEX(757.03,"ASAB",MNEM,""))
- Q:$D(^LEX(757.03,"B",MNEM)) $O(^LEX(757.03,"B",MNEM,""))
- Q:$D(^LEX(757.03,"B",$E(MNEM,1,3))) $O(^LEX(757.03,"B",$E(MNEM,1,3),""))
- Q:$D(^LEX(757.03,"C",MNEM)) $O(^LEX(757.03,"C",MNEM,""))
- Q:MNEM?1N.N&($D(^LEX(757.03,+MNEM,0))) +MNEM
- Q "-1"
- SMNEM(SIEN) ; Return code system mnemonic for IEN
- I '$D(^LEX(757.03,+($G(SIEN)),0)) Q ""
- Q $P(^LEX(757.03,SIEN,0),"^")
- PR(LEX,X) ; Parse Array into Specified String Lengths
- ;
- ; Input
- ;
- ; .LEX(n) Local Array of Text passed by reference
- ; X Length of the Text strings in the output
- ;
- ;
- ; Output
- ;
- ; LEX Number of lines in array LEX(n)
- ; LEX(n) Local Array of Text in the specified string
- ; Lengths
- ;
- 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)
- S LEXLEN=+($G(X)) S:+LEXLEN'>0 LEXLEN=79 S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0
- 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
- K LEX S (LEXC,LEXI)=0 F S LEXI=$O(^UTILITY($J,"W",1,LEXI)) Q:+LEXI=0 D
- . S LEX(LEXI)=$$TM($G(^UTILITY($J,"W",1,LEXI,0))," "),LEXC=LEXC+1
- S:$L(LEXC) LEX=LEXC K ^UTILITY($J,"W")
- Q
- PRMN(LEX,X) ; Parse Minimum Character Length (DIWP Work-Around)
- N LEXI,LEXL,LEXN,LEXMX K LEXN S LEXL=0,LEXMX=+($G(X)) S:LEXMX'>0 LEXMX=500
- F S LEXL=$O(LEX(LEXL)) Q:+LEXL'>0 D
- . N LEXTX S LEXTX=$$TM($G(LEX(LEXL))) Q:'$L(LEXTX)
- . I $L(LEXTX)<LEXMX D Q
- . . N LEXC S LEXC=+($O(LEXN(" "),-1))+1,LEXN(+LEXC)=LEXTX S LEXTX=""
- . F Q:'$L($$TM(LEXTX)) D Q:'$L($$TM(LEXTX))
- . . N LEXC,LEXREM,LEXSTO,LEXPSN Q:'$L(LEXTX)
- . . I $L(LEXTX)<LEXMX D Q
- . . . N LEXC S LEXC=+($O(LEXN(" "),-1))+1,LEXN(+LEXC)=LEXTX S LEXTX=""
- . . I $L(LEXTX)'<LEXMX D
- . . . F LEXPSN=(LEXMX-1):-1 Q:$E(LEXTX,LEXPSN)=" "
- . . . S LEXSTO=$$TM($E(LEXTX,1,LEXPSN)),LEXREM=$$TM($E(LEXTX,LEXPSN,$L(LEXTX)))
- . . . S LEXC=+($O(LEXN(" "),-1))+1,LEXN(+LEXC)=LEXSTO
- . . . S LEXTX=LEXREM
- K LEX S LEXI=0 F S LEXI=$O(LEXN(LEXI)) Q:+LEXI'>0 S LEX(LEXI)=$G(LEXN(LEXI))
- Q
- TM(X,Y) ; Trim Character Y - Default " "
- 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))
- F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
- Q X
- SUBSETS(CODE,SRC,LEX) ; Get Subsets for a Code
- ;
- ; Input
- ;
- ; CODE This is a valid classification code from one of
- ; the coding systems in the Lexicon (see the CODING
- ; SYSTEMS file 757.03)
- ;
- ; SRC This is coding system for which the code belongs.
- ; It can either be the Source Abbreviation (SAB)
- ; found in the .01 field of the CODING SYSTEMS file
- ; #757.03 or a pointer to the CODING SYSTEMS file
- ; #757.03
- ;
- ; Output
- ;
- ; $$SUBSETS Subset Identifiers
- ;
- ; 2 or more (variable) Piece "^" delimited string
- ;
- ; 1 Number of Subsets found
- ; 2 Subset Identifier #1
- ; 3 Subset Identifier #2
- ; 4 Subset Identifier #n
- ;
- ; Example:
- ;
- ; $$SUBSETS^LEXU(205365003,56)
- ;
- ; "4^CLF^DIS^PLS^SCT^"
- ;
- ; 4 Subsets found including CLF, DIS, PLS and SCT
- ;
- ; OR
- ;
- ; -1 ^ Error Message
- ;
- ; LEX Optional 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
- ;
- ; Where <sub> is a three character identifier of a
- ; subset.
- ;
- ; Example of the LEX array:
- ;
- ; $$SUBSETS^LEXU(205365003,56,.ARY)
- ;
- ; ARY("CLF")="Clinical Findings^7000039^70071537^7301845"
- ; ARY("DIS")="Disorder^7000002^7150923^7301845"
- ; ARY("PLS")="PL Standard^7000038^70175664^7301845"
- ; ARY("SCT")="SNOMED CT^7000037^7457760^7301845"
- ;
- K LEX N LEXIENS,LEXEX,LEXMC,LEXIEN,LEXSO,LEXSIEN,LEXSRC,LEXFND S LEXSO=$G(CODE)
- Q:'$L(LEXSO) "-1^Code Missing" Q:'$L($G(SRC)) "-1^Coding System Missing"
- S LEXFND=0,LEXSRC="" S:$G(SRC)?1N.N&($D(^LEX(757.03,+($G(SRC)),0))) LEXSRC=+($G(SRC))
- 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))
- Q:'$D(^LEX(757.03,+LEXSRC,0)) "-1^Invalid Coding System" S LEXMC="",LEXSIEN=0
- F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D Q:LEXMC>0
- . N LEXND,LEXEF,LEXHS,LEXST S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",3)'=LEXSRC Q:$P(LEXND,"^",5)'>0
- . S LEXEF=$O(^LEX(757.02,+LEXSIEN,4,"B"," "),-1) Q:LEXEF'?7N
- . S LEXHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1) Q:+LEXHS'>0
- . S LEXST=$G(^LEX(757.02,+LEXSIEN,4,+LEXHS,0)) Q:$P(LEXST,"^",2)'>0
- . S LEXMC=$P(LEXND,"^",4)
- 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)
- . S LEXIEN=LEXEX,LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.21,"B",+LEXEX,LEXSIEN)) Q:LEXSIEN'>0 D
- . . N LEXND,LEXSI,LEXSA,LEXSF,LEXSTR
- . . 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
- . . S LEXSTR="",LEXFND=0,LEXSA="" F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) D
- . . . S LEXFND=+($G(LEXFND))+1 S LEXSTR=LEXSTR_"^"_LEXSA
- . . S:+LEXFND>0&($L($TR(LEXSTR,"^",""))) LEXFND=+LEXFND_LEXSTR_"^"
- S 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 "-1^Code not Found" 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
- . . S LEXFND=0,LEXSA="" F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) S LEXFND=+($G(LEXFND))+1
- . . S LEXSTR="",LEXFND=0,LEXSA="" F S LEXSA=$O(LEX(LEXSA)) Q:'$L(LEXSA) D
- . . . S LEXFND=+($G(LEXFND))+1 S LEXSTR=LEXSTR_"^"_LEXSA
- . . S:+LEXFND>0&($L($TR(LEXSTR,"^",""))) LEXFND=+LEXFND_LEXSTR_"^"
- Q $G(LEXFND)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXU5 9484 printed Feb 18, 2025@23:35:57 Page 2
- LEXU5 ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
- +1 ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
- +2 ;
- +3 ; Global Variables
- +4 ; ^LEX(757.001) N/A
- +5 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
- +6 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
- +7 ; ^UTILITY($J ICR 10011
- +8 ;
- +9 ; External References
- +10 ; ^DIWP ICR 10011
- +11 ; $$DT^XLFDT ICR 10103
- +12 ; $$FMADD^XLFDT ICR 10103
- +13 ; $$FMDIFF^XLFDT ICR 10103
- +14 ; $$FMTE^XLFDT ICR 10103
- +15 ; $$GET1^DIQ ICR 2056
- +16 ; ^DIC ICR 10006
- +17 ;
- IMPDATE(SYS) ; Get the Implementation Date for a Coding System
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; SYS Coding System Abbreviation (757.03,.01)
- +5 ; or pointer to file 757.03
- +6 ;
- +7 ; Output
- +8 ;
- +9 ; $$IMPDATE Implementation Date in FileMan format
- +10 ;
- +11 NEW FRMT,CSIEN,IMPDATE
- SET FRMT="I"
- SET CSIEN=$$CSYSIEN^LEXTRAN($GET(SYS))
- IF +CSIEN<0
- QUIT CSIEN
- +12 SET CSIEN=$PIECE(CSIEN,U,2)
- SET IMPDATE=$$GET1^DIQ(757.03,CSIEN,11,FRMT)
- +13 QUIT IMPDATE
- CSYS(SYS) ; Get Coding System Info
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; SYS Coding System Abbreviation (757.03,.01)
- +5 ; or pointer to file 757.03
- +6 ;
- +7 ; Output
- +8 ;
- +9 ; A 13 piece caret (^) delimited string
- +10 ;
- +11 ; 1 IEN
- +12 ; 2 SAB (3 character source abbreviation)
- +13 ; 3 Source Abbreviation (3-7 char) (#.01)
- +14 ; 4 Nomenclature (2-11 char) (#1)
- +15 ; 5 Source Title (2-52 char) (#2)
- +16 ; 6 Source (2-50 char) (#3)
- +17 ; 7 Entries (numeric) (#4)
- +18 ; 8 Unique Entries (numeric) (#5)
- +19 ; 9 Inactive Version (1-20 char) (#6)
- +20 ; 10 HL7 Coding System (2-40 char) (#7)
- +21 ; 11 SDO Version Date (date) (757.08 #.01)
- +22 ; 12 SDO Version Id (1-40 char) (757.08 #1)
- +23 ; 13 Implementation Date (date) (#11)
- +24 ; 14 Lookup Threshold (#12)
- +25 ;
- +26 NEW LEXSYS,LEXOUT,LEXND,LEXIEN,LEXEFF,LEXVER,LEXIMP,LEXTHR
- +27 SET LEXSYS=$GET(SYS)
- if '$LENGTH(LEXSYS)
- QUIT "-1^Coding System missing"
- +28 SET LEXIEN=$$SIEN(LEXSYS)
- +29 if +LEXIEN'>0!('$DATA(^LEX(757.03,+LEXIEN,0)))
- QUIT "-1^Coding System not found"
- +30 SET LEXSYS=$$SMNEM(+LEXIEN)
- +31 SET LEXND=$GET(^LEX(757.03,+LEXIEN,0))
- +32 if $LENGTH(LEXND)'>3
- QUIT "-1^Invalid Coding System HUH"
- +33 SET $PIECE(LEXND,"^",8)=$PIECE(LEXND,"^",8)
- +34 SET LEXEFF=$ORDER(^LEX(757.03,LEXIEN,1,"B"," "),-1)
- +35 SET LEXVER=$ORDER(^LEX(757.03,LEXIEN,1,"B",+LEXEFF),-1)
- +36 SET LEXVER=$PIECE($GET(^LEX(757.03,LEXIEN,1,+LEXVER,0)),"^",2)
- +37 SET LEXIMP=$PIECE($GET(^LEX(757.03,LEXIEN,2)),"^",1)
- +38 SET LEXTHR=$PIECE($GET(^LEX(757.03,LEXIEN,2)),"^",2)
- +39 SET LEXOUT=LEXIEN_"^"_$EXTRACT(LEXND,1,3)_"^"_LEXND_"^"_LEXEFF_"^"_LEXVER_"^"_LEXIMP_"^"_LEXTHR
- +40 QUIT LEXOUT
- SIEN(MNEM) ; Return code system IEN for mnemonic
- +1 if '$LENGTH($GET(MNEM))
- QUIT "-1"
- +2 if $DATA(^LEX(757.03,"ASAB",MNEM))
- QUIT $ORDER(^LEX(757.03,"ASAB",MNEM,""))
- +3 if $DATA(^LEX(757.03,"B",MNEM))
- QUIT $ORDER(^LEX(757.03,"B",MNEM,""))
- +4 if $DATA(^LEX(757.03,"B",$EXTRACT(MNEM,1,3)))
- QUIT $ORDER(^LEX(757.03,"B",$EXTRACT(MNEM,1,3),""))
- +5 if $DATA(^LEX(757.03,"C",MNEM))
- QUIT $ORDER(^LEX(757.03,"C",MNEM,""))
- +6 if MNEM?1N.N&($DATA(^LEX(757.03,+MNEM,0)))
- QUIT +MNEM
- +7 QUIT "-1"
- SMNEM(SIEN) ; Return code system mnemonic for IEN
- +1 IF '$DATA(^LEX(757.03,+($GET(SIEN)),0))
- QUIT ""
- +2 QUIT $PIECE(^LEX(757.03,SIEN,0),"^")
- PR(LEX,X) ; Parse Array into Specified String Lengths
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; .LEX(n) Local Array of Text passed by reference
- +5 ; X Length of the Text strings in the output
- +6 ;
- +7 ;
- +8 ; Output
- +9 ;
- +10 ; LEX Number of lines in array LEX(n)
- +11 ; LEX(n) Local Array of Text in the specified string
- +12 ; Lengths
- +13 ;
- +14 NEW %,D,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,LEXI,LEXLEN,LEXC,Z
- KILL ^UTILITY($JOB,"W")
- if '$DATA(LEX)
- QUIT
- DO PRMN(.LEX,500)
- +15 SET LEXLEN=+($GET(X))
- if +LEXLEN'>0
- SET LEXLEN=79
- SET LEXC=+($GET(LEX))
- if +($GET(LEXC))'>0
- SET LEXC=$ORDER(LEX(" "),-1)
- if +LEXC'>0
- QUIT
- +16 SET DIWL=1
- SET DIWF="C"_+LEXLEN
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEX(LEXI))
- if +LEXI=0
- QUIT
- SET X=$GET(LEX(LEXI))
- DO ^DIWP
- +17 KILL LEX
- SET (LEXC,LEXI)=0
- FOR
- SET LEXI=$ORDER(^UTILITY($JOB,"W",1,LEXI))
- if +LEXI=0
- QUIT
- Begin DoDot:1
- +18 SET LEX(LEXI)=$$TM($GET(^UTILITY($JOB,"W",1,LEXI,0))," ")
- SET LEXC=LEXC+1
- End DoDot:1
- +19 if $LENGTH(LEXC)
- SET LEX=LEXC
- KILL ^UTILITY($JOB,"W")
- +20 QUIT
- PRMN(LEX,X) ; Parse Minimum Character Length (DIWP Work-Around)
- +1 NEW LEXI,LEXL,LEXN,LEXMX
- KILL LEXN
- SET LEXL=0
- SET LEXMX=+($GET(X))
- if LEXMX'>0
- SET LEXMX=500
- +2 FOR
- SET LEXL=$ORDER(LEX(LEXL))
- if +LEXL'>0
- QUIT
- Begin DoDot:1
- +3 NEW LEXTX
- SET LEXTX=$$TM($GET(LEX(LEXL)))
- if '$LENGTH(LEXTX)
- QUIT
- +4 IF $LENGTH(LEXTX)<LEXMX
- Begin DoDot:2
- +5 NEW LEXC
- SET LEXC=+($ORDER(LEXN(" "),-1))+1
- SET LEXN(+LEXC)=LEXTX
- SET LEXTX=""
- End DoDot:2
- QUIT
- +6 FOR
- if '$LENGTH($$TM(LEXTX))
- QUIT
- Begin DoDot:2
- +7 NEW LEXC,LEXREM,LEXSTO,LEXPSN
- if '$LENGTH(LEXTX)
- QUIT
- +8 IF $LENGTH(LEXTX)<LEXMX
- Begin DoDot:3
- +9 NEW LEXC
- SET LEXC=+($ORDER(LEXN(" "),-1))+1
- SET LEXN(+LEXC)=LEXTX
- SET LEXTX=""
- End DoDot:3
- QUIT
- +10 IF $LENGTH(LEXTX)'<LEXMX
- Begin DoDot:3
- +11 FOR LEXPSN=(LEXMX-1):-1
- if $EXTRACT(LEXTX,LEXPSN)=" "
- QUIT
- +12 SET LEXSTO=$$TM($EXTRACT(LEXTX,1,LEXPSN))
- SET LEXREM=$$TM($EXTRACT(LEXTX,LEXPSN,$LENGTH(LEXTX)))
- +13 SET LEXC=+($ORDER(LEXN(" "),-1))+1
- SET LEXN(+LEXC)=LEXSTO
- +14 SET LEXTX=LEXREM
- End DoDot:3
- End DoDot:2
- if '$LENGTH($$TM(LEXTX))
- QUIT
- End DoDot:1
- +15 KILL LEX
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXN(LEXI))
- if +LEXI'>0
- QUIT
- SET LEX(LEXI)=$GET(LEXN(LEXI))
- +16 QUIT
- TM(X,Y) ; Trim Character Y - Default " "
- +1 SET X=$GET(X)
- if X=""
- QUIT X
- SET Y=$GET(Y)
- if '$LENGTH(Y)
- SET Y=" "
- FOR
- if $EXTRACT(X,1)'=Y
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +2 FOR
- if $EXTRACT(X,$LENGTH(X))'=Y
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +3 QUIT X
- SUBSETS(CODE,SRC,LEX) ; Get Subsets for a Code
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; CODE This is a valid classification code from one of
- +5 ; the coding systems in the Lexicon (see the CODING
- +6 ; SYSTEMS file 757.03)
- +7 ;
- +8 ; SRC This is coding system for which the code belongs.
- +9 ; It can either be the Source Abbreviation (SAB)
- +10 ; found in the .01 field of the CODING SYSTEMS file
- +11 ; #757.03 or a pointer to the CODING SYSTEMS file
- +12 ; #757.03
- +13 ;
- +14 ; Output
- +15 ;
- +16 ; $$SUBSETS Subset Identifiers
- +17 ;
- +18 ; 2 or more (variable) Piece "^" delimited string
- +19 ;
- +20 ; 1 Number of Subsets found
- +21 ; 2 Subset Identifier #1
- +22 ; 3 Subset Identifier #2
- +23 ; 4 Subset Identifier #n
- +24 ;
- +25 ; Example:
- +26 ;
- +27 ; $$SUBSETS^LEXU(205365003,56)
- +28 ;
- +29 ; "4^CLF^DIS^PLS^SCT^"
- +30 ;
- +31 ; 4 Subsets found including CLF, DIS, PLS and SCT
- +32 ;
- +33 ; OR
- +34 ;
- +35 ; -1 ^ Error Message
- +36 ;
- +37 ; LEX Optional array passed by Reference
- +38 ;
- +39 ; LEX(<sub>) = 4 Piece "^" delimited string
- +40 ;
- +41 ; 1 Subset Name
- +42 ; 2 Subset Definition IEN file 757.2
- +43 ; 3 Subset IEN file 757.21
- +44 ; 4 Expression IEN file 757.01
- +45 ;
- +46 ; Where <sub> is a three character identifier of a
- +47 ; subset.
- +48 ;
- +49 ; Example of the LEX array:
- +50 ;
- +51 ; $$SUBSETS^LEXU(205365003,56,.ARY)
- +52 ;
- +53 ; ARY("CLF")="Clinical Findings^7000039^70071537^7301845"
- +54 ; ARY("DIS")="Disorder^7000002^7150923^7301845"
- +55 ; ARY("PLS")="PL Standard^7000038^70175664^7301845"
- +56 ; ARY("SCT")="SNOMED CT^7000037^7457760^7301845"
- +57 ;
- +58 KILL LEX
- NEW LEXIENS,LEXEX,LEXMC,LEXIEN,LEXSO,LEXSIEN,LEXSRC,LEXFND
- SET LEXSO=$GET(CODE)
- +59 if '$LENGTH(LEXSO)
- QUIT "-1^Code Missing"
- if '$LENGTH($GET(SRC))
- QUIT "-1^Coding System Missing"
- +60 SET LEXFND=0
- SET LEXSRC=""
- if $GET(SRC)?1N.N&($DATA(^LEX(757.03,+($GET(SRC)),0)))
- SET LEXSRC=+($GET(SRC))
- +61 if $GET(SRC)'?1N.N&($LENGTH($GET(SRC))=3)&($DATA(^LEX(757.03,"ASAB",$GET(SRC))))
- SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",$GET(SRC),0))
- +62 if '$DATA(^LEX(757.03,+LEXSRC,0))
- QUIT "-1^Invalid Coding System"
- SET LEXMC=""
- SET LEXSIEN=0
- +63 FOR
- SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
- if +LEXSIEN'>0
- QUIT
- Begin DoDot:1
- +64 NEW LEXND,LEXEF,LEXHS,LEXST
- SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
- if $PIECE(LEXND,"^",3)'=LEXSRC
- QUIT
- if $PIECE(LEXND,"^",5)'>0
- QUIT
- +65 SET LEXEF=$ORDER(^LEX(757.02,+LEXSIEN,4,"B"," "),-1)
- if LEXEF'?7N
- QUIT
- +66 SET LEXHS=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXEF," "),-1)
- if +LEXHS'>0
- QUIT
- +67 SET LEXST=$GET(^LEX(757.02,+LEXSIEN,4,+LEXHS,0))
- if $PIECE(LEXST,"^",2)'>0
- QUIT
- +68 SET LEXMC=$PIECE(LEXND,"^",4)
- End DoDot:1
- if LEXMC>0
- QUIT
- +69 if +LEXMC'>0
- QUIT "-1^Code not Found"
- SET LEXEX=+($GET(^LEX(757,+LEXMC,0)))
- IF $DATA(^LEX(757.21,"B",+LEXEX))
- Begin DoDot:1
- +70 SET LEXIEN=LEXEX
- SET LEXSIEN=0
- FOR
- SET LEXSIEN=$ORDER(^LEX(757.21,"B",+LEXEX,LEXSIEN))
- if LEXSIEN'>0
- QUIT
- Begin DoDot:2
- +71 NEW LEXND,LEXSI,LEXSA,LEXSF,LEXSTR
- +72 SET LEXSI=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
- SET LEXND=$GET(^LEXT(757.2,+LEXSI,0))
- +73 SET LEXSA=$PIECE(LEXND,"^",2)
- SET LEXSF=$$MIX^LEXXM($PIECE(LEXND,"^",1))
- +74 if $LENGTH(LEXSA)=3&($LENGTH(LEXSF))
- SET LEX(LEXSA)=LEXSF_"^"_LEXSI_"^"_LEXSIEN_"^"_LEXIEN
- +75 SET LEXSTR=""
- SET LEXFND=0
- SET LEXSA=""
- FOR
- SET LEXSA=$ORDER(LEX(LEXSA))
- if '$LENGTH(LEXSA)
- QUIT
- Begin DoDot:3
- +76 SET LEXFND=+($GET(LEXFND))+1
- SET LEXSTR=LEXSTR_"^"_LEXSA
- End DoDot:3
- +77 if +LEXFND>0&($LENGTH($TRANSLATE(LEXSTR,"^","")))
- SET LEXFND=+LEXFND_LEXSTR_"^"
- End DoDot:2
- End DoDot:1
- QUIT $GET(LEXFND)
- +78 SET LEXIEN=0
- FOR
- SET LEXIEN=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXIEN))
- if +LEXIEN'>0
- QUIT
- Begin DoDot:1
- +79 if $PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",5)>0
- QUIT
- SET LEXIENS(LEXIEN)=""
- End DoDot:1
- +80 if $ORDER(LEXIENS(0))'>0
- QUIT "-1^Code not Found"
- SET LEXIEN=0
- FOR
- SET LEXIEN=$ORDER(LEXIENS(LEXIEN))
- if +LEXIEN'>0
- QUIT
- Begin DoDot:1
- +81 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
- +82 NEW LEXND,LEXSI,LEXSA,LEXSF
- SET LEXSI=$PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2)
- SET LEXND=$GET(^LEXT(757.2,+LEXSI,0))
- +83 SET LEXSA=$PIECE(LEXND,"^",2)
- SET LEXSF=$$MIX^LEXXM($PIECE(LEXND,"^",1))
- +84 if $LENGTH(LEXSA)=3&($LENGTH(LEXSF))
- SET LEX(LEXSA)=LEXSF_"^"_LEXSI_"^"_LEXSIEN_"^"_LEXIEN
- +85 SET LEXFND=0
- SET LEXSA=""
- FOR
- SET LEXSA=$ORDER(LEX(LEXSA))
- if '$LENGTH(LEXSA)
- QUIT
- SET LEXFND=+($GET(LEXFND))+1
- +86 SET LEXSTR=""
- SET LEXFND=0
- SET LEXSA=""
- FOR
- SET LEXSA=$ORDER(LEX(LEXSA))
- if '$LENGTH(LEXSA)
- QUIT
- Begin DoDot:3
- +87 SET LEXFND=+($GET(LEXFND))+1
- SET LEXSTR=LEXSTR_"^"_LEXSA
- End DoDot:3
- +88 if +LEXFND>0&($LENGTH($TRANSLATE(LEXSTR,"^","")))
- SET LEXFND=+LEXFND_LEXSTR_"^"
- End DoDot:2
- End DoDot:1
- +89 QUIT $GET(LEXFND)