BMCMOD ; IHS/PHXAO/TMJ - MODIFY A REFERRAL 1 OF 2 ; [ 08/22/2006 11:07 AM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2,3,6,8,9,12**;JAN 09, 2006;Build 101
;
;IHS/ITSC/FCJ ADDED OPTION TO REDISPLAY PAT REF'S
; NEW OPTION TO SEND BULLETIN;DATE/USER STAMPED ADDING COMMENTS
; FOR BUS OFF, DSCH NOTES AND MED HX;BUS OFF OPT CHGD TO REQUEST
; COMMENTS ONLY;TEST OF 7 & 9 TO ALLOW EDIT FROM MENU FOR BOC & CASE
; COM;MOD CHS ELIG EDIT FOR BUS OFF COM ; ADDED MENU OPTION
;4.0 IHS/OIT/FCJ ADDED 0 TO FILTER AND PRNT REVIEWER
; This option allows the user to select and modify referrals.
;4.0*2 8.22.06 IHS.OIT.FCJ NO LONGER ALLOW EDIT OF PHY NOTES
;BMC*4.0*3 10.1.2007 IHS/ITSC/FCJ ADDED OPT 16 ALERT TO PHYS
;BMC*4.0*12 IHS/OIT/FCJ CHANGED TEMPLATES FOR CALL IN TYPE
;
; See ^BMCVDOC for system wide variables set by main menu
;
START ;
D:'$D(BMCPARM) PARMCHK^BMC
F D MAIN Q:BMCQ D HDR^BMC
D EOJ
Q
MAIN ;
S BMCQ=0,BMCMODE="M"
D REFERRAL ; get referral record to modify
Q:BMCQ
S BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N") S:+BMCDOS<1 BMCDOS=$P(^BMCREF(BMCRIEN,0),U) ;BMC*4.0*9
;BMC*4.0*6 IHS.OIT.FCJ COMBINED LINES FOR MENU OPTION CALLS
;I $G(BMCDTYPE)=7 D 7 Q
;I $G(BMCDTYPE)=9 D 9 Q
;I $G(BMCDTYPE)=10 D 10 Q
D GETSNO^BMCADD3 ;BMC*4.0*8
I $G(BMCDTYPE) D @BMCDTYPE Q
I BMCCHSE=1 D CHS
Q:BMCCHSE=1
F D TYPE Q:BMCQ ; modify referral
D PCCL
I BMCDTYPE=13 S BMCQ=0
Q
REFERRAL ; GET REFERRAL TO MODIFY
I BMCCLOSE=1 D SCREEN Q
I BMCCLOSE="" D GETREF Q
I BMCCHSE=1 D GETREF Q
GETREF ;Screens out closed Referrals
S BMCRTY=0 I BMCCHSE=1 S BMCRTY=2
S BMCQ=1
W !
S DIC="^BMCREF(",DIC("S")="I $$FILTER^BMCFLTR(0,BMCCURFY,BMCRTY)",DIC(0)="AEMQ",DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
D DIC^BMCFMC
Q:Y<1
S BMCRIEN=+Y
S BMCQ=0
Q
;
SCREEN ;Display ONLY CLOSED Referrals
S BMCQ=1
W !
S DIC="^BMCREF(",DIC("S")="I $$FILTER^BMCFLTR(1,BMCCURFY,0)",DIC(0)="AEMQ",DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
D DIC^BMCFMC
Q:Y<1
S BMCRIEN=+Y
S BMCQ=0
Q
;
CHS ;Enter CHS Data with Screenman
S DDSFILE=90001,DA=BMCRIEN,DR=$S(BMCRIO="I":"[BMC CHS ADD]",1:"[BMC CHS ADD]"),DDSPARM="C"
D DDS^BMCFMC
I BMCRIO="I" D D:+Y>0 DENR^BMCCHSE
.S DIR("A")="Do you wish to EDIT Denial Reasons",DIR(0)="Y",DIR("B")="NO" ;BMC*4.0*8 ADD DENIAL EDIT
.D ^DIR K DIR
Q
TYPE ; EP - Get type of data to edit
S BMCQ=1,BMCDTYPE=""
;BMC*4.0*9 CHNG ICD9 TO ICD IN NXT LINE
S DIR(0)="SO^0:QUIT;1:MINI MOD;2:ALL DATA;3:DATE/COUNTS;4:COSTS;5:ICD DX;6:CPT PROCEDURES;7:CASE REVIEW;8:PURPOSE/MED HX/OTHER DX INFO;9:BUSINESS OFFICE;10:DISCHARGE NOTES;11:ADD DOCUMENTATION;12:CHS ELIG FACTORS;13:OTHER REFERRALS"
;BMC*4.0*3 10.1.2007 IHS/ITSC/FCJ ADDED OPT 16 TO NXT LINE;4.0*8 7.10.13 IHS.OIT.FCJ ADDED OPT 17
S DIR(0)=DIR(0)_";14:SEND GROUP MESSAGE;15:SEND MESSAGE TO PROVIDERS;16:SEND ALERT TO PROVIDERS;17:APPROVE REFERRAL"
S DIR("A")="EDIT Which Data Type",DIR("B")="0" K DA D ^DIR K DIR
Q:$D(DIRUT)
Q:'Y
S BMCDTYPE=+Y
D @BMCDTYPE
I BMCDTYPE=13 Q
S BMCQ=0
Q
;
MINIMOD ; REFERRAL MINI MODIFICATION FORM
1 ; LABEL FOR @DO
;BMC*4.0*12 IHS/OIT/FCJ ADDED TEST FOR CALLIN TYPE
;S DDSFILE=90001,DA=BMCRIEN,DR="[BMCX REFERRAL ADD]",DDSPARM="C"
S DDSFILE=90001,DA=BMCRIEN,DR=$S($P($G(^BMCREF(BMCRIEN,1)),U,3)?1N.N:"[BMC REF ADD CALL-IN]",1:"[BMCX REFERRAL ADD]"),DDSPARM="C"
D DDS^BMCFMC
I BMCVREF D VREFP D:BMCRSTAT="A" VREF ;BMC*4.0*8 CHECK FOR CHANGE OF SNOMED CD
E D SNO
D 80
S Y=BMCRIEN
D ^BMCREF
Q
ALLDATA ; MODIFY ALL REFERRAL DATA
2 ; LABEL FOR @DO
S BMCTMP=BMCMODE,BMCMODE="E"
;BMC*4.0*12 IHS/OIT/FCJ ADDED TEST FOR CALLIN TYPE
;S DDSFILE=90001,DA=BMCRIEN,DR="[BMC REFERRAL MOD]",DDSPARM="C"
S DDSFILE=90001,DA=BMCRIEN,DR=$S($P($G(^BMCREF(BMCRIEN,1)),U,3)?1N.N:"[BMC REF ADD CALL-IN]",1:"[BMC REFERRAL MOD]"),DDSPARM="C"
D DDS^BMCFMC
S Y=BMCRIEN
D ^BMCREF ; set standard variables from record
F X=4,5,6,80 D @X Q:$D(DIRUT) ; edit all other data
I BMCVREF D VREFP D:BMCRSTAT="A" VREF ;BMC*4.0*8 CHECK FOR CHANGE OF SNOMED CD
E D SNO
S BMCMODE=BMCTMP
Q
;
S DDSFILE=90001,DA=BMCRIEN,DR="[BMC MODIFY COST INFORMATION]",DDSPARM="C"
D DDS^BMCFMC
Q
;
DATES ; MODIFY DATE FIELDS
3 ; LABEL FOR @DO
S DDSFILE=90001,DA=BMCRIEN,DR=$S(BMCRIO="I":"[BMC MODIFY DATES (INPT)]",1:"[BMC MODIFY DATES (OUPT)]"),DDSPARM="C"
D DDS^BMCFMC
Q
;
COST ;MODIFY COST FIELDS
4 ; LABEL FOR @DO
S DDSFILE=90001,DA=BMCRIEN,DR="[BMC MODIFY COST INFORMATION]",DDSPARM="C"
D DDS^BMCFMC
Q
;
DX ; EP - EDIT DIAGNOSES EDIT DIAGNOSES
5 ; LABEL FOR @DO
S APCDOVRR=""
S BMCV="DX",BMCTERM="Diagnoses",BMCATEMP="[BMC DIAGNOSIS ADD]",BMCG="^BMCDX(",BMCETEMP="[BMC DIAGNOSIS EDIT]"
S BMCCTYP="DX"
D ASK
Q
;
PROC ; EP - EDIT PROCEDURES
6 ; LABEL FOR @DO
S BMCV="PROC",BMCTERM="Procedures",BMCATEMP="[BMC PROCEDURE ADD]",BMCG="^BMCPX(",BMCETEMP="[BMC PROCEDURE EDIT]"
S BMCCTYP="P"
D ASK
Q
;
7 ; LABEL FOR @DO
S BMCV="COM",BMCTERM="Case Review Comments",BMCATEMP="[BMC COMMENTS ADD]",BMCG="^BMCCOM(",BMCETEMP="[BMC COMMENTS EDIT]"
S BMCCTYP="C"
D ASK
S DIE="^BMCREF(",DA=BMCRIEN,DR=".31" ; get next review date
D DIE^BMCFMC
Q
;
PURPOSE ; EDIT PURPOSE OF REFERRAL
8 ; LABEL FOR @DO
S DDSFILE=90001,DA=BMCRIEN,DR="[BMC MODIFY MEDICAL INFO]",DDSPARM="C"
D DDS^BMCFMC
;IHS/ITSC/FCJ REMOVED BUSINESS, DISCHARGE, MED HX FROM
;SCREENMAN TEMPLATE WILL NOW ASK INDIVIDUALLY ADDED NXT 6 LNS
80 ;EP FROM 2ND REF AND FR MED HX MENU OPTION
S BMCV="COM",BMCTERM="Medical HX/Findings Comments",BMCATEMP="[BMC COMMENTS ADD]",BMCG="^BMCCOM(",BMCETEMP="[BMC COMMENTS EDIT]"
S BMCCTYP="M"
D ASK
Q:(BMCDTYPE=1)!(BMCDTYPE=8)!(BMCDTYPE=80) ;BMC*4.0*6 4.22.2010 IHS.OIT.FCJ ADDED TEST FOR BMCDTYPE=80
F X=10,9 D @X Q:$D(DIRUT)
Q
;
BUSINESS ; EDIT BUSINESS OFFICE COMMENTS
9 ; LABEL FOR @DO
;IHS/ITSC/FCJ CHG TO ASK FOR ONLY BO COMMENTS
S BMCV="COM",BMCTERM="Business Office Comment",BMCATEMP="[BMC COMMENTS ADD]",BMCG="^BMCCOM(",BMCETEMP="[BMC COMMENTS EDIT]"
S BMCCTYP="B"
D ASK
Q
;
DSCHARGE ; EDIT DISCHARGE NOTES
10 ; LABEL FOR @DO
;IHS/ITSC/FCJ CHG TO ADD COMMENTS TO COMMENT FILE W/USER & DATE STAMP
S BMCV="COM",BMCTERM="Discharge Notes Comments",BMCATEMP="[BMC COMMENTS ADD]",BMCG="^BMCCOM(",BMCETEMP="[BMC COMMENTS EDIT]"
S BMCCTYP="D"
D ASK
S DIE="^BMCREF(",DA=BMCRIEN,DR=".18" ; get ltr release date
D DIE^BMCFMC
Q
;
ADDLDOC ; EDIT LIST OF ADDITIONAL DOCUMENTATION TO BE INCLUDED WITH REFERRAL
11 ; LABEL FOR @DO
S DDSFILE=90001,DA=BMCRIEN,DR="[BMC ADDITIONAL DOC]"
D DDS^BMCFMC
Q
FACTOR ;CHS ELIG FACTORS
12 ; LABEL FOR @DO
S DDSFILE=90001,DA=BMCRIEN,DR="[BMC CHS ELIGIBILITY]",DDSPARM="C"
D DDS^BMCFMC
S BMCV="COM",BMCTERM="Business Office Comments",BMCATEMP="[BMC COMMENTS ADD]",BMCG="^BMCCOM(",BMCETEMP="[BMC COMMENTS EDIT]"
S BMCCTYP="B"
D ASK
Q
REF ;IHS/ITSC/FCJ ADD 13TH OPTION TO ALLOW SELECTING OTHER REF FOR PATIENT
13 ;LABEL FOR @DO
S DIC("B")=BMCREC("PAT NAME")
Q
ALERT ;Mail Bulletin Alerts
14 ;IHS/ITSC/FCJ ADD 14TH OPT TO ALLOW SENDING MAILMAN MESSAGE
W @IOF
;I 'BMCCHSA,BMCRTYPE="C" D ER Q
;I 'BMCIHSA,BMCRTYPE="I" D ER Q
;I 'BMCOTHRA,BMCRTYPE="O" D ER Q
;I 'BMCHOUSA,BMCRTYPE="N" D ER Q
;I 'BMCCHSA,'BMCIHSA,'BMCOTHRA,'BMCHOUSA D ER Q
D ENMM^BMCMM
Q
15 ;IHS/ITSC/FCJ ADD 15TH OPT TO ALLOW SENDING MAILMAN MESSAGE TO PRIM
;AND REF PROVIDER ONLY
D ENMM^BMCMM
Q
16 ;BMC*4.0*3 10.1.2007 IHS/ITSC/FCJ ADD 16TH OPT TO ALLOW TO PRIM AND REF PROVIDER ONLY
S BMCPPRV=$P(^AUPNPAT(BMCDFN,0),U,14),BMCRPRV=$P(^BMCREF(BMCRIEN,0),U,6),BMCRHDR="Updated"
S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you wish to send alert to the Referring Provider"
W ! D ^DIR K DIR Q:$D(DUOUT)
NEW XQA
I Y>0 S XQA(BMCRPRV)=""
;TEST FOR PAT PRIM PROV
I BMCPPRV'="",BMCPPRV'=BMCRPRV D
.S DIR(0)="Y",DIR("B")="Y",DIR("A")="Patient's Primary Provider is different then the Referring Physician, do you want to send alert to the Primary Provider"
.W ! D ^DIR K DIR Q:($D(DUOUT))!(Y=0)
.S XQA(BMCPPRV)=""
I $D(XQA) D PALRT1^BMCALERT
Q
17 ;EP BMCMODS;BMC 4.0*8 5.8.13 IHS/OIT/FCJ ADDED OPTION TO UPDATE STATUS TO A1-APPROVED
S BMCSTAT=""
K DIR
I $P(^BMCREF(BMCRIEN,0),U,15)'="A" D Q
.W !,"Referral status can only be changed from Active to Approved,",!?10,"Referral Status: ",$$VAL^XBDIQ1(90001,BMCRIEN,.15)
.D PAUSE^BMC
W !!
S DIR(0)="SOA^A:ACTIVE;A1:APPROVED",DIR("?")="Set to Approved if patient will receive referred services even if denied by CHS"
S DIR("A")="Enter Referral Status: ACTIVE// "
S DIR("A",1)=" Referral Status: "_$$VAL^XBDIQ1(90001,BMCRIEN,.15)
S DIR("A",2)=""
S DIR("A",3)="Select A1 to Approve the Referral"
S DIR("A",4)=" A ACTIVE"
S DIR("A",5)=" A1 APPROVAL"
D ^DIR K DIR
Q:X'="A1"
S BMCSTAT=Y
S DIE="^BMCREF(",DR=".15////"_BMCSTAT,DA=BMCRIEN
D DIE^BMCFMC
Q
ER W !,"Parameters have not been set up to send messages for this type of Referral." H 1
Q
ASK ;EP
S BMCDF=$S($G(BMCCLOSE):"A",1:"E")
F D ASK2 Q:BMCQ
Q
;
ASK2 ;IHS/ITSC/FCJ MODIFED TO NOT ALLOW EDITING OR DELETING OF BO COMMENTS
S BMCQ=1
W:$D(IOF) @IOF
;4.0*2 8.22.06 IHS.OIT.FCJ NO LONGER ALLOW EDIT OF PHY NOTES
I (BMCCTYP="B")!(BMCCTYP="M"),'$G(BMCSUP) W !!,"You may add a new "_BMCTERM,!
E W !!,"You may edit one of the existing "_BMCTERM_" or add a new one",!
S BMCNONE=0
D @("DISP"_BMCV_"^BMCMOD1")
;4.0*2 8.22.06 IHS.OIT.FCJ NO LONGER ALLOW EDIT OF PHY NOTES
I (BMCCTYP="B")!(BMCCTYP="M"),'$G(BMCSUP) S BMCNONE=1
;add or edit one of above
W !
I BMCNONE S DIR(0)="S^A:ADD a new "_BMCTERM,BMCDF="Q" W:BMCCTYP'="B" !," No entries to edit",! I 1
E S DIR(0)="S^E:EDIT one of the above "_BMCTERM_";A:ADD a new "_BMCTERM_";D:DELETE one of the above "_BMCTERM
S DIR(0)=DIR(0)_";Q:QUIT"
;S DIR("A")="Do you wish to",DIR("B")=$S(BMCDF="E":"Q",1:"A") ;4.0 7.11.05 IHS/ITSC/FCJ ADDED TEST FOR MODE TO DEFAULT TO Q ON COMMENTS
S DIR("A")="Do you wish to",DIR("B")=$S(BMCMODE="E":"Q",BMCDF="E":"Q",1:"A")
D ^DIR K DIR
Q:$D(DIRUT)
Q:Y="Q"
D @Y
S:'$G(BMCCLOSE) BMCDF="Q"
S BMCQ=0
Q
;
E ;edit an existing XXX
D @("DISP"_BMCV_"^BMCMOD1")
W ! S DIR(0)="N^1:"_BMCC_":",DIR("A")="Which One do you wish to EDIT" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
Q:'Y
S BMCC=+Y
I '$D(BMCRDX(BMCC)) W !!,"Invalid choice." Q
S DA=BMCRDX(BMCC),DIE=BMCG,DR=BMCETEMP
D DIE^BMCFMC
I $D(Y) W !!,"ERROR ENCOUNTERED IN EDITING A "_BMCTERM Q
Q
;
A ;add a new XXX
S BMCLOOK=1
W !!,"Adding a NEW "_BMCTERM_"...",!
I BMCV="COM" D COMMENTS^BMCADD1 Q
I BMCV="DX" D ADDDX^BMCMOD1 Q ;BMC*4.0*9 ADDED TO CALL LEXICON
I BMCV="PROC" D ADDPX^BMCMOD1 Q ;BMC*4.0*9 ADDED
S DIE="^BMCREF(",DR=BMCATEMP,DA=BMCRIEN
D DIE^BMCFMC
I $D(Y) W !!,"NO "_BMCTERM_" ADDED!"
K BMCLOOK
Q
;
D ;delete XXX
D @("DISP"_BMCV_"^BMCMOD1")
S DIR(0)="N^1:"_BMCC_":",DIR("A")="Which One do you wish to DELETE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
Q:'Y
S BMCC=+Y
I '$D(BMCRDX(BMCC)) W !!,"Invalid choice." Q
;
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this "_BMCTERM,DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
I 'Y W !,"Okay, not deleted." Q
S DA=BMCRDX(BMCC),DIK=BMCG D DIK^BMCFMC W !,BMCTERM_" DELETED" Q
Q
;
PCCL ; PCC LINK
I $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1" D ^BMCPCCL
Q
;
VREF ;EP FR BMCMODS;BMC*4.0*8 NEW MODULE TO UPDATE SNOMED IN V REF FILE
Q:$P(^AUPNVREF(BMCVREF,0),U)=BMCSCOD
S DIE="^AUPNVREF(",DA=BMCVREF,DR=".01///"_BMCSCOD_";1218////"_$$NOW^XLFDT
D DIE^BMCFMC
Q
VREFP ;BMC*4.0*8 NEW MODULE TO UPDATE PROV IN V REF FILE
Q:$P(^AUPNVREF(BMCVREF,12),U,2)=$P(^BMCREF(BMCRIEN,0),U,6)
S DIE="^AUPNVREF(",DA=BMCVREF,DR="1202////"_$P(^BMCREF(BMCRIEN,0),U,6)_";1218////"_$$NOW^XLFDT
D DIE^BMCFMC
K DIE,DR,X,DA
Q
SNO ;EP FROM BMCMODS;BMC*4.0*9 NEW MODULE TO ADD SNOMED FOR SITES W/O PCC
Q:BMCSCOD=$P($G(^BMCREF(BMCRIEN,22,1,0)),U)
S DR=".01///"_BMCSCOD
S DIE="^BMCREF("_BMCRIEN_",22,",DA=1
D DIE^BMCFMC
K DIE,DR,X,DA
Q
;
EOJ ; END OF JOB
K BMCRTY
D ^BMCKILL
D ^XBFMK
Q
BMCMOD ; IHS/PHXAO/TMJ - MODIFY A REFERRAL 1 OF 2 ; [ 08/22/2006 11:07 AM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2,3,6,8,9,12**;JAN 09, 2006;Build 101
+2 ;
+3 ;IHS/ITSC/FCJ ADDED OPTION TO REDISPLAY PAT REF'S
+4 ; NEW OPTION TO SEND BULLETIN;DATE/USER STAMPED ADDING COMMENTS
+5 ; FOR BUS OFF, DSCH NOTES AND MED HX;BUS OFF OPT CHGD TO REQUEST
+6 ; COMMENTS ONLY;TEST OF 7 & 9 TO ALLOW EDIT FROM MENU FOR BOC & CASE
+7 ; COM;MOD CHS ELIG EDIT FOR BUS OFF COM ; ADDED MENU OPTION
+8 ;4.0 IHS/OIT/FCJ ADDED 0 TO FILTER AND PRNT REVIEWER
+9 ; This option allows the user to select and modify referrals.
+10 ;4.0*2 8.22.06 IHS.OIT.FCJ NO LONGER ALLOW EDIT OF PHY NOTES
+11 ;BMC*4.0*3 10.1.2007 IHS/ITSC/FCJ ADDED OPT 16 ALERT TO PHYS
+12 ;BMC*4.0*12 IHS/OIT/FCJ CHANGED TEMPLATES FOR CALL IN TYPE
+13 ;
+14 ; See ^BMCVDOC for system wide variables set by main menu
+15 ;
START ;
+1 IF '$DATA(BMCPARM)
DO PARMCHK^BMC
+2 FOR
DO MAIN
IF BMCQ
QUIT
DO HDR^BMC
+3 DO EOJ
+4 QUIT
MAIN ;
+1 SET BMCQ=0
SET BMCMODE="M"
+2 ; get referral record to modify
DO REFERRAL
+3 IF BMCQ
QUIT
+4 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N")
IF +BMCDOS<1
SET BMCDOS=$PIECE(^BMCREF(BMCRIEN,0),U)
+5 ;BMC*4.0*6 IHS.OIT.FCJ COMBINED LINES FOR MENU OPTION CALLS
+6 ;I $G(BMCDTYPE)=7 D 7 Q
+7 ;I $G(BMCDTYPE)=9 D 9 Q
+8 ;I $G(BMCDTYPE)=10 D 10 Q
+9 ;BMC*4.0*8
DO GETSNO^BMCADD3
+10 IF $GET(BMCDTYPE)
DO @BMCDTYPE
QUIT
+11 IF BMCCHSE=1
DO CHS
+12 IF BMCCHSE=1
QUIT
+13 ; modify referral
FOR
DO TYPE
IF BMCQ
QUIT
+14 DO PCCL
+15 IF BMCDTYPE=13
SET BMCQ=0
+16 QUIT
REFERRAL ; GET REFERRAL TO MODIFY
+1 IF BMCCLOSE=1
DO SCREEN
QUIT
+2 IF BMCCLOSE=""
DO GETREF
QUIT
+3 IF BMCCHSE=1
DO GETREF
QUIT
GETREF ;Screens out closed Referrals
+1 SET BMCRTY=0
IF BMCCHSE=1
SET BMCRTY=2
+2 SET BMCQ=1
+3 WRITE !
+4 SET DIC="^BMCREF("
SET DIC("S")="I $$FILTER^BMCFLTR(0,BMCCURFY,BMCRTY)"
SET DIC(0)="AEMQ"
SET DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
+5 DO DIC^BMCFMC
+6 IF Y<1
QUIT
+7 SET BMCRIEN=+Y
+8 SET BMCQ=0
+9 QUIT
+10 ;
SCREEN ;Display ONLY CLOSED Referrals
+1 SET BMCQ=1
+2 WRITE !
+3 SET DIC="^BMCREF("
SET DIC("S")="I $$FILTER^BMCFLTR(1,BMCCURFY,0)"
SET DIC(0)="AEMQ"
SET DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
+4 DO DIC^BMCFMC
+5 IF Y<1
QUIT
+6 SET BMCRIEN=+Y
+7 SET BMCQ=0
+8 QUIT
+9 ;
CHS ;Enter CHS Data with Screenman
+1 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR=$SELECT(BMCRIO="I":"[BMC CHS ADD]",1:"[BMC CHS ADD]")
SET DDSPARM="C"
+2 DO DDS^BMCFMC
+3 IF BMCRIO="I"
Begin DoDot:1
+4 ;BMC*4.0*8 ADD DENIAL EDIT
SET DIR("A")="Do you wish to EDIT Denial Reasons"
SET DIR(0)="Y"
SET DIR("B")="NO"
+5 DO ^DIR
KILL DIR
End DoDot:1
IF +Y>0
DO DENR^BMCCHSE
+6 QUIT
TYPE ; EP - Get type of data to edit
+1 SET BMCQ=1
SET BMCDTYPE=""
+2 ;BMC*4.0*9 CHNG ICD9 TO ICD IN NXT LINE
+3 SET DIR(0)="SO^0:QUIT;1:MINI MOD;2:ALL DATA;3:DATE/COUNTS;4:COSTS;5:ICD DX;6:CPT PROCEDURES;7:CASE REVIEW;8:PURPOSE/MED HX/OTHER DX INFO;9:BUSINESS OFFICE;10:DISCHARGE NOTES;11:ADD DOCUMENTATION;12:CHS ELIG FACTORS;13:OTHER REFERRALS"
+4 ;BMC*4.0*3 10.1.2007 IHS/ITSC/FCJ ADDED OPT 16 TO NXT LINE;4.0*8 7.10.13 IHS.OIT.FCJ ADDED OPT 17
+5 SET DIR(0)=DIR(0)_";14:SEND GROUP MESSAGE;15:SEND MESSAGE TO PROVIDERS;16:SEND ALERT TO PROVIDERS;17:APPROVE REFERRAL"
+6 SET DIR("A")="EDIT Which Data Type"
SET DIR("B")="0"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
QUIT
+8 IF 'Y
QUIT
+9 SET BMCDTYPE=+Y
+10 DO @BMCDTYPE
+11 IF BMCDTYPE=13
QUIT
+12 SET BMCQ=0
+13 QUIT
+14 ;
MINIMOD ; REFERRAL MINI MODIFICATION FORM
1 ; LABEL FOR @DO
+1 ;BMC*4.0*12 IHS/OIT/FCJ ADDED TEST FOR CALLIN TYPE
+2 ;S DDSFILE=90001,DA=BMCRIEN,DR="[BMCX REFERRAL ADD]",DDSPARM="C"
+3 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR=$SELECT($PIECE($GET(^BMCREF(BMCRIEN,1)),U,3)?1N.N:"[BMC REF ADD CALL-IN]",1:"[BMCX REFERRAL ADD]")
SET DDSPARM="C"
+4 DO DDS^BMCFMC
+5 ;BMC*4.0*8 CHECK FOR CHANGE OF SNOMED CD
IF BMCVREF
DO VREFP
IF BMCRSTAT="A"
DO VREF
+6 IF '$TEST
DO SNO
+7 DO 80
+8 SET Y=BMCRIEN
+9 DO ^BMCREF
+10 QUIT
ALLDATA ; MODIFY ALL REFERRAL DATA
2 ; LABEL FOR @DO
+1 SET BMCTMP=BMCMODE
SET BMCMODE="E"
+2 ;BMC*4.0*12 IHS/OIT/FCJ ADDED TEST FOR CALLIN TYPE
+3 ;S DDSFILE=90001,DA=BMCRIEN,DR="[BMC REFERRAL MOD]",DDSPARM="C"
+4 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR=$SELECT($PIECE($GET(^BMCREF(BMCRIEN,1)),U,3)?1N.N:"[BMC REF ADD CALL-IN]",1:"[BMC REFERRAL MOD]")
SET DDSPARM="C"
+5 DO DDS^BMCFMC
+6 SET Y=BMCRIEN
+7 ; set standard variables from record
DO ^BMCREF
+8 ; edit all other data
FOR X=4,5,6,80
DO @X
IF $DATA(DIRUT)
QUIT
+9 ;BMC*4.0*8 CHECK FOR CHANGE OF SNOMED CD
IF BMCVREF
DO VREFP
IF BMCRSTAT="A"
DO VREF
+10 IF '$TEST
DO SNO
+11 SET BMCMODE=BMCTMP
+12 QUIT
+13 ;
+14 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR="[BMC MODIFY COST INFORMATION]"
SET DDSPARM="C"
+15 DO DDS^BMCFMC
+16 QUIT
+17 ;
DATES ; MODIFY DATE FIELDS
3 ; LABEL FOR @DO
+1 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR=$SELECT(BMCRIO="I":"[BMC MODIFY DATES (INPT)]",1:"[BMC MODIFY DATES (OUPT)]")
SET DDSPARM="C"
+2 DO DDS^BMCFMC
+3 QUIT
+4 ;
COST ;MODIFY COST FIELDS
4 ; LABEL FOR @DO
+1 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR="[BMC MODIFY COST INFORMATION]"
SET DDSPARM="C"
+2 DO DDS^BMCFMC
+3 QUIT
+4 ;
DX ; EP - EDIT DIAGNOSES EDIT DIAGNOSES
5 ; LABEL FOR @DO
+1 SET APCDOVRR=""
+2 SET BMCV="DX"
SET BMCTERM="Diagnoses"
SET BMCATEMP="[BMC DIAGNOSIS ADD]"
SET BMCG="^BMCDX("
SET BMCETEMP="[BMC DIAGNOSIS EDIT]"
+3 SET BMCCTYP="DX"
+4 DO ASK
+5 QUIT
+6 ;
PROC ; EP - EDIT PROCEDURES
6 ; LABEL FOR @DO
+1 SET BMCV="PROC"
SET BMCTERM="Procedures"
SET BMCATEMP="[BMC PROCEDURE ADD]"
SET BMCG="^BMCPX("
SET BMCETEMP="[BMC PROCEDURE EDIT]"
+2 SET BMCCTYP="P"
+3 DO ASK
+4 QUIT
+5 ;
7 ; LABEL FOR @DO
+1 SET BMCV="COM"
SET BMCTERM="Case Review Comments"
SET BMCATEMP="[BMC COMMENTS ADD]"
SET BMCG="^BMCCOM("
SET BMCETEMP="[BMC COMMENTS EDIT]"
+2 SET BMCCTYP="C"
+3 DO ASK
+4 ; get next review date
SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR=".31"
+5 DO DIE^BMCFMC
+6 QUIT
+7 ;
PURPOSE ; EDIT PURPOSE OF REFERRAL
8 ; LABEL FOR @DO
+1 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR="[BMC MODIFY MEDICAL INFO]"
SET DDSPARM="C"
+2 DO DDS^BMCFMC
+3 ;IHS/ITSC/FCJ REMOVED BUSINESS, DISCHARGE, MED HX FROM
+4 ;SCREENMAN TEMPLATE WILL NOW ASK INDIVIDUALLY ADDED NXT 6 LNS
80 ;EP FROM 2ND REF AND FR MED HX MENU OPTION
+1 SET BMCV="COM"
SET BMCTERM="Medical HX/Findings Comments"
SET BMCATEMP="[BMC COMMENTS ADD]"
SET BMCG="^BMCCOM("
SET BMCETEMP="[BMC COMMENTS EDIT]"
+2 SET BMCCTYP="M"
+3 DO ASK
+4 ;BMC*4.0*6 4.22.2010 IHS.OIT.FCJ ADDED TEST FOR BMCDTYPE=80
IF (BMCDTYPE=1)!(BMCDTYPE=8)!(BMCDTYPE=80)
QUIT
+5 FOR X=10,9
DO @X
IF $DATA(DIRUT)
QUIT
+6 QUIT
+7 ;
BUSINESS ; EDIT BUSINESS OFFICE COMMENTS
9 ; LABEL FOR @DO
+1 ;IHS/ITSC/FCJ CHG TO ASK FOR ONLY BO COMMENTS
+2 SET BMCV="COM"
SET BMCTERM="Business Office Comment"
SET BMCATEMP="[BMC COMMENTS ADD]"
SET BMCG="^BMCCOM("
SET BMCETEMP="[BMC COMMENTS EDIT]"
+3 SET BMCCTYP="B"
+4 DO ASK
+5 QUIT
+6 ;
DSCHARGE ; EDIT DISCHARGE NOTES
10 ; LABEL FOR @DO
+1 ;IHS/ITSC/FCJ CHG TO ADD COMMENTS TO COMMENT FILE W/USER & DATE STAMP
+2 SET BMCV="COM"
SET BMCTERM="Discharge Notes Comments"
SET BMCATEMP="[BMC COMMENTS ADD]"
SET BMCG="^BMCCOM("
SET BMCETEMP="[BMC COMMENTS EDIT]"
+3 SET BMCCTYP="D"
+4 DO ASK
+5 ; get ltr release date
SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR=".18"
+6 DO DIE^BMCFMC
+7 QUIT
+8 ;
ADDLDOC ; EDIT LIST OF ADDITIONAL DOCUMENTATION TO BE INCLUDED WITH REFERRAL
11 ; LABEL FOR @DO
+1 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR="[BMC ADDITIONAL DOC]"
+2 DO DDS^BMCFMC
+3 QUIT
FACTOR ;CHS ELIG FACTORS
12 ; LABEL FOR @DO
+1 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR="[BMC CHS ELIGIBILITY]"
SET DDSPARM="C"
+2 DO DDS^BMCFMC
+3 SET BMCV="COM"
SET BMCTERM="Business Office Comments"
SET BMCATEMP="[BMC COMMENTS ADD]"
SET BMCG="^BMCCOM("
SET BMCETEMP="[BMC COMMENTS EDIT]"
+4 SET BMCCTYP="B"
+5 DO ASK
+6 QUIT
REF ;IHS/ITSC/FCJ ADD 13TH OPTION TO ALLOW SELECTING OTHER REF FOR PATIENT
13 ;LABEL FOR @DO
+1 SET DIC("B")=BMCREC("PAT NAME")
+2 QUIT
ALERT ;Mail Bulletin Alerts
14 ;IHS/ITSC/FCJ ADD 14TH OPT TO ALLOW SENDING MAILMAN MESSAGE
+1 WRITE @IOF
+2 ;I 'BMCCHSA,BMCRTYPE="C" D ER Q
+3 ;I 'BMCIHSA,BMCRTYPE="I" D ER Q
+4 ;I 'BMCOTHRA,BMCRTYPE="O" D ER Q
+5 ;I 'BMCHOUSA,BMCRTYPE="N" D ER Q
+6 ;I 'BMCCHSA,'BMCIHSA,'BMCOTHRA,'BMCHOUSA D ER Q
+7 DO ENMM^BMCMM
+8 QUIT
15 ;IHS/ITSC/FCJ ADD 15TH OPT TO ALLOW SENDING MAILMAN MESSAGE TO PRIM
+1 ;AND REF PROVIDER ONLY
+2 DO ENMM^BMCMM
+3 QUIT
16 ;BMC*4.0*3 10.1.2007 IHS/ITSC/FCJ ADD 16TH OPT TO ALLOW TO PRIM AND REF PROVIDER ONLY
+1 SET BMCPPRV=$PIECE(^AUPNPAT(BMCDFN,0),U,14)
SET BMCRPRV=$PIECE(^BMCREF(BMCRIEN,0),U,6)
SET BMCRHDR="Updated"
+2 SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Do you wish to send alert to the Referring Provider"
+3 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
QUIT
+4 NEW XQA
+5 IF Y>0
SET XQA(BMCRPRV)=""
+6 ;TEST FOR PAT PRIM PROV
+7 IF BMCPPRV'=""
IF BMCPPRV'=BMCRPRV
Begin DoDot:1
+8 SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Patient's Primary Provider is different then the Referring Physician, do you want to send alert to the Primary Provider"
+9 WRITE !
DO ^DIR
KILL DIR
IF ($DATA(DUOUT))!(Y=0)
QUIT
+10 SET XQA(BMCPPRV)=""
End DoDot:1
+11 IF $DATA(XQA)
DO PALRT1^BMCALERT
+12 QUIT
17 ;EP BMCMODS;BMC 4.0*8 5.8.13 IHS/OIT/FCJ ADDED OPTION TO UPDATE STATUS TO A1-APPROVED
+1 SET BMCSTAT=""
+2 KILL DIR
+3 IF $PIECE(^BMCREF(BMCRIEN,0),U,15)'="A"
Begin DoDot:1
+4 WRITE !,"Referral status can only be changed from Active to Approved,",!?10,"Referral Status: ",$$VAL^XBDIQ1(90001,BMCRIEN,.15)
+5 DO PAUSE^BMC
End DoDot:1
QUIT
+6 WRITE !!
+7 SET DIR(0)="SOA^A:ACTIVE;A1:APPROVED"
SET DIR("?")="Set to Approved if patient will receive referred services even if denied by CHS"
+8 SET DIR("A")="Enter Referral Status: ACTIVE// "
+9 SET DIR("A",1)=" Referral Status: "_$$VAL^XBDIQ1(90001,BMCRIEN,.15)
+10 SET DIR("A",2)=""
+11 SET DIR("A",3)="Select A1 to Approve the Referral"
+12 SET DIR("A",4)=" A ACTIVE"
+13 SET DIR("A",5)=" A1 APPROVAL"
+14 DO ^DIR
KILL DIR
+15 IF X'="A1"
QUIT
+16 SET BMCSTAT=Y
+17 SET DIE="^BMCREF("
SET DR=".15////"_BMCSTAT
SET DA=BMCRIEN
+18 DO DIE^BMCFMC
+19 QUIT
ER WRITE !,"Parameters have not been set up to send messages for this type of Referral."
HANG 1
+1 QUIT
ASK ;EP
+1 SET BMCDF=$SELECT($GET(BMCCLOSE):"A",1:"E")
+2 FOR
DO ASK2
IF BMCQ
QUIT
+3 QUIT
+4 ;
ASK2 ;IHS/ITSC/FCJ MODIFED TO NOT ALLOW EDITING OR DELETING OF BO COMMENTS
+1 SET BMCQ=1
+2 IF $DATA(IOF)
WRITE @IOF
+3 ;4.0*2 8.22.06 IHS.OIT.FCJ NO LONGER ALLOW EDIT OF PHY NOTES
+4 IF (BMCCTYP="B")!(BMCCTYP="M")
IF '$GET(BMCSUP)
WRITE !!,"You may add a new "_BMCTERM,!
+5 IF '$TEST
WRITE !!,"You may edit one of the existing "_BMCTERM_" or add a new one",!
+6 SET BMCNONE=0
+7 DO @("DISP"_BMCV_"^BMCMOD1")
+8 ;4.0*2 8.22.06 IHS.OIT.FCJ NO LONGER ALLOW EDIT OF PHY NOTES
+9 IF (BMCCTYP="B")!(BMCCTYP="M")
IF '$GET(BMCSUP)
SET BMCNONE=1
+10 ;add or edit one of above
+11 WRITE !
+12 IF BMCNONE
SET DIR(0)="S^A:ADD a new "_BMCTERM
SET BMCDF="Q"
IF BMCCTYP'="B"
WRITE !," No entries to edit",!
IF 1
+13 IF '$TEST
SET DIR(0)="S^E:EDIT one of the above "_BMCTERM_";A:ADD a new "_BMCTERM_";D:DELETE one of the above "_BMCTERM
+14 SET DIR(0)=DIR(0)_";Q:QUIT"
+15 ;S DIR("A")="Do you wish to",DIR("B")=$S(BMCDF="E":"Q",1:"A") ;4.0 7.11.05 IHS/ITSC/FCJ ADDED TEST FOR MODE TO DEFAULT TO Q ON COMMENTS
+16 SET DIR("A")="Do you wish to"
SET DIR("B")=$SELECT(BMCMODE="E":"Q",BMCDF="E":"Q",1:"A")
+17 DO ^DIR
KILL DIR
+18 IF $DATA(DIRUT)
QUIT
+19 IF Y="Q"
QUIT
+20 DO @Y
+21 IF '$GET(BMCCLOSE)
SET BMCDF="Q"
+22 SET BMCQ=0
+23 QUIT
+24 ;
E ;edit an existing XXX
+1 DO @("DISP"_BMCV_"^BMCMOD1")
+2 WRITE !
SET DIR(0)="N^1:"_BMCC_":"
SET DIR("A")="Which One do you wish to EDIT"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 IF 'Y
QUIT
+5 SET BMCC=+Y
+6 IF '$DATA(BMCRDX(BMCC))
WRITE !!,"Invalid choice."
QUIT
+7 SET DA=BMCRDX(BMCC)
SET DIE=BMCG
SET DR=BMCETEMP
+8 DO DIE^BMCFMC
+9 IF $DATA(Y)
WRITE !!,"ERROR ENCOUNTERED IN EDITING A "_BMCTERM
QUIT
+10 QUIT
+11 ;
A ;add a new XXX
+1 SET BMCLOOK=1
+2 WRITE !!,"Adding a NEW "_BMCTERM_"...",!
+3 IF BMCV="COM"
DO COMMENTS^BMCADD1
QUIT
+4 ;BMC*4.0*9 ADDED TO CALL LEXICON
IF BMCV="DX"
DO ADDDX^BMCMOD1
QUIT
+5 ;BMC*4.0*9 ADDED
IF BMCV="PROC"
DO ADDPX^BMCMOD1
QUIT
+6 SET DIE="^BMCREF("
SET DR=BMCATEMP
SET DA=BMCRIEN
+7 DO DIE^BMCFMC
+8 IF $DATA(Y)
WRITE !!,"NO "_BMCTERM_" ADDED!"
+9 KILL BMCLOOK
+10 QUIT
+11 ;
D ;delete XXX
+1 DO @("DISP"_BMCV_"^BMCMOD1")
+2 SET DIR(0)="N^1:"_BMCC_":"
SET DIR("A")="Which One do you wish to DELETE"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 IF 'Y
QUIT
+5 SET BMCC=+Y
+6 IF '$DATA(BMCRDX(BMCC))
WRITE !!,"Invalid choice."
QUIT
+7 ;
+8 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this "_BMCTERM
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+9 IF $DATA(DIRUT)
QUIT
+10 IF 'Y
WRITE !,"Okay, not deleted."
QUIT
+11 SET DA=BMCRDX(BMCC)
SET DIK=BMCG
DO DIK^BMCFMC
WRITE !,BMCTERM_" DELETED"
QUIT
+12 QUIT
+13 ;
PCCL ; PCC LINK
+1 IF $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1"
DO ^BMCPCCL
+2 QUIT
+3 ;
VREF ;EP FR BMCMODS;BMC*4.0*8 NEW MODULE TO UPDATE SNOMED IN V REF FILE
+1 IF $PIECE(^AUPNVREF(BMCVREF,0),U)=BMCSCOD
QUIT
+2 SET DIE="^AUPNVREF("
SET DA=BMCVREF
SET DR=".01///"_BMCSCOD_";1218////"_$$NOW^XLFDT
+3 DO DIE^BMCFMC
+4 QUIT
VREFP ;BMC*4.0*8 NEW MODULE TO UPDATE PROV IN V REF FILE
+1 IF $PIECE(^AUPNVREF(BMCVREF,12),U,2)=$PIECE(^BMCREF(BMCRIEN,0),U,6)
QUIT
+2 SET DIE="^AUPNVREF("
SET DA=BMCVREF
SET DR="1202////"_$PIECE(^BMCREF(BMCRIEN,0),U,6)_";1218////"_$$NOW^XLFDT
+3 DO DIE^BMCFMC
+4 KILL DIE,DR,X,DA
+5 QUIT
SNO ;EP FROM BMCMODS;BMC*4.0*9 NEW MODULE TO ADD SNOMED FOR SITES W/O PCC
+1 IF BMCSCOD=$PIECE($GET(^BMCREF(BMCRIEN,22,1,0)),U)
QUIT
+2 SET DR=".01///"_BMCSCOD
+3 SET DIE="^BMCREF("_BMCRIEN_",22,"
SET DA=1
+4 DO DIE^BMCFMC
+5 KILL DIE,DR,X,DA
+6 QUIT
+7 ;
EOJ ; END OF JOB
+1 KILL BMCRTY
+2 DO ^BMCKILL
+3 DO ^XBFMK
+4 QUIT
