source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD1832S.m@ 1008

Last change on this file since 1008 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.8 KB
Line 
1ICD1832S ;;ALB/EG/JAT - FY 2008 UPDATE FOLLOW-UP; 6/19/05 4:08pm ; 12/19/07 12:15pm
2 ;;18.0;DRG Grouper;**32**;Oct 13,2000;Build 9
3 ;
4 Q
5 ;
6PRO ;-update operation/procedure codes
7 ; from Table 6B in Fed Reg - assumes new codes already added by Lexicon
8 D BMES^XPDUTL(">>>Modifying new op/pro codes - file 80.1")
9 N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,MDC24,SUBLINE,DATA,FDA
10 F LINE=1:1 S X=$T(REV+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
11 .Q:ICDPROC["+"
12 .; check if already created in case patch being re-installed
13 .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
14 .I $D(^ICD0(ENTRY,2,"B",3071001)) D
15 ..;kill existing entry for FY
16 .. S DA(1)=ENTRY,DA=$O(^ICD0(ENTRY,2,"B",3071001,0))
17 .. S DIK="^ICD0("_DA(1)_",2," D ^DIK K DIK,DA
18 .I ENTRY D
19 ..;check for possible inactive dupe
20 ..I $P($G(^ICD0(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",ENTRY)) I 'ENTRY Q
21 ..S DA=ENTRY,DIE="^ICD0("
22 ..S IDENT=$P(ICDPROC,U,2)
23 ..S MDC24=$P(ICDPROC,U,3)
24 ..S DR="2///^S X=IDENT;5///^S X=MDC24"
25 ..I IDENT=""&(MDC24="") Q
26 ..D ^DIE
27 ..;add 80.171, 80.1711 and 80.17111 records
28 ..F SUBLINE=1:1 S X=$T(REV+LINE+SUBLINE) S DATA=$P(X,";;",2) Q:DATA'["+" D
29 ...I SUBLINE=1 D
30 ....S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
31 ....S FDA(1820,80.171,"+2,?1,",.01)=3071001
32 ....D UPDATE^DIE("","FDA(1820)") K FDA(1820)
33 ...S DATA=$E(DATA,2,99)
34 ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
35 ...S FDA(1820,80.171,"?2,?1,",.01)=3071001
36 ...S FDA(1820,80.1711,"+3,?2,?1,",.01)=$P(DATA,U)
37 ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
38 ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
39 ...S FDA(1820,80.171,"?2,?1,",.01)=3071001
40 ...S FDA(1820,80.1711,"?3,?2,?1,",.01)=$P(DATA,U)
41 ...S FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$P(DATA,U,2)
42 ...I $P(DATA,U,3) S FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$P(DATA,U,3)
43 ...I $P(DATA,U,4) S FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$P(DATA,U,4)
44 ...I $P(DATA,U,5) S FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$P(DATA,U,5)
45 ...I $P(DATA,U,6) S FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$P(DATA,U,6)
46 ...I $P(DATA,U,7) S FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$P(DATA,U,7)
47 ...I $P(DATA,U,8) S FDA(1820,80.17111,"+10,?3,?2,?1,",.01)=$P(DATA,U,8)
48 ...I $P(DATA,U,9) S FDA(1820,80.17111,"+11,?3,?2,?1,",.01)=$P(DATA,U,9)
49 ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
50 Q
51 ;
52REV ;PROC/OP^IDENTIFIER^MDC24^DRG...
53 ;;53.00^OzJ^
54 ;;+6^350^351^352
55 ;;53.01^OzJ^
56 ;;+6^350^351^352
57 ;;53.02^OzJ^
58 ;;+6^350^351^352
59 ;;53.03^OzJ^
60 ;;+6^350^351^352
61 ;;53.04^OzJ^
62 ;;+6^350^351^352
63 ;;53.05^OzJ^
64 ;;+6^350^351^352
65 ;;53.10^OzJ^
66 ;;+6^350^351^352
67 ;;53.11^OzJ^
68 ;;+6^350^351^352
69 ;;53.12^OzJ^
70 ;;+6^350^351^352
71 ;;53.13^OzJ^
72 ;;+6^350^351^352
73 ;;53.14^OzJ^
74 ;;+6^350^351^352
75 ;;53.15^OzJ^
76 ;;+6^350^351^352
77 ;;53.16^OzJ^
78 ;;+6^350^351^352
79 ;;53.17^OzJ^
80 ;;+6^350^351^352
81 ;;53.21^OzJ^
82 ;;+6^350^351^352
83 ;;53.29^OzJ^
84 ;;+6^350^351^352
85 ;;53.31^OzJ^
86 ;;+6^350^351^352
87 ;;53.39^OzJ^
88 ;;+6^350^351^352
89 ;;EXIT
Note: See TracBrowser for help on using the repository browser.