ICDEXLK ;SLC/KER - ICD Extractor - Lookup ;04/21/2014
;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
;
; Global Variables
; ^ICDS( N/A
; ^TMP("ICD0") SACC 2.3.2.5.1
; ^TMP("ICD9") SACC 2.3.2.5.1
; ^TMP("ICDEXLK") SACC 2.3.2.5.1
;
; External References
; ^DIM ICR 10016
; $$DT^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed Elsewhere
; DIC,ICDFMT,ICDSYS,ICDVDT
;
LK ; Lookup
;
; This is the Special Lookup program for files 80 and 80.1.
; Only the ^DIC call honors the special lookup routines.
; Those calls that allow the user to specify the indexes
; (IX^DIC and MIX^DIC1), and the Data Base Server calls
; (FIND^DIC, $$FIND1^DIC, and UPDATE^DIE) all ignore the
; Special Lookup Program. Also, if DIC(0) contains an
; "I" then the Special Lookup program will be ignored.
;
; Local Variables Newed or Killed by Calling Application
;
; Versioning Date (Fileman format) (OLD, CSV)
;
; ICDVDT or
; ^TMP("ICDEXLK",$J,"ICDVDT"
;
; If supplied only active codes on that date
; will be included in the selection list.
;
; If not supplied, the date will default to
; TODAY and all codes may be selected, active
; and inactive.
;
; In both cases the display will be altered
; based on the date.
;
; Coding System (from file 80.4) (new)
;
; ICDSYS or
; ^TMP("ICDEXLK",$J,"ICDSYS"
;
; 1 ICD ICD-9-CM
; 2 ICP ICD-9 Proc
; 30 10D ICD-10-CM
; 31 10P ICD-10-PCS
;
; Display Format (numeric, 1-4) (new)
;
; ICDFMT or
; ^TMP("ICDEXLK",$J,"ICDFMT"
;
; 1 = Fileman format, code and short text (default)
;
; 250.00 DMII CMP NT ST UNCNTR
;
; 2 = Fileman format, code and description
;
; 250.00 DIABETES MELLITUS NO MENTION OF
; COMPLICATION, TYPE II OR UNSPECIFIED
; TYPE, NOT STATED AS UNCONTROLLED
;
; 3 = Lexicon format, short text followed by code
;
; DMII CMP NT ST UNCNTR (250.00)
;
; 4 = Lexicon format, description followed by code
;
; DIABETES MELLITUS NO MENTION OF COMPLICATION,
; TYPE II OR UNSPECIFIED TYPE, NOT STATED AS
; UNCONTROLLED (250.00)
;
; Special Lookup
; ^DD(80,0,"DIC")="ICDEXLK"
; ^DD(80.1,0,"DIC")="ICDEXLK"
;
; FileMan Variables
;
; X If DIC(0) does not contain an A, then the variable
; X must be defined equal to the value you want to
; find in the requested Index(es).
;
; DIC Global root or File Number
;
; ^ICD9( or 80
; ^ICD0( or 80.1
;
; DIC(0) (Optional) A string of characters which alter how
; DIC responds. Default value for ICD files "AEM"
;
; Applicable to a versioned lookup
; A Ask the entry; if erroneous, ask again
; E Echo information
; F Forget the lookup value
; I Ignore the special lookup program
; M Multiple-index lookup allowed
; O Only find one entry if it matches exactly
; S Suppresses display of .01
; X EXact match required
; Z Zero node in Y(0), external form in Y(0,0)
;
; Not Applicable to a versioned lookup
; C Versioned cross-references not turned off
; B There is no B index to use
; K Primary Key not established
; L Learning a new entry LAYGO not allowed
; N Uppercase, IEN lookup allowed (not forced)
; n ICD has no pure numeric entries
; Q Input is pre-processed, ?? not necessary
; U All values are external
; T All versioned Indexes are used
; V Verification is not optional
;
; DIC("A") (Optional) A prompt that is displayed prior to the
; reading of the X input. If DIC("A") is not defined,
; a prompt will be supplied by the special lookup
; routines.
;
; DIC("B") (Optional) The default answer which is presented to
; the user when the lookup prompt is issued. If a
; terminal user simply presses the Enter/Return key,
; the DIC("B") default value will be used, and
; returned in X. DIC("B") will only be used if it is
; non-null.
;
; DIC("S") (Optional) DIC("S") is a string of M code that DIC
; executes to screen an entry from selection.
; DIC("S") must contain an IF statement to set the
; value of $T. Those entries that the IF sets as
; $T=0 will not be displayed or selectable. If the
; DIC("S") code is executed, the local variable Y is
; the internal number of the entry being screened
; and the M naked indicator is at the global level
; @(DIC_"Y,0)").
;
; DIC("W") (Optional) An M command string which is executed
; when DIC displays each of the entries that match
; the user's input. The condition of the variable
; Y and of the naked indicator is the same as for
; DIC("S"). If DIC("W") is defined, it overrides
; the display of any identifiers of the file. Thus,
; if DIC("W")="", the display of identifiers will
; be suppressed.
;
; DIC("?N",<file>)=n
; (Optional) The number "n" should be an integer set
; to the number of entries to be displayed on the
; screen at one time when using "?" help in a lookup.
;
; FileMan Variables not used:
;
; DIC("DR")
; DIC("PTRIX",<from>,<to>,<file>)
; DIC("T")
; DIC("V")
; DIC("?PARAM",<file>,"INDEX")
; DIC("?PARAM",<file>,"FROM",<subscript>)
; DIC("?PARAM",<file>,"PART",<subscript>)
;
; FileMan Variables KILLed:
;
; DLAYGO
; DINUM
;
; Output
;
; Y IEN ^ Code Fileman
;
; If DIC(0) contains "Z"
;
; Y(0) 0 Node Fileman
; Y(0,0) Code Fileman
; Y(0,1) $$ICDDX or $$ICDOP Non-Fileman
; Y(0,2) Long Description Non-Fileman
;
K ^TMP("ICD9",$J),^TMP("ICD0",$J) D DIE
N DIRUT,DIROUT,FILE,ROOT,SUB,SBI,FND,ICDDICA,ICDDICB,ICDDICN,ICDDICW,ICDDICS,ICDDICSS
N ICDDICST,ICDDIC0,ICDOLD0,ICDDIC00,ICDCDT,ICDCSY,ICDISF,ICDOUT,ICDVER,ICDX,ICDXP,KEY,INP,INP2,INP1,ERR
N ICDOFND,ICDOSEL,ICDOINP,ICDREDO,ICDOREV,ICDISCD,ICDOUPA
S (ICDOFND,ICDOSEL,ICDOREV,ICDOUPA)=0,ICDXP=$G(X)
K DLAYGO,DINUM S (ICDOINP,ICDX)=$S($E($G(X),1)'=" ":$$TM($G(X)),1:$G(X))
K X,Y,DTOUT,DUOUT S ICDCSY=0,ROOT=$G(DIC),FILE=$$FILE^ICDEX(ROOT)
I "^80^80.1^"'[("^"_FILE_"^") S ERR="Invalid File" G ERR
S ROOT=$$ROOT^ICDEX(FILE)
I "^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L(ROOT))_"^") S ERR="Invalid Global Root" G ERR
I $L(ICDXP) D
. N ICD0,ICD1,ICD2 S ICD0=$TR(ICDXP,"""",""),ICD1=$O(@(ROOT_"""BA"","""_ICD0_""",0)"))
. S ICD2=$O(@(ROOT_"""BA"","""_ICD0_""","" "")"),-1) I ICD1>0,ICD1=ICD2 S (X,ICDX)="`"_+ICD1
I $G(ICDX)[";" D
. N ICD1,ICD2 S ICD1=$P(ICDX,";",1),ICD2=("^"_$P(ICDX,";",2))
. Q:ICD2'=DIC Q:ICD1'?1N.N S:$D(@(ROOT_+ICD1_",0)")) (X,ICDX)="`"_+ICD1
; System
S ICDCSY=0
S:$L($G(ICDSYS)) ICDCSY=$G(ICDSYS)
S:'$L($G(ICDSYS))&($L($G(^TMP("ICDEXLK",$J,"ICDSYS")))) ICDCSY=$G(^TMP("ICDEXLK",$J,"ICDSYS"))
S ICDCSY=$$SYS^ICDEX($G(ICDCSY))
; Date
S:$L($G(ICDVDT)) ICDCDT=$G(ICDVDT)
S:'$L($G(ICDVDT))&($L($G(^TMP("ICDEXLK",$J,"ICDVDT")))) ICDCDT=$G(^TMP("ICDEXLK",$J,"ICDVDT"))
; Format
S ICDOUT=0 S:$L($G(ICDFMT)) ICDOUT=$G(ICDFMT)
I $D(DDS) S:$D(ICDFMT) ICDFMT=1 S ICDOUT=1
S:'$L($G(ICDFMT))&($L($G(^TMP("ICDEXLK",$J,"ICDFMT")))) ICDOUT=$G(^TMP("ICDEXLK",$J,"ICDFMT"))
S:+ICDOUT'>0 ICDOUT=1 S:+ICDOUT>4 ICDOUT=1
S:$L($G(ICDFMT))!($L($G(^TMP("ICDEXLK",$J,"ICDFMT")))) ICDISF=1
; Versioned Lookup
S ICDVER=$S($G(ICDCDT)?7N:1,1:0) S:$G(ICDCDT)'?7N ICDCDT=$$DT^XLFDT
; Enforce Business Rule for Date
I ICDVER'>0 S:$D(^ICDS(+ICDCSY,0)) ICDCDT=$$DTBR^ICDEX(ICDCDT,,+($G(ICDCSY)))
; Space Bar Return (passed)
I $D(ICDX),$G(ICDX)=" ",DIC(0)'["A" D SBR^ICDEXLK2 G:+($G(Y))>0 QUIT K Y
; TMP global
S SUB=$TR(ROOT,"^(","") K ^TMP(SUB,$J)
; Save DIC
S ICDDICA=$G(DIC("A")),ICDDICB=$G(DIC("B")),ICDDICW=$G(DIC("W"))
S ICDDICS="",ICDDICST=$$DICS($G(DIC("S"))) S:$L(ICDDICST) ICDDICS=ICDDICST
S ICDDICSS="" I $L($G(DICR(1,31))) D
. Q N X S X=$G(DICR(1,31)) D ^DIM S:$D(X) ICDDICSS=X
S ICDDICN=$G(DIC("?N",FILE)) S:+ICDDICN'>0 ICDDICN=5
S ICDDIC00=$G(DIC(0)),(ICDDIC0,DIC(0))=$$DIC0^ICDEXLK6($G(DIC(0)))
K:+($G(ICDISF))>0 DIC("W") K:$D(DDS) DIC("W")
I $L(ICDX)'>4,ICDX'["." D
. S:ICDX?3N&($D(@(ROOT_"""BA"","""_ICDX_". "")"))) ICDX=ICDX_"."
. S:$E(ICDX,1)="E"&($E(ICDX,2,4)?3N)&($D(@(ROOT_"""BA"","""_ICDX_". "")"))) ICDX=ICDX_"."
. S:$E(ICDX,1)?1U&($E(ICDX,2,3)?2N)&($D(@(ROOT_"""BA"","""_ICDX_". "")"))) ICDX=ICDX_"."
I ICDX="?",$G(DIC(0))'["A" D I $L($G(DIE)),$L($G(DIC)),$G(DIE)'=$G(DIC) S Y=-1 W:'$D(DDS) ! Q
. D INPH^ICDEXLK2(FILE) S ICDX="" S:$G(DIC(0))'["A" DIC(0)=DIC(0)_"A"
I ICDX="??",$G(DIC(0))'["A" D I $L($G(DIE)),$L($G(DIC)),$G(DIE)'=$G(DIC) S Y=-1 W:'$D(DDS) ! Q
. D INPH2^ICDEXLK2(FILE) S ICDX="" S:$G(DIC(0))'["A" DIC(0)=DIC(0)_"A"
LKR ; Lookup Recursive
; QUASAR
I '$D(DIC("S")),$G(DICR(2,1))="^ACK(509850.1," S DIROUT=1,X="^^",ICDX="",Y=-1 G QUIT
I $D(DICR),+($G(ICDOREV))>0,+($G(ICDOFND))>0,+($G(ICDOSEL))'>0 N ICDDICS S ICDDICS=""
S FND=0 S:'$L(DIC(0)) DIC(0)="AEM" S ICDREDO=""
S:$L($G(DIC(0))) DIC(0)=$TR(DIC(0),"CL","")
I +($G(ICDOREV))>0 D
. S (ICDOFND,ICDOSEL,ICDOREV)=0 K X S ICDX=""
I $G(DIC(0))["A" D I '$L(X),$G(DIC(0))'["T" S X="",ICDOREV=1 G ERR
. S X=$$INP^ICDEXLK2(FILE,$G(ICDVER),$G(ICDCDT))
I $D(DTOUT)!($D(DUOUT)) G ERR
I ($G(DIC(0))["A"),('$L(X)!(X="^")),$G(DIC(0))["T" S X="" K Y G LKR
I $G(DIC(0))'["A"&($L($G(ICDX))) S X=$G(ICDX)
I $G(X)["^" S DUOUT="" G ERR
I '$L($G(X)) G ERR
S X=$$TM(X),INP=X,INP1=$E(INP,1),INP2=$E(INP,2,245)
; Forced IEN
K Y I INP1="`",INP2?1N.N,+INP2>0 D G:$L(X)&(+($G(Y))<0) QUIT I +($G(FND))'>0 K X,Y G LKR
. D IEN^ICDEXLK5 I +FND'>0,$G(DIC(0))["Q" D
. . W:'$D(DICR(1))&('$D(DIROUT))&('$D(DUOUT))&('$D(DTOUT))&('$D(DDS))&(+($G(ICDOREV))'>0) " ??"
. . W:$D(DICR(1))&('$D(DDS)) !
I $D(Y) S:+Y<0 X=INP G QUIT
; Lookup X
I X'?1N.N G:$L($G(X))'>0!($E($G(X))="^")!($G(X)["^^")!($D(DTOUT))!($D(DUOUT)) ERR
N LOUD S LOUD="" S ICDX=X I +($G(FND))'>0 D
. S:$L(ICDX)&($L(ICDX)>1) FND=$$LK^ICDEXLK3($G(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
. S:$L(ICDX)&($L(ICDX)'>1) FND=$$CD^ICDEXLK3($G(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
. S:+($G(FND))>0 ICDOFND=+($G(FND)) S:$L($G(ICDX)) X=$G(ICDX)
I +FND'>0,$G(DIC(0))["Q" W:'$D(DICR(1))&('$D(DIROUT))&('$D(DUOUT))&('$D(DTOUT))&('$D(DDS))&(+($G(ICDOREV))'>0) " ??"
I +FND'>0,$L(INP),$E(INP,1)'=" ",'$D(DTOUT),'$D(DUOUT),$G(DIC(0))["A",'($G(DIC(0))["N"&(INP?1N.N)) K X,Y G LKR
S:+FND'>0 X=INP
; Check Numeric - DIC(0)["N" and DIC(0)'["E"
I +$G(ICDOSEL)'>0,$G(DIC(0))["N",INP?1N.N D G:+($G(Y))>0 QUIT
. Q:DIC(0)["E"&(+$G(ICDOSEL)'>0)&(+$G(ICDOFND)>0) K Y N XX
. I $D(@(ROOT_+INP_",0)")) S FND=1 D Q
. . N IEN S IEN=+INP S (FND,ICDOFND,ICDOSEL)=1
. . S X=$P($G(@(ROOT_+X_",0)")),"^",1)
. . D Y^ICDEXLK2($G(ROOT),IEN,$G(ICDCDT))
. I '$D(@(ROOT_+INP_",0)")) D Q
. . S X=$S($L($G(INP)):INP,1:$G(X))
. . S Y="-1^Numeric value not found"
. S XX=$$LD^ICDEX(FILE,+$G(INP),ICDCDT)
. I $E(XX,1,2)="-1" D Q
. . S Y="-1^Long description not found",X=$G(INP)
. W:$G(DIC(0))["E"&('$D(DDS)) " ",XX S X=$G(INP)
. D Y^ICDEXLK2($G(ROOT),$G(X),$G(ICDCDT))
. S:+Y>0&(+X'<0) X=XX S:+Y<0 X=INP
I +FND'>0,$G(DIC(0))["N",X?1N.N,+($G(Y))<0 G ERR
I +FND'>0,$L($G(ICDX)),$L($G(DIC("S"))),$L($G(DICR(1))),$L($G(DICR(1,1))) K DIC("S") K Y G LKR
I +FND'>0,$L($G(ICDX)),'$D(DIC("S")),$L($G(DICR(1))),$G(DICR(1))=$G(ICDX),$L($G(DICR(1,1))) D G QUIT
. S X=$S($L($G(INP)):INP,1:$G(X)),Y="-1^No matches found"
I +FND'>0,$G(DIC(0))'["T" D G QUIT
. W:$G(DIC(0))["E"&('$L($G(DICR(1))))&('$D(DDS)) !," No matches found"
. S X=$S($L($G(INP)):INP,1:$G(X)),Y="-1^No matches found"
I +FND'>0,$G(DIC(0))["T" K Y G LKR
S ICDOUPA=0 D ASK^ICDEXLK2
I $D(DUOUT),$D(DIROUT) D G QUIT
. S (DUOUT,DIRUT)=1,X="^^"
. S ICDX="",Y=-1
I +FND=1,$G(ICDOFND)=1,$G(ICDOSEL)=0,$G(ICDOREV)=1,'$D(DICR(1)) D G:$D(DIROUT)!($G(DIC(0))'["A") QUIT G:DIC(0)["A" LKR
. S (ICDX,INP1,INP2,ICDOINP,X)="",Y="-1^No selection made"
I +FND=1,$G(ICDOFND)=1,$G(ICDOSEL)=0,$G(ICDOREV)=1,$D(DICR(1)) D G:$D(DIROUT)!($G(DIC(0))'["A") QUIT N ICDDICS G:DIC(0)["A" LKR
. S:$D(DICR("1")) DICR("1")=ICDX S X=ICDX S:$D(DIROUT)!($G(DIC(0))'["A") (ICDX,INP1,INP2,ICDOINP,X)="",Y="-1^No selection made"
I +FND>1,$G(ICDOSEL)=0,$G(ICDOREV)=1 D G:$D(DUOUT)!($G(DIC(0))'["A") QUIT G:DIC(0)["A" LKR
. S X="",Y=-1
I $G(ICDOUPA)>0,'$D(DICR(1)),'$D(DIE),'$D(DR),'$D(DDS),DIC(0)["A" S (X,ICDX)="" K Y G LKR
I $D(DUOUT),'$D(DIROUT) S (DUOUT,DIRUT)=1,X="^",ICDX="",Y=-1 D I '$D(DICR(1)),'$D(DDS) G:+($G(ICDOREV))>0 QUIT G:+($G(ICDOREV))'>0 LKR
. Q:$D(DICR(1))!($D(DDS)) S:+($G(ICDOREV))>0 (X,ICDX)="^",Y=-1 I +($G(ICDOREV))'>0 S ICDX="" K DUOUT,DIRUT,DIROUT,DTOUT,X,Y
I ($D(DUOUT)!($D(DIROUT)))&($D(DICR(1))) D G ERR
. S:$D(DUOUT) X="^",DUOUT=1 S:$D(DIROUT) X="^^",DUOUT=1,DIROUT=1 W:'$D(DDS) !
I +($G(FND))>1,+($G(ICDOFND))>1,+($G(ICDOSEL))=0,+($G(ICDOREV))=1,$D(DICR(1)),'$D(DIC("S")) D G QUIT
. S (ICDOFND,ICDOSEL,ICDOREV)=0,Y=-1,(X,ICDX,ICDOINP,DICR("1"))=""
I $L($G(ICDREDO)) D G LKR
. S DIC(0)=$TR(DIC(0),"A","") S:'$L(DIC(0)) DIC(0)="EMQ" K DIC("S")
. S (ICDX,X,INP)=ICDREDO K Y
; If found, all reviewed and no selection made
I +($G(ICDOFND))>0,+($G(ICDOSEL))'>0,+($G(ICDOREV))>0 D G:$G(DIC(0))'["A" ERR G:$G(DIC(0))["A" LKR
. K ICDX,Y,INP,INP1,INP2,KEY,^TMP(SUB,$J),X S (FND,ICDOFND,ICDOSEL,ICDOREV)=0 S:$D(DICR("1")) DICR("1")=""
; If found, not all are reviewed and no selection made, single up arrow
I +($G(ICDOFND))>0,+($G(ICDOSEL))'>0,+($G(ICDOREV))'>0,$D(DUOUT),'$D(DIROUT) D G:$G(DIC(0))'["A" ERR G:$G(DIC(0))["A" LKR
. K ICDX,Y,INP,INP1,INP2,KEY,^TMP(SUB,$J),X S (FND,ICDOFND,ICDOSEL,ICDOREV)=0 S:$D(DICR("1")) DICR("1")=""
; If found, no selection made, no up arrow and no timeout
I +($G(ICDOFND))>0,+($G(ICDOSEL))'>0,'$D(DUOUT),'$D(DTOUT),$G(DIC(0))["E" G LKR
G:+($G(Y))'>0&($D(DUOUT))&('$D(DIROUT)) LKR
G:+($G(ICDOSEL))'>0 ERR
G:+($G(Y))'>0&('$D(DUOUT))&('$D(DTOUT)) LKR
G:+($G(Y))'>0&($D(DUOUT))&('$D(DIROUT)) LKR
G:+($G(Y))'>0 ERR
D RED,UDIC
Q
LKQ ; Quit
Q
ERR ; Quit On Error
N ICDX,ICDY,ICDE S ICDY=$G(Y),ICDX=$G(X) K X,Y S Y=-1
S:$L($P($G(ICDY),"^",2)) Y=Y_"^"_$P($G(ICDY),"^",2)
I $D(DTOUT),$G(DIC(0))["E",'$D(DDS) W !!,?2,"Try again later" K ERR
I $D(DUOUT),$G(DIC(0))["E" K ERR
I '$D(DUOUT),+($G(ICDOFND)>0),+($G(ICDOSEL)'>0),$G(DIC(0))["E" K ERR
I $L($G(ERR)),$G(DIC(0))["E",'$D(DDS) W !!,?2,$G(ERR)
S:$E(ICDY,1,2)="-1"&($L($P(ICDY,"^",2))) Y=ICDY
S X=ICDX I $D(DTOUT) S X="",Y="-1^Search timed out"
I Y="-1",+($G(ICDOFND)>0),+($G(ICDOSEL)'>0) S Y="-1^No Selection Made"
N XX S XX=$G(X) S X="" S:XX="^"!(XX="^^") X=XX D QUIT
Q
QUIT ; Quit without Error
N ICDUA S ICDUA=$$UA($G(ICDX))
I ICDUA="^" S X=ICDUA,Y="-1^Search aborted (up-arrow detected)"
I ICDUA="^^" S X=ICDUA,Y="-1^Search aborted (up-arrow detected)"
S:ICDUA["^"&(+($G(ICDOUPA))=2) Y="-1^Search aborted (doupble up-arrow detected)"
I +Y>0 D Y^ICDEXLK2($G(ROOT),+Y,$G(ICDCDT))
I $P($G(X),"`",2)=$P($G(Y),"^",1),$L($P($G(Y),"^",2)) S (ICDX,X)=$P($G(Y),"^",2)
D UDIC I $D(DDS) S:$L($G(ICDOINP))&(+Y'>0) X=$G(ICDOINP)
S:$L($G(ICDX)) X=$G(ICDX) S X=$G(X) D RED
Q
UDIC ; Undo DIC
S:$L($G(ICDDICW)) DIC("W")=$G(ICDDICW)
S:$L($G(ICDDICA)) DIC("A")=$G(ICDDICA)
S:$L($G(ICDDICB)) DIC("B")=$G(ICDDICB)
S:$L($G(ICDDICS)) DIC("S")=$G(ICDDICS)
S:$L($G(ICDDIC0)) DIC(0)=$G(ICDDIC0)
S:$L($G(ICDDIC00)) DIC(0)=$G(ICDDIC00)
Q
DIE ; Set for DIE call
Q:'$L($G(DIE)) S:'$L($G(DIC("A")))&($L($G(DIP))) DIC("A")=$G(DIP)
S:$L($G(DIC("A")))&($G(DIC("A"))'[": ") DIC("A")=$G(DIC("A"))_": "
N DIE,DIP,DZ,X1
Q
DICS(ICDS) ; Check DIC("S")
N ICDT1,ICDT2,ICDTS S ICDT1=$D(X),ICDT2=$G(X) Q:'$L($G(ICDS)) ""
S (ICDTS,X)=$G(ICDS) D ^DIM I '$D(X) S:ICDT1>0 X=$G(ICDT2) Q ""
S ICDS=$G(ICDTS) S:ICDT1>0 X=$G(ICDT2) S:$L($G(ICDX)) X=$G(ICDX)
Q ICDS
RED ; Re-Display
Q:+($G(Y))'>0 Q:'$L($P(Y,"^",2)) Q:$G(FILE)'>0 Q:$D(DDS) Q:$G(DIC(0))'["E"
Q:$G(DICR(2,1))="^ACK(509850.1,"
N CODE,EXP,CC,STA S CODE=$P(Y,"^",2) S CODE=CODE_$J(" ",(10-$L(CODE)))
S CC="" S:FILE=80 CC=$$VCC^ICDEX(+Y,$G(ICDCDT))
S CC=$S(CC="1":"(CC)",CC="2":"(Major CC)",1:"")
S STA=$O(@(ROOT_+Y_",66,""B"","_(+($G(ICDCDT))+.000001)_")"),-1)
S STA=$O(@(ROOT_+Y_",66,""B"","_+STA_","" "")"),-1)
S STA=$P($G(@(ROOT_+Y_",66,"_+STA_",0)")),"^",2)
S STA=$S($G(STA)?1N&(+$G(STA)'>0):" (Inactive)",$G(STA)'?1N&(+$G(STA)'>0):" (Pending)",1:"")
S:$G(ICDFMT)=2!($G(ICDFMT)=4) EXP=$$VLT^ICDEX(FILE,+Y,$G(ICDCDT))
S:$G(ICDFMT)=1!($G(ICDFMT)=3)!($G(ICDFMT)="") EXP=$$VST^ICDEX(FILE,+Y,$G(ICDCDT))
W:$L(CODE)&($L(EXP))&($D(DPP(1))) !,?5 W:$L(CODE)&($L(EXP)) " ",$G(CODE),$G(EXP),$G(CC),$G(STA)
Q
UA(X) ; Up Arrow
Q:($D(DUOUT)!($D(DIROUT)))&($D(DICR(1))) "^^"
K:$G(ICDOUPA)>0&($G(ICDOUPA)'>1) DIROUT
Q:$D(DUOUT)&('$D(DIROUT)) "^" Q:$D(DUOUT)&($D(DIROUT)) "^^"
Q:$G(INP)["^"&($G(INP)'["^^") "^" Q:$G(INP)["^"&($G(INP)["^^") "^^"
Q:$G(X)["^"&($G(X)'["^^") "^" Q:$G(X)["^"&($G(X)["^^") "^^"
Q X
TM(X,Y) ; Trim Y
S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
S X=$TR(X,"""","")
Q X
CLR ; Clear Environment
K DDS,DICR N ICDTEST,DPP,DR
Q
ICDEXLK ;SLC/KER - ICD Extractor - Lookup ;04/21/2014
+1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 7
+2 ;
+3 ; Global Variables
+4 ; ^ICDS( N/A
+5 ; ^TMP("ICD0") SACC 2.3.2.5.1
+6 ; ^TMP("ICD9") SACC 2.3.2.5.1
+7 ; ^TMP("ICDEXLK") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; ^DIM ICR 10016
+11 ; $$DT^XLFDT ICR 10103
+12 ;
+13 ; Local Variables NEWed or KILLed Elsewhere
+14 ; DIC,ICDFMT,ICDSYS,ICDVDT
+15 ;
LK ; Lookup
+1 ;
+2 ; This is the Special Lookup program for files 80 and 80.1.
+3 ; Only the ^DIC call honors the special lookup routines.
+4 ; Those calls that allow the user to specify the indexes
+5 ; (IX^DIC and MIX^DIC1), and the Data Base Server calls
+6 ; (FIND^DIC, $$FIND1^DIC, and UPDATE^DIE) all ignore the
+7 ; Special Lookup Program. Also, if DIC(0) contains an
+8 ; "I" then the Special Lookup program will be ignored.
+9 ;
+10 ; Local Variables Newed or Killed by Calling Application
+11 ;
+12 ; Versioning Date (Fileman format) (OLD, CSV)
+13 ;
+14 ; ICDVDT or
+15 ; ^TMP("ICDEXLK",$J,"ICDVDT"
+16 ;
+17 ; If supplied only active codes on that date
+18 ; will be included in the selection list.
+19 ;
+20 ; If not supplied, the date will default to
+21 ; TODAY and all codes may be selected, active
+22 ; and inactive.
+23 ;
+24 ; In both cases the display will be altered
+25 ; based on the date.
+26 ;
+27 ; Coding System (from file 80.4) (new)
+28 ;
+29 ; ICDSYS or
+30 ; ^TMP("ICDEXLK",$J,"ICDSYS"
+31 ;
+32 ; 1 ICD ICD-9-CM
+33 ; 2 ICP ICD-9 Proc
+34 ; 30 10D ICD-10-CM
+35 ; 31 10P ICD-10-PCS
+36 ;
+37 ; Display Format (numeric, 1-4) (new)
+38 ;
+39 ; ICDFMT or
+40 ; ^TMP("ICDEXLK",$J,"ICDFMT"
+41 ;
+42 ; 1 = Fileman format, code and short text (default)
+43 ;
+44 ; 250.00 DMII CMP NT ST UNCNTR
+45 ;
+46 ; 2 = Fileman format, code and description
+47 ;
+48 ; 250.00 DIABETES MELLITUS NO MENTION OF
+49 ; COMPLICATION, TYPE II OR UNSPECIFIED
+50 ; TYPE, NOT STATED AS UNCONTROLLED
+51 ;
+52 ; 3 = Lexicon format, short text followed by code
+53 ;
+54 ; DMII CMP NT ST UNCNTR (250.00)
+55 ;
+56 ; 4 = Lexicon format, description followed by code
+57 ;
+58 ; DIABETES MELLITUS NO MENTION OF COMPLICATION,
+59 ; TYPE II OR UNSPECIFIED TYPE, NOT STATED AS
+60 ; UNCONTROLLED (250.00)
+61 ;
+62 ; Special Lookup
+63 ; ^DD(80,0,"DIC")="ICDEXLK"
+64 ; ^DD(80.1,0,"DIC")="ICDEXLK"
+65 ;
+66 ; FileMan Variables
+67 ;
+68 ; X If DIC(0) does not contain an A, then the variable
+69 ; X must be defined equal to the value you want to
+70 ; find in the requested Index(es).
+71 ;
+72 ; DIC Global root or File Number
+73 ;
+74 ; ^ICD9( or 80
+75 ; ^ICD0( or 80.1
+76 ;
+77 ; DIC(0) (Optional) A string of characters which alter how
+78 ; DIC responds. Default value for ICD files "AEM"
+79 ;
+80 ; Applicable to a versioned lookup
+81 ; A Ask the entry; if erroneous, ask again
+82 ; E Echo information
+83 ; F Forget the lookup value
+84 ; I Ignore the special lookup program
+85 ; M Multiple-index lookup allowed
+86 ; O Only find one entry if it matches exactly
+87 ; S Suppresses display of .01
+88 ; X EXact match required
+89 ; Z Zero node in Y(0), external form in Y(0,0)
+90 ;
+91 ; Not Applicable to a versioned lookup
+92 ; C Versioned cross-references not turned off
+93 ; B There is no B index to use
+94 ; K Primary Key not established
+95 ; L Learning a new entry LAYGO not allowed
+96 ; N Uppercase, IEN lookup allowed (not forced)
+97 ; n ICD has no pure numeric entries
+98 ; Q Input is pre-processed, ?? not necessary
+99 ; U All values are external
+100 ; T All versioned Indexes are used
+101 ; V Verification is not optional
+102 ;
+103 ; DIC("A") (Optional) A prompt that is displayed prior to the
+104 ; reading of the X input. If DIC("A") is not defined,
+105 ; a prompt will be supplied by the special lookup
+106 ; routines.
+107 ;
+108 ; DIC("B") (Optional) The default answer which is presented to
+109 ; the user when the lookup prompt is issued. If a
+110 ; terminal user simply presses the Enter/Return key,
+111 ; the DIC("B") default value will be used, and
+112 ; returned in X. DIC("B") will only be used if it is
+113 ; non-null.
+114 ;
+115 ; DIC("S") (Optional) DIC("S") is a string of M code that DIC
+116 ; executes to screen an entry from selection.
+117 ; DIC("S") must contain an IF statement to set the
+118 ; value of $T. Those entries that the IF sets as
+119 ; $T=0 will not be displayed or selectable. If the
+120 ; DIC("S") code is executed, the local variable Y is
+121 ; the internal number of the entry being screened
+122 ; and the M naked indicator is at the global level
+123 ; @(DIC_"Y,0)").
+124 ;
+125 ; DIC("W") (Optional) An M command string which is executed
+126 ; when DIC displays each of the entries that match
+127 ; the user's input. The condition of the variable
+128 ; Y and of the naked indicator is the same as for
+129 ; DIC("S"). If DIC("W") is defined, it overrides
+130 ; the display of any identifiers of the file. Thus,
+131 ; if DIC("W")="", the display of identifiers will
+132 ; be suppressed.
+133 ;
+134 ; DIC("?N",<file>)=n
+135 ; (Optional) The number "n" should be an integer set
+136 ; to the number of entries to be displayed on the
+137 ; screen at one time when using "?" help in a lookup.
+138 ;
+139 ; FileMan Variables not used:
+140 ;
+141 ; DIC("DR")
+142 ; DIC("PTRIX",<from>,<to>,<file>)
+143 ; DIC("T")
+144 ; DIC("V")
+145 ; DIC("?PARAM",<file>,"INDEX")
+146 ; DIC("?PARAM",<file>,"FROM",<subscript>)
+147 ; DIC("?PARAM",<file>,"PART",<subscript>)
+148 ;
+149 ; FileMan Variables KILLed:
+150 ;
+151 ; DLAYGO
+152 ; DINUM
+153 ;
+154 ; Output
+155 ;
+156 ; Y IEN ^ Code Fileman
+157 ;
+158 ; If DIC(0) contains "Z"
+159 ;
+160 ; Y(0) 0 Node Fileman
+161 ; Y(0,0) Code Fileman
+162 ; Y(0,1) $$ICDDX or $$ICDOP Non-Fileman
+163 ; Y(0,2) Long Description Non-Fileman
+164 ;
+165 KILL ^TMP("ICD9",$JOB),^TMP("ICD0",$JOB)
DO DIE
+166 NEW DIRUT,DIROUT,FILE,ROOT,SUB,SBI,FND,ICDDICA,ICDDICB,ICDDICN,ICDDICW,ICDDICS,ICDDICSS
+167 NEW ICDDICST,ICDDIC0,ICDOLD0,ICDDIC00,ICDCDT,ICDCSY,ICDISF,ICDOUT,ICDVER,ICDX,ICDXP,KEY,INP,INP2,INP1,ERR
+168 NEW ICDOFND,ICDOSEL,ICDOINP,ICDREDO,ICDOREV,ICDISCD,ICDOUPA
+169 SET (ICDOFND,ICDOSEL,ICDOREV,ICDOUPA)=0
SET ICDXP=$GET(X)
+170 KILL DLAYGO,DINUM
SET (ICDOINP,ICDX)=$SELECT($EXTRACT($GET(X),1)'=" ":$$TM($GET(X)),1:$GET(X))
+171 KILL X,Y,DTOUT,DUOUT
SET ICDCSY=0
SET ROOT=$GET(DIC)
SET FILE=$$FILE^ICDEX(ROOT)
+172 IF "^80^80.1^"'[("^"_FILE_"^")
SET ERR="Invalid File"
GOTO ERR
+173 SET ROOT=$$ROOT^ICDEX(FILE)
+174 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH(ROOT))_"^")
SET ERR="Invalid Global Root"
GOTO ERR
+175 IF $LENGTH(ICDXP)
Begin DoDot:1
+176 NEW ICD0,ICD1,ICD2
SET ICD0=$TRANSLATE(ICDXP,"""","")
SET ICD1=$ORDER(@(ROOT_"""BA"","""_ICD0_""",0)"))
+177 SET ICD2=$ORDER(@(ROOT_"""BA"","""_ICD0_""","" "")"),-1)
IF ICD1>0
IF ICD1=ICD2
SET (X,ICDX)="`"_+ICD1
End DoDot:1
+178 IF $GET(ICDX)[";"
Begin DoDot:1
+179 NEW ICD1,ICD2
SET ICD1=$PIECE(ICDX,";",1)
SET ICD2=("^"_$PIECE(ICDX,";",2))
+180 IF ICD2'=DIC
QUIT
IF ICD1'?1N.N
QUIT
IF $DATA(@(ROOT_+ICD1_",0)"))
SET (X,ICDX)="`"_+ICD1
End DoDot:1
+181 ; System
+182 SET ICDCSY=0
+183 IF $LENGTH($GET(ICDSYS))
SET ICDCSY=$GET(ICDSYS)
+184 IF '$LENGTH($GET(ICDSYS))&($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDSYS"))))
SET ICDCSY=$GET(^TMP("ICDEXLK",$JOB,"ICDSYS"))
+185 SET ICDCSY=$$SYS^ICDEX($GET(ICDCSY))
+186 ; Date
+187 IF $LENGTH($GET(ICDVDT))
SET ICDCDT=$GET(ICDVDT)
+188 IF '$LENGTH($GET(ICDVDT))&($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDVDT"))))
SET ICDCDT=$GET(^TMP("ICDEXLK",$JOB,"ICDVDT"))
+189 ; Format
+190 SET ICDOUT=0
IF $LENGTH($GET(ICDFMT))
SET ICDOUT=$GET(ICDFMT)
+191 IF $DATA(DDS)
IF $DATA(ICDFMT)
SET ICDFMT=1
SET ICDOUT=1
+192 IF '$LENGTH($GET(ICDFMT))&($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDFMT"))))
SET ICDOUT=$GET(^TMP("ICDEXLK",$JOB,"ICDFMT"))
+193 IF +ICDOUT'>0
SET ICDOUT=1
IF +ICDOUT>4
SET ICDOUT=1
+194 IF $LENGTH($GET(ICDFMT))!($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDFMT"))))
SET ICDISF=1
+195 ; Versioned Lookup
+196 SET ICDVER=$SELECT($GET(ICDCDT)?7N:1,1:0)
IF $GET(ICDCDT)'?7N
SET ICDCDT=$$DT^XLFDT
+197 ; Enforce Business Rule for Date
+198 IF ICDVER'>0
IF $DATA(^ICDS(+ICDCSY,0))
SET ICDCDT=$$DTBR^ICDEX(ICDCDT,,+($GET(ICDCSY)))
+199 ; Space Bar Return (passed)
+200 IF $DATA(ICDX)
IF $GET(ICDX)=" "
IF DIC(0)'["A"
DO SBR^ICDEXLK2
IF +($GET(Y))>0
GOTO QUIT
KILL Y
+201 ; TMP global
+202 SET SUB=$TRANSLATE(ROOT,"^(","")
KILL ^TMP(SUB,$JOB)
+203 ; Save DIC
+204 SET ICDDICA=$GET(DIC("A"))
SET ICDDICB=$GET(DIC("B"))
SET ICDDICW=$GET(DIC("W"))
+205 SET ICDDICS=""
SET ICDDICST=$$DICS($GET(DIC("S")))
IF $LENGTH(ICDDICST)
SET ICDDICS=ICDDICST
+206 SET ICDDICSS=""
IF $LENGTH($GET(DICR(1,31)))
Begin DoDot:1
+207 QUIT
NEW X
SET X=$GET(DICR(1,31))
DO ^DIM
IF $DATA(X)
SET ICDDICSS=X
End DoDot:1
+208 SET ICDDICN=$GET(DIC("?N",FILE))
IF +ICDDICN'>0
SET ICDDICN=5
+209 SET ICDDIC00=$GET(DIC(0))
SET (ICDDIC0,DIC(0))=$$DIC0^ICDEXLK6($GET(DIC(0)))
+210 IF +($GET(ICDISF))>0
KILL DIC("W")
IF $DATA(DDS)
KILL DIC("W")
+211 IF $LENGTH(ICDX)'>4
IF ICDX'["."
Begin DoDot:1
+212 IF ICDX?3N&($DATA(@(ROOT_"""BA"","""_ICDX_". "")")))
SET ICDX=ICDX_"."
+213 IF $EXTRACT(ICDX,1)="E"&($EXTRACT(ICDX,2,4)?3N)&($DATA(@(ROOT_"""BA"","""_ICDX_". "")")))
SET ICDX=ICDX_"."
+214 IF $EXTRACT(ICDX,1)?1U&($EXTRACT(ICDX,2,3)?2N)&($DATA(@(ROOT_"""BA"","""_ICDX_". "")")))
SET ICDX=ICDX_"."
End DoDot:1
+215 IF ICDX="?"
IF $GET(DIC(0))'["A"
Begin DoDot:1
+216 DO INPH^ICDEXLK2(FILE)
SET ICDX=""
IF $GET(DIC(0))'["A"
SET DIC(0)=DIC(0)_"A"
End DoDot:1
IF $LENGTH($GET(DIE))
IF $LENGTH($GET(DIC))
IF $GET(DIE)'=$GET(DIC)
SET Y=-1
IF '$DATA(DDS)
WRITE !
QUIT
+217 IF ICDX="??"
IF $GET(DIC(0))'["A"
Begin DoDot:1
+218 DO INPH2^ICDEXLK2(FILE)
SET ICDX=""
IF $GET(DIC(0))'["A"
SET DIC(0)=DIC(0)_"A"
End DoDot:1
IF $LENGTH($GET(DIE))
IF $LENGTH($GET(DIC))
IF $GET(DIE)'=$GET(DIC)
SET Y=-1
IF '$DATA(DDS)
WRITE !
QUIT
LKR ; Lookup Recursive
+1 ; QUASAR
+2 IF '$DATA(DIC("S"))
IF $GET(DICR(2,1))="^ACK(509850.1,"
SET DIROUT=1
SET X="^^"
SET ICDX=""
SET Y=-1
GOTO QUIT
+3 IF $DATA(DICR)
IF +($GET(ICDOREV))>0
IF +($GET(ICDOFND))>0
IF +($GET(ICDOSEL))'>0
NEW ICDDICS
SET ICDDICS=""
+4 SET FND=0
IF '$LENGTH(DIC(0))
SET DIC(0)="AEM"
SET ICDREDO=""
+5 IF $LENGTH($GET(DIC(0)))
SET DIC(0)=$TRANSLATE(DIC(0),"CL","")
+6 IF +($GET(ICDOREV))>0
Begin DoDot:1
+7 SET (ICDOFND,ICDOSEL,ICDOREV)=0
KILL X
SET ICDX=""
End DoDot:1
+8 IF $GET(DIC(0))["A"
Begin DoDot:1
+9 SET X=$$INP^ICDEXLK2(FILE,$GET(ICDVER),$GET(ICDCDT))
End DoDot:1
IF '$LENGTH(X)
IF $GET(DIC(0))'["T"
SET X=""
SET ICDOREV=1
GOTO ERR
+10 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO ERR
+11 IF ($GET(DIC(0))["A")
IF ('$LENGTH(X)!(X="^"))
IF $GET(DIC(0))["T"
SET X=""
KILL Y
GOTO LKR
+12 IF $GET(DIC(0))'["A"&($LENGTH($GET(ICDX)))
SET X=$GET(ICDX)
+13 IF $GET(X)["^"
SET DUOUT=""
GOTO ERR
+14 IF '$LENGTH($GET(X))
GOTO ERR
+15 SET X=$$TM(X)
SET INP=X
SET INP1=$EXTRACT(INP,1)
SET INP2=$EXTRACT(INP,2,245)
+16 ; Forced IEN
+17 KILL Y
IF INP1="`"
IF INP2?1N.N
IF +INP2>0
Begin DoDot:1
+18 DO IEN^ICDEXLK5
IF +FND'>0
IF $GET(DIC(0))["Q"
Begin DoDot:2
+19 IF '$DATA(DICR(1))&('$DATA(DIROUT))&('$DATA(DUOUT))&('$DATA(DTOUT))&('$DATA(DDS))&(+($GET(ICDOREV))'>0)
WRITE " ??"
+20 IF $DATA(DICR(1))&('$DATA(DDS))
WRITE !
End DoDot:2
End DoDot:1
IF $LENGTH(X)&(+($GET(Y))<0)
GOTO QUIT
IF +($GET(FND))'>0
KILL X,Y
GOTO LKR
+21 IF $DATA(Y)
IF +Y<0
SET X=INP
GOTO QUIT
+22 ; Lookup X
+23 IF X'?1N.N
IF $LENGTH($GET(X))'>0!($EXTRACT($GET(X))="^")!($GET(X)["^^")!($DATA(DTOUT))!($DATA(DUOUT))
GOTO ERR
+24 NEW LOUD
SET LOUD=""
SET ICDX=X
IF +($GET(FND))'>0
Begin DoDot:1
+25 IF $LENGTH(ICDX)&($LENGTH(ICDX)>1)
SET FND=$$LK^ICDEXLK3($GET(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
+26 IF $LENGTH(ICDX)&($LENGTH(ICDX)'>1)
SET FND=$$CD^ICDEXLK3($GET(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
+27 IF +($GET(FND))>0
SET ICDOFND=+($GET(FND))
IF $LENGTH($GET(ICDX))
SET X=$GET(ICDX)
End DoDot:1
+28 IF +FND'>0
IF $GET(DIC(0))["Q"
IF '$DATA(DICR(1))&('$DATA(DIROUT))&('$DATA(DUOUT))&('$DATA(DTOUT))&('$DATA(DDS))&(+($GET(ICDOREV))'>0)
WRITE " ??"
+29 IF +FND'>0
IF $LENGTH(INP)
IF $EXTRACT(INP,1)'=" "
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
IF $GET(DIC(0))["A"
IF '($GET(DIC(0))["N"&(INP?1N.N))
KILL X,Y
GOTO LKR
+30 IF +FND'>0
SET X=INP
+31 ; Check Numeric - DIC(0)["N" and DIC(0)'["E"
+32 IF +$GET(ICDOSEL)'>0
IF $GET(DIC(0))["N"
IF INP?1N.N
Begin DoDot:1
+33 IF DIC(0)["E"&(+$GET(ICDOSEL)'>0)&(+$GET(ICDOFND)>0)
QUIT
KILL Y
NEW XX
+34 IF $DATA(@(ROOT_+INP_",0)"))
SET FND=1
Begin DoDot:2
+35 NEW IEN
SET IEN=+INP
SET (FND,ICDOFND,ICDOSEL)=1
+36 SET X=$PIECE($GET(@(ROOT_+X_",0)")),"^",1)
+37 DO Y^ICDEXLK2($GET(ROOT),IEN,$GET(ICDCDT))
End DoDot:2
QUIT
+38 IF '$DATA(@(ROOT_+INP_",0)"))
Begin DoDot:2
+39 SET X=$SELECT($LENGTH($GET(INP)):INP,1:$GET(X))
+40 SET Y="-1^Numeric value not found"
End DoDot:2
QUIT
+41 SET XX=$$LD^ICDEX(FILE,+$GET(INP),ICDCDT)
+42 IF $EXTRACT(XX,1,2)="-1"
Begin DoDot:2
+43 SET Y="-1^Long description not found"
SET X=$GET(INP)
End DoDot:2
QUIT
+44 IF $GET(DIC(0))["E"&('$DATA(DDS))
WRITE " ",XX
SET X=$GET(INP)
+45 DO Y^ICDEXLK2($GET(ROOT),$GET(X),$GET(ICDCDT))
+46 IF +Y>0&(+X'<0)
SET X=XX
IF +Y<0
SET X=INP
End DoDot:1
IF +($GET(Y))>0
GOTO QUIT
+47 IF +FND'>0
IF $GET(DIC(0))["N"
IF X?1N.N
IF +($GET(Y))<0
GOTO ERR
+48 IF +FND'>0
IF $LENGTH($GET(ICDX))
IF $LENGTH($GET(DIC("S")))
IF $LENGTH($GET(DICR(1)))
IF $LENGTH($GET(DICR(1,1)))
KILL DIC("S")
KILL Y
GOTO LKR
+49 IF +FND'>0
IF $LENGTH($GET(ICDX))
IF '$DATA(DIC("S"))
IF $LENGTH($GET(DICR(1)))
IF $GET(DICR(1))=$GET(ICDX)
IF $LENGTH($GET(DICR(1,1)))
Begin DoDot:1
+50 SET X=$SELECT($LENGTH($GET(INP)):INP,1:$GET(X))
SET Y="-1^No matches found"
End DoDot:1
GOTO QUIT
+51 IF +FND'>0
IF $GET(DIC(0))'["T"
Begin DoDot:1
+52 IF $GET(DIC(0))["E"&('$LENGTH($GET(DICR(1))))&('$DATA(DDS))
WRITE !," No matches found"
+53 SET X=$SELECT($LENGTH($GET(INP)):INP,1:$GET(X))
SET Y="-1^No matches found"
End DoDot:1
GOTO QUIT
+54 IF +FND'>0
IF $GET(DIC(0))["T"
KILL Y
GOTO LKR
+55 SET ICDOUPA=0
DO ASK^ICDEXLK2
+56 IF $DATA(DUOUT)
IF $DATA(DIROUT)
Begin DoDot:1
+57 SET (DUOUT,DIRUT)=1
SET X="^^"
+58 SET ICDX=""
SET Y=-1
End DoDot:1
GOTO QUIT
+59 IF +FND=1
IF $GET(ICDOFND)=1
IF $GET(ICDOSEL)=0
IF $GET(ICDOREV)=1
IF '$DATA(DICR(1))
Begin DoDot:1
+60 SET (ICDX,INP1,INP2,ICDOINP,X)=""
SET Y="-1^No selection made"
End DoDot:1
IF $DATA(DIROUT)!($GET(DIC(0))'["A")
GOTO QUIT
IF DIC(0)["A"
GOTO LKR
+61 IF +FND=1
IF $GET(ICDOFND)=1
IF $GET(ICDOSEL)=0
IF $GET(ICDOREV)=1
IF $DATA(DICR(1))
Begin DoDot:1
+62 IF $DATA(DICR("1"))
SET DICR("1")=ICDX
SET X=ICDX
IF $DATA(DIROUT)!($GET(DIC(0))'["A")
SET (ICDX,INP1,INP2,ICDOINP,X)=""
SET Y="-1^No selection made"
End DoDot:1
IF $DATA(DIROUT)!($GET(DIC(0))'["A")
GOTO QUIT
NEW ICDDICS
IF DIC(0)["A"
GOTO LKR
+63 IF +FND>1
IF $GET(ICDOSEL)=0
IF $GET(ICDOREV)=1
Begin DoDot:1
+64 SET X=""
SET Y=-1
End DoDot:1
IF $DATA(DUOUT)!($GET(DIC(0))'["A")
GOTO QUIT
IF DIC(0)["A"
GOTO LKR
+65 IF $GET(ICDOUPA)>0
IF '$DATA(DICR(1))
IF '$DATA(DIE)
IF '$DATA(DR)
IF '$DATA(DDS)
IF DIC(0)["A"
SET (X,ICDX)=""
KILL Y
GOTO LKR
+66 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
SET (DUOUT,DIRUT)=1
SET X="^"
SET ICDX=""
SET Y=-1
Begin DoDot:1
+67 IF $DATA(DICR(1))!($DATA(DDS))
QUIT
IF +($GET(ICDOREV))>0
SET (X,ICDX)="^"
SET Y=-1
IF +($GET(ICDOREV))'>0
SET ICDX=""
KILL DUOUT,DIRUT,DIROUT,DTOUT,X,Y
End DoDot:1
IF '$DATA(DICR(1))
IF '$DATA(DDS)
IF +($GET(ICDOREV))>0
GOTO QUIT
IF +($GET(ICDOREV))'>0
GOTO LKR
+68 IF ($DATA(DUOUT)!($DATA(DIROUT)))&($DATA(DICR(1)))
Begin DoDot:1
+69 IF $DATA(DUOUT)
SET X="^"
SET DUOUT=1
IF $DATA(DIROUT)
SET X="^^"
SET DUOUT=1
SET DIROUT=1
IF '$DATA(DDS)
WRITE !
End DoDot:1
GOTO ERR
+70 IF +($GET(FND))>1
IF +($GET(ICDOFND))>1
IF +($GET(ICDOSEL))=0
IF +($GET(ICDOREV))=1
IF $DATA(DICR(1))
IF '$DATA(DIC("S"))
Begin DoDot:1
+71 SET (ICDOFND,ICDOSEL,ICDOREV)=0
SET Y=-1
SET (X,ICDX,ICDOINP,DICR("1"))=""
End DoDot:1
GOTO QUIT
+72 IF $LENGTH($GET(ICDREDO))
Begin DoDot:1
+73 SET DIC(0)=$TRANSLATE(DIC(0),"A","")
IF '$LENGTH(DIC(0))
SET DIC(0)="EMQ"
KILL DIC("S")
+74 SET (ICDX,X,INP)=ICDREDO
KILL Y
End DoDot:1
GOTO LKR
+75 ; If found, all reviewed and no selection made
+76 IF +($GET(ICDOFND))>0
IF +($GET(ICDOSEL))'>0
IF +($GET(ICDOREV))>0
Begin DoDot:1
+77 KILL ICDX,Y,INP,INP1,INP2,KEY,^TMP(SUB,$JOB),X
SET (FND,ICDOFND,ICDOSEL,ICDOREV)=0
IF $DATA(DICR("1"))
SET DICR("1")=""
End DoDot:1
IF $GET(DIC(0))'["A"
GOTO ERR
IF $GET(DIC(0))["A"
GOTO LKR
+78 ; If found, not all are reviewed and no selection made, single up arrow
+79 IF +($GET(ICDOFND))>0
IF +($GET(ICDOSEL))'>0
IF +($GET(ICDOREV))'>0
IF $DATA(DUOUT)
IF '$DATA(DIROUT)
Begin DoDot:1
+80 KILL ICDX,Y,INP,INP1,INP2,KEY,^TMP(SUB,$JOB),X
SET (FND,ICDOFND,ICDOSEL,ICDOREV)=0
IF $DATA(DICR("1"))
SET DICR("1")=""
End DoDot:1
IF $GET(DIC(0))'["A"
GOTO ERR
IF $GET(DIC(0))["A"
GOTO LKR
+81 ; If found, no selection made, no up arrow and no timeout
+82 IF +($GET(ICDOFND))>0
IF +($GET(ICDOSEL))'>0
IF '$DATA(DUOUT)
IF '$DATA(DTOUT)
IF $GET(DIC(0))["E"
GOTO LKR
+83 IF +($GET(Y))'>0&($DATA(DUOUT))&('$DATA(DIROUT))
GOTO LKR
+84 IF +($GET(ICDOSEL))'>0
GOTO ERR
+85 IF +($GET(Y))'>0&('$DATA(DUOUT))&('$DATA(DTOUT))
GOTO LKR
+86 IF +($GET(Y))'>0&($DATA(DUOUT))&('$DATA(DIROUT))
GOTO LKR
+87 IF +($GET(Y))'>0
GOTO ERR
+88 DO RED
DO UDIC
+89 QUIT
LKQ ; Quit
+1 QUIT
ERR ; Quit On Error
+1 NEW ICDX,ICDY,ICDE
SET ICDY=$GET(Y)
SET ICDX=$GET(X)
KILL X,Y
SET Y=-1
+2 IF $LENGTH($PIECE($GET(ICDY),"^",2))
SET Y=Y_"^"_$PIECE($GET(ICDY),"^",2)
+3 IF $DATA(DTOUT)
IF $GET(DIC(0))["E"
IF '$DATA(DDS)
WRITE !!,?2,"Try again later"
KILL ERR
+4 IF $DATA(DUOUT)
IF $GET(DIC(0))["E"
KILL ERR
+5 IF '$DATA(DUOUT)
IF +($GET(ICDOFND)>0)
IF +($GET(ICDOSEL)'>0)
IF $GET(DIC(0))["E"
KILL ERR
+6 IF $LENGTH($GET(ERR))
IF $GET(DIC(0))["E"
IF '$DATA(DDS)
WRITE !!,?2,$GET(ERR)
+7 IF $EXTRACT(ICDY,1,2)="-1"&($LENGTH($PIECE(ICDY,"^",2)))
SET Y=ICDY
+8 SET X=ICDX
IF $DATA(DTOUT)
SET X=""
SET Y="-1^Search timed out"
+9 IF Y="-1"
IF +($GET(ICDOFND)>0)
IF +($GET(ICDOSEL)'>0)
SET Y="-1^No Selection Made"
+10 NEW XX
SET XX=$GET(X)
SET X=""
IF XX="^"!(XX="^^")
SET X=XX
DO QUIT
+11 QUIT
QUIT ; Quit without Error
+1 NEW ICDUA
SET ICDUA=$$UA($GET(ICDX))
+2 IF ICDUA="^"
SET X=ICDUA
SET Y="-1^Search aborted (up-arrow detected)"
+3 IF ICDUA="^^"
SET X=ICDUA
SET Y="-1^Search aborted (up-arrow detected)"
+4 IF ICDUA["^"&(+($GET(ICDOUPA))=2)
SET Y="-1^Search aborted (doupble up-arrow detected)"
+5 IF +Y>0
DO Y^ICDEXLK2($GET(ROOT),+Y,$GET(ICDCDT))
+6 IF $PIECE($GET(X),"`",2)=$PIECE($GET(Y),"^",1)
IF $LENGTH($PIECE($GET(Y),"^",2))
SET (ICDX,X)=$PIECE($GET(Y),"^",2)
+7 DO UDIC
IF $DATA(DDS)
IF $LENGTH($GET(ICDOINP))&(+Y'>0)
SET X=$GET(ICDOINP)
+8 IF $LENGTH($GET(ICDX))
SET X=$GET(ICDX)
SET X=$GET(X)
DO RED
+9 QUIT
UDIC ; Undo DIC
+1 IF $LENGTH($GET(ICDDICW))
SET DIC("W")=$GET(ICDDICW)
+2 IF $LENGTH($GET(ICDDICA))
SET DIC("A")=$GET(ICDDICA)
+3 IF $LENGTH($GET(ICDDICB))
SET DIC("B")=$GET(ICDDICB)
+4 IF $LENGTH($GET(ICDDICS))
SET DIC("S")=$GET(ICDDICS)
+5 IF $LENGTH($GET(ICDDIC0))
SET DIC(0)=$GET(ICDDIC0)
+6 IF $LENGTH($GET(ICDDIC00))
SET DIC(0)=$GET(ICDDIC00)
+7 QUIT
DIE ; Set for DIE call
+1 IF '$LENGTH($GET(DIE))
QUIT
IF '$LENGTH($GET(DIC("A")))&($LENGTH($GET(DIP)))
SET DIC("A")=$GET(DIP)
+2 IF $LENGTH($GET(DIC("A")))&($GET(DIC("A"))'["
SET DIC("A")=$GET(DIC("A"))_": "
+3 NEW DIE,DIP,DZ,X1
+4 QUIT
DICS(ICDS) ; Check DIC("S")
+1 NEW ICDT1,ICDT2,ICDTS
SET ICDT1=$DATA(X)
SET ICDT2=$GET(X)
IF '$LENGTH($GET(ICDS))
QUIT ""
+2 SET (ICDTS,X)=$GET(ICDS)
DO ^DIM
IF '$DATA(X)
IF ICDT1>0
SET X=$GET(ICDT2)
QUIT ""
+3 SET ICDS=$GET(ICDTS)
IF ICDT1>0
SET X=$GET(ICDT2)
IF $LENGTH($GET(ICDX))
SET X=$GET(ICDX)
+4 QUIT ICDS
RED ; Re-Display
+1 IF +($GET(Y))'>0
QUIT
IF '$LENGTH($PIECE(Y,"^",2))
QUIT
IF $GET(FILE)'>0
QUIT
IF $DATA(DDS)
QUIT
IF $GET(DIC(0))'["E"
QUIT
+2 IF $GET(DICR(2,1))="^ACK(509850.1,"
QUIT
+3 NEW CODE,EXP,CC,STA
SET CODE=$PIECE(Y,"^",2)
SET CODE=CODE_$JUSTIFY(" ",(10-$LENGTH(CODE)))
+4 SET CC=""
IF FILE=80
SET CC=$$VCC^ICDEX(+Y,$GET(ICDCDT))
+5 SET CC=$SELECT(CC="1":"(CC)",CC="2":"(Major CC)",1:"")
+6 SET STA=$ORDER(@(ROOT_+Y_",66,""B"","_(+($GET(ICDCDT))+.000001)_")"),-1)
+7 SET STA=$ORDER(@(ROOT_+Y_",66,""B"","_+STA_","" "")"),-1)
+8 SET STA=$PIECE($GET(@(ROOT_+Y_",66,"_+STA_",0)")),"^",2)
+9 SET STA=$SELECT($GET(STA)?1N&(+$GET(STA)'>0):" (Inactive)",$GET(STA)'?1N&(+$GET(STA)'>0):" (Pending)",1:"")
+10 IF $GET(ICDFMT)=2!($GET(ICDFMT)=4)
SET EXP=$$VLT^ICDEX(FILE,+Y,$GET(ICDCDT))
+11 IF $GET(ICDFMT)=1!($GET(ICDFMT)=3)!($GET(ICDFMT)="")
SET EXP=$$VST^ICDEX(FILE,+Y,$GET(ICDCDT))
+12 IF $LENGTH(CODE)&($LENGTH(EXP))&($DATA(DPP(1)))
WRITE !,?5
IF $LENGTH(CODE)&($LENGTH(EXP))
WRITE " ",$GET(CODE),$GET(EXP),$GET(CC),$GET(STA)
+13 QUIT
UA(X) ; Up Arrow
+1 IF ($DATA(DUOUT)!($DATA(DIROUT)))&($DATA(DICR(1)))
QUIT "^^"
+2 IF $GET(ICDOUPA)>0&($GET(ICDOUPA)'>1)
KILL DIROUT
+3 IF $DATA(DUOUT)&('$DATA(DIROUT))
QUIT "^"
IF $DATA(DUOUT)&($DATA(DIROUT))
QUIT "^^"
+4 IF $GET(INP)["^"&($GET(INP)'["^^")
QUIT "^"
IF $GET(INP)["^"&($GET(INP)["^^")
QUIT "^^"
+5 IF $GET(X)["^"&($GET(X)'["^^")
QUIT "^"
IF $GET(X)["^"&($GET(X)["^^")
QUIT "^^"
+6 QUIT X
TM(X,Y) ; Trim Y
+1 SET Y=$GET(Y)
IF '$LENGTH(Y)
SET Y=" "
+2 FOR
IF $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 SET X=$TRANSLATE(X,"""","")
+5 QUIT X
CLR ; Clear Environment
+1 KILL DDS,DICR
NEW ICDTEST,DPP,DR
+2 QUIT
