XTLKTOKN ;IHS/OHPRD/ACC,SFISC/JC - CONVERT INPUT LINE TO TOKENS ;07/22/93 15:51
;;7.3;TOOLKIT;;Apr 25, 1995
; XTLKX IS PASSED IN AND SHOULD NOT BE KILLED
; XTLKWT IS PASSED OUT AND SHOULD NOT BE KILLED
K XTLKWT
Q:'$D(XTLKX) Q:XTLKX?.E1C.E
S XTLKSWB="",XTLKST="SKIP",XTLKI=0,XTLKXLEN=$L(XTLKX)
CHLOOP S XTLKI=XTLKI+1 G:XTLKI>XTLKXLEN EXIT
S XTLKC=$E(XTLKX,XTLKI)
S XTLKOST=XTLKST
I XTLKOST="SKIP",(XTLKC'?1P!("'~"[XTLKC&(($E(XTLKX,XTLKI+1)?1U)!("'~"[$E(XTLKX,XTLKI+1))))) S XTLKST="SCAN",XTLKWS=XTLKI
I XTLKOST="SCAN",XTLKC?1P,"-'~"'[XTLKC S XTLKEND=0 D ENDWORD S XTLKST="SKIP"
G CHLOOP
EXIT I XTLKST="SCAN" S XTLKEND=1 D ENDWORD
K XTLKSWB,XTLKOST,XTLKST,XTLKXLEN,XTLKC,XTLKWF,XTLKWS,XTLKWD,XTLKWD2,XTLKWL,XTLKEND,XTLKI,XTLKJ,XTLKQ
Q
ENDWORD S XTLKWL=XTLKI-XTLKWS,XTLKWD=$E(XTLKX,XTLKWS,XTLKI-1)
I XTLKWL=1 S XTLKSWB=XTLKSWB_XTLKWD I XTLKEND S XTLKWD=XTLKSWB D STOREWD
I XTLKWL>1 D STOREWD I XTLKSWB'="" S XTLKWD=XTLKSWB,XTLKSWB="" D STOREWD
Q
STOREWD ;
Q:XTLKWD'?.E1U.E
S XTLKJ=$S($E(XTLKWD)="'":2,$E(XTLKWD,1,2)="~'":3,1:1)
RMQ S XTLKJ=$F(XTLKWD,"'",XTLKJ) I XTLKJ S XTLKWD=$E(XTLKWD,1,XTLKJ-2)_$E(XTLKWD,XTLKJ,255),XTLKJ=XTLKJ-1 G RMQ
N XTLKL S XTLKL=$L(XTLKWD)
I XTLKWD'["-" S XTLKWT(XTLKWD)="" Q
S XTLKWD2="" F XTLKJ=1:1 S XTLKWF=$P(XTLKWD,"-",XTLKJ) Q:XTLKWF="" Q:$L(XTLKWF)>2 S XTLKWD2=XTLKWD2_XTLKWF
I XTLKWF="" S XTLKWT(XTLKWD2)="" Q
S XTLKWD2=XTLKWD F XTLKJ=1:1 S XTLKWF=$P(XTLKWD2,"-",XTLKJ) Q:XTLKWF="" S XTLKWT(XTLKWF)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTLKTOKN 1495 printed Nov 22, 2024@17:51:24 Page 2
XTLKTOKN ;IHS/OHPRD/ACC,SFISC/JC - CONVERT INPUT LINE TO TOKENS ;07/22/93 15:51
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
+2 ; XTLKX IS PASSED IN AND SHOULD NOT BE KILLED
+3 ; XTLKWT IS PASSED OUT AND SHOULD NOT BE KILLED
+4 KILL XTLKWT
+5 if '$DATA(XTLKX)
QUIT
if XTLKX?.E1C.E
QUIT
+6 SET XTLKSWB=""
SET XTLKST="SKIP"
SET XTLKI=0
SET XTLKXLEN=$LENGTH(XTLKX)
CHLOOP SET XTLKI=XTLKI+1
if XTLKI>XTLKXLEN
GOTO EXIT
+1 SET XTLKC=$EXTRACT(XTLKX,XTLKI)
+2 SET XTLKOST=XTLKST
+3 IF XTLKOST="SKIP"
IF (XTLKC'?1P!("'~"[XTLKC&(($EXTRACT(XTLKX,XTLKI+1)?1U)!("'~"[$EXTRACT(XTLKX,XTLKI+1)))))
SET XTLKST="SCAN"
SET XTLKWS=XTLKI
+4 IF XTLKOST="SCAN"
IF XTLKC?1P
IF "-'~"'[XTLKC
SET XTLKEND=0
DO ENDWORD
SET XTLKST="SKIP"
+5 GOTO CHLOOP
EXIT IF XTLKST="SCAN"
SET XTLKEND=1
DO ENDWORD
+1 KILL XTLKSWB,XTLKOST,XTLKST,XTLKXLEN,XTLKC,XTLKWF,XTLKWS,XTLKWD,XTLKWD2,XTLKWL,XTLKEND,XTLKI,XTLKJ,XTLKQ
+2 QUIT
ENDWORD SET XTLKWL=XTLKI-XTLKWS
SET XTLKWD=$EXTRACT(XTLKX,XTLKWS,XTLKI-1)
+1 IF XTLKWL=1
SET XTLKSWB=XTLKSWB_XTLKWD
IF XTLKEND
SET XTLKWD=XTLKSWB
DO STOREWD
+2 IF XTLKWL>1
DO STOREWD
IF XTLKSWB'=""
SET XTLKWD=XTLKSWB
SET XTLKSWB=""
DO STOREWD
+3 QUIT
STOREWD ;
+1 if XTLKWD'?.E1U.E
QUIT
+2 SET XTLKJ=$SELECT($EXTRACT(XTLKWD)="'":2,$EXTRACT(XTLKWD,1,2)="~'":3,1:1)
RMQ SET XTLKJ=$FIND(XTLKWD,"'",XTLKJ)
IF XTLKJ
SET XTLKWD=$EXTRACT(XTLKWD,1,XTLKJ-2)_$EXTRACT(XTLKWD,XTLKJ,255)
SET XTLKJ=XTLKJ-1
GOTO RMQ
+1 NEW XTLKL
SET XTLKL=$LENGTH(XTLKWD)
+2 IF XTLKWD'["-"
SET XTLKWT(XTLKWD)=""
QUIT
+3 SET XTLKWD2=""
FOR XTLKJ=1:1
SET XTLKWF=$PIECE(XTLKWD,"-",XTLKJ)
if XTLKWF=""
QUIT
if $LENGTH(XTLKWF)>2
QUIT
SET XTLKWD2=XTLKWD2_XTLKWF
+4 IF XTLKWF=""
SET XTLKWT(XTLKWD2)=""
QUIT
+5 SET XTLKWD2=XTLKWD
FOR XTLKJ=1:1
SET XTLKWF=$PIECE(XTLKWD2,"-",XTLKJ)
if XTLKWF=""
QUIT
SET XTLKWT(XTLKWF)=""
+6 QUIT
