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 Dec 13, 2024@02:09:53 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)
