BUD5ENV.m

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       ;;