RMPOICD1 ;ALB/MGD - ICD-10 DIAGNOSIS CODE LOOK UP; 12-06-11
;;3.0;PROSTHETICS;**168**;Feb 09, 1996;Build 43
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to $$DIAGSRCH^LEX10CS supported by ICR #5681
; Reference to $$IMPDATE^LEXU supported by ICR #5679
; Reference to $$FREQ^LEXU supported by ICR #5679
; Reference to $$MAX^LEXU supported by ICR #5679
; Reference to LS^ICDEX supported by ICR #5747
; Reference to CSI^ICDEX supported by ICR #5747
;
; This routine is based on ^ICDLOOK
;
EN ;
D DEMO
Q
;
;this is a demo code,
;in your applications you might need to use some or all of the code below,
;see comments
DEMO ;
D INITVARS ;set standards variables, you might not need this if it was already done in your application
N RMPQUIT ; to manage demo loop
N RMPRETV ;to store the selected code information
N RMPPARAM ; to set your application specific prompts and messages
N RMPCSYS ;coding system "ICD9" or ICD10"
N RMPOUT ;to return all available information about the selected code
N RMPDFLT9 ;default ICD-9 value for demo
N RMPDFL10 ;default ICD-10 value for demo
;settings:
D SETPARAM(.RMPPARAM) ;edit the SETPARAM subroutine below to set your application specific prompts
;starting demo loop
S RMPQUIT=0 F Q:RMPQUIT=1 D
. S RMPRETV=0,RMPOUT=""
. W @IOF ;reset the screen
. ;prompt for the date of interest
. S RMPDT=$$ASKDATE(RMPPARAM("ASKDATE"))
. I RMPDT=-1 S RMPQUIT=1 Q
. ;prompt for "try again" with "No" as default if ^ or null entered for the date or if timed out
. I RMPDT'>0 S:$$QUESTION(2,RMPPARAM("TRY ANOTHER"))'=1 RMPQUIT=1 Q
. ;determine coding system based on the date of interest
. S RMPCSYS=$$ICDSYSDG(RMPDT)
. ;set default response for your prompt
. S RMPDFLT9=""
. S RMPDFL10=""
. ;run either ICD9 or ICD10 prompt/search/select logic
. ;ICD9 (1 is a pointer to the ICD-9 diagnosis system entry in the new file #80.4 )
. I RMPCSYS=1 S RMPRETV=$$DIAG9(RMPDT,RMPDFLT9,.RMPOUT,.RMPPARAM) I RMPRETV=-2 S:$$QUESTION(1,RMPPARAM("TRY ANOTHER"))'=1 RMPQUIT=1 Q
. ;ICD10 (30 is a pointer to the ICD-10 diagnosis system entry in the new file #80.4 )
. I RMPCSYS=30 S RMPRETV=$$DIAG10(RMPDT,RMPDFL10,.RMPPARAM)
. ;display information about the code selected (for demo purposes)
. I +RMPRETV>0 W !,"SELECTED: " D CODEINFO(RMPRETV) S RMPQUIT=1 Q
. ;if no data found
. I +RMPRETV="" W !!,RMPPARAM("NO DATA FOUND") Q
. ;in ICD10 if the user answered NO for the question "Do you wish to continue(Y/N)?"
. I +RMPRETV=-4 S RMPQUIT=1 Q
. ;no changes to the default value
. I +RMPRETV=-5 S RMPQUIT=1 Q
. ;no data or was aborted
. I +RMPRETV=-2 S RMPQUIT=1 Q
. ;if exit due to ^ in the ICD Diagnosis code prompt
. I +RMPRETV=-3 S RMPQUIT=1 Q
. ;if no data found
. I +RMPRETV=-1,$P(RMPRETV,U,2)=-1 S RMPQUIT=1 Q
. ;user entered "@" to delete the currently selected ICD code
. I +RMPRETV=-6 W !,RMPPARAM("DELETE IT"),! S:$$QUESTION(1,RMPPARAM("TRY ANOTHER"))'=1 RMPQUIT=1 Q
. ; if continue search
Q
;
;//---------
;The entry point for ICD-10 diagnosis search functionality
;can be called from applications directly
;input parameters :
; RMPDT - date of interest (Fileman format)
; RMPDFLT - default values for the search string (can be a code by default)
; RMPPARAM - parameters/string constants (see SETPARAM for details)
;returns ICD-10 code selected by the user:
; IEN file #80;ICD code value;IEN file # 757.01^description
; results
; or -1 if invalid data(press enter)
; "" if not found
; or -2 if time out
; or -3 if ^ or ^^
; or -4 in ICD10 if the user answered NO for the question "Do you wish to continue(Y/N)?"
; or -5 if no changes to the default value
DIAG10(RMPDT,RMPDFLT,RMPPARAM) ;
N RMPINP
F D Q:RMPINP<0!($L($P(RMPINP,U,2))>1)
.S RMPINP=$$SRCHSTR(RMPPARAM("SEARCH_PROMPT"),RMPPARAM("HELP ?"),RMPPARAM("HELP ??"),RMPDFLT)
.I RMPINP'<0 I $L($P(RMPINP,U,2))'>1 W !!,RMPPARAM("ENTER MORE") W:$L(RMPPARAM("ENTER MORE2"))>0 !,RMPPARAM("ENTER MORE2") W ! ;user should enter at least 2 characters
I RMPINP<0 Q RMPINP_"^-1"
Q $$LEXICD10($P(RMPINP,U,2),RMPDT,.RMPPARAM)
;
;//---------
;The entry point for ICD-9 FileMan type (^DIC) diagnosis search functionality
;can be called from applications directly
;input parameters :
; RMPDT - date of interest
; RMPDFLT - default values for the search string (can be a code by default)
; RMPOUT - local array to return results(passed as a reference)
; RMPPARAM - parameters/string constants (see SETPARAM for details)
;returns ICD-9 code selected by the user:
; IEN file #80;ICD code value^description
; -1 no data or was aborted
; -2 if timeout
; -3 was aborted
; -5 if no changes to the default value
DIAG9(RMPDT,RMPDFLT,RMPOUT,RMPPARAM) ;
N RMPINP,RMPRETV
S RMPRETV=$$ICD9(RMPDFLT,RMPDT,.RMPOUT,RMPPARAM("SEARCH_PROMPT"))
Q RMPRETV
;
;--------------
;The entry point for ICD-10 diagnosis search functionality
;can be called from applications directly
; Supported ICR 5681 ($$DIAGSRCH^LEX10CS)
;input parameters :
; RMPTXT - search string
; RMPDATE - date of interest
; RMPPAR - array with text messages and other string constants
;returns ICD-10 code selected by the user:
; IEN file #80;ICD code value^description
; or
; "" if not found
; -1 if exit : ^ or ^^
; -2 if continue searching
;
LEXICD10(RMPTXT,RMPDATE,RMPPAR) ; ICD-10 Search
N RMPLVTXT
;parameters check
S RMPDATE=+$G(RMPDATE)
I RMPDATE'?7N Q -1
S RMPTXT=$G(RMPTXT)
Q:'$L(RMPTXT) -1
N RMPNUMB
S RMPNUMB=$$FREQ^LEXU(RMPTXT) ; Supported ICR #5679
I RMPNUMB>$$MAX^LEXU(30) D I $$QUESTION(2,RMPPAR("WISH CONTINUE"))'=1 Q -4 ; Supported ICR #5679
. W !
. D FORMWRIT(RMPPAR("EXCEEDS MESSAGE1")_RMPTXT_RMPPAR("EXCEEDS MESSAGE2")_RMPNUMB_RMPPAR("EXCEEDS MESSAGE3")_RMPTXT_""".",0)
. D FORMWRIT("",2)
. W !
;new and set variables
N DIROUT,DUOUT,DTOUT,RMPEXIT,RMPICDNT
N RMPRETV,RMPXX,RMPLEVEL
S RMPRETV=""
S RMPEXIT=0
S RMPLEVEL=1,RMPLVTXT(RMPLEVEL)=RMPTXT ;level 1 stores the original search string
; main loop
F Q:RMPEXIT>0 D
.K RMPICDY
.;W !,"Level #: ",RMPLEVEL,", search string: ",RMPLVTXT(RMPLEVEL)
.;get the search string from the current level and call LEX API
.S RMPICDY=$$DIAGSRCH^LEX10CS(RMPLVTXT(RMPLEVEL),.RMPICDY,RMPDATE,30) ; Supported ICR #5681
.;W !,"Search for: ",RMPLVTXT(RMPLEVEL),"Date: ",RMPDATE,!! ZW RMPICDY W @IOF
.S:$O(RMPICDY(" "),-1)>0 RMPICDY=+RMPICDY
.; Nothing found
.I +RMPICDY'>0 S RMPEXIT=1 S RMPXX=-1 Q
.; display the list of items and ask the user to select the item from the list
.S RMPXX=$$SEL^RMPOICD2(.RMPICDY,8)
.; if ^ was entered
.; if this is on the top level then quit
.I RMPXX=-2,RMPLEVEL'>1 S RMPRETV=-1 S RMPEXIT=1 Q
.; if lower level then go one level up
.I RMPXX=-2,RMPLEVEL>1 S:RMPLEVEL>1 RMPLEVEL=RMPLEVEL-1 Q
.; If timeout, or not selected, or ^^ then quit
.I RMPXX=-1 S RMPRETV=-1 S RMPEXIT=1 Q
.; if Code Found and Selected by the user save selection in RMPRETV and quit
.I $P(RMPXX,";")'="99:CAT" S RMPRETV=RMPXX S RMPEXIT=1 Q
.; If Category Found and Selected by the user:
.; go to the next inner level
.; change level number
.S RMPLEVEL=RMPLEVEL+1
.; set the new level with the new search string
.; and repeat
.S RMPLVTXT(RMPLEVEL)=$P($P($G(RMPXX),"^"),";",2)
Q RMPRETV
;----------
;ICD-9 lookup (FileMan lookup)
;Supported ICR 5773 (FileMan lookup for files #80 and #80.1)
;input parameters :
; RMPSRCH - search string/ default values
; RMPICDT - date of interest
; RMPOUT - local array to return detailed info (passed as a reference)
; RMPPRMT - prompt
;returns ICD-9 code selected by the user:
; IEN file #80;ICD code value^description
; or
; -1 if exit : ^ or ^^
; -2 if no results (timeout)
;the array RMPOUT returns details if the return value >0, here is an example:
; RMPOUT="6065^814.14"
; RMPOUT(0)=814.14
; RMPOUT(0,0)=814.14
; RMPOUT(0,1)="6065^814.14^^FX PISIFORM-OPEN^^8^^1^^1^^^0^^^^2781001^^1^1"
; RMPOUT(0,2)="OPEN FRACTURE OF PISIFORM BONE OF WRIST"
;Note: this API is not silent because the ICD lookup is not silent
ICD9(RMPSRCH,RMPICDT,RMPOUT) ;
N KEY,X,Y,DIC,RMPCDS
;KEY must be newed as ICD lookup code doesn't kill it
S DIC="^ICD9(",DIC(0)="EQMNZIA"
S:$G(RMPPRMT)]"" DIC("A")=RMPPRMT
S:$G(RMPSRCH)]"" DIC("B")=RMPSRCH
S RMPCDS="ICD9"
;note: you must use Y for the 2nd parameter of $$LS^ICDEX & $$CSI^ICDEX
S DIC("S")="I $$LS^ICDEX(80,+Y,RMPICDT)>0,$$CSI^ICDEX(80,+Y)=1"
D ^DIC
M RMPOUT=Y
I $G(Y) Q $S($D(DTOUT):-2,$D(DUOUT):-1,$D(DUOUT):-1,Y=-1:-1,Y=-5:"",1:+Y_";"_$P(Y,U,2)_U_$G(Y(0,2)))
Q X
;
;---------
; Clean up environment and quit
EXIT ;
K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
Q
;
;-----------
; Look-up help for ?
INPHLP ;
I $G(X)["???" D INPHLP3 Q
I $G(X)["??" D INPHLP2 Q
W !," Enter code or ""text"" for more information." Q
Q
;-----------
; Look-up help for ??
INPHLP2 ;
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"
W !," associated with the code."
W !!," or "
W !!," Enter a ""partial code"". Include the decimal when a search criterion"
W !," includes 3 characters or more for code searches."
Q
;--------
; Look-up help for ???
INPHLP3 ;
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"
W !," and 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 ""family"""
W !," that are possible selections."
Q
;--------
;prompt the user for a date of interest
;input parameters :
; RMPPRMT - prompt
;returns YYYMMDD
; or -1 if invalid date
; or -2 if time out
; or -3 if ^
ASKDATE(RMPPRMT) ;
N %DT,DIROUT,DUOUT,DTOUT
S %DT="AEX",%DT("A")=$G(RMPPRMT,"Enter a date: ")
D ^%DT
Q:Y<0 -1
Q:$D(DTOUT) -2
Q:X="^" -3
Q (+Y)
;--------
;ask YES/NO questions
;input parameters :
; RMPDFLT- 0/null- not default, 1- yes, 2 -no
; RMPPROM - prompt string
;returns
; 2 - no,
; 1 - yes,
; 0 - no answer (time out)
; -3 - ^ or ^^
QUESTION(RMPDFLT,RMPPROM,RMPHELP) ;
N DIR
S %=$G(RMPDFLT,2)
S DIR(0)="Y",DIR("A")=RMPPROM,DIR("B")=$S(%=1:"Yes",%=2:"No",1:"")
S:$L($G(RMPHELP)) DIR("?")=RMPHELP
D ^DIR
Q:Y["^" -3
Q:Y=1 1
Q:Y=0 2
Q 0
;
;------------
;get search string
;input parameters :
; RMPPRMT prompt text
; RMPHLP1 "?" help text
; RMPHLP2 "??" help text
; RMPDFLT- default response
;returns piece1 ^ piece 2
; piece1:
; 0 if normal input
; or -1 if invalid data
; or -2 if time out
; or -3 if ^
; or -5 if user accepts default value then no need to validate it
; or -6 if user enters "@"
; piece2: string entered by the user
SRCHSTR(RMPPRMT,RMPHLP1,RMPHLP2,RMPDFLT) ;
N DIR
S DIR("A")=RMPPRMT
S:($G(RMPHLP1)]"") DIR("?")=RMPHLP1
S:($G(RMPHLP2)]"") DIR("??")=RMPHLP2
I $L($G(RMPDFLT)) S DIR("B")=RMPDFLT
S DIR(0)="FAOr^0:245"
D ^DIR
Q:$D(DTOUT) -2
Q:$D(DUOUT) -3
Q:X="@" -6 ;quit if user entered "@" and handle deletion case in your application
Q:Y["^" -3
Q:Y="" -1
Q:(($L($G(RMPDFLT)))&(Y=RMPDFLT)) -5 ;if user accepts default value then no need to validate it
Q 0_U_Y
;
;----------
;Determines and returns ACTIVE coding system for DIAGNOSES based on date of interest
;input parameters :
; RMPICDD - date of interest
; if date of interest is null, today's date will be assumed
;returns coding system
; as a pointer to the ICD CODING SYSTEM file #80.4 (supported ICR 5780)
; 30 if ICD-10-CM is active system
; 1 if ICD-9-CM is active system
ICDSYSDG(RMPICDD) ;
N RMPIMPDT
S RMPICDD=$S(RMPICDD<0!($L(+RMPICDD)'=7):DT,1:+$G(RMPICDD))
S RMPIMPDT=$$IMPDATE^LEXU("10D")
Q $S(RMPICDD'<RMPIMPDT:30,1:1)
;
;set parameters
;edit these hardcoded strings that are used for prompts, messages and so on to adjust them to your application's needs
;input parameters
; RMPPAR - local array to set and store string constants for your messages and prompts
SETPARAM(RMPPAR) ;
S RMPPAR("SEARCH_PROMPT")="ICD-10 DIAGNOSIS CODE: "
S RMPPAR("HELP ?")="^D INPHLP^RMPOICD1"
S RMPPAR("HELP ??")="^D INPHLP2^RMPOICD1"
S RMPPAR("NO DATA FOUND")=" No data found"
S RMPPAR("EXITING")=" Exiting"
S RMPPAR("TRY LATER")=" Try again later"
S RMPPAR("NO DATA SELECTED")=" No data selected"
S RMPPAR("TRY ANOTHER")="Try another"
S RMPPAR("WISH CONTINUE")="Do you wish to continue(Y/N)"
S RMPPAR("EXCEEDS MESSAGE1")="Searching for """
S RMPPAR("EXCEEDS MESSAGE2")=""" requires inspecting "
S RMPPAR("EXCEEDS MESSAGE3")=" records to determine if they match the search criteria. This could take quite some time. Suggest refining the search by further specifying """
S RMPPAR("NO CHANGES")=" No changes made"
S RMPPAR("DELETE IT")=" SURE YOU WANT TO DELETE"
S RMPPAR("ENTER MORE")=" Please enter at least the first two characters of the ICD-10 code or code"
S RMPPAR("ENTER MORE2")=" description to start the search."
S RMPPAR("YES OR NO")="Answer 'Y' for 'Yes' or 'N' for 'No'"
Q
;
;
;a wrapper for ^DIWP
;accumulates a text and then writes it to the device
;input parameters :
; X - text
; RMPMODE:
; 0 - start
; 1 - accumulate
; 2 - write
;example:
;D FORMWRIT^ZZLXDG("this API is a wrapper for ^DIWP, it accumulates a text and then writes it to the device, you can use it in your application code",0)
;D FORMWRIT^ZZLXDG("some more text ",1)
;D FORMWRIT^ZZLXDG("",2)
FORMWRIT(X,RMPMODE) ;
N RMPLI1
;if "start" mode
I RMPMODE=0 K ^UTILITY($J,"W")
S DIWL=1,DIWR=79
I $L(X)>0 D ^DIWP
;if "write" mode
I RMPMODE=2 D
. S RMPLI1=0 F S RMPLI1=$O(^UTILITY($J,"W",1,RMPLI1)) Q:+RMPLI1=0 W !,$G(^UTILITY($J,"W",1,RMPLI1,0))
. K ^UTILITY($J,"W")
Q
;
;---------------
;Initialize variables if you need , your application most likely already has this
INITVARS ;
D HOME^%ZIS
S:$G(DT)=0 DT=$$DT^XLFDT
Q
;press any key (used for demo)
PRESSKEY ;
R !!,"Press any key to continue.",RMPKEY:DTIME
Q
;display code info (used for demo)
CODEINFO(RMPXX2) ; Write Output
N RMPKEY
W !," ICD Diagnosis code:",?30,$P(RMPXX2,";",2)
W !," ICD Diagnosis code IEN:",?30,$P(RMPXX2,";",1)
W !," Lexicon Expression IEN:",?30,+$P(RMPXX2,";",3)
W !," ICD Diagnosis description:",?30,$P(RMPXX2,"^",2)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOICD1 15147 printed Sep 23, 2025@20:07:02 Page 2
RMPOICD1 ;ALB/MGD - ICD-10 DIAGNOSIS CODE LOOK UP; 12-06-11
+1 ;;3.0;PROSTHETICS;**168**;Feb 09, 1996;Build 43
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to $$DIAGSRCH^LEX10CS supported by ICR #5681
+5 ; Reference to $$IMPDATE^LEXU supported by ICR #5679
+6 ; Reference to $$FREQ^LEXU supported by ICR #5679
+7 ; Reference to $$MAX^LEXU supported by ICR #5679
+8 ; Reference to LS^ICDEX supported by ICR #5747
+9 ; Reference to CSI^ICDEX supported by ICR #5747
+10 ;
+11 ; This routine is based on ^ICDLOOK
+12 ;
EN ;
+1 DO DEMO
+2 QUIT
+3 ;
+4 ;this is a demo code,
+5 ;in your applications you might need to use some or all of the code below,
+6 ;see comments
DEMO ;
+1 ;set standards variables, you might not need this if it was already done in your application
DO INITVARS
+2 ; to manage demo loop
NEW RMPQUIT
+3 ;to store the selected code information
NEW RMPRETV
+4 ; to set your application specific prompts and messages
NEW RMPPARAM
+5 ;coding system "ICD9" or ICD10"
NEW RMPCSYS
+6 ;to return all available information about the selected code
NEW RMPOUT
+7 ;default ICD-9 value for demo
NEW RMPDFLT9
+8 ;default ICD-10 value for demo
NEW RMPDFL10
+9 ;settings:
+10 ;edit the SETPARAM subroutine below to set your application specific prompts
DO SETPARAM(.RMPPARAM)
+11 ;starting demo loop
+12 SET RMPQUIT=0
FOR
if RMPQUIT=1
QUIT
Begin DoDot:1
+13 SET RMPRETV=0
SET RMPOUT=""
+14 ;reset the screen
WRITE @IOF
+15 ;prompt for the date of interest
+16 SET RMPDT=$$ASKDATE(RMPPARAM("ASKDATE"))
+17 IF RMPDT=-1
SET RMPQUIT=1
QUIT
+18 ;prompt for "try again" with "No" as default if ^ or null entered for the date or if timed out
+19 IF RMPDT'>0
if $$QUESTION(2,RMPPARAM("TRY ANOTHER"))'=1
SET RMPQUIT=1
QUIT
+20 ;determine coding system based on the date of interest
+21 SET RMPCSYS=$$ICDSYSDG(RMPDT)
+22 ;set default response for your prompt
+23 SET RMPDFLT9=""
+24 SET RMPDFL10=""
+25 ;run either ICD9 or ICD10 prompt/search/select logic
+26 ;ICD9 (1 is a pointer to the ICD-9 diagnosis system entry in the new file #80.4 )
+27 IF RMPCSYS=1
SET RMPRETV=$$DIAG9(RMPDT,RMPDFLT9,.RMPOUT,.RMPPARAM)
IF RMPRETV=-2
if $$QUESTION(1,RMPPARAM("TRY ANOTHER"))'=1
SET RMPQUIT=1
QUIT
+28 ;ICD10 (30 is a pointer to the ICD-10 diagnosis system entry in the new file #80.4 )
+29 IF RMPCSYS=30
SET RMPRETV=$$DIAG10(RMPDT,RMPDFL10,.RMPPARAM)
+30 ;display information about the code selected (for demo purposes)
+31 IF +RMPRETV>0
WRITE !,"SELECTED: "
DO CODEINFO(RMPRETV)
SET RMPQUIT=1
QUIT
+32 ;if no data found
+33 IF +RMPRETV=""
WRITE !!,RMPPARAM("NO DATA FOUND")
QUIT
+34 ;in ICD10 if the user answered NO for the question "Do you wish to continue(Y/N)?"
+35 IF +RMPRETV=-4
SET RMPQUIT=1
QUIT
+36 ;no changes to the default value
+37 IF +RMPRETV=-5
SET RMPQUIT=1
QUIT
+38 ;no data or was aborted
+39 IF +RMPRETV=-2
SET RMPQUIT=1
QUIT
+40 ;if exit due to ^ in the ICD Diagnosis code prompt
+41 IF +RMPRETV=-3
SET RMPQUIT=1
QUIT
+42 ;if no data found
+43 IF +RMPRETV=-1
IF $PIECE(RMPRETV,U,2)=-1
SET RMPQUIT=1
QUIT
+44 ;user entered "@" to delete the currently selected ICD code
+45 IF +RMPRETV=-6
WRITE !,RMPPARAM("DELETE IT"),!
if $$QUESTION(1,RMPPARAM("TRY ANOTHER"))'=1
SET RMPQUIT=1
QUIT
+46 ; if continue search
End DoDot:1
+47 QUIT
+48 ;
+49 ;//---------
+50 ;The entry point for ICD-10 diagnosis search functionality
+51 ;can be called from applications directly
+52 ;input parameters :
+53 ; RMPDT - date of interest (Fileman format)
+54 ; RMPDFLT - default values for the search string (can be a code by default)
+55 ; RMPPARAM - parameters/string constants (see SETPARAM for details)
+56 ;returns ICD-10 code selected by the user:
+57 ; IEN file #80;ICD code value;IEN file # 757.01^description
+58 ; results
+59 ; or -1 if invalid data(press enter)
+60 ; "" if not found
+61 ; or -2 if time out
+62 ; or -3 if ^ or ^^
+63 ; or -4 in ICD10 if the user answered NO for the question "Do you wish to continue(Y/N)?"
+64 ; or -5 if no changes to the default value
DIAG10(RMPDT,RMPDFLT,RMPPARAM) ;
+1 NEW RMPINP
+2 FOR
Begin DoDot:1
+3 SET RMPINP=$$SRCHSTR(RMPPARAM("SEARCH_PROMPT"),RMPPARAM("HELP ?"),RMPPARAM("HELP ??"),RMPDFLT)
+4 ;user should enter at least 2 characters
IF RMPINP'<0
IF $LENGTH($PIECE(RMPINP,U,2))'>1
WRITE !!,RMPPARAM("ENTER MORE")
if $LENGTH(RMPPARAM("ENTER MORE2"))>0
WRITE !,RMPPARAM("ENTER MORE2")
WRITE !
End DoDot:1
if RMPINP<0!($LENGTH($PIECE(RMPINP,U,2))>1)
QUIT
+5 IF RMPINP<0
QUIT RMPINP_"^-1"
+6 QUIT $$LEXICD10($PIECE(RMPINP,U,2),RMPDT,.RMPPARAM)
+7 ;
+8 ;//---------
+9 ;The entry point for ICD-9 FileMan type (^DIC) diagnosis search functionality
+10 ;can be called from applications directly
+11 ;input parameters :
+12 ; RMPDT - date of interest
+13 ; RMPDFLT - default values for the search string (can be a code by default)
+14 ; RMPOUT - local array to return results(passed as a reference)
+15 ; RMPPARAM - parameters/string constants (see SETPARAM for details)
+16 ;returns ICD-9 code selected by the user:
+17 ; IEN file #80;ICD code value^description
+18 ; -1 no data or was aborted
+19 ; -2 if timeout
+20 ; -3 was aborted
+21 ; -5 if no changes to the default value
DIAG9(RMPDT,RMPDFLT,RMPOUT,RMPPARAM) ;
+1 NEW RMPINP,RMPRETV
+2 SET RMPRETV=$$ICD9(RMPDFLT,RMPDT,.RMPOUT,RMPPARAM("SEARCH_PROMPT"))
+3 QUIT RMPRETV
+4 ;
+5 ;--------------
+6 ;The entry point for ICD-10 diagnosis search functionality
+7 ;can be called from applications directly
+8 ; Supported ICR 5681 ($$DIAGSRCH^LEX10CS)
+9 ;input parameters :
+10 ; RMPTXT - search string
+11 ; RMPDATE - date of interest
+12 ; RMPPAR - array with text messages and other string constants
+13 ;returns ICD-10 code selected by the user:
+14 ; IEN file #80;ICD code value^description
+15 ; or
+16 ; "" if not found
+17 ; -1 if exit : ^ or ^^
+18 ; -2 if continue searching
+19 ;
LEXICD10(RMPTXT,RMPDATE,RMPPAR) ; ICD-10 Search
+1 NEW RMPLVTXT
+2 ;parameters check
+3 SET RMPDATE=+$GET(RMPDATE)
+4 IF RMPDATE'?7N
QUIT -1
+5 SET RMPTXT=$GET(RMPTXT)
+6 if '$LENGTH(RMPTXT)
QUIT -1
+7 NEW RMPNUMB
+8 ; Supported ICR #5679
SET RMPNUMB=$$FREQ^LEXU(RMPTXT)
+9 ; Supported ICR #5679
IF RMPNUMB>$$MAX^LEXU(30)
Begin DoDot:1
+10 WRITE !
+11 DO FORMWRIT(RMPPAR("EXCEEDS MESSAGE1")_RMPTXT_RMPPAR("EXCEEDS MESSAGE2")_RMPNUMB_RMPPAR("EXCEEDS MESSAGE3")_RMPTXT_""".",0)
+12 DO FORMWRIT("",2)
+13 WRITE !
End DoDot:1
IF $$QUESTION(2,RMPPAR("WISH CONTINUE"))'=1
QUIT -4
+14 ;new and set variables
+15 NEW DIROUT,DUOUT,DTOUT,RMPEXIT,RMPICDNT
+16 NEW RMPRETV,RMPXX,RMPLEVEL
+17 SET RMPRETV=""
+18 SET RMPEXIT=0
+19 ;level 1 stores the original search string
SET RMPLEVEL=1
SET RMPLVTXT(RMPLEVEL)=RMPTXT
+20 ; main loop
+21 FOR
if RMPEXIT>0
QUIT
Begin DoDot:1
+22 KILL RMPICDY
+23 ;W !,"Level #: ",RMPLEVEL,", search string: ",RMPLVTXT(RMPLEVEL)
+24 ;get the search string from the current level and call LEX API
+25 ; Supported ICR #5681
SET RMPICDY=$$DIAGSRCH^LEX10CS(RMPLVTXT(RMPLEVEL),.RMPICDY,RMPDATE,30)
+26 ;W !,"Search for: ",RMPLVTXT(RMPLEVEL),"Date: ",RMPDATE,!! ZW RMPICDY W @IOF
+27 if $ORDER(RMPICDY(" "),-1)>0
SET RMPICDY=+RMPICDY
+28 ; Nothing found
+29 IF +RMPICDY'>0
SET RMPEXIT=1
SET RMPXX=-1
QUIT
+30 ; display the list of items and ask the user to select the item from the list
+31 SET RMPXX=$$SEL^RMPOICD2(.RMPICDY,8)
+32 ; if ^ was entered
+33 ; if this is on the top level then quit
+34 IF RMPXX=-2
IF RMPLEVEL'>1
SET RMPRETV=-1
SET RMPEXIT=1
QUIT
+35 ; if lower level then go one level up
+36 IF RMPXX=-2
IF RMPLEVEL>1
if RMPLEVEL>1
SET RMPLEVEL=RMPLEVEL-1
QUIT
+37 ; If timeout, or not selected, or ^^ then quit
+38 IF RMPXX=-1
SET RMPRETV=-1
SET RMPEXIT=1
QUIT
+39 ; if Code Found and Selected by the user save selection in RMPRETV and quit
+40 IF $PIECE(RMPXX,";")'="99:CAT"
SET RMPRETV=RMPXX
SET RMPEXIT=1
QUIT
+41 ; If Category Found and Selected by the user:
+42 ; go to the next inner level
+43 ; change level number
+44 SET RMPLEVEL=RMPLEVEL+1
+45 ; set the new level with the new search string
+46 ; and repeat
+47 SET RMPLVTXT(RMPLEVEL)=$PIECE($PIECE($GET(RMPXX),"^"),";",2)
End DoDot:1
+48 QUIT RMPRETV
+49 ;----------
+50 ;ICD-9 lookup (FileMan lookup)
+51 ;Supported ICR 5773 (FileMan lookup for files #80 and #80.1)
+52 ;input parameters :
+53 ; RMPSRCH - search string/ default values
+54 ; RMPICDT - date of interest
+55 ; RMPOUT - local array to return detailed info (passed as a reference)
+56 ; RMPPRMT - prompt
+57 ;returns ICD-9 code selected by the user:
+58 ; IEN file #80;ICD code value^description
+59 ; or
+60 ; -1 if exit : ^ or ^^
+61 ; -2 if no results (timeout)
+62 ;the array RMPOUT returns details if the return value >0, here is an example:
+63 ; RMPOUT="6065^814.14"
+64 ; RMPOUT(0)=814.14
+65 ; RMPOUT(0,0)=814.14
+66 ; RMPOUT(0,1)="6065^814.14^^FX PISIFORM-OPEN^^8^^1^^1^^^0^^^^2781001^^1^1"
+67 ; RMPOUT(0,2)="OPEN FRACTURE OF PISIFORM BONE OF WRIST"
+68 ;Note: this API is not silent because the ICD lookup is not silent
ICD9(RMPSRCH,RMPICDT,RMPOUT) ;
+1 NEW KEY,X,Y,DIC,RMPCDS
+2 ;KEY must be newed as ICD lookup code doesn't kill it
+3 SET DIC="^ICD9("
SET DIC(0)="EQMNZIA"
+4 if $GET(RMPPRMT)]""
SET DIC("A")=RMPPRMT
+5 if $GET(RMPSRCH)]""
SET DIC("B")=RMPSRCH
+6 SET RMPCDS="ICD9"
+7 ;note: you must use Y for the 2nd parameter of $$LS^ICDEX & $$CSI^ICDEX
+8 SET DIC("S")="I $$LS^ICDEX(80,+Y,RMPICDT)>0,$$CSI^ICDEX(80,+Y)=1"
+9 DO ^DIC
+10 MERGE RMPOUT=Y
+11 IF $GET(Y)
QUIT $SELECT($DATA(DTOUT):-2,$DATA(DUOUT):-1,$DATA(DUOUT):-1,Y=-1:-1,Y=-5:"",1:+Y_";"_$PIECE(Y,U,2)_U_$GET(Y(0,2)))
+12 QUIT X
+13 ;
+14 ;---------
+15 ; Clean up environment and quit
EXIT ;
+1 KILL %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 QUIT
+3 ;
+4 ;-----------
+5 ; Look-up help for ?
INPHLP ;
+1 IF $GET(X)["???"
DO INPHLP3
QUIT
+2 IF $GET(X)["??"
DO INPHLP2
QUIT
+3 WRITE !," Enter code or ""text"" for more information."
QUIT
+4 QUIT
+5 ;-----------
+6 ; Look-up help for ??
INPHLP2 ;
+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"
+4 WRITE !," associated with the code."
+5 WRITE !!," or "
+6 WRITE !!," Enter a ""partial code"". Include the decimal when a search criterion"
+7 WRITE !," includes 3 characters or more for code searches."
+8 QUIT
+9 ;--------
+10 ; Look-up help for ???
INPHLP3 ;
+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"
+10 WRITE !," and 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 ""family"""
+14 WRITE !," that are possible selections."
+15 QUIT
+16 ;--------
+17 ;prompt the user for a date of interest
+18 ;input parameters :
+19 ; RMPPRMT - prompt
+20 ;returns YYYMMDD
+21 ; or -1 if invalid date
+22 ; or -2 if time out
+23 ; or -3 if ^
ASKDATE(RMPPRMT) ;
+1 NEW %DT,DIROUT,DUOUT,DTOUT
+2 SET %DT="AEX"
SET %DT("A")=$GET(RMPPRMT,"Enter a date: ")
+3 DO ^%DT
+4 if Y<0
QUIT -1
+5 if $DATA(DTOUT)
QUIT -2
+6 if X="^"
QUIT -3
+7 QUIT (+Y)
+8 ;--------
+9 ;ask YES/NO questions
+10 ;input parameters :
+11 ; RMPDFLT- 0/null- not default, 1- yes, 2 -no
+12 ; RMPPROM - prompt string
+13 ;returns
+14 ; 2 - no,
+15 ; 1 - yes,
+16 ; 0 - no answer (time out)
+17 ; -3 - ^ or ^^
QUESTION(RMPDFLT,RMPPROM,RMPHELP) ;
+1 NEW DIR
+2 SET %=$GET(RMPDFLT,2)
+3 SET DIR(0)="Y"
SET DIR("A")=RMPPROM
SET DIR("B")=$SELECT(%=1:"Yes",%=2:"No",1:"")
+4 if $LENGTH($GET(RMPHELP))
SET DIR("?")=RMPHELP
+5 DO ^DIR
+6 if Y["^"
QUIT -3
+7 if Y=1
QUIT 1
+8 if Y=0
QUIT 2
+9 QUIT 0
+10 ;
+11 ;------------
+12 ;get search string
+13 ;input parameters :
+14 ; RMPPRMT prompt text
+15 ; RMPHLP1 "?" help text
+16 ; RMPHLP2 "??" help text
+17 ; RMPDFLT- default response
+18 ;returns piece1 ^ piece 2
+19 ; piece1:
+20 ; 0 if normal input
+21 ; or -1 if invalid data
+22 ; or -2 if time out
+23 ; or -3 if ^
+24 ; or -5 if user accepts default value then no need to validate it
+25 ; or -6 if user enters "@"
+26 ; piece2: string entered by the user
SRCHSTR(RMPPRMT,RMPHLP1,RMPHLP2,RMPDFLT) ;
+1 NEW DIR
+2 SET DIR("A")=RMPPRMT
+3 if ($GET(RMPHLP1)]"")
SET DIR("?")=RMPHLP1
+4 if ($GET(RMPHLP2)]"")
SET DIR("??")=RMPHLP2
+5 IF $LENGTH($GET(RMPDFLT))
SET DIR("B")=RMPDFLT
+6 SET DIR(0)="FAOr^0:245"
+7 DO ^DIR
+8 if $DATA(DTOUT)
QUIT -2
+9 if $DATA(DUOUT)
QUIT -3
+10 ;quit if user entered "@" and handle deletion case in your application
if X="@"
QUIT -6
+11 if Y["^"
QUIT -3
+12 if Y=""
QUIT -1
+13 ;if user accepts default value then no need to validate it
if (($LENGTH($GET(RMPDFLT)))&(Y=RMPDFLT))
QUIT -5
+14 QUIT 0_U_Y
+15 ;
+16 ;----------
+17 ;Determines and returns ACTIVE coding system for DIAGNOSES based on date of interest
+18 ;input parameters :
+19 ; RMPICDD - date of interest
+20 ; if date of interest is null, today's date will be assumed
+21 ;returns coding system
+22 ; as a pointer to the ICD CODING SYSTEM file #80.4 (supported ICR 5780)
+23 ; 30 if ICD-10-CM is active system
+24 ; 1 if ICD-9-CM is active system
ICDSYSDG(RMPICDD) ;
+1 NEW RMPIMPDT
+2 SET RMPICDD=$SELECT(RMPICDD<0!($LENGTH(+RMPICDD)'=7):DT,1:+$GET(RMPICDD))
+3 SET RMPIMPDT=$$IMPDATE^LEXU("10D")
+4 QUIT $SELECT(RMPICDD'<RMPIMPDT:30,1:1)
+5 ;
+6 ;set parameters
+7 ;edit these hardcoded strings that are used for prompts, messages and so on to adjust them to your application's needs
+8 ;input parameters
+9 ; RMPPAR - local array to set and store string constants for your messages and prompts
SETPARAM(RMPPAR) ;
+1 SET RMPPAR("SEARCH_PROMPT")="ICD-10 DIAGNOSIS CODE: "
+2 SET RMPPAR("HELP ?")="^D INPHLP^RMPOICD1"
+3 SET RMPPAR("HELP ??")="^D INPHLP2^RMPOICD1"
+4 SET RMPPAR("NO DATA FOUND")=" No data found"
+5 SET RMPPAR("EXITING")=" Exiting"
+6 SET RMPPAR("TRY LATER")=" Try again later"
+7 SET RMPPAR("NO DATA SELECTED")=" No data selected"
+8 SET RMPPAR("TRY ANOTHER")="Try another"
+9 SET RMPPAR("WISH CONTINUE")="Do you wish to continue(Y/N)"
+10 SET RMPPAR("EXCEEDS MESSAGE1")="Searching for """
+11 SET RMPPAR("EXCEEDS MESSAGE2")=""" requires inspecting "
+12 SET RMPPAR("EXCEEDS MESSAGE3")=" records to determine if they match the search criteria. This could take quite some time. Suggest refining the search by further specifying """
+13 SET RMPPAR("NO CHANGES")=" No changes made"
+14 SET RMPPAR("DELETE IT")=" SURE YOU WANT TO DELETE"
+15 SET RMPPAR("ENTER MORE")=" Please enter at least the first two characters of the ICD-10 code or code"
+16 SET RMPPAR("ENTER MORE2")=" description to start the search."
+17 SET RMPPAR("YES OR NO")="Answer 'Y' for 'Yes' or 'N' for 'No'"
+18 QUIT
+19 ;
+20 ;
+21 ;a wrapper for ^DIWP
+22 ;accumulates a text and then writes it to the device
+23 ;input parameters :
+24 ; X - text
+25 ; RMPMODE:
+26 ; 0 - start
+27 ; 1 - accumulate
+28 ; 2 - write
+29 ;example:
+30 ;D FORMWRIT^ZZLXDG("this API is a wrapper for ^DIWP, it accumulates a text and then writes it to the device, you can use it in your application code",0)
+31 ;D FORMWRIT^ZZLXDG("some more text ",1)
+32 ;D FORMWRIT^ZZLXDG("",2)
FORMWRIT(X,RMPMODE) ;
+1 NEW RMPLI1
+2 ;if "start" mode
+3 IF RMPMODE=0
KILL ^UTILITY($JOB,"W")
+4 SET DIWL=1
SET DIWR=79
+5 IF $LENGTH(X)>0
DO ^DIWP
+6 ;if "write" mode
+7 IF RMPMODE=2
Begin DoDot:1
+8 SET RMPLI1=0
FOR
SET RMPLI1=$ORDER(^UTILITY($JOB,"W",1,RMPLI1))
if +RMPLI1=0
QUIT
WRITE !,$GET(^UTILITY($JOB,"W",1,RMPLI1,0))
+9 KILL ^UTILITY($JOB,"W")
End DoDot:1
+10 QUIT
+11 ;
+12 ;---------------
+13 ;Initialize variables if you need , your application most likely already has this
INITVARS ;
+1 DO HOME^%ZIS
+2 if $GET(DT)=0
SET DT=$$DT^XLFDT
+3 QUIT
+4 ;press any key (used for demo)
PRESSKEY ;
+1 READ !!,"Press any key to continue.",RMPKEY:DTIME
+2 QUIT
+3 ;display code info (used for demo)
CODEINFO(RMPXX2) ; Write Output
+1 NEW RMPKEY
+2 WRITE !," ICD Diagnosis code:",?30,$PIECE(RMPXX2,";",2)
+3 WRITE !," ICD Diagnosis code IEN:",?30,$PIECE(RMPXX2,";",1)
+4 WRITE !," Lexicon Expression IEN:",?30,+$PIECE(RMPXX2,";",3)
+5 WRITE !," ICD Diagnosis description:",?30,$PIECE(RMPXX2,"^",2)
+6 QUIT
+7 ;
