- AICDTOKN ; IHS/OHPRD/ACC - CONVERT INPUT LINE TO TOKENS ;
- ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991
- ; AICDX IS PASSED IN AND SHOULD NOT BE KILLED
- ; AICDWT IS PASSED OUT AND SHOULD NOT BE KILLED
- K AICDWT
- Q:'$D(AICDX) Q:AICDX?.E1C.E
- S AICDSWB="",AICDST="SKIP",AICDI=0,AICDXLEN=$L(AICDX)
- CHLOOP S AICDI=AICDI+1 G:AICDI>AICDXLEN EXIT
- S AICDC=$E(AICDX,AICDI)
- S AICDOST=AICDST
- I AICDOST="SKIP",(AICDC'?1P!("'~"[AICDC&(($E(AICDX,AICDI+1)?1U)!("'~"[$E(AICDX,AICDI+1))))) S AICDST="SCAN",AICDWS=AICDI
- I AICDOST="SCAN",AICDC?1P,"-'~"'[AICDC S AICDEND=0 D ENDWORD S AICDST="SKIP"
- G CHLOOP
- EXIT I AICDST="SCAN" S AICDEND=1 D ENDWORD
- K AICDSWB,AICDOST,AICDST,AICDXLEN,AICDC,AICDWF,AICDWS,AICDWD,AICDWD2,AICDWL,AICDEND,AICDI,AICDJ,AICDQ
- Q
- ENDWORD S AICDWL=AICDI-AICDWS,AICDWD=$E(AICDX,AICDWS,AICDI-1)
- I AICDWL=1 S AICDSWB=AICDSWB_AICDWD I AICDEND S AICDWD=AICDSWB D STOREWD
- I AICDWL>1 D STOREWD I AICDSWB'="" S AICDWD=AICDSWB,AICDSWB="" D STOREWD
- Q
- STOREWD ;
- Q:AICDWD'?.E1U.E
- S AICDJ=$S($E(AICDWD)="'":2,$E(AICDWD,1,2)="~'":3,1:1)
- RMQ S AICDJ=$F(AICDWD,"'",AICDJ) I AICDJ S AICDWD=$E(AICDWD,1,AICDJ-2)_$E(AICDWD,AICDJ,255),AICDJ=AICDJ-1 G RMQ
- I AICDWD'["-" S AICDWT(AICDWD)="" Q
- S AICDWD2="" F AICDJ=1:1 S AICDWF=$P(AICDWD,"-",AICDJ) Q:AICDWF="" Q:$L(AICDWF)>2 S AICDWD2=AICDWD2_AICDWF
- I AICDWF="" S AICDWT(AICDWD2)="" Q
- S AICDWD2=AICDWD F AICDJ=1:1 S AICDWF=$P(AICDWD2,"-",AICDJ) Q:AICDWF="" S AICDWT(AICDWF)=""
- Q
- AICDTOKN ; IHS/OHPRD/ACC - CONVERT INPUT LINE TO TOKENS ;
- +1 ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991
- +2 ; AICDX IS PASSED IN AND SHOULD NOT BE KILLED
- +3 ; AICDWT IS PASSED OUT AND SHOULD NOT BE KILLED
- +4 KILL AICDWT
- +5 IF '$DATA(AICDX)
- QUIT
- IF AICDX?.E1C.E
- QUIT
- +6 SET AICDSWB=""
- SET AICDST="SKIP"
- SET AICDI=0
- SET AICDXLEN=$LENGTH(AICDX)
- CHLOOP SET AICDI=AICDI+1
- IF AICDI>AICDXLEN
- GOTO EXIT
- +1 SET AICDC=$EXTRACT(AICDX,AICDI)
- +2 SET AICDOST=AICDST
- +3 IF AICDOST="SKIP"
- IF (AICDC'?1P!("'~"[AICDC&(($EXTRACT(AICDX,AICDI+1)?1U)!("'~"[$EXTRACT(AICDX,AICDI+1)))))
- SET AICDST="SCAN"
- SET AICDWS=AICDI
- +4 IF AICDOST="SCAN"
- IF AICDC?1P
- IF "-'~"'[AICDC
- SET AICDEND=0
- DO ENDWORD
- SET AICDST="SKIP"
- +5 GOTO CHLOOP
- EXIT IF AICDST="SCAN"
- SET AICDEND=1
- DO ENDWORD
- +1 KILL AICDSWB,AICDOST,AICDST,AICDXLEN,AICDC,AICDWF,AICDWS,AICDWD,AICDWD2,AICDWL,AICDEND,AICDI,AICDJ,AICDQ
- +2 QUIT
- ENDWORD SET AICDWL=AICDI-AICDWS
- SET AICDWD=$EXTRACT(AICDX,AICDWS,AICDI-1)
- +1 IF AICDWL=1
- SET AICDSWB=AICDSWB_AICDWD
- IF AICDEND
- SET AICDWD=AICDSWB
- DO STOREWD
- +2 IF AICDWL>1
- DO STOREWD
- IF AICDSWB'=""
- SET AICDWD=AICDSWB
- SET AICDSWB=""
- DO STOREWD
- +3 QUIT
- STOREWD ;
- +1 IF AICDWD'?.E1U.E
- QUIT
- +2 SET AICDJ=$SELECT($EXTRACT(AICDWD)="'":2,$EXTRACT(AICDWD,1,2)="~'":3,1:1)
- RMQ SET AICDJ=$FIND(AICDWD,"'",AICDJ)
- IF AICDJ
- SET AICDWD=$EXTRACT(AICDWD,1,AICDJ-2)_$EXTRACT(AICDWD,AICDJ,255)
- SET AICDJ=AICDJ-1
- GOTO RMQ
- +1 IF AICDWD'["-"
- SET AICDWT(AICDWD)=""
- QUIT
- +2 SET AICDWD2=""
- FOR AICDJ=1:1
- SET AICDWF=$PIECE(AICDWD,"-",AICDJ)
- IF AICDWF=""
- QUIT
- IF $LENGTH(AICDWF)>2
- QUIT
- SET AICDWD2=AICDWD2_AICDWF
- +3 IF AICDWF=""
- SET AICDWT(AICDWD2)=""
- QUIT
- +4 SET AICDWD2=AICDWD
- FOR AICDJ=1:1
- SET AICDWF=$PIECE(AICDWD2,"-",AICDJ)
- IF AICDWF=""
- QUIT
- SET AICDWT(AICDWF)=""
- +5 QUIT
