- 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 Mar 13, 2025@21:46:32 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
