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
;
Q
;
BEGWT01 ;- Entry point for wts & trims update for FY 2002
N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
D UPD01
Q
;
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("")
Q
;
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
Q
;
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)
Q
;
MORE ;- Set zero node with FY 2002 stats
S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD183P 1836 printed Nov 22, 2024@16:58:57 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 ;
