AICDADK.m

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