- TIUCOPSU ;SLC/TDP - Pasted Text Search Utilities ;03/12/19 13:26
- ;;1.0;TEXT INTEGRATION UTILITIES;**290**;JUN 20,1997;Build 548
- ;
- ; DBIA 10104 $$UP^XLFSTR
- ; DBIA 10018 ^DIE
- ;
- EN ;
- Q
- ;
- SUB(SARY,PS) ;Determine next subscript in array
- N X
- ;I SARY'="F",SARY'="S",SARY'="P",SARY'="T" Q "ERR"
- I SARY'="T" Q "ERR"
- S X=""
- ;I SARY="F" S X=$O(F(PS,X),-1)+1 Q X
- ;I SARY="S" S X=$O(S(X),-1)+1 Q X
- ;I SARY="P" S X=$O(P(X),-1)+1 Q X
- I SARY="T" S X=$O(TMPARY(PS,X),-1)+1 Q $S(+X>0:X,1:1)
- Q X
- TRIM(T,PUNC) ;Trim leading and trailing spaces and leading punctuation from input
- N BSPC,ESPC,TSPC
- S T=$G(T)
- I T="" Q T
- S PUNC=+PUNC
- I PUNC'=1 S PUNC=0
- N X,DN,EX
- S (BSPC,ESPC,TSPC,DN)=0
- F X=$L(T):-1:1 D Q:DN=1
- . S EX=$E(T,X)
- . I EX=" " D Q:DN=1
- .. S ESPC=ESPC+1
- .. I X=1 S T="",DN=1 Q
- .. I X>1 S T=$E(T,1,(X-1))
- . I EX'=" " S DN=1
- S DN=0
- I PUNC=1 D
- . F X=1:1:$L(T) D Q:DN=1
- .. S EX=$E(T,1)
- .. I (EX=" ")!("!.?"[EX) D Q:DN=1
- ... S BSPC=BSPC+1
- ... I 1=$L(T) S T="",DN=1 Q
- ... I 1<$L(T) S T=$E(T,2,$L(T))
- .. I EX'=" ","!.?"'[EX S DN=1
- I PUNC=0 D
- . F X=1:1:$L(T) D Q:DN=1
- .. S EX=$E(T,1)
- .. I (EX=" ") D Q:DN=1
- ... S BSPC=BSPC+1
- ... I 1=$L(T) S T="",DN=1 Q
- ... I 1<$L(T) S T=$E(T,2,$L(T))
- .. I EX'=" " S DN=1
- S TSPC=BSPC+ESPC
- Q T
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUCOPSU 1318 printed Mar 13, 2025@21:44:19 Page 2
- TIUCOPSU ;SLC/TDP - Pasted Text Search Utilities ;03/12/19 13:26
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**290**;JUN 20,1997;Build 548
- +2 ;
- +3 ; DBIA 10104 $$UP^XLFSTR
- +4 ; DBIA 10018 ^DIE
- +5 ;
- EN ;
- +1 QUIT
- +2 ;
- SUB(SARY,PS) ;Determine next subscript in array
- +1 NEW X
- +2 ;I SARY'="F",SARY'="S",SARY'="P",SARY'="T" Q "ERR"
- +3 IF SARY'="T"
- QUIT "ERR"
- +4 SET X=""
- +5 ;I SARY="F" S X=$O(F(PS,X),-1)+1 Q X
- +6 ;I SARY="S" S X=$O(S(X),-1)+1 Q X
- +7 ;I SARY="P" S X=$O(P(X),-1)+1 Q X
- +8 IF SARY="T"
- SET X=$ORDER(TMPARY(PS,X),-1)+1
- QUIT $SELECT(+X>0:X,1:1)
- +9 QUIT X
- TRIM(T,PUNC) ;Trim leading and trailing spaces and leading punctuation from input
- +1 NEW BSPC,ESPC,TSPC
- +2 SET T=$GET(T)
- +3 IF T=""
- QUIT T
- +4 SET PUNC=+PUNC
- +5 IF PUNC'=1
- SET PUNC=0
- +6 NEW X,DN,EX
- +7 SET (BSPC,ESPC,TSPC,DN)=0
- +8 FOR X=$LENGTH(T):-1:1
- Begin DoDot:1
- +9 SET EX=$EXTRACT(T,X)
- +10 IF EX=" "
- Begin DoDot:2
- +11 SET ESPC=ESPC+1
- +12 IF X=1
- SET T=""
- SET DN=1
- QUIT
- +13 IF X>1
- SET T=$EXTRACT(T,1,(X-1))
- End DoDot:2
- if DN=1
- QUIT
- +14 IF EX'=" "
- SET DN=1
- End DoDot:1
- if DN=1
- QUIT
- +15 SET DN=0
- +16 IF PUNC=1
- Begin DoDot:1
- +17 FOR X=1:1:$LENGTH(T)
- Begin DoDot:2
- +18 SET EX=$EXTRACT(T,1)
- +19 IF (EX=" ")!("!.?"[EX)
- Begin DoDot:3
- +20 SET BSPC=BSPC+1
- +21 IF 1=$LENGTH(T)
- SET T=""
- SET DN=1
- QUIT
- +22 IF 1<$LENGTH(T)
- SET T=$EXTRACT(T,2,$LENGTH(T))
- End DoDot:3
- if DN=1
- QUIT
- +23 IF EX'=" "
- IF "!.?"'[EX
- SET DN=1
- End DoDot:2
- if DN=1
- QUIT
- End DoDot:1
- +24 IF PUNC=0
- Begin DoDot:1
- +25 FOR X=1:1:$LENGTH(T)
- Begin DoDot:2
- +26 SET EX=$EXTRACT(T,1)
- +27 IF (EX=" ")
- Begin DoDot:3
- +28 SET BSPC=BSPC+1
- +29 IF 1=$LENGTH(T)
- SET T=""
- SET DN=1
- QUIT
- +30 IF 1<$LENGTH(T)
- SET T=$EXTRACT(T,2,$LENGTH(T))
- End DoDot:3
- if DN=1
- QUIT
- +31 IF EX'=" "
- SET DN=1
- End DoDot:2
- if DN=1
- QUIT
- End DoDot:1
- +32 SET TSPC=BSPC+ESPC
- +33 QUIT T
