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 5
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1824O 3187 printed Dec 13, 2024@01:48:12 Page 2
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 5
+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
