Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICD1824A

ICD1824A.m

Go to the documentation of this file. 
  1. 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 7
  1.  ;
  1.  Q
  1.  ;
  1. ADDDRG ; add new DRGs
  1.  N DIC,X,Y,DINUM,LINE,ICDDRG,DA,DRGX,DRGY,MDC,SURG,ROUTINE,ICDIEN
  1.  D BMES^XPDUTL(">>> Adding New DRGs - Please verify that 20 were added")
  1.  ; create top-level record (relative weights & average length of stay (ALOS) will be added later)
  1.  F LINE=1:1 S X=$T(ADD+LINE) S ICDDRG=$P(X,";;",2) Q:ICDDRG="EXIT"  D
  1.     .S DIC="^ICD(",DIC(0)="L"
  1.     .S MDC=$P(ICDDRG,U,2) I MDC="PRE" S MDC=98
  1.     .S SURG=$P(ICDDRG,U,3)
  1.     .S DIC("DR")="5///^S X=MDC;.06///^S X=SURG"
  1.     .S X="DRG",X=X_$P(ICDDRG,U)
  1.     .; check for duplicates in case install is being rerun
  1.     .I $D(^ICD($P(ICDDRG,U),0)) Q
  1.     .K DO D FILE^DICN
  1.     .K DIC,DA
  1.     .;create 80.21A subfile
  1.     .S DA(1)=$P(ICDDRG,U)
  1.     .S DIC="^ICD("_DA(1)_",1,"
  1.     .S DIC(0)="L"
  1.     .S X=$P(ICDDRG,U,4)
  1.     .K DO D FILE^DICN
  1.     .;create 80.266 subfile
  1.     .K DIC,DA
  1.     .S DA(1)=$P(ICDDRG,U)
  1.     .S DIC="^ICD("_DA(1)_",66,"
  1.     .S DIC(0)="L"
  1.     .I SURG="" S SURG=0
  1.     .S DIC("DR")=".03///1;.05///^S X=MDC;.06///^S X=SURG"
  1.     .S X=3061001
  1.     .K DO D FILE^DICN
  1.     .; create 80.271 subfile
  1.     .K DIC,DA
  1.     .S DA(1)=$P(ICDDRG,U)
  1.     .S DIC="^ICD("_DA(1)_",2,"
  1.     .S DIC(0)="L"
  1.     .S ROUTINE="ICDTLB6C"
  1.     .S DIC("DR")="1///^S X=ROUTINE"
  1.     .S X=3061001
  1.     .K DO D FILE^DICN
  1.     .; create 80.268 and 80.2681 subfiles
  1.     .K DIC,DA
  1.     .N FDA
  1.     .S ICDIEN=$P(ICDDRG,U)
  1.     .S FDA(1820,80.2,"?1,",.01)=ICDIEN
  1.     .S FDA(1820,80.268,"+2,?1,",.01)=3061001
  1.     .D UPDATE^DIE("","FDA(1820)") K FDA(1820)
  1.     .S FDA(1820,80.2,"?1,",.01)=ICDIEN
  1.     .S FDA(1820,80.268,"?2,?1,",.01)=3061001
  1.     .S FDA(1820,80.2681,"+3,?2,?1,",.01)=$P(ICDDRG,U,4)
  1.     .D UPDATE^DIE("","FDA(1820)")
  1.     .; displays listing
  1.     .S DRGX=$P(ICDDRG,U),DRGY=$P(ICDDRG,U,4)
  1.     .D MES^XPDUTL("  DRG"_DRGX_"     "_DRGY)
  1.     .Q
  1.  ; now update entire file for weights & versioning
  1.  D UPDTDRG^ICD1824B
  1.  ; inactivate some DRGs
  1.  D INACTDRG^ICD1824B
  1.  ; modify some DRG titles
  1.  D DRGTITLE^ICD1824B
  1.  Q
  1.  ;
  1. ADD ;New DRGs
  1.  ;;560^1^^BACTERIAL & TUBERCULOUS INFECTIONS OF NERVOUS SYSTEM
  1.  ;;561^1^^NON-BACTERIAL INFECTIONS OF NERVOUS SYSTEM EXCEPT VIRAL MENINGITIS
  1.  ;;562^1^^SEIZURE AGE > 17 W CC
  1.  ;;563^1^^SEIZURE AGE > 17 W/O CC
  1.  ;;564^1^^HEADACHES AGE >17
  1.  ;;565^4^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT 96+ HOURS
  1.  ;;566^6^^RESPIRATORY SYSTEM DIAGNOSIS WITH VENTILATOR SUPPORT < 96 HOURS
  1.  ;;567^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROC AGE > 17 W CC W MAJOR GI DX
  1.  ;;568^6^1^STOMACH, ESOPHAGEAL & DUODENAL PROCEDURES PROC AGE > 17 W CC W/O MAJOR GI DX
  1.  ;;569^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W MAJOR GI DX
  1.  ;;570^6^1^MAJOR SMALL & LARGE BOWEL PROCEDURES W CC W/O MAJOR GI DX
  1.  ;;571^6^1^MAJOR ESOPHAGEAL DISORDERS
  1.  ;;572^8^^MAJOR GASTROINTESTINAL DISORDERS AND PERITONEAL INFECTIONS
  1.  ;;573^11^1^MAJOR BLADDER PROCEDURES
  1.  ;;574^16^^MAJOR HEMATOLOGIC/IMMUNOLOGIC DIAG EXC SICKLE CELL CRISIS & COAGUL
  1.  ;;575^18^^SEPTICEMIA W MV96+ HOURS  AGE  >17
  1.  ;;576^18^^SEPTICEMIA W/O MV96+ HOURS AGE  >17
  1.  ;;577^1^1^CAROTID ARTERY STENT PROCEDURE
  1.  ;;578^18^1^INFECTIOUS & PARASITIC DISEASES W OR PROCEDURE
  1.  ;;579^18^1^POSTOPERATIVE OR POST-TRAUMATIC INFECTIONS W OR PROCEDURE
  1.  ;;EXIT
  1.  ;       
  1. PRO ;-update operation/procedure codes
  1.  ; from Table 6B in Fed Reg - assumes new codes already added by Lexicon
  1.  D BMES^XPDUTL(">>>Modifying new op/pro codes - file 80.1")
  1.  N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,MDC24,SUBLINE,DATA,FDA
  1.  F LINE=1:1 S X=$T(REV+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT"  D
  1.  .Q:ICDPROC["+"
  1.  .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
  1.  .I ENTRY D
  1.  ..;check for possible inactive dupe
  1.  ..I $P($G(^ICD0(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",ENTRY)) I 'ENTRY Q
  1.  ..S DA=ENTRY,DIE="^ICD0("
  1.  ..;the "O" (not zero) is from the OR column in Table 6B (a "Y" there), rest is as needed  
  1.  ..S IDENT=$P(ICDPROC,U,2)
  1.  ..S MDC24=$P(ICDPROC,U,3)
  1.  ..S DR="2///^S X=IDENT;5///^S X=MDC24"
  1.  ..I IDENT=""&(MDC24="") Q
  1.  ..D ^DIE
  1.  ..; check if already created in case patch being re-installed
  1.  ..Q:$D(^ICD0(ENTRY,2,"B",3061001))
  1.  ..;add 80.171, 80.1711 and 80.17111 records
  1.  ..F SUBLINE=1:1 S X=$T(REV+LINE+SUBLINE) S DATA=$P(X,";;",2) Q:DATA'["+"  D
  1.  ...I SUBLINE=1 D
  1.  ....S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
  1.  ....S FDA(1820,80.171,"+2,?1,",.01)=3061001
  1.  ....D UPDATE^DIE("","FDA(1820)") K FDA(1820)
  1.  ...S DATA=$E(DATA,2,99)
  1.  ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
  1.  ...S FDA(1820,80.171,"?2,?1,",.01)=3061001
  1.  ...S FDA(1820,80.1711,"+3,?2,?1,",.01)=$P(DATA,U)
  1.  ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
  1.  ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
  1.  ...S FDA(1820,80.171,"?2,?1,",.01)=3061001
  1.  ...S FDA(1820,80.1711,"?3,?2,?1,",.01)=$P(DATA,U)
  1.  ...S FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$P(DATA,U,2)
  1.  ...I $P(DATA,U,3) S FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$P(DATA,U,3)
  1.  ...I $P(DATA,U,4) S FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$P(DATA,U,4)
  1.  ...I $P(DATA,U,5) S FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$P(DATA,U,5)
  1.  ...I $P(DATA,U,6) S FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$P(DATA,U,6)
  1.  ...I $P(DATA,U,7) S FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$P(DATA,U,7)
  1.  ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
  1.  Q
  1.  ; 
  1. REV ;
  1.  ;;00.44^^
  1.  ;;00.56^Op^
  1.  ;;+5^117^120
  1.  ;;00.57^O^
  1.  ;;+5^118^120
  1.  ;;00.77^^
  1.  ;;00.85^OM^2
  1.  ;;+8^471^544
  1.  ;;+21^442^443
  1.  ;;+24^485
  1.  ;;00.86^OM^2
  1.  ;;+8^471^544
  1.  ;;+10^292^293
  1.  ;;+21^442^443
  1.  ;;+24^485
  1.  ;;00.87^OM^2
  1.  ;;+8^471^544
  1.  ;;+10^292^293
  1.  ;;+21^442^443
  1.  ;;+24^485
  1.  ;;01.28^OQ^1
  1.  ;;+1^1^2^3^543
  1.  ;;+17^406^407^539^540
  1.  ;;+21^442^443
  1.  ;;+24^484
  1.  ;;13.90^O^3
  1.  ;;+2^39
  1.  ;;+21^442^443
  1.  ;;+24^486
  1.  ;;13.91^O^3
  1.  ;;+2^39
  1.  ;;+21^442^443
  1.  ;;+24^486
  1.  ;;32.23^O^
  1.  ;;+4^75
  1.  ;;+17^406^407^539^540
  1.  ;;32.24^O^
  1.  ;;+4^76^7
  1.  ;;32.25^O^
  1.  ;;+4^75
  1.  ;;+17^406^407^539^540
  1.  ;;32.26^O^
  1.  ;;+4^75
  1.  ;;33.71^N^
  1.  ;;+17^412
  1.  ;;33.78^N^
  1.  ;;+17^412
  1.  ;;33.79^N^
  1.  ;;+17^412
  1.  ;;35.55^Oo^
  1.  ;;+5^108
  1.  ;;36.33^Oo^
  1.  ;;+5^108
  1.  ;;36.34^Oo^
  1.  ;;+5^108
  1.  ;;37.20^^
  1.  ;;39.74^OQ^3
  1.  ;;+1^1^2^3^543
  1.  ;;+21^442^443
  1.  ;;+24^486
  1.  ;;50.23^O^
  1.  ;;+6^170^171
  1.  ;;+7^191^192
  1.  ;;50.24^O^
  1.  ;;+6^170^171
  1.  ;;+7^191^192
  1.  ;;50.25^O^
  1.  ;;+6^170^171
  1.  ;;+7^191^192
  1.  ;;50.26^O^
  1.  ;;+6^170^171
  1.  ;;+7^191^192
  1.  ;;55.32^O^
  1.  ;;+11^303^304^305
  1.  ;;55.33^O^
  1.  ;;+11^303^304^305
  1.  ;;55.34^O^
  1.  ;;+11^303^304^305
  1.  ;;55.35^O^
  1.  ;;+11^303^304^305
  1.  ;;68.41^O^
  1.  ;;+13^354^355^357^358^359
  1.  ;;+14^375
  1.  ;;68.49^O^
  1.  ;;+13^354^355^357^358^359
  1.  ;;+14^375
  1.  ;;68.61^O^
  1.  ;;+13^353
  1.  ;;+14^375
  1.  ;;68.69^O^
  1.  ;;+13^353
  1.  ;;+14^375
  1.  ;;68.71^O^
  1.  ;;+13^353
  1.  ;;+14^375
  1.  ;;68.79^O^
  1.  ;;+13^353
  1.  ;;+14^375
  1.  ;;EXIT