ICDCODLK ;KUM - LOOK UP ICD-10 PROCEDURE CODE;12/07/2011
;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103
;
; ICDDATE is EFFECTIVE DATE that passed from Calling Routine
;
EN ; Initialize variables
W @IOF D LOOK
G EXIT
LOOK ; Look-up term
W !! K X S ICDPRC="" D ASK K DIC
AGAIN ; Try again?
W !,"Try another" S %=$S(+($$X):1,1:2)
D YN^DICN I %=-1!(%=2) Q
I '% W !!,"You have searched for a string in the Lexicon, do you want to" G AGAIN
I +($$X)&(%=1) G LOOK
I '+($$X)&(%=1) G LOOK
I (+($$X)&(%=2))!('+($$X)&(%=1)) Q
G LOOK Q
ASK ; Get user input
N DUOUT,DTOUT,DIR,DIRUT,DIROUT,ICDDATE1,ICDT1,ICDX,ICDXX,ICDPRT
I $G(ICDXX1) S ICDPRT="Enter Operation/Procedure (ICD 10):"
I $G(ICDDATE)="" D EFFDATE^ICDDRGM G EXIT:$D(DUOUT),EXIT:$D(DTOUT)
I $G(ICDDATE)'="" S ICDDATE1=ICDDATE
S ICDRES=1
I $G(ICDPRC)="" S ICDPRC="" D GICDPRC
I ICDPRC="" S ICDX=0
I ICDPRC'="" S ICDX=1
I ICDPRC'["*" G ASKCONT1
I ICDPRC["*" S ICDPRC=$P(ICDPRC,"*",1) ; D GICDPRC
;S ICDPRC="",ICDX=0
F ICDT1=1:1 Q:($L($G(ICDPRC))>=7)!(ICDPRC["^")!(ICDRES=0) D
. S ICDRES=$$PCSDIG^LEX10CS(ICDPRC,ICDDATE1)
. I ICDRES=1 D
. . D LOAD
. . D PRCDESCB
. . D PRCDESC
. . S X=$$SEL^ICDSELPS(.ICDS,5)
. . I X'=-1 S ICDPRC=ICDPRC_$P(X,"^",1)
. . S ICDX=1
. . D GICDPRC
. I ICDRES'=1 W !,ICDPRC_" IS NOT A VALID ICD PROCEDURE CODE" G EXIT
I $G(ICDXX1),ICDPRC["^^" S ICDPRC=$E(ICDPRC,1,$L(ICDPRC)-2)
I '$G(ICDXX1),ICDPRC["^" G EXIT
ASKCONT1 ; Tag to continue when ICDPRC doesnt have *
I $L($G(ICDPRC))=7&(ICDPRC'["^") D
. S ICDRES=$$PCSDIG^LEX10CS(ICDPRC,ICDDATE1)
. I ICDRES=1 D
. . S ICDPDESC=LEXPCDAT("PCSDESC")
. . S ICDPSTS=LEXPCDAT("STATUS")
. . D PRCDESCB
. . D PRCDESC
. . W !!,ICDPRC,?15,ICDPDESC,! ;add printing of descript disclaimer msg
. . I $G(ICDXX1) S ICDXX=+$$CODEN^ICDEX(ICDPRC,80.1)
. . I '$P(ICDPSTS,"^",1) W " **CODE INACTIVE" I $P(ICDPSTS,"^",2)'="" S Y=$P(ICDPSTS,"^",2) D DD^%DT W " AS OF ",Y," **",!
. I ICDRES'=1 D
. . W !,ICDPRC_" IS NOT A VALID PROCEDURE CODE."
I $L($G(ICDPRC))=7&(ICDPRC'["^")&(ICDRES=1)&('$P($G(ICDPSTS),"^",1)) G ASKCNT2
I $L($G(ICDPRC))'=7,ICDPRC'="",ICDPRC'["^" S ICDRES=0 W !,ICDPRC_" IS NOT A VALID ICD PROCEDURE CODE"_$S($G(ICDXX1):". IGNORING THE PROCEDURE CODE",1:".")
S (X,Y)=""
I ICDPRC["^" S X="^",Y=""
S:$G(ICDXX) (X,Y)=ICDXX
I $G(ICDXX1) D
. I (ICDRES'=1)!(($L($G(ICDPRC))'=7)&(ICDPRC'="")&(ICDPRC'["^")) S X=0 R ICDQWE:300 K ICDQWE Q
. I ICDPRC'="" D
. . W !,"OK? (Yes/No) " S %=1
. . D YN^DICN
. . I %'=1 S X=0
ASKCNT2 K ICDDATE1,ICDRES,ICDPDESC,ICDPSTS,LEXPCDAT,ICDPRCT,ICDPRCX,ICDLEX
Q
INPHLP ; Look-up help
Q:X["^^" "^^" Q:X["^" "^"
W !," Enter a ""free text"" term. Best results occur using one to "
W !," three full or partial words without a suffix"
W:$G(X)'["??" "."
W:$G(X)["??" " (i.e., ""DIABETES"","
W:$G(X)["??" !," ""DIAB MELL"",""DIAB MELL INSUL"")"
W !," or "
W !," Enter a classification code (ICD/CPT etc) to find the single "
W !," term associated with the code."
W:$G(X)["??" " Example, a lookup of code 239.0 "
W:$G(X)["??" !," returns one and only one term, that is the preferred "
W:$G(X)["??" !," term for the code 239.0, ""Neoplasm of unspecified nature "
W:$G(X)["??" !," of digestive system"""
W !," or "
W !," Enter a classification code (ICD/CPT etc) followed by a plus"
W !," sign (+) to retrieve all terms associated with the code."
W:$G(X)["??" " Example,"
W:$G(X)["??" !," a lookup of 239.0+ returns all terms that are linked to the "
W:$G(X)["??" !," code 239.0."
Q
EXIT ; Clean up environment and quit
K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,ICDLEX,ICDPRCX,ICDPRCT
Q
X(ICDLEX) ; Evaluate X
Q:$L($G(X)) 1 Q 0
Y(ICDLEX) ; Evaluate Y
Q:+($G(Y))>1 1 Q 0
LOAD ; Load data
K ICDS
S ICDLOAD1=1
S ICDLOADP=""
S ICDLOAD="" F S ICDLOAD=$O(LEXPCDAT("NEXLEV",ICDLOAD)) Q:ICDLOAD="" D
. I ICDLOAD'=ICDLOADP D
. . S ICDS(ICDLOAD1,0)=ICDLOAD
. . S ICDS(ICDLOAD1,"LEX")=LEXPCDAT("NEXLEV",ICDLOAD,"DESC")
. . S ICDLOAD1=ICDLOAD1+1
. . S ICDLOADP=ICDLOAD
K ICDLOAD1,ICDLOADP,ICDLOAD
Q
PRCDESC ; Display Descriptions of each character
S ICDPRCT=ICDPRC,ICDPRCT1="",ICDX=0
F ICDTEMP=1:1 Q:ICDPRCT="" D
. S ICDC=$E(ICDPRCT,1,1)
. S ICDRES=$$PCSDIG^LEX10CS(ICDPRCT1,ICDDATE1)
. I ICDRES'=1 D
. . S ICDPRCT=""
. I ICDRES=1 D
. . S ICDLOAD="" F S ICDLOAD=$O(LEXPCDAT("NEXLEV",ICDLOAD)) Q:ICDLOAD=""!(ICDLOAD=ICDC)
. . I ICDLOAD=ICDC W ICDC_" - "_LEXPCDAT("NEXLEV",ICDLOAD,"DESC") W !
. . S ICDPRCT=$E(ICDPRCT,2,$L(ICDPRCT))
. . S ICDPRCT1=ICDPRCT1_ICDC
K ICDTEMP,ICDPRCT,ICDPRCT1,ICDC,ICDLOAD
Q
GICDPRC ; Get ICDPRC from User
S ICDPRCX="" S ICDPRCT=""
AA ; Read character by character
W @IOF
I $G(ICDX)=1 D PRCDESC W !
W "Press '*' to display available choices for next character or '^' to exit."
I $G(ICDPRT)="" S ICDPRT="ICD-10 Procedure code:"
W !,ICDPRT_ICDPRC S ICDREAD="R *ICDA:300 I '$T S ICDA=13"
X ICDREAD
; Show choices on "*"
I ICDA=42 G BB
; Exit when Enter and is full length else ignore
;I ICDA=13 G:$L(ICDPRC)>6 BB S ICDX=1 G AA
I ICDA=13,$G(ICDXX1) S:$L(ICDPRC)'=7 ICDPRC=ICDPRC_$C(94)_$C(94) G BB
I ICDA=13,'$G(ICDXX1) G:$L(ICDPRC)>6 BB S ICDX=1 G AA
; If Backspace is entered, truncate last character and display the ICDPRC
I ICDA=127 S ICDPRC=$E(ICDPRC,1,$L(ICDPRC)-1) S ICDX=1 G AA
; If ^ is entered, exit
I ICDA=94 S ICDPRC=ICDPRC_$C(ICDA) G BB
; check for valid characters
I ICDA<48!((ICDA>57)&(ICDA<65))!((ICDA>90)&(ICDA<97))!(ICDA>122) G AA
; Any character other than Enter or Backspace
I ICDA'=127 D
. S ICDPRC=ICDPRC_$C(ICDA)
. S ICDX=1 G AA
BB ;Exit
W !
K ICDA,ICDREAD
Q
PRCDESCB ; Call Before PRCDESC
W @IOF
W "Press '*' to display available choices for next character or '^' to exit."
W !,"ICD-10 Procedure code:"_ICDPRC
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDCODLK 5961 printed Sep 23, 2025@19:26:04 Page 2
ICDCODLK ;KUM - LOOK UP ICD-10 PROCEDURE CODE;12/07/2011
+1 ;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103
+2 ;
+3 ; ICDDATE is EFFECTIVE DATE that passed from Calling Routine
+4 ;
EN ; Initialize variables
+1 WRITE @IOF
DO LOOK
+2 GOTO EXIT
LOOK ; Look-up term
+1 WRITE !!
KILL X
SET ICDPRC=""
DO ASK
KILL DIC
AGAIN ; Try again?
+1 WRITE !,"Try another"
SET %=$SELECT(+($$X):1,1:2)
+2 DO YN^DICN
IF %=-1!(%=2)
QUIT
+3 IF '%
WRITE !!,"You have searched for a string in the Lexicon, do you want to"
GOTO AGAIN
+4 IF +($$X)&(%=1)
GOTO LOOK
+5 IF '+($$X)&(%=1)
GOTO LOOK
+6 IF (+($$X)&(%=2))!('+($$X)&(%=1))
QUIT
+7 GOTO LOOK
QUIT
ASK ; Get user input
+1 NEW DUOUT,DTOUT,DIR,DIRUT,DIROUT,ICDDATE1,ICDT1,ICDX,ICDXX,ICDPRT
+2 IF $GET(ICDXX1)
SET ICDPRT="Enter Operation/Procedure (ICD 10):"
+3 IF $GET(ICDDATE)=""
DO EFFDATE^ICDDRGM
if $DATA(DUOUT)
GOTO EXIT
if $DATA(DTOUT)
GOTO EXIT
+4 IF $GET(ICDDATE)'=""
SET ICDDATE1=ICDDATE
+5 SET ICDRES=1
+6 IF $GET(ICDPRC)=""
SET ICDPRC=""
DO GICDPRC
+7 IF ICDPRC=""
SET ICDX=0
+8 IF ICDPRC'=""
SET ICDX=1
+9 IF ICDPRC'["*"
GOTO ASKCONT1
+10 ; D GICDPRC
IF ICDPRC["*"
SET ICDPRC=$PIECE(ICDPRC,"*",1)
+11 ;S ICDPRC="",ICDX=0
+12 FOR ICDT1=1:1
if ($LENGTH($GET(ICDPRC))>=7)!(ICDPRC["^")!(ICDRES=0)
QUIT
Begin DoDot:1
+13 SET ICDRES=$$PCSDIG^LEX10CS(ICDPRC,ICDDATE1)
+14 IF ICDRES=1
Begin DoDot:2
+15 DO LOAD
+16 DO PRCDESCB
+17 DO PRCDESC
+18 SET X=$$SEL^ICDSELPS(.ICDS,5)
+19 IF X'=-1
SET ICDPRC=ICDPRC_$PIECE(X,"^",1)
+20 SET ICDX=1
+21 DO GICDPRC
End DoDot:2
+22 IF ICDRES'=1
WRITE !,ICDPRC_" IS NOT A VALID ICD PROCEDURE CODE"
GOTO EXIT
End DoDot:1
+23 IF $GET(ICDXX1)
IF ICDPRC["^^"
SET ICDPRC=$EXTRACT(ICDPRC,1,$LENGTH(ICDPRC)-2)
+24 IF '$GET(ICDXX1)
IF ICDPRC["^"
GOTO EXIT
ASKCONT1 ; Tag to continue when ICDPRC doesnt have *
+1 IF $LENGTH($GET(ICDPRC))=7&(ICDPRC'["^")
Begin DoDot:1
+2 SET ICDRES=$$PCSDIG^LEX10CS(ICDPRC,ICDDATE1)
+3 IF ICDRES=1
Begin DoDot:2
+4 SET ICDPDESC=LEXPCDAT("PCSDESC")
+5 SET ICDPSTS=LEXPCDAT("STATUS")
+6 DO PRCDESCB
+7 DO PRCDESC
+8 ;add printing of descript disclaimer msg
WRITE !!,ICDPRC,?15,ICDPDESC,!
+9 IF $GET(ICDXX1)
SET ICDXX=+$$CODEN^ICDEX(ICDPRC,80.1)
+10 IF '$PIECE(ICDPSTS,"^",1)
WRITE " **CODE INACTIVE"
IF $PIECE(ICDPSTS,"^",2)'=""
SET Y=$PIECE(ICDPSTS,"^",2)
DO DD^%DT
WRITE " AS OF ",Y," **",!
End DoDot:2
+11 IF ICDRES'=1
Begin DoDot:2
+12 WRITE !,ICDPRC_" IS NOT A VALID PROCEDURE CODE."
End DoDot:2
End DoDot:1
+13 IF $LENGTH($GET(ICDPRC))=7&(ICDPRC'["^")&(ICDRES=1)&('$PIECE($GET(ICDPSTS),"^",1))
GOTO ASKCNT2
+14 IF $LENGTH($GET(ICDPRC))'=7
IF ICDPRC'=""
IF ICDPRC'["^"
SET ICDRES=0
WRITE !,ICDPRC_" IS NOT A VALID ICD PROCEDURE CODE"_$SELECT($GET(ICDXX1):". IGNORING THE PROCEDURE CODE",1:".")
+15 SET (X,Y)=""
+16 IF ICDPRC["^"
SET X="^"
SET Y=""
+17 if $GET(ICDXX)
SET (X,Y)=ICDXX
+18 IF $GET(ICDXX1)
Begin DoDot:1
+19 IF (ICDRES'=1)!(($LENGTH($GET(ICDPRC))'=7)&(ICDPRC'="")&(ICDPRC'["^"))
SET X=0
READ ICDQWE:300
KILL ICDQWE
QUIT
+20 IF ICDPRC'=""
Begin DoDot:2
+21 WRITE !,"OK? (Yes/No) "
SET %=1
+22 DO YN^DICN
+23 IF %'=1
SET X=0
End DoDot:2
End DoDot:1
ASKCNT2 KILL ICDDATE1,ICDRES,ICDPDESC,ICDPSTS,LEXPCDAT,ICDPRCT,ICDPRCX,ICDLEX
+1 QUIT
INPHLP ; Look-up help
+1 if X["^^"
QUIT "^^"
if X["^"
QUIT "^"
+2 WRITE !," Enter a ""free text"" term. Best results occur using one to "
+3 WRITE !," three full or partial words without a suffix"
+4 if $GET(X)'["??"
WRITE "."
+5 if $GET(X)["??"
WRITE " (i.e., ""DIABETES"","
+6 if $GET(X)["??"
WRITE !," ""DIAB MELL"",""DIAB MELL INSUL"")"
+7 WRITE !," or "
+8 WRITE !," Enter a classification code (ICD/CPT etc) to find the single "
+9 WRITE !," term associated with the code."
+10 if $GET(X)["??"
WRITE " Example, a lookup of code 239.0 "
+11 if $GET(X)["??"
WRITE !," returns one and only one term, that is the preferred "
+12 if $GET(X)["??"
WRITE !," term for the code 239.0, ""Neoplasm of unspecified nature "
+13 if $GET(X)["??"
WRITE !," of digestive system"""
+14 WRITE !," or "
+15 WRITE !," Enter a classification code (ICD/CPT etc) followed by a plus"
+16 WRITE !," sign (+) to retrieve all terms associated with the code."
+17 if $GET(X)["??"
WRITE " Example,"
+18 if $GET(X)["??"
WRITE !," a lookup of 239.0+ returns all terms that are linked to the "
+19 if $GET(X)["??"
WRITE !," code 239.0."
+20 QUIT
EXIT ; Clean up environment and quit
+1 KILL %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,ICDLEX,ICDPRCX,ICDPRCT
+2 QUIT
X(ICDLEX) ; Evaluate X
+1 if $LENGTH($GET(X))
QUIT 1
QUIT 0
Y(ICDLEX) ; Evaluate Y
+1 if +($GET(Y))>1
QUIT 1
QUIT 0
LOAD ; Load data
+1 KILL ICDS
+2 SET ICDLOAD1=1
+3 SET ICDLOADP=""
+4 SET ICDLOAD=""
FOR
SET ICDLOAD=$ORDER(LEXPCDAT("NEXLEV",ICDLOAD))
if ICDLOAD=""
QUIT
Begin DoDot:1
+5 IF ICDLOAD'=ICDLOADP
Begin DoDot:2
+6 SET ICDS(ICDLOAD1,0)=ICDLOAD
+7 SET ICDS(ICDLOAD1,"LEX")=LEXPCDAT("NEXLEV",ICDLOAD,"DESC")
+8 SET ICDLOAD1=ICDLOAD1+1
+9 SET ICDLOADP=ICDLOAD
End DoDot:2
End DoDot:1
+10 KILL ICDLOAD1,ICDLOADP,ICDLOAD
+11 QUIT
PRCDESC ; Display Descriptions of each character
+1 SET ICDPRCT=ICDPRC
SET ICDPRCT1=""
SET ICDX=0
+2 FOR ICDTEMP=1:1
if ICDPRCT=""
QUIT
Begin DoDot:1
+3 SET ICDC=$EXTRACT(ICDPRCT,1,1)
+4 SET ICDRES=$$PCSDIG^LEX10CS(ICDPRCT1,ICDDATE1)
+5 IF ICDRES'=1
Begin DoDot:2
+6 SET ICDPRCT=""
End DoDot:2
+7 IF ICDRES=1
Begin DoDot:2
+8 SET ICDLOAD=""
FOR
SET ICDLOAD=$ORDER(LEXPCDAT("NEXLEV",ICDLOAD))
if ICDLOAD=""!(ICDLOAD=ICDC)
QUIT
+9 IF ICDLOAD=ICDC
WRITE ICDC_" - "_LEXPCDAT("NEXLEV",ICDLOAD,"DESC")
WRITE !
+10 SET ICDPRCT=$EXTRACT(ICDPRCT,2,$LENGTH(ICDPRCT))
+11 SET ICDPRCT1=ICDPRCT1_ICDC
End DoDot:2
End DoDot:1
+12 KILL ICDTEMP,ICDPRCT,ICDPRCT1,ICDC,ICDLOAD
+13 QUIT
GICDPRC ; Get ICDPRC from User
+1 SET ICDPRCX=""
SET ICDPRCT=""
AA ; Read character by character
+1 WRITE @IOF
+2 IF $GET(ICDX)=1
DO PRCDESC
WRITE !
+3 WRITE "Press '*' to display available choices for next character or '^' to exit."
+4 IF $GET(ICDPRT)=""
SET ICDPRT="ICD-10 Procedure code:"
+5 WRITE !,ICDPRT_ICDPRC
SET ICDREAD="R *ICDA:300 I '$T S ICDA=13"
+6 XECUTE ICDREAD
+7 ; Show choices on "*"
+8 IF ICDA=42
GOTO BB
+9 ; Exit when Enter and is full length else ignore
+10 ;I ICDA=13 G:$L(ICDPRC)>6 BB S ICDX=1 G AA
+11 IF ICDA=13
IF $GET(ICDXX1)
if $LENGTH(ICDPRC)'=7
SET ICDPRC=ICDPRC_$CHAR(94)_$CHAR(94)
GOTO BB
+12 IF ICDA=13
IF '$GET(ICDXX1)
if $LENGTH(ICDPRC)>6
GOTO BB
SET ICDX=1
GOTO AA
+13 ; If Backspace is entered, truncate last character and display the ICDPRC
+14 IF ICDA=127
SET ICDPRC=$EXTRACT(ICDPRC,1,$LENGTH(ICDPRC)-1)
SET ICDX=1
GOTO AA
+15 ; If ^ is entered, exit
+16 IF ICDA=94
SET ICDPRC=ICDPRC_$CHAR(ICDA)
GOTO BB
+17 ; check for valid characters
+18 IF ICDA<48!((ICDA>57)&(ICDA<65))!((ICDA>90)&(ICDA<97))!(ICDA>122)
GOTO AA
+19 ; Any character other than Enter or Backspace
+20 IF ICDA'=127
Begin DoDot:1
+21 SET ICDPRC=ICDPRC_$CHAR(ICDA)
+22 SET ICDX=1
GOTO AA
End DoDot:1
BB ;Exit
+1 WRITE !
+2 KILL ICDA,ICDREAD
+3 QUIT
PRCDESCB ; Call Before PRCDESC
+1 WRITE @IOF
+2 WRITE "Press '*' to display available choices for next character or '^' to exit."
+3 WRITE !,"ICD-10 Procedure code:"_ICDPRC
+4 WRITE !
+5 QUIT
