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

BLREMERA.m

Go to the documentation of this file. 
  1. BLREMERA ; IHS/MSC/MKK - BLR EMERgency Alert parameter edit  ; 02-May-2016 15:50 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1039**;NOV 01, 1997;Build 38
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. PEP ; EP
  1.  D CHANGE("BLR EMERGENCY ALERT")
  1.  Q
  1.  ;
  1. COLDTACC ; EP - Collection Date visit Creation parameter
  1.  D CHANGE("BLR COLL DT PCC VISIT CREATION")
  1.  Q
  1.  ;
  1.  ;
  1. CHANGE(PARAMETER) ; EP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PARAMETER,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="IHS Laboratory"
  1.  S HEADER(2)=PARAMETER_" Parameter"
  1.  S HEADER(3)=$$CJ^XLFSTR("Modify Value",IOM)
  1.  ;
  1.  S RESULT=$$GET^XPAR("PKG",PARAMETER,1,"Q")
  1.  S RESULT=$S(RESULT:"YES",RESULT=0:"NO",1:"")
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("A")=PARAMETER_" (YES/NO)"
  1.  S:$L(RESULT) DIR("B")=RESULT
  1.  D ^DIR
  1.  ;
  1.  I +$G(DIRUT)!($G(Y)="") D  Q
  1.  . W !!,?4,"Invalid/No Entry/Quit. Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S ANSWER=$S($E($$UP^XLFSTR(X))="Y":"YES",1:"NO")
  1.  ;
  1.  D EN^XPAR("PKG",PARAMETER,,ANSWER,.ERRS)
  1.  ;
  1.  I +$G(ERRS)<1 D
  1.  . S RESULT=$$GET^XPAR("PKG",PARAMETER,1,"Q")
  1.  . W !!,?4,PARAMETER," Parameter is currently ",$S(RESULT:"YES",RESULT=0:"NO",1:"")
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  D:+$G(ERRS)>0 RPTERR(.ERRS,PARAMETER)
  1.  ;
  1.  Q
  1.  ;
  1. RPTERR(ERROR,PARAMETER) ; EP
  1.  NEW ERRDESC,ERRNUM,NOWH
  1.  ;
  1.  S ERRNUM=$P(ERROR,"^")
  1.  S ERRDESC=$P(ERROR,"^",2)
  1.  ;
  1.  W !!,"*** ERROR Modifying ",PARAMETER," paramter. ***",!!
  1.  W ?4,"Error Number:",ERRNUM,!
  1.  D LINEWRAP^BLRGMENU(9,ERRDESC,60)
  1.  W !
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  D STORERRS(ERROR,PARAMETER)
  1.  Q
  1.  ;
  1. STORERRS(ERROR,PARAMETER) ; EP - Store Error(s)
  1.  NEW (ERROR,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PARAMETER,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  S:$D(^XTMP(BLRVERN))<1 XTMP(BLRVERN)="^"_$$DT^XLFDT_"^Error(s) Modifying "_PARAMETER_" Parameter"
  1.  S $P(^XTMP(BLRVERN),"^")=$$HTFM^XLFDT(+$H+90)
  1.  ;
  1.  S NOWH=$H
  1.  S ^XTMP(BLRVERN,NOWH)=$$HTE^XLFDT(NOWH,"5Z")
  1.  M ^XTMP(BLRVERN,NOWH,"01","DUZ")=DUZ
  1.  S ^XTMP(BLRVERN,NOWH,"02","ERROR")=ERROR
  1.  ;
  1.  Q
  1.  ;
  1. EDITMGRP ; EP - Edit the LAB HIGH URGENCY NOTIFICATION Mail Group
  1.  D MAILGRPE("LAB HIGH URGENCY NOTIFICATION")
  1.  Q
  1.  ;
  1. MAILGRPE(MGROUP) ; EP - Mail Group Edit
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,MGROUP,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  ;
  1.  D ADDTMENU^BLRGMENU("ADDTMGRP^BLREMERA","Add User to Mail Group")
  1.  D ADDTMENU^BLRGMENU("DELFMGRP^BLREMERA","Delete User From Mail Group")
  1.  D ADDTMENU^BLRGMENU("LISTMGRP^BLREMERA","List Users on Mail Group")
  1.  ;
  1.  D MENUDRVR^BLRGMENU("RPMS Lab",MGROUP,$$CJ^XLFSTR("Mail Group Modifications",IOM))
  1.  Q
  1.  ;
  1. ADDTMGRP ; EP - ADD user(s) To Mail GRouP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,MGROUP,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="IHS Laboratory"
  1.  S HEADER(2)=MGROUP
  1.  S HEADER(3)=$$CJ^XLFSTR("Add User to Mail Group",IOM)
  1.  ;
  1.  S ONGO="YES",(NUMADD,NUMERRS)=0
  1.  F  Q:ONGO="NO"  D
  1.  . D HEADERDT^BLRGMENU
  1.  . D ^XBFMK
  1.  . S DIR(0)="PO^200:EMZ"
  1.  . D ^DIR
  1.  . I +$G(DIRUT) D PROMPTO^BLRUTIL7("Exit/No Entry.")  S ONGO="NO"  Q
  1.  . ;
  1.  . S NEWMEM=+Y,NEWMEMN=$P(Y,U,2)
  1.  . ;
  1.  . K XMY
  1.  . S XMY(+Y)=""
  1.  . S SUCCESS=$$MG^XMBGRP(MGROUP,,,,.XMY,,1)
  1.  . W !!
  1.  . I SUCCESS  W ?4,NEWMEMN," added to ",MGROUP  S NUMADD=NUMADD+1
  1.  . E  W ?4,NEWMEMN," *NOT* added to ",MGROUP  S NUMERRS=NUMERRS+1
  1.  . W !
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  W !!,?4,NUMADD," Users added to ",MGROUP,!
  1.  W !,?4,NUMERRS," Errors when trying to add users to ",MGROUP,!
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. DELFMGRP ; EP - DELete user(s) From Mail GRouP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,MGROUP,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="IHS Laboratory"
  1.  S HEADER(2)=MGROUP
  1.  S HEADER(3)=$$CJ^XLFSTR("Delete User from Mail Group",IOM)
  1.  ;
  1.  S MGIEN=$$FIND1^DIC(3.8,,,MGROUP)
  1.  ;
  1.  S ONGO="YES",(NUMDEL,NUMERRS)=0
  1.  F  Q:ONGO="NO"  D
  1.  . D HEADERDT^BLRGMENU
  1.  . D ^XBFMK
  1.  . Q:$$GETMEMS()<1
  1.  . D ^DIR
  1.  . I +$G(DIRUT) D PROMPTO^BLRUTIL7("Exit/No Entry.")  S ONGO="NO"  Q
  1.  . ;
  1.  . S DELMEM=+SELECTED(Y),DELMEMN=$P($G(SELECTED(Y)),U,2)
  1.  . K XMY
  1.  . S XMY(DELMEM)=""
  1.  . S SUCCESS=$$DM^XMBGRP(MGROUP,.XMY,1)
  1.  . W !!
  1.  . I SUCCESS  W ?4,DELMEMN," deleted from ",MGROUP," Mail Group"  S NUMDEL=NUMDEL+1
  1.  . E  W ?4,DELMEMN," *NOT* deleted from ",MGROUP," Mail Group"  S NUMERRS=NUMERRS+1
  1.  . W !
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  W !!,?4,$S(NUMDEL:NUMDEL,1:"No")," User",$S(NUMDEL>1:"s",1:"")," deleted from ",MGROUP,!
  1.  W:NUMDEL !,?4,NUMERRS," Errors when trying to delete users from ",MGROUP,!
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. GETMEMS() ; EP - GET the MEMberS of the Mail Group and setup DIR array
  1.  K MEMBER
  1.  S (MEMBER,MGMEMIEN)=0
  1.  F  S MGMEMIEN=$O(^XMB(3.8,MGIEN,1,"B",MGMEMIEN))  Q:MGMEMIEN<1  D
  1.  . S MEMBER($$GET1^DIQ(200,MGMEMIEN,.01))=MGMEMIEN
  1.  . S MEMBER=MEMBER+1
  1.  ;
  1.  Q:MEMBER<1 0
  1.  ;
  1.  K DIR,SELECTED
  1.  S DIR(0)="SO^",TAB=$J("",5)
  1.  S MEMNAME="",MEMCNT=0
  1.  F  S MEMNAME=$O(MEMBER(MEMNAME))  Q:MEMNAME=""  D
  1.  . S MEMCNT=MEMCNT+1
  1.  . S:MEMCNT=1 DIR(0)=$G(DIR(0))_MEMCNT_":"
  1.  . S:MEMCNT>1 DIR(0)=$G(DIR(0))_";"_MEMCNT_":"
  1.  . S DIR("L",MEMCNT+3)=TAB_MEMCNT_" "_MEMNAME
  1.  . S SELECTED(MEMCNT)=$G(MEMBER(MEMNAME))_U_MEMNAME
  1.  S DIR("L")=""
  1.  S DIR("L",1)="Select one of the users below to delete:"
  1.  S DIR("L",2)=""
  1.  S DIR("A")="Enter Number"
  1.  Q 1
  1.  ;
  1. LISTMGRP ; EP - LIST all the users on a Mail GRouP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,MGROUP,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="IHS Laboratory"
  1.  S HEADER(2)=MGROUP
  1.  S HEADER(3)=$$CJ^XLFSTR("Mail Group Members",IOM)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  ;
  1.  S HEADER(4)=" "
  1.  S $E(HEADER(5),5)="DUZ"
  1.  S $E(HEADER(5),15)="Name"
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S PG=0,QFLG="NO"
  1.  ;
  1.  S MGIEN=+$$FIND1^DIC(3.8,,,MGROUP)
  1.  S MEMBER=.9999999,CNT=0
  1.  F  S MEMBER=$O(^XMB(3.8,MGIEN,1,MEMBER))  Q:MEMBER<1!(QFLG="Q")  D
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  . S MEMIEN=MEMBER_","_MGIEN
  1.  . W ?4,$$GET1^DIQ(3.81,MEMIEN,.01,"I")
  1.  . W ?14,$$GET1^DIQ(3.81,MEMIEN,.01)
  1.  . W !
  1.  . S LINES=LINES+1
  1.  . S CNT=CNT+1
  1.  ;
  1.  W !!,?9,CNT," Members"
  1.  D PRESSKEY^BLRGMENU(14)
  1.  Q
  1.  ;
  1.  ;
  1. SETBLRVS(TWO) ; EP - Set the BLRVERN variable
  1.  K BLRVERN
  1.  ;
  1.  S BLRVERN=$P($P($T(+1),";")," ")
  1.  Q