Routine: BMCMOD

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

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

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

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

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

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

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

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

 S DDSFILE=90001,DA=BMCRIEN,DR="[BMC MODIFY COST INFORMATION]",DDSPARM="C"

 D DDS^BMCFMC

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

COST ;MODIFY COST FIELDS

4 ; LABEL FOR @DO

 S DDSFILE=90001,DA=BMCRIEN,DR="[BMC MODIFY COST INFORMATION]",DDSPARM="C"

 D DDS^BMCFMC

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

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

COMMENTS ; EDIT COMMENTS CASE REVIEW

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

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)

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

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

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

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

REF ;IHS/ITSC/FCJ ADD 13TH OPTION TO ALLOW SELECTING OTHER REF FOR PATIENT

13 ;LABEL FOR @DO

 S DIC("B")=BMCREC("PAT NAME")

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

15 ;IHS/ITSC/FCJ ADD 15TH OPT TO ALLOW SENDING MAILMAN MESSAGE TO PRIM

 ;AND REF PROVIDER ONLY

 D ENMM^BMCMM

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

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

ER W !,"Parameters have not been set up to send messages for this type of Referral." H 1

ASK ;EP

 S BMCDF=$S($G(BMCCLOSE):"A",1:"E")

 F  D ASK2 Q:BMCQ

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

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

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

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

PCCL ; PCC LINK

 I $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1" D ^BMCPCCL

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

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

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

EOJ ; END OF JOB

 K BMCRTY

 D ^BMCKILL

 D ^XBFMK

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       ;

COMMENTS  ; EDIT COMMENTS CASE REVIEW

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

BMCMOD.m