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

SR206UTL.m

Go to the documentation of this file. 
  1. SR206UTL ;HPS/JSG - SR*3*206 UTILITY ROUTINE ; May 10, 2022@14:25
  1.  ;;3.0;Surgery;**206**;24 Jun 93;Build 2
  1.  ;
  1. PRE ; -- pre-install process for SR*3*206
  1.  I '$D(^XTMP("PRE 2022-UPDATE BACKUP OF 137")) D
  1.  . N X1,X2,X
  1.  . S X1=DT,X2=120 D C^%DTC
  1.  . S ^XTMP("PRE 2022-UPDATE BACKUP OF 137",0)=$G(X)_"^"_$G(DT)_"^"_"Backup of file 137 before 2022 update is performed by Patch SR*3*206"
  1.  . D EN^DDIOL("Backing up the CPT EXCLUSIONS file (#137) to ^XTMP.","","!!?1")
  1.  . M ^XTMP("PRE 2022-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*206
  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^SR206UT0,EX^SR206UT1,EX^SR206UT2,EX^SR206UT3
  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 SR206UT0, SR206UT1, SR206UT2, SR206UT3
  1.  I '$$GET^XUPARAM("XPD NO_EPP_DELETE") D
  1.  . F X="SR206UT0","SR206UT1","SR206UT2","SR206UT3" 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. LIST ;
  1.  ;;0001A,0001F,0001U,0002A,0002U,0003U,0005F,0005U,0007U,0008U,0009U,00100,00102
  1.  ;;00103,00104,0010U,0011A,0011U,00120,00124,00126,0012A,0012F,0012U,0013U,00140
  1.  ;;00142,00144,00145,00147,00148,0014F,0014M,0014U,0015F,0015M,00160,00162,00164
  1.  ;;0016M,0016U,00170,00172,00174,00176,0017M,0017U,0018M,0018U,00190,00192,0019U
  1.  ;;00210,00211,00212,00214,00215,00216,00218,0021A,0021U,00220,00222,0022A,0022U
  1.  ;;0023U,0024U,0025U,0026U,0027U,0029U,00300,0030U,0031A,0031U,00320,00322,00326
  1.  ;;0032U,0033U,0034U,00350,00352,0035U,0036U,0037U,0038U,0039U,00400,00402,00404
  1.  ;;00406,0040U,00410,0041A,0041U,0042A,0042T,0042U,0043U,0044U,00450,00454,0045U
  1.  ;;0046U,00470,00472,00474,0047U,0048U,0049U,00500,0050U,0051U,00520,00522,00524
  1.  ;;00528,00529,0052U,00530,00532,00534,00537,00539,0053U,00540,00541,00542,00546
  1.  ;;00548,0054T,0054U,00550,0055T,0055U,00560,00561,00562,00563,00566,00567,0056U
  1.  ;;00580,0058U,0059U,00600,00604,0060U,0061U,00620,00625,00626,0062U,00630,00632
  1.  ;;00635,0063U,00640,0064U,0065U,0066U,00670,0067U,0068U,0069U,00700,00702,0070U
  1.  ;;0071T,0071U,0072T,0072U,00730,00731,00732,0073U,0074U,00750,00752,00754,00756
  1.  ;;0075U,0076U,00770,0077U,0078U,00790,00792,00794,00796,00797,0079U,00800,00802
  1.  ;;0080U,00811,00812,00813,00820,0082U,00830,00832,00834,00836,0083U,00840,00842
  1.  ;;00844,00846,00848,0084U,00851,00860,00862,00864,00865,00866,00868,0086U,00870
  1.  ;;00872,00873,0087U,00880,00882,0088U,0089U,00902,00904,00906,00908,0090U,00910
  1.  ;;00912,00914,00916,00918,0091U,00920,00921,00922,00924,00926,00928,0092U,00930
  1.  ;;00932,00934,00936,00938,0093U,00940,00942,00944,00948,0094U,00950,00952,0095U
  1.  ;;0096U,0097U,0098U,0099U,0100T,0100U,0101T,0101U,0102T,0102U,0103U,0105U,0106T
  1.  ;;0106U,0107T,0107U,0108T,0108U,0109T,0109U,0110T,0110U,01112,0111U,01120,0112U
  1.  ;;01130,0113U,01140,0114U,01150,0115U,01160,0116U,01170,01173,0117U,0118U,0119U
  1.  ;;01200,01202,0120U,01210,01212,01214,01215,0121U,01220,0122U,01230,01232,01234
  1.  ;;0123U,01250,01260,01270,01272,01274,0129U,0130U,0131U,01320,0132U,0133U,01340
  1.  ;;0134U,0135U,01360,0136U,0137U,01380,01382,0138U,01390,01392,0139U,01400,01402
  1.  ;;01404,0140U,0141U,01420,0142U,01430,01432,0143U,01440,01442,01444,0144U,0145U
  1.  ;;01462,01464,0146U,01470,01472,01474,0147U,01480,01482,01484,01486,0148U,01490
  1.  ;;0149U,01500,01502,0150U,0151U,01520,01522,0152U,0153U,0154U,0155U,0156U,0157U
  1.  ;;0158U,0159U,0160U,01610,0161U,01620,01622,0162U,01630,01634,01636,01638,0163T
  1.  ;;0163U,0164T,0164U,01650,01652,01654,01656,0165T,0165U,0166U,01670,0167U,01680
  1.  ;;0168U,0169U,0170U,01710,01712,01714,01716,0171U,0172U,01730,01732,0173U,01740
  1.  ;;01742,01744,0174T,0174U,01756,01758,0175T,0175U,01760,0176U,01770,01772,0177U
  1.  ;;01780,01782,0178U,0179U,0180U,01810,0181U,01820,01829,0182U,01830,01832,0183U
  1.  ;;01840,01842,01844,0184U,01850,01852,0185U,01860,0186U,0187U,0188U,0189U,0190U
  1.  ;;01916,0191T,0191U,01920,01922,01924,01925,01926,0192U,01930,01931,01932,01933
  1.  ;;01935,01936,01937,01938,01939,0193U,01940,01941,01942,0194U,01951,01952,01953
  1.  ;;01958,0195U,01960,01961,01962,01963,01965,01966,01967,01968,01969,0196U,0197U
  1.  ;;0198T,0198U,01990,01991,01992,01996,01999,0199U,0200T,0200U,0201T,0201U,0202U
  1.  ;;0203U,02045,0204U,0206U,0207T,0207U,0208T,0208U,0209T,0209U,0210T,0210U,0211T
  1.  ;;0211U,0212T,0212U,0213T,0213U,0214T,0214U,0215T,0215U,0216T,0216U,0217T,0217U
  1.  ;;0218T,0218U,0219U,0220U,0221U,0222U,0223U,0224U,0225U,0226U,0227U,0228U,0229U
  1.  ;;0230U,0230U,0231U,0232T,0232U,0233U,0234U,0235U,0236U,0237U,0238U,0239U,0240U
  1.  ;;0241U,0242U,0243U,0244U,0245U,0246U,0247U,0248U,0249U,0250U,0251U,0252U,0253T
  1.  ;;0253U,0254U,0255U,0256U,0257U,0258U,0259U,0260U,0261U,0262U,0263T,0263U,0264T
  1.  ;;0264U,0265T,0265U,0266T,0266U,0267T,0267U,0268T,0268U,0269T,0269U,0270T,0270U
  1.  ;;0271T,0271U,0272T,0272U,0273T,0273U,0274U,0275T,0275U,0276U,0277U,0278T,0278U
  1.  ;;0279U,0280U,0281U,0282U,0283U,0284U,0290T,0308T,0312T,0313T,0314T,0315T,0316T
  1.  ;;0317T,0329T,0330T,0331T,0332T,0333T,0335T,0338T,0339T,0342T,0345T,0347T,0348T
  1.  ;;0349T,0350T,0351T,0352T,0353T,0354T,0355T,0356T,0358T,0362T,0373T,0376T,0378T
  1.  ;;0379T,0394T,0395T,0397T,0398T,0402T,0403T,0404T,0408T,0409T,0410T,0411T,0412T
  1.  ;;0413T,0414T,0415T,0416T,0417T,0418T,0419T,0420T,0422T,0423T,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,0462T,0463T,0464T
  1.  ;;0465T,0466T,0467T,0468T,0469T,0470T,0471T,0472T,0473T,0474T,0475T,0476T,0477T