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

AMH40P3.m

Go to the documentation of this file. 
  1. AMH40P3 ; IHS/CMI/LAB - POST INIT BH 16 Apr 2009 7:37 AM 01 Aug 2009 5:37 AM ; 13 Apr 2010  3:54 PM
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**3**;JUN 18, 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*2") D SORRY(2)
  1.  Q
  1.  ;
  1. PRE ;
  1.  S DA=0 F  S DA=$O(^AMHRECD(DA)) Q:DA'=+DA  S DIK="^AMHRECD(" D ^DIK
  1.  K DA,DIK
  1.  Q
  1.  ;
  1. POST ;EP
  1.  ;D RESET  ;reset AEX for all visits with a visit date 100106 or greater.
  1.  ;set new site parameter to 1 if it is not filled in
  1.  S AMHX=0 F  S AMHX=$O(^AMHSITE(AMHX)) Q:AMHX'=+AMHX  D
  1.  .I $P($G(^AMHSITE(AMHX,18)),U,10)'="" Q  ;already set
  1.  .S DA=AMHX,DIE="^AMHSITE(",DR="1810///1" D ^DIE K DA,DR,DIE
  1.  D MENU
  1.  D ZISH
  1.  D BMXPO
  1.  Q
  1.  ;
  1.  N X
  1.  S X=$$ADD^XPDMENU("AMH M EXPORT UTILITY","AMH EY AUTO EXPORT","SAE")
  1.  Q
  1.  ;
  1. ZISH ;create entry in ZISH SEND PARAMETERS file
  1.  D ^XBFMK K DIADD,DLAYGO,DIC,DD,D0,DO
  1.  ;Q:$D(^%ZIB(9888888.93,"B","AMH AUTO SEND"))
  1.  S APCLY=0 F  S APCLY=$O(^%ZIB(9888888.93,"B","AMH AUTO SEND",0)) Q:APCLY'=+APCLY  D
  1.  .I APCLY S DA=APCLY,DIK="^%ZIB(9888888.93," D ^DIK K DA,DIK
  1.  S X="AMH AUTO SEND",DIC(0)="L",DIC="^%ZIB(9888888.93," D FILE^DICN
  1.  I Y=-1 W !!,"error creating ZISH SEND PARAMETERS entry" Q
  1.  S DA=+Y,DIE="^%ZIB(9888888.93,",DR=".02///QUOVADX-IE.IHS.GOV;.03///ihpesusr;.04///g2dwy66b;.06///-u;.07///B;.08///sendto"
  1.  D ^DIE
  1.  I $D(Y) W !!,"error updating ZISH SEND PARAMETERS entry" Q
  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