ICD1824A ;;ALB/EG/JAT - FY 2007 UPDATE; 6/19/05 4:08pm ; 6/24/05 3:29pm
;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 5
;
Q
;
ADDDRG ; add new DRGs
N DIC,X,Y,DINUM,LINE,ICDDRG,DA,DRGX,DRGY,MDC,SURG,ROUTINE,ICDIEN
D BMES^XPDUTL(">>> Adding New DRGs - Please verify that 20 were added")
; create top-level record (relative weights & average length of stay (ALOS) will be added later)
F LINE=1:1 S X=$T(ADD+LINE) S ICDDRG=$P(X,";;",2) Q:ICDDRG="EXIT" D
.S DIC="^ICD(",DIC(0)="L"
.S MDC=$P(ICDDRG,U,2) I MDC="PRE" S MDC=98
.S SURG=$P(ICDDRG,U,3)
.S DIC("DR")="5///^S X=MDC;.06///^S X=SURG"
.S X="DRG",X=X_$P(ICDDRG,U)
.; check for duplicates in case install is being rerun
.I $D(^ICD($P(ICDDRG,U),0)) Q
.K DO D FILE^DICN
.K DIC,DA
.;create 80.21A subfile
.S DA(1)=$P(ICDDRG,U)
.S DIC="^ICD("_DA(1)_",1,"
.S DIC(0)="L"
.S X=$P(ICDDRG,U,4)
.K DO D FILE^DICN
.;create 80.266 subfile
.K DIC,DA
.S DA(1)=$P(ICDDRG,U)
.S DIC="^ICD("_DA(1)_",66,"
.S DIC(0)="L"
.I SURG="" S SURG=0
.S DIC("DR")=".03///1;.05///^S X=MDC;.06///^S X=SURG"
.S X=3061001
.K DO D FILE^DICN
.; create 80.271 subfile
.K DIC,DA
.S DA(1)=$P(ICDDRG,U)
.S DIC="^ICD("_DA(1)_",2,"
.S DIC(0)="L"
.S ROUTINE="ICDTLB6C"
.S DIC("DR")="1///^S X=ROUTINE"
.S X=3061001
.K DO D FILE^DICN
.; create 80.268 and 80.2681 subfiles
.K DIC,DA
.N FDA
.S ICDIEN=$P(ICDDRG,U)
.S FDA(1820,80.2,"?1,",.01)=ICDIEN
.S FDA(1820,80.268,"+2,?1,",.01)=3061001
.D UPDATE^DIE("","FDA(1820)") K FDA(1820)
.S FDA(1820,80.2,"?1,",.01)=ICDIEN
.S FDA(1820,80.268,"?2,?1,",.01)=3061001
.S FDA(1820,80.2681,"+3,?2,?1,",.01)=$P(ICDDRG,U,4)
.D UPDATE^DIE("","FDA(1820)")
.; displays listing
.S DRGX=$P(ICDDRG,U),DRGY=$P(ICDDRG,U,4)
.D MES^XPDUTL(" DRG"_DRGX_" "_DRGY)
.Q
; now update entire file for weights & versioning
D UPDTDRG^ICD1824B
; inactivate some DRGs
D INACTDRG^ICD1824B
; modify some DRG titles
D DRGTITLE^ICD1824B
Q
;
ADD ;New DRGs
;;560^1^^BACTERIAL & TUBERCULOUS INFECTIONS OF NERVOUS SYSTEM
;;561^1^^NON-BACTERIAL INFECTIONS OF NERVOUS SYSTEM EXCEPT VIRAL MENINGITIS
;;562^1^^SEIZURE AGE > 17 W CC
;;563^1^^SEIZURE AGE > 17 W/O CC
;;564^1^^HEADACHES AGE >17
;;565^4^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT 96+ HOURS
;;566^6^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT < 96 HOURS
;;567^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROC AGE > 17 W CC W MAJOR GI DX
;;568^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROCEDURES PROC AGE > 17 W CC W/O MAJOR GI DX
;;569^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W MAJOR GI DX
;;570^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W/O MAJOR GI DX
;;571^6^1^MAJOR ESOPHAGEAL DISORDERS
;;572^8^^MAJOR GASTROINTESTINAL DISORDERS AND PERITONEAL INFECTIONS
;;573^11^1^MAJOR BLADDER PROCEDURES
;;574^16^^MAJOR HEMATOLOGIC/IMMUNOLOGIC DIAG EXC SICKLE CELL CRISIS & COAGUL
;;575^18^^SEPTICEMIA W MV96+ HOURS AGE >17
;;576^18^^SEPTICEMIA W/O MV96+ HOURS AGE >17
;;577^1^1^CAROTID ARTERY STENT PROCEDURE
;;578^18^1^INFECTIOUS & PARASITIC DISEASES W OR PROCEDURE
;;579^18^1^POSTOPERATIVE OR POST-TRAUMATIC INFECTIONS W OR PROCEDURE
;;EXIT
;
PRO ;-update operation/procedure codes
; from Table 6B in Fed Reg - assumes new codes already added by Lexicon
D BMES^XPDUTL(">>>Modifying new op/pro codes - file 80.1")
N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,MDC24,SUBLINE,DATA,FDA
F LINE=1:1 S X=$T(REV+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
.Q:ICDPROC["+"
.S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
.I ENTRY D
..;check for possible inactive dupe
..I $P($G(^ICD0(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",ENTRY)) I 'ENTRY Q
..S DA=ENTRY,DIE="^ICD0("
..;the "O" (not zero) is from the OR column in Table 6B (a "Y" there), rest is as needed
..S IDENT=$P(ICDPROC,U,2)
..S MDC24=$P(ICDPROC,U,3)
..S DR="2///^S X=IDENT;5///^S X=MDC24"
..I IDENT=""&(MDC24="") Q
..D ^DIE
..; check if already created in case patch being re-installed
..Q:$D(^ICD0(ENTRY,2,"B",3061001))
..;add 80.171, 80.1711 and 80.17111 records
..F SUBLINE=1:1 S X=$T(REV+LINE+SUBLINE) S DATA=$P(X,";;",2) Q:DATA'["+" D
...I SUBLINE=1 D
....S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
....S FDA(1820,80.171,"+2,?1,",.01)=3061001
....D UPDATE^DIE("","FDA(1820)") K FDA(1820)
...S DATA=$E(DATA,2,99)
...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
...S FDA(1820,80.171,"?2,?1,",.01)=3061001
...S FDA(1820,80.1711,"+3,?2,?1,",.01)=$P(DATA,U)
...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
...S FDA(1820,80.171,"?2,?1,",.01)=3061001
...S FDA(1820,80.1711,"?3,?2,?1,",.01)=$P(DATA,U)
...S FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$P(DATA,U,2)
...I $P(DATA,U,3) S FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$P(DATA,U,3)
...I $P(DATA,U,4) S FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$P(DATA,U,4)
...I $P(DATA,U,5) S FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$P(DATA,U,5)
...I $P(DATA,U,6) S FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$P(DATA,U,6)
...I $P(DATA,U,7) S FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$P(DATA,U,7)
...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
Q
;
REV ;
;;00.44^^
;;00.56^Op^
;;+5^117^120
;;00.57^O^
;;+5^118^120
;;00.77^^
;;00.85^OM^2
;;+8^471^544
;;+21^442^443
;;+24^485
;;00.86^OM^2
;;+8^471^544
;;+10^292^293
;;+21^442^443
;;+24^485
;;00.87^OM^2
;;+8^471^544
;;+10^292^293
;;+21^442^443
;;+24^485
;;01.28^OQ^1
;;+1^1^2^3^543
;;+17^406^407^539^540
;;+21^442^443
;;+24^484
;;13.90^O^3
;;+2^39
;;+21^442^443
;;+24^486
;;13.91^O^3
;;+2^39
;;+21^442^443
;;+24^486
;;32.23^O^
;;+4^75
;;+17^406^407^539^540
;;32.24^O^
;;+4^76^7
;;32.25^O^
;;+4^75
;;+17^406^407^539^540
;;32.26^O^
;;+4^75
;;33.71^N^
;;+17^412
;;33.78^N^
;;+17^412
;;33.79^N^
;;+17^412
;;35.55^Oo^
;;+5^108
;;36.33^Oo^
;;+5^108
;;36.34^Oo^
;;+5^108
;;37.20^^
;;39.74^OQ^3
;;+1^1^2^3^543
;;+21^442^443
;;+24^486
;;50.23^O^
;;+6^170^171
;;+7^191^192
;;50.24^O^
;;+6^170^171
;;+7^191^192
;;50.25^O^
;;+6^170^171
;;+7^191^192
;;50.26^O^
;;+6^170^171
;;+7^191^192
;;55.32^O^
;;+11^303^304^305
;;55.33^O^
;;+11^303^304^305
;;55.34^O^
;;+11^303^304^305
;;55.35^O^
;;+11^303^304^305
;;68.41^O^
;;+13^354^355^357^358^359
;;+14^375
;;68.49^O^
;;+13^354^355^357^358^359
;;+14^375
;;68.61^O^
;;+13^353
;;+14^375
;;68.69^O^
;;+13^353
;;+14^375
;;68.71^O^
;;+13^353
;;+14^375
;;68.79^O^
;;+13^353
;;+14^375
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1824A 6753 printed Apr 09, 2024@20:56:05 Page 2
ICD1824A ;;ALB/EG/JAT - FY 2007 UPDATE; 6/19/05 4:08pm ; 6/24/05 3:29pm
+1 ;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 5
+2 ;
+3 QUIT
+4 ;
ADDDRG ; add new DRGs
+1 NEW DIC,X,Y,DINUM,LINE,ICDDRG,DA,DRGX,DRGY,MDC,SURG,ROUTINE,ICDIEN
+2 DO BMES^XPDUTL(">>> Adding New DRGs - Please verify that 20 were added")
+3 ; create top-level record (relative weights & average length of stay (ALOS) will be added later)
+4 FOR LINE=1:1
SET X=$TEXT(ADD+LINE)
SET ICDDRG=$PIECE(X,";;",2)
if ICDDRG="EXIT"
QUIT
Begin DoDot:1
+5 SET DIC="^ICD("
SET DIC(0)="L"
+6 SET MDC=$PIECE(ICDDRG,U,2)
IF MDC="PRE"
SET MDC=98
+7 SET SURG=$PIECE(ICDDRG,U,3)
+8 SET DIC("DR")="5///^S X=MDC;.06///^S X=SURG"
+9 SET X="DRG"
SET X=X_$PIECE(ICDDRG,U)
+10 ; check for duplicates in case install is being rerun
+11 IF $DATA(^ICD($PIECE(ICDDRG,U),0))
QUIT
+12 KILL DO
DO FILE^DICN
+13 KILL DIC,DA
+14 ;create 80.21A subfile
+15 SET DA(1)=$PIECE(ICDDRG,U)
+16 SET DIC="^ICD("_DA(1)_",1,"
+17 SET DIC(0)="L"
+18 SET X=$PIECE(ICDDRG,U,4)
+19 KILL DO
DO FILE^DICN
+20 ;create 80.266 subfile
+21 KILL DIC,DA
+22 SET DA(1)=$PIECE(ICDDRG,U)
+23 SET DIC="^ICD("_DA(1)_",66,"
+24 SET DIC(0)="L"
+25 IF SURG=""
SET SURG=0
+26 SET DIC("DR")=".03///1;.05///^S X=MDC;.06///^S X=SURG"
+27 SET X=3061001
+28 KILL DO
DO FILE^DICN
+29 ; create 80.271 subfile
+30 KILL DIC,DA
+31 SET DA(1)=$PIECE(ICDDRG,U)
+32 SET DIC="^ICD("_DA(1)_",2,"
+33 SET DIC(0)="L"
+34 SET ROUTINE="ICDTLB6C"
+35 SET DIC("DR")="1///^S X=ROUTINE"
+36 SET X=3061001
+37 KILL DO
DO FILE^DICN
+38 ; create 80.268 and 80.2681 subfiles
+39 KILL DIC,DA
+40 NEW FDA
+41 SET ICDIEN=$PIECE(ICDDRG,U)
+42 SET FDA(1820,80.2,"?1,",.01)=ICDIEN
+43 SET FDA(1820,80.268,"+2,?1,",.01)=3061001
+44 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
+45 SET FDA(1820,80.2,"?1,",.01)=ICDIEN
+46 SET FDA(1820,80.268,"?2,?1,",.01)=3061001
+47 SET FDA(1820,80.2681,"+3,?2,?1,",.01)=$PIECE(ICDDRG,U,4)
+48 DO UPDATE^DIE("","FDA(1820)")
+49 ; displays listing
+50 SET DRGX=$PIECE(ICDDRG,U)
SET DRGY=$PIECE(ICDDRG,U,4)
+51 DO MES^XPDUTL(" DRG"_DRGX_" "_DRGY)
+52 QUIT
End DoDot:1
+53 ; now update entire file for weights & versioning
+54 DO UPDTDRG^ICD1824B
+55 ; inactivate some DRGs
+56 DO INACTDRG^ICD1824B
+57 ; modify some DRG titles
+58 DO DRGTITLE^ICD1824B
+59 QUIT
+60 ;
ADD ;New DRGs
+1 ;;560^1^^BACTERIAL & TUBERCULOUS INFECTIONS OF NERVOUS SYSTEM
+2 ;;561^1^^NON-BACTERIAL INFECTIONS OF NERVOUS SYSTEM EXCEPT VIRAL MENINGITIS
+3 ;;562^1^^SEIZURE AGE > 17 W CC
+4 ;;563^1^^SEIZURE AGE > 17 W/O CC
+5 ;;564^1^^HEADACHES AGE >17
+6 ;;565^4^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT 96+ HOURS
+7 ;;566^6^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT < 96 HOURS
+8 ;;567^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROC AGE > 17 W CC W MAJOR GI DX
+9 ;;568^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROCEDURES PROC AGE > 17 W CC W/O MAJOR GI DX
+10 ;;569^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W MAJOR GI DX
+11 ;;570^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W/O MAJOR GI DX
+12 ;;571^6^1^MAJOR ESOPHAGEAL DISORDERS
+13 ;;572^8^^MAJOR GASTROINTESTINAL DISORDERS AND PERITONEAL INFECTIONS
+14 ;;573^11^1^MAJOR BLADDER PROCEDURES
+15 ;;574^16^^MAJOR HEMATOLOGIC/IMMUNOLOGIC DIAG EXC SICKLE CELL CRISIS & COAGUL
+16 ;;575^18^^SEPTICEMIA W MV96+ HOURS AGE >17
+17 ;;576^18^^SEPTICEMIA W/O MV96+ HOURS AGE >17
+18 ;;577^1^1^CAROTID ARTERY STENT PROCEDURE
+19 ;;578^18^1^INFECTIOUS & PARASITIC DISEASES W OR PROCEDURE
+20 ;;579^18^1^POSTOPERATIVE OR POST-TRAUMATIC INFECTIONS W OR PROCEDURE
+21 ;;EXIT
+22 ;
PRO ;-update operation/procedure codes
+1 ; from Table 6B in Fed Reg - assumes new codes already added by Lexicon
+2 DO BMES^XPDUTL(">>>Modifying new op/pro codes - file 80.1")
+3 NEW LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,MDC24,SUBLINE,DATA,FDA
+4 FOR LINE=1:1
SET X=$TEXT(REV+LINE)
SET ICDPROC=$PIECE(X,";;",2)
if ICDPROC="EXIT"
QUIT
Begin DoDot:1
+5 if ICDPROC["+"
QUIT
+6 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
+7 IF ENTRY
Begin DoDot:2
+8 ;check for possible inactive dupe
+9 IF $PIECE($GET(^ICD0(ENTRY,0)),U,9)=1
SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",ENTRY))
IF 'ENTRY
QUIT
+10 SET DA=ENTRY
SET DIE="^ICD0("
+11 ;the "O" (not zero) is from the OR column in Table 6B (a "Y" there), rest is as needed
+12 SET IDENT=$PIECE(ICDPROC,U,2)
+13 SET MDC24=$PIECE(ICDPROC,U,3)
+14 SET DR="2///^S X=IDENT;5///^S X=MDC24"
+15 IF IDENT=""&(MDC24="")
QUIT
+16 DO ^DIE
+17 ; check if already created in case patch being re-installed
+18 if $DATA(^ICD0(ENTRY,2,"B",3061001))
QUIT
+19 ;add 80.171, 80.1711 and 80.17111 records
+20 FOR SUBLINE=1:1
SET X=$TEXT(REV+LINE+SUBLINE)
SET DATA=$PIECE(X,";;",2)
if DATA'["+"
QUIT
Begin DoDot:3
+21 IF SUBLINE=1
Begin DoDot:4
+22 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
+23 SET FDA(1820,80.171,"+2,?1,",.01)=3061001
+24 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
End DoDot:4
+25 SET DATA=$EXTRACT(DATA,2,99)
+26 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
+27 SET FDA(1820,80.171,"?2,?1,",.01)=3061001
+28 SET FDA(1820,80.1711,"+3,?2,?1,",.01)=$PIECE(DATA,U)
+29 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
+30 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
+31 SET FDA(1820,80.171,"?2,?1,",.01)=3061001
+32 SET FDA(1820,80.1711,"?3,?2,?1,",.01)=$PIECE(DATA,U)
+33 SET FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$PIECE(DATA,U,2)
+34 IF $PIECE(DATA,U,3)
SET FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$PIECE(DATA,U,3)
+35 IF $PIECE(DATA,U,4)
SET FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$PIECE(DATA,U,4)
+36 IF $PIECE(DATA,U,5)
SET FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$PIECE(DATA,U,5)
+37 IF $PIECE(DATA,U,6)
SET FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$PIECE(DATA,U,6)
+38 IF $PIECE(DATA,U,7)
SET FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$PIECE(DATA,U,7)
+39 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
End DoDot:3
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
REV ;
+1 ;;00.44^^
+2 ;;00.56^Op^
+3 ;;+5^117^120
+4 ;;00.57^O^
+5 ;;+5^118^120
+6 ;;00.77^^
+7 ;;00.85^OM^2
+8 ;;+8^471^544
+9 ;;+21^442^443
+10 ;;+24^485
+11 ;;00.86^OM^2
+12 ;;+8^471^544
+13 ;;+10^292^293
+14 ;;+21^442^443
+15 ;;+24^485
+16 ;;00.87^OM^2
+17 ;;+8^471^544
+18 ;;+10^292^293
+19 ;;+21^442^443
+20 ;;+24^485
+21 ;;01.28^OQ^1
+22 ;;+1^1^2^3^543
+23 ;;+17^406^407^539^540
+24 ;;+21^442^443
+25 ;;+24^484
+26 ;;13.90^O^3
+27 ;;+2^39
+28 ;;+21^442^443
+29 ;;+24^486
+30 ;;13.91^O^3
+31 ;;+2^39
+32 ;;+21^442^443
+33 ;;+24^486
+34 ;;32.23^O^
+35 ;;+4^75
+36 ;;+17^406^407^539^540
+37 ;;32.24^O^
+38 ;;+4^76^7
+39 ;;32.25^O^
+40 ;;+4^75
+41 ;;+17^406^407^539^540
+42 ;;32.26^O^
+43 ;;+4^75
+44 ;;33.71^N^
+45 ;;+17^412
+46 ;;33.78^N^
+47 ;;+17^412
+48 ;;33.79^N^
+49 ;;+17^412
+50 ;;35.55^Oo^
+51 ;;+5^108
+52 ;;36.33^Oo^
+53 ;;+5^108
+54 ;;36.34^Oo^
+55 ;;+5^108
+56 ;;37.20^^
+57 ;;39.74^OQ^3
+58 ;;+1^1^2^3^543
+59 ;;+21^442^443
+60 ;;+24^486
+61 ;;50.23^O^
+62 ;;+6^170^171
+63 ;;+7^191^192
+64 ;;50.24^O^
+65 ;;+6^170^171
+66 ;;+7^191^192
+67 ;;50.25^O^
+68 ;;+6^170^171
+69 ;;+7^191^192
+70 ;;50.26^O^
+71 ;;+6^170^171
+72 ;;+7^191^192
+73 ;;55.32^O^
+74 ;;+11^303^304^305
+75 ;;55.33^O^
+76 ;;+11^303^304^305
+77 ;;55.34^O^
+78 ;;+11^303^304^305
+79 ;;55.35^O^
+80 ;;+11^303^304^305
+81 ;;68.41^O^
+82 ;;+13^354^355^357^358^359
+83 ;;+14^375
+84 ;;68.49^O^
+85 ;;+13^354^355^357^358^359
+86 ;;+14^375
+87 ;;68.61^O^
+88 ;;+13^353
+89 ;;+14^375
+90 ;;68.69^O^
+91 ;;+13^353
+92 ;;+14^375
+93 ;;68.71^O^
+94 ;;+13^353
+95 ;;+14^375
+96 ;;68.79^O^
+97 ;;+13^353
+98 ;;+14^375
+99 ;;EXIT
