BUD6ENV ; 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
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
I '$$INSTALLD("AICD*3.51*7") D SORRY(2)
I '$D(^DIC(9.4,"C","LEX")) D SORRY(2)
Q
;
;
PRE ;
F DA=1:1:50 S DIK="^BUDVCNTL(" D ^DIK
F DA=1:1:50 S DIK="^BUDVIL(" D ^DIK
F DA=1:1:50 S DIK="^BUDVFIV(" D ^DIK
F DA=1:1:50 S DIK="^BUDVTTA(" D ^DIK
F DA=1:1:50 S DIK="^BUDSCNTL(" D ^DIK
F DA=1:1:50 S DIK="^BUDSIL(" D ^DIK
F DA=1:1:50 S DIK="^BUDSFIV(" D ^DIK
F DA=1:1:50 S DIK="^BUDSTTA(" D ^DIK
Q
POST ;
;move site parameters from 04 to 05 on first time install only
I '$O(^BUDSSITE(0)) D
.S BUDX=0 F S BUDX=$O(^BUDVSITE(BUDX)) Q:BUDX'=+BUDX D
..M ^BUDSSITE(BUDX)=^BUDVSITE(BUDX)
..S DA=BUDX,DIK="^BUDSSITE(" D IX1^DIK
D ^BUD6TX
LAB ;
S BUDX="BGP PAP SMEAR TAX" D LAB1
S BUDX="BGP 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
LABTAX ;
;;BGP HIV TEST TAX|0|BUD
;;BGP PAP SMEAR TAX|0|BUD
;;
TAX ;
;;BUD CPT HIV TESTS|1|BUD
;;BUD CPT PAP 05|1|BUD
;;BGP HIV TEST LOINC CODES|1|BUD
;;BGP PAP LOINC CODES|1|BUD
;;BUD IMM CPTS|1|BUD
;;BUD L26 CPTS|1|BUD
;;
BUD6ENV ; 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 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+5 IF '$$INSTALLD("AICD*3.51*7")
DO SORRY(2)
+6 IF '$DATA(^DIC(9.4,"C","LEX"))
DO SORRY(2)
+7 QUIT
+8 ;
+9 ;
PRE ;
+1 FOR DA=1:1:50
SET DIK="^BUDVCNTL("
DO ^DIK
+2 FOR DA=1:1:50
SET DIK="^BUDVIL("
DO ^DIK
+3 FOR DA=1:1:50
SET DIK="^BUDVFIV("
DO ^DIK
+4 FOR DA=1:1:50
SET DIK="^BUDVTTA("
DO ^DIK
+5 FOR DA=1:1:50
SET DIK="^BUDSCNTL("
DO ^DIK
+6 FOR DA=1:1:50
SET DIK="^BUDSIL("
DO ^DIK
+7 FOR DA=1:1:50
SET DIK="^BUDSFIV("
DO ^DIK
+8 FOR DA=1:1:50
SET DIK="^BUDSTTA("
DO ^DIK
+9 QUIT
POST ;
+1 ;move site parameters from 04 to 05 on first time install only
+2 IF '$ORDER(^BUDSSITE(0))
Begin DoDot:1
+3 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDVSITE(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:2
+4 MERGE ^BUDSSITE(BUDX)=^BUDVSITE(BUDX)
+5 SET DA=BUDX
SET DIK="^BUDSSITE("
DO IX1^DIK
End DoDot:2
End DoDot:1
+6 DO ^BUD6TX
LAB ;
+1 SET BUDX="BGP PAP SMEAR TAX"
DO LAB1
+2 SET BUDX="BGP 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
LABTAX ;
+1 ;;BGP HIV TEST TAX|0|BUD
+2 ;;BGP PAP SMEAR TAX|0|BUD
+3 ;;
TAX ;
+1 ;;BUD CPT HIV TESTS|1|BUD
+2 ;;BUD CPT PAP 05|1|BUD
+3 ;;BGP HIV TEST LOINC CODES|1|BUD
+4 ;;BGP PAP LOINC CODES|1|BUD
+5 ;;BUD IMM CPTS|1|BUD
+6 ;;BUD L26 CPTS|1|BUD
+7 ;;
