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

LEXQID4.m

Go to the documentation of this file. 
  1. LEXQID4 ;ISL/KER - Query - ICD Diagnosis - Save ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^TMP("LEXQID")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXQIDO")     SACC 2.3.2.5.1
  1.  ;               
  1.  ; External References
  1.  ;    $$UPDX^ICDEX        ICR   5747
  1.  ;    $$VAGEH^ICDEXD      ICR   5747
  1.  ;    $$VAGEL^ICDEXD      ICR   5747
  1.  ;    $$VSEX^ICDEXD       ICR   5747
  1.  ;    $$UP^XLFSTR         ICR  10104
  1.  ;               
  1.  ; Local Variables NEWed or KILLed in LEXQID
  1.  ;     LEXIEN             ICD Internal Entry Number
  1.  ;     LEXCDT             Code Set Date
  1.  ;     LEXLEN             Offset Length
  1.  ;     LEXST              ICD Status and Effective Dates
  1.  ;     LEXSD              Versioned Short Description
  1.  ;     LEXLD              Versioned Long Description
  1.  ;     LEXLX              Versioned Lexicon Term
  1.  ;     LEXWN              Warning
  1.  ;     LEXCC              Code CC Status
  1.  ;     LEXMC              Major Diagnostic Category
  1.  ;     LEXELDT            External Last Date
  1.  ;               
  1. EN ; Main Entry Point
  1.  K ^TMP("LEXQIDO",$J) Q:'$L($G(LEXELDT))  I +($G(LEXST))<0 D FUT D:$D(^TMP("LEXQIDO",$J)) DSP^LEXQO("LEXQIDO") Q
  1.  D FUL D:$D(^TMP("LEXQIDO",$J)) DSP^LEXQO("LEXQIDO")
  1.  Q
  1. FUT ; Future Activation
  1.  N LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXSTA S LEXI=+($G(LEXIEN)) Q:+LEXI'>0
  1.  S LEXL=+($G(LEXLEN)) Q:+LEXL'>0  S:LEXL>62 LEXL=62
  1.  Q:'$L($G(LEXSO))  Q:'$L($G(LEXNAM))  S LEXSTA=$G(LEXST)
  1.  S LEXEFF=$P(LEXSTA,"^",5),LEXSTA=$P(LEXSTA,"^",4)
  1.  Q:'$L(LEXSTA)  Q:'$L(LEXEFF)  S (LEX1,LEX2,LEX3)=""
  1.  D BOD(LEXELDT),COD(LEXSO,LEXNAM,+($G(LEXL))),STA(.LEXST,+($G(LEXL)))
  1.  Q
  1. BOD(X) ;   Based on Date
  1.  N LEXBOD S LEXBOD=$G(X),X="Display based on date:  "_LEXBOD D BL,TL(X)
  1.  Q
  1. COD(X,Y,LEXLEN) ;   Code Line
  1.  N LEXC,LEXN,LEXT S LEXC=$G(X),LEXN=$G(Y),LEXT="Code:  "_LEXC
  1.  S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  Q
  1. STA(X,LEXLEN) ;   Status Line
  1.  N LEX,LEXC,LEXX,LEXE,LEXI,LEXN,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
  1.  S LEXX=$G(X),LEXSTA=$P(LEXX,"^",4),LEXEFF=$P(LEXX,"^",5)
  1.  S LEXEFF=$TR(LEXEFF,"()",""),LEXW=$P(LEXX,"^",6)
  1.  S LEXT="  Status:  ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXSTA
  1.  S LEXT=LEXT_$J(" ",(35-$L(LEXT)))
  1.  S:LEXEFF'["future" LEXT=LEXT_"Effective:  "
  1.  S LEXT=LEXT_$$UP^XLFSTR($E(LEXEFF,1))_$E(LEXEFF,2,$L(LEXEFF)) D BL,TL(LEXT)
  1.  I $L(LEXW) D
  1.  . N LEX,LEXT,LEXC,LEXI,LEXN S LEX(1)=LEXW D PR^LEXQM(.LEX,(LEXLEN-7))
  1.  . Q:+($O(LEX(" "),-1))'>0  S LEXT=$J(" ",((79-+($G(LEXLEN)))))
  1.  . S (LEXC,LEXI)=0 F  S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0  D
  1.  . . N LEXN S LEXN=$$TM^LEXQM($G(LEX(LEXI))) S:$L(LEXN) LEXC=LEXC+1
  1.  . . D:LEXC=1 BL D TL((LEXT_LEXN))
  1.  Q
  1. FUL ; Full Display
  1.  N LEXFUL,LEX,LEXL S LEXL=+($G(LEXLEN)) S:LEXL>62 LEXL=62
  1.  S LEXFUL=""  D FUT
  1.  D LIM(+($G(LEXIEN)),+($G(LEXL)))
  1.  D SD(.LEXSD,+($G(LEXL)))
  1.  D LD(.LEXLD,+($G(LEXL)))
  1.  D LX(.LEXLX,+($G(LEXL)))
  1.  D WN(.LEXWN,+($G(LEXL)))
  1.  D:$L($G(LEXCC(1)))!($L($G(LEXMC(1)))) BL
  1.  D CC(.LEXCC,+($G(LEXL)))
  1.  D MC(.LEXMC,+($G(LEXL)))
  1.  D DRG(+($G(LEXL)))
  1.  D NOT(+($G(LEXL)))
  1.  D REQ(+($G(LEXL)))
  1.  D NCC(+($G(LEXL)))
  1.  Q
  1. LIM(X,LEXLEN) ;   Limitations - Age Low, Age High and Sex
  1.  N LEXC,LEXI,LEXH,LEXL,LEXS,LEXT,LEXU,LEXP S LEXC=0,LEXI=+($G(X))
  1.  S LEXL=$$VAGEL^ICDEX(+($G(LEXIEN)),$G(LEXCDT)) S:'$L(LEXL) LEXL="N/A"
  1.  S LEXH=$$VAGEH^ICDEX(+($G(LEXIEN)),$G(LEXCDT)) S:'$L(LEXH) LEXH="N/A"
  1.  S LEXS=$$VSEX^ICDEX(80,+($G(LEXIEN)),$G(LEXCDT))
  1.  S LEXS=$S(LEXS="M":"Male",LEXS="F":"Female",1:"") S:'$L(LEXS) LEXS="N/A"
  1.  S LEXU=$$UPDX^ICDEX(+($G(LEXIEN))) S:'$L(LEXU)!(LEXU=0) LEXU="N/A"
  1.  I (LEXH_LEXL_LEXS+LEXU)'="N/AN/AN/AN/A" D
  1.  . N LEXLDR S LEXLDR="  Limitations: ",LEXC=0
  1.  . I LEXL'="N/A" D
  1.  . . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Minimum Age:   "_LEXL
  1.  . . S LEXLDR="               " I $L(LEXT) D BL,TL(LEXT) S LEXC=1
  1.  . I LEXH'="N/A" D
  1.  . . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Maximum Age:   "_LEXH
  1.  . . S LEXLDR="               " I $L(LEXT) D:'LEXC BL D TL(LEXT) S LEXC=1
  1.  . I LEXS'="N/A" D
  1.  . . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Applies to:    "_LEXS_" patients"
  1.  . . S LEXLDR="               " I $L(LEXT) D:'LEXC BL D TL(LEXT) S LEXC=1
  1.  . I LEXU'="N/A" D
  1.  . . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Principle DX:  "_"Code is unacceptable as a principal DX"
  1.  . . S LEXLDR="               " I $L(LEXT) D:'LEXC BL D TL(LEXT) S LEXC=1
  1.  Q
  1. SD(X,LEXLEN) ;   Short Description
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1))  S LEXN=$G(X(1)),LEXT="  Short Name: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXE=$G(X(0)),LEXT="    "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
  1.  Q
  1. LD(X,LEXLEN) ;   Long Description
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1))  S LEXN=$G(X(1)),LEXT="  Description: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXE=$G(X(0)),LEXT="    "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
  1.  S LEXT=$J(" ",((79-+($G(LEXLEN))))) S LEXI=2 F  S LEXI=$O(X(LEXI)) Q:+LEXI'>0  S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
  1.  Q
  1. LX(X,LEXLEN) ;   Lexicon Expression
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1))  S LEXN=$G(X(1)),LEXT="  Lexicon Term:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXE=$G(X(0)),LEXT="    "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
  1.  S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=2 F  S LEXI=$O(X(LEXI)) Q:+LEXI'>0  S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
  1.  Q
  1. WN(X,LEXLEN) ;   Warning
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT,LEXC Q:'$D(X(1))  S LEXC=0,LEXN=$G(X(1)),LEXT="",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=1 F  S LEXI=$O(X(LEXI)) Q:+LEXI'>0  S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
  1.  Q
  1. CC(X,LEXLEN) ;   Complication/Comorbidity
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1))  S LEXN=$G(X(1)),LEXE=$G(X(0)),LEXT="  CC:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN
  1.  S LEXT=LEXT_$J(" ",(66-$L(LEXT)))_LEXE D TL(LEXT)
  1.  Q
  1. MC(X,LEXLEN) ;   Major Diagnostic Category
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1))  S LEXN=$G(X(1)),LEXE=$G(X(0)),LEXT="  MDC:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN
  1.  S LEXT=LEXT_$J(" ",(66-$L(LEXT)))_LEXE D TL(LEXT)
  1.  Q
  1. DRG(LEXLEN) ;   Diagnosis Related Groups
  1.  Q:$O(^TMP("LEXQID",$J,"DRG",3,0))'>0  Q:'$D(^TMP("LEXQID",$J,"DRG",3,1))  Q:'$D(^TMP("LEXQID",$J,"DRG",1,1))
  1.  Q:'$D(^TMP("LEXQID",$J,"DRG",1,2))  Q:'$D(^TMP("LEXQID",$J,"DRG",2,1))  N LEXI,LEXH,LEXE,LEXN,LEXT
  1.  S LEXT="  "_$G(^TMP("LEXQID",$J,"DRG",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"DRG",2,1)) S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXE=$G(^TMP("LEXQID",$J,"DRG",1,2)),LEXT="    "_LEXE,LEXN=$G(^TMP("LEXQID",$J,"DRG",3,1)) S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
  1.  S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=1 F  S LEXI=$O(^TMP("LEXQID",$J,"DRG",3,LEXI)) Q:+LEXI'>0  D
  1.  . S LEXN=LEXT_$G(^TMP("LEXQID",$J,"DRG",3,LEXI)) D TL(LEXN)
  1.  K ^TMP("LEXQID",$J,"DRG")
  1.  Q
  1. NOT(LEXLEN) ;   ICD codes not used with
  1.  Q:'$L($O(^TMP("LEXQID",$J,"NOT",3,"")))  Q:'$D(^TMP("LEXQID",$J,"NOT",1,1))  Q:'$D(^TMP("LEXQID",$J,"NOT",2,1))
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT S LEXT="  "_$G(^TMP("LEXQID",$J,"NOT",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"NOT",2,1))
  1.  S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXN=$$TM^LEXQM($G(^TMP("LEXQID",$J,"NOT",2,2))) I $L(LEXN) D TL((LEXT_LEXN))
  1.  S LEXI=" " F  S LEXI=$O(^TMP("LEXQID",$J,"NOT",3,LEXI)) Q:'$L(LEXI)  D
  1.  . S LEXN=$G(^TMP("LEXQID",$J,"NOT",3,LEXI)) D TL((LEXT_LEXN))
  1.  K ^TMP("LEXQID",$J,"NOT")
  1.  Q
  1. REQ(LEXLEN) ;   ICD codes requried with
  1.  Q:'$L($O(^TMP("LEXQID",$J,"REQ",3,"")))  Q:'$D(^TMP("LEXQID",$J,"REQ",1,1))  Q:'$D(^TMP("LEXQID",$J,"REQ",2,1))
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT S LEXT="  "_$G(^TMP("LEXQID",$J,"REQ",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"REQ",2,1))
  1.  S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXN=$$TM^LEXQM($G(^TMP("LEXQID",$J,"REQ",2,2))) I $L(LEXN) D TL((LEXT_LEXN))
  1.  S LEXI=" " F  S LEXI=$O(^TMP("LEXQID",$J,"REQ",3,LEXI)) Q:'$L(LEXI)  D
  1.  . S LEXN=$G(^TMP("LEXQID",$J,"REQ",3,LEXI)) D TL((LEXT_LEXN))
  1.  K ^TMP("LEXQID",$J,"REQ")
  1.  Q
  1. NCC(LEXLEN) ;   Not CC with
  1.  Q:'$L($O(^TMP("LEXQID",$J,"NCC",3,"")))  Q:'$D(^TMP("LEXQID",$J,"NCC",1,1))  Q:'$D(^TMP("LEXQID",$J,"NCC",2,1))
  1.  N LEXI,LEXH,LEXE,LEXN,LEXT S LEXT="  "_$G(^TMP("LEXQID",$J,"NCC",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"NCC",2,1))
  1.  S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
  1.  S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXN=$$TM^LEXQM($G(^TMP("LEXQID",$J,"NCC",2,2))) I $L(LEXN) D TL((LEXT_LEXN))
  1.  S LEXI=" " F  S LEXI=$O(^TMP("LEXQID",$J,"NCC",3,LEXI)) Q:'$L(LEXI)  D
  1.  . S LEXN=$G(^TMP("LEXQID",$J,"NCC",3,LEXI)) D TL((LEXT_LEXN))
  1.  K ^TMP("LEXQID",$J,"NCC")
  1.  Q
  1.  ;
  1.  ; Miscellaneous
  1. BL ;   Blank Line
  1.  D TL(" ") Q
  1. TL(X) ;   Text Line
  1.  I $D(LEXTEST) W !,$G(X) Q
  1.  N LEXI,LEXTEST S LEXI=+($O(^TMP("LEXQIDO",$J," "),-1))+1 S ^TMP("LEXQIDO",$J,LEXI)=$G(X),^TMP("LEXQIDO",$J,0)=LEXI
  1.  Q