Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMH40P6

AMH40P6.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. ENV ;EP 
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  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
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
  1.  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
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
  1.  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
  1.  E  D MES^XPDUTL($$CJ^XLFSTR("Requires AMH v4.0....Present.",80))
  1.  I '$$INSTALLD("AMH*4.0*5") D SORRY(2)
  1.  Q
  1.  ;
  1. PRE ;
  1.  S AMHX=0 F  S AMHX=$O(^AMHSORT(AMHX)) Q:AMHX'=+AMHX  S DIK="^AMHSORT(",DA=AMHX D ^DIK
  1.  Q
  1.  ;
  1. POST ;EP
  1.  ;D BMXPO
  1.  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
  1.  ;REFLAG SF
  1.  D SFRFLG
  1.  Q
  1. SFRFLG ;
  1.  S AMHD=$O(^AMHPSUIC("AEX",0))
  1.  I AMHD="" S AMHD=DT
  1.  S AMHAS=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)
  1.  S AMHX=0 F  S AMHX=$O(^AMHPSUIC(AMHX)) Q:AMHX'=+AMHX  D
  1.  .S X=$P($G(^AMHPSUIC(AMHX,0)),U,1)
  1.  .Q:X=""
  1.  .;Q:$L(X)=24
  1.  .I $E(X,1,6)=AMHAS Q
  1.  .S P=$P($G(^AMHPSUIC(AMHX,0)),U,4)
  1.  .S D=$P($G(^AMHPSUIC(AMHX,0)),U,6)
  1.  .S Z=$$UPI^AMHLESF(P,D)
  1.  .;S DIE="^AMHPSUIC(",DR=".01///"_Z,DA=AMHX D ^DIE
  1.  .S $P(^AMHPSUIC(AMHX,0),U,1)=Z
  1.  .S ^AMHPSUIC("AEX",AMHD,AMHX)=""
  1.  K ^AMHPSUIC("B")
  1.  S DIK="^AMHPSUIC(",DIK(1)=".01^B" D ENALL^DIK
  1.  Q
  1. BMXPO ;-- update the RPC file
  1.  N AMHRPC
  1.  S AMHRPC=$O(^DIC(19,"B","AMHGRPC",0))
  1.  Q:'AMHRPC
  1.  D CLEAN(AMHRPC)
  1.  D GUIEP^BMXPO(.RETVAL,AMHRPC_"|AMH")
  1.  Q
  1.  ;
  1. CLEAN(APP) ;-- clean out the RPC multiple first
  1.  S DA(1)=APP
  1.  S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
  1.  N AMHDA
  1.  S AMHDA=0 F  S AMHDA=$O(^DIC(19,APP,"RPC",AMHDA)) Q:'AMHDA  D
  1.  . S DA=AMHDA
  1.  . D ^DIK
  1.  K ^DIC(19,APP,"RPC","B")
  1.  Q
  1. INSTALLD(AMHSTAL) ;EP - Determine if patch AMHSTAL was installed, where
  1.  ; APCLSTAL is the name of the INSTALL.  E.g "AG*6.0*11".
  1.  ;
  1.  NEW AMHY,DIC,X,Y
  1.  S X=$P(AMHSTAL,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",22,",X=$P(AMHSTAL,"*",2)
  1.  D ^DIC
  1.  I Y<1 D IMES Q 0
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(AMHSTAL,"*",3)
  1.  D ^DIC
  1.  S AMHY=Y
  1.  D IMES
  1.  Q $S(AMHY<1:0,1:1)
  1. IMES ;
  1.  D MES^XPDUTL($$CJ^XLFSTR("Patch """_AMHSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" Present.",IOM))
  1.  Q
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  I X=3 S XPDQUIT=2 Q
  1.  S XPDQUIT=X
  1.  W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
  1.  Q