BGP2POS1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
;;12.1;IHS CLINICAL REPORTING;**1**;MAY 17, 2012;Build 2
;
;
DRUGS ;EP set up drug taxonomies
S ATXFLG=1
S BGPX=$O(^ATXAX("B","BGP PQA ACEI ARB MEDS",0))
I BGPX S DA=BGPX,DIE="^ATXAX(",DR=".01///BGP PQA RASA MEDS" D ^DIE K DR,DIE,DA
S BGPX="BGP CMS WARFARIN MEDS",BGPTAX="",BGPNDCT="" D DRUG1 D
.S BGPTX=$O(^ATXAX("B","BGP CMS WARFARIN MEDS",0))
.Q:'BGPTX
.S A=0,B="" F S A=$O(^ATXAX(BGPTX,21,A)) Q:A'=+A S B=A
.S BGPC=B
.S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J S C=$P(^PSDRUG(J,0),U,1) I C["WARFARIN" D
..Q:$D(^ATXAX(BGPTX,21,"B",J))
..S BGPC=BGPC+1,^ATXAX(BGPTX,21,BGPC,0)=J_U_J,^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
.S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
S BGPX="BGP CMS ACEI MEDS",BGPTAX="BGP CMS ACEI MEDS CLASS",BGPNDCT="" D DRUG1
S BGPX="BGP CMS BETA BLOCKER MEDS",BGPTAX="BGP CMS BETA BLOCKER CLASS",BGPNDCT="BGP CMS BETA BLOCKER NDC" D DRUG1
S BGPX="BGP CMS ANTIBIOTIC MEDS",BGPTAX="BGP CMS ANTIBIOTICS MEDS CLASS",BGPNDCT="" D DRUG1
S BGPX="BGP CMS ARB MEDS",BGPTAX="BGP CMS ARB MEDS CLASS",BGPNDCT="" D DRUG1
S BGPX="DM AUDIT ASPIRIN DRUGS",BGPTAX="",BGPNDCT="" D DRUG1
S BGPX="BGP ANTI-PLATELET DRUGS",BGPTAX="BGP CMS ANTI-PLATELET CLASS",BGPNDCT="" D DRUG1
S BGPX="BGP HEDIS OSTEOPOROSIS DRUGS",BGPTAX="",BGPNDCT="BGP HEDIS OSTEOPOROSIS NDC" D DRUG1
S BGPX="BGP ASTHMA CONTROLLERS",BGPTAX="",BGPNDCT="BGP ASTHMA CONTROLLER NDC" D DRUG1
S BGPX="BGP ASTHMA INHALED STEROIDS",BGPTAX="",BGPNDCT="BGP ASTHMA INHALED STEROID NDC" D DRUG1
S BGPX="BGP ASTHMA LEUKOTRIENE",BGPTAX="",BGPNDCT="BGP ASTHMA LEUKOTRIENE NDC" D DRUG1
S BGPX="BGP HEDIS ANTIDEPRESSANT MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ANTIDEPRESSANT NDC" D DRUG1
S BGPX="BGP RA OA NSAID MEDS",BGPTAX="",BGPNDCT="BGP RA OA NSAID NDC" D DRUG1
S BGPX="BGP RA GLUCOCORTICOIDS MEDS",BGPTAX="BGP RA GLUCOCORTICOIDS CLASS",BGPNDCT="" D DRUG1
S BGPX="BGP HEDIS ANTIBIOTICS MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ANTIBIOTICS NDC" D DRUG1
S BGPX="BGP HEDIS ASTHMA LEUK MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ASTHMA LEUK NDC" D DRUG1
S BGPX="BGP HEDIS ASTHMA MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ASTHMA NDC" D DRUG1
S BGPX="BGP HEDIS PRIMARY ASTHMA MEDS",BGPTAX="",BGPNDCT="BGP HEDIS PRIMARY ASTHMA NDC" D DRUG1
S BGPX="BGP HEDIS ASTHMA INHALED MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ASTHMA INHALED NDC" D DRUG1
S BGPX="BGP HEDIS BETA BLOCKER MEDS",BGPTAX="",BGPNDCT="BGP HEDIS BETA BLOCKER NDC" D DRUG1
S BGPX="BGP RA IM GOLD MEDS",BGPTAX="",BGPNDCT="BGP RA IM GOLD NDC" D DRUG1
S BGPX="BGP RA AZATHIOPRINE MEDS",BGPTAX="",BGPNDCT="BGP RA AZATHIOPRINE NDC" D DRUG1
S BGPX="BGP RA LEFLUNOMIDE MEDS",BGPTAX="",BGPNDCT="BGP RA LEFLUNOMIDE NDC" D DRUG1
S BGPX="BGP RA ORAL GOLD MEDS",BGPTAX="",BGPNDCT="" D DRUG1
S BGPX="BGP RA CYCLOSPORINE MEDS",BGPTAX="",BGPNDCT="BGP RA CYCLOSPORINE NDC" D DRUG1
S BGPX="BGP RA METHOTREXATE MEDS",BGPTAX="",BGPNDCT="BGP RA METHOTREXATE NDC" D DRUG1
S BGPX="BGP RA MYCOPHENOLATE MEDS",BGPTAX="",BGPNDCT="BGP RA MYCOPHENOLATE NDC" D DRUG1
S BGPX="BGP RA PENICILLAMINE MEDS",BGPTAX="",BGPNDCT="BGP RA PENICILLAMINE NDC" D DRUG1
S BGPX="BGP RA SULFASALAZINE MEDS",BGPTAX="",BGPNDCT="BGP RA SULFASALAZINE NDC" D DRUG1
S BGPX="BGP CMS THROMBOLYTIC MEDS",BGPTAX="BGP THROMBOLYTIC AGENT CLASS",BGPNDCT="" D DRUG1
S BGPX="BGP HEDIS ANTIANXIETY MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ANTIANXIETY NDC" D DRUG1
S BGPX="BGP HEDIS ANTIEMETIC MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ANTIEMETIC NDC" D DRUG1
S BGPX="BGP HEDIS ANALGESIC MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ANALGESIC NDC" D DRUG1
S BGPX="BGP HEDIS ANTIHISTAMINE MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ANTIHISTAMINE NDC" D DRUG1
S BGPX="BGP HEDIS ANTIPSYCHOTIC MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ANTIPSYCHOTIC NDC" D DRUG1
S BGPX="BGP HEDIS AMPHETAMINE MEDS",BGPTAX="",BGPNDCT="BGP HEDIS AMPHETAMINE NDC" D DRUG1
S BGPX="BGP HEDIS BARBITURATE MEDS",BGPTAX="",BGPNDCT="BGP HEDIS BARBITURATE NDC" D DRUG1
S BGPX="BGP HEDIS BENZODIAZEPINE MEDS",BGPTAX="",BGPNDCT="BGP HEDIS BENZODIAZEPINE NDC" D DRUG1
;S BGPX="BGP HEDIS OTHER BENZODIAZEPINE",BGPTAX="",BGPNDCT="BGP HEDIS OTHER BENZO NDC" D DRUG1
S BGPX="BGP HEDIS CALCIUM CHANNEL MEDS",BGPTAX="",BGPNDCT="BGP HEDIS CALCIUM CHANNEL NDC" D DRUG1
S BGPX="BGP HEDIS GASTRO ANTISPASM MED",BGPTAX="",BGPNDCT="BGP HEDIS GASTRO ANTISPASM NDC" D DRUG1
S BGPX="BGP HEDIS BELLADONNA ALKA MEDS",BGPTAX="",BGPNDCT="BGP HEDIS BELLADONNA ALKA NDC" D DRUG1
S BGPX="BGP HEDIS SKL MUSCLE RELAX MED",BGPTAX="",BGPNDCT="BGP HEDIS SKL MUSCLE RELAX NDC" D DRUG1
S BGPX="BGP HEDIS ORAL ESTROGEN MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ORAL ESTROGEN NDC" D DRUG1
S BGPX="BGP HEDIS ORAL HYPOGLYCEMIC RX",BGPTAX="",BGPNDCT="BGP HEDIS ORAL HYPOGLYCEMIC ND" D DRUG1
S BGPX="BGP HEDIS VASODILATOR MEDS",BGPTAX="",BGPNDCT="BGP HEDIS VASODILATOR NDC" D DRUG1
S BGPX="BGP HEDIS OTHER MEDS AVOID ELD",BGPTAX="",BGPNDCT="BGP HEDIS OTHER NDC AVOID ELD" D DRUG1
S BGPX="BGP HEDIS NARCOTIC MEDS",BGPTAX="",BGPNDCT="BGP HEDIS NARCOTIC NDC" D DRUG1
S BGPX="BGP HEDIS ACEI MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ACEI NDC" D DRUG1
S BGPX="BGP HEDIS ARB MEDS",BGPTAX="",BGPNDCT="BGP HEDIS ARB NDC" D DRUG1
S BGPX="BGP HEDIS STATIN MEDS",BGPTAX="",BGPNDCT="BGP HEDIS STATIN NDC" D DRUG1
;PQA
S BGPX="BGP PQA BETA BLOCKER MEDS",BGPTAX="",BGPNDCT="BGP PQA BETA BLOCKER NDC" D DRUG1
S BGPX="BGP PQA RASA MEDS",BGPTAX="",BGPNDCT="BGP PQA RASA NDC" D DRUG1
S BGPX="BGP PQA CCB MEDS",BGPTAX="",BGPNDCT="BGP PQA CCB NDC" D DRUG1
S BGPX="BGP PQA BIGUANIDE MEDS",BGPTAX="",BGPNDCT="BGP PQA BIGUANIDE NDC" D DRUG1
S BGPX="BGP PQA SULFONYLUREA MEDS",BGPTAX="",BGPNDCT="BGP PQA SULFONYLUREA NDC" D DRUG1
S BGPX="BGP PQA THIAZOLIDINEDIONE MEDS",BGPTAX="",BGPNDCT="BGP PQA THIAZOLIDINEDIONE NDC" D DRUG1
S BGPX="BGP PQA STATIN MEDS",BGPTAX="",BGPNDCT="BGP PQA STATIN NDC" D DRUG1
S BGPX="BGP PQA ANTIRETROVIRAL MEDS",BGPTAX="",BGPNDCT="BGP PQA ANTIRETROVIRAL NDC" D DRUG1
S BGPX="BGP PQA SABA MEDS",BGPTAX="",BGPNDCT="BGP PQA SABA NDC" D DRUG1
S BGPX="BGP PQA CONTROLLER MEDS",BGPTAX="",BGPNDCT="BGP PQA CONTROLLER NDC" D DRUG1
S BGPX="BGP ASTHMA LABA MEDS",BGPTAX="",BGPNDCT="BGP ASTHMA LABA NDC" D DRUG1
SM ;
S ATXFLG=1,BGPX="BGP CMS SMOKING CESSATION MEDS",BGPTAX="",BGPNDCT="BGP CMS SMOKING CESSATION NDC" D DRUG1
D SMOKING
;
S BGPX="BGP CMS SYSTEMIC CHEMO MEDS",BGPTAX="",BGPNDCT="" D DRUG1
;prepopulate this one
D SYSCHEMO
S BGPX="BGP CMS IMMUNOSUPPRESSIVE MEDS",BGPTAX="",BGPNDCT="" D DRUG1
D IMMUNO
FIXA ;TAKE OUT ARB'S FROM ASPIRIN TAXONOMY
S BGPT=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
I BGPT D
.S BGPX=0 F S BGPX=$O(^ATXAX(BGPT,21,BGPX)) Q:BGPX'=+BGPX D
..S BGPY=$P(^ATXAX(BGPT,21,BGPX,0),U)
..I $P($G(^PSDRUG(BGPY,0)),U,2)="CV805" D
...K ^ATXAX(BGPT,21,"B",BGPY),^ATXAX(BGPT,21,"AA",BGPY),^ATXAX(BGPT,21,BGPX,0)
K ATXFLG,BGPX,BGPDA,BGPTX
Q
DRUG1 ;
W !,"Creating ",BGPX," Taxonomy..."
S BGPTX=$O(^ATXAX("B",BGPX,0))
I 'BGPTX D Q:Y=-1
.S X=BGPX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
.I Y=-1 W !!,"ERROR IN CREATING ",BGPX," TAX" Q
.S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)=BGPX,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=173,$P(^(0),U,13)=0,$P(^(0),U,15)=50,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
I $G(BGPTAX)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BGPTX,21,A)) Q:A'=+A S B=A
.S BGPC=B
.S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BGPTAX,0))
.S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J S C=$P($G(^PSDRUG(J,0)),U,2) I C]"",$D(^ATXAX(Z,21,"B",C)) D
..Q:$D(^ATXAX(BGPTX,21,"B",J))
..S BGPC=BGPC+1,^ATXAX(BGPTX,21,BGPC,0)=J_U_J
I $G(BGPNDCT)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BGPTX,21,A)) Q:A'=+A S B=A
.S BGPC=B
.S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BGPNDCT,0))
.S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J S C=$P($G(^PSDRUG(J,2)),U,4) I C]"",$D(^ATXAX(Z,21,"B",C)) D
..Q:$D(^ATXAX(BGPTX,21,"B",J))
..S BGPC=BGPC+1,^ATXAX(BGPTX,21,BGPC,0)=J_U_J
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
LAB ;EP
S BGPX=$O(^ATXLAB("B","BGP PCR TAX",0))
I BGPX S DA=BGPX,DR=".01///BGP HIV VIRAL LOAD TAX",DIE="^ATXLAB(" D ^DIE K DA,DR,DIE,DIV,DIU,DIC
S BGPX="BGP HEP C TESTS TAX" D LAB1
S BGPX="BGP CD4 TAX" D LAB1
S BGPX="BGP CHLAMYDIA TESTS TAX" D LAB1
S BGPX="BGP CMS ABG TESTS" D LAB1
S BGPX="BGP GPRA ESTIMATED GFR TAX" D LAB1
S BGPX="BGP GPRA FOB TESTS" D LAB1
S BGPX="BGP HIV TEST TAX" D LAB1
S BGPX="BGP HIV VIRAL LOAD TAX" D LAB1
S BGPX="BGP PAP SMEAR TAX" D LAB1
S BGPX="DM AUDIT A/C RATIO TAX" D LAB1
S BGPX="DM AUDIT CHOLESTEROL TAX" D LAB1
S BGPX="DM AUDIT CREATININE TAX" D LAB1
S BGPX="DM AUDIT FASTING GLUCOSE TESTS" D LAB1
S BGPX="DM AUDIT HDL TAX" D LAB1
S BGPX="DM AUDIT HGB A1C TAX" D LAB1
S BGPX="DM AUDIT LDL CHOLESTEROL TAX" D LAB1
S BGPX="DM AUDIT MICROALBUMINURIA TAX" D LAB1
S BGPX="DM AUDIT TRIGLYCERIDE TAX" D LAB1
S BGPX="DM AUDIT URINE PROTEIN TAX" D LAB1
S BGPX="BGP CBC TESTS" D LAB1
S BGPX="DM AUDIT URINALYSIS TAX" D LAB1
S BGPX="DM AUDIT AST TAX" D LAB1
S BGPX="DM AUDIT ALT TAX" D LAB1
S BGPX="BGP GROUP A STREP TESTS" D LAB1
S BGPX="BGP LIVER FUNCTION TESTS" D LAB1
S BGPX="BGP URINE GLUCOSE" D LAB1
S BGPX="BGP POTASSIUM TESTS" D LAB1
S BGPX="BGP CMS BLOOD CULTURE" D LAB1
S BGPX="BGP QUANT URINE PROTEIN" D LAB1
S BGPX="DM AUDIT GLUCOSE TESTS TAX" D LAB1
S BGPX="BGP CREATINE KINASE TAX" D LAB1
S BGPX="BGP HEP C TESTS TAX" D LAB1
Q
LAB1 ;
S BGPDA=$O(^ATXLAB("B",BGPX,0))
Q:BGPDA ;taxonomy already exisits
W !,"Creating ",BGPX," Taxonomy..."
S X=BGPX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",BGPX," TAX" Q
S BGPTX=+Y,$P(^ATXLAB(BGPTX,0),U,2)=BGPX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60
S ^ATXLAB(BGPTX,21,0)="^9002228.02101PA^0^0"
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
CLTAX ;EP
W !,"Creating Primary Care Clinics taxonomy..."
S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP PRIMARY CARE CLINICS",BGPDA)) I BGPDA S DA=BGPDA S DIK="^ATXAX(" D ^DIK K DA,DIK
S X="BGP PRIMARY CARE CLINICS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING BGP PRIMARY CARE CLINICS TAX" Q
S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP PRIMARY CARE CLINICS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=172,$P(^(0),U,13)=0,$P(^(0),U,15)=40.7,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
D ^XBFMK K DIADD,DLAYGO S BGPTEXT="CLINICS" F BGPX=1:1:6 S X=$P($T(@BGPTEXT+BGPX),";;",2),Y=$O(^DIC(40.7,"C",X,0)) I Y D
.S ^ATXAX(BGPTX,21,BGPX,0)=+Y,$P(^ATXAX(BGPTX,21,0),U,3)=BGPX,$P(^(0),U,4)=BGPX,^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
.Q
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
PRVTAX ;EP
S ATXFLG=1
W !,"Creating Prescribing provider taxonomy..."
S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP PRESCRIBING PROVIDER CLASS",BGPDA)) I BGPDA S DA=BGPDA S DIK="^ATXAX(" D ^DIK K DA,DIK
S X="BGP PRESCRIBING PROVIDER CLASS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING BGP PRESCRIBING PROVIDER CLASS TAX" Q
S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP PRESCRIBING PROVIDER CLASS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=210,$P(^(0),U,13)=0,$P(^(0),U,15)=7,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
D ^XBFMK K DIADD,DLAYGO S BGPTEXT="PREPROV" F BGPX=1:1:43 S X=$P($T(@BGPTEXT+BGPX),";;",2),Y=$O(^DIC(7,"D",X,0)) I Y D
.S ^ATXAX(BGPTX,21,BGPX,0)=+Y,$P(^ATXAX(BGPTX,21,0),U,3)=BGPX,$P(^(0),U,4)=BGPX,^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
.Q
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
SYSCHEMO ;
S BGPTX=$O(^ATXAX("B","BGP CMS SYSTEMIC CHEMO MEDS",0))
Q:'BGPTX
S A=0,B="" F S A=$O(^ATXAX(BGPTX,21,A)) Q:A'=+A S B=A
S BGPC=B
S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J D
.S C=$P($G(^PSDRUG(J,0)),U,2)
.I C["AN" D
..Q:$D(^ATXAX(BGPTX,21,"B",J))
..S BGPC=BGPC+1,^ATXAX(BGPTX,21,BGPC,0)=J_U_J
..S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
..Q
.Q
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
IMMUNO ;
S BGPTX=$O(^ATXAX("B","BGP CMS IMMUNOSUPPRESSIVE MEDS",0))
Q:'BGPTX
S A=0,B="" F S A=$O(^ATXAX(BGPTX,21,A)) Q:A'=+A S B=A
S BGPC=B
S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J D
.S C=$P($G(^PSDRUG(J,0)),U,2)
.I C="IM600"!(C="MS190")!(C="MS109"&($$UP^XLFSTR($P(^PSDRUG(J,0),U))'["HYALURONATE")) D
..Q:$D(^ATXAX(BGPTX,21,"B",J))
..S BGPC=BGPC+1,^ATXAX(BGPTX,21,BGPC,0)=J_U_J
..S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
..Q
.Q
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
SMOKING ;
S BGPTX=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
Q:'BGPTX
S A=0,B="" F S A=$O(^ATXAX(BGPTX,21,A)) Q:A'=+A S B=A
S BGPC=B
S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
S J=0 F S J=$O(^PSDRUG(J)) Q:J'=+J D
.S C=$P($G(^PSDRUG(J,0)),U,1)
.I C["NICOTINE PATCH"!(C["NICOTINE POLACRILEX")!(C["NICOTINE INHALER")!(C["NICOTINE NASAL SPRAY") D
..Q:$D(^ATXAX(BGPTX,21,"B",J))
..S BGPC=BGPC+1,^ATXAX(BGPTX,21,BGPC,0)=J_U_J
..S ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
..Q
.Q
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
MHTAX ;EP
S ATXFLG=1
W !,"Creating Mental Health provider taxonomy..."
S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP MENTAL HEALTH PROV CLASS",BGPDA)) I BGPDA S DA=BGPDA S DIK="^ATXAX(" D ^DIK K DA,DIK
S X="BGP MENTAL HEALTH PROV CLASS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING BGP MENTAL HEALTH PROV CLASS TAX" Q
S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP MENTAL HEALTH PROV CLASS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=210,$P(^(0),U,13)=0,$P(^(0),U,15)=7,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
D ^XBFMK K DIADD,DLAYGO S BGPTEXT="MHPROV" F BGPX=1:1:14 S X=$P($T(@BGPTEXT+BGPX),";;",2),Y=$O(^DIC(7,"D",X,0)) I Y D
.S ^ATXAX(BGPTX,21,BGPX,0)=+Y,$P(^ATXAX(BGPTX,21,0),U,3)=BGPX,$P(^(0),U,4)=BGPX,^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
.Q
S DA=BGPTX,DIK="^ATXAX(" D IX1^DIK
Q
;
MHPROV ;
;;06
;;12
;;19
;;48
;;49
;;50
;;62
;;63
;;81
;;92
;;93
;;94
;;95
;;96
;;
CLINICS ;
;;01
;;06
;;13
;;20
;;24
;;28
;;
PRVS ;
;;00
;;11
;;16
;;17
;;18
;;21
;;25
;;33
;;41
;;44
;;45
;;49
;;64
;;68
;;69
;;70
;;71
;;72
;;73
;;74
;;75
;;76
;;77
;;78
;;79
;;80
;;81
;;82
;;83
;;84
;;85
;;86
;;A1
;;
PREPROV ;;
;;00
;;08
;;11
;;16
;;17
;;18
;;21
;;24
;;25
;;30
;;33
;;41
;;44
;;45
;;47
;;49
;;64
;;67
;;68
;;70
;;71
;;72
;;73
;;74
;;75
;;76
;;77
;;78
;;79
;;80
;;81
;;82
;;83
;;85
;;86
;;A1
;;A9
;;B1
;;B2
;;B3
;;B4
;;B5
;;B6
;;
;
BGP2POS1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
+1 ;;12.1;IHS CLINICAL REPORTING;**1**;MAY 17, 2012;Build 2
+2 ;
+3 ;
DRUGS ;EP set up drug taxonomies
+1 SET ATXFLG=1
+2 SET BGPX=$ORDER(^ATXAX("B","BGP PQA ACEI ARB MEDS",0))
+3 IF BGPX
SET DA=BGPX
SET DIE="^ATXAX("
SET DR=".01///BGP PQA RASA MEDS"
DO ^DIE
KILL DR,DIE,DA
+4 SET BGPX="BGP CMS WARFARIN MEDS"
SET BGPTAX=""
SET BGPNDCT=""
DO DRUG1
Begin DoDot:1
+5 SET BGPTX=$ORDER(^ATXAX("B","BGP CMS WARFARIN MEDS",0))
+6 IF 'BGPTX
QUIT
+7 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BGPTX,21,A))
IF A'=+A
QUIT
SET B=A
+8 SET BGPC=B
+9 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
SET C=$PIECE(^PSDRUG(J,0),U,1)
IF C["WARFARIN"
Begin DoDot:2
+10 IF $DATA(^ATXAX(BGPTX,21,"B",J))
QUIT
+11 SET BGPC=BGPC+1
SET ^ATXAX(BGPTX,21,BGPC,0)=J_U_J
SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
End DoDot:2
+12 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
End DoDot:1
+13 SET BGPX="BGP CMS ACEI MEDS"
SET BGPTAX="BGP CMS ACEI MEDS CLASS"
SET BGPNDCT=""
DO DRUG1
+14 SET BGPX="BGP CMS BETA BLOCKER MEDS"
SET BGPTAX="BGP CMS BETA BLOCKER CLASS"
SET BGPNDCT="BGP CMS BETA BLOCKER NDC"
DO DRUG1
+15 SET BGPX="BGP CMS ANTIBIOTIC MEDS"
SET BGPTAX="BGP CMS ANTIBIOTICS MEDS CLASS"
SET BGPNDCT=""
DO DRUG1
+16 SET BGPX="BGP CMS ARB MEDS"
SET BGPTAX="BGP CMS ARB MEDS CLASS"
SET BGPNDCT=""
DO DRUG1
+17 SET BGPX="DM AUDIT ASPIRIN DRUGS"
SET BGPTAX=""
SET BGPNDCT=""
DO DRUG1
+18 SET BGPX="BGP ANTI-PLATELET DRUGS"
SET BGPTAX="BGP CMS ANTI-PLATELET CLASS"
SET BGPNDCT=""
DO DRUG1
+19 SET BGPX="BGP HEDIS OSTEOPOROSIS DRUGS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS OSTEOPOROSIS NDC"
DO DRUG1
+20 SET BGPX="BGP ASTHMA CONTROLLERS"
SET BGPTAX=""
SET BGPNDCT="BGP ASTHMA CONTROLLER NDC"
DO DRUG1
+21 SET BGPX="BGP ASTHMA INHALED STEROIDS"
SET BGPTAX=""
SET BGPNDCT="BGP ASTHMA INHALED STEROID NDC"
DO DRUG1
+22 SET BGPX="BGP ASTHMA LEUKOTRIENE"
SET BGPTAX=""
SET BGPNDCT="BGP ASTHMA LEUKOTRIENE NDC"
DO DRUG1
+23 SET BGPX="BGP HEDIS ANTIDEPRESSANT MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ANTIDEPRESSANT NDC"
DO DRUG1
+24 SET BGPX="BGP RA OA NSAID MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA OA NSAID NDC"
DO DRUG1
+25 SET BGPX="BGP RA GLUCOCORTICOIDS MEDS"
SET BGPTAX="BGP RA GLUCOCORTICOIDS CLASS"
SET BGPNDCT=""
DO DRUG1
+26 SET BGPX="BGP HEDIS ANTIBIOTICS MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ANTIBIOTICS NDC"
DO DRUG1
+27 SET BGPX="BGP HEDIS ASTHMA LEUK MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ASTHMA LEUK NDC"
DO DRUG1
+28 SET BGPX="BGP HEDIS ASTHMA MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ASTHMA NDC"
DO DRUG1
+29 SET BGPX="BGP HEDIS PRIMARY ASTHMA MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS PRIMARY ASTHMA NDC"
DO DRUG1
+30 SET BGPX="BGP HEDIS ASTHMA INHALED MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ASTHMA INHALED NDC"
DO DRUG1
+31 SET BGPX="BGP HEDIS BETA BLOCKER MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS BETA BLOCKER NDC"
DO DRUG1
+32 SET BGPX="BGP RA IM GOLD MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA IM GOLD NDC"
DO DRUG1
+33 SET BGPX="BGP RA AZATHIOPRINE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA AZATHIOPRINE NDC"
DO DRUG1
+34 SET BGPX="BGP RA LEFLUNOMIDE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA LEFLUNOMIDE NDC"
DO DRUG1
+35 SET BGPX="BGP RA ORAL GOLD MEDS"
SET BGPTAX=""
SET BGPNDCT=""
DO DRUG1
+36 SET BGPX="BGP RA CYCLOSPORINE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA CYCLOSPORINE NDC"
DO DRUG1
+37 SET BGPX="BGP RA METHOTREXATE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA METHOTREXATE NDC"
DO DRUG1
+38 SET BGPX="BGP RA MYCOPHENOLATE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA MYCOPHENOLATE NDC"
DO DRUG1
+39 SET BGPX="BGP RA PENICILLAMINE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA PENICILLAMINE NDC"
DO DRUG1
+40 SET BGPX="BGP RA SULFASALAZINE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP RA SULFASALAZINE NDC"
DO DRUG1
+41 SET BGPX="BGP CMS THROMBOLYTIC MEDS"
SET BGPTAX="BGP THROMBOLYTIC AGENT CLASS"
SET BGPNDCT=""
DO DRUG1
+42 SET BGPX="BGP HEDIS ANTIANXIETY MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ANTIANXIETY NDC"
DO DRUG1
+43 SET BGPX="BGP HEDIS ANTIEMETIC MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ANTIEMETIC NDC"
DO DRUG1
+44 SET BGPX="BGP HEDIS ANALGESIC MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ANALGESIC NDC"
DO DRUG1
+45 SET BGPX="BGP HEDIS ANTIHISTAMINE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ANTIHISTAMINE NDC"
DO DRUG1
+46 SET BGPX="BGP HEDIS ANTIPSYCHOTIC MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ANTIPSYCHOTIC NDC"
DO DRUG1
+47 SET BGPX="BGP HEDIS AMPHETAMINE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS AMPHETAMINE NDC"
DO DRUG1
+48 SET BGPX="BGP HEDIS BARBITURATE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS BARBITURATE NDC"
DO DRUG1
+49 SET BGPX="BGP HEDIS BENZODIAZEPINE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS BENZODIAZEPINE NDC"
DO DRUG1
+50 ;S BGPX="BGP HEDIS OTHER BENZODIAZEPINE",BGPTAX="",BGPNDCT="BGP HEDIS OTHER BENZO NDC" D DRUG1
+51 SET BGPX="BGP HEDIS CALCIUM CHANNEL MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS CALCIUM CHANNEL NDC"
DO DRUG1
+52 SET BGPX="BGP HEDIS GASTRO ANTISPASM MED"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS GASTRO ANTISPASM NDC"
DO DRUG1
+53 SET BGPX="BGP HEDIS BELLADONNA ALKA MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS BELLADONNA ALKA NDC"
DO DRUG1
+54 SET BGPX="BGP HEDIS SKL MUSCLE RELAX MED"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS SKL MUSCLE RELAX NDC"
DO DRUG1
+55 SET BGPX="BGP HEDIS ORAL ESTROGEN MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ORAL ESTROGEN NDC"
DO DRUG1
+56 SET BGPX="BGP HEDIS ORAL HYPOGLYCEMIC RX"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ORAL HYPOGLYCEMIC ND"
DO DRUG1
+57 SET BGPX="BGP HEDIS VASODILATOR MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS VASODILATOR NDC"
DO DRUG1
+58 SET BGPX="BGP HEDIS OTHER MEDS AVOID ELD"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS OTHER NDC AVOID ELD"
DO DRUG1
+59 SET BGPX="BGP HEDIS NARCOTIC MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS NARCOTIC NDC"
DO DRUG1
+60 SET BGPX="BGP HEDIS ACEI MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ACEI NDC"
DO DRUG1
+61 SET BGPX="BGP HEDIS ARB MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS ARB NDC"
DO DRUG1
+62 SET BGPX="BGP HEDIS STATIN MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP HEDIS STATIN NDC"
DO DRUG1
+63 ;PQA
+64 SET BGPX="BGP PQA BETA BLOCKER MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA BETA BLOCKER NDC"
DO DRUG1
+65 SET BGPX="BGP PQA RASA MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA RASA NDC"
DO DRUG1
+66 SET BGPX="BGP PQA CCB MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA CCB NDC"
DO DRUG1
+67 SET BGPX="BGP PQA BIGUANIDE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA BIGUANIDE NDC"
DO DRUG1
+68 SET BGPX="BGP PQA SULFONYLUREA MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA SULFONYLUREA NDC"
DO DRUG1
+69 SET BGPX="BGP PQA THIAZOLIDINEDIONE MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA THIAZOLIDINEDIONE NDC"
DO DRUG1
+70 SET BGPX="BGP PQA STATIN MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA STATIN NDC"
DO DRUG1
+71 SET BGPX="BGP PQA ANTIRETROVIRAL MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA ANTIRETROVIRAL NDC"
DO DRUG1
+72 SET BGPX="BGP PQA SABA MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA SABA NDC"
DO DRUG1
+73 SET BGPX="BGP PQA CONTROLLER MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP PQA CONTROLLER NDC"
DO DRUG1
+74 SET BGPX="BGP ASTHMA LABA MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP ASTHMA LABA NDC"
DO DRUG1
SM ;
+1 SET ATXFLG=1
SET BGPX="BGP CMS SMOKING CESSATION MEDS"
SET BGPTAX=""
SET BGPNDCT="BGP CMS SMOKING CESSATION NDC"
DO DRUG1
+2 DO SMOKING
+3 ;
+4 SET BGPX="BGP CMS SYSTEMIC CHEMO MEDS"
SET BGPTAX=""
SET BGPNDCT=""
DO DRUG1
+5 ;prepopulate this one
+6 DO SYSCHEMO
+7 SET BGPX="BGP CMS IMMUNOSUPPRESSIVE MEDS"
SET BGPTAX=""
SET BGPNDCT=""
DO DRUG1
+8 DO IMMUNO
FIXA ;TAKE OUT ARB'S FROM ASPIRIN TAXONOMY
+1 SET BGPT=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+2 IF BGPT
Begin DoDot:1
+3 SET BGPX=0
FOR
SET BGPX=$ORDER(^ATXAX(BGPT,21,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+4 SET BGPY=$PIECE(^ATXAX(BGPT,21,BGPX,0),U)
+5 IF $PIECE($GET(^PSDRUG(BGPY,0)),U,2)="CV805"
Begin DoDot:3
+6 KILL ^ATXAX(BGPT,21,"B",BGPY),^ATXAX(BGPT,21,"AA",BGPY),^ATXAX(BGPT,21,BGPX,0)
End DoDot:3
End DoDot:2
End DoDot:1
+7 KILL ATXFLG,BGPX,BGPDA,BGPTX
+8 QUIT
DRUG1 ;
+1 WRITE !,"Creating ",BGPX," Taxonomy..."
+2 SET BGPTX=$ORDER(^ATXAX("B",BGPX,0))
+3 IF 'BGPTX
Begin DoDot:1
+4 SET X=BGPX
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING ",BGPX," TAX"
QUIT
+6 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)=BGPX
SET $PIECE(^(0),U,8)=0
SET $PIECE(^(0),U,9)=DT
SET $PIECE(^(0),U,12)=173
SET $PIECE(^(0),U,13)=0
SET $PIECE(^(0),U,15)=50
SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
End DoDot:1
IF Y=-1
QUIT
+7 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+8 IF $GET(BGPTAX)]""
Begin DoDot:1
+9 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BGPTX,21,A))
IF A'=+A
QUIT
SET B=A
+10 SET BGPC=B
+11 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
+12 SET Z=$ORDER(^ATXAX("B",BGPTAX,0))
+13 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
SET C=$PIECE($GET(^PSDRUG(J,0)),U,2)
IF C]""
IF $DATA(^ATXAX(Z,21,"B",C))
Begin DoDot:2
+14 IF $DATA(^ATXAX(BGPTX,21,"B",J))
QUIT
+15 SET BGPC=BGPC+1
SET ^ATXAX(BGPTX,21,BGPC,0)=J_U_J
End DoDot:2
End DoDot:1
+16 IF $GET(BGPNDCT)]""
Begin DoDot:1
+17 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BGPTX,21,A))
IF A'=+A
QUIT
SET B=A
+18 SET BGPC=B
+19 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
+20 SET Z=$ORDER(^ATXAX("B",BGPNDCT,0))
+21 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
SET C=$PIECE($GET(^PSDRUG(J,2)),U,4)
IF C]""
IF $DATA(^ATXAX(Z,21,"B",C))
Begin DoDot:2
+22 IF $DATA(^ATXAX(BGPTX,21,"B",J))
QUIT
+23 SET BGPC=BGPC+1
SET ^ATXAX(BGPTX,21,BGPC,0)=J_U_J
End DoDot:2
End DoDot:1
+24 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+25 QUIT
+26 ;
LAB ;EP
+1 SET BGPX=$ORDER(^ATXLAB("B","BGP PCR TAX",0))
+2 IF BGPX
SET DA=BGPX
SET DR=".01///BGP HIV VIRAL LOAD TAX"
SET DIE="^ATXLAB("
DO ^DIE
KILL DA,DR,DIE,DIV,DIU,DIC
+3 SET BGPX="BGP HEP C TESTS TAX"
DO LAB1
+4 SET BGPX="BGP CD4 TAX"
DO LAB1
+5 SET BGPX="BGP CHLAMYDIA TESTS TAX"
DO LAB1
+6 SET BGPX="BGP CMS ABG TESTS"
DO LAB1
+7 SET BGPX="BGP GPRA ESTIMATED GFR TAX"
DO LAB1
+8 SET BGPX="BGP GPRA FOB TESTS"
DO LAB1
+9 SET BGPX="BGP HIV TEST TAX"
DO LAB1
+10 SET BGPX="BGP HIV VIRAL LOAD TAX"
DO LAB1
+11 SET BGPX="BGP PAP SMEAR TAX"
DO LAB1
+12 SET BGPX="DM AUDIT A/C RATIO TAX"
DO LAB1
+13 SET BGPX="DM AUDIT CHOLESTEROL TAX"
DO LAB1
+14 SET BGPX="DM AUDIT CREATININE TAX"
DO LAB1
+15 SET BGPX="DM AUDIT FASTING GLUCOSE TESTS"
DO LAB1
+16 SET BGPX="DM AUDIT HDL TAX"
DO LAB1
+17 SET BGPX="DM AUDIT HGB A1C TAX"
DO LAB1
+18 SET BGPX="DM AUDIT LDL CHOLESTEROL TAX"
DO LAB1
+19 SET BGPX="DM AUDIT MICROALBUMINURIA TAX"
DO LAB1
+20 SET BGPX="DM AUDIT TRIGLYCERIDE TAX"
DO LAB1
+21 SET BGPX="DM AUDIT URINE PROTEIN TAX"
DO LAB1
+22 SET BGPX="BGP CBC TESTS"
DO LAB1
+23 SET BGPX="DM AUDIT URINALYSIS TAX"
DO LAB1
+24 SET BGPX="DM AUDIT AST TAX"
DO LAB1
+25 SET BGPX="DM AUDIT ALT TAX"
DO LAB1
+26 SET BGPX="BGP GROUP A STREP TESTS"
DO LAB1
+27 SET BGPX="BGP LIVER FUNCTION TESTS"
DO LAB1
+28 SET BGPX="BGP URINE GLUCOSE"
DO LAB1
+29 SET BGPX="BGP POTASSIUM TESTS"
DO LAB1
+30 SET BGPX="BGP CMS BLOOD CULTURE"
DO LAB1
+31 SET BGPX="BGP QUANT URINE PROTEIN"
DO LAB1
+32 SET BGPX="DM AUDIT GLUCOSE TESTS TAX"
DO LAB1
+33 SET BGPX="BGP CREATINE KINASE TAX"
DO LAB1
+34 SET BGPX="BGP HEP C TESTS TAX"
DO LAB1
+35 QUIT
LAB1 ;
+1 SET BGPDA=$ORDER(^ATXLAB("B",BGPX,0))
+2 ;taxonomy already exisits
IF BGPDA
QUIT
+3 WRITE !,"Creating ",BGPX," Taxonomy..."
+4 SET X=BGPX
SET DIC="^ATXLAB("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002228
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING ",BGPX," TAX"
QUIT
+6 SET BGPTX=+Y
SET $PIECE(^ATXLAB(BGPTX,0),U,2)=BGPX
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,6)=DT
SET $PIECE(^(0),U,8)="B"
SET $PIECE(^(0),U,9)=60
+7 SET ^ATXLAB(BGPTX,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+9 QUIT
+10 ;
CLTAX ;EP
+1 WRITE !,"Creating Primary Care Clinics taxonomy..."
+2 SET BGPDA=0
SET BGPDA=$ORDER(^ATXAX("B","BGP PRIMARY CARE CLINICS",BGPDA))
IF BGPDA
SET DA=BGPDA
SET DIK="^ATXAX("
DO ^DIK
KILL DA,DIK
+3 SET X="BGP PRIMARY CARE CLINICS"
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+4 IF Y=-1
WRITE !!,"ERROR IN CREATING BGP PRIMARY CARE CLINICS TAX"
QUIT
+5 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP PRIMARY CARE CLINICS"
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,8)=0
SET $PIECE(^(0),U,9)=DT
SET $PIECE(^(0),U,12)=172
SET $PIECE(^(0),U,13)=0
SET $PIECE(^(0),U,15)=40.7
SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
+6 DO ^XBFMK
KILL DIADD,DLAYGO
SET BGPTEXT="CLINICS"
FOR BGPX=1:1:6
SET X=$PIECE($TEXT(@BGPTEXT+BGPX),";;",2)
SET Y=$ORDER(^DIC(40.7,"C",X,0))
IF Y
Begin DoDot:1
+7 SET ^ATXAX(BGPTX,21,BGPX,0)=+Y
SET $PIECE(^ATXAX(BGPTX,21,0),U,3)=BGPX
SET $PIECE(^(0),U,4)=BGPX
SET ^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
+8 QUIT
End DoDot:1
+9 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+10 QUIT
+11 ;
PRVTAX ;EP
+1 SET ATXFLG=1
+2 WRITE !,"Creating Prescribing provider taxonomy..."
+3 SET BGPDA=0
SET BGPDA=$ORDER(^ATXAX("B","BGP PRESCRIBING PROVIDER CLASS",BGPDA))
IF BGPDA
SET DA=BGPDA
SET DIK="^ATXAX("
DO ^DIK
KILL DA,DIK
+4 SET X="BGP PRESCRIBING PROVIDER CLASS"
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING BGP PRESCRIBING PROVIDER CLASS TAX"
QUIT
+6 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP PRESCRIBING PROVIDER CLASS"
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,8)=0
SET $PIECE(^(0),U,9)=DT
SET $PIECE(^(0),U,12)=210
SET $PIECE(^(0),U,13)=0
SET $PIECE(^(0),U,15)=7
SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
+7 DO ^XBFMK
KILL DIADD,DLAYGO
SET BGPTEXT="PREPROV"
FOR BGPX=1:1:43
SET X=$PIECE($TEXT(@BGPTEXT+BGPX),";;",2)
SET Y=$ORDER(^DIC(7,"D",X,0))
IF Y
Begin DoDot:1
+8 SET ^ATXAX(BGPTX,21,BGPX,0)=+Y
SET $PIECE(^ATXAX(BGPTX,21,0),U,3)=BGPX
SET $PIECE(^(0),U,4)=BGPX
SET ^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
+9 QUIT
End DoDot:1
+10 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+11 QUIT
+12 ;
SYSCHEMO ;
+1 SET BGPTX=$ORDER(^ATXAX("B","BGP CMS SYSTEMIC CHEMO MEDS",0))
+2 IF 'BGPTX
QUIT
+3 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BGPTX,21,A))
IF A'=+A
QUIT
SET B=A
+4 SET BGPC=B
+5 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
+6 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
Begin DoDot:1
+7 SET C=$PIECE($GET(^PSDRUG(J,0)),U,2)
+8 IF C["AN"
Begin DoDot:2
+9 IF $DATA(^ATXAX(BGPTX,21,"B",J))
QUIT
+10 SET BGPC=BGPC+1
SET ^ATXAX(BGPTX,21,BGPC,0)=J_U_J
+11 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+15 QUIT
IMMUNO ;
+1 SET BGPTX=$ORDER(^ATXAX("B","BGP CMS IMMUNOSUPPRESSIVE MEDS",0))
+2 IF 'BGPTX
QUIT
+3 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BGPTX,21,A))
IF A'=+A
QUIT
SET B=A
+4 SET BGPC=B
+5 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
+6 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
Begin DoDot:1
+7 SET C=$PIECE($GET(^PSDRUG(J,0)),U,2)
+8 IF C="IM600"!(C="MS190")!(C="MS109"&($$UP^XLFSTR($PIECE(^PSDRUG(J,0),U))'["HYALURONATE"))
Begin DoDot:2
+9 IF $DATA(^ATXAX(BGPTX,21,"B",J))
QUIT
+10 SET BGPC=BGPC+1
SET ^ATXAX(BGPTX,21,BGPC,0)=J_U_J
+11 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+15 QUIT
SMOKING ;
+1 SET BGPTX=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
+2 IF 'BGPTX
QUIT
+3 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BGPTX,21,A))
IF A'=+A
QUIT
SET B=A
+4 SET BGPC=B
+5 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B
+6 SET J=0
FOR
SET J=$ORDER(^PSDRUG(J))
IF J'=+J
QUIT
Begin DoDot:1
+7 SET C=$PIECE($GET(^PSDRUG(J,0)),U,1)
+8 IF C["NICOTINE PATCH"!(C["NICOTINE POLACRILEX")!(C["NICOTINE INHALER")!(C["NICOTINE NASAL SPRAY")
Begin DoDot:2
+9 IF $DATA(^ATXAX(BGPTX,21,"B",J))
QUIT
+10 SET BGPC=BGPC+1
SET ^ATXAX(BGPTX,21,BGPC,0)=J_U_J
+11 SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_BGPC_U_BGPC
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+15 QUIT
MHTAX ;EP
+1 SET ATXFLG=1
+2 WRITE !,"Creating Mental Health provider taxonomy..."
+3 SET BGPDA=0
SET BGPDA=$ORDER(^ATXAX("B","BGP MENTAL HEALTH PROV CLASS",BGPDA))
IF BGPDA
SET DA=BGPDA
SET DIK="^ATXAX("
DO ^DIK
KILL DA,DIK
+4 SET X="BGP MENTAL HEALTH PROV CLASS"
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DA,DIADD,DLAYGO,I
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING BGP MENTAL HEALTH PROV CLASS TAX"
QUIT
+6 SET BGPTX=+Y
SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP MENTAL HEALTH PROV CLASS"
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,8)=0
SET $PIECE(^(0),U,9)=DT
SET $PIECE(^(0),U,12)=210
SET $PIECE(^(0),U,13)=0
SET $PIECE(^(0),U,15)=7
SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"
+7 DO ^XBFMK
KILL DIADD,DLAYGO
SET BGPTEXT="MHPROV"
FOR BGPX=1:1:14
SET X=$PIECE($TEXT(@BGPTEXT+BGPX),";;",2)
SET Y=$ORDER(^DIC(7,"D",X,0))
IF Y
Begin DoDot:1
+8 SET ^ATXAX(BGPTX,21,BGPX,0)=+Y
SET $PIECE(^ATXAX(BGPTX,21,0),U,3)=BGPX
SET $PIECE(^(0),U,4)=BGPX
SET ^ATXAX(BGPTX,21,"AA",+Y,+Y)=""
+9 QUIT
End DoDot:1
+10 SET DA=BGPTX
SET DIK="^ATXAX("
DO IX1^DIK
+11 QUIT
+12 ;
MHPROV ;
+1 ;;06
+2 ;;12
+3 ;;19
+4 ;;48
+5 ;;49
+6 ;;50
+7 ;;62
+8 ;;63
+9 ;;81
+10 ;;92
+11 ;;93
+12 ;;94
+13 ;;95
+14 ;;96
+15 ;;
CLINICS ;
+1 ;;01
+2 ;;06
+3 ;;13
+4 ;;20
+5 ;;24
+6 ;;28
+7 ;;
PRVS ;
+1 ;;00
+2 ;;11
+3 ;;16
+4 ;;17
+5 ;;18
+6 ;;21
+7 ;;25
+8 ;;33
+9 ;;41
+10 ;;44
+11 ;;45
+12 ;;49
+13 ;;64
+14 ;;68
+15 ;;69
+16 ;;70
+17 ;;71
+18 ;;72
+19 ;;73
+20 ;;74
+21 ;;75
+22 ;;76
+23 ;;77
+24 ;;78
+25 ;;79
+26 ;;80
+27 ;;81
+28 ;;82
+29 ;;83
+30 ;;84
+31 ;;85
+32 ;;86
+33 ;;A1
+34 ;;
PREPROV ;;
+1 ;;00
+2 ;;08
+3 ;;11
+4 ;;16
+5 ;;17
+6 ;;18
+7 ;;21
+8 ;;24
+9 ;;25
+10 ;;30
+11 ;;33
+12 ;;41
+13 ;;44
+14 ;;45
+15 ;;47
+16 ;;49
+17 ;;64
+18 ;;67
+19 ;;68
+20 ;;70
+21 ;;71
+22 ;;72
+23 ;;73
+24 ;;74
+25 ;;75
+26 ;;76
+27 ;;77
+28 ;;78
+29 ;;79
+30 ;;80
+31 ;;81
+32 ;;82
+33 ;;83
+34 ;;85
+35 ;;86
+36 ;;A1
+37 ;;A9
+38 ;;B1
+39 ;;B2
+40 ;;B3
+41 ;;B4
+42 ;;B5
+43 ;;B6
+44 ;;
+45 ;
