LEX10CX2 ;ISL/KER - ICD-10 Cross-Over - Source (get) ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXFND") SACC 2.3.2.5.1
; ^TMP("LEXHIT") SACC 2.3.2.5.1
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; ^DIC ICR 10006
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed Elsewhere
; None
;
SRA(LEXSO,LEXSAB,LEXA) ; Source Array from Code/SAB
;
; Input
;
; LEXSO Code
; LEXSAB Source Abbreviation file 757.01, field .01
; LEXA Local Array (passed by reference)
;
; Output
;
; X Three piece "^" delimited string
; 1 Pointer to Expression file
; 2 Expression
; 3 Code
;
; LEXA Local Array (if passed by reference)
;
; LEXA(0)=Number of entries in array
; LEXA(1)=Expression of selected Major Concept
; LEXA(2)=Expression of synonym #1
; LEXA(3)=Expression of synonym #2
; LEXA(n)=Expression of synonym #n
; LEXA("SEG",1)=Segment 1
; LEXA("SEG",2)=Segment 2
; LEXA("SEG",n)=Segment n
; LEXA("SOURCE","EXP")=Expression
; LEXA("SOURCE","EXI")=Expression (internal)
; LEXA("SOURCE","SOE")=Code (external)
; LEXA("SOURCE","SOI")=Code (internal)
; LEXA("SOURCE","SAB")=Source Abbreviation
; LEXA("SOURCE","SRC")=Source Nomenclature
; LEXA("SOURCE","SRI")=Source (Internal)
; LEXA("SOURCE","Y")=DIC lookup value for Y
;
N LEXEIEN,LEXI,LEXMC,LEXNOM,LEXEXP,LEXPIEN,LEXSIEN,LEXSRC,LEXLA
N LEXSRI,LEXSTA,LEXT,X,Y S (X,Y)=-1,LEXSO=$G(LEXSO)
Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) X
S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB) X
Q:'$D(^LEX(757.03,"ASAB",LEXSAB)) X
S LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0))
Q:+LEXSRI'>0!('$D(^LEX(757.03,+LEXSRI,0))) X
S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2)
Q:'$L(LEXNOM) X S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,,,LEXSAB)
S LEXSIEN=$P(LEXSTA,"^",2) Q:+LEXSIEN'>0 X
S LEXPIEN=+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",1)) Q:+LEXPIEN'>0 X
Q:'$D(^LEX(757.01,LEXPIEN,0)) X
S LEXMC=+($G(^LEX(757.01,LEXPIEN,1))) Q:+LEXMC'>0 X
S (LEXEXP,LEXA(1))=$G(^LEX(757.01,LEXPIEN,0)),LEXA(0)=1,LEXEIEN=0
F S LEXEIEN=$O(^LEX(757.01,"AMC",LEXMC,LEXEIEN)) Q:+LEXEIEN'>0 D
. Q:LEXEIEN=LEXPIEN N LEXT,LEXI
. S LEXT=$G(^LEX(757.01,LEXEIEN,0)) Q:'$L(LEXT)
. S LEXI=$O(LEXA(" "),-1)+1
. S LEXA(LEXI)=LEXT,LEXA(0)=LEXI
S LEXA("SOURCE","EXP")=LEXEXP
S:+($G(LEXPIEN))>0 LEXA("SOURCE","EXI")=+($G(LEXPIEN))
S LEXA("SOURCE","SOE")=LEXSO
S:+($G(LEXSIEN))>0 LEXA("SOURCE","SOI")=+($G(LEXSIEN))
S LEXA("SOURCE","SAB")=LEXSAB
S LEXA("SOURCE","SRC")=LEXNOM
S:+($G(LEXSRI))>0 LEXA("SOURCE","SRI")=+($G(LEXSRI))
S (X,LEXA("SOURCE","Y"))=LEXPIEN_"^"_LEXEXP_"^"_LEXSO
D SEG^LEX10CX5(,.LEXA)
Q X
SRL(LEXSAB,LEXA) ; Source Array from Lookup
;
; Input
;
; LEXA Local Array (passed by reference)
; LEXS Source Abbreviation file 757.01, field .01
;
; Output Same as $$SRA
;
N DIC,DO,LEXCDT,LEXEFF,LEXEX,LEXH,LEXI,LEXIEN,LEXILA,LEXLA
N LEXNOM,LEXQUIET,LEXS,LEXSO,LEXSRI,LEXSTA,LEXTD,LEXTX,LEXVDT
N X,Y K LEXA S LEXSAB=$G(LEXSAB) Q:$L(LEXSAB)'=3 -1
S LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0))
Q:+LEXSRI'>0!('$D(^LEX(757.03,+LEXSRI,0))) -1 S LEXTD=$$DT^XLFDT
S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2)
Q:'$L(LEXNOM) -1 S DIC("A")=" Enter "_LEXNOM_" code or text: "
S DIC("S")="I $$SO^LEXU(Y,"""_LEXSAB_""",+($G(LEXICCD)))"
S LEXCDT=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),-3)
S:"^ICD^ICP^DS3^DS4^"'[("^"_LEXSAB_"^") LEXCDT=LEXTD
K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
D CONFIG^LEXSET(LEXSAB,LEXSAB,LEXCDT)
S ^TMP("LEXSCH",$J,"DIS",0)=LEXSAB
S ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
S DIC(0)="AEQMZ",DIC="^LEX(757.01," K X
S LEXQUIET=1 D ^DIC Q:+Y'>0 -1 S X="" I +Y>0 D
. N LEXILA,LEXIEN,LEXLA,LEXSO,LEXTX,LEXS,LEXIEN,LEXEX
. N LEXH,LEXEX,LEXI,LEXSTA,LEXSIEN S LEXSO=$G(Y(1)),LEXIEN=+Y
. S:'$L(LEXSO) LEXSO=$$SO^LEX10CX5(LEXIEN,LEXSAB,LEXCDT) Q:'$L(LEXSO)
. S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$G(LEXCDT),,$G(LEXSAB))
. S LEXSIEN=$P(LEXSTA,"^",2) Q:+LEXSIEN'>0
. S LEXTX=$G(Y(0)) Q:'$L(LEXTX) S LEXILA=$$LA^LEX10CX5(LEXSO,LEXSAB),LEXS=0
. F S LEXS=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXS)) Q:+LEXS'>0 D
. . N LEXI Q:$P($G(^LEX(757.02,+LEXS,0)),"^",3)'=LEXSRI
. . S LEXLA="",LEXH=0
. . F S LEXH=$O(^LEX(757.02,+LEXS,4,LEXH)) Q:+LEXH'>0 D
. . . N LEXEFF,LEXSTA
. . . S LEXEFF=$P($G(^LEX(757.02,+LEXS,4,+LEXH,0)),"^",1)
. . . S LEXSTA=$P($G(^LEX(757.02,+LEXS,4,+LEXH,0)),"^",2)
. . . S:LEXSTA>0 LEXLA=LEXEFF
. . Q:LEXLA'?7N Q:LEXILA'?7N Q:LEXILA>LEXLA
. . S LEXEX=+($P($G(^LEX(757.02,+LEXS,0)),"^",1))
. . S LEXEX=$G(^LEX(757.01,+LEXEX,0)) Q:'$L(LEXEX)
. . Q:$D(LEXA("B",LEXEX)) S LEXI=$O(LEXA(" "),-1)+1
. . S LEXA(LEXI)=LEXEX,LEXA("B",LEXEX)="",LEXA(0)=LEXI
. K LEXA("B")
. I +($G(LEXA(0)))>0,+($G(Y))>0,$L($P($G(Y),"^",2)) D
. . N LEXPIEN
. . S LEXPIEN=+($G(^LEX(757.02,+($G(LEXSIEN)),0)))
. . S LEXA("SOURCE","SOE")=LEXSO
. . S:+($G(LEXSIEN))>0 LEXA("SOURCE","SOI")=+($G(LEXSIEN))
. . S LEXA("SOURCE","Y")=$G(Y)
. . S LEXA("SOURCE","EXP")=LEXTX
. . S:+($G(LEXPIEN))>0 LEXA("SOURCE","EXI")=+($G(LEXPIEN))
. . S:$L($G(LEXSAB))=3 LEXA("SOURCE","SAB")=$G(LEXSAB)
. . S:$L($G(LEXNOM)) LEXA("SOURCE","SRC")=$G(LEXNOM)
. . S:+($G(LEXSRI))>0 LEXA("SOURCE","SRI")=+($G(LEXSRI))
. . S X=Y_"^"_LEXSO
K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
K LEXVDT
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10CX2 5868 printed Dec 13, 2024@02:03:23 Page 2
LEX10CX2 ;ISL/KER - ICD-10 Cross-Over - Source (get) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+5 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+6 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; ^DIC ICR 10006
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMADD^XLFDT ICR 10103
+12 ;
+13 ; Local Variables NEWed or KILLed Elsewhere
+14 ; None
+15 ;
SRA(LEXSO,LEXSAB,LEXA) ; Source Array from Code/SAB
+1 ;
+2 ; Input
+3 ;
+4 ; LEXSO Code
+5 ; LEXSAB Source Abbreviation file 757.01, field .01
+6 ; LEXA Local Array (passed by reference)
+7 ;
+8 ; Output
+9 ;
+10 ; X Three piece "^" delimited string
+11 ; 1 Pointer to Expression file
+12 ; 2 Expression
+13 ; 3 Code
+14 ;
+15 ; LEXA Local Array (if passed by reference)
+16 ;
+17 ; LEXA(0)=Number of entries in array
+18 ; LEXA(1)=Expression of selected Major Concept
+19 ; LEXA(2)=Expression of synonym #1
+20 ; LEXA(3)=Expression of synonym #2
+21 ; LEXA(n)=Expression of synonym #n
+22 ; LEXA("SEG",1)=Segment 1
+23 ; LEXA("SEG",2)=Segment 2
+24 ; LEXA("SEG",n)=Segment n
+25 ; LEXA("SOURCE","EXP")=Expression
+26 ; LEXA("SOURCE","EXI")=Expression (internal)
+27 ; LEXA("SOURCE","SOE")=Code (external)
+28 ; LEXA("SOURCE","SOI")=Code (internal)
+29 ; LEXA("SOURCE","SAB")=Source Abbreviation
+30 ; LEXA("SOURCE","SRC")=Source Nomenclature
+31 ; LEXA("SOURCE","SRI")=Source (Internal)
+32 ; LEXA("SOURCE","Y")=DIC lookup value for Y
+33 ;
+34 NEW LEXEIEN,LEXI,LEXMC,LEXNOM,LEXEXP,LEXPIEN,LEXSIEN,LEXSRC,LEXLA
+35 NEW LEXSRI,LEXSTA,LEXT,X,Y
SET (X,Y)=-1
SET LEXSO=$GET(LEXSO)
+36 if '$DATA(^LEX(757.02,"CODE",(LEXSO_" ")))
QUIT X
+37 SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT X
+38 if '$DATA(^LEX(757.03,"ASAB",LEXSAB))
QUIT X
+39 SET LEXSRI=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
+40 if +LEXSRI'>0!('$DATA(^LEX(757.03,+LEXSRI,0)))
QUIT X
+41 SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRI,0)),"^",2)
+42 if '$LENGTH(LEXNOM)
QUIT X
SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,,,LEXSAB)
+43 SET LEXSIEN=$PIECE(LEXSTA,"^",2)
if +LEXSIEN'>0
QUIT X
+44 SET LEXPIEN=+($PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",1))
if +LEXPIEN'>0
QUIT X
+45 if '$DATA(^LEX(757.01,LEXPIEN,0))
QUIT X
+46 SET LEXMC=+($GET(^LEX(757.01,LEXPIEN,1)))
if +LEXMC'>0
QUIT X
+47 SET (LEXEXP,LEXA(1))=$GET(^LEX(757.01,LEXPIEN,0))
SET LEXA(0)=1
SET LEXEIEN=0
+48 FOR
SET LEXEIEN=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXEIEN))
if +LEXEIEN'>0
QUIT
Begin DoDot:1
+49 if LEXEIEN=LEXPIEN
QUIT
NEW LEXT,LEXI
+50 SET LEXT=$GET(^LEX(757.01,LEXEIEN,0))
if '$LENGTH(LEXT)
QUIT
+51 SET LEXI=$ORDER(LEXA(" "),-1)+1
+52 SET LEXA(LEXI)=LEXT
SET LEXA(0)=LEXI
End DoDot:1
+53 SET LEXA("SOURCE","EXP")=LEXEXP
+54 if +($GET(LEXPIEN))>0
SET LEXA("SOURCE","EXI")=+($GET(LEXPIEN))
+55 SET LEXA("SOURCE","SOE")=LEXSO
+56 if +($GET(LEXSIEN))>0
SET LEXA("SOURCE","SOI")=+($GET(LEXSIEN))
+57 SET LEXA("SOURCE","SAB")=LEXSAB
+58 SET LEXA("SOURCE","SRC")=LEXNOM
+59 if +($GET(LEXSRI))>0
SET LEXA("SOURCE","SRI")=+($GET(LEXSRI))
+60 SET (X,LEXA("SOURCE","Y"))=LEXPIEN_"^"_LEXEXP_"^"_LEXSO
+61 DO SEG^LEX10CX5(,.LEXA)
+62 QUIT X
SRL(LEXSAB,LEXA) ; Source Array from Lookup
+1 ;
+2 ; Input
+3 ;
+4 ; LEXA Local Array (passed by reference)
+5 ; LEXS Source Abbreviation file 757.01, field .01
+6 ;
+7 ; Output Same as $$SRA
+8 ;
+9 NEW DIC,DO,LEXCDT,LEXEFF,LEXEX,LEXH,LEXI,LEXIEN,LEXILA,LEXLA
+10 NEW LEXNOM,LEXQUIET,LEXS,LEXSO,LEXSRI,LEXSTA,LEXTD,LEXTX,LEXVDT
+11 NEW X,Y
KILL LEXA
SET LEXSAB=$GET(LEXSAB)
if $LENGTH(LEXSAB)'=3
QUIT -1
+12 SET LEXSRI=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
+13 if +LEXSRI'>0!('$DATA(^LEX(757.03,+LEXSRI,0)))
QUIT -1
SET LEXTD=$$DT^XLFDT
+14 SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSRI,0)),"^",2)
+15 if '$LENGTH(LEXNOM)
QUIT -1
SET DIC("A")=" Enter "_LEXNOM_" code or text: "
+16 SET DIC("S")="I $$SO^LEXU(Y,"""_LEXSAB_""",+($G(LEXICCD)))"
+17 SET LEXCDT=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),-3)
+18 if "^ICD^ICP^DS3^DS4^"'[("^"_LEXSAB_"^")
SET LEXCDT=LEXTD
+19 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB)
+20 DO CONFIG^LEXSET(LEXSAB,LEXSAB,LEXCDT)
+21 SET ^TMP("LEXSCH",$JOB,"DIS",0)=LEXSAB
+22 SET ^TMP("LEXSCH",$JOB,"FIL",0)=DIC("S")
+23 SET DIC(0)="AEQMZ"
SET DIC="^LEX(757.01,"
KILL X
+24 SET LEXQUIET=1
DO ^DIC
if +Y'>0
QUIT -1
SET X=""
IF +Y>0
Begin DoDot:1
+25 NEW LEXILA,LEXIEN,LEXLA,LEXSO,LEXTX,LEXS,LEXIEN,LEXEX
+26 NEW LEXH,LEXEX,LEXI,LEXSTA,LEXSIEN
SET LEXSO=$GET(Y(1))
SET LEXIEN=+Y
+27 if '$LENGTH(LEXSO)
SET LEXSO=$$SO^LEX10CX5(LEXIEN,LEXSAB,LEXCDT)
if '$LENGTH(LEXSO)
QUIT
+28 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$GET(LEXCDT),,$GET(LEXSAB))
+29 SET LEXSIEN=$PIECE(LEXSTA,"^",2)
if +LEXSIEN'>0
QUIT
+30 SET LEXTX=$GET(Y(0))
if '$LENGTH(LEXTX)
QUIT
SET LEXILA=$$LA^LEX10CX5(LEXSO,LEXSAB)
SET LEXS=0
+31 FOR
SET LEXS=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXS))
if +LEXS'>0
QUIT
Begin DoDot:2
+32 NEW LEXI
if $PIECE($GET(^LEX(757.02,+LEXS,0)),"^",3)'=LEXSRI
QUIT
+33 SET LEXLA=""
SET LEXH=0
+34 FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXS,4,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:3
+35 NEW LEXEFF,LEXSTA
+36 SET LEXEFF=$PIECE($GET(^LEX(757.02,+LEXS,4,+LEXH,0)),"^",1)
+37 SET LEXSTA=$PIECE($GET(^LEX(757.02,+LEXS,4,+LEXH,0)),"^",2)
+38 if LEXSTA>0
SET LEXLA=LEXEFF
End DoDot:3
+39 if LEXLA'?7N
QUIT
if LEXILA'?7N
QUIT
if LEXILA>LEXLA
QUIT
+40 SET LEXEX=+($PIECE($GET(^LEX(757.02,+LEXS,0)),"^",1))
+41 SET LEXEX=$GET(^LEX(757.01,+LEXEX,0))
if '$LENGTH(LEXEX)
QUIT
+42 if $DATA(LEXA("B",LEXEX))
QUIT
SET LEXI=$ORDER(LEXA(" "),-1)+1
+43 SET LEXA(LEXI)=LEXEX
SET LEXA("B",LEXEX)=""
SET LEXA(0)=LEXI
End DoDot:2
+44 KILL LEXA("B")
+45 IF +($GET(LEXA(0)))>0
IF +($GET(Y))>0
IF $LENGTH($PIECE($GET(Y),"^",2))
Begin DoDot:2
+46 NEW LEXPIEN
+47 SET LEXPIEN=+($GET(^LEX(757.02,+($GET(LEXSIEN)),0)))
+48 SET LEXA("SOURCE","SOE")=LEXSO
+49 if +($GET(LEXSIEN))>0
SET LEXA("SOURCE","SOI")=+($GET(LEXSIEN))
+50 SET LEXA("SOURCE","Y")=$GET(Y)
+51 SET LEXA("SOURCE","EXP")=LEXTX
+52 if +($GET(LEXPIEN))>0
SET LEXA("SOURCE","EXI")=+($GET(LEXPIEN))
+53 if $LENGTH($GET(LEXSAB))=3
SET LEXA("SOURCE","SAB")=$GET(LEXSAB)
+54 if $LENGTH($GET(LEXNOM))
SET LEXA("SOURCE","SRC")=$GET(LEXNOM)
+55 if +($GET(LEXSRI))>0
SET LEXA("SOURCE","SRI")=+($GET(LEXSRI))
+56 SET X=Y_"^"_LEXSO
End DoDot:2
End DoDot:1
+57 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXSCH",$JOB)
+58 KILL LEXVDT
+59 QUIT X
