RMPOICD2 ;ALB/MGD - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
;;3.0;PROSTHETICS;**168**;Feb 09, 1996;Build 43
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
;
; Input
;
; X Length of list to display (default 5)
; .RMPSRL Local array passed by reference
;
; RMPSRL() Input Array from ICDSRCH^LEX10CS
;
; RMPSRL(0)=# found ^ Pruning Indicator
; RMPSRL(1,0)=Code ^ Code IEN ^ date
; RMPSRL(1,"IDL")=ICD-9/10 Description, Long
; RMPSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
; RMPSRL(1,"IDS")=ICD-9/10 Description, Short
; RMPSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
; RMPSRL(1,"LEX")=Lexicon Description
; RMPSRL(1,"LEX",1)=Expression IEN ^ date
; RMPSRL(1,"SYN",1)=Synonym #1
; RMPSRL(1,"SYN",m)=Synonym #m
; ...
;
; Output
;
; $$SEL Two Piece "^" delimited string same as
; Fileman's Y output variable
;
; 1 Lexicon IEN
; 2 Lexicon Term
;
; RMPSRL Local array passed by reference
;
; RMPSRL(0)=Code ^ Code IEN ^ date
; RMPSRL("IDL")=ICD-9/10 Description, Long
; RMPSRL("IDL",1)=ICD-9/10 IEN ^ date
; RMPSRL("IDS")=ICD-9/10 Description, Short
; RMPSRL("IDS",1)=ICD-9/10 IEN ^ date
; RMPSRL("LEX")=Lexicon Description
; RMPSRL("LEX",1)=Expression IEN ^ date
;
; or ^ on error
; or -1 for non-selection
; or -2 if "^" was entered
;
SEL(RMPSRL,X) ; Select from List
N RMPGOUP S RMPGOUP=0
S X=+($G(X))
S:X'>0 X=5
S X=$$ASK(.RMPSRL,X)
I RMPGOUP=1 Q -2
Q X
;
ASK(RMPSRL,X) ; Ask for Selection
N DTOUT,DUOUT,DIROUT
N RMPLIT,RMPLL,RMPLTOT
S RMPLL=+($G(X))
S:RMPLL'>0 RMPLL=5
S RMPLIT=0,RMPLTOT=$O(RMPSRL(" "),-1)
Q:+RMPLTOT'>0 "^"
K X
S:+RMPLTOT=1 X=$$ONE(RMPLL,.RMPSRL)
S:+RMPLTOT>1 X=$$MUL(.RMPSRL,RMPLL)
S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
Q X
ONE(X,RMPSRL) ; One Entry Found
Q:+($G(RMPLIT))>0 "^^"
N DIR,RMPLC,RMPLEX,RMPLFI,RMPLIT,RMPLSO,RMPLNC
N RMPLSP,RMPLTX,RMPLC,Y
S RMPLFI=$O(RMPSRL(0)) Q:+RMPLFI'>0 "^" S RMPLSP=$J(" ",25)
S RMPLSO=$P(RMPSRL(1,0),"^",1),RMPLNC=$P(RMPSRL(1,0),"^",3)
S:+RMPLNC>0 RMPLNC=" ("_RMPLNC_")" S RMPLEX=$G(RMPSRL(1,"MENU"))
S RMPLC=$S($D(RMPSRL(1,"CAT")):"-",1:"")
S RMPLTX(1)=RMPLSO_RMPLC_$J(" ",(9-$L(RMPLSO)))_" "_RMPLEX_RMPLNC
D PR(.RMPLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
S DIR("A",3)=" "_$G(RMPLTX(1)),RMPLC=3 I $L($G(RMPLTX(2))) D
. S RMPLC=RMPLC+1,DIR("A",RMPLC)=RMPLSP_$G(RMPLTX(2))
S RMPLC=RMPLC+1,DIR("A",RMPLC)=" ",RMPLC=RMPLC+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)) RMPLIT=1
I X["^^"!(+($G(RMPLIT))>0) K RMPSRL Q "^^"
S X=$S(+Y>0:$$X(1,.RMPSRL),1:-1)
Q X
MUL(RMPSRL,Y) ; Multiple Entries Found
Q:+($G(RMPLIT))>0 "^^"
N RMPSRLE,RMPLL,RMPLMAX,RMPLSS,RMPLX,X
S (RMPLMAX,RMPLSS,RMPLIT)=0,RMPLL=+($G(Y)),U="^" S:+($G(RMPLL))'>0 RMPLL=5
S RMPLX=$O(RMPSRL(" "),-1),RMPLSS=0
G:+RMPLX=0 MULQ W ! W:+RMPLX>1 !," ",RMPLX," matches found"
F RMPSRLE=1:1:RMPLX Q:((RMPLSS>0)&(RMPLSS<(RMPSRLE+1))) Q:RMPLIT D Q:RMPLIT
. W:RMPSRLE#RMPLL=1 ! D MULW
. S RMPLMAX=RMPSRLE W:RMPSRLE#RMPLL=0 !
. S:RMPSRLE#RMPLL=0 RMPLSS=$$MULS(RMPLMAX,RMPSRLE,.RMPSRL) S:RMPLSS["^" RMPLIT=1
I RMPSRLE#RMPLL'=0,+RMPLSS<=0 D
. W ! S RMPLSS=$$MULS(RMPLMAX,RMPSRLE,.RMPSRL) S:RMPLSS["^" RMPLIT=1
G MULQ
Q X
MULW ; Write Multiple
N RMPLEX,RMPLI1,RMPLSO,RMPLNC,RMPLT2,RMPLTX S RMPLSO=$P(RMPSRL(+RMPSRLE,0),"^",1)
S RMPLNC=$P(RMPSRL(+RMPSRLE,0),"^",3) S:+RMPLNC>0 RMPLNC=" ("_RMPLNC_")"
S RMPLEX=$G(RMPSRL(+RMPSRLE,"MENU")),RMPLTX(1)=RMPLSO
S RMPLTX(1)=RMPLTX(1)_$S($D(RMPSRL(+RMPSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(RMPLSO)))_" "_RMPLEX_RMPLNC
D PR(.RMPLTX,60) W !,$J(RMPSRLE,5),". ",$G(RMPLTX(1))
F RMPLI1=2:1:5 S RMPLT2=$G(RMPLTX(RMPLI1)) W:$L(RMPLT2) !,$J(" ",19),RMPLT2
Q
MULS(X,Y,RMPSRL) ; Select from Multiple Entries
N DIR,DIRB,RMPLFI,RMPLHLP,RMPLLST,RMPLMAX,RMPLS1 ;@#$ not sure RMPLS1 is neede here
Q:+($G(RMPLIT))>0 "^^" S RMPLMAX=+($G(X)),RMPLLST=+($G(Y))
Q:RMPLMAX=0 -1 S RMPLFI=$O(RMPSRL(0)) Q:+RMPLFI'>0 -1
I +($O(RMPSRL(+RMPLLST)))>0 D
. S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
. S DIR("A")=DIR("A")_RMPLMAX_": "
I +($O(RMPSRL(+RMPLLST)))'>0 D
. S DIR("A")=" Select 1-"_RMPLMAX_": "
S RMPLHLP=" Answer must be from 1 to "
S RMPLHLP=RMPLHLP_RMPLMAX_", or <Return> to continue"
S DIR("PRE")="S:X[""?"" X=""??"""
S (DIR("?"),DIR("??"))="^D MULSH^RMPOICD2"
S DIR(0)="NAO^1:"_RMPLMAX_":0" D ^DIR
S:X="^" RMPGOUP=1
Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
S:X["^^"!($D(DTOUT)) RMPLIT=1,X="^^" I X["^^"!(+($G(RMPLIT))>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(RMPLHLP)) W !,$G(RMPLHLP) Q
Q
MULQ ; Quit Multiple
I +RMPLSS'>0,$G(RMPLSS)="^" Q "^"
S X=-1 S:+($G(RMPLIT))'>0 X=$$X(+RMPLSS,.RMPSRL)
Q X
X(X,RMPSRL) ; Set X and Output Array
N RMPLEX,RMPSRFI,RMPLIEN,RMPLN1,RMPLNC,RMPLNN,RMPLRN,RMPLS1,RMPLSO
S RMPLS1=+($G(X))
S RMPSRFI=$O(RMPSRL(0)) ;@#$ not used?
S RMPLSO=$P($G(RMPSRL(RMPLS1,0)),"^",1),RMPLEX=$G(RMPSRL(RMPLS1,"MENU"))
S RMPLIEN=$S($D(RMPSRL(RMPLS1,"CAT")):"99:CAT;"_$P($G(RMPSRL(RMPLS1,0)),"^"),1:$P($G(RMPSRL(RMPLS1,"IDS",1)),"^")_";"_$P($G(RMPSRL(RMPLS1,0)),"^")_";"_$P($G(RMPSRL(RMPLS1,"LEX",1)),"^")) Q:'$L(RMPLSO) "^"
Q:'$L(RMPLEX) "^" Q:+RMPLIEN'>0 "^" S X=RMPLIEN_"^"_RMPLEX
S RMPLNN="RMPSRL("_+RMPLS1_")",RMPLNC="RMPSRL("_+RMPLS1_","
F S RMPLNN=$Q(@RMPLNN) Q:'$L(RMPLNN)!(RMPLNN'[RMPLNC) D
. S RMPLRN="RMPLN1("_$P(RMPLNN,"(",2,299) S @RMPLRN=@RMPLNN
K RMPSRL S RMPLNN="RMPLN1("_+RMPLS1_")",RMPLNC="RMPLN1("_+RMPLS1_","
F S RMPLNN=$Q(@RMPLNN) Q:'$L(RMPLNN)!(RMPLNN'[RMPLNC) D
. S RMPLRN="RMPSRL("_$P(RMPLNN,"(",2,299),@RMPLRN=@RMPLNN
Q X
;
; Miscellaneous
CL ; Clear
K RMPLIT
Q
PR(RMPSRL,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,RMPLC,RMPLI1,RMPLL
K ^UTILITY($J,"W")
Q:'$D(RMPSRL)
S RMPLL=+($G(X))
S:+RMPLL'>0 RMPLL=79
S RMPLC=+($G(RMPSRL))
S:+($G(RMPLC))'>0 RMPLC=$O(RMPSRL(" "),-1)
Q:+RMPLC'>0
S DIWL=1,DIWF="C"_+RMPLL
S RMPLI1=0
F S RMPLI1=$O(RMPSRL(RMPLI1)) Q:+RMPLI1=0 S X=$G(RMPSRL(RMPLI1)) D ^DIWP
K RMPSRL
S (RMPLC,RMPLI1)=0
F S RMPLI1=$O(^UTILITY($J,"W",1,RMPLI1)) Q:+RMPLI1=0 D
. S RMPSRL(RMPLI1)=$$TM($G(^UTILITY($J,"W",1,RMPLI1,0))," "),RMPLC=RMPLC+1
S:$L(RMPLC) RMPSRL=RMPLC
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[HRMPOICD2 7110 printed Dec 13, 2024@02:30:54 Page 2
RMPOICD2 ;ALB/MGD - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST ;12/07/2011
+1 ;;3.0;PROSTHETICS;**168**;Feb 09, 1996;Build 43
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
+5 ;
+6 ; Input
+7 ;
+8 ; X Length of list to display (default 5)
+9 ; .RMPSRL Local array passed by reference
+10 ;
+11 ; RMPSRL() Input Array from ICDSRCH^LEX10CS
+12 ;
+13 ; RMPSRL(0)=# found ^ Pruning Indicator
+14 ; RMPSRL(1,0)=Code ^ Code IEN ^ date
+15 ; RMPSRL(1,"IDL")=ICD-9/10 Description, Long
+16 ; RMPSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
+17 ; RMPSRL(1,"IDS")=ICD-9/10 Description, Short
+18 ; RMPSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
+19 ; RMPSRL(1,"LEX")=Lexicon Description
+20 ; RMPSRL(1,"LEX",1)=Expression IEN ^ date
+21 ; RMPSRL(1,"SYN",1)=Synonym #1
+22 ; RMPSRL(1,"SYN",m)=Synonym #m
+23 ; ...
+24 ;
+25 ; Output
+26 ;
+27 ; $$SEL Two Piece "^" delimited string same as
+28 ; Fileman's Y output variable
+29 ;
+30 ; 1 Lexicon IEN
+31 ; 2 Lexicon Term
+32 ;
+33 ; RMPSRL Local array passed by reference
+34 ;
+35 ; RMPSRL(0)=Code ^ Code IEN ^ date
+36 ; RMPSRL("IDL")=ICD-9/10 Description, Long
+37 ; RMPSRL("IDL",1)=ICD-9/10 IEN ^ date
+38 ; RMPSRL("IDS")=ICD-9/10 Description, Short
+39 ; RMPSRL("IDS",1)=ICD-9/10 IEN ^ date
+40 ; RMPSRL("LEX")=Lexicon Description
+41 ; RMPSRL("LEX",1)=Expression IEN ^ date
+42 ;
+43 ; or ^ on error
+44 ; or -1 for non-selection
+45 ; or -2 if "^" was entered
+46 ;
SEL(RMPSRL,X) ; Select from List
+1 NEW RMPGOUP
SET RMPGOUP=0
+2 SET X=+($GET(X))
+3 if X'>0
SET X=5
+4 SET X=$$ASK(.RMPSRL,X)
+5 IF RMPGOUP=1
QUIT -2
+6 QUIT X
+7 ;
ASK(RMPSRL,X) ; Ask for Selection
+1 NEW DTOUT,DUOUT,DIROUT
+2 NEW RMPLIT,RMPLL,RMPLTOT
+3 SET RMPLL=+($GET(X))
+4 if RMPLL'>0
SET RMPLL=5
+5 SET RMPLIT=0
SET RMPLTOT=$ORDER(RMPSRL(" "),-1)
+6 if +RMPLTOT'>0
QUIT "^"
+7 KILL X
+8 if +RMPLTOT=1
SET X=$$ONE(RMPLL,.RMPSRL)
+9 if +RMPLTOT>1
SET X=$$MUL(.RMPSRL,RMPLL)
+10 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
SET X=-1
+11 QUIT X
ONE(X,RMPSRL) ; One Entry Found
+1 if +($GET(RMPLIT))>0
QUIT "^^"
+2 NEW DIR,RMPLC,RMPLEX,RMPLFI,RMPLIT,RMPLSO,RMPLNC
+3 NEW RMPLSP,RMPLTX,RMPLC,Y
+4 SET RMPLFI=$ORDER(RMPSRL(0))
if +RMPLFI'>0
QUIT "^"
SET RMPLSP=$JUSTIFY(" ",25)
+5 SET RMPLSO=$PIECE(RMPSRL(1,0),"^",1)
SET RMPLNC=$PIECE(RMPSRL(1,0),"^",3)
+6 if +RMPLNC>0
SET RMPLNC=" ("_RMPLNC_")"
SET RMPLEX=$GET(RMPSRL(1,"MENU"))
+7 SET RMPLC=$SELECT($DATA(RMPSRL(1,"CAT")):"-",1:"")
+8 SET RMPLTX(1)=RMPLSO_RMPLC_$JUSTIFY(" ",(9-$LENGTH(RMPLSO)))_" "_RMPLEX_RMPLNC
+9 DO PR(.RMPLTX,64)
SET DIR("A",1)=" One match found"
SET DIR("A",2)=" "
+10 SET DIR("A",3)=" "_$GET(RMPLTX(1))
SET RMPLC=3
IF $LENGTH($GET(RMPLTX(2)))
Begin DoDot:1
+11 SET RMPLC=RMPLC+1
SET DIR("A",RMPLC)=RMPLSP_$GET(RMPLTX(2))
End DoDot:1
+12 SET RMPLC=RMPLC+1
SET DIR("A",RMPLC)=" "
SET RMPLC=RMPLC+1
+13 SET DIR("A")=" OK? (Yes/No) "
SET DIR("B")="Yes"
SET DIR(0)="YAO"
WRITE !
+14 DO ^DIR
if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+15 if X["^^"!($DATA(DTOUT))
SET RMPLIT=1
+16 IF X["^^"!(+($GET(RMPLIT))>0)
KILL RMPSRL
QUIT "^^"
+17 SET X=$SELECT(+Y>0:$$X(1,.RMPSRL),1:-1)
+18 QUIT X
MUL(RMPSRL,Y) ; Multiple Entries Found
+1 if +($GET(RMPLIT))>0
QUIT "^^"
+2 NEW RMPSRLE,RMPLL,RMPLMAX,RMPLSS,RMPLX,X
+3 SET (RMPLMAX,RMPLSS,RMPLIT)=0
SET RMPLL=+($GET(Y))
SET U="^"
if +($GET(RMPLL))'>0
SET RMPLL=5
+4 SET RMPLX=$ORDER(RMPSRL(" "),-1)
SET RMPLSS=0
+5 if +RMPLX=0
GOTO MULQ
WRITE !
if +RMPLX>1
WRITE !," ",RMPLX," matches found"
+6 FOR RMPSRLE=1:1:RMPLX
if ((RMPLSS>0)&(RMPLSS<(RMPSRLE+1)))
QUIT
if RMPLIT
QUIT
Begin DoDot:1
+7 if RMPSRLE#RMPLL=1
WRITE !
DO MULW
+8 SET RMPLMAX=RMPSRLE
if RMPSRLE#RMPLL=0
WRITE !
+9 if RMPSRLE#RMPLL=0
SET RMPLSS=$$MULS(RMPLMAX,RMPSRLE,.RMPSRL)
if RMPLSS["^"
SET RMPLIT=1
End DoDot:1
if RMPLIT
QUIT
+10 IF RMPSRLE#RMPLL'=0
IF +RMPLSS<=0
Begin DoDot:1
+11 WRITE !
SET RMPLSS=$$MULS(RMPLMAX,RMPSRLE,.RMPSRL)
if RMPLSS["^"
SET RMPLIT=1
End DoDot:1
+12 GOTO MULQ
+13 QUIT X
MULW ; Write Multiple
+1 NEW RMPLEX,RMPLI1,RMPLSO,RMPLNC,RMPLT2,RMPLTX
SET RMPLSO=$PIECE(RMPSRL(+RMPSRLE,0),"^",1)
+2 SET RMPLNC=$PIECE(RMPSRL(+RMPSRLE,0),"^",3)
if +RMPLNC>0
SET RMPLNC=" ("_RMPLNC_")"
+3 SET RMPLEX=$GET(RMPSRL(+RMPSRLE,"MENU"))
SET RMPLTX(1)=RMPLSO
+4 SET RMPLTX(1)=RMPLTX(1)_$SELECT($DATA(RMPSRL(+RMPSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(RMPLSO)))_" "_RMPLEX_RMPLNC
+5 DO PR(.RMPLTX,60)
WRITE !,$JUSTIFY(RMPSRLE,5),". ",$GET(RMPLTX(1))
+6 FOR RMPLI1=2:1:5
SET RMPLT2=$GET(RMPLTX(RMPLI1))
if $LENGTH(RMPLT2)
WRITE !,$JUSTIFY(" ",19),RMPLT2
+7 QUIT
MULS(X,Y,RMPSRL) ; Select from Multiple Entries
+1 ;@#$ not sure RMPLS1 is neede here
NEW DIR,DIRB,RMPLFI,RMPLHLP,RMPLLST,RMPLMAX,RMPLS1
+2 if +($GET(RMPLIT))>0
QUIT "^^"
SET RMPLMAX=+($GET(X))
SET RMPLLST=+($GET(Y))
+3 if RMPLMAX=0
QUIT -1
SET RMPLFI=$ORDER(RMPSRL(0))
if +RMPLFI'>0
QUIT -1
+4 IF +($ORDER(RMPSRL(+RMPLLST)))>0
Begin DoDot:1
+5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
+6 SET DIR("A")=DIR("A")_RMPLMAX_": "
End DoDot:1
+7 IF +($ORDER(RMPSRL(+RMPLLST)))'>0
Begin DoDot:1
+8 SET DIR("A")=" Select 1-"_RMPLMAX_": "
End DoDot:1
+9 SET RMPLHLP=" Answer must be from 1 to "
+10 SET RMPLHLP=RMPLHLP_RMPLMAX_", or <Return> to continue"
+11 SET DIR("PRE")="S:X[""?"" X=""??"""
+12 SET (DIR("?"),DIR("??"))="^D MULSH^RMPOICD2"
+13 SET DIR(0)="NAO^1:"_RMPLMAX_":0"
DO ^DIR
+14 if X="^"
SET RMPGOUP=1
+15 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
QUIT -1
+16 if X["^^"!($DATA(DTOUT))
SET RMPLIT=1
SET X="^^"
IF X["^^"!(+($GET(RMPLIT))>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(RMPLHLP))
WRITE !,$GET(RMPLHLP)
QUIT
+2 QUIT
MULQ ; Quit Multiple
+1 IF +RMPLSS'>0
IF $GET(RMPLSS)="^"
QUIT "^"
+2 SET X=-1
if +($GET(RMPLIT))'>0
SET X=$$X(+RMPLSS,.RMPSRL)
+3 QUIT X
X(X,RMPSRL) ; Set X and Output Array
+1 NEW RMPLEX,RMPSRFI,RMPLIEN,RMPLN1,RMPLNC,RMPLNN,RMPLRN,RMPLS1,RMPLSO
+2 SET RMPLS1=+($GET(X))
+3 ;@#$ not used?
SET RMPSRFI=$ORDER(RMPSRL(0))
+4 SET RMPLSO=$PIECE($GET(RMPSRL(RMPLS1,0)),"^",1)
SET RMPLEX=$GET(RMPSRL(RMPLS1,"MENU"))
+5 SET RMPLIEN=$SELECT($DATA(RMPSRL(RMPLS1,"CAT")):"99:CAT;"_$PIECE($GET(RMPSRL(RMPLS1,0)),"^"),1:$PIECE($GET(RMPSRL(RMPLS1,"IDS",1)),"^")_";"_$PIECE($GET(RMPSRL(RMPLS1,0)),"^")_";"_$PIECE($GET(RMPSRL(RMPLS1,"LEX",1)),"^"))
if '$LENGTH(RMPLSO)
QUIT "^"
+6 if '$LENGTH(RMPLEX)
QUIT "^"
if +RMPLIEN'>0
QUIT "^"
SET X=RMPLIEN_"^"_RMPLEX
+7 SET RMPLNN="RMPSRL("_+RMPLS1_")"
SET RMPLNC="RMPSRL("_+RMPLS1_","
+8 FOR
SET RMPLNN=$QUERY(@RMPLNN)
if '$LENGTH(RMPLNN)!(RMPLNN'[RMPLNC)
QUIT
Begin DoDot:1
+9 SET RMPLRN="RMPLN1("_$PIECE(RMPLNN,"(",2,299)
SET @RMPLRN=@RMPLNN
End DoDot:1
+10 KILL RMPSRL
SET RMPLNN="RMPLN1("_+RMPLS1_")"
SET RMPLNC="RMPLN1("_+RMPLS1_","
+11 FOR
SET RMPLNN=$QUERY(@RMPLNN)
if '$LENGTH(RMPLNN)!(RMPLNN'[RMPLNC)
QUIT
Begin DoDot:1
+12 SET RMPLRN="RMPSRL("_$PIECE(RMPLNN,"(",2,299)
SET @RMPLRN=@RMPLNN
End DoDot:1
+13 QUIT X
+14 ;
+15 ; Miscellaneous
CL ; Clear
+1 KILL RMPLIT
+2 QUIT
PR(RMPSRL,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,RMPLC,RMPLI1,RMPLL
+2 KILL ^UTILITY($JOB,"W")
+3 if '$DATA(RMPSRL)
QUIT
+4 SET RMPLL=+($GET(X))
+5 if +RMPLL'>0
SET RMPLL=79
+6 SET RMPLC=+($GET(RMPSRL))
+7 if +($GET(RMPLC))'>0
SET RMPLC=$ORDER(RMPSRL(" "),-1)
+8 if +RMPLC'>0
QUIT
+9 SET DIWL=1
SET DIWF="C"_+RMPLL
+10 SET RMPLI1=0
+11 FOR
SET RMPLI1=$ORDER(RMPSRL(RMPLI1))
if +RMPLI1=0
QUIT
SET X=$GET(RMPSRL(RMPLI1))
DO ^DIWP
+12 KILL RMPSRL
+13 SET (RMPLC,RMPLI1)=0
+14 FOR
SET RMPLI1=$ORDER(^UTILITY($JOB,"W",1,RMPLI1))
if +RMPLI1=0
QUIT
Begin DoDot:1
+15 SET RMPSRL(RMPLI1)=$$TM($GET(^UTILITY($JOB,"W",1,RMPLI1,0))," ")
SET RMPLC=RMPLC+1
End DoDot:1
+16 if $LENGTH(RMPLC)
SET RMPSRL=RMPLC
+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
