BUD4ENV.m

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