BGP010P1.m

BGP010P1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2007 7:41 PM ; 

 ;;10.0;IHS CLINICAL REPORTING;**1**;JUL 1, 2009

 ;

 ;

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

 Q

 ;

PRE ;EP

 ;CHANGE PACKAGE FILE NAME

 S BGPX=0 F  S BGPX=$O(^BGPPEIT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPPEIT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPELIT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPELIT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPELIIT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPELIIT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPCMSIT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPCMSIT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPNPLT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPNPLT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPHEIT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPHEIT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPHEIIT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPHEIIT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPINDTC(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPINDTC(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPINDT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPINDT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPTAXT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPTAXT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPCMSMT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPCMSMT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPSCAT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPSCAT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPICAGT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPICAGT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPICACT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPICACT(" D ^DIK

 F BGPX=0 F  S BGPX=$O(^BGPEOMT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPEOMT(" D ^DIK

 S BGPX=0 F  S BGPX=$O(^BGPEOMIT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPEOMIT(" D ^DIK

 F BGPX=1:1:2000 K ^BGPTAXT(BGPX)

 S BGPX=0 F  S BGPX=$O(^BGPTAXTT(BGPX)) Q:BGPX'=+BGPX  S DA=BGPX,DIK="^BGPTAXTT(" D ^DIK

 F BGPX=1:1:2000 K ^BGPTAXTT(BGPX)

 S X=0 F  S X=$O(^BGPSITE(X)) Q:X'=+X  S $P(^BGPSITE(X,0),U,3)=""

 S X=0 F  S X=$O(^ATXAX(X)) Q:X'=+X  D

 .I $D(^ATXAX(X,21,0)),$P(^ATXAX(X,21,0),U,2)'["9002226.02101A" S $P(^ATXAX(X,21,0),U,2)="9002226.02101A"

 .I $D(^ATXAX(X,41,0)),$P(^ATXAX(X,41,0),U,2)'["9002226.04101P" S $P(^ATXAX(X,41,0),U,2)="9002226.04101P"

 K ATXFLG

 Q

POST ;EP - called from kids build

 ;BGP UNI

 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

BGP010P1  ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM 25 Nov 2007 7:41 PM ; 

 +1       ;;10.0;IHS CLINICAL REPORTING;**1**;JUL 1, 2009

 +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        IF $$VERSION^XPDUTL("BGP")'="10.0"

               DO SORRY(2)

 +10       QUIT 

 +11      ;

PRE       ;EP

 +1       ;CHANGE PACKAGE FILE NAME

 +2        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPPEIT("

               DO ^DIK

 +3        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPELIT("

               DO ^DIK

 +4        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPELIIT("

               DO ^DIK

 +5        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPCMSIT("

               DO ^DIK

 +6        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPNPLT("

               DO ^DIK

 +7        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPHEIT("

               DO ^DIK

 +8        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPHEIIT("

               DO ^DIK

 +9        SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPINDTC("

               DO ^DIK

 +10       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPINDT("

               DO ^DIK

 +11       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPTAXT("

               DO ^DIK

 +12       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPCMSMT("

               DO ^DIK

 +13       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPSCAT("

               DO ^DIK

 +14       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPICAGT("

               DO ^DIK

 +15       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPICACT("

               DO ^DIK

 +16       FOR BGPX=0

               FOR 

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

                   IF BGPX'=+BGPX

                       QUIT 

                   SET DA=BGPX

                   SET DIK="^BGPEOMT("

                   DO ^DIK

 +17       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPEOMIT("

               DO ^DIK

 +18       FOR BGPX=1:1:2000

               KILL ^BGPTAXT(BGPX)

 +19       SET BGPX=0

           FOR 

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

               IF BGPX'=+BGPX

                   QUIT 

               SET DA=BGPX

               SET DIK="^BGPTAXTT("

               DO ^DIK

 +20       FOR BGPX=1:1:2000

               KILL ^BGPTAXTT(BGPX)

 +21       SET X=0

           FOR 

               SET X=$ORDER(^BGPSITE(X))

               IF X'=+X

                   QUIT 

               SET $PIECE(^BGPSITE(X,0),U,3)=""

 +22       SET X=0

           FOR 

               SET X=$ORDER(^ATXAX(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +23               IF $DATA(^ATXAX(X,21,0))

                       IF $PIECE(^ATXAX(X,21,0),U,2)'["9002226.02101A"

                           SET $PIECE(^ATXAX(X,21,0),U,2)="9002226.02101A"

 +24               IF $DATA(^ATXAX(X,41,0))

                       IF $PIECE(^ATXAX(X,41,0),U,2)'["9002226.04101P"

                           SET $PIECE(^ATXAX(X,41,0),U,2)="9002226.04101P"

               End DoDot:1

 +25       KILL ATXFLG

 +26       QUIT 

POST      ;EP - called from kids build

 +1       ;BGP UNI

 +2        QUIT 

 +3       ;

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