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