LRAPICD2 ;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 ^ZZLXDG2
;
; Input
;
; X Length of list to display (default 5)
; .LRASRL Local array passed by reference
;
; LRASRL() Input Array from ICDSRCH^LEX10CS
;
; LRASRL(0)=# found ^ Pruning Indicator
; LRASRL(1,0)=Code ^ Code IEN ^ date
; LRASRL(1,"IDL")=ICD-9/10 Description, Long
; LRASRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; LRASRL(1,"IDS")=ICD-9/10 Description, Short
; LRASRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; LRASRL(1,"LEX")=Lexicon Description
; LRASRL(1,"LEX",1)=Expression IEN ^ date
; LRASRL(1,"SYN",1)=Synonym #1
; LRASRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; LRASRL Local array passed by reference
;
; LRASRL(0)=Code ^ Code IEN ^ date
; LRASRL("IDL")=ICD-9/10 Description, Long
; LRASRL("IDL",1)=ICD-9/10 IEN ^ date
; LRASRL("IDS")=ICD-9/10 Description, Short
; LRASRL("IDS",1)=ICD-9/10 IEN ^ date
; LRASRL("LEX")=Lexicon Description
; LRASRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
; or -2 if "^" was entered
;
SEL(LRASRL,X) ; Select from List
N LRAGOUP S LRAGOUP=0
S X=+($G(X))
S:X'>0 X=5
S X=$$ASK(.LRASRL,X)
I LRAGOUP=1 Q -2
Q X
;
ASK(LRASRL,X) ; Ask for Selection
N DTOUT,DUOUT,DIROUT
N LRALIT,LRALL,LRALTOT
S LRALL=+($G(X))
S:LRALL'>0 LRALL=5
S LRALIT=0,LRALTOT=$O(LRASRL(" "),-1)
Q:+LRALTOT'>0 "^"
K X
S:+LRALTOT=1 X=$$ONE(LRALL,.LRASRL)
S:+LRALTOT>1 X=$$MUL(.LRASRL,LRALL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,LRASRL) ; One Entry Found
Q:+($G(LRALIT))>0 "^^"
N DIR,LRALC,LRALEX,LRALFI,LRALIT,LRALSO,LRALNC,LRACNT1
N LRALSP,LRALTX,LRALC,Y
S LRALFI=$O(LRASRL(0)) Q:+LRALFI'>0 "^" S LRALSP=$J(" ",11)
S LRALSO=$P(LRASRL(1,0),"^",1),LRALNC=$P(LRASRL(1,0),"^",3)
S:+LRALNC>0 LRALNC=" ("_LRALNC_")" S LRALEX=$G(LRASRL(1,"MENU"))
S LRALC=$S($D(LRASRL(1,"CAT")):"-",1:"")
S LRALTX(1)=LRALSO_LRALC_$J(" ",(9-$L(LRALSO)))_" "_LRALEX_LRALNC
D PR(.LRALTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(LRALTX(1))
S LRALC=3
F LRACNT1=2:1 Q:$G(LRALTX(LRACNT1))="" S LRALC=LRALC+1,DIR("A",LRALC)=LRALSP_$G(LRALTX(LRACNT1))
S LRALC=LRALC+1,DIR("A",LRALC)=" ",LRALC=LRALC+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)) LRALIT=1
I X["^^"!(+($G(LRALIT))>0) K LRASRL Q "^^"
S X=$S(+Y>0:$$X(1,.LRASRL),1:-1)
Q X
MUL(LRASRL,Y) ; Multiple Entries Found
Q:+($G(LRALIT))>0 "^^"
N LRASRLE,LRALL,LRALMAX,LRALSS,LRALX,X
S (LRALMAX,LRALSS,LRALIT)=0,LRALL=+($G(Y)),U="^" S:+($G(LRALL))'>0 LRALL=5
S LRALX=$O(LRASRL(" "),-1),LRALSS=0
G:+LRALX=0 MULQ W ! W:+LRALX>1 !," ",LRALX," matches found"
F LRASRLE=1:1:LRALX Q:((LRALSS>0)&(LRALSS<(LRASRLE+1))) Q:LRALIT D Q:LRALIT
. W:LRASRLE#LRALL=1 ! D MULW
. S LRALMAX=LRASRLE W:LRASRLE#LRALL=0 !
. S:LRASRLE#LRALL=0 LRALSS=$$MULS(LRALMAX,LRASRLE,.LRASRL) S:LRALSS["^" LRALIT=1
I LRASRLE#LRALL'=0,+LRALSS<=0 D
. W ! S LRALSS=$$MULS(LRALMAX,LRASRLE,.LRASRL) S:LRALSS["^" LRALIT=1
G MULQ
Q X
MULW ; Write Multiple
N LRALEX,LRALI1,LRALSO,LRALNC,LRALT2,LRALTX S LRALSO=$P(LRASRL(+LRASRLE,0),"^",1)
S LRALNC=$P(LRASRL(+LRASRLE,0),"^",3) S:+LRALNC>0 LRALNC=" ("_LRALNC_")"
S LRALEX=$G(LRASRL(+LRASRLE,"MENU")),LRALTX(1)=LRALSO
S LRALTX(1)=LRALTX(1)_$S($D(LRASRL(+LRASRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(LRALSO)))_" "_LRALEX_LRALNC
D PR(.LRALTX,60) W !,$J(LRASRLE,5),". ",$G(LRALTX(1))
F LRALI1=2:1:5 S LRALT2=$G(LRALTX(LRALI1)) W:$L(LRALT2) !,$J(" ",19),LRALT2
Q
MULS(X,Y,LRASRL) ; Select from Multiple Entries
N DIR,DIRB,LRALFI,LRALHLP,LRALLST,LRALMAX,LRALS1 ;@#$ not sure LRALS1 is needed here
Q:+($G(LRALIT))>0 "^^" S LRALMAX=+($G(X)),LRALLST=+($G(Y))
Q:LRALMAX=0 -1 S LRALFI=$O(LRASRL(0)) Q:+LRALFI'>0 -1
I +($O(LRASRL(+LRALLST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_LRALMAX_": "
I +($O(LRASRL(+LRALLST)))'>0 D
. S DIR("A")=" Select 1-"_LRALMAX_": "
S LRALHLP=" Answer must be from 1 to "
S LRALHLP=LRALHLP_LRALMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^LRAPICD2"
S DIR(0)="NAO^1:"_LRALMAX_":0" D ^DIR
S:X="^" LRAGOUP=1
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) LRALIT=1,X="^^" I X["^^"!(+($G(LRALIT))>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(LRALHLP)) W !,$G(LRALHLP) Q
Q
MULQ ; Quit Multiple
I +LRALSS'>0,$G(LRALSS)="^" Q "^"
S X=-1 S:+($G(LRALIT))'>0 X=$$X(+LRALSS,.LRASRL)
Q X
X(X,LRASRL) ; Set X and Output Array
N LRALEX,LRASRFI,ZZLIEN,LRALN1,LRALNC,LRALNN,LRALRN,LRALS1,LRALSO
S LRALS1=+($G(X))
S LRASRFI=$O(LRASRL(0)) ;@#$ not used?
S LRALSO=$P($G(LRASRL(LRALS1,0)),"^",1),LRALEX=$G(LRASRL(LRALS1,"MENU"))
S ZZLIEN=$S($D(LRASRL(LRALS1,"CAT")):"99:CAT;"_$P($G(LRASRL(LRALS1,0)),"^"),1:$P($G(LRASRL(LRALS1,"IDS",1)),"^")_";"_$P($G(LRASRL(LRALS1,0)),"^")_";"_$P($G(LRASRL(LRALS1,"LEX",1)),"^")) Q:'$L(LRALSO) "^"
Q:'$L(LRALEX) "^" Q:+ZZLIEN'>0 "^" S X=ZZLIEN_"^"_LRALEX
S LRALNN="LRASRL("_+LRALS1_")",LRALNC="LRASRL("_+LRALS1_","
F S LRALNN=$Q(@LRALNN) Q:'$L(LRALNN)!(LRALNN'[LRALNC) D
. S LRALRN="LRALN1("_$P(LRALNN,"(",2,299) S @LRALRN=@LRALNN
K LRASRL S LRALNN="LRALN1("_+LRALS1_")",LRALNC="LRALN1("_+LRALS1_","
F S LRALNN=$Q(@LRALNN) Q:'$L(LRALNN)!(LRALNN'[LRALNC) D
. S LRALRN="LRASRL("_$P(LRALNN,"(",2,299),@LRALRN=@LRALNN
Q X
;
; Miscellaneous
CL ; Clear
K LRALIT
Q
PR(LRASRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,%,%D,LRALC,LRALI1,LRALL
K ^UTILITY($J,"W")
Q:'$D(LRASRL)
S LRALL=+($G(X))
S:+LRALL'>0 LRALL=79
S LRALC=+($G(LRASRL))
S:+($G(LRALC))'>0 LRALC=$O(LRASRL(" "),-1)
Q:+LRALC'>0
S DIWL=1,DIWF="C"_+LRALL
S LRALI1=0
F S LRALI1=$O(LRASRL(LRALI1)) Q:+LRALI1=0 S X=$G(LRASRL(LRALI1)) D ^DIWP
K LRASRL
S (LRALC,LRALI1)=0
F S LRALI1=$O(^UTILITY($J,"W",1,LRALI1)) Q:+LRALI1=0 D
. S LRASRL(LRALI1)=$$TM($G(^UTILITY($J,"W",1,LRALI1,0))," "),LRALC=LRALC+1
S:$L(LRALC) LRASRL=LRALC
K ^UTILITY($J,"W")
Q
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPICD2 7161 printed Dec 13, 2024@02:07:30 Page 2
LRAPICD2 ;ALB/JAM - Anatomic Pathology ICD-10 DIAGNOSIS CODE API ;6/15/12
+1 ;;5.2;LAB SERVICE;**422**;Sep 27, 1994;Build 29
+2 ;
+3 ;;Per VHA Directive 2004-038, this routine should not be modified.
+4 ;
+5 ;Routine based on ^ZZLXDG2
+6 ;
+7 ; Input
+8 ;
+9 ; X Length of list to display (default 5)
+10 ; .LRASRL Local array passed by reference
+11 ;
+12 ; LRASRL() Input Array from ICDSRCH^LEX10CS
+13 ;
+14 ; LRASRL(0)=# found ^ Pruning Indicator
+15 ; LRASRL(1,0)=Code ^ Code IEN ^ date
+16 ; LRASRL(1,"IDL")=ICD-9/10 Description, Long
+17 ; LRASRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+18 ; LRASRL(1,"IDS")=ICD-9/10 Description, Short
+19 ; LRASRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+20 ; LRASRL(1,"LEX")=Lexicon Description
+21 ; LRASRL(1,"LEX",1)=Expression IEN ^ date
+22 ; LRASRL(1,"SYN",1)=Synonym #1
+23 ; LRASRL(1,"SYN",m)=Synonym #m
+24 ; ...
+25 ;
+26 ; Output
+27 ;
+28 ; $$SEL Two Piece "^" delimited string same as
+29 ; Fileman's Y output variable
+30 ;
+31 ; 1 Lexicon IEN
+32 ; 2 Lexicon Term
+33 ;
+34 ; LRASRL Local array passed by reference
+35 ;
+36 ; LRASRL(0)=Code ^ Code IEN ^ date
+37 ; LRASRL("IDL")=ICD-9/10 Description, Long
+38 ; LRASRL("IDL",1)=ICD-9/10 IEN ^ date
+39 ; LRASRL("IDS")=ICD-9/10 Description, Short
+40 ; LRASRL("IDS",1)=ICD-9/10 IEN ^ date
+41 ; LRASRL("LEX")=Lexicon Description
+42 ; LRASRL("LEX",1)=Expression IEN ^ date
+43 ;
+44 ; or ^ on error
+45 ; or -1 for non-selection
+46 ; or -2 if "^" was entered
+47 ;
SEL(LRASRL,X) ; Select from List
+1 NEW LRAGOUP
SET LRAGOUP=0
+2 SET X=+($GET(X))
+3 if X'>0
SET X=5
+4 SET X=$$ASK(.LRASRL,X)
+5 IF LRAGOUP=1
QUIT -2
+6 QUIT X
+7 ;
ASK(LRASRL,X) ; Ask for Selection
+1 NEW DTOUT,DUOUT,DIROUT
+2 NEW LRALIT,LRALL,LRALTOT
+3 SET LRALL=+($GET(X))
+4 if LRALL'>0
SET LRALL=5
+5 SET LRALIT=0
SET LRALTOT=$ORDER(LRASRL(" "),-1)
+6 if +LRALTOT'>0
QUIT "^"
+7 KILL X
+8 if +LRALTOT=1
SET X=$$ONE(LRALL,.LRASRL)
+9 if +LRALTOT>1
SET X=$$MUL(.LRASRL,LRALL)
+10 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+11 QUIT X
ONE(X,LRASRL) ; One Entry Found
+1 if +($GET(LRALIT))>0
QUIT "^^"
+2 NEW DIR,LRALC,LRALEX,LRALFI,LRALIT,LRALSO,LRALNC,LRACNT1
+3 NEW LRALSP,LRALTX,LRALC,Y
+4 SET LRALFI=$ORDER(LRASRL(0))
if +LRALFI'>0
QUIT "^"
SET LRALSP=$JUSTIFY(" ",11)
+5 SET LRALSO=$PIECE(LRASRL(1,0),"^",1)
SET LRALNC=$PIECE(LRASRL(1,0),"^",3)
+6 if +LRALNC>0
SET LRALNC=" ("_LRALNC_")"
SET LRALEX=$GET(LRASRL(1,"MENU"))
+7 SET LRALC=$SELECT($DATA(LRASRL(1,"CAT")):"-",1:"")
+8 SET LRALTX(1)=LRALSO_LRALC_$JUSTIFY(" ",(9-$LENGTH(LRALSO)))_" "_LRALEX_LRALNC
+9 DO PR(.LRALTX,64)
SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+10 SET DIR("A",3)=" "_$GET(LRALTX(1))
+11 SET LRALC=3
+12 FOR LRACNT1=2:1
if $GET(LRALTX(LRACNT1))=""
QUIT
SET LRALC=LRALC+1
SET DIR("A",LRALC)=LRALSP_$GET(LRALTX(LRACNT1))
+13 SET LRALC=LRALC+1
SET DIR("A",LRALC)=" "
SET LRALC=LRALC+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 LRALIT=1
+17 IF X["^^"!(+($GET(LRALIT))>0)
KILL LRASRL
QUIT "^^"
+18 SET X=$SELECT(+Y>0:$$X(1,.LRASRL),1:-1)
+19 QUIT X
MUL(LRASRL,Y) ; Multiple Entries Found
+1 if +($GET(LRALIT))>0
QUIT "^^"
+2 NEW LRASRLE,LRALL,LRALMAX,LRALSS,LRALX,X
+3 SET (LRALMAX,LRALSS,LRALIT)=0
SET LRALL=+($GET(Y))
SET U="^"
if +($GET(LRALL))'>0
SET LRALL=5
+4 SET LRALX=$ORDER(LRASRL(" "),-1)
SET LRALSS=0
+5 if +LRALX=0
GOTO MULQ
WRITE !
if +LRALX>1
WRITE !," ",LRALX," matches found"
+6 FOR LRASRLE=1:1:LRALX
if ((LRALSS>0)&(LRALSS<(LRASRLE+1)))
QUIT
if LRALIT
QUIT
Begin DoDot:1
+7 if LRASRLE#LRALL=1
WRITE !
DO MULW
+8 SET LRALMAX=LRASRLE
if LRASRLE#LRALL=0
WRITE !
+9 if LRASRLE#LRALL=0
SET LRALSS=$$MULS(LRALMAX,LRASRLE,.LRASRL)
if LRALSS["^"
SET LRALIT=1
End DoDot:1
if LRALIT
QUIT
+10 IF LRASRLE#LRALL'=0
IF +LRALSS<=0
Begin DoDot:1
+11 WRITE !
SET LRALSS=$$MULS(LRALMAX,LRASRLE,.LRASRL)
if LRALSS["^"
SET LRALIT=1
End DoDot:1
+12 GOTO MULQ
+13 QUIT X
MULW ; Write Multiple
+1 NEW LRALEX,LRALI1,LRALSO,LRALNC,LRALT2,LRALTX
SET LRALSO=$PIECE(LRASRL(+LRASRLE,0),"^",1)
+2 SET LRALNC=$PIECE(LRASRL(+LRASRLE,0),"^",3)
if +LRALNC>0
SET LRALNC=" ("_LRALNC_")"
+3 SET LRALEX=$GET(LRASRL(+LRASRLE,"MENU"))
SET LRALTX(1)=LRALSO
+4 SET LRALTX(1)=LRALTX(1)_$SELECT($DATA(LRASRL(+LRASRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(LRALSO)))_" "_LRALEX_LRALNC
+5 DO PR(.LRALTX,60)
WRITE !,$JUSTIFY(LRASRLE,5),". ",$GET(LRALTX(1))
+6 FOR LRALI1=2:1:5
SET LRALT2=$GET(LRALTX(LRALI1))
if $LENGTH(LRALT2)
WRITE !,$JUSTIFY(" ",19),LRALT2
+7 QUIT
MULS(X,Y,LRASRL) ; Select from Multiple Entries
+1 ;@#$ not sure LRALS1 is needed here
NEW DIR,DIRB,LRALFI,LRALHLP,LRALLST,LRALMAX,LRALS1
+2 if +($GET(LRALIT))>0
QUIT "^^"
SET LRALMAX=+($GET(X))
SET LRALLST=+($GET(Y))
+3 if LRALMAX=0
QUIT -1
SET LRALFI=$ORDER(LRASRL(0))
if +LRALFI'>0
QUIT -1
+4 IF +($ORDER(LRASRL(+LRALLST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_LRALMAX_": "
End DoDot:1
+7 IF +($ORDER(LRASRL(+LRALLST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_LRALMAX_": "
End DoDot:1
+9 SET LRALHLP=" Answer must be from 1 to "
+10 SET LRALHLP=LRALHLP_LRALMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^LRAPICD2"
+13 SET DIR(0)="NAO^1:"_LRALMAX_":0"
DO ^DIR
+14 if X="^"
SET LRAGOUP=1
+15 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+16 if X["^^"!($DATA(DTOUT))
SET LRALIT=1
SET X="^^"
IF X["^^"!(+($GET(LRALIT))>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(LRALHLP))
WRITE !,$GET(LRALHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +LRALSS'>0
IF $GET(LRALSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(LRALIT))'>0
SET X=$$X(+LRALSS,.LRASRL)
+3 QUIT X
X(X,LRASRL) ; Set X and Output Array
+1 NEW LRALEX,LRASRFI,ZZLIEN,LRALN1,LRALNC,LRALNN,LRALRN,LRALS1,LRALSO
+2 SET LRALS1=+($GET(X))
+3 ;@#$ not used?
SET LRASRFI=$ORDER(LRASRL(0))
+4 SET LRALSO=$PIECE($GET(LRASRL(LRALS1,0)),"^",1)
SET LRALEX=$GET(LRASRL(LRALS1,"MENU"))
+5 SET ZZLIEN=$SELECT($DATA(LRASRL(LRALS1,"CAT")):"99:CAT;"_$PIECE($GET(LRASRL(LRALS1,0)),"^"),1:$PIECE($GET(LRASRL(LRALS1,"IDS",1)),"^")_";"_$PIECE($GET(LRASRL(LRALS1,0)),"^")_";"_$PIECE($GET(LRASRL(LRALS1,"LEX",1)),"^"))
if '$LENGTH(LRALSO)
QUIT "^"
+6 if '$LENGTH(LRALEX)
QUIT "^"
if +ZZLIEN'>0
QUIT "^"
SET X=ZZLIEN_"^"_LRALEX
+7 SET LRALNN="LRASRL("_+LRALS1_")"
SET LRALNC="LRASRL("_+LRALS1_","
+8 FOR
SET LRALNN=$QUERY(@LRALNN)
if '$LENGTH(LRALNN)!(LRALNN'[LRALNC)
QUIT
Begin DoDot:1
+9 SET LRALRN="LRALN1("_$PIECE(LRALNN,"(",2,299)
SET @LRALRN=@LRALNN
End DoDot:1
+10 KILL LRASRL
SET LRALNN="LRALN1("_+LRALS1_")"
SET LRALNC="LRALN1("_+LRALS1_","
+11 FOR
SET LRALNN=$QUERY(@LRALNN)
if '$LENGTH(LRALNN)!(LRALNN'[LRALNC)
QUIT
Begin DoDot:1
+12 SET LRALRN="LRASRL("_$PIECE(LRALNN,"(",2,299)
SET @LRALRN=@LRALNN
End DoDot:1
+13 QUIT X
+14 ;
+15 ; Miscellaneous
CL ; Clear
+1 KILL LRALIT
+2 QUIT
PR(LRASRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,%,%D,LRALC,LRALI1,LRALL
+2 KILL ^UTILITY($JOB,"W")
+3 if '$DATA(LRASRL)
QUIT
+4 SET LRALL=+($GET(X))
+5 if +LRALL'>0
SET LRALL=79
+6 SET LRALC=+($GET(LRASRL))
+7 if +($GET(LRALC))'>0
SET LRALC=$ORDER(LRASRL(" "),-1)
+8 if +LRALC'>0
QUIT
+9 SET DIWL=1
SET DIWF="C"_+LRALL
+10 SET LRALI1=0
+11 FOR
SET LRALI1=$ORDER(LRASRL(LRALI1))
if +LRALI1=0
QUIT
SET X=$GET(LRASRL(LRALI1))
DO ^DIWP
+12 KILL LRASRL
+13 SET (LRALC,LRALI1)=0
+14 FOR
SET LRALI1=$ORDER(^UTILITY($JOB,"W",1,LRALI1))
if +LRALI1=0
QUIT
Begin DoDot:1
+15 SET LRASRL(LRALI1)=$$TM($GET(^UTILITY($JOB,"W",1,LRALI1,0))," ")
SET LRALC=LRALC+1
End DoDot:1
+16 if $LENGTH(LRALC)
SET LRASRL=LRALC
+17 KILL ^UTILITY($JOB,"W")
+18 QUIT
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
