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

LEX10DL.m

Go to the documentation of this file. 
  1. LEX10DL ;ISL/KER - ICD-10 Diagnosis Lookup ;04/21/2014
  1.  ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^%ZOSF("TEST")      ICR  10096
  1.  ;    ^LEX(757.033        N/A
  1.  ;    ^XTMP(              SACC 2.3.2.5.2
  1.  ;               
  1.  ; External References
  1.  ;    HOME^%ZIS           ICR  10086
  1.  ;    ^DIM                ICR  10016
  1.  ;    $$GET1^DIQ          ICR   2056
  1.  ;    ^DIR                ICR  10026
  1.  ;    $$ICDDX^ICDEX       ICR   5747
  1.  ;    $$IMP^ICDEX         ICR   5747
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMADD^XLFDT       ICR  10103
  1.  ;    $$FMDIFF^XLFDT      ICR  10103
  1.  ;    $$FMTE^XLFDT        ICR  10103
  1.  ;    $$NOW^XLFDT         ICR  10103
  1.  ;    $$UP^XLFSTR         ICR  10103
  1.  ;               
  1. EN ; Main Entry Point
  1.  ; 
  1.  ; Input   
  1.  ; 
  1.  ;   None
  1.  ; 
  1.  ; Output
  1.  ; 
  1.  ;   Y          2 Piece "^" delimited string
  1.  ;                 1   IEN to the Expression File 757.01
  1.  ;                 2   Expression Display Text
  1.  ;                 
  1.  ;   Y("ICD")   2 Piece "^" delimited string
  1.  ;                 1   IEN to the ICD DIAGNOSIS File #80
  1.  ;                 2   ICD Code
  1.  ; 
  1.  N LEXENV S LEXENV=$$ENV Q:+LEXENV'>0
  1.  N DTOUT,DUOUT,DIRUT,DIROUT,LEXDT,LEXIM,LEXMAX,LEXFRQ,LEXCONT,X
  1.  S LEXDT=$G(LEXVDT) S:LEXDT'?7N LEXDT=$$DT^XLFDT S LEXMAX=$$MAX^LEXU(30)
  1.  S LEXIM=$$IMP^ICDEX(30) S:LEXDT'>LEXIM LEXDT=LEXIM S LEXCONT=1
  1. X ; Get user input
  1.  S X=$$SO S LEXFRQ=$$FREQ^LEXU(X)
  1.  I LEXFRQ>LEXMAX D  Q:$D(DIRUT)  Q:$D(LEXCONT)["^"  G:LEXCONT'>0 X
  1.  . N LEXX S LEXX=X S LEXCONT=$$CONT^LEX10DLS(LEXX,LEXFRQ) W !
  1.  W ! K Y,LEXY D:$L(X)&(X'["^") BEG N LEXTEST
  1.  Q 
  1. BEG ; Begin Recursive Loop
  1.  N DIROUT,DUOUT,DTOUT,LEXIT,LEXVDT,LEXTXT,LEXUP,LEXY,LEXX
  1.  N LEXBEG,LEXEND,LEXELP,LEXSEC
  1.  K Y S Y=-1,U="^",LEXTXT=$G(X) Q:'$L(LEXTXT)
  1.  S LEXVDT=$G(LEXDT),LEXIT=0
  1. LOOK ;   Lookup
  1.  Q:+($G(LEXIT))>0  K LEXY S LEXBEG=$$NOW^XLFDT
  1.  S LEXY=$$DIAGSRCH^LEX10CS(LEXTXT,.LEXY,LEXVDT,30)
  1.  S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
  1.  S LEXSEC=$$FMDIFF^XLFDT(LEXEND,LEXBEG,2)
  1.  S:$L(LEXELP,":")=3 LEXELP=$TR(LEXELP," ","0")
  1.  S:$L(LEXELP,":")'=3!(LEXSEC'>0) LEXELP="00:00:00"
  1.  I $D(LEXTEST) D
  1.  . W ! W !,"   Search for:     ",LEXTXT
  1.  . W !,"   Begin Search:   ",$$FMTE^XLFDT(LEXBEG,"5Z")
  1.  . W !,"   Finish Search:  ",$$FMTE^XLFDT(LEXBEG,"5Z")
  1.  . W !,"   Elapsed Time:   ",LEXELP W !
  1.  S:$O(LEXY(" "),-1)>0 LEXY=+LEXY
  1.  I +LEXY'>0 W !,"  No data found",! K X Q
  1.  S LEXX=$$SEL^LEX10DLS(.LEXY,8)
  1.  I $D(DUOUT)&('$D(DIROUT)) K:'$D(LEXNT) X Q
  1.  I $D(DTOUT)&('$D(DIROUT)) S LEXIT=1 K X Q
  1.  I $D(DIROUT) S LEXIT=1 K X Q
  1.  ;     Quit if
  1.  ;       Timed out or user enters "^^"
  1.  I $D(DTOUT)!($D(DIROUT)) S LEXIT=1 K X Q
  1.  ;       Up one level (LEXUP) if user enters "^"
  1.  ;       Quit if already at top level and user enters "^"
  1.  I $D(DUOUT),'$D(DIROUT),$L($G(LEXUP)) K X Q
  1.  ;       No Selection Made
  1.  I '$D(DUOUT),LEXX=-1 S LEXIT=1
  1.  ;       Code Found and Selected
  1.  I $P(LEXX,";")'="99:CAT" D  Q
  1.  . N LEXIEN,LEXCODE,LEXTERM,LEXICD
  1.  . S LEXIEN=$P($P(LEXX,"^"),";",1),LEXCODE=$P($P(LEXX,"^"),";",2)
  1.  . S LEXTERM=$P(LEXX,"^",2) S:$L(LEXTERM)&($L(LEXCODE)) LEXTERM=LEXTERM_" (ICD-10-CM "_LEXCODE_")"
  1.  . S LEXICD=+$$ICDDX^ICDEX(LEXCODE,,30),LEXIT=1
  1.  . S Y=LEXIEN_"^"_LEXTERM,Y("ICD")=LEXICD_"^"_LEXCODE
  1.  ;       Category Found and Selected
  1.  D NXT G:+($G(LEXIT))'>0 LOOK
  1.  Q
  1. NXT ;   Next
  1.  Q:+($G(LEXIT))>0  N LEXNT,LEXND,LEXXX
  1.  S LEXNT=$G(LEXTXT),LEXND=$G(LEXVDT),LEXXX=$G(LEXX)
  1.  N LEXTXT,LEXVDT S LEXTXT=$P($P(LEXXX,"^"),";",2),LEXVDT=LEXND
  1.  G LOOK
  1.  Q
  1.  ;     
  1. SO(X) ; Enter a Code/Code Fragment
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,DIRB,LEXTD,Y,LEX,LEXCOM,LEXERR,LEXSBR
  1.  S LEXTD=$G(LEXVDT) S:LEXTD'?7N LEXTD=$$DT^XLFDT
  1.  S LEXCOM="Enter Diagnosis, a Code or a Code Fragment"
  1.  S DIR(0)="FAO^1:30",DIR("A")=" "_LEXCOM_":  "
  1.  S (LEXSBR,DIRB)=$$RET("LEX10DL","SO",+($G(DUZ)),LEXCOM)
  1.  S DIR("PRE")="S X=$$SOP^LEX10DL(X) W:X[""??"" ""  ??"""
  1.  S (DIR("?"),DIR("??"))="^D SOH^LEX10DL" D ^DIR
  1.  I $D(DTOUT) W !!,?3,"Try later",! Q "^"
  1.  I '$L(X)!('$L(Y)) W !!,?3,"No selection made",! Q "^"
  1.  S:$D(DUOUT) X="^" S:$D(DIROUT) X="^^"
  1.  I $G(X)["^" W !!,?3,"Selection aborted",! Q "^"
  1.  S (LEX,X)=$G(Y) D:$L(LEX)&(LEX'["^") SAV("LEX10DL","SO",+($G(DUZ)),LEXCOM,LEX)
  1.  Q X
  1. SOH ;   Select a Code Help
  1.  W:$L($G(LEXERR)) !,"     ",LEXERR,!
  1.  W !,"     Enter either: "
  1.  W !,"                                            Example"
  1.  W !,"       ICD-10 Diagnosis code                S62.131K"
  1.  W !,"       Partial ICD-10 Diagnosis code        S62.131"
  1.  W !,"       ICD-10 Diagnosis sub-category        S62.131"
  1.  W !,"       ICD-10 Diagnosis category            S62."
  1.  W !,"       Partial ICD-10 Diagnosis category    S6"
  1.  W !,"       Diagnostic Text                      Diabetes Mellitus",!
  1.  W !,"     Must have at least 2 characters.  If a code is entered"
  1.  W !,"     it may not exceed 7 characters.  Enter return or ""^"" "
  1.  W !,"     to exit, ""Space-Bar-Return"" to select previous"
  1.  W !,"     search parameter.",!
  1.  K LEXERR
  1.  Q
  1. SOP(X) ;   Code Pre-Processing
  1.  N LEX,LEXO,LEXR,LEXB,LEXOK,LEXSTB,LEXSO S LEXSO=0
  1.  S (LEX,X)=$$UP^XLFSTR($G(X)),LEXSTB=$E(LEX,1,3),LEXB=$G(DIR("B"))
  1.  I ($L(LEX)&($E(LEX,1)=" "))&($L($G(LEXSBR))) D  Q X
  1.  . S (LEX,X)=$G(LEXSBR) W "  ",X
  1.  Q:LEX["?" "??"  S:LEX["^^" (LEX,X)="^^",DUOUT=1,DIROUT=1
  1.  S:LEX["^"&(LEX'["^^") (LEX,X)="^",DUOUT=1
  1.  Q:LEX["^" X  S:'$L(LEX)&($L(LEXB)) (LEX,X)=$G(LEXB)
  1.  Q:'$L(LEX) ""  S LEXR=LEX S:$L(LEXR) LEXR=" ("_LEXR_")"
  1.  S LEXSO=0 I $L(LEXSTB) D
  1.  . S:$O(^LEX(757.02,"ADX",(LEXSTB_" ")))[LEXSTB LEXSO=1
  1.  I 'LEXSO Q X
  1.  S:$L(LEX)'>1 LEXERR="Input must be at least 2 characters"_LEXR
  1.  S:$L(LEX)>8 LEXERR="Input can not exceed 8 characters"_LEXR
  1.  Q:$L(LEX)'>1!($L(LEX)>8) "??"
  1.  S:$L(LEX)>3&($E(LEX,4)'=".") LEXERR="Fourth character position must be a decimal"_LEXR
  1.  Q:$L(LEX)>3&($E(LEX,4)'=".") "??"  S LEXOK=0
  1.  S LEXO=$E(LEX,1,($L(LEX)-1))_$C($A($E(LEX,$L(LEX)))-1)_"~"
  1.  S:$L(LEX)=3&(LEX'[".") (LEX,X)=LEX_"."
  1.  S:$D(^LEX(757.02,"ADX",(LEX_" "))) LEXOK=1
  1.  S:$O(^LEX(757.02,"ADX",(LEXO_" ")))[LEX LEXOK=1
  1.  S:$D(^LEX(757.033,"AFRAG",30,(LEX_" "))) LEXOK=1
  1.  S:$O(^LEX(757.033,"AFRAG",30,(LEXO_" ")))[LEX LEXOK=1
  1.  S:'LEXOK LEXERR="Input is not a code or category"_LEXR
  1.  S:'LEXOK (LEX,X)="??"
  1.  Q X
  1.  ;               
  1.  ; Miscellaneous
  1. SAV(X,Y,LEXN,LEXC,LEXV) ;   Save Defaults
  1.  N LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXVAL,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY S LEXRTN=$G(X) Q:+($$ROK(LEXRTN))'>0  S LEXTAG=$G(Y) Q:+($$TAG((LEXTAG_"^"_LEXRTN)))'>0
  1.  S LEXUSR=+($G(LEXN)),LEXVAL=$G(LEXV) Q:LEXUSR'>0  Q:'$L(LEXVAL)  S LEXCOM=$G(LEXC) Q:'$L(LEXCOM)  S LEXKEY=$E(LEXCOM,1,13) F  Q:$L(LEXKEY)>12  S LEXKEY=LEXKEY_" "
  1.  S LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01) Q:'$L(LEXNM)  S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,30),LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
  1.  S ^XTMP(LEXID,0)=LEXFD_"^"_LEXTD_"^"_LEXCOM,^XTMP(LEXID,LEXTAG)=LEXVAL
  1.  Q
  1. RET(X,Y,LEXN,LEXC) ;   Retrieve Defaults
  1.  N LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY S LEXRTN=$G(X) Q:+($$ROK(LEXRTN))'>0 ""
  1.  S LEXTAG=$G(Y) Q:+($$TAG((LEXTAG_"^"_LEXRTN)))'>0 ""  S LEXUSR=+($G(LEXN)) Q:LEXUSR'>0 ""
  1.  S LEXCOM=$G(LEXC) Q:'$L(LEXCOM) ""  S LEXKEY=$E(LEXCOM,1,13) F  Q:$L(LEXKEY)>12  S LEXKEY=LEXKEY_" "
  1.  S LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01) Q:'$L(LEXNM) ""  S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,30),LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
  1.  S X=$G(^XTMP(LEXID,LEXTAG))
  1.  Q X
  1. ROK(X) ;   Routine OK
  1.  S X=$G(X) Q:'$L(X) 0  Q:$L(X)>8 0  X ^%ZOSF("TEST") Q:$T 1  Q 0
  1. TAG(X) ;   Sub-Routine OK
  1.  N LEXT,LEXE,LEXL S X=$G(X) Q:'$L(X) 0  Q:X'["^" 0
  1.  Q:'$L($P(X,"^",1)) 0  Q:$L($P(X,"^",1))>8 0  Q:$E($P(X,"^",1),1)'?1U 0
  1.  Q:'$L($P(X,"^",2)) 0  Q:$L($P(X,"^",2))>8 0  Q:$E($P(X,"^",2),1)'?1U 0
  1.  S LEXL=0,LEXT=X,(LEXE,X)="S LEXL=$L($T("_X_"))" D ^DIM X:$D(X) LEXE
  1.  S X=$S(LEXL>0:1,1:0)
  1.  Q X
  1. ENV(X) ;   Check environment
  1.  N LEX S DT=$$DT^XLFDT D HOME^%ZIS S U="^" I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
  1.  S LEX=$$GET1^DIQ(200,(DUZ_","),.01) I '$L(LEX) W !!,?5,"DUZ not valid" Q 0
  1.  Q 1