ICDSELPS.m

ICDSELPS ;ALB/KUM - Select ICD PROCEDURE FROM A LIXICON UTILITY LIST ;12/07/2011

 ;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103

 ;

SEL(ICDSRL,X) ; Select from List

 ;

 ; 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

 ;               

 S X=+($G(X)) S:X'>0 X=5 S X=$$ASK(.ICDSRL,X)

 Q X

ASK(ICDSRL,X) ;   Ask for Selection

 K X N ICDSRLIT,ICDSRLL,ICDSRTOT S ICDSRLL=+($G(X)) S:ICDSRLL'>0 ICDSRLL=5

 S ICDSRLIT=0,ICDSRTOT=$O(ICDSRL(" "),-1) Q:+ICDSRTOT'>0 "^"

 K X S:+ICDSRTOT=1 X=$$ONE(ICDSRLL,.ICDSRL) S:+ICDSRTOT>1 X=$$MUL(.ICDSRL,ICDSRLL)

 Q X

ONE(X,ICDSRL) ;     One Entry Found

 Q:+($G(ICDSRLIT))>0 "^^"  N DIR,DTOUT,ICDSRLC,ICDSRLEX,ICDSRLFI,ICDSRLIT,ICDSRLSO

 N ICDSRLSP,ICDSRLTX,Y

 S ICDSRLFI=$O(ICDSRL(0)) Q:+ICDSRLFI'>0 "^"  S ICDSRLSP=$J(" ",25)

 S ICDSRLSO=$P(ICDSRL(1,0),"^",1),ICDSRLEX=$G(ICDSRL(1,"LEX"))

 S ICDSRLTX(1)=ICDSRLSO_$J(" ",(9-$L(ICDSRLSO)))_" "_ICDSRLEX

 D PR(.ICDSRLTX,64) S DIR("A",1)=" One code found for character "_($L($G(ICDPRC))+1)_".",DIR("A",2)=" "

 S DIR("A",3)="     "_$G(ICDSRLTX(1)),ICDSRLC=3 I $L($G(ICDSRLTX(2))) D

 . S ICDSRLC=ICDSRLC+1,DIR("A",ICDSRLC)=ICDSRLSP_$G(ICDSRLTX(2))

 S ICDSRLC=ICDSRLC+1,DIR("A",ICDSRLC)=" ",ICDSRLC=ICDSRLC+1

 S DIR("A")="   OK?  (Yes/No)  ",DIR("B")="Yes",DIR(0)="YAO" W !

 D ^DIR S:X["^^"!($D(DTOUT)) ICDSRLIT=1

 I X["^^"!(+($G(ICDSRLIT))>0) K ICDSRL Q "^^"

 S X=$S(+Y>0:$$X(1,.ICDSRL),1:-1)

 Q X

MUL(ICDSRL,Y) ;     Multiple Entries Found

 Q:+($G(ICDSRLIT))>0 "^^"  N ICDSRLE,ICDSRLL,ICDSRMAX,ICDSRLSS,ICDSRLX,X

 S (ICDSRMAX,ICDSRLSS,ICDSRLIT)=0,ICDSRLL=+($G(Y)),U="^" S:+($G(ICDSRLL))'>0 ICDSRLL=5

 S ICDSRLX=$O(ICDSRL(" "),-1),ICDSRLSS=0

 G:+ICDSRLX=0 MULQ W ! W:+ICDSRLX>1 !," ",ICDSRLX," matches found for character ",$L($G(ICDPRC))+1,"."

 F ICDSRLE=1:1:ICDSRLX Q:((ICDSRLSS>0)&(ICDSRLSS<(ICDSRLE+1)))  Q:ICDSRLIT  D  Q:ICDSRLIT

 . W:ICDSRLE#ICDSRLL=1 ! D MULW

 . S ICDSRMAX=ICDSRLE W:ICDSRLE#ICDSRLL=0 !

 . S:ICDSRLE#ICDSRLL=0 ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL) S:ICDSRLSS["^" ICDSRLIT=1

 I ICDSRLE#ICDSRLL'=0,+ICDSRLSS<=0 D

 . W ! S ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL) S:ICDSRLSS["^" ICDSRLIT=1

 G MULQ

 Q X

MULW ;       Write Multiple

 N ICDSRLEX,ICDSRLI,ICDSRLSO,ICDSRLT,ICDSRLTX S ICDSRLSO=$P(ICDSRL(+ICDSRLE,0),"^",1)

 S ICDSRLEX=$G(ICDSRL(+ICDSRLE,"LEX")),ICDSRLTX(1)=ICDSRLSO

 S ICDSRLTX(1)=ICDSRLTX(1)_$J(" ",(9-$L(ICDSRLSO)))_" "_ICDSRLEX

 D PR(.ICDSRLTX,63) W !,$J(ICDSRLE,5),".  ",$G(ICDSRLTX(1))

 F ICDSRLI=2:1:5 S ICDSRLT=$G(ICDSRLTX(ICDSRLI)) W:$L(ICDSRLT) !,$J(" ",18),ICDSRLT

 Q

MULS(X,Y,ICDSRL) ;       Select from Multiple Entries

 N DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,ICDSRLFI,ICDSRHLP,ICDSRLAST,ICDSRMAX,ICDSRLS

 Q:+($G(ICDSRLIT))>0 "^^"  S ICDSRMAX=+($G(X)),ICDSRLAST=+($G(Y))

 Q:ICDSRMAX=0 -1  S ICDSRLFI=$O(ICDSRL(0)) Q:+ICDSRLFI'>0 -1

 I +($O(ICDSRL(+ICDSRLAST)))>0 D

 . S DIR("A")=" Press <RETURN> for more, '^' to quit selection, or Select 1-"

 . S DIR("A")=DIR("A")_ICDSRMAX_":  "

 I +($O(ICDSRL(+ICDSRLAST)))'>0 D

 . S DIR("A")=" Select 1-"_ICDSRMAX_":  "

 S ICDSRHLP="    Answer must be from 1 to "

 S ICDSRHLP=ICDSRHLP_ICDSRMAX_", or <Return> to continue"

 S DIR("PRE")="S:X[""?"" X=""??"""

 S (DIR("?"),DIR("??"))="^D MULSH^ICDSELPS"

 S DIR(0)="NAO^1:"_ICDSRMAX_":0" D ^DIR

 I X["^^"!($D(DTOUT)) S ICDSRLIT=1,X="^^" Q "^^"

 K DIR Q:$D(DTOUT)!(X[U) "^"

 Q $S(+Y>0:+Y,1:"-1")

MULSH ;       Select from Multiple Entries Help

 I $L($G(ICDSRHLP)) W !,$G(ICDSRHLP) Q

 Q

MULQ ;       Quit Multiple Entries Selection

 Q:+($G(ICDSRLSS))'>0 -1  S X=-1 S:+($G(ICDSRLIT))'>0 X=$$X(+ICDSRLSS,.ICDSRL)

 Q X

X(X,ICDSRL) ;   Set X and Outpot Array

 N ICDSRLEX,ICDLEXFI,ICDSRLIEN,ICDSRLN,ICDSRLNC,ICDSRLNN,ICDSRLRN,ICDSRLS,ICDSRLSO

 S ICDSRLS=+($G(X))

 S ICDSRLSO=$P($G(ICDSRL(ICDSRLS,0)),"^",1)

 S ICDSRLEX=$G(ICDSRL(ICDSRLS,"LEX"))

 Q:'$L(ICDSRLEX) "^" S X=ICDSRLSO_"^"_ICDSRLEX

 Q X

 ;        

 ; Miscellaneous

CL ;   Clear

 K ICDSRLIT

 Q

PR(ICDSRL,X) ;   Parse Array

 N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,ICDDN,ICDSRLC,ICDSRLI,ICDSRLL

 K ^UTILITY($J,"W") Q:'$D(ICDSRL)  S ICDSRLL=+($G(X)) S:+ICDSRLL'>0 ICDSRLL=79

 S ICDSRLC=+($G(ICDSRL)) S:+($G(ICDSRLC))'>0 ICDSRLC=$O(ICDSRL(" "),-1) Q:+ICDSRLC'>0

 S DIWL=1,DIWF="C"_+ICDSRLL S ICDSRLI=0

 F  S ICDSRLI=$O(ICDSRL(ICDSRLI)) Q:+ICDSRLI=0  S X=$G(ICDSRL(ICDSRLI)) D ^DIWP

 K ICDSRL S (ICDSRLC,ICDSRLI)=0

 F  S ICDSRLI=$O(^UTILITY($J,"W",1,ICDSRLI)) Q:+ICDSRLI=0  D

 . S ICDSRL(ICDSRLI)=$$TM($G(^UTILITY($J,"W",1,ICDSRLI,0))," "),ICDSRLC=ICDSRLC+1

 S:$L(ICDSRLC) ICDSRL=ICDSRLC 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 ---ICDSELPS   6213     printed  Feb 18, 2025@23:17:26                                                                                                                                                                                                    Page 2

ICDSELPS  ;ALB/KUM - Select ICD PROCEDURE FROM A LIXICON UTILITY LIST ;12/07/2011

 +1       ;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103

 +2       ;

SEL(ICDSRL,X) ; Select from List

 +1       ;

 +2       ; Input   

 +3       ; 

 +4       ;     X     Length of list to display (default 5)

 +5       ;    .ICDSRL   Local array passed by reference

 +6       ;               

 +7       ;             ICDSRL()   Input Array from ICDSRCH^LEX10CS

 +8       ;               

 +9       ;             ICDSRL(0)=# found ^ Pruning Indicator

 +10      ;             ICDSRL(1,0)=Code ^ Code IEN ^ date

 +11      ;             ICDSRL(1,"IDL")=ICD-9/10 Description, Long

 +12      ;             ICDSRL(1,"IDL",1)=ICD-9/10 IEN ^ date

 +13      ;             ICDSRL(1,"IDS")=ICD-9/10 Description, Short

 +14      ;             ICDSRL(1,"IDS",1)=ICD-9/10 IEN ^ date

 +15      ;             ICDSRL(1,"LEX")=Lexicon Description

 +16      ;             ICDSRL(1,"LEX",1)=Expression IEN ^ date

 +17      ;             ICDSRL(1,"SYN",1)=Synonym #1

 +18      ;             ICDSRL(1,"SYN",m)=Synonym #m

 +19      ;             ...

 +20      ;               

 +21      ; Output

 +22      ;               

 +23      ;    $$SEL  Two Piece "^" delimited string same as

 +24      ;           Fileman's Y output variable

 +25      ;               

 +26      ;             1  Lexicon IEN

 +27      ;             2  Lexicon Term

 +28      ;               

 +29      ;    ICDSRL    Local array passed by reference

 +30      ;               

 +31      ;             ICDSRL(0)=Code ^ Code IEN ^ date

 +32      ;             ICDSRL("IDL")=ICD-9/10 Description, Long

 +33      ;             ICDSRL("IDL",1)=ICD-9/10 IEN ^ date

 +34      ;             ICDSRL("IDS")=ICD-9/10 Description, Short

 +35      ;             ICDSRL("IDS",1)=ICD-9/10 IEN ^ date

 +36      ;             ICDSRL("LEX")=Lexicon Description

 +37      ;             ICDSRL("LEX",1)=Expression IEN ^ date

 +38      ;               

 +39      ;    or ^ on error 

 +40      ;    or -1 for non-selection

 +41      ;               

 +42       SET X=+($GET(X))

           if X'>0

               SET X=5

           SET X=$$ASK(.ICDSRL,X)

 +43       QUIT X

ASK(ICDSRL,X) ;   Ask for Selection

 +1        KILL X

           NEW ICDSRLIT,ICDSRLL,ICDSRTOT

           SET ICDSRLL=+($GET(X))

           if ICDSRLL'>0

               SET ICDSRLL=5

 +2        SET ICDSRLIT=0

           SET ICDSRTOT=$ORDER(ICDSRL(" "),-1)

           if +ICDSRTOT'>0

               QUIT "^"

 +3        KILL X

           if +ICDSRTOT=1

               SET X=$$ONE(ICDSRLL,.ICDSRL)

           if +ICDSRTOT>1

               SET X=$$MUL(.ICDSRL,ICDSRLL)

 +4        QUIT X

ONE(X,ICDSRL) ;     One Entry Found

 +1        if +($GET(ICDSRLIT))>0

               QUIT "^^"

           NEW DIR,DTOUT,ICDSRLC,ICDSRLEX,ICDSRLFI,ICDSRLIT,ICDSRLSO

 +2        NEW ICDSRLSP,ICDSRLTX,Y

 +3        SET ICDSRLFI=$ORDER(ICDSRL(0))

           if +ICDSRLFI'>0

               QUIT "^"

           SET ICDSRLSP=$JUSTIFY(" ",25)

 +4        SET ICDSRLSO=$PIECE(ICDSRL(1,0),"^",1)

           SET ICDSRLEX=$GET(ICDSRL(1,"LEX"))

 +5        SET ICDSRLTX(1)=ICDSRLSO_$JUSTIFY(" ",(9-$LENGTH(ICDSRLSO)))_" "_ICDSRLEX

 +6        DO PR(.ICDSRLTX,64)

           SET DIR("A",1)=" One code found for character "_($LENGTH($GET(ICDPRC))+1)_"."

           SET DIR("A",2)=" "

 +7        SET DIR("A",3)="     "_$GET(ICDSRLTX(1))

           SET ICDSRLC=3

           IF $LENGTH($GET(ICDSRLTX(2)))

               Begin DoDot:1

 +8                SET ICDSRLC=ICDSRLC+1

                   SET DIR("A",ICDSRLC)=ICDSRLSP_$GET(ICDSRLTX(2))

               End DoDot:1

 +9        SET ICDSRLC=ICDSRLC+1

           SET DIR("A",ICDSRLC)=" "

           SET ICDSRLC=ICDSRLC+1

 +10       SET DIR("A")="   OK?  (Yes/No)  "

           SET DIR("B")="Yes"

           SET DIR(0)="YAO"

           WRITE !

 +11       DO ^DIR

           if X["^^"!($DATA(DTOUT))

               SET ICDSRLIT=1

 +12       IF X["^^"!(+($GET(ICDSRLIT))>0)

               KILL ICDSRL

               QUIT "^^"

 +13       SET X=$SELECT(+Y>0:$$X(1,.ICDSRL),1:-1)

 +14       QUIT X

MUL(ICDSRL,Y) ;     Multiple Entries Found

 +1        if +($GET(ICDSRLIT))>0

               QUIT "^^"

           NEW ICDSRLE,ICDSRLL,ICDSRMAX,ICDSRLSS,ICDSRLX,X

 +2        SET (ICDSRMAX,ICDSRLSS,ICDSRLIT)=0

           SET ICDSRLL=+($GET(Y))

           SET U="^"

           if +($GET(ICDSRLL))'>0

               SET ICDSRLL=5

 +3        SET ICDSRLX=$ORDER(ICDSRL(" "),-1)

           SET ICDSRLSS=0

 +4        if +ICDSRLX=0

               GOTO MULQ

           WRITE !

           if +ICDSRLX>1

               WRITE !," ",ICDSRLX," matches found for character ",$LENGTH($GET(ICDPRC))+1,"."

 +5        FOR ICDSRLE=1:1:ICDSRLX

               if ((ICDSRLSS>0)&(ICDSRLSS<(ICDSRLE+1)))

                   QUIT 

               if ICDSRLIT

                   QUIT 

               Begin DoDot:1

 +6                if ICDSRLE#ICDSRLL=1

                       WRITE !

                   DO MULW

 +7                SET ICDSRMAX=ICDSRLE

                   if ICDSRLE#ICDSRLL=0

                       WRITE !

 +8                if ICDSRLE#ICDSRLL=0

                       SET ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL)

                   if ICDSRLSS["^"

                       SET ICDSRLIT=1

               End DoDot:1

               if ICDSRLIT

                   QUIT 

 +9        IF ICDSRLE#ICDSRLL'=0

               IF +ICDSRLSS<=0

                   Begin DoDot:1

 +10                   WRITE !

                       SET ICDSRLSS=$$MULS(ICDSRMAX,ICDSRLE,.ICDSRL)

                       if ICDSRLSS["^"

                           SET ICDSRLIT=1

                   End DoDot:1

 +11       GOTO MULQ

 +12       QUIT X

MULW      ;       Write Multiple

 +1        NEW ICDSRLEX,ICDSRLI,ICDSRLSO,ICDSRLT,ICDSRLTX

           SET ICDSRLSO=$PIECE(ICDSRL(+ICDSRLE,0),"^",1)

 +2        SET ICDSRLEX=$GET(ICDSRL(+ICDSRLE,"LEX"))

           SET ICDSRLTX(1)=ICDSRLSO

 +3        SET ICDSRLTX(1)=ICDSRLTX(1)_$JUSTIFY(" ",(9-$LENGTH(ICDSRLSO)))_" "_ICDSRLEX

 +4        DO PR(.ICDSRLTX,63)

           WRITE !,$JUSTIFY(ICDSRLE,5),".  ",$GET(ICDSRLTX(1))

 +5        FOR ICDSRLI=2:1:5

               SET ICDSRLT=$GET(ICDSRLTX(ICDSRLI))

               if $LENGTH(ICDSRLT)

                   WRITE !,$JUSTIFY(" ",18),ICDSRLT

 +6        QUIT 

MULS(X,Y,ICDSRL) ;       Select from Multiple Entries

 +1        NEW DIR,DIRB,DIROUT,DIRUT,DTOUT,DUOUT,ICDSRLFI,ICDSRHLP,ICDSRLAST,ICDSRMAX,ICDSRLS

 +2        if +($GET(ICDSRLIT))>0

               QUIT "^^"

           SET ICDSRMAX=+($GET(X))

           SET ICDSRLAST=+($GET(Y))

 +3        if ICDSRMAX=0

               QUIT -1

           SET ICDSRLFI=$ORDER(ICDSRL(0))

           if +ICDSRLFI'>0

               QUIT -1

 +4        IF +($ORDER(ICDSRL(+ICDSRLAST)))>0

               Begin DoDot:1

 +5                SET DIR("A")=" Press <RETURN> for more, '^' to quit selection, or Select 1-"

 +6                SET DIR("A")=DIR("A")_ICDSRMAX_":  "

               End DoDot:1

 +7        IF +($ORDER(ICDSRL(+ICDSRLAST)))'>0

               Begin DoDot:1

 +8                SET DIR("A")=" Select 1-"_ICDSRMAX_":  "

               End DoDot:1

 +9        SET ICDSRHLP="    Answer must be from 1 to "

 +10       SET ICDSRHLP=ICDSRHLP_ICDSRMAX_", or <Return> to continue"

 +11       SET DIR("PRE")="S:X[""?"" X=""??"""

 +12       SET (DIR("?"),DIR("??"))="^D MULSH^ICDSELPS"

 +13       SET DIR(0)="NAO^1:"_ICDSRMAX_":0"

           DO ^DIR

 +14       IF X["^^"!($DATA(DTOUT))

               SET ICDSRLIT=1

               SET X="^^"

               QUIT "^^"

 +15       KILL DIR

           if $DATA(DTOUT)!(X[U)

               QUIT "^"

 +16       QUIT $SELECT(+Y>0:+Y,1:"-1")

MULSH     ;       Select from Multiple Entries Help

 +1        IF $LENGTH($GET(ICDSRHLP))

               WRITE !,$GET(ICDSRHLP)

               QUIT 

 +2        QUIT 

MULQ      ;       Quit Multiple Entries Selection

 +1        if +($GET(ICDSRLSS))'>0

               QUIT -1

           SET X=-1

           if +($GET(ICDSRLIT))'>0

               SET X=$$X(+ICDSRLSS,.ICDSRL)

 +2        QUIT X

X(X,ICDSRL) ;   Set X and Outpot Array

 +1        NEW ICDSRLEX,ICDLEXFI,ICDSRLIEN,ICDSRLN,ICDSRLNC,ICDSRLNN,ICDSRLRN,ICDSRLS,ICDSRLSO

 +2        SET ICDSRLS=+($GET(X))

 +3        SET ICDSRLSO=$PIECE($GET(ICDSRL(ICDSRLS,0)),"^",1)

 +4        SET ICDSRLEX=$GET(ICDSRL(ICDSRLS,"LEX"))

 +5        if '$LENGTH(ICDSRLEX)

               QUIT "^"

           SET X=ICDSRLSO_"^"_ICDSRLEX

 +6        QUIT X

 +7       ;        

 +8       ; Miscellaneous

CL        ;   Clear

 +1        KILL ICDSRLIT

 +2        QUIT 

PR(ICDSRL,X) ;   Parse Array

 +1        NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,ICDDN,ICDSRLC,ICDSRLI,ICDSRLL

 +2        KILL ^UTILITY($JOB,"W")

           if '$DATA(ICDSRL)

               QUIT 

           SET ICDSRLL=+($GET(X))

           if +ICDSRLL'>0

               SET ICDSRLL=79

 +3        SET ICDSRLC=+($GET(ICDSRL))

           if +($GET(ICDSRLC))'>0

               SET ICDSRLC=$ORDER(ICDSRL(" "),-1)

           if +ICDSRLC'>0

               QUIT 

 +4        SET DIWL=1

           SET DIWF="C"_+ICDSRLL

           SET ICDSRLI=0

 +5        FOR 

               SET ICDSRLI=$ORDER(ICDSRL(ICDSRLI))

               if +ICDSRLI=0

                   QUIT 

               SET X=$GET(ICDSRL(ICDSRLI))

               DO ^DIWP

 +6        KILL ICDSRL

           SET (ICDSRLC,ICDSRLI)=0

 +7        FOR 

               SET ICDSRLI=$ORDER(^UTILITY($JOB,"W",1,ICDSRLI))

               if +ICDSRLI=0

                   QUIT 

               Begin DoDot:1

 +8                SET ICDSRL(ICDSRLI)=$$TM($GET(^UTILITY($JOB,"W",1,ICDSRLI,0))," ")

                   SET ICDSRLC=ICDSRLC+1

               End DoDot:1

 +9        if $LENGTH(ICDSRLC)

               SET ICDSRL=ICDSRLC

           KILL ^UTILITY($JOB,"W")

 +10       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