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

LEXQID.m

Go to the documentation of this file. 
  1. LEXQID ;ISL/KER - Query - ICD Diagnosis - Extract ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**62,73,80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^TMP("LEXQID")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXQIDA"      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXQIDC"      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXQIDN"      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXQIDO"      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXQIDR"      SACC 2.3.2.5.1
  1.  ;               
  1.  ; External References
  1.  ;    $$CODEC^ICDEX       ICR   5747
  1.  ;    $$CSI^ICDEX         ICR   5747
  1.  ;    $$DTBR^ICDEX        ICR   5747
  1.  ;    $$EXIST^ICDEX       ICR   5747
  1.  ;    $$HIST^ICDEX        ICR   5747
  1.  ;    $$ICDDX^ICDEX       ICR   5747
  1.  ;    $$LA^ICDEX          ICR   5747
  1.  ;    $$SD^ICDEX          ICR   5747
  1.  ;    $$SYS^ICDEX         ICR   5747
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;               
  1. EN ; Main Entry Point
  1.  N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0
  1.  N DIC,DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,EXD,ICDFMT,ICDSYS,ICDVDT,LEX,LEX1,LEX2,LEX3,LEXAD,LEXBOD,LEXBRD,LEXBRW,LEXC,LEXCC,LEXCCD,LEXCCE,LEXCCI,LEXCDT
  1.  N LEXCT,LEXCTE,LEXD,LEXDAT,LEXDDD,LEXDDE,LEXDDI,LEXDDT,LEXDEF,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRP,LEXDTXT,LEXDX,LEXE,LEXEDT,LEXEE,LEXEF
  1.  N LEXEFF,LEXELDT,LEXENV,LEXES,LEXEVDT,LEXEXIT,LEXFA,LEXFUL,LEXGET,LEXH,LEXHIS,LEXI,LEXIA,LEXICD,LEXICDC,LEXID,LEXIEN,LEXIENS,LEXINC,LEXINCC
  1.  N LEXINOT,LEXIREQ,LEXISO,LEXL,LEXLA,LEXLAST,LEXLD,LEXLDD,LEXLDR,LEXLDT,LEXLEF,LEXLEN,LEXLHI,LEXLHS,LEXLS,LEXLSD,LEXLSO,LEXLST,LEXLTXT,LEXLX,LEXM
  1.  N LEXMC,LEXMD,LEXMDC,LEXMH,LEXN,LEXN0,LEXNAM,LEXNCC,LEXO,LEXOD,LEXODD,LEXP,LEXPF,LEXPIE,LEXR,LEXREF,LEXS,LEXSAB,LEXSD,LEXSDD,LEXSDT,LEXSIEN,LEXSO
  1.  N LEXST,LEXSTA,LEXSTAT,LEXSTR,LEXSY,LEXSYS,LEXT,LEXTMP,LEXU,LEXVDT,LEXVTMP,LEXVTXT,LEXW,LEXWN,LEXX,X,Y S LEXEXIT=0
  1.  K ^TMP("LEXQID",$J),^TMP("LEXQIDO",$J),^TMP("LEXQIDA",$J),^TMP("LEXQIDN",$J),^TMP("LEXQIDR",$J),^TMP("LEXQIDC",$J)
  1.  W ! F  S LEXCDT=$$AD^LEXQM,LEXAD=LEXCDT Q:'$L(LEXCDT)  S LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2) Q:LEXCDT'?7N  D LOOK Q:LEXCDT'?7N  Q:+LEXEXIT>0
  1.  K ^TMP("LEXQID",$J),^TMP("LEXQIDO",$J),^TMP("LEXQIDA",$J),^TMP("LEXQIDN",$J),^TMP("LEXQIDR",$J),^TMP("LEXQIDC",$J)
  1.  Q 
  1. LOOK ; ICD Lookup Loop
  1.  N LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXCC,LEXMC,LEXICD,LEXICDC
  1.  S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
  1.  S LEXLEN=62 F  S LEXICD=$$ICD^LEXQIDA D  Q:LEXICD="^"!(LEXICD="^^")
  1.  . S:LEXICD="^^" LEXEXIT=1 Q:+($G(LEXEXIT))>0  Q:LEXICD="^"!(LEXICD="^^")
  1.  . K LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXCC,LEXMC,^TMP("LEXQID",$J)
  1.  . N LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINOT,LEXIREQ,LEXINCC,LEXFA
  1.  . S LEXIEN=+($G(LEXICD)),LEXLDT=+($G(LEXCDT)),LEXFA=$$FA(+LEXIEN) Q:+LEXIEN'>0  Q:LEXLDT'?7N
  1.  . S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
  1.  . S (LEXINOT,LEXIREQ,LEXINCC)=0 I LEXFA?7N,LEXCDT?7N,LEXFA'>LEXCDT D
  1.  . . S LEXINOT=$$EXIST^ICDEX(+($G(LEXIEN)),20) S:+LEXINOT>0 LEXINOT=$$NOT^LEXQIDA(+($G(LEXIEN))) S:LEXINOT["^^" LEXEXIT=1 Q:LEXINOT["^"
  1.  . . S LEXIREQ=$$EXIST^ICDEX(+($G(LEXIEN)),30) S:+LEXIREQ>0 LEXIREQ=$$REQ^LEXQIDA(+($G(LEXIEN))) S:LEXIREQ["^^" LEXEXIT=1 Q:LEXIREQ["^"
  1.  . . S LEXINCC=$$EXIST^ICDEX(+($G(LEXIEN)),40) S:LEXINCC>0 LEXINCC=$$NCC^LEXQIDA(+($G(LEXIEN))) S:LEXINCC["^^" LEXEXIT=1 Q:LEXINCC["^"
  1.  . D CSV,EN^LEXQID4
  1.  Q
  1. CSV ; Code Set Versioning Display
  1.  N LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSTAT,LEXDAT
  1.  S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S (LEXICD,LEXCDT)="" Q
  1.  S LEXIEN=+($G(LEXICD)),LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
  1.  S LEXLTXT=$P($G(LEXICD),"^",3) S LEXSYS=$$CSI^ICDEX(80,+LEXIEN)
  1.  Q:+LEXIEN'>0  Q:'$L(LEXSO)  Q:+LEXSYS'>0
  1.  S LEXDAT=$$ICDDX^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
  1.  S LEXSO=$P(LEXDAT,"^",2),LEXNAM=$P(LEXDAT,"^",4)
  1.  I '$L(LEXNAM) D
  1.  . N LEXLA S LEXLA=$$LA^ICDEX(80,+LEXIEN,9999999)
  1.  . S LEXNAM=$$SD^ICDEX(80,+LEXIEN,LEXLA)
  1.  Q:'$L($G(LEXNAM))
  1.  ; 
  1.  ; Get the "Versioned" Fields
  1.  ;            
  1.  ;   Date/Status          80.066  (66)
  1.  S LEXST=$$EF(+($G(LEXIEN)),+LEXCDT),LEXSTAT=+($P(LEXST,"^",2))
  1.  ;   Diagnosis Name       80.067  (67)
  1.  D SDS(+($G(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
  1.  ;   Description          80.068  (68)
  1.  D LDS^LEXQID2(+($G(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
  1.  ;   Lexicon Expression          
  1.  D LX^LEXQID2(+($G(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
  1.  ;   Warning Message
  1.  D WN^LEXQID2(+LEXCDT,.LEXWN,62)
  1.  ;   DRG Groups           80.071  (71)
  1.  D DRG^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
  1.  ;   CC                   80.0103 (103)
  1.  D CC^LEXQID3(+($G(LEXIEN)),+LEXCDT,.LEXCC)
  1.  ;   MDC                  80.072  (72)
  1.  D MDC^LEXQID2(+($G(LEXIEN)),LEXCDT,.LEXMC)
  1.  ;            
  1.  ; Get the "Asked for" Fields
  1.  ;            
  1.  ;   Codes not to use     80.01   (20) 
  1.  D:+($G(LEXINOT))>0 NOT^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
  1.  ;   Codes required with  80.02   (30) 
  1.  D:+($G(LEXIREQ))>0 REQ^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
  1.  ;   Codes not CC with    80.03   (40)
  1.  D:+($G(LEXINCC))>0 NCC^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
  1.  Q
  1.  ; 
  1. EF(X,LEXCDT) ; Effective Dates
  1.  N LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXSO,LEXST,LEXSY S LEXIEN=+($G(X)),LEXCDT=+($G(LEXCDT))
  1.  Q:+LEXIEN'>0 "^^"  Q:LEXCDT'?7N "^^"  S LEXSO=$$CODEC^ICDEX(80,+LEXIEN),LEXSY=$$SYS^ICDEX(LEXSO,LEXCDT),LEX=$$ICDDX^ICDEX(LEXSO,LEXCDT,LEXSY,"E")
  1.  S LEXFA=$$FA(+LEXIEN),(LEXLS,LEXST)=$P(LEX,"^",10),LEXID=$P(LEX,"^",12),LEXBRD=$$IMPDATE^LEXU("ICD"),LEXBRW=""
  1.  I LEXCDT<LEXBRD&(+LEXFA=LEXBRD) D
  1.  . S LEXBRW="Warning:  The 'Based on Date' provided precedes the initial Code Set Business Rule date of "
  1.  . S LEXBRW=LEXBRW_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
  1.  S LEXAD=$P(LEX,"^",17),LEXES=$S(+LEXST>0:"Active",1:"Inactive")
  1.  S:+LEXST'>0&(+LEXAD'>0) LEXES="Not Applicable",LEXLS=-1
  1.  S:+LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT) LEXES="Pending",LEXLS=-1,LEXST=0,LEXBRW=""
  1.  S:LEXST>0 LEXEF=LEXAD S:LEXST'>0 LEXEF=LEXID
  1.  S:LEXST'>0&(+LEXID'>0) LEXEF=LEXFA S LEXEE=$$SD^LEXQM(LEXEF)
  1.  I LEXST'>0,+LEXID'>0,$L(LEXEE),+LEXEF>LEXCDT S LEXEE="(future activation of "_LEXEE_")",LEXEF=""
  1.  S X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE S:$L(LEXBRW) $P(X,"^",6)=LEXBRW
  1.  Q X
  1.  ; 
  1. SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Diagnosis (short description)
  1.  ; 
  1.  ; LEX=# of Lines
  1.  ; LEX(0)=External Date of Diagnosis Name
  1.  ; LEX(#)=Diagnosis Name
  1.  ; 
  1.  N LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
  1.  N LEXHIS,LEXI,LEXIA,LEXIEN,LEXL,LEXLA,LEXLAST,LEXLEF
  1.  N LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXSD,LEXSDD
  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 LEXLAST=$$ICDDX^ICDEX(LEXSO,LEXLA,LEXSY,"E")
  1.  S LEXLSD=$P(LEXLAST,"^",5),LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
  1.  S LEXSD=$$SD^ICDEX(80,+LEXIEN,LEXVDT,.LEXS)
  1.  S LEXSD=$G(LEXS(1)),LEXSDD=$P($G(LEXS(0)),"^",2)
  1.  S:'$L(LEXSD) LEXSDD="--/--/----" S LEXM=""
  1.  I $P(LEXSD,"^",1)="-1"!('$L(LEXSD)) D
  1.  . S LEXM="Diagnosis Short Name 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.  I $L(LEXSD)&($P(LEXSD,"^",1)'="-1") D
  1.  . S LEXM="" S LEXOD=LEXSD,LEXODD=$S(LEXSDD?7N:$$ED^LEXQM(LEXSDD),1:"--/--/----")
  1.  S:'$L(LEXOD) LEXOD="Diagnosis Short Name not found"
  1.  S:'$L(LEXODD) LEXODD="--/--/----"
  1.  K LEX,LEXT S LEXT(1)=LEXOD D PR^LEXQM(.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^LEXQM(.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.  ; 
  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