source: WorldVistAEHR/trunk/r/DRG_GROUPER-ICD--ICPT/ICD18PT.m@ 1766

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1ICD18PT ;ALB/ESD - DRG V16 POST-INSTALL ; 10/23/00 11:57am
2 ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1
3 ;
4 ;
5 ; This routine may be re-run.
6 ;
7EN ;- Post-Install entry point
8 ;
9 ;- Remove dup "B" xrefs from Description multiple
10 ;D REMXREF
11 ;
12 ;- Revise DRGs/new descriptions, or changed to Inactie
13 ;D DRGEDIT
14 ;
15 ;- Weights & trims for FY 97
16 ;D BEGWT
17 ;
18 ;- Display reminder msg
19 D BMES^XPDUTL(">>> IMPORTANT: Please restore your ICD9 and ICD0 global files from <<<")
20 D MES^XPDUTL(">>> ICD9_18.GBL and ICD0_18.GBL at this time. <<<")
21 Q
22 ;
23 ;
24REMXREF ;- Remove dup "B" xref on Description multiple and reindex
25 ;
26 N DA,DIK,I,ICDIEN
27 D MES^XPDUTL("")
28 D BMES^XPDUTL(">>> Correcting duplicate ""B"" cross-ref entries in the Description")
29 D MES^XPDUTL(" multiple of the DRG file (#80.2)...")
30 F I=1:1 S ICDIEN=$P($T(REMXDRG+I),";;",2) Q:ICDIEN="QUIT" D
31 . K ^ICD(ICDIEN,1,"B")
32 . S DA(1)=ICDIEN,DA=1
33 . S DIK="^ICD("_DA(1)_",1,"
34 . S DIK(1)=".01^B"
35 . D EN1^DIK
36 D MES^XPDUTL(">>> ...completed.")
37 D MES^XPDUTL("")
38 Q
39 ;
40 ;
41DRGEDIT ;- Edit DRG records (Description change)
42 ;
43 N CNT,DA,DIC,DIE,DR,DRG,I,ICDI,ICDIEN,ICDESC,NOVAL,X,Y
44 S CNT=0
45 D BMES^XPDUTL(">>> Revising DRG records in the DRG file (#80.2)...")
46 F I=1:1 S DRG=$P($T(REVDRG+I),";;",2) Q:DRG="QUIT" D
47 . S DIC="^ICD(",DIC(0)="MX"
48 . S X=$P(DRG,"^")
49 . D ^DIC
50 . I +Y>0 D
51 .. S ICDESC=""
52 .. F S ICDESC=$O(^ICD(+Y,1,"B",ICDESC)) Q:ICDESC="" S ICDIEN=+$O(^(ICDESC,0))
53 .. S (ICDI,DA(1))=+Y,DA=ICDIEN
54 .. S DIE=DIC_DA(1)_","_DA_","
55 .. S DR=".01///^S X=$P(DRG,""^"",2)"
56 .. D ^DIE
57 .. D
58 ... I $P(DRG,"^",3)="" Q
59 ... S DIE=DIC
60 ... S DA=ICDI
61 ... S DR=".06///^S X=$P(DRG,""^"",3);5///^S X=$P(DRG,""^"",4)"
62 ... D ^DIE
63 .. S CNT=CNT+1
64 .. D MES^XPDUTL(" Edited: "_$P(DRG,"^")_" to "_$P(DRG,"^",2))
65 . E D ERRMSG($P(DRG,"^"))
66 ;
67 ;- Total DRG records revised
68 D MES^XPDUTL(">>> ...completed. "_CNT_" record(s) revised.")
69 D MES^XPDUTL("")
70 Q
71 ;
72 ;
73ERRMSG(VAR,IN) ;- Display error msg if DRG not found
74 ;
75 Q:VAR=""
76 D BMES^XPDUTL(">>> ERROR: "_VAR_" was not found and could not be "_$S(+$G(IN):"inactivated.",1:"revised."))
77 D MES^XPDUTL("")
78 Q
79 ;
80 ;
81BEGWT ;- Entry point for wts & trims update for 97
82 N DRG,FYR,ICDLOW,ICDHIGH,ICDLOS,ICDWWU,ICDCNT,WT,I,J
83 D UPD97
84 Q
85 ;
86 ;
87UPD97 ;- Load FY 97 WWU into ICD DRG file (#80.2)
88 S FYR=2970000
89 D BMES^XPDUTL(">>> Adding FY 97 Weights & Trims...")
90 F I=1:1 S WT=$P($T(WW97+I^ICD16P97),";;",2,99) Q:'WT D SETVAR,FY,MORE
91 F I=1:1 S WT=$P($T(WW97+I^ICD1697A),";;",2,99) Q:'WT D SETVAR,FY,MORE
92 S ^ICD("AFY",2970000)=""
93 D MES^XPDUTL(">>> ...completed.")
94 D MES^XPDUTL("")
95 Q
96 ;
97 ;
98FY ;- Set FY multiple with FYR stats
99 S $P(^ICD(DRG,"FY",FYR,0),"^",1,4)=FYR_"^"_ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",9)=ICDLOS
100 I '$D(^ICD(DRG,"FY",0)) S ^ICD(DRG,"FY",0)="^80.22^"_FYR_"^1" Q
101 S ICDCNT="" F J=0:1 S ICDCNT=$O(^ICD(DRG,"FY",ICDCNT)) Q:ICDCNT=""
102 S $P(^ICD(DRG,"FY",0),"^",3,4)=FYR_"^"_J
103 Q
104 ;
105 ;
106SETVAR ;- Set variables
107 S DRG=+WT,ICDLOW=$P(WT,"^",2),ICDLOS=$P(WT,"^",3),ICDHIGH=$P(WT,"^",4),ICDWWU=$P(WT,"^",5)
108 Q
109 ;
110 ;
111MORE ;- Set zero node with FY 97 stats
112 S $P(^ICD(DRG,0),"^",2,4)=ICDWWU_"^"_ICDLOW_"^"_ICDHIGH,$P(^(0),"^",8)=ICDLOS
113 D FY
114 Q
115 ;
116 ;
117REVDRG ;- Description edits
118 ;;DRG104^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W CARD CATH
119 ;;DRG105^CARDIAC VALVE & OTH MAJ CARDIOTHORACIC PROC W/O CARD CATH
120 ;;DRG106^CORONARY BYPASS WITH PTCA^1^5
121 ;;DRG107^CORONARY BYPASS W CARDIAC CATH^1^5
122 ;;DRG109^CORONARY BYPASS W/O CARDIAC CATH^1^5
123 ;;DRG115^PERM PACE IMPLNT W AMI,HRT FAIL OR SHOCK OR AICD LEAD OR GEN PROC
124 ;;DRG116^OTH PERM CARDIAC PACEMAKER IMPLANT OR PTCA W CORONARY ART STENT
125 ;;DRG121^CIRCULATORY DISORDERS W AMI & MAJOR COMP DISCH ALIVE
126 ;;DRG122^CIRCULATORY DISORDERS W AMI W/O MAJOR COMP DISCH ALIVE
127 ;;DRG406^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W CC
128 ;;DRG407^MYELOPROLIF DISORD OR POORLY DIFF NEOPL W MAJ O.R.PROC W/O CC
129 ;;DRG485^LIMB REATTACHMENT, HIP AND FEMUR PROC FOR MULTIPLE SIGNIFICANT TR
130 ;;DRG214^NO LONGER VALID
131 ;;DRG215^NO LONGER VALID
132 ;;DRG221^NO LONGER VALID
133 ;;DRG222^NO LONGER VALID
134 ;;DRG456^NO LONGER VALID
135 ;;DRG457^NO LONGER VALID
136 ;;DRG458^NO LONGER VALID
137 ;;DRG459^NO LONGER VALID
138 ;;DRG460^NO LONGER VALID
139 ;;DRG472^NO LONGER VALID
140 ;;QUIT
141 ;
142 ;
143REMXDRG ;- DRG dup "B" xref IENs
144 ;;11
145 ;;48
146 ;;53
147 ;;54
148 ;;89
149 ;;90
150 ;;91
151 ;;104
152 ;;105
153 ;;116
154 ;;193
155 ;;194
156 ;;195
157 ;;196
158 ;;197
159 ;;198
160 ;;384
161 ;;410
162 ;;444
163 ;;445
164 ;;446
165 ;;461
166 ;;477
167 ;;482
168 ;;483
169 ;;485
170 ;;486
171 ;;488
172 ;;490
173 ;;QUIT
Note: See TracBrowser for help on using the repository browser.