ICD15PT ;ABR/ALB - POST-INIT FOR DRG 15 ; 5 JAN 1998
;;15.0;DRG Grouper;;Feb 23, 1998
;
; This routine updates the FY entries in the DRG file (#80.2) to
; make them Y2K compatible. All 2-digit FYs have been changed to the
; FileMan 3-digit entry (e.g. '91' becomes '291')
;
; The Break-even nodes were similarly corrected, with the 3-digit
; FY preceding the 1-4 quarter indicator.
; E.g. - '871' becomes '2871' for 1st quarter, 1987.
;
; Reference routines are added for the new DRGs that were added
; to the DRG file as part of patch ICD*14*2 - DRGs 496-503.
;
; BEGST adds the 1995 and 1996
; Weights & Trims to the DRG file.
;
; This routine may be re-run.
;
EN ; POST-INSTALL ENTRY POINT
D DRGREF
D DRGFIELD ; delete starred field 8 from DRG file
D FYUPD
D BEGWT
D BMES^XPDUTL("*** Please restore your ICD9 and ICD0 global files from ***")
D MES^XPDUTL("*** ICD9_15.GBL and ICD0_15.GBL at this time. ***")
Q
DRGREF ; add routine reference to new DRGs
N DRG
F DRG=496:1:503 S ^ICD(DRG,"MC1")="ICDTLB6"
Q
DRGFIELD ; delete starred field from DRG file
N DIK,DA,I
D BMES^XPDUTL(">>> Deleting obsolete MUMPS CODE field from DRG file.")
S DIK="^DD(80.2,",DA=8,DA(1)=80.2
D ^DIK
; kill old data from deleted field
D BMES^XPDUTL(">>> Deleting data from obsolete MUMPS CODE field")
F I=0:0 S I=$O(^ICD(I)) Q:'I K ^ICD(I,"MC")
Q
FYUPD ; change FY for weights & trims, break-evens to FM format
S U="^"
N DRG,FY
D BMES^XPDUTL(">> Updating FY nodes for Year 2000 compatibility.")
F DRG=0:0 S DRG=$O(^ICD(DRG)) Q:'DRG D
. I $D(^ICD(DRG,"FY")) D WTUP(DRG) ; update wts/trims nodes
. I $D(^ICD(DRG,"BE")) D BEUP(DRG) ; update break-even nodes
F FY=0:0 S FY=$O(^ICD("AFY",FY)) Q:'FY!(FY>500) D
. N X,Y,%DT S X=FY D ^%DT
. S ^ICD("AFY",Y)="" K ^(FY)
Q
WTUP(DRG) ; change wts/trims FY to FM FY references
N FY,FMFY
F FY=0:0 S FY=$O(^ICD(DRG,"FY",FY)) Q:'FY!(FY>500) D
. S FMFY=$S(FY>500:FY,1:(FY+200)_"0000")
. S ^ICD(DRG,"FY",FMFY,0)=FMFY_U_$P(^ICD(DRG,"FY",FY,0),U,2,99)
. I FY'=FMFY K ^ICD(DRG,"FY",FY)
S:$G(FMFY) $P(^ICD(DRG,"FY",0),U,3)=FMFY
Q
BEUP(DRG) ;change break-even FY to FM FY references
N BE,FMBE
F BE=0:0 S BE=$O(^ICD(DRG,"BE",BE)) Q:'BE!(BE>10000) D
. S FMBE=$S(BE>10000:BE,1:BE+19000)
. S X=$G(^ICD(DRG,"BE",BE,0)) I X]"" S ^ICD(DRG,"BE",FMBE,0)=FMBE_U_$P(X,U,2,99)
. I $D(^ICD(DRG,"BE",BE,"S")) D SERVICE
. I BE'=FMBE K ^ICD(DRG,"BE",BE)
S:$G(FMBE) $P(^ICD(DRG,"BE",0),U,3)=FMBE
Q
SERVICE ; update services for break-evens
N SVC,X
S X=$G(^ICD(DRG,"BE",BE,"S",0)) I X]"" S ^ICD(DRG,"BE",FMBE,"S",0)=X
I $O(^ICD(DRG,"BE",BE,"S",0)) F SVC=1:1:5 S X=$G(^ICD(DRG,"BE",BE,"S",SVC,0)) I X S ^ICD(DRG,"BE",FMBE,"S",SVC,0)=X
Q
;
BEGWT ; entry point for wts & trims update for 95
N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
D UPD95
D UPD96
Q
UPD95 ; load fy 95 wwu into ICD DRG file (80.2)
S FYR=2950000
D MES^XPDUTL(">> Adding FY 95 Weights & Trims.")
F I=1:1 S WT=$P($T(WW95+I^ICD15P95),";;",2,99) Q:'WT D SETVAR,FY
F I=1:1 S WT=$P($T(WW95+I^ICD1595A),";;",2,99) Q:'WT D SETVAR,FY
S ^ICD("AFY",2950000)=""
Q
UPD96 ; load fy 96 wwu into ICD DRG file (80.2)
S FYR=2960000
D MES^XPDUTL(">> Adding FY 96 Weights & Trims.")
F I=1:1 S WT=$P($T(WW96+I^ICD15P96),";;",2,99) Q:'WT D SETVAR,FY,MORE
F I=1:1 S WT=$P($T(WW96+I^ICD1596A),";;",2,99) Q:'WT D SETVAR,FY,MORE
S ^ICD("AFY",2960000)=""
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=+WT,ICDLOW=$P(WT,U,2),ICDLOS=$P(WT,U,3),ICDHIGH=$P(WT,U,4),ICDWWU=$P(WT,U,5)
Q
MORE ;set 0 node with FY 96 stats
S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
D FY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD15PT 4048 printed Dec 13, 2024@01:47:39 Page 2
ICD15PT ;ABR/ALB - POST-INIT FOR DRG 15 ; 5 JAN 1998
+1 ;;15.0;DRG Grouper;;Feb 23, 1998
+2 ;
+3 ; This routine updates the FY entries in the DRG file (#80.2) to
+4 ; make them Y2K compatible. All 2-digit FYs have been changed to the
+5 ; FileMan 3-digit entry (e.g. '91' becomes '291')
+6 ;
+7 ; The Break-even nodes were similarly corrected, with the 3-digit
+8 ; FY preceding the 1-4 quarter indicator.
+9 ; E.g. - '871' becomes '2871' for 1st quarter, 1987.
+10 ;
+11 ; Reference routines are added for the new DRGs that were added
+12 ; to the DRG file as part of patch ICD*14*2 - DRGs 496-503.
+13 ;
+14 ; BEGST adds the 1995 and 1996
+15 ; Weights & Trims to the DRG file.
+16 ;
+17 ; This routine may be re-run.
+18 ;
EN ; POST-INSTALL ENTRY POINT
+1 DO DRGREF
+2 ; delete starred field 8 from DRG file
DO DRGFIELD
+3 DO FYUPD
+4 DO BEGWT
+5 DO BMES^XPDUTL("*** Please restore your ICD9 and ICD0 global files from ***")
+6 DO MES^XPDUTL("*** ICD9_15.GBL and ICD0_15.GBL at this time. ***")
+7 QUIT
DRGREF ; add routine reference to new DRGs
+1 NEW DRG
+2 FOR DRG=496:1:503
SET ^ICD(DRG,"MC1")="ICDTLB6"
+3 QUIT
DRGFIELD ; delete starred field from DRG file
+1 NEW DIK,DA,I
+2 DO BMES^XPDUTL(">>> Deleting obsolete MUMPS CODE field from DRG file.")
+3 SET DIK="^DD(80.2,"
SET DA=8
SET DA(1)=80.2
+4 DO ^DIK
+5 ; kill old data from deleted field
+6 DO BMES^XPDUTL(">>> Deleting data from obsolete MUMPS CODE field")
+7 FOR I=0:0
SET I=$ORDER(^ICD(I))
if 'I
QUIT
KILL ^ICD(I,"MC")
+8 QUIT
FYUPD ; change FY for weights & trims, break-evens to FM format
+1 SET U="^"
+2 NEW DRG,FY
+3 DO BMES^XPDUTL(">> Updating FY nodes for Year 2000 compatibility.")
+4 FOR DRG=0:0
SET DRG=$ORDER(^ICD(DRG))
if 'DRG
QUIT
Begin DoDot:1
+5 ; update wts/trims nodes
IF $DATA(^ICD(DRG,"FY"))
DO WTUP(DRG)
+6 ; update break-even nodes
IF $DATA(^ICD(DRG,"BE"))
DO BEUP(DRG)
End DoDot:1
+7 FOR FY=0:0
SET FY=$ORDER(^ICD("AFY",FY))
if 'FY!(FY>500)
QUIT
Begin DoDot:1
+8 NEW X,Y,%DT
SET X=FY
DO ^%DT
+9 SET ^ICD("AFY",Y)=""
KILL ^(FY)
End DoDot:1
+10 QUIT
WTUP(DRG) ; change wts/trims FY to FM FY references
+1 NEW FY,FMFY
+2 FOR FY=0:0
SET FY=$ORDER(^ICD(DRG,"FY",FY))
if 'FY!(FY>500)
QUIT
Begin DoDot:1
+3 SET FMFY=$SELECT(FY>500:FY,1:(FY+200)_"0000")
+4 SET ^ICD(DRG,"FY",FMFY,0)=FMFY_U_$PIECE(^ICD(DRG,"FY",FY,0),U,2,99)
+5 IF FY'=FMFY
KILL ^ICD(DRG,"FY",FY)
End DoDot:1
+6 if $GET(FMFY)
SET $PIECE(^ICD(DRG,"FY",0),U,3)=FMFY
+7 QUIT
BEUP(DRG) ;change break-even FY to FM FY references
+1 NEW BE,FMBE
+2 FOR BE=0:0
SET BE=$ORDER(^ICD(DRG,"BE",BE))
if 'BE!(BE>10000)
QUIT
Begin DoDot:1
+3 SET FMBE=$SELECT(BE>10000:BE,1:BE+19000)
+4 SET X=$GET(^ICD(DRG,"BE",BE,0))
IF X]""
SET ^ICD(DRG,"BE",FMBE,0)=FMBE_U_$PIECE(X,U,2,99)
+5 IF $DATA(^ICD(DRG,"BE",BE,"S"))
DO SERVICE
+6 IF BE'=FMBE
KILL ^ICD(DRG,"BE",BE)
End DoDot:1
+7 if $GET(FMBE)
SET $PIECE(^ICD(DRG,"BE",0),U,3)=FMBE
+8 QUIT
SERVICE ; update services for break-evens
+1 NEW SVC,X
+2 SET X=$GET(^ICD(DRG,"BE",BE,"S",0))
IF X]""
SET ^ICD(DRG,"BE",FMBE,"S",0)=X
+3 IF $ORDER(^ICD(DRG,"BE",BE,"S",0))
FOR SVC=1:1:5
SET X=$GET(^ICD(DRG,"BE",BE,"S",SVC,0))
IF X
SET ^ICD(DRG,"BE",FMBE,"S",SVC,0)=X
+4 QUIT
+5 ;
BEGWT ; entry point for wts & trims update for 95
+1 NEW DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
+2 DO UPD95
+3 DO UPD96
+4 QUIT
UPD95 ; load fy 95 wwu into ICD DRG file (80.2)
+1 SET FYR=2950000
+2 DO MES^XPDUTL(">> Adding FY 95 Weights & Trims.")
+3 FOR I=1:1
SET WT=$PIECE($TEXT(WW95+I^ICD15P95),";;",2,99)
if 'WT
QUIT
DO SETVAR
DO FY
+4 FOR I=1:1
SET WT=$PIECE($TEXT(WW95+I^ICD1595A),";;",2,99)
if 'WT
QUIT
DO SETVAR
DO FY
+5 SET ^ICD("AFY",2950000)=""
+6 QUIT
UPD96 ; load fy 96 wwu into ICD DRG file (80.2)
+1 SET FYR=2960000
+2 DO MES^XPDUTL(">> Adding FY 96 Weights & Trims.")
+3 FOR I=1:1
SET WT=$PIECE($TEXT(WW96+I^ICD15P96),";;",2,99)
if 'WT
QUIT
DO SETVAR
DO FY
DO MORE
+4 FOR I=1:1
SET WT=$PIECE($TEXT(WW96+I^ICD1596A),";;",2,99)
if 'WT
QUIT
DO SETVAR
DO FY
DO MORE
+5 SET ^ICD("AFY",2960000)=""
+6 QUIT
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
SETVAR ; SET VARIABLES
+1 SET DRG=+WT
SET ICDLOW=$PIECE(WT,U,2)
SET ICDLOS=$PIECE(WT,U,3)
SET ICDHIGH=$PIECE(WT,U,4)
SET ICDWWU=$PIECE(WT,U,5)
+2 QUIT
MORE ;set 0 node with FY 96 stats
+1 SET $PIECE(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH
SET $PIECE(^(0),"^",8)=ICDLOS
+2 DO FY
+3 QUIT
