LEX10PL ;ISL/KER - ICD-10 Procedure Lookup ;05/23/2017
;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^%ZOSF("TEST" ICR 10096
; ^LEX(757.033 N/A
; ^XTMP( SACC 2.3.2.5.2
;
; External References
; HOME^%ZIS ICR 10086
; ENDR^%ZISS ICR 10088
; KILL^%ZISS ICR 10088
; ^DIM ICR 10016
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$ICDOP^ICDEX ICR 5747
; $$IMP^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
EN ; Main Entry Point
;
; Input
;
; None
;
; Output
;
; Y 2 Piece "^" delimited string
; 1 IEN to the Expression File 757.01
; 2 Expression Display Text
;
; Y("ICD") 2 Piece "^" delimited string
; 1 IEN ICD OPERATION/PROCEDURE File #80.1
; 2 ICD Code
;
N LEXENV S LEXENV=$$ENV Q:+LEXENV'>0 N X,LEXDT,LEXIM
N BOLD,DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,IOINHI,IOINORM,LEX
N LEXA,LEXB,LEXC,LEXCHR,LEXCODE,LEXCOM,LEXDT,LEXE,LEXEFF
N LEXENV,LEXERR,LEXFD,LEXI,LEXICD,LEXID,LEXIEN,LEXIM,LEXIN
N LEXIT,LEXKEY,LEXL,LEXN,LEXNAM,LEXND,LEXNM,LEXNT,LEXO
N LEXOFF,LEXOK,LEXPCDAT,LEXPSN,LEXR,LEXRTN,LEXS,LEXSBR
N LEXSEC,LEXSIEN,LEXSTA,LEXT,LEXTAG,LEXTD,LEXTERM,LEXTOT
N LEXTXT,LEXUP,LEXUSR,LEXV,LEXVAL,LEXVDT,LEXX,LEXY,NORM,X
X ; Get user input
K DIROUT,DIRUT,DTOUT,DUOUT
S LEXDT=$G(LEXVDT) S:LEXDT'?7N LEXDT=$$DT^XLFDT
S LEXIM=$$IMP^ICDEX(30) S:LEXDT'>LEXIM LEXDT=LEXIM S X=$$SO Q:X["^"
K Y,LEXY D:$L(X)&(X'["^") BEG I $D(DUOUT)&'$D(DIROUT) W ! G X
N LEXTEST
Q
BEG ; Begin Recursive Loop
K DIROUT,DIRUT,DTOUT,DUOUT N LEXIT,LEXVDT,LEXTXT,LEXUP,LEXY,LEXX
N LEXBEG,LEXEND,LEXELP,LEXSEC
K Y S Y=-1,U="^",LEXTXT=$G(X) Q:'$L(LEXTXT)
S LEXVDT=$G(LEXDT),LEXIT=0
LOOK ; Lookup
Q:+($G(LEXIT))>0 K LEXY
S LEXY=$$PCSDIG^LEX10CS(LEXTXT,LEXDT),LEXTOT=$$FND
S:$L(LEXTXT)>0 LEXUP=$E(LEXTXT,1,($L(LEXTXT)-1))
I $L($O(LEXPCDAT("NEXLEV",""))) S LEXCHR=$$SEL^LEX10PLS(LEXTXT)
S LEXCHR=$G(LEXCHR)
; Quit if
; Timed out or user enters "^^"
I $D(DTOUT)!($D(DIROUT)) S LEXIT=1 K X Q
; Up one level (LEXUP) if user enters "^"
; Quit if already at top level and user enters "^"
I $D(DUOUT),'$D(DIROUT),$D(DIRUT),$L($G(LEXTXT))=1 D Q
. K X,LEXUP,LEXNT S LEXIT=1,(LEXCHR,LEXTXT,X)=""
I $D(DUOUT),'$D(DIROUT),$D(DIRUT),$L($G(LEXUP)) D G:'LEXIT LOOK Q:LEXIT
. K X S (X,LEXTXT)=LEXUP I '$L(X) S LEXIT=1 K X S LEXTXT=""
. S:$L($G(LEXNT))>1 LEXNT=$E($G(LEXNT),1,($L($G(LEXNT))-1))
I $D(DUOUT),'$D(DIROUT),$D(DIRUT),'$L($G(LEXUP)) S LEXIT=1 K X S LEXTXT="" Q
I $D(DUOUT)&('$D(DIROUT)) K:'$D(LEXNT) X Q
; No Selection Made
I '$D(DUOUT),LEXCHR="" S LEXIT=1
; Character Found and Selected
I $L(LEXCHR),LEXCHR'["^",(LEXCHR?1N!(LEXCHR?1U)) D Q:+($G(Y))>0
. K Y S LEXTXT=LEXTXT_LEXCHR Q:$L(LEXTXT)<7
. N LEXSTA,LEXSIEN,LEXIEN,LEXCODE,LEXEFF,LEXTERM,LEXND,LEXICD
. S LEXSTA=$$STATCHK^LEXSRC2(LEXTXT,$G(LEXDT),,31)
. S LEXSIEN=$P(LEXSTA,"^",2)
. S LEXEFF=$P(LEXSTA,"^",3)
. S LEXSTA=$P(LEXSTA,"^",1)
. S LEXND=$G(^LEX(757.02,+LEXSIEN,0))
. S LEXCODE=$P(LEXND,"^",2),LEXIEN=+LEXND
. S LEXTERM=$G(^LEX(757.01,+LEXIEN,0))
. S LEXICD=+$$ICDOP^ICDEX(LEXCODE,,31),LEXIT=1
. S Y=LEXIEN_"^"_LEXTERM,Y("ICD")=LEXICD_"^"_LEXCODE
. D END(LEXCODE,LEXTERM)
; Category Found and Selected
I $L(LEXCHR),LEXCHR'["^",(LEXCHR?1N!(LEXCHR?1U)) D G:+($G(LEXIT))'>0 LOOK
. D NXT I $G(Y)="^" D
. . Q:'$L(LEXTXT) S LEXTXT=$E(LEXTXT,1,($L(LEXTXT)-1)) Q:'$L(LEXTXT)
. . F S LEXTXT=$E(LEXTXT,1,($L(LEXTXT)-1)) Q:$$TOT($E(LEXTXT,1,($L(LEXTXT)-1)),LEXDT)>0
Q
NXT ; Next
Q:+($G(LEXIT))>0 N LEXNT,LEXND
S LEXNT=$G(LEXTXT),LEXND=$G(LEXDT)
N LEXTXT,LEXDT S LEXTXT=LEXNT,LEXDT=LEXND
G LOOK
Q
TOT(X,Y) ; Total Possible
N LEXPCDAT,LEXDT,LEXY S X=$G(X) Q:'$L(X) 0 S LEXDT=$G(Y)
S LEXY=$$PCSDIG^LEX10CS(X,LEXDT),X=$$FND
Q X
;
SO(X) ; Enter a Code/Code Fragment
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,DIRB,LEXTD,Y,LEX,LEXCOM,LEXERR,LEXSBR
S LEXTD=$G(LEXVDT) S:LEXTD'?7N LEXTD=$$DT^XLFDT
S LEXCOM="Enter a Procedure Code/Code Fragment"
S DIR(0)="FAO^1:30",DIR("A")=" "_LEXCOM_": "
S (LEXSBR,DIRB)=$$RET("LEX10PL","SO",+($G(DUZ)),LEXCOM)
S DIR("PRE")="S X=$$SOP^LEX10PL(X) W:X[""??"" "" ??"""
S (DIR("?"),DIR("??"))="^D SOH^LEX10PL" D ^DIR
Q:$D(DTOUT) "^" Q:'$L(X)!('$L(Y)) "^" Q:$D(DUOUT) "^" Q:$D(DIROUT) "^" Q:$G(X)["^" "^"
S (LEX,X)=$G(Y) D:$L(LEX)&(LEX'["^") SAV("LEX10PL","SO",+($G(DUZ)),LEXCOM,LEX)
Q X
SOH ; Select a Code Help
W:$L($G(LEXERR)) !," ",LEXERR,!
W !," Enter either: "
W !," Example"
W !," ICD-10 Procedure code 04LE0CT"
W !," Partial ICD-10 Procedure code 00C6",!
W !," May not exceed 7 characters. Enter return or ""^"""
W !," to exit."
K LEXERR
Q
SOP(X) ; Code Pre-Processing
N LEX,LEXO,LEXR,LEXB,LEXOK K LEXERR Q:'$L($G(X)) ""
S (LEX,X)=$$UP^XLFSTR($G(X)) Q:'$L(LEX) "??"
Q:LEX["?" "??" S:LEX["^^" (LEX,X)="^^",DUOUT=1,DIROUT=1
S:LEX["^"&(LEX'["^^") (LEX,X)="^",DUOUT=1 Q:LEX["^" X Q:'$L(LEX) ""
I LEX["." S LEXERR="Procedure codes do not have decimal places" Q "??"
I $E(LEX,1)="Z" S LEXERR="First character must not contain ""Z""" Q "??"
S (LEXC,LEXO,LEXR)=$E(LEX,1),LEXO=$C($A(LEXO)-1)_"~ ",LEXN=($O(^LEX(757.02,"APR",LEXO)))
I (LEXR'?1U&(LEXR'?1N)) S LEXERR="First character must be uppercase or numeric" Q "??"
I $E(LEXN,1,$L(LEXC))'=LEXC S LEXERR="First character """_$E(LEX,1)_""" is not valid" Q "??"
I $L(LEX)'>1 S X=LEX Q X
S (LEXC,LEXO)=$E(LEX,1,2),LEXR=$E(LEX,2),LEXO=$E(LEXO,1,($L(LEXO)-1))_$C($A($E(LEXO,$L(LEXO)))-1)_"~"
S LEXN=($O(^LEX(757.02,"APR",LEXO)))
I (LEXR'?1U&(LEXR'?1N)) S LEXERR="Second character must be uppercase or numeric" Q "??"
I $L(LEX)>1 I $E(LEXN,1,$L(LEXC))'=LEXC S LEXERR="Second character """_LEXR_""" is not valid" Q "??"
I $L(LEX)'>2 S X=LEX Q X
S (LEXC,LEXO)=$E(LEX,1,3),LEXR=$E(LEX,3),LEXO=$E(LEXO,1,($L(LEXO)-1))_$C($A($E(LEXO,$L(LEXO)))-1)_"~"
S LEXN=($O(^LEX(757.02,"APR",LEXO)))
I (LEXR'?1U&(LEXR'?1N))!(LEXR="Z") S LEXERR="Third character must not contain ""Z""" Q "??"
I (LEXR'?1U&(LEXR'?1N)) S LEXERR="Third character must be uppercase or numeric" Q "??"
I $L(X)>1 I $E(LEXN,1,$L(LEXC))'=LEXC S LEXERR="Third character """_LEXR_""" is not valid" Q "??"
I $L(LEX)'>3 S X=LEX Q X
S (LEXC,LEXO)=$E(LEX,1,4),LEXR=$E(LEX,4),LEXO=$E(LEXO,1,($L(LEXO)-1))_$C($A($E(LEXO,$L(LEXO)))-1)_"~"
S LEXN=($O(^LEX(757.02,"APR",LEXO)))
I (LEXR'?1U&(LEXR'?1N)) S LEXERR="Fourth character must be uppercase or numeric" Q "??"
I $L(X)>1 I $E(LEXN,1,$L(LEXC))'=LEXC S LEXERR="Fourth character """_LEXR_""" is not valid" Q "??"
I $L(LEX)'>4 S X=LEX Q X
S (LEXC,LEXO)=$E(LEX,1,5),LEXR=$E(LEX,5),LEXO=$E(LEXO,1,($L(LEXO)-1))_$C($A($E(LEXO,$L(LEXO)))-1)_"~"
S LEXN=($O(^LEX(757.02,"APR",LEXO)))
I (LEXR'?1U&(LEXR'?1N)) S LEXERR="Fifth character must be uppercase or numeric" Q "??"
I $L(X)>1 I $E(LEXN,1,$L(LEXC))'=LEXC S LEXERR="Fifth character """_LEXR_""" is not valid" Q "??"
I $L(LEX)'>5 S X=LEX Q X
S (LEXC,LEXO)=$E(LEX,1,6),LEXR=$E(LEX,6),LEXO=$E(LEXO,1,($L(LEXO)-1))_$C($A($E(LEXO,$L(LEXO)))-1)_"~"
S LEXN=($O(^LEX(757.02,"APR",LEXO)))
I (LEXR'?1U&(LEXR'?1N)) S LEXERR="Sixth character must be uppercase or numeric" Q "??"
I $L(X)>1 I $E(LEXN,1,$L(LEXC))'=LEXC S LEXERR="Sixth character """_LEXR_""" is not valid" Q "??"
I $L(LEX)'>6 S X=LEX Q X
S (LEXC,LEXO)=$E(LEX,1,7),LEXR=$E(LEX,7),LEXO=$E(LEXO,1,($L(LEXO)-1))_$C($A($E(LEXO,$L(LEXO)))-1)_"~"
S LEXN=($O(^LEX(757.02,"APR",LEXO)))
I (LEXR'?1U&(LEXR'?1N)) S LEXERR="Seventh character must be uppercase or numeric" Q "??"
I $L(X)>1 I $E(LEXN,1,$L(LEXC))'=LEXC S LEXERR="Seventh character """_LEXR_""" is not valid" Q "??"
S X=LEX
Q X
;
; Miscellaneous
SAV(X,Y,LEXN,LEXC,LEXV) ; Save Defaults
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
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_" "
S LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01) Q:'$L(LEXNM) S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,30),LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
S ^XTMP(LEXID,0)=LEXFD_"^"_LEXTD_"^"_LEXCOM,^XTMP(LEXID,LEXTAG)=LEXVAL
Q
RET(X,Y,LEXN,LEXC) ; Retrieve Defaults
N LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY S LEXRTN=$G(X) Q:+($$ROK(LEXRTN))'>0 ""
S LEXTAG=$G(Y) Q:+($$TAG((LEXTAG_"^"_LEXRTN)))'>0 "" S LEXUSR=+($G(LEXN)) Q:LEXUSR'>0 ""
S LEXCOM=$G(LEXC) Q:'$L(LEXCOM) "" S LEXKEY=$E(LEXCOM,1,13) F Q:$L(LEXKEY)>12 S LEXKEY=LEXKEY_" "
S LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01) Q:'$L(LEXNM) "" S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,30),LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
S X=$G(^XTMP(LEXID,LEXTAG))
Q X
ROK(X) ; Routine OK
S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0
TAG(X) ; Sub-Routine OK
N LEXT,LEXE,LEXL S X=$G(X) Q:'$L(X) 0 Q:X'["^" 0
Q:'$L($P(X,"^",1)) 0 Q:$L($P(X,"^",1))>8 0 Q:$E($P(X,"^",1),1)'?1U 0
Q:'$L($P(X,"^",2)) 0 Q:$L($P(X,"^",2))>8 0 Q:$E($P(X,"^",2),1)'?1U 0
S LEXL=0,LEXT=X,(LEXE,X)="S LEXL=$L($T("_X_"))" D ^DIM X:$D(X) LEXE
S X=$S(LEXL>0:1,1:0)
Q X
END(X,Y) ; End Search, display results
N LEXCODE,LEXTERM,LEXC,LEXI,LEXS S LEXCODE=$G(X),LEXTERM(1)=$G(Y) Q:$L(LEXCODE)'=7 Q:'$L(LEXTERM(1))
D PR^LEXU(.LEXTERM,69),GCUR($G(LEXCODE),.LEXC)
S LEXS="",$P(LEXS,"-",$L(LEXC))="-" S LEXC=$J(" ",1)_LEXC,LEXS=$J(" ",1)_LEXS
W:$L($G(IOF)) @IOF S LEXI=0 F S LEXI=$O(LEXTERM(LEXI)) Q:+LEXI'>0 D
. W !,?2,$G(LEXTERM(LEXI))
W ! D ATTR W !,$G(BOLD),$G(LEXC),$G(NORM),!," ",$G(LEXS) D KATTR
S LEXI=0 F S LEXI=$O(LEXC(LEXI)) Q:+LEXI'>0 W !," ",$G(LEXC(LEXI))
W !!
Q
CUR(X) ; Current Array
N LEXC,LEXS,LEXI K LEXC D GCUR($G(X),.LEXC) Q:'$D(LEXC) S LEXC=$TR(LEXC," ","") Q:'$L($G(LEXC)) Q:$O(LEXC(0))'>0
N LEXS,LEXI S LEXS="",$P(LEXS,"-",$L(LEXC))="-" S LEXC=$J(" ",1)_LEXC,LEXS=$J(" ",1)_LEXS
W:$L($G(IOF)) @IOF D ATTR W !,$G(BOLD),$G(LEXC),$G(NORM),!,$G(LEXS) D KATTR
S LEXI=0 F S LEXI=$O(LEXC(LEXI)) Q:+LEXI'>0 W !,$G(LEXC(LEXI))
Q
GCUR(X,LEXA) ; Get Current Array
K LEXA N LEXIN,LEXPSN,LEXOFF,LEXOK D ATTR
S LEXIN=$TR($G(X)," ",""),LEXOFF=$L(LEXIN)+2 Q:'$L(LEXIN) Q:'$D(^LEX(757.033,"AFRAG",31,(LEXIN_" ")))
S LEXOK=1,LEXA=$J(" ",1)_LEXIN F LEXPSN=1:1:$L(LEXIN) D
. N LEXTXT,LEXSEC,LEXCHR,LEXNAM S LEXSEC=$E(LEXIN,1,LEXPSN),LEXCHR=$E(LEXIN,LEXPSN),LEXNAM=$$NAM(LEXSEC)
. I '$L(LEXSEC)!('$L(LEXCHR))!('$L(LEXNAM)) S LEXOK=0 Q
. S LEXTXT=$J(" ",LEXPSN)_$G(BOLD)_LEXCHR_$G(NORM)
. S LEXTXT=LEXTXT_$J(" ",(LEXOFF-LEXPSN))_LEXNAM
. S LEXA(LEXPSN)=LEXTXT
D KATTR
K:'LEXOK LEXA
Q
NAM(X) ; Descriptive Dane
N LEXIN,LEXDT,LEXEFF,LEXIEN S LEXIN=$G(X) Q:'$L(LEXIN) "" Q:'$D(^LEX(757.033,"AFRAG",31,(LEXIN_" "))) ""
S LEXDT=$G(LEXVDT) S:LEXDT'?7N LEXDT=$$IMP^ICDEX(31)
S LEXEFF=$O(^LEX(757.033,"AFRAG",31,(LEXIN_" "),(LEXDT+.001)),-1) Q:LEXEFF'?7N ""
S LEXIEN=$O(^LEX(757.033,"AFRAG",31,(LEXIN_" "),LEXEFF," "),-1) Q:+LEXIEN'>0 ""
S X=$$SN(LEXIEN)
Q X
SN(X,EFF) ; Short Name
N IEN,CDT,IMP,EFF,HIS S IEN=+($G(X)),CDT=$G(LEXVDT) S:$G(EFF)?7N CDT=$G(EFF)
S IMP=$$IMP^ICDEX(31) S:CDT'?7N CDT=$$DT^XLFDT S:CDT'>IMP&(IMP?7N) CDT=IMP
S EFF=$O(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
S HIS=$O(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
S X=$G(^LEX(757.033,+IEN,2,+HIS,1))
Q X
FND(X) ; Found
N LEXI S X=0,LEXI="" F S LEXI=$O(LEXPCDAT("NEXLEV",LEXI)) Q:'$L(LEXI) S X=X+1
Q X
GETO(X) ; Get One
S X=$O(LEXPCDAT("NEXLEV",""))
Q X
ATTR ; Screen Attributes
N X,IOINHI,IOINORM S X="IOINHI;IOINORM" D ENDR^%ZISS S BOLD=$G(IOINHI),NORM=$G(IOINORM)
Q
KATTR ; Kill Screen Attributes
D KILL^%ZISS K BOLD,NORM
Q
ENV(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[HLEX10PL 12433 printed Sep 23, 2025@19:39:21 Page 2
LEX10PL ;ISL/KER - ICD-10 Procedure Lookup ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^%ZOSF("TEST" ICR 10096
+5 ; ^LEX(757.033 N/A
+6 ; ^XTMP( SACC 2.3.2.5.2
+7 ;
+8 ; External References
+9 ; HOME^%ZIS ICR 10086
+10 ; ENDR^%ZISS ICR 10088
+11 ; KILL^%ZISS ICR 10088
+12 ; ^DIM ICR 10016
+13 ; $$GET1^DIQ ICR 2056
+14 ; ^DIR ICR 10026
+15 ; $$ICDOP^ICDEX ICR 5747
+16 ; $$IMP^ICDEX ICR 5747
+17 ; $$DT^XLFDT ICR 10103
+18 ; $$FMADD^XLFDT ICR 10103
+19 ; $$UP^XLFSTR ICR 10104
+20 ;
EN ; Main Entry Point
+1 ;
+2 ; Input
+3 ;
+4 ; None
+5 ;
+6 ; Output
+7 ;
+8 ; Y 2 Piece "^" delimited string
+9 ; 1 IEN to the Expression File 757.01
+10 ; 2 Expression Display Text
+11 ;
+12 ; Y("ICD") 2 Piece "^" delimited string
+13 ; 1 IEN ICD OPERATION/PROCEDURE File #80.1
+14 ; 2 ICD Code
+15 ;
+16 NEW LEXENV
SET LEXENV=$$ENV
if +LEXENV'>0
QUIT
NEW X,LEXDT,LEXIM
+17 NEW BOLD,DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,IOINHI,IOINORM,LEX
+18 NEW LEXA,LEXB,LEXC,LEXCHR,LEXCODE,LEXCOM,LEXDT,LEXE,LEXEFF
+19 NEW LEXENV,LEXERR,LEXFD,LEXI,LEXICD,LEXID,LEXIEN,LEXIM,LEXIN
+20 NEW LEXIT,LEXKEY,LEXL,LEXN,LEXNAM,LEXND,LEXNM,LEXNT,LEXO
+21 NEW LEXOFF,LEXOK,LEXPCDAT,LEXPSN,LEXR,LEXRTN,LEXS,LEXSBR
+22 NEW LEXSEC,LEXSIEN,LEXSTA,LEXT,LEXTAG,LEXTD,LEXTERM,LEXTOT
+23 NEW LEXTXT,LEXUP,LEXUSR,LEXV,LEXVAL,LEXVDT,LEXX,LEXY,NORM,X
X ; Get user input
+1 KILL DIROUT,DIRUT,DTOUT,DUOUT
+2 SET LEXDT=$GET(LEXVDT)
if LEXDT'?7N
SET LEXDT=$$DT^XLFDT
+3 SET LEXIM=$$IMP^ICDEX(30)
if LEXDT'>LEXIM
SET LEXDT=LEXIM
SET X=$$SO
if X["^"
QUIT
+4 KILL Y,LEXY
if $LENGTH(X)&(X'["^")
DO BEG
IF $DATA(DUOUT)&'$DATA(DIROUT)
WRITE !
GOTO X
+5 NEW LEXTEST
+6 QUIT
BEG ; Begin Recursive Loop
+1 KILL DIROUT,DIRUT,DTOUT,DUOUT
NEW LEXIT,LEXVDT,LEXTXT,LEXUP,LEXY,LEXX
+2 NEW LEXBEG,LEXEND,LEXELP,LEXSEC
+3 KILL Y
SET Y=-1
SET U="^"
SET LEXTXT=$GET(X)
if '$LENGTH(LEXTXT)
QUIT
+4 SET LEXVDT=$GET(LEXDT)
SET LEXIT=0
LOOK ; Lookup
+1 if +($GET(LEXIT))>0
QUIT
KILL LEXY
+2 SET LEXY=$$PCSDIG^LEX10CS(LEXTXT,LEXDT)
SET LEXTOT=$$FND
+3 if $LENGTH(LEXTXT)>0
SET LEXUP=$EXTRACT(LEXTXT,1,($LENGTH(LEXTXT)-1))
+4 IF $LENGTH($ORDER(LEXPCDAT("NEXLEV","")))
SET LEXCHR=$$SEL^LEX10PLS(LEXTXT)
+5 SET LEXCHR=$GET(LEXCHR)
+6 ; Quit if
+7 ; Timed out or user enters "^^"
+8 IF $DATA(DTOUT)!($DATA(DIROUT))
SET LEXIT=1
KILL X
QUIT
+9 ; Up one level (LEXUP) if user enters "^"
+10 ; Quit if already at top level and user enters "^"
+11 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
IF $DATA(DIRUT)
IF $LENGTH($GET(LEXTXT))=1
Begin DoDot:1
+12 KILL X,LEXUP,LEXNT
SET LEXIT=1
SET (LEXCHR,LEXTXT,X)=""
End DoDot:1
QUIT
+13 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
IF $DATA(DIRUT)
IF $LENGTH($GET(LEXUP))
Begin DoDot:1
+14 KILL X
SET (X,LEXTXT)=LEXUP
IF '$LENGTH(X)
SET LEXIT=1
KILL X
SET LEXTXT=""
+15 if $LENGTH($GET(LEXNT))>1
SET LEXNT=$EXTRACT($GET(LEXNT),1,($LENGTH($GET(LEXNT))-1))
End DoDot:1
if 'LEXIT
GOTO LOOK
if LEXIT
QUIT
+16 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
IF $DATA(DIRUT)
IF '$LENGTH($GET(LEXUP))
SET LEXIT=1
KILL X
SET LEXTXT=""
QUIT
+17 IF $DATA(DUOUT)&('$DATA(DIROUT))
if '$DATA(LEXNT)
KILL X
QUIT
+18 ; No Selection Made
+19 IF '$DATA(DUOUT)
IF LEXCHR=""
SET LEXIT=1
+20 ; Character Found and Selected
+21 IF $LENGTH(LEXCHR)
IF LEXCHR'["^"
IF (LEXCHR?1N!(LEXCHR?1U))
Begin DoDot:1
+22 KILL Y
SET LEXTXT=LEXTXT_LEXCHR
if $LENGTH(LEXTXT)<7
QUIT
+23 NEW LEXSTA,LEXSIEN,LEXIEN,LEXCODE,LEXEFF,LEXTERM,LEXND,LEXICD
+24 SET LEXSTA=$$STATCHK^LEXSRC2(LEXTXT,$GET(LEXDT),,31)
+25 SET LEXSIEN=$PIECE(LEXSTA,"^",2)
+26 SET LEXEFF=$PIECE(LEXSTA,"^",3)
+27 SET LEXSTA=$PIECE(LEXSTA,"^",1)
+28 SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
+29 SET LEXCODE=$PIECE(LEXND,"^",2)
SET LEXIEN=+LEXND
+30 SET LEXTERM=$GET(^LEX(757.01,+LEXIEN,0))
+31 SET LEXICD=+$$ICDOP^ICDEX(LEXCODE,,31)
SET LEXIT=1
+32 SET Y=LEXIEN_"^"_LEXTERM
SET Y("ICD")=LEXICD_"^"_LEXCODE
+33 DO END(LEXCODE,LEXTERM)
End DoDot:1
if +($GET(Y))>0
QUIT
+34 ; Category Found and Selected
+35 IF $LENGTH(LEXCHR)
IF LEXCHR'["^"
IF (LEXCHR?1N!(LEXCHR?1U))
Begin DoDot:1
+36 DO NXT
IF $GET(Y)="^"
Begin DoDot:2
+37 if '$LENGTH(LEXTXT)
QUIT
SET LEXTXT=$EXTRACT(LEXTXT,1,($LENGTH(LEXTXT)-1))
if '$LENGTH(LEXTXT)
QUIT
+38 FOR
SET LEXTXT=$EXTRACT(LEXTXT,1,($LENGTH(LEXTXT)-1))
if $$TOT($EXTRACT(LEXTXT,1,($LENGTH(LEXTXT)-1)),LEXDT)>0
QUIT
End DoDot:2
End DoDot:1
if +($GET(LEXIT))'>0
GOTO LOOK
+39 QUIT
NXT ; Next
+1 if +($GET(LEXIT))>0
QUIT
NEW LEXNT,LEXND
+2 SET LEXNT=$GET(LEXTXT)
SET LEXND=$GET(LEXDT)
+3 NEW LEXTXT,LEXDT
SET LEXTXT=LEXNT
SET LEXDT=LEXND
+4 GOTO LOOK
+5 QUIT
TOT(X,Y) ; Total Possible
+1 NEW LEXPCDAT,LEXDT,LEXY
SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
SET LEXDT=$GET(Y)
+2 SET LEXY=$$PCSDIG^LEX10CS(X,LEXDT)
SET X=$$FND
+3 QUIT X
+4 ;
SO(X) ; Enter a Code/Code Fragment
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,DIRB,LEXTD,Y,LEX,LEXCOM,LEXERR,LEXSBR
+2 SET LEXTD=$GET(LEXVDT)
if LEXTD'?7N
SET LEXTD=$$DT^XLFDT
+3 SET LEXCOM="Enter a Procedure Code/Code Fragment"
+4 SET DIR(0)="FAO^1:30"
SET DIR("A")=" "_LEXCOM_": "
+5 SET (LEXSBR,DIRB)=$$RET("LEX10PL","SO",+($GET(DUZ)),LEXCOM)
+6 SET DIR("PRE")="S X=$$SOP^LEX10PL(X) W:X[""??"" "" ??"""
+7 SET (DIR("?"),DIR("??"))="^D SOH^LEX10PL"
DO ^DIR
+8 if $DATA(DTOUT)
QUIT "^"
if '$LENGTH(X)!('$LENGTH(Y))
QUIT "^"
if $DATA(DUOUT)
QUIT "^"
if $DATA(DIROUT)
QUIT "^"
if $GET(X)["^"
QUIT "^"
+9 SET (LEX,X)=$GET(Y)
if $LENGTH(LEX)&(LEX'["^")
DO SAV("LEX10PL","SO",+($GET(DUZ)),LEXCOM,LEX)
+10 QUIT X
SOH ; Select a Code Help
+1 if $LENGTH($GET(LEXERR))
WRITE !," ",LEXERR,!
+2 WRITE !," Enter either: "
+3 WRITE !," Example"
+4 WRITE !," ICD-10 Procedure code 04LE0CT"
+5 WRITE !," Partial ICD-10 Procedure code 00C6",!
+6 WRITE !," May not exceed 7 characters. Enter return or ""^"""
+7 WRITE !," to exit."
+8 KILL LEXERR
+9 QUIT
SOP(X) ; Code Pre-Processing
+1 NEW LEX,LEXO,LEXR,LEXB,LEXOK
KILL LEXERR
if '$LENGTH($GET(X))
QUIT ""
+2 SET (LEX,X)=$$UP^XLFSTR($GET(X))
if '$LENGTH(LEX)
QUIT "??"
+3 if LEX["?"
QUIT "??"
if LEX["^^"
SET (LEX,X)="^^"
SET DUOUT=1
SET DIROUT=1
+4 if LEX["^"&(LEX'["^^")
SET (LEX,X)="^"
SET DUOUT=1
if LEX["^"
QUIT X
if '$LENGTH(LEX)
QUIT ""
+5 IF LEX["."
SET LEXERR="Procedure codes do not have decimal places"
QUIT "??"
+6 IF $EXTRACT(LEX,1)="Z"
SET LEXERR="First character must not contain ""Z"""
QUIT "??"
+7 SET (LEXC,LEXO,LEXR)=$EXTRACT(LEX,1)
SET LEXO=$CHAR($ASCII(LEXO)-1)_"~ "
SET LEXN=($ORDER(^LEX(757.02,"APR",LEXO)))
+8 IF (LEXR'?1U&(LEXR'?1N))
SET LEXERR="First character must be uppercase or numeric"
QUIT "??"
+9 IF $EXTRACT(LEXN,1,$LENGTH(LEXC))'=LEXC
SET LEXERR="First character """_$EXTRACT(LEX,1)_""" is not valid"
QUIT "??"
+10 IF $LENGTH(LEX)'>1
SET X=LEX
QUIT X
+11 SET (LEXC,LEXO)=$EXTRACT(LEX,1,2)
SET LEXR=$EXTRACT(LEX,2)
SET LEXO=$EXTRACT(LEXO,1,($LENGTH(LEXO)-1))_$CHAR($ASCII($EXTRACT(LEXO,$LENGTH(LEXO)))-1)_"~"
+12 SET LEXN=($ORDER(^LEX(757.02,"APR",LEXO)))
+13 IF (LEXR'?1U&(LEXR'?1N))
SET LEXERR="Second character must be uppercase or numeric"
QUIT "??"
+14 IF $LENGTH(LEX)>1
IF $EXTRACT(LEXN,1,$LENGTH(LEXC))'=LEXC
SET LEXERR="Second character """_LEXR_""" is not valid"
QUIT "??"
+15 IF $LENGTH(LEX)'>2
SET X=LEX
QUIT X
+16 SET (LEXC,LEXO)=$EXTRACT(LEX,1,3)
SET LEXR=$EXTRACT(LEX,3)
SET LEXO=$EXTRACT(LEXO,1,($LENGTH(LEXO)-1))_$CHAR($ASCII($EXTRACT(LEXO,$LENGTH(LEXO)))-1)_"~"
+17 SET LEXN=($ORDER(^LEX(757.02,"APR",LEXO)))
+18 IF (LEXR'?1U&(LEXR'?1N))!(LEXR="Z")
SET LEXERR="Third character must not contain ""Z"""
QUIT "??"
+19 IF (LEXR'?1U&(LEXR'?1N))
SET LEXERR="Third character must be uppercase or numeric"
QUIT "??"
+20 IF $LENGTH(X)>1
IF $EXTRACT(LEXN,1,$LENGTH(LEXC))'=LEXC
SET LEXERR="Third character """_LEXR_""" is not valid"
QUIT "??"
+21 IF $LENGTH(LEX)'>3
SET X=LEX
QUIT X
+22 SET (LEXC,LEXO)=$EXTRACT(LEX,1,4)
SET LEXR=$EXTRACT(LEX,4)
SET LEXO=$EXTRACT(LEXO,1,($LENGTH(LEXO)-1))_$CHAR($ASCII($EXTRACT(LEXO,$LENGTH(LEXO)))-1)_"~"
+23 SET LEXN=($ORDER(^LEX(757.02,"APR",LEXO)))
+24 IF (LEXR'?1U&(LEXR'?1N))
SET LEXERR="Fourth character must be uppercase or numeric"
QUIT "??"
+25 IF $LENGTH(X)>1
IF $EXTRACT(LEXN,1,$LENGTH(LEXC))'=LEXC
SET LEXERR="Fourth character """_LEXR_""" is not valid"
QUIT "??"
+26 IF $LENGTH(LEX)'>4
SET X=LEX
QUIT X
+27 SET (LEXC,LEXO)=$EXTRACT(LEX,1,5)
SET LEXR=$EXTRACT(LEX,5)
SET LEXO=$EXTRACT(LEXO,1,($LENGTH(LEXO)-1))_$CHAR($ASCII($EXTRACT(LEXO,$LENGTH(LEXO)))-1)_"~"
+28 SET LEXN=($ORDER(^LEX(757.02,"APR",LEXO)))
+29 IF (LEXR'?1U&(LEXR'?1N))
SET LEXERR="Fifth character must be uppercase or numeric"
QUIT "??"
+30 IF $LENGTH(X)>1
IF $EXTRACT(LEXN,1,$LENGTH(LEXC))'=LEXC
SET LEXERR="Fifth character """_LEXR_""" is not valid"
QUIT "??"
+31 IF $LENGTH(LEX)'>5
SET X=LEX
QUIT X
+32 SET (LEXC,LEXO)=$EXTRACT(LEX,1,6)
SET LEXR=$EXTRACT(LEX,6)
SET LEXO=$EXTRACT(LEXO,1,($LENGTH(LEXO)-1))_$CHAR($ASCII($EXTRACT(LEXO,$LENGTH(LEXO)))-1)_"~"
+33 SET LEXN=($ORDER(^LEX(757.02,"APR",LEXO)))
+34 IF (LEXR'?1U&(LEXR'?1N))
SET LEXERR="Sixth character must be uppercase or numeric"
QUIT "??"
+35 IF $LENGTH(X)>1
IF $EXTRACT(LEXN,1,$LENGTH(LEXC))'=LEXC
SET LEXERR="Sixth character """_LEXR_""" is not valid"
QUIT "??"
+36 IF $LENGTH(LEX)'>6
SET X=LEX
QUIT X
+37 SET (LEXC,LEXO)=$EXTRACT(LEX,1,7)
SET LEXR=$EXTRACT(LEX,7)
SET LEXO=$EXTRACT(LEXO,1,($LENGTH(LEXO)-1))_$CHAR($ASCII($EXTRACT(LEXO,$LENGTH(LEXO)))-1)_"~"
+38 SET LEXN=($ORDER(^LEX(757.02,"APR",LEXO)))
+39 IF (LEXR'?1U&(LEXR'?1N))
SET LEXERR="Seventh character must be uppercase or numeric"
QUIT "??"
+40 IF $LENGTH(X)>1
IF $EXTRACT(LEXN,1,$LENGTH(LEXC))'=LEXC
SET LEXERR="Seventh character """_LEXR_""" is not valid"
QUIT "??"
+41 SET X=LEX
+42 QUIT X
+43 ;
+44 ; Miscellaneous
SAV(X,Y,LEXN,LEXC,LEXV) ; Save Defaults
+1 NEW LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXVAL,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY
SET LEXRTN=$GET(X)
if +($$ROK(LEXRTN))'>0
QUIT
SET LEXTAG=$GET(Y)
if +($$TAG((LEXTAG_"^"_LEXRTN)))'>0
QUIT
+2 SET LEXUSR=+($GET(LEXN))
SET LEXVAL=$GET(LEXV)
if LEXUSR'>0
QUIT
if '$LENGTH(LEXVAL)
QUIT
SET LEXCOM=$GET(LEXC)
if '$LENGTH(LEXCOM)
QUIT
SET LEXKEY=$EXTRACT(LEXCOM,1,13)
FOR
if $LENGTH(LEXKEY)>12
QUIT
SET LEXKEY=LEXKEY_" "
+3 SET LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01)
if '$LENGTH(LEXNM)
QUIT
SET LEXTD=$$DT^XLFDT
SET LEXFD=$$FMADD^XLFDT(LEXTD,30)
SET LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
+4 SET ^XTMP(LEXID,0)=LEXFD_"^"_LEXTD_"^"_LEXCOM
SET ^XTMP(LEXID,LEXTAG)=LEXVAL
+5 QUIT
RET(X,Y,LEXN,LEXC) ; Retrieve Defaults
+1 NEW LEXRTN,LEXTAG,LEXUSR,LEXCOM,LEXNM,LEXID,LEXTD,LEXFD,LEXKEY
SET LEXRTN=$GET(X)
if +($$ROK(LEXRTN))'>0
QUIT ""
+2 SET LEXTAG=$GET(Y)
if +($$TAG((LEXTAG_"^"_LEXRTN)))'>0
QUIT ""
SET LEXUSR=+($GET(LEXN))
if LEXUSR'>0
QUIT ""
+3 SET LEXCOM=$GET(LEXC)
if '$LENGTH(LEXCOM)
QUIT ""
SET LEXKEY=$EXTRACT(LEXCOM,1,13)
FOR
if $LENGTH(LEXKEY)>12
QUIT
SET LEXKEY=LEXKEY_" "
+4 SET LEXNM=$$GET1^DIQ(200,(LEXUSR_","),.01)
if '$LENGTH(LEXNM)
QUIT ""
SET LEXTD=$$DT^XLFDT
SET LEXFD=$$FMADD^XLFDT(LEXTD,30)
SET LEXID=LEXRTN_" "_LEXUSR_" "_LEXKEY
+5 SET X=$GET(^XTMP(LEXID,LEXTAG))
+6 QUIT X
ROK(X) ; Routine OK
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
if $LENGTH(X)>8
QUIT 0
XECUTE ^%ZOSF("TEST")
if $TEST
QUIT 1
QUIT 0
TAG(X) ; Sub-Routine OK
+1 NEW LEXT,LEXE,LEXL
SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
if X'["^"
QUIT 0
+2 if '$LENGTH($PIECE(X,"^",1))
QUIT 0
if $LENGTH($PIECE(X,"^",1))>8
QUIT 0
if $EXTRACT($PIECE(X,"^",1),1)'?1U
QUIT 0
+3 if '$LENGTH($PIECE(X,"^",2))
QUIT 0
if $LENGTH($PIECE(X,"^",2))>8
QUIT 0
if $EXTRACT($PIECE(X,"^",2),1)'?1U
QUIT 0
+4 SET LEXL=0
SET LEXT=X
SET (LEXE,X)="S LEXL=$L($T("_X_"))"
DO ^DIM
if $DATA(X)
XECUTE LEXE
+5 SET X=$SELECT(LEXL>0:1,1:0)
+6 QUIT X
END(X,Y) ; End Search, display results
+1 NEW LEXCODE,LEXTERM,LEXC,LEXI,LEXS
SET LEXCODE=$GET(X)
SET LEXTERM(1)=$GET(Y)
if $LENGTH(LEXCODE)'=7
QUIT
if '$LENGTH(LEXTERM(1))
QUIT
+2 DO PR^LEXU(.LEXTERM,69)
DO GCUR($GET(LEXCODE),.LEXC)
+3 SET LEXS=""
SET $PIECE(LEXS,"-",$LENGTH(LEXC))="-"
SET LEXC=$JUSTIFY(" ",1)_LEXC
SET LEXS=$JUSTIFY(" ",1)_LEXS
+4 if $LENGTH($GET(IOF))
WRITE @IOF
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXTERM(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+5 WRITE !,?2,$GET(LEXTERM(LEXI))
End DoDot:1
+6 WRITE !
DO ATTR
WRITE !,$GET(BOLD),$GET(LEXC),$GET(NORM),!," ",$GET(LEXS)
DO KATTR
+7 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXC(LEXI))
if +LEXI'>0
QUIT
WRITE !," ",$GET(LEXC(LEXI))
+8 WRITE !!
+9 QUIT
CUR(X) ; Current Array
+1 NEW LEXC,LEXS,LEXI
KILL LEXC
DO GCUR($GET(X),.LEXC)
if '$DATA(LEXC)
QUIT
SET LEXC=$TRANSLATE(LEXC," ","")
if '$LENGTH($GET(LEXC))
QUIT
if $ORDER(LEXC(0))'>0
QUIT
+2 NEW LEXS,LEXI
SET LEXS=""
SET $PIECE(LEXS,"-",$LENGTH(LEXC))="-"
SET LEXC=$JUSTIFY(" ",1)_LEXC
SET LEXS=$JUSTIFY(" ",1)_LEXS
+3 if $LENGTH($GET(IOF))
WRITE @IOF
DO ATTR
WRITE !,$GET(BOLD),$GET(LEXC),$GET(NORM),!,$GET(LEXS)
DO KATTR
+4 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXC(LEXI))
if +LEXI'>0
QUIT
WRITE !,$GET(LEXC(LEXI))
+5 QUIT
GCUR(X,LEXA) ; Get Current Array
+1 KILL LEXA
NEW LEXIN,LEXPSN,LEXOFF,LEXOK
DO ATTR
+2 SET LEXIN=$TRANSLATE($GET(X)," ","")
SET LEXOFF=$LENGTH(LEXIN)+2
if '$LENGTH(LEXIN)
QUIT
if '$DATA(^LEX(757.033,"AFRAG",31,(LEXIN_" ")))
QUIT
+3 SET LEXOK=1
SET LEXA=$JUSTIFY(" ",1)_LEXIN
FOR LEXPSN=1:1:$LENGTH(LEXIN)
Begin DoDot:1
+4 NEW LEXTXT,LEXSEC,LEXCHR,LEXNAM
SET LEXSEC=$EXTRACT(LEXIN,1,LEXPSN)
SET LEXCHR=$EXTRACT(LEXIN,LEXPSN)
SET LEXNAM=$$NAM(LEXSEC)
+5 IF '$LENGTH(LEXSEC)!('$LENGTH(LEXCHR))!('$LENGTH(LEXNAM))
SET LEXOK=0
QUIT
+6 SET LEXTXT=$JUSTIFY(" ",LEXPSN)_$GET(BOLD)_LEXCHR_$GET(NORM)
+7 SET LEXTXT=LEXTXT_$JUSTIFY(" ",(LEXOFF-LEXPSN))_LEXNAM
+8 SET LEXA(LEXPSN)=LEXTXT
End DoDot:1
+9 DO KATTR
+10 if 'LEXOK
KILL LEXA
+11 QUIT
NAM(X) ; Descriptive Dane
+1 NEW LEXIN,LEXDT,LEXEFF,LEXIEN
SET LEXIN=$GET(X)
if '$LENGTH(LEXIN)
QUIT ""
if '$DATA(^LEX(757.033,"AFRAG",31,(LEXIN_" ")))
QUIT ""
+2 SET LEXDT=$GET(LEXVDT)
if LEXDT'?7N
SET LEXDT=$$IMP^ICDEX(31)
+3 SET LEXEFF=$ORDER(^LEX(757.033,"AFRAG",31,(LEXIN_" "),(LEXDT+.001)),-1)
if LEXEFF'?7N
QUIT ""
+4 SET LEXIEN=$ORDER(^LEX(757.033,"AFRAG",31,(LEXIN_" "),LEXEFF," "),-1)
if +LEXIEN'>0
QUIT ""
+5 SET X=$$SN(LEXIEN)
+6 QUIT X
SN(X,EFF) ; Short Name
+1 NEW IEN,CDT,IMP,EFF,HIS
SET IEN=+($GET(X))
SET CDT=$GET(LEXVDT)
if $GET(EFF)?7N
SET CDT=$GET(EFF)
+2 SET IMP=$$IMP^ICDEX(31)
if CDT'?7N
SET CDT=$$DT^XLFDT
if CDT'>IMP&(IMP?7N)
SET CDT=IMP
+3 SET EFF=$ORDER(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
+4 SET HIS=$ORDER(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
+5 SET X=$GET(^LEX(757.033,+IEN,2,+HIS,1))
+6 QUIT X
FND(X) ; Found
+1 NEW LEXI
SET X=0
SET LEXI=""
FOR
SET LEXI=$ORDER(LEXPCDAT("NEXLEV",LEXI))
if '$LENGTH(LEXI)
QUIT
SET X=X+1
+2 QUIT X
GETO(X) ; Get One
+1 SET X=$ORDER(LEXPCDAT("NEXLEV",""))
+2 QUIT X
ATTR ; Screen Attributes
+1 NEW X,IOINHI,IOINORM
SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
SET BOLD=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+2 QUIT
KATTR ; Kill Screen Attributes
+1 DO KILL^%ZISS
KILL BOLD,NORM
+2 QUIT
ENV(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
