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

BMCBULL.m

Go to the documentation of this file.
  1. BMCBULL ; IHS/PHXAO/TMJ - RCIS - SEND BULLETIN ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
  1. ;
  1. ;IHS/ITSC/FCJ REMOVED EN4,EN5,EN6 AND EN7
  1. ; COMBINED TO CALL EP ENMM FOR MAILMAN MESSAGES
  1. ; WILL LIST ANY PREVIOUS MESSAGE SENT AND
  1. ; OPTION TO SELECT GROUPS TO SEND MESSAGE TO
  1. ; ALSO STORE HISTORY OF MSG SENT IN RCIS MESSAGE FILE
  1. ;
  1. ; This routine sends bulletins to RCIS users as appropriate.
  1. ;
  1. EN1 ; EP - DX BULLETINS
  1. NEW Y,BMCBULLN,BMCNARR,BMCNODE
  1. Q:'$G(BMCDFN)
  1. Q:'$G(BMCRDATE)
  1. K XMY
  1. I $D(BMCBULLC) S BMCBULLN="BMC POTENTIAL HIGH COST DX",BMCNODE=21,BMCNARR=$$VAL^XBDIQ1(90001,BMCRIEN,.12) D SEND Q
  1. 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
  1. 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
  1. Q
  1. EN2 ;EP - procedure bulletins (high cost, cosmetic, exp)
  1. NEW Y,BMCBULLN,BMCNARR,BMCNODE
  1. Q:'$G(BMCDFN)
  1. Q:'$G(BMCRDATE)
  1. K XMY
  1. 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
  1. 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
  1. 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
  1. Q
  1. SEND ;SEND BULLETIN
  1. K XMB
  1. S XMB=BMCBULLN
  1. S XMB(1)=BMCREC("PAT NAME")
  1. S XMB(2)=BMCREC("REF DATE")
  1. S XMB(3)=BMCRNUMB
  1. S XMB(4)=""
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,6)
  1. S:Y XMB(4)=$P(^VA(200,Y,0),U)
  1. S XMB(5)=$G(BMCNARR)
  1. K XMY
  1. 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(%)=""
  1. Q:'$D(XMY)
  1. D ^XMB
  1. K XMB,XMY
  1. Q
  1. ;
  1. ENX ; EP - POTENTIAL HIGH COST DX
  1. NEW Y
  1. Q:'$G(BMCDFN)
  1. Q:'$G(BMCRDATE)
  1. K XMY
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,4)
  1. Q:Y="N" ; quit if type is In-House
  1. Q:Y="O" ; quit if type is Other
  1. I Y="C",BMCCHSS S XMY(BMCCHSS)="" ; if CHS send to chs supvr
  1. I Y="I",BMCBOS S XMY(BMCBOS)="" ; if IHS send to business office
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,19) ; send to case manager
  1. I Y S XMY(Y)=""
  1. Q:'$D(XMY) ; quit if no addressees
  1. K XMB
  1. S XMB="BMC POTENTIAL HIGH COST DX"
  1. S XMB(1)=BMCREC("PAT NAME")
  1. S XMB(2)=BMCREC("REF DATE")
  1. S XMB(3)=BMCRNUMB
  1. S XMB(4)=""
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,6)
  1. S:Y XMB(4)=$P(^VA(200,Y,0),U)
  1. S Y=$$VAL^XBDIQ1(90001.02,DA,.01)_" "_$$VAL^XBDIQ1(90001.02,DA,.019)
  1. S:Y]"" XMB(5)=Y
  1. D ^XMB
  1. K XMB,XMY
  1. Q
  1. ;
  1. EN3 ;EP
  1. NEW Y
  1. Q:'$G(BMCDFN)
  1. Q:'$G(BMCRDATE)
  1. K XMY
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,4)
  1. Q:Y="N" ; quit if type is In-House
  1. Q:Y="O" ; quit if type is Other
  1. I Y="C",BMCCHSS S XMY(BMCCHSS)="" ; if CHS send to chs supvr
  1. I Y="I",BMCBOS S XMY(BMCBOS)="" ; if IHS send to business office
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,19) ; send to case manager
  1. I Y S XMY(Y)=""
  1. Q:'$D(XMY) ; quit if no addressees
  1. K XMB
  1. S XMB="BMC CPT CATEGORY/PROCEDURE"
  1. S XMB(1)=BMCREC("PAT NAME")
  1. S XMB(2)=BMCREC("REF DATE")
  1. S XMB(3)=BMCRNUMB
  1. S XMB(4)=""
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,6)
  1. S:Y XMB(4)=$P(^VA(200,Y,0),U)
  1. S Y=$$VAL^XBDIQ1(90001,BMCRIEN,.12)
  1. S:Y]"" XMB(5)=Y
  1. S Y=$$VAL^XBDIQ1(90001,BMCRIEN,.13)
  1. S:Y]"" XMB(6)=Y
  1. D ^XMB
  1. K XMB,XMY
  1. Q
  1. ;
  1. ;IHS/ITSC/FCJ REMOVED EN4,EN5,EN6 AND EN7 ADDED ENMM THROUGH EXT
  1. ENMM ;EP;MESSAGE NEW REF AND MODIFICATIONS
  1. NEW Y,DIC
  1. Q:'$G(BMCDFN)
  1. Q:'$G(BMCRDATE)
  1. MSG ;TEST FOR EXISTING MESSAGES ALREADY SENT
  1. I $D(^BMCMSG("C",BMCRIEN)) D
  1. .W !!,"A Message has already been sent for this referral:"
  1. .S BMCMSG=0 W !?3,"DATE",?25,"SENT BY",?55,"GROUP"
  1. .F S BMCMSG=$O(^BMCMSG("C",BMCRIEN,BMCMSG)) Q:BMCMSG'?1N.N D
  1. ..S Y=$P(^BMCMSG(BMCMSG,0),U) D DD^%DT
  1. ..W !?3,Y,?25,$P(^VA(200,$P(^BMCMSG(BMCMSG,0),U,4),0),U)
  1. ..S BMCGRP=0 F S BMCGRP=$O(^BMCMSG(BMCMSG,1,BMCGRP)) Q:BMCGRP'?1N.N D
  1. ...S BMCGRP1=$P(^BMCMSG(BMCMSG,1,BMCGRP,0),U)
  1. ...W ?55,$P(^XMB(3.8,BMCGRP1,0),U),!
  1. E W !!,"A Message has NOT been sent for this referral."
  1. S DIR(0)="Y",DIR("A")="Do you wish to send a message",DIR("B")="Y"
  1. D ^DIR K DIR I $D(DIRUT)!'Y G EXT
  1. MGRP ;SELECT MAIL GROUPS TO SEND MESSAGE TO
  1. ;ENTER THE GROUP TO SEND IT TO AND ADD ENTRY TO THE RCIS MESSAGE FILE
  1. S BMCGRP="BMC",DIR(0)="S^",Y=0
  1. F S BMCGRP=$O(^XMB(3.8,"B",BMCGRP)) Q:$E(BMCGRP,1,3)'="BMC" D
  1. .S BMCGRP1=0 S BMCGRP1=$O(^XMB(3.8,"B",BMCGRP,BMCGRP1))
  1. .S Y=Y+1,BMCGRP(Y)=BMCGRP_U_BMCGRP1
  1. 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
  1. F I=1:1:Y W !?5,I_". "_$P(BMCGRP(I),U)
  1. S DIR("A")="To select recipient group(s) enter a list or range of numbers"
  1. S DIR(0)="L^1:"_Y
  1. D ^DIR I $D(DIRUT) W !?5,"***MESSAGE WAS NOT SENT***" G EXT
  1. SNDMSG ;SEND BULLETIN
  1. K XMB,XMY
  1. 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))=""
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,4)
  1. S XMZ=""
  1. ;REF IF OPTION SET AND USER ANSWERS YES....
  1. ;Q:Y="N" ;quit if In-House referral ;FCJ REMOVED
  1. S XMB="BMC REFERRAL ALERT" ;FCJ NEW BULLETIN
  1. S XMB(1)=BMCREC("PAT NAME")
  1. S XMB(2)=BMCREC("REF DATE")
  1. S XMB(3)=BMCRNUMB
  1. S XMB(4)=""
  1. S XMB(5)=$$VAL^XBDIQ1(90001,BMCRIEN,1201)
  1. S XMB(6)=$$FACREF^BMCRLU(BMCRIEN)
  1. S XMB(7)=$$VAL^XBDIQ1(90001,BMCRIEN,1301)
  1. S XMB(8)=$$VAL^XBDIQ1(90001,BMCRIEN,.32)
  1. S Y=$P(^BMCREF(BMCRIEN,0),U,6)
  1. S:Y XMB(4)=$P(^VA(200,Y,0),U)
  1. S XMB(9)=$$VAL^XBDIQ1(90001,BMCRIEN,.04)
  1. ;IHS/ITSC/FCJ ADDED BO COM FR RCIS COMMENTS FILE,LIFO DISPLAY
  1. I $D(^BMCCOM("AD",BMCRIEN)) D
  1. .S BMCL=0,BMCL2=10
  1. .F S BMCL=$O(^BMCCOM("AD",BMCRIEN,BMCL)) Q:BMCL'?1N.N D
  1. ..Q:$P(^BMCCOM(BMCL,0),U,5)'="B"
  1. ..I $D(^BMCCOM(BMCL,1)) D
  1. ...S XMB(BMCL2)=" Date: "_$$FMTE^XLFDT($P(^BMCCOM(BMCL,0),U),"5D")_" By: "_$$VAL^XBDIQ1(90001.03,BMCL,.04)
  1. ...S BMCL1=0
  1. ...F S BMCL1=$O(^BMCCOM(BMCL,1,BMCL1)) Q:BMCL1'?1N.N D
  1. ....S BMCL2=BMCL2+1
  1. ....S XMB(BMCL2)=^BMCCOM(BMCL,1,BMCL1,0)
  1. ..S BMCL2=BMCL2+1
  1. D EN^XMB
  1. I $D(XMB) W !?5,"***ERROR: NO MESSAGE SENT***" G EXT
  1. W !?5,"***MESSAGE SENT***"
  1. ADD ;IF MESSAGE SENT ADD TO RCIS MESSAGE FILE
  1. S (DIE,DIC)="^BMCMSG(",DIC(0)="L"
  1. D NOW^%DTC S X=%
  1. S DIC("DR")=".02////"_BMCRIEN_";.03////"_BMCRNUMB_";.04////"_DUZ_";.05////REFERRAL ALERT"
  1. D ^DIC
  1. S DA(1)=+Y,(DIE,DIC)=DIC_DA(1)_",1,",DA=1
  1. I '$D(^BMCREG(DA(1),1)) S ^BMCREG(DA(1),1,0)="^90001.571P^^"
  1. D ^DIC
  1. S BMCGRP=0 F S BMCGRP=$O(BMCGRPS(BMCGRP)) Q:BMCGRP'?1N.N D
  1. .S DR=".01////"_BMCGRP
  1. .D ^DIE
  1. .S $P(^BMCMSG(DA(1),1,0),U,3,4)=DA_U_DA
  1. .S DA=DA+1
  1. EXT K XMB,XMY,XMZ,DIR,DIC,DIE,DA,DR
  1. K BMCMSG,BMCGRP,BMCGRPS,BMCGRP1,BMCL,BMCL1,BMCL2,BMCLDT,BMCTMP
  1. Q