Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SR210UTL

SR210UTL.m

Go to the documentation of this file. 
  1. SR210UTL ;HPS/JSG - SR*3*210 UTILITY ROUTINE; Mar 28, 2023@09:52
  1.  ;;3.0;Surgery;**206,210**;24 Jun 93;Build 4
  1.  ;
  1. PRE ; -- pre-install process for SR*3*202
  1.  I '$D(^XTMP("PRE 2023-UPDATE BACKUP OF 137")) D
  1.  . N X1,X2,X
  1.  . S X1=DT,X2=120 D C^%DTC
  1.  . S ^XTMP("PRE 2023-UPDATE BACKUP OF 137",0)=$G(X)_"^"_$G(DT)_"^"_"Backup of file 137 before 2023 update is performed by Patch SR*3*210"
  1.  . D EN^DDIOL("Backing up the CPT EXCLUSIONS file (#137) to ^XTMP.","","!!?1")
  1.  . M ^XTMP("PRE 2023-UPDATE BACKUP OF 137",137)=^SRO(137)
  1.  . D EN^DDIOL("Backup complete","","!!?1")
  1.  ;
  1.  D DATDEL ; delete data from file #137 prior to updating
  1.  Q
  1.  ;
  1. POST ; -- post-install process for SR*3*210
  1.  ; -- populate the CPT EXCLUSIONS file (#137)
  1.  N SRI,SRJ,SRL,SRLIST,SRX,SRY,X
  1.  D MES^XPDUTL("  Populating CPT EXCLUSIONS file (#137)...")
  1.  F SRJ=1: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
  1.  D EX^SR210UT0,EX^SR210UT1,EX^SR210UT2,EX^SR210UT3
  1.  ;
  1.  ; -- The following CPT Code ranges are excluded: "00001-0051S", "0051U-0052S", "0052U-0053S", "0053U-0075S",
  1.  ;    "0075U-0076S", "0076U-0078S", "0078U-0095S", "0095U-0098S", "0098U-0171S", "0171U-0172S", "0172U-0184S"
  1.  ;    "0184U-01999", "70000-79999", "80000-89999", "90000-93589", "93593-99999"
  1.  S SRX="00001" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0051S"))  D INT
  1.  S SRX="0051U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0052S"))  D INT
  1.  S SRX="0052U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0053S"))  D INT
  1.  S SRX="0053U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0075S"))  D INT
  1.  S SRX="0075U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0076S"))  D INT
  1.  S SRX="0076U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0078S"))  D INT
  1.  S SRX="0078U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0095S"))  D INT
  1.  S SRX="0095U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0098S"))  D INT
  1.  S SRX="0098U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0171S"))  D INT
  1.  S SRX="0171U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0172S"))  D INT
  1.  S SRX="0172U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0184S"))  D INT
  1.  S SRX="0184U" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","01999"))  D INT
  1.  S SRX="70000" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","79999"))  D INT
  1.  S SRX="80000" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","89999"))  D INT
  1.  S SRX="90000" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","93589"))  D INT
  1.  S SRX="93593" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","99999"))  D INT
  1.  ;
  1.  ; -- Exclude all CPT CODES that start with alphabets
  1.  S SRX="A" F  S SRX=$O(^ICPT("B",SRX)) Q:SRX=""  D INT
  1.  ;
  1.  ; -- Honor KIDS "No Delete" setting if called from a KIDS install.
  1.  ; -- Delete routines SR210UT0, SR210UT1,& SR210UT2
  1.  I '$$GET^XUPARAM("XPD NO_EPP_DELETE") D
  1.  . F X="SR210UT0","SR210UT1","SR210UT2","SR210UT3" X ^%ZOSF("TEST") I $T D
  1.  . .D MES^XPDUTL(" Deleting routine "_X_"...") X ^%ZOSF("DEL")
  1.  K DA,DIC,DD,DO,DINUM,X
  1.  Q
  1.  ;
  1. INT S SRY=0,SRY=$O(^ICPT("B",SRX,SRY)) Q:SRY=""
  1.  K DA,DIC,DD,DO,DINUM S (DINUM,X)=SRY,DIC="^SRO(137,",DIC(0)="L" D FILE^DICN
  1.  Q
  1.  ;
  1. DATDEL ; Delete all data from file #137
  1.  N SRTXT
  1.  S SRTXT="File #137 hasn't been set up yet, so no data to delete."
  1.  I '$D(^SRO(137,0))#2 D DISP Q
  1.  S SRTXT="File #137 doesn't have any data, so nothing to delete."
  1.  I '$O(^SRO(137,0)) D DISP Q
  1.  S SRTXT="Deleting data from file #137..."
  1.  D DISP
  1.  K ^SRO(137)
  1.  S ^SRO(137,0)="CPT EXCLUSIONS^137P^^0"
  1.  Q
  1.  ;
  1. DISP ;display one-line text either interactively or within KIDS installation
  1.  I '$D(XPDNM)#2 U 0 W !!?5,SRTXT
  1.  E  D BMES^XPDUTL(SRTXT)
  1.  Q
  1.  ;
  1. LINES ;Create n lines each with 13 codes
  1.  S LC=0,L="",NC=0
  1.  F I=1:1:7781 S C=$P(^JSG(I),$C(9)),NC=NC+1 S L=$S(NC<13:L_C_",",1:L_C) I NC=13!(I=7781) D
  1.  . S LC=LC+1,^JSGL(LC)=L,NC=0,L=""
  1.  Q
  1.  ;
  1. LIST ;
  1.  ;;0001A,0001F,0002A,0005F,00100,00102,00103,00104,0011A,00120,00124,00126,0012A
  1.  ;;0012F,00140,00142,00144,00145,00147,00148,0014F,0014M,0015F,0015M,00160,00162
  1.  ;;00164,0016M,00170,00172,00174,00176,0017M,0018M,00190,00192,00210,00211,00212
  1.  ;;00214,00215,00216,00218,0021A,00220,00222,0022A,00300,0031A,00320,00322,00326
  1.  ;;00350,00352,00400,00402,00404,00406,00410,0041A,0042A,0042T,00450,00454,00470
  1.  ;;00472,00474,00500,00520,00522,00524,00528,00529,00530,00532,00534,00537,00539
  1.  ;;00540,00541,00542,00546,00548,0054T,00550,0055T,00560,00561,00562,00563,00566
  1.  ;;00567,00580,00600,00604,00620,00625,00626,00630,00632,00635,00640,00670,00700
  1.  ;;00702,0071T,0072T,00730,00731,00732,00750,00752,00754,00756,00770,00790,00792
  1.  ;;00794,00796,00797,00800,00802,00811,00812,00813,00820,00830,00832,00834,00836
  1.  ;;00840,00842,00844,00846,00848,00851,00860,00862,00864,00865,00866,00868,00870
  1.  ;;00872,00873,00880,00882,00902,00904,00906,00908,00910,00912,00914,00916,00918
  1.  ;;00920,00921,00922,00924,00926,00928,00930,00932,00934,00936,00938,00940,00942
  1.  ;;00944,00948,00950,00952,0100T,0101T,0102T,0106T,0107T,0108T,0109T,0110T,01112
  1.  ;;01120,01130,01140,01150,01160,01170,01173,01200,01202,01210,01212,01214,01215
  1.  ;;01220,01230,01232,01234,01250,01260,01270,01272,01274,01320,01340,01360,01380
  1.  ;;01382,01390,01392,01400,01402,01404,01420,01430,01432,01440,01442,01444,01462
  1.  ;;01464,01470,01472,01474,01480,01482,01484,01486,01490,01500,01502,01520,01522
  1.  ;;01610,01620,01622,01630,01634,01636,01638,0164T,01650,01652,01654,01656,0165T
  1.  ;;01670,01680,01710,01712,01714,01716,01730,01732,01740,01742,01744,0174T,01756
  1.  ;;01758,0175T,01760,01770,01772,01780,01782,01810,01820,01829,01830,01832,01840
  1.  ;;01842,01844,01850,01852,01860,01916,01920,01922,01924,01925,01926,01930,01931
  1.  ;;01932,01933,01937,01938,01939,01940,01941,01942,01951,01952,01953,01958,01960
  1.  ;;01961,01962,01963,01965,01966,01967,01968,01969,0198T,01990,01991,01992,01996
  1.  ;;01999,0200T,0201T,0207T,0208T,0209T,0210T,0211T,0212T,0213T,0214T,0215T,0216T
  1.  ;;0217T,0218T,0232T,0253T,0263T,0264T,0265T,0266T,0267T,0268T,0269T,0270T,0271T
  1.  ;;0272T,0273T,0275T,0278T,0308T,0329T,0330T,0331T,0332T,0333T,0335T,0338T,0339T
  1.  ;;0342T,0345T,0347T,0348T,0349T,0350T,0351T,0352T,0353T,0354T,0358T,0362T,0373T
  1.  ;;0378T,0379T,0394T,0395T,0397T,0398T,0402T,0403T,0404T,0408T,0409T,0410T,0411T
  1.  ;;0412T,0413T,0414T,0415T,0416T,0417T,0418T,0419T,0420T,0422T,0424T,0425T,0426T
  1.  ;;0427T,0428T,0429T,0430T,0431T,0432T,0433T,0434T,0435T,0436T,0437T,0439T,0440T
  1.  ;;0441T,0442T,0443T,0444T,0445T,0446T,0447T,0448T,0449T,0450T,0464T,0465T,0469T
  1.  ;;0472T,0473T,0474T,0479T,0480T,0481T,0485T,0486T,0488T,0489T,0490T,0494T,0495T
  1.  ;;0496T,0500F,0500T,0501F,0501T,0502F,0502T,0503F,0503T,0504T,0505F,0505T,0506T
  1.  ;;0507F,0507T,0508T,0509F,0509T,0510T,0511T,0512T,0513F,0513T,0514F,0515T,0516F
  1.  ;;0516T,0517F,0517T,0518F,0518T,0519F,0519T,0520F,0520T,0521F,0521T,0522T,0523T
  1.  ;;0524T,0525F,0525T,0526F,0526T,0527T,0528F,0528T,0529F,0529T,0530T,0531T,0532T
  1.  ;;0533T,0534T,0535F,0535T,0536T,0537T,0538T,0539T,0540F,0540T,0541T,0542T,0545F
  1.  ;;0546T,0547T,0550F,0551F,0552T,0553T,0554T,0555F,0555T,0556F,0556T,0557F,0557T
  1.  ;;0558T,0559T,0560T,0561T,0562T,0563T,0564T,0565T,0566T,0567T,0568T,0571T,0572T
  1.  ;;0573T,0574T,0575F,0575T,0576T,0577T,0578T,0579T,0580F,0580T,0581F,0581T,0582F
  1.  ;;0582T,0583F,0583T,0584F,0587T,0588T,0589T,0590T,0591T,0592T,0593T,0594T,0596T
  1.  ;;0597T,0598T,0599T,0600T,0601T,0602T,0603T,0604T,0605T,0606T,0607T,0608T,0609T
  1.  ;;0610T,0611T,0612T,0613T,0614T,0615T,0616T,0617T,0618T,0619T,0620T,0621T,0622T
  1.  ;;0623T,0624T,0625T,0626T,0627T,0628T,0629T,0630T,0631T,0632T,0633T,0634T,0635T
  1.  ;;0636T,0637T,0638T,0639T,0640T,0641T,0642T,0647T,0648T,0649T,0650T,0651T,0652T
  1.  ;;0653T,0654T,0655T,0658T,0659T,0660T,0661T,0662T,0663T,0664T,0671T,0672T,0673T
  1.  ;;0682T,0683T,0684T,0685T,0686T,0687T,0688T,0689T,0690T,0691T,0692T,0693T,0694T
  1.  ;;0695T,0696T,0697T,0698T,0699T,0700T,0701T,0704T,0705T,0706T,0707T,0708T,0709T
  1.  ;;0710T,0711T,0712T,0713T,0715T,0716T,0717T,0718T,0719T,0720T,0721T,0722T,0723T
  1.  ;;0724T,0728T,0729T,0730T,0731T,0732T,0733T,0734T,0736T,0738T,0739T,0740T,0741T
  1.  ;;0742T,0743T,0745T,0746T,0747T,0748T,0749T,0750T,0751T,0752T,0753T,0754T,0755T
  1.  ;;0756T,0757T,0758T,0759T,0760T,0761T,0762T,0763T,0764T,0765T,0766T,0767T,0768T
  1.  ;;0769T,0770T,0771T,0772T,0773T,0774T,0775T,0776T,0777T,0778T,0779T,0780T,0781T
  1.  ;;0782T,0783T,10004,10005,10006,10007,10008,10009,1000F,10010,10011,10012,10021
  1.  ;;1002F,10030,10035,10036,1003F,10040,1004F,1005F,10060,10061,1006F,1007F,10080
  1.  ;;10081,1008F,1010F,1011F,10120,10121,1012F,10140,1015F,10160,10180,1018F,1019F
  1.  ;;1022F,1026F,1030F,1031F,1032F,1033F,1034F,1035F,1036F,1038F,1039F,1040F,1050F