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

LEXQID2.m

Go to the documentation of this file. 
  1. LEXQID2 ;ISL/KER - Query - ICD Diagnosis - Extract (cont) ;05/23/2017
  1.  ;;2.0;LEXICON UTILITY;**62,73,80,86,103**;Sep 23, 1996;Build 2
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^ICM(               ICR   4488
  1.  ;               
  1.  ; External References
  1.  ;    $$CODEC^ICDEX       ICR   5747
  1.  ;    $$CSI^ICDEX         ICR   5747
  1.  ;    $$DTBR^ICDEX        ICR   5747
  1.  ;    $$HIST^ICDEX        ICR   5747
  1.  ;    $$LA^ICDEX          ICR   5747
  1.  ;    $$LD^ICDEX          ICR   5747
  1.  ;    $$VMDC^ICDEX        ICR   5747
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$UP^XLFSTR         ICR  10104
  1.  ;               
  1.  ; Local Variables NEWed or KILLed in LEXQID
  1.  ;    LEXIIEN             Include IENs flag
  1.  ;    LEXLX               Local Array containing Lexicon term
  1.  ;               
  1.  Q
  1. LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Long Description
  1.  ; 
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date of Description
  1.  ; LEX(#)=Description
  1.  ; 
  1.  N LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
  1.  N LEXHIS,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLA,LEXLAST
  1.  N LEXLEF,LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXLD,LEXLDD
  1.  N LEXSDT,LEXSO,LEXSY,LEXT S LEXIEN=$G(X) Q:+LEXIEN'>0
  1.  S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
  1.  S LEXSTA=+($G(LEXSTA)) S LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
  1.  S LEXSY=$$CSI^ICDEX(80,+LEXIEN)
  1.  S LEXLA=$$LA^ICDEX(80,+LEXIEN,9999999),LEXFA=$$FA(+LEXIEN)
  1.  S LEXLSD=$$LD^ICDEX(80,+LEXIEN,LEXLA)
  1.  S LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
  1.  S LEXLD=$$LD^ICDEX(80,+LEXIEN,LEXVDT,.LEXS,245)
  1.  S LEXLD=$G(LEXS(1)),LEXLDD=$P($G(LEXS(0)),"^",2)
  1.  S:'$L(LEXLD) LEXLDD="--/--/----" S LEXM=""
  1.  I $P(LEXLD,"^",1)="-1"!('$L(LEXLD)) D
  1.  . S LEXM="Diagnosis Description is not available."
  1.  . I (LEXVDT'?7N!(LEXFA'?7N)),LEXVDT<LEXFA D
  1.  . . S LEXM=LEXM_"  The date provided precedes the initial activation of the code"
  1.  . I LEXVDT?7N&(LEXFA?7N),LEXVDT<LEXFA D
  1.  . . S LEXM=LEXM_"  The date provided ("_$$ED^LEXQM(LEXVDT)_") precedes the initial activation ("_$$ED^LEXQM(LEXFA)_") of the code"
  1.  . S:$L(LEXM) LEXM="NOTE:  "_LEXM S LEXOD=LEXLSD,LEXODD="--/--/----"
  1.  S LEXAIEN=LEXIEN,LEXSIEN="" I $L(LEXLD)&($P(LEXLD,"^",1)'="-1") D
  1.  . S:LEXLDD?7N LEXSIEN=$O(@("^ICD9("_LEXIEN_",68,""B"","_LEXLDD_",0)"))
  1.  . S:LEXSIEN>0 LEXAIEN=LEXAIEN_";"_LEXSIEN
  1.  . S LEXM="" S LEXOD=LEXLD S:$L(LEXOD)&($D(LEXIIEN)) LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
  1.  . S LEXODD=$S(LEXLDD?7N:$$ED^LEXQM(LEXLDD),1:"--/--/----")
  1.  S:'$L(LEXOD) LEXOD="Diagnosis Description not found"
  1.  S:'$L(LEXODD) LEXODD="--/--/----"
  1.  K LEX,LEXT S LEXT(1)=LEXOD D PR^LEXU(.LEXT,(LEXLEN-7))
  1.  S LEXI=0 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  S LEXT=$G(LEXT(LEXI)) S LEX(LEXI)=LEXT
  1.  I $L($G(LEXM)) D
  1.  . K LEX,LEXT N LEXC S LEXT(1)=LEXM D PR^LEXU(.LEXT,(LEXLEN-7))
  1.  . S LEXI=0 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  S LEXT=$G(LEXT(LEXI)) S LEXC=$O(LEX(" "),-1)+1,LEX(LEXC)=LEXT
  1.  S:$D(LEX(1)) LEX(0)=LEXODD
  1.  Q
  1. LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
  1.  ; 
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date of Expression
  1.  ; LEX(#)=Expression
  1.  ; 
  1.  N LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0
  1.  N LEXPF,LEXSAB,LEXSRC,LEXSIEN,LEXSO,LEXTSRC,LEXT,LEXTE,LEXTEXP,LEXTEF,LEXTEFE,LEXTS,LEXTSTA,LEXVTMP
  1.  S LEXIEN=$G(X) Q:+LEXIEN'>0
  1.  S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA))
  1.  S LEXEVDT=$$SD^LEXQM(LEXVDT),LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62
  1.  Q:'$L(LEXEVDT)  S LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
  1.  Q:'$L(LEXSO)  S LEXFA=$$FA(+LEXIEN),LEXM="",LEXIA=$$IA(LEXVDT)
  1.  S LEXTSRC=$$SAB^ICDEX($$CSI^ICDEX(80,+LEXIEN)) S:$L(LEXTSRC)'=3 LEXTSRC="" S LEXTSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXTSRC)
  1.  S LEXTS=$P($G(LEXTSTA),"^",2),LEXTE=+($G(^LEX(757.02,+LEXTS,0))),LEXTEXP=$G(^LEX(757.01,+LEXTE,0))
  1.  S (LEXTEF,LEXTEFE)="",LEXEF="" F  S LEXEF=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF)) Q:+LEXEF'>0  D
  1.  . N LEXH S LEXH=0 F  S LEXH=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF,LEXH)) Q:+LEXH'>0  D
  1.  . . S:$P($G(^LEX(757.02,+LEXTS,4,+LEXH,0)),"^",2)>0&(LEXEF?7N) LEXTEF=LEXEF
  1.  . . S:LEXTEF?7N LEXTEFE=$$SD^LEXQM(LEXTEF)
  1.  I LEXSTA'>0,$L($G(LEXTEXP)),$G(LEXTEF)?7N,$L($G(LEXTEFE)) D  Q
  1.  . K LEX N LEXT,LEXM,LEXI S LEXT(1)=LEXTEXP S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXTE_")"
  1.  . D PR^LEXU(.LEXT,(LEXLEN-7)) S LEXI=0 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
  1.  . S LEX=+($O(LEX(" "),-1)) S LEX(0)=LEXTEFE
  1.  S LEXSIEN=0 F  S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0  D
  1.  . N LEXN0 S LEXN0=$G(^LEX(757.02,+LEXSIEN,0)),LEXSAB=$P(LEXN0,"^",3)
  1.  . Q:"^1^30^"'[("^"_LEXSAB_"^")  S LEXPF=+($P(LEXN0,"^",5)) S LEXLEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1)
  1.  . I LEXLEF?7N D
  1.  . . S LEXLHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1) I +LEXLHS>0 D
  1.  . . . S LEXLST=$G(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0)),LEXLST=$P(LEXLST,"^",2)
  1.  . . . S:LEXLST>0 LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
  1.  S (LEXLEX,LEXEF)="",LEXSIEN=$O(LEXVTMP(1,0)),LEXLEX=+($G(LEXVTMP(1,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(1,+LEXSIEN)),"^",2)
  1.  S:+LEXSIEN'>0!(+LEXLEX'>0) LEXSIEN=$O(LEXVTMP(0,0)),LEXLEX=+($G(LEXVTMP(0,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(0,+LEXSIEN)),"^",2)
  1.  K LEX I +LEXLEX>0,$L($G(^LEX(757.01,+LEXLEX,0))),$L(LEXEF),LEXEF?7N  D  Q
  1.  . S LEXAIEN=LEXLEX
  1.  . K LEX N LEXT,LEXM,LEXI S LEXT(1)=$G(^LEX(757.01,+LEXLEX,0))
  1.  . S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXAIEN_")"
  1.  . D PR^LEXU(.LEXT,(LEXLEN-7))
  1.  . S LEXI=0 F  S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0  S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
  1.  . S LEX=+($O(LEX(" "),-1)) S LEXEE=$$SD^LEXQM(LEXEF) S LEX(0)=LEXEE
  1.  Q
  1. WN(X,LEX,LEXLEN) ; Warning
  1.  ;            
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date
  1.  ; LEX(#)=Warning
  1.  ;            
  1.  N LEXVDT,LEXREF,LEXIA,LEXTMP K LEX S LEXVDT=$G(X) Q:LEXVDT'?7N  S LEXIA=$$IA(LEXVDT) Q:+LEXIA'>0  S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62
  1.  S LEXREF="Diagnosis (Short Name) and Description" S:$D(LEXLX) LEXREF="Diagnosis (Short Name), Description and Lexicon Term"
  1.  S LEXTMP(1)="Warning:  The 'Based on Date' provided precedes Code Set Versioning.  The "_LEXREF_" may be inaccurate for "_$$SD^LEXQM(LEXVDT)
  1.  D PR^LEXU(.LEXTMP,LEXLEN) K LEX S LEXI=0 F  S LEXI=$O(LEXTMP(LEXI)) Q:+LEXI'>0  S LEX(LEXI)=$G(LEXTMP(LEXI))
  1.  S LEX=$O(LEX(" "),-1),LEX(0)=$$SD^LEXQM(LEXVDT)
  1.  Q
  1. MDC(X,LEXVDT,LEX) ; Major Diagnostic Category
  1.  ; 
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date of MDC
  1.  ; LEX(#)=MDC
  1.  ; 
  1.  Q
  1.  N LEXEF,LEXMDC,LEXMH,LEXN0,LEXNAM
  1.  K LEX S LEX=0,LEXIEN=+($G(X)) Q:+LEXIEN'>0
  1.  S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
  1.  S LEXMDC=$$VMDC^ICDEX(+LEXIEN,+LEXVDT,1)
  1.  S LEXEF=$P(LEXMDC,"^",2),LEXMDC=$P(LEXMDC,"^",1)
  1.  Q:+LEXMDC'>0  Q:'$D(^ICM(+LEXMDC,0))
  1.  S LEXNAM=$$UP^XLFSTR($P($G(^ICM(+LEXMDC,0)),"^",1)) Q:'$L(LEXNAM)
  1.  S:$D(LEXIIEN) LEXNAM=LEXNAM_" (IEN "_+LEXMDC_")"
  1.  S LEX=1,LEX(0)=$$SD^LEXQM(LEXEF),LEX(1)=LEXNAM
  1.  Q
  1.  ; Miscellaneous
  1. FA(X) ;   First Activation
  1.  N LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
  1.  S LEXIEN=+($G(X)) S X="",LEXSO=$$CODEC^ICDEX(80,+LEXIEN),LEXSY=$$CSI^ICDEX(80,+LEXIEN)
  1.  K LEXH S X=$$HIST^ICDEX(LEXSO,.LEXH,LEXSY) S LEXFA="",LEXI=0
  1.  F  S LEXI=$O(LEXH(LEXI)) Q:+LEXI'>0!($L(LEXFA))  S:+($G(LEXH(LEXI)))>0&(LEXI?7N) LEXFA=LEXI Q:$L(LEXFA)
  1.  S X=LEXFA
  1.  Q X
  1. IA(X,Y) ;   Inaccurate
  1.  N LEXBRD,LEXVDT,LEXIEN,LEXSYS S LEXVDT=+($G(X)),LEXIEN=+($G(Y)) Q:+LEXIEN'>0 0
  1.  S LEXSYS=$$CSI^ICDEX(80,+LEXIEN) Q:+LEXSYS'>0 0  S:'$L(LEXVDT) LEXVDT=$$DT^XLFDT
  1.  S:LEXVDT#10000=0 LEXVDT=LEXVDT+101 S:LEXVDT#100=0 LEXVDT=LEXVDT+1
  1.  S LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSYS) S X=$S(LEXVDT<LEXBRD:1,1:0)
  1.  Q X