- 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 Feb 18, 2025@23:11:19 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 ;