Routine: AICDTICD

AICDTICD ; IHS/OHPRD/ACC - DRIVER ROUTINE FOR ICD LOOKUP UTILITY ;

 ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991

 W !!,"AICDTICD CANNOT BE ENTERED AT THE TOP.",!! Q

P S AICDTTYP="PROCEDURES" G COMMON

D S AICDTTYP="DIAGNOSES" G COMMON

C S AICDTTYP="CPT PROCEDURES" G COMMON

COMMON W ! F Q=0:0 R "NARRATIVE: ",X:$S($D(DTIME):DTIME,1:300) S:'$T X="^" Q:"^"[X  W:X?.E1C.E *7," -- NO CONTROL CHARACTERS ALLOWED!",! D:X'?.E1C.E LOOKUP

W !

 K AICDTTYP,Q,DIC

LOOKUP ;

 I X="^SYN" S DIE="^AICDKWLC(",DR=".011:999",DA=$O(^AICDKWLC("B",AICDTTYP,"")) D ^DIE W ! Q

 K DIC S DIC("S")="I $P(^(0),""^"",9)=""""" ; SCREEN OUT INACTIVE CODES

 S:$E(AICDTTYP)="D" DIC("S")=DIC("S")_",'(+^(0)>300&+^(0)<400&($L($P($P(^(0),""^"",1),""."",2))=3))"

 S:$E(AICDTTYP)="P" DIC("S")=DIC("S")_",'($L($P($P(^(0),""^"",1),""."",2))=3)"

 I X'?1N.E,X'?1"E"1N.E,X'?1"V"1N.E,X'?1"."1N.N G NARR

CODE S DIC=$S($E(AICDTTYP)="D":80,$E(AICDTTYP)="P":80.1,1:81),DIC(0)="EQMZ" D ^DIC W ! Q

NARR W ! G ICDDX^AICDKWLD:$E(AICDTTYP)="D",ICDOP^AICDKWLD:$E(AICDTTYP)="P",CPTOP^AICDKWLD

AICDTICD  ; IHS/OHPRD/ACC - DRIVER ROUTINE FOR ICD LOOKUP UTILITY ;

 +1       ;;3.51;IHS ICD/CPT lookup & grouper;;MAY 30, 1991

 +2       ;

 +3        WRITE !!,"AICDTICD CANNOT BE ENTERED AT THE TOP.",!!

           QUIT

 +4       ;

P          SET AICDTTYP="PROCEDURES"

           GOTO COMMON

D          SET AICDTTYP="DIAGNOSES"

           GOTO COMMON

C          SET AICDTTYP="CPT PROCEDURES"

           GOTO COMMON

 +1       ;

COMMON     WRITE !

           FOR Q=0:0

               READ "NARRATIVE: ",X:$SELECT($DATA(DTIME):DTIME,1:300)

               IF '$TEST

                   SET X="^"

               IF "^"[X

                   QUIT

               IF X?.E1C.E

                   WRITE *7," -- NO CONTROL CHARACTERS ALLOWED!",!

               IF X'?.E1C.E

                   DO LOOKUP

 +1        WRITE !

 +2        KILL AICDTTYP,Q,DIC

 +3        QUIT

 +4       ;

LOOKUP    ;

 +1        IF X="^SYN"

               SET DIE="^AICDKWLC("

               SET DR=".011:999"

               SET DA=$ORDER(^AICDKWLC("B",AICDTTYP,""))

               DO ^DIE

               WRITE !

               QUIT

 +2       ; SCREEN OUT INACTIVE CODES

           KILL DIC

           SET DIC("S")="I $P(^(0),""^"",9)="""""

 +3        IF $EXTRACT(AICDTTYP)="D"

               SET DIC("S")=DIC("S")_",'(+^(0)>300&+^(0)<400&($L($P($P(^(0),""^"",1),""."",2))=3))"

 +4        IF $EXTRACT(AICDTTYP)="P"

               SET DIC("S")=DIC("S")_",'($L($P($P(^(0),""^"",1),""."",2))=3)"

 +5        IF X'?1N.E

               IF X'?1"E"1N.E

                   IF X'?1"V"1N.E

                       IF X'?1"."1N.N

                           GOTO NARR

CODE       SET DIC=$SELECT($EXTRACT(AICDTTYP)="D":80,$EXTRACT(AICDTTYP)="P":80.1,1:81)

           SET DIC(0)="EQMZ"

           DO ^DIC

           WRITE !

           QUIT

NARR       WRITE !

           IF $EXTRACT(AICDTTYP)="D"

               GOTO ICDDX^AICDKWLD

           IF $EXTRACT(AICDTTYP)="P"

               GOTO ICDOP^AICDKWLD

           GOTO CPTOP^AICDKWLD

AICDTICD.m