BMCBULL ; IHS/PHXAO/TMJ - RCIS - SEND BULLETIN ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
;
;IHS/ITSC/FCJ REMOVED EN4,EN5,EN6 AND EN7
; COMBINED TO CALL EP ENMM FOR MAILMAN MESSAGES
; WILL LIST ANY PREVIOUS MESSAGE SENT AND
; OPTION TO SELECT GROUPS TO SEND MESSAGE TO
; ALSO STORE HISTORY OF MSG SENT IN RCIS MESSAGE FILE
;
; This routine sends bulletins to RCIS users as appropriate.
;
EN1 ; EP - DX BULLETINS
NEW Y,BMCBULLN,BMCNARR,BMCNODE
Q:'$G(BMCDFN)
Q:'$G(BMCRDATE)
K XMY
I $D(BMCBULLC) S BMCBULLN="BMC POTENTIAL HIGH COST DX",BMCNODE=21,BMCNARR=$$VAL^XBDIQ1(90001,BMCRIEN,.12) D SEND Q
I $G(BMCTXL3P),$$TXC^ATXTXCHK(X,BMCTXL3P) S BMCBULLN="BMC 3RD PARTY LIABILITY",BMCNARR=$$VAL^XBDIQ1(90001.01,DA,.01)_" "_$$VAL^XBDIQ1(90001.01,DA,.019),BMCNODE=25 D SEND
I $G(BMCTXPHC),$$TXC^ATXTXCHK(X,BMCTXPHC) S BMCBULLN="BMC POTENTIAL HIGH COST DX",BMCNARR=$$VAL^XBDIQ1(90001.01,DA,.01)_" "_$$VAL^XBDIQ1(90001.01,DA,.019),BMCNODE=21 D SEND Q
Q
EN2 ;EP - procedure bulletins (high cost, cosmetic, exp)
NEW Y,BMCBULLN,BMCNARR,BMCNODE
Q:'$G(BMCDFN)
Q:'$G(BMCRDATE)
K XMY
I $G(BMCTXCHC),$$TXC^ATXTXCHK(X,BMCTXCHC) S BMCBULLN="BMC POTENTIAL HIGH COST PROC",BMCNARR=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019),BMCNODE=22 D SEND
I $G(BMCTXCCP),$$TXC^ATXTXCHK(X,BMCTXCCP) S BMCBULLN="BMC COSMETIC PROCEDURE",BMCNARR=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019),BMCNODE=23 D SEND
I $G(BMCTXCEX),$$TXC^ATXTXCHK(X,BMCTXCEX) S BMCBULLN="BMC EXPERIMENTAL PROCEDURE",BMCNARR=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019),BMCNODE=24 D SEND
Q
SEND ;SEND BULLETIN
K XMB
S XMB=BMCBULLN
S XMB(1)=BMCREC("PAT NAME")
S XMB(2)=BMCREC("REF DATE")
S XMB(3)=BMCRNUMB
S XMB(4)=""
S Y=$P(^BMCREF(BMCRIEN,0),U,6)
S:Y XMB(4)=$P(^VA(200,Y,0),U)
S XMB(5)=$G(BMCNARR)
K XMY
S Y=0 F S Y=$O(^BMCPARM(DUZ(2),BMCNODE,Y)) Q:Y'=+Y S %=$P(^BMCPARM(DUZ(2),BMCNODE,Y,0),U) I %,$P(^BMCPARM(DUZ(2),BMCNODE,Y,0),U,2)]"",$P(^(0),U,2)[BMCRTYPE S XMY(%)=""
Q:'$D(XMY)
D ^XMB
K XMB,XMY
Q
;
ENX ; EP - POTENTIAL HIGH COST DX
NEW Y
Q:'$G(BMCDFN)
Q:'$G(BMCRDATE)
K XMY
S Y=$P(^BMCREF(BMCRIEN,0),U,4)
Q:Y="N" ; quit if type is In-House
Q:Y="O" ; quit if type is Other
I Y="C",BMCCHSS S XMY(BMCCHSS)="" ; if CHS send to chs supvr
I Y="I",BMCBOS S XMY(BMCBOS)="" ; if IHS send to business office
S Y=$P(^BMCREF(BMCRIEN,0),U,19) ; send to case manager
I Y S XMY(Y)=""
Q:'$D(XMY) ; quit if no addressees
K XMB
S XMB="BMC POTENTIAL HIGH COST DX"
S XMB(1)=BMCREC("PAT NAME")
S XMB(2)=BMCREC("REF DATE")
S XMB(3)=BMCRNUMB
S XMB(4)=""
S Y=$P(^BMCREF(BMCRIEN,0),U,6)
S:Y XMB(4)=$P(^VA(200,Y,0),U)
S Y=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019)
S:Y]"" XMB(5)=Y
D ^XMB
K XMB,XMY
Q
;
EN3 ;EP
NEW Y
Q:'$G(BMCDFN)
Q:'$G(BMCRDATE)
K XMY
S Y=$P(^BMCREF(BMCRIEN,0),U,4)
Q:Y="N" ; quit if type is In-House
Q:Y="O" ; quit if type is Other
I Y="C",BMCCHSS S XMY(BMCCHSS)="" ; if CHS send to chs supvr
I Y="I",BMCBOS S XMY(BMCBOS)="" ; if IHS send to business office
S Y=$P(^BMCREF(BMCRIEN,0),U,19) ; send to case manager
I Y S XMY(Y)=""
Q:'$D(XMY) ; quit if no addressees
K XMB
S XMB="BMC CPT CATEGORY/PROCEDURE"
S XMB(1)=BMCREC("PAT NAME")
S XMB(2)=BMCREC("REF DATE")
S XMB(3)=BMCRNUMB
S XMB(4)=""
S Y=$P(^BMCREF(BMCRIEN,0),U,6)
S:Y XMB(4)=$P(^VA(200,Y,0),U)
S Y=$$VAL^XBDIQ1(90001,BMCRIEN,.12)
S:Y]"" XMB(5)=Y
S Y=$$VAL^XBDIQ1(90001,BMCRIEN,.13)
S:Y]"" XMB(6)=Y
D ^XMB
K XMB,XMY
Q
;
;IHS/ITSC/FCJ REMOVED EN4,EN5,EN6 AND EN7 ADDED ENMM THROUGH EXT
ENMM ;EP;MESSAGE NEW REF AND MODIFICATIONS
NEW Y,DIC
Q:'$G(BMCDFN)
Q:'$G(BMCRDATE)
MSG ;TEST FOR EXISTING MESSAGES ALREADY SENT
I $D(^BMCMSG("C",BMCRIEN)) D
.W !!,"A Message has already been sent for this referral:"
.S BMCMSG=0 W !?3,"DATE",?25,"SENT BY",?55,"GROUP"
.F S BMCMSG=$O(^BMCMSG("C",BMCRIEN,BMCMSG)) Q:BMCMSG'?1N.N D
..S Y=$P(^BMCMSG(BMCMSG,0),U) D DD^%DT
..W !?3,Y,?25,$P(^VA(200,$P(^BMCMSG(BMCMSG,0),U,4),0),U)
..S BMCGRP=0 F S BMCGRP=$O(^BMCMSG(BMCMSG,1,BMCGRP)) Q:BMCGRP'?1N.N D
...S BMCGRP1=$P(^BMCMSG(BMCMSG,1,BMCGRP,0),U)
...W ?55,$P(^XMB(3.8,BMCGRP1,0),U),!
E W !!,"A Message has NOT been sent for this referral."
S DIR(0)="Y",DIR("A")="Do you wish to send a message",DIR("B")="Y"
D ^DIR K DIR I $D(DIRUT)!'Y G EXT
MGRP ;SELECT MAIL GROUPS TO SEND MESSAGE TO
;ENTER THE GROUP TO SEND IT TO AND ADD ENTRY TO THE RCIS MESSAGE FILE
S BMCGRP="BMC",DIR(0)="S^",Y=0
F S BMCGRP=$O(^XMB(3.8,"B",BMCGRP)) Q:$E(BMCGRP,1,3)'="BMC" D
.S BMCGRP1=0 S BMCGRP1=$O(^XMB(3.8,"B",BMCGRP,BMCGRP1))
.S Y=Y+1,BMCGRP(Y)=BMCGRP_U_BMCGRP1
I Y=0 W !,"THERE ARE NOT ANY RCIS MAIL GROUPS SET UP.",!,"If you would like to set up a mail group, use Mail Groups Option under the",!,"RCIS Management Menu." Q
F I=1:1:Y W !?5,I_". "_$P(BMCGRP(I),U)
S DIR("A")="To select recipient group(s) enter a list or range of numbers"
S DIR(0)="L^1:"_Y
D ^DIR I $D(DIRUT) W !?5,"***MESSAGE WAS NOT SENT***" G EXT
SNDMSG ;SEND BULLETIN
K XMB,XMY
F I=1:1 Q:$P(Y,",",I)'?1N.N S XMY("G."_$P(BMCGRP($P(Y,",",I)),U))="",BMCGRPS($P(BMCGRP($P(Y,",",I)),U,2))=""
S Y=$P(^BMCREF(BMCRIEN,0),U,4)
S XMZ=""
;REF IF OPTION SET AND USER ANSWERS YES....
;Q:Y="N" ;quit if In-House referral ;FCJ REMOVED
S XMB="BMC REFERRAL ALERT" ;FCJ NEW BULLETIN
S XMB(1)=BMCREC("PAT NAME")
S XMB(2)=BMCREC("REF DATE")
S XMB(3)=BMCRNUMB
S XMB(4)=""
S XMB(5)=$$VAL^XBDIQ1(90001,BMCRIEN,1201)
S XMB(6)=$$FACREF^BMCRLU(BMCRIEN)
S XMB(7)=$$VAL^XBDIQ1(90001,BMCRIEN,1301)
S XMB(8)=$$VAL^XBDIQ1(90001,BMCRIEN,.32)
S Y=$P(^BMCREF(BMCRIEN,0),U,6)
S:Y XMB(4)=$P(^VA(200,Y,0),U)
S XMB(9)=$$VAL^XBDIQ1(90001,BMCRIEN,.04)
;IHS/ITSC/FCJ ADDED BO COM FR RCIS COMMENTS FILE,LIFO DISPLAY
I $D(^BMCCOM("AD",BMCRIEN)) D
.S BMCL=0,BMCL2=10
.F S BMCL=$O(^BMCCOM("AD",BMCRIEN,BMCL)) Q:BMCL'?1N.N D
..Q:$P(^BMCCOM(BMCL,0),U,5)'="B"
..I $D(^BMCCOM(BMCL,1)) D
...S XMB(BMCL2)=" Date: "_$$FMTE^XLFDT($P(^BMCCOM(BMCL,0),U),"5D")_" By: "_$$VAL^XBDIQ1(90001.03,BMCL,.04)
...S BMCL1=0
...F S BMCL1=$O(^BMCCOM(BMCL,1,BMCL1)) Q:BMCL1'?1N.N D
....S BMCL2=BMCL2+1
....S XMB(BMCL2)=^BMCCOM(BMCL,1,BMCL1,0)
..S BMCL2=BMCL2+1
D EN^XMB
I $D(XMB) W !?5,"***ERROR: NO MESSAGE SENT***" G EXT
W !?5,"***MESSAGE SENT***"
ADD ;IF MESSAGE SENT ADD TO RCIS MESSAGE FILE
S (DIE,DIC)="^BMCMSG(",DIC(0)="L"
D NOW^%DTC S X=%
S DIC("DR")=".02////"_BMCRIEN_";.03////"_BMCRNUMB_";.04////"_DUZ_";.05////REFERRAL ALERT"
D ^DIC
S DA(1)=+Y,(DIE,DIC)=DIC_DA(1)_",1,",DA=1
I '$D(^BMCREG(DA(1),1)) S ^BMCREG(DA(1),1,0)="^90001.571P^^"
D ^DIC
S BMCGRP=0 F S BMCGRP=$O(BMCGRPS(BMCGRP)) Q:BMCGRP'?1N.N D
.S DR=".01////"_BMCGRP
.D ^DIE
.S $P(^BMCMSG(DA(1),1,0),U,3,4)=DA_U_DA
.S DA=DA+1
EXT K XMB,XMY,XMZ,DIR,DIC,DIE,DA,DR
K BMCMSG,BMCGRP,BMCGRPS,BMCGRP1,BMCL,BMCL1,BMCL2,BMCLDT,BMCTMP
Q
BMCBULL ; IHS/PHXAO/TMJ - RCIS - SEND BULLETIN ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 ;
+3 ;IHS/ITSC/FCJ REMOVED EN4,EN5,EN6 AND EN7
+4 ; COMBINED TO CALL EP ENMM FOR MAILMAN MESSAGES
+5 ; WILL LIST ANY PREVIOUS MESSAGE SENT AND
+6 ; OPTION TO SELECT GROUPS TO SEND MESSAGE TO
+7 ; ALSO STORE HISTORY OF MSG SENT IN RCIS MESSAGE FILE
+8 ;
+9 ; This routine sends bulletins to RCIS users as appropriate.
+10 ;
EN1 ; EP - DX BULLETINS
+1 NEW Y,BMCBULLN,BMCNARR,BMCNODE
+2 IF '$GET(BMCDFN)
QUIT
+3 IF '$GET(BMCRDATE)
QUIT
+4 KILL XMY
+5 IF $DATA(BMCBULLC)
SET BMCBULLN="BMC POTENTIAL HIGH COST DX"
SET BMCNODE=21
SET BMCNARR=$$VAL^XBDIQ1(90001,BMCRIEN,.12)
DO SEND
QUIT
+6 IF $GET(BMCTXL3P)
IF $$TXC^ATXTXCHK(X,BMCTXL3P)
SET BMCBULLN="BMC 3RD PARTY LIABILITY"
SET BMCNARR=$$VAL^XBDIQ1(90001.01,DA,.01)_" "_$$VAL^XBDIQ1(90001.01,DA,.019)
SET BMCNODE=25
DO SEND
+7 IF $GET(BMCTXPHC)
IF $$TXC^ATXTXCHK(X,BMCTXPHC)
SET BMCBULLN="BMC POTENTIAL HIGH COST DX"
SET BMCNARR=$$VAL^XBDIQ1(90001.01,DA,.01)_" "_$$VAL^XBDIQ1(90001.01,DA,.019)
SET BMCNODE=21
DO SEND
QUIT
+8 QUIT
EN2 ;EP - procedure bulletins (high cost, cosmetic, exp)
+1 NEW Y,BMCBULLN,BMCNARR,BMCNODE
+2 IF '$GET(BMCDFN)
QUIT
+3 IF '$GET(BMCRDATE)
QUIT
+4 KILL XMY
+5 IF $GET(BMCTXCHC)
IF $$TXC^ATXTXCHK(X,BMCTXCHC)
SET BMCBULLN="BMC POTENTIAL HIGH COST PROC"
SET BMCNARR=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019)
SET BMCNODE=22
DO SEND
+6 IF $GET(BMCTXCCP)
IF $$TXC^ATXTXCHK(X,BMCTXCCP)
SET BMCBULLN="BMC COSMETIC PROCEDURE"
SET BMCNARR=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019)
SET BMCNODE=23
DO SEND
+7 IF $GET(BMCTXCEX)
IF $$TXC^ATXTXCHK(X,BMCTXCEX)
SET BMCBULLN="BMC EXPERIMENTAL PROCEDURE"
SET BMCNARR=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019)
SET BMCNODE=24
DO SEND
+8 QUIT
SEND ;SEND BULLETIN
+1 KILL XMB
+2 SET XMB=BMCBULLN
+3 SET XMB(1)=BMCREC("PAT NAME")
+4 SET XMB(2)=BMCREC("REF DATE")
+5 SET XMB(3)=BMCRNUMB
+6 SET XMB(4)=""
+7 SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,6)
+8 IF Y
SET XMB(4)=$PIECE(^VA(200,Y,0),U)
+9 SET XMB(5)=$GET(BMCNARR)
+10 KILL XMY
+11 SET Y=0
FOR
SET Y=$ORDER(^BMCPARM(DUZ(2),BMCNODE,Y))
IF Y'=+Y
QUIT
SET %=$PIECE(^BMCPARM(DUZ(2),BMCNODE,Y,0),U)
IF %
IF $PIECE(^BMCPARM(DUZ(2),BMCNODE,Y,0),U,2)]""
IF $PIECE(^(0),U,2)[BMCRTYPE
SET XMY(%)=""
+12 IF '$DATA(XMY)
QUIT
+13 DO ^XMB
+14 KILL XMB,XMY
+15 QUIT
+16 ;
ENX ; EP - POTENTIAL HIGH COST DX
+1 NEW Y
+2 IF '$GET(BMCDFN)
QUIT
+3 IF '$GET(BMCRDATE)
QUIT
+4 KILL XMY
+5 SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,4)
+6 ; quit if type is In-House
IF Y="N"
QUIT
+7 ; quit if type is Other
IF Y="O"
QUIT
+8 ; if CHS send to chs supvr
IF Y="C"
IF BMCCHSS
SET XMY(BMCCHSS)=""
+9 ; if IHS send to business office
IF Y="I"
IF BMCBOS
SET XMY(BMCBOS)=""
+10 ; send to case manager
SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,19)
+11 IF Y
SET XMY(Y)=""
+12 ; quit if no addressees
IF '$DATA(XMY)
QUIT
+13 KILL XMB
+14 SET XMB="BMC POTENTIAL HIGH COST DX"
+15 SET XMB(1)=BMCREC("PAT NAME")
+16 SET XMB(2)=BMCREC("REF DATE")
+17 SET XMB(3)=BMCRNUMB
+18 SET XMB(4)=""
+19 SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,6)
+20 IF Y
SET XMB(4)=$PIECE(^VA(200,Y,0),U)
+21 SET Y=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019)
+22 IF Y]""
SET XMB(5)=Y
+23 DO ^XMB
+24 KILL XMB,XMY
+25 QUIT
+26 ;
EN3 ;EP
+1 NEW Y
+2 IF '$GET(BMCDFN)
QUIT
+3 IF '$GET(BMCRDATE)
QUIT
+4 KILL XMY
+5 SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,4)
+6 ; quit if type is In-House
IF Y="N"
QUIT
+7 ; quit if type is Other
IF Y="O"
QUIT
+8 ; if CHS send to chs supvr
IF Y="C"
IF BMCCHSS
SET XMY(BMCCHSS)=""
+9 ; if IHS send to business office
IF Y="I"
IF BMCBOS
SET XMY(BMCBOS)=""
+10 ; send to case manager
SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,19)
+11 IF Y
SET XMY(Y)=""
+12 ; quit if no addressees
IF '$DATA(XMY)
QUIT
+13 KILL XMB
+14 SET XMB="BMC CPT CATEGORY/PROCEDURE"
+15 SET XMB(1)=BMCREC("PAT NAME")
+16 SET XMB(2)=BMCREC("REF DATE")
+17 SET XMB(3)=BMCRNUMB
+18 SET XMB(4)=""
+19 SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,6)
+20 IF Y
SET XMB(4)=$PIECE(^VA(200,Y,0),U)
+21 SET Y=$$VAL^XBDIQ1(90001,BMCRIEN,.12)
+22 IF Y]""
SET XMB(5)=Y
+23 SET Y=$$VAL^XBDIQ1(90001,BMCRIEN,.13)
+24 IF Y]""
SET XMB(6)=Y
+25 DO ^XMB
+26 KILL XMB,XMY
+27 QUIT
+28 ;
+29 ;IHS/ITSC/FCJ REMOVED EN4,EN5,EN6 AND EN7 ADDED ENMM THROUGH EXT
ENMM ;EP;MESSAGE NEW REF AND MODIFICATIONS
+1 NEW Y,DIC
+2 IF '$GET(BMCDFN)
QUIT
+3 IF '$GET(BMCRDATE)
QUIT
MSG ;TEST FOR EXISTING MESSAGES ALREADY SENT
+1 IF $DATA(^BMCMSG("C",BMCRIEN))
Begin DoDot:1
+2 WRITE !!,"A Message has already been sent for this referral:"
+3 SET BMCMSG=0
WRITE !?3,"DATE",?25,"SENT BY",?55,"GROUP"
+4 FOR
SET BMCMSG=$ORDER(^BMCMSG("C",BMCRIEN,BMCMSG))
IF BMCMSG'?1N.N
QUIT
Begin DoDot:2
+5 SET Y=$PIECE(^BMCMSG(BMCMSG,0),U)
DO DD^%DT
+6 WRITE !?3,Y,?25,$PIECE(^VA(200,$PIECE(^BMCMSG(BMCMSG,0),U,4),0),U)
+7 SET BMCGRP=0
FOR
SET BMCGRP=$ORDER(^BMCMSG(BMCMSG,1,BMCGRP))
IF BMCGRP'?1N.N
QUIT
Begin DoDot:3
+8 SET BMCGRP1=$PIECE(^BMCMSG(BMCMSG,1,BMCGRP,0),U)
+9 WRITE ?55,$PIECE(^XMB(3.8,BMCGRP1,0),U),!
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF '$TEST
WRITE !!,"A Message has NOT been sent for this referral."
+11 SET DIR(0)="Y"
SET DIR("A")="Do you wish to send a message"
SET DIR("B")="Y"
+12 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!'Y
GOTO EXT
MGRP ;SELECT MAIL GROUPS TO SEND MESSAGE TO
+1 ;ENTER THE GROUP TO SEND IT TO AND ADD ENTRY TO THE RCIS MESSAGE FILE
+2 SET BMCGRP="BMC"
SET DIR(0)="S^"
SET Y=0
+3 FOR
SET BMCGRP=$ORDER(^XMB(3.8,"B",BMCGRP))
IF $EXTRACT(BMCGRP,1,3)'="BMC"
QUIT
Begin DoDot:1
+4 SET BMCGRP1=0
SET BMCGRP1=$ORDER(^XMB(3.8,"B",BMCGRP,BMCGRP1))
+5 SET Y=Y+1
SET BMCGRP(Y)=BMCGRP_U_BMCGRP1
End DoDot:1
+6 IF Y=0
WRITE !,"THERE ARE NOT ANY RCIS MAIL GROUPS SET UP.",!,"If you would like to set up a mail group, use Mail Groups Option under the",!,"RCIS Management Menu."
QUIT
+7 FOR I=1:1:Y
WRITE !?5,I_". "_$PIECE(BMCGRP(I),U)
+8 SET DIR("A")="To select recipient group(s) enter a list or range of numbers"
+9 SET DIR(0)="L^1:"_Y
+10 DO ^DIR
IF $DATA(DIRUT)
WRITE !?5,"***MESSAGE WAS NOT SENT***"
GOTO EXT
SNDMSG ;SEND BULLETIN
+1 KILL XMB,XMY
+2 FOR I=1:1
IF $PIECE(Y,",",I)'?1N.N
QUIT
SET XMY("G."_$PIECE(BMCGRP($PIECE(Y,",",I)),U))=""
SET BMCGRPS($PIECE(BMCGRP($PIECE(Y,",",I)),U,2))=""
+3 SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,4)
+4 SET XMZ=""
+5 ;REF IF OPTION SET AND USER ANSWERS YES....
+6 ;Q:Y="N" ;quit if In-House referral ;FCJ REMOVED
+7 ;FCJ NEW BULLETIN
SET XMB="BMC REFERRAL ALERT"
+8 SET XMB(1)=BMCREC("PAT NAME")
+9 SET XMB(2)=BMCREC("REF DATE")
+10 SET XMB(3)=BMCRNUMB
+11 SET XMB(4)=""
+12 SET XMB(5)=$$VAL^XBDIQ1(90001,BMCRIEN,1201)
+13 SET XMB(6)=$$FACREF^BMCRLU(BMCRIEN)
+14 SET XMB(7)=$$VAL^XBDIQ1(90001,BMCRIEN,1301)
+15 SET XMB(8)=$$VAL^XBDIQ1(90001,BMCRIEN,.32)
+16 SET Y=$PIECE(^BMCREF(BMCRIEN,0),U,6)
+17 IF Y
SET XMB(4)=$PIECE(^VA(200,Y,0),U)
+18 SET XMB(9)=$$VAL^XBDIQ1(90001,BMCRIEN,.04)
+19 ;IHS/ITSC/FCJ ADDED BO COM FR RCIS COMMENTS FILE,LIFO DISPLAY
+20 IF $DATA(^BMCCOM("AD",BMCRIEN))
Begin DoDot:1
+21 SET BMCL=0
SET BMCL2=10
+22 FOR
SET BMCL=$ORDER(^BMCCOM("AD",BMCRIEN,BMCL))
IF BMCL'?1N.N
QUIT
Begin DoDot:2
+23 IF $PIECE(^BMCCOM(BMCL,0),U,5)'="B"
QUIT
+24 IF $DATA(^BMCCOM(BMCL,1))
Begin DoDot:3
+25 SET XMB(BMCL2)=" Date: "_$$FMTE^XLFDT($PIECE(^BMCCOM(BMCL,0),U),"5D")_" By: "_$$VAL^XBDIQ1(90001.03,BMCL,.04)
+26 SET BMCL1=0
+27 FOR
SET BMCL1=$ORDER(^BMCCOM(BMCL,1,BMCL1))
IF BMCL1'?1N.N
QUIT
Begin DoDot:4
+28 SET BMCL2=BMCL2+1
+29 SET XMB(BMCL2)=^BMCCOM(BMCL,1,BMCL1,0)
End DoDot:4
End DoDot:3
+30 SET BMCL2=BMCL2+1
End DoDot:2
End DoDot:1
+31 DO EN^XMB
+32 IF $DATA(XMB)
WRITE !?5,"***ERROR: NO MESSAGE SENT***"
GOTO EXT
+33 WRITE !?5,"***MESSAGE SENT***"
ADD ;IF MESSAGE SENT ADD TO RCIS MESSAGE FILE
+1 SET (DIE,DIC)="^BMCMSG("
SET DIC(0)="L"
+2 DO NOW^%DTC
SET X=%
+3 SET DIC("DR")=".02////"_BMCRIEN_";.03////"_BMCRNUMB_";.04////"_DUZ_";.05////REFERRAL ALERT"
+4 DO ^DIC
+5 SET DA(1)=+Y
SET (DIE,DIC)=DIC_DA(1)_",1,"
SET DA=1
+6 IF '$DATA(^BMCREG(DA(1),1))
SET ^BMCREG(DA(1),1,0)="^90001.571P^^"
+7 DO ^DIC
+8 SET BMCGRP=0
FOR
SET BMCGRP=$ORDER(BMCGRPS(BMCGRP))
IF BMCGRP'?1N.N
QUIT
Begin DoDot:1
+9 SET DR=".01////"_BMCGRP
+10 DO ^DIE
+11 SET $PIECE(^BMCMSG(DA(1),1,0),U,3,4)=DA_U_DA
+12 SET DA=DA+1
End DoDot:1
EXT KILL XMB,XMY,XMZ,DIR,DIC,DIE,DA,DR
+1 KILL BMCMSG,BMCGRP,BMCGRPS,BMCGRP1,BMCL,BMCL1,BMCL2,BMCLDT,BMCTMP
+2 QUIT
