- 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 Jan 18, 2025@03:29: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