- TIULP ; SLC/JER - Functions determining privilege ; 6/9/20 4:44pm
- ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217,236,234,232,241,256,297,334**;Jun 20, 1997;Build 3
- ; CANDO^USRLA: ICA 2325, ISA^USRLM: ICA 2324
- ; 8930.1,2,8: IACS 3129,3128,3104
- CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now
- ; Receives: TIUDA=Record number in file 8925
- ; TIUACT=Name of user action in 8930.8 (USR ACTION)
- ; PERSON=New Person file IFN.
- ; Assumed to be DUZ if not received.
- ; New **100** ID param, backward compatible.
- ; Returns: TIUY=1:yes,0:no_"^"_why not message
- N TIUI,TIUTYP,TIUROLE,STATUS,TIUY,TIUATYP,MSG,WHO,MODIFIER,TIUD0,TIUACTW
- S TIUY=0 I '$G(PERSON) S PERSON=DUZ
- S TIUD0=$G(^TIU(8925,+TIUDA,0)) I 'TIUD0 G CANDOX
- 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
- S TIUACTW=$G(TIUACT)
- ;VMP/AM P256 Only Hims/Mis Chiefs and Privacy Act Officers are allowed to delete NIRs and ARs
- I (($G(XQY0)["OR CPRS GUI CHART")!($G(XQY0)["TIU ")),$$ISSURG^TIULP3(+TIUDA),$G(TIUACTW)["DELETE ",'$$AUTHUSR^TIULP3(PERSON) D G CANDOX
- . S TIUY="0^ Only Privacy Act Officers or MIS/HIMS Chiefs may DELETE this Document."
- ;**100** was I +TIUACT'>0 S TIUACT etc.
- S TIUACT=$$USREVNT(TIUACT) I +TIUACT'>0 G CANDOX
- ; -- Historical Procedures - Prohibit actions detailed in
- ; HPCAN^TIUCP: P182
- N HPCAN I $$ISHISTCP^TIUCP(+TIUD0) S HPCAN=$$HPCAN^TIUCP(+TIUACT) I 'HPCAN S TIUY=HPCAN G CANDOX
- ; **152 Get status
- S STATUS=+$P(TIUD0,U,5)
- ; **152[234] prevents editing or sending back a completed or uncosigned document.
- I STATUS>5,(+TIUACT=9)!(+TIUACT=17) D G CANDOX
- . ; **152[234] Displays message to user
- . I +TIUACT=9 S TIUY="0^ You may not edit uncosigned or completed documents."
- . I +TIUACT=17 S TIUY="0^You may not send back uncosigned or completed documents."
- ; -- In case business rules have changed, & children already existed:
- I +TIUACT=24,$D(^TIU(8925,"GDAD",TIUDA)) D G CANDOX
- . S TIUY="0^ This note cannot be attached; it has its own children."
- I +TIUACT=25,+$G(^TIU(8925,TIUDA,21)) D G CANDOX
- . S TIUY="0^ This note cannot receive interdisciplinary children; it is itself a child."
- ;VMP/AM P241 If note is administratively closed, then bypass check for blank characters
- I $P($G(^TIU(8925,+TIUDA,16)),U,13)'="S",+TIUACT=4!(+TIUACT=5),+$$BLANK^TIULC(TIUDA) D G CANDOX ;Sets TIUPRM1
- . S TIUY="0^ Contains blanks ("_$P(TIUPRM1,U,6)_") which must be filled before "_$P(TIUACT,U,2)_"ATURE."
- ;
- ; **Beginning changes entered with TIU*1*297**
- ; Check for Unauthorized Abbreviation in Progress Note
- I +TIUACT=4,STATUS'=7,$G(XQY0)="OR CPRS GUI CHART" D I $G(TIUY)'="" G CANDOX
- . S TIUY="",TIUY=$$EN^TIUABBVC(TIUDA)
- ; Check document for "to be dictated"
- I STATUS<6,+TIUACT=7 D G:'TIUY CANDOX
- . N TIUDCTY S TIUDCTY=$$DICTATE^TIUDCT(TIUDA) I TIUDCTY="" S TIUY=1 Q ; Do nothing
- . I 'TIUDCTY S TIUY=TIUDCTY Q ; Return error status
- . S TIUDCTY=$$UPDATE^TIUDCT(TIUDA) S TIUY=TIUDCTY
- ;** End changes added for TIU*1*297 ***
- ;
- S TIUROLE=$$USRROLE(TIUDA,PERSON)
- S TIUTYP=+TIUD0
- I $$ISADDNDM^TIULC1(+TIUDA) S TIUATYP=TIUTYP,TIUTYP=+$G(^TIU(8925,+$P(TIUD0,U,6),0))
- I TIUROLE']"" S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON)
- F TIUI=1:1:($L(TIUROLE,U)-1) D Q:+$G(TIUY)>0
- . S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON,$P(TIUROLE,U,TIUI))
- I +$G(TIUATYP) S TIUTYP=+$G(TIUATYP)
- ;VMP/AM P256 Hims/Mis Chiefs and Privacy Act Officers are allowed to delete NIRs and ARs regardless of business rules
- I ($$ISSURG^TIULP3(+TIUDA)&$$AUTHUSR^TIULP3(PERSON)),$G(TIUACTW)["DELETE" S TIUY=1
- ;**100** update for PERSON param; update for verb modifier:
- I +TIUY'>0 D G CANDOX
- . S WHO=" You"
- . ;I PERSON'=DUZ S WHO=$P(^VA(200,PERSON,0),U),WHO=$$NAME^TIULS(WHO,"FIRST LAST")
- . I PERSON'=DUZ S WHO=$$NAME^TIULS($$GET1^DIQ(200,PERSON,.01),"FIRST LAST") ;P182
- . S MODIFIER=$P(TIUACT,U,3) I $L(MODIFIER) S MODIFIER=" "_MODIFIER
- . ;e.g. "You may not ATTACH this UNSIGNED TELEPHONE NOTE TO AN ID NOTE."
- . S MSG=WHO_" may not "_$P(TIUACT,U,2)_" this "_$P($G(^TIU(8925.6,+STATUS,0)),U)_" "_$$PNAME^TIULC1(TIUTYP)_MODIFIER_"."
- . S TIUY=TIUY_U_MSG
- I +TIUACT=15,$$HASIMG^TIURB2(+TIUDA) D G CANDOX
- . S TIUY="0^ This document contains linked images. You must ""delete"" the Images using the Imaging package before proceeding."
- ;VMP/ELR P217. Do not allow deletion of a parent with child
- I $G(TIUACTW)["DELETE RECORD",$$HASIDKID^TIUGBR(+TIUDA) D G CANDOX
- . ;VMP/ELR P232. Create new error msg.
- . NEW TIUMSG D IDMSG^TIULP3(.TIUMSG) S TIUY="0^"_TIUMSG
- ;VMP/ELR P232 do not allow edit, delete or addendum on NIR and Anesthesia report IA3356 FOR XQY0
- ;VMP/AM P256 Only Hims/Mis Chiefs and Privacy Act Officers are allowed to delete NIRs and ARs
- I (($G(XQY0)["OR CPRS GUI CHART")!($G(XQY0)["TIU ")),$$ACTION^TIULP3($G(TIUACTW)),$$ISSURG^TIULP3(+TIUDA) D G CANDOX
- . S TIUY="0^ "_$$SURMSG^TIULP3($G(TIUACTW))
- CANDOX Q TIUY
- ;
- CANLINK(TIUTYP) ; Can user (DUZ) link (attach) a document of a particular type
- ;to an ID note.
- ; For use in ADD NEW ID NOTE, where docmt is not entered yet.
- ; Assume most favorable circumstances (user will complete
- ;the note, so if user still can't attach, can tell them no,
- ;when they first select title for the new entry.
- ; Rule out if TIUTYP can be an ID parent, since ID parent
- ;and ID kid function as mutually exclusive, (regardless of
- ;business rules).
- N TIUACT,STATUS,USRROLE,TIUY
- S TIUACT=$$USREVNT("ATTACH TO ID NOTE"),STATUS=7 ; complete
- S USRROLE=+$O(^USR(8930.2,"B","COMPLETER",0))
- S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE)
- I '$G(TIUY) S TIUY="0^ You may not use this title for interdisciplinary child entries." Q TIUY
- ; -- If user can attach a certain note, but note can also receive
- ; ID entries, don't let user attach it. --
- I $$POSSPRNT^TIULP(TIUTYP) S TIUY="0^ This interdisciplinary PARENT title cannot be used for CHILD entries."
- ; -- If selected type is a CWAD, don't let user attach it: --
- I $$ISCWAD^TIULX(TIUTYP) S TIUY="0^ CWAD titles cannot be used for interdisciplinary entries."
- ; -- If selected type is a PRF, don't let user attach it: --
- I $$ISPFTTL^TIUPRFL(TIUTYP) S TIUY="0^ Patient Record Flag titles cannot be used for interdisciplinary entries."
- ; -- If selected type is a consult, don't let user attach it: --
- I $$ISA^TIULX(TIUTYP,+$$CLASS^TIUCNSLT) S TIUY="0^ Consult titles cannot be used for interdisciplinary entries."
- Q TIUY
- ;
- POSSPRNT(TIUTYP) ; Is a docmt intended as a possible ID parent?
- ;Returns 1^WHYCAN'TATTACH if there are business rules permitting ANYONE
- ;to attach ID entries to notes of type TIUTYP.
- ;Else returns 0.
- N TIUACT,STATUS,TIUY,DADTYP
- S TIUY=0,TIUACT=+$$USREVNT("ATTACH ID ENTRY")
- F STATUS=6,7,8 D G:TIUY POSSX
- . I $O(^USR(8930.1,"AR",TIUTYP,STATUS,TIUACT,0)) S TIUY=1 Q
- . I $O(^USR(8930.1,"AC",TIUTYP,STATUS,TIUACT,0)) S TIUY=1
- ; -- If no rules for TIUTYP, try its parent: --
- S DADTYP=$O(^TIU(8925.1,"AD",TIUTYP,0)) G:DADTYP'>0 POSSX
- S TIUY=$$POSSPRNT(DADTYP)
- POSSX I TIUY S TIUY="1^ Interdisciplinary PARENT notes cannot be attached as CHILD entries."
- Q TIUY
- ;
- CANENTR(TIUTYP) ; Evaluate privilege to enter a document of a particular type
- N TIUACT,STATUS,USRROLE,TIUY
- S TIUACT=$$USREVNT("ENTRY"),STATUS=2 ; untranscribed
- S USRROLE=3 ; transcriber
- S TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE)
- Q TIUY
- USRROLE(TIUDA,PERSON) ; Identify the user's role with respect to the document
- ; 3/20/00 **100** Added role COMPLETER
- ; 3/20/00 **100** Added PERSON param
- N TIU0,TIU12,TIU13,TIUY,TIU15,COMPLTR,STATUS
- S PERSON=$G(PERSON,DUZ)
- S TIU0=$G(^TIU(8925,+TIUDA,0)),STATUS=$P(TIU0,U,5)
- S TIU12=$G(^TIU(8925,+TIUDA,12))
- S TIU13=$G(^TIU(8925,+TIUDA,13)),TIU15=$G(^TIU(8925,+TIUDA,15))
- I PERSON=+$P(TIU13,U,2) S TIUY=+$O(^USR(8930.2,"B","TRANSCRIBER",0))_U
- I PERSON=+$P(TIU12,U,2) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","AUTHOR/DICTATOR",0))_U
- I PERSON=+$P(TIU12,U,9) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ATTENDING PHYSICIAN",0))_U
- I PERSON=+$P(TIU12,U,4) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED SIGNER",0))_U
- I PERSON=+$P(TIU12,U,8) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","EXPECTED COSIGNER",0))_U
- I $$ASURG^TIUADSIG(TIUDA) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U ;P157
- I $G(TIUY)'[+$O(^USR(8930.2,"B","SURROGATE",0)) D ;P334
- . I $$ISSURFOR^TIUADSIG(PERSON,+$P(TIU12,U,2)) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U Q
- . I $P(TIU12,U,9)'="",$$ISSURFOR^TIUADSIG(PERSON,+$P(TIU12,U,9)) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U Q
- . I $P(TIU12,U,4)'="",$$ISSURFOR^TIUADSIG(PERSON,+$P(TIU12,U,4)) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U Q
- . I $P(TIU12,U,8)'="",$$ISSURFOR^TIUADSIG(PERSON,+$P(TIU12,U,8)) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","SURROGATE",0))_U Q
- ;Check if the person can be an Interpreter for this document via a Consult API
- I $$CPINTERP^GMRCCP(+TIUDA,PERSON) S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","INTERPRETER",0))_U
- I STATUS>6 D I COMPLTR S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","COMPLETER",0))_U
- . S COMPLTR=0
- . I PERSON=+$P(TIU15,U,8) S COMPLTR=1 Q
- . I '$P(TIU15,U,8),PERSON=+$P(TIU15,U,2) S COMPLTR=1
- I +$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0)) D
- . N TIUXTRA S TIUXTRA=+$O(^TIU(8925.7,"AE",+TIUDA,+PERSON,0))
- . I +$P($G(^TIU(8925.7,+TIUXTRA,0)),U,4) Q
- . S TIUY=$G(TIUY)_+$O(^USR(8930.2,"B","ADDITIONAL SIGNER",0))_U
- Q $G(TIUY)
- USREVNT(EVENT) ; Given event name, return:
- ;EVENT = event pointer^user verb^verb modifier
- ; **100** added verb modifier piece (.07)
- N TIUY,TIUDA,NODE0
- S TIUDA=+$O(^USR(8930.8,"B",EVENT,0))
- S NODE0=$G(^USR(8930.8,TIUDA,0))
- S TIUY=TIUDA_U_$P(NODE0,U,5)_U_$P(NODE0,U,7)
- Q TIUY
- CANPICK(TIUTYP) ; Screens selection of title by title status and
- ;(for status TEST), by owner.
- N TIUPOWN,TIUCOWN,TIUT0,TIUTSTAT,TIUY S TIUY=0
- S TIUT0=$G(^TIU(8925.1,+TIUTYP,0)),TIUTSTAT=$P(TIUT0,U,7)
- I TIUTSTAT']"" S TIUY=0 G CANPIX
- I TIUTSTAT=13 S TIUY=0 G CANPIX
- I TIUTSTAT=11 S TIUY=1 G CANPIX
- S TIUPOWN=$P(TIUT0,U,5),TIUCOWN=+$P(TIUT0,U,6)
- I TIUTSTAT=10 S TIUY=$S(TIUPOWN=DUZ:1,+$$ISA^USRLM(DUZ,TIUCOWN):1,1:0)
- CANPIX Q +$G(TIUY)
- REQCOSIG(TIUTYP,TIUDA,USER,TIUDT) ; Evaluate whether user requires cosignature
- N TIUI,TIUY,TIUDPRM S USER=$S(+$G(USER):+$G(USER),1:+$G(DUZ))
- D DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$G(TIUDA))
- I $G(TIUDPRM(5))="" G REQCOSX
- I +$G(TIUDT)'>0 S TIUDT=+$P($P(+$G(^TIU(8925,+$G(TIUDA),13)),U),".")
- F TIUI=1:1:$L(TIUDPRM(5),U) D Q:+TIUY>0
- . S TIUY=+$$ISA^USRLM(+USER,+$P(TIUDPRM(5),U,TIUI),,+$G(TIUDT))
- REQCOSX Q +$G(TIUY)
- ;
- REQCPF(TIUCDA) ;Check if clinical procedure fields are required
- ; Input -- TIUCDA Request/Consult File (#123) IEN
- ; Output -- 1=Required and 0=Not Required
- N TIUCPACT,REQF
- I '$G(TIUCDA) G REQCPFQ
- S TIUCPACT=$$CPACTM^GMRCCP(TIUCDA)
- I TIUCPACT=1!(TIUCPACT=3) S REQF=1
- REQCPFQ Q +$G(REQF)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULP 11130 printed Jan 18, 2025@03:43:30 Page 2
- TIULP ; SLC/JER - Functions determining privilege ; 6/9/20 4:44pm
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217,236,234,232,241,256,297,334**;Jun 20, 1997;Build 3
- +2 ; CANDO^USRLA: ICA 2325, ISA^USRLM: ICA 2324
- +3 ; 8930.1,2,8: IACS 3129,3128,3104
- CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now
- +1 ; Receives: TIUDA=Record number in file 8925
- +2 ; TIUACT=Name of user action in 8930.8 (USR ACTION)
- +3 ; PERSON=New Person file IFN.
- +4 ; Assumed to be DUZ if not received.
- +5 ; New **100** ID param, backward compatible.
- +6 ; Returns: TIUY=1:yes,0:no_"^"_why not message
- +7 NEW TIUI,TIUTYP,TIUROLE,STATUS,TIUY,TIUATYP,MSG,WHO,MODIFIER,TIUD0,TIUACTW
- +8 SET TIUY=0
- IF '$GET(PERSON)
- SET PERSON=DUZ
- +9 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
- IF 'TIUD0
- GOTO CANDOX
- +10 IF $$ISPRFDOC^TIUPRF(TIUDA)
- IF ((TIUACT="ATTACH ID ENTRY")!(TIUACT="ATTACH TO ID NOTE"))
- SET TIUY="0^Patient Record Flag notes may not be used as Interdisciplinary notes."
- GOTO CANDOX
- +11 SET TIUACTW=$GET(TIUACT)
- +12 ;VMP/AM P256 Only Hims/Mis Chiefs and Privacy Act Officers are allowed to delete NIRs and ARs
- +13 IF (($GET(XQY0)["OR CPRS GUI CHART")!($GET(XQY0)["TIU "))
- IF $$ISSURG^TIULP3(+TIUDA)
- IF $GET(TIUACTW)["DELETE "
- IF '$$AUTHUSR^TIULP3(PERSON)
- Begin DoDot:1
- +14 SET TIUY="0^ Only Privacy Act Officers or MIS/HIMS Chiefs may DELETE this Document."
- End DoDot:1
- GOTO CANDOX
- +15 ;**100** was I +TIUACT'>0 S TIUACT etc.
- +16 SET TIUACT=$$USREVNT(TIUACT)
- IF +TIUACT'>0
- GOTO CANDOX
- +17 ; -- Historical Procedures - Prohibit actions detailed in
- +18 ; HPCAN^TIUCP: P182
- +19 NEW HPCAN
- IF $$ISHISTCP^TIUCP(+TIUD0)
- SET HPCAN=$$HPCAN^TIUCP(+TIUACT)
- IF 'HPCAN
- SET TIUY=HPCAN
- GOTO CANDOX
- +20 ; **152 Get status
- +21 SET STATUS=+$PIECE(TIUD0,U,5)
- +22 ; **152[234] prevents editing or sending back a completed or uncosigned document.
- +23 IF STATUS>5
- IF (+TIUACT=9)!(+TIUACT=17)
- Begin DoDot:1
- +24 ; **152[234] Displays message to user
- +25 IF +TIUACT=9
- SET TIUY="0^ You may not edit uncosigned or completed documents."
- +26 IF +TIUACT=17
- SET TIUY="0^You may not send back uncosigned or completed documents."
- End DoDot:1
- GOTO CANDOX
- +27 ; -- In case business rules have changed, & children already existed:
- +28 IF +TIUACT=24
- IF $DATA(^TIU(8925,"GDAD",TIUDA))
- Begin DoDot:1
- +29 SET TIUY="0^ This note cannot be attached; it has its own children."
- End DoDot:1
- GOTO CANDOX
- +30 IF +TIUACT=25
- IF +$GET(^TIU(8925,TIUDA,21))
- Begin DoDot:1
- +31 SET TIUY="0^ This note cannot receive interdisciplinary children; it is itself a child."
- End DoDot:1
- GOTO CANDOX
- +32 ;VMP/AM P241 If note is administratively closed, then bypass check for blank characters
- +33 ;Sets TIUPRM1
- IF $PIECE($GET(^TIU(8925,+TIUDA,16)),U,13)'="S"
- IF +TIUACT=4!(+TIUACT=5)
- IF +$$BLANK^TIULC(TIUDA)
- Begin DoDot:1
- +34 SET TIUY="0^ Contains blanks ("_$PIECE(TIUPRM1,U,6)_") which must be filled before "_$PIECE(TIUACT,U,2)_"ATURE."
- End DoDot:1
- GOTO CANDOX
- +35 ;
- +36 ; **Beginning changes entered with TIU*1*297**
- +37 ; Check for Unauthorized Abbreviation in Progress Note
- +38 IF +TIUACT=4
- IF STATUS'=7
- IF $GET(XQY0)="OR CPRS GUI CHART"
- Begin DoDot:1
- +39 SET TIUY=""
- SET TIUY=$$EN^TIUABBVC(TIUDA)
- End DoDot:1
- IF $GET(TIUY)'=""
- GOTO CANDOX
- +40 ; Check document for "to be dictated"
- +41 IF STATUS<6
- IF +TIUACT=7
- Begin DoDot:1
- +42 ; Do nothing
- NEW TIUDCTY
- SET TIUDCTY=$$DICTATE^TIUDCT(TIUDA)
- IF TIUDCTY=""
- SET TIUY=1
- QUIT
- +43 ; Return error status
- IF 'TIUDCTY
- SET TIUY=TIUDCTY
- QUIT
- +44 SET TIUDCTY=$$UPDATE^TIUDCT(TIUDA)
- SET TIUY=TIUDCTY
- End DoDot:1
- if 'TIUY
- GOTO CANDOX
- +45 ;** End changes added for TIU*1*297 ***
- +46 ;
- +47 SET TIUROLE=$$USRROLE(TIUDA,PERSON)
- +48 SET TIUTYP=+TIUD0
- +49 IF $$ISADDNDM^TIULC1(+TIUDA)
- SET TIUATYP=TIUTYP
- SET TIUTYP=+$GET(^TIU(8925,+$PIECE(TIUD0,U,6),0))
- +50 IF TIUROLE']""
- SET TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON)
- +51 FOR TIUI=1:1:($LENGTH(TIUROLE,U)-1)
- Begin DoDot:1
- +52 SET TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,PERSON,$PIECE(TIUROLE,U,TIUI))
- End DoDot:1
- if +$GET(TIUY)>0
- QUIT
- +53 IF +$GET(TIUATYP)
- SET TIUTYP=+$GET(TIUATYP)
- +54 ;VMP/AM P256 Hims/Mis Chiefs and Privacy Act Officers are allowed to delete NIRs and ARs regardless of business rules
- +55 IF ($$ISSURG^TIULP3(+TIUDA)&$$AUTHUSR^TIULP3(PERSON))
- IF $GET(TIUACTW)["DELETE"
- SET TIUY=1
- +56 ;**100** update for PERSON param; update for verb modifier:
- +57 IF +TIUY'>0
- Begin DoDot:1
- +58 SET WHO=" You"
- +59 ;I PERSON'=DUZ S WHO=$P(^VA(200,PERSON,0),U),WHO=$$NAME^TIULS(WHO,"FIRST LAST")
- +60 ;P182
- IF PERSON'=DUZ
- SET WHO=$$NAME^TIULS($$GET1^DIQ(200,PERSON,.01),"FIRST LAST")
- +61 SET MODIFIER=$PIECE(TIUACT,U,3)
- IF $LENGTH(MODIFIER)
- SET MODIFIER=" "_MODIFIER
- +62 ;e.g. "You may not ATTACH this UNSIGNED TELEPHONE NOTE TO AN ID NOTE."
- +63 SET MSG=WHO_" may not "_$PIECE(TIUACT,U,2)_" this "_$PIECE($GET(^TIU(8925.6,+STATUS,0)),U)_" "_$$PNAME^TIULC1(TIUTYP)_MODIFIER_"."
- +64 SET TIUY=TIUY_U_MSG
- End DoDot:1
- GOTO CANDOX
- +65 IF +TIUACT=15
- IF $$HASIMG^TIURB2(+TIUDA)
- Begin DoDot:1
- +66 SET TIUY="0^ This document contains linked images. You must ""delete"" the Images using the Imaging package before proceeding."
- End DoDot:1
- GOTO CANDOX
- +67 ;VMP/ELR P217. Do not allow deletion of a parent with child
- +68 IF $GET(TIUACTW)["DELETE RECORD"
- IF $$HASIDKID^TIUGBR(+TIUDA)
- Begin DoDot:1
- +69 ;VMP/ELR P232. Create new error msg.
- +70 NEW TIUMSG
- DO IDMSG^TIULP3(.TIUMSG)
- SET TIUY="0^"_TIUMSG
- End DoDot:1
- GOTO CANDOX
- +71 ;VMP/ELR P232 do not allow edit, delete or addendum on NIR and Anesthesia report IA3356 FOR XQY0
- +72 ;VMP/AM P256 Only Hims/Mis Chiefs and Privacy Act Officers are allowed to delete NIRs and ARs
- +73 IF (($GET(XQY0)["OR CPRS GUI CHART")!($GET(XQY0)["TIU "))
- IF $$ACTION^TIULP3($GET(TIUACTW))
- IF $$ISSURG^TIULP3(+TIUDA)
- Begin DoDot:1
- +74 SET TIUY="0^ "_$$SURMSG^TIULP3($GET(TIUACTW))
- End DoDot:1
- GOTO CANDOX
- CANDOX QUIT TIUY
- +1 ;
- CANLINK(TIUTYP) ; Can user (DUZ) link (attach) a document of a particular type
- +1 ;to an ID note.
- +2 ; For use in ADD NEW ID NOTE, where docmt is not entered yet.
- +3 ; Assume most favorable circumstances (user will complete
- +4 ;the note, so if user still can't attach, can tell them no,
- +5 ;when they first select title for the new entry.
- +6 ; Rule out if TIUTYP can be an ID parent, since ID parent
- +7 ;and ID kid function as mutually exclusive, (regardless of
- +8 ;business rules).
- +9 NEW TIUACT,STATUS,USRROLE,TIUY
- +10 ; complete
- SET TIUACT=$$USREVNT("ATTACH TO ID NOTE")
- SET STATUS=7
- +11 SET USRROLE=+$ORDER(^USR(8930.2,"B","COMPLETER",0))
- +12 SET TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE)
- +13 IF '$GET(TIUY)
- SET TIUY="0^ You may not use this title for interdisciplinary child entries."
- QUIT TIUY
- +14 ; -- If user can attach a certain note, but note can also receive
- +15 ; ID entries, don't let user attach it. --
- +16 IF $$POSSPRNT^TIULP(TIUTYP)
- SET TIUY="0^ This interdisciplinary PARENT title cannot be used for CHILD entries."
- +17 ; -- If selected type is a CWAD, don't let user attach it: --
- +18 IF $$ISCWAD^TIULX(TIUTYP)
- SET TIUY="0^ CWAD titles cannot be used for interdisciplinary entries."
- +19 ; -- If selected type is a PRF, don't let user attach it: --
- +20 IF $$ISPFTTL^TIUPRFL(TIUTYP)
- SET TIUY="0^ Patient Record Flag titles cannot be used for interdisciplinary entries."
- +21 ; -- If selected type is a consult, don't let user attach it: --
- +22 IF $$ISA^TIULX(TIUTYP,+$$CLASS^TIUCNSLT)
- SET TIUY="0^ Consult titles cannot be used for interdisciplinary entries."
- +23 QUIT TIUY
- +24 ;
- POSSPRNT(TIUTYP) ; Is a docmt intended as a possible ID parent?
- +1 ;Returns 1^WHYCAN'TATTACH if there are business rules permitting ANYONE
- +2 ;to attach ID entries to notes of type TIUTYP.
- +3 ;Else returns 0.
- +4 NEW TIUACT,STATUS,TIUY,DADTYP
- +5 SET TIUY=0
- SET TIUACT=+$$USREVNT("ATTACH ID ENTRY")
- +6 FOR STATUS=6,7,8
- Begin DoDot:1
- +7 IF $ORDER(^USR(8930.1,"AR",TIUTYP,STATUS,TIUACT,0))
- SET TIUY=1
- QUIT
- +8 IF $ORDER(^USR(8930.1,"AC",TIUTYP,STATUS,TIUACT,0))
- SET TIUY=1
- End DoDot:1
- if TIUY
- GOTO POSSX
- +9 ; -- If no rules for TIUTYP, try its parent: --
- +10 SET DADTYP=$ORDER(^TIU(8925.1,"AD",TIUTYP,0))
- if DADTYP'>0
- GOTO POSSX
- +11 SET TIUY=$$POSSPRNT(DADTYP)
- POSSX IF TIUY
- SET TIUY="1^ Interdisciplinary PARENT notes cannot be attached as CHILD entries."
- +1 QUIT TIUY
- +2 ;
- CANENTR(TIUTYP) ; Evaluate privilege to enter a document of a particular type
- +1 NEW TIUACT,STATUS,USRROLE,TIUY
- +2 ; untranscribed
- SET TIUACT=$$USREVNT("ENTRY")
- SET STATUS=2
- +3 ; transcriber
- SET USRROLE=3
- +4 SET TIUY=$$CANDO^USRLA(TIUTYP,STATUS,+TIUACT,DUZ,USRROLE)
- +5 QUIT TIUY
- USRROLE(TIUDA,PERSON) ; Identify the user's role with respect to the document
- +1 ; 3/20/00 **100** Added role COMPLETER
- +2 ; 3/20/00 **100** Added PERSON param
- +3 NEW TIU0,TIU12,TIU13,TIUY,TIU15,COMPLTR,STATUS
- +4 SET PERSON=$GET(PERSON,DUZ)
- +5 SET TIU0=$GET(^TIU(8925,+TIUDA,0))
- SET STATUS=$PIECE(TIU0,U,5)
- +6 SET TIU12=$GET(^TIU(8925,+TIUDA,12))
- +7 SET TIU13=$GET(^TIU(8925,+TIUDA,13))
- SET TIU15=$GET(^TIU(8925,+TIUDA,15))
- +8 IF PERSON=+$PIECE(TIU13,U,2)
- SET TIUY=+$ORDER(^USR(8930.2,"B","TRANSCRIBER",0))_U
- +9 IF PERSON=+$PIECE(TIU12,U,2)
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","AUTHOR/DICTATOR",0))_U
- +10 IF PERSON=+$PIECE(TIU12,U,9)
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","ATTENDING PHYSICIAN",0))_U
- +11 IF PERSON=+$PIECE(TIU12,U,4)
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","EXPECTED SIGNER",0))_U
- +12 IF PERSON=+$PIECE(TIU12,U,8)
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","EXPECTED COSIGNER",0))_U
- +13 ;P157
- IF $$ASURG^TIUADSIG(TIUDA)
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","SURROGATE",0))_U
- +14 ;P334
- IF $GET(TIUY)'[+$ORDER(^USR(8930.2,"B","SURROGATE",0))
- Begin DoDot:1
- +15 IF $$ISSURFOR^TIUADSIG(PERSON,+$PIECE(TIU12,U,2))
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","SURROGATE",0))_U
- QUIT
- +16 IF $PIECE(TIU12,U,9)'=""
- IF $$ISSURFOR^TIUADSIG(PERSON,+$PIECE(TIU12,U,9))
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","SURROGATE",0))_U
- QUIT
- +17 IF $PIECE(TIU12,U,4)'=""
- IF $$ISSURFOR^TIUADSIG(PERSON,+$PIECE(TIU12,U,4))
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","SURROGATE",0))_U
- QUIT
- +18 IF $PIECE(TIU12,U,8)'=""
- IF $$ISSURFOR^TIUADSIG(PERSON,+$PIECE(TIU12,U,8))
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","SURROGATE",0))_U
- QUIT
- End DoDot:1
- +19 ;Check if the person can be an Interpreter for this document via a Consult API
- +20 IF $$CPINTERP^GMRCCP(+TIUDA,PERSON)
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","INTERPRETER",0))_U
- +21 IF STATUS>6
- Begin DoDot:1
- +22 SET COMPLTR=0
- +23 IF PERSON=+$PIECE(TIU15,U,8)
- SET COMPLTR=1
- QUIT
- +24 IF '$PIECE(TIU15,U,8)
- IF PERSON=+$PIECE(TIU15,U,2)
- SET COMPLTR=1
- End DoDot:1
- IF COMPLTR
- SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","COMPLETER",0))_U
- +25 IF +$ORDER(^TIU(8925.7,"AE",+TIUDA,+PERSON,0))
- Begin DoDot:1
- +26 NEW TIUXTRA
- SET TIUXTRA=+$ORDER(^TIU(8925.7,"AE",+TIUDA,+PERSON,0))
- +27 IF +$PIECE($GET(^TIU(8925.7,+TIUXTRA,0)),U,4)
- QUIT
- +28 SET TIUY=$GET(TIUY)_+$ORDER(^USR(8930.2,"B","ADDITIONAL SIGNER",0))_U
- End DoDot:1
- +29 QUIT $GET(TIUY)
- USREVNT(EVENT) ; Given event name, return:
- +1 ;EVENT = event pointer^user verb^verb modifier
- +2 ; **100** added verb modifier piece (.07)
- +3 NEW TIUY,TIUDA,NODE0
- +4 SET TIUDA=+$ORDER(^USR(8930.8,"B",EVENT,0))
- +5 SET NODE0=$GET(^USR(8930.8,TIUDA,0))
- +6 SET TIUY=TIUDA_U_$PIECE(NODE0,U,5)_U_$PIECE(NODE0,U,7)
- +7 QUIT TIUY
- CANPICK(TIUTYP) ; Screens selection of title by title status and
- +1 ;(for status TEST), by owner.
- +2 NEW TIUPOWN,TIUCOWN,TIUT0,TIUTSTAT,TIUY
- SET TIUY=0
- +3 SET TIUT0=$GET(^TIU(8925.1,+TIUTYP,0))
- SET TIUTSTAT=$PIECE(TIUT0,U,7)
- +4 IF TIUTSTAT']""
- SET TIUY=0
- GOTO CANPIX
- +5 IF TIUTSTAT=13
- SET TIUY=0
- GOTO CANPIX
- +6 IF TIUTSTAT=11
- SET TIUY=1
- GOTO CANPIX
- +7 SET TIUPOWN=$PIECE(TIUT0,U,5)
- SET TIUCOWN=+$PIECE(TIUT0,U,6)
- +8 IF TIUTSTAT=10
- SET TIUY=$SELECT(TIUPOWN=DUZ:1,+$$ISA^USRLM(DUZ,TIUCOWN):1,1:0)
- CANPIX QUIT +$GET(TIUY)
- REQCOSIG(TIUTYP,TIUDA,USER,TIUDT) ; Evaluate whether user requires cosignature
- +1 NEW TIUI,TIUY,TIUDPRM
- SET USER=$SELECT(+$GET(USER):+$GET(USER),1:+$GET(DUZ))
- +2 DO DOCPRM^TIULC1(TIUTYP,.TIUDPRM,+$GET(TIUDA))
- +3 IF $GET(TIUDPRM(5))=""
- GOTO REQCOSX
- +4 IF +$GET(TIUDT)'>0
- SET TIUDT=+$PIECE($PIECE(+$GET(^TIU(8925,+$GET(TIUDA),13)),U),".")
- +5 FOR TIUI=1:1:$LENGTH(TIUDPRM(5),U)
- Begin DoDot:1
- +6 SET TIUY=+$$ISA^USRLM(+USER,+$PIECE(TIUDPRM(5),U,TIUI),,+$GET(TIUDT))
- End DoDot:1
- if +TIUY>0
- QUIT
- REQCOSX QUIT +$GET(TIUY)
- +1 ;
- REQCPF(TIUCDA) ;Check if clinical procedure fields are required
- +1 ; Input -- TIUCDA Request/Consult File (#123) IEN
- +2 ; Output -- 1=Required and 0=Not Required
- +3 NEW TIUCPACT,REQF
- +4 IF '$GET(TIUCDA)
- GOTO REQCPFQ
- +5 SET TIUCPACT=$$CPACTM^GMRCCP(TIUCDA)
- +6 IF TIUCPACT=1!(TIUCPACT=3)
- SET REQF=1
- REQCPFQ QUIT +$GET(REQF)