LEXNDX9 ;ISL/KER - Set/kill indexes 757.07/757.33 ;05/23/2017
;;2.0;LEXICON UTILITY;**73,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.07 SACC 1.3
; ^LEX(757.33 SACC 1.3
;
; External References
; $$UP^XLFSTR ICR 10103
;
; File 757.33, field 1
SAHC ; Set new value when Code is Edited
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP S LEXIEN=+$G(DA) Q:+LEXIEN'>0
I $D(^LEX(757.33,+LEXIEN,2,"B")) S LEXHIS=0 D Q
. F S LEXHIS=$O(^LEX(757.33,+LEXIEN,2,LEXHIS)) Q:+LEXHIS=0 D
. . N DA,X S DA=+LEXHIS,DA(1)=+LEXIEN D HDC Q:'$L($G(LEXEFF)) Q:'$L($G(LEXSTA)) D SHIS
Q
KAHC ; Kill old value when Code is Edited
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP S LEXIEN=+$G(DA) Q:+LEXIEN'>0
I $D(^LEX(757.33,+LEXIEN,2,"B")) S LEXHIS=0 D Q
. F S LEXHIS=$O(^LEX(757.33,+LEXIEN,2,LEXHIS)) Q:+LEXHIS=0 D
. . N DA,X S DA=+LEXHIS,DA(1)=+LEXIEN D HDC Q:'$L($G(LEXEFF)) Q:'$L($G(LEXSTA)) D KHIS
Q
; File 757.333, field .01
SAHD ; Set new value when Effective Date is Edited
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA
D HDC Q:'$L($G(LEXSTA)) Q:+LEXEFF=0 D SHIS
Q
KAHD ; Kill old value when Effective Date is Edited
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA
D HDC Q:'$L($G(LEXSTA)) S LEXEFF=+$G(X) Q:+LEXEFF=0 D KHIS
Q
; File 757.333 field 1
SAHS ; Set new value when Status is Edited
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA,LEXSYS
D HDC Q:+LEXEFF=0 S LEXSTA=$G(X) Q:'$L(LEXSTA) D SHIS
Q
KAHS ; Kill old value when Status is Edited
N LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA
D HDC Q:+LEXEFF=0 S LEXSTA=$G(X) Q:'$L(LEXSTA) D KHIS
Q
; File 757.33 Set and Kills
SHIS ; Set "G" Index
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF)) Q:+$G(DA(1))'>0 Q:+$G(DA)'>0 Q:'$D(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0))
K:$L($G(LEXDDT)) ^LEX(757.33,"G",LEXMAP,LEXDDT,LEXSTA,DA(1)) S ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1))=""
Q
SDHIS ; Set "G" Index Default
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF)) Q:+$G(LEXIEN)'>0 Q:'$D(^LEX(757.33,+$G(LEXIEN),0))
S ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN)=""
Q
KHIS ; Kill "G" Index
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF)) Q:+$G(DA(1))'>0 Q:+$G(DA)'>0 Q:'$D(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0))
K ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1),DA)
Q
KDHIS ; Kill "G" Index Default
Q:'$L($G(LEXSTA)) Q:'$L($G(LEXEFF)) Q:+$G(LEXIEN)'>0 Q:'$D(^LEX(757.33,+$G(LEXIEN),0))
K ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN,0)
Q
; File 757.07
SD(X,IENS) ; Set "D" KWIC Index
N ARY,I Q:$G(IENS)'?1N.N Q:$G(IENS(1))'?1N.N Q:'$L($G(X)) D PR($G(X),.ARY) S I=0 F S I=$O(ARY(I)) Q:+I'>0 D
. N TKN S TKN=$$UP^XLFSTR($$TM($G(ARY(I)))) Q:'$L(TKN) S ^LEX(757.07,"D",TKN,+($G(IENS(1))),+($G(IENS)))=""
K ARY
Q
KD(X,IENS) ; Kill "D" KWIC Index
N ARY,I Q:$G(IENS)'?1N.N Q:$G(IENS(1))'?1N.N Q:'$L($G(X)) D PR($G(X),.ARY) S I=0 F S I=$O(ARY(I)) Q:+I'>0 D
. N TKN S TKN=$$UP^XLFSTR($$TM($G(ARY(I)))) Q:'$L(TKN) S ^LEX(757.07,"D",TKN,+($G(IENS(1))),+($G(IENS)))=""
K ARY
Q
SAED(X,Y,IENS) ; Set "AED" Phrase Index
N EXM,STR,PIE,I Q:$G(IENS)'?1N.N Q:$G(IENS(1))'?1N.N Q:'$L($G(X)) Q:'$L($G(Y))
S EXM=$G(X),STR=$G(Y) F I=1:1 S PIE=$$TM($P(STR,"/",I)) Q:'$L(PIE) D
. S ^LEX(757.07,"AED",$$UP^XLFSTR(EXM),PIE,+($G(IENS(1))),+($G(IENS)))=""
Q
KAED(X,Y,IENS) ; Kill "AED" Phrase Index
N EXM,STR,PIE,I Q:$G(IENS)'?1N.N Q:$G(IENS(1))'?1N.N Q:'$L($G(X)) Q:'$L($G(Y))
S EXM=$G(X),STR=$G(Y) F I=1:1 S PIE=$$TM($P(STR,"/",I)) Q:'$L(PIE) D
. K ^LEX(757.07,"AED",$$UP^XLFSTR(EXM),PIE,+($G(IENS(1))),+($G(IENS)))
Q
;
; Miscellaneous
HDC ; Set Common Variables (Status and Effective Date)
S (LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXSTA,LEXMAP)="" Q:+$G(DA(1))'>0 Q:+$G(DA)'>0 Q:'$D(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0))
S LEXMAP=$P(^LEX(757.33,DA(1),0),U),LEXNOD=$G(^LEX(757.33,+$G(DA(1)),2,+$G(DA),0)),LEXSTA=$P(LEXNOD,U,2),LEXEFF=$P(LEXNOD,U)
S LEXSTA=$S(LEXSTA="A":1,LEXSTA="I":0,1:LEXSTA),LEXDDT=$$DDTBR(LEXDSYS,LEXSTA)
Q
DF(X,CODE) ; Default Status
N LEXI,LEXNF,LEXL,LEXEFF,LEXC S LEXI=+$G(X) Q:+LEXI'>0 "" S LEXEFF=$O(^LEX(757.33,+LEXI,2,"B"," "),-1)
S LEXL=$O(^LEX(757.33,+LEXI,2,"B",+LEXEFF,0)),LEXL=$P($G(^LEX(757.33,+LEXI,2,+LEXL,0)),U,2) S X=LEXL
Q X
DDTBR(SYS,STA) ; Default Date Business Rules
; Input:
; SYS - System
; STA - Status
; Output:
; If Status = 1 (Give)
; If SYS = ICD/ICP use October 1, 1978 2781001
; If SYS = CPT/CPC use January 1, 1989 2890101
; If SYS is not listed above, use 2960923
; If Status = 0 (InGive)
; If SYS = ICD/ICP use October 2, 1978 2791001
; If SYS = CPT/CPC use January 2, 1989 2900101
; If SYS is not listed above, use 2960924
N LEXSTA,LEXSYS,LEXDT
S LEXSTA=+$G(STA),LEXSYS=$G(SYS),LEXDT=0
S:$L(LEXSYS)=3&("^ICD^ICP^CPT^CPC^"'[LEXSYS) LEXSTA=1
I $L(LEXSYS)'=3 D Q LEXDT
. S:+LEXSTA>0 LEXDT=2960923 S:+LEXSTA'>0 LEXDT=2970923
I LEXSYS="ICD"!(LEXSYS="ICP") D Q LEXDT
. S:LEXSTA>0 LEXDT=2781001 S:LEXSTA'>0 LEXDT=2791001
I LEXSYS="CPT"!(LEXSYS="CPC") D Q LEXDT
. S:LEXSTA>0 LEXDT=2890101 S:LEXSTA'>0 LEXDT=2900101
I "^ICD^ICP^CPT^CPC^"'[LEXSYS D Q LEXDT
. S:LEXSTA>0 LEXDT=2960923 S:LEXSTA'>0 LEXDT=2970923
S:+LEXSTA>0 LEXDT=2960923 S:+LEXSTA'>0 LEXDT=2970923
Q LEXDT
PR(X,ARY) ; Parse Expression into Tokens
N CTL,EXP,CUR,PRE,TC,CT,OUT,P1,ST,P2,PC S EXP=$G(X) K ARY
S CTL="^ ^!^@^#^$^%^^^&^*^(^)^_^+^-^=^{^}^|^[^]^\^:^""^;^'^<^>^?^,^.^/^"
S (CUR,PRE)="",TC=1,CT=0,(OUT,P1,ST,P2)="" F PC=1:1:$L(EXP) D
. N CHR S (CUR,CHR)=$E(EXP,PC)
. I CTL'[("^"_CHR_"^") D Q
. . S ARY(+TC)=$G(ARY(+TC))_CHR S PRE=CUR
. I CTL[("^"_CHR_"^") D Q
. . N CC,NXT S CC=$O(ARY(+TC,"B"," "),-1)+1
. . S ARY(+TC,"B",CC)=CHR
. . S NXT=$E(EXP,(PC+1))
. . I $L(NXT),CTL'[("^"_NXT_"^") S TC=TC+1
. . S PRE=CUR
S TC=0 F S TC=$O(ARY(TC)) Q:+TC'>0 D
. N TKN S TKN=$G(ARY(TC)) S:$L(TKN) ARY(TC,"O")=TKN
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[HLEXNDX9 6429 printed Apr 09, 2024@21:13:28 Page 2
LEXNDX9 ;ISL/KER - Set/kill indexes 757.07/757.33 ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**73,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.07 SACC 1.3
+5 ; ^LEX(757.33 SACC 1.3
+6 ;
+7 ; External References
+8 ; $$UP^XLFSTR ICR 10103
+9 ;
+10 ; File 757.33, field 1
SAHC ; Set new value when Code is Edited
+1 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP
SET LEXIEN=+$GET(DA)
if +LEXIEN'>0
QUIT
+2 IF $DATA(^LEX(757.33,+LEXIEN,2,"B"))
SET LEXHIS=0
Begin DoDot:1
+3 FOR
SET LEXHIS=$ORDER(^LEX(757.33,+LEXIEN,2,LEXHIS))
if +LEXHIS=0
QUIT
Begin DoDot:2
+4 NEW DA,X
SET DA=+LEXHIS
SET DA(1)=+LEXIEN
DO HDC
if '$LENGTH($GET(LEXEFF))
QUIT
if '$LENGTH($GET(LEXSTA))
QUIT
DO SHIS
End DoDot:2
End DoDot:1
QUIT
+5 QUIT
KAHC ; Kill old value when Code is Edited
+1 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXNOD,LEXSTA,LEXMAP
SET LEXIEN=+$GET(DA)
if +LEXIEN'>0
QUIT
+2 IF $DATA(^LEX(757.33,+LEXIEN,2,"B"))
SET LEXHIS=0
Begin DoDot:1
+3 FOR
SET LEXHIS=$ORDER(^LEX(757.33,+LEXIEN,2,LEXHIS))
if +LEXHIS=0
QUIT
Begin DoDot:2
+4 NEW DA,X
SET DA=+LEXHIS
SET DA(1)=+LEXIEN
DO HDC
if '$LENGTH($GET(LEXEFF))
QUIT
if '$LENGTH($GET(LEXSTA))
QUIT
DO KHIS
End DoDot:2
End DoDot:1
QUIT
+5 QUIT
+6 ; File 757.333, field .01
SAHD ; Set new value when Effective Date is Edited
+1 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA
+2 DO HDC
if '$LENGTH($GET(LEXSTA))
QUIT
if +LEXEFF=0
QUIT
DO SHIS
+3 QUIT
KAHD ; Kill old value when Effective Date is Edited
+1 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA
+2 DO HDC
if '$LENGTH($GET(LEXSTA))
QUIT
SET LEXEFF=+$GET(X)
if +LEXEFF=0
QUIT
DO KHIS
+3 QUIT
+4 ; File 757.333 field 1
SAHS ; Set new value when Status is Edited
+1 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA,LEXSYS
+2 DO HDC
if +LEXEFF=0
QUIT
SET LEXSTA=$GET(X)
if '$LENGTH(LEXSTA)
QUIT
DO SHIS
+3 QUIT
KAHS ; Kill old value when Status is Edited
+1 NEW LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXHIS,LEXIEN,LEXMAP,LEXNOD,LEXSTA
+2 DO HDC
if +LEXEFF=0
QUIT
SET LEXSTA=$GET(X)
if '$LENGTH(LEXSTA)
QUIT
DO KHIS
+3 QUIT
+4 ; File 757.33 Set and Kills
SHIS ; Set "G" Index
+1 if '$LENGTH($GET(LEXSTA))
QUIT
if '$LENGTH($GET(LEXEFF))
QUIT
if +$GET(DA(1))'>0
QUIT
if +$GET(DA)'>0
QUIT
if '$DATA(^LEX(757.33,+$GET(DA(1)),2,+$GET(DA),0))
QUIT
+2 if $LENGTH($GET(LEXDDT))
KILL ^LEX(757.33,"G",LEXMAP,LEXDDT,LEXSTA,DA(1))
SET ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1))=""
+3 QUIT
SDHIS ; Set "G" Index Default
+1 if '$LENGTH($GET(LEXSTA))
QUIT
if '$LENGTH($GET(LEXEFF))
QUIT
if +$GET(LEXIEN)'>0
QUIT
if '$DATA(^LEX(757.33,+$GET(LEXIEN),0))
QUIT
+2 SET ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN)=""
+3 QUIT
KHIS ; Kill "G" Index
+1 if '$LENGTH($GET(LEXSTA))
QUIT
if '$LENGTH($GET(LEXEFF))
QUIT
if +$GET(DA(1))'>0
QUIT
if +$GET(DA)'>0
QUIT
if '$DATA(^LEX(757.33,+$GET(DA(1)),2,+$GET(DA),0))
QUIT
+2 KILL ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,DA(1),DA)
+3 QUIT
KDHIS ; Kill "G" Index Default
+1 if '$LENGTH($GET(LEXSTA))
QUIT
if '$LENGTH($GET(LEXEFF))
QUIT
if +$GET(LEXIEN)'>0
QUIT
if '$DATA(^LEX(757.33,+$GET(LEXIEN),0))
QUIT
+2 KILL ^LEX(757.33,"G",LEXMAP,LEXEFF,LEXSTA,+LEXIEN,0)
+3 QUIT
+4 ; File 757.07
SD(X,IENS) ; Set "D" KWIC Index
+1 NEW ARY,I
if $GET(IENS)'?1N.N
QUIT
if $GET(IENS(1))'?1N.N
QUIT
if '$LENGTH($GET(X))
QUIT
DO PR($GET(X),.ARY)
SET I=0
FOR
SET I=$ORDER(ARY(I))
if +I'>0
QUIT
Begin DoDot:1
+2 NEW TKN
SET TKN=$$UP^XLFSTR($$TM($GET(ARY(I))))
if '$LENGTH(TKN)
QUIT
SET ^LEX(757.07,"D",TKN,+($GET(IENS(1))),+($GET(IENS)))=""
End DoDot:1
+3 KILL ARY
+4 QUIT
KD(X,IENS) ; Kill "D" KWIC Index
+1 NEW ARY,I
if $GET(IENS)'?1N.N
QUIT
if $GET(IENS(1))'?1N.N
QUIT
if '$LENGTH($GET(X))
QUIT
DO PR($GET(X),.ARY)
SET I=0
FOR
SET I=$ORDER(ARY(I))
if +I'>0
QUIT
Begin DoDot:1
+2 NEW TKN
SET TKN=$$UP^XLFSTR($$TM($GET(ARY(I))))
if '$LENGTH(TKN)
QUIT
SET ^LEX(757.07,"D",TKN,+($GET(IENS(1))),+($GET(IENS)))=""
End DoDot:1
+3 KILL ARY
+4 QUIT
SAED(X,Y,IENS) ; Set "AED" Phrase Index
+1 NEW EXM,STR,PIE,I
if $GET(IENS)'?1N.N
QUIT
if $GET(IENS(1))'?1N.N
QUIT
if '$LENGTH($GET(X))
QUIT
if '$LENGTH($GET(Y))
QUIT
+2 SET EXM=$GET(X)
SET STR=$GET(Y)
FOR I=1:1
SET PIE=$$TM($PIECE(STR,"/",I))
if '$LENGTH(PIE)
QUIT
Begin DoDot:1
+3 SET ^LEX(757.07,"AED",$$UP^XLFSTR(EXM),PIE,+($GET(IENS(1))),+($GET(IENS)))=""
End DoDot:1
+4 QUIT
KAED(X,Y,IENS) ; Kill "AED" Phrase Index
+1 NEW EXM,STR,PIE,I
if $GET(IENS)'?1N.N
QUIT
if $GET(IENS(1))'?1N.N
QUIT
if '$LENGTH($GET(X))
QUIT
if '$LENGTH($GET(Y))
QUIT
+2 SET EXM=$GET(X)
SET STR=$GET(Y)
FOR I=1:1
SET PIE=$$TM($PIECE(STR,"/",I))
if '$LENGTH(PIE)
QUIT
Begin DoDot:1
+3 KILL ^LEX(757.07,"AED",$$UP^XLFSTR(EXM),PIE,+($GET(IENS(1))),+($GET(IENS)))
End DoDot:1
+4 QUIT
+5 ;
+6 ; Miscellaneous
HDC ; Set Common Variables (Status and Effective Date)
+1 SET (LEXDDT,LEXDSYS,LEXDSTA,LEXEFF,LEXSTA,LEXMAP)=""
if +$GET(DA(1))'>0
QUIT
if +$GET(DA)'>0
QUIT
if '$DATA(^LEX(757.33,+$GET(DA(1)),2,+$GET(DA),0))
QUIT
+2 SET LEXMAP=$PIECE(^LEX(757.33,DA(1),0),U)
SET LEXNOD=$GET(^LEX(757.33,+$GET(DA(1)),2,+$GET(DA),0))
SET LEXSTA=$PIECE(LEXNOD,U,2)
SET LEXEFF=$PIECE(LEXNOD,U)
+3 SET LEXSTA=$SELECT(LEXSTA="A":1,LEXSTA="I":0,1:LEXSTA)
SET LEXDDT=$$DDTBR(LEXDSYS,LEXSTA)
+4 QUIT
DF(X,CODE) ; Default Status
+1 NEW LEXI,LEXNF,LEXL,LEXEFF,LEXC
SET LEXI=+$GET(X)
if +LEXI'>0
QUIT ""
SET LEXEFF=$ORDER(^LEX(757.33,+LEXI,2,"B"," "),-1)
+2 SET LEXL=$ORDER(^LEX(757.33,+LEXI,2,"B",+LEXEFF,0))
SET LEXL=$PIECE($GET(^LEX(757.33,+LEXI,2,+LEXL,0)),U,2)
SET X=LEXL
+3 QUIT X
DDTBR(SYS,STA) ; Default Date Business Rules
+1 ; Input:
+2 ; SYS - System
+3 ; STA - Status
+4 ; Output:
+5 ; If Status = 1 (Give)
+6 ; If SYS = ICD/ICP use October 1, 1978 2781001
+7 ; If SYS = CPT/CPC use January 1, 1989 2890101
+8 ; If SYS is not listed above, use 2960923
+9 ; If Status = 0 (InGive)
+10 ; If SYS = ICD/ICP use October 2, 1978 2791001
+11 ; If SYS = CPT/CPC use January 2, 1989 2900101
+12 ; If SYS is not listed above, use 2960924
+13 NEW LEXSTA,LEXSYS,LEXDT
+14 SET LEXSTA=+$GET(STA)
SET LEXSYS=$GET(SYS)
SET LEXDT=0
+15 if $LENGTH(LEXSYS)=3&("^ICD^ICP^CPT^CPC^"'[LEXSYS)
SET LEXSTA=1
+16 IF $LENGTH(LEXSYS)'=3
Begin DoDot:1
+17 if +LEXSTA>0
SET LEXDT=2960923
if +LEXSTA'>0
SET LEXDT=2970923
End DoDot:1
QUIT LEXDT
+18 IF LEXSYS="ICD"!(LEXSYS="ICP")
Begin DoDot:1
+19 if LEXSTA>0
SET LEXDT=2781001
if LEXSTA'>0
SET LEXDT=2791001
End DoDot:1
QUIT LEXDT
+20 IF LEXSYS="CPT"!(LEXSYS="CPC")
Begin DoDot:1
+21 if LEXSTA>0
SET LEXDT=2890101
if LEXSTA'>0
SET LEXDT=2900101
End DoDot:1
QUIT LEXDT
+22 IF "^ICD^ICP^CPT^CPC^"'[LEXSYS
Begin DoDot:1
+23 if LEXSTA>0
SET LEXDT=2960923
if LEXSTA'>0
SET LEXDT=2970923
End DoDot:1
QUIT LEXDT
+24 if +LEXSTA>0
SET LEXDT=2960923
if +LEXSTA'>0
SET LEXDT=2970923
+25 QUIT LEXDT
PR(X,ARY) ; Parse Expression into Tokens
+1 NEW CTL,EXP,CUR,PRE,TC,CT,OUT,P1,ST,P2,PC
SET EXP=$GET(X)
KILL ARY
+2 SET CTL="^ ^!^@^#^$^%^^^&^*^(^)^_^+^-^=^{^}^|^[^]^\^:^""^;^'^<^>^?^,^.^/^"
+3 SET (CUR,PRE)=""
SET TC=1
SET CT=0
SET (OUT,P1,ST,P2)=""
FOR PC=1:1:$LENGTH(EXP)
Begin DoDot:1
+4 NEW CHR
SET (CUR,CHR)=$EXTRACT(EXP,PC)
+5 IF CTL'[("^"_CHR_"^")
Begin DoDot:2
+6 SET ARY(+TC)=$GET(ARY(+TC))_CHR
SET PRE=CUR
End DoDot:2
QUIT
+7 IF CTL[("^"_CHR_"^")
Begin DoDot:2
+8 NEW CC,NXT
SET CC=$ORDER(ARY(+TC,"B"," "),-1)+1
+9 SET ARY(+TC,"B",CC)=CHR
+10 SET NXT=$EXTRACT(EXP,(PC+1))
+11 IF $LENGTH(NXT)
IF CTL'[("^"_NXT_"^")
SET TC=TC+1
+12 SET PRE=CUR
End DoDot:2
QUIT
End DoDot:1
+13 SET TC=0
FOR
SET TC=$ORDER(ARY(TC))
if +TC'>0
QUIT
Begin DoDot:1
+14 NEW TKN
SET TKN=$GET(ARY(TC))
if $LENGTH(TKN)
SET ARY(TC,"O")=TKN
End DoDot:1
+15 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=" "
FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
