BDMD9PS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;
;
MAIN ;EP
D DRUG,LAB,MENU ;LAB,LOINC,MENU
;D ^BDM8X
Q
;
DRUG ;EP set up drug taxonomies
S ATXFLG=1
S BDMX="DM AUDIT INCRETIN MIMETIC",BDMTAX="",BDMNDCT="" D DRUG1
S BDMX="DM AUDIT DPP4 INHIBITOR DRUGS",BDMTAX="",BDMNDCT="" D DRUG1
Q
DRUG1 ;
S BDMTX=$O(^ATXAX("B",BDMX,0))
I 'BDMTX D Q:Y=-1
.W !,"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,^ATXAX(BDMTX,21,0)="^9002226.02101A^0^0"
S DA=BDMTX,DIK="^ATXAX(" D IX1^DIK
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
;
LAB ;EP
S BDMX="DM AUDIT P/C RATIO TAX" D LAB1
Q
LAB1 ;
S BDMDA=$O(^ATXLAB("B",BDMX,0))
Q:BDMDA ;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 BDMTX=+Y,$P(^ATXLAB(BDMTX,0),U,2)=BDMX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60
S ^ATXLAB(BDMTX,21,0)="^9002228.02101PA^0^0"
S DA=BDMTX,DIK="^ATXAX(" D IX1^DIK
Q
;
LOINC ;EP
S BDMX="DM AUDIT P/C RATIO LOINC"
D LOINC1
Q
;
LOINC1 ;
S BDMDA=$O(^ATXAX("B",BDMX,0))
Q:BDMDA ;taxonomy already exisits
W !,"Creating ",BDMX," Taxonomy..."
S X=BDMX,DIC="^ATXAX(",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 BDMTX=+Y,$P(^ATXAX(BDMTX,0),U,2)=BDMX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="FIHS",$P(^(0),U,9)=95.3
S ^ATXAX(BDMTX,21,0)="^9002228.02101PA^0^0"
S DA=BDMTX,DIK="^ATXAX(" D IX1^DIK
Q
;
F BDMX="BDM DM2009 AUDIT MENU" D
.S BDMY="DM08"
.S X=$$ADD^XPDMENU("BDM M MAIN DM MENU",BDMX,BDMY,9)
Q
;
DELFL ;delete entries out of the file before reinstalling
F DA=1:1:40 S DIK="^BDMRECD(" D ^DIK
F DA=1:1:20 S DIK="^BDMDMTX(" D ^DIK
Q
;
BDMD9PS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;
+3 ;
MAIN ;EP
+1 ;LAB,LOINC,MENU
DO DRUG
DO LAB
DO MENU
+2 ;D ^BDM8X
+3 QUIT
+4 ;
DRUG ;EP set up drug taxonomies
+1 SET ATXFLG=1
+2 SET BDMX="DM AUDIT INCRETIN MIMETIC"
SET BDMTAX=""
SET BDMNDCT=""
DO DRUG1
+3 SET BDMX="DM AUDIT DPP4 INHIBITOR DRUGS"
SET BDMTAX=""
SET BDMNDCT=""
DO DRUG1
+4 QUIT
DRUG1 ;
+1 SET BDMTX=$ORDER(^ATXAX("B",BDMX,0))
+2 IF 'BDMTX
Begin DoDot:1
+3 WRITE !,"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 ^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 IF $GET(BDMTAX)]""
Begin DoDot:1
+9 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BDMTX,21,A))
IF A'=+A
QUIT
SET B=A
+10 SET BDMC=B
+11 SET ^ATXAX(BDMTX,21,0)="^9002226.02101A^"_B_U_B
+12 SET Z=$ORDER(^ATXAX("B",BDMTAX,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(BDMTX,21,"B",J))
QUIT
+15 SET BDMC=BDMC+1
SET ^ATXAX(BDMTX,21,BDMC,0)=J_U_J
End DoDot:2
End DoDot:1
+16 IF $GET(BDMNDCT)]""
Begin DoDot:1
+17 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BDMTX,21,A))
IF A'=+A
QUIT
SET B=A
+18 SET BDMC=B
+19 SET ^ATXAX(BDMTX,21,0)="^9002226.02101A^"_B_U_B
+20 SET Z=$ORDER(^ATXAX("B",BDMNDCT,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(BDMTX,21,"B",J))
QUIT
+23 SET BDMC=BDMC+1
SET ^ATXAX(BDMTX,21,BDMC,0)=J_U_J
End DoDot:2
End DoDot:1
+24 SET DA=BDMTX
SET DIK="^ATXAX("
DO IX1^DIK
+25 QUIT
+26 ;
LAB ;EP
+1 SET BDMX="DM AUDIT P/C RATIO TAX"
DO LAB1
+2 QUIT
LAB1 ;
+1 SET BDMDA=$ORDER(^ATXLAB("B",BDMX,0))
+2 ;taxonomy already exists
IF BDMDA
QUIT
+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 BDMTX=+Y
SET $PIECE(^ATXLAB(BDMTX,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
+7 SET ^ATXLAB(BDMTX,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BDMTX
SET DIK="^ATXAX("
DO IX1^DIK
+9 QUIT
+10 ;
LOINC ;EP
+1 SET BDMX="DM AUDIT P/C RATIO LOINC"
+2 DO LOINC1
+3 QUIT
+4 ;
LOINC1 ;
+1 SET BDMDA=$ORDER(^ATXAX("B",BDMX,0))
+2 ;taxonomy already exisits
IF BDMDA
QUIT
+3 WRITE !,"Creating ",BDMX," Taxonomy..."
+4 SET X=BDMX
SET DIC="^ATXAX("
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 BDMTX=+Y
SET $PIECE(^ATXAX(BDMTX,0),U,2)=BDMX
SET $PIECE(^(0),U,5)=DUZ
SET $PIECE(^(0),U,6)=DT
SET $PIECE(^(0),U,8)="FIHS"
SET $PIECE(^(0),U,9)=95.3
+7 SET ^ATXAX(BDMTX,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BDMTX
SET DIK="^ATXAX("
DO IX1^DIK
+9 QUIT
+10 ;
+1 FOR BDMX="BDM DM2009 AUDIT MENU"
Begin DoDot:1
+2 SET BDMY="DM08"
+3 SET X=$$ADD^XPDMENU("BDM M MAIN DM MENU",BDMX,BDMY,9)
End DoDot:1
+4 QUIT
+5 ;
DELFL ;delete entries out of the file before reinstalling
+1 FOR DA=1:1:40
SET DIK="^BDMRECD("
DO ^DIK
+2 FOR DA=1:1:20
SET DIK="^BDMDMTX("
DO ^DIK
+3 QUIT
+4 ;
