SR170UT0 ;BIR/ADM - FY09 CPT EXCLUSION UTILITY, CONTINUED ;05/07/09
;;3.0; Surgery ;**170**;24 Jun 93;Build 3
Q
PEX ; populate file 137
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
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 ;;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,41512,41520,41530,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,43273,43450,43453
;;43456,43458,43460,43499,43600,43653,43750,43752,43760,43761,43830,44015,44100,44132,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,46930,46934,46935,46936
;;46937,46938,46945,46946,47000,47011,47100,47133,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,50323,50325,50327,50328,50329,50385,50386,50390,50392
;;50393,50394,50398,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,55706,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,61796,61797,61798,61799,61800,62140,62141,62142,62143
;;62146,62147,62163,62252,62263,62264,62267,62268,62269,62270,62272,62273,62280,62281,62282
;;62284,62287,62290,62291,62292,62294,62310,62311,62318,62319,62355,62367,63600,63610,63615
;;63620,63621,63650,64400,64402,64405,64408,64410,64412,64413,64415,64416,64417,64418,64420
;;64421,64425,64430,64435,64445,64446,64447,64448,64449,64450,64455,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,64632,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,65756,65757,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR170UT0 7737 printed Nov 22, 2024@17:48:08 Page 2
SR170UT0 ;BIR/ADM - FY09 CPT EXCLUSION UTILITY, CONTINUED ;05/07/09
+1 ;;3.0; Surgery ;**170**;24 Jun 93;Build 3
+2 QUIT
PEX ; populate file 137
+1 FOR SRJ=0:1
SET SRLIST=$PIECE($TEXT(LIST+SRJ),";;",2)
if SRLIST=""
QUIT
FOR SRI=1:1
SET SRX=$PIECE(SRLIST,",",SRI)
if SRX=""
QUIT
IF $DATA(^ICPT("B",SRX))
DO INT
+2 QUIT
INT SET SRY=0
SET SRY=$ORDER(^ICPT("B",SRX,SRY))
if SRY=""
QUIT
+1 KILL DA,DIC,DD,DO,DINUM
SET (DINUM,X)=SRY
SET DIC="^SRO(137,"
SET DIC(0)="L"
DO FILE^DICN
+2 QUIT
LIST ;;36595,36596,36597,36600,36620,36625,36640,36660,36680,36800,36810,36815,36820,36821,36822
+1 ;;36823,36825,36830,36831,36832,36833,36835,36870,37183,37195,37200,37209,37250,37251,37501
+2 ;;37609,37620,37785,38200,38204,38205,38206,38207,38208,38209,38210,38211,38212,38213,38214
+3 ;;38215,38220,38221,38230,38240,38241,38242,38500,38505,38510,38520,38525,38530,38790,38792
+4 ;;38794,40490,40799,40806,40808,40831,41010,41015,41019,41100,41105,41108,41115,41250,41251
+5 ;;41252,41510,41512,41520,41530,41800,41805,41870,41872,41874,41899,42000,42100,42180,42182
+6 ;;42280,42281,42310,42400,42405,42600,42650,42660,42800,42802,42804,42806,42820,42821,42825
+7 ;;42826,42830,42831,42835,42836,42860,42970,42971,43200,43201,43202,43204,43205,43215,43216
+8 ;;43217,43219,43220,43226,43227,43228,43231,43232,43234,43235,43236,43237,43238,43239,43240
+9 ;;43241,43242,43243,43244,43245,43246,43247,43248,43249,43250,43251,43255,43256,43257,43258
+10 ;;43259,43260,43261,43262,43263,43264,43265,43267,43268,43269,43271,43272,43273,43450,43453
+11 ;;43456,43458,43460,43499,43600,43653,43750,43752,43760,43761,43830,44015,44100,44132,44300
+12 ;;44360,44361,44363,44364,44365,44366,44369,44370,44372,44373,44376,44377,44378,44379,44380
+13 ;;44382,44383,44385,44386,44388,44389,44390,44391,44392,44393,44394,44397,44500,44715,44720
+14 ;;44721,44901,45100,45300,45303,45305,45307,45308,45309,45315,45317,45320,45321,45327,45330
+15 ;;45331,45332,45333,45334,45335,45337,45338,45339,45340,45341,45342,45345,45355,45378,45379
+16 ;;45380,45381,45382,45383,45384,45385,45386,45387,45520,45900,45915,45990,46050,46070,46080
+17 ;;46083,46200,46210,46211,46220,46221,46230,46250,46255,46257,46258,46260,46261,46262,46270
+18 ;;46275,46280,46285,46288,46320,46500,46505,46600,46604,46606,46608,46610,46611,46612,46614
+19 ;;46615,46700,46705,46706,46754,46900,46910,46916,46917,46922,46924,46930,46934,46935,46936
+20 ;;46937,46938,46945,46946,47000,47011,47100,47133,47143,47144,47145,47146,47147,47490,47500
+21 ;;47505,47510,47511,47525,47530,47552,47553,47554,47555,47556,47801,48102,48400,48550,48551
+22 ;;48552,48554,48556,49041,49180,49320,49400,49419,49420,49421,49422,49423,49424,49427,49428
+23 ;;49429,49440,49441,49442,49446,49450,49451,49452,49460,49465,49491,49492,49495,49496,49500
+24 ;;49501,50040,50080,50081,50200,50300,50323,50325,50327,50328,50329,50385,50386,50390,50392
+25 ;;50393,50394,50398,50551,50553,50555,50557,50561,50562,50570,50572,50574,50575,50576,50580
+26 ;;50590,50592,50600,50605,50684,50686,50688,50690,50951,50953,50955,50957,50961,50970,50972
+27 ;;50974,50976,50980,51000,51005,51010,51100,51101,51102,51600,51605,51610,51700,51701,51702
+28 ;;51703,51705,51710,51715,51720,51725,51726,51736,51741,51772,51784,51785,51792,51795,51797
+29 ;;51798,52000,52001,52005,52007,52010,52204,52214,52224,52250,52260,52265,52270,52275,52276
+30 ;;52277,52281,52282,52283,52285,52290,52300,52301,52305,52310,52315,52317,52318,52327,52332
+31 ;;52334,52343,52351,52352,52353,52354,52355,53020,53025,53060,53200,53270,53275,53600,53601
+32 ;;53620,53621,53660,53661,53850,54000,54001,54055,54056,54060,54100,54105,54150,54160,54161
+33 ;;54162,54200,54230,54231,54235,54240,54250,54400,54401,54405,54406,54408,54410,54415,54416
+34 ;;54450,54500,54505,54512,54520,54530,54535,54700,54800,54830,55000,55250,55300,55400,55450
+35 ;;55500,55520,55559,55700,55705,55706,55870,55920,56605,56606,56700,56820,57020,57022,57023
+36 ;;57100,57105,57150,57155,57160,57170,57180,57287,57400,57410,57420,57421,57452,57454,57456
+37 ;;57500,57510,57511,57513,57520,57700,58100,58300,58301,58321,58322,58323,58340,58345,58346
+38 ;;58353,58555,58558,58559,58560,58561,58562,58563,58660,58661,58662,58670,58671,58672,58673
+39 ;;58679,58823,58900,58970,58974,58976,59000,59001,59012,59015,59020,59025,59030,59050,59051
+40 ;;59070,59072,59074,59076,59100,59160,59200,59300,59320,59325,59400,59409,59410,59412,59414
+41 ;;59425,59426,59430,59510,59514,59515,59525,59610,59612,59614,59618,59840,59841,59850,59851
+42 ;;59852,59855,59856,59857,59866,59870,59871,59897,59899,60001,60100,60300,61001,61026,61050
+43 ;;61055,61070,61623,61790,61791,61793,61796,61797,61798,61799,61800,62140,62141,62142,62143
+44 ;;62146,62147,62163,62252,62263,62264,62267,62268,62269,62270,62272,62273,62280,62281,62282
+45 ;;62284,62287,62290,62291,62292,62294,62310,62311,62318,62319,62355,62367,63600,63610,63615
+46 ;;63620,63621,63650,64400,64402,64405,64408,64410,64412,64413,64415,64416,64417,64418,64420
+47 ;;64421,64425,64430,64435,64445,64446,64447,64448,64449,64450,64455,64470,64472,64475,64476
+48 ;;64479,64480,64483,64484,64505,64508,64510,64517,64520,64530,64550,64553,64555,64560,64561
+49 ;;64565,64573,64575,64577,64580,64581,64585,64590,64595,64600,64605,64610,64612,64613,64614
+50 ;;64620,64622,64623,64626,64627,64630,64632,64640,64650,64653,64680,64681,64716,64718,64719
+51 ;;64721,64732,64734,64736,64738,64740,64742,64744,64761,64763,64766,64771,64772,64774,64776
+52 ;;64778,64782,64783,64784,64786,64787,64788,64790,64792,64795,64820,64822,64823,64999,65091
+53 ;;65093,65101,65103,65105,65110,65112,65114,65125,65130,65135,65140,65150,65155,65175,65205
+54 ;;65210,65220,65222,65235,65260,65265,65270,65272,65273,65275,65280,65285,65286,65290,65400
+55 ;;65410,65420,65426,65430,65435,65436,65450,65600,65710,65730,65750,65755,65756,65757,65760
+56 ;;65765,65767,65770,65771,65772,65775,65780,65781,65782,65800,65805,65810,65815,65820,65850
+57 ;;65855,65860,65865,65870,65875,65880,65900,65920,65930,66020,66030,66130,66150,66155,66160
+58 ;;66165,66170,66172,66180,66185,66220,66225,66250,66500,66505,66600,66605,66625,66630,66635
+59 ;;66680,66682,66700,66710,66711,66720,66740,66761,66762,66770,66820,66821,66825,66830,66840
+60 ;;66850,66852,66920,66930,66940,66982,66983,66984,66985,66986,66990,66999,67005,67010,67015
+61 ;;67025,67027,67028,67030,67031,67036,67038,67039,67040,67041,67042,67043,67101,67105,67107
+62 ;;67108,67110,67112,67113,67115,67120,67121,67141,67145,67208,67210,67218,67220,67221,67225
+63 ;;67227,67228,67229,67250,67255,67299,67311,67312,67314,67316,67318,67320,67331,67332,67334
+64 ;;67335,67340,67343,67345,67346,67399,67400,67405,67412,67413,67414,67415,67420,67430,67440
+65 ;;67445,67450,67500,67505,67515,67550,67560,67570,67599,67700,67710,67715,67800,67801,67805
+66 ;;67808,67810,67820,67825,67830,67835,67840,67850,67875,67880,67882,67900,67901,67902,67903
+67 ;;67904,67906,67908,67909,67911,67912,67914,67915,67916,67917,67921,67922,67923,67924,67930
+68 ;;67935,67938,67950,67961,67966,67971,67973,67974,67975,67999,68020,68040,68100,68110,68115
+69 ;;68130,68135,68200,68320,68325,68326,68328,68330,68335,68340,68360,68362,68371,68399,68400
+70 ;;68420,68440,68500,68505,68510,68520,68525,68530,68540,68550,68700,68705,68720,68745,68750
+71 ;;68760,68761,68770,68801,68810,68811,68815,68816,68840,68850,68899,69000,69005,69020,69090
+72 ;;69100,69105,69110,69120,69140,69145,69150,69155,69200,69205,69210,69220,69222,69300,69310
+73 ;;69320,69399,69400,69401,69405,69420,69421,69424,69433,69436,69440,69450,69501,69502,69505
+74 ;;69511,69530,69535,69540,69550,69552,69554,69601,69602,69603,69604,69605,69610,69620,69631
+75 ;;69632,69633,69635,69636,69637,69641,69642,69643,69644,69645,69646,69650,69660,69661,69662
+76 ;;69666,69667,69670,69676,69700,69710,69711,69720,69725,69740,69745,69799,69801,69802,69805
+77 ;;69806,69820,69840,69905,69910,69915,69930,69949,69950,69955,69960,69970,69979,69990
