- 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 Dec 13, 2024@02:08:38 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