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

LEXQH.m

Go to the documentation of this file.
  1. LEXQH ;ISL/KER - Query History - Main ;04/21/2014
  1. ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 1
  1. ;
  1. ; Global Variables
  1. ; ^TMP("LEXQH") SACC 2.3.2.5.1
  1. ; ^TMP("LEXQHL") SACC 2.3.2.5.1
  1. ; ^TMP("LEXQHLA") SACC 2.3.2.5.1
  1. ; ^TMP("LEXQHO") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; ^DIM ICR 10016
  1. ; $$GET1^DIQ ICR 2056
  1. ; $$DT^XLFDT ICR 10103
  1. ; HOME^%ZIS ICR 10086
  1. ;
  1. EN ; Main Entry Point
  1. N DIR,DIRB,DIROUT,DIRUT,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LEX,LEX1,LEX2,LEX3,LEXACT,LEXAT,LEXATD,LEXB,LEXC,LEXC1,LEXC2,LEXCMD
  1. N LEXCODE,LEXCOM,LEXCT,LEXCTY,LEXD,LEXDC,LEXDG,LEXDI,LEXDISP,LEXDR,LEXDRG,LEXDS,LEXDT,LEXE,LEXEC,LEXEF,LEXEIEN,LEXENT,LEXEX,LEXFD,LEXEXIT,LEXFI
  1. N LEXFILE,LEXFIRST,LEXG,LEXH,LEXHD,LEXHDR,LEXI,LEXIA,LEXIAD,LEXICT,LEXID,LEXIEN,LEXIN,LEXIT,LEXIX,LEXKEY,LEXL,LEXL1,LEXL2,LEXL3,LEXLAST,LEXLEN
  1. N LEXM,LEXMAX,LEXMC,LEXMCI,LEXMCT,LEXMD,LEXMDG,LEXMDRG,LEXMOD,LEXMS,LEXN,LEXN1,LEXN2,LEXN3,LEXNAME,LEXNC,LEXNM,LEXNMD,LEXNN,LEXNODE,LEXO,LEXO1
  1. N LEXO2,LEXO3,LEXOC,LEXOMD,LEXP,LEXRAN,LEXROOT,LEXRTN,LEXS,LEXSAB,LEXSEL,LEXSIEN,LEXSO,LEXSS,LEXSTR,LEXT,LEXT1,LEXT2,LEXT3,LEXTAG,LEXTD,LEXTN
  1. N LEXTOT,LEXTQ,LEXTS,LEXTTT,LEXTY,LEXTYPE,LEXUN,LEXUND,LEXUSR,LEXV,LEXVAL,LEXVDT,LEXVT,LEXX,X,Y
  1. K ^TMP("LEXQH",$J),^TMP("LEXQHL",$J),^TMP("LEXQHLA"),^TMP("LEXQHO",$J) S LEXEXIT=0,LEXTD=$$DT^XLFDT W ! S LEXSO=$$SO^LEXQL
  1. K ^TMP("LEXQH",$J) I +LEXEXIT>0!('$L(LEXSO)) W !!,?4,"Code not selected" G ABT
  1. S LEXIEN=+LEXSO,LEXROOT=$P(LEXSO,U,2),LEXFILE=$P(LEXSO,U,3),LEXSYS=$P(LEXSO,U,4),LEXCODE=$P(LEXSO,U,5),LEXNAME=$P(LEXSO,U,6)
  1. S LEXTYPE=$$TY(LEXFILE,LEXSYS)
  1. I '$L(LEXCODE)!('$L(LEXFILE))!('$L(LEXNAME))!('$L(LEXIEN))!('$L(LEXTYPE))!('$L(LEXROOT))!(+LEXIEN'>0) W !!,?4,"Valid Code not selected" G ABT
  1. S LEXROOT="^"_LEXROOT S LEXNODE=@(LEXROOT_LEXIEN_",0)") I '$L(LEXNODE) W !!,?4,"Record for code not found" G ABT
  1. S LEXDISP=$$DIS^LEXQHA I +($G(LEXEXIT))>0!("^CH^SB^"'[("^"_LEXDISP_"^")) W !!,?4,"Display not selected" G ABT
  1. S (LEXTAG,LEXRTN,LEXENT)=""
  1. S:LEXFILE=80 LEXENT="D EN^LEXQHL1("_+LEXIEN_",$G(LEXDISP))"
  1. S:LEXFILE=80.1 LEXENT="D EN^LEXQHL2("_+LEXIEN_",$G(LEXDISP))"
  1. S:LEXFILE=81 LEXENT="D EN^LEXQHL3("_+LEXIEN_",$G(LEXDISP))" S LEXEXIT=0
  1. S:LEXFILE=81.3 LEXENT="D EN^LEXQHL4("_+LEXIEN_",$G(LEXDISP),$G(LEXRAN))"
  1. S LEXRAN=0 S:LEXFILE=81.3 LEXRAN=$$RAN^LEXQHA
  1. I +($G(LEXEXIT))>0!(LEXFILE=81.3&($G(LEXRAN)["^")) W !!,?4,"Range not selected" G ABT
  1. S LEXT=$S(LEXDISP="CH":"Chronological ",LEXDISP="SB":"Subjective ",1:"")
  1. S LEXT=LEXT_"Display of "_LEXTYPE_" "_LEXCODE
  1. S:$L(LEXNAME) LEXT=LEXT_", """_LEXNAME
  1. S:$L(LEXNAME)&((LEXFILE'=81.3)!(LEXFILE=81.3&(+($G(LEXRAN))'>0))) LEXT=LEXT_""""
  1. S:$L(LEXNAME)&(LEXFILE=81.3&(+($G(LEXRAN))>0)) LEXT=LEXT_","""
  1. S:LEXFILE=81.3&(+($G(LEXRAN))>0) LEXT=LEXT_" with CPT Code Ranges"
  1. W !!,?2,"Display a ",$S(LEXDISP="CH":"Chronological ",LEXDISP="SB":"Subjective ",1:""),"History of ",LEXTYPE," ",LEXCODE
  1. W !,?4,LEXNAME W:LEXFILE=81.3&(+($G(LEXRAN))>0) !,?6,"with CPT Code Ranges" W !
  1. S LEXTAG=$P(LEXENT,U,1) S:LEXTAG[" " LEXTAG=$P(LEXTAG," ",2) S LEXRTN=$P(LEXENT,U,2) S:LEXRTN["(" LEXRTN=$P(LEXRTN,"(",1)
  1. K ^TMP("LEXQHO",$J) S X=LEXENT D ^DIM S:'$D(X) LEXEXIT=1
  1. I +($$TAG^LEXQD((LEXTAG_"^"_LEXRTN)))'>0!(+($G(LEXEXIT))>0) W !!,?4,"Invalid Code or Display selected" G ABT
  1. X LEXENT I '$D(^TMP("LEXQHO",$J)) W !!,?4,"No history to display" G ABT
  1. D:$D(^TMP("LEXQHO",$J)) DSP^LEXQO("LEXQHO") K ^TMP("LEXQH",$J),^TMP("LEXQHL",$J),^TMP("LEXQHLA",$J)
  1. Q
  1. ABT ; Abort
  1. K ^TMP("LEXQH",$J),^TMP("LEXQHL",$J),^TMP("LEXQHLA",$J),^TMP("LEXQHO",$J)
  1. Q
  1. TY(X,Y) ; Code Type
  1. N LEXF,LEXS S LEXF=+($G(X)),LEXS=+($G(Y))
  1. Q:LEXF=80&(LEXS=1) "ICD-9 Diagnostic Code"
  1. Q:LEXF=80.1&(LEXS=2) "ICD-9 Procedural Code"
  1. Q:LEXF=80&(LEXS=30) "ICD-10 Diagnostic Code"
  1. Q:LEXF=80.1&(LEXS=31) "ICD-10 Procedural Code"
  1. Q:LEXF=81 "CPT/HCPCS Procedural Code"
  1. Q:LEXF=81.3 "CPT Modifier Code"
  1. Q ""
  1. EV(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