source: WorldVistAEHR/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCAFRD.m@ 1093

Last change on this file since 1093 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.3 KB
Line 
1GMRCAFRD ;SLC/DLT,DCM,JFR - LM FORWARD ACTION ;7/11/03 14:02
2 ;;3.0;CONSULT/REQUEST TRACKING;**1,4,10,12,15,22,35,39**;DEC 27, 1997
3 ;
4 ; This routine invokes IA #2395
5 ;
6FR(GMRCO) ;Forward Request to a new service
7 N ORVP,GMRCLCK,DFN,GMRCACT
8 W !!,"Forward Request To Another Service For Action."
9 W !,"Select the service to send the consult to.",!
10 S:$D(GMRCSS) GMRCSSS=GMRCSS
11 N GMRCPL,GMRCPR,GMRCURG,GMRCDG,GMRCFF,GMRCORNP,GMRCAD,GMRCTO,GMRCADUZ
12 K GMRCQUT,GMRCSEL,GMRCSSS
13 I '$L($G(GMRCO)) D SELECT^GMRCA2(.GMRCO) I $D(GMRCQUT) D END Q
14 I '+$G(GMRCO) D END S GMRCQUT=1 Q
15 I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D Q
16 . N DIR
17 . W !,"The requesting facility may not take this action on an "
18 . W "inter-facility consult."
19 . S DIR(0)="E" D ^DIR
20 . D END
21 . S GMRCQUT=1
22 I '$$LOCK^GMRCA1(GMRCO) D END S GMRCQUT=1 Q
23 S GMRCLCK=1
24 ;
25 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
26 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
27 I $P(^GMR(123,GMRCO,0),"^",12)=9 D Q:+$G(GMRCQUT)
28 .S GMRCMSG="Invalid action. This consult has partial results."
29 .S GMRCMSG(1)="Remove the associated results before forwarding."
30 .D EXAC^GMRCADC(.GMRCMSG),END S GMRCQUT=1 Q
31 ;
32 I $D(IOBM),$D(IOTM),$D(IOSTBM) D FULL^VALM1
33 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!"
34 S DFN=+$P(^GMR(123,GMRCO,0),"^",2)
35 S GMRCTO=1,GMRCASV="Forward Consult To Which Service/Specialty: "
36 D ASRV^GMRCASV K GMRCASV I $S($D(DTOUT):1,$D(DIROUT):1,$D(GMRCQUT):1,1:0) D END Q
37 I 'GMRCDG S GMRCMSG="No Service Was Selected. Consult Was Not Forwarded To Any Service!" D EXAC^GMRCADC(GMRCMSG),END S GMRCQUT=1 Q
38 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
39 S GETPROV="Who is responsible for Forwarding the Consult?"
40FRGTPRV D GETPROV^GMRCAU I '$D(GMRCORNP) D END S GMRCQUT=1 Q
41 S GMRCACT=$$PROVIDER^XUSER(GMRCORNP) I $P(GMRCACT,U)'=1 D G FRGTPRV
42 .W !!,"***User account is TERMINATED please choose another responsible user.***"
43 S GMRCAD=$$GETDT^GMRCUTL1 I GMRCAD="^" D END S GMRCQUT=1 Q
44 I '$G(GMRCAD) S GMRCAD=$$NOW^XLFDT
45 N GMRCSS,GMRCSSNM,GMRCA,GMRCMSG,GMRCIROL,GMRCINM,GMRCIROU,ORSTS
46 D DEFAULT
47 S GMRCSS=+GMRCDG
48 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
49 S GMRCSSNM=$S($L($G(^GMR(123.5,+GMRCSS,.1))):^(.1),1:$P($G(^GMR(123.5,+GMRCSS,0)),U,1))
50 D URG I $D(GMRCEND),GMRCEND D END S GMRCQUT=1 Q
51 S GMRCA=17,DR=""
52 I $D(^GMR(123.5,+GMRCSS,"IFC")) D ; if fwd to IFC serv, get extra flds
53 . S GMRCIROU=$P(^GMR(123.5,+GMRCSS,"IFC"),U) Q:GMRCIROU="" ;no rout fac
54 . S GMRCINM=$P(^GMR(123.5,+GMRCSS,"IFC"),U,2) Q:GMRCINM="" ;no serv nm
55 . S GMRCA=25,GMRCIROL="P"
56 . S DR=".07////^S X=GMRCIROU;.125////^S X=GMRCIROL;.131///^S X=GMRCINM;"
57 S DIE="^GMR(123,",DA=GMRCO,ORSTS=5
58 S DR=DR_"1////^S X=GMRCSS;5////^S X=GMRCURGI;8////^S X=ORSTS;9////^S X=GMRCA;.1///@"
59 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
60 D ^DIE L -^GMR(123,GMRCO) K DIE,DA,DR
61 S GMRCOM=1 D AUDIT^GMRCP ;GMRCORNP is the responsible provider here
62 ;
63 I $G(GMRCLCK) D UNLOCK^GMRCA1(GMRCO) ;unlk before FWD changes order #
64 ;
65FRMSG ; Common logic used by GUI and List Manager to process the HL7 message
66 ; to update the order in OE/RR and then forward an alert to recipients
67 ; is passed in as the DUZ instead of the responsible provider
68 D EN^GMRCHL7(DFN,GMRCO,$G(GMRCTYPE),$G(GMRCRB),"XX^FORWARD",$G(DUZ),$G(VISIT),.GMRCOM,,$G(GMRCAD))
69 S GMRCADUZ=""
70 S GMRCORNP=$P(^GMR(123,GMRCO,0),"^",14) ;This is the original provider that ordered the consult
71 I +$G(GMRCORNP) S GMRCADUZ(+GMRCORNP)="" ;alert original provider of forward
72 S GMRCORTX="Forwarded consult "_$$ORTX^GMRCAU(+GMRCO)_" ("_GMRCURG_")"
73 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
74 K GMRCOM
75 S GMRCDEV=$P($G(^GMR(123.5,GMRCSS,123)),"^",9)
76 I GMRCDEV D PRNT^GMRCUTL1(GMRCSS,+GMRCO)
77 D END
78 Q
79URG ;Get the default urgency
80 N X,Y,XQORM,DIROUT,DTOUT,DIRUT,DUOUT
81 I $P(^GMR(123,+GMRCO,0),"^",18)["I" D
82 .I GMRCTYPE="GMRCOR CONSULT" S X="GMRCURGENCYM CSLT - INPATIENT"
83 .S X="GMRCURGENCYM REQ - INPATIENT"
84 E S X="GMRCURGENCYM - OUTPATIENT"
85 I '$D(GMRCURG) S GMRCURGI=$O(^ORD(101,"B","GMRCURGENCY - ROUTINE","")) S:+GMRCURGI GMRCURG=$P($G(^ORD(101,+GMRCURGI,0)),"^",2)
86 S Y=$O(^ORD(101,"B",X,""))
87 S XQORM=+Y_";ORD(101,",XQORM(0)="1A\",XQORM("A")="Urgency: ",XQORM("NO^^")=""
88 S:$L(GMRCURG) XQORM("B")=GMRCURG D EN^XQORM I X="^"!($D(DIROUT)) K XQORM S GMRCEND=1 Q
89 K XQORM(0),XQORM("A"),XQORM("B"),XQORM("NO^^") S XQORM=""
90 I '$D(Y) S GMRCEND=1 Q
91 I $D(Y(1)) S GMRCURG=$P(Y(1),"^",3),GMRCURGI=$P(Y(1),"^",2)
92 Q
93DEFAULT ;Set up defaults for editing to be equal to the existing data.
94 D DEM^GMRCU
95 N GMRC,GMRCDIC,GMRCPLI,GMRCPRI
96 Q:'$D(GMRCO) S (GMRCSS,GMRCSSNM,GMRCPL,GMRCPR,GMRCPRI,GMRCURG)=""
97 S GMRCOM=0,GMRC(0)=$S($D(^GMR(123,+GMRCO,0)):^(0),1:"")
98 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:"")
99 S GMRCPLI=$P(GMRC(0),"^",10) I GMRCPLI S GMRCPL=$P($G(^ORD(101,GMRCPLI,0)),"^",2)
100 S GMRCURGI=$P(GMRC(0),"^",9) I GMRCURGI S GMRCURG=$P($G(^ORD(101,GMRCURGI,0)),"^",2)
101 S GMRCPRI=$P(GMRC(0),"^",8) I GMRCPRI["ORD(101" D
102 . S GMRCPR=$$GET1^DIQ(101,+GMRCPRI,1)
103 I $L(GMRCPRI),GMRCPRI'["ORD(101" D ;ZPROC
104 . S GMRCPR=$$GET1^DIQ(123.3,+GMRCPRI,.01)
105TYPE ;This entry point is used when the only default needed is the GMRCTYPE
106 ;Called by GMRCGUIA to get variables ready for FRMSG call.
107 S GMRCTYPE=$$GET1^DIQ(123,+GMRCO,13,"I") ;ZPROC (P or C)
108 Q
109END ;Kill off variables and exit
110 I $G(GMRCLCK) D UNLOCK^GMRCA1(GMRCO)
111 K GETPROV,GMRCDG,GMRCDEV,GMRCEND,GMRCFF,GMRCOM,GMRCIFN,GMRCO,GMRCORNP
112 K GMRCTYPE,GMRCORTX,GMRCPL,GMRCPR,GMRCSEL,GMRCURG,GMRCADUZ,Y
113 K DTOUT,DIROUT,DUOUT,GMRCURGI
114 S:$D(^TMP("GMRC",$J,"CURRENT","MENU")) XQORM("HIJACK")=^("MENU")
115 Q
Note: See TracBrowser for help on using the repository browser.