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