Routine: ICD185P

ICD185P ;ALB/MRY - ICD/DRG; 10/17/02 2:43pm

 ;;18.0;DRG Grouper;**5**;Oct 13,2000

 ; Taken from ICD182P with the exception of updates released

 ; in ICD184P.

EN ;- Post-Install entry point

 ; - Add new DRGs

 D ADDDRG^ICD185P1

 S ^DD(80.2,0,"VR")="20.0"

 ;- Inactivate/revise DRGS

 D DRGEDIT

 ;- DRG reclassification changes

 D EN^ICD185P4

 ; - Weights & trims for FY 2002

 D BEGWT01

 ;- Update Diagnoses w/complications/comorbidities

 D EN^ICD185P5

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("")

BEGWT01 ;- Entry point for wts & trims update for 2003

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

 D UPD01

UPD01 ;- Load FY 2003 into ICD DRG file (#80.2)

 S FYR=3030000

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

 Q:$D(^ICD(527,"FY",3030000,0))

 F I=1:1 S WT=$P($T(WEIGHTS+I^ICD185PA),";;",2,99) Q:I>200  D SETVAR,FY,MORE

 F I=1:1 S WT=$P($T(WEIGHTS+I^ICD185PB),";;",2,99) Q:I>200  D SETVAR,FY,MORE

 F I=1:1 S WT=$P($T(WEIGHTS+I^ICD185PC),";;",2,99) Q:$E(WT,1,3)="END"  D SETVAR,FY,MORE

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

 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=$E(WT,1,3),ICDLOW=1,ICDLOS=$E(WT,12,14),ICDHIGH=$E(WT,16,17),ICDWWU=$E(WT,5,10)

DRG I $E(DRG,1)=0 S DRG=$E(DRG,2,3) G DRG

 S ICDLOS=$E(ICDLOS,1,2)_"."_$E(ICDLOS,3) I $E(ICDLOS,1)=0 S ICDLOS=$E(ICDLOS,2,4)

 I $E(ICDHIGH,1)=0 S ICDHIGH=$E(ICDHIGH,2)

 S ICDWWU=$E(ICDWWU,1,2)_"."_$E(ICDWWU,3,6) I $E(ICDWWU,1)=0 S ICDWWU=$E(ICDWWU,2,7)

 ; if HIGH-TRIM is .0 use last year's FY02 value.  If new DRG, use 99

 I ICDHIGH["." D

 .S ICDHIGH=$S(DRG=524!(DRG=525)!(DRG=526)!(DRG=527):99,1:ICDHIGH) I ICDHIGH=99 Q

 .I $D(^ICD(DRG,"FY",3020000,0)) S ICDHIGH=$P(^(0),"^",4)

MORE ;- Set zero node with FY 2002 stats

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

REVDRG ;- Description edits

 ;;DRG1^CRANIOTOMY AGE>17 W CC

 ;;DRG2^CRANIOTOMY AGE>17 W/O CC

 ;;DRG14^INTRACRANIAL HEMORRHAGE & STROKE W INFARCT

 ;;DRG15^NONSPECIFIC CVA & PRECEREBRAL OCCLUSION W/O INFARCT

 ;;DRG483^TRACH W MECH VENT 96+ HRS OR PDX EXCEPT FACE,MOUTH & NECK DIAG

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD185P   3653     printed  Apr 23, 2025@18:03:27                                                                                                                                                                                                     Page 2

ICD185P   ;ALB/MRY - ICD/DRG; 10/17/02 2:43pm

 +1       ;;18.0;DRG Grouper;**5**;Oct 13,2000

 +2       ;

 +3       ; Taken from ICD182P with the exception of updates released

 +4       ; in ICD184P.

 +5       ;

EN        ;- Post-Install entry point

 +1       ;

 +2       ; - Add new DRGs

 +3        DO ADDDRG^ICD185P1

 +4        SET ^DD(80.2,0,"VR")="20.0"

 +5       ;

 +6       ;- Inactivate/revise DRGS

 +7        DO DRGEDIT

 +8       ;

 +9       ;- DRG reclassification changes

 +10       DO EN^ICD185P4

 +11      ;

 +12      ; - Weights & trims for FY 2002

 +13       DO BEGWT01

 +14      ;

 +15      ;- Update Diagnoses w/complications/comorbidities

 +16       DO EN^ICD185P5

 +17      ;

 +18       QUIT

 +19      ;

 +20      ;

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       ;

BEGWT01   ;- Entry point for wts & trims update for 2003

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

 +2        DO UPD01

 +3        QUIT

 +4       ;

 +5       ;

UPD01     ;- Load FY 2003 into ICD DRG file (#80.2)

 +1        SET FYR=3030000

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

 +3        if $DATA(^ICD(527,"FY",3030000,0))

               QUIT

 +4        FOR I=1:1

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

               if I>200

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

 +5        FOR I=1:1

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

               if I>200

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

 +6        FOR I=1:1

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

               if $EXTRACT(WT,1,3)="END"

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

 +7        SET ^ICD("AFY",3030000)=""

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

 +9        DO MES^XPDUTL("")

 +10       QUIT

 +11      ;

 +12      ;

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=$EXTRACT(WT,1,3)

           SET ICDLOW=1

           SET ICDLOS=$EXTRACT(WT,12,14)

           SET ICDHIGH=$EXTRACT(WT,16,17)

           SET ICDWWU=$EXTRACT(WT,5,10)

DRG        IF $EXTRACT(DRG,1)=0

               SET DRG=$EXTRACT(DRG,2,3)

               GOTO DRG

 +1        SET ICDLOS=$EXTRACT(ICDLOS,1,2)_"."_$EXTRACT(ICDLOS,3)

           IF $EXTRACT(ICDLOS,1)=0

               SET ICDLOS=$EXTRACT(ICDLOS,2,4)

 +2        IF $EXTRACT(ICDHIGH,1)=0

               SET ICDHIGH=$EXTRACT(ICDHIGH,2)

 +3        SET ICDWWU=$EXTRACT(ICDWWU,1,2)_"."_$EXTRACT(ICDWWU,3,6)

           IF $EXTRACT(ICDWWU,1)=0

               SET ICDWWU=$EXTRACT(ICDWWU,2,7)

 +4       ; if HIGH-TRIM is .0 use last year's FY02 value.  If new DRG, use 99

 +5        IF ICDHIGH["."

               Begin DoDot:1

 +6                SET ICDHIGH=$SELECT(DRG=524!(DRG=525)!(DRG=526)!(DRG=527):99,1:ICDHIGH)

                   IF ICDHIGH=99

                       QUIT

 +7                IF $DATA(^ICD(DRG,"FY",3020000,0))

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

               End DoDot:1

 +8        QUIT

 +9       ;

 +10      ;

MORE      ;- Set zero node with FY 2002 stats

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

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

 +2        QUIT

 +3       ;

 +4       ;

REVDRG    ;- Description edits

 +1       ;;DRG1^CRANIOTOMY AGE>17 W CC

 +2       ;;DRG2^CRANIOTOMY AGE>17 W/O CC

 +3       ;;DRG14^INTRACRANIAL HEMORRHAGE & STROKE W INFARCT

 +4       ;;DRG15^NONSPECIFIC CVA & PRECEREBRAL OCCLUSION W/O INFARCT

 +5       ;;DRG483^TRACH W MECH VENT 96+ HRS OR PDX EXCEPT FACE,MOUTH & NECK DIAG

 +6       ;;QUIT

 +7       ;

 +8       ;

ICD185P.m