GMRCACMT ;SLC/DLT,DCM,MA,JFR - Comment Action and alerting ; Jan 17, 2024@13:17
;;3.0;CONSULT/REQUEST TRACKING;**4,14,18,20,22,29,35,47,55,75,99,196**;DEC 27, 1997;Build 3
;
; Reference to ^VA(200 in ICR #10060
;
; Deprecated HCP interface via GMRC*3.0*196
;
K GMRCQIT,GMRCQUT N GMRCA
I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1
S GMRCNOW=$$NOW^XLFDT,GMRCAD=GMRCNOW
S GMRCOM=1,GMRCA=20,GMRCPROV=$P(^GMR(123,GMRCO,0),"^",14) D AUDIT^GMRCP
; GMRCOM=1 defined the variable and tells AUDIT^GMRCP that the
; word-processing logic should be executed. If an actual comment is
; added, $P(GMRCOM,"^",2)=1 (send alert), if not GMRCOM=1 and no '^'
; exists (do not send alert)
I $G(GMRCERR)=1 S GMRCMSG=GMRCERMS D EXAC^GMRCADC(GMRCMSG),END Q
;continue if no lock problems occurred
I $P(GMRCOM,"^",2) D
. I $P($G(^GMR(123,GMRCO,12)),U,5)="F" D
.. W !!,"The ordering provider for this inter-facility consult will"
.. W " automatically be ",!,"notified.",!
. D PROCALRT("",1,20,GMRCO)
. ;if a Non VA Care consult, notify HCP of the comment
. ;I $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I")) D COMMENT^GMRCHL7H(GMRCO) ;p196 Deprecated
. I $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I")) Q ;p196 Deprecated
. ;if a COMMUNITY CARE consult, notify CCRA of the comment
. I $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I")) D COMMENT^GMRCCCRA(GMRCO) ;patch 99 to send to CCRA
. ;update LAST ACTION field even though no status change
. N GMRCDR,GMRCSTS
. S GMRCSTS="",GMRCDR="9////20"
. D STATUS^GMRCP
D END
Q
;
PROCALRT(GMRCORTX,GMRCDELR,ACTION,GMRCO) ;Process alert for comments
;If GMRCDELR=1, the ordering provider can be deleted from the list.
N GMRCADUZ,GMRCANS,NOTIF,GMRCQIT,GMRCTM
;S GMRCANS=$$READ("Y","Do You Wish To Send An Alert With This Comment","N","Enter Y to continue with recipient prompts. Otherwise, enter N.",1)
;I (GMRCANS[U)!(GMRCANS=0) D END Q
;
D WHOTO
;I $G(GMRCQIT) D END Q ;User "^" at requesting provider.
;
N GMRCALT
S NOTIF=$S(ACTION=20:63,ACTION=8:63,1:23)
;
D SENDMSG(NOTIF,+GMRCO,$G(GMRCTM))
Q
;
SENDMSG(NOTIF,GMRCO,GMRCATM) ;Send the alert
N GMRCDFN
I '$D(GMRCADUZ) S GMRCADUZ=""
W !,"Processing Alerts..."
S GMRCDFN=$P($G(^GMR(123,+GMRCO,0)),"^",2)
I '$L(GMRCORTX) D
. N TXT
. S TXT="Comment Added to "
. I $P($G(^GMR(123,GMRCO,12)),U,5)'="P" S GMRCORTX=TXT_"consult " Q
. S GMRCORTX=TXT_"remote consult "
S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCO)
D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTIF,.GMRCADUZ,$G(GMRCATM))
Q
;
END ;kill off variables and exit
K GMRC,GMRCA,GMRCMSG,GMRCOM,GMRCO,GMRCORTX,GMRCERR,GMRCERMS,GMRCQUT,GMRCUT
I $D(DTOUT)!$D(DIROUT) S GMRCQIT=""
K DTOUT,DIROUT,DUOUT,DIRUT
S:$D(^TMP("GMRC",$J,"CURRENT","MENU")) XQORM("HIJACK")=^("MENU")
Q
;
WHOTO ;Get the users who should receive an alert
;Asks about requesting provider first, then prompts for additional users
;Returns GMRCADUZ array of users to send an alert to and GMRCQIT if "^"
N GMRCRP,GMRCANS,GMRCUPD
S GMRCRP=+$P($G(^GMR(123,+GMRCO,0)),U,14) ;requesting provider entry
S GMRCUPD=$$VALID^GMRCAU($P(^GMR(123,+GMRCO,0),U,5),GMRCO,DUZ)
I GMRCRP=DUZ D ;alert team if ord. prov. takes the action
. S GMRCTM=1
. W !,"Service update users will be notified.",!
I +GMRCUPD>1,GMRCRP'=DUZ D ; alert ord. prov if update users takes action
. S GMRCADUZ(GMRCRP)=""
. W !,"Requesting provider will be notified.",!
I '$G(GMRCTM),+GMRCUPD<2 D ;alert both if not ord. prov or update user
. S GMRCTM=1,GMRCADUZ(GMRCRP)=""
. W !,"Requesting provider and service update users will be notified.",!
;
;
ANDTO ;Ask for additional recipients
D NAMELIST("Additional alert recipients: ",.GMRCADUZ,GMRCDELR)
Q
;
NAMELIST(GMRCP,GMRCOLD,GMRCDELR) ;manage the list of recipients
;
; GMRCP - Prompt
; GMRCOLD - Original list with ordering provider.
; GMRCDELR - 1 means the original list may have names deleted
; Returns final list in GMRCOLD array
;
N GMRCNEW,GMRCNT,GMRCDUZ,GMRCUSER,GMRCQ,GMRCADD,DIC,X,Y
;
M GMRCNEW=GMRCOLD
I GMRCDELR=1 K GMRCOLD S GMRCOLD="" ;Remove mandatory users from GMRCOLD
S GMRCNT=0 F D Q:(GMRCUSER[U)
.S GMRCUSER=$$READ("FAO;3;46",$S(GMRCNT:"And ",1:"")_GMRCP,"","^D NAMEHELP^GMRCACMT")
.S:'$L(GMRCUSER) GMRCUSER=U Q:(GMRCUSER[U)
.I ($E(GMRCUSER,1)="-") S GMRCADD=0,GMRCUSER=$E(GMRCUSER,2,$L(GMRCUSER))
.E S GMRCADD=1
.;
.S X=GMRCUSER,DIC=200,DIC(0)="EMQ" D ^DIC
.;
.I (Y>0) D I 1
..;W $E($P(Y,U,2),$L(GMRCUSER)+1,$L($P(Y,U,2)))
..;
..I GMRCADD D
...I $D(GMRCNEW(+Y)) W " already in the list." Q
...S GMRCNEW(+Y)="" W " added to the list." S GMRCNT=GMRCNT+1
..;
..I 'GMRCADD D
...I $D(GMRCOLD(+Y)) W " can't delete this name from the list." Q
...I '$D(GMRCNEW(+Y)) W " not currently in the list." Q
...K GMRCNEW(+Y) S GMRCNT=GMRCNT-1 W " deleted from the list."
.;
.E I $L(GMRCUSER) W " Name not found."
;
M GMRCOLD=GMRCNEW
Q
;
READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL) ;read logic
;
; GMRC0 -> DIR(0) --- Type of read
; GMRCA -> DIR("A") - Prompt
; GMRCB -> DIR("B") - Default Answer
; GMRCH -> DIR("?") - Help text or ^Execute code
; GMRCL -> Number of blank lines to put before Prompt
;
; Returns "^" or answer
;
N GMRCLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
Q:'$L($G(GMRC0)) U
S DIR(0)=GMRC0
S:$L($G(GMRCA)) DIR("A")=GMRCA
S:$L($G(GMRCB)) DIR("B")=GMRCB
S:$L($G(GMRCH)) DIR("?")=GMRCH
F GMRCLINE=1:1:($G(GMRCL)-1) W !
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
Q Y
;
;
NAMEHELP ;Help for the recipient list logic
N GMRCDUZ
W !,"Enter the name of the user to send the alert to,"
W !," or put a '-' in front of a name to delete from the list."
W !
W !," Example:"
W !," SMITH,FRED -> to add Fred to the list."
W !," -SMITH,FRED -> to delete Fred from the list."
W !,"Already selected: "
W !
S GMRCDUZ=0 F S GMRCDUZ=$O(GMRCNEW(GMRCDUZ)) Q:'GMRCDUZ D
.W !,?5,$P(^VA(200,GMRCDUZ,0),U,1)
.W:$D(GMRCOLD(GMRCDUZ)) " <mandatory>"
W !
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCACMT 6124 printed Sep 23, 2025@19:20:56 Page 2
GMRCACMT ;SLC/DLT,DCM,MA,JFR - Comment Action and alerting ; Jan 17, 2024@13:17
+1 ;;3.0;CONSULT/REQUEST TRACKING;**4,14,18,20,22,29,35,47,55,75,99,196**;DEC 27, 1997;Build 3
+2 ;
+3 ; Reference to ^VA(200 in ICR #10060
+4 ;
+5 ; Deprecated HCP interface via GMRC*3.0*196
+6 ;
+1 KILL GMRCQIT,GMRCQUT
NEW GMRCA
+2 IF $DATA(IOTM)
IF $DATA(IOBM)
IF $DATA(IOSTBM)
DO FULL^VALM1
+3 SET GMRCNOW=$$NOW^XLFDT
SET GMRCAD=GMRCNOW
+4 SET GMRCOM=1
SET GMRCA=20
SET GMRCPROV=$PIECE(^GMR(123,GMRCO,0),"^",14)
DO AUDIT^GMRCP
+5 ; GMRCOM=1 defined the variable and tells AUDIT^GMRCP that the
+6 ; word-processing logic should be executed. If an actual comment is
+7 ; added, $P(GMRCOM,"^",2)=1 (send alert), if not GMRCOM=1 and no '^'
+8 ; exists (do not send alert)
+9 IF $GET(GMRCERR)=1
SET GMRCMSG=GMRCERMS
DO EXAC^GMRCADC(GMRCMSG)
DO END
QUIT
+10 ;continue if no lock problems occurred
+11 IF $PIECE(GMRCOM,"^",2)
Begin DoDot:1
+12 IF $PIECE($GET(^GMR(123,GMRCO,12)),U,5)="F"
Begin DoDot:2
+13 WRITE !!,"The ordering provider for this inter-facility consult will"
+14 WRITE " automatically be ",!,"notified.",!
End DoDot:2
+15 DO PROCALRT("",1,20,GMRCO)
+16 ;if a Non VA Care consult, notify HCP of the comment
+17 ;I $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I")) D COMMENT^GMRCHL7H(GMRCO) ;p196 Deprecated
+18 ;p196 Deprecated
IF $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I"))
QUIT
+19 ;if a COMMUNITY CARE consult, notify CCRA of the comment
+20 ;patch 99 to send to CCRA
IF $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I"))
DO COMMENT^GMRCCCRA(GMRCO)
+21 ;update LAST ACTION field even though no status change
+22 NEW GMRCDR,GMRCSTS
+23 SET GMRCSTS=""
SET GMRCDR="9////20"
+24 DO STATUS^GMRCP
End DoDot:1
+25 DO END
+26 QUIT
+27 ;
PROCALRT(GMRCORTX,GMRCDELR,ACTION,GMRCO) ;Process alert for comments
+1 ;If GMRCDELR=1, the ordering provider can be deleted from the list.
+2 NEW GMRCADUZ,GMRCANS,NOTIF,GMRCQIT,GMRCTM
+3 ;S GMRCANS=$$READ("Y","Do You Wish To Send An Alert With This Comment","N","Enter Y to continue with recipient prompts. Otherwise, enter N.",1)
+4 ;I (GMRCANS[U)!(GMRCANS=0) D END Q
+5 ;
+6 DO WHOTO
+7 ;I $G(GMRCQIT) D END Q ;User "^" at requesting provider.
+8 ;
+9 NEW GMRCALT
+10 SET NOTIF=$SELECT(ACTION=20:63,ACTION=8:63,1:23)
+11 ;
+12 DO SENDMSG(NOTIF,+GMRCO,$GET(GMRCTM))
+13 QUIT
+14 ;
SENDMSG(NOTIF,GMRCO,GMRCATM) ;Send the alert
+1 NEW GMRCDFN
+2 IF '$DATA(GMRCADUZ)
SET GMRCADUZ=""
+3 WRITE !,"Processing Alerts..."
+4 SET GMRCDFN=$PIECE($GET(^GMR(123,+GMRCO,0)),"^",2)
+5 IF '$LENGTH(GMRCORTX)
Begin DoDot:1
+6 NEW TXT
+7 SET TXT="Comment Added to "
+8 IF $PIECE($GET(^GMR(123,GMRCO,12)),U,5)'="P"
SET GMRCORTX=TXT_"consult "
QUIT
+9 SET GMRCORTX=TXT_"remote consult "
End DoDot:1
+10 SET GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCO)
+11 DO MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTIF,.GMRCADUZ,$GET(GMRCATM))
+12 QUIT
+13 ;
END ;kill off variables and exit
+1 KILL GMRC,GMRCA,GMRCMSG,GMRCOM,GMRCO,GMRCORTX,GMRCERR,GMRCERMS,GMRCQUT,GMRCUT
+2 IF $DATA(DTOUT)!$DATA(DIROUT)
SET GMRCQIT=""
+3 KILL DTOUT,DIROUT,DUOUT,DIRUT
+4 if $DATA(^TMP("GMRC",$JOB,"CURRENT","MENU"))
SET XQORM("HIJACK")=^("MENU")
+5 QUIT
+6 ;
WHOTO ;Get the users who should receive an alert
+1 ;Asks about requesting provider first, then prompts for additional users
+2 ;Returns GMRCADUZ array of users to send an alert to and GMRCQIT if "^"
+3 NEW GMRCRP,GMRCANS,GMRCUPD
+4 ;requesting provider entry
SET GMRCRP=+$PIECE($GET(^GMR(123,+GMRCO,0)),U,14)
+5 SET GMRCUPD=$$VALID^GMRCAU($PIECE(^GMR(123,+GMRCO,0),U,5),GMRCO,DUZ)
+6 ;alert team if ord. prov. takes the action
IF GMRCRP=DUZ
Begin DoDot:1
+7 SET GMRCTM=1
+8 WRITE !,"Service update users will be notified.",!
End DoDot:1
+9 ; alert ord. prov if update users takes action
IF +GMRCUPD>1
IF GMRCRP'=DUZ
Begin DoDot:1
+10 SET GMRCADUZ(GMRCRP)=""
+11 WRITE !,"Requesting provider will be notified.",!
End DoDot:1
+12 ;alert both if not ord. prov or update user
IF '$GET(GMRCTM)
IF +GMRCUPD<2
Begin DoDot:1
+13 SET GMRCTM=1
SET GMRCADUZ(GMRCRP)=""
+14 WRITE !,"Requesting provider and service update users will be notified.",!
End DoDot:1
+15 ;
+16 ;
ANDTO ;Ask for additional recipients
+1 DO NAMELIST("Additional alert recipients: ",.GMRCADUZ,GMRCDELR)
+2 QUIT
+3 ;
NAMELIST(GMRCP,GMRCOLD,GMRCDELR) ;manage the list of recipients
+1 ;
+2 ; GMRCP - Prompt
+3 ; GMRCOLD - Original list with ordering provider.
+4 ; GMRCDELR - 1 means the original list may have names deleted
+5 ; Returns final list in GMRCOLD array
+6 ;
+7 NEW GMRCNEW,GMRCNT,GMRCDUZ,GMRCUSER,GMRCQ,GMRCADD,DIC,X,Y
+8 ;
+9 MERGE GMRCNEW=GMRCOLD
+10 ;Remove mandatory users from GMRCOLD
IF GMRCDELR=1
KILL GMRCOLD
SET GMRCOLD=""
+11 SET GMRCNT=0
FOR
Begin DoDot:1
+12 SET GMRCUSER=$$READ("FAO;3;46",$SELECT(GMRCNT:"And ",1:"")_GMRCP,"","^D NAMEHELP^GMRCACMT")
+13 if '$LENGTH(GMRCUSER)
SET GMRCUSER=U
if (GMRCUSER[U)
QUIT
+14 IF ($EXTRACT(GMRCUSER,1)="-")
SET GMRCADD=0
SET GMRCUSER=$EXTRACT(GMRCUSER,2,$LENGTH(GMRCUSER))
+15 IF '$TEST
SET GMRCADD=1
+16 ;
+17 SET X=GMRCUSER
SET DIC=200
SET DIC(0)="EMQ"
DO ^DIC
+18 ;
+19 IF (Y>0)
Begin DoDot:2
+20 ;W $E($P(Y,U,2),$L(GMRCUSER)+1,$L($P(Y,U,2)))
+21 ;
+22 IF GMRCADD
Begin DoDot:3
+23 IF $DATA(GMRCNEW(+Y))
WRITE " already in the list."
QUIT
+24 SET GMRCNEW(+Y)=""
WRITE " added to the list."
SET GMRCNT=GMRCNT+1
End DoDot:3
+25 ;
+26 IF 'GMRCADD
Begin DoDot:3
+27 IF $DATA(GMRCOLD(+Y))
WRITE " can't delete this name from the list."
QUIT
+28 IF '$DATA(GMRCNEW(+Y))
WRITE " not currently in the list."
QUIT
+29 KILL GMRCNEW(+Y)
SET GMRCNT=GMRCNT-1
WRITE " deleted from the list."
End DoDot:3
End DoDot:2
IF 1
+30 ;
+31 IF '$TEST
IF $LENGTH(GMRCUSER)
WRITE " Name not found."
End DoDot:1
if (GMRCUSER[U)
QUIT
+32 ;
+33 MERGE GMRCOLD=GMRCNEW
+34 QUIT
+35 ;
READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL) ;read logic
+1 ;
+2 ; GMRC0 -> DIR(0) --- Type of read
+3 ; GMRCA -> DIR("A") - Prompt
+4 ; GMRCB -> DIR("B") - Default Answer
+5 ; GMRCH -> DIR("?") - Help text or ^Execute code
+6 ; GMRCL -> Number of blank lines to put before Prompt
+7 ;
+8 ; Returns "^" or answer
+9 ;
+10 NEW GMRCLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+11 if '$LENGTH($GET(GMRC0))
QUIT U
+12 SET DIR(0)=GMRC0
+13 if $LENGTH($GET(GMRCA))
SET DIR("A")=GMRCA
+14 if $LENGTH($GET(GMRCB))
SET DIR("B")=GMRCB
+15 if $LENGTH($GET(GMRCH))
SET DIR("?")=GMRCH
+16 FOR GMRCLINE=1:1:($GET(GMRCL)-1)
WRITE !
+17 DO ^DIR
+18 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT U
+19 QUIT Y
+20 ;
+21 ;
NAMEHELP ;Help for the recipient list logic
+1 NEW GMRCDUZ
+2 WRITE !,"Enter the name of the user to send the alert to,"
+3 WRITE !," or put a '-' in front of a name to delete from the list."
+4 WRITE !
+5 WRITE !," Example:"
+6 WRITE !," SMITH,FRED -> to add Fred to the list."
+7 WRITE !," -SMITH,FRED -> to delete Fred from the list."
+8 WRITE !,"Already selected: "
+9 WRITE !
+10 SET GMRCDUZ=0
FOR
SET GMRCDUZ=$ORDER(GMRCNEW(GMRCDUZ))
if 'GMRCDUZ
QUIT
Begin DoDot:1
+11 WRITE !,?5,$PIECE(^VA(200,GMRCDUZ,0),U,1)
+12 if $DATA(GMRCOLD(GMRCDUZ))
WRITE " <mandatory>"
End DoDot:1
+13 WRITE !
+14 QUIT
+15 ;
