BUD1ENV ; IHS/CMI/LAB - environmental check 13 Jan 2011 7:22 AM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
ENV ;
; 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 $$VERSION^XPDUTL("BJPC")'="2.0" D SORRY(2)
I $$VERSION^XPDUTL("BGP")'>"9.0" D SORRY(2)
;I '$D(^DIC(9.4,"C","LEX")) D MES^XPDUTL($$CJ^XLFSTR("Lexicon is *NOT* installed.",IOM)) D SORRY(2)
Q
;
;
PRE ;
;ADD ALL OTHERS BACK IN
F DA=1:1:50 S DIK="^BUDLCNTL(" D ^DIK
F DA=1:1:50 S DIK="^BUDLIL(" D ^DIK
F DA=1:1:50 S DIK="^BUDLTFIV(" D ^DIK
F DA=1:1:50 S DIK="^BUDLTTA(" D ^DIK
Q
POST ;
;move site parameters from 04 to 05 on first time install only
I '$O(^BUDLSITE(0)) D
.S BUDX=0 F S BUDX=$O(^BUDTSITE(BUDX)) Q:BUDX'=+BUDX D
..M ^BUDLSITE(BUDX)=^BUDTSITE(BUDX)
..S DA=BUDX,DIK="^BUDLSITE(" D IX1^DIK
D ^BUD1Z
D ^BUD1Y
;create and populate drug taxonomy
D DRUG
D LAB
Q
LAB ;EP
S BUDX="BUD HEPATITIS B TESTS" D LAB1
S BUDX="BUD HEPATITIS C TESTS" D LAB1
Q
LAB1 ;
S BUDDA=$O(^ATXLAB("B",BUDX,0))
Q:BUDDA ;taxonomy already exisits
W !,"Creating ",BUDX," Taxonomy..."
S X=BUDX,DIC="^ATXLAB(",DIC(0)="L",DIADD=1,DLAYGO=9002228 D ^DIC K DIC,DA,DIADD,DLAYGO,I
I Y=-1 W !!,"ERROR IN CREATING ",BUDX," TAX" Q
S BUDTX=+Y,$P(^ATXLAB(BUDTX,0),U,2)=BUDX,$P(^(0),U,5)=DUZ,$P(^(0),U,6)=DT,$P(^(0),U,8)="B",$P(^(0),U,9)=60
S ^ATXLAB(BUDTX,21,0)="^9002228.02101PA^0^0"
S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK
Q
;
INSTALLD(BUDSTAL) ;EP - Determine if patch BUDSTAL was installed, where
; BUDSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BUDY,DIC,X,Y
S X=$P(BUDSTAL,"*",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(BUDSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BUDSTAL,"*",3)
D ^DIC
S BUDY=Y
D IMES
Q $S(BUDY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BUDSTAL_""" 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
DRUG ;EP set up drug taxonomies
S ATXFLG=1
S BUDX="BUD DIABETES MEDS TAX",BUDTAX="",BUDNDCT="BUD DIABETES MEDS NDC" D DRUG1
S BUDX="BGP PQA CONTROLLER MEDS",BUDTAX="",BUDNDCT="BGP PQA CONTROLLER NDC" D DRUG1
S BUDX="BGP PQA SABA MEDS",BUDTAX="",BUDNDCT="BGP PQA SABA NDC" D DRUG1
K ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX
Q
DRUG1 ;
W !,"Creating ",BUDX," Taxonomy..."
S BUDTX=$O(^ATXAX("B",BUDX,0))
I 'BUDTX D Q:Y=-1
.S X=BUDX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I
.I Y=-1 W !!,"ERROR IN CREATING ",BUDX," TAX" Q
.S BUDTX=+Y,$P(^ATXAX(BUDTX,0),U,2)=BUDX,$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(BUDTX,21,0)="^9002226.02101A^0^0"
S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK
I $G(BUDTAX)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BUDTX,21,A)) Q:A'=+A S B=A
.S BUDC=B
.S ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BUDTAX,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(BUDTX,21,"B",J))
..S BUDC=BUDC+1,^ATXAX(BUDTX,21,BUDC,0)=J_U_J
I $G(BUDNDCT)]"" D
.S A=0,B="" F S A=$O(^ATXAX(BUDTX,21,A)) Q:A'=+A S B=A
.S BUDC=B
.S ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
.S Z=$O(^ATXAX("B",BUDNDCT,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(BUDTX,21,"B",J))
..S BUDC=BUDC+1,^ATXAX(BUDTX,21,BUDC,0)=J_U_J
S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK
Q
;
BUD1ENV ; IHS/CMI/LAB - environmental check 13 Jan 2011 7:22 AM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
ENV ;
+1 ; The following line prevents the "Disable Options..." and "Move
+2 ; Routines..." questions from being asked during the install.
+3 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+4 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+5 IF $$VERSION^XPDUTL("BJPC")'="2.0"
DO SORRY(2)
+6 IF $$VERSION^XPDUTL("BGP")'>"9.0"
DO SORRY(2)
+7 ;I '$D(^DIC(9.4,"C","LEX")) D MES^XPDUTL($$CJ^XLFSTR("Lexicon is *NOT* installed.",IOM)) D SORRY(2)
+8 QUIT
+9 ;
+10 ;
PRE ;
+1 ;ADD ALL OTHERS BACK IN
+2 FOR DA=1:1:50
SET DIK="^BUDLCNTL("
DO ^DIK
+3 FOR DA=1:1:50
SET DIK="^BUDLIL("
DO ^DIK
+4 FOR DA=1:1:50
SET DIK="^BUDLTFIV("
DO ^DIK
+5 FOR DA=1:1:50
SET DIK="^BUDLTTA("
DO ^DIK
+6 QUIT
POST ;
+1 ;move site parameters from 04 to 05 on first time install only
+2 IF '$ORDER(^BUDLSITE(0))
Begin DoDot:1
+3 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDTSITE(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:2
+4 MERGE ^BUDLSITE(BUDX)=^BUDTSITE(BUDX)
+5 SET DA=BUDX
SET DIK="^BUDLSITE("
DO IX1^DIK
End DoDot:2
End DoDot:1
+6 DO ^BUD1Z
+7 DO ^BUD1Y
+8 ;create and populate drug taxonomy
+9 DO DRUG
+10 DO LAB
+11 QUIT
LAB ;EP
+1 SET BUDX="BUD HEPATITIS B TESTS"
DO LAB1
+2 SET BUDX="BUD HEPATITIS C TESTS"
DO LAB1
+3 QUIT
LAB1 ;
+1 SET BUDDA=$ORDER(^ATXLAB("B",BUDX,0))
+2 ;taxonomy already exisits
IF BUDDA
QUIT
+3 WRITE !,"Creating ",BUDX," Taxonomy..."
+4 SET X=BUDX
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 ",BUDX," TAX"
QUIT
+6 SET BUDTX=+Y
SET $PIECE(^ATXLAB(BUDTX,0),U,2)=BUDX
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(BUDTX,21,0)="^9002228.02101PA^0^0"
+8 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+9 QUIT
+10 ;
INSTALLD(BUDSTAL) ;EP - Determine if patch BUDSTAL was installed, where
+1 ; BUDSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BUDY,DIC,X,Y
+4 SET X=$PIECE(BUDSTAL,"*",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(BUDSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BUDSTAL,"*",3)
+12 DO ^DIC
+13 SET BUDY=Y
+14 DO IMES
+15 QUIT $SELECT(BUDY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BUDSTAL_""" 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
DRUG ;EP set up drug taxonomies
+1 SET ATXFLG=1
+2 SET BUDX="BUD DIABETES MEDS TAX"
SET BUDTAX=""
SET BUDNDCT="BUD DIABETES MEDS NDC"
DO DRUG1
+3 SET BUDX="BGP PQA CONTROLLER MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP PQA CONTROLLER NDC"
DO DRUG1
+4 SET BUDX="BGP PQA SABA MEDS"
SET BUDTAX=""
SET BUDNDCT="BGP PQA SABA NDC"
DO DRUG1
+5 KILL ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX
+6 QUIT
DRUG1 ;
+1 WRITE !,"Creating ",BUDX," Taxonomy..."
+2 SET BUDTX=$ORDER(^ATXAX("B",BUDX,0))
+3 IF 'BUDTX
Begin DoDot:1
+4 SET X=BUDX
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 ",BUDX," TAX"
QUIT
+6 SET BUDTX=+Y
SET $PIECE(^ATXAX(BUDTX,0),U,2)=BUDX
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(BUDTX,21,0)="^9002226.02101A^0^0"
End DoDot:1
IF Y=-1
QUIT
+7 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+8 IF $GET(BUDTAX)]""
Begin DoDot:1
+9 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BUDTX,21,A))
IF A'=+A
QUIT
SET B=A
+10 SET BUDC=B
+11 SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
+12 SET Z=$ORDER(^ATXAX("B",BUDTAX,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(BUDTX,21,"B",J))
QUIT
+15 SET BUDC=BUDC+1
SET ^ATXAX(BUDTX,21,BUDC,0)=J_U_J
End DoDot:2
End DoDot:1
+16 IF $GET(BUDNDCT)]""
Begin DoDot:1
+17 SET A=0
SET B=""
FOR
SET A=$ORDER(^ATXAX(BUDTX,21,A))
IF A'=+A
QUIT
SET B=A
+18 SET BUDC=B
+19 SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B
+20 SET Z=$ORDER(^ATXAX("B",BUDNDCT,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(BUDTX,21,"B",J))
QUIT
+23 SET BUDC=BUDC+1
SET ^ATXAX(BUDTX,21,BUDC,0)=J_U_J
End DoDot:2
End DoDot:1
+24 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+25 QUIT
+26 ;
