VistA-WorldVistAEHR/r/SURGERY-SR/SR169UTL.m

179 lines
15 KiB
Mathematica

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