source: WorldVistAEHR/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCAU.m@ 1800

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

initial load of WorldVistAEHR
File size: 8.8 KB
Line 
1GMRCAU ;SLC/DLT,JFR - Action Utilities ;10/17/01 18:31
2 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,11,14,12,15,17,22,55**;DEC 27, 1997;Build 4
3 ;
4 ; This routine invokes IA #2324,#2692
5 ;
6GETPROV K GMRCORNP N DIR S DIR(0)="123.02,3"
7 S DIR("A")=$S($D(GETPROV):GETPROV,1:"Responsible Clinician")
8 D ^DIR K DIR I $D(DTOUT)!$D(DIROUT)!(X="^") S GMRCQIT="Q" Q
9 G:Y<1 GETPROV S GMRCORNP=+Y
10 Q
11GETDT ;Get actual activity date
12 K GMRCQIT,%
13 D NOW^%DTC S (X,GMRCDT)=% D REGDTM^GMRCU S GMRCAD=X
14 S DIR(0)="123.02,2",DIR("A")=$S($D(GETDT):GETDT,1:"Date/Time of Actual Activity"),DIR("B")="NOW" D ^DIR K DIR I $D(DIRUT) S GMRCQIT="Q" Q
15 I X="NOW" K GMRCAD,Y Q
16 S GMRCAD=Y K X,Y,DIRUT,DUOUT
17 Q
18ORTX(GMRCO) ;Get the abbreviated text for alert displays
19 ;GMRCO is the consult entry from 123
20 N GMRCSVC,GMRCSSNM,GMRCPROC,GMRCORTX
21 S GMRCSSNM=$$SVC(GMRCO)
22 S GMRCPROC=$$PROC(GMRCO)
23 S GMRCORTX=$S($L(GMRCPROC):($E(GMRCSSNM,1,10)_" "_$E(GMRCPROC,1,10)),1:$E(GMRCSSNM,1,20))
24 Q GMRCORTX
25 ;
26SVC(GMRCO) ;Get abbreviated service text
27 N GMRCSSNM,GMRCSVC
28 S GMRCSVC=$P(^GMR(123,+GMRCO,0),"^",5),GMRCSSNM=""
29 I +GMRCSVC S GMRCSSNM=$S($L($G(^GMR(123.5,+GMRCSVC,.1))):^(.1),1:$P($G(^GMR(123.5,+GMRCSVC,0)),U,1))
30 Q GMRCSSNM
31PROC(GMRCO) ;Get abbreviated procedure text
32 N GMRCPROC
33 S GMRCPROC=$P(^GMR(123,+GMRCO,0),"^",8)
34 I +GMRCPROC S GMRCPROC=$$GET1^DIQ(123.3,+GMRCPROC,.01)
35 Q GMRCPROC
36 ;
37LMTX(GMRCO) ;Get the text for list manager displays
38 ;GMRCO is the consult entry from 123
39 N GMRCSVC,GMRCSSNM,GMRCREQ,GMRCORTX
40 S GMRCSSNM=$$SVC(GMRCO)
41 S GMRCREQ=$$PROC(GMRCO)
42 S GMRCORTX=$S($L(GMRCREQ):($E(GMRCSSNM,1,10)_" "_$E(GMRCREQ,1,10)),1:$E(GMRCSSNM,1,20))
43 Q GMRCORTX
44 ;
45 ;
46VALID(GMRCSER,GMRCO,GMRCUSER,GMRCTST,GMRCIFC) ;Get users update authority
47 ; check GMRCSS and all parents for authority
48 ; codes returned are same as $$VALIDU
49 N GMRCUPDL,GMRCLIS,GMRCHKD,GMRCNT,GMRCLP,GMRCQUIT
50 I '$G(GMRCUSER) S GMRCUSER=DUZ
51 ; check initial service first
52 S GMRCUPDL=$$VALIDU(GMRCSER,GMRCUSER,$G(GMRCIFC)) I +GMRCUPDL D G VALEX
53 . I $G(GMRCTST) S $P(GMRCUPDL,U,3)=$P($G(^GMR(123.5,+GMRCSER,0)),U)
54 S GMRCHKD(+GMRCSER)="",GMRCNT=1
55 ; find parents if set to process, quit if none
56 I '$P($G(^GMR(123.5,+GMRCSER,0)),U,7) G VALEX ;process parents = 0
57 D FINDPAR(GMRCSER,.GMRCNT) I '$D(GMRCLIS) S GMRCUPDL=0 G VALEX
58 S GMRCLP=0
59 F S GMRCLP=$O(GMRCLIS(GMRCLP)) Q:'GMRCLP!($D(GMRCQUIT)) D I +GMRCUPDL G VALEX
60 . I +$P(GMRCLIS(GMRCLP),U,2) K GMRCLIS(GMRCLP) Q ;been checked
61 . I '$D(GMRCHKD(+GMRCLIS(GMRCLP))) D
62 .. ; check parent
63 .. S GMRCUPDL=$$VALIDU(+GMRCLIS(GMRCLP),GMRCUSER,$G(GMRCIFC))
64 .. S GMRCHKD(+GMRCLIS(GMRCLP))=""
65 . S $P(GMRCLIS(GMRCLP),U,2)=1
66 . I +GMRCUPDL D Q ;got one
67 .. S:$G(GMRCTST) $P(GMRCUPDL,U,3)=$P($G(^GMR(123.5,+GMRCLIS(GMRCLP),0)),U)
68 . I $P(^GMR(123.5,+GMRCLIS(GMRCLP),0),U,7) D ;process parents
69 .. D FINDPAR(+GMRCLIS(GMRCLP),.GMRCNT)
70 . S GMRCLP=0 ;start back at top and don't miss any
71VALEX Q GMRCUPDL
72FINDPAR(SERV,ARCNT) ;find parents of SERV
73 ; SERV = service to find parents of
74 ; ARCNT = next array element
75 N PARENT
76 S PARENT=0
77 F S PARENT=$O(^GMR(123.5,"APC",SERV,PARENT)) Q:'PARENT D
78 . S GMRCLIS(ARCNT)=PARENT
79 . S ARCNT=ARCNT+1
80 Q
81 ;
82VALIDU(GMRCSS,GMRCUSR,GMRCIFC) ;Check to see if user is an update user
83 ;The value returned is the equivalent of this set of codes:
84 ; 0 = not an update user
85 ; 1 = unrestricted access user
86 ; 2 = update user
87 ; 3 = administrative update user
88 ; 4 = admin AND update user
89 ; 5 = IFC coordinator
90 ;
91 N GMRCUPD,GMRCAD,GMRCUP
92 I '$G(GMRCUSR) S GMRCUSR=DUZ
93 I '+$G(GMRCSS) Q 0
94 S GMRCAD=0,GMRCUP=0
95 I $G(GMRCIFC),$P($G(^GMR(123.5,GMRCSS,"IFC")),U,3) Q 5
96 I 'GMRCUP,$D(^GMR(123.5,+GMRCSS,123.3,"B",GMRCUSR)) D
97 . S GMRCUP=2_$$FIELD(123.3)
98 I 'GMRCUP,GMRCUSR=$P($G(^GMR(123.5,+GMRCSS,123)),"^",8) D
99 . S GMRCUP=2_$$FIELD(123.08)
100 I 'GMRCUP,+$P($G(^GMR(123.5,GMRCSS,0)),U,6) S GMRCUP=1_$$FIELD(.06)
101 I $D(^GMR(123.5,+GMRCSS,123.33,"B",GMRCUSR)) S GMRCAD=3_$$FIELD(123.33)
102 ;
103 I GMRCAD,GMRCUP Q $$BOTH(GMRCAD,GMRCUP) ;admin and upd user
104 ;
105 S GMRCUPD=0
106 ; check service teams to notify, update teams w/o
107 I 'GMRCUP N NODE F NODE=123.1,123.31 D I +GMRCUP Q
108 . I '$D(^GMR(123.5,+GMRCSS,NODE)) Q
109 . D TEAM(.GMRCUP,NODE,GMRCUSR)
110 ;
111 I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd user
112 ;
113 I 'GMRCAD D ;check adm teams w/o
114 . I '$D(^GMR(123.5,+GMRCSS,123.34)) Q
115 . D TEAM(.GMRCAD,123.34,GMRCUSR)
116 ;
117 I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd user
118 ;
119 ; check ASU user classes in field 123.35
120 I 'GMRCUP S GMRCUP=$$USR(GMRCSS,GMRCUSR)
121 ;
122 I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd
123 ;
124 I 'GMRCUP I $D(^GMR(123.5,+GMRCSS,123.2)) D LOC(.GMRCUP)
125 ;
126 I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd
127 I GMRCUP,'GMRCAD Q GMRCUP ;update user only
128 I GMRCAD,'GMRCUP Q GMRCAD ;admin user only
129 Q 0
130 ;
131BOTH(ADMN,UPD) ;return string with fields if testing
132 I $G(GMRCTST) Q "4^"_$P(ADMN,U,2)_" and "_$P(UPD,U,2)
133 Q 4
134 ;
135LOC(GMRCUPD) ;Check for the DUZ in the NOTIFICATION BY PT LOCATION multiple
136 N GMRCL,GMRCTM
137 S GMRCL=0 ;Check if DUZ is associated with any location/ward
138 F S GMRCL=$O(^GMR(123.5,+GMRCSS,123.2,GMRCL)) Q:'GMRCL!+GMRCUPD D Q:+GMRCUPD
139 . ;Get user and/or team assigned to location
140 . S GMRCL(0)=$G(^GMR(123.5,+GMRCSS,123.2,+GMRCL,0))
141 . I $P(GMRCL(0),"^",2)=DUZ S GMRCUPD=2 Q
142 . I $P(GMRCL(0),"^",3) S GMRCTM=$P(GMRCL(0),"^",3) ;D CHKTM
143 Q
144 ;
145TEAM(TYPE,SUBSC,USER) ;Check for the DUZ in the multiple of SUBSC
146 N GMRCTM,GMRCHIT
147 S GMRCTM=""
148 I '$G(USER) S USER=DUZ
149 F S GMRCTM=$O(^GMR(123.5,GMRCSS,SUBSC,"B",GMRCTM)) Q:'GMRCTM!+TYPE D
150 . S GMRCHIT=$$CHKTM(GMRCTM,USER) Q:'GMRCHIT
151 . S TYPE=$S(SUBSC=123.34:3,1:2)_$$FIELD(SUBSC)
152 Q
153 ;
154CHKTM(TEAM,PERS) ;checks for PERS in list of users on TEAM
155 ;Input: TEAM must be set to the Order Team entry number
156 ;Output: 1 will be returned PERS is on TEAM
157 N ND,GMRCLST,FOUND
158 S GMRCLST=""
159 D TEAMPROV^ORQPTQ1(.GMRCLST,TEAM)
160 I $P(GMRCLST(1),"^",2)="No providers found." Q 0
161 S ND=0
162 F S ND=$O(GMRCLST(ND)) Q:ND="" I +GMRCLST(ND)=PERS S FOUND=1 Q
163 Q $S($G(FOUND):1,1:0)
164 ;
165USR(SERV,USER) ; check USR classes for user
166 N UCLS,UPD
167 I '$O(^GMR(123.5,+SERV,123.35,0)) Q 0
168 S UCLS=0,UPD=0
169 F S UCLS=$O(^GMR(123.5,+SERV,123.35,"B",UCLS)) Q:'UCLS!(+UPD) D
170 . Q:'UCLS
171 . S UPD=$$ISA^USRLM(USER,UCLS)
172 . I +UPD S UPD=2_$$FIELD(123.35)
173 . Q
174 Q UPD
175FIELD(GMRCFLD) ;return field name where became update user
176 I '$G(GMRCTST) Q ""
177 D FIELD^DID(123.5,GMRCFLD,,"LABEL","GMRCFLD")
178 Q "^"_$G(GMRCFLD("LABEL"))
179COMPLETE(GMRCA) ;Determine if the action is a complete action (10,13,14)
180 S GMRCA=$G(GMRCA)
181 Q $S(GMRCA=13:1,GMRCA=14:1,GMRCA=10:1,1:0)
182 ; 10=administrative complete, 13=ADDENDUM ADDED, 14=New Note
183 ;
184RESOLUA(GMRCA) ;Determine if action has resolution info for clinician
185 ;Action value is based on value in ^ORD(100.01,"
186 ;Returns 1 for consult resolution, 0 for pending resolution
187 S GMRCA=$G(GMRCA)
188 Q $S(GMRCA=4:1,GMRCA=6:1,GMRCA=10:1,GMRCA=11:1,GMRCA=12:1,GMRCA=13:1,GMRCA=14:1,GMRCA=19:1,1:0)
189 ; 4=Sig Findings, 6=discontinued, 10=administrative complete
190 ; 11=Edit/resubmit
191 ; 12=Disassociate result, 13=Addendum Added, 14=New Note
192 ; 19=cancelled
193 ;
194RESOLUS(GMRCSTS) ;Determine status indicates the consult has a resolution
195 ;Status value is based on values in ^ORD(100.01,"
196 ;Returns 1 for consult resolution, 0 for pending resolution
197 S GMRCSTS=$G(GMRCSTS)
198 Q $S(GMRCSTS:1,GMRCSTS=2:1,GMRCSTS=13:1,1:0)
199 ; 1=dc,2=comp,13=canc
200 ;
201TEST ;called from GMRC UPDATE AUTHORITY
202 ; determines how a user gets update authority for a service
203 W !
204 N GMRCSRV,GMRCUSR,UPD,GMRCDG,GMRC1
205 N DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
206 S DIR(0)="PO^123.5:EM",DIR("A")="Select Consult Service"
207 S DIR("?")="Choose the consult service to check update status of user"
208 S DIR("??")="^D TESTHELP^GMRCAU(""ALL SERVICES"")" D ^DIR
209 I $D(DIRUT) Q
210 S GMRCSRV=+Y
211 N DIR
212 S DIR(0)="PO^200:EM",DIR("A")="Choose user to check for update status"
213 D ^DIR I $D(DIRUT) Q
214 S GMRCUSR=+Y
215 S UPD=$$VALID(GMRCSRV,,GMRCUSR,1)
216 I +UPD=0 W !!,"This user has no update authority"
217 I +UPD D
218 . I +UPD=2 W !!,"This user is an update user for: ",$P(UPD,U,3)
219 . I +UPD=3 W !!,"This user is an administrative user for: ",$P(UPD,U,3)
220 . I +UPD=4 D
221 .. W !!,"This user is both and administrative and update user"
222 .. W " for: ",!,$P(UPD,U,3)
223 . W !,"via the ",$P(UPD,U,2)," field",$S(+UPD=4:"(s).",1:".")
224 . W ! I $L($P(UPD,U,3)) D
225 .. I $P(UPD,U,3)'=$P(^GMR(123.5,+GMRCSRV,0),U) D HIER^GMRCT($P(UPD,U,3))
226 W !!
227 K GMRCSRV,GMRCUSR,UPD
228 K DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
229 G TEST
230TESTHELP(GMRCSVNM) ;wrapper for LISTSRV^GMRCASV
231 N DIR,GMRC1,GMRCDG
232 D LISTSRV^GMRCASV
233 Q
234TSTINTRO ;entry action of GMRC UPDATE AUTHORITY option
235 W !!,"This option will allow you to check a user's update authority for any given"
236 W !,"service in the consults hierarchy. If the PROCESS PARENTS FOR UPDATES field"
237 W !,"is set to YES, all ancestors of the selected service will be checked."
238 W !,"The type of update authority and the service to which they are assigned will"
239 W !,"be displayed.",!!
240 Q
Note: See TracBrowser for help on using the repository browser.