BDM20P7 ; IHS/CMI/LAB - BDM V2.0 patch 7 environment check ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**7**;JUN 14, 2007;Build 24
;
;
; 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*6") 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=$$DELETE^XPDMENU("BDMMENU","APCDEDMUPD")
S X=$$ADD^XPDMENU("BDM M MAIN DM MENU","BDM DM2014 AUDIT MENU","DM14",3)
I 'X W !,"Attempt to add BDM DM2014 AUDIT MENU option failed.." H 3
S X=$$ADD^XPDMENU("BDMMENU","BDMEEDMUPD","DMU",45)
I 'X W !,"Attempt to add BDM UPDATE option failed.." H 3
S X=$$DELETE^XPDMENU("BDMMENU","APCDEDMUPD")
D BMXPO
D MEDTAX
D LABTAX
D ^BDMTB1
Q ;ihs/cmi/maw p7 add necessary post install here
;
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
S BDMX="DM AUDIT COLESEVELAM DRUGS",BDMPG="BDM" D DRUG1
S BDMX="DM AUDIT SGLT-2 INHIBITOR DRUG",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
S BDMX="DM AUDIT NON-HDL TESTS",BDMPG="BDM",BDMAP=0 D LAB1
S BDMX="DM AUDIT QUANT UACR",BDMPG="BDM",BDMAP=0 D LAB1
Q
;
BMXPO ;-- update the RPC file
N BDMRPC
S BDMRPC=$O(^DIC(19,"B","BDMGRPC",0))
Q:'BDMRPC
D CLEAN(BDMRPC)
D GUIEP^BMXPO(.RETVAL,BDMRPC_"|BDM")
Q
;
CLEAN(APP) ;-- clean out the RPC multiple first
S DA(1)=APP
S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
N AMHDA
S AMHDA=0 F S AMHDA=$O(^DIC(19,APP,"RPC",AMHDA)) Q:'AMHDA D
. S DA=AMHDA
. D ^DIK
K ^DIC(19,APP,"RPC","B")
Q
;
LAB1 ;
S BDMDB=$O(^ATXLAB("B",BDMX,0))
I BDMDB 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 BDMDB=+Y,$P(^ATXLAB(BDMDB,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(BDMDB,21,0)="^9002228.02101PA^0^0"
S DA=BDMDB,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(BDMDB,41,"B",BDMPI))
.S X="`"_BDMPI,DIC="^ATXLAB("_BDMDB_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=BDMDB
.D ^DIC
.I Y=-1 W !,"updating package multiple for ",BDMPI," entry ",$P(^ATXAX(BDMDB,0),U)," failed"
.K DIC,DA,Y,X
Q
BDM20P7 ; IHS/CMI/LAB - BDM V2.0 patch 7 environment check ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**7**;JUN 14, 2007;Build 24
+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*6")
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=$$DELETE^XPDMENU("BDMMENU","APCDEDMUPD")
+2 SET X=$$ADD^XPDMENU("BDM M MAIN DM MENU","BDM DM2014 AUDIT MENU","DM14",3)
+3 IF 'X
WRITE !,"Attempt to add BDM DM2014 AUDIT MENU option failed.."
HANG 3
+4 SET X=$$ADD^XPDMENU("BDMMENU","BDMEEDMUPD","DMU",45)
+5 IF 'X
WRITE !,"Attempt to add BDM UPDATE option failed.."
HANG 3
+6 SET X=$$DELETE^XPDMENU("BDMMENU","APCDEDMUPD")
+7 DO BMXPO
+8 DO MEDTAX
+9 DO LABTAX
+10 DO ^BDMTB1
+11 ;ihs/cmi/maw p7 add necessary post install here
QUIT
+12 ;
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 SET BDMX="DM AUDIT COLESEVELAM DRUGS"
SET BDMPG="BDM"
DO DRUG1
+28 SET BDMX="DM AUDIT SGLT-2 INHIBITOR DRUG"
SET BDMPG="BDM"
DO DRUG1
+29 QUIT
+30 ;
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 SET BDMX="DM AUDIT NON-HDL TESTS"
SET BDMPG="BDM"
SET BDMAP=0
DO LAB1
+22 SET BDMX="DM AUDIT QUANT UACR"
SET BDMPG="BDM"
SET BDMAP=0
DO LAB1
+23 QUIT
+24 ;
BMXPO ;-- update the RPC file
+1 NEW BDMRPC
+2 SET BDMRPC=$ORDER(^DIC(19,"B","BDMGRPC",0))
+3 IF 'BDMRPC
QUIT
+4 DO CLEAN(BDMRPC)
+5 DO GUIEP^BMXPO(.RETVAL,BDMRPC_"|BDM")
+6 QUIT
+7 ;
CLEAN(APP) ;-- clean out the RPC multiple first
+1 SET DA(1)=APP
+2 SET DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
+3 NEW AMHDA
+4 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^DIC(19,APP,"RPC",AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+5 SET DA=AMHDA
+6 DO ^DIK
End DoDot:1
+7 KILL ^DIC(19,APP,"RPC","B")
+8 QUIT
+9 ;
LAB1 ;
+1 SET BDMDB=$ORDER(^ATXLAB("B",BDMX,0))
+2 ;taxonomy already exists
IF BDMDB
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 BDMDB=+Y
SET $PIECE(^ATXLAB(BDMDB,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(BDMDB,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BDMDB
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(BDMDB,41,"B",BDMPI))
QUIT
+5 SET X="`"_BDMPI
SET DIC="^ATXLAB("_BDMDB_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)
SET DA(1)=BDMDB
+6 DO ^DIC
+7 IF Y=-1
WRITE !,"updating package multiple for ",BDMPI," entry ",$PIECE(^ATXAX(BDMDB,0),U)," failed"
+8 KILL DIC,DA,Y,X
End DoDot:1
+9 QUIT
