Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCAU

GMRCAU.m

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