Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCACMT

GMRCACMT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^VA(200 in ICR #10060
  1. ;
  1. ; Deprecated HCP interface via GMRC*3.0*196
  1. ;
  1. COMMENT(GMRCO) ;Add a comment without changing the status
  1. K GMRCQIT,GMRCQUT N GMRCA
  1. I $D(IOTM),$D(IOBM),$D(IOSTBM) D FULL^VALM1
  1. S GMRCNOW=$$NOW^XLFDT,GMRCAD=GMRCNOW
  1. S GMRCOM=1,GMRCA=20,GMRCPROV=$P(^GMR(123,GMRCO,0),"^",14) D AUDIT^GMRCP
  1. ; GMRCOM=1 defined the variable and tells AUDIT^GMRCP that the
  1. ; word-processing logic should be executed. If an actual comment is
  1. ; added, $P(GMRCOM,"^",2)=1 (send alert), if not GMRCOM=1 and no '^'
  1. ; exists (do not send alert)
  1. I $G(GMRCERR)=1 S GMRCMSG=GMRCERMS D EXAC^GMRCADC(GMRCMSG),END Q
  1. ;continue if no lock problems occurred
  1. I $P(GMRCOM,"^",2) D
  1. . I $P($G(^GMR(123,GMRCO,12)),U,5)="F" D
  1. .. W !!,"The ordering provider for this inter-facility consult will"
  1. .. W " automatically be ",!,"notified.",!
  1. . D PROCALRT("",1,20,GMRCO)
  1. . ;if a Non VA Care consult, notify HCP of the comment
  1. . ;I $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I")) D COMMENT^GMRCHL7H(GMRCO) ;p196 Deprecated
  1. . I $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I")) Q ;p196 Deprecated
  1. . ;if a COMMUNITY CARE consult, notify CCRA of the comment
  1. . I $$FEE^GMRCHL7H($$GET1^DIQ(123,GMRCO,1,"I")) D COMMENT^GMRCCCRA(GMRCO) ;patch 99 to send to CCRA
  1. . ;update LAST ACTION field even though no status change
  1. . N GMRCDR,GMRCSTS
  1. . S GMRCSTS="",GMRCDR="9////20"
  1. . D STATUS^GMRCP
  1. D END
  1. Q
  1. ;
  1. PROCALRT(GMRCORTX,GMRCDELR,ACTION,GMRCO) ;Process alert for comments
  1. ;If GMRCDELR=1, the ordering provider can be deleted from the list.
  1. N GMRCADUZ,GMRCANS,NOTIF,GMRCQIT,GMRCTM
  1. ;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)
  1. ;I (GMRCANS[U)!(GMRCANS=0) D END Q
  1. ;
  1. D WHOTO
  1. ;I $G(GMRCQIT) D END Q ;User "^" at requesting provider.
  1. ;
  1. N GMRCALT
  1. S NOTIF=$S(ACTION=20:63,ACTION=8:63,1:23)
  1. ;
  1. D SENDMSG(NOTIF,+GMRCO,$G(GMRCTM))
  1. Q
  1. ;
  1. SENDMSG(NOTIF,GMRCO,GMRCATM) ;Send the alert
  1. N GMRCDFN
  1. I '$D(GMRCADUZ) S GMRCADUZ=""
  1. W !,"Processing Alerts..."
  1. S GMRCDFN=$P($G(^GMR(123,+GMRCO,0)),"^",2)
  1. I '$L(GMRCORTX) D
  1. . N TXT
  1. . S TXT="Comment Added to "
  1. . I $P($G(^GMR(123,GMRCO,12)),U,5)'="P" S GMRCORTX=TXT_"consult " Q
  1. . S GMRCORTX=TXT_"remote consult "
  1. S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCO)
  1. D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCO,NOTIF,.GMRCADUZ,$G(GMRCATM))
  1. Q
  1. ;
  1. END ;kill off variables and exit
  1. K GMRC,GMRCA,GMRCMSG,GMRCOM,GMRCO,GMRCORTX,GMRCERR,GMRCERMS,GMRCQUT,GMRCUT
  1. I $D(DTOUT)!$D(DIROUT) S GMRCQIT=""
  1. K DTOUT,DIROUT,DUOUT,DIRUT
  1. S:$D(^TMP("GMRC",$J,"CURRENT","MENU")) XQORM("HIJACK")=^("MENU")
  1. Q
  1. ;
  1. WHOTO ;Get the users who should receive an alert
  1. ;Asks about requesting provider first, then prompts for additional users
  1. ;Returns GMRCADUZ array of users to send an alert to and GMRCQIT if "^"
  1. N GMRCRP,GMRCANS,GMRCUPD
  1. S GMRCRP=+$P($G(^GMR(123,+GMRCO,0)),U,14) ;requesting provider entry
  1. S GMRCUPD=$$VALID^GMRCAU($P(^GMR(123,+GMRCO,0),U,5),GMRCO,DUZ)
  1. I GMRCRP=DUZ D ;alert team if ord. prov. takes the action
  1. . S GMRCTM=1
  1. . W !,"Service update users will be notified.",!
  1. I +GMRCUPD>1,GMRCRP'=DUZ D ; alert ord. prov if update users takes action
  1. . S GMRCADUZ(GMRCRP)=""
  1. . W !,"Requesting provider will be notified.",!
  1. I '$G(GMRCTM),+GMRCUPD<2 D ;alert both if not ord. prov or update user
  1. . S GMRCTM=1,GMRCADUZ(GMRCRP)=""
  1. . W !,"Requesting provider and service update users will be notified.",!
  1. ;
  1. ;
  1. ANDTO ;Ask for additional recipients
  1. D NAMELIST("Additional alert recipients: ",.GMRCADUZ,GMRCDELR)
  1. Q
  1. ;
  1. NAMELIST(GMRCP,GMRCOLD,GMRCDELR) ;manage the list of recipients
  1. ;
  1. ; GMRCP - Prompt
  1. ; GMRCOLD - Original list with ordering provider.
  1. ; GMRCDELR - 1 means the original list may have names deleted
  1. ; Returns final list in GMRCOLD array
  1. ;
  1. N GMRCNEW,GMRCNT,GMRCDUZ,GMRCUSER,GMRCQ,GMRCADD,DIC,X,Y
  1. ;
  1. M GMRCNEW=GMRCOLD
  1. I GMRCDELR=1 K GMRCOLD S GMRCOLD="" ;Remove mandatory users from GMRCOLD
  1. S GMRCNT=0 F D Q:(GMRCUSER[U)
  1. .S GMRCUSER=$$READ("FAO;3;46",$S(GMRCNT:"And ",1:"")_GMRCP,"","^D NAMEHELP^GMRCACMT")
  1. .S:'$L(GMRCUSER) GMRCUSER=U Q:(GMRCUSER[U)
  1. .I ($E(GMRCUSER,1)="-") S GMRCADD=0,GMRCUSER=$E(GMRCUSER,2,$L(GMRCUSER))
  1. .E S GMRCADD=1
  1. .;
  1. .S X=GMRCUSER,DIC=200,DIC(0)="EMQ" D ^DIC
  1. .;
  1. .I (Y>0) D I 1
  1. ..;W $E($P(Y,U,2),$L(GMRCUSER)+1,$L($P(Y,U,2)))
  1. ..;
  1. ..I GMRCADD D
  1. ...I $D(GMRCNEW(+Y)) W " already in the list." Q
  1. ...S GMRCNEW(+Y)="" W " added to the list." S GMRCNT=GMRCNT+1
  1. ..;
  1. ..I 'GMRCADD D
  1. ...I $D(GMRCOLD(+Y)) W " can't delete this name from the list." Q
  1. ...I '$D(GMRCNEW(+Y)) W " not currently in the list." Q
  1. ...K GMRCNEW(+Y) S GMRCNT=GMRCNT-1 W " deleted from the list."
  1. .;
  1. .E I $L(GMRCUSER) W " Name not found."
  1. ;
  1. M GMRCOLD=GMRCNEW
  1. Q
  1. ;
  1. READ(GMRC0,GMRCA,GMRCB,GMRCH,GMRCL) ;read logic
  1. ;
  1. ; GMRC0 -> DIR(0) --- Type of read
  1. ; GMRCA -> DIR("A") - Prompt
  1. ; GMRCB -> DIR("B") - Default Answer
  1. ; GMRCH -> DIR("?") - Help text or ^Execute code
  1. ; GMRCL -> Number of blank lines to put before Prompt
  1. ;
  1. ; Returns "^" or answer
  1. ;
  1. N GMRCLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
  1. Q:'$L($G(GMRC0)) U
  1. S DIR(0)=GMRC0
  1. S:$L($G(GMRCA)) DIR("A")=GMRCA
  1. S:$L($G(GMRCB)) DIR("B")=GMRCB
  1. S:$L($G(GMRCH)) DIR("?")=GMRCH
  1. F GMRCLINE=1:1:($G(GMRCL)-1) W !
  1. D ^DIR
  1. I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
  1. Q Y
  1. ;
  1. ;
  1. NAMEHELP ;Help for the recipient list logic
  1. N GMRCDUZ
  1. W !,"Enter the name of the user to send the alert to,"
  1. W !," or put a '-' in front of a name to delete from the list."
  1. W !
  1. W !," Example:"
  1. W !," SMITH,FRED -> to add Fred to the list."
  1. W !," -SMITH,FRED -> to delete Fred from the list."
  1. W !,"Already selected: "
  1. W !
  1. S GMRCDUZ=0 F S GMRCDUZ=$O(GMRCNEW(GMRCDUZ)) Q:'GMRCDUZ D
  1. .W !,?5,$P(^VA(200,GMRCDUZ,0),U,1)
  1. .W:$D(GMRCOLD(GMRCDUZ)) " <mandatory>"
  1. W !
  1. Q
  1. ;