241 lines
8.8 KiB
Mathematica
241 lines
8.8 KiB
Mathematica
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**;DEC 27, 1997;Build 4
|
|
;
|
|
; 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 and 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
|