- 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 Jan 18, 2025@02:49:17 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