BUD5ENV ; 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
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
Q
POST ;
;move site parameters from 04 to 05 on first time install only
I '$O(^BUDVSITE(0)) D
.S BUDX=0 F S BUDX=$O(^BUDFSITE(BUDX)) Q:BUDX'=+BUDX D
..M ^BUDVSITE(BUDX)=^BUDFSITE(BUDX)
..S DA=BUDX,DIK="^BUDVSITE(" D IX1^DIK
D ^BUD5TX
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
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
;;
BUD5ENV ; 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 QUIT
+6 ;
+7 ;
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 QUIT
POST ;
+1 ;move site parameters from 04 to 05 on first time install only
+2 IF '$ORDER(^BUDVSITE(0))
Begin DoDot:1
+3 SET BUDX=0
FOR
SET BUDX=$ORDER(^BUDFSITE(BUDX))
IF BUDX'=+BUDX
QUIT
Begin DoDot:2
+4 MERGE ^BUDVSITE(BUDX)=^BUDFSITE(BUDX)
+5 SET DA=BUDX
SET DIK="^BUDVSITE("
DO IX1^DIK
End DoDot:2
End DoDot:1
+6 DO ^BUD5TX
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
+19 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 ;;
