LEX10DL ;ISL/KER - ICD-10 Diagnosis Lookup ;12/19/2014
;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
;
; Global Variables
; ^%ZOSF("TEST") ICR 10096
; ^LEX(757.033 N/A
; ^XTMP( SACC 2.3.2.5.2
;
; External References
; HOME^%ZIS ICR 10086
; ^DIM ICR 10016
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$ICDDX^ICDEX ICR 5747
; $$IMP^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMDIFF^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10103
;
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 to the ICD DIAGNOSIS File #80
; 2 ICD Code
;
N LEXENV S LEXENV=$$ENV Q:+LEXENV'>0
N DTOUT,DUOUT,DIRUT,DIROUT,LEXDT,LEXIM,LEXMAX,LEXFRQ,LEXCONT,X
S LEXDT=$G(LEXVDT) S:LEXDT'?7N LEXDT=$$DT^XLFDT S LEXMAX=$$MAX^LEXU(30)
S LEXIM=$$IMP^ICDEX(30) S:LEXDT'>LEXIM LEXDT=LEXIM S LEXCONT=1
X ; Get user input
K DIROUT,DUOUT,DTOUT,DIRUT
S X=$$SO Q:X["^" S LEXFRQ=$$FREQ^LEXU(X)
I LEXFRQ>LEXMAX D Q:$D(DIRUT) Q:$D(LEXCONT)["^" G:LEXCONT'>0 X
. N LEXX S LEXX=X S LEXCONT=$$CONT^LEX10DLS(LEXX,LEXFRQ) W !
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,DUOUT,DTOUT,DIRUT
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 LEXBEG=$$NOW^XLFDT
S LEXY=$$DIAGSRCH^LEX10CS(LEXTXT,.LEXY,LEXVDT,30)
S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
S LEXSEC=$$FMDIFF^XLFDT(LEXEND,LEXBEG,2)
S:$L(LEXELP,":")=3 LEXELP=$TR(LEXELP," ","0")
S:$L(LEXELP,":")'=3!(LEXSEC'>0) LEXELP="00:00:00"
I $D(LEXTEST) D
. W ! W !," Search for: ",LEXTXT
. W !," Begin Search: ",$$FMTE^XLFDT(LEXBEG,"5Z")
. W !," Finish Search: ",$$FMTE^XLFDT(LEXBEG,"5Z")
. W !," Elapsed Time: ",LEXELP W !
S:$O(LEXY(" "),-1)>0 LEXY=+LEXY
I +LEXY'>0 W !," No data found",! K X Q
S LEXX=$$SEL^LEX10DLS(.LEXY,8)
I $D(DUOUT)&('$D(DIROUT)) K:'$D(LEXNT) X Q
I $D(DTOUT)&('$D(DIROUT)) S LEXIT=1 K X Q
I $D(DIROUT) S LEXIT=1 K X Q
; 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),$L($G(LEXUP)) K X Q
; No Selection Made
I '$D(DUOUT),LEXX=-1 S LEXIT=1
; Code Found and Selected
I $P(LEXX,";")'="99:CAT" D Q
. N LEXIEN,LEXCODE,LEXTERM,LEXICD
. S LEXIEN=$P($P(LEXX,"^"),";",1),LEXCODE=$P($P(LEXX,"^"),";",2)
. S LEXTERM=$P(LEXX,"^",2) S:$L(LEXTERM)&($L(LEXCODE)) LEXTERM=LEXTERM_" (ICD-10-CM "_LEXCODE_")"
. S LEXICD=+$$ICDDX^ICDEX(LEXCODE,,30),LEXIT=1
. S Y=LEXIEN_"^"_LEXTERM,Y("ICD")=LEXICD_"^"_LEXCODE
; Category Found and Selected
D NXT G:+($G(LEXIT))'>0 LOOK
Q
NXT ; Next
Q:+($G(LEXIT))>0 N LEXNT,LEXND,LEXXX
S LEXNT=$G(LEXTXT),LEXND=$G(LEXVDT),LEXXX=$G(LEXX)
N LEXTXT,LEXVDT S LEXTXT=$P($P(LEXXX,"^"),";",2),LEXVDT=LEXND
G LOOK
Q
;
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 Diagnosis, a Code or a Code Fragment"
S DIR(0)="FAO^1:30",DIR("A")=" "_LEXCOM_": "
S (LEXSBR,DIRB)=$$RET("LEX10DL","SO",+($G(DUZ)),LEXCOM)
S DIR("PRE")="S X=$$SOP^LEX10DL(X) W:X[""??"" "" ??"""
S (DIR("?"),DIR("??"))="^D SOH^LEX10DL" D ^DIR
Q:$D(DTOUT) "^" Q:'$L(X)!('$L(Y)) "^"
S:$D(DUOUT) X="^" S:$D(DIROUT) X="^^" Q:$G(X)["^" "^"
S (LEX,X)=$G(Y) D:$L(LEX)&(LEX'["^") SAV("LEX10DL","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 Diagnosis code S62.131K"
W !," Partial ICD-10 Diagnosis code S62.131"
W !," ICD-10 Diagnosis sub-category S62.131"
W !," ICD-10 Diagnosis category S62."
W !," Partial ICD-10 Diagnosis category S6"
W !," Diagnostic Text Diabetes Mellitus",!
W !," Must have at least 2 characters. If a code is entered"
W !," it may not exceed 7 characters. Enter return or ""^"" "
W !," to exit, ""Space-Bar-Return"" to select previous"
W !," search parameter.",!
K LEXERR
Q
SOP(X) ; Code Pre-Processing
N LEX,LEXO,LEXR,LEXB,LEXOK,LEXSTB,LEXSO S LEXSO=0
S (LEX,X)=$$UP^XLFSTR($G(X)),LEXSTB=$E(LEX,1,3),LEXB=$G(DIR("B"))
I ($L(LEX)&($E(LEX,1)=" "))&($L($G(LEXSBR))) D Q X
. S (LEX,X)=$G(LEXSBR) W " ",X
Q:LEX["?" "??" S:LEX["^^" (LEX,X)="^^",DUOUT=1,DIROUT=1
S:LEX["^"&(LEX'["^^") (LEX,X)="^",DUOUT=1
Q:LEX["^" X S:'$L(LEX)&($L(LEXB)) (LEX,X)=$G(LEXB)
Q:'$L(LEX) "" S LEXR=LEX S:$L(LEXR) LEXR=" ("_LEXR_")"
S LEXSO=0 I $L(LEXSTB) D
. S:$O(^LEX(757.02,"ADX",(LEXSTB_" ")))[LEXSTB LEXSO=1
I 'LEXSO Q X
S:$L(LEX)'>1 LEXERR="Input must be at least 2 characters"_LEXR
S:$L(LEX)>8 LEXERR="Input can not exceed 8 characters"_LEXR
Q:$L(LEX)'>1!($L(LEX)>8) "??"
S:$L(LEX)>3&($E(LEX,4)'=".") LEXERR="Fourth character position must be a decimal"_LEXR
Q:$L(LEX)>3&($E(LEX,4)'=".") "??" S LEXOK=0
S LEXO=$E(LEX,1,($L(LEX)-1))_$C($A($E(LEX,$L(LEX)))-1)_"~"
S:$L(LEX)=3&(LEX'[".") (LEX,X)=LEX_"."
S:$D(^LEX(757.02,"ADX",(LEX_" "))) LEXOK=1
S:$O(^LEX(757.02,"ADX",(LEXO_" ")))[LEX LEXOK=1
S:$D(^LEX(757.033,"AFRAG",30,(LEX_" "))) LEXOK=1
S:$O(^LEX(757.033,"AFRAG",30,(LEXO_" ")))[LEX LEXOK=1
S:'LEXOK LEXERR="Input is not a code or category"_LEXR
S:'LEXOK (LEX,X)="??"
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
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[HLEX10DL 8016 printed Oct 16, 2024@18:04:13 Page 2
LEX10DL ;ISL/KER - ICD-10 Diagnosis Lookup ;12/19/2014
+1 ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
+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 ; ^DIM ICR 10016
+11 ; $$GET1^DIQ ICR 2056
+12 ; ^DIR ICR 10026
+13 ; $$ICDDX^ICDEX ICR 5747
+14 ; $$IMP^ICDEX ICR 5747
+15 ; $$DT^XLFDT ICR 10103
+16 ; $$FMADD^XLFDT ICR 10103
+17 ; $$FMDIFF^XLFDT ICR 10103
+18 ; $$FMTE^XLFDT ICR 10103
+19 ; $$NOW^XLFDT ICR 10103
+20 ; $$UP^XLFSTR ICR 10103
+21 ;
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 to the ICD DIAGNOSIS File #80
+14 ; 2 ICD Code
+15 ;
+16 NEW LEXENV
SET LEXENV=$$ENV
if +LEXENV'>0
QUIT
+17 NEW DTOUT,DUOUT,DIRUT,DIROUT,LEXDT,LEXIM,LEXMAX,LEXFRQ,LEXCONT,X
+18 SET LEXDT=$GET(LEXVDT)
if LEXDT'?7N
SET LEXDT=$$DT^XLFDT
SET LEXMAX=$$MAX^LEXU(30)
+19 SET LEXIM=$$IMP^ICDEX(30)
if LEXDT'>LEXIM
SET LEXDT=LEXIM
SET LEXCONT=1
X ; Get user input
+1 KILL DIROUT,DUOUT,DTOUT,DIRUT
+2 SET X=$$SO
if X["^"
QUIT
SET LEXFRQ=$$FREQ^LEXU(X)
+3 IF LEXFRQ>LEXMAX
Begin DoDot:1
+4 NEW LEXX
SET LEXX=X
SET LEXCONT=$$CONT^LEX10DLS(LEXX,LEXFRQ)
WRITE !
End DoDot:1
if $DATA(DIRUT)
QUIT
if $DATA(LEXCONT)["^"
QUIT
if LEXCONT'>0
GOTO X
+5 KILL Y,LEXY
if $LENGTH(X)&(X'["^")
DO BEG
IF $DATA(DUOUT)&'$DATA(DIROUT)
WRITE !
GOTO X
+6 NEW LEXTEST
+7 QUIT
BEG ; Begin Recursive Loop
+1 KILL DIROUT,DUOUT,DTOUT,DIRUT
+2 NEW LEXIT,LEXVDT,LEXTXT,LEXUP,LEXY,LEXX
+3 NEW LEXBEG,LEXEND,LEXELP,LEXSEC
+4 KILL Y
SET Y=-1
SET U="^"
SET LEXTXT=$GET(X)
if '$LENGTH(LEXTXT)
QUIT
+5 SET LEXVDT=$GET(LEXDT)
SET LEXIT=0
LOOK ; Lookup
+1 if +($GET(LEXIT))>0
QUIT
KILL LEXY
SET LEXBEG=$$NOW^XLFDT
+2 SET LEXY=$$DIAGSRCH^LEX10CS(LEXTXT,.LEXY,LEXVDT,30)
+3 SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+4 SET LEXSEC=$$FMDIFF^XLFDT(LEXEND,LEXBEG,2)
+5 if $LENGTH(LEXELP,"
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+6 if $LENGTH(LEXELP,"
SET LEXELP="00:00:00"
+7 IF $DATA(LEXTEST)
Begin DoDot:1
+8 WRITE !
WRITE !," Search for: ",LEXTXT
+9 WRITE !," Begin Search: ",$$FMTE^XLFDT(LEXBEG,"5Z")
+10 WRITE !," Finish Search: ",$$FMTE^XLFDT(LEXBEG,"5Z")
+11 WRITE !," Elapsed Time: ",LEXELP
WRITE !
End DoDot:1
+12 if $ORDER(LEXY(" "),-1)>0
SET LEXY=+LEXY
+13 IF +LEXY'>0
WRITE !," No data found",!
KILL X
QUIT
+14 SET LEXX=$$SEL^LEX10DLS(.LEXY,8)
+15 IF $DATA(DUOUT)&('$DATA(DIROUT))
if '$DATA(LEXNT)
KILL X
QUIT
+16 IF $DATA(DTOUT)&('$DATA(DIROUT))
SET LEXIT=1
KILL X
QUIT
+17 IF $DATA(DIROUT)
SET LEXIT=1
KILL X
QUIT
+18 ; Quit if
+19 ; Timed out or user enters "^^"
+20 IF $DATA(DTOUT)!($DATA(DIROUT))
SET LEXIT=1
KILL X
QUIT
+21 ; Up one level (LEXUP) if user enters "^"
+22 ; Quit if already at top level and user enters "^"
+23 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
IF $LENGTH($GET(LEXUP))
KILL X
QUIT
+24 ; No Selection Made
+25 IF '$DATA(DUOUT)
IF LEXX=-1
SET LEXIT=1
+26 ; Code Found and Selected
+27 IF $PIECE(LEXX,";")'="99:CAT"
Begin DoDot:1
+28 NEW LEXIEN,LEXCODE,LEXTERM,LEXICD
+29 SET LEXIEN=$PIECE($PIECE(LEXX,"^"),";",1)
SET LEXCODE=$PIECE($PIECE(LEXX,"^"),";",2)
+30 SET LEXTERM=$PIECE(LEXX,"^",2)
if $LENGTH(LEXTERM)&($LENGTH(LEXCODE))
SET LEXTERM=LEXTERM_" (ICD-10-CM "_LEXCODE_")"
+31 SET LEXICD=+$$ICDDX^ICDEX(LEXCODE,,30)
SET LEXIT=1
+32 SET Y=LEXIEN_"^"_LEXTERM
SET Y("ICD")=LEXICD_"^"_LEXCODE
End DoDot:1
QUIT
+33 ; Category Found and Selected
+34 DO NXT
if +($GET(LEXIT))'>0
GOTO LOOK
+35 QUIT
NXT ; Next
+1 if +($GET(LEXIT))>0
QUIT
NEW LEXNT,LEXND,LEXXX
+2 SET LEXNT=$GET(LEXTXT)
SET LEXND=$GET(LEXVDT)
SET LEXXX=$GET(LEXX)
+3 NEW LEXTXT,LEXVDT
SET LEXTXT=$PIECE($PIECE(LEXXX,"^"),";",2)
SET LEXVDT=LEXND
+4 GOTO LOOK
+5 QUIT
+6 ;
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 Diagnosis, a Code or a Code Fragment"
+4 SET DIR(0)="FAO^1:30"
SET DIR("A")=" "_LEXCOM_": "
+5 SET (LEXSBR,DIRB)=$$RET("LEX10DL","SO",+($GET(DUZ)),LEXCOM)
+6 SET DIR("PRE")="S X=$$SOP^LEX10DL(X) W:X[""??"" "" ??"""
+7 SET (DIR("?"),DIR("??"))="^D SOH^LEX10DL"
DO ^DIR
+8 if $DATA(DTOUT)
QUIT "^"
if '$LENGTH(X)!('$LENGTH(Y))
QUIT "^"
+9 if $DATA(DUOUT)
SET X="^"
if $DATA(DIROUT)
SET X="^^"
if $GET(X)["^"
QUIT "^"
+10 SET (LEX,X)=$GET(Y)
if $LENGTH(LEX)&(LEX'["^")
DO SAV("LEX10DL","SO",+($GET(DUZ)),LEXCOM,LEX)
+11 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 Diagnosis code S62.131K"
+5 WRITE !," Partial ICD-10 Diagnosis code S62.131"
+6 WRITE !," ICD-10 Diagnosis sub-category S62.131"
+7 WRITE !," ICD-10 Diagnosis category S62."
+8 WRITE !," Partial ICD-10 Diagnosis category S6"
+9 WRITE !," Diagnostic Text Diabetes Mellitus",!
+10 WRITE !," Must have at least 2 characters. If a code is entered"
+11 WRITE !," it may not exceed 7 characters. Enter return or ""^"" "
+12 WRITE !," to exit, ""Space-Bar-Return"" to select previous"
+13 WRITE !," search parameter.",!
+14 KILL LEXERR
+15 QUIT
SOP(X) ; Code Pre-Processing
+1 NEW LEX,LEXO,LEXR,LEXB,LEXOK,LEXSTB,LEXSO
SET LEXSO=0
+2 SET (LEX,X)=$$UP^XLFSTR($GET(X))
SET LEXSTB=$EXTRACT(LEX,1,3)
SET LEXB=$GET(DIR("B"))
+3 IF ($LENGTH(LEX)&($EXTRACT(LEX,1)=" "))&($LENGTH($GET(LEXSBR)))
Begin DoDot:1
+4 SET (LEX,X)=$GET(LEXSBR)
WRITE " ",X
End DoDot:1
QUIT X
+5 if LEX["?"
QUIT "??"
if LEX["^^"
SET (LEX,X)="^^"
SET DUOUT=1
SET DIROUT=1
+6 if LEX["^"&(LEX'["^^")
SET (LEX,X)="^"
SET DUOUT=1
+7 if LEX["^"
QUIT X
if '$LENGTH(LEX)&($LENGTH(LEXB))
SET (LEX,X)=$GET(LEXB)
+8 if '$LENGTH(LEX)
QUIT ""
SET LEXR=LEX
if $LENGTH(LEXR)
SET LEXR=" ("_LEXR_")"
+9 SET LEXSO=0
IF $LENGTH(LEXSTB)
Begin DoDot:1
+10 if $ORDER(^LEX(757.02,"ADX",(LEXSTB_" ")))[LEXSTB
SET LEXSO=1
End DoDot:1
+11 IF 'LEXSO
QUIT X
+12 if $LENGTH(LEX)'>1
SET LEXERR="Input must be at least 2 characters"_LEXR
+13 if $LENGTH(LEX)>8
SET LEXERR="Input can not exceed 8 characters"_LEXR
+14 if $LENGTH(LEX)'>1!($LENGTH(LEX)>8)
QUIT "??"
+15 if $LENGTH(LEX)>3&($EXTRACT(LEX,4)'=".")
SET LEXERR="Fourth character position must be a decimal"_LEXR
+16 if $LENGTH(LEX)>3&($EXTRACT(LEX,4)'=".")
QUIT "??"
SET LEXOK=0
+17 SET LEXO=$EXTRACT(LEX,1,($LENGTH(LEX)-1))_$CHAR($ASCII($EXTRACT(LEX,$LENGTH(LEX)))-1)_"~"
+18 if $LENGTH(LEX)=3&(LEX'[".")
SET (LEX,X)=LEX_"."
+19 if $DATA(^LEX(757.02,"ADX",(LEX_" ")))
SET LEXOK=1
+20 if $ORDER(^LEX(757.02,"ADX",(LEXO_" ")))[LEX
SET LEXOK=1
+21 if $DATA(^LEX(757.033,"AFRAG",30,(LEX_" ")))
SET LEXOK=1
+22 if $ORDER(^LEX(757.033,"AFRAG",30,(LEXO_" ")))[LEX
SET LEXOK=1
+23 if 'LEXOK
SET LEXERR="Input is not a code or category"_LEXR
+24 if 'LEXOK
SET (LEX,X)="??"
+25 QUIT X
+26 ;
+27 ; 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
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
