ICDEXLK ;SLC/KER - ICD Extractor - Lookup ;12/19/2014
;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
;
; 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
; $$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.
;
; 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
;
; 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 (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
;
; 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
; E Echo
; F Forget lookup value
; I Ignore lookup program
; O Find one exact match
; Q Question Input ??
; S Suppresses display of .01
; X EXact match required
; Z Expand output Y variable
;
; Not Applicable/Used in a versioned lookup
;
; C, B, K, L, M, N, n, U, T and V
;
; DIC("A") (Optional) A prompt that is displayed prior to the
; reading of the X input.
;
; DIC("B") (Optional) The default answer which is presented to
; the user when the lookup prompt is issued.
;
; DIC("S") (Optional) DIC("S") Screen M code that sets the
; value of $T.
;
; DIC("W") (Optional) An M command string displays each entry
; that matches the user's input
;
; DIC("?N",<file>)=n
; (Optional) The number "n" should be an integer set
; to the number of entries to be displayed
;
; FileMan Variables KILLed: DLAYGO and 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^ICDEXLK6
N DIRUT,DIROUT,FILE,ROOT,SUB,SBI,ICDDICA,ICDDICB,ICDDICN,ICDDICW,ICDDICS,ICDDICST
N ICDDIC0,ICDOLD0,ICDDIC00,ICDCDT,ICDCSY,ICDISF,ICDOUT,ICDVER,ICDX,ICDXP,KEY,INP,INP2,INP1
N INPE,ERR,ICDOFND,ICDOSEL,ICDOINP,ICDREDO,ICDOREV,ICDISCD,ICDOUPA,ICDOTIM,ICDOPTR,ICDOVAL
S (ICDOFND,ICDOSEL,ICDOREV,ICDOUPA,ICDOTIM)=0,ICDXP=$$XT^ICDEXLK6($G(X)),ICDOPTR=+($O(DICR(" "),-1))
K DLAYGO,DINUM S (ICDOINP,ICDX)=$$XT^ICDEXLK6($S($E($G(X),1)'=" ":$$TM^ICDEXLK6($G(X)),1:$G(X)))
K X,Y,DTOUT,DUOUT S ICDCSY=0,ROOT=$G(DIC),FILE=$$FILE^ICDEX(ROOT),ICDOVAL=1
I "^80^80.1^"'[("^"_FILE_"^") S ERR="Invalid File" G ERR
S ROOT=$$ROOT^ICDEX(FILE)
I "^ICD9(^ICD0(^"'[("^"_$E(ROOT,2,$L($G(ROOT)))_"^") S ERR="Invalid Global Root" G ERR
; Exact code entered, no subordinates
I $L($G(ICDXP)),$G(DIC(0))'["A" D
. N ICDTMP F ICDTMP=ICDXP,($TR(ICDXP,"""","")_".") D Q:$G(ICDX)["`"
. . N ICD0,ICD1,ICD2,ICDF S ICD0=$TR(ICDTMP,"""","")
. . S ICD1=$O(@(ROOT_"""BA"","""_ICD0_""",0)"))
. . S ICD2=$O(@(ROOT_"""BA"","""_ICD0_""","" "")"),-1)
. . I ICD1>0,ICD1=ICD2 S (X,ICDX)="`"_+ICD1 Q
. . S 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,ICD3 S ICD1=$P(ICDX,";",1),ICD2=("^"_$P(ICDX,";",2))
. Q:ICD2'=DIC Q:ICD1'?1N.N S ICD3=$P($G(@(ROOT_+ICD1_",0)")),"^",1)
. I $D(@(ROOT_+ICD1_",0)")) S (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 S:+($G(Y))>0&(X'=ICDX) ICDX=X 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^ICDEXLK6($G(DIC("S"))) S:$L($G(ICDDICST)) ICDDICS=ICDDICST
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($G(ICDX))'>4,ICDX'["." D
. S:ICDX?3N&($D(@(ROOT_"""BA"","""_ICDX_". "")"))) ICDX=ICDX_".",ICDXP=ICDXP_"."
. S:$E(ICDX,1)="E"&($E(ICDX,2,4)?3N)&($D(@(ROOT_"""BA"","""_ICDX_". "")"))) ICDX=ICDX_".",ICDXP=ICDXP_"."
. S:$E(ICDX,1)?1U&($E(ICDX,2,3)?2N)&($D(@(ROOT_"""BA"","""_ICDX_". "")"))) ICDX=ICDX_".",ICDXP=ICDXP_"."
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
S:$G(DIC(0))'["A"&($L($G(ICDX)))&('$L($G(X))) X=ICDX
S (INPE,ICDOFND)=0,ICDOVAL=1 S:'$L($G(DIC(0))) DIC(0)="AEM" S ICDREDO=""
S:$L($G(DIC(0))) DIC(0)=$TR(DIC(0),"CL","")
; User Input
I +($G(ICDOREV))>0 D
. S (ICDOFND,ICDOSEL,ICDOREV)=0 K X S ICDX=""
S (ICDOUPA,ICDOTIM)=0 I $G(DIC(0))["A" D
. N ICDT S ICDOVAL=1,X=$$INP^ICDEXLK2(FILE,$G(ICDVER),$G(ICDCDT)) S ICDT=$$XT^ICDEXLK6(X)
. S:ICDT'=X ICDOVAL=0,X=ICDT
I '$L($G(X)),$G(DIC(0))'["T",+($G(ICDOUPA))'>1,+($G(ICDOVAL))>0 S X="",ICDOREV=1 G ERR
I '$L($G(X)),+($G(ICDOVAL))'>0,+($G(ICDOUPA))'>0,+($G(ICDOTIM))'>0 D G LKR
. W:ICDOUPA'>0&(ICDOTIM'>0)&('$D(DDS)) " ??"
S:ICDOTIM>0 DTOUT=1 G:ICDOTIM>0 ERR S:ICDOUPA>0 DUOUT=1 G:ICDOUPA>0 ERR
I ($G(DIC(0))["A"),('$L($G(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^ICDEXLK6(X),INP=X,INP1=$E(INP,1),INP2=$E(INP,2,245) S:INP1="`"&(INP2?1N.N) INPE=1
; Search #1 - Forced IEN
K Y S (ICDOUPA,ICDOTIM)=0 I INPE>0 D
. D IEN^ICDEXLK5 S ICDOUPA=+($G(ICDOUPA)),ICDOTIM=+($G(ICDOTIM))
. S:+($G(Y))>0&($L($P($G(Y),"^",2))>0) (ICDX,X)=$P($G(Y),"^",2)
. I '$L($G(X)),+($G(Y))<0,$G(DIC(0))'["A" D Q
. . S (X,ICDX,ICDXP,INP,INP1,INP2)="",Y="-1^No Selection Made"
. . S:$L($G(DICR("1"))) DICR("1")=""
. I +($G(ICDOFND))'>0,$G(DIC(0))["Q" D
. . W:(ICDOPTR'>0)&(ICDOUPA'>0)&(ICDOTIM'>0)&('$D(DDS))&(+($G(ICDOREV))'>0) " ??"
. . W:(ICDOPTR>0)&('$D(DDS)) !
. I +($G(ICDOFND))'>0 S (ICDX,X)="",Y=-1 S:$D(ICDOINP) ICDOINP=""
; Abort Search #1
I INPE>0,'$L($G(X)),+($G(Y))<0,$G(DIC(0))'["A" G QUIT
I INPE>0,$L($G(X)),+($G(Y))>0,$P($G(Y),"^",2)=$G(X) G QUIT
I INPE>0 G:($L($G(X))&(+($G(Y))>0))!($G(ICDOUPA)=2) QUIT G:+($G(ICDOTIM))>0 QUIT
I INPE>0 G:(+($G(ICDOFND))'>0!($G(ICDOUPA)=1))&($G(DIC(0))["A") LKR
I INPE>0 G:+($G(ICDOFND))>0&($G(ICDOSEL)'>0)&($G(ICDOREV)>0)&($G(DIC(0))["A") LKR
I $D(Y) S:+Y<0 X=INP G QUIT
; Search #2 - Lookup X
S (ICDOUPA,ICDOTIM)=0 N LOUD S LOUD="" S ICDX=X I +($G(ICDOFND))'>0 D
. ; Text Search
. S:$L($G(ICDX))&($L($G(ICDX))>1) ICDOFND=$$LK^ICDEXLK3($G(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
. ; Code Search
. S:$L($G(ICDX))&($L($G(ICDX))'>1) ICDOFND=$$CD^ICDEXLK3($G(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
. S ICDOFND=+($G(ICDOFND)) S:$L($G(ICDX)) X=$G(ICDX)
; Abort Search #2
I +($G(ICDOFND))'>0,$G(DIC(0))["Q" D
. W:(ICDOPTR'>0)&('$D(DDS))&(+($G(ICDOREV))'>0) " ??"
I +($G(ICDOFND))'>0,$L($G(INP)),$E(INP,1)'=" ",$G(DIC(0))["A" K ICDX,X,Y,INP,INP1,INP2 G LKR
S:+($G(ICDOFND))'>0 X=$G(INP)
; Nothing Found
I +($G(ICDOFND))'>0,$G(DIC(0))'["T" D G QUIT
. W:$G(DIC(0))["E"&(ICDOPTR'>0)&('$D(DDS)) !," No matches found"
. S X=$S($L($G(INP)):INP,1:$G(X)),Y="-1^No matches found"
I +($G(ICDOFND))'>0,$G(DIC(0))["T" K Y G LKR
; Results found
S (ICDOUPA,ICDOTIM)=0 D ASK^ICDEXLK2 G:$D(DTOUT) ERR
S:ICDOTIM>0 DTOUT=1 G:ICDOTIM>0 ERR
I +($G(ICDOUPA))>1 S DUOUT=1 W:'$D(DDS) ! G QUIT
G:+($G(ICDOUPA))=1&(DIC(0)'["A") QUIT
G:+($G(ICDOUPA))=1&(DIC(0)["A") LKR
I +($G(ICDOFND))>0,+($G(ICDOSEL))'>0,+($G(ICDOREV))>0,+($G(ICDOPTR))>0 D G QUIT
. S X=ICDX S:$G(DIC(0))'["A" (ICDX,INP1,INP2,ICDOINP,X)="",Y="-1^No selection made"
I +($G(ICDOFND))>0,+($G(ICDOSEL))'>0,+($G(ICDOREV))>0,+($G(ICDOPTR))'>0 D G:$G(ICDOUPA)>1!($G(DIC(0))'["A") QUIT G:DIC(0)["A" LKR
. S (ICDX,INP1,INP2,ICDOINP,X)="",Y="-1^No selection made"
G:+($G(Y))'>0 ERR D QUIT
Q
LKQ ; Quit
Q
ERR ; Quit On Error/Time Out
N ICDX,ICDY 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 $G(ICDOTIM)>0,$G(DIC(0))["E",'$D(DDS) W !!,?2,"Try again later" K ERR
I $G(ICDOUPA)>0,$G(DIC(0))["E" K ERR
I $G(ICDOUPA)>0,+($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($G(ICDY),"^",2))) Y=ICDY S X=ICDX
I $E(Y,1,2)="-1",+($G(ICDOFND)>0),+($G(ICDOSEL)'>0) S Y="-1^No Selection Made"
D QUIT
Q
QUIT ; Quit without Error
K DUOUT,DTOUT S:ICDOUPA=1 DUOUT=1,X="^",Y="-1^Search aborted (up-arrow detected)"
S:ICDOUPA=2 DUOUT=1,X="^^",Y="-1^Search aborted (double up-arrow detected)"
S:ICDOTIM>0 DTOUT=1,X="",Y="-1^Search aborted (timed out)" Q:$D(DUOUT)!($D(DTOUT))
I $G(ICDOFND)>0,$G(ICDOREV)>0,$G(ICDOSEL)'>0 S X="",Y="-1^No Selection Made" Q
I '$L(($G(ICDX)_$G(X))),+Y<0,'$L($P($G(Y),"^",2)),$G(DIC(0))'["A" S Y="-1^No user input" Q
D:+Y>0 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)
I +($G(Y))>0,X=$P($G(Y),"^",1),$L($P($G(Y),"^",2)) S (ICDX,X)=$P($G(Y),"^",2)
I X=" ",$P($G(Y),"^",1)>0,$L($P($G(Y),"^",2)),$D(@(ROOT_+($P($G(Y),"^",1))_",0)")) S X=$P($G(Y),"^",2)
D DICU^ICDEXLK6 I $D(DDS) S:$L($G(ICDOINP))&(+Y'>0) X=$G(ICDOINP)
I ICDOTIM'>0,$G(DIC(0))["A",$L($G(INP)),+($G(Y))>0,$L($P($G(Y),"^",2)) S (ICDX,X)=INP
S:$L($G(ICDX)) X=$G(ICDX) S X=$G(X) D RED
Q
RED ; Re-Display
Q:+($G(Y))'>0 Q:'$L($P($G(Y),"^",2)) Q:$G(FILE)'>0 Q:$D(DDS) Q:$G(DIC(0))'["E"
Q:ICDOPTR>1 N CODE,EXP,CC,STA S CODE=$P(Y,"^",2) S CODE=CODE_$J(" ",(10-$L($G(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($G(CODE))&($L($G(EXP)))&($D(DPP(1))) !,?5 W:$L($G(CODE))&($L($G(EXP))) " ",$G(CODE),$G(EXP),$G(CC),$G(STA)
Q
CLR ; Clear Environment
K DDS,DICR N ICDTEST,DPP,DR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDEXLK 13969 printed Sep 23, 2025@19:26:45 Page 2
ICDEXLK ;SLC/KER - ICD Extractor - Lookup ;12/19/2014
+1 ;;18.0;DRG Grouper;**57,67**;Oct 20, 2000;Build 1
+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 ; $$DT^XLFDT ICR 10103
+11 ;
+12 ; Local Variables NEWed or KILLed Elsewhere
+13 ; DIC,ICDFMT,ICDSYS,ICDVDT
+14 ;
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 ; Coding System (from file 80.4) (new)
+25 ;
+26 ; ICDSYS or
+27 ; ^TMP("ICDEXLK",$J,"ICDSYS"
+28 ;
+29 ; 1 ICD ICD-9-CM
+30 ; 2 ICP ICD-9 Proc
+31 ; 30 10D ICD-10-CM
+32 ; 31 10P ICD-10-PCS
+33 ;
+34 ; Display Format (numeric, 1-4) (new)
+35 ;
+36 ; ICDFMT or
+37 ; ^TMP("ICDEXLK",$J,"ICDFMT"
+38 ;
+39 ; 1 = Fileman format, code and short text (default)
+40 ;
+41 ; 250.00 DMII CMP NT ST UNCNTR
+42 ;
+43 ; 2 = Fileman format, code and description
+44 ;
+45 ; 250.00 DIABETES MELLITUS NO MENTION OF
+46 ; COMPLICATION, TYPE II OR UNSPECIFIED TYPE
+47 ;
+48 ; 3 = Lexicon format, short text followed by code
+49 ;
+50 ; DMII CMP NT ST UNCNTR (250.00)
+51 ;
+52 ; 4 = Lexicon format, description followed by code
+53 ;
+54 ; DIABETES MELLITUS NO MENTION OF COMPLICATION,
+55 ; TYPE II OR UNSPECIFIED TYPE (250.00)
+56 ;
+57 ; Special Lookup
+58 ; ^DD(80,0,"DIC")="ICDEXLK"
+59 ; ^DD(80.1,0,"DIC")="ICDEXLK"
+60 ;
+61 ; FileMan Variables
+62 ;
+63 ; X If DIC(0) does not contain an A, then the variable
+64 ; X must be defined
+65 ;
+66 ; DIC Global root or File Number
+67 ;
+68 ; ^ICD9( or 80
+69 ; ^ICD0( or 80.1
+70 ;
+71 ; DIC(0) (Optional) A string of characters which alter how
+72 ; DIC responds. Default value for ICD files "AEM"
+73 ;
+74 ; Applicable to a versioned lookup
+75 ; A Ask
+76 ; E Echo
+77 ; F Forget lookup value
+78 ; I Ignore lookup program
+79 ; O Find one exact match
+80 ; Q Question Input ??
+81 ; S Suppresses display of .01
+82 ; X EXact match required
+83 ; Z Expand output Y variable
+84 ;
+85 ; Not Applicable/Used in a versioned lookup
+86 ;
+87 ; C, B, K, L, M, N, n, U, T and V
+88 ;
+89 ; DIC("A") (Optional) A prompt that is displayed prior to the
+90 ; reading of the X input.
+91 ;
+92 ; DIC("B") (Optional) The default answer which is presented to
+93 ; the user when the lookup prompt is issued.
+94 ;
+95 ; DIC("S") (Optional) DIC("S") Screen M code that sets the
+96 ; value of $T.
+97 ;
+98 ; DIC("W") (Optional) An M command string displays each entry
+99 ; that matches the user's input
+100 ;
+101 ; DIC("?N",<file>)=n
+102 ; (Optional) The number "n" should be an integer set
+103 ; to the number of entries to be displayed
+104 ;
+105 ; FileMan Variables KILLed: DLAYGO and DINUM
+106 ;
+107 ; Output
+108 ;
+109 ; Y IEN ^ Code Fileman
+110 ;
+111 ; If DIC(0) contains "Z"
+112 ;
+113 ; Y(0) 0 Node Fileman
+114 ; Y(0,0) Code Fileman
+115 ; Y(0,1) $$ICDDX or $$ICDOP Non-Fileman
+116 ; Y(0,2) Long Description Non-Fileman
+117 ;
+118 KILL ^TMP("ICD9",$JOB),^TMP("ICD0",$JOB)
DO DIE^ICDEXLK6
+119 NEW DIRUT,DIROUT,FILE,ROOT,SUB,SBI,ICDDICA,ICDDICB,ICDDICN,ICDDICW,ICDDICS,ICDDICST
+120 NEW ICDDIC0,ICDOLD0,ICDDIC00,ICDCDT,ICDCSY,ICDISF,ICDOUT,ICDVER,ICDX,ICDXP,KEY,INP,INP2,INP1
+121 NEW INPE,ERR,ICDOFND,ICDOSEL,ICDOINP,ICDREDO,ICDOREV,ICDISCD,ICDOUPA,ICDOTIM,ICDOPTR,ICDOVAL
+122 SET (ICDOFND,ICDOSEL,ICDOREV,ICDOUPA,ICDOTIM)=0
SET ICDXP=$$XT^ICDEXLK6($GET(X))
SET ICDOPTR=+($ORDER(DICR(" "),-1))
+123 KILL DLAYGO,DINUM
SET (ICDOINP,ICDX)=$$XT^ICDEXLK6($SELECT($EXTRACT($GET(X),1)'=" ":$$TM^ICDEXLK6($GET(X)),1:$GET(X)))
+124 KILL X,Y,DTOUT,DUOUT
SET ICDCSY=0
SET ROOT=$GET(DIC)
SET FILE=$$FILE^ICDEX(ROOT)
SET ICDOVAL=1
+125 IF "^80^80.1^"'[("^"_FILE_"^")
SET ERR="Invalid File"
GOTO ERR
+126 SET ROOT=$$ROOT^ICDEX(FILE)
+127 IF "^ICD9(^ICD0(^"'[("^"_$EXTRACT(ROOT,2,$LENGTH($GET(ROOT)))_"^")
SET ERR="Invalid Global Root"
GOTO ERR
+128 ; Exact code entered, no subordinates
+129 IF $LENGTH($GET(ICDXP))
IF $GET(DIC(0))'["A"
Begin DoDot:1
+130 NEW ICDTMP
FOR ICDTMP=ICDXP,($TRANSLATE(ICDXP,"""","")_".")
Begin DoDot:2
+131 NEW ICD0,ICD1,ICD2,ICDF
SET ICD0=$TRANSLATE(ICDTMP,"""","")
+132 SET ICD1=$ORDER(@(ROOT_"""BA"","""_ICD0_""",0)"))
+133 SET ICD2=$ORDER(@(ROOT_"""BA"","""_ICD0_""","" "")"),-1)
+134 IF ICD1>0
IF ICD1=ICD2
SET (X,ICDX)="`"_+ICD1
QUIT
+135 SET ICD1=$ORDER(@(ROOT_"""BA"","""_ICD0_" "",0)"))
+136 SET ICD2=$ORDER(@(ROOT_"""BA"","""_ICD0_" "","" "")"),-1)
+137 IF ICD1>0
IF ICD1=ICD2
SET (X,ICDX)="`"_+ICD1
End DoDot:2
if $GET(ICDX)["`"
QUIT
End DoDot:1
+138 IF $GET(ICDX)[";"
Begin DoDot:1
+139 NEW ICD1,ICD2,ICD3
SET ICD1=$PIECE(ICDX,";",1)
SET ICD2=("^"_$PIECE(ICDX,";",2))
+140 if ICD2'=DIC
QUIT
if ICD1'?1N.N
QUIT
SET ICD3=$PIECE($GET(@(ROOT_+ICD1_",0)")),"^",1)
+141 IF $DATA(@(ROOT_+ICD1_",0)"))
SET (X,ICDX)="`"_+ICD1
End DoDot:1
+142 ; System
+143 SET ICDCSY=0
+144 if $LENGTH($GET(ICDSYS))
SET ICDCSY=$GET(ICDSYS)
+145 if '$LENGTH($GET(ICDSYS))&($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDSYS"))))
SET ICDCSY=$GET(^TMP("ICDEXLK",$JOB,"ICDSYS"))
+146 SET ICDCSY=$$SYS^ICDEX($GET(ICDCSY))
+147 ; Date
+148 if $LENGTH($GET(ICDVDT))
SET ICDCDT=$GET(ICDVDT)
+149 if '$LENGTH($GET(ICDVDT))&($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDVDT"))))
SET ICDCDT=$GET(^TMP("ICDEXLK",$JOB,"ICDVDT"))
+150 ; Format
+151 SET ICDOUT=0
if $LENGTH($GET(ICDFMT))
SET ICDOUT=$GET(ICDFMT)
+152 IF $DATA(DDS)
if $DATA(ICDFMT)
SET ICDFMT=1
SET ICDOUT=1
+153 if '$LENGTH($GET(ICDFMT))&($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDFMT"))))
SET ICDOUT=$GET(^TMP("ICDEXLK",$JOB,"ICDFMT"))
+154 if +ICDOUT'>0
SET ICDOUT=1
if +ICDOUT>4
SET ICDOUT=1
+155 if $LENGTH($GET(ICDFMT))!($LENGTH($GET(^TMP("ICDEXLK",$JOB,"ICDFMT"))))
SET ICDISF=1
+156 ; Versioned Lookup
+157 SET ICDVER=$SELECT($GET(ICDCDT)?7N:1,1:0)
if $GET(ICDCDT)'?7N
SET ICDCDT=$$DT^XLFDT
+158 ; Enforce Business Rule for Date
+159 IF ICDVER'>0
if $DATA(^ICDS(+ICDCSY,0))
SET ICDCDT=$$DTBR^ICDEX(ICDCDT,,+($GET(ICDCSY)))
+160 ; Space Bar Return (passed)
+161 IF $DATA(ICDX)
IF $GET(ICDX)=" "
IF DIC(0)'["A"
DO SBR^ICDEXLK2
if +($GET(Y))>0&(X'=ICDX)
SET ICDX=X
if +($GET(Y))>0
GOTO QUIT
KILL Y
+162 ; TMP global
+163 SET SUB=$TRANSLATE(ROOT,"^(","")
KILL ^TMP(SUB,$JOB)
+164 ; Save DIC
+165 SET ICDDICA=$GET(DIC("A"))
SET ICDDICB=$GET(DIC("B"))
SET ICDDICW=$GET(DIC("W"))
+166 SET ICDDICS=""
SET ICDDICST=$$DICS^ICDEXLK6($GET(DIC("S")))
if $LENGTH($GET(ICDDICST))
SET ICDDICS=ICDDICST
+167 SET ICDDICN=$GET(DIC("?N",FILE))
if +ICDDICN'>0
SET ICDDICN=5
+168 SET ICDDIC00=$GET(DIC(0))
SET (ICDDIC0,DIC(0))=$$DIC0^ICDEXLK6($GET(DIC(0)))
+169 if +($GET(ICDISF))>0
KILL DIC("W")
if $DATA(DDS)
KILL DIC("W")
+170 IF $LENGTH($GET(ICDX))'>4
IF ICDX'["."
Begin DoDot:1
+171 if ICDX?3N&($DATA(@(ROOT_"""BA"","""_ICDX_". "")")))
SET ICDX=ICDX_"."
SET ICDXP=ICDXP_"."
+172 if $EXTRACT(ICDX,1)="E"&($EXTRACT(ICDX,2,4)?3N)&($DATA(@(ROOT_"""BA"","""_ICDX_". "")")))
SET ICDX=ICDX_"."
SET ICDXP=ICDXP_"."
+173 if $EXTRACT(ICDX,1)?1U&($EXTRACT(ICDX,2,3)?2N)&($DATA(@(ROOT_"""BA"","""_ICDX_". "")")))
SET ICDX=ICDX_"."
SET ICDXP=ICDXP_"."
End DoDot:1
+174 IF ICDX="?"
IF $GET(DIC(0))'["A"
Begin DoDot:1
+175 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
+176 IF ICDX="??"
IF $GET(DIC(0))'["A"
Begin DoDot:1
+177 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 if $GET(DIC(0))'["A"&($LENGTH($GET(ICDX)))&('$LENGTH($GET(X)))
SET X=ICDX
+2 SET (INPE,ICDOFND)=0
SET ICDOVAL=1
if '$LENGTH($GET(DIC(0)))
SET DIC(0)="AEM"
SET ICDREDO=""
+3 if $LENGTH($GET(DIC(0)))
SET DIC(0)=$TRANSLATE(DIC(0),"CL","")
+4 ; User Input
+5 IF +($GET(ICDOREV))>0
Begin DoDot:1
+6 SET (ICDOFND,ICDOSEL,ICDOREV)=0
KILL X
SET ICDX=""
End DoDot:1
+7 SET (ICDOUPA,ICDOTIM)=0
IF $GET(DIC(0))["A"
Begin DoDot:1
+8 NEW ICDT
SET ICDOVAL=1
SET X=$$INP^ICDEXLK2(FILE,$GET(ICDVER),$GET(ICDCDT))
SET ICDT=$$XT^ICDEXLK6(X)
+9 if ICDT'=X
SET ICDOVAL=0
SET X=ICDT
End DoDot:1
+10 IF '$LENGTH($GET(X))
IF $GET(DIC(0))'["T"
IF +($GET(ICDOUPA))'>1
IF +($GET(ICDOVAL))>0
SET X=""
SET ICDOREV=1
GOTO ERR
+11 IF '$LENGTH($GET(X))
IF +($GET(ICDOVAL))'>0
IF +($GET(ICDOUPA))'>0
IF +($GET(ICDOTIM))'>0
Begin DoDot:1
+12 if ICDOUPA'>0&(ICDOTIM'>0)&('$DATA(DDS))
WRITE " ??"
End DoDot:1
GOTO LKR
+13 if ICDOTIM>0
SET DTOUT=1
if ICDOTIM>0
GOTO ERR
if ICDOUPA>0
SET DUOUT=1
if ICDOUPA>0
GOTO ERR
+14 IF ($GET(DIC(0))["A")
IF ('$LENGTH($GET(X))!(X="^"))
IF $GET(DIC(0))["T"
SET X=""
KILL Y
GOTO LKR
+15 IF $GET(DIC(0))'["A"&($LENGTH($GET(ICDX)))
SET X=$GET(ICDX)
+16 IF $GET(X)["^"
SET DUOUT=""
GOTO ERR
+17 IF '$LENGTH($GET(X))
GOTO ERR
+18 SET X=$$TM^ICDEXLK6(X)
SET INP=X
SET INP1=$EXTRACT(INP,1)
SET INP2=$EXTRACT(INP,2,245)
if INP1="`"&(INP2?1N.N)
SET INPE=1
+19 ; Search #1 - Forced IEN
+20 KILL Y
SET (ICDOUPA,ICDOTIM)=0
IF INPE>0
Begin DoDot:1
+21 DO IEN^ICDEXLK5
SET ICDOUPA=+($GET(ICDOUPA))
SET ICDOTIM=+($GET(ICDOTIM))
+22 if +($GET(Y))>0&($LENGTH($PIECE($GET(Y),"^",2))>0)
SET (ICDX,X)=$PIECE($GET(Y),"^",2)
+23 IF '$LENGTH($GET(X))
IF +($GET(Y))<0
IF $GET(DIC(0))'["A"
Begin DoDot:2
+24 SET (X,ICDX,ICDXP,INP,INP1,INP2)=""
SET Y="-1^No Selection Made"
+25 if $LENGTH($GET(DICR("1")))
SET DICR("1")=""
End DoDot:2
QUIT
+26 IF +($GET(ICDOFND))'>0
IF $GET(DIC(0))["Q"
Begin DoDot:2
+27 if (ICDOPTR'>0)&(ICDOUPA'>0)&(ICDOTIM'>0)&('$DATA(DDS))&(+($GET(ICDOREV))'>0)
WRITE " ??"
+28 if (ICDOPTR>0)&('$DATA(DDS))
WRITE !
End DoDot:2
+29 IF +($GET(ICDOFND))'>0
SET (ICDX,X)=""
SET Y=-1
if $DATA(ICDOINP)
SET ICDOINP=""
End DoDot:1
+30 ; Abort Search #1
+31 IF INPE>0
IF '$LENGTH($GET(X))
IF +($GET(Y))<0
IF $GET(DIC(0))'["A"
GOTO QUIT
+32 IF INPE>0
IF $LENGTH($GET(X))
IF +($GET(Y))>0
IF $PIECE($GET(Y),"^",2)=$GET(X)
GOTO QUIT
+33 IF INPE>0
if ($LENGTH($GET(X))&(+($GET(Y))>0))!($GET(ICDOUPA)=2)
GOTO QUIT
if +($GET(ICDOTIM))>0
GOTO QUIT
+34 IF INPE>0
if (+($GET(ICDOFND))'>0!($GET(ICDOUPA)=1))&($GET(DIC(0))["A")
GOTO LKR
+35 IF INPE>0
if +($GET(ICDOFND))>0&($GET(ICDOSEL)'>0)&($GET(ICDOREV)>0)&($GET(DIC(0))["A")
GOTO LKR
+36 IF $DATA(Y)
if +Y<0
SET X=INP
GOTO QUIT
+37 ; Search #2 - Lookup X
+38 SET (ICDOUPA,ICDOTIM)=0
NEW LOUD
SET LOUD=""
SET ICDX=X
IF +($GET(ICDOFND))'>0
Begin DoDot:1
+39 ; Text Search
+40 if $LENGTH($GET(ICDX))&($LENGTH($GET(ICDX))>1)
SET ICDOFND=$$LK^ICDEXLK3($GET(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
+41 ; Code Search
+42 if $LENGTH($GET(ICDX))&($LENGTH($GET(ICDX))'>1)
SET ICDOFND=$$CD^ICDEXLK3($GET(X),FILE,ICDCDT,ICDCSY,ICDVER,ICDOUT)
+43 SET ICDOFND=+($GET(ICDOFND))
if $LENGTH($GET(ICDX))
SET X=$GET(ICDX)
End DoDot:1
+44 ; Abort Search #2
+45 IF +($GET(ICDOFND))'>0
IF $GET(DIC(0))["Q"
Begin DoDot:1
+46 if (ICDOPTR'>0)&('$DATA(DDS))&(+($GET(ICDOREV))'>0)
WRITE " ??"
End DoDot:1
+47 IF +($GET(ICDOFND))'>0
IF $LENGTH($GET(INP))
IF $EXTRACT(INP,1)'=" "
IF $GET(DIC(0))["A"
KILL ICDX,X,Y,INP,INP1,INP2
GOTO LKR
+48 if +($GET(ICDOFND))'>0
SET X=$GET(INP)
+49 ; Nothing Found
+50 IF +($GET(ICDOFND))'>0
IF $GET(DIC(0))'["T"
Begin DoDot:1
+51 if $GET(DIC(0))["E"&(ICDOPTR'>0)&('$DATA(DDS))
WRITE !," No matches found"
+52 SET X=$SELECT($LENGTH($GET(INP)):INP,1:$GET(X))
SET Y="-1^No matches found"
End DoDot:1
GOTO QUIT
+53 IF +($GET(ICDOFND))'>0
IF $GET(DIC(0))["T"
KILL Y
GOTO LKR
+54 ; Results found
+55 SET (ICDOUPA,ICDOTIM)=0
DO ASK^ICDEXLK2
if $DATA(DTOUT)
GOTO ERR
+56 if ICDOTIM>0
SET DTOUT=1
if ICDOTIM>0
GOTO ERR
+57 IF +($GET(ICDOUPA))>1
SET DUOUT=1
if '$DATA(DDS)
WRITE !
GOTO QUIT
+58 if +($GET(ICDOUPA))=1&(DIC(0)'["A")
GOTO QUIT
+59 if +($GET(ICDOUPA))=1&(DIC(0)["A")
GOTO LKR
+60 IF +($GET(ICDOFND))>0
IF +($GET(ICDOSEL))'>0
IF +($GET(ICDOREV))>0
IF +($GET(ICDOPTR))>0
Begin DoDot:1
+61 SET X=ICDX
if $GET(DIC(0))'["A"
SET (ICDX,INP1,INP2,ICDOINP,X)=""
SET Y="-1^No selection made"
End DoDot:1
GOTO QUIT
+62 IF +($GET(ICDOFND))>0
IF +($GET(ICDOSEL))'>0
IF +($GET(ICDOREV))>0
IF +($GET(ICDOPTR))'>0
Begin DoDot:1
+63 SET (ICDX,INP1,INP2,ICDOINP,X)=""
SET Y="-1^No selection made"
End DoDot:1
if $GET(ICDOUPA)>1!($GET(DIC(0))'["A")
GOTO QUIT
if DIC(0)["A"
GOTO LKR
+64 if +($GET(Y))'>0
GOTO ERR
DO QUIT
+65 QUIT
LKQ ; Quit
+1 QUIT
ERR ; Quit On Error/Time Out
+1 NEW ICDX,ICDY
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 $GET(ICDOTIM)>0
IF $GET(DIC(0))["E"
IF '$DATA(DDS)
WRITE !!,?2,"Try again later"
KILL ERR
+4 IF $GET(ICDOUPA)>0
IF $GET(DIC(0))["E"
KILL ERR
+5 IF $GET(ICDOUPA)>0
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($GET(ICDY),"^",2)))
SET Y=ICDY
SET X=ICDX
+8 IF $EXTRACT(Y,1,2)="-1"
IF +($GET(ICDOFND)>0)
IF +($GET(ICDOSEL)'>0)
SET Y="-1^No Selection Made"
+9 DO QUIT
+10 QUIT
QUIT ; Quit without Error
+1 KILL DUOUT,DTOUT
if ICDOUPA=1
SET DUOUT=1
SET X="^"
SET Y="-1^Search aborted (up-arrow detected)"
+2 if ICDOUPA=2
SET DUOUT=1
SET X="^^"
SET Y="-1^Search aborted (double up-arrow detected)"
+3 if ICDOTIM>0
SET DTOUT=1
SET X=""
SET Y="-1^Search aborted (timed out)"
if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+4 IF $GET(ICDOFND)>0
IF $GET(ICDOREV)>0
IF $GET(ICDOSEL)'>0
SET X=""
SET Y="-1^No Selection Made"
QUIT
+5 IF '$LENGTH(($GET(ICDX)_$GET(X)))
IF +Y<0
IF '$LENGTH($PIECE($GET(Y),"^",2))
IF $GET(DIC(0))'["A"
SET Y="-1^No user input"
QUIT
+6 if +Y>0
DO Y^ICDEXLK2($GET(ROOT),+Y,$GET(ICDCDT))
+7 IF $PIECE($GET(X),"`",2)=$PIECE($GET(Y),"^",1)
IF $LENGTH($PIECE($GET(Y),"^",2))
SET (ICDX,X)=$PIECE($GET(Y),"^",2)
+8 IF +($GET(Y))>0
IF X=$PIECE($GET(Y),"^",1)
IF $LENGTH($PIECE($GET(Y),"^",2))
SET (ICDX,X)=$PIECE($GET(Y),"^",2)
+9 IF X=" "
IF $PIECE($GET(Y),"^",1)>0
IF $LENGTH($PIECE($GET(Y),"^",2))
IF $DATA(@(ROOT_+($PIECE($GET(Y),"^",1))_",0)"))
SET X=$PIECE($GET(Y),"^",2)
+10 DO DICU^ICDEXLK6
IF $DATA(DDS)
if $LENGTH($GET(ICDOINP))&(+Y'>0)
SET X=$GET(ICDOINP)
+11 IF ICDOTIM'>0
IF $GET(DIC(0))["A"
IF $LENGTH($GET(INP))
IF +($GET(Y))>0
IF $LENGTH($PIECE($GET(Y),"^",2))
SET (ICDX,X)=INP
+12 if $LENGTH($GET(ICDX))
SET X=$GET(ICDX)
SET X=$GET(X)
DO RED
+13 QUIT
RED ; Re-Display
+1 if +($GET(Y))'>0
QUIT
if '$LENGTH($PIECE($GET(Y),"^",2))
QUIT
if $GET(FILE)'>0
QUIT
if $DATA(DDS)
QUIT
if $GET(DIC(0))'["E"
QUIT
+2 if ICDOPTR>1
QUIT
NEW CODE,EXP,CC,STA
SET CODE=$PIECE(Y,"^",2)
SET CODE=CODE_$JUSTIFY(" ",(10-$LENGTH($GET(CODE))))
+3 SET CC=""
if FILE=80
SET CC=$$VCC^ICDEX(+Y,$GET(ICDCDT))
+4 SET CC=$SELECT(CC="1":" (CC)",CC="2":" (Major CC)",1:"")
+5 SET STA=$ORDER(@(ROOT_+Y_",66,""B"","_(+($GET(ICDCDT))+.000001)_")"),-1)
+6 SET STA=$ORDER(@(ROOT_+Y_",66,""B"","_+STA_","" "")"),-1)
+7 SET STA=$PIECE($GET(@(ROOT_+Y_",66,"_+STA_",0)")),"^",2)
+8 SET STA=$SELECT($GET(STA)?1N&(+$GET(STA)'>0):" (Inactive)",$GET(STA)'?1N&(+$GET(STA)'>0):" (Pending)",1:"")
+9 if $GET(ICDFMT)=2!($GET(ICDFMT)=4)
SET EXP=$$VLT^ICDEX(FILE,+Y,$GET(ICDCDT))
+10 if $GET(ICDFMT)=1!($GET(ICDFMT)=3)!($GET(ICDFMT)="")
SET EXP=$$VST^ICDEX(FILE,+Y,$GET(ICDCDT))
+11 if $LENGTH($GET(CODE))&($LENGTH($GET(EXP)))&($DATA(DPP(1)))
WRITE !,?5
if $LENGTH($GET(CODE))&($LENGTH($GET(EXP)))
WRITE " ",$GET(CODE),$GET(EXP),$GET(CC),$GET(STA)
+12 QUIT
CLR ; Clear Environment
+1 KILL DDS,DICR
NEW ICDTEST,DPP,DR
+2 QUIT
