ICD1817P ;;ALB/EG/JAT - CORRECT PROC CODES ; 6/27/05 1:03pm
;;18.0;DRG Grouper;**17**;Oct 13,2000
;
D CHGPROC
D CHGDIAG
Q
;
CHGPROC ;
D BMES^XPDUTL(">>>Modifying records in file 80.1")
; modify Identifier field (#2) in file 80.1
N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,DIC
S LINE=1
F S X=$T(REVP+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
..S LINE=LINE+1
; kill 80.171 sub-file record and descendants for proc 80.51
N DA,DIK
S DA(1)=3867
S DA=2
S DIK="^ICD0("_DA(1)_",""2"","
D ^DIK
; add Oct 1,2004 record to 80.171, MDC 1 to 80.1711, and 543
; to 80.17111 for proc 01.14 ONLY
S ENTRY=2963
; check if already created in case patch being re-installed
I $D(^ICD0(ENTRY,2,2)) G SKIP
S DA(1)=ENTRY
S DIC="^ICD0("_DA(1)_",2,"
S DIC(0)="L"
S X=3041001 K DO D FILE^DICN K DIC,DA
S DA(2)=ENTRY
S DA(1)=2
S DIC="^ICD0("_DA(2)_",2,"_DA(1)_",1,"
S DIC(0)="L"
S X=1 K DO D FILE^DICN K DIC,DA
S DA(3)=ENTRY
S DA(2)=2
S DA(1)=1
S DIC="^ICD0("_DA(3)_",2,"_DA(2)_",1,"_DA(1)_",1,"
S DIC(0)="L"
S X=543 K DO D FILE^DICN K DIC,DA
; add 80.17111 sub-file records to 80.1711 and 80.171
SKIP ;
S LINE=1
N Z
F S Z=$T(REVPRO+LINE) S ICDPROC=$P(Z,";;",2) Q:ICDPROC="EXIT" D
.S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0)) I ENTRY D
..S DA(3)=ENTRY,DA(2)=2,DA(1)=1
..S DIC="^ICD0("_DA(3)_",2,"_DA(2)_",1,"_DA(1)_",1,"
..S DIC(0)="L"
..; check if already created in case patch being re-installed
..I $D(^ICD0(ENTRY,2,2,1,1,1,2,0)) S LINE=LINE+1 Q
..; add DRG 1,2 and 3
..S X=1
..K DO
..D FILE^DICN
..S X=2
..D FILE^DICN
..S X=3
..D FILE^DICN
..S LINE=LINE+1
Q
;
REVP ;
;;36.12^Ob6
;;36.13^Ob6
;;36.14^Ob6
;;51.23^TT
;;81.61^O
;;01.14^OQ
;;02.13^OQK
;;38.01^OQK
;;38.11^OQK
;;38.31^OQK
;;38.41^OQK
;;38.51^OQK
;;38.61^OQK
;;38.81^OQK
;;39.28^OQK
;;39.51^OQK
;;39.52^OQK
;;39.53^OQK
;;39.72^OQK
;;39.79^OQK
;;EXIT
Q
REVPRO ;
;;01.59^
;;01.12^
;;01.14^
;;01.15^
;;01.18^
;;01.19^
;;01.21^
;;01.22^
;;01.23^
;;01.24^
;;01.25^
;;01.31^
;;01.32^
;;01.39^
;;01.41^
;;01.42^
;;01.51^
;;01.52^
;;01.53^
;;01.6^
;;02.01^
;;02.02^
;;02.03^
;;02.04^
;;02.05^
;;02.06^
;;02.07^
;;02.11^
;;02.12^
;;02.13^
;;02.14^
;;02.2^
;;02.91^
;;02.92^
;;02.93^
;;02.94^
;;02.99^
;;04.01^
;;04.41^
;;07.13^
;;07.14^
;;07.15^
;;07.17^
;;07.51^
;;07.52^
;;07.53^
;;07.54^
;;07.59^
;;07.61^
;;07.62^
;;07.63^
;;07.64^
;;07.65^
;;07.68^
;;07.69^
;;07.71^
;;07.72^
;;07.79^
;;29.92^
;;38.01^
;;38.11^
;;38.31^
;;38.41^
;;38.51^
;;38.61^
;;38.81^
;;39.28^
;;39.51^
;;39.52^
;;39.53^
;;39.72^
;;39.79^
;;EXIT
Q
;
CHGDIAG ;
D BMES^XPDUTL(">>>Modifying records in file 80")
; modify Identifier field (#2) in file 80
N LINE,X,ICDDIAG,ENTRY,DA,DIE,DR,IDENT
S LINE=1
F 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
..S DA=ENTRY,DIE="^ICD9("
..S IDENT=$P(ICDDIAG,U,2)
..S DR="2///^S X=IDENT"
..D ^DIE
..S LINE=LINE+1
; change MDC
S DA=8725,DIE="^ICD9(",IDENT=5
S DR="5///^S X=IDENT"
D ^DIE
; add 80.071, 80.711 and 80.072 records for diag 428.0
I $D(^ICD9(9061,3)) G DELETE
N FDA
S FDA(428,80,"?1,",.01)="`9061"
S FDA(428,80.071,"+2,?1,",.01)=3031001
S FDA(428,80.072,"+3,?1,",.01)=3031001
S FDA(428,80.072,"+3,?1,",1)=5
D UPDATE^DIE("","FDA(428)") K FDA(428)
S FDA(428,80,"?1,",.01)="`9061"
S FDA(428,80.071,"?2,?1,",.01)=3031001
S FDA(428,80.711,"+3,?2,?1,",.01)=115
S FDA(428,80.711,"+4,?2,?1,",.01)=121
S FDA(428,80.711,"+5,?2,?1,",.01)=124
S FDA(428,80.711,"+6,?2,?1,",.01)=127
D UPDATE^DIE("","FDA(428)")
; kill 80.071 and 80.072 subfile records for diag 309.81
DELETE ;
N DA,DIK
S DA(1)=1399
S DA=2
S DIK="^ICD9("_DA(1)_",""3"","
D ^DIK
S DIK="^ICD9("_DA(1)_",""4"","
D ^DIK
;kill 80.071 and 80.072 subfile records for diag 250.70
S DA(1)=8725
S DA=2
S DIK="^ICD9("_DA(1)_",""3"","
D ^DIK
S DIK="^ICD9("_DA(1)_",""4"","
D ^DIK
Q
;
REVD ;
;;402.91^ZX
;;428.32^ZX
;;430.^CQK
;;431.^CQK
;;432.9^CQK
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1817P 4404 printed Dec 13, 2024@01:48:04 Page 2
ICD1817P ;;ALB/EG/JAT - CORRECT PROC CODES ; 6/27/05 1:03pm
+1 ;;18.0;DRG Grouper;**17**;Oct 13,2000
+2 ;
+3 DO CHGPROC
+4 DO CHGDIAG
+5 QUIT
+6 ;
CHGPROC ;
+1 DO BMES^XPDUTL(">>>Modifying records in file 80.1")
+2 ; modify Identifier field (#2) in file 80.1
+3 NEW LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,DIC
+4 SET LINE=1
+5 FOR
SET X=$TEXT(REVP+LINE)
SET ICDPROC=$PIECE(X,";;",2)
if ICDPROC="EXIT"
QUIT
Begin DoDot:1
+6 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
IF ENTRY
Begin DoDot:2
+7 SET DA=ENTRY
SET DIE="^ICD0("
+8 SET IDENT=$PIECE(ICDPROC,U,2)
+9 SET DR="2///^S X=IDENT"
+10 DO ^DIE
+11 SET LINE=LINE+1
End DoDot:2
End DoDot:1
+12 ; kill 80.171 sub-file record and descendants for proc 80.51
+13 NEW DA,DIK
+14 SET DA(1)=3867
+15 SET DA=2
+16 SET DIK="^ICD0("_DA(1)_",""2"","
+17 DO ^DIK
+18 ; add Oct 1,2004 record to 80.171, MDC 1 to 80.1711, and 543
+19 ; to 80.17111 for proc 01.14 ONLY
+20 SET ENTRY=2963
+21 ; check if already created in case patch being re-installed
+22 IF $DATA(^ICD0(ENTRY,2,2))
GOTO SKIP
+23 SET DA(1)=ENTRY
+24 SET DIC="^ICD0("_DA(1)_",2,"
+25 SET DIC(0)="L"
+26 SET X=3041001
KILL DO
DO FILE^DICN
KILL DIC,DA
+27 SET DA(2)=ENTRY
+28 SET DA(1)=2
+29 SET DIC="^ICD0("_DA(2)_",2,"_DA(1)_",1,"
+30 SET DIC(0)="L"
+31 SET X=1
KILL DO
DO FILE^DICN
KILL DIC,DA
+32 SET DA(3)=ENTRY
+33 SET DA(2)=2
+34 SET DA(1)=1
+35 SET DIC="^ICD0("_DA(3)_",2,"_DA(2)_",1,"_DA(1)_",1,"
+36 SET DIC(0)="L"
+37 SET X=543
KILL DO
DO FILE^DICN
KILL DIC,DA
+38 ; add 80.17111 sub-file records to 80.1711 and 80.171
SKIP ;
+1 SET LINE=1
+2 NEW Z
+3 FOR
SET Z=$TEXT(REVPRO+LINE)
SET ICDPROC=$PIECE(Z,";;",2)
if ICDPROC="EXIT"
QUIT
Begin DoDot:1
+4 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
IF ENTRY
Begin DoDot:2
+5 SET DA(3)=ENTRY
SET DA(2)=2
SET DA(1)=1
+6 SET DIC="^ICD0("_DA(3)_",2,"_DA(2)_",1,"_DA(1)_",1,"
+7 SET DIC(0)="L"
+8 ; check if already created in case patch being re-installed
+9 IF $DATA(^ICD0(ENTRY,2,2,1,1,1,2,0))
SET LINE=LINE+1
QUIT
+10 ; add DRG 1,2 and 3
+11 SET X=1
+12 KILL DO
+13 DO FILE^DICN
+14 SET X=2
+15 DO FILE^DICN
+16 SET X=3
+17 DO FILE^DICN
+18 SET LINE=LINE+1
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
REVP ;
+1 ;;36.12^Ob6
+2 ;;36.13^Ob6
+3 ;;36.14^Ob6
+4 ;;51.23^TT
+5 ;;81.61^O
+6 ;;01.14^OQ
+7 ;;02.13^OQK
+8 ;;38.01^OQK
+9 ;;38.11^OQK
+10 ;;38.31^OQK
+11 ;;38.41^OQK
+12 ;;38.51^OQK
+13 ;;38.61^OQK
+14 ;;38.81^OQK
+15 ;;39.28^OQK
+16 ;;39.51^OQK
+17 ;;39.52^OQK
+18 ;;39.53^OQK
+19 ;;39.72^OQK
+20 ;;39.79^OQK
+21 ;;EXIT
+22 QUIT
REVPRO ;
+1 ;;01.59^
+2 ;;01.12^
+3 ;;01.14^
+4 ;;01.15^
+5 ;;01.18^
+6 ;;01.19^
+7 ;;01.21^
+8 ;;01.22^
+9 ;;01.23^
+10 ;;01.24^
+11 ;;01.25^
+12 ;;01.31^
+13 ;;01.32^
+14 ;;01.39^
+15 ;;01.41^
+16 ;;01.42^
+17 ;;01.51^
+18 ;;01.52^
+19 ;;01.53^
+20 ;;01.6^
+21 ;;02.01^
+22 ;;02.02^
+23 ;;02.03^
+24 ;;02.04^
+25 ;;02.05^
+26 ;;02.06^
+27 ;;02.07^
+28 ;;02.11^
+29 ;;02.12^
+30 ;;02.13^
+31 ;;02.14^
+32 ;;02.2^
+33 ;;02.91^
+34 ;;02.92^
+35 ;;02.93^
+36 ;;02.94^
+37 ;;02.99^
+38 ;;04.01^
+39 ;;04.41^
+40 ;;07.13^
+41 ;;07.14^
+42 ;;07.15^
+43 ;;07.17^
+44 ;;07.51^
+45 ;;07.52^
+46 ;;07.53^
+47 ;;07.54^
+48 ;;07.59^
+49 ;;07.61^
+50 ;;07.62^
+51 ;;07.63^
+52 ;;07.64^
+53 ;;07.65^
+54 ;;07.68^
+55 ;;07.69^
+56 ;;07.71^
+57 ;;07.72^
+58 ;;07.79^
+59 ;;29.92^
+60 ;;38.01^
+61 ;;38.11^
+62 ;;38.31^
+63 ;;38.41^
+64 ;;38.51^
+65 ;;38.61^
+66 ;;38.81^
+67 ;;39.28^
+68 ;;39.51^
+69 ;;39.52^
+70 ;;39.53^
+71 ;;39.72^
+72 ;;39.79^
+73 ;;EXIT
+74 QUIT
+75 ;
CHGDIAG ;
+1 DO BMES^XPDUTL(">>>Modifying records in file 80")
+2 ; modify Identifier field (#2) in file 80
+3 NEW LINE,X,ICDDIAG,ENTRY,DA,DIE,DR,IDENT
+4 SET LINE=1
+5 FOR
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))
IF ENTRY
Begin DoDot:2
+7 SET DA=ENTRY
SET DIE="^ICD9("
+8 SET IDENT=$PIECE(ICDDIAG,U,2)
+9 SET DR="2///^S X=IDENT"
+10 DO ^DIE
+11 SET LINE=LINE+1
End DoDot:2
End DoDot:1
+12 ; change MDC
+13 SET DA=8725
SET DIE="^ICD9("
SET IDENT=5
+14 SET DR="5///^S X=IDENT"
+15 DO ^DIE
+16 ; add 80.071, 80.711 and 80.072 records for diag 428.0
+17 IF $DATA(^ICD9(9061,3))
GOTO DELETE
+18 NEW FDA
+19 SET FDA(428,80,"?1,",.01)="`9061"
+20 SET FDA(428,80.071,"+2,?1,",.01)=3031001
+21 SET FDA(428,80.072,"+3,?1,",.01)=3031001
+22 SET FDA(428,80.072,"+3,?1,",1)=5
+23 DO UPDATE^DIE("","FDA(428)")
KILL FDA(428)
+24 SET FDA(428,80,"?1,",.01)="`9061"
+25 SET FDA(428,80.071,"?2,?1,",.01)=3031001
+26 SET FDA(428,80.711,"+3,?2,?1,",.01)=115
+27 SET FDA(428,80.711,"+4,?2,?1,",.01)=121
+28 SET FDA(428,80.711,"+5,?2,?1,",.01)=124
+29 SET FDA(428,80.711,"+6,?2,?1,",.01)=127
+30 DO UPDATE^DIE("","FDA(428)")
+31 ; kill 80.071 and 80.072 subfile records for diag 309.81
DELETE ;
+1 NEW DA,DIK
+2 SET DA(1)=1399
+3 SET DA=2
+4 SET DIK="^ICD9("_DA(1)_",""3"","
+5 DO ^DIK
+6 SET DIK="^ICD9("_DA(1)_",""4"","
+7 DO ^DIK
+8 ;kill 80.071 and 80.072 subfile records for diag 250.70
+9 SET DA(1)=8725
+10 SET DA=2
+11 SET DIK="^ICD9("_DA(1)_",""3"","
+12 DO ^DIK
+13 SET DIK="^ICD9("_DA(1)_",""4"","
+14 DO ^DIK
+15 QUIT
+16 ;
REVD ;
+1 ;;402.91^ZX
+2 ;;428.32^ZX
+3 ;;430.^CQK
+4 ;;431.^CQK
+5 ;;432.9^CQK
+6 ;;EXIT
