GMRCGUIA ;SLC/DCM,JFR - File Consult actions from GUI ;7/8/03 07:36
;;3.0;CONSULT/REQUEST TRACKING;**1,4,12,15,22,35,64,114**;DEC 27, 1997;Build 2
;
; This routine invokes IA #2638,#2926
;
NEW(DFN,GMRCDA,GMRCLOC,GMRCTYPE,GMRCSVC,GMRCPROV,GMRCURG,GMRCPLI,GMRCNP,GMRCATN,GMRCINOT,GMRCDIAG,GMRCRFQ) ;Add a new consult for a patient.
;DFN=Patient ^DPT( file number
;GMRCRFQ=Reason For Request, why the consult is being ordered. Passed in as
; an array
;GMRCDIAG=Povisional diagnosis; what is suspected to be the problem
;GMRCTYPE=Request type -Consult or Procedure
;GMRCLOC=Patient location.
;GMRCDA=Date Time of Request
;GMRCSVC=To Service; consulting service
;GMRCLOC=Hospital Location ordering consult
;GMRCPR=If a procedure, the procedure ordered (pointer to file 101)
;GMRCURG=Urgency of request (stat, routine, etc) from file 101
;GMRCPLI=Place of consultation (bedside, consultants choice, etc.) from file 101
;GMRCPROV=Sending Provider
;GMRCATN=if consult is to go to a specific provider, this provider is identified here.
;GMRCINOT=Service provided as Inpatient or Outpatient
N DIC,DLAYGO,Y,DIE,GMRCADUZ,X,GMRCO,DR
S DIC="^GMR(123,",DIC(0)="L",X="""N""",DLAYGO=123 D ^DIC K DLAYGO
S (DA,GMRCO)=+Y,GMRCSTS=5,GMRCA=1,DIE=DIC
L +^GMR(123,GMRCO):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
S DR=".02////^S X=DFN;.04////^S X=GMRCLOC;1////^S X=GMRCSVC;3////^S X=GMRCDA;4////^S X=GMRCPR;5////^S X=GMRCURG;6////^S X=GMRCPLI"_$S(GMRCATN]"":"7////^S X=GMRCATN",1:"")
D ^DIE
S DR="8////^S X=GMRCSTS;9////^S X=GMRCA;10////^S X=GMRCPROV;11////^S X=GMRCATN;13////^S X=GMRCTYPE;14////^S X=GMRCINOT"_$S($D(GMRCDIAG):"30:////^S X=GMRCDIAG",1:"")
D ^DIE L -^GMR(123,GMRCO)
I $O(GMRCRFQ(0)) D REASON^GMRCGUIB(GMRCO,GMRCRFQ,GMRCDA)
D EN^GMRCHL7(DFN,GMRCDA,GMRCTYPE,$G(GMRCRB),"NW",DUZ,$G(VISIT),"")
D EXIT
Q
;
RC(GMRCO,GMRCORNP,GMRCAD,GMRCMT,GMRCDUZ) ;Receive consult into service
;
;Input variables:
;GMRCO - The internal file number of the consult from File 123
;GMRCORNP - Name of the person who actually 'Received'the consult
;GMRCDUZ - DUZ of person entering the consult as being 'RECEIVED'.
;GMRCAD - Actual date time that consult was received into the service.
;GMRCMT - array of comments if entered (by reference)
; ARRAY(1)="FIRST LINE OF COMMENT"
; ARRAY(2)="SECOND LINE OF COMMENT"
;GMRCDUZ - DUZ of person entering the consult as being 'RECEIVED'
;
;Output:
;GMRCERR - Error Condition Code: 0 = NO error, 1=error
;GMRCERMS - Error message or null
; returned as GMRCERR^GMRCERMS
;
N DFN,GMRCSTS,GMRCNOW,GMRCERR,GMRCERMS
S GMRCERR=0,GMRCERMS="",GMRCNOW=$$NOW^XLFDT
S:$G(GMRCAD)="" GMRCAD=GMRCNOW
S:'$G(GMRCDUZ) GMRCDUZ=DUZ
S DFN=$P($G(^GMR(123,GMRCO,0)),"^",2) I DFN="" S GMRCERR="1",GMRCERMS="Not A Valid Consult - File Not Found." D EXIT Q GMRCERR_"^"_GMRCERMS
S GMRCSTS=6,GMRCA=21
D STATUS^GMRCP I $D(GMRCQUT) D EXIT Q GMRCERR_"^"_GMRCERMS
I '$O(GMRCMT(0)) D AUDIT^GMRCP
I $O(GMRCMT(0)) D
. S DA=$$SETDA^GMRCGUIB
. D SETCOM^GMRCGUIB(.GMRCMT,GMRCDUZ)
D EN^GMRCHL7(DFN,GMRCO,"","","SC",GMRCORNP,"","")
D EXIT
Q GMRCERR_"^"_GMRCERMS
;
DC(GMRCO,GMRCORNP,GMRCAD,GMRCACTM,GMRCOM) ;Discontinue or Deny a consult
;
;Input variables:
;GMRCO - Internal file number of consult from File 123
;GMRCORNP - Provider who Discontinued or Denied consult
;GMRCAD - FM date/time of actual activity.
;GMRCACTM - set to "DY" if 'CANCELLED'(old DENY)
; set to "DC" if consult is Discontinued
;GMRCOM - Comment array containing explanation of action
; Passed by reference in the following form :
; ARRAY(1)="xxx xxx xxx"
; ARRAY(2)="XXX XXX"
; ARRAY(3)="XXX XXX xx", etc.
; Comment is a required field when consult is denied or discontinued.
;
;Output:
;GMRCERR=Error Flag: 0 if no error, 1 if error occurred
;GMRCERMS - Error message or null
; returned as GMRCERR^GMRCERMS
;
N GMRCDUZ,DFN,GMRCNOW,GMRCSTS,GMRCERR,GMRCERMS,GMRCADUZ,GMRCTRLC
S GMRCERR=0,GMRCERMS=""
S GMRCDUZ=DUZ,GMRCERR=0,GMRCERMS="",GMRCNOW=$$NOW^XLFDT
K GMRCQUT
S:$G(GMRCAD)="" GMRCAD=GMRCNOW
S DFN=$P($G(^GMR(123,GMRCO,0)),"^",2) I DFN="" S GMRCERR="1",GMRCERMS="Not A Valid Consult - File Not Found." D EXIT Q GMRCERR_"^"_GMRCERMS
I '$D(GMRCOM) S GMRCERR=1,GMRCERMS="Comments are required for this action." D EXIT Q GMRCERR_"^"_GMRCERMS
S GMRCSTS=$P(^ORD(100.01,$P(^GMR(123,GMRCO,0),"^",12),0),U,2)
I GMRCSTS="dc" S GMRCERR=1,GMRCERMS="Order Has Already Been Discontinued." D EXIT Q GMRCERR_"^"_GMRCERMS
I GMRCSTS="ca" S GMRCERR=1,GMRCERMS="Order Has Already Been Cancelled." D EXIT Q GMRCERR_"^"_GMRCERMS
I GMRCSTS="comp" S GMRCERR=1,GMRCERMS="Order Has Already Been Completed." D EXIT Q GMRCERR_"^"_GMRCERMS
S GMRCA=$S(GMRCACTM="DC":6,1:19),GMRCSTS=$S(GMRCA=6:1,1:13)
D STATUS^GMRCP I $D(GMRCQUT) D EXIT Q GMRCERR_"^"_GMRCERMS
I GMRCACTM="DC",$$DCPRNT^GMRCUTL1(GMRCO,DUZ) D PRNT^GMRCUTL1("",GMRCO)
S DA=$$SETDA^GMRCGUIB D SETCOM^GMRCGUIB(.GMRCOM)
S GMRCOM(0)=DA
S GMRCTRLC=$S(GMRCACTM="DC":"OD",1:"OC")
D EN^GMRCHL7(DFN,GMRCO,$G(GMRCTYPE),$G(GMRCRB),GMRCTRLC,GMRCORNP,$G(GMRCVSIT),.GMRCOM,,GMRCAD)
S GMRCORTX=$S(GMRCACTM="DY":"Cancelled",1:"Discontinued")_" consult "
S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCO)
S GMRCADUZ="",GMRCFL=0
I GMRCACTM="DC" D
. S GMRCFL=$$DCNOTE^GMRCADC(GMRCO,DUZ) ;NOTIFY SERVICE ON DC ?
I +$P($G(^GMR(123,+GMRCO,0)),"^",14),$P(^(0),"^",14)'=DUZ D
. S GMRCADUZ($P(^(0),"^",14))=""
;send notification
N NOTYPE S NOTYPE=$S(GMRCA=6:23,1:30)
D MSG^GMRCP(DFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
D EXIT
Q GMRCERR_"^"_GMRCERMS
;
FR(GMRCO,GMRCSS,GMRCORNP,GMRCATTN,GMRCURGI,GMRCOM,GMRCAD) ;FWD consult
;to another service
;
;Input variables:
;GMRCO=File 123 IEN of the consult record
;GMRCSS=service being forwarded to; ptr to REQUEST SERVICES (#123.5)
;GMRCORNP=Provider Responsible for action
;GMRCATTN=NEW PERSON to whose attention action should be directed
;GMRCURGI=urgency from PROTOCOL(#101) file
;GMRCOM=Comment array containing explanation of action
; Passed by reference in the following form :
; ARRAY(1)="xxx xxx xxx"
; ARRAY(2)="XXX XXX"
; ARRAY(3)="XXX XXX xx", etc.
;GMRCAD=FM date/time of actual activity
;
;Output:
; GMRCERR=Error Flag: 0 if no error, 1 if error occurred
; GMRCERMS - Error message or null
; returned as GMRCERR^GMRCERMS
;
N DR,GMRCDUZ,GMRCNOW,GMRCFF,GMRCFR,GMRCADUZ,GMRCURG,GMRCPA,GMRCSEQ,GMRCDOC
N GMRCERR,GMRCERMS,GMRCIROL,GMRCINM,GMRCIROU,GMRD
S GMRCERR=0,GMRCERMS=""
I $P(^GMR(123,+GMRCO,0),U,12)=9 S GMRCERR=1,GMRCERMS="Invalid action. This consult has partial results."
S GMRCSEQ=0,GMRCDOC="" F S GMRCSEQ=$O(^GMR(123,+GMRCO,50,GMRCSEQ)) Q:GMRCSEQ="" D Q:+$G(GMRCERR)
. I $P($G(^GMR(123,+GMRCO,50,GMRCSEQ,0)),";",2)="TIU(8925," S GMRCDOC=$P(^GMR(123,+GMRCO,50,GMRCSEQ,0),";",1)
. I $G(GMRCDOC)="" Q
. I $P($G(^TIU(8925,GMRCDOC,0)),U,5)=5 D
. . S GMRCERMS="Invalid Action. This consult has an unsigned note.",GMRCERR=1
. I $P($G(^TIU(8925,GMRCDOC,0)),U,5)=6 D
. . S GMRCERMS="Invalid Action. This consult has an uncosigned note.",GMRCERR=1
S GMRCSEQ=0,GMRCDOC="" F S GMRCSEQ=$O(^GMR(123,+GMRCO,40,GMRCSEQ)) Q:GMRCSEQ="" D Q:+$G(GMRCERR)
. I $P($P($G(^GMR(123,+GMRCO,40,GMRCSEQ,0)),U,9),";",2)="TIU(8925," S GMRCDOC=$P($P($G(^GMR(123,+GMRCO,40,GMRCSEQ,0)),U,9),";",1)
. I $G(GMRCDOC)="" Q
. S GMRD=$P($G(^TIU(8925,GMRCDOC,14)),U,5)
. I $P($G(^TIU(8925,GMRCDOC,0)),U,5)=5,(GMRD["GMR"&(+GMRD=GMRCO)) D
. . S GMRCERMS="Invalid Action. This consult has an unsigned note.",GMRCERR=1
. I $P($G(^TIU(8925,GMRCDOC,0)),U,5)=6,(GMRD["GMR"&(+GMRD=GMRCO)) D
. . S GMRCERMS="Invalid Action. This consult has an uncosigned note.",GMRCERR=1
I GMRCERR=1 D EXIT Q GMRCERR_"^"_GMRCERMS
S DFN=$P(^GMR(123,+GMRCO,0),U,2)
S GMRCDUZ=DUZ,GMRCNOW=$$NOW^XLFDT
S:'$G(GMRCAD) GMRCAD=GMRCNOW ;Actual FM date/time consult was FWD'd
S:'$G(GMRCURGI) GMRCURGI=$P(^GMR(123,GMRCO,0),U,9)
S GMRCA=17,GMRCSTS=5
S GMRCFF=$P($G(^GMR(123.5,+GMRCSS,123)),U,9) ;printed to new serv
S GMRCFR=$P($G(^GMR(123,+GMRCO,0)),"^",5) ;Get current service
S GMRCPA=$P($G(^GMR(123,+GMRCO,0)),"^",11) ;get current attention
S DIE="^GMR(123,",DA=GMRCO,DR=""
I $D(^GMR(123.5,+GMRCSS,"IFC")) D ; if fwd to IFC serv, get extra flds
. S GMRCIROU=$P(^GMR(123.5,+GMRCSS,"IFC"),U) Q:GMRCIROU="" ;no rout fac
. S GMRCINM=$P(^GMR(123.5,+GMRCSS,"IFC"),U,2) Q:GMRCINM="" ;no serv nm
. S GMRCA=25,GMRCIROL="P"
. S DR=".07////^S X=GMRCIROU;.125////^S X=GMRCIROL;.131///^S X=GMRCINM;"
S DR=DR_"1////^S X=$G(GMRCSS);5////^S X=$G(GMRCURGI);8////^S X=$G(GMRCSTS);9////^S X=$G(GMRCA);.1///@"_$S($L($G(GMRCATTN)):";7////^S X=GMRCATTN",1:";7///@")
L +^GMR(123,GMRCO):3 I '$T K DIE,DA,DR S GMRCERR=1,GMRCERMS="Data Not Filed - File In Use By Another User." D EXIT Q GMRCERR_"^"_GMRCERMS
D ^DIE L -^GMR(123,GMRCO) K DIE,DA,DR
S DA=$$SETDA^GMRCGUIB D SETCOM^GMRCGUIB(.GMRCOM)
S GMRCURG=$P($G(^ORD(101,+GMRCURGI,0)),"^",2)
D DEM^GMRCU ;sets GMRCRB and other variables
D TYPE^GMRCAFRD ;sets GMRCTYPE
D FRMSG^GMRCAFRD ;create XX HL7 message for OE/RR and send alert
D EXIT
Q GMRCERR_"^"_GMRCERMS
;
RT(GMRCO,TMPGLOB) ;Set ^TMP("GMRCR",$J,"DT", with results from med and TIU
;GMRCO=IEN of consult from file 123
;Set TMPGLOB to a ^TMP global other than ^TMP("GMRCR",$J,"MCAR", or ^TMP("GMRCR",$J,"RES", i.e., S TMPGLOB="^TMP(""GMRCR"",$J,""RT"")"'
Q:'$G(GMRCO)
K @TMPGLOB
S GMRCDVL="",$P(GMRCDVL,"-",41)=""
S GMRCSR=$P(^GMR(123,+GMRCO,0),"^",15),GMRCTUFN=$P(^(0),"^",20)
S GMRCRTFL=$S('+GMRCSR&('GMRCTUFN):1,1:0)
;
D GETRSLT^GMRCART(TMPGLOB)
;
D EXIT
Q
EXIT ;kill off variables for exit from actions
K GMRCA,GMRCDVL,GMRCSR,GMRCRTFL,GMRCFL,GMRCORNP,GMRCQUT,GMRCSTS,GMRCTUFN
K GMRCRTFL,GMRCADUZ,GMRCORTX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCGUIA 9880 printed Apr 09, 2024@20:51:34 Page 2
GMRCGUIA ;SLC/DCM,JFR - File Consult actions from GUI ;7/8/03 07:36
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,12,15,22,35,64,114**;DEC 27, 1997;Build 2
+2 ;
+3 ; This routine invokes IA #2638,#2926
+4 ;
NEW(DFN,GMRCDA,GMRCLOC,GMRCTYPE,GMRCSVC,GMRCPROV,GMRCURG,GMRCPLI,GMRCNP,GMRCATN,GMRCINOT,GMRCDIAG,GMRCRFQ) ;Add a new consult for a patient.
+1 ;DFN=Patient ^DPT( file number
+2 ;GMRCRFQ=Reason For Request, why the consult is being ordered. Passed in as
+3 ; an array
+4 ;GMRCDIAG=Povisional diagnosis; what is suspected to be the problem
+5 ;GMRCTYPE=Request type -Consult or Procedure
+6 ;GMRCLOC=Patient location.
+7 ;GMRCDA=Date Time of Request
+8 ;GMRCSVC=To Service; consulting service
+9 ;GMRCLOC=Hospital Location ordering consult
+10 ;GMRCPR=If a procedure, the procedure ordered (pointer to file 101)
+11 ;GMRCURG=Urgency of request (stat, routine, etc) from file 101
+12 ;GMRCPLI=Place of consultation (bedside, consultants choice, etc.) from file 101
+13 ;GMRCPROV=Sending Provider
+14 ;GMRCATN=if consult is to go to a specific provider, this provider is identified here.
+15 ;GMRCINOT=Service provided as Inpatient or Outpatient
+16 NEW DIC,DLAYGO,Y,DIE,GMRCADUZ,X,GMRCO,DR
+17 SET DIC="^GMR(123,"
SET DIC(0)="L"
SET X="""N"""
SET DLAYGO=123
DO ^DIC
KILL DLAYGO
+18 SET (DA,GMRCO)=+Y
SET GMRCSTS=5
SET GMRCA=1
SET DIE=DIC
+19 LOCK +^GMR(123,GMRCO):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+20 SET DR=".02////^S X=DFN;.04////^S X=GMRCLOC;1////^S X=GMRCSVC;3////^S X=GMRCDA;4////^S X=GMRCPR;5////^S X=GMRCURG;6////^S X=GMRCPLI"_$SELECT(GMRCATN]"":"7////^S X=GMRCATN",1:"")
+21 DO ^DIE
+22 SET DR="8////^S X=GMRCSTS;9////^S X=GMRCA;10////^S X=GMRCPROV;11////^S X=GMRCATN;13////^S X=GMRCTYPE;14////^S X=GMRCINOT"_$SELECT($DATA(GMRCDIAG):"30:////^S X=GMRCDIAG",1:"")
+23 DO ^DIE
LOCK -^GMR(123,GMRCO)
+24 IF $ORDER(GMRCRFQ(0))
DO REASON^GMRCGUIB(GMRCO,GMRCRFQ,GMRCDA)
+25 DO EN^GMRCHL7(DFN,GMRCDA,GMRCTYPE,$GET(GMRCRB),"NW",DUZ,$GET(VISIT),"")
+26 DO EXIT
+27 QUIT
+28 ;
RC(GMRCO,GMRCORNP,GMRCAD,GMRCMT,GMRCDUZ) ;Receive consult into service
+1 ;
+2 ;Input variables:
+3 ;GMRCO - The internal file number of the consult from File 123
+4 ;GMRCORNP - Name of the person who actually 'Received'the consult
+5 ;GMRCDUZ - DUZ of person entering the consult as being 'RECEIVED'.
+6 ;GMRCAD - Actual date time that consult was received into the service.
+7 ;GMRCMT - array of comments if entered (by reference)
+8 ; ARRAY(1)="FIRST LINE OF COMMENT"
+9 ; ARRAY(2)="SECOND LINE OF COMMENT"
+10 ;GMRCDUZ - DUZ of person entering the consult as being 'RECEIVED'
+11 ;
+12 ;Output:
+13 ;GMRCERR - Error Condition Code: 0 = NO error, 1=error
+14 ;GMRCERMS - Error message or null
+15 ; returned as GMRCERR^GMRCERMS
+16 ;
+17 NEW DFN,GMRCSTS,GMRCNOW,GMRCERR,GMRCERMS
+18 SET GMRCERR=0
SET GMRCERMS=""
SET GMRCNOW=$$NOW^XLFDT
+19 if $GET(GMRCAD)=""
SET GMRCAD=GMRCNOW
+20 if '$GET(GMRCDUZ)
SET GMRCDUZ=DUZ
+21 SET DFN=$PIECE($GET(^GMR(123,GMRCO,0)),"^",2)
IF DFN=""
SET GMRCERR="1"
SET GMRCERMS="Not A Valid Consult - File Not Found."
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+22 SET GMRCSTS=6
SET GMRCA=21
+23 DO STATUS^GMRCP
IF $DATA(GMRCQUT)
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+24 IF '$ORDER(GMRCMT(0))
DO AUDIT^GMRCP
+25 IF $ORDER(GMRCMT(0))
Begin DoDot:1
+26 SET DA=$$SETDA^GMRCGUIB
+27 DO SETCOM^GMRCGUIB(.GMRCMT,GMRCDUZ)
End DoDot:1
+28 DO EN^GMRCHL7(DFN,GMRCO,"","","SC",GMRCORNP,"","")
+29 DO EXIT
+30 QUIT GMRCERR_"^"_GMRCERMS
+31 ;
DC(GMRCO,GMRCORNP,GMRCAD,GMRCACTM,GMRCOM) ;Discontinue or Deny a consult
+1 ;
+2 ;Input variables:
+3 ;GMRCO - Internal file number of consult from File 123
+4 ;GMRCORNP - Provider who Discontinued or Denied consult
+5 ;GMRCAD - FM date/time of actual activity.
+6 ;GMRCACTM - set to "DY" if 'CANCELLED'(old DENY)
+7 ; set to "DC" if consult is Discontinued
+8 ;GMRCOM - Comment array containing explanation of action
+9 ; Passed by reference in the following form :
+10 ; ARRAY(1)="xxx xxx xxx"
+11 ; ARRAY(2)="XXX XXX"
+12 ; ARRAY(3)="XXX XXX xx", etc.
+13 ; Comment is a required field when consult is denied or discontinued.
+14 ;
+15 ;Output:
+16 ;GMRCERR=Error Flag: 0 if no error, 1 if error occurred
+17 ;GMRCERMS - Error message or null
+18 ; returned as GMRCERR^GMRCERMS
+19 ;
+20 NEW GMRCDUZ,DFN,GMRCNOW,GMRCSTS,GMRCERR,GMRCERMS,GMRCADUZ,GMRCTRLC
+21 SET GMRCERR=0
SET GMRCERMS=""
+22 SET GMRCDUZ=DUZ
SET GMRCERR=0
SET GMRCERMS=""
SET GMRCNOW=$$NOW^XLFDT
+23 KILL GMRCQUT
+24 if $GET(GMRCAD)=""
SET GMRCAD=GMRCNOW
+25 SET DFN=$PIECE($GET(^GMR(123,GMRCO,0)),"^",2)
IF DFN=""
SET GMRCERR="1"
SET GMRCERMS="Not A Valid Consult - File Not Found."
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+26 IF '$DATA(GMRCOM)
SET GMRCERR=1
SET GMRCERMS="Comments are required for this action."
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+27 SET GMRCSTS=$PIECE(^ORD(100.01,$PIECE(^GMR(123,GMRCO,0),"^",12),0),U,2)
+28 IF GMRCSTS="dc"
SET GMRCERR=1
SET GMRCERMS="Order Has Already Been Discontinued."
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+29 IF GMRCSTS="ca"
SET GMRCERR=1
SET GMRCERMS="Order Has Already Been Cancelled."
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+30 IF GMRCSTS="comp"
SET GMRCERR=1
SET GMRCERMS="Order Has Already Been Completed."
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+31 SET GMRCA=$SELECT(GMRCACTM="DC":6,1:19)
SET GMRCSTS=$SELECT(GMRCA=6:1,1:13)
+32 DO STATUS^GMRCP
IF $DATA(GMRCQUT)
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+33 IF GMRCACTM="DC"
IF $$DCPRNT^GMRCUTL1(GMRCO,DUZ)
DO PRNT^GMRCUTL1("",GMRCO)
+34 SET DA=$$SETDA^GMRCGUIB
DO SETCOM^GMRCGUIB(.GMRCOM)
+35 SET GMRCOM(0)=DA
+36 SET GMRCTRLC=$SELECT(GMRCACTM="DC":"OD",1:"OC")
+37 DO EN^GMRCHL7(DFN,GMRCO,$GET(GMRCTYPE),$GET(GMRCRB),GMRCTRLC,GMRCORNP,$GET(GMRCVSIT),.GMRCOM,,GMRCAD)
+38 SET GMRCORTX=$SELECT(GMRCACTM="DY":"Cancelled",1:"Discontinued")_" consult "
+39 SET GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCO)
+40 SET GMRCADUZ=""
SET GMRCFL=0
+41 IF GMRCACTM="DC"
Begin DoDot:1
+42 ;NOTIFY SERVICE ON DC ?
SET GMRCFL=$$DCNOTE^GMRCADC(GMRCO,DUZ)
End DoDot:1
+43 IF +$PIECE($GET(^GMR(123,+GMRCO,0)),"^",14)
IF $PIECE(^(0),"^",14)'=DUZ
Begin DoDot:1
+44 SET GMRCADUZ($PIECE(^(0),"^",14))=""
End DoDot:1
+45 ;send notification
+46 NEW NOTYPE
SET NOTYPE=$SELECT(GMRCA=6:23,1:30)
+47 DO MSG^GMRCP(DFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
+48 DO EXIT
+49 QUIT GMRCERR_"^"_GMRCERMS
+50 ;
FR(GMRCO,GMRCSS,GMRCORNP,GMRCATTN,GMRCURGI,GMRCOM,GMRCAD) ;FWD consult
+1 ;to another service
+2 ;
+3 ;Input variables:
+4 ;GMRCO=File 123 IEN of the consult record
+5 ;GMRCSS=service being forwarded to; ptr to REQUEST SERVICES (#123.5)
+6 ;GMRCORNP=Provider Responsible for action
+7 ;GMRCATTN=NEW PERSON to whose attention action should be directed
+8 ;GMRCURGI=urgency from PROTOCOL(#101) file
+9 ;GMRCOM=Comment array containing explanation of action
+10 ; Passed by reference in the following form :
+11 ; ARRAY(1)="xxx xxx xxx"
+12 ; ARRAY(2)="XXX XXX"
+13 ; ARRAY(3)="XXX XXX xx", etc.
+14 ;GMRCAD=FM date/time of actual activity
+15 ;
+16 ;Output:
+17 ; GMRCERR=Error Flag: 0 if no error, 1 if error occurred
+18 ; GMRCERMS - Error message or null
+19 ; returned as GMRCERR^GMRCERMS
+20 ;
+21 NEW DR,GMRCDUZ,GMRCNOW,GMRCFF,GMRCFR,GMRCADUZ,GMRCURG,GMRCPA,GMRCSEQ,GMRCDOC
+22 NEW GMRCERR,GMRCERMS,GMRCIROL,GMRCINM,GMRCIROU,GMRD
+23 SET GMRCERR=0
SET GMRCERMS=""
+24 IF $PIECE(^GMR(123,+GMRCO,0),U,12)=9
SET GMRCERR=1
SET GMRCERMS="Invalid action. This consult has partial results."
+25 SET GMRCSEQ=0
SET GMRCDOC=""
FOR
SET GMRCSEQ=$ORDER(^GMR(123,+GMRCO,50,GMRCSEQ))
if GMRCSEQ=""
QUIT
Begin DoDot:1
+26 IF $PIECE($GET(^GMR(123,+GMRCO,50,GMRCSEQ,0)),";",2)="TIU(8925,"
SET GMRCDOC=$PIECE(^GMR(123,+GMRCO,50,GMRCSEQ,0),";",1)
+27 IF $GET(GMRCDOC)=""
QUIT
+28 IF $PIECE($GET(^TIU(8925,GMRCDOC,0)),U,5)=5
Begin DoDot:2
+29 SET GMRCERMS="Invalid Action. This consult has an unsigned note."
SET GMRCERR=1
End DoDot:2
+30 IF $PIECE($GET(^TIU(8925,GMRCDOC,0)),U,5)=6
Begin DoDot:2
+31 SET GMRCERMS="Invalid Action. This consult has an uncosigned note."
SET GMRCERR=1
End DoDot:2
End DoDot:1
if +$GET(GMRCERR)
QUIT
+32 SET GMRCSEQ=0
SET GMRCDOC=""
FOR
SET GMRCSEQ=$ORDER(^GMR(123,+GMRCO,40,GMRCSEQ))
if GMRCSEQ=""
QUIT
Begin DoDot:1
+33 IF $PIECE($PIECE($GET(^GMR(123,+GMRCO,40,GMRCSEQ,0)),U,9),";",2)="TIU(8925,"
SET GMRCDOC=$PIECE($PIECE($GET(^GMR(123,+GMRCO,40,GMRCSEQ,0)),U,9),";",1)
+34 IF $GET(GMRCDOC)=""
QUIT
+35 SET GMRD=$PIECE($GET(^TIU(8925,GMRCDOC,14)),U,5)
+36 IF $PIECE($GET(^TIU(8925,GMRCDOC,0)),U,5)=5
IF (GMRD["GMR"&(+GMRD=GMRCO))
Begin DoDot:2
+37 SET GMRCERMS="Invalid Action. This consult has an unsigned note."
SET GMRCERR=1
End DoDot:2
+38 IF $PIECE($GET(^TIU(8925,GMRCDOC,0)),U,5)=6
IF (GMRD["GMR"&(+GMRD=GMRCO))
Begin DoDot:2
+39 SET GMRCERMS="Invalid Action. This consult has an uncosigned note."
SET GMRCERR=1
End DoDot:2
End DoDot:1
if +$GET(GMRCERR)
QUIT
+40 IF GMRCERR=1
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+41 SET DFN=$PIECE(^GMR(123,+GMRCO,0),U,2)
+42 SET GMRCDUZ=DUZ
SET GMRCNOW=$$NOW^XLFDT
+43 ;Actual FM date/time consult was FWD'd
if '$GET(GMRCAD)
SET GMRCAD=GMRCNOW
+44 if '$GET(GMRCURGI)
SET GMRCURGI=$PIECE(^GMR(123,GMRCO,0),U,9)
+45 SET GMRCA=17
SET GMRCSTS=5
+46 ;printed to new serv
SET GMRCFF=$PIECE($GET(^GMR(123.5,+GMRCSS,123)),U,9)
+47 ;Get current service
SET GMRCFR=$PIECE($GET(^GMR(123,+GMRCO,0)),"^",5)
+48 ;get current attention
SET GMRCPA=$PIECE($GET(^GMR(123,+GMRCO,0)),"^",11)
+49 SET DIE="^GMR(123,"
SET DA=GMRCO
SET DR=""
+50 ; if fwd to IFC serv, get extra flds
IF $DATA(^GMR(123.5,+GMRCSS,"IFC"))
Begin DoDot:1
+51 ;no rout fac
SET GMRCIROU=$PIECE(^GMR(123.5,+GMRCSS,"IFC"),U)
if GMRCIROU=""
QUIT
+52 ;no serv nm
SET GMRCINM=$PIECE(^GMR(123.5,+GMRCSS,"IFC"),U,2)
if GMRCINM=""
QUIT
+53 SET GMRCA=25
SET GMRCIROL="P"
+54 SET DR=".07////^S X=GMRCIROU;.125////^S X=GMRCIROL;.131///^S X=GMRCINM;"
End DoDot:1
+55 SET DR=DR_"1////^S X=$G(GMRCSS);5////^S X=$G(GMRCURGI);8////^S X=$G(GMRCSTS);9////^S X=$G(GMRCA);.1///@"_$SELECT($LENGTH($GET(GMRCATTN)):";7////^S X=GMRCATTN",1:";7///@")
+56 LOCK +^GMR(123,GMRCO):3
IF '$TEST
KILL DIE,DA,DR
SET GMRCERR=1
SET GMRCERMS="Data Not Filed - File In Use By Another User."
DO EXIT
QUIT GMRCERR_"^"_GMRCERMS
+57 DO ^DIE
LOCK -^GMR(123,GMRCO)
KILL DIE,DA,DR
+58 SET DA=$$SETDA^GMRCGUIB
DO SETCOM^GMRCGUIB(.GMRCOM)
+59 SET GMRCURG=$PIECE($GET(^ORD(101,+GMRCURGI,0)),"^",2)
+60 ;sets GMRCRB and other variables
DO DEM^GMRCU
+61 ;sets GMRCTYPE
DO TYPE^GMRCAFRD
+62 ;create XX HL7 message for OE/RR and send alert
DO FRMSG^GMRCAFRD
+63 DO EXIT
+64 QUIT GMRCERR_"^"_GMRCERMS
+65 ;
RT(GMRCO,TMPGLOB) ;Set ^TMP("GMRCR",$J,"DT", with results from med and TIU
+1 ;GMRCO=IEN of consult from file 123
+2 ;Set TMPGLOB to a ^TMP global other than ^TMP("GMRCR",$J,"MCAR", or ^TMP("GMRCR",$J,"RES", i.e., S TMPGLOB="^TMP(""GMRCR"",$J,""RT"")"'
+3 if '$GET(GMRCO)
QUIT
+4 KILL @TMPGLOB
+5 SET GMRCDVL=""
SET $PIECE(GMRCDVL,"-",41)=""
+6 SET GMRCSR=$PIECE(^GMR(123,+GMRCO,0),"^",15)
SET GMRCTUFN=$PIECE(^(0),"^",20)
+7 SET GMRCRTFL=$SELECT('+GMRCSR&('GMRCTUFN):1,1:0)
+8 ;
+9 DO GETRSLT^GMRCART(TMPGLOB)
+10 ;
+11 DO EXIT
+12 QUIT
EXIT ;kill off variables for exit from actions
+1 KILL GMRCA,GMRCDVL,GMRCSR,GMRCRTFL,GMRCFL,GMRCORNP,GMRCQUT,GMRCSTS,GMRCTUFN
+2 KILL GMRCRTFL,GMRCADUZ,GMRCORTX
+3 QUIT
