BUD4ENV ; IHS/CMI/LAB - environmental check ;
;;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
I '$$INSTALLD("BGP*9.0*1") D SORRY(2)
I $$VERSION^XPDUTL("BJPC")'="2.0" W !,"version 2.0 of BJPC is required" D SORRY(2)
Q
;
;
PRE ;
F DA=1:1:50 S DIK="^BUDFCNTL(" D ^DIK
F DA=1:1:50 S DIK="^BUDFIL(" D ^DIK
F DA=1:1:50 S DIK="^BUDFFIV(" D ^DIK
F DA=1:1:50 S DIK="^BUDFTTA(" D ^DIK
Q
POST ;
;move site parameters from 03 to 04 on first time install only
I '$O(^BUDFSITE(0)) D
.S BUDX=0 F S BUDX=$O(^BUDFSITE(BUDX)) Q:BUDX'=+BUDX D
..M ^BUDFSITE(BUDX)=^BUDFSITE(BUDX)
..S DA=BUDX,DIK="^BUDFSITE(" D IX1^DIK
D ^BUDTX
D ^BUD4TX
LAB ;
S BUDX="BUD PAP SMEAR TAX" D LAB1
S BUDX="BUD HIV TEST TAX" D LAB1
D SETTAX
D SETTAXL
Q
LAB1 ;
W !,"Creating ",BUDX," Taxonomy..."
S BUDDA=$O(^ATXLAB("B",BUDX,0))
Q:BUDDA ;taxonomy already exisits
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,^ATXLAB(BUDTX,21,0)="^9002228.02101PA^0^0"
S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK
Q
SETTAX ;
Q:'$D(^DD(9002226,4101,0)) ;taxonomy patch not yet installed
S BUDTEXT="TAX" F BUDX=1:1 S BUDDATA=$P($T(@BUDTEXT+BUDX),";;",2) Q:BUDDATA="" D
.S BUDDA=$O(^ATXAX("B",$P(BUDDATA,"|"),0))
.Q:BUDDA=""
.S $P(^ATXAX(BUDDA,0),U,4)="n" W !,$P(BUDDATA,"|") ;SET NO DELETE
.S $P(^ATXAX(BUDDA,0),U,22)=$P(BUDDATA,"|",2) ;set read only
.;set packages in multiple
.K DIC,DA,DR
.S BUDP=$P(BUDDATA,"|",3)
.F BUDN=1:1 S BUDPP=$P(BUDP,"*",BUDN) Q:BUDPP="" D
..S BUDPI=$O(^DIC(9.4,"C",BUDPP,0))
..Q:BUDPI="" ;NO PACKAGE
..S X="`"_BUDPI,DIC="^ATXAX("_BUDDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002226,4101,0),U,2),DA(1)=BUDDA
..D ^DIC
..I Y=-1 W !,"updating package multiple for ",BUDPP," entry ",$P(^ATXAX(BUDDA,0),U)," failed"
..K DIC,DA,Y,X
.Q
Q
SETTAXL ;
Q:'$D(^DD(9002228,4101,0)) ;taxonomy patch not yet installed
S BUDTEXT="LABTAX" F BUDX=1:1 S BUDDATA=$P($T(@BUDTEXT+BUDX),";;",2) Q:BUDDATA="" D
.S BUDDA=$O(^ATXLAB("B",$P(BUDDATA,"|"),0))
.Q:BUDDA=""
.S $P(^ATXLAB(BUDDA,0),U,4)="n" W !,$P(BUDDATA,"|") ;SET NO DELETE
.S $P(^ATXLAB(BUDDA,0),U,22)=$P(BUDDATA,"|",2) ;set read only
.;set packages in multiple
.K DIC,DA,DR
.S BUDP=$P(BUDDATA,"|",3)
.F BUDN=1:1 S BUDPP=$P(BUDP,"*",BUDN) Q:BUDPP="" D
..S BUDPI=$O(^DIC(9.4,"C",BUDPP,0))
..Q:BUDPI="" ;NO PACKAGE
..S X="`"_BUDPI,DIC="^ATXLAB("_BUDDA_",41,",DIC(0)="L",DIC("P")=$P(^DD(9002228,4101,0),U,2),DA(1)=BUDDA
..D ^DIC
..I Y=-1 W !,"updating package multiple for ",BUDPP," entry ",$P(^ATXLAB(BUDDA,0),U)," failed"
..K DIC,DA,Y,X
.Q
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
Q
LABTAX ;
;;BUD HIV TEST TAX|0|BUD
;;BUD PAP SMEAR TAX|0|BUD
;;
TAX ;
;;BUD CPT HIV TESTS|1|BUD
;;BUD CPT PAP 04|1|BUD
;;BUD HIV TEST LOINC CODES|1|BUD
;;BUD PAP LOINC CODES|1|BUD
;;BUD IMM CPTS|1|BUD
;;BUD L26 CPTS|1|BUD
;;
BUD4ENV ; IHS/CMI/LAB - environmental check ;
+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 IF '$$INSTALLD("BGP*9.0*1")
DO SORRY(2)
+5 IF $$VERSION^XPDUTL("BJPC")'="2.0"
WRITE !,"version 2.0 of BJPC is required"
DO SORRY(2)
+6 QUIT
+7 ;
+8 ;
PRE ;
+1 FOR DA=1:1:50
SET DIK="^BUDFCNTL("
DO ^DIK
+2 FOR DA=1:1:50
SET DIK="^BUDFIL("
DO ^DIK
+3 FOR DA=1:1:50
SET DIK="^BUDFFIV("
DO ^DIK
+4 FOR DA=1:1:50
SET DIK="^BUDFTTA("
DO ^DIK
+5 QUIT
POST ;
+1 ;move site parameters from 03 to 04 on first time install only
+2 IF '$ORDER(^BUDFSITE(0))
Begin DoDot:1
+3 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDFSITE(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:2
+4 MERGE ^BUDFSITE(BUDX)=^BUDFSITE(BUDX)
+5 SET DA=BUDX
SET DIK="^BUDFSITE("
DO IX1^DIK
End DoDot:2
End DoDot:1
+6 DO ^BUDTX
+7 DO ^BUD4TX
LAB ;
+1 SET BUDX="BUD PAP SMEAR TAX"
DO LAB1
+2 SET BUDX="BUD HIV TEST TAX"
DO LAB1
+3 DO SETTAX
+4 DO SETTAXL
+5 QUIT
LAB1 ;
+1 WRITE !,"Creating ",BUDX," Taxonomy..."
+2 SET BUDDA=$ORDER(^ATXLAB("B",BUDX,0))
+3 ;taxonomy already exisits
IF BUDDA
QUIT
+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
SET ^ATXLAB(BUDTX,21,0)="^9002228.02101PA^0^0"
+7 SET DA=BUDTX
SET DIK="^ATXAX("
DO IX1^DIK
+8 QUIT
SETTAX ;
+1 ;taxonomy patch not yet installed
IF '$DATA(^DD(9002226,4101,0))
QUIT
+2 SET BUDTEXT="TAX"
FOR BUDX=1:1
SET BUDDATA=$PIECE($TEXT(@BUDTEXT+BUDX),";;",2)
IF BUDDATA=""
QUIT
Begin DoDot:1
+3 SET BUDDA=$ORDER(^ATXAX("B",$PIECE(BUDDATA,"|"),0))
+4 IF BUDDA=""
QUIT
+5 ;SET NO DELETE
SET $PIECE(^ATXAX(BUDDA,0),U,4)="n"
WRITE !,$PIECE(BUDDATA,"|")
+6 ;set read only
SET $PIECE(^ATXAX(BUDDA,0),U,22)=$PIECE(BUDDATA,"|",2)
+7 ;set packages in multiple
+8 KILL DIC,DA,DR
+9 SET BUDP=$PIECE(BUDDATA,"|",3)
+10 FOR BUDN=1:1
SET BUDPP=$PIECE(BUDP,"*",BUDN)
IF BUDPP=""
QUIT
Begin DoDot:2
+11 SET BUDPI=$ORDER(^DIC(9.4,"C",BUDPP,0))
+12 ;NO PACKAGE
IF BUDPI=""
QUIT
+13 SET X="`"_BUDPI
SET DIC="^ATXAX("_BUDDA_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002226,4101,0),U,2)
SET DA(1)=BUDDA
+14 DO ^DIC
+15 IF Y=-1
WRITE !,"updating package multiple for ",BUDPP," entry ",$PIECE(^ATXAX(BUDDA,0),U)," failed"
+16 KILL DIC,DA,Y,X
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
SETTAXL ;
+1 ;taxonomy patch not yet installed
IF '$DATA(^DD(9002228,4101,0))
QUIT
+2 SET BUDTEXT="LABTAX"
FOR BUDX=1:1
SET BUDDATA=$PIECE($TEXT(@BUDTEXT+BUDX),";;",2)
IF BUDDATA=""
QUIT
Begin DoDot:1
+3 SET BUDDA=$ORDER(^ATXLAB("B",$PIECE(BUDDATA,"|"),0))
+4 IF BUDDA=""
QUIT
+5 ;SET NO DELETE
SET $PIECE(^ATXLAB(BUDDA,0),U,4)="n"
WRITE !,$PIECE(BUDDATA,"|")
+6 ;set read only
SET $PIECE(^ATXLAB(BUDDA,0),U,22)=$PIECE(BUDDATA,"|",2)
+7 ;set packages in multiple
+8 KILL DIC,DA,DR
+9 SET BUDP=$PIECE(BUDDATA,"|",3)
+10 FOR BUDN=1:1
SET BUDPP=$PIECE(BUDP,"*",BUDN)
IF BUDPP=""
QUIT
Begin DoDot:2
+11 SET BUDPI=$ORDER(^DIC(9.4,"C",BUDPP,0))
+12 ;NO PACKAGE
IF BUDPI=""
QUIT
+13 SET X="`"_BUDPI
SET DIC="^ATXLAB("_BUDDA_",41,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9002228,4101,0),U,2)
SET DA(1)=BUDDA
+14 DO ^DIC
+15 IF Y=-1
WRITE !,"updating package multiple for ",BUDPP," entry ",$PIECE(^ATXLAB(BUDDA,0),U)," failed"
+16 KILL DIC,DA,Y,X
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
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
+6 QUIT
LABTAX ;
+1 ;;BUD HIV TEST TAX|0|BUD
+2 ;;BUD PAP SMEAR TAX|0|BUD
+3 ;;
TAX ;
+1 ;;BUD CPT HIV TESTS|1|BUD
+2 ;;BUD CPT PAP 04|1|BUD
+3 ;;BUD HIV TEST LOINC CODES|1|BUD
+4 ;;BUD PAP LOINC CODES|1|BUD
+5 ;;BUD IMM CPTS|1|BUD
+6 ;;BUD L26 CPTS|1|BUD
+7 ;;
