BUDAENV.m

BUDAENV ; IHS/CMI/LAB - environmental check 13 Jan 2013 7:22 AM ;

 ;;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 $$VERSION^XPDUTL("BJPC")'="2.0" D SORRY(2)

 I $$VERSION^XPDUTL("BGP")'>"12.9" D SORRY(2)

 Q

 ;

 ;

PRE ;

 ;ADD ALL OTHERS BACK IN

 F DA=1:1:50 S DIK="^BUDQCNTL(" D ^DIK

 F DA=1:1:50 S DIK="^BUDQIL(" D ^DIK

 F DA=1:1:50 S DIK="^BUDQTFIV(" D ^DIK

 F DA=1:1:50 S DIK="^BUDQTTA(" D ^DIK

 F DA=1:1:50 S DIK="^BUDQLST2(" D ^DIK

 Q

POST ;

 ;move site parameters from 04 to 05 on first time install only

 I '$O(^BUDQSITE(0)) D

 .S BUDX=0 F  S BUDX=$O(^BUDRSITE(BUDX)) Q:BUDX'=+BUDX   D

 ..M ^BUDQSITE(BUDX)=^BUDRSITE(BUDX)

 ..S DA=BUDX,DIK="^BUDQSITE(" D IX1^DIK

 D ^BUDAX

 ;create and populate drug taxonomy

 D DRUG

 ;D LAB

 Q

LAB ;EP

 S BUDX="BUD HEPATITIS B TESTS" D LAB1

 S BUDX="BUD HEPATITIS C TESTS" D LAB1

 Q

LAB1 ;

 S BUDDA=$O(^ATXLAB("B",BUDX,0))

 Q:BUDDA  ;taxonomy already exisits

 W !,"Creating ",BUDX," Taxonomy..."

 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

 S ^ATXLAB(BUDTX,21,0)="^9002228.02101PA^0^0"

 S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK

 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

DRUG ;EP set up drug taxonomies

 S ATXFLG=1

 S BUDX="BUD DIABETES MEDS TAX",BUDTAX="",BUDNDCT="BUD DIABETES MEDS NDC" D DRUG1

 S BUDX="BGP PQA CONTROLLER MEDS",BUDTAX="",BUDNDCT="BGP PQA CONTROLLER NDC" D DRUG1

 S BUDX="BGP PQA SABA MEDS",BUDTAX="",BUDNDCT="BGP PQA SABA NDC" D DRUG1

 S BUDX="BUD LIPID LOWERING MEDS",BUDTAX="",BUDNDCT="BGPMU LIPID LOWERING NDCS" D DRUG1

 S BUDX="BUD ANTIPLATELET MEDS",BUDTAX="",BUDNDCT="BGPMU IVD ANTIPLATELET NDCS" D DRUG1

 K ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX

 Q

DRUG1 ;

 W !,"Creating ",BUDX," Taxonomy..."

 S BUDTX=$O(^ATXAX("B",BUDX,0))

 I 'BUDTX D  Q:Y=-1

 .S X=BUDX,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 .I Y=-1 W !!,"ERROR IN CREATING ",BUDX," TAX" Q

 .S BUDTX=+Y,$P(^ATXAX(BUDTX,0),U,2)=BUDX,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=173,$P(^(0),U,13)=0,$P(^(0),U,15)=50,^ATXAX(BUDTX,21,0)="^9002226.02101A^0^0"

 S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK

 I $G(BUDTAX)]"" D

 .S A=0,B="" F  S A=$O(^ATXAX(BUDTX,21,A)) Q:A'=+A  S B=A

 .S BUDC=B

 .S ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B

 .S Z=$O(^ATXAX("B",BUDTAX,0))

 .S J=0 F  S J=$O(^PSDRUG(J)) Q:J'=+J  S C=$P($G(^PSDRUG(J,0)),U,2) I C]"",$D(^ATXAX(Z,21,"B",C)) D

 ..Q:$D(^ATXAX(BUDTX,21,"B",J))

 ..S BUDC=BUDC+1,^ATXAX(BUDTX,21,BUDC,0)=J_U_J

 I $G(BUDNDCT)]"" D

 .S A=0,B="" F  S A=$O(^ATXAX(BUDTX,21,A)) Q:A'=+A  S B=A

 .S BUDC=B

 .S ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B

 .S Z=$O(^ATXAX("B",BUDNDCT,0))

 .S J=0 F  S J=$O(^PSDRUG(J)) Q:J'=+J  D

 ..S G=0

 ..S C=$P($G(^PSDRUG(J,2)),U,4)

 ..I C]"",$D(^ATXAX(Z,21,"B",$$STRIP^XLFSTR(C,"-"))) S G=1

 ..I C]"",$D(^ATXAX(Z,21,"B",C)) S G=1

 ..Q:'G

 ..Q:$D(^ATXAX(BUDTX,21,"B",J))

 ..S BUDC=BUDC+1,^ATXAX(BUDTX,21,BUDC,0)=J_U_J

 S DA=BUDTX,DIK="^ATXAX(" D IX1^DIK

 Q

 ;

INC ;UPDATE INCOME LEVELS

 S X=8 F  S X=$O(^BUDQIL("B",X)) Q:X'=+X  D

 .S Y=$O(^BUDQIL("B",X,0))

 .S C=X-8

 .S $P(^BUDQIL(Y,0),U,2)=(C*4020)+39630

 .S $P(^BUDQIL(Y,0),U,3)=(C*5030)+49560

 .S $P(^BUDQIL(Y,0),U,4)=(C*4620)+45570

 Q

BUDAENV   ; IHS/CMI/LAB - environmental check 13 Jan 2013 7:22 AM ;

 +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 $$VERSION^XPDUTL("BJPC")'="2.0"

               DO SORRY(2)

 +6        IF $$VERSION^XPDUTL("BGP")'>"12.9"

               DO SORRY(2)

 +7        QUIT 

 +8       ;

 +9       ;

PRE       ;

 +1       ;ADD ALL OTHERS BACK IN

 +2        FOR DA=1:1:50

               SET DIK="^BUDQCNTL("

               DO ^DIK

 +3        FOR DA=1:1:50

               SET DIK="^BUDQIL("

               DO ^DIK

 +4        FOR DA=1:1:50

               SET DIK="^BUDQTFIV("

               DO ^DIK

 +5        FOR DA=1:1:50

               SET DIK="^BUDQTTA("

               DO ^DIK

 +6        FOR DA=1:1:50

               SET DIK="^BUDQLST2("

               DO ^DIK

 +7        QUIT 

POST      ;

 +1       ;move site parameters from 04 to 05 on first time install only

 +2        IF '$ORDER(^BUDQSITE(0))

               Begin DoDot:1

 +3                SET BUDX=0

                   FOR 

                       SET BUDX=$ORDER(^BUDRSITE(BUDX))

                       IF BUDX'=+BUDX

                           QUIT 

                       Begin DoDot:2

 +4                        MERGE ^BUDQSITE(BUDX)=^BUDRSITE(BUDX)

 +5                        SET DA=BUDX

                           SET DIK="^BUDQSITE("

                           DO IX1^DIK

                       End DoDot:2

               End DoDot:1

 +6        DO ^BUDAX

 +7       ;create and populate drug taxonomy

 +8        DO DRUG

 +9       ;D LAB

 +10       QUIT 

LAB       ;EP

 +1        SET BUDX="BUD HEPATITIS B TESTS"

           DO LAB1

 +2        SET BUDX="BUD HEPATITIS C TESTS"

           DO LAB1

 +3        QUIT 

LAB1      ;

 +1        SET BUDDA=$ORDER(^ATXLAB("B",BUDX,0))

 +2       ;taxonomy already exisits

           IF BUDDA

               QUIT 

 +3        WRITE !,"Creating ",BUDX," Taxonomy..."

 +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

 +7        SET ^ATXLAB(BUDTX,21,0)="^9002228.02101PA^0^0"

 +8        SET DA=BUDTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +9        QUIT 

 +10      ;

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 

DRUG      ;EP set up drug taxonomies

 +1        SET ATXFLG=1

 +2        SET BUDX="BUD DIABETES MEDS TAX"

           SET BUDTAX=""

           SET BUDNDCT="BUD DIABETES MEDS NDC"

           DO DRUG1

 +3        SET BUDX="BGP PQA CONTROLLER MEDS"

           SET BUDTAX=""

           SET BUDNDCT="BGP PQA CONTROLLER NDC"

           DO DRUG1

 +4        SET BUDX="BGP PQA SABA MEDS"

           SET BUDTAX=""

           SET BUDNDCT="BGP PQA SABA NDC"

           DO DRUG1

 +5        SET BUDX="BUD LIPID LOWERING MEDS"

           SET BUDTAX=""

           SET BUDNDCT="BGPMU LIPID LOWERING NDCS"

           DO DRUG1

 +6        SET BUDX="BUD ANTIPLATELET MEDS"

           SET BUDTAX=""

           SET BUDNDCT="BGPMU IVD ANTIPLATELET NDCS"

           DO DRUG1

 +7        KILL ATXFLG,BUDX,BUDDA,BUDTX,BUDNDCT,BUDTAX

 +8        QUIT 

DRUG1     ;

 +1        WRITE !,"Creating ",BUDX," Taxonomy..."

 +2        SET BUDTX=$ORDER(^ATXAX("B",BUDX,0))

 +3        IF 'BUDTX

               Begin DoDot:1

 +4                SET X=BUDX

                   SET DIC="^ATXAX("

                   SET DIC(0)="L"

                   SET DIADD=1

                   SET DLAYGO=9002226

                   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(^ATXAX(BUDTX,0),U,2)=BUDX

                   SET $PIECE(^(0),U,8)=0

                   SET $PIECE(^(0),U,9)=DT

                   SET $PIECE(^(0),U,12)=173

                   SET $PIECE(^(0),U,13)=0

                   SET $PIECE(^(0),U,15)=50

                   SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^0^0"

               End DoDot:1

               IF Y=-1

                   QUIT 

 +7        SET DA=BUDTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +8        IF $GET(BUDTAX)]""

               Begin DoDot:1

 +9                SET A=0

                   SET B=""

                   FOR 

                       SET A=$ORDER(^ATXAX(BUDTX,21,A))

                       IF A'=+A

                           QUIT 

                       SET B=A

 +10               SET BUDC=B

 +11               SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B

 +12               SET Z=$ORDER(^ATXAX("B",BUDTAX,0))

 +13               SET J=0

                   FOR 

                       SET J=$ORDER(^PSDRUG(J))

                       IF J'=+J

                           QUIT 

                       SET C=$PIECE($GET(^PSDRUG(J,0)),U,2)

                       IF C]""

                           IF $DATA(^ATXAX(Z,21,"B",C))

                               Begin DoDot:2

 +14                               IF $DATA(^ATXAX(BUDTX,21,"B",J))

                                       QUIT 

 +15                               SET BUDC=BUDC+1

                                   SET ^ATXAX(BUDTX,21,BUDC,0)=J_U_J

                               End DoDot:2

               End DoDot:1

 +16       IF $GET(BUDNDCT)]""

               Begin DoDot:1

 +17               SET A=0

                   SET B=""

                   FOR 

                       SET A=$ORDER(^ATXAX(BUDTX,21,A))

                       IF A'=+A

                           QUIT 

                       SET B=A

 +18               SET BUDC=B

 +19               SET ^ATXAX(BUDTX,21,0)="^9002226.02101A^"_B_U_B

 +20               SET Z=$ORDER(^ATXAX("B",BUDNDCT,0))

 +21               SET J=0

                   FOR 

                       SET J=$ORDER(^PSDRUG(J))

                       IF J'=+J

                           QUIT 

                       Begin DoDot:2

 +22                       SET G=0

 +23                       SET C=$PIECE($GET(^PSDRUG(J,2)),U,4)

 +24                       IF C]""

                               IF $DATA(^ATXAX(Z,21,"B",$$STRIP^XLFSTR(C,"-")))

                                   SET G=1

 +25                       IF C]""

                               IF $DATA(^ATXAX(Z,21,"B",C))

                                   SET G=1

 +26                       IF 'G

                               QUIT 

 +27                       IF $DATA(^ATXAX(BUDTX,21,"B",J))

                               QUIT 

 +28                       SET BUDC=BUDC+1

                           SET ^ATXAX(BUDTX,21,BUDC,0)=J_U_J

                       End DoDot:2

               End DoDot:1

 +29       SET DA=BUDTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +30       QUIT 

 +31      ;

INC       ;UPDATE INCOME LEVELS

 +1        SET X=8

           FOR 

               SET X=$ORDER(^BUDQIL("B",X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET Y=$ORDER(^BUDQIL("B",X,0))

 +3                SET C=X-8

 +4                SET $PIECE(^BUDQIL(Y,0),U,2)=(C*4020)+39630

 +5                SET $PIECE(^BUDQIL(Y,0),U,3)=(C*5030)+49560

 +6                SET $PIECE(^BUDQIL(Y,0),U,4)=(C*4620)+45570

               End DoDot:1

 +7        QUIT