ICD1831T.m

ICD1831T   ; ALB/JAT - FY 2008 UPDATE; 7/27/05 14:50;

 ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7

 Q

 ;

DIAG ;

 D BMES^XPDUTL(">>>DRG Reclassification changes")

 D MES^XPDUTL(">>>Modifying diagnosis codes - file 80")

 D MES^XPDUTL(">>>for new DRGs")

 N LINE,X,ICDDIAG,ENTRY,FDA

 F LINE=1:1 S X=$T(REVD+LINE) S ICDDIAG=$P(X,";;",2) Q:ICDDIAG="EXIT"  D

 .S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",0))

 .I ENTRY D

 ..;check for possible inactive dupe

 ..I $P($G(^ICD9(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",ENTRY)) I 'ENTRY Q 

 ..;check if already created in case patch being re-installed

 ..I $D(^ICD9(ENTRY,3,"B",3071001)) D

 ...S DA(1)=ENTRY,DA=$O(^ICD9(ENTRY,3,"B",3071001,0))

 ...S DIK="^ICD9("_DA(1)_",3," D ^DIK

 ..; add 80.071 and 80.711 records

 ..S FDA(1820,80,"?1,",.01)="`"_ENTRY

 ..S FDA(1820,80.071,"+2,?1,",.01)=3071001

 ..D UPDATE^DIE("","FDA(1820)") K FDA(1820)

 ..S FDA(1820,80,"?1,",.01)="`"_ENTRY

 ..S FDA(1820,80.071,"?2,?1,",.01)=3071001

 ..S FDA(1820,80.711,"+3,?2,?1,",.01)=$P(ICDDIAG,U,2)

 ..I $P(ICDDIAG,U,3) S FDA(1820,80.711,"+4,?2,?1,",.01)=$P(ICDDIAG,U,3)

 ..I $P(ICDDIAG,U,4) S FDA(1820,80.711,"+5,?2,?1,",.01)=$P(ICDDIAG,U,4)

 ..I $P(ICDDIAG,U,5) S FDA(1820,80.711,"+6,?2,?1,",.01)=$P(ICDDIAG,U,5)

 ..I $P(ICDDIAG,U,6) S FDA(1820,80.711,"+7,?2,?1,",.01)=$P(ICDDIAG,U,6)

 ..I $P(ICDDIAG,U,7) S FDA(1820,80.711,"+8,?2,?1,",.01)=$P(ICDDIAG,U,7)

 ..D UPDATE^DIE("","FDA(1820)") K FDA(1820)

 Q

REVD ; DIAG^DRG...

 ;;015.02^456^457^458^459

 ;;015.04^456^457^458^459

 ;;015.05^456^457^458^459

 ;;730.08^456^457^458^459

 ;;730.18^456^457^458^459

 ;;730.28^456^457^458^459

 ;;V58.0^849

 ;;V67.1^849

 ;;V58.11^837^838^839^846^847^848

 ;;V58.12^837^838^839^846^847^848

 ;;V67.2^837^838^839^846^847^848

 ;;958.3^856^857^858^862^863

 ;;998.51^856^857^858^862^863

 ;;998.59^856^857^858^862^863

 ;;999.39^856^857^858^867^868^869

 ;;EXIT

ICD1831T  ; ALB/JAT - FY 2008 UPDATE; 7/27/05 14:50;

 +1       ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7

 +2        QUIT 

 +3       ;

DIAG      ;

 +1        DO BMES^XPDUTL(">>>DRG Reclassification changes")

 +2        DO MES^XPDUTL(">>>Modifying diagnosis codes - file 80")

 +3        DO MES^XPDUTL(">>>for new DRGs")

 +4        NEW LINE,X,ICDDIAG,ENTRY,FDA

 +5        FOR LINE=1:1

               SET X=$TEXT(REVD+LINE)

               SET ICDDIAG=$PIECE(X,";;",2)

               IF ICDDIAG="EXIT"

                   QUIT 

               Begin DoDot:1

 +6                SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",0))

 +7                IF ENTRY

                       Begin DoDot:2

 +8       ;check for possible inactive dupe

 +9                        IF $PIECE($GET(^ICD9(ENTRY,0)),U,9)=1

                               SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",ENTRY))

                               IF 'ENTRY

                                   QUIT 

 +10      ;check if already created in case patch being re-installed

 +11                       IF $DATA(^ICD9(ENTRY,3,"B",3071001))

                               Begin DoDot:3

 +12                               SET DA(1)=ENTRY

                                   SET DA=$ORDER(^ICD9(ENTRY,3,"B",3071001,0))

 +13                               SET DIK="^ICD9("_DA(1)_",3,"

                                   DO ^DIK

                               End DoDot:3

 +14      ; add 80.071 and 80.711 records

 +15                       SET FDA(1820,80,"?1,",.01)="`"_ENTRY

 +16                       SET FDA(1820,80.071,"+2,?1,",.01)=3071001

 +17                       DO UPDATE^DIE("","FDA(1820)")

                           KILL FDA(1820)

 +18                       SET FDA(1820,80,"?1,",.01)="`"_ENTRY

 +19                       SET FDA(1820,80.071,"?2,?1,",.01)=3071001

 +20                       SET FDA(1820,80.711,"+3,?2,?1,",.01)=$PIECE(ICDDIAG,U,2)

 +21                       IF $PIECE(ICDDIAG,U,3)

                               SET FDA(1820,80.711,"+4,?2,?1,",.01)=$PIECE(ICDDIAG,U,3)

 +22                       IF $PIECE(ICDDIAG,U,4)

                               SET FDA(1820,80.711,"+5,?2,?1,",.01)=$PIECE(ICDDIAG,U,4)

 +23                       IF $PIECE(ICDDIAG,U,5)

                               SET FDA(1820,80.711,"+6,?2,?1,",.01)=$PIECE(ICDDIAG,U,5)

 +24                       IF $PIECE(ICDDIAG,U,6)

                               SET FDA(1820,80.711,"+7,?2,?1,",.01)=$PIECE(ICDDIAG,U,6)

 +25                       IF $PIECE(ICDDIAG,U,7)

                               SET FDA(1820,80.711,"+8,?2,?1,",.01)=$PIECE(ICDDIAG,U,7)

 +26                       DO UPDATE^DIE("","FDA(1820)")

                           KILL FDA(1820)

                       End DoDot:2

               End DoDot:1

 +27       QUIT 

REVD      ; DIAG^DRG...

 +1       ;;015.02^456^457^458^459

 +2       ;;015.04^456^457^458^459

 +3       ;;015.05^456^457^458^459

 +4       ;;730.08^456^457^458^459

 +5       ;;730.18^456^457^458^459

 +6       ;;730.28^456^457^458^459

 +7       ;;V58.0^849

 +8       ;;V67.1^849

 +9       ;;V58.11^837^838^839^846^847^848

 +10      ;;V58.12^837^838^839^846^847^848

 +11      ;;V67.2^837^838^839^846^847^848

 +12      ;;958.3^856^857^858^862^863

 +13      ;;998.51^856^857^858^862^863

 +14      ;;998.59^856^857^858^862^863

 +15      ;;999.39^856^857^858^867^868^869

 +16      ;;EXIT