source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m@ 1670

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

revised back to 6/30/08 version
File size: 8.5 KB
Line 
1TIULP ; SLC/JER - Functions determining privilege ;7/29/05
2 ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217**;Jun 20, 1997
3CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now
4 ; Receives: TIUDA=Record number in file 8925
5 ; TIUACT=Name of user action in 8930.8 (USR ACTION)
6 ; PERSON=New Person file IFN.
7 ; Assumed to be DUZ if not received.
8 ; New **100** ID param, backward compatible.
9 ; Returns: TIUY=1:yes,0:no_"^"_why not message
10 N TIUI,TIUTYP,TIUROLE,STATUS,TIUY,TIUATYP,MSG,WHO,MODIFIER,TIUD0,TIUACTW
11 S TIUY=0 I '$G(PERSON) S PERSON=DUZ
12 S TIUD0=$G(^TIU(8925,+TIUDA,0)) I 'TIUD0 G CANDOX
13 I $$ISPRFDOC^TIUPRF(TIUDA),((TIUACT="ATTACH ID ENTRY")!(TIUACT="ATTACH TO ID NOTE")) S TIUY="0^Patient Record Flag notes may not be used as Interdisciplinary notes." G CANDOX
14 S TIUACTW=$G(TIUACT)
15 ;**100** was I +TIUACT'>0 S TIUACT etc.
16 S TIUACT=$$USREVNT(TIUACT) I +TIUACT'>0 G CANDOX
17 ; -- Historical Procedures - Prohibit actions detailed in
18 ; HPCAN^TIUCP: P182
19 N HPCAN I $$ISHISTCP^TIUCP(+TIUD0) S HPCAN=$$HPCAN^TIUCP(+TIUACT) I 'HPCAN S TIUY=HPCAN G CANDOX
20 ; **152 Get status to evaluate for completed document.
21 S STATUS=+$P(TIUD0,U,5)
22 ; **152 prevents editing or sending back a completed document.
23 I STATUS>6,(+TIUACT=9)!(+TIUACT=17) D G CANDOX
24 .; **152 Displays message to user
25 . I +TIUACT=9 S TIUY="0^ You may not edit a completed document."
26 . I +TIUACT=17 S TIUY="0^You may not send back this completed document."
27 ; -- In case business rules have changed, & children already existed:
28 I +TIUACT=24,$D(^TIU(8925,"GDAD",TIUDA)) D G CANDOX
29 . S TIUY="0^ This note cannot be attached; it has its own children."
30 I +TIUACT=25,+$G(^TIU(8925,TIUDA,21)) D G CANDOX
31 . S TIUY="0^ This note cannot receive interdisciplinary children; it is itself a child."
32 I +TIUACT=4!(+TIUACT=5),+$$BLANK^TIULC(TIUDA) D G CANDOX
33 . S TIUY="0^ Contains blanks ("_$P(TIUPRM1,U,6)_") which must be filled before "_$P(TIUACT,U,2)_"ATURE."
34 S TIUROLE=$$USRROLE(TIUDA,PERSON)
35 S TIUTYP=+TIUD0
36 I $$ISADDNDM^TIULC1(+TIUDA) S TIUATYP=TIUTYP,TIUTYP=+$G(^TIU(8925,+$P(TIUD0,U,6),0))
37 I TIUROLE']"" S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON)
38 F TIUI=1:1:($L(TIUROLE,U)-1) D Q:+$G(TIUY)>0
39 . S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON,$P(TIUROLE,U,TIUI))
40 I +$G(TIUATYP) S TIUTYP=+$G(TIUATYP)
41 ;**100** update for PERSON param; update for verb modifier:
42 I +TIUY'>0 D G CANDOX
43 . S WHO=" You"
44 . ;I PERSON'=DUZ S WHO=$P(^VA(200,PERSON,0),U),WHO=$$NAME^TIULS(WHO,"FIRST LAST")
45 . I PERSON'=DUZ S WHO=$$NAME^TIULS($$GET1^DIQ(200,PERSON,.01),"FIRST LAST") ;P182
46 . S MODIFIER=$P(TIUACT,U,3) I $L(MODIFIER) S MODIFIER=" "_MODIFIER
47 . ;e.g. "You may not ATTACH this UNSIGNED TELEPHONE NOTE TO AN ID NOTE."
48 . S MSG=WHO_" may not "_$P(TIUACT,U,2)_" this "_$P($G(^TIU(8925.6,+STATUS,0)),U)_" "_$$PNAME^TIULC1(TIUTYP)_MODIFIER_"."
49 . S TIUY=TIUY_U_MSG
50 I +TIUACT=15,$$HASIMG^TIURB2(+TIUDA) D G CANDOX
51 . S TIUY="0^ This document contains linked images. You must ""delete"" the Images using the Imaging package before proceeding."
52 ;VMP/ELR P217. Do not allow deletion of a parent with child
53 I $G(TIUACTW)["DELETE RECORD",$$HASIDKID^TIUGBR(+TIUDA) D G CANDOX
54 . S TIUY="0^ "_$$EZBLD^DIALOG(89250013)
55CANDOX Q TIUY
56 ;
57CANLINK(TIUTYP) ; Can user (DUZ) link (attach) a document of a particular type
58 ;to an ID note.
59 ; For use in ADD NEW ID NOTE, where docmt is not entered yet.
60 ; Assume most favorable circumstances (user will complete
61 ;the note, so if user still can't attach, can tell them no,
62 ;when they first select title for the new entry.
63 ; Rule out if TIUTYP can be an ID parent, since ID parent
64 ;and ID kid function as mutually exclusive, (regardless of
65 ;business rules).
66 N TIUACT,STATUS,USRROLE,TIUY
67 S TIUACT=$$USREVNT("ATTACH TO ID NOTE"),STATUS=7 ; complete
68 S USRROLE=+$O(^USR(8930.2,"B","COMPLETER",0))
69 S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE)
70 I '$G(TIUY) S TIUY="0^ You may not use this title for interdisciplinary child entries." Q TIUY
71 ; -- If user can attach a certain note, but note can also receive
72 ; ID entries, don't let user attach it. --
73 I $$POSSPRNT^TIULP(TIUTYP) S TIUY="0^ This interdisciplinary PARENT title cannot be used for CHILD entries."
74 ; -- If selected type is a CWAD, don't let user attach it: --
75 I $$ISCWAD^TIULX(TIUTYP) S TIUY="0^ CWAD titles cannot be used for interdisciplinary entries."
76 ; -- If selected type is a PRF, don't let user attach it: --
77 I $$ISPFTTL^TIUPRFL(TIUTYP) S TIUY="0^ Patient Record Flag titles cannot be used for interdisciplinary entries."
78 ; -- If selected type is a consult, don't let user attach it: --
79 I $$ISA^TIULX(TIUTYP,+$$CLASS^TIUCNSLT) S TIUY="0^ Consult titles cannot be used for interdisciplinary entries."
80 Q TIUY
81 ;
82POSSPRNT(TIUTYP) ; Is a docmt intended as a possible ID parent?
83 ;Returns 1^WHYCAN'TATTACH if there are business rules permitting ANYONE
84 ;to attach ID entries to notes of type TIUTYP.
85 ;Else returns 0.
86 N TIUACT,STATUS,TIUY,DADTYP
87 S TIUY=0,TIUACT=+$$USREVNT("ATTACH ID ENTRY")
88 F STATUS=6,7,8 D G:TIUY POSSX
89 . I $O(^USR(8930.1,"AR",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 Q
90 . I $O(^USR(8930.1,"AC",TIUTYP,STATUS,TIUACT,0)) S TIUY=1
91 ; -- If no rules for TIUTYP, try its parent: --
92 S DADTYP=$O(^TIU(8925.1,"AD",TIUTYP,0)) G:DADTYP'>0 POSSX
93 S TIUY=$$POSSPRNT(DADTYP)
94POSSX I TIUY S TIUY="1^ Interdisciplinary PARENT notes cannot be attached as CHILD entries."
95 Q TIUY
96 ;
97CANENTR(TIUTYP) ; Evaluate privilege to enter a document of a particular type
98 N TIUACT,STATUS,USRROLE,TIUY
99 S TIUACT=$$USREVNT("ENTRY"),STATUS=2 ; untranscribed
100 S USRROLE=3 ; transcriber
101 S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE)
102 Q TIUY
103USRROLE(TIUDA,PERSON) ; Identify the user's role with respect to the document
104 ; 3/20/00 **100** Added role COMPLETER
105 ; 3/20/00 **100** Added PERSON param
106 N TIU0,TIU12,TIU13,TIUY,TIU15,COMPLTR,STATUS
107 S PERSON=$G(PERSON,DUZ)
108 S TIU0=$G(^TIU(8925,+TIUDA,0)),STATUS=$P(TIU0,U,5)
109 S TIU12=$G(^TIU(8925,+TIUDA,12))
110 S TIU13=$G(^TIU(8925,+TIUDA,13)),TIU15=$G(^TIU(8925,+TIUDA,15))
111 I PERSON=+$P(TIU13,U,2) S TIUY=+$O(^USR(8930.2,"B","TRANSCRIBER",0))_U
112 I PERSON=+$P(TIU12,U,2) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","AUTHOR/DICTATOR",0))_U
113 I PERSON=+$P(TIU12,U,9) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ATTENDING PHYSICIAN",0))_U
114 I PERSON=+$P(TIU12,U,4) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED SIGNER",0))_U
115 I PERSON=+$P(TIU12,U,8) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED COSIGNER",0))_U
116 I $$ASURG^TIUADSIG(TIUDA) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U ;P157
117 ;Check if the person can be an Interpreter for this document via a Consult API
118 I $$CPINTERP^GMRCCP(+TIUDA,PERSON) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","INTERPRETER",0))_U
119 I STATUS>6 D I COMPLTR S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","COMPLETER",0))_U
120 . S COMPLTR=0
121 . I PERSON=+$P(TIU15,U,8) S COMPLTR=1 Q
122 . I '$P(TIU15,U,8),PERSON=+$P(TIU15,U,2) S COMPLTR=1
123 I +$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) D
124 . N TIUXTRA S TIUXTRA=+$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0))
125 . I +$P($G(^TIU(8925.7,+TIUXTRA,0)),U,4) Q
126 . S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ADDITIONAL SIGNER",0))_U
127 Q $G(TIUY)
128USREVNT(EVENT) ; Given event name, return:
129 ;EVENT = event pointer^user verb^verb modifier
130 ; **100** added verb modifier piece (.07)
131 N TIUY,TIUDA,NODE0
132 S TIUDA=+$O(^USR(8930.8,"B",EVENT,0))
133 S NODE0=$G(^USR(8930.8,TIUDA,0))
134 S TIUY=TIUDA_U_$P(NODE0,U,5)_U_$P(NODE0,U,7)
135 Q TIUY
136CANPICK(TIUTYP) ; Screens selection of title by title status and
137 ;(for status TEST), by owner.
138 N TIUPOWN,TIUCOWN,TIUT0,TIUTSTAT,TIUY S TIUY=0
139 S TIUT0=$G(^TIU(8925.1,+TIUTYP,0)),TIUTSTAT=$P(TIUT0,U,7)
140 I TIUTSTAT']"" S TIUY=0 G CANPIX
141 I TIUTSTAT=13 S TIUY=0 G CANPIX
142 I TIUTSTAT=11 S TIUY=1 G CANPIX
143 S TIUPOWN=$P(TIUT0,U,5),TIUCOWN=+$P(TIUT0,U,6)
144 I TIUTSTAT=10 S TIUY=$S(TIUPOWN=DUZ:1,+$$ISA^USRLM(DUZ,TIUCOWN):1,1:0)
145CANPIX Q +$G(TIUY)
146REQCOSIG(TIUTYP,TIUDA,USER,TIUDT) ; Evaluate whether user requires cosignature
147 N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ))
148 D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA))
149 I $G(TIUDPRM(5))="" G REQCOSX
150 I +$G(TIUDT)'>0 S TIUDT=+$P($P(+$G(^TIU(8925,+$G(TIUDA),13)),U),".")
151 F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0
152 . S TIUY=+$$ISA^USRLM(+USER,+$P(TIUDPRM(5),U,TIUI),,+$G(TIUDT))
153REQCOSX Q +$G(TIUY)
154 ;
155REQCPF(TIUCDA) ;Check if clinical procedure fields are required
156 ; Input -- TIUCDA Request/Consult File (#123) IEN
157 ; Output -- 1=Required and 0=Not Required
158 N TIUCPACT,REQF
159 I '$G(TIUCDA) G REQCPFQ
160 S TIUCPACT=$$CPACTM^GMRCCP(TIUCDA)
161 I TIUCPACT=1!(TIUCPACT=3) S REQF=1
162REQCPFQ Q +$G(REQF)
Note: See TracBrowser for help on using the repository browser.