source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORB3USER.m@ 1608

Last change on this file since 1608 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1ORB3USER ; slc/CLA - Alert recipient algorithms for OE/RR 3 notifications; 1/19/00 14:45 [8/16/05 9:53am]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**74,91,105,139,200,220**;Dec 17, 1997
3USER(XQA,ORBDUZ,ORN,ORBU,ORBUI,ORBDFN,ORNUM) ;called from ORB3
4 ;check to see if potential recip (ORBDUZ) should be an alert recip
5 ;XQA array of alert recips passed to Kernel Alert Utility
6 ;ORBDUZ duz of current potential alert recipient
7 ;ORN notif ien from file 100.9
8 ;ORBU array of info for utility displaying recip who and why
9 ;ORBUI counter for utility array
10 ;ORBDFN patient ien from Patient file [#2]
11 ;ORNUM order number to base division params on[optional]
12 ;
13 N ORBNODE,ORBSUR,ORBTM,ORBTMF,ORBTEAM,ORBON,ORBDUP
14 I $G(ORBDUZ)["G." S XQA(ORBDUZ)="" Q
15 Q:+$G(ORBDUZ)<.5
16 ;
17 S ORBTM=$P(ORBDUZ,U,2) I $L(ORBTM) D ;if user recip via team
18 .S ORBTMF=$$GET^XPAR(ORBTM_";OR(100.21,","ORB PROCESSING FLAG",ORN,"I")
19 .S ORBTEAM=ORBTMF_U_$P(^OR(100.21,ORBTM,0),U)
20 .I $D(ORBU) D
21 ..S ORBU(ORBUI)=" User "_$P(^VA(200,+ORBDUZ,0),U)_" is a potential recipient via team "_$P(ORBTEAM,U,2),ORBUI=ORBUI+1
22 ;
23 I '$D(ORBU) D
24 .I $L($G(ORBTMF))=0 D
25 ..S:$D(^XTMP("ORBUSER",$J,+ORBDUZ)) ORBDUP=1
26 ..S ^XTMP("ORBUSER",$J,+ORBDUZ)=""
27 Q:$G(ORBDUP)=1 ;quit if user already processed and no team param value
28 ;
29 S ORBDUZ=$P(ORBDUZ,U)
30 ;
31 S:$G(ORBTEAM)="" ORBTEAM="^"
32 S ORBON=$$ONOFF(ORN,ORBDUZ,ORBDFN,ORBTEAM,$G(ORNUM))
33 I $D(ORBU) D
34 .S ORBNODE=$G(^VA(200,ORBDUZ,0)) I $L($G(ORBNODE)) D
35 ..S ORBU(ORBUI)=" "_$P(ORBNODE,U)_": "_$P(ORBON,U)_" because ",ORBUI=ORBUI+1
36 ..S ORBU(ORBUI)=" "_$P(ORBON,U,2),ORBUI=ORBUI+1
37 I $D(ORBU),($P(ORBON,U)="ON"),($G(ORBDUZ)'["G.") D
38 .S ORBSUR=$$ACTVSURO^XQALSURO(ORBDUZ) ;DBIA 2790 Alert surrogate
39 .I +$G(ORBSUR)>0 D
40 ..S ORBU(ORBUI)=" [Surrogate "_$$GET1^DIQ(200,ORBSUR_",",.01)_" will receive alert for user]",ORBUI=ORBUI+1
41 Q:$P(ORBON,U)="OFF" ;quit if user is disabled for this notif
42 Q:$D(ORBU) ;quit if entered rtn via UTL (do not sent alert)
43 D PREALERT(ORBDUZ,ORN,ORBDFN) ;if user has undel prev alert, delete it
44 S XQA(ORBDUZ)="" ;send alert to the user
45 Q
46 ;
47PREALERT(ORBDUZ,ORN,ORBDFN) ;if user (ORBDUZ) has an undeleted previous
48 ;version of this alert (ORN) for patient (ORBDFN), delete it
49 ;
50 Q:$P(^ORD(100.9,ORN,0),U,4)'="NOT" ;quit if not a "NOT" notif/alert
51 N XQAID,XQAKILL,XQAUSER,ORBDT
52 S XQAID="OR,"_ORBDFN_","_ORN
53 I $D(^XTV(8992,"AXQAN",XQAID,ORBDUZ)) D ;DBIA# 2689
54 .S ORBDT=0,ORBDT=$O(^XTV(8992,"AXQAN",XQAID,ORBDUZ,ORBDT))
55 .I $G(ORBDT)>0 D
56 ..S XQAUSER=ORBDUZ
57 ..S XQAKILL=1
58 ..D DELETEA^XQALERT
59 Q
60 ;
61ONOFF(ORN,ORBUSR,ORBPT,ORBTEAM,ORNUM) ;Extrinsic function to check param file
62 ;determines if user ORBUSR should receive notification ORN for patient
63 ;patient ORBPT. If ORBUSR was derived via teams, ORBTEAM may be used.
64 ;ORN notification ien from file 100.9 (req'd)
65 ;ORBUSR user ien from file 200 (req'd)
66 ;ORBPT patient ien from file 2 (not req'd)
67 ;ORBTEAM processing flag^name for team assoc. w/ORBUSR (not req'd)
68 ;ORNUM order number to base division params on (not req'd)
69 N NODE,ORBPTN,ORBNOTN,ORBUSRF,ORBUSRN,ORBLOC,ORBLOCF,ORBLOCN
70 S (ORBPTN,ORBNOTN,ORBUSRF,ORBUSRN,ORBLOC,ORBLOCF,ORBLOCN)=""
71 N ORBSRV,ORBSRVF,ORBSRVN,ORBTEA,ORBTEAF,ORBTEAN,ORBTEAD,ORBTEAE
72 S (ORBSRV,ORBSRVF,ORBSRVN,ORBTEA,ORBTEAF,ORBTEAN,ORBTEAD,ORBTEAE)=""
73 N ORBCLS,ORBCLSF,ORBCLSN,ORBLST,ORBI
74 S (ORBCLS,ORBCLSF,ORBCLSN)=""
75 N ORBDIV,ORBDIVF,ORBDIVN,ORBSYSF,ORBPKGF
76 S (ORBDIV,ORBDIVF,ORBDIVN,ORBSYSF,ORBPKGF)=""
77 ;
78 ;get notification name:
79 S NODE=$G(^ORD(100.9,ORN,0)) S:$L($G(NODE)) ORBNOTN=$P(NODE,U)
80 ;
81 ;get user name:
82 S NODE=$G(^VA(200,ORBUSR,0)) S:$L($G(NODE)) ORBUSRN=$P(NODE,U)
83 ;
84 ;get patient name:
85 S:$L($G(ORBPT)) NODE=$G(^DPT(ORBPT,0)) S:$L($G(NODE)) ORBPTN=$P(NODE,U)
86 ;
87 ;get division flag and name:
88 S ORBDIV=$$DIVF(ORBUSR,ORN,$G(ORNUM))
89 I $L(ORBDIV) D
90 .S ORBDIVF=$P(ORBDIV,U,2),ORBDIV=$P(ORBDIV,U),NODE=$G(^DIC(4,ORBDIV,0))
91 .S:$L($G(NODE)) ORBDIVN=$P(NODE,U)
92 ;
93 ;get system flag:
94 S ORBSYSF=$$GET^XPAR("SYS","ORB PROCESSING FLAG",ORN,"I")
95 ;
96 ;get OE/RR package-export flag:
97 S ORBPKGF=$$GET^XPAR("PKG","ORB PROCESSING FLAG",ORN,"I")
98 ;
99 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
100 ;reliably determined, and many simultaneous outpt locations can occur):
101 I +$G(ORBPT)>0 D
102 .N DFN S DFN=ORBPT,VA200="" D OERR^VADPT
103 .S ORBLOC=+$G(^DIC(42,+VAIN(4),44)) I +$G(ORBLOC)>0 D
104 ..S ORBLOCN=$P(^SC(+ORBLOC,0),U)
105 ..S ORBLOCF=$$GET^XPAR(+$G(ORBLOC)_";SC(","ORB PROCESSING FLAG",ORN,"I")
106 K VA200,VAIN
107 ;
108 ;get user's service/section flag:
109 S ORBSRV=$G(^VA(200,ORBUSR,5)) I +ORBSRV>0 S ORBSRV=$P(ORBSRV,U) D
110 .S NODE=$G(^DIC(49,ORBSRV,0)) S:$L($G(NODE)) ORBSRVN=$P(NODE,U)
111 .S:+$G(ORBSRV)>0 ORBSRVF=$$GET^XPAR(ORBSRV_";DIC(49,","ORB PROCESSING FLAG",ORN,"I")
112 ;
113 ;get user's team flag:
114 I $L($G(ORBTEAM)) S ORBTEAF=$P(ORBTEAM,U),ORBTEAN=$P(ORBTEAM,U,2)
115 ;
116 ;get class flag for the user's most recently active ASU class
117 ;S ORBCLS=$$RECENT(ORBUSR) I $L($G(ORBCLS))>0 D
118 ;.S ORBCLSN=$P(ORBCLS,U,2),ORBCLS=$P(ORBCLS,U)
119 ;.S:+$G(ORBCLS)>0 ORBCLSF=$$GET^XPAR(ORBCLS_";USR(8930,","ORB PROCESSING FLAG",ORN,"I")
120 ;
121 ;get user's flag:
122 S ORBUSRF=$$GET^XPAR(ORBUSR_";VA(200,","ORB PROCESSING FLAG",ORN,"I")
123 ;
124 ;determine overall flag:
125 I $G(ORBUSRF)="M" Q "ON^User "_ORBUSRN_" is Mandatory.^User value is Mandatory"
126 I $G(ORBUSRF)="E" Q "ON^User "_ORBUSRN_" is Enabled.^User value is Enabled"
127 ;I $G(ORBCLSF)="M" Q "ON^User's class "_ORBCLSN_" is Mandatory.^User's class "_ORBCLSN_" value is Mandatory"
128 I $G(ORBTEAF)="M" Q "ON^User's team "_ORBTEAN_" is Mandatory.^User's team "_ORBTEAN_" value is Mandatory"
129 I $G(ORBTEAF)="D" Q "OFF^User's team "_ORBTEAN_" is Disabled.^User's team "_ORBTEAN_" value is Disabled"
130 I $G(ORBSRVF)="M" Q "ON^User's service "_ORBSRVN_" is Mandatory.^User's service "_ORBSRVN_" value is Mandatory"
131 I $G(ORBLOCF)="M" Q "ON^Patient's location "_ORBLOCN_" is Mandatory.^Pt's location "_ORBLOCN_" value is Mandatory"
132 I $G(ORBLOCF)="D" Q "OFF^Patient's location "_ORBLOCN_" is Disabled.^Pt's location "_ORBLOCN_" value is Disabled"
133 I $G(ORBDIVF)="M",($G(ORBLOCF)="") Q "ON^Division "_ORBDIVN_" is Mandatory, no Pt Location value.^Division "_ORBDIVN_" value is Mandatory"
134 I $G(ORBSYSF)="M",($G(ORBDIVF)=""),($G(ORBLOCF)="") Q "ON^System default is Mandatory, no Division or Pt Location values.^System value is Mandatory"
135 I $G(ORBPKGF)="M",($G(ORBSYSF)=""),($G(ORBDIVF)=""),($G(ORBLOCF)="") Q "ON^OERR default is Mandatory, no Division, System, or Pt Location values.^OERR value is Mandatory"
136 I $G(ORBUSRF)="D" Q "OFF^User "_ORBUSRN_" is Disabled - no Mandatory values found.^User value is Disabled"
137 ;I $G(ORBCLSF)="D" Q "OFF^User's class "_ORBCLSN_" is Disabled - no Mandatory values found.^User's class "_ORBCLSN_" value is Disabled""
138 I $G(ORBTEAF)="E" Q "ON^User's team "_ORBTEAN_" is Enabled.^User's team "_ORBTEAN_" value is Enabled"
139 I $G(ORBSRVF)="D" Q "OFF^User's service "_ORBSRVN_" is Disabled.^User's service "_ORBSRVN_" value is Disabled"
140 I $G(ORBSRVF)="E" Q "ON^User's service "_ORBSRVN_" is Enabled.^User's service "_ORBSRVN_" value is Enabled"
141 I $G(ORBLOCF)="E" Q "ON^Patient's location "_ORBLOCN_" is Enabled.^Pt's location "_ORBLOCN_" value is Enabled"
142 I $G(ORBDIVF)="D" Q "OFF^Division "_ORBDIVN_" is Disabled.^Division "_ORBDIVN_" value is Disabled"
143 I $G(ORBDIVF)="E" Q "ON^Division "_ORBDIVN_" is Enabled.^Division "_ORBDIVN_" value is Enabled"
144 I $G(ORBSYSF)="D" Q "OFF^System default is Disabled.^System value is Disabled"
145 I $G(ORBSYSF)="E" Q "ON^System default is Enabled.^System value is Enabled"
146 I $G(ORBPKGF)="D" Q "OFF^OERR default is Disabled.^OERR value is Disabled"
147 I $G(ORBPKGF)="E" Q "ON^OERR default is Enabled.^OERR value is Enabled"
148 Q "OFF^No Mandatory, Disabled or Enabled values found.^No Mandatory/Disabled/Enabled values"
149 ;
150RECENT(USER) ;ext funct rtns a user's most recent, active user class
151 Q:+$G(USER)<1 "^Error: User not identified."
152 N CLS,CLASS,INACT,ACT,ORX,INVDT,RESULT
153 ;call api to determine user's class(es)
154 Q:'$L($G(CLS(0))) "^No user classes found."
155 D NOW^%DTC
156 S CLASS="" F S CLASS=$O(CLS(CLASS)) Q:CLASS="" D
157 .S INACT=$P(CLS(CLASS),U,5),ACT=$P(CLS(CLASS),U,4)
158 .I INACT,(INACT<%) Q ;quit if class has an inactive date before now
159 .Q:'ACT ;quit if class has no active date
160 .S ORX("DT",9999999-ACT)=$P(CLS(CLASS),U)_U_CLASS
161 S INVDT="",INVDT=$O(ORX("DT",INVDT))
162 I INVDT S RESULT=ORX("DT",INVDT)
163 E S RESULT="^No user classes found."
164 K %
165 Q RESULT
166DIVF(USER,ORN,ORNUM) ;ext funct rtns user's division value for ORB PROCESSING FLAG
167 N DIV,DIVF,MDIVF,EDIVF,DDIVF
168 I +$G(ORNUM) D Q DIVF
169 .S DIVF=""
170 .S DIV=$$ORDIV^ORB31(ORNUM)
171 .I +$G(DIV)'>0 Q
172 .S DIVF=$$GET^XPAR(DIV_";DIC(4,","ORB PROCESSING FLAG",ORN,"I")
173 .I $L(DIVF) S DIVF=DIV_U_DIVF
174 S DIV=0,(DIVF,MDIVF,EDIVF,DDIVF)=""
175 F S DIV=$O(^VA(200,USER,2,"B",DIV)) Q:+$G(DIV)<1!(DIVF="M") D
176 .S DIVF=$$GET^XPAR(DIV_";DIC(4,","ORB PROCESSING FLAG",ORN,"I")
177 .I DIVF="M" S MDIVF=DIV_U_DIVF
178 .I DIVF="E" S EDIVF=DIV_U_DIVF
179 .I DIVF="D" S DDIVF=DIV_U_DIVF
180 Q:$L(MDIVF) MDIVF
181 Q:$L(EDIVF) EDIVF
182 Q:$L(DDIVF) DDIVF
183 Q ""
Note: See TracBrowser for help on using the repository browser.