ICD161P.m

ICD161P ;ALB/JDS - DRG GROUPER 16 PRE-INSTALL ; 09-DEC-98

 ;;16.0;DRG Grouper;**1**;Jan 15, 1999

 ;

 ;  This routine makes modifications to ICD files

 ;

 ;  These files must be reloaded upon completion of the

 ;  patch installation.

 ;

EN ;

 N I,XPDIDTOT,ICDX,ENTRY,DA,DIC,MDC22,DIE,DIK,DR,PROC,X

 S MDC22=$P($T(MDC22),";;",2)

 D BMES^XPDUTL(">>>> Updating MDC 22 Diagnosis Codes")

 F I=1:1:$L(MDC22,U) D

 .S ENTRY=$P(MDC22,U,I)

 .S DA=+$O(^ICD9("BA",ENTRY_" ",0)) Q:'DA

 .S DR="2///b;Q;2///@;61///510;60///511;5///22"

 .S DIE="^ICD9(" D ^DIE

 ;MDC 1

 D BMES^XPDUTL(">>>> Updating MDC 1 Procedure Codes")

 F PROC=38.7,83.92,83.93 S ENTRY=+$O(^ICD0("BA",PROC_" ",0)) I ENTRY D

 .I $D(^ICD0(ENTRY,"MDC",1)) S DIK="^DIK(ENTRY,""MDC"",",DA=1,DA(1)=ENTRY D ^DIK

 .I '$D(^ICD0(ENTRY,"MDC",0)) S ^(0)="^80.12PA"

 .S DIC="^ICD0(ENTRY,""MDC"",",X=1,DIC("DR")="1///7;2///8",DIC(0)="LM",DA(1)=ENTRY D ^DIC

 ;MDC 5

 D BMES^XPDUTL(">>>> Updating MDC 5 Procedure Codes")

 S ENTRY=+$O(^ICD0("BA","86.06 ",0)) I ENTRY D

 .I $D(^ICD0(ENTRY,"MDC",5)) S DIK="^ICD0(ENTRY,""MDC"",",DA=5,DA(1)=ENTRY D ^DIK

 .I '$D(^ICD0(ENTRY,"MDC",0)) S ^(0)="^80.12PA"

 .S DIC="^ICD0(ENTRY,""MDC"",",X=5,DIC("DR")="1///120",DA(1)=ENTRY,DIC(0)="LM" D ^DIC

 ;MDC 4

 D BMES^XPDUTL(">>> Updating MDC 4 Procedure Codes")

 S ENTRY=+$O(^ICD0("BA","39.50 ",0)) I ENTRY D

 .I $D(^ICD0(ENTRY,"MDC",4)) S DIK="^ICD0(ENTRY,""MDC"",",DA=4,DA(1)=ENTRY D ^DIK

 .I '$D(^ICD0(ENTRY,"MDC",0)) S ^(0)="^80.12PA"

 .S DIC="^ICD0(ENTRY,""MDC"",",X=4,DIC("DR")="1///76;2///77",DA(1)=ENTRY,DIC(0)="LM" D ^DIC

 D BMES^XPDUTL(">>> Changing Diagnostic Code as Valid Principal Diagnoses")

 S DA=+$O(^ICD9("BA","V71.9 ",0))

 I DA S DIE="^ICD9(",DR="101///1;Q;101///@" D ^DIE

 Q

MDC22 ;;948.90^948.80^948.70^948.60^948.50^948.40^948.30^948.20^948.10^948.00

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ICD161P   1832     printed  Apr 23, 2025@18:02:06                                                                                                                                                                                                     Page 2

ICD161P   ;ALB/JDS - DRG GROUPER 16 PRE-INSTALL ; 09-DEC-98

 +1       ;;16.0;DRG Grouper;**1**;Jan 15, 1999

 +2       ;

 +3       ;  This routine makes modifications to ICD files

 +4       ;

 +5       ;  These files must be reloaded upon completion of the

 +6       ;  patch installation.

 +7       ;

EN        ;

 +1        NEW I,XPDIDTOT,ICDX,ENTRY,DA,DIC,MDC22,DIE,DIK,DR,PROC,X

 +2        SET MDC22=$PIECE($TEXT(MDC22),";;",2)

 +3        DO BMES^XPDUTL(">>>> Updating MDC 22 Diagnosis Codes")

 +4        FOR I=1:1:$LENGTH(MDC22,U)

               Begin DoDot:1

 +5                SET ENTRY=$PIECE(MDC22,U,I)

 +6                SET DA=+$ORDER(^ICD9("BA",ENTRY_" ",0))

                   if 'DA

                       QUIT 

 +7                SET DR="2///b;Q;2///@;61///510;60///511;5///22"

 +8                SET DIE="^ICD9("

                   DO ^DIE

               End DoDot:1

 +9       ;MDC 1

 +10       DO BMES^XPDUTL(">>>> Updating MDC 1 Procedure Codes")

 +11       FOR PROC=38.7,83.92,83.93

               SET ENTRY=+$ORDER(^ICD0("BA",PROC_" ",0))

               IF ENTRY

                   Begin DoDot:1

 +12                   IF $DATA(^ICD0(ENTRY,"MDC",1))

                           SET DIK="^DIK(ENTRY,""MDC"","

                           SET DA=1

                           SET DA(1)=ENTRY

                           DO ^DIK

 +13                   IF '$DATA(^ICD0(ENTRY,"MDC",0))

                           SET ^(0)="^80.12PA"

 +14                   SET DIC="^ICD0(ENTRY,""MDC"","

                       SET X=1

                       SET DIC("DR")="1///7;2///8"

                       SET DIC(0)="LM"

                       SET DA(1)=ENTRY

                       DO ^DIC

                   End DoDot:1

 +15      ;MDC 5

 +16       DO BMES^XPDUTL(">>>> Updating MDC 5 Procedure Codes")

 +17       SET ENTRY=+$ORDER(^ICD0("BA","86.06 ",0))

           IF ENTRY

               Begin DoDot:1

 +18               IF $DATA(^ICD0(ENTRY,"MDC",5))

                       SET DIK="^ICD0(ENTRY,""MDC"","

                       SET DA=5

                       SET DA(1)=ENTRY

                       DO ^DIK

 +19               IF '$DATA(^ICD0(ENTRY,"MDC",0))

                       SET ^(0)="^80.12PA"

 +20               SET DIC="^ICD0(ENTRY,""MDC"","

                   SET X=5

                   SET DIC("DR")="1///120"

                   SET DA(1)=ENTRY

                   SET DIC(0)="LM"

                   DO ^DIC

               End DoDot:1

 +21      ;MDC 4

 +22       DO BMES^XPDUTL(">>> Updating MDC 4 Procedure Codes")

 +23       SET ENTRY=+$ORDER(^ICD0("BA","39.50 ",0))

           IF ENTRY

               Begin DoDot:1

 +24               IF $DATA(^ICD0(ENTRY,"MDC",4))

                       SET DIK="^ICD0(ENTRY,""MDC"","

                       SET DA=4

                       SET DA(1)=ENTRY

                       DO ^DIK

 +25               IF '$DATA(^ICD0(ENTRY,"MDC",0))

                       SET ^(0)="^80.12PA"

 +26               SET DIC="^ICD0(ENTRY,""MDC"","

                   SET X=4

                   SET DIC("DR")="1///76;2///77"

                   SET DA(1)=ENTRY

                   SET DIC(0)="LM"

                   DO ^DIC

               End DoDot:1

 +27       DO BMES^XPDUTL(">>> Changing Diagnostic Code as Valid Principal Diagnoses")

 +28       SET DA=+$ORDER(^ICD9("BA","V71.9 ",0))

 +29       IF DA

               SET DIE="^ICD9("

               SET DR="101///1;Q;101///@"

               DO ^DIE

 +30       QUIT 

MDC22     ;;948.90^948.80^948.70^948.60^948.50^948.40^948.30^948.20^948.10^948.00