ICD1839P.m

ICD1839P ;ALB/MJB - ADD NON CC CODE ; 06/11/08 4:07pm

 ;;18.0;DRG Grouper;**39**;Oct 20, 2000;Build 4

 Q

POST ;entry point to add CODE NOT CC WITH 428.0 to 428.21 

 ; and code 428.0 to code 425.4

 N SDA,ICDFLG

 N SDA

 S SDA(1)="",SDA(2)=" Adding CODE NOT CC WITH(#80.03) in the "

 S SDA(3)=" ICD DIAGNOSIS file (# 80)for codes 428.21"  D ATADDQ

 ;

EN ;start update

 N ICDA

 S ICDA=0,ICDFLG=0

 F  S ICDA=$O(^ICD9("ACC",13637,ICDA)) Q:ICDFLG!(ICDA="")  D

 .I ICDA=9061 D ICDADDQ S ICDFLG=1 Q

 ;

 N DIC,X,DA

 S DIC="^ICD9(13637,"_"2,",DA(1)=2,X=9061,DIC(0)="X"

 I '$D(^ICD9("ACC",13637,X)) D

 . D FILE^DICN

 .S ^ICD9("ACC",13637,X)=""

 .N SDA

 .S SDA(1)="",SDA(2)="    CODE ADDED.....",SDA(3)="" D ATADDQ

 .Q

 Q

ICDADDQ ;

 N SDA

 S SDA(1)="",SDA(2)=" DUPLICATE CODE - CODE NOT ADDED" D ATADDQ

ATADDQ ;

 D MES^XPDUTL(.SDA) K SDA

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ICD1839P   863     printed  Apr 09, 2024@20:52:54                                                                                                                                                                                                     Page 2

ICD1839P  ;ALB/MJB - ADD NON CC CODE ; 06/11/08 4:07pm

 +1       ;;18.0;DRG Grouper;**39**;Oct 20, 2000;Build 4

 +2        QUIT 

POST      ;entry point to add CODE NOT CC WITH 428.0 to 428.21 

 +1       ; and code 428.0 to code 425.4

 +2        NEW SDA,ICDFLG

 +3        NEW SDA

 +4        SET SDA(1)=""

           SET SDA(2)=" Adding CODE NOT CC WITH(#80.03) in the "

 +5        SET SDA(3)=" ICD DIAGNOSIS file (# 80)for codes 428.21"

           DO ATADDQ

 +6       ;

EN        ;start update

 +1        NEW ICDA

 +2        SET ICDA=0

           SET ICDFLG=0

 +3        FOR 

               SET ICDA=$ORDER(^ICD9("ACC",13637,ICDA))

               if ICDFLG!(ICDA="")

                   QUIT 

               Begin DoDot:1

 +4                IF ICDA=9061

                       DO ICDADDQ

                       SET ICDFLG=1

                       QUIT 

               End DoDot:1

 +5       ;

 +6        NEW DIC,X,DA

 +7        SET DIC="^ICD9(13637,"_"2,"

           SET DA(1)=2

           SET X=9061

           SET DIC(0)="X"

 +8        IF '$DATA(^ICD9("ACC",13637,X))

               Begin DoDot:1

 +9                DO FILE^DICN

 +10               SET ^ICD9("ACC",13637,X)=""

 +11               NEW SDA

 +12               SET SDA(1)=""

                   SET SDA(2)="    CODE ADDED....."

                   SET SDA(3)=""

                   DO ATADDQ

 +13               QUIT 

               End DoDot:1

 +14       QUIT 

ICDADDQ   ;

 +1        NEW SDA

 +2        SET SDA(1)=""

           SET SDA(2)=" DUPLICATE CODE - CODE NOT ADDED"

           DO ATADDQ

ATADDQ    ;

 +1        DO MES^XPDUTL(.SDA)

           KILL SDA

 +2        QUIT 

 +3       ;