GMRCR ;SLC/DLT - Driver for reviewing patient consult/requests - Used by Medicine Package to link Consults to Medicine results ;9/18/98 16:26
;;3.0;CONSULT/REQUEST TRACKING;**1,5,46**;DEC 27, 1997;Build 23
EN ;Entry point for medicine results entry by procedure or consult type
;Required variables:
; GMRCPRNM = name of procedure file with results.
; DFN = patient file (2) ien
;Optional variables:
; GMRCSR = variable pointer for results
; ORSTS = order status
; GMRCI = 0 or undefined, assume interactive
; 1, assume non-interactive - not operational currently
;Returned variables:
; ORIFN = Pointer to the consult order in file 100
; GMRCO = Pointer to the Request/Consultation entry in file 123.5
;
K DTOUT,DUOUT,ORIFN,GMRCO,GMRCX
I '$D(GMRCPNM) D DEM^GMRCU
I $D(GMRCPRNM) S GMRC=$O(^ORD(101,"B","GMRCR "_GMRCPRNM,0)),GMRCTYPE="GMRCOR REQUEST"
E I $D(GMRCPR) S GMRC=GMRCPR,GMRCTYPE="GMRCOR REQUEST"
I $D(GMRCCT) S GMRC=GMRCCT,GMRCTYPE="GMRCOR CONSULT"
I $D(GMRC)=1!($D(GMRC)=11),+GMRC D
.S GMRCVP=GMRC_";ORD(101,",GMRCNM=$S($D(^ORD(101,GMRC,0)):$P(^(0),"^",2),1:"")
.S GMRCSS=$P($G(^ORD(101,+GMRCVP,5)),"^"),GMRCSS=+GMRCSS
EN1 ;Entry point for
Q I 'GMRCSS D ASRV^GMRCASV D Q:GMRCEND S GMRCSS=+GMRCDG I 'GMRCDG S GMRCEND=1 K GMRCSS Q
.I $D(DTOUT)!($D(DIROUT)) S GMRCEND=1 K DTOUT,DIROUT,DIRUT,DUOUT Q
.Q
E S GMRCDG=GMRCSS D SERV1^GMRCASV
I '$D(ORTKG) S ORTKG=$$PACKAGE I ORTKG="" S GMRCMSG="Missing package entry for CONSULT/REQUEST TRACKING" D EXAC^GMRCADC(GMRCMSG) K GMRCMSG S GMRCEND=1 Q
;old code? D TEAM^GMRCASV
S GMRCSSNM=$P(^GMR(123.5,GMRCSS,0),"^",1)
;old codeN GMRCQIT
;old code? S ORVP=DFN_";DPT(",GMRCGRP=0
;old code? K ^TMP("GMRCR",$J)
K GMRCOER,GMRCQUT
S GMRCEN=1
D EN^GMRCMENU ; used to be D EN^GMRCACTM
S GMRCOER=0
D AD^GMRCSLM1 ; used to be D AD^GMRCRA
D EN^VALM("GMRC CONSULT TRACKING")
D KILL
Q
KILL ; Kill variables, but don't kill GMRCO and ORIFN if from MC option
;K VALMCNT,VALMBCK,VALMPGE
;K ^TMP("GMRCR",$J,"CS"),^TMP("GMRCS",$J)
K X,Y,Z,DTOUT,DUOUT,DIROUT
K GMRC,GMRCA,GMRCACT,GMRCACTM,GMRCAGE,GMRCCT,GMRCCTX,GMRCDG,GMRCDGT
K GMRCDOB,GMRCDTM,GMRCGRP,GMRCH,GMRCHDR,GMRCIFN,GMRCLFG,GMRCNM,GMRCNPG
K GMRCPNM,GMRCRB,GMRCWARD,GMRCSN,GMRCRPG,GMRCNPG,GMRCTITL,GMRCX,GMRCHDR,GMRCH,GMRCDTM
K GMRCSTS,GMRCTYPE,GMRCVP,GMRCEND,GMRCTO,GMRCURG,GMRCL,GMRCDT,GMRCDIC
K VA,VAIN,VAINDT,VADM,VAEL,VAPA,VAERR,VAROOT
K O,OREND,ORINDX,ORNS,POP,SEX,W,XQORSPEW
I $D(XQY0),$E(XQY0,1,2)="MC" S:'$D(GMRCO) (ORIFN,GMRCO)="" Q
K ORIFN,GMRCO,GMRCSR
Q
RESULT ;Entry point to set up variable pointer to results and update OE/RR status
Q
Q:'$D(GMRCSR) Q:'$D(GMRCO) S (GMRCSS,GMRCSSNM,GMRCNM,GMRC,GMRCVP)=""
S GMRCOM=0,GMR(0)=$S($D(^GMR(123,+GMRCO,0)):^(0),1:""),GMRCSS=$P(GMR(0),"^",5) I GMRCSS,$D(^GMR(123.5,GMRCSS,0)) S GMRCSSNM=$S($L($P(^GMR(123.5,GMRCSS,0),"^",9)):$P(^(0),"^",9),1:$P(^(0),"^"))
S GMRCVP=$P(GMR(0),"^",8) I +GMRCVP S DIC="^"_$P(GMRCVP,";",2)_$P(GMRCVP,";")_",0)" I $L(DIC),$D(@DIC) S GMRCNM=@(DIC),GMRCNM=$P(GMRCNM,"^",2)
I '$D(ORSTS) S ORSTS=6 ;Assume order entry status of active
S GMRCA=$O(^GMR(123.1,"AC",+ORSTS,"")) I 'GMRCA S GMRCA=9
S DIE=123,DA=GMRCO,DR="11////^S X=GMRCSR;8////^S X=ORSTS;9////^S X=GMRCA"
L +^GMR(123,GMRCO):$S($G(DILOCKTM)>0:DILOCKTM,1:5) I '$T S GMRCMSG="Consult/Request Is Being Used By Another User.",GMRCMSG(1)="RESULT UPDATE WAS UNSUCCESSFUL! Try Again Later" D EXAC^GMRCADC(.GMRCMSG) K GMRCO,ORIFN,GMRCMSG D KILL Q
D ^DIE K DIE,DA,DR
L -^GMR(123,GMRCO) D AUDIT^GMRCP
S:'$D(ORIFN) ORIFN=$P(^GMR(123,+GMRCO,0),"^",3)
S GMRCORNP=$P(GMR(0),"^",14),GMRCTYPE=$P(GMR(0),"^",17)
I $L($P(GMR(0),"^",14)),$P(GMR(0),"^",14)'=DUZ S GMRCADUZ($P(GMR(0),"^",14))=""
I ORIFN D EN^GMRCHL7(DFN,GMRCO,$G(GMRCTYPE),$G(GMRCRB),"RE",GMRCORNP,$G(GMRCVSIT),.GMRCOM)
K GMR,GMRCSS,GMRCORVP,GMRCVP,GMRCNM,DIC,GMRCPR
Q
;
PACKAGE() ; Returns the package entry number for 'CONSULT/REQUEST TRACKING"
Q $$FIND1^DIC(9.4,,"QX","CONSULT/REQUEST TRACKING")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCR 4043 printed Sep 23, 2025@19:23:04 Page 2
GMRCR ;SLC/DLT - Driver for reviewing patient consult/requests - Used by Medicine Package to link Consults to Medicine results ;9/18/98 16:26
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,46**;DEC 27, 1997;Build 23
EN ;Entry point for medicine results entry by procedure or consult type
+1 ;Required variables:
+2 ; GMRCPRNM = name of procedure file with results.
+3 ; DFN = patient file (2) ien
+4 ;Optional variables:
+5 ; GMRCSR = variable pointer for results
+6 ; ORSTS = order status
+7 ; GMRCI = 0 or undefined, assume interactive
+8 ; 1, assume non-interactive - not operational currently
+9 ;Returned variables:
+10 ; ORIFN = Pointer to the consult order in file 100
+11 ; GMRCO = Pointer to the Request/Consultation entry in file 123.5
+12 ;
+13 KILL DTOUT,DUOUT,ORIFN,GMRCO,GMRCX
+14 IF '$DATA(GMRCPNM)
DO DEM^GMRCU
+15 IF $DATA(GMRCPRNM)
SET GMRC=$ORDER(^ORD(101,"B","GMRCR "_GMRCPRNM,0))
SET GMRCTYPE="GMRCOR REQUEST"
+16 IF '$TEST
IF $DATA(GMRCPR)
SET GMRC=GMRCPR
SET GMRCTYPE="GMRCOR REQUEST"
+17 IF $DATA(GMRCCT)
SET GMRC=GMRCCT
SET GMRCTYPE="GMRCOR CONSULT"
+18 IF $DATA(GMRC)=1!($DATA(GMRC)=11)
IF +GMRC
Begin DoDot:1
+19 SET GMRCVP=GMRC_";ORD(101,"
SET GMRCNM=$SELECT($DATA(^ORD(101,GMRC,0)):$PIECE(^(0),"^",2),1:"")
+20 SET GMRCSS=$PIECE($GET(^ORD(101,+GMRCVP,5)),"^")
SET GMRCSS=+GMRCSS
End DoDot:1
EN1 ;Entry point for
+1 QUIT
IF 'GMRCSS
DO ASRV^GMRCASV
Begin DoDot:1
+2 IF $DATA(DTOUT)!($DATA(DIROUT))
SET GMRCEND=1
KILL DTOUT,DIROUT,DIRUT,DUOUT
QUIT
+3 QUIT
End DoDot:1
if GMRCEND
QUIT
SET GMRCSS=+GMRCDG
IF 'GMRCDG
SET GMRCEND=1
KILL GMRCSS
QUIT
+4 IF '$TEST
SET GMRCDG=GMRCSS
DO SERV1^GMRCASV
+5 IF '$DATA(ORTKG)
SET ORTKG=$$PACKAGE
IF ORTKG=""
SET GMRCMSG="Missing package entry for CONSULT/REQUEST TRACKING"
DO EXAC^GMRCADC(GMRCMSG)
KILL GMRCMSG
SET GMRCEND=1
QUIT
+6 ;old code? D TEAM^GMRCASV
+7 SET GMRCSSNM=$PIECE(^GMR(123.5,GMRCSS,0),"^",1)
+8 ;old codeN GMRCQIT
+9 ;old code? S ORVP=DFN_";DPT(",GMRCGRP=0
+10 ;old code? K ^TMP("GMRCR",$J)
+11 KILL GMRCOER,GMRCQUT
+12 SET GMRCEN=1
+13 ; used to be D EN^GMRCACTM
DO EN^GMRCMENU
+14 SET GMRCOER=0
+15 ; used to be D AD^GMRCRA
DO AD^GMRCSLM1
+16 DO EN^VALM("GMRC CONSULT TRACKING")
+17 DO KILL
+18 QUIT
KILL ; Kill variables, but don't kill GMRCO and ORIFN if from MC option
+1 ;K VALMCNT,VALMBCK,VALMPGE
+2 ;K ^TMP("GMRCR",$J,"CS"),^TMP("GMRCS",$J)
+3 KILL X,Y,Z,DTOUT,DUOUT,DIROUT
+4 KILL GMRC,GMRCA,GMRCACT,GMRCACTM,GMRCAGE,GMRCCT,GMRCCTX,GMRCDG,GMRCDGT
+5 KILL GMRCDOB,GMRCDTM,GMRCGRP,GMRCH,GMRCHDR,GMRCIFN,GMRCLFG,GMRCNM,GMRCNPG
+6 KILL GMRCPNM,GMRCRB,GMRCWARD,GMRCSN,GMRCRPG,GMRCNPG,GMRCTITL,GMRCX,GMRCHDR,GMRCH,GMRCDTM
+7 KILL GMRCSTS,GMRCTYPE,GMRCVP,GMRCEND,GMRCTO,GMRCURG,GMRCL,GMRCDT,GMRCDIC
+8 KILL VA,VAIN,VAINDT,VADM,VAEL,VAPA,VAERR,VAROOT
+9 KILL O,OREND,ORINDX,ORNS,POP,SEX,W,XQORSPEW
+10 IF $DATA(XQY0)
IF $EXTRACT(XQY0,1,2)="MC"
if '$DATA(GMRCO)
SET (ORIFN,GMRCO)=""
QUIT
+11 KILL ORIFN,GMRCO,GMRCSR
+12 QUIT
RESULT ;Entry point to set up variable pointer to results and update OE/RR status
+1 QUIT
+2 if '$DATA(GMRCSR)
QUIT
if '$DATA(GMRCO)
QUIT
SET (GMRCSS,GMRCSSNM,GMRCNM,GMRC,GMRCVP)=""
+3 SET GMRCOM=0
SET GMR(0)=$SELECT($DATA(^GMR(123,+GMRCO,0)):^(0),1:"")
SET GMRCSS=$PIECE(GMR(0),"^",5)
IF GMRCSS
IF $DATA(^GMR(123.5,GMRCSS,0))
SET GMRCSSNM=$SELECT($LENGTH($PIECE(^GMR(123.5,GMRCSS,0),"^",9)):$PIECE(^(0),"^",9),1:$PIECE(^(0),"^"))
+4 SET GMRCVP=$PIECE(GMR(0),"^",8)
IF +GMRCVP
SET DIC="^"_$PIECE(GMRCVP,";",2)_$PIECE(GMRCVP,";")_",0)"
IF $LENGTH(DIC)
IF $DATA(@DIC)
SET GMRCNM=@(DIC)
SET GMRCNM=$PIECE(GMRCNM,"^",2)
+5 ;Assume order entry status of active
IF '$DATA(ORSTS)
SET ORSTS=6
+6 SET GMRCA=$ORDER(^GMR(123.1,"AC",+ORSTS,""))
IF 'GMRCA
SET GMRCA=9
+7 SET DIE=123
SET DA=GMRCO
SET DR="11////^S X=GMRCSR;8////^S X=ORSTS;9////^S X=GMRCA"
+8 LOCK +^GMR(123,GMRCO):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
IF '$TEST
SET GMRCMSG="Consult/Request Is Being Used By Another User."
SET GMRCMSG(1)="RESULT UPDATE WAS UNSUCCESSFUL! Try Again Later"
DO EXAC^GMRCADC(.GMRCMSG)
KILL GMRCO,ORIFN,GMRCMSG
DO KILL
QUIT
+9 DO ^DIE
KILL DIE,DA,DR
+10 LOCK -^GMR(123,GMRCO)
DO AUDIT^GMRCP
+11 if '$DATA(ORIFN)
SET ORIFN=$PIECE(^GMR(123,+GMRCO,0),"^",3)
+12 SET GMRCORNP=$PIECE(GMR(0),"^",14)
SET GMRCTYPE=$PIECE(GMR(0),"^",17)
+13 IF $LENGTH($PIECE(GMR(0),"^",14))
IF $PIECE(GMR(0),"^",14)'=DUZ
SET GMRCADUZ($PIECE(GMR(0),"^",14))=""
+14 IF ORIFN
DO EN^GMRCHL7(DFN,GMRCO,$GET(GMRCTYPE),$GET(GMRCRB),"RE",GMRCORNP,$GET(GMRCVSIT),.GMRCOM)
+15 KILL GMR,GMRCSS,GMRCORVP,GMRCVP,GMRCNM,DIC,GMRCPR
+16 QUIT
+17 ;
PACKAGE() ; Returns the package entry number for 'CONSULT/REQUEST TRACKING"
+1 QUIT $$FIND1^DIC(9.4,,"QX","CONSULT/REQUEST TRACKING")
+2 ;
