Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICD1817P

ICD1817P.m

Go to the documentation of this file.
  1. ICD1817P ;;ALB/EG/JAT - CORRECT PROC CODES ; 6/27/05 1:03pm
  1. ;;18.0;DRG Grouper;**17**;Oct 13,2000
  1. ;
  1. D CHGPROC
  1. D CHGDIAG
  1. Q
  1. ;
  1. CHGPROC ;
  1. D BMES^XPDUTL(">>>Modifying records in file 80.1")
  1. ; modify Identifier field (#2) in file 80.1
  1. N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,DIC
  1. S LINE=1
  1. F S X=$T(REVP+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
  1. .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0)) I ENTRY D
  1. ..S DA=ENTRY,DIE="^ICD0("
  1. ..S IDENT=$P(ICDPROC,U,2)
  1. ..S DR="2///^S X=IDENT"
  1. ..D ^DIE
  1. ..S LINE=LINE+1
  1. ; kill 80.171 sub-file record and descendants for proc 80.51
  1. N DA,DIK
  1. S DA(1)=3867
  1. S DA=2
  1. S DIK="^ICD0("_DA(1)_",""2"","
  1. D ^DIK
  1. ; add Oct 1,2004 record to 80.171, MDC 1 to 80.1711, and 543
  1. ; to 80.17111 for proc 01.14 ONLY
  1. S ENTRY=2963
  1. ; check if already created in case patch being re-installed
  1. I $D(^ICD0(ENTRY,2,2)) G SKIP
  1. S DA(1)=ENTRY
  1. S DIC="^ICD0("_DA(1)_",2,"
  1. S DIC(0)="L"
  1. S X=3041001 K DO D FILE^DICN K DIC,DA
  1. S DA(2)=ENTRY
  1. S DA(1)=2
  1. S DIC="^ICD0("_DA(2)_",2,"_DA(1)_",1,"
  1. S DIC(0)="L"
  1. S X=1 K DO D FILE^DICN K DIC,DA
  1. S DA(3)=ENTRY
  1. S DA(2)=2
  1. S DA(1)=1
  1. S DIC="^ICD0("_DA(3)_",2,"_DA(2)_",1,"_DA(1)_",1,"
  1. S DIC(0)="L"
  1. S X=543 K DO D FILE^DICN K DIC,DA
  1. ; add 80.17111 sub-file records to 80.1711 and 80.171
  1. SKIP ;
  1. S LINE=1
  1. N Z
  1. F S Z=$T(REVPRO+LINE) S ICDPROC=$P(Z,";;",2) Q:ICDPROC="EXIT" D
  1. .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0)) I ENTRY D
  1. ..S DA(3)=ENTRY,DA(2)=2,DA(1)=1
  1. ..S DIC="^ICD0("_DA(3)_",2,"_DA(2)_",1,"_DA(1)_",1,"
  1. ..S DIC(0)="L"
  1. ..; check if already created in case patch being re-installed
  1. ..I $D(^ICD0(ENTRY,2,2,1,1,1,2,0)) S LINE=LINE+1 Q
  1. ..; add DRG 1,2 and 3
  1. ..S X=1
  1. ..K DO
  1. ..D FILE^DICN
  1. ..S X=2
  1. ..D FILE^DICN
  1. ..S X=3
  1. ..D FILE^DICN
  1. ..S LINE=LINE+1
  1. Q
  1. ;
  1. REVP ;
  1. ;;36.12^Ob6
  1. ;;36.13^Ob6
  1. ;;36.14^Ob6
  1. ;;51.23^TT
  1. ;;81.61^O
  1. ;;01.14^OQ
  1. ;;02.13^OQK
  1. ;;38.01^OQK
  1. ;;38.11^OQK
  1. ;;38.31^OQK
  1. ;;38.41^OQK
  1. ;;38.51^OQK
  1. ;;38.61^OQK
  1. ;;38.81^OQK
  1. ;;39.28^OQK
  1. ;;39.51^OQK
  1. ;;39.52^OQK
  1. ;;39.53^OQK
  1. ;;39.72^OQK
  1. ;;39.79^OQK
  1. ;;EXIT
  1. Q
  1. REVPRO ;
  1. ;;01.59^
  1. ;;01.12^
  1. ;;01.14^
  1. ;;01.15^
  1. ;;01.18^
  1. ;;01.19^
  1. ;;01.21^
  1. ;;01.22^
  1. ;;01.23^
  1. ;;01.24^
  1. ;;01.25^
  1. ;;01.31^
  1. ;;01.32^
  1. ;;01.39^
  1. ;;01.41^
  1. ;;01.42^
  1. ;;01.51^
  1. ;;01.52^
  1. ;;01.53^
  1. ;;01.6^
  1. ;;02.01^
  1. ;;02.02^
  1. ;;02.03^
  1. ;;02.04^
  1. ;;02.05^
  1. ;;02.06^
  1. ;;02.07^
  1. ;;02.11^
  1. ;;02.12^
  1. ;;02.13^
  1. ;;02.14^
  1. ;;02.2^
  1. ;;02.91^
  1. ;;02.92^
  1. ;;02.93^
  1. ;;02.94^
  1. ;;02.99^
  1. ;;04.01^
  1. ;;04.41^
  1. ;;07.13^
  1. ;;07.14^
  1. ;;07.15^
  1. ;;07.17^
  1. ;;07.51^
  1. ;;07.52^
  1. ;;07.53^
  1. ;;07.54^
  1. ;;07.59^
  1. ;;07.61^
  1. ;;07.62^
  1. ;;07.63^
  1. ;;07.64^
  1. ;;07.65^
  1. ;;07.68^
  1. ;;07.69^
  1. ;;07.71^
  1. ;;07.72^
  1. ;;07.79^
  1. ;;29.92^
  1. ;;38.01^
  1. ;;38.11^
  1. ;;38.31^
  1. ;;38.41^
  1. ;;38.51^
  1. ;;38.61^
  1. ;;38.81^
  1. ;;39.28^
  1. ;;39.51^
  1. ;;39.52^
  1. ;;39.53^
  1. ;;39.72^
  1. ;;39.79^
  1. ;;EXIT
  1. Q
  1. ;
  1. CHGDIAG ;
  1. D BMES^XPDUTL(">>>Modifying records in file 80")
  1. ; modify Identifier field (#2) in file 80
  1. N LINE,X,ICDDIAG,ENTRY,DA,DIE,DR,IDENT
  1. S LINE=1
  1. F S X=$T(REVD+LINE) S ICDDIAG=$P(X,";;",2) Q:ICDDIAG="EXIT" D
  1. .S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",0)) I ENTRY D
  1. ..S DA=ENTRY,DIE="^ICD9("
  1. ..S IDENT=$P(ICDDIAG,U,2)
  1. ..S DR="2///^S X=IDENT"
  1. ..D ^DIE
  1. ..S LINE=LINE+1
  1. ; change MDC
  1. S DA=8725,DIE="^ICD9(",IDENT=5
  1. S DR="5///^S X=IDENT"
  1. D ^DIE
  1. ; add 80.071, 80.711 and 80.072 records for diag 428.0
  1. I $D(^ICD9(9061,3)) G DELETE
  1. N FDA
  1. S FDA(428,80,"?1,",.01)="`9061"
  1. S FDA(428,80.071,"+2,?1,",.01)=3031001
  1. S FDA(428,80.072,"+3,?1,",.01)=3031001
  1. S FDA(428,80.072,"+3,?1,",1)=5
  1. D UPDATE^DIE("","FDA(428)") K FDA(428)
  1. S FDA(428,80,"?1,",.01)="`9061"
  1. S FDA(428,80.071,"?2,?1,",.01)=3031001
  1. S FDA(428,80.711,"+3,?2,?1,",.01)=115
  1. S FDA(428,80.711,"+4,?2,?1,",.01)=121
  1. S FDA(428,80.711,"+5,?2,?1,",.01)=124
  1. S FDA(428,80.711,"+6,?2,?1,",.01)=127
  1. D UPDATE^DIE("","FDA(428)")
  1. ; kill 80.071 and 80.072 subfile records for diag 309.81
  1. DELETE ;
  1. N DA,DIK
  1. S DA(1)=1399
  1. S DA=2
  1. S DIK="^ICD9("_DA(1)_",""3"","
  1. D ^DIK
  1. S DIK="^ICD9("_DA(1)_",""4"","
  1. D ^DIK
  1. ;kill 80.071 and 80.072 subfile records for diag 250.70
  1. S DA(1)=8725
  1. S DA=2
  1. S DIK="^ICD9("_DA(1)_",""3"","
  1. D ^DIK
  1. S DIK="^ICD9("_DA(1)_",""4"","
  1. D ^DIK
  1. Q
  1. ;
  1. REVD ;
  1. ;;402.91^ZX
  1. ;;428.32^ZX
  1. ;;430.^CQK
  1. ;;431.^CQK
  1. ;;432.9^CQK
  1. ;;EXIT