ICDSELDS ;ALB/SJA/SS/KUM - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
;;18.0;DRG Grouper;**64,94**;Oct 20, 2000;Build 5
;
;
;
; Input
;
; X Length of list to display (default 5)
; .ICDSRL Local array passed by reference
;
; ICDSRL() Input Array from ICDSRCH^LEX10CS
;
; ICDSRL(0)=# found ^ Pruning Indicator
; ICDSRL(1,0)=Code ^ Code IEN ^ date
; ICDSRL(1,"IDL")=ICD-9/10 Description, Long
; ICDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; ICDSRL(1,"IDS")=ICD-9/10 Description, Short
; ICDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; ICDSRL(1,"LEX")=Lexicon Description
; ICDSRL(1,"LEX",1)=Expression IEN ^ date
; ICDSRL(1,"SYN",1)=Synonym #1
; ICDSRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; ICDSRL Local array passed by reference
;
; ICDSRL(0)=Code ^ Code IEN ^ date
; ICDSRL("IDL")=ICD-9/10 Description, Long
; ICDSRL("IDL",1)=ICD-9/10 IEN ^ date
; ICDSRL("IDS")=ICD-9/10 Description, Short
; ICDSRL("IDS",1)=ICD-9/10 IEN ^ date
; ICDSRL("LEX")=Lexicon Description
; ICDSRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
; or -2 if "^" was entered
;
SEL(ICDSRL,X) ; Select from List
N ICDGOUP S ICDGOUP=0
S X=+($G(X))
S:X'>0 X=5
S X=$$ASK(.ICDSRL,X)
I ICDGOUP=1 Q -2
Q X
;
ASK(ICDSRL,X) ; Ask for Selection
N DTOUT,DUOUT,DIROUT
N ICDLIT,ICDLL,ICDLTOT
S ICDLL=+($G(X))
S:ICDLL'>0 ICDLL=5
S ICDLIT=0,ICDLTOT=$O(ICDSRL(" "),-1)
Q:+ICDLTOT'>0 "^"
K X
S:+ICDLTOT=1 X=$$ONE(ICDLL,.ICDSRL)
S:+ICDLTOT>1 X=$$MUL(.ICDSRL,ICDLL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,ICDSRL) ; One Entry Found
Q:+($G(ICDLIT))>0 "^^"
N DIR,ICDLC,ICDLEX,ICDLFI,ICDLIT,ICDLSO,ICDLNC
N ICDLSP,ICDLTX,ICDLC,Y,ICDCNT1
S ICDLFI=$O(ICDSRL(0)) Q:+ICDLFI'>0 "^" S ICDLSP=$J(" ",11)
S ICDLSO=$P(ICDSRL(1,0),"^",1),ICDLNC=$P(ICDSRL(1,0),"^",3)
S:+ICDLNC>0 ICDLNC=" ("_ICDLNC_")" S ICDLEX=$G(ICDSRL(1,"MENU"))
S ICDLC=$S($D(ICDSRL(1,"CAT")):"-",1:"")
S ICDLTX(1)=ICDLSO_ICDLC_$J(" ",(9-$L(ICDLSO)))_" "_ICDLEX_ICDLNC
D PR(.ICDLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(ICDLTX(1))
S ICDLC=3
F ICDCNT1=2:1 Q:$G(ICDLTX(ICDCNT1))="" S ICDLC=ICDLC+1,DIR("A",ICDLC)=ICDLSP_$G(ICDLTX(ICDCNT1))
S ICDLC=ICDLC+1,DIR("A",ICDLC)=" ",ICDLC=ICDLC+1
S DIR("A")=" OK? (Yes/No) ",DIR("B")="Yes",DIR(0)="YAO" W !
D ^DIR Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) ICDLIT=1
I X["^^"!(+($G(ICDLIT))>0) K ICDSRL Q "^^"
S X=$S(+Y>0:$$X(1,.ICDSRL),1:-1)
Q X
MUL(ICDSRL,Y) ; Multiple Entries Found
Q:+($G(ICDLIT))>0 "^^"
N ICDSRLE,ICDLL,ICDLMAX,ICDLSS,ICDLX,X
S (ICDLMAX,ICDLSS,ICDLIT)=0,ICDLL=+($G(Y)),U="^" S:+($G(ICDLL))'>0 ICDLL=5
S ICDLX=$O(ICDSRL(" "),-1),ICDLSS=0
G:+ICDLX=0 MULQ W ! W:+ICDLX>1 !," ",ICDLX," matches found"
F ICDSRLE=1:1:ICDLX Q:((ICDLSS>0)&(ICDLSS<(ICDSRLE+1))) Q:ICDLIT D Q:ICDLIT
. W:ICDSRLE#ICDLL=1 ! D MULW
. S ICDLMAX=ICDSRLE W:ICDSRLE#ICDLL=0 !
. S:ICDSRLE#ICDLL=0 ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL) S:ICDLSS["^" ICDLIT=1
I ICDSRLE#ICDLL'=0,+ICDLSS<=0 D
. W ! S ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL) S:ICDLSS["^" ICDLIT=1
G MULQ
Q X
MULW ; Write Multiple
N ICDLEX,ICDLI1,ICDLSO,ICDLNC,ICDLT2,ICDLTX S ICDLSO=$P(ICDSRL(+ICDSRLE,0),"^",1)
S ICDLNC=$P(ICDSRL(+ICDSRLE,0),"^",3) S:+ICDLNC>0 ICDLNC=" ("_ICDLNC_")"
S ICDLEX=$G(ICDSRL(+ICDSRLE,"MENU")),ICDLTX(1)=ICDLSO
S ICDLTX(1)=ICDLTX(1)_$S($D(ICDSRL(+ICDSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(ICDLSO)))_" "_ICDLEX_ICDLNC
D PR(.ICDLTX,60) W !,$J(ICDSRLE,5),". ",$G(ICDLTX(1))
F ICDLI1=2:1:5 S ICDLT2=$G(ICDLTX(ICDLI1)) W:$L(ICDLT2) !,$J(" ",19),ICDLT2
Q
MULS(X,Y,ICDSRL) ; Select from Multiple Entries
N DIR,DIRB,ICDLFI,ICDLHLP,ICDLLST,ICDLMAX,ICDLS1 ;@#$ not sure ICDLS1 is needed here
Q:+($G(ICDLIT))>0 "^^" S ICDLMAX=+($G(X)),ICDLLST=+($G(Y))
Q:ICDLMAX=0 -1 S ICDLFI=$O(ICDSRL(0)) Q:+ICDLFI'>0 -1
I +($O(ICDSRL(+ICDLLST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_ICDLMAX_": "
I +($O(ICDSRL(+ICDLLST)))'>0 D
. S DIR("A")=" Select 1-"_ICDLMAX_": "
S ICDLHLP=" Answer must be from 1 to "
S ICDLHLP=ICDLHLP_ICDLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^ICDSELDS"
S DIR(0)="NAO^1:"_ICDLMAX_":0" D ^DIR
S:X="^" ICDGOUP=1
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) ICDLIT=1,X="^^" I X["^^"!(+($G(ICDLIT))>0) Q "^^"
K DIR Q:$D(DTOUT)!(X[U) "^^"
Q $S(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
I $L($G(ICDLHLP)) W !,$G(ICDLHLP) Q
Q
MULQ ; Quit Multiple
I +ICDLSS'>0,$G(ICDLSS)="^" Q "^"
S X=-1 S:+($G(ICDLIT))'>0 X=$$X(+ICDLSS,.ICDSRL)
Q X
X(X,ICDSRL) ; Set X and Output Array
N ICDLEX,ICDSRFI,ICDLIEN,ICDLN1,ICDLNC,ICDLNN,ICDLRN,ICDLS1,ICDLSO
S ICDLS1=+($G(X))
S ICDSRFI=$O(ICDSRL(0)) ;@#$ not used?
S ICDLSO=$P($G(ICDSRL(ICDLS1,0)),"^",1),ICDLEX=$G(ICDSRL(ICDLS1,"MENU"))
S ICDLIEN=$S($D(ICDSRL(ICDLS1,"CAT")):"99:CAT;"_$P($G(ICDSRL(ICDLS1,0)),"^"),1:$P($G(ICDSRL(ICDLS1,"LEX",1)),"^")_";"_$P($G(ICDSRL(ICDLS1,0)),"^")) Q:'$L(ICDLSO) "^"
Q:'$L(ICDLEX) "^" Q:+ICDLIEN'>0 "^" S X=ICDLIEN_"^"_ICDLEX
S ICDLNN="ICDSRL("_+ICDLS1_")",ICDLNC="ICDSRL("_+ICDLS1_","
F S ICDLNN=$Q(@ICDLNN) Q:'$L(ICDLNN)!(ICDLNN'[ICDLNC) D
. S ICDLRN="ICDLN1("_$P(ICDLNN,"(",2,299) S @ICDLRN=@ICDLNN
K ICDSRL S ICDLNN="ICDLN1("_+ICDLS1_")",ICDLNC="ICDLN1("_+ICDLS1_","
F S ICDLNN=$Q(@ICDLNN) Q:'$L(ICDLNN)!(ICDLNN'[ICDLNC) D
. S ICDLRN="ICDSRL("_$P(ICDLNN,"(",2,299),@ICDLRN=@ICDLNN
Q X
;
; Miscellaneous
CL ; Clear
K ICDLIT
Q
PR(ICDSRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,ICDDN,I,Z,%,%D,ICDLC,ICDLI1,ICDLL
K ^UTILITY($J,"W")
Q:'$D(ICDSRL)
S ICDLL=+($G(X))
S:+ICDLL'>0 ICDLL=79
S ICDLC=+($G(ICDSRL))
S:+($G(ICDLC))'>0 ICDLC=$O(ICDSRL(" "),-1)
Q:+ICDLC'>0
S DIWL=1,DIWF="C"_+ICDLL
S ICDLI1=0
F S ICDLI1=$O(ICDSRL(ICDLI1)) Q:+ICDLI1=0 S X=$G(ICDSRL(ICDLI1)) D ^DIWP
K ICDSRL
S (ICDLC,ICDLI1)=0
F S ICDLI1=$O(^UTILITY($J,"W",1,ICDLI1)) Q:+ICDLI1=0 D
. S ICDSRL(ICDLI1)=$$TM($G(^UTILITY($J,"W",1,ICDLI1,0))," "),ICDLC=ICDLC+1
S:$L(ICDLC) ICDSRL=ICDLC
K ^UTILITY($J,"W")
Q
TM(ICDX,ICDY) ; Trim Character Y - Default " "
S ICDX=$G(ICDX) Q:ICDX="" ICDX S ICDY=$G(ICDY) S:'$L(ICDY) ICDY=" "
F Q:$E(ICDX,1)'=ICDY S ICDX=$E(ICDX,2,$L(ICDX))
F Q:$E(ICDX,$L(ICDX))'=ICDY S ICDX=$E(ICDX,1,($L(ICDX)-1))
Q ICDX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDSELDS 7115 printed Sep 23, 2025@19:27:05 Page 2
ICDSELDS ;ALB/SJA/SS/KUM - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
+1 ;;18.0;DRG Grouper;**64,94**;Oct 20, 2000;Build 5
+2 ;
+3 ;
+4 ;
+5 ; Input
+6 ;
+7 ; X Length of list to display (default 5)
+8 ; .ICDSRL Local array passed by reference
+9 ;
+10 ; ICDSRL() Input Array from ICDSRCH^LEX10CS
+11 ;
+12 ; ICDSRL(0)=# found ^ Pruning Indicator
+13 ; ICDSRL(1,0)=Code ^ Code IEN ^ date
+14 ; ICDSRL(1,"IDL")=ICD-9/10 Description, Long
+15 ; ICDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+16 ; ICDSRL(1,"IDS")=ICD-9/10 Description, Short
+17 ; ICDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+18 ; ICDSRL(1,"LEX")=Lexicon Description
+19 ; ICDSRL(1,"LEX",1)=Expression IEN ^ date
+20 ; ICDSRL(1,"SYN",1)=Synonym #1
+21 ; ICDSRL(1,"SYN",m)=Synonym #m
+22 ; ...
+23 ;
+24 ; Output
+25 ;
+26 ; $$SEL Two Piece "^" delimited string same as
+27 ; Fileman's Y output variable
+28 ;
+29 ; 1 Lexicon IEN
+30 ; 2 Lexicon Term
+31 ;
+32 ; ICDSRL Local array passed by reference
+33 ;
+34 ; ICDSRL(0)=Code ^ Code IEN ^ date
+35 ; ICDSRL("IDL")=ICD-9/10 Description, Long
+36 ; ICDSRL("IDL",1)=ICD-9/10 IEN ^ date
+37 ; ICDSRL("IDS")=ICD-9/10 Description, Short
+38 ; ICDSRL("IDS",1)=ICD-9/10 IEN ^ date
+39 ; ICDSRL("LEX")=Lexicon Description
+40 ; ICDSRL("LEX",1)=Expression IEN ^ date
+41 ;
+42 ; or ^ on error
+43 ; or -1 for non-selection
+44 ; or -2 if "^" was entered
+45 ;
SEL(ICDSRL,X) ; Select from List
+1 NEW ICDGOUP
SET ICDGOUP=0
+2 SET X=+($GET(X))
+3 if X'>0
SET X=5
+4 SET X=$$ASK(.ICDSRL,X)
+5 IF ICDGOUP=1
QUIT -2
+6 QUIT X
+7 ;
ASK(ICDSRL,X) ; Ask for Selection
+1 NEW DTOUT,DUOUT,DIROUT
+2 NEW ICDLIT,ICDLL,ICDLTOT
+3 SET ICDLL=+($GET(X))
+4 if ICDLL'>0
SET ICDLL=5
+5 SET ICDLIT=0
SET ICDLTOT=$ORDER(ICDSRL(" "),-1)
+6 if +ICDLTOT'>0
QUIT "^"
+7 KILL X
+8 if +ICDLTOT=1
SET X=$$ONE(ICDLL,.ICDSRL)
+9 if +ICDLTOT>1
SET X=$$MUL(.ICDSRL,ICDLL)
+10 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+11 QUIT X
ONE(X,ICDSRL) ; One Entry Found
+1 if +($GET(ICDLIT))>0
QUIT "^^"
+2 NEW DIR,ICDLC,ICDLEX,ICDLFI,ICDLIT,ICDLSO,ICDLNC
+3 NEW ICDLSP,ICDLTX,ICDLC,Y,ICDCNT1
+4 SET ICDLFI=$ORDER(ICDSRL(0))
if +ICDLFI'>0
QUIT "^"
SET ICDLSP=$JUSTIFY(" ",11)
+5 SET ICDLSO=$PIECE(ICDSRL(1,0),"^",1)
SET ICDLNC=$PIECE(ICDSRL(1,0),"^",3)
+6 if +ICDLNC>0
SET ICDLNC=" ("_ICDLNC_")"
SET ICDLEX=$GET(ICDSRL(1,"MENU"))
+7 SET ICDLC=$SELECT($DATA(ICDSRL(1,"CAT")):"-",1:"")
+8 SET ICDLTX(1)=ICDLSO_ICDLC_$JUSTIFY(" ",(9-$LENGTH(ICDLSO)))_" "_ICDLEX_ICDLNC
+9 DO PR(.ICDLTX,64)
SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+10 SET DIR("A",3)=" "_$GET(ICDLTX(1))
+11 SET ICDLC=3
+12 FOR ICDCNT1=2:1
if $GET(ICDLTX(ICDCNT1))=""
QUIT
SET ICDLC=ICDLC+1
SET DIR("A",ICDLC)=ICDLSP_$GET(ICDLTX(ICDCNT1))
+13 SET ICDLC=ICDLC+1
SET DIR("A",ICDLC)=" "
SET ICDLC=ICDLC+1
+14 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+15 DO ^DIR
if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+16 if X["^^"!($DATA(DTOUT))
SET ICDLIT=1
+17 IF X["^^"!(+($GET(ICDLIT))>0)
KILL ICDSRL
QUIT "^^"
+18 SET X=$SELECT(+Y>0:$$X(1,.ICDSRL),1:-1)
+19 QUIT X
MUL(ICDSRL,Y) ; Multiple Entries Found
+1 if +($GET(ICDLIT))>0
QUIT "^^"
+2 NEW ICDSRLE,ICDLL,ICDLMAX,ICDLSS,ICDLX,X
+3 SET (ICDLMAX,ICDLSS,ICDLIT)=0
SET ICDLL=+($GET(Y))
SET U="^"
if +($GET(ICDLL))'>0
SET ICDLL=5
+4 SET ICDLX=$ORDER(ICDSRL(" "),-1)
SET ICDLSS=0
+5 if +ICDLX=0
GOTO MULQ
WRITE !
if +ICDLX>1
WRITE !," ",ICDLX," matches found"
+6 FOR ICDSRLE=1:1:ICDLX
if ((ICDLSS>0)&(ICDLSS<(ICDSRLE+1)))
QUIT
if ICDLIT
QUIT
Begin DoDot:1
+7 if ICDSRLE#ICDLL=1
WRITE !
DO MULW
+8 SET ICDLMAX=ICDSRLE
if ICDSRLE#ICDLL=0
WRITE !
+9 if ICDSRLE#ICDLL=0
SET ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL)
if ICDLSS["^"
SET ICDLIT=1
End DoDot:1
if ICDLIT
QUIT
+10 IF ICDSRLE#ICDLL'=0
IF +ICDLSS<=0
Begin DoDot:1
+11 WRITE !
SET ICDLSS=$$MULS(ICDLMAX,ICDSRLE,.ICDSRL)
if ICDLSS["^"
SET ICDLIT=1
End DoDot:1
+12 GOTO MULQ
+13 QUIT X
MULW ; Write Multiple
+1 NEW ICDLEX,ICDLI1,ICDLSO,ICDLNC,ICDLT2,ICDLTX
SET ICDLSO=$PIECE(ICDSRL(+ICDSRLE,0),"^",1)
+2 SET ICDLNC=$PIECE(ICDSRL(+ICDSRLE,0),"^",3)
if +ICDLNC>0
SET ICDLNC=" ("_ICDLNC_")"
+3 SET ICDLEX=$GET(ICDSRL(+ICDSRLE,"MENU"))
SET ICDLTX(1)=ICDLSO
+4 SET ICDLTX(1)=ICDLTX(1)_$SELECT($DATA(ICDSRL(+ICDSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(ICDLSO)))_" "_ICDLEX_ICDLNC
+5 DO PR(.ICDLTX,60)
WRITE !,$JUSTIFY(ICDSRLE,5),". ",$GET(ICDLTX(1))
+6 FOR ICDLI1=2:1:5
SET ICDLT2=$GET(ICDLTX(ICDLI1))
if $LENGTH(ICDLT2)
WRITE !,$JUSTIFY(" ",19),ICDLT2
+7 QUIT
MULS(X,Y,ICDSRL) ; Select from Multiple Entries
+1 ;@#$ not sure ICDLS1 is needed here
NEW DIR,DIRB,ICDLFI,ICDLHLP,ICDLLST,ICDLMAX,ICDLS1
+2 if +($GET(ICDLIT))>0
QUIT "^^"
SET ICDLMAX=+($GET(X))
SET ICDLLST=+($GET(Y))
+3 if ICDLMAX=0
QUIT -1
SET ICDLFI=$ORDER(ICDSRL(0))
if +ICDLFI'>0
QUIT -1
+4 IF +($ORDER(ICDSRL(+ICDLLST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_ICDLMAX_": "
End DoDot:1
+7 IF +($ORDER(ICDSRL(+ICDLLST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_ICDLMAX_": "
End DoDot:1
+9 SET ICDLHLP=" Answer must be from 1 to "
+10 SET ICDLHLP=ICDLHLP_ICDLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^ICDSELDS"
+13 SET DIR(0)="NAO^1:"_ICDLMAX_":0"
DO ^DIR
+14 if X="^"
SET ICDGOUP=1
+15 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+16 if X["^^"!($DATA(DTOUT))
SET ICDLIT=1
SET X="^^"
IF X["^^"!(+($GET(ICDLIT))>0)
QUIT "^^"
+17 KILL DIR
if $DATA(DTOUT)!(X[U)
QUIT "^^"
+18 QUIT $SELECT(+Y>0:+Y,1:"-1")
MULSH ; Select from Multiple Entries Help
+1 IF $LENGTH($GET(ICDLHLP))
WRITE !,$GET(ICDLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +ICDLSS'>0
IF $GET(ICDLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(ICDLIT))'>0
SET X=$$X(+ICDLSS,.ICDSRL)
+3 QUIT X
X(X,ICDSRL) ; Set X and Output Array
+1 NEW ICDLEX,ICDSRFI,ICDLIEN,ICDLN1,ICDLNC,ICDLNN,ICDLRN,ICDLS1,ICDLSO
+2 SET ICDLS1=+($GET(X))
+3 ;@#$ not used?
SET ICDSRFI=$ORDER(ICDSRL(0))
+4 SET ICDLSO=$PIECE($GET(ICDSRL(ICDLS1,0)),"^",1)
SET ICDLEX=$GET(ICDSRL(ICDLS1,"MENU"))
+5 SET ICDLIEN=$SELECT($DATA(ICDSRL(ICDLS1,"CAT")):"99:CAT;"_$PIECE($GET(ICDSRL(ICDLS1,0)),"^"),1:$PIECE($GET(ICDSRL(ICDLS1,"LEX",1)),"^")_";"_$PIECE($GET(ICDSRL(ICDLS1,0)),"^"))
if '$LENGTH(ICDLSO)
QUIT "^"
+6 if '$LENGTH(ICDLEX)
QUIT "^"
if +ICDLIEN'>0
QUIT "^"
SET X=ICDLIEN_"^"_ICDLEX
+7 SET ICDLNN="ICDSRL("_+ICDLS1_")"
SET ICDLNC="ICDSRL("_+ICDLS1_","
+8 FOR
SET ICDLNN=$QUERY(@ICDLNN)
if '$LENGTH(ICDLNN)!(ICDLNN'[ICDLNC)
QUIT
Begin DoDot:1
+9 SET ICDLRN="ICDLN1("_$PIECE(ICDLNN,"(",2,299)
SET @ICDLRN=@ICDLNN
End DoDot:1
+10 KILL ICDSRL
SET ICDLNN="ICDLN1("_+ICDLS1_")"
SET ICDLNC="ICDLN1("_+ICDLS1_","
+11 FOR
SET ICDLNN=$QUERY(@ICDLNN)
if '$LENGTH(ICDLNN)!(ICDLNN'[ICDLNC)
QUIT
Begin DoDot:1
+12 SET ICDLRN="ICDSRL("_$PIECE(ICDLNN,"(",2,299)
SET @ICDLRN=@ICDLNN
End DoDot:1
+13 QUIT X
+14 ;
+15 ; Miscellaneous
CL ; Clear
+1 KILL ICDLIT
+2 QUIT
PR(ICDSRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,ICDDN,I,Z,%,%D,ICDLC,ICDLI1,ICDLL
+2 KILL ^UTILITY($JOB,"W")
+3 if '$DATA(ICDSRL)
QUIT
+4 SET ICDLL=+($GET(X))
+5 if +ICDLL'>0
SET ICDLL=79
+6 SET ICDLC=+($GET(ICDSRL))
+7 if +($GET(ICDLC))'>0
SET ICDLC=$ORDER(ICDSRL(" "),-1)
+8 if +ICDLC'>0
QUIT
+9 SET DIWL=1
SET DIWF="C"_+ICDLL
+10 SET ICDLI1=0
+11 FOR
SET ICDLI1=$ORDER(ICDSRL(ICDLI1))
if +ICDLI1=0
QUIT
SET X=$GET(ICDSRL(ICDLI1))
DO ^DIWP
+12 KILL ICDSRL
+13 SET (ICDLC,ICDLI1)=0
+14 FOR
SET ICDLI1=$ORDER(^UTILITY($JOB,"W",1,ICDLI1))
if +ICDLI1=0
QUIT
Begin DoDot:1
+15 SET ICDSRL(ICDLI1)=$$TM($GET(^UTILITY($JOB,"W",1,ICDLI1,0))," ")
SET ICDLC=ICDLC+1
End DoDot:1
+16 if $LENGTH(ICDLC)
SET ICDSRL=ICDLC
+17 KILL ^UTILITY($JOB,"W")
+18 QUIT
TM(ICDX,ICDY) ; Trim Character Y - Default " "
+1 SET ICDX=$GET(ICDX)
if ICDX=""
QUIT ICDX
SET ICDY=$GET(ICDY)
if '$LENGTH(ICDY)
SET ICDY=" "
+2 FOR
if $EXTRACT(ICDX,1)'=ICDY
QUIT
SET ICDX=$EXTRACT(ICDX,2,$LENGTH(ICDX))
+3 FOR
if $EXTRACT(ICDX,$LENGTH(ICDX))'=ICDY
QUIT
SET ICDX=$EXTRACT(ICDX,1,($LENGTH(ICDX)-1))
+4 QUIT ICDX
