- ICD1865C ;ALB/JDG - YEARLY DRG UPDATE;8/9/2010
- ;;18.0;DRG Grouper;**65**;Oct 20, 2000;Build 7
- ;
- Q
- ;
- 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["+"
- .; check if already created in case patch being re-installed
- .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
- .I $D(^ICD0(ENTRY,2,"B",3121001)) D
- ..;kill existing entry for FY
- .. S DA(1)=ENTRY,DA=$O(^ICD0(ENTRY,2,"B",3121001,0))
- .. S DIK="^ICD0("_DA(1)_",2," D ^DIK K DIK,DA
- .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("
- ..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
- ..;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)=3121001
- ....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)=3121001
- ...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)=3121001
- ...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)
- ...I $P(DATA,U,8) S FDA(1820,80.17111,"+10,?3,?2,?1,",.01)=$P(DATA,U,8)
- ...I $P(DATA,U,9) S FDA(1820,80.17111,"+11,?3,?2,?1,",.01)=$P(DATA,U,9)
- ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
- Q
- ;
- REV ; PROC/OP^IDENTIFIER^
- ; +MDC^DRG
- ;;00.95^^
- ;;EXIT
- ICD1865C ;ALB/JDG - YEARLY DRG UPDATE;8/9/2010
- +1 ;;18.0;DRG Grouper;**65**;Oct 20, 2000;Build 7
- +2 ;
- +3 QUIT
- +4 ;
- 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 ; check if already created in case patch being re-installed
- +7 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
- +8 IF $DATA(^ICD0(ENTRY,2,"B",3121001))
- Begin DoDot:2
- +9 ;kill existing entry for FY
- +10 SET DA(1)=ENTRY
- SET DA=$ORDER(^ICD0(ENTRY,2,"B",3121001,0))
- +11 SET DIK="^ICD0("_DA(1)_",2,"
- DO ^DIK
- KILL DIK,DA
- End DoDot:2
- +12 IF ENTRY
- Begin DoDot:2
- +13 ;check for possible inactive dupe
- +14 IF $PIECE($GET(^ICD0(ENTRY,0)),U,9)=1
- SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",ENTRY))
- IF 'ENTRY
- QUIT
- +15 SET DA=ENTRY
- SET DIE="^ICD0("
- +16 SET IDENT=$PIECE(ICDPROC,U,2)
- +17 SET MDC24=$PIECE(ICDPROC,U,3)
- +18 SET DR="2///^S X=IDENT;5///^S X=MDC24"
- +19 ;I IDENT=""&(MDC24="") Q
- +20 DO ^DIE
- +21 ;add 80.171, 80.1711 and 80.17111 records
- +22 FOR SUBLINE=1:1
- SET X=$TEXT(REV+LINE+SUBLINE)
- SET DATA=$PIECE(X,";;",2)
- IF DATA'["+"
- QUIT
- Begin DoDot:3
- +23 IF SUBLINE=1
- Begin DoDot:4
- +24 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +25 SET FDA(1820,80.171,"+2,?1,",.01)=3121001
- +26 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- End DoDot:4
- +27 SET DATA=$EXTRACT(DATA,2,99)
- +28 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +29 SET FDA(1820,80.171,"?2,?1,",.01)=3121001
- +30 SET FDA(1820,80.1711,"+3,?2,?1,",.01)=$PIECE(DATA,U)
- +31 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- +32 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +33 SET FDA(1820,80.171,"?2,?1,",.01)=3121001
- +34 SET FDA(1820,80.1711,"?3,?2,?1,",.01)=$PIECE(DATA,U)
- +35 SET FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$PIECE(DATA,U,2)
- +36 IF $PIECE(DATA,U,3)
- SET FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$PIECE(DATA,U,3)
- +37 IF $PIECE(DATA,U,4)
- SET FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$PIECE(DATA,U,4)
- +38 IF $PIECE(DATA,U,5)
- SET FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$PIECE(DATA,U,5)
- +39 IF $PIECE(DATA,U,6)
- SET FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$PIECE(DATA,U,6)
- +40 IF $PIECE(DATA,U,7)
- SET FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$PIECE(DATA,U,7)
- +41 IF $PIECE(DATA,U,8)
- SET FDA(1820,80.17111,"+10,?3,?2,?1,",.01)=$PIECE(DATA,U,8)
- +42 IF $PIECE(DATA,U,9)
- SET FDA(1820,80.17111,"+11,?3,?2,?1,",.01)=$PIECE(DATA,U,9)
- +43 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +44 QUIT
- +45 ;
- REV ; PROC/OP^IDENTIFIER^
- +1 ; +MDC^DRG
- +2 ;;00.95^^
- +3 ;;EXIT
