DGICP ;AL/AAS/PLT KUM,WIOFO/PMK - LOOK UP ICD-10 PROCEDURE CODE ;04/15/2015 1:17 PM
;;5.3;Registration;**850,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
;This routine does not conform to Standard & Conventions routine naming
;conventions since package routine names of DG_I* (with the exceptions
;of Kernel, VA FileMan, and routines created to support the INIT
;process) should not be used. The SACC has granted an exemption for
;this routine.
;
;copied from ICDCODLK
;
; ICDDATE is EFFDATE variable that is passed in from Calling Routine
;
EN ; Initialize variables
W ! ;@IOF
D LOOK
G EXIT
LOOK ; Look-up term
N X
W !! S X="" D ASK K DIC
AGAIN ; Try again?
Q
;
ASK ; Get user input
N DIR,DIRUT,DIROUT,ICDDATE,ICDDATE1,ICDT1,ICDX,DGXX
Q:X="?BAD"!(X["^")
I X["?" D K X,Y Q ; - added here for calls that bypass ^DGICDGT
. N TAG,FORMAT
. S TAG=$S(X["???":"P3^DGICDGT",X["??":"P2^DGICDGT",X["?":"P1^DGICDGT",1:"P1^DGICDGT")
. D @TAG
. Q
S ICDDATE=$G(EFFDATE)
I $G(ICDDATE)'="" S ICDDATE1=ICDDATE
S ICDPRC=$G(X),ICDX=0
S ICDPRC=$$TR(X)
S ICDRES=1
F ICDT1=1:1 Q:($L($G(ICDPRC))>6)!(ICDPRC["^")!(ICDRES=0) D
. S ICDRES=$$PCSDIG^LEX10CS(ICDPRC,$G(ICDDATE1))
. I ICDRES=1 D
. . D LOAD
. . D PRCDESCB
. . D PRCDESC
. . S X=$$SEL^DGICPL(.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 ICDPRC["^" G EXIT
I $L($G(ICDPRC))=7 D
. S ICDRES=$$PCSDIG^LEX10CS(ICDPRC,$G(ICDDATE1))
. I ICDRES=1 D
. . S ICDPDESC=LEXPCDAT("PCSDESC")
. . S ICDPSTS=LEXPCDAT("STATUS")
. . D PRCDESCB
. . D PRCDESC
. . W !," ",ICDPDESC
. . S DGXX=+$$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 VALID"
I $L($G(ICDPRC))>7 W !,ICDPRC_" IS NOT A VALID ICD PROCEDURE CODE"
K X,Y
S:$G(DGXX) (X,Y)=DGXX
K ICDDATE1,ICDPRC,ICDRES,ICDPDESC,ICDPSTS,LEXPCDAT
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,LEX,X,Y,ICDLEX
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 dummy data
K ICDS
S ICDLOAD1=1
S PICDLOAD=""
S ICDLOAD="" F S ICDLOAD=$O(LEXPCDAT("NEXLEV",ICDLOAD)) Q:ICDLOAD="" D
. I ICDLOAD'=PICDLOAD D
. . S ICDS(ICDLOAD1,0)=ICDLOAD
. . S ICDS(ICDLOAD1,"LEX")=LEXPCDAT("NEXLEV",ICDLOAD,"DESC")
. . S ICDLOAD1=ICDLOAD1+1
. . S PICDLOAD=ICDLOAD
K ICDLOAD1,PICDLOAD,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,$G(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
AA ; Read character by character
W !
I $G(ICDX)=1 D PRCDESC W !
W "Press '*' to display available choices for next character or '^' to exit."
W !,"ICD-10 Procedure code:"_ICDPRC
I $L(ICDPRC)>6 G BB
S ICDA=$$READ^XGF(1,300) S ICDA=$S($G(DTOUT):13,1:$A(ICDA))
; 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 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 G:$L(ICDPRC)>6 BB G AA
. S ICDPRC=ICDPRC_$$TR($C(ICDA))
. S ICDX=1
BB ;Exit
W !
K ICDA
Q
PRCDESCB ; Call Before PRCDESC
W !,"ICD-10 Procedure code:"_ICDPRC
W !
Q
;
TR(X) ;
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGICP 5313 printed Oct 16, 2024@18:44:33 Page 2
DGICP ;AL/AAS/PLT KUM,WIOFO/PMK - LOOK UP ICD-10 PROCEDURE CODE ;04/15/2015 1:17 PM
+1 ;;5.3;Registration;**850,884**;Aug 13, 1993;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;This routine does not conform to Standard & Conventions routine naming
+5 ;conventions since package routine names of DG_I* (with the exceptions
+6 ;of Kernel, VA FileMan, and routines created to support the INIT
+7 ;process) should not be used. The SACC has granted an exemption for
+8 ;this routine.
+9 ;
+10 ;copied from ICDCODLK
+11 ;
+12 ; ICDDATE is EFFDATE variable that is passed in from Calling Routine
+13 ;
EN ; Initialize variables
+1 ;@IOF
WRITE !
+2 DO LOOK
+3 GOTO EXIT
LOOK ; Look-up term
+1 NEW X
+2 WRITE !!
SET X=""
DO ASK
KILL DIC
AGAIN ; Try again?
+1 QUIT
+2 ;
ASK ; Get user input
+1 NEW DIR,DIRUT,DIROUT,ICDDATE,ICDDATE1,ICDT1,ICDX,DGXX
+2 if X="?BAD"!(X["^")
QUIT
+3 ; - added here for calls that bypass ^DGICDGT
IF X["?"
Begin DoDot:1
+4 NEW TAG,FORMAT
+5 SET TAG=$SELECT(X["???":"P3^DGICDGT",X["??":"P2^DGICDGT",X["?":"P1^DGICDGT",1:"P1^DGICDGT")
+6 DO @TAG
+7 QUIT
End DoDot:1
KILL X,Y
QUIT
+8 SET ICDDATE=$GET(EFFDATE)
+9 IF $GET(ICDDATE)'=""
SET ICDDATE1=ICDDATE
+10 SET ICDPRC=$GET(X)
SET ICDX=0
+11 SET ICDPRC=$$TR(X)
+12 SET ICDRES=1
+13 FOR ICDT1=1:1
if ($LENGTH($GET(ICDPRC))>6)!(ICDPRC["^")!(ICDRES=0)
QUIT
Begin DoDot:1
+14 SET ICDRES=$$PCSDIG^LEX10CS(ICDPRC,$GET(ICDDATE1))
+15 IF ICDRES=1
Begin DoDot:2
+16 DO LOAD
+17 DO PRCDESCB
+18 DO PRCDESC
+19 SET X=$$SEL^DGICPL(.ICDS,5)
+20 IF X'=-1
SET ICDPRC=ICDPRC_$PIECE(X,"^",1)
+21 SET ICDX=1
+22 DO GICDPRC
End DoDot:2
+23 IF ICDRES'=1
WRITE !,ICDPRC_" IS NOT A VALID ICD PROCEDURE CODE"
GOTO EXIT
End DoDot:1
+24 IF ICDPRC["^"
GOTO EXIT
+25 IF $LENGTH($GET(ICDPRC))=7
Begin DoDot:1
+26 SET ICDRES=$$PCSDIG^LEX10CS(ICDPRC,$GET(ICDDATE1))
+27 IF ICDRES=1
Begin DoDot:2
+28 SET ICDPDESC=LEXPCDAT("PCSDESC")
+29 SET ICDPSTS=LEXPCDAT("STATUS")
+30 DO PRCDESCB
+31 DO PRCDESC
+32 WRITE !," ",ICDPDESC
+33 SET DGXX=+$$CODEN^ICDEX(ICDPRC,80.1)
+34 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
+35 IF ICDRES'=1
Begin DoDot:2
+36 WRITE !,ICDPRC_" IS NOT VALID"
End DoDot:2
End DoDot:1
+37 IF $LENGTH($GET(ICDPRC))>7
WRITE !,ICDPRC_" IS NOT A VALID ICD PROCEDURE CODE"
+38 KILL X,Y
+39 if $GET(DGXX)
SET (X,Y)=DGXX
+40 KILL ICDDATE1,ICDPRC,ICDRES,ICDPDESC,ICDPSTS,LEXPCDAT
+41 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,LEX,X,Y,ICDLEX
+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 dummy data
+1 KILL ICDS
+2 SET ICDLOAD1=1
+3 SET PICDLOAD=""
+4 SET ICDLOAD=""
FOR
SET ICDLOAD=$ORDER(LEXPCDAT("NEXLEV",ICDLOAD))
if ICDLOAD=""
QUIT
Begin DoDot:1
+5 IF ICDLOAD'=PICDLOAD
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 PICDLOAD=ICDLOAD
End DoDot:2
End DoDot:1
+10 KILL ICDLOAD1,PICDLOAD,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,$GET(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
AA ; Read character by character
+1 WRITE !
+2 IF $GET(ICDX)=1
DO PRCDESC
WRITE !
+3 WRITE "Press '*' to display available choices for next character or '^' to exit."
+4 WRITE !,"ICD-10 Procedure code:"_ICDPRC
+5 IF $LENGTH(ICDPRC)>6
GOTO BB
+6 SET ICDA=$$READ^XGF(1,300)
SET ICDA=$SELECT($GET(DTOUT):13,1:$ASCII(ICDA))
+7 ; show choices on "*"
+8 IF ICDA=42
GOTO BB
+9 ; Exit when Enter and is full length else ignore
+10 IF ICDA=13
if $LENGTH(ICDPRC)>6
GOTO BB
GOTO AA
+11 ; If Backspace is entered, truncate last character and display the ICDPRC
+12 IF ICDA=127
SET ICDPRC=$EXTRACT(ICDPRC,1,$LENGTH(ICDPRC)-1)
SET ICDX=1
GOTO AA
+13 ; If ^ is entered, exit
+14 IF ICDA=94
SET ICDPRC=ICDPRC_$CHAR(ICDA)
GOTO BB
+15 ;
+16 ; check for valid characters
+17 IF ICDA<48!((ICDA>57)&(ICDA<65))!((ICDA>90)&(ICDA<97))!(ICDA>122)
GOTO AA
+18 ;
+19 ; Any character other than Enter or Backspace
+20 IF ICDA'=127
Begin DoDot:1
+21 SET ICDPRC=ICDPRC_$$TR($CHAR(ICDA))
+22 SET ICDX=1
End DoDot:1
if $LENGTH(ICDPRC)>6
GOTO BB
GOTO AA
BB ;Exit
+1 WRITE !
+2 KILL ICDA
+3 QUIT
PRCDESCB ; Call Before PRCDESC
+1 WRITE !,"ICD-10 Procedure code:"_ICDPRC
+2 WRITE !
+3 QUIT
+4 ;
TR(X) ;
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT X
