LEXQH ;ISL/KER - Query History - Main ;04/21/2014
;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXQH") SACC 2.3.2.5.1
; ^TMP("LEXQHL") SACC 2.3.2.5.1
; ^TMP("LEXQHLA") SACC 2.3.2.5.1
; ^TMP("LEXQHO") SACC 2.3.2.5.1
;
; External References
; ^DIM ICR 10016
; $$GET1^DIQ ICR 2056
; $$DT^XLFDT ICR 10103
; HOME^%ZIS ICR 10086
;
EN ; Main Entry Point
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
N LEXCODE,LEXCOM,LEXCT,LEXCTY,LEXD,LEXDC,LEXDG,LEXDI,LEXDISP,LEXDR,LEXDRG,LEXDS,LEXDT,LEXE,LEXEC,LEXEF,LEXEIEN,LEXENT,LEXEX,LEXFD,LEXEXIT,LEXFI
N LEXFILE,LEXFIRST,LEXG,LEXH,LEXHD,LEXHDR,LEXI,LEXIA,LEXIAD,LEXICT,LEXID,LEXIEN,LEXIN,LEXIT,LEXIX,LEXKEY,LEXL,LEXL1,LEXL2,LEXL3,LEXLAST,LEXLEN
N LEXM,LEXMAX,LEXMC,LEXMCI,LEXMCT,LEXMD,LEXMDG,LEXMDRG,LEXMOD,LEXMS,LEXN,LEXN1,LEXN2,LEXN3,LEXNAME,LEXNC,LEXNM,LEXNMD,LEXNN,LEXNODE,LEXO,LEXO1
N LEXO2,LEXO3,LEXOC,LEXOMD,LEXP,LEXRAN,LEXROOT,LEXRTN,LEXS,LEXSAB,LEXSEL,LEXSIEN,LEXSO,LEXSS,LEXSTR,LEXT,LEXT1,LEXT2,LEXT3,LEXTAG,LEXTD,LEXTN
N LEXTOT,LEXTQ,LEXTS,LEXTTT,LEXTY,LEXTYPE,LEXUN,LEXUND,LEXUSR,LEXV,LEXVAL,LEXVDT,LEXVT,LEXX,X,Y
K ^TMP("LEXQH",$J),^TMP("LEXQHL",$J),^TMP("LEXQHLA"),^TMP("LEXQHO",$J) S LEXEXIT=0,LEXTD=$$DT^XLFDT W ! S LEXSO=$$SO^LEXQL
K ^TMP("LEXQH",$J) I +LEXEXIT>0!('$L(LEXSO)) W !!,?4,"Code not selected" G ABT
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)
S LEXTYPE=$$TY(LEXFILE,LEXSYS)
I '$L(LEXCODE)!('$L(LEXFILE))!('$L(LEXNAME))!('$L(LEXIEN))!('$L(LEXTYPE))!('$L(LEXROOT))!(+LEXIEN'>0) W !!,?4,"Valid Code not selected" G ABT
S LEXROOT="^"_LEXROOT S LEXNODE=@(LEXROOT_LEXIEN_",0)") I '$L(LEXNODE) W !!,?4,"Record for code not found" G ABT
S LEXDISP=$$DIS^LEXQHA I +($G(LEXEXIT))>0!("^CH^SB^"'[("^"_LEXDISP_"^")) W !!,?4,"Display not selected" G ABT
S (LEXTAG,LEXRTN,LEXENT)=""
S:LEXFILE=80 LEXENT="D EN^LEXQHL1("_+LEXIEN_",$G(LEXDISP))"
S:LEXFILE=80.1 LEXENT="D EN^LEXQHL2("_+LEXIEN_",$G(LEXDISP))"
S:LEXFILE=81 LEXENT="D EN^LEXQHL3("_+LEXIEN_",$G(LEXDISP))" S LEXEXIT=0
S:LEXFILE=81.3 LEXENT="D EN^LEXQHL4("_+LEXIEN_",$G(LEXDISP),$G(LEXRAN))"
S LEXRAN=0 S:LEXFILE=81.3 LEXRAN=$$RAN^LEXQHA
I +($G(LEXEXIT))>0!(LEXFILE=81.3&($G(LEXRAN)["^")) W !!,?4,"Range not selected" G ABT
S LEXT=$S(LEXDISP="CH":"Chronological ",LEXDISP="SB":"Subjective ",1:"")
S LEXT=LEXT_"Display of "_LEXTYPE_" "_LEXCODE
S:$L(LEXNAME) LEXT=LEXT_", """_LEXNAME
S:$L(LEXNAME)&((LEXFILE'=81.3)!(LEXFILE=81.3&(+($G(LEXRAN))'>0))) LEXT=LEXT_""""
S:$L(LEXNAME)&(LEXFILE=81.3&(+($G(LEXRAN))>0)) LEXT=LEXT_","""
S:LEXFILE=81.3&(+($G(LEXRAN))>0) LEXT=LEXT_" with CPT Code Ranges"
W !!,?2,"Display a ",$S(LEXDISP="CH":"Chronological ",LEXDISP="SB":"Subjective ",1:""),"History of ",LEXTYPE," ",LEXCODE
W !,?4,LEXNAME W:LEXFILE=81.3&(+($G(LEXRAN))>0) !,?6,"with CPT Code Ranges" W !
S LEXTAG=$P(LEXENT,U,1) S:LEXTAG[" " LEXTAG=$P(LEXTAG," ",2) S LEXRTN=$P(LEXENT,U,2) S:LEXRTN["(" LEXRTN=$P(LEXRTN,"(",1)
K ^TMP("LEXQHO",$J) S X=LEXENT D ^DIM S:'$D(X) LEXEXIT=1
I +($$TAG^LEXQD((LEXTAG_"^"_LEXRTN)))'>0!(+($G(LEXEXIT))>0) W !!,?4,"Invalid Code or Display selected" G ABT
X LEXENT I '$D(^TMP("LEXQHO",$J)) W !!,?4,"No history to display" G ABT
D:$D(^TMP("LEXQHO",$J)) DSP^LEXQO("LEXQHO") K ^TMP("LEXQH",$J),^TMP("LEXQHL",$J),^TMP("LEXQHLA",$J)
Q
ABT ; Abort
K ^TMP("LEXQH",$J),^TMP("LEXQHL",$J),^TMP("LEXQHLA",$J),^TMP("LEXQHO",$J)
Q
TY(X,Y) ; Code Type
N LEXF,LEXS S LEXF=+($G(X)),LEXS=+($G(Y))
Q:LEXF=80&(LEXS=1) "ICD-9 Diagnostic Code"
Q:LEXF=80.1&(LEXS=2) "ICD-9 Procedural Code"
Q:LEXF=80&(LEXS=30) "ICD-10 Diagnostic Code"
Q:LEXF=80.1&(LEXS=31) "ICD-10 Procedural Code"
Q:LEXF=81 "CPT/HCPCS Procedural Code"
Q:LEXF=81.3 "CPT Modifier Code"
Q ""
EV(X) ; Check environment
N LEX S DT=$$DT^XLFDT D HOME^%ZIS S U="^" I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
S LEX=$$GET1^DIQ(200,(DUZ_","),.01) I '$L(LEX) W !!,?5,"DUZ not valid" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQH 4248 printed Apr 09, 2024@21:07:45 Page 2
LEXQH ;ISL/KER - Query History - Main ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQH") SACC 2.3.2.5.1
+5 ; ^TMP("LEXQHL") SACC 2.3.2.5.1
+6 ; ^TMP("LEXQHLA") SACC 2.3.2.5.1
+7 ; ^TMP("LEXQHO") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; ^DIM ICR 10016
+11 ; $$GET1^DIQ ICR 2056
+12 ; $$DT^XLFDT ICR 10103
+13 ; HOME^%ZIS ICR 10086
+14 ;
EN ; Main Entry Point
+1 NEW 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
+2 NEW LEXCODE,LEXCOM,LEXCT,LEXCTY,LEXD,LEXDC,LEXDG,LEXDI,LEXDISP,LEXDR,LEXDRG,LEXDS,LEXDT,LEXE,LEXEC,LEXEF,LEXEIEN,LEXENT,LEXEX,LEXFD,LEXEXIT,LEXFI
+3 NEW LEXFILE,LEXFIRST,LEXG,LEXH,LEXHD,LEXHDR,LEXI,LEXIA,LEXIAD,LEXICT,LEXID,LEXIEN,LEXIN,LEXIT,LEXIX,LEXKEY,LEXL,LEXL1,LEXL2,LEXL3,LEXLAST,LEXLEN
+4 NEW LEXM,LEXMAX,LEXMC,LEXMCI,LEXMCT,LEXMD,LEXMDG,LEXMDRG,LEXMOD,LEXMS,LEXN,LEXN1,LEXN2,LEXN3,LEXNAME,LEXNC,LEXNM,LEXNMD,LEXNN,LEXNODE,LEXO,LEXO1
+5 NEW LEXO2,LEXO3,LEXOC,LEXOMD,LEXP,LEXRAN,LEXROOT,LEXRTN,LEXS,LEXSAB,LEXSEL,LEXSIEN,LEXSO,LEXSS,LEXSTR,LEXT,LEXT1,LEXT2,LEXT3,LEXTAG,LEXTD,LEXTN
+6 NEW LEXTOT,LEXTQ,LEXTS,LEXTTT,LEXTY,LEXTYPE,LEXUN,LEXUND,LEXUSR,LEXV,LEXVAL,LEXVDT,LEXVT,LEXX,X,Y
+7 KILL ^TMP("LEXQH",$JOB),^TMP("LEXQHL",$JOB),^TMP("LEXQHLA"),^TMP("LEXQHO",$JOB)
SET LEXEXIT=0
SET LEXTD=$$DT^XLFDT
WRITE !
SET LEXSO=$$SO^LEXQL
+8 KILL ^TMP("LEXQH",$JOB)
IF +LEXEXIT>0!('$LENGTH(LEXSO))
WRITE !!,?4,"Code not selected"
GOTO ABT
+9 SET LEXIEN=+LEXSO
SET LEXROOT=$PIECE(LEXSO,U,2)
SET LEXFILE=$PIECE(LEXSO,U,3)
SET LEXSYS=$PIECE(LEXSO,U,4)
SET LEXCODE=$PIECE(LEXSO,U,5)
SET LEXNAME=$PIECE(LEXSO,U,6)
+10 SET LEXTYPE=$$TY(LEXFILE,LEXSYS)
+11 IF '$LENGTH(LEXCODE)!('$LENGTH(LEXFILE))!('$LENGTH(LEXNAME))!('$LENGTH(LEXIEN))!('$LENGTH(LEXTYPE))!('$LENGTH(LEXROOT))!(+LEXIEN'>0)
WRITE !!,?4,"Valid Code not selected"
GOTO ABT
+12 SET LEXROOT="^"_LEXROOT
SET LEXNODE=@(LEXROOT_LEXIEN_",0)")
IF '$LENGTH(LEXNODE)
WRITE !!,?4,"Record for code not found"
GOTO ABT
+13 SET LEXDISP=$$DIS^LEXQHA
IF +($GET(LEXEXIT))>0!("^CH^SB^"'[("^"_LEXDISP_"^"))
WRITE !!,?4,"Display not selected"
GOTO ABT
+14 SET (LEXTAG,LEXRTN,LEXENT)=""
+15 if LEXFILE=80
SET LEXENT="D EN^LEXQHL1("_+LEXIEN_",$G(LEXDISP))"
+16 if LEXFILE=80.1
SET LEXENT="D EN^LEXQHL2("_+LEXIEN_",$G(LEXDISP))"
+17 if LEXFILE=81
SET LEXENT="D EN^LEXQHL3("_+LEXIEN_",$G(LEXDISP))"
SET LEXEXIT=0
+18 if LEXFILE=81.3
SET LEXENT="D EN^LEXQHL4("_+LEXIEN_",$G(LEXDISP),$G(LEXRAN))"
+19 SET LEXRAN=0
if LEXFILE=81.3
SET LEXRAN=$$RAN^LEXQHA
+20 IF +($GET(LEXEXIT))>0!(LEXFILE=81.3&($GET(LEXRAN)["^"))
WRITE !!,?4,"Range not selected"
GOTO ABT
+21 SET LEXT=$SELECT(LEXDISP="CH":"Chronological ",LEXDISP="SB":"Subjective ",1:"")
+22 SET LEXT=LEXT_"Display of "_LEXTYPE_" "_LEXCODE
+23 if $LENGTH(LEXNAME)
SET LEXT=LEXT_", """_LEXNAME
+24 if $LENGTH(LEXNAME)&((LEXFILE'=81.3)!(LEXFILE=81.3&(+($GET(LEXRAN))'>0)))
SET LEXT=LEXT_""""
+25 if $LENGTH(LEXNAME)&(LEXFILE=81.3&(+($GET(LEXRAN))>0))
SET LEXT=LEXT_","""
+26 if LEXFILE=81.3&(+($GET(LEXRAN))>0)
SET LEXT=LEXT_" with CPT Code Ranges"
+27 WRITE !!,?2,"Display a ",$SELECT(LEXDISP="CH":"Chronological ",LEXDISP="SB":"Subjective ",1:""),"History of ",LEXTYPE," ",LEXCODE
+28 WRITE !,?4,LEXNAME
if LEXFILE=81.3&(+($GET(LEXRAN))>0)
WRITE !,?6,"with CPT Code Ranges"
WRITE !
+29 SET LEXTAG=$PIECE(LEXENT,U,1)
if LEXTAG[" "
SET LEXTAG=$PIECE(LEXTAG," ",2)
SET LEXRTN=$PIECE(LEXENT,U,2)
if LEXRTN["("
SET LEXRTN=$PIECE(LEXRTN,"(",1)
+30 KILL ^TMP("LEXQHO",$JOB)
SET X=LEXENT
DO ^DIM
if '$DATA(X)
SET LEXEXIT=1
+31 IF +($$TAG^LEXQD((LEXTAG_"^"_LEXRTN)))'>0!(+($GET(LEXEXIT))>0)
WRITE !!,?4,"Invalid Code or Display selected"
GOTO ABT
+32 XECUTE LEXENT
IF '$DATA(^TMP("LEXQHO",$JOB))
WRITE !!,?4,"No history to display"
GOTO ABT
+33 if $DATA(^TMP("LEXQHO",$JOB))
DO DSP^LEXQO("LEXQHO")
KILL ^TMP("LEXQH",$JOB),^TMP("LEXQHL",$JOB),^TMP("LEXQHLA",$JOB)
+34 QUIT
ABT ; Abort
+1 KILL ^TMP("LEXQH",$JOB),^TMP("LEXQHL",$JOB),^TMP("LEXQHLA",$JOB),^TMP("LEXQHO",$JOB)
+2 QUIT
TY(X,Y) ; Code Type
+1 NEW LEXF,LEXS
SET LEXF=+($GET(X))
SET LEXS=+($GET(Y))
+2 if LEXF=80&(LEXS=1)
QUIT "ICD-9 Diagnostic Code"
+3 if LEXF=80.1&(LEXS=2)
QUIT "ICD-9 Procedural Code"
+4 if LEXF=80&(LEXS=30)
QUIT "ICD-10 Diagnostic Code"
+5 if LEXF=80.1&(LEXS=31)
QUIT "ICD-10 Procedural Code"
+6 if LEXF=81
QUIT "CPT/HCPCS Procedural Code"
+7 if LEXF=81.3
QUIT "CPT Modifier Code"
+8 QUIT ""
EV(X) ; Check environment
+1 NEW LEX
SET DT=$$DT^XLFDT
DO HOME^%ZIS
SET U="^"
IF +($GET(DUZ))=0
WRITE !!,?5,"DUZ not defined"
QUIT 0
+2 SET LEX=$$GET1^DIQ(200,(DUZ_","),.01)
IF '$LENGTH(LEX)
WRITE !!,?5,"DUZ not valid"
QUIT 0
+3 QUIT 1
