BGPPOST.m

BGPPOST ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;

 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 ;

 ;

 ;SEND OUT BGP TAXONOMIES

 ; 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("AUM*5.1*8") D SORRY(2)

 I '$$INSTALLD("ATX*5.1*8") D SORRY(2)

 I '$$INSTALLD("APCL*3.0*17") D SORRY(2)

 I '$$INSTALLD("AUPN*99.1*15") D SORRY(2)

 Q

 ;

PRE ;EP

 D PRE^BGPPOST1

 Q

POST ;EP - called from kids build

 S DA=$O(^BMXADO("B","BGP 06 HEDIS INDICATORS",0))

 I 'DA D

 . D ^XBFMK

 . S X="BGP 06 HEDIS INDICATORS"

 . S DIC="^BMXADO(",DIC(0)="L",DIADD=1,DLAYGO=90093.99

 . K DD,D0,DO

 . S DIC("DR")=".02///90375.01"

 . D FILE^DICN

 . I Y=-1 W !!,"Creating schema failed!! " Q

 . S Y=+Y

 . S ^BMXADO(Y,1,0)="^90093.991^1^1"

 . S ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"

 . S ^BMXADO(Y,1,"B",.05,1)=""

 . S DA=Y,DIK="^BMXADO(" D IX1^DIK

 . Q

 S ATXFLG=1

 D ^BGP6AX ;taxonomies

 D ^BGP6BX ;taxonomies

 D ^BGP6EX

 D ^BGP6FX

 D ^BGP6HX

 D ^BGP6GX

 D ^BGP6JX

MT ;MOVE TEMPORARY TAXONOMIES TO ATXAX

 S ATXFLG=1

 S BGPX=0 F  S BGPX=$O(^BGPTAXTM(BGPX)) Q:BGPX'=+BGPX  D

 .S BGPN=$P(^BGPTAXTM(BGPX,0),U)

 .S BGPY=$O(^ATXAX("B",BGPN,0))

 .I BGPY S DA=BGPY,DIK="^ATXAX(" D ^DIK

 .S X=BGPN,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 .I Y=-1 W !!,"creating taxonomy failed....",BGPN Q

 .S BGPZ=+Y

 .M ^ATXAX(BGPZ)=^BGPTAXTM(BGPX)

 .S DA=BGPZ,DIK="^ATXAX(" D IX1^DIK

 .Q

 D PRVTAX^BGPPOST1

 D CLTAX^BGPPOST1

 D MHTAX^BGPPOST1

 D LAB^BGPPOST1

 D DRUGS^BGPPOST1

 K ATXFLG

 S X=0 F  S X=$O(^ATXAX(X)) Q:X'=+X  I $E($P($G(^ATXAX(X,0)),U,1),1,3)["BGP" S $P(^ATXAX(X,0),U,4)="n"

 S X=0 F  S X=$O(^ATXLAB(X)) Q:X'=+X  I $E($P($G(^ATXLAB(X,0)),U,1),1,3)["BGP" S $P(^ATXLAB(X,0),U,4)="n"

 D EN^XBVK("BGP")

 D SEC

 D SETTAX

 D SETTAXL

 D SETTAXF

 ;move ado schemas to bmx ado schema

 S BGPX=0 F  S BGPX=$O(^BGPBMX(BGPX)) Q:BGPX'=+BGPX  D

 .S BGPN=$P(^BGPBMX(BGPX,0),U)

 .Q:$D(^BMXADO("B",BGPN))  ;already in file

 .S G=0,X=0 F  S X=$O(^BMXADO(X)) Q:X'=+X!(G)  I $P(^BMXADO(X,0),U)=BGPN S G=1

 .Q:G

 .S X=BGPN,DIC="^BMXADO(",DIADD=1,DLAYGO=90093.99,DIC(0)="AEMQL" K DO,D0,DD D FILE^DICN

 .I Y=-1 W !!,"Failure to add BMX ADO Schema ",BGPN K DIADD,DLAYGO,DIC,DA Q

 .S BGPDA=+Y

 .K DIADD,DLAYGO,DIC,DA D ^XBFMK

 .M ^BMXADO(BGPDA)=^BGPBMX(BGPX)

 .S DA=BGPDA,DIK="^BMXADO(" D IX1^DIK K DA,DIK

 Q

 ;

SETTAXF ;

 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

SETTAX ;

 Q:'$D(^DD(9002226,4101,0))  ;taxonomy patch not yet installed

 S BGPTFI="" F  S BGPTFI=$O(^BGPTAXV("B",BGPTFI)) Q:BGPTFI=""  D

 .S BGPTFIEN=$O(^BGPTAXV("B",BGPTFI,0))

 .I 'BGPTFIEN Q

 .Q:'$D(^BGPTAXV(BGPTFIEN))

 .Q:$P(^BGPTAXV(BGPTFIEN,0),U,2)="L"

 .S BGPTDA=$O(^ATXAX("B",BGPTFI,0))

 .Q:'BGPTDA  ;did not find taxonomy

 .S BGPE=$P(^BGPTAXV(BGPTFIEN,0),U,4)

 .I BGPE=0 S $P(^ATXAX(BGPTDA,0),U,22)=1

 .I BGPE=1 S $P(^ATXAX(BGPTDA,0),U,22)=0

 .S $P(^ATXAX(BGPTDA,0),U,4)="n"

 .;set packages in multiple

 .K DIC,DA,DR

 .S BGPPI=$O(^DIC(9.4,"C","BGP",0))

 .Q:BGPPI=""  ;NO PACKAGE

 .S X="`"_BGPPI,DIC="^ATXAX("_BGPTDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=BGPTDA

 .D ^DIC

 .I Y=-1 W !,"updating package multiple for ",BGPPP," entry ",$P(^ATXAX(BGPDA,0),U)," failed"

 .K DIC,DA,Y,X

 .Q

 S BGPTEXT="TAX" F BGPX=1:1 S BGPDATA=$P($T(@BGPTEXT+BGPX),";;",2) Q:BGPDATA=""  D

 .S BGPDA=$O(^ATXAX("B",$P(BGPDATA,"|"),0))

 .Q:BGPDA=""

 .S $P(^ATXAX(BGPDA,0),U,4)="n" W !,$P(BGPDATA,"|")  ;SET NO DELETE

 .S $P(^ATXAX(BGPDA,0),U,22)=$P(BGPDATA,"|",2) ;set read only

 .;set packages in multiple

 .K DIC,DA,DR

 .S BGPP=$P(BGPDATA,"|",3)

 .F BGPN=1:1 S BGPPP=$P(BGPP,"*",BGPN) Q:BGPPP=""  D

 ..S BGPPI=$O(^DIC(9.4,"C",BGPPP,0))

 ..Q:BGPPI=""  ;NO PACKAGE

 ..S X="`"_BGPPI,DIC="^ATXAX("_BGPDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=BGPDA

 ..D ^DIC

 ..I Y=-1 W !,"updating package multiple for ",BGPPP," entry ",$P(^ATXAX(BGPDA,0),U)," failed"

 ..K DIC,DA,Y,X

 .Q

 Q

SETTAXL ;

 Q:'$D(^DD(9002228,4101,0))  ;taxonomy patch not yet installed

 S BGPTEXT="LABTAX" F BGPX=1:1 S BGPDATA=$P($T(@BGPTEXT+BGPX),";;",2) Q:BGPDATA=""  D

 .S BGPDA=$O(^ATXLAB("B",$P(BGPDATA,"|"),0))

 .Q:BGPDA=""

 .S $P(^ATXLAB(BGPDA,0),U,4)="n" W !,$P(BGPDATA,"|")  ;SET NO DELETE

 .S $P(^ATXLAB(BGPDA,0),U,22)=$P(BGPDATA,"|",2) ;set read only

 .;set packages in multiple

 .K DIC,DA,DR

 .S BGPP=$P(BGPDATA,"|",3)

 .F BGPN=1:1 S BGPPP=$P(BGPP,"*",BGPN) Q:BGPPP=""  D

 ..S BGPPI=$O(^DIC(9.4,"C",BGPPP,0))

 ..Q:BGPPI=""  ;NO PACKAGE

 ..S X="`"_BGPPI,DIC="^ATXLAB("_BGPDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=BGPDA

 ..D ^DIC

 ..I Y=-1 W !,"updating package multiple for ",BGPPP," entry ",$P(^ATXLAB(BGPDA,0),U)," failed"

 ..K DIC,DA,Y,X

 .Q

 Q

INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where

 ; BGPSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 ;

 NEW BGPY,DIC,X,Y

 S X=$P(BGPSTAL,"*",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(BGPSTAL,"*",2)

 D ^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",""PAH"",",X=$P(BGPSTAL,"*",3)

 D ^DIC

 S BGPY=Y

 D IMES

 Q $S(BGPY<1:0,1:1)

IMES ;

 D MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" 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

LABTAX ;

 ;;BGP CD4 TAX|0|BGP

 ;;BGP CHLAMYDIA TESTS TAX|0|BGP

 ;;BGP GPRA ESTIMATED GFR TAX|0|BGP

 ;;BGP GPRA FOB TESTS|0|BGP

 ;;BGP HIV TEST TAX|0|BGP

 ;;BGP HIV VIRAL LOAD TAX|0|BGP

 ;;BGP PAP SMEAR TAX|0|BGP

 ;;DM AUDIT A/C RATIO TAX|0|APCL*BDM*BGP

 ;;DM AUDIT CHOLESTEROL TAX|0|APCL*BDM*BGP

 ;;DM AUDIT CREATININE TAX|0|APCL*BDM*BGP

 ;;DM AUDIT HDL TAX|0|APCL*BDM*BGP

 ;;DM AUDIT HGB A1C TAX|0|APCL*BDM*BGP

 ;;DM AUDIT LDL CHOLESTEROL TAX|0|APCL*BDM*BGP

 ;;DM AUDIT LIPID PROFILE TAX|0|APCL*BDM*BGP

 ;;DM AUDIT MICROALBUMINURIA TAX|0|APCL*BDM*BGP

 ;;DM AUDIT TRIGLYCERIDE TAX|0|APCL*BDM*BGP

 ;;DM AUDIT URINE PROTEIN TAX|0|APCL*BDM*BGP

 ;;DM AUDIT FASTING GLUCOSE TESTS|0|APCL*BDM*BGP

 ;;BGP CMS ABG TESTS|0|BGP

 ;;BGP CBC TESTS|0|BGP

 ;;DM AUDIT URINALYSIS TAX|0|BGP*APCL*BDM

 ;;DM AUDIT ALT TAX|0|BGP

 ;;DM AUDIT AST TAX|0|BGP*APCL*BDM

 ;;BGP GROUP A STREP TESTS|0|BGP

 ;;BGP LIVER FUNCTION TESTS|0|BGP

 ;;BGP URINE GLUCOSE|0|BGP

 ;;BGP POTASSIUM TESTS|0|BGP

 ;;BGP CMS BLOOD CULTURE|0|BGP

 ;;

TAX ; 

 ;;SURVEILLANCE DIABETES|1|BGP

 ;;SURVEILLANCE HYPERTENSION|1|BGP

 ;;BGP ALCOHOL DXS|1|BGP

 ;;BGP ASTHMA DXS|1|BGP

 ;;BGP BE CPTS|1|BGP

 ;;BGP CD4 LOINC CODES|1|BGP

 ;;BGP CHLAMYDIA CPTS|1|BGP

 ;;BGP CHLAMYDIA LOINC CODES|1|BGP

 ;;BGP COLO CPTS|1|BGP

 ;;BGP COLORECTAL CANCER DXS|1|BGP

 ;;BGP CPT FLU|1|BGP

 ;;BGP CPT HIV TESTS|1|BGP

 ;;BGP CPT MAMMOGRAM|1|BGP

 ;;BGP CPT MAMMOGRAM HEDIS|1|BGP

 ;;BGP CPT PAP|1|BGP

 ;;BGP CREATININE CPTS|1|BGP

 ;;BGP CREATININE LOINC CODES|1|BGP

 ;;BGP DEPRESSIVE DISORDERS|1|BGP

 ;;BGP DIPHTHERIA EVIDENCE|1|BGP

 ;;BGP DV DXS|1|BGP

 ;;BGP FOBT LOINC CODES|1|BGP

 ;;BGP GPRA EX EDUC TOPICS|1|BGP

 ;;BGP GPRA PREGNANCY DIAGNOSES|1|BGP

 ;;BGP GPRA SMOKING DXS|1|BGP

 ;;BGP HDL LOINC CODES|1|BGP

 ;;BGP HGBA1C LOINC CODES|1|BGP

 ;;BGP HIB EVIDENCE|1|BGP

 ;;BGP HIV TEST LOINC CODES|1|BGP

 ;;BGP HIV/AIDS DXS|1|BGP

 ;;BGP HYPERTENSION DXS|1|BGP

 ;;BGP HYPOTENSION DXS|1|BGP

 ;;BGP HYSTERECTOMY CPTS|1|BGP

 ;;BGP ISCHEMIC HEART DXS|1|BGP

 ;;BGP LDL LOINC CODES|1|BGP

 ;;BGP LIPID PROFILE LOINC CODES|1|BGP

 ;;BGP UNI MASTECTOMY PROCEDURES|1|BGP

 ;;BGP MEASLES EVIDENCE|1|BGP

 ;;BGP MICROALBUM LOINC CODES|1|BGP

 ;;BGP MISCARRIAGE/ABORTION DXS|1|BGP

 ;;BGP MMR CONTRAINDICATIONS|1|BGP

 ;;BGP MUMPS EVIDENCE|1|BGP

 ;;BGP NEPHROPATHY CPTS|1|BGP

 ;;BGP NEPHROPATHY DXS|1|BGP

 ;;BGP NEPHROPATHY PROCEDURES|1|BGP

 ;;BGP OPV CONTRAINDICATIONS|1|BGP

 ;;BGP OPV EVID DISEASE|1|BGP

 ;;BGP PAP LOINC CODES|1|BGP

 ;;BGP PERUTSSIS EVIDENCE|1|BGP

 ;;BGP PCR LOINC CODES|1|BGP

 ;;BGP PRIMARY CARE CLINICS|1|BGP

 ;;BGP PRIMARY PROVIDER DISC|1|BGP

 ;;BGP RECTAL PROCEDURE CODES|1|BGP

 ;;BGP RUBELLA EVIDENCE|1|BGP

 ;;BGP SIG CPTS|1|BGP

 ;;BGP TOTAL CHOLESTEROL LOINC|1|BGP

 ;;BGP TRIGLYCERIDE LOINC CODES|1|BGP

 ;;BGP URINE PROTEIN LOINC CODES|1|BGP

 ;;BGP VARICELLA CONTRA|1|BGP

 ;;BGP VARICELLA EVIDENCE|1|BGP

 ;;BGP VIRAL LOAD LOINC CODES|1|BGP

 ;;BGP CMS AMI DXS|1|BGP

 ;;BGP AMI DXS (HEDIS)|1|BGP

 ;;BGP AMI IND 30

 ;;BGP CMS PNEUMONIA DXS|1|BGP

 ;;BGP CMS SEPTI/RESP FAIL DXS|1|BGP

 ;;BGP CMS HEART FAILURE DXS|1|BGP

 ;;BGP CMS LVSD DXS|1|BGP

 ;;BGP CMS EJECTION FRACTION CPTS|1|BGP

 ;;BGP CMS EJECTION FRACTION PROC|1|BGP

 ;;BGP CMS CIRCULATORY SHOCK DXS|1|BGP

 ;;BGP CMS 2/3 HEART BLOCK DXS|1|BGP

 ;;BGP CMS BRADYCARDIA DXS|1|BGP

 ;;BGP ASA ALLERGY 995.0-995.3|1|BGP

 ;;BGP CMS ABG CPTS|1|BGP

 ;;BGP CMS AORTIC STENOSIS DXS|1|BGP

 ;;BGP CMS WARFARIN MEDS|0|BGP

 ;;DM AUDIT ASPIRIN DRUGS|0|BGP

 ;;DM AUDIT ANTI-PLATELET DRUGS|0|BGP

 ;;BGP CMS ANTIBIOTIC MEDS|0|BGP

 ;;BGP CMS BETA BLOCKER MEDS|0|BGP

 ;;BGP CMS ACEI MEDS|0|BGP

 ;;BGP CMS ARB MEDS|0|BGP

 ;;BGP CMS ANTI-PLATELET CLASS|1|BGP

 ;;BGP CMS ACEI MEDS CLASS|1|BGP

 ;;BGP CMS BETA BLOCKER CLASS|1|BGP

 ;;BGP CMS ARB MEDS CLASS|1|BGP

 ;;BGP CMS ANTIBIOTIC MEDS CLASS|1|BGP

 ;;BGP CMS BETA BLOCKER NDC|0|BGP

 ;;BGP HEDIS OSTEOPOROSIS NDC|0|BGP

 ;;BGP HEDIS OSTEOPOROSIS DRUGS|0|BGP

 ;;BGP HEDIS ANTIDEPRESSANT MEDS|0|BGP

 ;;BGP HEDIS ANTIDEPRESSANT NDC|1|BGP

 ;;BGP MOOD DISORDERS|1|BGP

 ;;BGP MAJOR DEPRESSIVE DISORDERS|1|BGP

 ;;BGP MAJOR DEPRESSION PRIOR|1|BGP

 ;;BGP ACUTE MENTAL HEALTH|1|BGP

 ;;BGP SUBSTANCE ABUSE|1|BGP

 ;;BGP POISONINGS SUBSTANCE ABUSE|1|BGP

 ;;BGP PRESCRIBING PROVIDER CLASS|1|BGP

 ;;BGP MENTAL HEALTH PROV CLASS|1|BGP

 ;;BGP OPT MH VISIT POVS|1|BGP

 ;;BGP OPT MH VISIT CPTS MH|1|BGP

 ;;BGP MH OPT VISIT CPT NMH 1|1|BGP

 ;;BGP MH OPT VISIT CPT NMH 3|1|BGP

 ;;BGP OSTEOPOROSIS DXS|1|BGP

 ;;BGP OSTEO SCREEN CPTS|1|BGP

 ;;BGP MAJOR DEPRESSION (ADM)|1|BGP

 ;;BGP ASTHMA CONTROLLER NDC|1|BGP

 ;;BGP ASTHMA CONTROLLERS|0|BGP

 ;;BGP ASTHMA INHALED STEROID NDC|1|BGP

 ;;BGP ASTHMA INHALED STEROIDS|0|BGP

 ;;BGP ASTHMA LEUKOTRIENE NDC|1|BGP

 ;;BGP ASTHMA LEUKOTRIENE|0|BGP

 ;;BGP BMD PROCEDURES|1|BGP

 ;;BGP BMD CPTS|1|BGP

 ;;BGP CABG CPTS|1|BGP

 ;;BGP CABG PROCS|1|BGP

 ;;BGP COPD DXS|1|BGP

 ;;BGP COPD DXS BB CONT|1|BGP

 ;;BGP EMPHYSEMA DXS|1|BGP

 ;;BGP ESRD DXS|1|BGP

 ;;BGP FRACTURE CPTS|1|BGP

 ;;BGP FRACTURE DXS|1|BGP

 ;;BGP FRACTURE PROCEDURES|1|BGP

 ;;BGP HEDIS RETINAL SCREENING|1|BGP

 ;;BGP HEDIS RETINAL SCRN PROCS|1|BGP

 ;;BGP HEP EVIDENCE|1|BGP

 ;;BGP MASTECTOMY PROCEDURES|1|BGP

 ;;BGP PTCA CPTS|1|BGP

 ;;BGP PTCA PROCS|1|BGP

 ;;BGP SINUS BRADYCARDIA DXS|1|BGP

 ;;DM AUDIT FASTING GLUC LOINC|1|BGP

 ;;BGP OSTEOARTHRITIS DXS|1|BGP

 ;;BGP RA OA NSAID MEDS|0|BGP

 ;;BGP RA OA NSAID NDC|1|BGP

 ;;BGP OA GLUCOCORTICOIDS MEDS|0|BGP

 ;;BGP OA GLUCOCORTICOIDS CLASS|1|BGP

 ;;BGP CBC CPT|1|BGP

 ;;BGP CBC LOINC|1|BGP

 ;;DM AUDIT URINALYSIS LOINC|1|BGP*APCL*BDM

 ;;BGP ALT LOINC|1|BGP

 ;;BGP ALT CPT|1|BGP

 ;;BGP AST CPT|1|BGP

 ;;BGP AST LOINC|1|BGP

 ;;BGP BMD DXS|1|BGP

 ;;BGP IVD DXS|1|BGP

 ;;BGP TOBACCO DXS|1|BGP

 ;;BGP TOTAL CHOLECTOMY CPTS|1|BGP

 ;;BGP TOTAL CHOLECTOMY PROCS|1|BGP

 ;;BGP HYSTERECTOMY PROCEDURES|1|BGP

 ;;BGP PHARYNGITIS DXS|1|BGP

 ;;BGP HEDIS ANTIBIOTICS NDC|1|BGP

 ;;BGP HEDIS ANTIBIOTICS MEDS|0|BGP

 ;;BGP GROUP A STREP CPT|1|BGP

 ;;BGP GROUP A STREP LOINC|1|BGP

 ;;BGP HEDIS ASTHMA LEUK MEDS|0|BGP

 ;;BGP HEDIS ASTHMA LEUK NDC|1|BGP

 ;;BGP CD4 CPTS|1|BGP

 ;;BGP URI DXS|1|BGP

 ;;BGP HEDIS ASTHMA MEDS|0|BGP

 ;;BGP HEDIS ASTHMA NDC|1|BGP

 ;;BGP HEDIS PRIMARY ASTHMA MEDS|0|BGP

 ;;BGP HEDIS PRIMARY ASTHMA NDC|1|BGP

 ;;BGP HEDIS ASTHMA INHALED MEDS|0|BGP

 ;;BGP HEDIS ASTHMA INHALED NDC|1|BGP

 ;;BGP LIVER FUNCTION LOINC|1|BGP

 ;;BGP HEDIS BETA BLOCKER MEDS|0|BGP

 ;;BGP HEDIS BETA BLOCKER NDC|1|BGP

 ;;BGP RA IM GOLD MEDS|0|BGP

 ;;BGP RA IM GOLD NDC|1|BGP

 ;;BGP RA ORAL GOLD MEDS|0|BGP

 ;;BGP RA AZATHIOPRINE MEDS|0|BGP

 ;;BGP RA AZATHIOPRINE NDC|1|BGP

 ;;BGP RA LEFLUNOMIDE MEDS|0|BGP

 ;;BGP RA LEFLUNOMIDE NDC|1|BGP

 ;;BGP RA METHOTREXATE MEDS|0|BGP

 ;;BGP RA METHOTREXATE NDC|1|BGP

 ;;BGP RA CYCLOSPORINE MEDS|0|BGP

 ;;BGP RA CYCLOSPORINE NDC|1|BGP

 ;;BGP RA MYCOPHENOLATE MEDS|0|BGP

 ;;BGP RA MYCOPHENOLATE NDC|1|BGP

 ;;BGP RA PENICILLAMINE MEDS|0|BGP

 ;;BGP RA PENICILLAMINE NDC|1|BGP

 ;;BGP RA SULFASALAZINE MEDS|0|BGP

 ;;BGP RA SULFASALAZINE NDC|1|BGP

 ;;BGP ESRD CPTS|1|BGP

 ;;BGP URINE GLUCOSE LOINC|1|BGP

 ;;BGP POTASSIUM LOINC|1|BGP

 ;;BGP ST ELEVATION DX|1|BGP

 ;;BGP LBBB ON ECG CPT|1|BGP

 ;;BGP LBBB ON ECG PROC|1|BGP

 ;;BGP THROMBOLYTIC AGENT CLASS|1|BGP

 ;;BGP CMS THROMBOLYTIC MEDS|0|BGP

 ;;BGP LVAD/HEART TRANSPLANT PROC|1|BGP

 ;;BGP CMS ABG LOINC|1|BGP

 ;;BGP BLOOD CULTURE LOINC|1|BGP

 ;;

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

 ;;

SEC ;set security on selected dd's

LP ;EP - loop through file entries

 F I=1:1 D  Q:BGPTXT["end"

 .S BGPTXT=$T(TXT+I)

 .Q:BGPTXT["end"

 .F J=2:1:4 S BGP(J)=$P(BGPTXT,";;",J)

 .S BGP(3)=""""_BGP(3)_""""

 .S BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"

 .S @BGPREF=BGP(4)

 Q

TXT ;file entries start here

 ;;90244.01;;AUDIT;;@

 ;;90244.01;;DD;;@

 ;;90244.01;;DEL;;@

 ;;90244.01;;LAYGO;;@

 ;;90244.01;;RD;;M

 ;;90244.01;;WR;;@

 ;;90244.02;;AUDIT;;@

 ;;90244.02;;DD;;@

 ;;90244.02;;DEL;;@

 ;;90244.02;;LAYGO;;@

 ;;90244.02;;RD;;M

 ;;90244.02;;WR;;@

 ;;90371.04;;AUDIT;;@

 ;;90371.04;;DD;;@

 ;;90371.04;;DEL;;@

 ;;90371.04;;LAYGO;;M

 ;;90371.04;;RD;;M

 ;;90371.04;;WR;;M

 ;;90372.03;;AUDIT;;@

 ;;90372.03;;DD;;@

 ;;90372.03;;DEL;;M

 ;;90372.03;;LAYGO;;M

 ;;90372.03;;RD;;M

 ;;90372.03;;WR;;M

 ;;90372.05;;AUDIT;;@

 ;;90372.05;;DD;;@

 ;;90372.05;;DEL;;M

 ;;90372.05;;LAYGO;;M

 ;;90372.05;;RD;;M

 ;;90372.05;;WR;;M

 ;;end

 Q

BGPPOST   ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;

 +1       ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 +2       ;

 +3       ;

 +4       ;SEND OUT BGP TAXONOMIES

 +5       ; The following line prevents the "Disable Options..." and "Move

 +6       ; Routines..." questions from being asked during the install.

 +7        IF $GET(XPDENV)=1

               SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +8        FOR X="XPO1","XPZ1","XPZ2","XPI1"

               SET XPDDIQ(X)=0

 +9       ;I '$$INSTALLD("AUM*5.1*8") D SORRY(2)

 +10       IF '$$INSTALLD("ATX*5.1*8")

               DO SORRY(2)

 +11       IF '$$INSTALLD("APCL*3.0*17")

               DO SORRY(2)

 +12       IF '$$INSTALLD("AUPN*99.1*15")

               DO SORRY(2)

 +13       QUIT 

 +14      ;

PRE       ;EP

 +1        DO PRE^BGPPOST1

 +2        QUIT 

POST      ;EP - called from kids build

 +1        SET DA=$ORDER(^BMXADO("B","BGP 06 HEDIS INDICATORS",0))

 +2        IF 'DA

               Begin DoDot:1

 +3                DO ^XBFMK

 +4                SET X="BGP 06 HEDIS INDICATORS"

 +5                SET DIC="^BMXADO("

                   SET DIC(0)="L"

                   SET DIADD=1

                   SET DLAYGO=90093.99

 +6                KILL DD,D0,DO

 +7                SET DIC("DR")=".02///90375.01"

 +8                DO FILE^DICN

 +9                IF Y=-1

                       WRITE !!,"Creating schema failed!! "

                       QUIT 

 +10               SET Y=+Y

 +11               SET ^BMXADO(Y,1,0)="^90093.991^1^1"

 +12               SET ^BMXADO(Y,1,1,0)=".05^T^80^Indicator"

 +13               SET ^BMXADO(Y,1,"B",.05,1)=""

 +14               SET DA=Y

                   SET DIK="^BMXADO("

                   DO IX1^DIK

 +15               QUIT 

               End DoDot:1

 +16       SET ATXFLG=1

 +17      ;taxonomies

           DO ^BGP6AX

 +18      ;taxonomies

           DO ^BGP6BX

 +19       DO ^BGP6EX

 +20       DO ^BGP6FX

 +21       DO ^BGP6HX

 +22       DO ^BGP6GX

 +23       DO ^BGP6JX

MT        ;MOVE TEMPORARY TAXONOMIES TO ATXAX

 +1        SET ATXFLG=1

 +2        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPTAXTM(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +3                SET BGPN=$PIECE(^BGPTAXTM(BGPX,0),U)

 +4                SET BGPY=$ORDER(^ATXAX("B",BGPN,0))

 +5                IF BGPY

                       SET DA=BGPY

                       SET DIK="^ATXAX("

                       DO ^DIK

 +6                SET X=BGPN

                   SET DIC="^ATXAX("

                   SET DIC(0)="L"

                   SET DIADD=1

                   SET DLAYGO=9002226

                   DO ^DIC

                   KILL DIC,DA,DIADD,DLAYGO,I

 +7                IF Y=-1

                       WRITE !!,"creating taxonomy failed....",BGPN

                       QUIT 

 +8                SET BGPZ=+Y

 +9                MERGE ^ATXAX(BGPZ)=^BGPTAXTM(BGPX)

 +10               SET DA=BGPZ

                   SET DIK="^ATXAX("

                   DO IX1^DIK

 +11               QUIT 

               End DoDot:1

 +12       DO PRVTAX^BGPPOST1

 +13       DO CLTAX^BGPPOST1

 +14       DO MHTAX^BGPPOST1

 +15       DO LAB^BGPPOST1

 +16       DO DRUGS^BGPPOST1

 +17       KILL ATXFLG

 +18       SET X=0

           FOR 

               SET X=$ORDER(^ATXAX(X))

               IF X'=+X

                   QUIT 

               IF $EXTRACT($PIECE($GET(^ATXAX(X,0)),U,1),1,3)["BGP"

                   SET $PIECE(^ATXAX(X,0),U,4)="n"

 +19       SET X=0

           FOR 

               SET X=$ORDER(^ATXLAB(X))

               IF X'=+X

                   QUIT 

               IF $EXTRACT($PIECE($GET(^ATXLAB(X,0)),U,1),1,3)["BGP"

                   SET $PIECE(^ATXLAB(X,0),U,4)="n"

 +20       DO EN^XBVK("BGP")

 +21       DO SEC

 +22       DO SETTAX

 +23       DO SETTAXL

 +24       DO SETTAXF

 +25      ;move ado schemas to bmx ado schema

 +26       SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPBMX(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +27               SET BGPN=$PIECE(^BGPBMX(BGPX,0),U)

 +28      ;already in file

                   IF $DATA(^BMXADO("B",BGPN))

                       QUIT 

 +29               SET G=0

                   SET X=0

                   FOR 

                       SET X=$ORDER(^BMXADO(X))

                       IF X'=+X!(G)

                           QUIT 

                       IF $PIECE(^BMXADO(X,0),U)=BGPN

                           SET G=1

 +30               IF G

                       QUIT 

 +31               SET X=BGPN

                   SET DIC="^BMXADO("

                   SET DIADD=1

                   SET DLAYGO=90093.99

                   SET DIC(0)="AEMQL"

                   KILL DO,D0,DD

                   DO FILE^DICN

 +32               IF Y=-1

                       WRITE !!,"Failure to add BMX ADO Schema ",BGPN

                       KILL DIADD,DLAYGO,DIC,DA

                       QUIT 

 +33               SET BGPDA=+Y

 +34               KILL DIADD,DLAYGO,DIC,DA

                   DO ^XBFMK

 +35               MERGE ^BMXADO(BGPDA)=^BGPBMX(BGPX)

 +36               SET DA=BGPDA

                   SET DIK="^BMXADO("

                   DO IX1^DIK

                   KILL DA,DIK

               End DoDot:1

 +37       QUIT 

 +38      ;

SETTAXF   ;

 +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 

SETTAX    ;

 +1       ;taxonomy patch not yet installed

           IF '$DATA(^DD(9002226,4101,0))

               QUIT 

 +2        SET BGPTFI=""

           FOR 

               SET BGPTFI=$ORDER(^BGPTAXV("B",BGPTFI))

               IF BGPTFI=""

                   QUIT 

               Begin DoDot:1

 +3                SET BGPTFIEN=$ORDER(^BGPTAXV("B",BGPTFI,0))

 +4                IF 'BGPTFIEN

                       QUIT 

 +5                IF '$DATA(^BGPTAXV(BGPTFIEN))

                       QUIT 

 +6                IF $PIECE(^BGPTAXV(BGPTFIEN,0),U,2)="L"

                       QUIT 

 +7                SET BGPTDA=$ORDER(^ATXAX("B",BGPTFI,0))

 +8       ;did not find taxonomy

                   IF 'BGPTDA

                       QUIT 

 +9                SET BGPE=$PIECE(^BGPTAXV(BGPTFIEN,0),U,4)

 +10               IF BGPE=0

                       SET $PIECE(^ATXAX(BGPTDA,0),U,22)=1

 +11               IF BGPE=1

                       SET $PIECE(^ATXAX(BGPTDA,0),U,22)=0

 +12               SET $PIECE(^ATXAX(BGPTDA,0),U,4)="n"

 +13      ;set packages in multiple

 +14               KILL DIC,DA,DR

 +15               SET BGPPI=$ORDER(^DIC(9.4,"C","BGP",0))

 +16      ;NO PACKAGE

                   IF BGPPI=""

                       QUIT 

 +17               SET X="`"_BGPPI

                   SET DIC="^ATXAX("_BGPTDA_",41,"

                   SET DIC(0)="L"

                   SET DIC("P")=$PIECE(^DD(9002226,4101,0),U,2)

                   SET DA(1)=BGPTDA

 +18               DO ^DIC

 +19               IF Y=-1

                       WRITE !,"updating package multiple for ",BGPPP," entry ",$PIECE(^ATXAX(BGPDA,0),U)," failed"

 +20               KILL DIC,DA,Y,X

 +21               QUIT 

               End DoDot:1

 +22       SET BGPTEXT="TAX"

           FOR BGPX=1:1

               SET BGPDATA=$PIECE($TEXT(@BGPTEXT+BGPX),";;",2)

               IF BGPDATA=""

                   QUIT 

               Begin DoDot:1

 +23               SET BGPDA=$ORDER(^ATXAX("B",$PIECE(BGPDATA,"|"),0))

 +24               IF BGPDA=""

                       QUIT 

 +25      ;SET NO DELETE

                   SET $PIECE(^ATXAX(BGPDA,0),U,4)="n"

                   WRITE !,$PIECE(BGPDATA,"|")

 +26      ;set read only

                   SET $PIECE(^ATXAX(BGPDA,0),U,22)=$PIECE(BGPDATA,"|",2)

 +27      ;set packages in multiple

 +28               KILL DIC,DA,DR

 +29               SET BGPP=$PIECE(BGPDATA,"|",3)

 +30               FOR BGPN=1:1

                       SET BGPPP=$PIECE(BGPP,"*",BGPN)

                       IF BGPPP=""

                           QUIT 

                       Begin DoDot:2

 +31                       SET BGPPI=$ORDER(^DIC(9.4,"C",BGPPP,0))

 +32      ;NO PACKAGE

                           IF BGPPI=""

                               QUIT 

 +33                       SET X="`"_BGPPI

                           SET DIC="^ATXAX("_BGPDA_",41,"

                           SET DIC(0)="L"

                           SET DIC("P")=$PIECE(^DD(9002226,4101,0),U,2)

                           SET DA(1)=BGPDA

 +34                       DO ^DIC

 +35                       IF Y=-1

                               WRITE !,"updating package multiple for ",BGPPP," entry ",$PIECE(^ATXAX(BGPDA,0),U)," failed"

 +36                       KILL DIC,DA,Y,X

                       End DoDot:2

 +37               QUIT 

               End DoDot:1

 +38       QUIT 

SETTAXL   ;

 +1       ;taxonomy patch not yet installed

           IF '$DATA(^DD(9002228,4101,0))

               QUIT 

 +2        SET BGPTEXT="LABTAX"

           FOR BGPX=1:1

               SET BGPDATA=$PIECE($TEXT(@BGPTEXT+BGPX),";;",2)

               IF BGPDATA=""

                   QUIT 

               Begin DoDot:1

 +3                SET BGPDA=$ORDER(^ATXLAB("B",$PIECE(BGPDATA,"|"),0))

 +4                IF BGPDA=""

                       QUIT 

 +5       ;SET NO DELETE

                   SET $PIECE(^ATXLAB(BGPDA,0),U,4)="n"

                   WRITE !,$PIECE(BGPDATA,"|")

 +6       ;set read only

                   SET $PIECE(^ATXLAB(BGPDA,0),U,22)=$PIECE(BGPDATA,"|",2)

 +7       ;set packages in multiple

 +8                KILL DIC,DA,DR

 +9                SET BGPP=$PIECE(BGPDATA,"|",3)

 +10               FOR BGPN=1:1

                       SET BGPPP=$PIECE(BGPP,"*",BGPN)

                       IF BGPPP=""

                           QUIT 

                       Begin DoDot:2

 +11                       SET BGPPI=$ORDER(^DIC(9.4,"C",BGPPP,0))

 +12      ;NO PACKAGE

                           IF BGPPI=""

                               QUIT 

 +13                       SET X="`"_BGPPI

                           SET DIC="^ATXLAB("_BGPDA_",41,"

                           SET DIC(0)="L"

                           SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)

                           SET DA(1)=BGPDA

 +14                       DO ^DIC

 +15                       IF Y=-1

                               WRITE !,"updating package multiple for ",BGPPP," entry ",$PIECE(^ATXLAB(BGPDA,0),U)," failed"

 +16                       KILL DIC,DA,Y,X

                       End DoDot:2

 +17               QUIT 

               End DoDot:1

 +18       QUIT 

INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where

 +1       ; BGPSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 +2       ;

 +3        NEW BGPY,DIC,X,Y

 +4        SET X=$PIECE(BGPSTAL,"*",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(BGPSTAL,"*",2)

 +9        DO ^DIC

 +10       IF Y<1

               DO IMES

               QUIT 0

 +11       SET DIC=DIC_+Y_",""PAH"","

           SET X=$PIECE(BGPSTAL,"*",3)

 +12       DO ^DIC

 +13       SET BGPY=Y

 +14       DO IMES

 +15       QUIT $SELECT(BGPY<1:0,1:1)

IMES      ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" 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 

LABTAX    ;

 +1       ;;BGP CD4 TAX|0|BGP

 +2       ;;BGP CHLAMYDIA TESTS TAX|0|BGP

 +3       ;;BGP GPRA ESTIMATED GFR TAX|0|BGP

 +4       ;;BGP GPRA FOB TESTS|0|BGP

 +5       ;;BGP HIV TEST TAX|0|BGP

 +6       ;;BGP HIV VIRAL LOAD TAX|0|BGP

 +7       ;;BGP PAP SMEAR TAX|0|BGP

 +8       ;;DM AUDIT A/C RATIO TAX|0|APCL*BDM*BGP

 +9       ;;DM AUDIT CHOLESTEROL TAX|0|APCL*BDM*BGP

 +10      ;;DM AUDIT CREATININE TAX|0|APCL*BDM*BGP

 +11      ;;DM AUDIT HDL TAX|0|APCL*BDM*BGP

 +12      ;;DM AUDIT HGB A1C TAX|0|APCL*BDM*BGP

 +13      ;;DM AUDIT LDL CHOLESTEROL TAX|0|APCL*BDM*BGP

 +14      ;;DM AUDIT LIPID PROFILE TAX|0|APCL*BDM*BGP

 +15      ;;DM AUDIT MICROALBUMINURIA TAX|0|APCL*BDM*BGP

 +16      ;;DM AUDIT TRIGLYCERIDE TAX|0|APCL*BDM*BGP

 +17      ;;DM AUDIT URINE PROTEIN TAX|0|APCL*BDM*BGP

 +18      ;;DM AUDIT FASTING GLUCOSE TESTS|0|APCL*BDM*BGP

 +19      ;;BGP CMS ABG TESTS|0|BGP

 +20      ;;BGP CBC TESTS|0|BGP

 +21      ;;DM AUDIT URINALYSIS TAX|0|BGP*APCL*BDM

 +22      ;;DM AUDIT ALT TAX|0|BGP

 +23      ;;DM AUDIT AST TAX|0|BGP*APCL*BDM

 +24      ;;BGP GROUP A STREP TESTS|0|BGP

 +25      ;;BGP LIVER FUNCTION TESTS|0|BGP

 +26      ;;BGP URINE GLUCOSE|0|BGP

 +27      ;;BGP POTASSIUM TESTS|0|BGP

 +28      ;;BGP CMS BLOOD CULTURE|0|BGP

 +29      ;;

TAX       ; 

 +1       ;;SURVEILLANCE DIABETES|1|BGP

 +2       ;;SURVEILLANCE HYPERTENSION|1|BGP

 +3       ;;BGP ALCOHOL DXS|1|BGP

 +4       ;;BGP ASTHMA DXS|1|BGP

 +5       ;;BGP BE CPTS|1|BGP

 +6       ;;BGP CD4 LOINC CODES|1|BGP

 +7       ;;BGP CHLAMYDIA CPTS|1|BGP

 +8       ;;BGP CHLAMYDIA LOINC CODES|1|BGP

 +9       ;;BGP COLO CPTS|1|BGP

 +10      ;;BGP COLORECTAL CANCER DXS|1|BGP

 +11      ;;BGP CPT FLU|1|BGP

 +12      ;;BGP CPT HIV TESTS|1|BGP

 +13      ;;BGP CPT MAMMOGRAM|1|BGP

 +14      ;;BGP CPT MAMMOGRAM HEDIS|1|BGP

 +15      ;;BGP CPT PAP|1|BGP

 +16      ;;BGP CREATININE CPTS|1|BGP

 +17      ;;BGP CREATININE LOINC CODES|1|BGP

 +18      ;;BGP DEPRESSIVE DISORDERS|1|BGP

 +19      ;;BGP DIPHTHERIA EVIDENCE|1|BGP

 +20      ;;BGP DV DXS|1|BGP

 +21      ;;BGP FOBT LOINC CODES|1|BGP

 +22      ;;BGP GPRA EX EDUC TOPICS|1|BGP

 +23      ;;BGP GPRA PREGNANCY DIAGNOSES|1|BGP

 +24      ;;BGP GPRA SMOKING DXS|1|BGP

 +25      ;;BGP HDL LOINC CODES|1|BGP

 +26      ;;BGP HGBA1C LOINC CODES|1|BGP

 +27      ;;BGP HIB EVIDENCE|1|BGP

 +28      ;;BGP HIV TEST LOINC CODES|1|BGP

 +29      ;;BGP HIV/AIDS DXS|1|BGP

 +30      ;;BGP HYPERTENSION DXS|1|BGP

 +31      ;;BGP HYPOTENSION DXS|1|BGP

 +32      ;;BGP HYSTERECTOMY CPTS|1|BGP

 +33      ;;BGP ISCHEMIC HEART DXS|1|BGP

 +34      ;;BGP LDL LOINC CODES|1|BGP

 +35      ;;BGP LIPID PROFILE LOINC CODES|1|BGP

 +36      ;;BGP UNI MASTECTOMY PROCEDURES|1|BGP

 +37      ;;BGP MEASLES EVIDENCE|1|BGP

 +38      ;;BGP MICROALBUM LOINC CODES|1|BGP

 +39      ;;BGP MISCARRIAGE/ABORTION DXS|1|BGP

 +40      ;;BGP MMR CONTRAINDICATIONS|1|BGP

 +41      ;;BGP MUMPS EVIDENCE|1|BGP

 +42      ;;BGP NEPHROPATHY CPTS|1|BGP

 +43      ;;BGP NEPHROPATHY DXS|1|BGP

 +44      ;;BGP NEPHROPATHY PROCEDURES|1|BGP

 +45      ;;BGP OPV CONTRAINDICATIONS|1|BGP

 +46      ;;BGP OPV EVID DISEASE|1|BGP

 +47      ;;BGP PAP LOINC CODES|1|BGP

 +48      ;;BGP PERUTSSIS EVIDENCE|1|BGP

 +49      ;;BGP PCR LOINC CODES|1|BGP

 +50      ;;BGP PRIMARY CARE CLINICS|1|BGP

 +51      ;;BGP PRIMARY PROVIDER DISC|1|BGP

 +52      ;;BGP RECTAL PROCEDURE CODES|1|BGP

 +53      ;;BGP RUBELLA EVIDENCE|1|BGP

 +54      ;;BGP SIG CPTS|1|BGP

 +55      ;;BGP TOTAL CHOLESTEROL LOINC|1|BGP

 +56      ;;BGP TRIGLYCERIDE LOINC CODES|1|BGP

 +57      ;;BGP URINE PROTEIN LOINC CODES|1|BGP

 +58      ;;BGP VARICELLA CONTRA|1|BGP

 +59      ;;BGP VARICELLA EVIDENCE|1|BGP

 +60      ;;BGP VIRAL LOAD LOINC CODES|1|BGP

 +61      ;;BGP CMS AMI DXS|1|BGP

 +62      ;;BGP AMI DXS (HEDIS)|1|BGP

 +63      ;;BGP AMI IND 30

 +64      ;;BGP CMS PNEUMONIA DXS|1|BGP

 +65      ;;BGP CMS SEPTI/RESP FAIL DXS|1|BGP

 +66      ;;BGP CMS HEART FAILURE DXS|1|BGP

 +67      ;;BGP CMS LVSD DXS|1|BGP

 +68      ;;BGP CMS EJECTION FRACTION CPTS|1|BGP

 +69      ;;BGP CMS EJECTION FRACTION PROC|1|BGP

 +70      ;;BGP CMS CIRCULATORY SHOCK DXS|1|BGP

 +71      ;;BGP CMS 2/3 HEART BLOCK DXS|1|BGP

 +72      ;;BGP CMS BRADYCARDIA DXS|1|BGP

 +73      ;;BGP ASA ALLERGY 995.0-995.3|1|BGP

 +74      ;;BGP CMS ABG CPTS|1|BGP

 +75      ;;BGP CMS AORTIC STENOSIS DXS|1|BGP

 +76      ;;BGP CMS WARFARIN MEDS|0|BGP

 +77      ;;DM AUDIT ASPIRIN DRUGS|0|BGP

 +78      ;;DM AUDIT ANTI-PLATELET DRUGS|0|BGP

 +79      ;;BGP CMS ANTIBIOTIC MEDS|0|BGP

 +80      ;;BGP CMS BETA BLOCKER MEDS|0|BGP

 +81      ;;BGP CMS ACEI MEDS|0|BGP

 +82      ;;BGP CMS ARB MEDS|0|BGP

 +83      ;;BGP CMS ANTI-PLATELET CLASS|1|BGP

 +84      ;;BGP CMS ACEI MEDS CLASS|1|BGP

 +85      ;;BGP CMS BETA BLOCKER CLASS|1|BGP

 +86      ;;BGP CMS ARB MEDS CLASS|1|BGP

 +87      ;;BGP CMS ANTIBIOTIC MEDS CLASS|1|BGP

 +88      ;;BGP CMS BETA BLOCKER NDC|0|BGP

 +89      ;;BGP HEDIS OSTEOPOROSIS NDC|0|BGP

 +90      ;;BGP HEDIS OSTEOPOROSIS DRUGS|0|BGP

 +91      ;;BGP HEDIS ANTIDEPRESSANT MEDS|0|BGP

 +92      ;;BGP HEDIS ANTIDEPRESSANT NDC|1|BGP

 +93      ;;BGP MOOD DISORDERS|1|BGP

 +94      ;;BGP MAJOR DEPRESSIVE DISORDERS|1|BGP

 +95      ;;BGP MAJOR DEPRESSION PRIOR|1|BGP

 +96      ;;BGP ACUTE MENTAL HEALTH|1|BGP

 +97      ;;BGP SUBSTANCE ABUSE|1|BGP

 +98      ;;BGP POISONINGS SUBSTANCE ABUSE|1|BGP

 +99      ;;BGP PRESCRIBING PROVIDER CLASS|1|BGP

 +100     ;;BGP MENTAL HEALTH PROV CLASS|1|BGP

 +101     ;;BGP OPT MH VISIT POVS|1|BGP

 +102     ;;BGP OPT MH VISIT CPTS MH|1|BGP

 +103     ;;BGP MH OPT VISIT CPT NMH 1|1|BGP

 +104     ;;BGP MH OPT VISIT CPT NMH 3|1|BGP

 +105     ;;BGP OSTEOPOROSIS DXS|1|BGP

 +106     ;;BGP OSTEO SCREEN CPTS|1|BGP

 +107     ;;BGP MAJOR DEPRESSION (ADM)|1|BGP

 +108     ;;BGP ASTHMA CONTROLLER NDC|1|BGP

 +109     ;;BGP ASTHMA CONTROLLERS|0|BGP

 +110     ;;BGP ASTHMA INHALED STEROID NDC|1|BGP

 +111     ;;BGP ASTHMA INHALED STEROIDS|0|BGP

 +112     ;;BGP ASTHMA LEUKOTRIENE NDC|1|BGP

 +113     ;;BGP ASTHMA LEUKOTRIENE|0|BGP

 +114     ;;BGP BMD PROCEDURES|1|BGP

 +115     ;;BGP BMD CPTS|1|BGP

 +116     ;;BGP CABG CPTS|1|BGP

 +117     ;;BGP CABG PROCS|1|BGP

 +118     ;;BGP COPD DXS|1|BGP

 +119     ;;BGP COPD DXS BB CONT|1|BGP

 +120     ;;BGP EMPHYSEMA DXS|1|BGP

 +121     ;;BGP ESRD DXS|1|BGP

 +122     ;;BGP FRACTURE CPTS|1|BGP

 +123     ;;BGP FRACTURE DXS|1|BGP

 +124     ;;BGP FRACTURE PROCEDURES|1|BGP

 +125     ;;BGP HEDIS RETINAL SCREENING|1|BGP

 +126     ;;BGP HEDIS RETINAL SCRN PROCS|1|BGP

 +127     ;;BGP HEP EVIDENCE|1|BGP

 +128     ;;BGP MASTECTOMY PROCEDURES|1|BGP

 +129     ;;BGP PTCA CPTS|1|BGP

 +130     ;;BGP PTCA PROCS|1|BGP

 +131     ;;BGP SINUS BRADYCARDIA DXS|1|BGP

 +132     ;;DM AUDIT FASTING GLUC LOINC|1|BGP

 +133     ;;BGP OSTEOARTHRITIS DXS|1|BGP

 +134     ;;BGP RA OA NSAID MEDS|0|BGP

 +135     ;;BGP RA OA NSAID NDC|1|BGP

 +136     ;;BGP OA GLUCOCORTICOIDS MEDS|0|BGP

 +137     ;;BGP OA GLUCOCORTICOIDS CLASS|1|BGP

 +138     ;;BGP CBC CPT|1|BGP

 +139     ;;BGP CBC LOINC|1|BGP

 +140     ;;DM AUDIT URINALYSIS LOINC|1|BGP*APCL*BDM

 +141     ;;BGP ALT LOINC|1|BGP

 +142     ;;BGP ALT CPT|1|BGP

 +143     ;;BGP AST CPT|1|BGP

 +144     ;;BGP AST LOINC|1|BGP

 +145     ;;BGP BMD DXS|1|BGP

 +146     ;;BGP IVD DXS|1|BGP

 +147     ;;BGP TOBACCO DXS|1|BGP

 +148     ;;BGP TOTAL CHOLECTOMY CPTS|1|BGP

 +149     ;;BGP TOTAL CHOLECTOMY PROCS|1|BGP

 +150     ;;BGP HYSTERECTOMY PROCEDURES|1|BGP

 +151     ;;BGP PHARYNGITIS DXS|1|BGP

 +152     ;;BGP HEDIS ANTIBIOTICS NDC|1|BGP

 +153     ;;BGP HEDIS ANTIBIOTICS MEDS|0|BGP

 +154     ;;BGP GROUP A STREP CPT|1|BGP

 +155     ;;BGP GROUP A STREP LOINC|1|BGP

 +156     ;;BGP HEDIS ASTHMA LEUK MEDS|0|BGP

 +157     ;;BGP HEDIS ASTHMA LEUK NDC|1|BGP

 +158     ;;BGP CD4 CPTS|1|BGP

 +159     ;;BGP URI DXS|1|BGP

 +160     ;;BGP HEDIS ASTHMA MEDS|0|BGP

 +161     ;;BGP HEDIS ASTHMA NDC|1|BGP

 +162     ;;BGP HEDIS PRIMARY ASTHMA MEDS|0|BGP

 +163     ;;BGP HEDIS PRIMARY ASTHMA NDC|1|BGP

 +164     ;;BGP HEDIS ASTHMA INHALED MEDS|0|BGP

 +165     ;;BGP HEDIS ASTHMA INHALED NDC|1|BGP

 +166     ;;BGP LIVER FUNCTION LOINC|1|BGP

 +167     ;;BGP HEDIS BETA BLOCKER MEDS|0|BGP

 +168     ;;BGP HEDIS BETA BLOCKER NDC|1|BGP

 +169     ;;BGP RA IM GOLD MEDS|0|BGP

 +170     ;;BGP RA IM GOLD NDC|1|BGP

 +171     ;;BGP RA ORAL GOLD MEDS|0|BGP

 +172     ;;BGP RA AZATHIOPRINE MEDS|0|BGP

 +173     ;;BGP RA AZATHIOPRINE NDC|1|BGP

 +174     ;;BGP RA LEFLUNOMIDE MEDS|0|BGP

 +175     ;;BGP RA LEFLUNOMIDE NDC|1|BGP

 +176     ;;BGP RA METHOTREXATE MEDS|0|BGP

 +177     ;;BGP RA METHOTREXATE NDC|1|BGP

 +178     ;;BGP RA CYCLOSPORINE MEDS|0|BGP

 +179     ;;BGP RA CYCLOSPORINE NDC|1|BGP

 +180     ;;BGP RA MYCOPHENOLATE MEDS|0|BGP

 +181     ;;BGP RA MYCOPHENOLATE NDC|1|BGP

 +182     ;;BGP RA PENICILLAMINE MEDS|0|BGP

 +183     ;;BGP RA PENICILLAMINE NDC|1|BGP

 +184     ;;BGP RA SULFASALAZINE MEDS|0|BGP

 +185     ;;BGP RA SULFASALAZINE NDC|1|BGP

 +186     ;;BGP ESRD CPTS|1|BGP

 +187     ;;BGP URINE GLUCOSE LOINC|1|BGP

 +188     ;;BGP POTASSIUM LOINC|1|BGP

 +189     ;;BGP ST ELEVATION DX|1|BGP

 +190     ;;BGP LBBB ON ECG CPT|1|BGP

 +191     ;;BGP LBBB ON ECG PROC|1|BGP

 +192     ;;BGP THROMBOLYTIC AGENT CLASS|1|BGP

 +193     ;;BGP CMS THROMBOLYTIC MEDS|0|BGP

 +194     ;;BGP LVAD/HEART TRANSPLANT PROC|1|BGP

 +195     ;;BGP CMS ABG LOINC|1|BGP

 +196     ;;BGP BLOOD CULTURE LOINC|1|BGP

 +197     ;;

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      ;;

SEC       ;set security on selected dd's

LP        ;EP - loop through file entries

 +1        FOR I=1:1

               Begin DoDot:1

 +2                SET BGPTXT=$TEXT(TXT+I)

 +3                IF BGPTXT["end"

                       QUIT 

 +4                FOR J=2:1:4

                       SET BGP(J)=$PIECE(BGPTXT,";;",J)

 +5                SET BGP(3)=""""_BGP(3)_""""

 +6                SET BGPREF="^DIC("_BGP(2)_",0,"_BGP(3)_")"

 +7                SET @BGPREF=BGP(4)

               End DoDot:1

               IF BGPTXT["end"

                   QUIT 

 +8        QUIT 

TXT       ;file entries start here

 +1       ;;90244.01;;AUDIT;;@

 +2       ;;90244.01;;DD;;@

 +3       ;;90244.01;;DEL;;@

 +4       ;;90244.01;;LAYGO;;@

 +5       ;;90244.01;;RD;;M

 +6       ;;90244.01;;WR;;@

 +7       ;;90244.02;;AUDIT;;@

 +8       ;;90244.02;;DD;;@

 +9       ;;90244.02;;DEL;;@

 +10      ;;90244.02;;LAYGO;;@

 +11      ;;90244.02;;RD;;M

 +12      ;;90244.02;;WR;;@

 +13      ;;90371.04;;AUDIT;;@

 +14      ;;90371.04;;DD;;@

 +15      ;;90371.04;;DEL;;@

 +16      ;;90371.04;;LAYGO;;M

 +17      ;;90371.04;;RD;;M

 +18      ;;90371.04;;WR;;M

 +19      ;;90372.03;;AUDIT;;@

 +20      ;;90372.03;;DD;;@

 +21      ;;90372.03;;DEL;;M

 +22      ;;90372.03;;LAYGO;;M

 +23      ;;90372.03;;RD;;M

 +24      ;;90372.03;;WR;;M

 +25      ;;90372.05;;AUDIT;;@

 +26      ;;90372.05;;DD;;@

 +27      ;;90372.05;;DEL;;M

 +28      ;;90372.05;;LAYGO;;M

 +29      ;;90372.05;;RD;;M

 +30      ;;90372.05;;WR;;M

 +31      ;;end

 +32       QUIT