BDM20P4 ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ; [ 02/05/2009 2:37 PM ]
;;2.0;DIABETES MANAGEMENT SYSTEM;**4**;JUN 14, 2007
;
;
; 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("BDM*2.0*3") D SORRY(2)
;
Q
;
PRE ;
S BDMX=0 F S BDMX=$O(^BDMRECD(BDMX)) Q:BDMX'=+BDMX S DA=BDMX,DIK="^BDMRECD(" D ^DIK
S BDMX=0 F S BDMX=$O(^BDMDMTX(BDMX)) Q:BDMX'=+BDMX S DA=BDMX,DIK="^BDMDMTX(" D ^DIK
S BDMX=0 F S BDMX=$O(^BDMTAXS(BDMX)) Q:BDMX'=+BDMX S DA=BDMX,DIK="^BDMTAXS(" D ^DIK
Q
POST ;
S X=$$ADD^XPDMENU("BDM REPORTS","BDM LAB/MED REPORT","LMR")
I 'X W !,"Attempt to add BDM LAB/MED REPORT option failed.." H 3
S X=$$ADD^XPDMENU("BDM M MAIN DM MENU","BDM DM2011 AUDIT MENU","DM11",6)
I 'X W !,"Attempt to add BDM DM2011 AUDIT MENU option failed.." H 3
D MEDTAX
D LABTAX
;copy A/C RATIO TAXONOMY
D UACR
D ^BDMTX5
Q
UACR ;
Q:$D(^ATXLAB("B","DM AUDIT QUANT UACR")) ;already have this taxonomy
;add it and then move the a/c ratio tax to this new one
S BDMX="DM AUDIT QUANT UACR",BDMPG="BDM",BDMAP=0 D LAB1
S BDMNDA=$O(^ATXLAB("B","DM AUDIT QUANT UACR",0))
S BDMODA=$O(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
I 'BDMNDA Q
I 'BDMODA Q
M ^ATXLAB(BDMNDA,21)=^ATXLAB(BDMODA,21)
Q
WRITEMSG ;
S X=$O(^APCLPDES("B","BDMV2",0))
Q:'X
S Y=0 F S Y=$O(^APCLPDES(X,11,Y)) Q:Y'=+Y S ^TMP($J,"BDMBUL",Y)=^APCLPDES(X,11,Y,0)
Q
;
GETRECIP ;
;
S CTR=0
F BDMKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
F S CTR=$O(^XUSEC(BDMKEY,CTR)) Q:'CTR S Y=CTR S XMY(Y)=""
Q
INSTALLD(BDMSTAL) ;EP - Determine if patch BDMSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BDMY,DIC,X,Y
S X=$P(BDMSTAL,"*",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(BDMSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BDMSTAL,"*",3)
D ^DIC
S BDMY=Y
D IMES
Q $S(BDMY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BDMSTAL_""" 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
;
MEDTAX ;EP set up drug taxonomies
S ATXFLG=1
S BDMNDCT="",BDMTAX=""
S BDMX="DM AUDIT ASPIRIN DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT ACARBOSE DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT ACE INHIBITORS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT ANTI-PLATELET DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT DPP4 INHIBITOR DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT GLITAZONE DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT INCRETIN MIMETIC",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT INSULIN DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT LIPID LOWERING DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT METFORMIN DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT ORAL HYPOGLYCEMICS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT SELF MONITOR DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT STATIN DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT SULFONYLUREA DRUGS",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT SULFONYLUREA-LIKE",BDMPG="BDM,APCH,APCL" D DRUG1
S BDMX="DM AUDIT AMYLIN ANALOGUES",BDMPG="APCH;BDM" D DRUG1
S BDMX="DM AUDIT FIBRATE DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT NIACIN DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT BILE ACID DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT EZETIMIBE DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT FISH OIL DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT LOVAZA DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT GLP-1 ANALOG DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT BROMOCRIPTINE DRUGS",BDMPG="BDM" D DRUG1
Q
;
DRUG1 ;
S BDMTX=$O(^ATXAX("B",BDMX,0))
I 'BDMTX D Q:Y=-1
.D MES^XPDUTL("Creating "_BDMX_" taxonomy")
.S X=BDMX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
.I Y=-1 W !!,"ERROR IN CREATING ",BDMX," TAX" Q
.S BDMTX=+Y,$P(^ATXAX(BDMTX,0),U,2)=BDMX,$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,$P(^(0),U,22)=0,$P(^(0),U,4)="n",^ATXAX(BDMTX,21,0)="^9002226.02101A^0^0"
S DA=BDMTX,DIK="^ATXAX(" D IX1^DIK
D MES^XPDUTL("Updating "_BDMX_" taxonomy")
I $G(BDMTAX)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BDMTX,21,A)) Q:A'=+A S B=A
.S BDMC=B
.S ^ATXAX(BDMTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BDMTAX,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(BDMTX,21,"B",J))
..S BDMC=BDMC+1,^ATXAX(BDMTX,21,BDMC,0)=J_U_J
I $G(BDMNDCT)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BDMTX,21,A)) Q:A'=+A S B=A
.S BDMC=B
.S ^ATXAX(BDMTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BDMNDCT,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(BDMTX,21,"B",J))
..S BDMC=BDMC+1,^ATXAX(BDMTX,21,BDMC,0)=J_U_J
S DA=BDMTX,DIK="^ATXAX(" D IX1^DIK
Q
;
LABTAX ;EP
S BDMX="DM AUDIT 2 HR GTT TAX",BDMPG="BDM,APCL,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT 75GM 2HR GLUCOSE",BDMPG="BDM,APCL,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT A/C RATIO TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT AST TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT ALT TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT CHOLESTEROL TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT CREATININE TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT FASTING GLUCOSE TESTS",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT GLUCOSE TESTS TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT HDL TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT HGB A1C TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT LDL CHOLESTEROL TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT MICROALBUMINURIA TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT P/C RATIO TAX",BDMPG="BDM,APCL,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT TRIGLYCERIDE TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT URINALYSIS TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=1 D LAB1
S BDMX="DM AUDIT URINE PROTEIN TAX",BDMPG="BDM,APCL,BGP,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT SEMI QUANT UACR",BDMPG="BDM,APCL,APCH",BDMAP=0 D LAB1
S BDMX="DM AUDIT TB LAB TESTS",BDMPG="BDM",BDMAP=0 D LAB1
S BDMX="DM AUDIT 24HR URINE PROTEIN",BDMPG="BDM",BDMAP=0 D LAB1
Q
;
LAB1 ;
S BDMDA=$O(^ATXLAB("B",BDMX,0))
I BDMDA G UP41 ;taxonomy already exists
W !,"Creating ",BDMX," Taxonomy..."
S X=BDMX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",BDMX," TAX" Q
S BDMDA=+Y,$P(^ATXLAB(BDMDA,0),U,2)=BDMX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60,$P(^(0),U,22)=0,$P(^(0),U,4)="n",$P(^(0),U,11)=BDMAP
S ^ATXLAB(BDMDA,21,0)="^9002228.02101PA^0^0"
S DA=BDMDA,DIK="^ATXAX(" D IX1^DIK
UP41 ;
F BDMI=1:1 S BDMPI=$P(BDMPG,",",BDMI) Q:BDMPI="" D
.S BDMPI=$O(^DIC(9.4,"C","BDM",0))
.Q:BDMPI="" ;NO PACKAGE
.Q:$D(^ATXLAB(BDMDA,41,"B",BDMPI))
.S X="`"_BDMPI,DIC="^ATXLAB("_BDMDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=BDMDA
.D ^DIC
.I Y=-1 W !,"updating package multiple for ",BDMPI," entry ",$P(^ATXAX(BDMDA,0),U)," failed"
.K DIC,DA,Y,X
Q
BDM20P4 ; IHS/CMI/LAB - PCC Suite v1.0 patch 1 environment check ; [ 02/05/2009 2:37 PM ]
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**4**;JUN 14, 2007
+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("BDM*2.0*3")
DO SORRY(2)
+9 ;
+10 QUIT
+11 ;
PRE ;
+1 SET BDMX=0
FOR
SET BDMX=$ORDER(^BDMRECD(BDMX))
IF BDMX'=+BDMX
QUIT
SET DA=BDMX
SET DIK="^BDMRECD("
DO ^DIK
+2 SET BDMX=0
FOR
SET BDMX=$ORDER(^BDMDMTX(BDMX))
IF BDMX'=+BDMX
QUIT
SET DA=BDMX
SET DIK="^BDMDMTX("
DO ^DIK
+3 SET BDMX=0
FOR
SET BDMX=$ORDER(^BDMTAXS(BDMX))
IF BDMX'=+BDMX
QUIT
SET DA=BDMX
SET DIK="^BDMTAXS("
DO ^DIK
+4 QUIT
POST ;
+1 SET X=$$ADD^XPDMENU("BDM REPORTS","BDM LAB/MED REPORT","LMR")
+2 IF 'X
WRITE !,"Attempt to add BDM LAB/MED REPORT option failed.."
HANG 3
+3 SET X=$$ADD^XPDMENU("BDM M MAIN DM MENU","BDM DM2011 AUDIT MENU","DM11",6)
+4 IF 'X
WRITE !,"Attempt to add BDM DM2011 AUDIT MENU option failed.."
HANG 3
+5 DO MEDTAX
+6 DO LABTAX
+7 ;copy A/C RATIO TAXONOMY
+8 DO UACR
+9 DO ^BDMTX5
+10 QUIT
UACR ;
+1 ;already have this taxonomy
IF $DATA(^ATXLAB("B","DM AUDIT QUANT UACR"))
QUIT
+2 ;add it and then move the a/c ratio tax to this new one
+3 SET BDMX="DM AUDIT QUANT UACR"
SET BDMPG="BDM"
SET BDMAP=0
DO LAB1
+4 SET BDMNDA=$ORDER(^ATXLAB("B","DM AUDIT QUANT UACR",0))
+5 SET BDMODA=$ORDER(^ATXLAB("B","DM AUDIT A/C RATIO TAX",0))
+6 IF 'BDMNDA
QUIT
+7 IF 'BDMODA
QUIT
+8 MERGE ^ATXLAB(BDMNDA,21)=^ATXLAB(BDMODA,21)
+9 QUIT
WRITEMSG ;
+1 SET X=$ORDER(^APCLPDES("B","BDMV2",0))
+2 IF 'X
QUIT
+3 SET Y=0
FOR
SET Y=$ORDER(^APCLPDES(X,11,Y))
IF Y'=+Y
QUIT
SET ^TMP($JOB,"BDMBUL",Y)=^APCLPDES(X,11,Y,0)
+4 QUIT
+5 ;
GETRECIP ;
+1 ;
+2 SET CTR=0
+3 FOR BDMKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
+4 FOR
SET CTR=$ORDER(^XUSEC(BDMKEY,CTR))
IF 'CTR
QUIT
SET Y=CTR
SET XMY(Y)=""
+5 QUIT
INSTALLD(BDMSTAL) ;EP - Determine if patch BDMSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BDMY,DIC,X,Y
+4 SET X=$PIECE(BDMSTAL,"*",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(BDMSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BDMSTAL,"*",3)
+12 DO ^DIC
+13 SET BDMY=Y
+14 DO IMES
+15 QUIT $SELECT(BDMY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BDMSTAL_""" 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
+6 ;
MEDTAX ;EP set up drug taxonomies
+1 SET ATXFLG=1
+2 SET BDMNDCT=""
SET BDMTAX=""
+3 SET BDMX="DM AUDIT ASPIRIN DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+4 SET BDMX="DM AUDIT ACARBOSE DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+5 SET BDMX="DM AUDIT ACE INHIBITORS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+6 SET BDMX="DM AUDIT ANTI-PLATELET DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+7 SET BDMX="DM AUDIT DPP4 INHIBITOR DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+8 SET BDMX="DM AUDIT GLITAZONE DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+9 SET BDMX="DM AUDIT INCRETIN MIMETIC"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+10 SET BDMX="DM AUDIT INSULIN DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+11 SET BDMX="DM AUDIT LIPID LOWERING DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+12 SET BDMX="DM AUDIT METFORMIN DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+13 SET BDMX="DM AUDIT ORAL HYPOGLYCEMICS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+14 SET BDMX="DM AUDIT SELF MONITOR DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+15 SET BDMX="DM AUDIT STATIN DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+16 SET BDMX="DM AUDIT SULFONYLUREA DRUGS"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+17 SET BDMX="DM AUDIT SULFONYLUREA-LIKE"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+18 SET BDMX="DM AUDIT AMYLIN ANALOGUES"
SET BDMPG="APCH;BDM"
DO DRUG1
+19 SET BDMX="DM AUDIT FIBRATE DRUGS"
SET BDMPG="BDM"
DO DRUG1
+20 SET BDMX="DM AUDIT NIACIN DRUGS"
SET BDMPG="BDM"
DO DRUG1
+21 SET BDMX="DM AUDIT BILE ACID DRUGS"
SET BDMPG="BDM"
DO DRUG1
+22 SET BDMX="DM AUDIT EZETIMIBE DRUGS"
SET BDMPG="BDM"
DO DRUG1
+23 SET BDMX="DM AUDIT FISH OIL DRUGS"
SET BDMPG="BDM"
DO DRUG1
+24 SET BDMX="DM AUDIT LOVAZA DRUGS"
SET BDMPG="BDM"
DO DRUG1
+25 SET BDMX="DM AUDIT GLP-1 ANALOG DRUGS"
SET BDMPG="BDM"
DO DRUG1
+26 SET BDMX="DM AUDIT BROMOCRIPTINE DRUGS"
SET BDMPG="BDM"
DO DRUG1
+27 QUIT
+28 ;
DRUG1 ;
+1 SET BDMTX=$ORDER(^ATXAX("B",BDMX,0))
+2 IF 'BDMTX
Begin DoDot:1
+3 DO MES^XPDUTL("Creating "_BDMX_" taxonomy")
+4 SET X=BDMX
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 ",BDMX," TAX"
QUIT
+6 SET BDMTX=+Y
SET $PIECE(^ATXAX(BDMTX,0),U,2)=BDMX
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 $PIECE(^(0),U,22)=0
SET $PIECE(^(0),U,4)="n"
SET ^ATXAX(BDMTX,21,0)="^9002226.02101A^0^0"
End DoDot:1
IF Y=-1
QUIT
+7 SET DA=BDMTX
SET DIK="^ATXAX("
DO IX1^DIK
+8 DO MES^XPDUTL("Updating "_BDMX_" taxonomy")
+9 IF $GET(BDMTAX)]""
Begin DoDot:1
+10 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BDMTX,21,A))
IF A'=+A
QUIT
SET B=A
+11 SET BDMC=B
+12 SET ^ATXAX(BDMTX,21,0)="^9002226.02101A^"_B_U_B
+13 SET Z=$ORDER(^ATXAX("B",BDMTAX,0))
+14 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
+15 IF $DATA(^ATXAX(BDMTX,21,"B",J))
QUIT
+16 SET BDMC=BDMC+1
SET ^ATXAX(BDMTX,21,BDMC,0)=J_U_J
End DoDot:2
End DoDot:1
+17 IF $GET(BDMNDCT)]""
Begin DoDot:1
+18 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BDMTX,21,A))
IF A'=+A
QUIT
SET B=A
+19 SET BDMC=B
+20 SET ^ATXAX(BDMTX,21,0)="^9002226.02101A^"_B_U_B
+21 SET Z=$ORDER(^ATXAX("B",BDMNDCT,0))
+22 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
+23 IF $DATA(^ATXAX(BDMTX,21,"B",J))
QUIT
+24 SET BDMC=BDMC+1
SET ^ATXAX(BDMTX,21,BDMC,0)=J_U_J
End DoDot:2
End DoDot:1
+25 SET DA=BDMTX
SET DIK="^ATXAX("
DO IX1^DIK
+26 QUIT
+27 ;
LABTAX ;EP
+1 SET BDMX="DM AUDIT 2 HR GTT TAX"
SET BDMPG="BDM,APCL,APCH"
SET BDMAP=0
DO LAB1
+2 SET BDMX="DM AUDIT 75GM 2HR GLUCOSE"
SET BDMPG="BDM,APCL,APCH"
SET BDMAP=0
DO LAB1
+3 SET BDMX="DM AUDIT A/C RATIO TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+4 SET BDMX="DM AUDIT AST TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+5 SET BDMX="DM AUDIT ALT TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+6 SET BDMX="DM AUDIT CHOLESTEROL TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+7 SET BDMX="DM AUDIT CREATININE TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+8 SET BDMX="DM AUDIT FASTING GLUCOSE TESTS"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+9 SET BDMX="DM AUDIT GLUCOSE TESTS TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+10 SET BDMX="DM AUDIT HDL TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+11 SET BDMX="DM AUDIT HGB A1C TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+12 SET BDMX="DM AUDIT LDL CHOLESTEROL TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+13 SET BDMX="DM AUDIT MICROALBUMINURIA TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+14 SET BDMX="DM AUDIT P/C RATIO TAX"
SET BDMPG="BDM,APCL,APCH"
SET BDMAP=0
DO LAB1
+15 SET BDMX="DM AUDIT TRIGLYCERIDE TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+16 SET BDMX="DM AUDIT URINALYSIS TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=1
DO LAB1
+17 SET BDMX="DM AUDIT URINE PROTEIN TAX"
SET BDMPG="BDM,APCL,BGP,APCH"
SET BDMAP=0
DO LAB1
+18 SET BDMX="DM AUDIT SEMI QUANT UACR"
SET BDMPG="BDM,APCL,APCH"
SET BDMAP=0
DO LAB1
+19 SET BDMX="DM AUDIT TB LAB TESTS"
SET BDMPG="BDM"
SET BDMAP=0
DO LAB1
+20 SET BDMX="DM AUDIT 24HR URINE PROTEIN"
SET BDMPG="BDM"
SET BDMAP=0
DO LAB1
+21 QUIT
+22 ;
LAB1 ;
+1 SET BDMDA=$ORDER(^ATXLAB("B",BDMX,0))
+2 ;taxonomy already exists
IF BDMDA
GOTO UP41
+3 WRITE !,"Creating ",BDMX," Taxonomy..."
+4 SET X=BDMX
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 ",BDMX," TAX"
QUIT
+6 SET BDMDA=+Y
SET $PIECE(^ATXLAB(BDMDA,0),U,2)=BDMX
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,6)=DT
SET $PIECE(^(0),U,8)="B"
SET $PIECE(^(0),U,9)=60
SET $PIECE(^(0),U,22)=0
SET $PIECE(^(0),U,4)="n"
SET $PIECE(^(0),U,11)=BDMAP
+7 SET ^ATXLAB(BDMDA,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BDMDA
SET DIK="^ATXAX("
DO IX1^DIK
UP41 ;
+1 FOR BDMI=1:1
SET BDMPI=$PIECE(BDMPG,",",BDMI)
IF BDMPI=""
QUIT
Begin DoDot:1
+2 SET BDMPI=$ORDER(^DIC(9.4,"C","BDM",0))
+3 ;NO PACKAGE
IF BDMPI=""
QUIT
+4 IF $DATA(^ATXLAB(BDMDA,41,"B",BDMPI))
QUIT
+5 SET X="`"_BDMPI
SET DIC="^ATXLAB("_BDMDA_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)
SET DA(1)=BDMDA
+6 DO ^DIC
+7 IF Y=-1
WRITE !,"updating package multiple for ",BDMPI," entry ",$PIECE(^ATXAX(BDMDA,0),U)," failed"
+8 KILL DIC,DA,Y,X
End DoDot:1
+9 QUIT
