AMH40P6 ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 18 Sep 2014 11:23 AM
;;4.0;IHS BEHAVIORAL HEALTH;**6**;JUN 02, 2010;Build 10
;
ENV ;EP
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
I +$$VERSION^XPDUTL("XU")<8 D MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
I +$$VERSION^XPDUTL("DI")<22 D MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
I $E($$VERSION^XPDUTL("AMH"),1,3)'="4.0" D MES^XPDUTL($$CJ^XLFSTR("Version 4.0 of AMH is required. Not installed.",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires AMH v4.0....Present.",80))
I '$$INSTALLD("AMH*4.0*5") D SORRY(2)
Q
;
PRE ;
S AMHX=0 F S AMHX=$O(^AMHSORT(AMHX)) Q:AMHX'=+AMHX S DIK="^AMHSORT(",DA=AMHX D ^DIK
Q
;
POST ;EP
;D BMXPO
S AMHX=0 F S AMHX=$O(^AMHSITE(AMHX)) Q:AMHX'=+AMHX I $P($G(^AMHSITE(AMHX,18)),U,11)="" S DA=AMHX,DR="1811////3151001",DIE="^AMHSITE(" D ^DIE K DA,DR,DIE
;REFLAG SF
D SFRFLG
Q
SFRFLG ;
S AMHD=$O(^AMHPSUIC("AEX",0))
I AMHD="" S AMHD=DT
S AMHAS=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)
S AMHX=0 F S AMHX=$O(^AMHPSUIC(AMHX)) Q:AMHX'=+AMHX D
.S X=$P($G(^AMHPSUIC(AMHX,0)),U,1)
.Q:X=""
.;Q:$L(X)=24
.I $E(X,1,6)=AMHAS Q
.S P=$P($G(^AMHPSUIC(AMHX,0)),U,4)
.S D=$P($G(^AMHPSUIC(AMHX,0)),U,6)
.S Z=$$UPI^AMHLESF(P,D)
.;S DIE="^AMHPSUIC(",DR=".01///"_Z,DA=AMHX D ^DIE
.S $P(^AMHPSUIC(AMHX,0),U,1)=Z
.S ^AMHPSUIC("AEX",AMHD,AMHX)=""
K ^AMHPSUIC("B")
S DIK="^AMHPSUIC(",DIK(1)=".01^B" D ENALL^DIK
Q
BMXPO ;-- update the RPC file
N AMHRPC
S AMHRPC=$O(^DIC(19,"B","AMHGRPC",0))
Q:'AMHRPC
D CLEAN(AMHRPC)
D GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")
Q
;
CLEAN(APP) ;-- clean out the RPC multiple first
S DA(1)=APP
S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
N AMHDA
S AMHDA=0 F S AMHDA=$O(^DIC(19,APP,"RPC",AMHDA)) Q:'AMHDA D
. S DA=AMHDA
. D ^DIK
K ^DIC(19,APP,"RPC","B")
Q
INSTALLD(AMHSTAL) ;EP - Determine if patch AMHSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW AMHY,DIC,X,Y
S X=$P(AMHSTAL,"*",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(AMHSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(AMHSTAL,"*",3)
D ^DIC
S AMHY=Y
D IMES
Q $S(AMHY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_AMHSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" Present.",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
AMH40P6 ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 18 Sep 2014 11:23 AM
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**6**;JUN 02, 2010;Build 10
+2 ;
ENV ;EP
+1 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+2 IF +$$VERSION^XPDUTL("XU")<8
DO MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80))
DO SORRY(2)
IF 1
+3 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
+4 IF +$$VERSION^XPDUTL("DI")<22
DO MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80))
DO SORRY(2)
IF 1
+5 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
+6 IF $EXTRACT($$VERSION^XPDUTL("AMH"),1,3)'="4.0"
DO MES^XPDUTL($$CJ^XLFSTR("Version 4.0 of AMH is required. Not installed.",80))
DO SORRY(2)
IF 1
+7 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires AMH v4.0....Present.",80))
+8 IF '$$INSTALLD("AMH*4.0*5")
DO SORRY(2)
+9 QUIT
+10 ;
PRE ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHSORT(AMHX))
IF AMHX'=+AMHX
QUIT
SET DIK="^AMHSORT("
SET DA=AMHX
DO ^DIK
+2 QUIT
+3 ;
POST ;EP
+1 ;D BMXPO
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHSITE(AMHX))
IF AMHX'=+AMHX
QUIT
IF $PIECE($GET(^AMHSITE(AMHX,18)),U,11)=""
SET DA=AMHX
SET DR="1811////3151001"
SET DIE="^AMHSITE("
DO ^DIE
KILL DA,DR,DIE
+3 ;REFLAG SF
+4 DO SFRFLG
+5 QUIT
SFRFLG ;
+1 SET AMHD=$ORDER(^AMHPSUIC("AEX",0))
+2 IF AMHD=""
SET AMHD=DT
+3 SET AMHAS=$PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U,1),0),U,10)
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHPSUIC(AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+5 SET X=$PIECE($GET(^AMHPSUIC(AMHX,0)),U,1)
+6 IF X=""
QUIT
+7 ;Q:$L(X)=24
+8 IF $EXTRACT(X,1,6)=AMHAS
QUIT
+9 SET P=$PIECE($GET(^AMHPSUIC(AMHX,0)),U,4)
+10 SET D=$PIECE($GET(^AMHPSUIC(AMHX,0)),U,6)
+11 SET Z=$$UPI^AMHLESF(P,D)
+12 ;S DIE="^AMHPSUIC(",DR=".01///"_Z,DA=AMHX D ^DIE
+13 SET $PIECE(^AMHPSUIC(AMHX,0),U,1)=Z
+14 SET ^AMHPSUIC("AEX",AMHD,AMHX)=""
End DoDot:1
+15 KILL ^AMHPSUIC("B")
+16 SET DIK="^AMHPSUIC("
SET DIK(1)=".01^B"
DO ENALL^DIK
+17 QUIT
BMXPO ;-- update the RPC file
+1 NEW AMHRPC
+2 SET AMHRPC=$ORDER(^DIC(19,"B","AMHGRPC",0))
+3 IF 'AMHRPC
QUIT
+4 DO CLEAN(AMHRPC)
+5 DO GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")
+6 QUIT
+7 ;
CLEAN(APP) ;-- clean out the RPC multiple first
+1 SET DA(1)=APP
+2 SET DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
+3 NEW AMHDA
+4 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^DIC(19,APP,"RPC",AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+5 SET DA=AMHDA
+6 DO ^DIK
End DoDot:1
+7 KILL ^DIC(19,APP,"RPC","B")
+8 QUIT
INSTALLD(AMHSTAL) ;EP - Determine if patch AMHSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW AMHY,DIC,X,Y
+4 SET X=$PIECE(AMHSTAL,"*",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(AMHSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(AMHSTAL,"*",3)
+12 DO ^DIC
+13 SET AMHY=Y
+14 DO IMES
+15 QUIT $SELECT(AMHY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_AMHSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" Present.",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
