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

BEHOXQ.m

Go to the documentation of this file. 
  1. BEHOXQ ;MSC/IND/DKM - Notification Support ;19-Nov-2013 16:57;PLS
  1.  ;;1.1;BEH COMPONENTS;**002003,002004,002006,002007**;Mar 20, 2007;Build 1
  1.  ;=================================================================
  1.  ; RPC: Get alerts for user
  1.  ;   DFN = If specified, limit alerts to only that patient
  1.  ;   ST  = If specified, starting date/time for alert retrieval
  1.  ;   Return format is:
  1.  ;    Priority^Info Only^Patient Name^Pt Location^Display Text^Date Delivered^Sender Name^DFN^Alert Type^Alert ID^Can Delete^Extra Info
  1. ALRLIST(DATA,DFN,ST) ;EP
  1.  N ALX,TOT,ALL,TMP,FN,NOW,QUALS,X,X3
  1.  D SETVAR^CIANBUTL("DFN",$G(DFN),"BEHOXQ")
  1.  S ALL='$L($G(DFN)),DFN=+$G(DFN),(ALX,TOT)=0,TMP=$$TMPGBL^CIAVMRPC,FN=90460.021,NOW=$$NOW^XLFDT,ST=+$G(ST)
  1.  D:'ST CLRVAR^CIANBUTL("BEHOXQ.AID")
  1.  D FIXXQA(DUZ)
  1.  F  S ALX=$O(^BEHOXQ(FN,ALX)) Q:'ALX  X $G(^(ALX,4))
  1.  S ALX=0
  1.  F  S ST=$O(^XTV(8992,DUZ,"XQA",ST)) Q:'ST  S X=$G(^(ST,0)),X3=$G(^(3)) D:$L(X)
  1.  .S ALX=ALX+1,@TMP@(ALX)=$S(X3'="":"G  ",$P(X,U,7,8)="^ ":"I  ",1:"   ")_$P(X,U,3)_U_$P(X,U,2)_U_$P(X,U)_U_$P(X,U,10)
  1.  S ALX=0
  1.  F  S ALX=$O(@TMP@(ALX)) Q:'ALX  D
  1.  .N ALR,ALY,ALD,ALW,ALS,AID,ALT,DFN2,INF,DEL,LOC
  1.  .S ALD=$G(@TMP@(ALX)),AID=$P(ALD,U,2),ALY=$$ALRIEN(AID),ALW=$P(ALD,U,3),DEL=''$P(ALD,U,4)
  1.  .Q:'ALY
  1.  .X $G(^BEHOXQ(FN,ALY,2))
  1.  .S ALT=$P(^BEHOXQ(FN,ALY,0),U),DFN2=+$G(ALR("DFN")),INF=''$G(ALR("INF"))
  1.  .S:INF DEL=1
  1.  .;I DFN2,'$$ISACTIVE^BEHOPTCX(DFN2,.QUALS) Q  ;P7
  1.  .I 'ALL,DFN2,DFN'=DFN2 Q
  1.  .S TOT=TOT+1,ALD=$E($P(ALD,U),4,999)
  1.  .S:ALD["): " ALD=$P(ALD,"): ",2,99)
  1.  .S ALR("TYP")=ALT_$S($L($G(ALR("TYP"))):"."_ALR("TYP"),1:"")
  1.  .S X=+$O(^XTV(8992.1,"B",AID,0)),X3=$G(^XTV(8992.1,X,20,+$O(^XTV(8992.1,X,20,"B",DUZ,$C(1)),-1),0)),ALS=+$P(X3,U,7)
  1.  .I ALS S ALW=$P(X3,U,8)  ; Alert was forwarded
  1.  .E  S ALS=$P($G(^XTV(8992.1,X,0)),U,5)
  1.  .S ALS=$$GET1^DIQ(200,+ALS,.01)
  1.  .S X=$P($G(^DPT(DFN2,0)),U),X3=$$HRN^BEHOPTCX(DFN2)
  1.  .;Added Patient Location (Room/Bed)
  1.  .S LOC=$G(^DPT(DFN2,.1))_"  "_$G(^DPT(DFN2,.101))
  1.  .S:$L(X3) X=X_"    ("_X3_")"
  1.  .S @DATA@(DFN2,TOT)=$G(ALR("PRI"),2)_U_INF_U_X_U_LOC_U_ALD_U_ALW_U_ALS_U_DFN2_U_ALR("TYP")_U_AID_U_DEL_U_$G(ALR("XTR"))
  1.  .D SETVAR^CIANBUTL(AID,1,"BEHOXQ.AID")
  1.  D SETVAR^CIANBUTL("START",NOW,"BEHOXQ")
  1.  K @TMP
  1.  Q
  1.  ; RPC: Retrieve comment and message text associated with an alert.
  1. ALRMSG(DATA,AID) ;EP
  1.  N CMT
  1.  I $$TEST^CIAUOS("XQALGUI") D
  1.  .N FNC
  1.  .S FNC("XQAID")=AID,FNC("LOC")="GETLONG"
  1.  .D ENTRY^XQALGUI(.DATA,.FNC)
  1.  S CMT=$P($G(^XTV(8992,DUZ,"XQA",$$XTVIEN(AID),2)),U,3)
  1.  S:$L(CMT) @DATA@(-2)=CMT,@DATA@(-1)=""
  1.  Q
  1.  ; RPC: Forward an alert
  1. FORWARD(DATA,AID,USR,CMT) ;EP
  1.  D FORWARD^XQALFWD(.AID,.USR,"A",$G(CMT))
  1.  S DATA=0
  1.  Q
  1.  ; Check for new and deleted alerts
  1. ALRCHECK N ST,TMP,X,Y
  1.  S ST=$$GETVAR^CIANBUTL("START",0,"BEHOXQ"),TMP=$$TMPGBL^CIAVMRPC(1),X=""
  1.  D ALRLIST(TMP,$$GETVAR^CIANBUTL("DFN",,"BEHOXQ"),ST)
  1.  F  S X=$O(@TMP@(X)),Y=0 Q:'$L(X)  D
  1.  .F  S Y=$O(@TMP@(X,Y)) Q:'Y  D
  1.  ..D QUEUE^CIANBEVT("ALERT.ADD",@TMP@(X,Y))
  1.  K @TMP
  1.  F  S X=$O(^XTMP("CIA",CIA("UID"),"V","BEHOXQ.AID",X)) Q:'$L(X)  D
  1.  .Q:$D(^XTV(8992,"AXQA",X))
  1.  .D QUEUE^CIANBEVT("ALERT.DELETE",X),SETVAR^CIANBUTL(X,,"BEHOXQ.AID")
  1.  Q
  1.  ; RPC: Alert post processing
  1. ALRPP(DATA,AID) ;EP
  1.  S DATA=$$ALRIEN(AID)
  1.  X:DATA $G(^BEHOXQ(90460.021,DATA,3))
  1.  Q
  1.  ; Return IEN of alert handler
  1. ALRIEN(AID) ;
  1.  N ALY,FN,IEN
  1.  S (ALY,IEN)=0,FN=90460.021
  1.  F  S ALY=$O(^BEHOXQ(FN,ALY)) Q:'ALY  D  Q:IEN
  1.  .I 0
  1.  .X $G(^BEHOXQ(FN,ALY,1))
  1.  .I  S IEN=ALY
  1.  Q IEN
  1.  ; Return IEN of alert in ALERT file
  1. XTVIEN(AID) ;
  1.  Q +$O(^XTV(8992,"AXQA",AID,DUZ,$C(1)),-1)
  1.  ; Parse an order alert
  1. ORPARSE(AID,ALR) ;
  1.  N ORN,PRI
  1.  S ORN=$P($P(AID,";"),",",3)
  1.  D URGENCY^ORQORB(.PRI,ORN)
  1.  S ALR("INF")=$P($G(^ORD(100.9,ORN,0)),U,6,7)="INFODEL^ORB3FUP2"
  1.  S ALR("DFN")=+$P(AID,",",2),ALR("TYP")=+$P($P(AID,";"),",",3),ALR("PRI")=$S(PRI>0:PRI,1:2)
  1.  Q
  1.  ; Parse a TIU alert
  1. TIUPARSE(AID,ALR) ;
  1.  N X
  1.  D GETALRT^TIUSRVR(.X,AID)
  1.  S ALR("XTR")=$P(X,U,3),ALR("TYP")=+ALR("XTR"),ALR("DFN")=+$P(X,U,2),ALR("PRI")=2
  1.  S ALR("XTR")=ALR("XTR")_U_"VSIT="_$P($G(^TIU(8925,+X,0)),U,3)
  1.  Q
  1.  ; Parse a BEH alert
  1. BEHPARSE(AID,ALR) ;EP
  1.  N XQAID,XQADATA,XQAROU,XQAOPT,X,Y,Z
  1.  D GETACT^XQALERT(AID)
  1.  S ALR("INF")=XQAROU="^ ",ALR("XTR")=XQADATA
  1.  F Z=1:1:$L(XQADATA,U) D
  1.  .S X=$P(XQADATA,U,Z),Y=$P(X,"=",2,999),X=$P(X,"=")
  1.  .S:$L(X) ALR(X)=Y
  1.  Q
  1.  ; Delete a BEH alert
  1. BEHDEL(XQAID,XQAKILL) ;EP
  1.  N XQAFOUND
  1.  D DELETE^XQALERT
  1.  Q:$Q +$G(XQAFOUND)
  1.  Q
  1.  ; RPC: Schedule an alert
  1. SCHALR(DATA,DAT,ID,SBJ,XTR,MSG,RCP) ;EP
  1.  N FDA,ERR,SUB,X,Y
  1.  S FDA=$NA(FDA(90460.022,"+1,"))
  1.  S @FDA@(.01)=DAT
  1.  S @FDA@(1)=ID
  1.  S @FDA@(2)="`"_DUZ
  1.  S @FDA@(5)=$G(SBJ)
  1.  S @FDA@(6)=$G(XTR)
  1.  S:$D(MSG)>1 @FDA@(20)="MSG"
  1.  S:'$D(RCP) RCP=DUZ
  1.  S:$G(RCP) RCP(-1)=RCP
  1.  S X="",Y=2
  1.  F  S X=$O(RCP(X)) Q:'$L(X)  D
  1.  .S RCP=RCP(X),RCP=$S('RCP:"",RCP<0:"G.`"_-RCP,1:"U.`"_RCP)
  1.  .S:$L(RCP) FDA(90460.0221,"+"_Y_",+1,",.01)=RCP,Y=Y+1
  1.  D UPDATE^DIE("UE","FDA",,"ERR")
  1.  S DATA='$D(ERR),SUB("DUZ",DUZ)=""
  1.  D:DATA BRDCAST^CIANBEVT("ALERT.SCHEDULE.ADD","",.SUB)
  1.  Q
  1.  ; Check for scheduled alerts
  1. SCHCHECK N DAT,NOW,IEN,FN
  1.  S DAT=0,NOW=$$NOW^XLFDT,FN=90460.022
  1.  F  S DAT=$O(^BEHOXQ(FN,"B",DAT)),IEN=0 Q:'DAT!(DAT>NOW)  D
  1.  .F  S IEN=$O(^BEHOXQ(FN,"B",DAT,IEN)) Q:'IEN  D
  1.  ..L +^BEHOXQ(FN,IEN):0
  1.  ..E  Q
  1.  ..N X,XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLG,XQAARCH,XQASURO,XQASUPV,XQATEXT,DUZ,RCP
  1.  ..S X=$G(^BEHOXQ(FN,IEN,0)),XQAMSG=$G(^(5)),XQADATA=$G(^(6)),XQAID=$P(X,U,2),DUZ=$P(X,U,3),XQATEXT=$NA(^(20)),RCP="",DUZ(2)=+$$GETDIV(DUZ)  ;IHSDIV^XUS1(DUZ)
  1.  ..I $$PATCH^XPDUTL("XU*8.0*285") D
  1.  ...N TMP S TMP=XQATEXT
  1.  ...K XQATEXT
  1.  ...M XQATEXT=@TMP
  1.  ..F  S RCP=$O(^BEHOXQ(FN,IEN,10,"B",RCP)) Q:'$L(RCP)  D
  1.  ...I RCP[";VA(200," S XQA(+RCP)=""
  1.  ...E  S XQA("G."_$$GET1^DIQ(3.8,+RCP,.01))=""
  1.  ..D SETUP^XQALERT,SCHDEL(,IEN)
  1.  ..L -^BEHOXQ(FN,IEN)
  1.  Q
  1.  ; RPC: Delete a scheduled alert
  1.  ;   DATA = True if entry deleted
  1. SCHDEL(DATA,IEN) ;EP
  1.  N FN,SUB
  1.  S FN=90460.022,DATA=0,SUB("DUZ",+$P($G(^BEHOXQ(FN,IEN,0)),U,3))=""
  1.  L +^BEHOXQ(FN,IEN):0
  1.  E  Q
  1.  D DIK(90460.022,IEN)
  1.  L -^BEHOXQ(FN,IEN)
  1.  S DATA='$D(^BEHOXQ(FN,IEN))
  1.  D:DATA BRDCAST^CIANBEVT("ALERT.SCHEDULE.DELETE",IEN,.SUB)
  1.  Q
  1.  ; RPC: List alerts scheduled by user.
  1.  ;  ID  = Alert ID
  1.  ;  USR = IEN of user (defaults to current)
  1.  ;  Return format is: IEN^Date^Patient Name^Subject^Data
  1. SCHLIST(DATA,ID,USR) ;EP
  1.  N X,IEN,CNT,DAT,DFN,SBJ,XTR
  1.  S:'$G(USR) USR=DUZ
  1.  S (IEN,CNT)=0
  1.  F  S IEN=$O(^BEHOXQ(90460.022,"C",USR,IEN)) Q:'IEN  D
  1.  .S X=$G(^BEHOXQ(90460.022,IEN,0)),SBJ=$G(^(5)),XTR=$G(^(6))
  1.  .Q:$P(X,U,2)'=ID
  1.  .S DAT=+X,DFN=+$P(U_XTR,"^DFN=",2),CNT=CNT+1
  1.  .S @DATA@(CNT)=IEN_U_DAT_U_$P($G(^DPT(DFN,0)),U)_U_SBJ_U_XTR
  1.  Q
  1.  ; RPC: Return list of recipients
  1. SCHRECIP(DATA,IEN) ;EP
  1.  N RCP,CNT,X
  1.  S RCP="",CNT=0
  1.  F  S RCP=$O(^BEHOXQ(90460.022,IEN,10,"B",RCP)) Q:'$L(RCP)  D
  1.  .I RCP[";VA(200," S X=+RCP_U_$$GET1^DIQ(200,+RCP,.01)
  1.  .E  S X=-RCP_U_"G."_$$GET1^DIQ(3.8,+RCP,.01)
  1.  .S CNT=CNT+1,@DATA@(CNT)=X
  1.  Q
  1.  ; RPC: Return message text associated with a scheduled alert.
  1. SCHMSG(DATA,IEN) ;EP
  1.  M @DATA=^BEHOXQ(90460.022,IEN,20)
  1.  K @DATA@(0)
  1.  Q
  1.  ; Delete a file entry
  1. DIK(DIK,DA) ;EP
  1.  S:DIK=+DIK DIK=$$ROOT^DILFD(DIK)
  1.  D ^DIK
  1.  Q
  1.  ; Return true if notification type is enabled
  1.  ;   ORN = IEN in OE/RR NOTIFICATION file
  1.  ;   USR = Potential recipient of notification
  1. ENABLED(ORN,USR) ;EP
  1.  Q:'ORN 1
  1.  Q:'$D(^ORD(100.9,ORN,0)) 1
  1.  ;IHS/MSC/PLS - 11/19/2013
  1.  ;I $$PATCH^XPDUTL("OR*3.0*220") Q:$$GET^XPAR($$ENTITY^ORB31(ORN),"ORB SYSTEM ENABLE/DISABLE",1,"I")="D" 0
  1.  ;E  Q:$$GET^XPAR($$ENTITY^ORB31(ORN,USR),"ORB SYSTEM ENABLE/DISABLE",1,"I")="D" 0
  1.  Q:$$GET^XPAR("DIV^SYS^PKG","ORB SYSTEM ENABLE/DISABLE",1,"I")="D" 0
  1.  Q $$GET^XPAR($$ENT^CIAVMRPC("ORB PROCESSING FLAG",,USR),"ORB PROCESSING FLAG",ORN)'="D"
  1.  ; Fix XQA node in Alert File for user
  1. FIXXQA(USER) ;
  1.  I $D(^XTV(8992,USER,"XQA",0))#2,'$P(^(0),U,2) S $P(^(0),U,2)="8992.01DA"
  1.  Q
  1.  ; Return mail group IEN if user is a member of the specified mail group
  1.  ; or indirectly through a member mail group.
  1. ISMBR(MGRP,USER,EXCL) ;PEP - See comment above
  1.  S USER=$G(USER,DUZ)
  1.  S:MGRP'=+MGRP MGRP=$O(^XMB(3.8,"B",MGRP,0))
  1.  Q:'MGRP 0
  1.  Q:$D(EXCL(MGRP)) 0
  1.  Q:$D(^XMB(3.8,MGRP,1,"B",USER)) MGRP
  1.  N GRP
  1.  S EXCL(MGRP)="",GRP=0
  1.  F  S GRP=$O(^XMB(3.8,MGRP,5,"B",GRP)) Q:'GRP  Q:$$ISMBR(GRP,USER,.EXCL)
  1.  Q +GRP
  1. GETDIV(USR) ;EP
  1.  Q:$G(DUZ("AG"))="I" $$IHSDIV^XUS1(USR)
  1.  N X
  1.  ; Default Division in file 200, "AX1" x-ref
  1.  S X=+$O(^VA(200,USR,2,"AX1",1,0))
  1.  ; If only one division get that one
  1.  I 'X D
  1.  .S X=+$O(^VA(200,USR,2,0))
  1.  .S:$O(^VA(200,USR,2,X)) X=0
  1.  Q X
  1. CANCHGPT(DATA,DFN) ; EP-
  1.  S DATA=$$ISACTIVE^BEHOPTCX(DFN)
  1.  Q