GMRCAFRD ;SLC/DLT,DCM,JFR - LM FORWARD ACTION ;7/11/03 14:02
;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,22,35,39**;DEC 27, 1997
;
; This routine invokes IA #2395
;
FR(GMRCO) ;Forward Request to a new service
N ORVP,GMRCLCK,DFN,GMRCACT
W !!,"Forward Request To Another Service For Action."
W !,"Select the service to send the consult to.",!
S:$D(GMRCSS) GMRCSSS=GMRCSS
N GMRCPL,GMRCPR,GMRCURG,GMRCDG,GMRCFF,GMRCORNP,GMRCAD,GMRCTO,GMRCADUZ
K GMRCQUT,GMRCSEL,GMRCSSS
I '$L($G(GMRCO)) D SELECT^GMRCA2(.GMRCO) I $D(GMRCQUT) D END Q
I '+$G(GMRCO) D END S GMRCQUT=1 Q
I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D Q
. N DIR
. W !,"The requesting facility may not take this action on an "
. W "inter-facility consult."
. S DIR(0)="E" D ^DIR
. D END
. S GMRCQUT=1
I '$$LOCK^GMRCA1(GMRCO) D END S GMRCQUT=1 Q
S GMRCLCK=1
;
I $P(^GMR(123,GMRCO,0),"^",12)<3 S GMRCMSG="NO ACTION POSSIBLE. This Consult Has Already Been Completed Or Discontinued." D EXAC^GMRCADC(GMRCMSG),END S GMRCQUT=1 Q
I $P(^GMR(123,GMRCO,0),"^",12)=13 S GMRCMSG="NO ACTION POSSIBLE. This Consult Has Already Been Cancelled." D EXAC^GMRCADC(GMRCMSG),END S GMRCQUT=1 Q
I $P(^GMR(123,GMRCO,0),"^",12)=9 D Q:+$G(GMRCQUT)
.S GMRCMSG="Invalid action. This consult has partial results."
.S GMRCMSG(1)="Remove the associated results before forwarding."
.D EXAC^GMRCADC(.GMRCMSG),END S GMRCQUT=1 Q
;
I $D(IOBM),$D(IOTM),$D(IOSTBM) D FULL^VALM1
I $P(^GMR(123,GMRCO,0),"^",16) W !!,"This is a SERVICE ENTERED order stub. Please send the written consult to the",!,"Service, in addition to the automated forwarding!"
S DFN=+$P(^GMR(123,GMRCO,0),"^",2)
S GMRCTO=1,GMRCASV="Forward Consult To Which Service/Specialty: "
D ASRV^GMRCASV K GMRCASV I $S($D(DTOUT):1,$D(DIROUT):1,$D(GMRCQUT):1,1:0) D END Q
I 'GMRCDG S GMRCMSG="No Service Was Selected. Consult Was Not Forwarded To Any Service!" D EXAC^GMRCADC(GMRCMSG),END S GMRCQUT=1 Q
S GMRCFF=$P(^GMR(123,GMRCO,0),"^",5) I GMRCFF=+GMRCDG S GMRCMSG="The Forwarding Service Cannot Forward A Consult To Itself!" D EXAC^GMRCADC(GMRCMSG),END S GMRCQUT=1 Q
S GETPROV="Who is responsible for Forwarding the Consult?"
FRGTPRV D GETPROV^GMRCAU I '$D(GMRCORNP) D END S GMRCQUT=1 Q
S GMRCACT=$$PROVIDER^XUSER(GMRCORNP) I $P(GMRCACT,U)'=1 D G FRGTPRV
.W !!,"***User account is TERMINATED please choose another responsible user.***"
S GMRCAD=$$GETDT^GMRCUTL1 I GMRCAD="^" D END S GMRCQUT=1 Q
I '$G(GMRCAD) S GMRCAD=$$NOW^XLFDT
N GMRCSS,GMRCSSNM,GMRCA,GMRCMSG,GMRCIROL,GMRCINM,GMRCIROU,ORSTS
D DEFAULT
S GMRCSS=+GMRCDG
I +GMRCSS,'$D(^GMR(123.5,+GMRCSS,0)) S GMRCMSG="Error in Service Chosen - SERVICE Does Not Exist!" D EXAC^GMRCADC(GMRCMSG),END S GMRCQUT=1 Q
S GMRCSSNM=$S($L($G(^GMR(123.5,+GMRCSS,.1))):^(.1),1:$P($G(^GMR(123.5,+GMRCSS,0)),U,1))
D URG I $D(GMRCEND),GMRCEND D END S GMRCQUT=1 Q
S GMRCA=17,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 DIE="^GMR(123,",DA=GMRCO,ORSTS=5
S DR=DR_"1////^S X=GMRCSS;5////^S X=GMRCURGI;8////^S X=ORSTS;9////^S X=GMRCA;.1///@"
L +^GMR(123,GMRCO):2 I '$T K DIE,DA,DR S GMRCMSG="Another User Is Accessing This Record. UPDATE WAS UNSUCCESSFUL.",GMRCMSG(1)="Try Again Later." D EXAC^GMRCADC(.GMRCMSG),END S GMRCQUT=1 Q
D ^DIE L -^GMR(123,GMRCO) K DIE,DA,DR
S GMRCOM=1 D AUDIT^GMRCP ;GMRCORNP is the responsible provider here
;
I $G(GMRCLCK) D UNLOCK^GMRCA1(GMRCO) ;unlk before FWD changes order #
;
FRMSG ; Common logic used by GUI and List Manager to process the HL7 message
; to update the order in OE/RR and then forward an alert to recipients
; is passed in as the DUZ instead of the responsible provider
D EN^GMRCHL7(DFN,GMRCO,$G(GMRCTYPE),$G(GMRCRB),"XX^FORWARD",$G(DUZ),$G(VISIT),.GMRCOM,,$G(GMRCAD))
S GMRCADUZ=""
S GMRCORNP=$P(^GMR(123,GMRCO,0),"^",14) ;This is the original provider that ordered the consult
I +$G(GMRCORNP) S GMRCADUZ(+GMRCORNP)="" ;alert original provider of forward
S GMRCORTX="Forwarded consult "_$$ORTX^GMRCAU(+GMRCO)_" ("_GMRCURG_")"
D MSG^GMRCP(DFN,GMRCORTX,+GMRCO,27,.GMRCADUZ,1) ;GMRCO=IEN of consult from file 123; 27 is notification entry from file ORD(100.9
K GMRCOM
S GMRCDEV=$P($G(^GMR(123.5,GMRCSS,123)),"^",9)
I GMRCDEV D PRNT^GMRCUTL1(GMRCSS,+GMRCO)
D END
Q
URG ;Get the default urgency
N X,Y,XQORM,DIROUT,DTOUT,DIRUT,DUOUT
I $P(^GMR(123,+GMRCO,0),"^",18)["I" D
.I GMRCTYPE="GMRCOR CONSULT" S X="GMRCURGENCYM CSLT - INPATIENT"
.S X="GMRCURGENCYM REQ - INPATIENT"
E S X="GMRCURGENCYM - OUTPATIENT"
I '$D(GMRCURG) S GMRCURGI=$O(^ORD(101,"B","GMRCURGENCY - ROUTINE","")) S:+GMRCURGI GMRCURG=$P($G(^ORD(101,+GMRCURGI,0)),"^",2)
S Y=$O(^ORD(101,"B",X,""))
S XQORM=+Y_";ORD(101,",XQORM(0)="1A\",XQORM("A")="Urgency: ",XQORM("NO^^")=""
S:$L(GMRCURG) XQORM("B")=GMRCURG D EN^XQORM I X="^"!($D(DIROUT)) K XQORM S GMRCEND=1 Q
K XQORM(0),XQORM("A"),XQORM("B"),XQORM("NO^^") S XQORM=""
I '$D(Y) S GMRCEND=1 Q
I $D(Y(1)) S GMRCURG=$P(Y(1),"^",3),GMRCURGI=$P(Y(1),"^",2)
Q
DEFAULT ;Set up defaults for editing to be equal to the existing data.
D DEM^GMRCU
N GMRC,GMRCDIC,GMRCPLI,GMRCPRI
Q:'$D(GMRCO) S (GMRCSS,GMRCSSNM,GMRCPL,GMRCPR,GMRCPRI,GMRCURG)=""
S GMRCOM=0,GMRC(0)=$S($D(^GMR(123,+GMRCO,0)):^(0),1:"")
S GMRCSS=$P(GMRC(0),"^",5) I +GMRCSS,$D(^GMR(123.5,+GMRCSS,0)) S GMRCSSNM=$S($L($P($G(^GMR(123.5,+GMRCSS,0)),U,1)):$P(^(0),U,1),1:"")
S GMRCPLI=$P(GMRC(0),"^",10) I GMRCPLI S GMRCPL=$P($G(^ORD(101,GMRCPLI,0)),"^",2)
S GMRCURGI=$P(GMRC(0),"^",9) I GMRCURGI S GMRCURG=$P($G(^ORD(101,GMRCURGI,0)),"^",2)
S GMRCPRI=$P(GMRC(0),"^",8) I GMRCPRI["ORD(101" D
. S GMRCPR=$$GET1^DIQ(101,+GMRCPRI,1)
I $L(GMRCPRI),GMRCPRI'["ORD(101" D ;ZPROC
. S GMRCPR=$$GET1^DIQ(123.3,+GMRCPRI,.01)
TYPE ;This entry point is used when the only default needed is the GMRCTYPE
;Called by GMRCGUIA to get variables ready for FRMSG call.
S GMRCTYPE=$$GET1^DIQ(123,+GMRCO,13,"I") ;ZPROC (P or C)
Q
END ;Kill off variables and exit
I $G(GMRCLCK) D UNLOCK^GMRCA1(GMRCO)
K GETPROV,GMRCDG,GMRCDEV,GMRCEND,GMRCFF,GMRCOM,GMRCIFN,GMRCO,GMRCORNP
K GMRCTYPE,GMRCORTX,GMRCPL,GMRCPR,GMRCSEL,GMRCURG,GMRCADUZ,Y
K DTOUT,DIROUT,DUOUT,GMRCURGI
S:$D(^TMP("GMRC",$J,"CURRENT","MENU")) XQORM("HIJACK")=^("MENU")
Q
GMRCAFRD ;SLC/DLT,DCM,JFR - LM FORWARD ACTION ;7/11/03 14:02
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,22,35,39**;DEC 27, 1997
+2 ;
+3 ; This routine invokes IA #2395
+4 ;
FR(GMRCO) ;Forward Request to a new service
+1 NEW ORVP,GMRCLCK,DFN,GMRCACT
+2 WRITE !!,"Forward Request To Another Service For Action."
+3 WRITE !,"Select the service to send the consult to.",!
+4 IF $DATA(GMRCSS)
SET GMRCSSS=GMRCSS
+5 NEW GMRCPL,GMRCPR,GMRCURG,GMRCDG,GMRCFF,GMRCORNP,GMRCAD,GMRCTO,GMRCADUZ
+6 KILL GMRCQUT,GMRCSEL,GMRCSSS
+7 IF '$LENGTH($GET(GMRCO))
DO SELECT^GMRCA2(.GMRCO)
IF $DATA(GMRCQUT)
DO END
QUIT
+8 IF '+$GET(GMRCO)
DO END
SET GMRCQUT=1
QUIT
+9 IF $PIECE($GET(^GMR(123,GMRCO,12)),U,5)="P"
Begin DoDot:1
+10 NEW DIR
+11 WRITE !,"The requesting facility may not take this action on an "
+12 WRITE "inter-facility consult."
+13 SET DIR(0)="E"
DO ^DIR
+14 DO END
+15 SET GMRCQUT=1
End DoDot:1
QUIT
+16 IF '$$LOCK^GMRCA1(GMRCO)
DO END
SET GMRCQUT=1
QUIT
+17 SET GMRCLCK=1
+18 ;
+19 IF $PIECE(^GMR(123,GMRCO,0),"^",12)<3
SET GMRCMSG="NO ACTION POSSIBLE. This Consult Has Already Been Completed Or Discontinued."
DO EXAC^GMRCADC(GMRCMSG)
DO END
SET GMRCQUT=1
QUIT
+20 IF $PIECE(^GMR(123,GMRCO,0),"^",12)=13
SET GMRCMSG="NO ACTION POSSIBLE. This Consult Has Already Been Cancelled."
DO EXAC^GMRCADC(GMRCMSG)
DO END
SET GMRCQUT=1
QUIT
+21 IF $PIECE(^GMR(123,GMRCO,0),"^",12)=9
Begin DoDot:1
+22 SET GMRCMSG="Invalid action. This consult has partial results."
+23 SET GMRCMSG(1)="Remove the associated results before forwarding."
+24 DO EXAC^GMRCADC(.GMRCMSG)
DO END
SET GMRCQUT=1
QUIT
End DoDot:1
IF +$GET(GMRCQUT)
QUIT
+25 ;
+26 IF $DATA(IOBM)
IF $DATA(IOTM)
IF $DATA(IOSTBM)
DO FULL^VALM1
+27 IF $PIECE(^GMR(123,GMRCO,0),"^",16)
WRITE !!,"This is a SERVICE ENTERED order stub. Please send the written consult to the",!,"Service, in addition to the automated forwarding!"
+28 SET DFN=+$PIECE(^GMR(123,GMRCO,0),"^",2)
+29 SET GMRCTO=1
SET GMRCASV="Forward Consult To Which Service/Specialty: "
+30 DO ASRV^GMRCASV
KILL GMRCASV
IF $SELECT($DATA(DTOUT):1,$DATA(DIROUT):1,$DATA(GMRCQUT):1,1:0)
DO END
QUIT
+31 IF 'GMRCDG
SET GMRCMSG="No Service Was Selected. Consult Was Not Forwarded To Any Service!"
DO EXAC^GMRCADC(GMRCMSG)
DO END
SET GMRCQUT=1
QUIT
+32 SET GMRCFF=$PIECE(^GMR(123,GMRCO,0),"^",5)
IF GMRCFF=+GMRCDG
SET GMRCMSG="The Forwarding Service Cannot Forward A Consult To Itself!"
DO EXAC^GMRCADC(GMRCMSG)
DO END
SET GMRCQUT=1
QUIT
+33 SET GETPROV="Who is responsible for Forwarding the Consult?"
FRGTPRV DO GETPROV^GMRCAU
IF '$DATA(GMRCORNP)
DO END
SET GMRCQUT=1
QUIT
+1 SET GMRCACT=$$PROVIDER^XUSER(GMRCORNP)
IF $PIECE(GMRCACT,U)'=1
Begin DoDot:1
+2 WRITE !!,"***User account is TERMINATED please choose another responsible user.***"
End DoDot:1
GOTO FRGTPRV
+3 SET GMRCAD=$$GETDT^GMRCUTL1
IF GMRCAD="^"
DO END
SET GMRCQUT=1
QUIT
+4 IF '$GET(GMRCAD)
SET GMRCAD=$$NOW^XLFDT
+5 NEW GMRCSS,GMRCSSNM,GMRCA,GMRCMSG,GMRCIROL,GMRCINM,GMRCIROU,ORSTS
+6 DO DEFAULT
+7 SET GMRCSS=+GMRCDG
+8 IF +GMRCSS
IF '$DATA(^GMR(123.5,+GMRCSS,0))
SET GMRCMSG="Error in Service Chosen - SERVICE Does Not Exist!"
DO EXAC^GMRCADC(GMRCMSG)
DO END
SET GMRCQUT=1
QUIT
+9 SET GMRCSSNM=$SELECT($LENGTH($GET(^GMR(123.5,+GMRCSS,.1))):^(.1),1:$PIECE($GET(^GMR(123.5,+GMRCSS,0)),U,1))
+10 DO URG
IF $DATA(GMRCEND)
IF GMRCEND
DO END
SET GMRCQUT=1
QUIT
+11 SET GMRCA=17
SET DR=""
+12 ; if fwd to IFC serv, get extra flds
IF $DATA(^GMR(123.5,+GMRCSS,"IFC"))
Begin DoDot:1
+13 ;no rout fac
SET GMRCIROU=$PIECE(^GMR(123.5,+GMRCSS,"IFC"),U)
IF GMRCIROU=""
QUIT
+14 ;no serv nm
SET GMRCINM=$PIECE(^GMR(123.5,+GMRCSS,"IFC"),U,2)
IF GMRCINM=""
QUIT
+15 SET GMRCA=25
SET GMRCIROL="P"
+16 SET DR=".07////^S X=GMRCIROU;.125////^S X=GMRCIROL;.131///^S X=GMRCINM;"
End DoDot:1
+17 SET DIE="^GMR(123,"
SET DA=GMRCO
SET ORSTS=5
+18 SET DR=DR_"1////^S X=GMRCSS;5////^S X=GMRCURGI;8////^S X=ORSTS;9////^S X=GMRCA;.1///@"
+19 LOCK +^GMR(123,GMRCO):2
IF '$TEST
KILL DIE,DA,DR
SET GMRCMSG="Another User Is Accessing This Record. UPDATE WAS UNSUCCESSFUL."
SET GMRCMSG(1)="Try Again Later."
DO EXAC^GMRCADC(.GMRCMSG)
DO END
SET GMRCQUT=1
QUIT
+20 DO ^DIE
LOCK -^GMR(123,GMRCO)
KILL DIE,DA,DR
+21 ;GMRCORNP is the responsible provider here
SET GMRCOM=1
DO AUDIT^GMRCP
+22 ;
+23 ;unlk before FWD changes order #
IF $GET(GMRCLCK)
DO UNLOCK^GMRCA1(GMRCO)
+24 ;
FRMSG ; Common logic used by GUI and List Manager to process the HL7 message
+1 ; to update the order in OE/RR and then forward an alert to recipients
+2 ; is passed in as the DUZ instead of the responsible provider
+3 DO EN^GMRCHL7(DFN,GMRCO,$GET(GMRCTYPE),$GET(GMRCRB),"XX^FORWARD",$GET(DUZ),$GET(VISIT),.GMRCOM,,$GET(GMRCAD))
+4 SET GMRCADUZ=""
+5 ;This is the original provider that ordered the consult
SET GMRCORNP=$PIECE(^GMR(123,GMRCO,0),"^",14)
+6 ;alert original provider of forward
IF +$GET(GMRCORNP)
SET GMRCADUZ(+GMRCORNP)=""
+7 SET GMRCORTX="Forwarded consult "_$$ORTX^GMRCAU(+GMRCO)_" ("_GMRCURG_")"
+8 ;GMRCO=IEN of consult from file 123; 27 is notification entry from file ORD(100.9
DO MSG^GMRCP(DFN,GMRCORTX,+GMRCO,27,.GMRCADUZ,1)
+9 KILL GMRCOM
+10 SET GMRCDEV=$PIECE($GET(^GMR(123.5,GMRCSS,123)),"^",9)
+11 IF GMRCDEV
DO PRNT^GMRCUTL1(GMRCSS,+GMRCO)
+12 DO END
+13 QUIT
URG ;Get the default urgency
+1 NEW X,Y,XQORM,DIROUT,DTOUT,DIRUT,DUOUT
+2 IF $PIECE(^GMR(123,+GMRCO,0),"^",18)["I"
Begin DoDot:1
+3 IF GMRCTYPE="GMRCOR CONSULT"
SET X="GMRCURGENCYM CSLT - INPATIENT"
+4 SET X="GMRCURGENCYM REQ - INPATIENT"
End DoDot:1
+5 IF '$TEST
SET X="GMRCURGENCYM - OUTPATIENT"
+6 IF '$DATA(GMRCURG)
SET GMRCURGI=$ORDER(^ORD(101,"B","GMRCURGENCY - ROUTINE",""))
IF +GMRCURGI
SET GMRCURG=$PIECE($GET(^ORD(101,+GMRCURGI,0)),"^",2)
+7 SET Y=$ORDER(^ORD(101,"B",X,""))
+8 SET XQORM=+Y_";ORD(101,"
SET XQORM(0)="1A\"
SET XQORM("A")="Urgency: "
SET XQORM("NO^^")=""
+9 IF $LENGTH(GMRCURG)
SET XQORM("B")=GMRCURG
DO EN^XQORM
IF X="^"!($DATA(DIROUT))
KILL XQORM
SET GMRCEND=1
QUIT
+10 KILL XQORM(0),XQORM("A"),XQORM("B"),XQORM("NO^^")
SET XQORM=""
+11 IF '$DATA(Y)
SET GMRCEND=1
QUIT
+12 IF $DATA(Y(1))
SET GMRCURG=$PIECE(Y(1),"^",3)
SET GMRCURGI=$PIECE(Y(1),"^",2)
+13 QUIT
DEFAULT ;Set up defaults for editing to be equal to the existing data.
+1 DO DEM^GMRCU
+2 NEW GMRC,GMRCDIC,GMRCPLI,GMRCPRI
+3 IF '$DATA(GMRCO)
QUIT
SET (GMRCSS,GMRCSSNM,GMRCPL,GMRCPR,GMRCPRI,GMRCURG)=""
+4 SET GMRCOM=0
SET GMRC(0)=$SELECT($DATA(^GMR(123,+GMRCO,0)):^(0),1:"")
+5 SET GMRCSS=$PIECE(GMRC(0),"^",5)
IF +GMRCSS
IF $DATA(^GMR(123.5,+GMRCSS,0))
SET GMRCSSNM=$SELECT($LENGTH($PIECE($GET(^GMR(123.5,+GMRCSS,0)),U,1)):$PIECE(^(0),U,1),1:"")
+6 SET GMRCPLI=$PIECE(GMRC(0),"^",10)
IF GMRCPLI
SET GMRCPL=$PIECE($GET(^ORD(101,GMRCPLI,0)),"^",2)
+7 SET GMRCURGI=$PIECE(GMRC(0),"^",9)
IF GMRCURGI
SET GMRCURG=$PIECE($GET(^ORD(101,GMRCURGI,0)),"^",2)
+8 SET GMRCPRI=$PIECE(GMRC(0),"^",8)
IF GMRCPRI["ORD(101"
Begin DoDot:1
+9 SET GMRCPR=$$GET1^DIQ(101,+GMRCPRI,1)
End DoDot:1
+10 ;ZPROC
IF $LENGTH(GMRCPRI)
IF GMRCPRI'["ORD(101"
Begin DoDot:1
+11 SET GMRCPR=$$GET1^DIQ(123.3,+GMRCPRI,.01)
End DoDot:1
TYPE ;This entry point is used when the only default needed is the GMRCTYPE
+1 ;Called by GMRCGUIA to get variables ready for FRMSG call.
+2 ;ZPROC (P or C)
SET GMRCTYPE=$$GET1^DIQ(123,+GMRCO,13,"I")
+3 QUIT
END ;Kill off variables and exit
+1 IF $GET(GMRCLCK)
DO UNLOCK^GMRCA1(GMRCO)
+2 KILL GETPROV,GMRCDG,GMRCDEV,GMRCEND,GMRCFF,GMRCOM,GMRCIFN,GMRCO,GMRCORNP
+3 KILL GMRCTYPE,GMRCORTX,GMRCPL,GMRCPR,GMRCSEL,GMRCURG,GMRCADUZ,Y
+4 KILL DTOUT,DIROUT,DUOUT,GMRCURGI
+5 IF $DATA(^TMP("GMRC",$JOB,"CURRENT","MENU"))
SET XQORM("HIJACK")=^("MENU")
+6 QUIT
