GMRCAU ;SLC/DLT,JFR - Action Utilities ;10/17/01 18:31
;;3.0;CONSULT/REQUEST TRACKING;**1,4,11,14,12,15,17,22,55,46**;DEC 27, 1997;Build 23
;
; This routine invokes IA #2324,#2692
;
GETPROV K GMRCORNP N DIR S DIR(0)="123.02,3"
S DIR("A")=$S($D(GETPROV):GETPROV,1:"Responsible Clinician")
D ^DIR K DIR I $D(DTOUT)!$D(DIROUT)!(X="^") S GMRCQIT="Q" Q
G:Y<1 GETPROV S GMRCORNP=+Y
Q
GETDT ;Get actual activity date
K GMRCQIT,%
D NOW^%DTC S (X,GMRCDT)=% D REGDTM^GMRCU S GMRCAD=X
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
I X="NOW" K GMRCAD,Y Q
S GMRCAD=Y K X,Y,DIRUT,DUOUT
Q
ORTX(GMRCO) ;Get the abbreviated text for alert displays
;GMRCO is the consult entry from 123
N GMRCSVC,GMRCSSNM,GMRCPROC,GMRCORTX
S GMRCSSNM=$$SVC(GMRCO)
S GMRCPROC=$$PROC(GMRCO)
S GMRCORTX=$S($L(GMRCPROC):($E(GMRCSSNM,1,10)_" "_$E(GMRCPROC,1,10)),1:$E(GMRCSSNM,1,20))
Q GMRCORTX
;
SVC(GMRCO) ;Get abbreviated service text
N GMRCSSNM,GMRCSVC
S GMRCSVC=$P(^GMR(123,+GMRCO,0),"^",5),GMRCSSNM=""
I +GMRCSVC S GMRCSSNM=$S($L($G(^GMR(123.5,+GMRCSVC,.1))):^(.1),1:$P($G(^GMR(123.5,+GMRCSVC,0)),U,1))
Q GMRCSSNM
PROC(GMRCO) ;Get abbreviated procedure text
N GMRCPROC
S GMRCPROC=$P(^GMR(123,+GMRCO,0),"^",8)
I +GMRCPROC S GMRCPROC=$$GET1^DIQ(123.3,+GMRCPROC,.01)
Q GMRCPROC
;
LMTX(GMRCO) ;Get the text for list manager displays
;GMRCO is the consult entry from 123
N GMRCSVC,GMRCSSNM,GMRCREQ,GMRCORTX
S GMRCSSNM=$$SVC(GMRCO)
S GMRCREQ=$$PROC(GMRCO)
S GMRCORTX=$S($L(GMRCREQ):($E(GMRCSSNM,1,10)_" "_$E(GMRCREQ,1,10)),1:$E(GMRCSSNM,1,20))
Q GMRCORTX
;
;
VALID(GMRCSER,GMRCO,GMRCUSER,GMRCTST,GMRCIFC) ;Get users update authority
; check GMRCSS and all parents for authority
; codes returned are same as $$VALIDU
N GMRCUPDL,GMRCLIS,GMRCHKD,GMRCNT,GMRCLP,GMRCQUIT
I '$G(GMRCUSER) S GMRCUSER=DUZ
; check initial service first
S GMRCUPDL=$$VALIDU(GMRCSER,GMRCUSER,$G(GMRCIFC)) I +GMRCUPDL D G VALEX
. I $G(GMRCTST) S $P(GMRCUPDL,U,3)=$P($G(^GMR(123.5,+GMRCSER,0)),U)
S GMRCHKD(+GMRCSER)="",GMRCNT=1
; find parents if set to process, quit if none
I '$P($G(^GMR(123.5,+GMRCSER,0)),U,7) G VALEX ;process parents = 0
D FINDPAR(GMRCSER,.GMRCNT) I '$D(GMRCLIS) S GMRCUPDL=0 G VALEX
S GMRCLP=0
F S GMRCLP=$O(GMRCLIS(GMRCLP)) Q:'GMRCLP!($D(GMRCQUIT)) D I +GMRCUPDL G VALEX
. I +$P(GMRCLIS(GMRCLP),U,2) K GMRCLIS(GMRCLP) Q ;been checked
. I '$D(GMRCHKD(+GMRCLIS(GMRCLP))) D
.. ; check parent
.. S GMRCUPDL=$$VALIDU(+GMRCLIS(GMRCLP),GMRCUSER,$G(GMRCIFC))
.. S GMRCHKD(+GMRCLIS(GMRCLP))=""
. S $P(GMRCLIS(GMRCLP),U,2)=1
. I +GMRCUPDL D Q ;got one
.. S:$G(GMRCTST) $P(GMRCUPDL,U,3)=$P($G(^GMR(123.5,+GMRCLIS(GMRCLP),0)),U)
. I $P(^GMR(123.5,+GMRCLIS(GMRCLP),0),U,7) D ;process parents
.. D FINDPAR(+GMRCLIS(GMRCLP),.GMRCNT)
. S GMRCLP=0 ;start back at top and don't miss any
VALEX Q GMRCUPDL
FINDPAR(SERV,ARCNT) ;find parents of SERV
; SERV = service to find parents of
; ARCNT = next array element
N PARENT
S PARENT=0
F S PARENT=$O(^GMR(123.5,"APC",SERV,PARENT)) Q:'PARENT D
. S GMRCLIS(ARCNT)=PARENT
. S ARCNT=ARCNT+1
Q
;
VALIDU(GMRCSS,GMRCUSR,GMRCIFC) ;Check to see if user is an update user
;The value returned is the equivalent of this set of codes:
; 0 = not an update user
; 1 = unrestricted access user
; 2 = update user
; 3 = administrative update user
; 4 = admin AND update user
; 5 = IFC coordinator
;
N GMRCUPD,GMRCAD,GMRCUP
I '$G(GMRCUSR) S GMRCUSR=DUZ
I '+$G(GMRCSS) Q 0
S GMRCAD=0,GMRCUP=0
I $G(GMRCIFC),$P($G(^GMR(123.5,GMRCSS,"IFC")),U,3) Q 5
I 'GMRCUP,$D(^GMR(123.5,+GMRCSS,123.3,"B",GMRCUSR)) D
. S GMRCUP=2_$$FIELD(123.3)
I 'GMRCUP,GMRCUSR=$P($G(^GMR(123.5,+GMRCSS,123)),"^",8) D
. S GMRCUP=2_$$FIELD(123.08)
I 'GMRCUP,+$P($G(^GMR(123.5,GMRCSS,0)),U,6) S GMRCUP=1_$$FIELD(.06)
I $D(^GMR(123.5,+GMRCSS,123.33,"B",GMRCUSR)) S GMRCAD=3_$$FIELD(123.33)
;
I GMRCAD,GMRCUP Q $$BOTH(GMRCAD,GMRCUP) ;admin and upd user
;
S GMRCUPD=0
; check service teams to notify, update teams w/o
I 'GMRCUP N NODE F NODE=123.1,123.31 D I +GMRCUP Q
. I '$D(^GMR(123.5,+GMRCSS,NODE)) Q
. D TEAM(.GMRCUP,NODE,GMRCUSR)
;
I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd user
;
I 'GMRCAD D ;check adm teams w/o
. I '$D(^GMR(123.5,+GMRCSS,123.34)) Q
. D TEAM(.GMRCAD,123.34,GMRCUSR)
;
I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd user
;
; check ASU user classes in field 123.35
I 'GMRCUP S GMRCUP=$$USR(GMRCSS,GMRCUSR)
;
I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd
;
I 'GMRCUP I $D(^GMR(123.5,+GMRCSS,123.2)) D LOC(.GMRCUP)
;
I GMRCAD,GMRCUP Q $$BOTH(GMRCUP,GMRCAD) ;admin and upd
I GMRCUP,'GMRCAD Q GMRCUP ;update user only
I GMRCAD,'GMRCUP Q GMRCAD ;admin user only
Q 0
;
BOTH(ADMN,UPD) ;return string with fields if testing
I $G(GMRCTST) Q "4^"_$P(ADMN,U,2)_" and "_$P(UPD,U,2)
Q 4
;
LOC(GMRCUPD) ;Check for the DUZ in the NOTIFICATION BY PT LOCATION multiple
N GMRCL,GMRCTM
S GMRCL=0 ;Check if DUZ is associated with any location/ward
F S GMRCL=$O(^GMR(123.5,+GMRCSS,123.2,GMRCL)) Q:'GMRCL!+GMRCUPD D Q:+GMRCUPD
. ;Get user and/or team assigned to location
. S GMRCL(0)=$G(^GMR(123.5,+GMRCSS,123.2,+GMRCL,0))
. I $P(GMRCL(0),"^",2)=DUZ S GMRCUPD=2 Q
. I $P(GMRCL(0),"^",3) S GMRCTM=$P(GMRCL(0),"^",3) ;D CHKTM
Q
;
TEAM(TYPE,SUBSC,USER) ;Check for the DUZ in the multiple of SUBSC
N GMRCTM,GMRCHIT
S GMRCTM=""
I '$G(USER) S USER=DUZ
F S GMRCTM=$O(^GMR(123.5,GMRCSS,SUBSC,"B",GMRCTM)) Q:'GMRCTM!+TYPE D
. S GMRCHIT=$$CHKTM(GMRCTM,USER) Q:'GMRCHIT
. S TYPE=$S(SUBSC=123.34:3,1:2)_$$FIELD(SUBSC)
Q
;
CHKTM(TEAM,PERS) ;checks for PERS in list of users on TEAM
;Input: TEAM must be set to the Order Team entry number
;Output: 1 will be returned PERS is on TEAM
N ND,GMRCLST,FOUND
S GMRCLST=""
D TEAMPROV^ORQPTQ1(.GMRCLST,TEAM)
I $P(GMRCLST(1),"^",2)="No providers found." Q 0
S ND=0
F S ND=$O(GMRCLST(ND)) Q:ND="" I +GMRCLST(ND)=PERS S FOUND=1 Q
Q $S($G(FOUND):1,1:0)
;
USR(SERV,USER) ; check USR classes for user
N UCLS,UPD
I '$O(^GMR(123.5,+SERV,123.35,0)) Q 0
S UCLS=0,UPD=0
F S UCLS=$O(^GMR(123.5,+SERV,123.35,"B",UCLS)) Q:'UCLS!(+UPD) D
. Q:'UCLS
. S UPD=$$ISA^USRLM(USER,UCLS)
. I +UPD S UPD=2_$$FIELD(123.35)
. Q
Q UPD
FIELD(GMRCFLD) ;return field name where became update user
I '$G(GMRCTST) Q ""
D FIELD^DID(123.5,GMRCFLD,,"LABEL","GMRCFLD")
Q "^"_$G(GMRCFLD("LABEL"))
COMPLETE(GMRCA) ;Determine if the action is a complete action (10,13,14)
S GMRCA=$G(GMRCA)
Q $S(GMRCA=13:1,GMRCA=14:1,GMRCA=10:1,1:0)
; 10=administrative complete, 13=ADDENDUM ADDED, 14=New Note
;
RESOLUA(GMRCA) ;Determine if action has resolution info for clinician
;Action value is based on value in ^ORD(100.01,"
;Returns 1 for consult resolution, 0 for pending resolution
S GMRCA=$G(GMRCA)
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)
; 4=Sig Findings, 6=discontinued, 10=administrative complete
; 11=Edit/resubmit
; 12=Disassociate result, 13=Addendum Added, 14=New Note
; 19=cancelled
;
RESOLUS(GMRCSTS) ;Determine status indicates the consult has a resolution
;Status value is based on values in ^ORD(100.01,"
;Returns 1 for consult resolution, 0 for pending resolution
S GMRCSTS=$G(GMRCSTS)
Q $S(GMRCSTS:1,GMRCSTS=2:1,GMRCSTS=13:1,1:0)
; 1=dc,2=comp,13=canc
;
TEST ;called from GMRC UPDATE AUTHORITY
; determines how a user gets update authority for a service
W !
N GMRCSRV,GMRCUSR,UPD,GMRCDG,GMRC1
N DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
S DIR(0)="PO^123.5:EM",DIR("A")="Select Consult Service"
S DIR("?")="Choose the consult service to check update status of user"
S DIR("??")="^D TESTHELP^GMRCAU(""ALL SERVICES"")" D ^DIR
I $D(DIRUT) Q
S GMRCSRV=+Y
N DIR
S DIR(0)="PO^200:EM",DIR("A")="Choose user to check for update status"
D ^DIR I $D(DIRUT) Q
S GMRCUSR=+Y
S UPD=$$VALID(GMRCSRV,,GMRCUSR,1)
I +UPD=0 W !!,"This user has no update authority"
I +UPD D
. I +UPD=2 W !!,"This user is an update user for: ",$P(UPD,U,3)
. I +UPD=3 W !!,"This user is an administrative user for: ",$P(UPD,U,3)
. I +UPD=4 D
.. W !!,"This user is both an administrative and update user"
.. W " for: ",!,$P(UPD,U,3)
. W !,"via the ",$P(UPD,U,2)," field",$S(+UPD=4:"(s).",1:".")
. W ! I $L($P(UPD,U,3)) D
.. I $P(UPD,U,3)'=$P(^GMR(123.5,+GMRCSRV,0),U) D HIER^GMRCT($P(UPD,U,3))
W !!
K GMRCSRV,GMRCUSR,UPD
K DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
G TEST
TESTHELP(GMRCSVNM) ;wrapper for LISTSRV^GMRCASV
N DIR,GMRC1,GMRCDG
D LISTSRV^GMRCASV
Q
TSTINTRO ;entry action of GMRC UPDATE AUTHORITY option
W !!,"This option will allow you to check a user's update authority for any given"
W !,"service in the consults hierarchy. If the PROCESS PARENTS FOR UPDATES field"
W !,"is set to YES, all ancestors of the selected service will be checked."
W !,"The type of update authority and the service to which they are assigned will"
W !,"be displayed.",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCAU 9230 printed Oct 16, 2024@17:46:02 Page 2
GMRCAU ;SLC/DLT,JFR - Action Utilities ;10/17/01 18:31
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,11,14,12,15,17,22,55,46**;DEC 27, 1997;Build 23
+2 ;
+3 ; This routine invokes IA #2324,#2692
+4 ;
GETPROV KILL GMRCORNP
NEW DIR
SET DIR(0)="123.02,3"
+1 SET DIR("A")=$SELECT($DATA(GETPROV):GETPROV,1:"Responsible Clinician")
+2 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DIROUT)!(X="^")
SET GMRCQIT="Q"
QUIT
+3 if Y<1
GOTO GETPROV
SET GMRCORNP=+Y
+4 QUIT
GETDT ;Get actual activity date
+1 KILL GMRCQIT,%
+2 DO NOW^%DTC
SET (X,GMRCDT)=%
DO REGDTM^GMRCU
SET GMRCAD=X
+3 SET DIR(0)="123.02,2"
SET DIR("A")=$SELECT($DATA(GETDT):GETDT,1:"Date/Time of Actual Activity")
SET DIR("B")="NOW"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET GMRCQIT="Q"
QUIT
+4 IF X="NOW"
KILL GMRCAD,Y
QUIT
+5 SET GMRCAD=Y
KILL X,Y,DIRUT,DUOUT
+6 QUIT
ORTX(GMRCO) ;Get the abbreviated text for alert displays
+1 ;GMRCO is the consult entry from 123
+2 NEW GMRCSVC,GMRCSSNM,GMRCPROC,GMRCORTX
+3 SET GMRCSSNM=$$SVC(GMRCO)
+4 SET GMRCPROC=$$PROC(GMRCO)
+5 SET GMRCORTX=$SELECT($LENGTH(GMRCPROC):($EXTRACT(GMRCSSNM,1,10)_" "_$EXTRACT(GMRCPROC,1,10)),1:$EXTRACT(GMRCSSNM,1,20))
+6 QUIT GMRCORTX
+7 ;
SVC(GMRCO) ;Get abbreviated service text
+1 NEW GMRCSSNM,GMRCSVC
+2 SET GMRCSVC=$PIECE(^GMR(123,+GMRCO,0),"^",5)
SET GMRCSSNM=""
+3 IF +GMRCSVC
SET GMRCSSNM=$SELECT($LENGTH($GET(^GMR(123.5,+GMRCSVC,.1))):^(.1),1:$PIECE($GET(^GMR(123.5,+GMRCSVC,0)),U,1))
+4 QUIT GMRCSSNM
PROC(GMRCO) ;Get abbreviated procedure text
+1 NEW GMRCPROC
+2 SET GMRCPROC=$PIECE(^GMR(123,+GMRCO,0),"^",8)
+3 IF +GMRCPROC
SET GMRCPROC=$$GET1^DIQ(123.3,+GMRCPROC,.01)
+4 QUIT GMRCPROC
+5 ;
LMTX(GMRCO) ;Get the text for list manager displays
+1 ;GMRCO is the consult entry from 123
+2 NEW GMRCSVC,GMRCSSNM,GMRCREQ,GMRCORTX
+3 SET GMRCSSNM=$$SVC(GMRCO)
+4 SET GMRCREQ=$$PROC(GMRCO)
+5 SET GMRCORTX=$SELECT($LENGTH(GMRCREQ):($EXTRACT(GMRCSSNM,1,10)_" "_$EXTRACT(GMRCREQ,1,10)),1:$EXTRACT(GMRCSSNM,1,20))
+6 QUIT GMRCORTX
+7 ;
+8 ;
VALID(GMRCSER,GMRCO,GMRCUSER,GMRCTST,GMRCIFC) ;Get users update authority
+1 ; check GMRCSS and all parents for authority
+2 ; codes returned are same as $$VALIDU
+3 NEW GMRCUPDL,GMRCLIS,GMRCHKD,GMRCNT,GMRCLP,GMRCQUIT
+4 IF '$GET(GMRCUSER)
SET GMRCUSER=DUZ
+5 ; check initial service first
+6 SET GMRCUPDL=$$VALIDU(GMRCSER,GMRCUSER,$GET(GMRCIFC))
IF +GMRCUPDL
Begin DoDot:1
+7 IF $GET(GMRCTST)
SET $PIECE(GMRCUPDL,U,3)=$PIECE($GET(^GMR(123.5,+GMRCSER,0)),U)
End DoDot:1
GOTO VALEX
+8 SET GMRCHKD(+GMRCSER)=""
SET GMRCNT=1
+9 ; find parents if set to process, quit if none
+10 ;process parents = 0
IF '$PIECE($GET(^GMR(123.5,+GMRCSER,0)),U,7)
GOTO VALEX
+11 DO FINDPAR(GMRCSER,.GMRCNT)
IF '$DATA(GMRCLIS)
SET GMRCUPDL=0
GOTO VALEX
+12 SET GMRCLP=0
+13 FOR
SET GMRCLP=$ORDER(GMRCLIS(GMRCLP))
if 'GMRCLP!($DATA(GMRCQUIT))
QUIT
Begin DoDot:1
+14 ;been checked
IF +$PIECE(GMRCLIS(GMRCLP),U,2)
KILL GMRCLIS(GMRCLP)
QUIT
+15 IF '$DATA(GMRCHKD(+GMRCLIS(GMRCLP)))
Begin DoDot:2
+16 ; check parent
+17 SET GMRCUPDL=$$VALIDU(+GMRCLIS(GMRCLP),GMRCUSER,$GET(GMRCIFC))
+18 SET GMRCHKD(+GMRCLIS(GMRCLP))=""
End DoDot:2
+19 SET $PIECE(GMRCLIS(GMRCLP),U,2)=1
+20 ;got one
IF +GMRCUPDL
Begin DoDot:2
+21 if $GET(GMRCTST)
SET $PIECE(GMRCUPDL,U,3)=$PIECE($GET(^GMR(123.5,+GMRCLIS(GMRCLP),0)),U)
End DoDot:2
QUIT
+22 ;process parents
IF $PIECE(^GMR(123.5,+GMRCLIS(GMRCLP),0),U,7)
Begin DoDot:2
+23 DO FINDPAR(+GMRCLIS(GMRCLP),.GMRCNT)
End DoDot:2
+24 ;start back at top and don't miss any
SET GMRCLP=0
End DoDot:1
IF +GMRCUPDL
GOTO VALEX
VALEX QUIT GMRCUPDL
FINDPAR(SERV,ARCNT) ;find parents of SERV
+1 ; SERV = service to find parents of
+2 ; ARCNT = next array element
+3 NEW PARENT
+4 SET PARENT=0
+5 FOR
SET PARENT=$ORDER(^GMR(123.5,"APC",SERV,PARENT))
if 'PARENT
QUIT
Begin DoDot:1
+6 SET GMRCLIS(ARCNT)=PARENT
+7 SET ARCNT=ARCNT+1
End DoDot:1
+8 QUIT
+9 ;
VALIDU(GMRCSS,GMRCUSR,GMRCIFC) ;Check to see if user is an update user
+1 ;The value returned is the equivalent of this set of codes:
+2 ; 0 = not an update user
+3 ; 1 = unrestricted access user
+4 ; 2 = update user
+5 ; 3 = administrative update user
+6 ; 4 = admin AND update user
+7 ; 5 = IFC coordinator
+8 ;
+9 NEW GMRCUPD,GMRCAD,GMRCUP
+10 IF '$GET(GMRCUSR)
SET GMRCUSR=DUZ
+11 IF '+$GET(GMRCSS)
QUIT 0
+12 SET GMRCAD=0
SET GMRCUP=0
+13 IF $GET(GMRCIFC)
IF $PIECE($GET(^GMR(123.5,GMRCSS,"IFC")),U,3)
QUIT 5
+14 IF 'GMRCUP
IF $DATA(^GMR(123.5,+GMRCSS,123.3,"B",GMRCUSR))
Begin DoDot:1
+15 SET GMRCUP=2_$$FIELD(123.3)
End DoDot:1
+16 IF 'GMRCUP
IF GMRCUSR=$PIECE($GET(^GMR(123.5,+GMRCSS,123)),"^",8)
Begin DoDot:1
+17 SET GMRCUP=2_$$FIELD(123.08)
End DoDot:1
+18 IF 'GMRCUP
IF +$PIECE($GET(^GMR(123.5,GMRCSS,0)),U,6)
SET GMRCUP=1_$$FIELD(.06)
+19 IF $DATA(^GMR(123.5,+GMRCSS,123.33,"B",GMRCUSR))
SET GMRCAD=3_$$FIELD(123.33)
+20 ;
+21 ;admin and upd user
IF GMRCAD
IF GMRCUP
QUIT $$BOTH(GMRCAD,GMRCUP)
+22 ;
+23 SET GMRCUPD=0
+24 ; check service teams to notify, update teams w/o
+25 IF 'GMRCUP
NEW NODE
FOR NODE=123.1,123.31
Begin DoDot:1
+26 IF '$DATA(^GMR(123.5,+GMRCSS,NODE))
QUIT
+27 DO TEAM(.GMRCUP,NODE,GMRCUSR)
End DoDot:1
IF +GMRCUP
QUIT
+28 ;
+29 ;admin and upd user
IF GMRCAD
IF GMRCUP
QUIT $$BOTH(GMRCUP,GMRCAD)
+30 ;
+31 ;check adm teams w/o
IF 'GMRCAD
Begin DoDot:1
+32 IF '$DATA(^GMR(123.5,+GMRCSS,123.34))
QUIT
+33 DO TEAM(.GMRCAD,123.34,GMRCUSR)
End DoDot:1
+34 ;
+35 ;admin and upd user
IF GMRCAD
IF GMRCUP
QUIT $$BOTH(GMRCUP,GMRCAD)
+36 ;
+37 ; check ASU user classes in field 123.35
+38 IF 'GMRCUP
SET GMRCUP=$$USR(GMRCSS,GMRCUSR)
+39 ;
+40 ;admin and upd
IF GMRCAD
IF GMRCUP
QUIT $$BOTH(GMRCUP,GMRCAD)
+41 ;
+42 IF 'GMRCUP
IF $DATA(^GMR(123.5,+GMRCSS,123.2))
DO LOC(.GMRCUP)
+43 ;
+44 ;admin and upd
IF GMRCAD
IF GMRCUP
QUIT $$BOTH(GMRCUP,GMRCAD)
+45 ;update user only
IF GMRCUP
IF 'GMRCAD
QUIT GMRCUP
+46 ;admin user only
IF GMRCAD
IF 'GMRCUP
QUIT GMRCAD
+47 QUIT 0
+48 ;
BOTH(ADMN,UPD) ;return string with fields if testing
+1 IF $GET(GMRCTST)
QUIT "4^"_$PIECE(ADMN,U,2)_" and "_$PIECE(UPD,U,2)
+2 QUIT 4
+3 ;
LOC(GMRCUPD) ;Check for the DUZ in the NOTIFICATION BY PT LOCATION multiple
+1 NEW GMRCL,GMRCTM
+2 ;Check if DUZ is associated with any location/ward
SET GMRCL=0
+3 FOR
SET GMRCL=$ORDER(^GMR(123.5,+GMRCSS,123.2,GMRCL))
if 'GMRCL!+GMRCUPD
QUIT
Begin DoDot:1
+4 ;Get user and/or team assigned to location
+5 SET GMRCL(0)=$GET(^GMR(123.5,+GMRCSS,123.2,+GMRCL,0))
+6 IF $PIECE(GMRCL(0),"^",2)=DUZ
SET GMRCUPD=2
QUIT
+7 ;D CHKTM
IF $PIECE(GMRCL(0),"^",3)
SET GMRCTM=$PIECE(GMRCL(0),"^",3)
End DoDot:1
if +GMRCUPD
QUIT
+8 QUIT
+9 ;
TEAM(TYPE,SUBSC,USER) ;Check for the DUZ in the multiple of SUBSC
+1 NEW GMRCTM,GMRCHIT
+2 SET GMRCTM=""
+3 IF '$GET(USER)
SET USER=DUZ
+4 FOR
SET GMRCTM=$ORDER(^GMR(123.5,GMRCSS,SUBSC,"B",GMRCTM))
if 'GMRCTM!+TYPE
QUIT
Begin DoDot:1
+5 SET GMRCHIT=$$CHKTM(GMRCTM,USER)
if 'GMRCHIT
QUIT
+6 SET TYPE=$SELECT(SUBSC=123.34:3,1:2)_$$FIELD(SUBSC)
End DoDot:1
+7 QUIT
+8 ;
CHKTM(TEAM,PERS) ;checks for PERS in list of users on TEAM
+1 ;Input: TEAM must be set to the Order Team entry number
+2 ;Output: 1 will be returned PERS is on TEAM
+3 NEW ND,GMRCLST,FOUND
+4 SET GMRCLST=""
+5 DO TEAMPROV^ORQPTQ1(.GMRCLST,TEAM)
+6 IF $PIECE(GMRCLST(1),"^",2)="No providers found."
QUIT 0
+7 SET ND=0
+8 FOR
SET ND=$ORDER(GMRCLST(ND))
if ND=""
QUIT
IF +GMRCLST(ND)=PERS
SET FOUND=1
QUIT
+9 QUIT $SELECT($GET(FOUND):1,1:0)
+10 ;
USR(SERV,USER) ; check USR classes for user
+1 NEW UCLS,UPD
+2 IF '$ORDER(^GMR(123.5,+SERV,123.35,0))
QUIT 0
+3 SET UCLS=0
SET UPD=0
+4 FOR
SET UCLS=$ORDER(^GMR(123.5,+SERV,123.35,"B",UCLS))
if 'UCLS!(+UPD)
QUIT
Begin DoDot:1
+5 if 'UCLS
QUIT
+6 SET UPD=$$ISA^USRLM(USER,UCLS)
+7 IF +UPD
SET UPD=2_$$FIELD(123.35)
+8 QUIT
End DoDot:1
+9 QUIT UPD
FIELD(GMRCFLD) ;return field name where became update user
+1 IF '$GET(GMRCTST)
QUIT ""
+2 DO FIELD^DID(123.5,GMRCFLD,,"LABEL","GMRCFLD")
+3 QUIT "^"_$GET(GMRCFLD("LABEL"))
COMPLETE(GMRCA) ;Determine if the action is a complete action (10,13,14)
+1 SET GMRCA=$GET(GMRCA)
+2 QUIT $SELECT(GMRCA=13:1,GMRCA=14:1,GMRCA=10:1,1:0)
+3 ; 10=administrative complete, 13=ADDENDUM ADDED, 14=New Note
+4 ;
RESOLUA(GMRCA) ;Determine if action has resolution info for clinician
+1 ;Action value is based on value in ^ORD(100.01,"
+2 ;Returns 1 for consult resolution, 0 for pending resolution
+3 SET GMRCA=$GET(GMRCA)
+4 QUIT $SELECT(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)
+5 ; 4=Sig Findings, 6=discontinued, 10=administrative complete
+6 ; 11=Edit/resubmit
+7 ; 12=Disassociate result, 13=Addendum Added, 14=New Note
+8 ; 19=cancelled
+9 ;
RESOLUS(GMRCSTS) ;Determine status indicates the consult has a resolution
+1 ;Status value is based on values in ^ORD(100.01,"
+2 ;Returns 1 for consult resolution, 0 for pending resolution
+3 SET GMRCSTS=$GET(GMRCSTS)
+4 QUIT $SELECT(GMRCSTS:1,GMRCSTS=2:1,GMRCSTS=13:1,1:0)
+5 ; 1=dc,2=comp,13=canc
+6 ;
TEST ;called from GMRC UPDATE AUTHORITY
+1 ; determines how a user gets update authority for a service
+2 WRITE !
+3 NEW GMRCSRV,GMRCUSR,UPD,GMRCDG,GMRC1
+4 NEW DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
+5 SET DIR(0)="PO^123.5:EM"
SET DIR("A")="Select Consult Service"
+6 SET DIR("?")="Choose the consult service to check update status of user"
+7 SET DIR("??")="^D TESTHELP^GMRCAU(""ALL SERVICES"")"
DO ^DIR
+8 IF $DATA(DIRUT)
QUIT
+9 SET GMRCSRV=+Y
+10 NEW DIR
+11 SET DIR(0)="PO^200:EM"
SET DIR("A")="Choose user to check for update status"
+12 DO ^DIR
IF $DATA(DIRUT)
QUIT
+13 SET GMRCUSR=+Y
+14 SET UPD=$$VALID(GMRCSRV,,GMRCUSR,1)
+15 IF +UPD=0
WRITE !!,"This user has no update authority"
+16 IF +UPD
Begin DoDot:1
+17 IF +UPD=2
WRITE !!,"This user is an update user for: ",$PIECE(UPD,U,3)
+18 IF +UPD=3
WRITE !!,"This user is an administrative user for: ",$PIECE(UPD,U,3)
+19 IF +UPD=4
Begin DoDot:2
+20 WRITE !!,"This user is both an administrative and update user"
+21 WRITE " for: ",!,$PIECE(UPD,U,3)
End DoDot:2
+22 WRITE !,"via the ",$PIECE(UPD,U,2)," field",$SELECT(+UPD=4:"(s).",1:".")
+23 WRITE !
IF $LENGTH($PIECE(UPD,U,3))
Begin DoDot:2
+24 IF $PIECE(UPD,U,3)'=$PIECE(^GMR(123.5,+GMRCSRV,0),U)
DO HIER^GMRCT($PIECE(UPD,U,3))
End DoDot:2
End DoDot:1
+25 WRITE !!
+26 KILL GMRCSRV,GMRCUSR,UPD
+27 KILL DIR,DIROUT,DIRUT,DUOUT,DTOUT,X,Y
+28 GOTO TEST
TESTHELP(GMRCSVNM) ;wrapper for LISTSRV^GMRCASV
+1 NEW DIR,GMRC1,GMRCDG
+2 DO LISTSRV^GMRCASV
+3 QUIT
TSTINTRO ;entry action of GMRC UPDATE AUTHORITY option
+1 WRITE !!,"This option will allow you to check a user's update authority for any given"
+2 WRITE !,"service in the consults hierarchy. If the PROCESS PARENTS FOR UPDATES field"
+3 WRITE !,"is set to YES, all ancestors of the selected service will be checked."
+4 WRITE !,"The type of update authority and the service to which they are assigned will"
+5 WRITE !,"be displayed.",!!
+6 QUIT
