LRAPICD ;ALB/JAM - Anatomic Pathology ICD-10 DIAGNOSIS CODE API ;6/15/12
;;5.2;LAB SERVICE;**422**;Sep 27, 1994;Build 29
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;Routine based on ^ZZLXDG and ^ICDLOOK
;
; Reference to $$CODEC^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR #5747
; Reference to $$SINFO^ICDEX supported by ICR #5747
; 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
;
EN(LRDXV) ;
N LRDFN,LRSS,LRI,CFL
I LRDXV="" Q
S LRDFN=$P(LRDXV,";"),LRSS=$P(LRDXV,";",2),LRI=$P(LRDXV,";",3)
I LRDFN="" Q
I LRSS'="AU",LRI="" Q
S CFL=0
D GETDX
D DEMO
I CFL D DXSAV
K X,Y
Q
;
;this is a demo code,
;in your applications you might need to use some or all of the code below,
;see comments
DEMO ;
N QUIT ; to manage demo loop
N LRETV ;to store the selected code information
N PARAM ; to set your application specific prompts and messages
N CSYS ;coding system "ICD9" or ICD10"
N LROUT ;to return all available information about the selected code
N DEFLV ;default ICD value for demo
N LRADT
;settings:
S LRADT=$P($G(LRICDT,DT),".")
;determine coding system based on the date of interest
S CSYS=$$ICDSYSDG(LRADT)
S DEFLV=$O(LRADX(""))
D SETPARAM(.PARAM) ;edit the SETPARAM subroutine below to set your application specific prompts
;starting demo loop
S QUIT=0 F Q:QUIT=1 D
. S LRETV=0,LROUT=""
. ;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 CSYS=1 S LRETV=$$DIAG9(LRADT,DEFLV,.LROUT,.PARAM) I LRETV=-2 S:$$QUESTION(1,PARAM("TRY ANOTHER"))'=1 QUIT=1 Q
. ;ICD10 (30 is a pointer to the ICD-10 diagnosis system entry in the new file #80.4 )
. I CSYS=30 S LRETV=$$DIAG10(LRADT,.DEFLV,.PARAM)
. ;display information about the code selected (for demo purposes)
. I LRETV>0 S LRADX($P(LRETV,";",2))=+LRETV D CODEINFO(LRETV) W ! D DXDSP S DEFLV="",CFL=1 W ! Q
. ;if no data found
. I LRETV="" W !!,PARAM("NO DATA FOUND"),!,PARAM("NO DATA FOUND 2"),! Q
. ;in ICD10 if the user answered NO for the question "Do you wish to continue(Y/N)?"
. I +LRETV=-4 Q
. ;no changes to the default value
. I +LRETV=-5 S QUIT=1 Q
. ;no data or was aborted
. I +LRETV=-2 S QUIT=1 Q
. ;if exit due to ^ in the ICD Diagnosis code prompt
. I +LRETV=-3 S QUIT=1 Q
. ;if no data found
. I +LRETV=-1 S:$P(LRETV,"^",2)=-1 QUIT=1 Q
. ;user entered "@" to delete the currently selected ICD code
. I +LRETV=-6 D Q
..I DEFLV="" W " <NOTHING TO DELETE>" Q
..I $$QUESTION(1,PARAM("DELETE"))=1 K:DEFLV'="" LRADX(DEFLV) D DXDSP S DEFLV=$O(LRADX("")),CFL=1 Q
..W " <NOTHING DELETED>",!
. ; if continue search
Q
;
;//---------
;The entry point for ICD-10 diagnosis search functionality
;can be called from applications directly
;input parameters :
; LRADT - date of interest (Fileman format)
; LRADFLT - default values for the search string (can be a code by default)
; PARAM - 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(LRADT,LRADFLT,PARAM) ;
N LRAINP,XX
F D Q:LRAINP<0!($L($P(LRAINP,U,2))>1)
. S LRAINP=$$SRCHSTR(PARAM("SEARCH_PROMPT"),PARAM("HELP ?"),PARAM("HELP ??"),LRADFLT)
. I LRAINP'<0 I $L($P(LRAINP,U,2))'>1 W !!,PARAM("ENTER MORE") W:$L(PARAM("ENTER MORE2"))>0 !,PARAM("ENTER MORE2") W ! ;user should enter at least 2 characters
I LRAINP<0 Q +LRAINP_"^-1"
I $D(LRADX($P(LRAINP,U,2))) D Q $P(LRAINP,U)_"^"_XX
.S XX=$$ICDDX^ICDEX($P(LRAINP,U,2),LRADT,30,"E"),LRADFLT=$P(XX,U,2),XX=$TR(XX,"^",";"),CFL=1
Q $$LEXICD10($P(LRAINP,U,2),LRADT,.PARAM)
;
;//---------
;The entry point for ICD-9 FileMan type (^DIC) diagnosis search functionality
;can be called from applications directly
;input parameters :
; LRADT - date of interest
; LRADFLT - default values for the search string (can be a code by default)
; LROUT - local array to return results(passed as a reference)
; PARAM - 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
DIAG9(LRADT,LRADFLT,LROUT,PARAM) ;
N LRAINP,LRETV,CDE9
S LRETV=$$ICD9(LRADFLT,LRADT,.LROUT,PARAM("SEARCH_PROMPT"))
I LRETV=-1 Q -2
I LRETV<0 Q +LRETV
S CDE9=$P(LRETV,U)
I $D(LRADX($P(CDE9,";",2))) D Q $P(CDE9,U)_"^"_XX
.S XX=$$ICDDX^ICDEX($P(CDE9,U,2),LRADT,1,"E"),LRADFLT=$P(XX,U,2),XX=$TR(XX,"^",";"),CFL=1
Q LRETV
;
;--------------
;The entry point for ICD-10 diagnosis search functionality
;can be called from applications directly
; Supported ICR 5681 ($$DIAGSRCH^LEX10CS)
;input parameters :
; LRATXT - search string
; LRADATE - date of interest
; LRAPAR - 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(LRATXT,LRADATE,LRAPAR) ; ICD-10 Search
N LRALVTXT
;parameters check
S LRADATE=+$G(LRADATE)
I LRADATE'?7N Q -1
S LRATXT=$G(LRATXT)
Q:'$L(LRATXT) -1
N LRANUMB
S LRANUMB=$$FREQ^LEXU(LRATXT)
I LRANUMB>$$MAX^LEXU(30) D I $$QUESTION(2,PARAM("WISH CONTINUE"))'=1 Q -4
. W !
. D FORMWRIT(LRAPAR("EXCEEDS MESSAGE1")_LRATXT_LRAPAR("EXCEEDS MESSAGE2")_LRANUMB_LRAPAR("EXCEEDS MESSAGE3")_LRATXT_""".",0)
. D FORMWRIT("",2)
. W !
;new and set variables
N DIROUT,DUOUT,DTOUT,LRAEXIT,LRAICDNT
N LRETV,LRAXX,LRALEVEL
S LRETV=""
S LRAEXIT=0
S LRALEVEL=1,LRALVTXT(LRALEVEL)=LRATXT ;level 1 stores the original search string
; main loop
F Q:LRAEXIT>0 D
.K LRAICDY
.;get the search string from the current level and call LEX API
.S LRAICDY=$$DIAGSRCH^LEX10CS(LRALVTXT(LRALEVEL),.LRAICDY,LRADATE,30)
.S:$O(LRAICDY(" "),-1)>0 LRAICDY=+LRAICDY
.; Nothing found
.I +LRAICDY'>0 S LRAEXIT=1 S LRAXX=-1 Q
.; display the list of items and ask the user to select the item from the list
.S LRAXX=$$SEL^LRAPICD2(.LRAICDY,8)
.; if ^ was entered
.; if this is on the top level then quit
.I LRAXX=-2,LRALEVEL'>1 S LRETV=-1 S LRAEXIT=1 Q
.; if lower level then go one level up
.I LRAXX=-2,LRALEVEL>1 S:LRALEVEL>1 LRALEVEL=LRALEVEL-1 Q
.; If timeout, or not selected, or ^^ then quit
.I LRAXX=-1 S LRETV=-1 S LRAEXIT=1 Q
.; if Code Found and Selected by the user save selection in LRETV and quit
.I $P(LRAXX,";")'="99:CAT" S LRETV=LRAXX S LRAEXIT=1 Q
.; If Category Found and Selected by the user:
.; go to the next inner level
.; change level number
.S LRALEVEL=LRALEVEL+1
.; set the new level with the new search string
.; and repeat
.S LRALVTXT(LRALEVEL)=$P($P($G(LRAXX),"^"),";",2)
Q LRETV
;----------
;ICD-9 lookup (FileMan lookup)
;Supported ICR 5773 (FileMan lookup for files #80 and #80.1)
;Supported ICR 5699 ($$ICDDATA^ICDXCODE)
;Supported ICR 5747 ($$CSI^ICDEX)
;input parameters :
; LRASRCH - search string
; LRAICDT - date of interest
; LROUT - local array to return detailed info (passed as a reference)
;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 LROUT returns details if the return value >0, here is an example:
; LROUT="6065^814.14"
; LROUT(0)=814.14
; LROUT(0,0)=814.14
; LROUT(0,1)="6065^814.14^^FX PISIFORM-OPEN^^8^^1^^1^^^0^^^^2781001^^1^1"
; LROUT(0,2)="OPEN FRACTURE OF PISIFORM BONE OF WRIST"
;Note: this API is not silent because the ICD lookup is not silent
ICD9(LRASRCH,LRAICDT,LROUT,LRAPRMT) ;
N KEY,X,Y,DIC,LRACDS
;KEY must be newed as ICD lookup code doesn't kill it
S DIC="^ICD9(",DIC(0)="EQMNZIA"
S:$G(LRAPRMT)]"" DIC("A")=LRAPRMT
S:$G(LRASRCH)]"" DIC("B")=LRASRCH
S LRACDS="ICD9"
;note: you must use Y for the 2nd parameter of $$ICDDATA^ICDXCODE
S DIC("S")="I $$LS^ICDEX(80,+Y,LRAICDT)>0,$$CSI^ICDEX(80,+Y)=1"
D ^DIC
M LROUT=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
;
;-----------
; Diagnosis display
DXDSP ;
N DXS
S DXS=""
F S DXS=$O(LRADX(DXS)) Q:DXS="" D
. ; Determine Active Coding System Based on Date of Interest
. S LRCS=$$SINFO^ICDEX("DIAG",$G(LRADT)) ; Supported by ICR 5747
. W !,?4,DXS,?15,$P($$ICDDX^ICDEX(DXS,$G(LRADT),+LRCS,"E"),"^",4) ; Supported by ICR 5747
Q
;-----------
; Look-up help for ?
INPHLP ;
N DXS,LRCS
I $D(LRADX) D
. W !?4,"Answer with ICD DIAGNOSIS"
. W !?5,"Choose from:"
. D DXDSP W !
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
;--------
;ask YES/NO questions
;input parameters :
; LRADFLT- 0/null- not default, 1- yes, 2 -no
; LRAPROM - prompt string
;returns
; 2 - no,
; 1 - yes,
; 0 - no answer (time out)
; -3 - ^ or ^^
QUESTION(LRADFLT,LRAPROM) ;
N DIR
S %=$G(LRADFLT,2)
S DIR(0)="Y",DIR("A")=LRAPROM,DIR("B")=$S(%=1:"Yes",%=2:"No",1:"")
D ^DIR
Q:Y["^" -3
Q:Y=1 1
Q:Y=0 2
Q 0
;
;------------
;get search string
;input parameters :
; LRAPRMT prompt text
; LRAHLP1 "?" help text
; LRAHLP2 "??" help text
; LRADFLT- 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(LRAPRMT,LRAHLP1,LRAHLP2,LRADFLT) ;
N DIR
S DIR("A")=LRAPRMT
S DIR("?")=LRAHLP1
S DIR("??")=LRAHLP2
I $L($G(LRADFLT)) S DIR("B")=LRADFLT
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(LRADFLT)))&(Y=LRADFLT)) -5 ;if user accepts default value then no need to validate it
Q 0_U_$$UP^XLFSTR(Y)
;
;----------
;Determines and returns ACTIVE coding system for DIAGNOSES based on date of interest
;input parameters :
; LRAICDD - 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(LRAICDD) ;
N LRAIMPDT
S LRAICDD=$S(LRAICDD<0!($L(+LRAICDD)'=7):DT,1:+$G(LRAICDD))
S LRAIMPDT=$$IMPDATE^LEXU("10D")
Q $S(LRAICDD'<LRAIMPDT: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
; LRAPAR - local array to sets and store string constants for your messages and prompts
SETPARAM(LRAPAR) ;
;S LRAPAR("ASKDATE")="Date of interest? "
S LRAPAR("SEARCH_PROMPT")="Select "_$S(LRSS="AU":"AUTOPSY ICD CODE",LRSS="EM":"ICD CODE",1:"ICD DIAGNOSIS")_": "
S LRAPAR("HELP ?")="^D INPHLP^LRAPICD"
S LRAPAR("HELP ??")="^D INPHLP^LRAPICD"
S LRAPAR("NO DATA FOUND")=" No records found matching the value entered, revise search or enter ""?"" for"
S LRAPAR("NO DATA FOUND 2")=" help."
S LRAPAR("EXITING")=" Exiting"
S LRAPAR("TRY LATER")=" Try again later"
S LRAPAR("NO DATA SELECTED")=" No data selected"
S LRAPAR("TRY ANOTHER")="Try another"
S LRAPAR("WISH CONTINUE")="Do you wish to continue (Y/N)"
S LRAPAR("EXCEEDS MESSAGE1")="Searching for """
S LRAPAR("EXCEEDS MESSAGE2")=""" requires inspecting "
S LRAPAR("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 LRAPAR("NO CHANGES")=" No changes made"
S LRAPAR("DELETE")=" SURE YOU WANT TO DELETE"
S LRAPAR("ENTER MORE")=" Please enter at least the first two characters of the ICD-10 code or code"
S LRAPAR("ENTER MORE2")=" description to start the search."
Q
;
;a wrapper for ^DIWP
;accumulates a text and then writes it to the device
;input parameters :
; X - text
; LRAMODE:
; 0 - start
; 1 - accumulate
; 2 - write
;example:
;D FORMWRIT^LRAPICD("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^LRAPICD("some more text ",1)
;D FORMWRIT^LRAPICD("",2)
FORMWRIT(X,LRAMODE) ;
N LRALI1,DIWL,DIWR
;if "start" mode
I LRAMODE=0 K ^UTILITY($J,"W")
S DIWL=1,DIWR=79
I $L(X)>0 D ^DIWP
;if "write" mode
I LRAMODE=2 D
. S LRALI1=0 F S LRALI1=$O(^UTILITY($J,"W",1,LRALI1)) Q:+LRALI1=0 W !,$G(^UTILITY($J,"W",1,LRALI1,0))
. K ^UTILITY($J,"W")
Q
;
;---------------
;press any key (used for demo)
PRESSKEY ;
N LRAKEY
R !!,"Press any key to continue.",LRAKEY:DTIME
Q
;display code info (used for demo)
CODEINFO(LRAXX2) ; Write Output
W " ",$P(LRAXX2,";",2)
Q
;
GETDX ;Get DX and set in LRADX array
N DX,DXC,CDE
K LRADX
S DX=0
I LRSS="AU" D Q
.F S DX=$O(^LR(LRDFN,80,DX)) Q:'DX D
..S DXC=$$CODEC^ICDEX(80,DX) Q:DXC<0 S LRADX(DXC)=DX
F S DX=$O(^LR(LRDFN,LRSS,LRI,3,DX)) Q:'DX D
.S CDE=+$G(^LR(LRDFN,LRSS,LRI,3,DX,0)) I 'CDE Q
.S DXC=$$CODEC^ICDEX(80,CDE) Q:DXC<0 S LRADX(DXC)=CDE
Q
;
DXSAV ;Save diagnosis codes
N DX,DXC,TMPDX,LRDXS,LRIEN,LRFL,DIK,DA
S DX=""
F S DX=$O(LRADX(DX)) Q:DX="" S TMPDX(LRADX(DX))=""
I LRSS="AU" S DX=0 D Q
.F S DX=$O(^LR(LRDFN,80,DX)) Q:'DX D
..I $D(TMPDX(DX)) K TMPDX(DX) Q
..I '$D(TMPDX(DX)) S DA(1)=LRDFN,DA=DX,DIK="^LR("_DA(1)_",80," D ^DIK Q
.S DX=0 F S DX=$O(TMPDX(DX)) Q:'DX D
..K LRIEN,LRDXS
..S LRIEN(1)=DX
..S LRDXS(63.808,"+1,"_LRDFN_",",.01)=DX
..D UPDATE^DIE("","LRDXS","LRIEN")
S DX=0
; save DX code to subfiles - 63.02(EM); 63.08 (SP); or 63.09 (CY)
; .01 field is DINUM except for subfile 68.02 (EM)
F S DX=$O(^LR(LRDFN,LRSS,LRI,3,DX)) Q:'DX D
.I $D(TMPDX(DX)) K TMPDX(DX) Q
.I '$D(TMPDX(DX)) S DA(2)=LRDFN,DA(1)=LRI,DA=DX,DIK="^LR("_DA(2)_","""_LRSS_""","_DA(1)_",3," D ^DIK Q
S LRFL=$S(LRSS="EM":63.203,LRSS="SP":63.88,1:63.901)
S DX=0 F S DX=$O(TMPDX(DX)) Q:'DX D
.K LRIEN,LRDXS
.S:LRSS'="EM" LRIEN(3)=DX
.S LRDXS(LRFL,"+3,"_LRI_","_LRDFN_",",.01)=DX
.D UPDATE^DIE("","LRDXS","LRIEN")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPICD 16265 printed Sep 23, 2025@19:43:08 Page 2
LRAPICD ;ALB/JAM - Anatomic Pathology ICD-10 DIAGNOSIS CODE API ;6/15/12
+1 ;;5.2;LAB SERVICE;**422**;Sep 27, 1994;Build 29
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Routine based on ^ZZLXDG and ^ICDLOOK
+5 ;
+6 ; Reference to $$CODEC^ICDEX supported by ICR #5747
+7 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+8 ; Reference to $$SINFO^ICDEX supported by ICR #5747
+9 ; Reference to $$DIAGSRCH^LEX10CS supported by ICR #5681
+10 ; Reference to $$IMPDATE^LEXU supported by ICR #5679
+11 ; Reference to $$FREQ^LEXU supported by ICR #5679
+12 ; Reference to $$MAX^LEXU supported by ICR #5679
+13 ;
EN(LRDXV) ;
+1 NEW LRDFN,LRSS,LRI,CFL
+2 IF LRDXV=""
QUIT
+3 SET LRDFN=$PIECE(LRDXV,";")
SET LRSS=$PIECE(LRDXV,";",2)
SET LRI=$PIECE(LRDXV,";",3)
+4 IF LRDFN=""
QUIT
+5 IF LRSS'="AU"
IF LRI=""
QUIT
+6 SET CFL=0
+7 DO GETDX
+8 DO DEMO
+9 IF CFL
DO DXSAV
+10 KILL X,Y
+11 QUIT
+12 ;
+13 ;this is a demo code,
+14 ;in your applications you might need to use some or all of the code below,
+15 ;see comments
DEMO ;
+1 ; to manage demo loop
NEW QUIT
+2 ;to store the selected code information
NEW LRETV
+3 ; to set your application specific prompts and messages
NEW PARAM
+4 ;coding system "ICD9" or ICD10"
NEW CSYS
+5 ;to return all available information about the selected code
NEW LROUT
+6 ;default ICD value for demo
NEW DEFLV
+7 NEW LRADT
+8 ;settings:
+9 SET LRADT=$PIECE($GET(LRICDT,DT),".")
+10 ;determine coding system based on the date of interest
+11 SET CSYS=$$ICDSYSDG(LRADT)
+12 SET DEFLV=$ORDER(LRADX(""))
+13 ;edit the SETPARAM subroutine below to set your application specific prompts
DO SETPARAM(.PARAM)
+14 ;starting demo loop
+15 SET QUIT=0
FOR
if QUIT=1
QUIT
Begin DoDot:1
+16 SET LRETV=0
SET LROUT=""
+17 ;run either ICD9 or ICD10 prompt/search/select logic
+18 ;ICD9 (1 is a pointer to the ICD-9 diagnosis system entry in the new file #80.4 )
+19 ;I CSYS=1 S LRETV=$$DIAG9(LRADT,DEFLV,.LROUT,.PARAM) I LRETV=-2 S:$$QUESTION(1,PARAM("TRY ANOTHER"))'=1 QUIT=1 Q
+20 ;ICD10 (30 is a pointer to the ICD-10 diagnosis system entry in the new file #80.4 )
+21 IF CSYS=30
SET LRETV=$$DIAG10(LRADT,.DEFLV,.PARAM)
+22 ;display information about the code selected (for demo purposes)
+23 IF LRETV>0
SET LRADX($PIECE(LRETV,";",2))=+LRETV
DO CODEINFO(LRETV)
WRITE !
DO DXDSP
SET DEFLV=""
SET CFL=1
WRITE !
QUIT
+24 ;if no data found
+25 IF LRETV=""
WRITE !!,PARAM("NO DATA FOUND"),!,PARAM("NO DATA FOUND 2"),!
QUIT
+26 ;in ICD10 if the user answered NO for the question "Do you wish to continue(Y/N)?"
+27 IF +LRETV=-4
QUIT
+28 ;no changes to the default value
+29 IF +LRETV=-5
SET QUIT=1
QUIT
+30 ;no data or was aborted
+31 IF +LRETV=-2
SET QUIT=1
QUIT
+32 ;if exit due to ^ in the ICD Diagnosis code prompt
+33 IF +LRETV=-3
SET QUIT=1
QUIT
+34 ;if no data found
+35 IF +LRETV=-1
if $PIECE(LRETV,"^",2)=-1
SET QUIT=1
QUIT
+36 ;user entered "@" to delete the currently selected ICD code
+37 IF +LRETV=-6
Begin DoDot:2
+38 IF DEFLV=""
WRITE " <NOTHING TO DELETE>"
QUIT
+39 IF $$QUESTION(1,PARAM("DELETE"))=1
if DEFLV'=""
KILL LRADX(DEFLV)
DO DXDSP
SET DEFLV=$ORDER(LRADX(""))
SET CFL=1
QUIT
+40 WRITE " <NOTHING DELETED>",!
End DoDot:2
QUIT
+41 ; if continue search
End DoDot:1
+42 QUIT
+43 ;
+44 ;//---------
+45 ;The entry point for ICD-10 diagnosis search functionality
+46 ;can be called from applications directly
+47 ;input parameters :
+48 ; LRADT - date of interest (Fileman format)
+49 ; LRADFLT - default values for the search string (can be a code by default)
+50 ; PARAM - parameters/string constants (see SETPARAM for details)
+51 ;returns ICD-10 code selected by the user:
+52 ; IEN file #80;ICD code value;IEN file # 757.01^description
+53 ; results
+54 ; or -1 if invalid data(press enter)
+55 ; "" if not found
+56 ; or -2 if time out
+57 ; or -3 if ^ or ^^
+58 ; or -4 in ICD10 if the user answered NO for the question "Do you wish to continue(Y/N)?"
+59 ; or -5 if no changes to the default value
DIAG10(LRADT,LRADFLT,PARAM) ;
+1 NEW LRAINP,XX
+2 FOR
Begin DoDot:1
+3 SET LRAINP=$$SRCHSTR(PARAM("SEARCH_PROMPT"),PARAM("HELP ?"),PARAM("HELP ??"),LRADFLT)
+4 ;user should enter at least 2 characters
IF LRAINP'<0
IF $LENGTH($PIECE(LRAINP,U,2))'>1
WRITE !!,PARAM("ENTER MORE")
if $LENGTH(PARAM("ENTER MORE2"))>0
WRITE !,PARAM("ENTER MORE2")
WRITE !
End DoDot:1
if LRAINP<0!($LENGTH($PIECE(LRAINP,U,2))>1)
QUIT
+5 IF LRAINP<0
QUIT +LRAINP_"^-1"
+6 IF $DATA(LRADX($PIECE(LRAINP,U,2)))
Begin DoDot:1
+7 SET XX=$$ICDDX^ICDEX($PIECE(LRAINP,U,2),LRADT,30,"E")
SET LRADFLT=$PIECE(XX,U,2)
SET XX=$TRANSLATE(XX,"^",";")
SET CFL=1
End DoDot:1
QUIT $PIECE(LRAINP,U)_"^"_XX
+8 QUIT $$LEXICD10($PIECE(LRAINP,U,2),LRADT,.PARAM)
+9 ;
+10 ;//---------
+11 ;The entry point for ICD-9 FileMan type (^DIC) diagnosis search functionality
+12 ;can be called from applications directly
+13 ;input parameters :
+14 ; LRADT - date of interest
+15 ; LRADFLT - default values for the search string (can be a code by default)
+16 ; LROUT - local array to return results(passed as a reference)
+17 ; PARAM - parameters/string constants (see SETPARAM for details)
+18 ;returns ICD-9 code selected by the user:
+19 ; IEN file #80;ICD code value^description
+20 ; -1 no data or was aborted
+21 ; -2 if timeout
DIAG9(LRADT,LRADFLT,LROUT,PARAM) ;
+1 NEW LRAINP,LRETV,CDE9
+2 SET LRETV=$$ICD9(LRADFLT,LRADT,.LROUT,PARAM("SEARCH_PROMPT"))
+3 IF LRETV=-1
QUIT -2
+4 IF LRETV<0
QUIT +LRETV
+5 SET CDE9=$PIECE(LRETV,U)
+6 IF $DATA(LRADX($PIECE(CDE9,";",2)))
Begin DoDot:1
+7 SET XX=$$ICDDX^ICDEX($PIECE(CDE9,U,2),LRADT,1,"E")
SET LRADFLT=$PIECE(XX,U,2)
SET XX=$TRANSLATE(XX,"^",";")
SET CFL=1
End DoDot:1
QUIT $PIECE(CDE9,U)_"^"_XX
+8 QUIT LRETV
+9 ;
+10 ;--------------
+11 ;The entry point for ICD-10 diagnosis search functionality
+12 ;can be called from applications directly
+13 ; Supported ICR 5681 ($$DIAGSRCH^LEX10CS)
+14 ;input parameters :
+15 ; LRATXT - search string
+16 ; LRADATE - date of interest
+17 ; LRAPAR - array with text messages and other string constants
+18 ;returns ICD-10 code selected by the user:
+19 ; IEN file #80;ICD code value^description
+20 ; or
+21 ; "" if not found
+22 ; -1 if exit : ^ or ^^
+23 ; -2 if continue searching
+24 ;
LEXICD10(LRATXT,LRADATE,LRAPAR) ; ICD-10 Search
+1 NEW LRALVTXT
+2 ;parameters check
+3 SET LRADATE=+$GET(LRADATE)
+4 IF LRADATE'?7N
QUIT -1
+5 SET LRATXT=$GET(LRATXT)
+6 if '$LENGTH(LRATXT)
QUIT -1
+7 NEW LRANUMB
+8 SET LRANUMB=$$FREQ^LEXU(LRATXT)
+9 IF LRANUMB>$$MAX^LEXU(30)
Begin DoDot:1
+10 WRITE !
+11 DO FORMWRIT(LRAPAR("EXCEEDS MESSAGE1")_LRATXT_LRAPAR("EXCEEDS MESSAGE2")_LRANUMB_LRAPAR("EXCEEDS MESSAGE3")_LRATXT_""".",0)
+12 DO FORMWRIT("",2)
+13 WRITE !
End DoDot:1
IF $$QUESTION(2,PARAM("WISH CONTINUE"))'=1
QUIT -4
+14 ;new and set variables
+15 NEW DIROUT,DUOUT,DTOUT,LRAEXIT,LRAICDNT
+16 NEW LRETV,LRAXX,LRALEVEL
+17 SET LRETV=""
+18 SET LRAEXIT=0
+19 ;level 1 stores the original search string
SET LRALEVEL=1
SET LRALVTXT(LRALEVEL)=LRATXT
+20 ; main loop
+21 FOR
if LRAEXIT>0
QUIT
Begin DoDot:1
+22 KILL LRAICDY
+23 ;get the search string from the current level and call LEX API
+24 SET LRAICDY=$$DIAGSRCH^LEX10CS(LRALVTXT(LRALEVEL),.LRAICDY,LRADATE,30)
+25 if $ORDER(LRAICDY(" "),-1)>0
SET LRAICDY=+LRAICDY
+26 ; Nothing found
+27 IF +LRAICDY'>0
SET LRAEXIT=1
SET LRAXX=-1
QUIT
+28 ; display the list of items and ask the user to select the item from the list
+29 SET LRAXX=$$SEL^LRAPICD2(.LRAICDY,8)
+30 ; if ^ was entered
+31 ; if this is on the top level then quit
+32 IF LRAXX=-2
IF LRALEVEL'>1
SET LRETV=-1
SET LRAEXIT=1
QUIT
+33 ; if lower level then go one level up
+34 IF LRAXX=-2
IF LRALEVEL>1
if LRALEVEL>1
SET LRALEVEL=LRALEVEL-1
QUIT
+35 ; If timeout, or not selected, or ^^ then quit
+36 IF LRAXX=-1
SET LRETV=-1
SET LRAEXIT=1
QUIT
+37 ; if Code Found and Selected by the user save selection in LRETV and quit
+38 IF $PIECE(LRAXX,";")'="99:CAT"
SET LRETV=LRAXX
SET LRAEXIT=1
QUIT
+39 ; If Category Found and Selected by the user:
+40 ; go to the next inner level
+41 ; change level number
+42 SET LRALEVEL=LRALEVEL+1
+43 ; set the new level with the new search string
+44 ; and repeat
+45 SET LRALVTXT(LRALEVEL)=$PIECE($PIECE($GET(LRAXX),"^"),";",2)
End DoDot:1
+46 QUIT LRETV
+47 ;----------
+48 ;ICD-9 lookup (FileMan lookup)
+49 ;Supported ICR 5773 (FileMan lookup for files #80 and #80.1)
+50 ;Supported ICR 5699 ($$ICDDATA^ICDXCODE)
+51 ;Supported ICR 5747 ($$CSI^ICDEX)
+52 ;input parameters :
+53 ; LRASRCH - search string
+54 ; LRAICDT - date of interest
+55 ; LROUT - local array to return detailed info (passed as a reference)
+56 ;returns ICD-9 code selected by the user:
+57 ; IEN file #80;ICD code value^description
+58 ; or
+59 ; -1 if exit : ^ or ^^
+60 ; -2 if no results (timeout)
+61 ;the array LROUT returns details if the return value >0, here is an example:
+62 ; LROUT="6065^814.14"
+63 ; LROUT(0)=814.14
+64 ; LROUT(0,0)=814.14
+65 ; LROUT(0,1)="6065^814.14^^FX PISIFORM-OPEN^^8^^1^^1^^^0^^^^2781001^^1^1"
+66 ; LROUT(0,2)="OPEN FRACTURE OF PISIFORM BONE OF WRIST"
+67 ;Note: this API is not silent because the ICD lookup is not silent
ICD9(LRASRCH,LRAICDT,LROUT,LRAPRMT) ;
+1 NEW KEY,X,Y,DIC,LRACDS
+2 ;KEY must be newed as ICD lookup code doesn't kill it
+3 SET DIC="^ICD9("
SET DIC(0)="EQMNZIA"
+4 if $GET(LRAPRMT)]""
SET DIC("A")=LRAPRMT
+5 if $GET(LRASRCH)]""
SET DIC("B")=LRASRCH
+6 SET LRACDS="ICD9"
+7 ;note: you must use Y for the 2nd parameter of $$ICDDATA^ICDXCODE
+8 SET DIC("S")="I $$LS^ICDEX(80,+Y,LRAICDT)>0,$$CSI^ICDEX(80,+Y)=1"
+9 DO ^DIC
+10 MERGE LROUT=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 ; Diagnosis display
DXDSP ;
+1 NEW DXS
+2 SET DXS=""
+3 FOR
SET DXS=$ORDER(LRADX(DXS))
if DXS=""
QUIT
Begin DoDot:1
+4 ; Determine Active Coding System Based on Date of Interest
+5 ; Supported by ICR 5747
SET LRCS=$$SINFO^ICDEX("DIAG",$GET(LRADT))
+6 ; Supported by ICR 5747
WRITE !,?4,DXS,?15,$PIECE($$ICDDX^ICDEX(DXS,$GET(LRADT),+LRCS,"E"),"^",4)
End DoDot:1
+7 QUIT
+8 ;-----------
+9 ; Look-up help for ?
INPHLP ;
+1 NEW DXS,LRCS
+2 IF $DATA(LRADX)
Begin DoDot:1
+3 WRITE !?4,"Answer with ICD DIAGNOSIS"
+4 WRITE !?5,"Choose from:"
+5 DO DXDSP
WRITE !
End DoDot:1
+6 IF $GET(X)["???"
DO INPHLP3
QUIT
+7 IF $GET(X)["??"
DO INPHLP2
QUIT
+8 WRITE !," Enter code or ""text"" for more information."
QUIT
+9 QUIT
+10 ;-----------
+11 ; 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 ;ask YES/NO questions
+18 ;input parameters :
+19 ; LRADFLT- 0/null- not default, 1- yes, 2 -no
+20 ; LRAPROM - prompt string
+21 ;returns
+22 ; 2 - no,
+23 ; 1 - yes,
+24 ; 0 - no answer (time out)
+25 ; -3 - ^ or ^^
QUESTION(LRADFLT,LRAPROM) ;
+1 NEW DIR
+2 SET %=$GET(LRADFLT,2)
+3 SET DIR(0)="Y"
SET DIR("A")=LRAPROM
SET DIR("B")=$SELECT(%=1:"Yes",%=2:"No",1:"")
+4 DO ^DIR
+5 if Y["^"
QUIT -3
+6 if Y=1
QUIT 1
+7 if Y=0
QUIT 2
+8 QUIT 0
+9 ;
+10 ;------------
+11 ;get search string
+12 ;input parameters :
+13 ; LRAPRMT prompt text
+14 ; LRAHLP1 "?" help text
+15 ; LRAHLP2 "??" help text
+16 ; LRADFLT- default response
+17 ;returns piece1 ^ piece 2
+18 ; piece1:
+19 ; 0 if normal input
+20 ; or -1 if invalid data
+21 ; or -2 if time out
+22 ; or -3 if ^
+23 ; or -5 if user accepts default value then no need to validate it
+24 ; or -6 if user enters "@"
+25 ; piece2: string entered by the user
SRCHSTR(LRAPRMT,LRAHLP1,LRAHLP2,LRADFLT) ;
+1 NEW DIR
+2 SET DIR("A")=LRAPRMT
+3 SET DIR("?")=LRAHLP1
+4 SET DIR("??")=LRAHLP2
+5 IF $LENGTH($GET(LRADFLT))
SET DIR("B")=LRADFLT
+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(LRADFLT)))&(Y=LRADFLT))
QUIT -5
+14 QUIT 0_U_$$UP^XLFSTR(Y)
+15 ;
+16 ;----------
+17 ;Determines and returns ACTIVE coding system for DIAGNOSES based on date of interest
+18 ;input parameters :
+19 ; LRAICDD - 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(LRAICDD) ;
+1 NEW LRAIMPDT
+2 SET LRAICDD=$SELECT(LRAICDD<0!($LENGTH(+LRAICDD)'=7):DT,1:+$GET(LRAICDD))
+3 SET LRAIMPDT=$$IMPDATE^LEXU("10D")
+4 QUIT $SELECT(LRAICDD'<LRAIMPDT: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 ; LRAPAR - local array to sets and store string constants for your messages and prompts
SETPARAM(LRAPAR) ;
+1 ;S LRAPAR("ASKDATE")="Date of interest? "
+2 SET LRAPAR("SEARCH_PROMPT")="Select "_$SELECT(LRSS="AU":"AUTOPSY ICD CODE",LRSS="EM":"ICD CODE",1:"ICD DIAGNOSIS")_": "
+3 SET LRAPAR("HELP ?")="^D INPHLP^LRAPICD"
+4 SET LRAPAR("HELP ??")="^D INPHLP^LRAPICD"
+5 SET LRAPAR("NO DATA FOUND")=" No records found matching the value entered, revise search or enter ""?"" for"
+6 SET LRAPAR("NO DATA FOUND 2")=" help."
+7 SET LRAPAR("EXITING")=" Exiting"
+8 SET LRAPAR("TRY LATER")=" Try again later"
+9 SET LRAPAR("NO DATA SELECTED")=" No data selected"
+10 SET LRAPAR("TRY ANOTHER")="Try another"
+11 SET LRAPAR("WISH CONTINUE")="Do you wish to continue (Y/N)"
+12 SET LRAPAR("EXCEEDS MESSAGE1")="Searching for """
+13 SET LRAPAR("EXCEEDS MESSAGE2")=""" requires inspecting "
+14 SET LRAPAR("EXCEEDS MESSAGE3")=" records to determine if they match the search criteria. This could take quite some time. Suggest refining the search by further specifying """
+15 SET LRAPAR("NO CHANGES")=" No changes made"
+16 SET LRAPAR("DELETE")=" SURE YOU WANT TO DELETE"
+17 SET LRAPAR("ENTER MORE")=" Please enter at least the first two characters of the ICD-10 code or code"
+18 SET LRAPAR("ENTER MORE2")=" description to start the search."
+19 QUIT
+20 ;
+21 ;a wrapper for ^DIWP
+22 ;accumulates a text and then writes it to the device
+23 ;input parameters :
+24 ; X - text
+25 ; LRAMODE:
+26 ; 0 - start
+27 ; 1 - accumulate
+28 ; 2 - write
+29 ;example:
+30 ;D FORMWRIT^LRAPICD("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^LRAPICD("some more text ",1)
+32 ;D FORMWRIT^LRAPICD("",2)
FORMWRIT(X,LRAMODE) ;
+1 NEW LRALI1,DIWL,DIWR
+2 ;if "start" mode
+3 IF LRAMODE=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 LRAMODE=2
Begin DoDot:1
+8 SET LRALI1=0
FOR
SET LRALI1=$ORDER(^UTILITY($JOB,"W",1,LRALI1))
if +LRALI1=0
QUIT
WRITE !,$GET(^UTILITY($JOB,"W",1,LRALI1,0))
+9 KILL ^UTILITY($JOB,"W")
End DoDot:1
+10 QUIT
+11 ;
+12 ;---------------
+13 ;press any key (used for demo)
PRESSKEY ;
+1 NEW LRAKEY
+2 READ !!,"Press any key to continue.",LRAKEY:DTIME
+3 QUIT
+4 ;display code info (used for demo)
CODEINFO(LRAXX2) ; Write Output
+1 WRITE " ",$PIECE(LRAXX2,";",2)
+2 QUIT
+3 ;
GETDX ;Get DX and set in LRADX array
+1 NEW DX,DXC,CDE
+2 KILL LRADX
+3 SET DX=0
+4 IF LRSS="AU"
Begin DoDot:1
+5 FOR
SET DX=$ORDER(^LR(LRDFN,80,DX))
if 'DX
QUIT
Begin DoDot:2
+6 SET DXC=$$CODEC^ICDEX(80,DX)
if DXC<0
QUIT
SET LRADX(DXC)=DX
End DoDot:2
End DoDot:1
QUIT
+7 FOR
SET DX=$ORDER(^LR(LRDFN,LRSS,LRI,3,DX))
if 'DX
QUIT
Begin DoDot:1
+8 SET CDE=+$GET(^LR(LRDFN,LRSS,LRI,3,DX,0))
IF 'CDE
QUIT
+9 SET DXC=$$CODEC^ICDEX(80,CDE)
if DXC<0
QUIT
SET LRADX(DXC)=CDE
End DoDot:1
+10 QUIT
+11 ;
DXSAV ;Save diagnosis codes
+1 NEW DX,DXC,TMPDX,LRDXS,LRIEN,LRFL,DIK,DA
+2 SET DX=""
+3 FOR
SET DX=$ORDER(LRADX(DX))
if DX=""
QUIT
SET TMPDX(LRADX(DX))=""
+4 IF LRSS="AU"
SET DX=0
Begin DoDot:1
+5 FOR
SET DX=$ORDER(^LR(LRDFN,80,DX))
if 'DX
QUIT
Begin DoDot:2
+6 IF $DATA(TMPDX(DX))
KILL TMPDX(DX)
QUIT
+7 IF '$DATA(TMPDX(DX))
SET DA(1)=LRDFN
SET DA=DX
SET DIK="^LR("_DA(1)_",80,"
DO ^DIK
QUIT
End DoDot:2
+8 SET DX=0
FOR
SET DX=$ORDER(TMPDX(DX))
if 'DX
QUIT
Begin DoDot:2
+9 KILL LRIEN,LRDXS
+10 SET LRIEN(1)=DX
+11 SET LRDXS(63.808,"+1,"_LRDFN_",",.01)=DX
+12 DO UPDATE^DIE("","LRDXS","LRIEN")
End DoDot:2
End DoDot:1
QUIT
+13 SET DX=0
+14 ; save DX code to subfiles - 63.02(EM); 63.08 (SP); or 63.09 (CY)
+15 ; .01 field is DINUM except for subfile 68.02 (EM)
+16 FOR
SET DX=$ORDER(^LR(LRDFN,LRSS,LRI,3,DX))
if 'DX
QUIT
Begin DoDot:1
+17 IF $DATA(TMPDX(DX))
KILL TMPDX(DX)
QUIT
+18 IF '$DATA(TMPDX(DX))
SET DA(2)=LRDFN
SET DA(1)=LRI
SET DA=DX
SET DIK="^LR("_DA(2)_","""_LRSS_""","_DA(1)_",3,"
DO ^DIK
QUIT
End DoDot:1
+19 SET LRFL=$SELECT(LRSS="EM":63.203,LRSS="SP":63.88,1:63.901)
+20 SET DX=0
FOR
SET DX=$ORDER(TMPDX(DX))
if 'DX
QUIT
Begin DoDot:1
+21 KILL LRIEN,LRDXS
+22 if LRSS'="EM"
SET LRIEN(3)=DX
+23 SET LRDXS(LRFL,"+3,"_LRI_","_LRDFN_",",.01)=DX
+24 DO UPDATE^DIE("","LRDXS","LRIEN")
End DoDot:1
+25 QUIT
