APCLD8PS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;
MAIN ;EP
D DRUG,LAB,MENU ;LAB,LOINC,MENU
D ^APCL8X
Q
;
DRUG ;EP set up drug taxonomies
S ATXFLG=1
S APCLX="DM AUDIT INCRETIN MIMETIC",APCLTAX="",APCLNDCT="" D DRUG1
S APCLX="DM AUDIT DPP4 INHIBITOR DRUGS",APCLTAX="",APCLNDCT="" D DRUG1
Q
DRUG1 ;
S APCLTX=$O(^ATXAX("B",APCLX,0))
I 'APCLTX D Q:Y=-1
.W !,"Creating ",APCLX," Taxonomy..."
.S X=APCLX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
.I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q
.S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)=APCLX,$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(APCLTX,21,0)="^9002226.02101A^0^0"
S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK
I $G(APCLTAX)]"" D
.S A=0,B="" F S A=$O(^ATXAX(APCLTX,21,A)) Q:A'=+A S B=A
.S APCLC=B
.S ^ATXAX(APCLTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",APCLTAX,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(APCLTX,21,"B",J))
..S APCLC=APCLC+1,^ATXAX(APCLTX,21,APCLC,0)=J_U_J
I $G(APCLNDCT)]"" D
.S A=0,B="" F S A=$O(^ATXAX(APCLTX,21,A)) Q:A'=+A S B=A
.S APCLC=B
.S ^ATXAX(APCLTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",APCLNDCT,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(APCLTX,21,"B",J))
..S APCLC=APCLC+1,^ATXAX(APCLTX,21,APCLC,0)=J_U_J
S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK
Q
;
LAB ;EP
S APCLX="DM AUDIT P/C RATIO TAX" D LAB1
Q
LAB1 ;
S APCLDA=$O(^ATXLAB("B",APCLX,0))
Q:APCLDA ;taxonomy already exists
W !,"Creating ",APCLX," Taxonomy..."
S X=APCLX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q
S APCLTX=+Y,$P(^ATXLAB(APCLTX,0),U,2)=APCLX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60
S ^ATXLAB(APCLTX,21,0)="^9002228.02101PA^0^0"
S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK
Q
;
LOINC ;EP
S APCLX="DM AUDIT P/C RATIO LOINC"
D LOINC1
Q
;
LOINC1 ;
S APCLDA=$O(^ATXAX("B",APCLX,0))
Q:APCLDA ;taxonomy already exisits
W !,"Creating ",APCLX," Taxonomy..."
S X=APCLX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",APCLX," TAX" Q
S APCLTX=+Y,$P(^ATXAX(APCLTX,0),U,2)=APCLX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="FIHS",$P(^(0),U,9)=95.3
S ^ATXAX(APCLTX,21,0)="^9002228.02101PA^0^0"
S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK
Q
;
F APCLX="APCL DM2008 AUDIT MENU" D
.S APCLY="DM08"
.S X=$$ADD^XPDMENU("APCL M MAIN DM MENU",APCLX,APCLY,9)
Q
;
DELFL ;delete entries out of the file before reinstalling
F DA=1:1:40 S DIK="^APCLRECD(" D ^DIK
F DA=1:1:20 S DIK="^APCLDMTX(" D ^DIK
Q
;
APCLD8PS ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;
MAIN ;EP
+1 ;LAB,LOINC,MENU
DO DRUG
DO LAB
DO MENU
+2 DO ^APCL8X
+3 QUIT
+4 ;
DRUG ;EP set up drug taxonomies
+1 SET ATXFLG=1
+2 SET APCLX="DM AUDIT INCRETIN MIMETIC"
SET APCLTAX=""
SET APCLNDCT=""
DO DRUG1
+3 SET APCLX="DM AUDIT DPP4 INHIBITOR DRUGS"
SET APCLTAX=""
SET APCLNDCT=""
DO DRUG1
+4 QUIT
DRUG1 ;
+1 SET APCLTX=$ORDER(^ATXAX("B",APCLX,0))
+2 IF 'APCLTX
Begin DoDot:1
+3 WRITE !,"Creating ",APCLX," Taxonomy..."
+4 SET X=APCLX
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 ",APCLX," TAX"
QUIT
+6 SET APCLTX=+Y
SET $PIECE(^ATXAX(APCLTX,0),U,2)=APCLX
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(APCLTX,21,0)="^9002226.02101A^0^0"
End DoDot:1
IF Y=-1
QUIT
+7 SET DA=APCLTX
SET DIK="^ATXAX("
DO IX1^DIK
+8 IF $GET(APCLTAX)]""
Begin DoDot:1
+9 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(APCLTX,21,A))
IF A'=+A
QUIT
SET B=A
+10 SET APCLC=B
+11 SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^"_B_U_B
+12 SET Z=$ORDER(^ATXAX("B",APCLTAX,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(APCLTX,21,"B",J))
QUIT
+15 SET APCLC=APCLC+1
SET ^ATXAX(APCLTX,21,APCLC,0)=J_U_J
End DoDot:2
End DoDot:1
+16 IF $GET(APCLNDCT)]""
Begin DoDot:1
+17 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(APCLTX,21,A))
IF A'=+A
QUIT
SET B=A
+18 SET APCLC=B
+19 SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^"_B_U_B
+20 SET Z=$ORDER(^ATXAX("B",APCLNDCT,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(APCLTX,21,"B",J))
QUIT
+23 SET APCLC=APCLC+1
SET ^ATXAX(APCLTX,21,APCLC,0)=J_U_J
End DoDot:2
End DoDot:1
+24 SET DA=APCLTX
SET DIK="^ATXAX("
DO IX1^DIK
+25 QUIT
+26 ;
LAB ;EP
+1 SET APCLX="DM AUDIT P/C RATIO TAX"
DO LAB1
+2 QUIT
LAB1 ;
+1 SET APCLDA=$ORDER(^ATXLAB("B",APCLX,0))
+2 ;taxonomy already exists
IF APCLDA
QUIT
+3 WRITE !,"Creating ",APCLX," Taxonomy..."
+4 SET X=APCLX
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 ",APCLX," TAX"
QUIT
+6 SET APCLTX=+Y
SET $PIECE(^ATXLAB(APCLTX,0),U,2)=APCLX
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(APCLTX,21,0)="^9002228.02101PA^0^0"
+8 SET DA=APCLTX
SET DIK="^ATXAX("
DO IX1^DIK
+9 QUIT
+10 ;
LOINC ;EP
+1 SET APCLX="DM AUDIT P/C RATIO LOINC"
+2 DO LOINC1
+3 QUIT
+4 ;
LOINC1 ;
+1 SET APCLDA=$ORDER(^ATXAX("B",APCLX,0))
+2 ;taxonomy already exisits
IF APCLDA
QUIT
+3 WRITE !,"Creating ",APCLX," Taxonomy..."
+4 SET X=APCLX
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 ",APCLX," TAX"
QUIT
+6 SET APCLTX=+Y
SET $PIECE(^ATXAX(APCLTX,0),U,2)=APCLX
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(APCLTX,21,0)="^9002228.02101PA^0^0"
+8 SET DA=APCLTX
SET DIK="^ATXAX("
DO IX1^DIK
+9 QUIT
+10 ;
+1 FOR APCLX="APCL DM2008 AUDIT MENU"
Begin DoDot:1
+2 SET APCLY="DM08"
+3 SET X=$$ADD^XPDMENU("APCL M MAIN DM MENU",APCLX,APCLY,9)
End DoDot:1
+4 QUIT
+5 ;
DELFL ;delete entries out of the file before reinstalling
+1 FOR DA=1:1:40
SET DIK="^APCLRECD("
DO ^DIK
+2 FOR DA=1:1:20
SET DIK="^APCLDMTX("
DO ^DIK
+3 QUIT
+4 ;
