- 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
