- 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 Feb 18, 2025@23:16:24 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
