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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1831T 1921 printed Nov 22, 2024@16:58:46 Page 2
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
