Routine: ICD18PT

ICD18PT ;ALB/ESD - DRG V16 POST-INSTALL ; 10/23/00 11:57am

 ;;18.0;DRG Grouper;;Oct 20, 2000

 ;  This routine may be re-run.

EN ;- Post-Install entry point

 ;- Remove dup "B" xrefs from Description multiple

 ;D REMXREF

 ;- Revise DRGs/new descriptions, or changed to Inactie

 ;D DRGEDIT

 ;- Weights & trims for FY 97

 ;D BEGWT

 ;- Display reminder msg

 D BMES^XPDUTL(">>>  IMPORTANT:  Please restore your ICD9 and ICD0 global files from  <<<")

 D MES^XPDUTL(">>>              ICD9_18.GBL and ICD0_18.GBL at this time.        <<<")

REMXREF ;- Remove dup "B" xref on Description multiple and reindex

 N DA,DIK,I,ICDIEN

 D MES^XPDUTL("")

 D BMES^XPDUTL(">>>  Correcting duplicate ""B"" cross-ref entries in the Description")

 D MES^XPDUTL("     multiple of the DRG file (#80.2)...")

 F I=1:1 S ICDIEN=$P($T(REMXDRG+I),";;",2) Q:ICDIEN="QUIT"  D

 . K ^ICD(ICDIEN,1,"B")

 . S DA(1)=ICDIEN,DA=1

 . S DIK="^ICD("_DA(1)_",1,"

 . S DIK(1)=".01^B"

 . D EN1^DIK

 D MES^XPDUTL(">>>  ...completed.")

 D MES^XPDUTL("")

DRGEDIT ;- Edit DRG records (Description change)

 N CNT,DA,DIC,DIE,DR,DRG,I,ICDI,ICDIEN,ICDESC,NOVAL,X,Y

 S CNT=0

 D BMES^XPDUTL(">>>  Revising DRG records in the DRG file (#80.2)...")

 F I=1:1 S DRG=$P($T(REVDRG+I),";;",2) Q:DRG="QUIT"  D

 . S DIC="^ICD(",DIC(0)="MX"

 . S X=$P(DRG,"^")

 . D ^DIC

 . I +Y>0 D

 .. S ICDESC=""

 .. F  S ICDESC=$O(^ICD(+Y,1,"B",ICDESC)) Q:ICDESC=""  S ICDIEN=+$O(^(ICDESC,0))

 .. S (ICDI,DA(1))=+Y,DA=ICDIEN

 .. S DIE=DIC_DA(1)_","_DA_","

 .. S DR=".01///^S X=$P(DRG,""^"",2)"

 .. D ^DIE

 .. D

 ... I $P(DRG,"^",3)="" Q

 ... S DIE=DIC

 ... S DA=ICDI

 ... S DR=".06///^S X=$P(DRG,""^"",3);5///^S X=$P(DRG,""^"",4)"

 ... D ^DIE

 .. S CNT=CNT+1

 .. D MES^XPDUTL("  Edited: "_$P(DRG,"^")_" to "_$P(DRG,"^",2))

 . E  D ERRMSG($P(DRG,"^"))

 ;- Total DRG records revised

 D MES^XPDUTL(">>>  ...completed.  "_CNT_" record(s) revised.")

 D MES^XPDUTL("")

ERRMSG(VAR,IN) ;- Display error msg if DRG not found

 Q:VAR=""

 D BMES^XPDUTL(">>>  ERROR:  "_VAR_"  was not found and could not be "_$S(+$G(IN):"inactivated.",1:"revised."))

 D MES^XPDUTL("")

BEGWT ;- Entry point for wts & trims update for 97

 N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J

 D UPD97

UPD97 ;- Load FY 97 WWU into ICD DRG file (#80.2)

 S FYR=2970000

 D BMES^XPDUTL(">>>  Adding FY 97 Weights & Trims...")

 F I=1:1 S WT=$P($T(WW97+I^ICD16P97),";;",2,99) Q:'WT  D SETVAR,FY,MORE

 F I=1:1 S WT=$P($T(WW97+I^ICD1697A),";;",2,99) Q:'WT  D SETVAR,FY,MORE

 S ^ICD("AFY",2970000)=""

 D MES^XPDUTL(">>>  ...completed.")

 D MES^XPDUTL("")

FY ;- Set FY multiple with FYR stats

 S $P(^ICD(DRG,"FY",FYR,0),"^",1,4)=FYR_"^"_ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",9)=ICDLOS

 I '$D(^ICD(DRG,"FY",0)) S ^ICD(DRG,"FY",0)="^80.22^"_FYR_"^1" Q

 S ICDCNT="" F J=0:1 S ICDCNT=$O(^ICD(DRG,"FY",ICDCNT)) Q:ICDCNT=""

 S $P(^ICD(DRG,"FY",0),"^",3,4)=FYR_"^"_J

SETVAR ;- Set variables

 S DRG=+WT,ICDLOW=$P(WT,"^",2),ICDLOS=$P(WT,"^",3),ICDHIGH=$P(WT,"^",4),ICDWWU=$P(WT,"^",5)

MORE ;- Set zero node with FY 97 stats

 S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS

 D FY

REVDRG ;- Description edits

 ;;DRG104^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W CARD CATH

 ;;DRG105^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W/O CARD CATH

 ;;DRG106^CORONARY BYPASS WITH PTCA^1^5

 ;;DRG107^CORONARY BYPASS W CARDIAC CATH^1^5

 ;;DRG109^CORONARY BYPASS W/O CARDIAC CATH^1^5

 ;;DRG115^PERM PACE IMPLNT W AMI,HRT FAIL OR SHOCK OR AICD LEAD OR GEN PROC

 ;;DRG116^OTH PERM CARDIAC PACEMAKER IMPLANT OR PTCA W CORONARY ART STENT

 ;;DRG121^CIRCULATORY DISORDERS W AMI & MAJOR COMP DISCH ALIVE

 ;;DRG122^CIRCULATORY DISORDERS W AMI W/O MAJOR COMP DISCH ALIVE

 ;;DRG406^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W CC

 ;;DRG407^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W/O CC

 ;;DRG485^LIMB REATTACHMENT, HIP AND FEMUR PROC FOR MULTIPLE SIGNIFICANT TR

 ;;DRG214^NO LONGER VALID

 ;;DRG215^NO LONGER VALID

 ;;DRG221^NO LONGER VALID

 ;;DRG222^NO LONGER VALID

 ;;DRG456^NO LONGER VALID

 ;;DRG457^NO LONGER VALID

 ;;DRG458^NO LONGER VALID

 ;;DRG459^NO LONGER VALID

 ;;DRG460^NO LONGER VALID

 ;;DRG472^NO LONGER VALID

 ;;QUIT

REMXDRG ;- DRG dup "B" xref IENs

 ;;11

 ;;48

 ;;53

 ;;54

 ;;89

 ;;90

 ;;91

 ;;104

 ;;105

 ;;116

 ;;193

 ;;194

 ;;195

 ;;196

 ;;197

 ;;198

 ;;384

 ;;410

 ;;444

 ;;445

 ;;446

 ;;461

 ;;477

 ;;482

 ;;483

 ;;485

 ;;486

 ;;488

 ;;490

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD18PT   4669     printed  Apr 23, 2025@18:04:25                                                                                                                                                                                                     Page 2

ICD18PT   ;ALB/ESD - DRG V16 POST-INSTALL ; 10/23/00 11:57am

 +1       ;;18.0;DRG Grouper;;Oct 20, 2000

 +2       ;

 +3       ;

 +4       ;  This routine may be re-run.

 +5       ;

EN        ;- Post-Install entry point

 +1       ;

 +2       ;- Remove dup "B" xrefs from Description multiple

 +3       ;D REMXREF

 +4       ;

 +5       ;- Revise DRGs/new descriptions, or changed to Inactie

 +6       ;D DRGEDIT

 +7       ;

 +8       ;- Weights & trims for FY 97

 +9       ;D BEGWT

 +10      ;

 +11      ;- Display reminder msg

 +12       DO BMES^XPDUTL(">>>  IMPORTANT:  Please restore your ICD9 and ICD0 global files from  <<<")

 +13       DO MES^XPDUTL(">>>              ICD9_18.GBL and ICD0_18.GBL at this time.        <<<")

 +14       QUIT

 +15      ;

 +16      ;

REMXREF   ;- Remove dup "B" xref on Description multiple and reindex

 +1       ;

 +2        NEW DA,DIK,I,ICDIEN

 +3        DO MES^XPDUTL("")

 +4        DO BMES^XPDUTL(">>>  Correcting duplicate ""B"" cross-ref entries in the Description")

 +5        DO MES^XPDUTL("     multiple of the DRG file (#80.2)...")

 +6        FOR I=1:1

               SET ICDIEN=$PIECE($TEXT(REMXDRG+I),";;",2)

               if ICDIEN="QUIT"

                   QUIT

               Begin DoDot:1

 +7                KILL ^ICD(ICDIEN,1,"B")

 +8                SET DA(1)=ICDIEN

                   SET DA=1

 +9                SET DIK="^ICD("_DA(1)_",1,"

 +10               SET DIK(1)=".01^B"

 +11               DO EN1^DIK

               End DoDot:1

 +12       DO MES^XPDUTL(">>>  ...completed.")

 +13       DO MES^XPDUTL("")

 +14       QUIT

 +15      ;

 +16      ;

DRGEDIT   ;- Edit DRG records (Description change)

 +1       ;

 +2        NEW CNT,DA,DIC,DIE,DR,DRG,I,ICDI,ICDIEN,ICDESC,NOVAL,X,Y

 +3        SET CNT=0

 +4        DO BMES^XPDUTL(">>>  Revising DRG records in the DRG file (#80.2)...")

 +5        FOR I=1:1

               SET DRG=$PIECE($TEXT(REVDRG+I),";;",2)

               if DRG="QUIT"

                   QUIT

               Begin DoDot:1

 +6                SET DIC="^ICD("

                   SET DIC(0)="MX"

 +7                SET X=$PIECE(DRG,"^")

 +8                DO ^DIC

 +9                IF +Y>0

                       Begin DoDot:2

 +10                       SET ICDESC=""

 +11                       FOR

                               SET ICDESC=$ORDER(^ICD(+Y,1,"B",ICDESC))

                               if ICDESC=""

                                   QUIT

                               SET ICDIEN=+$ORDER(^(ICDESC,0))

 +12                       SET (ICDI,DA(1))=+Y

                           SET DA=ICDIEN

 +13                       SET DIE=DIC_DA(1)_","_DA_","

 +14                       SET DR=".01///^S X=$P(DRG,""^"",2)"

 +15                       DO ^DIE

 +16                       Begin DoDot:3

 +17                           IF $PIECE(DRG,"^",3)=""

                                   QUIT

 +18                           SET DIE=DIC

 +19                           SET DA=ICDI

 +20                           SET DR=".06///^S X=$P(DRG,""^"",3);5///^S X=$P(DRG,""^"",4)"

 +21                           DO ^DIE

                           End DoDot:3

 +22                       SET CNT=CNT+1

 +23                       DO MES^XPDUTL("  Edited: "_$PIECE(DRG,"^")_" to "_$PIECE(DRG,"^",2))

                       End DoDot:2

 +24              IF '$TEST

                       DO ERRMSG($PIECE(DRG,"^"))

               End DoDot:1

 +25      ;

 +26      ;- Total DRG records revised

 +27       DO MES^XPDUTL(">>>  ...completed.  "_CNT_" record(s) revised.")

 +28       DO MES^XPDUTL("")

 +29       QUIT

 +30      ;

 +31      ;

ERRMSG(VAR,IN) ;- Display error msg if DRG not found

 +1       ;

 +2        if VAR=""

               QUIT

 +3        DO BMES^XPDUTL(">>>  ERROR:  "_VAR_"  was not found and could not be "_$SELECT(+$GET(IN):"inactivated.",1:"revised."))

 +4        DO MES^XPDUTL("")

 +5        QUIT

 +6       ;

 +7       ;

BEGWT     ;- Entry point for wts & trims update for 97

 +1        NEW DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J

 +2        DO UPD97

 +3        QUIT

 +4       ;

 +5       ;

UPD97     ;- Load FY 97 WWU into ICD DRG file (#80.2)

 +1        SET FYR=2970000

 +2        DO BMES^XPDUTL(">>>  Adding FY 97 Weights & Trims...")

 +3        FOR I=1:1

               SET WT=$PIECE($TEXT(WW97+I^ICD16P97),";;",2,99)

               if 'WT

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

 +4        FOR I=1:1

               SET WT=$PIECE($TEXT(WW97+I^ICD1697A),";;",2,99)

               if 'WT

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

 +5        SET ^ICD("AFY",2970000)=""

 +6        DO MES^XPDUTL(">>>  ...completed.")

 +7        DO MES^XPDUTL("")

 +8        QUIT

 +9       ;

 +10      ;

FY        ;- Set FY multiple with FYR stats

 +1        SET $PIECE(^ICD(DRG,"FY",FYR,0),"^",1,4)=FYR_"^"_ICDWWU_"^"_ICDLOW_"^"_ICDHIGH

           SET $PIECE(^(0),"^",9)=ICDLOS

 +2        IF '$DATA(^ICD(DRG,"FY",0))

               SET ^ICD(DRG,"FY",0)="^80.22^"_FYR_"^1"

               QUIT

 +3        SET ICDCNT=""

           FOR J=0:1

               SET ICDCNT=$ORDER(^ICD(DRG,"FY",ICDCNT))

               if ICDCNT=""

                   QUIT

 +4        SET $PIECE(^ICD(DRG,"FY",0),"^",3,4)=FYR_"^"_J

 +5        QUIT

 +6       ;

 +7       ;

SETVAR    ;- Set variables

 +1        SET DRG=+WT

           SET ICDLOW=$PIECE(WT,"^",2)

           SET ICDLOS=$PIECE(WT,"^",3)

           SET ICDHIGH=$PIECE(WT,"^",4)

           SET ICDWWU=$PIECE(WT,"^",5)

 +2        QUIT

 +3       ;

 +4       ;

MORE      ;- Set zero node with FY 97 stats

 +1        SET $PIECE(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH

           SET $PIECE(^(0),"^",8)=ICDLOS

 +2        DO FY

 +3        QUIT

 +4       ;

 +5       ;

REVDRG    ;- Description edits

 +1       ;;DRG104^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W CARD CATH

 +2       ;;DRG105^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W/O CARD CATH

 +3       ;;DRG106^CORONARY BYPASS WITH PTCA^1^5

 +4       ;;DRG107^CORONARY BYPASS W CARDIAC CATH^1^5

 +5       ;;DRG109^CORONARY BYPASS W/O CARDIAC CATH^1^5

 +6       ;;DRG115^PERM PACE IMPLNT W AMI,HRT FAIL OR SHOCK OR AICD LEAD OR GEN PROC

 +7       ;;DRG116^OTH PERM CARDIAC PACEMAKER IMPLANT OR PTCA W CORONARY ART STENT

 +8       ;;DRG121^CIRCULATORY DISORDERS W AMI & MAJOR COMP DISCH ALIVE

 +9       ;;DRG122^CIRCULATORY DISORDERS W AMI W/O MAJOR COMP DISCH ALIVE

 +10      ;;DRG406^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W CC

 +11      ;;DRG407^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W/O CC

 +12      ;;DRG485^LIMB REATTACHMENT, HIP AND FEMUR PROC FOR MULTIPLE SIGNIFICANT TR

 +13      ;;DRG214^NO LONGER VALID

 +14      ;;DRG215^NO LONGER VALID

 +15      ;;DRG221^NO LONGER VALID

 +16      ;;DRG222^NO LONGER VALID

 +17      ;;DRG456^NO LONGER VALID

 +18      ;;DRG457^NO LONGER VALID

 +19      ;;DRG458^NO LONGER VALID

 +20      ;;DRG459^NO LONGER VALID

 +21      ;;DRG460^NO LONGER VALID

 +22      ;;DRG472^NO LONGER VALID

 +23      ;;QUIT

 +24      ;

 +25      ;

REMXDRG   ;- DRG dup "B" xref IENs

 +1       ;;11

 +2       ;;48

 +3       ;;53

 +4       ;;54

 +5       ;;89

 +6       ;;90

 +7       ;;91

 +8       ;;104

 +9       ;;105

 +10      ;;116

 +11      ;;193

 +12      ;;194

 +13      ;;195

 +14      ;;196

 +15      ;;197

 +16      ;;198

 +17      ;;384

 +18      ;;410

 +19      ;;444

 +20      ;;445

 +21      ;;446

 +22      ;;461

 +23      ;;477

 +24      ;;482

 +25      ;;483

 +26      ;;485

 +27      ;;486

 +28      ;;488

 +29      ;;490

 +30      ;;QUIT

ICD18PT.m