Routine: ICD1832S

ICD1832S ;;ALB/EG/JAT - FY 2008 UPDATE FOLLOW-UP; 6/19/05 4:08pm ; 12/19/07 12:15pm

 ;;18.0;DRG Grouper;**32**;Oct 13,2000;Build 9

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",3071001)) D

 ..;kill existing entry for FY

 .. S DA(1)=ENTRY,DA=$O(^ICD0(ENTRY,2,"B",3071001,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)=3071001

 ....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)=3071001

 ...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)=3071001

 ...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)

REV ;PROC/OP^IDENTIFIER^MDC24^DRG...

 ;;53.00^OzJ^

 ;;+6^350^351^352

 ;;53.01^OzJ^

 ;;+6^350^351^352

 ;;53.02^OzJ^

 ;;+6^350^351^352

 ;;53.03^OzJ^

 ;;+6^350^351^352

 ;;53.04^OzJ^

 ;;+6^350^351^352

 ;;53.05^OzJ^

 ;;+6^350^351^352

 ;;53.10^OzJ^

 ;;+6^350^351^352

 ;;53.11^OzJ^

 ;;+6^350^351^352

 ;;53.12^OzJ^

 ;;+6^350^351^352

 ;;53.13^OzJ^

 ;;+6^350^351^352

 ;;53.14^OzJ^

 ;;+6^350^351^352

 ;;53.15^OzJ^

 ;;+6^350^351^352

 ;;53.16^OzJ^

 ;;+6^350^351^352

 ;;53.17^OzJ^

 ;;+6^350^351^352

 ;;53.21^OzJ^

 ;;+6^350^351^352

 ;;53.29^OzJ^

 ;;+6^350^351^352

 ;;53.31^OzJ^

 ;;+6^350^351^352

 ;;53.39^OzJ^

 ;;+6^350^351^352

 ;;EXIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1832S   2989     printed  Mar 13, 2025@20:53:19                                                                                                                                                                                                    Page 2

ICD1832S  ;;ALB/EG/JAT - FY 2008 UPDATE FOLLOW-UP; 6/19/05 4:08pm ; 12/19/07 12:15pm

 +1       ;;18.0;DRG Grouper;**32**;Oct 13,2000;Build 9

 +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",3071001))

                       Begin DoDot:2

 +9       ;kill existing entry for FY

 +10                       SET DA(1)=ENTRY

                           SET DA=$ORDER(^ICD0(ENTRY,2,"B",3071001,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                       IF IDENT=""&(MDC24="")

                               QUIT

 +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)=3071001

 +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)=3071001

 +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)=3071001

 +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^MDC24^DRG...

 +1       ;;53.00^OzJ^

 +2       ;;+6^350^351^352

 +3       ;;53.01^OzJ^

 +4       ;;+6^350^351^352

 +5       ;;53.02^OzJ^

 +6       ;;+6^350^351^352

 +7       ;;53.03^OzJ^

 +8       ;;+6^350^351^352

 +9       ;;53.04^OzJ^

 +10      ;;+6^350^351^352

 +11      ;;53.05^OzJ^

 +12      ;;+6^350^351^352

 +13      ;;53.10^OzJ^

 +14      ;;+6^350^351^352

 +15      ;;53.11^OzJ^

 +16      ;;+6^350^351^352

 +17      ;;53.12^OzJ^

 +18      ;;+6^350^351^352

 +19      ;;53.13^OzJ^

 +20      ;;+6^350^351^352

 +21      ;;53.14^OzJ^

 +22      ;;+6^350^351^352

 +23      ;;53.15^OzJ^

 +24      ;;+6^350^351^352

 +25      ;;53.16^OzJ^

 +26      ;;+6^350^351^352

 +27      ;;53.17^OzJ^

 +28      ;;+6^350^351^352

 +29      ;;53.21^OzJ^

 +30      ;;+6^350^351^352

 +31      ;;53.29^OzJ^

 +32      ;;+6^350^351^352

 +33      ;;53.31^OzJ^

 +34      ;;+6^350^351^352

 +35      ;;53.39^OzJ^

 +36      ;;+6^350^351^352

 +37      ;;EXIT

ICD1832S.m