- 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,64,46**;DEC 27, 1997;Build 23
- ;
- ; This routine invokes IA #2395
- ;
- FR(GMRCO) ;Forward Request to a new service
- N ORVP,GMRCLCK,DFN,GMRCACT,GMRCSEQ,GMRCDOC
- 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,GMRCATTN,NEWATTN,GMRCPA
- 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
- S GMRCSEQ=0,GMRCDOC="" F S GMRCSEQ=$O(^GMR(123,+GMRCO,50,GMRCSEQ)) Q:GMRCSEQ="" D Q:+$G(GMRCQUT)
- . 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 GMRCMSG="Invalid Action. This consult has an unsigned note."
- . . D EXAC^GMRCADC(.GMRCMSG),END S GMRCQUT=1 Q
- . I $P($G(^TIU(8925,GMRCDOC,0)),U,5)=6 D
- . . S GMRCMSG="Invalid Action. This consult has an uncosigned note."
- . . D EXAC^GMRCADC(.GMRCMSG),END S GMRCQUT=1 Q
- Q:+$G(GMRCQUT) S GMRCSEQ=0,GMRCDOC="" F S GMRCSEQ=$O(^GMR(123,+GMRCO,40,GMRCSEQ)) Q:GMRCSEQ="" D Q:+$G(GMRCQUT)
- . 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
- . I $P($G(^TIU(8925,GMRCDOC,0)),U,5)=5 D
- . . S GMRCMSG="Invalid Action. This consult has an unsigned note."
- . . D EXAC^GMRCADC(.GMRCMSG),END S GMRCQUT=1 Q
- . I $P($G(^TIU(8925,GMRCDOC,0)),U,5)=6 D
- . . S GMRCMSG="Invalid Action. This consult has an uncosigned note."
- . . D EXAC^GMRCADC(.GMRCMSG),END S GMRCQUT=1 Q
- Q:+$G(GMRCQUT)
- ;
- 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 GMRCATTN=$P($G(^GMR(123,GMRCO,0)),"^",11)
- N DIE,DR
- S DIE="^GMR(123,",DA=GMRCO,DR="7//"_$S($G(GMRCATTN)'="":GMRCATTN,1:"")
- D ^DIE
- S NEWATTN=$P($G(^GMR(123,+GMRCO,0)),"^",11)
- I NEWATTN'=GMRCATTN S GMRCPA=$G(GMRCATTN)
- 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),+$G(GMRCORNP)'=DUZ 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCAFRD 8003 printed Jan 18, 2025@02:46:16 Page 2
- 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,64,46**;DEC 27, 1997;Build 23
- +2 ;
- +3 ; This routine invokes IA #2395
- +4 ;
- FR(GMRCO) ;Forward Request to a new service
- +1 NEW ORVP,GMRCLCK,DFN,GMRCACT,GMRCSEQ,GMRCDOC
- +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,GMRCATTN,NEWATTN,GMRCPA
- +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 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 GMRCMSG="Invalid Action. This consult has an unsigned note."
- +30 DO EXAC^GMRCADC(.GMRCMSG)
- DO END
- SET GMRCQUT=1
- QUIT
- End DoDot:2
- +31 IF $PIECE($GET(^TIU(8925,GMRCDOC,0)),U,5)=6
- Begin DoDot:2
- +32 SET GMRCMSG="Invalid Action. This consult has an uncosigned note."
- +33 DO EXAC^GMRCADC(.GMRCMSG)
- DO END
- SET GMRCQUT=1
- QUIT
- End DoDot:2
- End DoDot:1
- if +$GET(GMRCQUT)
- QUIT
- +34 if +$GET(GMRCQUT)
- QUIT
- SET GMRCSEQ=0
- SET GMRCDOC=""
- FOR
- SET GMRCSEQ=$ORDER(^GMR(123,+GMRCO,40,GMRCSEQ))
- if GMRCSEQ=""
- QUIT
- Begin DoDot:1
- +35 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)
- +36 IF $GET(GMRCDOC)=""
- QUIT
- +37 IF $PIECE($GET(^TIU(8925,GMRCDOC,0)),U,5)=5
- Begin DoDot:2
- +38 SET GMRCMSG="Invalid Action. This consult has an unsigned note."
- +39 DO EXAC^GMRCADC(.GMRCMSG)
- DO END
- SET GMRCQUT=1
- QUIT
- End DoDot:2
- +40 IF $PIECE($GET(^TIU(8925,GMRCDOC,0)),U,5)=6
- Begin DoDot:2
- +41 SET GMRCMSG="Invalid Action. This consult has an uncosigned note."
- +42 DO EXAC^GMRCADC(.GMRCMSG)
- DO END
- SET GMRCQUT=1
- QUIT
- End DoDot:2
- End DoDot:1
- if +$GET(GMRCQUT)
- QUIT
- +43 if +$GET(GMRCQUT)
- QUIT
- +44 ;
- +45 IF $DATA(IOBM)
- IF $DATA(IOTM)
- IF $DATA(IOSTBM)
- DO FULL^VALM1
- +46 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!"
- +47 SET DFN=+$PIECE(^GMR(123,GMRCO,0),"^",2)
- +48 SET GMRCTO=1
- SET GMRCASV="Forward Consult To Which Service/Specialty: "
- +49 DO ASRV^GMRCASV
- KILL GMRCASV
- IF $SELECT($DATA(DTOUT):1,$DATA(DIROUT):1,$DATA(GMRCQUT):1,1:0)
- DO END
- QUIT
- +50 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
- +51 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
- +52 SET GMRCATTN=$PIECE($GET(^GMR(123,GMRCO,0)),"^",11)
- +53 NEW DIE,DR
- +54 SET DIE="^GMR(123,"
- SET DA=GMRCO
- SET DR="7//"_$SELECT($GET(GMRCATTN)'="":GMRCATTN,1:"")
- +55 DO ^DIE
- +56 SET NEWATTN=$PIECE($GET(^GMR(123,+GMRCO,0)),"^",11)
- +57 IF NEWATTN'=GMRCATTN
- SET GMRCPA=$GET(GMRCATTN)
- +58 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)
- IF +$GET(GMRCORNP)'=DUZ
- 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