BDM20P10 ; IHS/CMI/LAB - BDM V2.0 patch 10 environment check ; 29 Sep 2014 12:22 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**10**;JUN 14, 2007;Build 12
;
;
; 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*9") D SORRY(2)
;
Q
;
PRE ;
S DA=$O(^DIC(19,"B","BDM M MAIN MENU",0))
I DA S DIE="^DIC(19,",DR="1///Diabetes Audit Menu" D ^DIE K DA,DIE,DR
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
S BDMX=0 F S BDMX=$O(^BDMSNME(BDMX)) Q:BDMX'=+BDMX S DA=BDMX,DIK="^BDMSMME(" D ^DIK
Q
POST ;
;rename insert
S DA=$O(^BDMLETI("B","EXERCISE EDUCATION",0))
I DA S DIE="^BDMLETI(",DR=".01///PHYSICAL ACTIVITY EDUCATION" D ^DIE K DIE,DA,DR
S DA=$O(^BDMLETI("B","PNEUMO EDUCATION",0))
I DA S ^BDMLETI(DA,3,1,0)="This item will display the Pneumococcal education text."
;change letters
S X=0 F S X=$O(^BDMLET(X)) Q:X'=+X D
.S Y=0 F S Y=$O(^BDMLET(X,1,Y)) Q:Y'=+Y D
..I ^BDMLET(X,1,Y,0)["|EXERCISE EDUCATION|"!(^BDMLET(X,1,Y,0)["|exercise education|") D
...S Z=$P(^BDMLET(X,1,Y,0),"|EXERCISE EDUCATION|",1)_"|PHYSICAL ACTIVITY EDUCATION|"_$P(^BDMLET(X,1,Y,0),"|EXERCISE EDUCATION|",2)
...S ^BDMLET(X,1,Y,0)=Z
D ^BDMDEX
D BMXPO
;CREATE DM AUDIT ANTIPLT/ANTICOAG RX taxonomy, copy DM AUDIT ANTIPLATELET THERAPY
D MEDTAX
D TBHLTH
D BUILDSML^BDMUTL(2017)
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
I $P(BDMSTAL,"*",3)="" D IMES Q 1
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 ANTIPLT/ANTICOAG RX",BDMPG="BDM,APCH,APCL" D DRUG1
NEW BDMN,BDMO
S BDMN=$O(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0))
S BDMO=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
I 'BDMO!('BDMN) Q
M ^ATXAX(BDMN,21)=^ATXAX(BDMO,21)
S DA=BDMN,DIK="^ATXAX(" D IX1^DIK
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")
D GUIEP^BMXPO(.RETVAL,BDMRPC_"|ATX")
Q
;
BMXSCH ;--add the search template schema
Q:$O(^BMXADO("B","CMI VIEW SORT TEMPLATE",0))
N FDA,FIENS,FERR
S FDA(90093.99,"+1,",.01)="CMI VIEW SORT TEMPLATE"
S FDA(90093.99,"+1,",.02)=.401
S FDA(90093.991,"+2,+1,",.01)=.01
S FDA(90093.991,"+2,+1,",.02)="T"
S FDA(90093.991,"+2,+1,",.03)=80
S FDA(90093.991,"+2,+1,",.04)="TEMPLATE"
D UPDATE^DIE("","FDA","FIENS","FERR(1)")
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 BDMDC=$O(^ATXLAB("B",BDMX,0))
I BDMDC 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 BDMDC=+Y,$P(^ATXLAB(BDMDC,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(BDMDC,21,0)="^9002228.02101PA^0^0"
S DA=BDMDC,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(BDMDC,41,"B",BDMPI))
.S X="`"_BDMPI,DIC="^ATXLAB("_BDMDC_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=BDMDC
.D ^DIC
.I Y=-1 W !,"updating package multiple for ",BDMPI," entry ",$P(^ATXAX(BDMDC,0),U)," failed"
.K DIC,DA,Y,X
Q
TBHLTH ;tb health factors taxonomy
S ATXFLG=1
W !,"Creating TB HF Taxonomy... "
S APCLDA=0 F S APCLDA=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",APCLDA)) Q:APCLDA="" I APCLDA S DA=APCLDA S DIK="^ATXAX(" D ^DIK K DA,DIK
S X="DM AUDIT TB HEALTH FACTORS",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DIADD,DLAYGO,DA,DR,DO,D0
I Y=-1 W !!,"ERROR IN CREATING DM AUDIT TB HLTH FACTORS TAX" Q
S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)="TB TX STATUS HLTH FACTORS",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=78,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.64
S ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"
S APCLTEXT="TBHF" F APCLX=1:1:10 S X=$P($T(@APCLTEXT+APCLX),";;",2),DIC="^AUTTHF(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D
.S ^ATXAX(APCLTX,21,APCLX,0)=+Y,$P(^ATXAX(APCLTX,21,0),U,3)=APCLX,$P(^(0),U,4)=APCLX,^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""
.Q
S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK
Q
TBHF ;
;;TB - TX UNTREATED
;;TB - TX INCOMPLETE
;;TB - TX COMPLETE
;;TB - TX UNKNOWN
;;TB - TX IN PROGRESS
;;TX UNTREATED
;;TX INCOMPLETE
;;TX COMPLETE
;;TX UNKNOWN
;;TX IN PROGRESS
BDM20P10 ; IHS/CMI/LAB - BDM V2.0 patch 10 environment check ; 29 Sep 2014 12:22 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**10**;JUN 14, 2007;Build 12
+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*9")
DO SORRY(2)
+9 ;
+10 QUIT
+11 ;
PRE ;
+1 SET DA=$ORDER(^DIC(19,"B","BDM M MAIN MENU",0))
+2 IF DA
SET DIE="^DIC(19,"
SET DR="1///Diabetes Audit Menu"
DO ^DIE
KILL DA,DIE,DR
+3 SET BDMX=0
FOR
SET BDMX=$ORDER(^BDMRECD(BDMX))
IF BDMX'=+BDMX
QUIT
SET DA=BDMX
SET DIK="^BDMRECD("
DO ^DIK
+4 SET BDMX=0
FOR
SET BDMX=$ORDER(^BDMDMTX(BDMX))
IF BDMX'=+BDMX
QUIT
SET DA=BDMX
SET DIK="^BDMDMTX("
DO ^DIK
+5 SET BDMX=0
FOR
SET BDMX=$ORDER(^BDMTAXS(BDMX))
IF BDMX'=+BDMX
QUIT
SET DA=BDMX
SET DIK="^BDMTAXS("
DO ^DIK
+6 SET BDMX=0
FOR
SET BDMX=$ORDER(^BDMSNME(BDMX))
IF BDMX'=+BDMX
QUIT
SET DA=BDMX
SET DIK="^BDMSMME("
DO ^DIK
+7 QUIT
POST ;
+1 ;rename insert
+2 SET DA=$ORDER(^BDMLETI("B","EXERCISE EDUCATION",0))
+3 IF DA
SET DIE="^BDMLETI("
SET DR=".01///PHYSICAL ACTIVITY EDUCATION"
DO ^DIE
KILL DIE,DA,DR
+4 SET DA=$ORDER(^BDMLETI("B","PNEUMO EDUCATION",0))
+5 IF DA
SET ^BDMLETI(DA,3,1,0)="This item will display the Pneumococcal education text."
+6 ;change letters
+7 SET X=0
FOR
SET X=$ORDER(^BDMLET(X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET Y=0
FOR
SET Y=$ORDER(^BDMLET(X,1,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+9 IF ^BDMLET(X,1,Y,0)["|EXERCISE EDUCATION|"!(^BDMLET(X,1,Y,0)["|exercise education|")
Begin DoDot:3
+10 SET Z=$PIECE(^BDMLET(X,1,Y,0),"|EXERCISE EDUCATION|",1)_"|PHYSICAL ACTIVITY EDUCATION|"_$PIECE(^BDMLET(X,1,Y,0),"|EXERCISE EDUCATION|",2)
+11 SET ^BDMLET(X,1,Y,0)=Z
End DoDot:3
End DoDot:2
End DoDot:1
+12 DO ^BDMDEX
+13 DO BMXPO
+14 ;CREATE DM AUDIT ANTIPLT/ANTICOAG RX taxonomy, copy DM AUDIT ANTIPLATELET THERAPY
+15 DO MEDTAX
+16 DO TBHLTH
+17 DO BUILDSML^BDMUTL(2017)
+18 QUIT
+19 ;
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 IF $PIECE(BDMSTAL,"*",3)=""
DO IMES
QUIT 1
+12 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BDMSTAL,"*",3)
+13 DO ^DIC
+14 SET BDMY=Y
+15 DO IMES
+16 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 ANTIPLT/ANTICOAG RX"
SET BDMPG="BDM,APCH,APCL"
DO DRUG1
+4 NEW BDMN,BDMO
+5 SET BDMN=$ORDER(^ATXAX("B","DM AUDIT ANTIPLT/ANTICOAG RX",0))
+6 SET BDMO=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+7 IF 'BDMO!('BDMN)
QUIT
+8 MERGE ^ATXAX(BDMN,21)=^ATXAX(BDMO,21)
+9 SET DA=BDMN
SET DIK="^ATXAX("
DO IX1^DIK
+10 QUIT
+11 ;
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 DO GUIEP^BMXPO(.RETVAL,BDMRPC_"|ATX")
+7 QUIT
+8 ;
BMXSCH ;--add the search template schema
+1 IF $ORDER(^BMXADO("B","CMI VIEW SORT TEMPLATE",0))
QUIT
+2 NEW FDA,FIENS,FERR
+3 SET FDA(90093.99,"+1,",.01)="CMI VIEW SORT TEMPLATE"
+4 SET FDA(90093.99,"+1,",.02)=.401
+5 SET FDA(90093.991,"+2,+1,",.01)=.01
+6 SET FDA(90093.991,"+2,+1,",.02)="T"
+7 SET FDA(90093.991,"+2,+1,",.03)=80
+8 SET FDA(90093.991,"+2,+1,",.04)="TEMPLATE"
+9 DO UPDATE^DIE("","FDA","FIENS","FERR(1)")
+10 QUIT
+11 ;
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 BDMDC=$ORDER(^ATXLAB("B",BDMX,0))
+2 ;taxonomy already exists
IF BDMDC
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 BDMDC=+Y
SET $PIECE(^ATXLAB(BDMDC,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(BDMDC,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BDMDC
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(BDMDC,41,"B",BDMPI))
QUIT
+5 SET X="`"_BDMPI
SET DIC="^ATXLAB("_BDMDC_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)
SET DA(1)=BDMDC
+6 DO ^DIC
+7 IF Y=-1
WRITE !,"updating package multiple for ",BDMPI," entry ",$PIECE(^ATXAX(BDMDC,0),U)," failed"
+8 KILL DIC,DA,Y,X
End DoDot:1
+9 QUIT
TBHLTH ;tb health factors taxonomy
+1 SET ATXFLG=1
+2 WRITE !,"Creating TB HF Taxonomy... "
+3 SET APCLDA=0
FOR
SET APCLDA=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",APCLDA))
IF APCLDA=""
QUIT
IF APCLDA
SET DA=APCLDA
SET DIK="^ATXAX("
DO ^DIK
KILL DA,DIK
+4 SET X="DM AUDIT TB HEALTH FACTORS"
SET DIC="^ATXAX("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9002226
DO ^DIC
KILL DIC,DIADD,DLAYGO,DA,DR,DO,D0
+5 IF Y=-1
WRITE !!,"ERROR IN CREATING DM AUDIT TB HLTH FACTORS TAX"
QUIT
+6 SET APCLTX=+Y
SET $PIECE(^ATXAX(APCLTX,0),U,2)="TB TX STATUS HLTH FACTORS"
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,8)=0
SET $PIECE(^(0),U,9)=DT
SET $PIECE(^(0),U,12)=78
SET $PIECE(^(0),U,13)=0
SET $PIECE(^(0),U,15)=9999999.64
+7 SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"
+8 SET APCLTEXT="TBHF"
FOR APCLX=1:1:10
SET X=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)
SET DIC="^AUTTHF("
SET DIC(0)="M"
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0
IF $PIECE(Y,U)>0
Begin DoDot:1
+9 SET ^ATXAX(APCLTX,21,APCLX,0)=+Y
SET $PIECE(^ATXAX(APCLTX,21,0),U,3)=APCLX
SET $PIECE(^(0),U,4)=APCLX
SET ^ATXAX(APCLTX,21,"AA",+Y,APCLX)=""
+10 QUIT
End DoDot:1
+11 SET DA=APCLTX
SET DIK="^ATXAX("
DO IX1^DIK
+12 QUIT
TBHF ;
+1 ;;TB - TX UNTREATED
+2 ;;TB - TX INCOMPLETE
+3 ;;TB - TX COMPLETE
+4 ;;TB - TX UNKNOWN
+5 ;;TB - TX IN PROGRESS
+6 ;;TX UNTREATED
+7 ;;TX INCOMPLETE
+8 ;;TX COMPLETE
+9 ;;TX UNKNOWN
+10 ;;TX IN PROGRESS
