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

ATX6ENV.m

Go to the documentation of this file. 
  1. ATX6ENV ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ; 15 May 2013  2:57 PM
  1.  ;;5.1;TAXONOMY;**11,16**;FEB 04, 1997;Build 26
  1.  ;
  1.  ;
  1.  ; The following line prevents the "Disable Options..." and "Move
  1.  ; Routines..." questions from being asked during the install.
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  I '$$INSTALLD("BJPC*2.0*10") D SORRY(2)
  1.  I +$$VERSION^XPDUTL("AICD")<4 D MES^XPDUTL($$CJ^XLFSTR("Version 4.0 of AICD is required.  Not installed",80)) D SORRY(2) I 1
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires AICD V4.0....Present.",80))
  1.  ;
  1.  Q
  1.  ;
  1. PRE ;
  1.  ;RENAME BQI ROCKEY MTN FEVER DXS TO BQI ROCKY MTN FEVER DXS
  1.  S DA=$O(^ATXAX("B","BQI ROCKEY MTN FEVER DXS",0))
  1.  I DA S ATXFLG=1,DIE="^ATXAX(",DR=".01///BQI ROCKY MTN FEVER DXS" D ^DIE K DA,DR,DIE
  1.  Q
  1. POST ;
  1.  ;SET FILE 60 IN ALL LAB TAXONOMEIS
  1.  ;SET NDC FILE if needed
  1.  ;set read only
  1.  ;set no delete
  1.  ;SET ICD9 INTO TAXONOMIES
  1.  D SETTAXF  ;set file 60 into file field of ^ATXLAB if it is missing.
  1.  D SETCS
  1.  D ^ATXD1
  1.  D ^ATXD2
  1.  D ^ATXD3
  1.  D ^ATXD4
  1.  D ^ATXD5
  1.  D ^ATXD6
  1.  D ^ATXD7
  1.  D ^ATXD8
  1.  D ^ATXD9
  1.  D ^ATXDA
  1.  D ^ATXDB
  1.  D ^ATXDC
  1.  D ^ATXX
  1.  D ^ATXO1
  1.  D ^ATXO3
  1.  D ^ATXO4
  1.  D ^ATXO5
  1.  D SETTAXRN
  1.  D SETNDC
  1.  D SETCLASS
  1.  ;
  1.  S DIK="^ATXTYPE(",DIK(1)=".02^C" D ENALL^DIK K DIC
  1.  S DIK="^ATXAX(",DIK(1)=".15^AD" D ENALL^DIK K DIC
  1.  ;CHANGE ROUTINE IN APCL TAXONOMY SETUP TO ATXTAXG
  1.  S DA=$O(^DIC(19,"B","APCL TAXONOMY SETUP",0))
  1.  I DA S DIE="^DIC(19,",DR="25////ATXTAXG" D ^DIE K DIE,DA,DR
  1.  D DELOPT
  1. BULL ;modify bulletins
  1.  S ATXX="ATX" F  S ATXX=$O(^XMB(3.6,"B",ATXX)) Q:ATXX]"ATXZ"  D
  1.  .S X=0 F  S X=$O(^XMB(3.6,"B",ATXX,X)) Q:X'=+X  D
  1.  ..S Y=0 F  S Y=$O(^XMB(3.6,X,1,Y)) Q:Y'=+Y  D
  1.  ...I $G(^XMB(3.6,X,1,Y,0))["ICD9" S ^XMB(3.6,X,1,Y,0)=$TR(^XMB(3.6,X,1,Y,0),"ICD9","ICD")
  1.  ..S Y=0 F  S Y=$O(^XMB(3.6,X,4,Y)) Q:Y'=+Y  D
  1.  ...I $G(^XMB(3.6,X,4,Y,0))["ICD9" S ^XMB(3.6,X,4,Y,0)=$TR(^XMB(3.6,X,4,Y,0),"ICD9","ICD")
  1.  ...S Z=0 F  S Z=$O(^XMB(3.6,X,4,Y,1,Z)) Q:Z'=+Z  D
  1.  ....I $G(^XMB(3.6,X,4,Y,1,Z,0))["ICD9" S ^XMB(3.6,X,4,Y,1,Z,0)=$TR(^XMB(3.6,X,4,Y,1,Z,0),"ICD9","ICD")
  1.  S ATXX="APCL" F  S ATXX=$O(^XMB(3.6,"B",ATXX)) Q:ATXX]"APCLZ"  D
  1.  .S X=0 F  S X=$O(^XMB(3.6,"B",ATXX,X)) Q:X'=+X  D
  1.  ..S Y=0 F  S Y=$O(^XMB(3.6,X,1,Y)) Q:Y'=+Y  D
  1.  ...I $G(^XMB(3.6,X,1,Y,0))["ICD9" S ^XMB(3.6,X,1,Y,0)=$TR(^XMB(3.6,X,1,Y,0),"ICD9","ICD")
  1.  ..S Y=0 F  S Y=$O(^XMB(3.6,X,4,Y)) Q:Y'=+Y  D
  1.  ...I $G(^XMB(3.6,X,4,Y,0))["ICD9" S ^XMB(3.6,X,4,Y,0)=$TR(^XMB(3.6,X,4,Y,0),"ICD9","ICD")
  1.  ...S Z=0 F  S Z=$O(^XMB(3.6,X,4,Y,1,Z)) Q:Z'=+Z  D
  1.  ....I $G(^XMB(3.6,X,4,Y,1,Z,0))["ICD9" S ^XMB(3.6,X,4,Y,1,Z,0)=$TR(^XMB(3.6,X,4,Y,1,Z,0),"ICD9","ICD")
  1.  Q
  1.  ;
  1. SETCS ;EP
  1.  ;set coding system to ICD9 for any file 80 or 80.1 taxonomy by checking 1st code in the list.
  1.  ;if code is not found then set ICD9
  1.  ;S VARS TO CODING SYSTEM IEN
  1.  S ATXDX9CS=$O(^ICDS("B","ICD-9-CM",0))
  1.  S ATXPC9CS=$O(^ICDS("B","ICD-9 Proc",0))
  1.  S ATXDX1CS=$O(^ICDS("B","ICD-10-CM",0))
  1.  S ATXPC1CS=$O(^ICDS("B","ICD-10-PCS",0))
  1.  ;
  1.  S ATXX=0 F  S ATXX=$O(^ATXAX(ATXX)) Q:ATXX'=+ATXX  D
  1.  .S F=$P($G(^ATXAX(ATXX,0)),U,15)
  1.  .I F=80 D DXS
  1.  .I F=80.1 D PROCS
  1.  .Q
  1.  Q
  1. DXS ;EP
  1.  NEW X,Y,Z
  1.  S ATXY=0 F  S ATXY=$O(^ATXAX(ATXX,21,ATXY)) Q:ATXY'=+ATXY  D
  1.  .Q:$P(^ATXAX(ATXX,21,ATXY,0),U,3)]""  ;ALREADY TAGGED
  1.  .;get first code in range
  1.  .W !,^ATXAX(ATXX,0)
  1.  .S Y=$P(^ATXAX(ATXX,21,ATXY,0),U,1)
  1.  .S Y=$$STRIP^XLFSTR(Y," ")  ;take all spaces out
  1.  .I Y["*" S $P(^ATXAX(ATXX,21,ATXY,0),U,3)=ATXDX1CS Q  ;it must be icD10 if has a wildcard
  1.  .S %=$$ICDDX^ICDEX(Y)
  1.  .I $P(%,U,20)=ATXDX1CS S $P(^ATXAX(ATXX,21,ATXY,0),U,3)=ATXDX1CS Q  ;if it is a 10 set it, otherwise assume it is an ICD9
  1.  .;I am assuming it is an ICD9 if it is not an ICD10 as all of our existing taxonomies should be ICD9
  1.  .S $P(^ATXAX(ATXX,21,ATXY,0),U,3)=ATXDX9CS
  1.  .Q
  1.  Q
  1. PROCS ;EP
  1.  NEW X,Y,Z
  1.  S ATXY=0 F  S ATXY=$O(^ATXAX(ATXX,21,ATXY)) Q:ATXY'=+ATXY  D
  1.  .Q:$P(^ATXAX(ATXX,21,ATXY,0),U,3)]""  ;ALREADY TAGGED
  1.  .;get first code in range
  1.  .;W !,^ATXAX(ATXX,0)
  1.  .S Y=$P(^ATXAX(ATXX,21,ATXY,0),U,1)
  1.  .S Y=$$STRIP^XLFSTR(Y," ")  ;take all spaces out
  1.  .I Y["*" S $P(^ATXAX(ATXX,21,ATXY,0),U,3)=ATXPC1CS Q  ;it must be icD10 if has a wildcard
  1.  .S %=$$ICDOP^ICDEX(Y,,,"E")
  1.  .I $P(%,U,15)=ATXPC1CS S $P(^ATXAX(ATXX,21,ATXY,0),U,3)=ATXPC1CS Q  ;if it is a 10 set it, otherwise assume it is an ICD9
  1.  .S $P(^ATXAX(ATXX,21,ATXY,0),U,3)=ATXPC9CS
  1.  .Q
  1.  Q
  1. SETTAXF ;EP
  1.  S X=0 F  S X=$O(^ATXLAB(X)) Q:X'=+X  D
  1.  .Q:$P(^ATXLAB(X,0),U,9)]""
  1.  .S $P(^ATXLAB(X,0),U,9)=60
  1.  .Q
  1.  Q
  1. SETTAXRN ;EP
  1.  ;set read only and no delete for selected taxonomies
  1.  S ATXTFI="" F  S ATXTFI=$O(^ATXAX("B",ATXTFI)) Q:ATXTFI=""  D
  1.  .S ATXTDA=$O(^ATXAX("B",ATXTFI,0))
  1.  .Q:'ATXTDA  ;did not find taxonomy
  1.  .Q:'$$NS(ATXTFI)
  1.  .S $P(^ATXAX(ATXTDA,0),U,4)="n"  ;set no delete
  1.  .S F=$P(^ATXAX(ATXTDA,0),U,15)
  1.  .I $$RO(F,ATXTFI) S $P(^ATXAX(ATXTDA,0),U,22)=1  ;SET READ ONLY
  1.  .Q
  1.  Q
  1. RO(T,S) ;
  1.  I T=81 Q 1   ;CPT
  1.  I T=80 Q 1   ;ICD DX
  1.  I T=80.1 Q 1  ;ICD OP
  1.  I T=9999999.31 Q 1  ;
  1.  I T=9999999.64 Q 1  ;HEALTH FACTORS
  1.  I T=95.3 Q 1  ;LAB LOINC
  1.  I S[" NDC" Q 1  ;NDC taxonomies  -  not perfect logic by no tax had " NDC " but NDC taxonomies
  1.  Q 0
  1. DELOPT ;DELETE OBSOLETE OPTIONS
  1.  D MES^XPDUTL("Deleting old, obsolete ATX options")
  1.  S ATXY=0
  1.  F ATXX="ATXBULL","ATXEARCH","ATXENTPTS","ATXMAINT","ATXMODIFY","ATXMSEARCH","ATXPOVSEARCH","ATXPTAXDEL","ATXRCHDEL" D
  1.  .D MES^XPDUTL(ATXX)
  1.  .S DA=$O(^DIC(19,"B",ATXX,0))
  1.  .I 'DA Q
  1.  .S DIK="^DIC(19," D ^DIK S ATXY=1
  1.  Q:'ATXY
  1.  D MES^XPDUTL("Cleaning up dangling pointers in option file for these options")
  1.  D OFIX^XBDANGLE
  1.  Q
  1. NS(T,L) ;
  1.  I T["DIABETES REG" Q 0
  1.  I $E(T,1,4)="APCD" Q 1
  1.  I $E(T,1,3)="BGP" Q 1
  1.  I $E(T,1,7)="SURVEIL" Q 1
  1.  I $E(T,1,4)="APCH" Q 1
  1.  I $E(T,1,4)="APCL" Q 1
  1.  I $E(T,1,3)="ATX" Q 1
  1.  I $E(T,1,3)="BAT" Q 1
  1.  I $E(T,1,3)="BDR" Q 1
  1.  I $E(T,1,3)="BI " Q 1
  1.  I $E(T,1,4)="BJPC" Q 1
  1.  I $E(T,1,3)="BUD" Q 1
  1.  I $E(T,1,8)="DM AUDIT" Q 1
  1.  Q 0
  1.  ;
  1. SETNDC ;
  1.  S ATXTEXT="NDC" F ATXX=1:1 S ATXTX=$P($T(@ATXTEXT+ATXX),";;",2) Q:ATXTX=""  D
  1.  .S ATXDA=$O(^ATXAX("B",ATXTX,0))
  1.  .Q:'ATXDA
  1.  .Q:'$D(^ATXAX(ATXDA,0))
  1.  .Q:$P(^ATXAX(ATXDA,0),U,15)]""  ;already has a file
  1.  .S $P(^ATXAX(ATXDA,0),U,15)=50.67
  1.  .Q
  1.  S X=0 F  S X=$O(^ATXAX(X)) Q:X'=+X  D
  1.  .Q:$P(^ATXAX(X,0),U,1)'["NDC"
  1.  .Q:$P(^ATXAX(X,0),U,1)'["BGP"
  1.  .Q:$P(^ATXAX(X,0),U,15)]""  ;already has a file
  1.  .S $P(^ATXAX(X,0),U,15)=50.67
  1.  Q
  1. SETCLASS ;
  1.  S ATXTEXT="CLASS" F ATXX=1:1 S ATXTX=$P($T(@ATXTEXT+ATXX),";;",2) Q:ATXTX=""  D
  1.  .S ATXDA=$O(^ATXAX("B",ATXTX,0))
  1.  .Q:'ATXDA
  1.  .Q:'$D(^ATXAX(ATXDA,0))
  1.  .Q:$P(^ATXAX(ATXDA,0),U,15)]""  ;already has a file
  1.  .S $P(^ATXAX(ATXDA,0),U,15)=50.605
  1.  .Q
  1.  Q
  1. INSTALLD(ATXSTAL) ;EP - Determine if patch ATXSTAL was installed, where
  1.  ; ATXSTAL is the name of the INSTALL.  E.g "AG*6.0*11".
  1.  ;
  1.  NEW ATXY,DIC,X,Y
  1.  S X=$P(ATXSTAL,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",22,",X=$P(ATXSTAL,"*",2)
  1.  D ^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(ATXSTAL,"*",3)
  1.  D ^DIC
  1.  S ATXY=Y
  1.  D IMES
  1.  Q $S(ATXY<1:0,1:1)
  1. IMES ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Patch """_ATXSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
  1.  Q
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  I X=3 S XPDQUIT=2 Q
  1.  S XPDQUIT=X
  1.  W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
  1.  Q
  1. FIX ;
  1.  S X=0
  1.  F  S X=$O(^ATXAX(X)) Q:X'=+X  D
  1.  .Q:$P(^ATXAX(X,0),U,15)'=80.1
  1.  .S Y=0 F  S Y=$O(^ATXAX(X,21,Y)) Q:Y'=+Y  D
  1.  ..I $P(^ATXAX(X,21,Y,0),U,3)="" W !,X," ",$P(^ATXAX(X,0),U,1)," ",Y
  1.  Q
  1. NDC ;
  1.  ;;BAT ASTHMA CONTROLLER NDC
  1.  ;;BAT ASTHMA INHLD STEROIDS NDC
  1.  ;;BAT ASTHMA LEUKOTRIENE NDC
  1.  ;;BAT ASTHMA SHRT ACT INHLR NDC
  1.  ;;BAT ASTHMA SHRT ACT RELV NDC
  1.  ;;BGP ASTHMA CONTROLLER NDC
  1.  ;;BGP ASTHMA INHALED STEROID NDC
  1.  ;;BGP ASTHMA LABA NDC
  1.  ;;BGP ASTHMA LEUKOTRIENE NDC
  1.  ;;BGP CMS BETA BLOCKER NDC
  1.  ;;BGP CMS SMOKING CESSATION NDC
  1.  ;;BGP HEDIS AMPHETAMINE NDC
  1.  ;;BGP HEDIS ANALGESIC NDC
  1.  ;;BGP HEDIS ANTIANXIETY NDC
  1.  ;;BGP HEDIS ANTIBIOTICS NDC
  1.  ;;BGP HEDIS ANTIDEPRESSANT NDC
  1.  ;;BGP HEDIS ANTIEMETIC NDC
  1.  ;;BGP HEDIS ANTIHISTAMINE NDC
  1.  ;;BGP HEDIS ANTIPSYCHOTIC NDC
  1.  ;;BGP HEDIS ARB NDC
  1.  ;;BGP HEDIS ASTHMA INHALED NDC
  1.  ;;BGP HEDIS ASTHMA LEUK NDC
  1.  ;;BGP HEDIS ASTHMA NDC
  1.  ;;BGP HEDIS BARBITURATE NDC
  1.  ;;BGP HEDIS BELLADONNA ALKA NDC
  1.  ;;BGP HEDIS BENZODIAZEPINE NDC
  1.  ;;BGP HEDIS BETA BLOCKER NDC
  1.  ;;BGP HEDIS CALCIUM CHANNEL NDC
  1.  ;;BGP HEDIS GASTRO ANTISPASM NDC
  1.  ;;BGP HEDIS NARCOTIC NDC
  1.  ;;BGP HEDIS ORAL ESTROGEN NDC
  1.  ;;BGP HEDIS ORAL HYPOGLYCEMIC ND
  1.  ;;BGP HEDIS OSTEOPOROSIS NDC
  1.  ;;BGP HEDIS OSTEOPOROSIS NDC
  1.  ;;BGP HEDIS OTHER BENZO NDC
  1.  ;;BGP HEDIS OTHER NDC AVOID ELD
  1.  ;;BGP HEDIS PRIMARY ASTHMA NDC
  1.  ;;BGP HEDIS SKL MUSCLE RELAX NDC
  1.  ;;BGP HEDIS STATIN NDC
  1.  ;;BGP HEDIS VASODILATOR NDC
  1.  ;;BGP PQA ACEI ARB NDC
  1.  ;;BGP PQA ANTIRETROVIRAL NDC
  1.  ;;BGP PQA BETA BLOCKER NDC
  1.  ;;BGP PQA BIGUANIDE NDC
  1.  ;;BGP PQA CCB NDC
  1.  ;;BGP PQA CONTROLLER NDC
  1.  ;;BGP PQA DIABETES ALL CLASS NDC
  1.  ;;BGP PQA DPP IV NDC
  1.  ;;BGP PQA RASA NDC
  1.  ;;BGP PQA SABA NDC
  1.  ;;BGP PQA STATIN NDC
  1.  ;;BGP PQA SULFONYLUREA NDC
  1.  ;;BGP PQA THIAZOLIDINEDIONE NDC
  1.  ;;BGP RA AZATHIOPRINE NDC
  1.  ;;BGP RA CYCLOSPORINE NDC
  1.  ;;BGP RA IM GOLD NDC
  1.  ;;BGP RA LEFLUNOMIDE NDC
  1.  ;;BGP RA METHOTREXATE NDC
  1.  ;;BGP RA MYCOPHENOLATE NDC
  1.  ;;BGP RA OA NSAID NDC
  1.  ;;BGP RA PENICILLAMINE NDC
  1.  ;;BGP RA SULFASALAZINE NDC
  1.  ;;BGPMU ANTICOAG NDCS
  1.  ;;BGPMU ANTIPLATELET NDCS
  1.  ;;BGPMU ANTITHROMBOTIC NDCS
  1.  ;;BGPMU BETABLOCKER NDCS
  1.  ;;BGPMU GONODOTROPIN NDCS
  1.  ;;BGPMU LIPID LOWERING NDCS
  1.  ;;BGPMU PHARYNGITIS MEDS NDCS
  1.  ;;BGPMU STATIN NDCS
  1.  ;;BGPMU TAMOXIFEN AROMATASE NDCS
  1.  ;;BGPMU TPA NDC CODES
  1.  ;;BGPMU UFH THERAPY NDCS
  1.  ;;BGPMU VTE ANTICOAG NDCS
  1.  ;;BGPMU VTE PROPHYLAXIS
  1.  ;;BGPMU WARFARIN NDCS
  1.  ;;BKM TB MED NDCS
  1.  ;;BKMV EI MED NDCS
  1.  ;;BKMV II MED NDCS
  1.  ;;BKMV MAC PROPH MED NDCS
  1.  ;;BKMV NNRTI MED NDCS
  1.  ;;BKMV NRTI COMBO MED NDCS
  1.  ;;BKMV NRTI MED NDCS
  1.  ;;BKMV NRTI/NNRTI MED NDCS
  1.  ;;BKMV PCP PROPH MED NDCS
  1.  ;;BKMV PI BOOSTER MED NDCS
  1.  ;;BKMV PI MED NDCS
  1.  ;;BQI STATIN NDC
  1.  ;;BUD DIABETES MEDS NDC
  1.  ;;
  1. CLASS ;;
  1.  ;;DM AUDIT ACE INHIB CLASS
  1.  ;;BGP ANTIDEPRESSANT VA CLASS
  1.  ;;BGP THROMBOLYTIC AGENT CLASS
  1.  ;;BGP RA GLUCOCORTICOIDS CLASS
  1.  ;;BGP OA GLUCOCORTICOIDS CLASS
  1.  ;;BGP CMS ACEI MEDS CLASS
  1.  ;;BGP CMS ANTI-PLATELET CLASS
  1.  ;;BGP CMS ANTIBIOTICS MEDS CLASS
  1.  ;;BGP CMS ARB MEDS CLASS
  1.  ;;BGP CMS BETA BLOCKER CLASS
  1.  ;;