Routine: DGICP

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?

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

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."

EXIT ; Clean up environment and quit

 K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEX,X,Y,ICDLEX

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

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

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

PRCDESCB ; Call Before PRCDESC

 W !,"ICD-10 Procedure code:"_ICDPRC

W !

TR(X) ;

 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

Q X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGICP   5313     printed  Mar 13, 2025@21:48:29                                                                                                                                                                                                       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

DGICP.m