PXDSLK ;ALB/RBD - COPIED FROM ICDLOOK TO LOOK UP ICD-10 DX CODE;01 May 2014 1:39 PM
;;1.0;PCE PATIENT CARE ENCOUNTER;**199**;Aug 12, 1996;Build 51
;;
;
; Reference to CODEC^ICDEX supported by ICR #5747
; Reference to CODEN^ICDEX supported by ICR #5747
; Reference to ^DISV supported by ICR #510
;
; PXDATE is the EFFECTIVE DATE that is passed from the Calling Routine
; PXAGAIN controls the "Try Another" prompt; 0 = do not prompt
; PXDEF may be passed in as the default Dx value to be prompted
; PXDXASK if present will be used as the prompt when asking for the Dx code
;
EN ; Initialize variables
D HOME^%ZIS S DT=$$DT^XLFDT D LOOK
G EXIT
LOOK ; Look-up term
S PXXX=-1 D ASK K DIC
AGAIN ; Try again?
Q:$G(PXAGAIN)=0
W !,"Try another" S %=$S(+($$X):1,1:2)
D YN^DICN I %=-1!(%=2) Q
I '% W !!,"You have searched for an ICD-10 diagnosis code, do you want to" G AGAIN
I +($$X)&(%=1) K PXDEF G LOOK
I '+($$X)&(%=1) G LOOK
I (+($$X)&(%=2))!('+($$X)&(%=1)) Q
G LOOK Q
ASK ; Get user input
N ARY,DIR,DIRUT,DIROUT,PXSYS,PXO,PXY,RES,Y
K %DT,II,PXDT,PXMAX,PXNUMB,PXY
I $G(PXDATE)'="" S Y=PXDATE
I $G(PXDATE)="" K %DT S %DT="AEX",%DT("A")="Date of Interest? " D ^%DT K %DT I Y<0 G EXIT
S PXDT=Y,PXSYS=$P($P($$ACTDT^PXDXUTL(PXDT),U,3),"-",1,2)
K DIR
S DIR("A")=$S($D(PXDXASK):PXDXASK,1:PXSYS_" Diagnosis Code: ")
S DIR("?")="^D INPHLP^PXDSLK",DIR("??")="^D INPHLP^PXDSLK"
I $G(PXDEF)'="",'$D(PXDXASK) S X=PXDEF G ASK2 ; K PXDEF G ASK2
I $G(PXDEF)'="" S DIR("B")=PXDEF
S DIR(0)="FAO^0:60" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) G EXIT
I $L(X)=1,X'=" " D MIN2^PXDSLK G ASK
I X="@" S PXXX="@" Q
ASK2 I PXSYS["10" S PXTXT=X D ICD10 I $G(PXXX)=-2 S PXXX=-1,PXDEF="" G ASK
I PXSYS["-9" W !!,"SORRY, ICD-9 SPECIAL LOOK-UP NOT IMPLEMENTED." Q
I +$G(PXNUMB)>+$G(PXMAX) G ASK
I +PXXX>0 D
. N PXICDIEN S PXICDIEN=$$CODEN^ICDEX($P($P(PXXX,U,1),";",2))
. I +PXICDIEN'=-1 D SAVSPACE("^ICD9(",+PXICDIEN)
;
Q:$G(X)="" I $G(PXXX)=-1 S PXDEF="" G ASK
Q
ICD10 ; ICD-10 Search
N DIROUT,DUOUT,DTOUT,PXEXIT S PXEXIT=0
; Begin Recursive Loop
S PXTXT=$G(PXTXT) Q:'$L(PXTXT)
I PXTXT=" " S PXTXT=$$SPACEBAR("^ICD9(") I PXTXT=" " S PXXX=-2 Q
S PXNUMB=$$FREQ^LEXU(PXTXT),PXMAX=$$MAX^LEXU(30)
I PXNUMB>PXMAX D Q:%'=1
. W !!,"Searching for '",PXTXT,"' requires inspecting ",PXNUMB," records to determine"
. W !,"if they match the search criteria. This could take quite some time."
. W !,"Please refine the search by including more detail than '",PXTXT,"'.",!
. K PXDEF
. W !,"Do you wish to continue (Y/N)" S %=2 D YN^DICN W !
S PXDT=$P($G(PXDT),".",1) S:PXDT'?7N PXDT=$$DT^XLFDT
K PXNUMB,PXMAX D LK1
Q
LK1 ; Lookup
Q:+($G(PXEXIT))>0 K PXY
S PXY=$$DIAGSRCH^LEX10CS(PXTXT,.PXY,PXDT,30)
S:$O(PXY(" "),-1)>0 PXY=+PXY
; Nothing found
I +PXY'>0 W !!,"No records found matching the value entered, revise search or enter ""?"" for",!,"help.",! S PXXX=-2 Q
S PXXX=$$SEL^PXSELDS(.PXY,8),X=PXXX
I PXXX="@" S PXAGAIN=0 Q
I $D(DUOUT)&('$D(DIROUT)) W:'$D(PXNT) !!," Exiting list",! Q
I $D(DTOUT)&('$D(DIROUT)) W !!," Try again later",! S PXXX=-1,PXEXIT=1 Q
I $D(DIROUT) W !!," Exiting list",! S PXXX=-1,PXEXIT=1 Q
; Abort if timed out or user enters "^^"
I $D(DTOUT)!($D(DIROUT)) S PXEXIT=1 Q
; Quit if already at top level and user enters "^"
I $D(DUOUT),'$D(DIROUT) Q
; No Selection
I '$D(DUOUT),PXXX=-1 S PXEXIT=1,PXXX=-2 W !!," No data selected",!
; Code Found and Selected
I $P(PXXX,";")'="99:CAT" D WRT S PXEXIT=1 Q
; Category Found and Selected
D NXT G:+($G(PXEXIT))'>0 LK1
Q
WRT ; Write Output
I +PXXX'=-1,PXXX'=-2 D
. N PXCODE,PXTXT,PXI S PXCODE=$P($P(PXXX,"^"),";",2),PXTXT(1)=$P(PXXX,"^",2)
. D PR^PXSELDS(.PXTXT,48) W !
. W !," ICD-10 Diagnosis code: ",?31,PXCODE
. W !," ICD-10 Diagnosis description:",?31,PXTXT(1)
. S PXI=1 F S PXI=$O(PXTXT(PXI)) Q:+PXI'>0 W !,?31,$G(PXTXT(PXI))
. S PXEXIT=1
Q
NXT ; Next
Q:+($G(PXEXIT))>0 N PXNT,PXND,PXX
S PXNT=$G(PXTXT),PXND=$G(PXDT),PXX=$G(PXXX)
N PXTXT,PXDT S PXTXT=$P($P(PXX,"^"),";",2),PXDT=PXND
G LK1
Q
; retrieves the last code selected by the user - space bar recall
; logic here
SPACEBAR(PXROOT) ;
N PXICDIEN,PXRTV
S PXRTV=" " I PXROOT="^ICD9(" D
. S PXICDIEN=$G(^DISV(DUZ,PXROOT)) ; PCE subscribes to ICR #510
. I $L(PXICDIEN) S PXRTV=$$CODEC^ICDEX(80,PXICDIEN)
I PXRTV=" " W " ??"
Q PXRTV
;
; store the selected code for the space bar recall feature above
SAVSPACE(PXROOT,PXRETV) ;
I +$G(DUZ)=0 Q
I +$G(PXRETV)=0 Q
; PCE subscribes to ICR #510 for call to RECALL API below
I PXROOT="^ICD9(" D RECALL^DILFD(80,PXRETV_",",+DUZ) Q
Q
;
INPHLP ; Help text controller for ICD-10
N PXPAUSE S PXPAUSE=0
I X["???" D QM3 Q
I X["??" D QM2 Q
I X["?" D QM1 Q
Q
;
QM ; Diagnosis help text
; if calling from outside, set PXPAUSE=1 to pause the display and force the user to press <Enter> to continue
QM1 ; simple help text for 1 question mark
W !,"Enter code or ""text"" for more information.",!
I $G(PXPAUSE) N CR R !,"Press <Enter> to continue: ",CR:DTIME
Q
QM2 ; enhanced help text for 2 question marks
W !,"Enter a ""free text"" term or part of a term such as ""femur fracture"".",!
W !," or",!
W !,"Enter a ""classification code"" (ICD/CPT etc) to find the single term associated"
W !,"with the code.",!
W !," or",!
W !,"Enter a ""partial code"". Include the decimal when a search criterion includes"
W !,"3 characters or more for code searches.",!
I $G(PXPAUSE) N CR R !,"Press <Enter> to continue: ",CR:DTIME
Q
QM3 ; further explanation of format when there are multiple returns, displayed for 3 question marks.
W !,"Number of Code Matches"
W !,"----------------------",!
W !,"The ICD-10 Diagnosis Code search will show the user the number of matches"
W !,"found, indicate if additional characters in ICD code exist, and the number"
W !,"of codes within the category or subcategory that are available for selection."
W !,"For example:",!
W !,"14 matches found",!
W !,"M91. - Juvenile osteochondrosis of hip and pelvis (19)",!
W !,"This indicates that 14 unique matches or matching groups have been found and"
W !,"will be displayed.",!
W !,"M91. - the ""-"" indicates that there are additional characters that specify"
W !," unique ICD-10 codes available.",!
W !,"(19) Indicates that there are 19 additional ICD-10 codes in the M91"
W !," ""family"" that are possible selections.",!
I $G(PXPAUSE) N CR R !,"Press <Enter> to continue: ",CR:DTIME
Q
;
MIN2 ; Minimum length of 2 characters message
W $C(7)," ??",!
W !,"Please enter at least the first two characters of the ICD-10 code or "
W !,"code description to start the search.",!
Q
;
EXIT ; Clean up environment and quit
K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEX,PXAGAIN,PXDEF,PXDXASK
Q
X(LEX) ; Evaluate X
Q:$L($G(X)) 1 Q 0
Y(LEX) ; Evaluate Y
Q:+($G(Y))>1 1 Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXDSLK 6990 printed Sep 23, 2025@20:04:40 Page 2
PXDSLK ;ALB/RBD - COPIED FROM ICDLOOK TO LOOK UP ICD-10 DX CODE;01 May 2014 1:39 PM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**199**;Aug 12, 1996;Build 51
+2 ;;
+3 ;
+4 ; Reference to CODEC^ICDEX supported by ICR #5747
+5 ; Reference to CODEN^ICDEX supported by ICR #5747
+6 ; Reference to ^DISV supported by ICR #510
+7 ;
+8 ; PXDATE is the EFFECTIVE DATE that is passed from the Calling Routine
+9 ; PXAGAIN controls the "Try Another" prompt; 0 = do not prompt
+10 ; PXDEF may be passed in as the default Dx value to be prompted
+11 ; PXDXASK if present will be used as the prompt when asking for the Dx code
+12 ;
EN ; Initialize variables
+1 DO HOME^%ZIS
SET DT=$$DT^XLFDT
DO LOOK
+2 GOTO EXIT
LOOK ; Look-up term
+1 SET PXXX=-1
DO ASK
KILL DIC
AGAIN ; Try again?
+1 if $GET(PXAGAIN)=0
QUIT
+2 WRITE !,"Try another"
SET %=$SELECT(+($$X):1,1:2)
+3 DO YN^DICN
IF %=-1!(%=2)
QUIT
+4 IF '%
WRITE !!,"You have searched for an ICD-10 diagnosis code, do you want to"
GOTO AGAIN
+5 IF +($$X)&(%=1)
KILL PXDEF
GOTO LOOK
+6 IF '+($$X)&(%=1)
GOTO LOOK
+7 IF (+($$X)&(%=2))!('+($$X)&(%=1))
QUIT
+8 GOTO LOOK
QUIT
ASK ; Get user input
+1 NEW ARY,DIR,DIRUT,DIROUT,PXSYS,PXO,PXY,RES,Y
+2 KILL %DT,II,PXDT,PXMAX,PXNUMB,PXY
+3 IF $GET(PXDATE)'=""
SET Y=PXDATE
+4 IF $GET(PXDATE)=""
KILL %DT
SET %DT="AEX"
SET %DT("A")="Date of Interest? "
DO ^%DT
KILL %DT
IF Y<0
GOTO EXIT
+5 SET PXDT=Y
SET PXSYS=$PIECE($PIECE($$ACTDT^PXDXUTL(PXDT),U,3),"-",1,2)
+6 KILL DIR
+7 SET DIR("A")=$SELECT($DATA(PXDXASK):PXDXASK,1:PXSYS_" Diagnosis Code: ")
+8 SET DIR("?")="^D INPHLP^PXDSLK"
SET DIR("??")="^D INPHLP^PXDSLK"
+9 ; K PXDEF G ASK2
IF $GET(PXDEF)'=""
IF '$DATA(PXDXASK)
SET X=PXDEF
GOTO ASK2
+10 IF $GET(PXDEF)'=""
SET DIR("B")=PXDEF
+11 SET DIR(0)="FAO^0:60"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+12 IF $LENGTH(X)=1
IF X'=" "
DO MIN2^PXDSLK
GOTO ASK
+13 IF X="@"
SET PXXX="@"
QUIT
ASK2 IF PXSYS["10"
SET PXTXT=X
DO ICD10
IF $GET(PXXX)=-2
SET PXXX=-1
SET PXDEF=""
GOTO ASK
+1 IF PXSYS["-9"
WRITE !!,"SORRY, ICD-9 SPECIAL LOOK-UP NOT IMPLEMENTED."
QUIT
+2 IF +$GET(PXNUMB)>+$GET(PXMAX)
GOTO ASK
+3 IF +PXXX>0
Begin DoDot:1
+4 NEW PXICDIEN
SET PXICDIEN=$$CODEN^ICDEX($PIECE($PIECE(PXXX,U,1),";",2))
+5 IF +PXICDIEN'=-1
DO SAVSPACE("^ICD9(",+PXICDIEN)
End DoDot:1
+6 ;
+7 if $GET(X)=""
QUIT
IF $GET(PXXX)=-1
SET PXDEF=""
GOTO ASK
+8 QUIT
ICD10 ; ICD-10 Search
+1 NEW DIROUT,DUOUT,DTOUT,PXEXIT
SET PXEXIT=0
+2 ; Begin Recursive Loop
+3 SET PXTXT=$GET(PXTXT)
if '$LENGTH(PXTXT)
QUIT
+4 IF PXTXT=" "
SET PXTXT=$$SPACEBAR("^ICD9(")
IF PXTXT=" "
SET PXXX=-2
QUIT
+5 SET PXNUMB=$$FREQ^LEXU(PXTXT)
SET PXMAX=$$MAX^LEXU(30)
+6 IF PXNUMB>PXMAX
Begin DoDot:1
+7 WRITE !!,"Searching for '",PXTXT,"' requires inspecting ",PXNUMB," records to determine"
+8 WRITE !,"if they match the search criteria. This could take quite some time."
+9 WRITE !,"Please refine the search by including more detail than '",PXTXT,"'.",!
+10 KILL PXDEF
+11 WRITE !,"Do you wish to continue (Y/N)"
SET %=2
DO YN^DICN
WRITE !
End DoDot:1
if %'=1
QUIT
+12 SET PXDT=$PIECE($GET(PXDT),".",1)
if PXDT'?7N
SET PXDT=$$DT^XLFDT
+13 KILL PXNUMB,PXMAX
DO LK1
+14 QUIT
LK1 ; Lookup
+1 if +($GET(PXEXIT))>0
QUIT
KILL PXY
+2 SET PXY=$$DIAGSRCH^LEX10CS(PXTXT,.PXY,PXDT,30)
+3 if $ORDER(PXY(" "),-1)>0
SET PXY=+PXY
+4 ; Nothing found
+5 IF +PXY'>0
WRITE !!,"No records found matching the value entered, revise search or enter ""?"" for",!,"help.",!
SET PXXX=-2
QUIT
+6 SET PXXX=$$SEL^PXSELDS(.PXY,8)
SET X=PXXX
+7 IF PXXX="@"
SET PXAGAIN=0
QUIT
+8 IF $DATA(DUOUT)&('$DATA(DIROUT))
if '$DATA(PXNT)
WRITE !!," Exiting list",!
QUIT
+9 IF $DATA(DTOUT)&('$DATA(DIROUT))
WRITE !!," Try again later",!
SET PXXX=-1
SET PXEXIT=1
QUIT
+10 IF $DATA(DIROUT)
WRITE !!," Exiting list",!
SET PXXX=-1
SET PXEXIT=1
QUIT
+11 ; Abort if timed out or user enters "^^"
+12 IF $DATA(DTOUT)!($DATA(DIROUT))
SET PXEXIT=1
QUIT
+13 ; Quit if already at top level and user enters "^"
+14 IF $DATA(DUOUT)
IF '$DATA(DIROUT)
QUIT
+15 ; No Selection
+16 IF '$DATA(DUOUT)
IF PXXX=-1
SET PXEXIT=1
SET PXXX=-2
WRITE !!," No data selected",!
+17 ; Code Found and Selected
+18 IF $PIECE(PXXX,";")'="99:CAT"
DO WRT
SET PXEXIT=1
QUIT
+19 ; Category Found and Selected
+20 DO NXT
if +($GET(PXEXIT))'>0
GOTO LK1
+21 QUIT
WRT ; Write Output
+1 IF +PXXX'=-1
IF PXXX'=-2
Begin DoDot:1
+2 NEW PXCODE,PXTXT,PXI
SET PXCODE=$PIECE($PIECE(PXXX,"^"),";",2)
SET PXTXT(1)=$PIECE(PXXX,"^",2)
+3 DO PR^PXSELDS(.PXTXT,48)
WRITE !
+4 WRITE !," ICD-10 Diagnosis code: ",?31,PXCODE
+5 WRITE !," ICD-10 Diagnosis description:",?31,PXTXT(1)
+6 SET PXI=1
FOR
SET PXI=$ORDER(PXTXT(PXI))
if +PXI'>0
QUIT
WRITE !,?31,$GET(PXTXT(PXI))
+7 SET PXEXIT=1
End DoDot:1
+8 QUIT
NXT ; Next
+1 if +($GET(PXEXIT))>0
QUIT
NEW PXNT,PXND,PXX
+2 SET PXNT=$GET(PXTXT)
SET PXND=$GET(PXDT)
SET PXX=$GET(PXXX)
+3 NEW PXTXT,PXDT
SET PXTXT=$PIECE($PIECE(PXX,"^"),";",2)
SET PXDT=PXND
+4 GOTO LK1
+5 QUIT
+6 ; retrieves the last code selected by the user - space bar recall
+7 ; logic here
SPACEBAR(PXROOT) ;
+1 NEW PXICDIEN,PXRTV
+2 SET PXRTV=" "
IF PXROOT="^ICD9("
Begin DoDot:1
+3 ; PCE subscribes to ICR #510
SET PXICDIEN=$GET(^DISV(DUZ,PXROOT))
+4 IF $LENGTH(PXICDIEN)
SET PXRTV=$$CODEC^ICDEX(80,PXICDIEN)
End DoDot:1
+5 IF PXRTV=" "
WRITE " ??"
+6 QUIT PXRTV
+7 ;
+8 ; store the selected code for the space bar recall feature above
SAVSPACE(PXROOT,PXRETV) ;
+1 IF +$GET(DUZ)=0
QUIT
+2 IF +$GET(PXRETV)=0
QUIT
+3 ; PCE subscribes to ICR #510 for call to RECALL API below
+4 IF PXROOT="^ICD9("
DO RECALL^DILFD(80,PXRETV_",",+DUZ)
QUIT
+5 QUIT
+6 ;
INPHLP ; Help text controller for ICD-10
+1 NEW PXPAUSE
SET PXPAUSE=0
+2 IF X["???"
DO QM3
QUIT
+3 IF X["??"
DO QM2
QUIT
+4 IF X["?"
DO QM1
QUIT
+5 QUIT
+6 ;
QM ; Diagnosis help text
+1 ; if calling from outside, set PXPAUSE=1 to pause the display and force the user to press <Enter> to continue
QM1 ; simple help text for 1 question mark
+1 WRITE !,"Enter code or ""text"" for more information.",!
+2 IF $GET(PXPAUSE)
NEW CR
READ !,"Press <Enter> to continue: ",CR:DTIME
+3 QUIT
QM2 ; enhanced help text for 2 question marks
+1 WRITE !,"Enter a ""free text"" term or part of a term such as ""femur fracture"".",!
+2 WRITE !," or",!
+3 WRITE !,"Enter a ""classification code"" (ICD/CPT etc) to find the single term associated"
+4 WRITE !,"with the code.",!
+5 WRITE !," or",!
+6 WRITE !,"Enter a ""partial code"". Include the decimal when a search criterion includes"
+7 WRITE !,"3 characters or more for code searches.",!
+8 IF $GET(PXPAUSE)
NEW CR
READ !,"Press <Enter> to continue: ",CR:DTIME
+9 QUIT
QM3 ; further explanation of format when there are multiple returns, displayed for 3 question marks.
+1 WRITE !,"Number of Code Matches"
+2 WRITE !,"----------------------",!
+3 WRITE !,"The ICD-10 Diagnosis Code search will show the user the number of matches"
+4 WRITE !,"found, indicate if additional characters in ICD code exist, and the number"
+5 WRITE !,"of codes within the category or subcategory that are available for selection."
+6 WRITE !,"For example:",!
+7 WRITE !,"14 matches found",!
+8 WRITE !,"M91. - Juvenile osteochondrosis of hip and pelvis (19)",!
+9 WRITE !,"This indicates that 14 unique matches or matching groups have been found and"
+10 WRITE !,"will be displayed.",!
+11 WRITE !,"M91. - the ""-"" indicates that there are additional characters that specify"
+12 WRITE !," unique ICD-10 codes available.",!
+13 WRITE !,"(19) Indicates that there are 19 additional ICD-10 codes in the M91"
+14 WRITE !," ""family"" that are possible selections.",!
+15 IF $GET(PXPAUSE)
NEW CR
READ !,"Press <Enter> to continue: ",CR:DTIME
+16 QUIT
+17 ;
MIN2 ; Minimum length of 2 characters message
+1 WRITE $CHAR(7)," ??",!
+2 WRITE !,"Please enter at least the first two characters of the ICD-10 code or "
+3 WRITE !,"code description to start the search.",!
+4 QUIT
+5 ;
EXIT ; Clean up environment and quit
+1 KILL %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEX,PXAGAIN,PXDEF,PXDXASK
+2 QUIT
X(LEX) ; Evaluate X
+1 if $LENGTH($GET(X))
QUIT 1
QUIT 0
Y(LEX) ; Evaluate Y
+1 if +($GET(Y))>1
QUIT 1
QUIT 0
