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
