- YSLXDG2 ;ALB/RBD - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST;10 May 2013 9:46 AM
- ;;5.01;MENTAL HEALTH;**107**;Dec 30, 1994;Build 23
- ;
- ; Based on ZZLXDG2
- ;
- ; Input
- ;
- ; X Length of list to display (default 5)
- ; .YSSRL Local array passed by reference
- ;
- ; YSSRL() Input Array from ICDSRCH^LEX10CS
- ;
- ; YSSRL(0)=# found ^ Pruning Indicator
- ; YSSRL(1,0)=Code ^ Code IEN ^ date
- ; YSSRL(1,"IDL")=ICD-9/10 Description, Long
- ; YSSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
- ; YSSRL(1,"IDS")=ICD-9/10 Description, Short
- ; YSSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
- ; YSSRL(1,"LEX")=Lexicon Description
- ; YSSRL(1,"LEX",1)=Expression IEN ^ date
- ; YSSRL(1,"SYN",1)=Synonym #1
- ; YSSRL(1,"SYN",m)=Synonym #m
- ; ...
- ;
- ; Output
- ;
- ; $$SEL Two Piece "^" delimited string same as
- ; Fileman's Y output variable
- ;
- ; 1 Lexicon IEN
- ; 2 Lexicon Term
- ;
- ; YSSRL Local array passed by reference
- ;
- ; YSSRL(0)=Code ^ Code IEN ^ date
- ; YSSRL("IDL")=ICD-9/10 Description, Long
- ; YSSRL("IDL",1)=ICD-9/10 IEN ^ date
- ; YSSRL("IDS")=ICD-9/10 Description, Short
- ; YSSRL("IDS",1)=ICD-9/10 IEN ^ date
- ; YSSRL("LEX")=Lexicon Description
- ; YSSRL("LEX",1)=Expression IEN ^ date
- ;
- ; or ^ on error
- ; or -1 for non-selection
- ; or -2 if "^" was entered
- ;
- SEL(YSSRL,X) ; Select from List
- N YSGOUP S YSGOUP=0
- S X=+($G(X))
- S:X'>0 X=5
- S X=$$ASK(.YSSRL,X)
- I YSGOUP=1 Q -2
- Q X
- ;
- ASK(YSSRL,X) ; Ask for Selection
- N DTOUT,DUOUT,DIROUT
- N YSLIT,YSLL,YSLTOT
- S YSLL=+($G(X))
- S:YSLL'>0 YSLL=5
- S YSLIT=0,YSLTOT=$O(YSSRL(" "),-1)
- Q:+YSLTOT'>0 "^"
- K X
- S:+YSLTOT=1 X=$$ONE(YSLL,.YSSRL)
- S:+YSLTOT>1 X=$$MUL(.YSSRL,YSLL)
- S:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(X))'>0) X=-1
- Q X
- ONE(X,YSSRL) ; One Entry Found
- Q:+($G(YSLIT))>0 "^^"
- N DIR,YSLC,YSLEX,YSLFI,YSLIT,YSLSO,YSLNC
- N YSLSP,YSLTX,YSLC,YSNXTLIN,Y
- S YSLFI=$O(YSSRL(0)) Q:+YSLFI'>0 "^" S YSLSP=$J(" ",11)
- S YSLSO=$P(YSSRL(1,0),"^",1),YSLNC=$P(YSSRL(1,0),"^",3)
- S:+YSLNC>0 YSLNC=" ("_YSLNC_")" S YSLEX=$G(YSSRL(1,"MENU"))
- S YSLC=$S($D(YSSRL(1,"CAT")):"-",1:"")
- S YSLTX(1)=YSLSO_YSLC_$J(" ",(9-$L(YSLSO)))_" "_YSLEX_YSLNC
- D PR(.YSLTX,64) S DIR("A",1)=" One match found",DIR("A",2)=" "
- S DIR("A",3)=" "_$G(YSLTX(1)),YSLC=3 I $L($G(YSLTX(2))) D
- . F YSNXTLIN=2:1 Q:$G(YSLTX(YSNXTLIN))="" D
- .. S YSLC=YSLC+1,DIR("A",YSLC)=YSLSP_$G(YSLTX(YSNXTLIN))
- S YSLC=YSLC+1,DIR("A",YSLC)=" ",YSLC=YSLC+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)) YSLIT=1
- I X["^^"!(+($G(YSLIT))>0) K YSSRL Q "^^"
- S X=$S(+Y>0:$$X(1,.YSSRL),1:-1)
- Q X
- MUL(YSSRL,Y) ; Multiple Entries Found
- Q:+($G(YSLIT))>0 "^^"
- N YSSRLE,YSLL,YSLMAX,YSLSS,YSLX,X
- S (YSLMAX,YSLSS,YSLIT)=0,YSLL=+($G(Y)),U="^" S:+($G(YSLL))'>0 YSLL=5
- S YSLX=$O(YSSRL(" "),-1),YSLSS=0
- G:+YSLX=0 MULQ W ! W:+YSLX>1 !," ",YSLX," matches found"
- F YSSRLE=1:1:YSLX Q:((YSLSS>0)&(YSLSS<(YSSRLE+1))) Q:YSLIT D Q:YSLIT
- . W:YSSRLE#YSLL=1 ! D MULW
- . S YSLMAX=YSSRLE W:YSSRLE#YSLL=0 !
- . S:YSSRLE#YSLL=0 YSLSS=$$MULS(YSLMAX,YSSRLE,.YSSRL) S:YSLSS["^" YSLIT=1
- I YSSRLE#YSLL'=0,+YSLSS<=0 D
- . W ! S YSLSS=$$MULS(YSLMAX,YSSRLE,.YSSRL) S:YSLSS["^" YSLIT=1
- G MULQ
- Q X
- MULW ; Write Multiple
- N YSLEX,YSLI1,YSLSO,YSLNC,YSLT2,YSLTX S YSLSO=$P(YSSRL(+YSSRLE,0),"^",1)
- S YSLNC=$P(YSSRL(+YSSRLE,0),"^",3) S:+YSLNC>0 YSLNC=" ("_YSLNC_")"
- S YSLEX=$G(YSSRL(+YSSRLE,"MENU")),YSLTX(1)=YSLSO
- S YSLTX(1)=YSLTX(1)_$S($D(YSSRL(+YSSRLE,"CAT")):"-",1:" ")_$J(" ",(9-$L(YSLSO)))_" "_YSLEX_YSLNC
- D PR(.YSLTX,60) W !,$J(YSSRLE,5),". ",$G(YSLTX(1))
- F YSLI1=2:1:5 S YSLT2=$G(YSLTX(YSLI1)) W:$L(YSLT2) !,$J(" ",19),YSLT2
- Q
- MULS(X,Y,YSSRL) ; Select from Multiple Entries
- N DIR,DIRB,YSLFI,YSLHLP,YSLLST,YSLMAX,YSLS1 ;@#$ not sure YSLS1 is needed here
- Q:+($G(YSLIT))>0 "^^" S YSLMAX=+($G(X)),YSLLST=+($G(Y))
- Q:YSLMAX=0 -1 S YSLFI=$O(YSSRL(0)) Q:+YSLFI'>0 -1
- I +($O(YSSRL(+YSLLST)))>0 D
- . S DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
- . S DIR("A")=DIR("A")_YSLMAX_": "
- I +($O(YSSRL(+YSLLST)))'>0 D
- . S DIR("A")=" Select 1-"_YSLMAX_": "
- S YSLHLP=" Answer must be from 1 to "
- S YSLHLP=YSLHLP_YSLMAX_", or <Return> to continue"
- S DIR("PRE")="S:X[""?"" X=""??"""
- S (DIR("?"),DIR("??"))="^D MULSH^YSLXDG2"
- S DIR(0)="NAO^1:"_YSLMAX_":0" D ^DIR
- S:X="^" YSGOUP=1
- Q:'$D(DTOUT)&('$D(DUOUT))&('$D(DIROUT))&(+($G(Y))'>0) -1
- S:X["^^"!($D(DTOUT)) YSLIT=1,X="^^" I X["^^"!(+($G(YSLIT))>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(YSLHLP)) W !,$G(YSLHLP) Q
- Q
- MULQ ; Quit Multiple
- I +YSLSS'>0,$G(YSLSS)="^" Q "^"
- S X=-1 S:+($G(YSLIT))'>0 X=$$X(+YSLSS,.YSSRL)
- Q X
- X(X,YSSRL) ; Set X and Output Array
- N YSLEX,YSSRFI,YSLIEN,YSLN1,YSLNC,YSLNN,YSLRN,YSLS1,YSLSO
- S YSLS1=+($G(X))
- S YSSRFI=$O(YSSRL(0)) ;@#$ not used?
- S YSLSO=$P($G(YSSRL(YSLS1,0)),"^",1),YSLEX=$G(YSSRL(YSLS1,"MENU"))
- S YSLIEN=$S($D(YSSRL(YSLS1,"CAT")):"99:CAT;"_$P($G(YSSRL(YSLS1,0)),"^"),1:$P($G(YSSRL(YSLS1,"LEX",1)),"^")_";"_$P($G(YSSRL(YSLS1,0)),"^")) Q:'$L(YSLSO) "^"
- Q:'$L(YSLEX) "^" Q:+YSLIEN'>0 "^" S X=YSLIEN_"^"_YSLEX
- S YSLNN="YSSRL("_+YSLS1_")",YSLNC="YSSRL("_+YSLS1_","
- F S YSLNN=$Q(@YSLNN) Q:'$L(YSLNN)!(YSLNN'[YSLNC) D
- . S YSLRN="YSLN1("_$P(YSLNN,"(",2,299) S @YSLRN=@YSLNN
- K YSSRL S YSLNN="YSLN1("_+YSLS1_")",YSLNC="YSLN1("_+YSLS1_","
- F S YSLNN=$Q(@YSLNN) Q:'$L(YSLNN)!(YSLNN'[YSLNC) D
- . S YSLRN="YSSRL("_$P(YSLNN,"(",2,299),@YSLRN=@YSLNN
- Q X
- ;
- ; Miscellaneous
- CL ; Clear
- K YSLIT
- Q
- PR(YSSRL,X) ; Parse Array
- N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,YSLC,YSLI1,YSLL
- K ^UTILITY($J,"W")
- Q:'$D(YSSRL)
- S YSLL=+($G(X))
- S:+YSLL'>0 YSLL=79
- S YSLC=+($G(YSSRL))
- S:+($G(YSLC))'>0 YSLC=$O(YSSRL(" "),-1)
- Q:+YSLC'>0
- S DIWL=1,DIWF="C"_+YSLL
- S YSLI1=0
- F S YSLI1=$O(YSSRL(YSLI1)) Q:+YSLI1=0 S X=$G(YSSRL(YSLI1)) D ^DIWP
- K YSSRL
- S (YSLC,YSLI1)=0
- F S YSLI1=$O(^UTILITY($J,"W",1,YSLI1)) Q:+YSLI1=0 D
- . S YSSRL(YSLI1)=$$TM($G(^UTILITY($J,"W",1,YSLI1,0))," "),YSLC=YSLC+1
- S:$L(YSLC) YSSRL=YSLC
- 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[HYSLXDG2 6652 printed Jan 18, 2025@03:15:49 Page 2
- YSLXDG2 ;ALB/RBD - Select ICD DIAGNOSIS FROM LEXICON UTILITY LIST;10 May 2013 9:46 AM
- +1 ;;5.01;MENTAL HEALTH;**107**;Dec 30, 1994;Build 23
- +2 ;
- +3 ; Based on ZZLXDG2
- +4 ;
- +5 ; Input
- +6 ;
- +7 ; X Length of list to display (default 5)
- +8 ; .YSSRL Local array passed by reference
- +9 ;
- +10 ; YSSRL() Input Array from ICDSRCH^LEX10CS
- +11 ;
- +12 ; YSSRL(0)=# found ^ Pruning Indicator
- +13 ; YSSRL(1,0)=Code ^ Code IEN ^ date
- +14 ; YSSRL(1,"IDL")=ICD-9/10 Description, Long
- +15 ; YSSRL(1,"IDL",1)=ICD-9/10 IEN ^ date
- +16 ; YSSRL(1,"IDS")=ICD-9/10 Description, Short
- +17 ; YSSRL(1,"IDS",1)=ICD-9/10 IEN ^ date
- +18 ; YSSRL(1,"LEX")=Lexicon Description
- +19 ; YSSRL(1,"LEX",1)=Expression IEN ^ date
- +20 ; YSSRL(1,"SYN",1)=Synonym #1
- +21 ; YSSRL(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 ; YSSRL Local array passed by reference
- +33 ;
- +34 ; YSSRL(0)=Code ^ Code IEN ^ date
- +35 ; YSSRL("IDL")=ICD-9/10 Description, Long
- +36 ; YSSRL("IDL",1)=ICD-9/10 IEN ^ date
- +37 ; YSSRL("IDS")=ICD-9/10 Description, Short
- +38 ; YSSRL("IDS",1)=ICD-9/10 IEN ^ date
- +39 ; YSSRL("LEX")=Lexicon Description
- +40 ; YSSRL("LEX",1)=Expression IEN ^ date
- +41 ;
- +42 ; or ^ on error
- +43 ; or -1 for non-selection
- +44 ; or -2 if "^" was entered
- +45 ;
- SEL(YSSRL,X) ; Select from List
- +1 NEW YSGOUP
- SET YSGOUP=0
- +2 SET X=+($GET(X))
- +3 if X'>0
- SET X=5
- +4 SET X=$$ASK(.YSSRL,X)
- +5 IF YSGOUP=1
- QUIT -2
- +6 QUIT X
- +7 ;
- ASK(YSSRL,X) ; Ask for Selection
- +1 NEW DTOUT,DUOUT,DIROUT
- +2 NEW YSLIT,YSLL,YSLTOT
- +3 SET YSLL=+($GET(X))
- +4 if YSLL'>0
- SET YSLL=5
- +5 SET YSLIT=0
- SET YSLTOT=$ORDER(YSSRL(" "),-1)
- +6 if +YSLTOT'>0
- QUIT "^"
- +7 KILL X
- +8 if +YSLTOT=1
- SET X=$$ONE(YSLL,.YSSRL)
- +9 if +YSLTOT>1
- SET X=$$MUL(.YSSRL,YSLL)
- +10 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(X))'>0)
- SET X=-1
- +11 QUIT X
- ONE(X,YSSRL) ; One Entry Found
- +1 if +($GET(YSLIT))>0
- QUIT "^^"
- +2 NEW DIR,YSLC,YSLEX,YSLFI,YSLIT,YSLSO,YSLNC
- +3 NEW YSLSP,YSLTX,YSLC,YSNXTLIN,Y
- +4 SET YSLFI=$ORDER(YSSRL(0))
- if +YSLFI'>0
- QUIT "^"
- SET YSLSP=$JUSTIFY(" ",11)
- +5 SET YSLSO=$PIECE(YSSRL(1,0),"^",1)
- SET YSLNC=$PIECE(YSSRL(1,0),"^",3)
- +6 if +YSLNC>0
- SET YSLNC=" ("_YSLNC_")"
- SET YSLEX=$GET(YSSRL(1,"MENU"))
- +7 SET YSLC=$SELECT($DATA(YSSRL(1,"CAT")):"-",1:"")
- +8 SET YSLTX(1)=YSLSO_YSLC_$JUSTIFY(" ",(9-$LENGTH(YSLSO)))_" "_YSLEX_YSLNC
- +9 DO PR(.YSLTX,64)
- SET DIR("A",1)=" One match found"
- SET DIR("A",2)=" "
- +10 SET DIR("A",3)=" "_$GET(YSLTX(1))
- SET YSLC=3
- IF $LENGTH($GET(YSLTX(2)))
- Begin DoDot:1
- +11 FOR YSNXTLIN=2:1
- if $GET(YSLTX(YSNXTLIN))=""
- QUIT
- Begin DoDot:2
- +12 SET YSLC=YSLC+1
- SET DIR("A",YSLC)=YSLSP_$GET(YSLTX(YSNXTLIN))
- End DoDot:2
- End DoDot:1
- +13 SET YSLC=YSLC+1
- SET DIR("A",YSLC)=" "
- SET YSLC=YSLC+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 YSLIT=1
- +17 IF X["^^"!(+($GET(YSLIT))>0)
- KILL YSSRL
- QUIT "^^"
- +18 SET X=$SELECT(+Y>0:$$X(1,.YSSRL),1:-1)
- +19 QUIT X
- MUL(YSSRL,Y) ; Multiple Entries Found
- +1 if +($GET(YSLIT))>0
- QUIT "^^"
- +2 NEW YSSRLE,YSLL,YSLMAX,YSLSS,YSLX,X
- +3 SET (YSLMAX,YSLSS,YSLIT)=0
- SET YSLL=+($GET(Y))
- SET U="^"
- if +($GET(YSLL))'>0
- SET YSLL=5
- +4 SET YSLX=$ORDER(YSSRL(" "),-1)
- SET YSLSS=0
- +5 if +YSLX=0
- GOTO MULQ
- WRITE !
- if +YSLX>1
- WRITE !," ",YSLX," matches found"
- +6 FOR YSSRLE=1:1:YSLX
- if ((YSLSS>0)&(YSLSS<(YSSRLE+1)))
- QUIT
- if YSLIT
- QUIT
- Begin DoDot:1
- +7 if YSSRLE#YSLL=1
- WRITE !
- DO MULW
- +8 SET YSLMAX=YSSRLE
- if YSSRLE#YSLL=0
- WRITE !
- +9 if YSSRLE#YSLL=0
- SET YSLSS=$$MULS(YSLMAX,YSSRLE,.YSSRL)
- if YSLSS["^"
- SET YSLIT=1
- End DoDot:1
- if YSLIT
- QUIT
- +10 IF YSSRLE#YSLL'=0
- IF +YSLSS<=0
- Begin DoDot:1
- +11 WRITE !
- SET YSLSS=$$MULS(YSLMAX,YSSRLE,.YSSRL)
- if YSLSS["^"
- SET YSLIT=1
- End DoDot:1
- +12 GOTO MULQ
- +13 QUIT X
- MULW ; Write Multiple
- +1 NEW YSLEX,YSLI1,YSLSO,YSLNC,YSLT2,YSLTX
- SET YSLSO=$PIECE(YSSRL(+YSSRLE,0),"^",1)
- +2 SET YSLNC=$PIECE(YSSRL(+YSSRLE,0),"^",3)
- if +YSLNC>0
- SET YSLNC=" ("_YSLNC_")"
- +3 SET YSLEX=$GET(YSSRL(+YSSRLE,"MENU"))
- SET YSLTX(1)=YSLSO
- +4 SET YSLTX(1)=YSLTX(1)_$SELECT($DATA(YSSRL(+YSSRLE,"CAT")):"-",1:" ")_$JUSTIFY(" ",(9-$LENGTH(YSLSO)))_" "_YSLEX_YSLNC
- +5 DO PR(.YSLTX,60)
- WRITE !,$JUSTIFY(YSSRLE,5),". ",$GET(YSLTX(1))
- +6 FOR YSLI1=2:1:5
- SET YSLT2=$GET(YSLTX(YSLI1))
- if $LENGTH(YSLT2)
- WRITE !,$JUSTIFY(" ",19),YSLT2
- +7 QUIT
- MULS(X,Y,YSSRL) ; Select from Multiple Entries
- +1 ;@#$ not sure YSLS1 is needed here
- NEW DIR,DIRB,YSLFI,YSLHLP,YSLLST,YSLMAX,YSLS1
- +2 if +($GET(YSLIT))>0
- QUIT "^^"
- SET YSLMAX=+($GET(X))
- SET YSLLST=+($GET(Y))
- +3 if YSLMAX=0
- QUIT -1
- SET YSLFI=$ORDER(YSSRL(0))
- if +YSLFI'>0
- QUIT -1
- +4 IF +($ORDER(YSSRL(+YSLLST)))>0
- Begin DoDot:1
- +5 SET DIR("A")=" Press <RETURN> for more, ""^"" to exit, or Select 1-"
- +6 SET DIR("A")=DIR("A")_YSLMAX_": "
- End DoDot:1
- +7 IF +($ORDER(YSSRL(+YSLLST)))'>0
- Begin DoDot:1
- +8 SET DIR("A")=" Select 1-"_YSLMAX_": "
- End DoDot:1
- +9 SET YSLHLP=" Answer must be from 1 to "
- +10 SET YSLHLP=YSLHLP_YSLMAX_", or <Return> to continue"
- +11 SET DIR("PRE")="S:X[""?"" X=""??"""
- +12 SET (DIR("?"),DIR("??"))="^D MULSH^YSLXDG2"
- +13 SET DIR(0)="NAO^1:"_YSLMAX_":0"
- DO ^DIR
- +14 if X="^"
- SET YSGOUP=1
- +15 if '$DATA(DTOUT)&('$DATA(DUOUT))&('$DATA(DIROUT))&(+($GET(Y))'>0)
- QUIT -1
- +16 if X["^^"!($DATA(DTOUT))
- SET YSLIT=1
- SET X="^^"
- IF X["^^"!(+($GET(YSLIT))>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(YSLHLP))
- WRITE !,$GET(YSLHLP)
- QUIT
- +2 QUIT
- MULQ ; Quit Multiple
- +1 IF +YSLSS'>0
- IF $GET(YSLSS)="^"
- QUIT "^"
- +2 SET X=-1
- if +($GET(YSLIT))'>0
- SET X=$$X(+YSLSS,.YSSRL)
- +3 QUIT X
- X(X,YSSRL) ; Set X and Output Array
- +1 NEW YSLEX,YSSRFI,YSLIEN,YSLN1,YSLNC,YSLNN,YSLRN,YSLS1,YSLSO
- +2 SET YSLS1=+($GET(X))
- +3 ;@#$ not used?
- SET YSSRFI=$ORDER(YSSRL(0))
- +4 SET YSLSO=$PIECE($GET(YSSRL(YSLS1,0)),"^",1)
- SET YSLEX=$GET(YSSRL(YSLS1,"MENU"))
- +5 SET YSLIEN=$SELECT($DATA(YSSRL(YSLS1,"CAT")):"99:CAT;"_$PIECE($GET(YSSRL(YSLS1,0)),"^"),1:$PIECE($GET(YSSRL(YSLS1,"LEX",1)),"^")_";"_$PIECE($GET(YSSRL(YSLS1,0)),"^"))
- if '$LENGTH(YSLSO)
- QUIT "^"
- +6 if '$LENGTH(YSLEX)
- QUIT "^"
- if +YSLIEN'>0
- QUIT "^"
- SET X=YSLIEN_"^"_YSLEX
- +7 SET YSLNN="YSSRL("_+YSLS1_")"
- SET YSLNC="YSSRL("_+YSLS1_","
- +8 FOR
- SET YSLNN=$QUERY(@YSLNN)
- if '$LENGTH(YSLNN)!(YSLNN'[YSLNC)
- QUIT
- Begin DoDot:1
- +9 SET YSLRN="YSLN1("_$PIECE(YSLNN,"(",2,299)
- SET @YSLRN=@YSLNN
- End DoDot:1
- +10 KILL YSSRL
- SET YSLNN="YSLN1("_+YSLS1_")"
- SET YSLNC="YSLN1("_+YSLS1_","
- +11 FOR
- SET YSLNN=$QUERY(@YSLNN)
- if '$LENGTH(YSLNN)!(YSLNN'[YSLNC)
- QUIT
- Begin DoDot:1
- +12 SET YSLRN="YSSRL("_$PIECE(YSLNN,"(",2,299)
- SET @YSLRN=@YSLNN
- End DoDot:1
- +13 QUIT X
- +14 ;
- +15 ; Miscellaneous
- CL ; Clear
- +1 KILL YSLIT
- +2 QUIT
- PR(YSSRL,X) ; Parse Array
- +1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,I,Z,%,%D,YSLC,YSLI1,YSLL
- +2 KILL ^UTILITY($JOB,"W")
- +3 if '$DATA(YSSRL)
- QUIT
- +4 SET YSLL=+($GET(X))
- +5 if +YSLL'>0
- SET YSLL=79
- +6 SET YSLC=+($GET(YSSRL))
- +7 if +($GET(YSLC))'>0
- SET YSLC=$ORDER(YSSRL(" "),-1)
- +8 if +YSLC'>0
- QUIT
- +9 SET DIWL=1
- SET DIWF="C"_+YSLL
- +10 SET YSLI1=0
- +11 FOR
- SET YSLI1=$ORDER(YSSRL(YSLI1))
- if +YSLI1=0
- QUIT
- SET X=$GET(YSSRL(YSLI1))
- DO ^DIWP
- +12 KILL YSSRL
- +13 SET (YSLC,YSLI1)=0
- +14 FOR
- SET YSLI1=$ORDER(^UTILITY($JOB,"W",1,YSLI1))
- if +YSLI1=0
- QUIT
- Begin DoDot:1
- +15 SET YSSRL(YSLI1)=$$TM($GET(^UTILITY($JOB,"W",1,YSLI1,0))," ")
- SET YSLC=YSLC+1
- End DoDot:1
- +16 if $LENGTH(YSLC)
- SET YSSRL=YSLC
- +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