AICDADK1 ; IHS/OHPRD/ACC - PART 2 OF ADD KEYWORDS TO "OTHER KEYWORDS" FIELD IN ^ICD0/9 ;
;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991
; NOTE: ALL KILLS DONE IN MAIN ROUTINE (AICDADK)
;
NONCON D SETLOOP I (+$P(AICDCODE,".",1))=($P(AICDCODE,".",1)) S AICDNUMB=AICDCODE_"001" D SETLOOP
Q
;
CANONIC D SETLOOP S AICDNUMB=AICDCODE_" " D SETLOOP
Q
;
SETLOOP F AICDQ=0:0 S AICDNUMB=$O(@AICDGBL@("AB",AICDNUMB)) Q:AICDNUMB="" Q:$E(AICDNUMB,1,$L(AICDCODE))'=AICDCODE D SET
Q
;
GETKWD ; GET WORD STRING AND BUILD WORD TABLE
K AICDWT S AICDWT=0
R "Keywords: ",AICDL:DTIME,! S:'$T AICDL=U Q:U[AICDL
I AICDL="?" D LIST G GETKWD
I AICDL?.E1C.E W *7,"-- control characters not allowed in input!",! G GETKWD
F AICDQ=0:0 S AICDNW=$F(AICDL,"~") Q:'AICDNW S AICDL=$E(AICDL,1,AICDNW-2)_$C(8)_$E(AICDL,AICDNW,255)
S AICDWT=0 F AICDNW=1:1 S AICDWD=$P(AICDL," ",AICDNW) Q:AICDWD="" I AICDWD]"",AICDWD'="@",AICDNWS'[("^"_AICDWD_"^") S AICDWT=AICDWT+1,AICDWT(AICDWD)=""
Q
;
LIST ; LIST KEYWORDS FOR CODE
Q:'AICDCDFN Q:'$D(@AICDGBL@(AICDCDFN,AICDFLD,"B"))
S AICDWD=0 F AICDL=0:0 S AICDWD=$O(@AICDGBL@(AICDCDFN,AICDFLD,"B",AICDWD)) Q:AICDWD="" W AICDWD,!
Q
;
SET ; SET WORDS IN WORD TABLE INTO ^ICD0/9 UNDER 'NCODE'
S AICDDFN=$O(@AICDGBL@("AB",AICDNUMB,""))
L @AICDGBL@(AICDDFN,AICDFLD)
S:'$D(@AICDGBL@(AICDDFN,AICDFLD,0)) ^(0)="^80.999999921A^0^0"
S AICDCNT=$P(@AICDGBL@(AICDDFN,AICDFLD,0),U,4)
S AICDWD="" F AICDW=1:1 S AICDWD=$O(AICDWT(AICDWD)) Q:AICDWD="" D DECIDE
S $P(@AICDGBL@(AICDDFN,AICDFLD,0),U,4)=AICDCNT
L
W:$X'=0 !
Q
;
DECIDE ; DECIDE WHETHER TO SET OR KILL
S AICDWSV=AICDWD
I $E(AICDWD)="@" S AICDWD=$E(AICDWD,2,255) D KILLWD S AICDWD=AICDWSV Q
D SETWD S AICDWD=AICDWSV Q
;
KILLWD ; KILL WORD IN ^ICD0/9
I '$D(@AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD)) W AICDBB," -- '",AICDWD,"' not in ",AICDNUMB,! Q
S AICDSQN="" F AICDQ=0:0 S AICDSQN=$O(@AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD,AICDSQN)) Q:AICDSQN="" S AICDCNT=AICDCNT-1 W "." K ^(AICDSQN),@AICDGBL@(AICDDFN,AICDFLD,AICDSQN,0) S AICDEXEC="K @AICDGBL@(""AIHS"",AICDWD,AICDDFN,AICDSQN)" D TOKNDX
Q
;
SETWD ; SET WORD INTO ^ICD0/9
Q:$D(@AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD))
D GETSEQ
S AICDCNT=AICDCNT+1
S @AICDGBL@(AICDDFN,AICDFLD,AICDSQN,0)=AICDWD
S @AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD,AICDSQN)=""
S AICDEXEC="S @AICDGBL@(""AIHS"",AICDWD,AICDDFN,AICDSQN)="""""
D TOKNDX
Q
;
TOKNDX ; BREAK WORD INTO TOKENS AND INDEX
REMQT S AICDI=$F(AICDWD,"'") I AICDI>0 S AICDWD=$E(AICDWD,1,AICDI-2)_$E(AICDWD,AICDI,255) G REMQT
I '$F(AICDWD,"-") X AICDEXEC Q
S AICDWS=AICDWD,AICDWC=""
F AICDI=1:1 S AICDWF=$P(AICDWD,"-",AICDI) Q:AICDWF="" Q:$L(AICDWF)>2 S AICDWC=AICDWC_AICDWF
S:AICDWF'="" AICDWC=AICDWD
F AICDI=1:1 S AICDWD=$P(AICDWC,"-",AICDI) Q:AICDWD="" X AICDEXEC
S AICDWD=AICDWS
Q
;
GETSEQ ; GET NEXT AVAIILABLE SUB-DFN
F AICDSQN=1:1 Q:'$D(@AICDGBL@(AICDDFN,AICDFLD,AICDSQN))
Q
;
CHKCODE ; CHECK FORMAT OF CODE
G:AICDGBL="^ICD0" OPCODE
DXCODE S:AICDCODE?3N!(AICDCODE?1U1N.N) AICDCODE=AICDCODE_"."
Q:(AICDCODE?1"V"2N1".")!(AICDCODE?1"V"2N1"."1N)!(AICDCODE?1"V"2N1"."2N)
Q:(AICDCODE?1"E"3N1".")!(AICDCODE?1"E"3N1"."1N)!(AICDCODE?1"E"3N1"."2N)
Q:(AICDCODE?3N1".")!(AICDCODE?3N1"."1N)!(AICDCODE?3N1"."2N)!(AICDCODE?1"."4N)
S AICDCODE=""
Q
OPCODE S:AICDCODE?2N AICDCODE=AICDCODE_"."
Q:(AICDCODE?2N1".")!(AICDCODE?2N1"."1N)!(AICDCODE?2N1"."2N)
S AICDCODE=""
Q
AICDADK1 ; IHS/OHPRD/ACC - PART 2 OF ADD KEYWORDS TO "OTHER KEYWORDS" FIELD IN ^ICD0/9 ;
+1 ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991
+2 ; NOTE: ALL KILLS DONE IN MAIN ROUTINE (AICDADK)
+3 ;
NONCON DO SETLOOP
IF (+$PIECE(AICDCODE,".",1))=($PIECE(AICDCODE,".",1))
SET AICDNUMB=AICDCODE_"001"
DO SETLOOP
+1 QUIT
+2 ;
CANONIC DO SETLOOP
SET AICDNUMB=AICDCODE_" "
DO SETLOOP
+1 QUIT
+2 ;
SETLOOP FOR AICDQ=0:0
SET AICDNUMB=$ORDER(@AICDGBL@("AB",AICDNUMB))
IF AICDNUMB=""
QUIT
IF $EXTRACT(AICDNUMB,1,$LENGTH(AICDCODE))'=AICDCODE
QUIT
DO SET
+1 QUIT
+2 ;
GETKWD ; GET WORD STRING AND BUILD WORD TABLE
+1 KILL AICDWT
SET AICDWT=0
+2 READ "Keywords: ",AICDL:DTIME,!
IF '$TEST
SET AICDL=U
IF U[AICDL
QUIT
+3 IF AICDL="?"
DO LIST
GOTO GETKWD
+4 IF AICDL?.E1C.E
WRITE *7,"-- control characters not allowed in input!",!
GOTO GETKWD
+5 FOR AICDQ=0:0
SET AICDNW=$FIND(AICDL,"~")
IF 'AICDNW
QUIT
SET AICDL=$EXTRACT(AICDL,1,AICDNW-2)_$CHAR(8)_$EXTRACT(AICDL,AICDNW,255)
+6 SET AICDWT=0
FOR AICDNW=1:1
SET AICDWD=$PIECE(AICDL," ",AICDNW)
IF AICDWD=""
QUIT
IF AICDWD]""
IF AICDWD'="@"
IF AICDNWS'[("^"_AICDWD_"^")
SET AICDWT=AICDWT+1
SET AICDWT(AICDWD)=""
+7 QUIT
+8 ;
LIST ; LIST KEYWORDS FOR CODE
+1 IF 'AICDCDFN
QUIT
IF '$DATA(@AICDGBL@(AICDCDFN,AICDFLD,"B"))
QUIT
+2 SET AICDWD=0
FOR AICDL=0:0
SET AICDWD=$ORDER(@AICDGBL@(AICDCDFN,AICDFLD,"B",AICDWD))
IF AICDWD=""
QUIT
WRITE AICDWD,!
+3 QUIT
+4 ;
SET ; SET WORDS IN WORD TABLE INTO ^ICD0/9 UNDER 'NCODE'
+1 SET AICDDFN=$ORDER(@AICDGBL@("AB",AICDNUMB,""))
+2 LOCK @AICDGBL@(AICDDFN,AICDFLD)
+3 IF '$DATA(@AICDGBL@(AICDDFN,AICDFLD,0))
SET ^(0)="^80.999999921A^0^0"
+4 SET AICDCNT=$PIECE(@AICDGBL@(AICDDFN,AICDFLD,0),U,4)
+5 SET AICDWD=""
FOR AICDW=1:1
SET AICDWD=$ORDER(AICDWT(AICDWD))
IF AICDWD=""
QUIT
DO DECIDE
+6 SET $PIECE(@AICDGBL@(AICDDFN,AICDFLD,0),U,4)=AICDCNT
+7 LOCK
+8 IF $X'=0
WRITE !
+9 QUIT
+10 ;
DECIDE ; DECIDE WHETHER TO SET OR KILL
+1 SET AICDWSV=AICDWD
+2 IF $EXTRACT(AICDWD)="@"
SET AICDWD=$EXTRACT(AICDWD,2,255)
DO KILLWD
SET AICDWD=AICDWSV
QUIT
+3 DO SETWD
SET AICDWD=AICDWSV
QUIT
+4 ;
KILLWD ; KILL WORD IN ^ICD0/9
+1 IF '$DATA(@AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD))
WRITE AICDBB," -- '",AICDWD,"' not in ",AICDNUMB,!
QUIT
+2 SET AICDSQN=""
FOR AICDQ=0:0
SET AICDSQN=$ORDER(@AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD,AICDSQN))
IF AICDSQN=""
QUIT
SET AICDCNT=AICDCNT-1
WRITE "."
KILL ^(AICDSQN),@AICDGBL@(AICDDFN,AICDFLD,AICDSQN,0)
SET AICDEXEC="K @AICDGBL@(""AIHS"",AICDWD,AICDDFN,AICDSQN)"
DO TOKNDX
+3 QUIT
+4 ;
SETWD ; SET WORD INTO ^ICD0/9
+1 IF $DATA(@AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD))
QUIT
+2 DO GETSEQ
+3 SET AICDCNT=AICDCNT+1
+4 SET @AICDGBL@(AICDDFN,AICDFLD,AICDSQN,0)=AICDWD
+5 SET @AICDGBL@(AICDDFN,AICDFLD,"B",AICDWD,AICDSQN)=""
+6 SET AICDEXEC="S @AICDGBL@(""AIHS"",AICDWD,AICDDFN,AICDSQN)="""""
+7 DO TOKNDX
+8 QUIT
+9 ;
TOKNDX ; BREAK WORD INTO TOKENS AND INDEX
REMQT SET AICDI=$FIND(AICDWD,"'")
IF AICDI>0
SET AICDWD=$EXTRACT(AICDWD,1,AICDI-2)_$EXTRACT(AICDWD,AICDI,255)
GOTO REMQT
+1 IF '$FIND(AICDWD,"-")
XECUTE AICDEXEC
QUIT
+2 SET AICDWS=AICDWD
SET AICDWC=""
+3 FOR AICDI=1:1
SET AICDWF=$PIECE(AICDWD,"-",AICDI)
IF AICDWF=""
QUIT
IF $LENGTH(AICDWF)>2
QUIT
SET AICDWC=AICDWC_AICDWF
+4 IF AICDWF'=""
SET AICDWC=AICDWD
+5 FOR AICDI=1:1
SET AICDWD=$PIECE(AICDWC,"-",AICDI)
IF AICDWD=""
QUIT
XECUTE AICDEXEC
+6 SET AICDWD=AICDWS
+7 QUIT
+8 ;
GETSEQ ; GET NEXT AVAIILABLE SUB-DFN
+1 FOR AICDSQN=1:1
IF '$DATA(@AICDGBL@(AICDDFN,AICDFLD,AICDSQN))
QUIT
+2 QUIT
+3 ;
CHKCODE ; CHECK FORMAT OF CODE
+1 IF AICDGBL="^ICD0"
GOTO OPCODE
DXCODE IF AICDCODE?3N!(AICDCODE?1U1N.N)
SET AICDCODE=AICDCODE_"."
+1 IF (AICDCODE?1"V"2N1".")!(AICDCODE?1"V"2N1"."1N)!(AICDCODE?1"V"2N1"."2N)
QUIT
+2 IF (AICDCODE?1"E"3N1".")!(AICDCODE?1"E"3N1"."1N)!(AICDCODE?1"E"3N1"."2N)
QUIT
+3 IF (AICDCODE?3N1".")!(AICDCODE?3N1"."1N)!(AICDCODE?3N1"."2N)!(AICDCODE?1"."4N)
QUIT
+4 SET AICDCODE=""
+5 QUIT
OPCODE IF AICDCODE?2N
SET AICDCODE=AICDCODE_"."
+1 IF (AICDCODE?2N1".")!(AICDCODE?2N1"."1N)!(AICDCODE?2N1"."2N)
QUIT
+2 SET AICDCODE=""
+3 QUIT
