Routine: ICD183P

ICD183P ;ALB/ESD/JAT - ICD/DRG; 11/15/01 9:07am ; 12/3/01 4:17pm

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

EN ;- Pre-Install entry point

 ;- revise Diagnoses

 D CHGDIAG^ICD183P3

 ;  first need to create routines ICD183PA,B,C

 ;  from DRG Pricer file from Austin

 ;  (see ICD182PA,B,C from 2001)

 ; - Weights & trims for FY 2002

 D BEGWT01

BEGWT01 ;- Entry point for wts & trims update for FY 2002

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

 D UPD01

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

 S FYR=3020000

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

 Q:$D(^ICD(523,"FY",3020000,0))

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

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

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

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

 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)

MORE ;- Set zero node with FY 2002 stats

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD183P   1836     printed  Mar 13, 2025@20:53:25                                                                                                                                                                                                     Page 2

ICD183P   ;ALB/ESD/JAT - ICD/DRG; 11/15/01 9:07am ; 12/3/01 4:17pm

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

 +2       ;

 +3       ;

EN        ;- Pre-Install entry point

 +1       ;

 +2       ;- revise Diagnoses

 +3        DO CHGDIAG^ICD183P3

 +4       ;

 +5       ;  first need to create routines ICD183PA,B,C

 +6       ;  from DRG Pricer file from Austin

 +7       ;  (see ICD182PA,B,C from 2001)

 +8       ;

 +9       ; - Weights & trims for FY 2002

 +10       DO BEGWT01

 +11      ;

 +12       QUIT

 +13      ;

BEGWT01   ;- Entry point for wts & trims update for FY 2002

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

 +2        DO UPD01

 +3        QUIT

 +4       ;

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

 +1        SET FYR=3020000

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

 +3        if $DATA(^ICD(523,"FY",3020000,0))

               QUIT

 +4        FOR I=1:1

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

               if I>200

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

 +5        FOR I=1:1

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

               if I>200

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

 +6        FOR I=1:1

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

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

                   QUIT

               DO SETVAR

               DO FY

               DO MORE

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

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

 +9        DO MES^XPDUTL("")

 +10       QUIT

 +11      ;

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       ;

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        QUIT

 +5       ;

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       ;

ICD183P.m