BUDAENV ; IHS/CMI/LAB - environmental check 13 Jan 2013 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")'>"12.9" D SORRY(2)
Q
;
;
PRE ;
;ADD ALL OTHERS BACK IN
F DA=1:1:50 S DIK="^BUDQCNTL(" D ^DIK
F DA=1:1:50 S DIK="^BUDQIL(" D ^DIK
F DA=1:1:50 S DIK="^BUDQTFIV(" D ^DIK
F DA=1:1:50 S DIK="^BUDQTTA(" D ^DIK
F DA=1:1:50 S DIK="^BUDQLST2(" D ^DIK
Q
POST ;
;move site parameters from 04 to 05 on first time install only
I '$O(^BUDQSITE(0)) D
.S BUDX=0 F S BUDX=$O(^BUDRSITE(BUDX)) Q:BUDX'=+BUDX D
..M ^BUDQSITE(BUDX)=^BUDRSITE(BUDX)
..S DA=BUDX,DIK="^BUDQSITE(" D IX1^DIK
D ^BUDAX
;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
S BUDX="BUD LIPID LOWERING MEDS",BUDTAX="",BUDNDCT="BGPMU LIPID LOWERING NDCS" D DRUG1
S BUDX="BUD ANTIPLATELET MEDS",BUDTAX="",BUDNDCT="BGPMU IVD ANTIPLATELET NDCS" 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 D
..S G=0
..S C=$P($G(^PSDRUG(J,2)),U,4)
..I C]"",$D(^ATXAX(Z,21,"B",$$STRIP^XLFSTR(C,"-"))) S G=1
..I C]"",$D(^ATXAX(Z,21,"B",C)) S G=1
..Q:'G
..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
;
INC ;UPDATE INCOME LEVELS
S X=8 F S X=$O(^BUDQIL("B",X)) Q:X'=+X D
.S Y=$O(^BUDQIL("B",X,0))
.S C=X-8
.S $P(^BUDQIL(Y,0),U,2)=(C*4020)+39630
.S $P(^BUDQIL(Y,0),U,3)=(C*5030)+49560
.S $P(^BUDQIL(Y,0),U,4)=(C*4620)+45570
Q
BUDAENV ; IHS/CMI/LAB - environmental check 13 Jan 2013 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")'>"12.9"
DO SORRY(2)
+7 QUIT
+8 ;
+9 ;
PRE ;
+1 ;ADD ALL OTHERS BACK IN
+2 FOR DA=1:1:50
SET DIK="^BUDQCNTL("
DO ^DIK
+3 FOR DA=1:1:50
SET DIK="^BUDQIL("
DO ^DIK
+4 FOR DA=1:1:50
SET DIK="^BUDQTFIV("
DO ^DIK
+5 FOR DA=1:1:50
SET DIK="^BUDQTTA("
DO ^DIK
+6 FOR DA=1:1:50
SET DIK="^BUDQLST2("
DO ^DIK
+7 QUIT
POST ;
+1 ;move site parameters from 04 to 05 on first time install only
+2 IF '$ORDER(^BUDQSITE(0))
Begin DoDot:1
+3 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDRSITE(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:2
+4 MERGE ^BUDQSITE(BUDX)=^BUDRSITE(BUDX)
+5 SET DA=BUDX
SET DIK="^BUDQSITE("
DO IX1^DIK
End DoDot:2
End DoDot:1
+6 DO ^BUDAX
+7 ;create and populate drug taxonomy
+8 DO DRUG
+9 ;D LAB
+10 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 SET BUDX="BUD LIPID LOWERING MEDS"
SET BUDTAX=""
SET BUDNDCT="BGPMU LIPID LOWERING NDCS"
DO DRUG1
+6 SET BUDX="BUD ANTIPLATELET MEDS"
SET BUDTAX=""
SET BUDNDCT="BGPMU IVD ANTIPLATELET NDCS"
DO DRUG1
+7 KILL ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX
+8 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
Begin DoDot:2
+22 SET G=0
+23 SET C=$PIECE($GET(^PSDRUG(J,2)),U,4)
+24 IF C]""
IF $DATA(^ATXAX(Z,21,"B",$$STRIP^XLFSTR(C,"-")))
SET G=1
+25 IF C]""
IF $DATA(^ATXAX(Z,21,"B",C))
SET G=1
+26 IF 'G
QUIT
+27 IF $DATA(^ATXAX(BUDTX,21,"B",J))
QUIT
+28 SET BUDC=BUDC+1
SET ^ATXAX(BUDTX,21,BUDC,0)=J_U_J
End DoDot:2
End DoDot:1
+29 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+30 QUIT
+31 ;
INC ;UPDATE INCOME LEVELS
+1 SET X=8
FOR
SET X=$ORDER(^BUDQIL("B",X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$ORDER(^BUDQIL("B",X,0))
+3 SET C=X-8
+4 SET $PIECE(^BUDQIL(Y,0),U,2)=(C*4020)+39630
+5 SET $PIECE(^BUDQIL(Y,0),U,3)=(C*5030)+49560
+6 SET $PIECE(^BUDQIL(Y,0),U,4)=(C*4620)+45570
End DoDot:1
+7 QUIT
