ICDCOD.m

ICDCOD ;ALB/ABR/ADL - Inquire to ICD Codes ;04/21/2014

 ;;18.0;DRG Grouper;**7,57**;Oct 20, 2000;Build 7

 ;               

 ; Global Variables

 ;    None

 ;               

 ; External References

 ;    DD^%DT              ICR  10003

 ;    EN^DIQ1             ICR  10015

 ;    ^DIR                ICR  10026

 ;               

 ;This routine allows entry of an ICD9 or ICD0 code, and returns the description.

 ;It also alerts the user if it is an inactive code.

 ;

EN ;

 N DIRUT,DTOUT,DUOUT,DIR,DIC,DA,DR,DIQ,X,Y,ICDTMP

DATE D EFFDATE^ICDDRGM G EXIT:$D(DUOUT),EXIT:$D(DTOUT)

 F  S DIR(0)="SO^1:ICD DIAGNOSIS CODE;2:ICD OPERATION/PROCEDURE CODE" D ^DIR Q:Y<0!$D(DIRUT)  D @Y  Q:$D(DTOUT)

 G DATE

 ;

1 ;ICD DIAGNOSIS CODE

 S DIR(0)="PO^80:QAEMI"

 F  W !! S DIR("S")="I $$CSI^ICDEX(80,+Y)=1" D ^DIR K DIR("S") Q:Y<0!$D(DIRUT)  D

 . N ICDASK S DIC=$$ROOT^ICDEX(80),DA=+Y,DR=".01;1.1",DIQ(0)="ENI",DIQ="ICDASK" D EN^DIQ1

 . S ICDTMP=$$ICDDX^ICDCODE(+DA,ICDDATE)

 . W !!,ICDASK(80,DA,.01,"E"),?15,$P(ICDTMP,"^",4)

 . W !,$$VLT^ICDEX(80,+DA,ICDDATE),"     ",$P(ICDTMP,U,18),!  ;add printing of descript disclaimer msg

 . I '$P(ICDTMP,U,10) W "   **CODE INACTIVE" I $P(ICDTMP,U,12)'="" S Y=$P(ICDTMP,U,12) D DD^%DT W " AS OF   ",Y," **",!

 Q

 ;

2 ;ICD OPERATION/PROCEDURE

 S DIR(0)="PO^80.1:QAEMI"

 F  W !! S DIR("S")="I $$CSI^ICDEX(80.1,+Y)=2" D ^DIR K DIR("S") Q:Y<0!$D(DIRUT)  D

 . N ICDASK S DIC=$$ROOT^ICDEX(80.1),DA=+Y,DR=".01;1.1",DIQ(0)="ENI",DIQ="ICDASK" D EN^DIQ1

 . S ICDTMP=$$ICDOP^ICDCODE(+DA,ICDDATE)

 . W !!,ICDASK(80.1,DA,.01,"E"),?15,$P(ICDTMP,"^",5)

 . W !,$$VLT^ICDEX(80.1,+DA,ICDDATE),"     ",$P(ICDTMP,U,14),!  ;add printing of descript disclaimer msg

 . I '$P(ICDTMP,U,10) W "   **CODE INACTIVE" I $P(ICDTMP,U,12)'="" S Y=$P(ICDTMP,U,12) D DD^%DT W " AS OF   ",Y," **",!

 Q

EXIT Q  ;Exit subroutine

INA ; Inquire

 D INQ^ICDEX

 Q

ICDCOD    ;ALB/ABR/ADL - Inquire to ICD Codes ;04/21/2014

 +1       ;;18.0;DRG Grouper;**7,57**;Oct 20, 2000;Build 7

 +2       ;               

 +3       ; Global Variables

 +4       ;    None

 +5       ;               

 +6       ; External References

 +7       ;    DD^%DT              ICR  10003

 +8       ;    EN^DIQ1             ICR  10015

 +9       ;    ^DIR                ICR  10026

 +10      ;               

 +11      ;This routine allows entry of an ICD9 or ICD0 code, and returns the description.

 +12      ;It also alerts the user if it is an inactive code.

 +13      ;

EN        ;

 +1        NEW DIRUT,DTOUT,DUOUT,DIR,DIC,DA,DR,DIQ,X,Y,ICDTMP

DATE       DO EFFDATE^ICDDRGM

           IF $DATA(DUOUT)

               GOTO EXIT

           IF $DATA(DTOUT)

               GOTO EXIT

 +1        FOR 

               SET DIR(0)="SO^1:ICD DIAGNOSIS CODE;2:ICD OPERATION/PROCEDURE CODE"

               DO ^DIR

               IF Y<0!$DATA(DIRUT)

                   QUIT 

               DO @Y

               IF $DATA(DTOUT)

                   QUIT 

 +2        GOTO DATE

 +3       ;

1         ;ICD DIAGNOSIS CODE

 +1        SET DIR(0)="PO^80:QAEMI"

 +2        FOR 

               WRITE !!

               SET DIR("S")="I $$CSI^ICDEX(80,+Y)=1"

               DO ^DIR

               KILL DIR("S")

               IF Y<0!$DATA(DIRUT)

                   QUIT 

               Begin DoDot:1

 +3                NEW ICDASK

                   SET DIC=$$ROOT^ICDEX(80)

                   SET DA=+Y

                   SET DR=".01;1.1"

                   SET DIQ(0)="ENI"

                   SET DIQ="ICDASK"

                   DO EN^DIQ1

 +4                SET ICDTMP=$$ICDDX^ICDCODE(+DA,ICDDATE)

 +5                WRITE !!,ICDASK(80,DA,.01,"E"),?15,$PIECE(ICDTMP,"^",4)

 +6       ;add printing of descript disclaimer msg

                   WRITE !,$$VLT^ICDEX(80,+DA,ICDDATE),"     ",$PIECE(ICDTMP,U,18),!

 +7                IF '$PIECE(ICDTMP,U,10)

                       WRITE "   **CODE INACTIVE"

                       IF $PIECE(ICDTMP,U,12)'=""

                           SET Y=$PIECE(ICDTMP,U,12)

                           DO DD^%DT

                           WRITE " AS OF   ",Y," **",!

               End DoDot:1

 +8        QUIT 

 +9       ;

2         ;ICD OPERATION/PROCEDURE

 +1        SET DIR(0)="PO^80.1:QAEMI"

 +2        FOR 

               WRITE !!

               SET DIR("S")="I $$CSI^ICDEX(80.1,+Y)=2"

               DO ^DIR

               KILL DIR("S")

               IF Y<0!$DATA(DIRUT)

                   QUIT 

               Begin DoDot:1

 +3                NEW ICDASK

                   SET DIC=$$ROOT^ICDEX(80.1)

                   SET DA=+Y

                   SET DR=".01;1.1"

                   SET DIQ(0)="ENI"

                   SET DIQ="ICDASK"

                   DO EN^DIQ1

 +4                SET ICDTMP=$$ICDOP^ICDCODE(+DA,ICDDATE)

 +5                WRITE !!,ICDASK(80.1,DA,.01,"E"),?15,$PIECE(ICDTMP,"^",5)

 +6       ;add printing of descript disclaimer msg

                   WRITE !,$$VLT^ICDEX(80.1,+DA,ICDDATE),"     ",$PIECE(ICDTMP,U,14),!

 +7                IF '$PIECE(ICDTMP,U,10)

                       WRITE "   **CODE INACTIVE"

                       IF $PIECE(ICDTMP,U,12)'=""

                           SET Y=$PIECE(ICDTMP,U,12)

                           DO DD^%DT

                           WRITE " AS OF   ",Y," **",!

               End DoDot:1

 +8        QUIT 

EXIT      ;Exit subroutine

           QUIT 

INA       ; Inquire

 +1        DO INQ^ICDEX

 +2        QUIT