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