- 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