GMRCADC ;SLC/DLT/DCM - DC taken from List Manager ; 7/11/05 1:40pm
;;3.0;CONSULT/REQUEST TRACKING;**1,5,10,12,35,39,47**;DEC 27, 1997
EXAC(MSG) ;Exit message asking for user to press <ENTER> EXAC=Exit Action
N ND,X
W $C(7),!,MSG I $O(MSG(0)) S ND=0 F S ND=$O(MSG(ND)) Q:ND="" D
. W !,MSG(ND)
W !,"Press <RETURN> to continue: " R X:DTIME W !!
Q
DC(GMRCO,GMRCA) ;Discontinue a consult logic from DC^GMRCA1
I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1
N GMRCDA,GMRCACTM,GMRCADUZ,GMRCSERV,GMRCAD,GMRC
K GMRCQUT,GMRCQIT
I '+$G(GMRCO) D SELECT^GMRCA2(.GMRCO) I $D(GMRCQUT) Q
I '+$G(GMRCO) 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
. S GMRCQUT=1
I '$$LOCK^GMRCA1(GMRCO) S GMRCQUT=1 Q
;
S GMRC(0)=^GMR(123,GMRCO,0),GMRCDA=GMRCO
S (GMRCDFN,DFN)=$P(GMRC(0),"^",2)
I $D(GMRCA),+GMRCA S GMRCACTM=$S(GMRCA=6:"Discontinued",GMRCA=19:"Cancelled",1:$P($G(^GMR(123.1,+GMRCA,0)),"^",1))
;
D PROC I $D(GMRCQUT) D UNLOCK^GMRCA1(GMRCO) S GMRCQUT=1 Q
;send 513 back to service printer if request DC'd or Cancelled
I GMRCA=6,$$DCPRNT^GMRCUTL1(+GMRCO,DUZ) D
. D PRNT^GMRCUTL1(+$P(GMRC(0),U,5),+GMRCO)
S GMRCTRLC=$S(GMRCA=19:"OC",1:"OD")
D EN^GMRCHL7(DFN,GMRCO,$G(GMRCTYPE),$G(GMRCRB),GMRCTRLC,GMRCORNP,$G(GMRCVSIT),.GMRCOM,,$G(GMRCAD))
D UNLOCK^GMRCA1(GMRCO)
Q
;
PROC ;Check validity of action and if valid process the discontinue action
N DIROUT,DTOUT,DUOUT,GMRCMSG,GMRCFL,GMRCACT
I $P(GMRC(0),"^",12)=1 S GMRCMSG="This consult has already been discontinued!" D EXAC(GMRCMSG) S GMRCQUT=1 Q
I $P(GMRC(0),"^",12)=2 S GMRCMSG="This consult has already been completed!" D EXAC(GMRCMSG) S GMRCQUT=1 Q
I $P(GMRC(0),"^",12)=9 S GMRCMSG="Action invalid. This consult has partial results!",GMRCMSG(1)="Remove the associated results and then discontinue." D EXAC(.GMRCMSG) S GMRCQUT=1 Q
I $P(GMRC(0),"^",12)=13 S GMRCMSG="This consult has already been cancelled!" D EXAC(GMRCMSG) S GMRCQUT=1 Q
;
S GMRCORVP=GMRCDFN_";DPT("
N GETPROV
FRGTPRV D GETPROV^GMRCAU I $D(DIROUT)!$D(DTOUT)!$D(DUOUT) 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 ;Returns GMRCAD as the entered date
I GMRCAD="^" S GMRCQUT=1 Q
S GMRCSTS=$S(GMRCA=6:1,1:13),$P(GMRC(0),"^",12)=GMRCSTS
S GMRCOM=1
D STATUS^GMRCP
D AUDIT^GMRCP
;
S GMRCORTX=$S($L($G(GMRCACTM)):GMRCACTM,+GMRCA:$P(^GMR(123.1,GMRCA,0),U,1),1:"ACTION UNKNOWN FOR")_" consult "_$$ORTX^GMRCAU(+GMRCO)
S GMRCADUZ="",GMRCFL=0
I +$P($G(^GMR(123,+GMRCO,0)),"^",14),+$P(^(0),"^",14)'=DUZ S GMRCADUZ($P(^(0),"^",14))=""
;I +$P($G(^GMR(123,+GMRCO,0)),"^",14)=DUZ S GMRCFL=1
I GMRCA=6 S GMRCFL=$$DCNOTE(GMRCO,DUZ) ;check NOTIFY SERVICE ON DC
;I GMRCA=19 S GMRCFL=1
;send notification info to routine to be sent to OERR
N NOTYPE S NOTYPE=$S(GMRCA=6:23,1:30)
D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
Q
DCNOTE(IEN,USER) ;determine if service users receive alerts based on 1.04
N SERV,DCFLG
S SERV=$P(^GMR(123,IEN,0),U,5)
S DCFLG=$P($G(^GMR(123.5,SERV,1)),U,4)
I 'DCFLG Q 1
I DCFLG=2 Q 0
I DCFLG=1,'$$VALID^GMRCAU(SERV,IEN,USER) Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCADC 3364 printed Sep 23, 2025@19:21 Page 2
GMRCADC ;SLC/DLT/DCM - DC taken from List Manager ; 7/11/05 1:40pm
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,10,12,35,39,47**;DEC 27, 1997
EXAC(MSG) ;Exit message asking for user to press <ENTER> EXAC=Exit Action
+1 NEW ND,X
+2 WRITE $CHAR(7),!,MSG
IF $ORDER(MSG(0))
SET ND=0
FOR
SET ND=$ORDER(MSG(ND))
if ND=""
QUIT
Begin DoDot:1
+3 WRITE !,MSG(ND)
End DoDot:1
+4 WRITE !,"Press <RETURN> to continue: "
READ X:DTIME
WRITE !!
+5 QUIT
DC(GMRCO,GMRCA) ;Discontinue a consult logic from DC^GMRCA1
+1 IF $DATA(IOTM)
IF $DATA(IOBM)
IF $DATA(IOSTBM)
DO FULL^VALM1
+2 NEW GMRCDA,GMRCACTM,GMRCADUZ,GMRCSERV,GMRCAD,GMRC
+3 KILL GMRCQUT,GMRCQIT
+4 IF '+$GET(GMRCO)
DO SELECT^GMRCA2(.GMRCO)
IF $DATA(GMRCQUT)
QUIT
+5 IF '+$GET(GMRCO)
SET GMRCQUT=1
QUIT
+6 IF $PIECE($GET(^GMR(123,GMRCO,12)),U,5)="P"
Begin DoDot:1
+7 NEW DIR
+8 WRITE !,"The requesting facility may not take this action on an "
+9 WRITE "inter-facility consult."
+10 SET DIR(0)="E"
DO ^DIR
+11 SET GMRCQUT=1
End DoDot:1
QUIT
+12 IF '$$LOCK^GMRCA1(GMRCO)
SET GMRCQUT=1
QUIT
+13 ;
+14 SET GMRC(0)=^GMR(123,GMRCO,0)
SET GMRCDA=GMRCO
+15 SET (GMRCDFN,DFN)=$PIECE(GMRC(0),"^",2)
+16 IF $DATA(GMRCA)
IF +GMRCA
SET GMRCACTM=$SELECT(GMRCA=6:"Discontinued",GMRCA=19:"Cancelled",1:$PIECE($GET(^GMR(123.1,+GMRCA,0)),"^",1))
+17 ;
+18 DO PROC
IF $DATA(GMRCQUT)
DO UNLOCK^GMRCA1(GMRCO)
SET GMRCQUT=1
QUIT
+19 ;send 513 back to service printer if request DC'd or Cancelled
+20 IF GMRCA=6
IF $$DCPRNT^GMRCUTL1(+GMRCO,DUZ)
Begin DoDot:1
+21 DO PRNT^GMRCUTL1(+$PIECE(GMRC(0),U,5),+GMRCO)
End DoDot:1
+22 SET GMRCTRLC=$SELECT(GMRCA=19:"OC",1:"OD")
+23 DO EN^GMRCHL7(DFN,GMRCO,$GET(GMRCTYPE),$GET(GMRCRB),GMRCTRLC,GMRCORNP,$GET(GMRCVSIT),.GMRCOM,,$GET(GMRCAD))
+24 DO UNLOCK^GMRCA1(GMRCO)
+25 QUIT
+26 ;
PROC ;Check validity of action and if valid process the discontinue action
+1 NEW DIROUT,DTOUT,DUOUT,GMRCMSG,GMRCFL,GMRCACT
+2 IF $PIECE(GMRC(0),"^",12)=1
SET GMRCMSG="This consult has already been discontinued!"
DO EXAC(GMRCMSG)
SET GMRCQUT=1
QUIT
+3 IF $PIECE(GMRC(0),"^",12)=2
SET GMRCMSG="This consult has already been completed!"
DO EXAC(GMRCMSG)
SET GMRCQUT=1
QUIT
+4 IF $PIECE(GMRC(0),"^",12)=9
SET GMRCMSG="Action invalid. This consult has partial results!"
SET GMRCMSG(1)="Remove the associated results and then discontinue."
DO EXAC(.GMRCMSG)
SET GMRCQUT=1
QUIT
+5 IF $PIECE(GMRC(0),"^",12)=13
SET GMRCMSG="This consult has already been cancelled!"
DO EXAC(GMRCMSG)
SET GMRCQUT=1
QUIT
+6 ;
+7 SET GMRCORVP=GMRCDFN_";DPT("
+8 NEW GETPROV
FRGTPRV DO GETPROV^GMRCAU
IF $DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
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 ;Returns GMRCAD as the entered date
SET GMRCAD=$$GETDT^GMRCUTL1
+4 IF GMRCAD="^"
SET GMRCQUT=1
QUIT
+5 SET GMRCSTS=$SELECT(GMRCA=6:1,1:13)
SET $PIECE(GMRC(0),"^",12)=GMRCSTS
+6 SET GMRCOM=1
+7 DO STATUS^GMRCP
+8 DO AUDIT^GMRCP
+9 ;
+10 SET GMRCORTX=$SELECT($LENGTH($GET(GMRCACTM)):GMRCACTM,+GMRCA:$PIECE(^GMR(123.1,GMRCA,0),U,1),1:"ACTION UNKNOWN FOR")_" consult "_$$ORTX^GMRCAU(+GMRCO)
+11 SET GMRCADUZ=""
SET GMRCFL=0
+12 IF +$PIECE($GET(^GMR(123,+GMRCO,0)),"^",14)
IF +$PIECE(^(0),"^",14)'=DUZ
SET GMRCADUZ($PIECE(^(0),"^",14))=""
+13 ;I +$P($G(^GMR(123,+GMRCO,0)),"^",14)=DUZ S GMRCFL=1
+14 ;check NOTIFY SERVICE ON DC
IF GMRCA=6
SET GMRCFL=$$DCNOTE(GMRCO,DUZ)
+15 ;I GMRCA=19 S GMRCFL=1
+16 ;send notification info to routine to be sent to OERR
+17 NEW NOTYPE
SET NOTYPE=$SELECT(GMRCA=6:23,1:30)
+18 DO MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTYPE,.GMRCADUZ,GMRCFL)
+19 QUIT
DCNOTE(IEN,USER) ;determine if service users receive alerts based on 1.04
+1 NEW SERV,DCFLG
+2 SET SERV=$PIECE(^GMR(123,IEN,0),U,5)
+3 SET DCFLG=$PIECE($GET(^GMR(123.5,SERV,1)),U,4)
+4 IF 'DCFLG
QUIT 1
+5 IF DCFLG=2
QUIT 0
+6 IF DCFLG=1
IF '$$VALID^GMRCAU(SERV,IEN,USER)
QUIT 1
+7 QUIT 0
