- ICDTOKN ;DLS/DEK - Parse Text ;04/21/2014
- ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
- ;
- ; Global Variables
- ; None
- ;
- ; External References
- ; $$UP^XLFSTR ICR 10104
- ;
- Q
- TOK(X) ; Parse Text into Tokens in array PARS()
- K PARS D PAR($G(X),.PARS,1)
- Q
- TOKEN(X,ROOT,SYS,ARY) ; Parse Text into Tokens
- ;
- ; Input
- ;
- ; X Text (Required)
- ;
- ; ROOT Global Root/File # (Required)
- ;
- ; ^ICD9( or 80
- ; ^ICD0( or 80.1
- ;
- ; SYS Coding System (Required)
- ;
- ; 1 or ICD or ICD-9-CM
- ; 2 or ICP or ICD-9 Proc
- ; 30 or 10D or ICD-10-CM
- ; 31 or 10P or ICD-10-PCS
- ;
- ; .ARY Output array passed by reference (Required)
- ;
- ; This is an array of words parsed from the input
- ; string X arranged by frequency of use
- ;
- ; ARY(0)=# of words
- ; ARY(#)=word
- ;
- ; The least frequently used word will be ARY(1)
- ; and the most frequently used word will be
- ; ARY($O(ARY(" "),-1)). words not found in
- ; the file and coding system will not appear in
- ; the parsed array.
- ;
- ; D TOKEN^ICDTOKN($G(X),$G(ROOT),$G(SYS),.ARY) is called
- ; TOKEN^ICDEX to parse words in use order
- ;
- N TMP,ORD,NUM,IEN,USAGE,ABBR,TOKEN K ARY,TMP,ORD S ROOT=$$ROOT^ICDEX($G(ROOT)),SYS=$$SYS^ICDEX($G(SYS)) D PAR($G(X),.TMP)
- K ORD S IEN=0 F S IEN=$O(TMP(IEN)) Q:+IEN'>0 D
- . N NUM,SEG S SEG=$G(TMP(IEN)) Q:$L(SEG)'>1
- . S USAGE=$$CT(SEG,ROOT,SYS),ABBR=+($P(USAGE,"^",2)),USAGE=+USAGE
- . S NUM=$O(ORD(+USAGE," "),-1)+1
- . S ORD(+USAGE,NUM)=SEG
- . S:ABBR>0 ORD(+USAGE,NUM,"A")=1
- K ARY S USAGE="" F S USAGE=$O(ORD(USAGE)) Q:'$L(USAGE) D
- . N NUM S NUM=0 F S NUM=$O(ORD(USAGE,NUM)) Q:+NUM'>0 D
- . . N SEG,INC S SEG=$G(ORD(USAGE,NUM)) Q:'$L(SEG)
- . . S INC=$O(ARY(" "),-1)+1,ARY(INC)=SEG
- . . S:+($G(ORD(+USAGE,NUM,"A")))>0 ARY(INC,"A")=1
- K TMP,ORD S IEN=0 F S IEN=$O(ARY(IEN)) Q:+IEN'>0 S ARY(0)=$G(ARY(0))+1
- Q
- CT(SEG,ROOT,SYS) ; Count Usage
- S SEG=$G(SEG) Q:'$L(SEG) 0 S ROOT=$G(ROOT) Q:'$L(ROOT) 0 S SYS=+($G(SYS))
- N EROOT,IEN,CNT,ABR S (ABR,CNT)=0
- S EROOT=ROOT_"""D""," S:+SYS>0&($D(@(ROOT_"""AD"","_+SYS_")"))) EROOT=ROOT_"""AD"","_+SYS_","
- I $D(@(EROOT_""""_SEG_""")")) D
- . N IEN S IEN=0 F S IEN=$O(@(EROOT_""""_SEG_""","_+IEN_")")) Q:+IEN'>0 D
- . . S CNT=CNT+1 N EFF S EFF="" F S EFF=$O(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""")")) Q:'$L(EFF)!(EFF'?7N) D
- . . . N TIEN S TIEN=0 F S TIEN=$O(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""","_+TIEN_")")) Q:+TIEN'>0 D
- . . . . S:$O(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""","_+TIEN_",0)"))>0 ABR=ABR+1
- I '$D(@(EROOT_""""_SEG_""")")) D
- . N ORD,IEN S ORD=$E(SEG,1,($L(SEG)-1))_$C(($A($E(SEG,$L(SEG)))-1))_"~"
- . F S ORD=$O(@(EROOT_""""_ORD_""")")) Q:$E(ORD,1,$L(SEG))'=SEG D
- . . S IEN=0 F S IEN=$O(@(EROOT_""""_ORD_""","_+IEN_")")) Q:+IEN'>0 D
- . . . S CNT=CNT+1 N EFF S EFF="" F S EFF=$O(@(EROOT_""""_SEG_""","""_EFF_""")")) Q:'$L(EFF)!(EFF'?7N) D
- . . . . N TIEN S TIEN=0 F S TIEN=$O(@(EROOT_""""_SEG_""","""_EFF_""","_+TIEN_")")) Q:+TIEN'>0 D
- . . . . . S:$O(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""","_+TIEN_",0)"))>0 ABR=ABR+1
- S ABR=$S(CNT>0&(CNT=ABR):1,1:0) S CNT=CNT_"^"_ABR
- Q CNT
- PAR(X,ARY,FLG) ; Parse
- ;
- ; Called by ICDIDX for indexing words
- ; D PAR^ICDTOKN($G(X),.ARY,0)
- ;
- ; Called by ICDEXLK3 for lookup of words
- ; D PAR^ICDTOKN($G(X),.PARS,1)
- ;
- N BEG,END,CHR,I,NUM,TXT,PIE S TXT=$$UP^XLFSTR(X),TXT=$$SWAP(TXT)
- K ARY S BEG=1 F END=1:1:$L(TXT)+1 D
- . S CHR=$E(TXT,END) I "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[CHR D
- . . S PIE=$E(TXT,BEG,END-1),BEG=END+1
- . . I $L(PIE)>1,$L(PIE)<31,$$EXC(PIE) D
- . . . Q:$D(ARY("B",PIE)) N I,NUM S NUM=(246-$L(PIE))
- . . . I +($G(FLG))'>0 S I=$O(ARY(" "),-1)+1,ARY(I)=PIE,ARY("B",PIE)="" Q
- . . . S I=$O(ARY(+($G(NUM))," "),-1)+1,ARY(+($G(NUM)),I)=PIE,ARY("B",PIE)=""
- K ARY("B") S NUM=0 F S NUM=$O(ARY(NUM)) Q:+NUM'>0 D
- . I +($G(FLG))'>0 S ARY(0)=$G(ARY(0))+1 Q
- . N I S I=0 F S I=$O(ARY(NUM,I)) Q:+I'>0 S ARY(0)=$G(ARY(0))+1
- Q
- EXC(X) ; Exclusions
- Q:$L($G(X))'>1 0
- Q:"^ABOUT^AFTER^ALMOST^ALSO^ALTHOUGH^AND^ANOTHER^"[("^"_$G(X)_"^") 0
- Q:"^ANY^ARE^AREA^AREAS^AT^BE^BEEN^BEFORE^BEST^BUT^"[("^"_$G(X)_"^") 0
- Q:"^BY^CAN^COULD^DONE^EACH^EVEN^FAR^FOR^FORM^FORMS^"[("^"_$G(X)_"^") 0
- Q:"^FROM^GIVEN^HAD^HAVE^HER^HERE^HERSELF^HIM^"[("^"_$G(X)_"^") 0
- Q:"^HIMSELF^HIS^HOW^IN^INTO^IS^IT^IT'S^ITS^ITS'^"[("^"_$G(X)_"^") 0
- Q:"^ITSELF^KIND^LIKE^LOST^MANY^MAY^MERE^MORE^MOST^"[("^"_$G(X)_"^") 0
- Q:"^MUST^NEW^NOTE^NOW^OF^OFTEN^ON^ONESELF^ONLY^"[("^"_$G(X)_"^") 0
- Q:"^OR^OUR^OURS^OUT^OWN^PUT^SAME^SET^SHOULD^SOME^"[("^"_$G(X)_"^") 0
- Q:"^SUCH^STATED^SURE^THAN^THAT^THE^THEN^THERE^THEREBY^"[("^"_$G(X)_"^") 0
- Q:"^THESE^THEY^THIS^THUS^TO^TOO^UPON^WAS^"[("^"_$G(X)_"^") 0
- Q:"^WHAT^WHEN^WHERE^WHICH^WHO^WHOSE^WITHIN^"[("^"_$G(X)_"^") 0
- Q:"^WOULD^"[("^"_$G(X)_"^") 0
- Q 1
- ;
- SWAP(X) ; Special Case Word Swap
- ;
- ; This sub-routine swaps one word for another
- ; This swap must apply to both Lookup and Indexing
- ; This swap only applies to uppercase text
- ; These words cannot be Replacement Words in file 757.05
- ;
- N TXT S (X,TXT)=$G(X) Q:'$L(TXT) X
- S (X,TXT)=$$UP^XLFSTR(X) N SEG
- F SEG="X-RAY","X RAY" D
- . I TXT[SEG S TXT=$$SW(TXT,SEG,"XRAY")
- F SEG="E.COLI","E COLI","E. COLI" D
- . I TXT[SEG S TXT=$$SW(TXT,SEG,"ECOLI")
- S X=$G(TXT)
- Q X
- SW(X,SEG1,SEG2) ; Swap text SEG1 for SEG2 in X
- ;
- ; Input
- ;
- ; X Text string
- ; SEG1 Word to remove in string (replace)
- ; SEG2 Word to insert in string (with)
- ;
- ; Output
- ;
- ; X Text string without SEG1
- ;
- N TXT,NOT,CHR,LEAD,TRAIL S (X,TXT)=$G(X) Q:'$L(TXT) X S SEG1=$G(SEG1)
- Q:'$L(SEG1) X S SEG2=$G(SEG2) Q:'$L(SEG2) X Q:TXT'[SEG1 X
- S NOT="~!@#$%^&*()_+`{}|[]\:;'<>?,./" I TXT=SEG1 S X=SEG2 Q X
- I $E(TXT,1,$L(SEG1))=SEG1 D
- . N CHR S CHR=$E(TXT,($L(SEG1)+1)) Q:CHR'=" "
- . S TXT=SEG2_$E(TXT,($L(SEG1)+1),$L(TXT))
- F LEAD=" ","-","(","<","{","[","," D
- . N REP,WIT F TRAIL=" ","-",")",">","}","]","," D
- . . N REP,WIT
- . . S REP=LEAD_SEG1_TRAIL,WIT=LEAD_SEG2_TRAIL
- . . Q:TXT'[REP
- . . F Q:TXT'[REP S TXT=$P(TXT,REP,1)_WIT_$P(TXT,REP,2)
- . S REP=LEAD_SEG1,WIT=LEAD_SEG2
- . I TXT[REP,$L($P(TXT,REP,1)),'$L($P(TXT,REP,2)) D
- . . S TXT=$P(TXT,REP,1)_WIT
- S X=$G(TXT)
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDTOKN 6549 printed Mar 13, 2025@20:57:23 Page 2
- ICDTOKN ;DLS/DEK - Parse Text ;04/21/2014
- +1 ;;18.0;DRG Grouper;**57**;Oct 20, 2000;Build 1
- +2 ;
- +3 ; Global Variables
- +4 ; None
- +5 ;
- +6 ; External References
- +7 ; $$UP^XLFSTR ICR 10104
- +8 ;
- +9 QUIT
- TOK(X) ; Parse Text into Tokens in array PARS()
- +1 KILL PARS
- DO PAR($GET(X),.PARS,1)
- +2 QUIT
- TOKEN(X,ROOT,SYS,ARY) ; Parse Text into Tokens
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; X Text (Required)
- +5 ;
- +6 ; ROOT Global Root/File # (Required)
- +7 ;
- +8 ; ^ICD9( or 80
- +9 ; ^ICD0( or 80.1
- +10 ;
- +11 ; SYS Coding System (Required)
- +12 ;
- +13 ; 1 or ICD or ICD-9-CM
- +14 ; 2 or ICP or ICD-9 Proc
- +15 ; 30 or 10D or ICD-10-CM
- +16 ; 31 or 10P or ICD-10-PCS
- +17 ;
- +18 ; .ARY Output array passed by reference (Required)
- +19 ;
- +20 ; This is an array of words parsed from the input
- +21 ; string X arranged by frequency of use
- +22 ;
- +23 ; ARY(0)=# of words
- +24 ; ARY(#)=word
- +25 ;
- +26 ; The least frequently used word will be ARY(1)
- +27 ; and the most frequently used word will be
- +28 ; ARY($O(ARY(" "),-1)). words not found in
- +29 ; the file and coding system will not appear in
- +30 ; the parsed array.
- +31 ;
- +32 ; D TOKEN^ICDTOKN($G(X),$G(ROOT),$G(SYS),.ARY) is called
- +33 ; TOKEN^ICDEX to parse words in use order
- +34 ;
- +35 NEW TMP,ORD,NUM,IEN,USAGE,ABBR,TOKEN
- KILL ARY,TMP,ORD
- SET ROOT=$$ROOT^ICDEX($GET(ROOT))
- SET SYS=$$SYS^ICDEX($GET(SYS))
- DO PAR($GET(X),.TMP)
- +36 KILL ORD
- SET IEN=0
- FOR
- SET IEN=$ORDER(TMP(IEN))
- if +IEN'>0
- QUIT
- Begin DoDot:1
- +37 NEW NUM,SEG
- SET SEG=$GET(TMP(IEN))
- if $LENGTH(SEG)'>1
- QUIT
- +38 SET USAGE=$$CT(SEG,ROOT,SYS)
- SET ABBR=+($PIECE(USAGE,"^",2))
- SET USAGE=+USAGE
- +39 SET NUM=$ORDER(ORD(+USAGE," "),-1)+1
- +40 SET ORD(+USAGE,NUM)=SEG
- +41 if ABBR>0
- SET ORD(+USAGE,NUM,"A")=1
- End DoDot:1
- +42 KILL ARY
- SET USAGE=""
- FOR
- SET USAGE=$ORDER(ORD(USAGE))
- if '$LENGTH(USAGE)
- QUIT
- Begin DoDot:1
- +43 NEW NUM
- SET NUM=0
- FOR
- SET NUM=$ORDER(ORD(USAGE,NUM))
- if +NUM'>0
- QUIT
- Begin DoDot:2
- +44 NEW SEG,INC
- SET SEG=$GET(ORD(USAGE,NUM))
- if '$LENGTH(SEG)
- QUIT
- +45 SET INC=$ORDER(ARY(" "),-1)+1
- SET ARY(INC)=SEG
- +46 if +($GET(ORD(+USAGE,NUM,"A")))>0
- SET ARY(INC,"A")=1
- End DoDot:2
- End DoDot:1
- +47 KILL TMP,ORD
- SET IEN=0
- FOR
- SET IEN=$ORDER(ARY(IEN))
- if +IEN'>0
- QUIT
- SET ARY(0)=$GET(ARY(0))+1
- +48 QUIT
- CT(SEG,ROOT,SYS) ; Count Usage
- +1 SET SEG=$GET(SEG)
- if '$LENGTH(SEG)
- QUIT 0
- SET ROOT=$GET(ROOT)
- if '$LENGTH(ROOT)
- QUIT 0
- SET SYS=+($GET(SYS))
- +2 NEW EROOT,IEN,CNT,ABR
- SET (ABR,CNT)=0
- +3 SET EROOT=ROOT_"""D"","
- if +SYS>0&($DATA(@(ROOT_"""AD"","_+SYS_")")))
- SET EROOT=ROOT_"""AD"","_+SYS_","
- +4 IF $DATA(@(EROOT_""""_SEG_""")"))
- Begin DoDot:1
- +5 NEW IEN
- SET IEN=0
- FOR
- SET IEN=$ORDER(@(EROOT_""""_SEG_""","_+IEN_")"))
- if +IEN'>0
- QUIT
- Begin DoDot:2
- +6 SET CNT=CNT+1
- NEW EFF
- SET EFF=""
- FOR
- SET EFF=$ORDER(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""")"))
- if '$LENGTH(EFF)!(EFF'?7N)
- QUIT
- Begin DoDot:3
- +7 NEW TIEN
- SET TIEN=0
- FOR
- SET TIEN=$ORDER(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""","_+TIEN_")"))
- if +TIEN'>0
- QUIT
- Begin DoDot:4
- +8 if $ORDER(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""","_+TIEN_",0)"))>0
- SET ABR=ABR+1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +9 IF '$DATA(@(EROOT_""""_SEG_""")"))
- Begin DoDot:1
- +10 NEW ORD,IEN
- SET ORD=$EXTRACT(SEG,1,($LENGTH(SEG)-1))_$CHAR(($ASCII($EXTRACT(SEG,$LENGTH(SEG)))-1))_"~"
- +11 FOR
- SET ORD=$ORDER(@(EROOT_""""_ORD_""")"))
- if $EXTRACT(ORD,1,$LENGTH(SEG))'=SEG
- QUIT
- Begin DoDot:2
- +12 SET IEN=0
- FOR
- SET IEN=$ORDER(@(EROOT_""""_ORD_""","_+IEN_")"))
- if +IEN'>0
- QUIT
- Begin DoDot:3
- +13 SET CNT=CNT+1
- NEW EFF
- SET EFF=""
- FOR
- SET EFF=$ORDER(@(EROOT_""""_SEG_""","""_EFF_""")"))
- if '$LENGTH(EFF)!(EFF'?7N)
- QUIT
- Begin DoDot:4
- +14 NEW TIEN
- SET TIEN=0
- FOR
- SET TIEN=$ORDER(@(EROOT_""""_SEG_""","""_EFF_""","_+TIEN_")"))
- if +TIEN'>0
- QUIT
- Begin DoDot:5
- +15 if $ORDER(@(EROOT_""""_SEG_""","_+IEN_","""_EFF_""","_+TIEN_",0)"))>0
- SET ABR=ABR+1
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 SET ABR=$SELECT(CNT>0&(CNT=ABR):1,1:0)
- SET CNT=CNT_"^"_ABR
- +17 QUIT CNT
- PAR(X,ARY,FLG) ; Parse
- +1 ;
- +2 ; Called by ICDIDX for indexing words
- +3 ; D PAR^ICDTOKN($G(X),.ARY,0)
- +4 ;
- +5 ; Called by ICDEXLK3 for lookup of words
- +6 ; D PAR^ICDTOKN($G(X),.PARS,1)
- +7 ;
- +8 NEW BEG,END,CHR,I,NUM,TXT,PIE
- SET TXT=$$UP^XLFSTR(X)
- SET TXT=$$SWAP(TXT)
- +9 KILL ARY
- SET BEG=1
- FOR END=1:1:$LENGTH(TXT)+1
- Begin DoDot:1
- +10 SET CHR=$EXTRACT(TXT,END)
- IF "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[CHR
- Begin DoDot:2
- +11 SET PIE=$EXTRACT(TXT,BEG,END-1)
- SET BEG=END+1
- +12 IF $LENGTH(PIE)>1
- IF $LENGTH(PIE)<31
- IF $$EXC(PIE)
- Begin DoDot:3
- +13 if $DATA(ARY("B",PIE))
- QUIT
- NEW I,NUM
- SET NUM=(246-$LENGTH(PIE))
- +14 IF +($GET(FLG))'>0
- SET I=$ORDER(ARY(" "),-1)+1
- SET ARY(I)=PIE
- SET ARY("B",PIE)=""
- QUIT
- +15 SET I=$ORDER(ARY(+($GET(NUM))," "),-1)+1
- SET ARY(+($GET(NUM)),I)=PIE
- SET ARY("B",PIE)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 KILL ARY("B")
- SET NUM=0
- FOR
- SET NUM=$ORDER(ARY(NUM))
- if +NUM'>0
- QUIT
- Begin DoDot:1
- +17 IF +($GET(FLG))'>0
- SET ARY(0)=$GET(ARY(0))+1
- QUIT
- +18 NEW I
- SET I=0
- FOR
- SET I=$ORDER(ARY(NUM,I))
- if +I'>0
- QUIT
- SET ARY(0)=$GET(ARY(0))+1
- End DoDot:1
- +19 QUIT
- EXC(X) ; Exclusions
- +1 if $LENGTH($GET(X))'>1
- QUIT 0
- +2 if "^ABOUT^AFTER^ALMOST^ALSO^ALTHOUGH^AND^ANOTHER^"[("^"_$GET(X)_"^")
- QUIT 0
- +3 if "^ANY^ARE^AREA^AREAS^AT^BE^BEEN^BEFORE^BEST^BUT^"[("^"_$GET(X)_"^")
- QUIT 0
- +4 if "^BY^CAN^COULD^DONE^EACH^EVEN^FAR^FOR^FORM^FORMS^"[("^"_$GET(X)_"^")
- QUIT 0
- +5 if "^FROM^GIVEN^HAD^HAVE^HER^HERE^HERSELF^HIM^"[("^"_$GET(X)_"^")
- QUIT 0
- +6 if "^HIMSELF^HIS^HOW^IN^INTO^IS^IT^IT'S^ITS^ITS'^"[("^"_$GET(X)_"^")
- QUIT 0
- +7 if "^ITSELF^KIND^LIKE^LOST^MANY^MAY^MERE^MORE^MOST^"[("^"_$GET(X)_"^")
- QUIT 0
- +8 if "^MUST^NEW^NOTE^NOW^OF^OFTEN^ON^ONESELF^ONLY^"[("^"_$GET(X)_"^")
- QUIT 0
- +9 if "^OR^OUR^OURS^OUT^OWN^PUT^SAME^SET^SHOULD^SOME^"[("^"_$GET(X)_"^")
- QUIT 0
- +10 if "^SUCH^STATED^SURE^THAN^THAT^THE^THEN^THERE^THEREBY^"[("^"_$GET(X)_"^")
- QUIT 0
- +11 if "^THESE^THEY^THIS^THUS^TO^TOO^UPON^WAS^"[("^"_$GET(X)_"^")
- QUIT 0
- +12 if "^WHAT^WHEN^WHERE^WHICH^WHO^WHOSE^WITHIN^"[("^"_$GET(X)_"^")
- QUIT 0
- +13 if "^WOULD^"[("^"_$GET(X)_"^")
- QUIT 0
- +14 QUIT 1
- +15 ;
- SWAP(X) ; Special Case Word Swap
- +1 ;
- +2 ; This sub-routine swaps one word for another
- +3 ; This swap must apply to both Lookup and Indexing
- +4 ; This swap only applies to uppercase text
- +5 ; These words cannot be Replacement Words in file 757.05
- +6 ;
- +7 NEW TXT
- SET (X,TXT)=$GET(X)
- if '$LENGTH(TXT)
- QUIT X
- +8 SET (X,TXT)=$$UP^XLFSTR(X)
- NEW SEG
- +9 FOR SEG="X-RAY","X RAY"
- Begin DoDot:1
- +10 IF TXT[SEG
- SET TXT=$$SW(TXT,SEG,"XRAY")
- End DoDot:1
- +11 FOR SEG="E.COLI","E COLI","E. COLI"
- Begin DoDot:1
- +12 IF TXT[SEG
- SET TXT=$$SW(TXT,SEG,"ECOLI")
- End DoDot:1
- +13 SET X=$GET(TXT)
- +14 QUIT X
- SW(X,SEG1,SEG2) ; Swap text SEG1 for SEG2 in X
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; X Text string
- +5 ; SEG1 Word to remove in string (replace)
- +6 ; SEG2 Word to insert in string (with)
- +7 ;
- +8 ; Output
- +9 ;
- +10 ; X Text string without SEG1
- +11 ;
- +12 NEW TXT,NOT,CHR,LEAD,TRAIL
- SET (X,TXT)=$GET(X)
- if '$LENGTH(TXT)
- QUIT X
- SET SEG1=$GET(SEG1)
- +13 if '$LENGTH(SEG1)
- QUIT X
- SET SEG2=$GET(SEG2)
- if '$LENGTH(SEG2)
- QUIT X
- if TXT'[SEG1
- QUIT X
- +14 SET NOT="~!@#$%^&*()_+`{}|[]\:;'<>?,./"
- IF TXT=SEG1
- SET X=SEG2
- QUIT X
- +15 IF $EXTRACT(TXT,1,$LENGTH(SEG1))=SEG1
- Begin DoDot:1
- +16 NEW CHR
- SET CHR=$EXTRACT(TXT,($LENGTH(SEG1)+1))
- if CHR'=" "
- QUIT
- +17 SET TXT=SEG2_$EXTRACT(TXT,($LENGTH(SEG1)+1),$LENGTH(TXT))
- End DoDot:1
- +18 FOR LEAD=" ","-","(","<","{","[",","
- Begin DoDot:1
- +19 NEW REP,WIT
- FOR TRAIL=" ","-",")",">","}","]",","
- Begin DoDot:2
- +20 NEW REP,WIT
- +21 SET REP=LEAD_SEG1_TRAIL
- SET WIT=LEAD_SEG2_TRAIL
- +22 if TXT'[REP
- QUIT
- +23 FOR
- if TXT'[REP
- QUIT
- SET TXT=$PIECE(TXT,REP,1)_WIT_$PIECE(TXT,REP,2)
- End DoDot:2
- +24 SET REP=LEAD_SEG1
- SET WIT=LEAD_SEG2
- +25 IF TXT[REP
- IF $LENGTH($PIECE(TXT,REP,1))
- IF '$LENGTH($PIECE(TXT,REP,2))
- Begin DoDot:2
- +26 SET TXT=$PIECE(TXT,REP,1)_WIT
- End DoDot:2
- End DoDot:1
- +27 SET X=$GET(TXT)
- +28 QUIT X
