- ICD1824O ;;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 7
- ;
- Q
- ;
- PRO ;
- D BMES^XPDUTL(">>>Modifying procedure codes - file 80.1")
- D MES^XPDUTL(">>>for new DRGs")
- N LINE,X,ICDPROC,ENTRY,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
- ..; 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
- ID ;
- ; modify Identifier field (#2) in file 80.1 - add an "M" - this should have been
- ; done when these new codes were added in FY2006 so they can go to DRG 471
- ; although beginning with FY2007, only 00.70 and 00.80 can still go to DRG 471.
- ; Note also that DRG 471 doesn't work for bilateral (e.g. both hips) - HIM Staff know this
- ; as this is a limitation of the VistA Grouper who can't handle duplicate codes
- N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,DIC
- F LINE=1:1 S X=$T(REVID+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
- .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0)) I ENTRY D
- ..S DA=ENTRY,DIE="^ICD0("
- ..S IDENT=$P(ICDPROC,U,2)
- ..S DR="2///^S X=IDENT"
- ..D ^DIE
- Q
- ;
- REV ;
- ;;96.70^
- ;;+4^566
- ;;96.71^
- ;;+4^566
- ;;96.72^
- ;;+4^565
- ;;57.6^
- ;;+11^573
- ;;57.71^
- ;;+11^573
- ;;57.79^
- ;;+11^573
- ;;57.83^
- ;;+11^573
- ;;57.84^
- ;;+11^573
- ;;57.85^
- ;;+11^573
- ;;57.86^
- ;;+11^573
- ;;57.87^
- ;;+11^573
- ;;57.88^
- ;;+11^573
- ;;57.89^
- ;;+11^573
- ;;00.71^
- ;;+8^545
- ;;00.72^
- ;;+8^545
- ;;00.73^
- ;;+8^545
- ;;00.81^
- ;;+8^545
- ;;00.82^
- ;;+8^545
- ;;00.83^
- ;;+8^545
- ;;00.84^
- ;;+8^545
- ;;81.53^
- ;;+8^545
- ;;81.55^
- ;;+8^545
- ;;EXIT
- ;;
- REVID ; these codes were new in FY2006 and should have had an "M" added then
- ;;00.70^OM
- ;;00.71^OM
- ;;00.72^OM
- ;;00.73^OM
- ;;00.80^OM
- ;;00.81^OM
- ;;00.82^OM
- ;;00.83^OM
- ;;00.84^OM
- ;;EXIT
- ICD1824O ;;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
- +2 ;
- +3 QUIT
- +4 ;
- PRO ;
- +1 DO BMES^XPDUTL(">>>Modifying procedure codes - file 80.1")
- +2 DO MES^XPDUTL(">>>for new DRGs")
- +3 NEW LINE,X,ICDPROC,ENTRY,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 ; check if already created in case patch being re-installed
- +11 IF $DATA(^ICD0(ENTRY,2,"B",3061001))
- QUIT
- +12 ;add 80.171, 80.1711 and 80.17111 records
- +13 FOR SUBLINE=1:1
- SET X=$TEXT(REV+LINE+SUBLINE)
- SET DATA=$PIECE(X,";;",2)
- IF DATA'["+"
- QUIT
- Begin DoDot:3
- +14 IF SUBLINE=1
- Begin DoDot:4
- +15 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +16 SET FDA(1820,80.171,"+2,?1,",.01)=3061001
- +17 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- End DoDot:4
- +18 SET DATA=$EXTRACT(DATA,2,99)
- +19 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +20 SET FDA(1820,80.171,"?2,?1,",.01)=3061001
- +21 SET FDA(1820,80.1711,"+3,?2,?1,",.01)=$PIECE(DATA,U)
- +22 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- +23 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +24 SET FDA(1820,80.171,"?2,?1,",.01)=3061001
- +25 SET FDA(1820,80.1711,"?3,?2,?1,",.01)=$PIECE(DATA,U)
- +26 SET FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$PIECE(DATA,U,2)
- +27 IF $PIECE(DATA,U,3)
- SET FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$PIECE(DATA,U,3)
- +28 IF $PIECE(DATA,U,4)
- SET FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$PIECE(DATA,U,4)
- +29 IF $PIECE(DATA,U,5)
- SET FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$PIECE(DATA,U,5)
- +30 IF $PIECE(DATA,U,6)
- SET FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$PIECE(DATA,U,6)
- +31 IF $PIECE(DATA,U,7)
- SET FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$PIECE(DATA,U,7)
- +32 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +33 QUIT
- ID ;
- +1 ; modify Identifier field (#2) in file 80.1 - add an "M" - this should have been
- +2 ; done when these new codes were added in FY2006 so they can go to DRG 471
- +3 ; although beginning with FY2007, only 00.70 and 00.80 can still go to DRG 471.
- +4 ; Note also that DRG 471 doesn't work for bilateral (e.g. both hips) - HIM Staff know this
- +5 ; as this is a limitation of the VistA Grouper who can't handle duplicate codes
- +6 NEW LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,DIC
- +7 FOR LINE=1:1
- SET X=$TEXT(REVID+LINE)
- SET ICDPROC=$PIECE(X,";;",2)
- IF ICDPROC="EXIT"
- QUIT
- Begin DoDot:1
- +8 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
- IF ENTRY
- Begin DoDot:2
- +9 SET DA=ENTRY
- SET DIE="^ICD0("
- +10 SET IDENT=$PIECE(ICDPROC,U,2)
- +11 SET DR="2///^S X=IDENT"
- +12 DO ^DIE
- End DoDot:2
- End DoDot:1
- +13 QUIT
- +14 ;
- REV ;
- +1 ;;96.70^
- +2 ;;+4^566
- +3 ;;96.71^
- +4 ;;+4^566
- +5 ;;96.72^
- +6 ;;+4^565
- +7 ;;57.6^
- +8 ;;+11^573
- +9 ;;57.71^
- +10 ;;+11^573
- +11 ;;57.79^
- +12 ;;+11^573
- +13 ;;57.83^
- +14 ;;+11^573
- +15 ;;57.84^
- +16 ;;+11^573
- +17 ;;57.85^
- +18 ;;+11^573
- +19 ;;57.86^
- +20 ;;+11^573
- +21 ;;57.87^
- +22 ;;+11^573
- +23 ;;57.88^
- +24 ;;+11^573
- +25 ;;57.89^
- +26 ;;+11^573
- +27 ;;00.71^
- +28 ;;+8^545
- +29 ;;00.72^
- +30 ;;+8^545
- +31 ;;00.73^
- +32 ;;+8^545
- +33 ;;00.81^
- +34 ;;+8^545
- +35 ;;00.82^
- +36 ;;+8^545
- +37 ;;00.83^
- +38 ;;+8^545
- +39 ;;00.84^
- +40 ;;+8^545
- +41 ;;81.53^
- +42 ;;+8^545
- +43 ;;81.55^
- +44 ;;+8^545
- +45 ;;EXIT
- +46 ;;
- REVID ; these codes were new in FY2006 and should have had an "M" added then
- +1 ;;00.70^OM
- +2 ;;00.71^OM
- +3 ;;00.72^OM
- +4 ;;00.73^OM
- +5 ;;00.80^OM
- +6 ;;00.81^OM
- +7 ;;00.82^OM
- +8 ;;00.83^OM
- +9 ;;00.84^OM
- +10 ;;EXIT
