- AICDADK ; IHS/OHPRD/ACC - ADD KEYWORDS TO "OTHER KEYWORDS" FIELD IN ^ICD0/9 ;
- ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991
- W !!,*7,"AICDADK CANNOT BE ENTERED AT THE TOP -- USE DX OR OP",!!
- Q
- DX S AICDGBL="^ICD9"
- G INIT
- OP S AICDGBL="^ICD0"
- INIT D ^%AUKVAR S AICDBB=$C(7),AICDFLD="9999999.21",AICDLAST=""
- S AICDNWS=^DD("KWIC")_"IN^OF^AN^IS^AS^AT^IF^IT^ON^OR^BY^"
- W "- - - Add keywords to ",$P(@AICDGBL@(0),U,1)," ""OTHER KEYWORDS"" field - - -",!!
- MAINLP F AICDQ=0:0 R "Code: ",AICDCODE:DTIME S:'$T AICDCODE=U Q:U[AICDCODE S:AICDCODE=" " AICDCODE=AICDLAST S AICDLAST=AICDCODE D GCODE
- W !
- K AICDCODE,AICDNUMB,AICDBB,AICDFLD,AICDGBL,AICDSQN,AICDCNT,AICDDFN,AICDCDFN,AICDL,AICDNW,AICDWT,AICDWD,AICDWC,AICDWF,AICDWSV,AICDWS,AICDW,AICDNWS,AICDQ,AICDI,AICDA,AICDLAST,AICDEXEC
- W !,"B y e . . .",!
- Q
- ;
- GCODE ; GOT CODE
- D CHKCODE^AICDADK1 I AICDCODE="" W AICDBB," -- Invalid ICD code format",! Q
- S AICDCDFN=""
- I $D(@AICDGBL@("AB",AICDCODE)) S AICDCDFN=$O(^(AICDCODE,"")) W " ",@AICDGBL@(AICDCDFN,1),! S AICDNUMB=AICDCODE D GETKWD^AICDADK1,SET^AICDADK1 Q
- S AICDNUMB=$O(@AICDGBL@("BA",AICDCODE_" "))
- I $E(AICDNUMB,1,$L(AICDCODE))'=AICDCODE S AICDCODE="" W AICDBB," -- Code does not exist and has no more specific descendents.",! Q
- W !," Code does not exist as entered, but has descendents."
- R !," Do you wish to add keywords to the more specific subcodes? Y// ",AICDA:DTIME,! S:'$T AICDA=U
- Q:"Yy"'[$E(AICDA_"Y")
- D GETKWD^AICDADK1
- S AICDNUMB=AICDCODE
- I AICDCODE'=+AICDCODE D NONCON^AICDADK1 Q
- D CANONIC^AICDADK1
- Q
- AICDADK ; IHS/OHPRD/ACC - ADD KEYWORDS TO "OTHER KEYWORDS" FIELD IN ^ICD0/9 ;
- +1 ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991
- +2 WRITE !!,*7,"AICDADK CANNOT BE ENTERED AT THE TOP -- USE DX OR OP",!!
- +3 QUIT
- DX SET AICDGBL="^ICD9"
- +1 GOTO INIT
- OP SET AICDGBL="^ICD0"
- INIT DO ^%AUKVAR
- SET AICDBB=$CHAR(7)
- SET AICDFLD="9999999.21"
- SET AICDLAST=""
- +1 SET AICDNWS=^DD("KWIC")_"IN^OF^AN^IS^AS^AT^IF^IT^ON^OR^BY^"
- +2 WRITE "- - - Add keywords to ",$PIECE(@AICDGBL@(0),U,1)," ""OTHER KEYWORDS"" field - - -",!!
- MAINLP FOR AICDQ=0:0
- READ "Code: ",AICDCODE:DTIME
- IF '$TEST
- SET AICDCODE=U
- IF U[AICDCODE
- QUIT
- IF AICDCODE=" "
- SET AICDCODE=AICDLAST
- SET AICDLAST=AICDCODE
- DO GCODE
- +1 WRITE !
- +2 KILL AICDCODE,AICDNUMB,AICDBB,AICDFLD,AICDGBL,AICDSQN,AICDCNT,AICDDFN,AICDCDFN,AICDL,AICDNW,AICDWT,AICDWD,AICDWC,AICDWF,AICDWSV,AICDWS,AICDW,AICDNWS,AICDQ,AICDI,AICDA,AICDLAST,AICDEXEC
- +3 WRITE !,"B y e . . .",!
- +4 QUIT
- +5 ;
- GCODE ; GOT CODE
- +1 DO CHKCODE^AICDADK1
- IF AICDCODE=""
- WRITE AICDBB," -- Invalid ICD code format",!
- QUIT
- +2 SET AICDCDFN=""
- +3 IF $DATA(@AICDGBL@("AB",AICDCODE))
- SET AICDCDFN=$ORDER(^(AICDCODE,""))
- WRITE " ",@AICDGBL@(AICDCDFN,1),!
- SET AICDNUMB=AICDCODE
- DO GETKWD^AICDADK1
- DO SET^AICDADK1
- QUIT
- +4 SET AICDNUMB=$ORDER(@AICDGBL@("BA",AICDCODE_" "))
- +5 IF $EXTRACT(AICDNUMB,1,$LENGTH(AICDCODE))'=AICDCODE
- SET AICDCODE=""
- WRITE AICDBB," -- Code does not exist and has no more specific descendents.",!
- QUIT
- +6 WRITE !," Code does not exist as entered, but has descendents."
- +7 READ !," Do you wish to add keywords to the more specific subcodes? Y// ",AICDA:DTIME,!
- IF '$TEST
- SET AICDA=U
- +8 IF "Yy"'[$EXTRACT(AICDA_"Y")
- QUIT
- +9 DO GETKWD^AICDADK1
- +10 SET AICDNUMB=AICDCODE
- +11 IF AICDCODE'=+AICDCODE
- DO NONCON^AICDADK1
- QUIT
- +12 DO CANONIC^AICDADK1
- +13 QUIT