source: WorldVistAEHR/trunk/r/SURGERY-SR/SR169UTL.m@ 1154

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

initial load of WorldVistAEHR
File size: 15.4 KB
RevLine 
[613]1SR169UTL ;BIR/ADM - FY08 CPT EXCLUSION UTILITY ;06/25/08
2 ;;3.0; Surgery ;**169**;24 Jun 93;Build 2
3 Q
4PEX ; populate file 137
5 N SRI,SRJ,SRL,SRLIST,SRX,SRY,X
6 D MES^XPDUTL(" Populating CPT EXCLUSIONS file...")
7 K ^SRO(137) S ^SRO(137,0)="CPT EXCLUSIONS^137P^^"
8 F SRJ=0:1 S SRLIST=$P($T(LIST+SRJ),";;",2) Q:SRLIST="" F SRI=1:1 S SRX=$P(SRLIST,",",SRI) Q:SRX="" I $D(^ICPT("B",SRX)) D INT
9 S SRX="00000" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","01999")) D INT
10 S SRX="69999" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","79999")) D INT
11 S SRX="79999" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","89999")) D INT
12 S SRX="89999" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","99999")) D INT
13 S SRX="A" F S SRX=$O(^ICPT("B",SRX)) Q:SRX="" D INT
14 S SRX="" F S SRX=$O(^ICPT("B",SRX)) Q:SRX="" I "TF"[$E(SRX,5) D INT
15 K DA,DIC,DD,DO,DINUM
16 Q
17INT S SRY=0,SRY=$O(^ICPT("B",SRX,SRY)) Q:SRY=""
18 K DA,DIC,DD,DO,DINUM S (DINUM,X)=SRY,DIC="^SRO(137,",DIC(0)="L" D FILE^DICN
19 Q
20LIST ;;10021,10022,10040,10060,10061,10080,10081,10120,11000,11010,11011,11012,11040,11041,11042,11043,11044
21 ;;11055,11056,11057,11100,11101,11200,11201,11300,11301,11302,11303,11305,11306,11307,11308
22 ;;11310,11311,11312,11313,11400,11401,11402,11403,11404,11406,11420,11421,11422,11423,11424
23 ;;11426,11440,11441,11442,11443,11444,11446,11450,11451,11462,11463,11470,11471,11600,11601
24 ;;11602,11603,11604,11606,11620,11621,11622,11623,11624,11626,11640,11641,11642,11643,11644
25 ;;11646,11719,11720,11721,11730,11732,11740,11750,11752,11755,11760,11762,11765,11770,11771
26 ;;11772,11900,11901,11920,11921,11922,11950,11951,11952,11954,11970,11971,11975,11976,11977
27 ;;11980,11981,11982,11983,12001,12002,12004,12005,12006,12007,12011,12013,12014,12015,12016
28 ;;12017,12018,12020,12021,12031,12032,12034,12035,12036,12037,12041,12042,12044,12045,12046
29 ;;12047,12051,12052,12053,12054,12055,12056,12057,13100,13101,13102,13120,13121,13122,13131
30 ;;13132,13133,13150,13151,13152,13153,13160,14000,14001,14020,14021,14040,14041,14060,14061
31 ;;14300,14350,15050,15100,15101,15110,15111,15115,15116,15120,15121,15130,15131,15135,15136
32 ;;15150,15151,15152,15155,15156,15157,15170,15171,15175,15176,15200,15201,15220,15221,15240
33 ;;15241,15260,15261,15300,15301,15320,15321,15330,15331,15335,15336,15340,15341,15360,15361
34 ;;15365,15366,15400,15401,15420,15421,15430,15431,15775,15776,15780,15781,15782,15783,15786
35 ;;15787,15788,15789,15792,15793,15819,15820,15821,15822,15823,15824,15825,15826,15828,15829
36 ;;15832,15833,15834,15835,15836,15837,15838,15839,15850,15851,15852,15860,16000,16020,16025
37 ;;16030,16035,16036,17000,17003,17110,17250,17260,17261,17262,17263,17264,17266,17270,17271
38 ;;17272,17273,17274,17276,17280,17281,17282,17283,17284,17286,17340,17360,17380,17999,19000
39 ;;19001,19030,19100,19101,19102,19103,19112,19290,19291,19295,20200,20205,20206,20220,20225
40 ;;20240,20245,20250,20251,20500,20501,20520,20525,20526,20550,20551,20552,20553,20555,20600
41 ;;20605,20610,20612,20615,20650,20660,20661,20662,20663,20664,20665,20670,20680,20690,20692
42 ;;20693,20694,20912,20924,20950,20974,20979,20982,20985,20986,20987,21030,21031,21032,21073
43 ;;21076,21077,21079,21080,21081,21082,21083,21084,21085,21086,21087,21088,21089,21116,21210
44 ;;21310,21315,21320,21325,21330,21335,21336,21337,21338,21339,21340,21345,21400,21401,21421
45 ;;21431,21440,21450,21451,21452,21453,21480,21485,21497,21550,21800,21820,21920,21925,21930
46 ;;22305,22310,22315,22505,22520,22521,22522,23065,23066,23100,23330,23331,23350,23500,23505
47 ;;23520,23525,23540,23545,23570,23575,23600,23605,23620,23625,23650,23655,23665,23675,23700
48 ;;23930,23931,24065,24066,24100,24101,24147,24160,24164,24200,24220,24300,24343,24470,24500
49 ;;24505,24530,24535,24560,24565,24576,24577,24600,24605,24620,24640,24650,24655,24670,24675
50 ;;25028,25031,25065,25066,25075,25100,25246,25250,25251,25259,25500,25505,25520,25530,25535
51 ;;25560,25565,25600,25605,25622,25624,25630,25635,25650,25651,25660,25671,25675,25680,25690
52 ;;25800,25805,25810,25820,25825,25830,26010,26011,26020,26025,26030,26034,26035,26037,26040
53 ;;26045,26055,26060,26070,26075,26080,26100,26105,26110,26115,26140,26160,26200,26210,26262
54 ;;26320,26340,26416,26432,26508,26516,26517,26518,26600,26605,26607,26608,26641,26645,26670
55 ;;26675,26700,26705,26720,26725,26740,26742,26750,26755,26756,26770,26775,26820,26841,26842
56 ;;26843,26844,26850,26852,26860,26861,26862,26863,26910,26951,27003,27040,27041,27050,27052
57 ;;27065,27090,27091,27093,27095,27096,27175,27178,27193,27194,27200,27216,27220,27222,27230
58 ;;27232,27238,27240,27246,27250,27252,27256,27257,27265,27266,27267,27268,27275,27306,27323
59 ;;27324,27330,27370,27500,27501,27502,27503,27508,27510,27516,27517,27520,27530,27532,27538
60 ;;27550,27552,27560,27562,27570,27613,27614,27648,27690,27691,27750,27752,27760,27762,27767
61 ;;27768,27780,27781,27786,27788,27808,27810,27816,27818,27824,27825,27830,27831,27840,27842
62 ;;27860,27870,27871,28001,28005,28008,28010,28011,28020,28022,28024,28035,28043,28045,28046
63 ;;28050,28052,28054,28055,28060,28062,28070,28072,28080,28086,28088,28090,28092,28100,28102
64 ;;28103,28104,28106,28107,28108,28110,28111,28112,28113,28114,28116,28118,28119,28120,28122
65 ;;28124,28126,28130,28140,28150,28153,28160,28171,28173,28175,28190,28192,28193,28200,28202
66 ;;28208,28210,28220,28222,28225,28226,28230,28232,28234,28238,28240,28250,28260,28261,28262
67 ;;28264,28270,28272,28280,28285,28286,28288,28289,28290,28292,28293,28294,28296,28297,28298
68 ;;28299,28300,28302,28304,28305,28306,28307,28308,28309,28310,28312,28313,28315,28320,28322
69 ;;28340,28341,28344,28345,28360,28400,28405,28406,28415,28430,28435,28436,28450,28455,28456
70 ;;28465,28470,28475,28476,28485,28490,28495,28496,28505,28510,28515,28525,28530,28531,28540
71 ;;28545,28546,28555,28570,28575,28576,28585,28600,28605,28606,28615,28630,28635,28636,28645
72 ;;28660,28665,28666,28675,28705,28715,28725,28730,28735,28737,28740,28750,28755,28760,28810
73 ;;28820,28825,28890,28899,29000,29010,29015,29020,29025,29035,29040,29044,29046,29049,29055
74 ;;29058,29065,29075,29085,29086,29105,29125,29126,29130,29131,29200,29220,29240,29260,29280
75 ;;29305,29325,29345,29355,29358,29365,29405,29425,29435,29440,29445,29450,29505,29515,29520
76 ;;29530,29540,29550,29580,29590,29700,29705,29710,29715,29720,29730,29740,29750,29799,29800
77 ;;29804,29805,29830,29836,29840,29843,29845,29848,29856,29860,29863,29870,29900,29901,29902
78 ;;30000,30020,30100,30110,30115,30117,30118,30120,30124,30125,30130,30140,30150,30160,30200
79 ;;30210,30220,30300,30310,30320,30400,30410,30420,30430,30435,30450,30460,30462,30465,30520
80 ;;30540,30545,30560,30580,30600,30620,30630,30801,30802,30901,30903,30905,30906,30915,30920
81 ;;30930,30999,31000,31002,31020,31030,31032,31040,31050,31051,31070,31075,31080,31081,31084
82 ;;31085,31086,31087,31090,31200,31201,31205,31225,31230,31231,31233,31235,31237,31238,31239
83 ;;31240,31254,31255,31256,31267,31276,31287,31288,31290,31291,31292,31293,31294,31299,31500
84 ;;31502,31505,31510,31511,31512,31513,31515,31520,31525,31526,31527,31528,31529,31530,31531
85 ;;31535,31536,31540,31541,31545,31546,31560,31561,31570,31571,31575,31576,31577,31578,31579
86 ;;31582,31584,31588,31600,31601,31603,31605,31610,31612,31613,31615,31622,31623,31624,31625
87 ;;31628,31629,31630,31631,31632,31633,31635,31640,31641,31643,31645,31646,31656,31715,31717
88 ;;31720,31725,31730,31830,32000,32002,32005,32019,32020,32400,32405,32420,32421,32422,32550
89 ;;32551,32560,32601,32602,32603,32604,32605,32606,32850,32855,32856,32960,33206,33207,33208
90 ;;33210,33211,33212,33213,33214,33215,33216,33217,33218,33220,33222,33223,33224,33225,33226
91 ;;33233,33234,33235,33236,33237,33238,33240,33241,33243,33244,33249,33282,33284,33420,33470
92 ;;33471,33930,33933,33935,33940,33944,33945,33960,33961,33967,33968,33970,33971,33973,33974
93 ;;33975,33976,33977,33978,33979,33980,35400,35450,35452,35454,35456,35458,35459,35460,35470
94 ;;35471,35472,35473,35474,35475,35476,35480,35481,35482,35483,35484,35485,35490,35491,35492
95 ;;35493,35494,35495,36000,36002,36005,36010,36011,36012,36013,36014,36015,36100,36120,36140
96 ;;36145,36160,36200,36215,36216,36217,36218,36245,36246,36247,36248,36260,36261,36262,36299
97 ;;36400,36405,36406,36410,36415,36416,36420,36425,36430,36440,36450,36455,36460,36468,36469
98 ;;36470,36471,36481,36500,36510,36511,36512,36513,36514,36515,36516,36522,36540,36550,36555
99 ;;36556,36557,36558,36560,36561,36563,36565,36566,36568,36569,36570,36571,36575,36576,36578
100 ;;36580,36581,36582,36583,36584,36585,36589,36590,36591,36592,36593,36595,36596,36597,36600
101 ;;36620,36625,36640,36660,36680,36800,36810,36815,36820,36821,36822,36823,36825,36830,36831
102 ;;36832,36833,36835,36870,37183,37195,37200,37209,37250,37251,37501,37609,37620,37785,38200
103 ;;38204,38205,38206,38207,38208,38209,38210,38211,38212,38213,38214,38215,38220,38221,38230
104 ;;38240,38241,38242,38500,38505,38510,38520,38525,38530,38790,38792,38794,40490,40799,40806
105 ;;40808,40831,41010,41015,41019,41100,41105,41108,41115,41250,41251,41252,41510,41520,41800
106 ;;41805,41870,41872,41874,41899,42000,42100,42180,42182,42280,42281,42310,42400,42405,42600
107 ;;42650,42660,42800,42802,42804,42806,42820,42821,42825,42826,42830,42831,42835,42836,42860
108 ;;42970,42971,43200,43201,43202,43204,43205,43215,43216,43217,43219,43220,43226,43227,43228
109 ;;43231,43232,43234,43235,43236,43237,43238,43239,43240,43241,43242,43243,43244,43245,43246
110 ;;43247,43248,43249,43250,43251,43255,43256,43257,43258,43259,43260,43261,43262,43263,43264
111 ;;43265,43267,43268,43269,43271,43272,43450,43453,43456,43458,43460,43499,43600,43653,43752
112 ;;43760,43761,43830,44015,44100,44132,44133,44135,44136,44137,44300,44360,44361,44363,44364
113 ;;44365,44366,44369,44370,44372,44373,44376,44377,44378,44379,44380,44382,44383,44385,44386
114 ;;44388,44389,44390,44391,44392,44393,44394,44397,44500,44715,44720,44721,44901,45100,45300
115 ;;45303,45305,45307,45308,45309,45315,45317,45320,45321,45327,45330,45331,45332,45333,45334
116 ;;45335,45337,45338,45339,45340,45341,45342,45345,45355,45378,45379,45380,45381,45382,45383
117 ;;45384,45385,45386,45387,45520,45900,45915,45990,46050,46070,46080,46083,46200,46210,46211
118 ;;46220,46221,46230,46250,46255,46257,46258,46260,46261,46262,46270,46275,46280,46285,46288,
119 ;;46320,46500,46505,46600,46604,46606,46608,46610,46611,46612,46614,46615,46700,46705,46706
120 ;;46754,46900,46910,46916,46917,46922,46924,46934,46935,46936,46937,46938,46945,46946,47000
121 ;;47011,47100,47133,47135,47136,47140,47141,47142,47143,47144,47145,47146,47147,47490,47500
122 ;;47505,47510,47511,47525,47530,47552,47553,47554,47555,47556,47801,48102,48400,48550,48551
123 ;;48552,48554,48556,49041,49180,49320,49400,49419,49420,49421,49422,49423,49424,49427,49428
124 ;;49429,49440,49441,49442,49446,49450,49451,49452,49460,49465,49491,49492,49495,49496,49500
125 ;;49501,50040,50080,50081,50200,50300,50320,50323,50325,50327,50328,50329,50385,50386,50390
126 ;;50392,50393,50394,50398,50547,50551,50553,50555,50557,50561,50562,50570,50572,50574,50575
127 ;;50576,50580,50590,50592,50600,50605,50684,50686,50688,50690,50951,50953,50955,50957,50961
128 ;;50970,50972,50974,50976,50980,51000,51005,51010,51100,51101,51102,51600,51605,51610,51700
129 ;;51701,51702,51703,51705,51710,51715,51720,51725,51726,51736,51741,51772,51784,51785,51792
130 ;;51795,51797,51798,52000,52001,52005,52007,52010,52204,52214,52224,52250,52260,52265,52270
131 ;;52275,52276,52277,52281,52282,52283,52285,52290,52300,52301,52305,52310,52315,52317,52318
132 ;;52327,52332,52334,52343,52351,52352,52353,52354,52355,53020,53025,53060,53200,53270,53275
133 ;;53600,53601,53620,53621,53660,53661,53850,54000,54001,54055,54056,54060,54100,54105,54150
134 ;;54160,54161,54162,54200,54230,54231,54235,54240,54250,54400,54401,54405,54406,54408,54410
135 ;;54415,54416,54450,54500,54505,54512,54520,54530,54535,54700,54800,54830,55000,55250,55300
136 ;;55400,55450,55500,55520,55559,55700,55705,55870,55920,56605,56606,56700,56820,57020,57022
137 ;;57023,57100,57105,57150,57155,57160,57170,57180,57287,57400,57410,57420,57421,57452,57454
138 ;;57456,57500,57510,57511,57513,57520,57700,58100,58300,58301,58321,58322,58323,58340,58345
139 ;;58346,58353,58555,58558,58559,58560,58561,58562,58563,58660,58661,58662,58670,58671,58672
140 ;;58673,58679,58823,58900,58970,58974,58976,59000,59001,59012,59015,59020,59025,59030,59050
141 ;;59051,59070,59072,59074,59076,59100,59160,59200,59300,59320,59325,59400,59409,59410,59412
142 ;;59414,59425,59426,59430,59510,59514,59515,59525,59610,59612,59614,59618,59840,59841,59850
143 ;;59851,59852,59855,59856,59857,59866,59870,59871,59897,59899,60001,60100,60300,61001,61026
144 ;;61050,61055,61070,61623,61790,61791,61793,62140,62141,62142,62143,62146,62147,62163,62252
145 ;;62263,62264,62268,62269,62270,62272,62273,62280,62281,62282,62284,62287,62290,62291,62292
146 ;;62294,62310,62311,62318,62319,62355,62367,63600,63610,63615,63650,64400,64402,64405,64408
147 ;;64410,64412,64413,64415,64416,64417,64418,64420,64421,64425,64430,64435,64445,64446,64447
148 ;;64448,64449,64450,64470,64472,64475,64476,64479,64480,64483,64484,64505,64508,64510,64517
149 ;;64520,64530,64550,64553,64555,64560,64561,64565,64573,64575,64577,64580,64581,64585,64590
150 ;;64595,64600,64605,64610,64612,64613,64614,64620,64622,64623,64626,64627,64630,64640,64650
151 ;;64653,64680,64681,64716,64718,64719,64721,64732,64734,64736,64738,64740,64742,64744,64761
152 ;;64763,64766,64771,64772,64774,64776,64778,64782,64783,64784,64786,64787,64788,64790,64792
153 ;;64795,64820,64822,64823,64999,65091,65093,65101,65103,65105,65110,65112,65114,65125,65130
154 ;;65135,65140,65150,65155,65175,65205,65210,65220,65222,65235,65260,65265,65270,65272,65273
155 ;;65275,65280,65285,65286,65290,65400,65410,65420,65426,65430,65435,65436,65450,65600,65710
156 ;;65730,65750,65755,65760,65765,65767,65770,65771,65772,65775,65780,65781,65782,65800,65805
157 ;;65810,65815,65820,65850,65855,65860,65865,65870,65875,65880,65900,65920,65930,66020,66030
158 ;;66130,66150,66155,66160,66165,66170,66172,66180,66185,66220,66225,66250,66500,66505,66600
159 ;;66605,66625,66630,66635,66680,66682,66700,66710,66711,66720,66740,66761,66762,66770,66820
160 ;;66821,66825,66830,66840,66850,66852,66920,66930,66940,66982,66983,66984,66985,66986,66990
161 ;;66999,67005,67010,67015,67025,67027,67028,67030,67031,67036,67038,67039,67040,67041,67042
162 ;;67043,67101,67105,67107,67108,67110,67112,67113,67115,67120,67121,67141,67145,67208,67210
163 ;;67218,67220,67221,67225,67227,67228,67229,67250,67255,67299,67311,67312,67314,67316,67318
164 ;;67320,67331,67332,67334,67335,67340,67343,67345,67346,67399,67400,67405,67412,67413,67414
165 ;;67415,67420,67430,67440,67445,67450,67500,67505,67515,67550,67560,67570,67599,67700,67710
166 ;;67715,67800,67801,67805,67808,67810,67820,67825,67830,67835,67840,67850,67875,67880,67882
167 ;;67900,67901,67902,67903,67904,67906,67908,67909,67911,67912,67914,67915,67916,67917,67921
168 ;;67922,67923,67924,67930,67935,67938,67950,67961,67966,67971,67973,67974,67975,67999,68020
169 ;;68040,68100,68110,68115,68130,68135,68200,68320,68325,68326,68328,68330,68335,68340,68360
170 ;;68362,68371,68399,68400,68420,68440,68500,68505,68510,68520,68525,68530,68540,68550,68700
171 ;;68705,68720,68745,68750,68760,68761,68770,68801,68810,68811,68815,68816,68840,68850,68899
172 ;;69000,69005,69020,69090,69100,69105,69110,69120,69140,69145,69150,69155,69200,69205,69210
173 ;;69220,69222,69300,69310,69320,69399,69400,69401,69405,69420,69421,69424,69433,69436,69440
174 ;;69450,69501,69502,69505,69511,69530,69535,69540,69550,69552,69554,69601,69602,69603,69604
175 ;;69605,69610,69620,69631,69632,69633,69635,69636,69637,69641,69642,69643,69644,69645,69646
176 ;;69650,69660,69661,69662,69666,69667,69670,69676,69700,69710,69711,69720,69725,69740,69745
177 ;;69799,69801,69802,69805,69806,69820,69840,69905,69910,69915,69930,69949,69950,69955,69960
178 ;;69970,69979,69990
Note: See TracBrowser for help on using the repository browser.