BGP8P181.m

BGP8P181 ; IHS/CMI/LAB - V18.1 PATCH 1 POST INIT

 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65

 ;

 ;

 ;SEND OUT BGP TAXONOMIES

 ; 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("BGP*18.0*1") D MES^XPDUTL($$CJ^XLFSTR("CRS v18.0 patch 1 is required.  Not installed.",80)) D SORRY(2)

 I +$$VERSION^XPDUTL("BGP")<18.1 D MES^XPDUTL($$CJ^XLFSTR("Version 18.1 of the IHS CLINICAL REPORTING is required.  Not installed.",80)) D SORRY(2) I 1

 Q

 ;

PRE ;EP

 Q

POST ;EP - called from kids build

 D DRUGS^BGP8POS1

 D LAB^BGP8POS1

 D RXNORM

 D S17

T ;OOO OPTIONS

 D OOO

 Q

OOO ;

 S BGPN="BGP 02" F  S BGPN=$O(^DIC(19,"B",BGPN)) Q:BGPN]"BGP 13Z"!(BGPN="")  D

 .S DA=$O(^DIC(19,"B",BGPN,0))

 .S DIE="^DIC(19,"

 .S DR="2///NO LONGER AVAILABLE"

 .D ^DIE K DA,DR,DIE

 .Q

 Q

S17 ;WIPE OUT ALL 18.0 FILES SO START CLEAN WITH 18.1 FILES

 S BGPX=0 F  S BGPX=$O(^BGPGPDCR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPGPDCR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPGPDPR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPGPDPR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPGPDBR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPGPDBR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPEDLCR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPEDLCR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPEDLPR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPEDLPR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPEDLBR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPEDLBR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPPEDCR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPPEDCR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPPEDPR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPPEDPR(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPPEDBR(BGPX)) Q:BGPX'=+BGPX  D

 .S DA=BGPX,DIK="^BGPPEDBR(" D ^DIK

 Q

BMXPO ;-- update the RPC file

 N BGPRPC

 S BGPRPC=$O(^DIC(19,"B","BGPGRPC",0))

 Q:'BGPRPC

 D CLEAN(BGPRPC)

 D GUIEP^BMXPO(.RETVAL,BGPRPC_"|BGP")

 D GUIEP^BMXPO(.RETVAL,BGPRPC_"|ATX")

 Q

CLEAN(APP) ;-- clean out the RPC multiple first

 S DA(1)=APP

 S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","

 N BGPDA

 S BGPDA=0 F  S BGPDA=$O(^DIC(19,APP,"RPC",BGPDA)) Q:'BGPDA  D

 . S DA=BGPDA

 . D ^DIK

 K ^DIC(19,APP,"RPC","B")

 Q

 ;

INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where

 ; BGPSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 ;

 NEW BGPY,DIC,X,Y

 S X=$P(BGPSTAL,"*",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(BGPSTAL,"*",2)

 D ^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",""PAH"",",X=$P(BGPSTAL,"*",3)

 D ^DIC

 S BGPY=Y

 D IMES

 Q $S(BGPY<1:0,1:1)

IMES ;

 D MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" 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

ADA ;

 S ATXFLG=1

 S BGPDA=0 S BGPDA=$O(^ATXAX("B","BGP IPC BMI ADA CODES",BGPDA))

 I BGPDA S DIK="^ATXAX(",DA=BGPDA D ^DIK  ;get rid of existing one

 W !,"Creating/Updating BGP IPC BMI ADA Codes Taxonomy..."

 S X="BGP IPC BMI ADA CODES",DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING BGP IPC BMI ADA CODES TAX" Q

 S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)="BGP IPC BMI ADA CODES",$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=174,$P(^(0),U,13)=0,$P(^(0),U,15)=9999999.31,^ATXAX(BGPTX,21,0)="^9002226.02101A^0^0"

 S BGPX=0

 F X="7140","7210" S DIC="^AUTTADA(",DIC(0)="M" D ^DIC K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 I $P(Y,U)>0 D

 .S BGPX=BGPX+1

 .S ^ATXAX(BGPTX,21,BGPX,0)=+Y,$P(^ATXAX(BGPTX,21,0),U,3)=BGPX,$P(^(0),U,4)=BGPX,^ATXAX(BGPTX,21,"AA",+Y,BGPX)=""

 .Q

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

 Q

RXNORM ;

 S ATXFLG=1

 S BGPX="BGP IPC DEPRESSION MEDS",BGPRXN="BGP IPC DEPRESSION RXNORM" D RXNORM1

 S BGPX="BGP IPC ABOVE NORMAL MEDS",BGPRXN="BGP IPC ABOVE NORMAL RXNORM" D RXNORM1

 S BGPX="BGP IPC BELOW NORMAL MEDS",BGPRXN="BGP IPC BELOW NORMAL RXNORM" D RXNORM1

 Q

RXNORM1 ;

 W !,BGPRXN

 W !,"Creating ",BGPX," Taxonomy..."

 S BGPTX=$O(^ATXAX("B",BGPX,0))

 I 'BGPTX D  Q:Y=-1

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

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

 .S BGPTX=+Y,$P(^ATXAX(BGPTX,0),U,2)=BGPX,$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(BGPTX,21,0)="^9002226.02101A^0^0"

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

 I $G(BGPRXN)]"" D

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

 .S BGPC=B

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

 .S Z=$O(^BGPSNOMR("B",BGPRXN,0))

 .S J=0 F  S J=$O(^PSDRUG(J)) Q:J'=+J  S C=$$VAL^XBDIQ1(50,J,9999999.27) I C]"",$D(^BGPSNOMR(Z,11,"B",C)) D

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

 ..S BGPC=BGPC+1,^ATXAX(BGPTX,21,BGPC,0)=J_U_J

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

 Q

BGP8P181  ; IHS/CMI/LAB - V18.1 PATCH 1 POST INIT

 +1       ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65

 +2       ;

 +3       ;

 +4       ;SEND OUT BGP TAXONOMIES

 +5       ; The following line prevents the "Disable Options..." and "Move

 +6       ; Routines..." questions from being asked during the install.

 +7        IF $GET(XPDENV)=1

               SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +8        FOR X="XPO1","XPZ1","XPZ2","XPI1"

               SET XPDDIQ(X)=0

 +9       ;I '$$INSTALLD("BGP*18.0*1") D MES^XPDUTL($$CJ^XLFSTR("CRS v18.0 patch 1 is required.  Not installed.",80)) D SORRY(2)

 +10       IF +$$VERSION^XPDUTL("BGP")<18.1

               DO MES^XPDUTL($$CJ^XLFSTR("Version 18.1 of the IHS CLINICAL REPORTING is required.  Not installed.",80))

               DO SORRY(2)

               IF 1

 +11       QUIT 

 +12      ;

PRE       ;EP

 +1        QUIT 

POST      ;EP - called from kids build

 +1        DO DRUGS^BGP8POS1

 +2        DO LAB^BGP8POS1

 +3        DO RXNORM

 +4        DO S17

T         ;OOO OPTIONS

 +1        DO OOO

 +2        QUIT 

OOO       ;

 +1        SET BGPN="BGP 02"

           FOR 

               SET BGPN=$ORDER(^DIC(19,"B",BGPN))

               IF BGPN]"BGP 13Z"!(BGPN="")

                   QUIT 

               Begin DoDot:1

 +2                SET DA=$ORDER(^DIC(19,"B",BGPN,0))

 +3                SET DIE="^DIC(19,"

 +4                SET DR="2///NO LONGER AVAILABLE"

 +5                DO ^DIE

                   KILL DA,DR,DIE

 +6                QUIT 

               End DoDot:1

 +7        QUIT 

S17       ;WIPE OUT ALL 18.0 FILES SO START CLEAN WITH 18.1 FILES

 +1        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPGPDCR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +2                SET DA=BGPX

                   SET DIK="^BGPGPDCR("

                   DO ^DIK

               End DoDot:1

 +3        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPGPDPR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +4                SET DA=BGPX

                   SET DIK="^BGPGPDPR("

                   DO ^DIK

               End DoDot:1

 +5        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPGPDBR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +6                SET DA=BGPX

                   SET DIK="^BGPGPDBR("

                   DO ^DIK

               End DoDot:1

 +7        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPEDLCR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +8                SET DA=BGPX

                   SET DIK="^BGPEDLCR("

                   DO ^DIK

               End DoDot:1

 +9        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPEDLPR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +10               SET DA=BGPX

                   SET DIK="^BGPEDLPR("

                   DO ^DIK

               End DoDot:1

 +11       SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPEDLBR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +12               SET DA=BGPX

                   SET DIK="^BGPEDLBR("

                   DO ^DIK

               End DoDot:1

 +13       SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPPEDCR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +14               SET DA=BGPX

                   SET DIK="^BGPPEDCR("

                   DO ^DIK

               End DoDot:1

 +15       SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPPEDPR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +16               SET DA=BGPX

                   SET DIK="^BGPPEDPR("

                   DO ^DIK

               End DoDot:1

 +17       SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^BGPPEDBR(BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               Begin DoDot:1

 +18               SET DA=BGPX

                   SET DIK="^BGPPEDBR("

                   DO ^DIK

               End DoDot:1

 +19       QUIT 

BMXPO     ;-- update the RPC file

 +1        NEW BGPRPC

 +2        SET BGPRPC=$ORDER(^DIC(19,"B","BGPGRPC",0))

 +3        IF 'BGPRPC

               QUIT 

 +4        DO CLEAN(BGPRPC)

 +5        DO GUIEP^BMXPO(.RETVAL,BGPRPC_"|BGP")

 +6        DO GUIEP^BMXPO(.RETVAL,BGPRPC_"|ATX")

 +7        QUIT 

CLEAN(APP) ;-- clean out the RPC multiple first

 +1        SET DA(1)=APP

 +2        SET DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","

 +3        NEW BGPDA

 +4        SET BGPDA=0

           FOR 

               SET BGPDA=$ORDER(^DIC(19,APP,"RPC",BGPDA))

               IF 'BGPDA

                   QUIT 

               Begin DoDot:1

 +5                SET DA=BGPDA

 +6                DO ^DIK

               End DoDot:1

 +7        KILL ^DIC(19,APP,"RPC","B")

 +8        QUIT 

 +9       ;

INSTALLD(BGPSTAL) ;EP - Determine if patch BGPSTAL was installed, where

 +1       ; BGPSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 +2       ;

 +3        NEW BGPY,DIC,X,Y

 +4        SET X=$PIECE(BGPSTAL,"*",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(BGPSTAL,"*",2)

 +9        DO ^DIC

 +10       IF Y<1

               DO IMES

               QUIT 0

 +11       SET DIC=DIC_+Y_",""PAH"","

           SET X=$PIECE(BGPSTAL,"*",3)

 +12       DO ^DIC

 +13       SET BGPY=Y

 +14       DO IMES

 +15       QUIT $SELECT(BGPY<1:0,1:1)

IMES      ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BGPSTAL_""" 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 

ADA       ;

 +1        SET ATXFLG=1

 +2        SET BGPDA=0

           SET BGPDA=$ORDER(^ATXAX("B","BGP IPC BMI ADA CODES",BGPDA))

 +3       ;get rid of existing one

           IF BGPDA

               SET DIK="^ATXAX("

               SET DA=BGPDA

               DO ^DIK

 +4        WRITE !,"Creating/Updating BGP IPC BMI ADA Codes Taxonomy..."

 +5        SET X="BGP IPC BMI ADA CODES"

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +6        IF Y=-1

               WRITE !!,"ERROR IN CREATING BGP IPC BMI ADA CODES TAX"

               QUIT 

 +7        SET BGPTX=+Y

           SET $PIECE(^ATXAX(BGPTX,0),U,2)="BGP IPC BMI ADA CODES"

           SET $PIECE(^(0),U,5)=DUZ

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

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

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

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

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

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

 +8        SET BGPX=0

 +9        FOR X="7140","7210"

               SET DIC="^AUTTADA("

               SET DIC(0)="M"

               DO ^DIC

               KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

               IF $PIECE(Y,U)>0

                   Begin DoDot:1

 +10                   SET BGPX=BGPX+1

 +11                   SET ^ATXAX(BGPTX,21,BGPX,0)=+Y

                       SET $PIECE(^ATXAX(BGPTX,21,0),U,3)=BGPX

                       SET $PIECE(^(0),U,4)=BGPX

                       SET ^ATXAX(BGPTX,21,"AA",+Y,BGPX)=""

 +12                   QUIT 

                   End DoDot:1

 +13       SET DA=BGPTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +14       QUIT 

RXNORM    ;

 +1        SET ATXFLG=1

 +2        SET BGPX="BGP IPC DEPRESSION MEDS"

           SET BGPRXN="BGP IPC DEPRESSION RXNORM"

           DO RXNORM1

 +3        SET BGPX="BGP IPC ABOVE NORMAL MEDS"

           SET BGPRXN="BGP IPC ABOVE NORMAL RXNORM"

           DO RXNORM1

 +4        SET BGPX="BGP IPC BELOW NORMAL MEDS"

           SET BGPRXN="BGP IPC BELOW NORMAL RXNORM"

           DO RXNORM1

 +5        QUIT 

RXNORM1   ;

 +1        WRITE !,BGPRXN

 +2        WRITE !,"Creating ",BGPX," Taxonomy..."

 +3        SET BGPTX=$ORDER(^ATXAX("B",BGPX,0))

 +4        IF 'BGPTX

               Begin DoDot:1

 +5                SET X=BGPX

                   SET DIC="^ATXAX("

                   SET DIC(0)="L"

                   SET DIADD=1

                   SET DLAYGO=9002226

                   DO ^DIC

                   KILL DIC,DA,DIADD,DLAYGO,I

 +6                IF Y=-1

                       WRITE !!,"ERROR IN CREATING ",BGPX," TAX"

                       QUIT 

 +7                SET BGPTX=+Y

                   SET $PIECE(^ATXAX(BGPTX,0),U,2)=BGPX

                   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(BGPTX,21,0)="^9002226.02101A^0^0"

               End DoDot:1

               IF Y=-1

                   QUIT 

 +8        SET DA=BGPTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +9        IF $GET(BGPRXN)]""

               Begin DoDot:1

 +10               SET A=0

                   SET B=""

                   FOR 

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

                       IF A'=+A

                           QUIT 

                       SET B=A

 +11               SET BGPC=B

 +12               SET ^ATXAX(BGPTX,21,0)="^9002226.02101A^"_B_U_B

 +13               SET Z=$ORDER(^BGPSNOMR("B",BGPRXN,0))

 +14               SET J=0

                   FOR 

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

                       IF J'=+J

                           QUIT 

                       SET C=$$VAL^XBDIQ1(50,J,9999999.27)

                       IF C]""

                           IF $DATA(^BGPSNOMR(Z,11,"B",C))

                               Begin DoDot:2

 +15                               IF $DATA(^ATXAX(BGPTX,21,"B",J))

                                       QUIT 

 +16                               SET BGPC=BGPC+1

                                   SET ^ATXAX(BGPTX,21,BGPC,0)=J_U_J

                               End DoDot:2

               End DoDot:1

 +17       SET DA=BGPTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +18       QUIT