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

LEX10CX2.m

Go to the documentation of this file. 
  1. LEX10CX2 ;ISL/KER - ICD-10 Cross-Over - Source (get) ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^TMP("LEXFND")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXHIT")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXSCH")      SACC 2.3.2.5.1
  1.  ;               
  1.  ; External References
  1.  ;    ^DIC                ICR  10006
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMADD^XLFDT       ICR  10103
  1.  ;               
  1.  ; Local Variables NEWed or KILLed Elsewhere
  1.  ;    None
  1.  ;               
  1. SRA(LEXSO,LEXSAB,LEXA) ; Source Array from Code/SAB
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;     LEXSO   Code
  1.  ;     LEXSAB  Source Abbreviation file 757.01, field .01
  1.  ;     LEXA    Local Array (passed by reference)
  1.  ; 
  1.  ; Output
  1.  ; 
  1.  ;     X       Three piece "^" delimited string
  1.  ;               1  Pointer to Expression file
  1.  ;               2  Expression
  1.  ;               3  Code
  1.  ;              
  1.  ;     LEXA    Local Array (if passed by reference)
  1.  ; 
  1.  ;               LEXA(0)=Number of entries in array
  1.  ;               LEXA(1)=Expression of selected Major Concept
  1.  ;               LEXA(2)=Expression of synonym #1
  1.  ;               LEXA(3)=Expression of synonym #2
  1.  ;               LEXA(n)=Expression of synonym #n
  1.  ;               LEXA("SEG",1)=Segment 1
  1.  ;               LEXA("SEG",2)=Segment 2
  1.  ;               LEXA("SEG",n)=Segment n
  1.  ;               LEXA("SOURCE","EXP")=Expression
  1.  ;               LEXA("SOURCE","EXI")=Expression (internal)
  1.  ;               LEXA("SOURCE","SOE")=Code (external)
  1.  ;               LEXA("SOURCE","SOI")=Code (internal)
  1.  ;               LEXA("SOURCE","SAB")=Source Abbreviation
  1.  ;               LEXA("SOURCE","SRC")=Source Nomenclature
  1.  ;               LEXA("SOURCE","SRI")=Source (Internal)
  1.  ;               LEXA("SOURCE","Y")=DIC lookup value for Y
  1.  ;
  1.  N LEXEIEN,LEXI,LEXMC,LEXNOM,LEXEXP,LEXPIEN,LEXSIEN,LEXSRC,LEXLA
  1.  N LEXSRI,LEXSTA,LEXT,X,Y S (X,Y)=-1,LEXSO=$G(LEXSO)
  1.  Q:'$D(^LEX(757.02,"CODE",(LEXSO_" "))) X
  1.  S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB) X
  1.  Q:'$D(^LEX(757.03,"ASAB",LEXSAB)) X
  1.  S LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0))
  1.  Q:+LEXSRI'>0!('$D(^LEX(757.03,+LEXSRI,0))) X
  1.  S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2)
  1.  Q:'$L(LEXNOM) X  S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,,,LEXSAB)
  1.  S LEXSIEN=$P(LEXSTA,"^",2) Q:+LEXSIEN'>0 X
  1.  S LEXPIEN=+($P($G(^LEX(757.02,+LEXSIEN,0)),"^",1)) Q:+LEXPIEN'>0 X
  1.  Q:'$D(^LEX(757.01,LEXPIEN,0)) X
  1.  S LEXMC=+($G(^LEX(757.01,LEXPIEN,1))) Q:+LEXMC'>0 X
  1.  S (LEXEXP,LEXA(1))=$G(^LEX(757.01,LEXPIEN,0)),LEXA(0)=1,LEXEIEN=0
  1.  F  S LEXEIEN=$O(^LEX(757.01,"AMC",LEXMC,LEXEIEN)) Q:+LEXEIEN'>0  D
  1.  . Q:LEXEIEN=LEXPIEN  N LEXT,LEXI
  1.  . S LEXT=$G(^LEX(757.01,LEXEIEN,0)) Q:'$L(LEXT)
  1.  . S LEXI=$O(LEXA(" "),-1)+1
  1.  . S LEXA(LEXI)=LEXT,LEXA(0)=LEXI
  1.  S LEXA("SOURCE","EXP")=LEXEXP
  1.  S:+($G(LEXPIEN))>0 LEXA("SOURCE","EXI")=+($G(LEXPIEN))
  1.  S LEXA("SOURCE","SOE")=LEXSO
  1.  S:+($G(LEXSIEN))>0 LEXA("SOURCE","SOI")=+($G(LEXSIEN))
  1.  S LEXA("SOURCE","SAB")=LEXSAB
  1.  S LEXA("SOURCE","SRC")=LEXNOM
  1.  S:+($G(LEXSRI))>0 LEXA("SOURCE","SRI")=+($G(LEXSRI))
  1.  S (X,LEXA("SOURCE","Y"))=LEXPIEN_"^"_LEXEXP_"^"_LEXSO
  1.  D SEG^LEX10CX5(,.LEXA)
  1.  Q X
  1. SRL(LEXSAB,LEXA) ; Source Array from Lookup
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;     LEXA   Local Array (passed by reference)
  1.  ;     LEXS   Source Abbreviation file 757.01, field .01
  1.  ; 
  1.  ; Output     Same as $$SRA
  1.  ; 
  1.  N DIC,DO,LEXCDT,LEXEFF,LEXEX,LEXH,LEXI,LEXIEN,LEXILA,LEXLA
  1.  N LEXNOM,LEXQUIET,LEXS,LEXSO,LEXSRI,LEXSTA,LEXTD,LEXTX,LEXVDT
  1.  N X,Y K LEXA S LEXSAB=$G(LEXSAB) Q:$L(LEXSAB)'=3 -1
  1.  S LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0))
  1.  Q:+LEXSRI'>0!('$D(^LEX(757.03,+LEXSRI,0))) -1  S LEXTD=$$DT^XLFDT
  1.  S LEXNOM=$P($G(^LEX(757.03,+LEXSRI,0)),"^",2)
  1.  Q:'$L(LEXNOM) -1  S DIC("A")=" Enter "_LEXNOM_" code or text:  "
  1.  S DIC("S")="I $$SO^LEXU(Y,"""_LEXSAB_""",+($G(LEXICCD)))"
  1.  S LEXCDT=$$FMADD^XLFDT($$IMPDATE^LEXU("10D"),-3)
  1.  S:"^ICD^ICP^DS3^DS4^"'[("^"_LEXSAB_"^") LEXCDT=LEXTD
  1.  K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
  1.  D CONFIG^LEXSET(LEXSAB,LEXSAB,LEXCDT)
  1.  S ^TMP("LEXSCH",$J,"DIS",0)=LEXSAB
  1.  S ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
  1.  S DIC(0)="AEQMZ",DIC="^LEX(757.01," K X
  1.  S LEXQUIET=1 D ^DIC Q:+Y'>0 -1 S X="" I +Y>0 D
  1.  . N LEXILA,LEXIEN,LEXLA,LEXSO,LEXTX,LEXS,LEXIEN,LEXEX
  1.  . N LEXH,LEXEX,LEXI,LEXSTA,LEXSIEN S LEXSO=$G(Y(1)),LEXIEN=+Y
  1.  . S:'$L(LEXSO) LEXSO=$$SO^LEX10CX5(LEXIEN,LEXSAB,LEXCDT) Q:'$L(LEXSO)
  1.  . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$G(LEXCDT),,$G(LEXSAB))
  1.  . S LEXSIEN=$P(LEXSTA,"^",2) Q:+LEXSIEN'>0
  1.  . S LEXTX=$G(Y(0)) Q:'$L(LEXTX)  S LEXILA=$$LA^LEX10CX5(LEXSO,LEXSAB),LEXS=0
  1.  . F  S LEXS=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXS)) Q:+LEXS'>0  D
  1.  . . N LEXI Q:$P($G(^LEX(757.02,+LEXS,0)),"^",3)'=LEXSRI
  1.  . . S LEXLA="",LEXH=0
  1.  . . F  S LEXH=$O(^LEX(757.02,+LEXS,4,LEXH)) Q:+LEXH'>0  D
  1.  . . . N LEXEFF,LEXSTA
  1.  . . . S LEXEFF=$P($G(^LEX(757.02,+LEXS,4,+LEXH,0)),"^",1)
  1.  . . . S LEXSTA=$P($G(^LEX(757.02,+LEXS,4,+LEXH,0)),"^",2)
  1.  . . . S:LEXSTA>0 LEXLA=LEXEFF
  1.  . . Q:LEXLA'?7N  Q:LEXILA'?7N  Q:LEXILA>LEXLA
  1.  . . S LEXEX=+($P($G(^LEX(757.02,+LEXS,0)),"^",1))
  1.  . . S LEXEX=$G(^LEX(757.01,+LEXEX,0)) Q:'$L(LEXEX)
  1.  . . Q:$D(LEXA("B",LEXEX))  S LEXI=$O(LEXA(" "),-1)+1
  1.  . . S LEXA(LEXI)=LEXEX,LEXA("B",LEXEX)="",LEXA(0)=LEXI
  1.  . K LEXA("B")
  1.  . I +($G(LEXA(0)))>0,+($G(Y))>0,$L($P($G(Y),"^",2)) D
  1.  . . N LEXPIEN
  1.  . . S LEXPIEN=+($G(^LEX(757.02,+($G(LEXSIEN)),0)))
  1.  . . S LEXA("SOURCE","SOE")=LEXSO
  1.  . . S:+($G(LEXSIEN))>0 LEXA("SOURCE","SOI")=+($G(LEXSIEN))
  1.  . . S LEXA("SOURCE","Y")=$G(Y)
  1.  . . S LEXA("SOURCE","EXP")=LEXTX
  1.  . . S:+($G(LEXPIEN))>0 LEXA("SOURCE","EXI")=+($G(LEXPIEN))
  1.  . . S:$L($G(LEXSAB))=3 LEXA("SOURCE","SAB")=$G(LEXSAB)
  1.  . . S:$L($G(LEXNOM)) LEXA("SOURCE","SRC")=$G(LEXNOM)
  1.  . . S:+($G(LEXSRI))>0 LEXA("SOURCE","SRI")=+($G(LEXSRI))
  1.  . . S X=Y_"^"_LEXSO
  1.  K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J)
  1.  K LEXVDT
  1.  Q X