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

BCHENV.m

Go to the documentation of this file. 
  1. BCHENV ; IHS/TUCSON/LAB - environmental check [ 09/21/2006  11:23 AM ]
  1.  ;;1.0;IHS RPMS CHR SYSTEM;**12,14,15**;OCT 28, 1996
  1.  ;
  1.  ;;
  1.  ; The following line prevents the "Disable Options..." and "Move
  1.  ; Routines..." questions from being asked during the install.
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
  1.  Q
  1.  ;
  1. PRE ;EP - delete CHR POV file
  1.  F DA=1:1:200 S DIK="^BCHSORT(" D ^DIK
  1.  S DA=$O(^BCHTREF("B","SUBSTANCE ABUSE PROGRAM",0))
  1.  I DA S DIE="^BCHTREF(",DR=".01///BEHAVIORAL HEALTH;.03///BH" D ^DIE K DA,DIE,DR
  1.  S DA=$O(^BCHTHAC("B","MENTAL HEALTH",0))
  1.  I DA S DIE="^BCHTHAC(",DR=".01///BEHAVIORAL HEALTH" D ^DIE K DA,DIE,DR
  1.  S DA=$O(^BCHTPROB("C","TB",0))
  1.  I DA S DIE="^BCHTPROB(",DR=".01///TUBERCULOSIS" D ^DIE K DA,DIE,DR
  1.  S DA=$O(^BCHTPROB("C","HI",0))
  1.  I DA S DIE="^BCHTPROB(",DR=".01///HIV/AIDS" D ^DIE K DA,DIE,DA
  1.  S DA=$O(^BCHTHAC("C","MENTAL HEALTH",0))
  1.  I DA S DIE="^BCHTHAC(",DR=".01///BEHAVIORAL HEALTH" D ^DIE K DA,DIE,DR
  1.  S DA=$O(^BCHTPROB("C","SX",0))
  1.  I DA S DIE="^BCHTPROB(",DR=".01///SEXUALLY TRANSMITTED" D ^DIE K DA,DIE,DR
  1.  ;S DA=$O(^BCHTPROB("C","SD",0))
  1.  ;I DA S DIE="^BCHTPROB(",DR=".02///SZ" D ^DIE K DA,DIE,DR
  1.  S DA=$O(^BCHTPROB("C","DA",0))
  1.  I DA S DIE="^BCHTPROB(",DR=".01///SUBSTANCE ABUSE;.02///SA" D ^DIE K DA,DIE,DR
  1.  S DIK="^DD(90002.53,",DA=.04,DA(1)=90002.53 D ^DIK
  1.  S X=0 F  S X=$O(^BCHTPROB(X)) Q:X'=+X  S $P(^BCHTPROB(X,0),U,4)=""
  1.  S DA=$O(^BCHTSERV("B","NO CONTACT",0)) I DA S DIK="^BCHTSERV(" D ^DIK
  1.  Q
  1. POST ;EP
  1.  ;
  1.  ;get rid of infections and repoint to infections (ear)
  1.  S BCHIN=$O(^BCHTPROB("B","INFECTIONS",0))
  1.  S BCHINE=$O(^BCHTPROB("B","INFECTIONS (EAR)",0))
  1.  I BCHIN,BCHINE D
  1.  .S BCHX=0 F  S BCHX=$O(^BCHRPROB("B",BCHINE,0)) Q:BCHX'=+BCHX  D
  1.  ..S DIE="^BCHRPROB(",DA=BCHX,DR=".01///`"_BCHIN D ^DIE W "."
  1.  ..K DIE,DA,DR
  1.  .S DA=BCHINE,DIK="^BCHTPROB(" D ^DIK
  1.   ;get rid of infections and repoint to infections (ear)
  1.  NEW X
  1.  S X=$$ADD^XPDMENU("BCH M MANAGER UTILITIES","BHL CHR MENU","CHL7")
  1.  I 'X W "Attempt to add BHL HL7 option failed.." H 3
  1.  Q
  1. SENDBULL ;
  1.  ;;
  1.  ;;Here's how to make this work:
  1.  ;;
  1.  ;;1. Create your message in subroutine WRITEMSG
  1.  ;;2. Identify recipients in GETRECIP by setting BCHKEY
  1.  ;;3. Make changes in SUBJECT and SENDER as desired
  1.  ;;4. Rename this routine in appropriate namespace and 
  1.  ;;   call on completion of patch or upgrade
  1.  ;
  1.  I '$G(DUZ) W !,"DUZ UNDEFINED OR ZERO.",! Q
  1.  D HOME^%ZIS,DT^DICRW
  1.  ;
  1.  NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
  1.  KILL ^TMP($J,"BCHBUL")
  1.  D WRITEMSG,GETRECIP
  1.  ;Change following lines as desired
  1. SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
  1. SENDER S XMDUZ="IHS Information Technology"
  1.  S XMTEXT="^TMP($J,""BCHBUL"",",XMY(1)="",XMY(DUZ)=""
  1.  I $E(IOST)="C" W !,"Sending Mailman message to holders of the"_" "_BCHKEY_" "_"security key."
  1.  D ^XMD
  1.  KILL ^TMP($J,"BCHBUL"),BCHKEY
  1.  Q
  1.  ;
  1. WRITEMSG ;
  1.  F %=3:1 S X=$P($T(WRITEMSG+%),";",3) Q:X="###"  S ^TMP($J,"BCHBUL",%)=X
  1.  Q
  1.  ;;  
  1.  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1.  ;;RPMS CHR Reporting System patch 1 has been installed on your system.
  1.  ;;
  1.  ;;You will notice the following change:
  1.  ;;  There is a new menu option/action that allows you to browse a patient's
  1.  ;;  CHR visits.
  1.  ;;
  1.  ;;+++++++++++++++++++++ end of announcement +++++++++++++++++++++++
  1.  ;;###
  1.  ;
  1. GETRECIP ;
  1.  ;* * * Define key below to identify recipients * * *
  1.  ;
  1.  S CTR=0,BCHKEY="BCHZMENU"
  1.  F  S CTR=$O(^XUSEC(BCHKEY,CTR)) Q:'CTR  S Y=CTR S XMY(Y)=""
  1.  Q