Routine: BMCADD

BMCADD ; IHS/PHXAO/TMJ - ADD A NEW REFERRAL ;         [ 07/12/2006  3:48 PM ]

 ;;4.0;REFERRED CARE INFO SYSTEM;**2,8,9,12*;JAN 09, 2006;Build 101

 ;4.0*2 IHS/OIT/FCJ Marked EP for API routine

 ;4.0*8 IHS/OIT/FCJ Added selecting a visit and adding a v ref entry

 ;4.0*9 IHS/OIT/FCJ ADDED TEST FOR PREVIOUS REFERRALS

 ;4.0*12 IHS/OIT/FCJ ADDED CALL IN BY AND CALL IN NOTIFICATION DATE And V Ref change to Visit provider

 ;IHS/OIT/FCJ Messages are no longer triggered.  Prompts

 ;    user if they would like to send a message.

 ;   CHANGED COMMENT CALL, BUSINESS OFF AND MED HX

 ;   ARE NO LONGER CALLED FROM FORM. Called at the end of Data entry.

 ;   CHANGED OPT 1 AND 4 DISPLAY NAMES

 ;   Remove BO/Case/Manage care comments fr physician option

 ;   Removed asking for Case comments

 ;   Test for SR and add a new form for call-in's

 ; See ^BMCVDOC for system wide variables set by main menu

 ; Subscripted BMCREC is EXTERNAL form.

 ;   BMCREC("PAT NAME")=patient name

 ;   BMCREC("REF DATE")=referral date

 ;   BMCDFN=patient ien

 ;   BMCRDATE=referral date in internal FileMan form

 ;   BMCRNUMB=referral number

 ;   BMCRIEN=referral ien

 ;   BMCMODE=A for add, M for modify

 ;   BMCRTYPE=type of referral (.04 field)

 ;   BMCRIO=Inpatient or Outpatient (.14 field)

START ;

 D:$G(BMCPARM)="" PARMSET^BMC

 F  D MAIN Q:BMCQ  D HDR^BMC

 D EOJ

MAIN ;

 S BMCQ=0

 S BMCMODE="A",(BMCLOOK,BMCVDFN,BMCVRIE,BMCSTRM,BMCSNO,BMCSCOD)="" ;BMC*4.0*8 ADDED BMCVDFN AND BMCSTRM

 S APCDOVRR=""

 D PATIENT ;              get patient being referred

 Q:BMCQ

 D REFDISP

 I BMCQ=1 D GETDATE Q

 D ASK

 Q:BMCQ

GETDATE ;EP;Do Get Date if no existing Referrals

 D DATE ;                 get date of referral

 Q:BMCQ

 D NUMBER ;               get next referral number

 Q:BMCQ

 D ADD ;                  add new referral record

 Q:BMCQ

 I BMCPCC,'$G(BMCOUTR) D DSPV^BMCADDP I BMCQ D DELETE Q  ;BMC*4.0*8 TEST FOR PCC LINK AND GO TO REQUIRE A VST

 D EDIT ;                 edit referral record just added

 Q:BMCQ                                 ;BMC*4.0*8

 I BMCPCC,'$G(BMCOUTR) D ADDVREF        ;BMC*4.0*8 Add to V Ref file

PATIENT ;EP; GET PATIENT

 F  D PATIENT2 I BMCQ!($G(BMCDFN)) Q

PATIENT2 ; ASK FOR PATIENT UNTIL USER SELECTS OR QUITS

 S BMCQ=1

 S DIC="^AUPNPAT(",DIC(0)="AEMQ" D DIC^BMCFMC

 Q:Y<1

 S BMCDFN=+Y,BMCREC("PAT NAME")=$P(^DPT(+Y,0),U)

 S BMCQ=0

 I $$DOD^AUPNPAT(BMCDFN) D  I 'Y K BMCDFN,BMCREC("PAT NAME") Q

 . W !!,"This patient is deceased."

 . S DIR(0)="YO",DIR("A")="Are you sure you want this patient",DIR("B")="NO" K DA D ^DIR K DIR

 . W !

ASK ;EP;Ask to Continue

 S BMCQ=0

 W !! S DIR(0)="Y",DIR("A")="Do you want to continue with adding a new referral",DIR("B")="Y" K DA D ^DIR K DIR

 I $D(DIRUT) S BMCQ=1 Q

 I 'Y S BMCQ=1 Q

REFDISP ;EP;Display if Patient has existing Referrals

 W !!,?25,"********************",!

 W ?25,"**LAST 5 REFERRALS**",!,?25,"********************",!

 I '$D(^BMCREF("AA",BMCDFN)) W !,?20,"**--NO EXISTING REFERRALS--**",! S BMCQ=1 Q

 S BMCQ=0

 S BMCDT="",CT=5  ;BMC*3.1*9 ADDED CT AND CT TO NXT LINE

 F I=1:1:5 S BMCDT=$O(^BMCREF("AA",BMCDFN,BMCDT),-1) Q:BMCDT=""  D NEXT Q:CT=0

 K CT Q

NEXT ;2ND $O

 S BMCRIEN=""

 F  S BMCRIEN=$O(^BMCREF("AA",BMCDFN,BMCDT,BMCRIEN),-1) Q:BMCRIEN'=+BMCRIEN  D

 . Q:BMCDT=""

 . Q:BMCRIEN=""

 . Q:$P($G(^BMCREF(BMCRIEN,1)),U)'=""  ;4.0 IHS/ITSC/FCJ TST FOR SR

 . Q:CT=0   ;BMC*3.1*9

 . D START^BMCLKID1

 . S CT=CT-1  ;BMC*3.1*9

DATE ; GET DATE OF REFERRAL

W !

 S BMCQ=1

 S DIR(0)="90001,.01",DIR("B")="TODAY" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 S BMCRDATE=+Y,BMCREC("REF DATE")=Y(0)

 S BMCQ=0

 ; Search index to determine if referral exists for patient/date.

 ; If so, display message.

 I $D(^BMCREF("AA",BMCDFN,BMCRDATE)) D  Q

 .W !!,"A REFERRAL FOR '",BMCREC("PAT NAME"),"', ON '",BMCREC("REF DATE"),"' EXISTS.",!,"USE THE 'MODIFY' OPTION TO EDIT THE REFERRAL.",!

 .D EOP^BMC

 S BMCQ=0

PROV ; GET REQUESTING PROVIDER

 S BMCPROV="",BMCQ=1

 I $G(BMCOUTR) S BMCQ=0 Q  ; do not ask provider if outside referral

 S DIR(0)="90001,.06",DIR("A")="Enter REQUESTING PROVIDER" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 S BMCPROV=+Y,BMCRPROV=$P(Y,U,2)

 S BMCQ=0

CALLIN ;GET CALL IN BY AND DATE  ;BMC*4.0*12 IHS/OIT/FCJ NEW SECTION

W !

 S (BMCCDT,BMCCBY)="",BMCQ=1

 S DIR(0)="90001,103",DIR("A")="Enter Call in Notification date" K DA D ^DIR K DIR

 Q:$D(DIRUT)!(+Y<1)

 S BMCCDT=Y

W !

 S DIR(0)="90001,104",DIR("A")="Enter Call in Notification By" K DA D ^DIR K DIR

 Q:$D(DIRUT)!(Y'?1A)

 S BMCCBY=Y

 S BMCQ=0

NUMBER ; GENERATE REFERRAL NUMBER

 S BMCQ=1

 S X=$$REFN^BMC

 Q:'X

 X $P(^DD(90001,.02,0),U,5,99)

 I '$D(X) W !,"Error generating new referral number.  Notify programmer.",! D EOP^BMC Q

 S BMCRNUMB=X

 S BMCQ=0

ADD ; ADD NEW REFERRAL RECORD

 S BMCQ=1

 D ADD2 Q:'$D(BMCRR)  I 1

 E  S BMCRR=""

 D PROV

 Q:BMCQ

 I $G(BMCOUTR) D CALLIN  ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY

 Q:BMCQ                  ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY

 I BMCRR="" D  Q

 .;BMC*4.0*8 SPLIT NXT LINE AND ADDED TOC STATUS FIELD 1304

 .S DIC="^BMCREF(",DIC(0)="L",DLAYGO=90001,X=BMCRDATE

 .S DIC("DR")=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.06////"_BMCPROV_";.15////A;.25////"_DUZ_";.26////"_DT_";.27////"_DT_";1304////P"

 .I $G(BMCOUTR) S DIC("DR")=DIC("DR")_";103////"_BMCCDT_";104////"_BMCCBY  ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY

 .D FILE^BMCFMC

 .I Y<0 W !,"Error creating REFERRAL.",!,"Notify programmer.",! D EOP^BMC Q

 .W !!,"REFERRAL number : ",BMCRNUMB,!

 .S BMCRIEN=+Y

 .S BMCQ=0

.Q

RR ;routine referral selected

 ;create entry with .01

 ;%rcr

 ;re-index

 ;call die with other fields

 ;set BMCRIEN,BMCQ=0

 S BMCOVRPS="" ;override post selection action

 S DIC="^BMCREF(",DIC(0)="L",DLAYGO=90001,X=BMCRDATE D FILE^BMCFMC

 K BMCOVRPS ;kill override variable

 I Y<0 W !,"Error creating REFERRAL.",!,"Notify programmer.",! D EOP^BMC Q

 S BMCRIEN=+Y

 ;call %RCR to copy routine referral into the newly created

 ;RCIS Referral entry

 S %X="^BMCRTNRF("_BMCRR_",",%Y="^BMCREF("_BMCRIEN_"," D %XY^%RCR ;move 0 node

 S BMCSCOD="",BMCSTRM=""   ;BMC*4.0*8

 S BMCSCOD=$P($G(^BMCRTNRF(BMCRR,13)),U,3) S:BMCSCOD BMCSTRM=$P($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)  ;BMC*4.0*8

 S $P(^BMCREF(BMCRIEN,13),U,3)=""  ;BMC*4.0*8

 K ^BMCREF(BMCRIEN,61),^BMCREF(BMCRIEN,62) ;kill off nodes that don't belong

 I $D(^BMCREF(BMCRIEN,21,0)),$P(^BMCREF(BMCRIEN,21,0),U,2)[3221 S $P(^BMCREF(BMCRIEN,21,0),U,2)="90001.21PA"

 ;*******IMPORTANT - in line above, if nodes are added to the routine referral definition file, you must add the node to the line above

 S $P(^BMCREF(BMCRIEN,0),U)=BMCRDATE

 S DA=BMCRIEN,DIK="^BMCREF(" D IX1^DIK ;reindex entry

 ;BMC*4.0*8 IHS.OIT.FCJ ADDING TOC STATUS

 S DIE="^BMCREF(",DR=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.06////"_BMCPROV_";.15////A;.25////"_DUZ_";.26////"_DT_";.27////"_DT_";1304////P"

 D DIE^BMCFMC

 I $D(Y) W !!,"Error in editing referral entry.  NOTIFY PROGRAMMER." Q

 S Y=BMCRIEN D ^BMCREF

 S BMCQ=0

ADDVREF ;EP FR BMCADDFY AND BMCADDS;ADD ENTRY TO V REF FILE ;BMC*4.0*8 NEW SECTION

 S DIC="^AUPNVREF(",DIC(0)="L",DLAYGO=9000010.59,X=BMCSCOD

 ;BMC*4.0*12 MODIFIED NEXT LINE TO SET VISIT PROVIDER ENCOUNTER IN V REF

 ;S DIC("DR")=".02////"_BMCDFN_";.03////"_BMCVDFN_";.06////"_BMCRIEN_";1201////"_$$NOW^XLFDT_";1202////"_BMCPROV_";1204////"_BMCPROV_";1216////"_$$NOW^XLFDT

 S DIC("DR")=".02////"_BMCDFN_";.03////"_BMCVDFN_";.06////"_BMCRIEN_";1201////"_$$NOW^XLFDT_";1202////"_BMCPROV_";1204////"_$$PRIMPROV^APCLV(BMCVDFN,"I")_";1216////"_$$NOW^XLFDT

 D FILE^BMCFMC

 I +Y<0 W !,"Error creating V REFERRAL.",!,"Notify programmer.",! D EOP^BMC Q

 S BMCVRIE=+Y

 ;Now add V Referral pointer to RCIS REFERRAL

 K DIC

 S DIE="^BMCREF(",DA=BMCRIEN

 S DR="1303////"_BMCVRIE

 D ^DIE

 I $D(Y) W !,"Error adding V REFERRAL in RCIS Referral file.",!,"Notify programmer."

 K DIE

ADD2 ;add if routine referrals have been defined

 K BMCDISP,BMCSEL,BMCHIGH,BMCRR,BMCOUTR,BMCMINI,BMCMINIX

 S BMCHIGH=1,BMCSEL(1)="Mini Referral"

 S BMCHIGH=2,BMCSEL(2)="Complete Referral (all referral data)"

 S BMCHIGH=3,BMCSEL(3)="Call In Notification"                 ;BMC*4.0*12 REMOVED- BY OUTSITE FACILITY

 S BMCHIGH=4,BMCSEL(4)="Abbreviated entry for clinicians"

 W:$D(IOF) @IOF

 W !,"Please select the referral form you wish to use."

 W !!?5,"1.  ",BMCSEL(1)

 W !?5,"2.  ",BMCSEL(2)

 W !?5,"3.  ",BMCSEL(3)

 W !?5,"4.  ",BMCSEL(4)

 S (X,BMCRRC)=0 F  S X=$O(^BMCRTNRF("B",X)) Q:X=""  S BMCRRC=BMCRRC+1

 W:BMCRRC<31 !!?5,"Locally-defined Routine Referral Templates:",!

 S X=0 F  S X=$O(^BMCRTNRF("B",X)) Q:X=""  S Y=$O(^BMCRTNRF("B",X,"")) S BMCHIGH=BMCHIGH+1,BMCSEL(BMCHIGH)=Y_U_$E($P(^BMCRTNRF(Y,0),U))_$E($$LOW^XLFSTR($P(^BMCRTNRF(Y,0),U)),2,999)

L16 ;

 I BMCRRC<16 D

 .S I=4 F  S I=$O(BMCSEL(I)) Q:I'=+I  W !?5,I,".  ",$P(BMCSEL(I),U,2)

 .D GETANS

 I BMCRRC>15&(BMCRRC<31) D

 .S BMCCUT=(BMCHIGH-3)/2 S:BMCCUT'=(BMCCUT\1) BMCCUT=(BMCCUT\1)+1

 .S I=4,J=1,K=1 F  S I=$O(BMCSEL(I)) Q:I'=+I!($D(BMCDISP(I)))  W !?5,I,")  ",$P(BMCSEL(I),U,2) S BMCDISP(I)="",J=I+BMCCUT I $D(BMCSEL(J)),'$D(BMCDISP(J)) W ?40,J,")  ",$P(BMCSEL(J),U,2) S BMCDISP(J)=""

 .D GETANS

G30 ;

 I BMCRRC>30 D

 .S BMCSEL(5)="5.  Select a locally defined routine referral template from a list"

 .W !!?5,BMCSEL(5),!

 .W ! S DIR(0)="N^1:"_BMCHIGH_":0",DIR("A")="Enter REFERRAL FORM ",DIR("B")=2 D ^DIR K DIR

 .Q:$D(DIRUT)

 .I Y=2 S BMCRR="" Q

 .I Y=3 S BMCOUTR=1,BMCRR="" Q

 .I Y=1 S BMCMINI=1,BMCRR="" Q

 .I Y=4 S BMCMINIX=1,BMCRR="" Q

 .I Y=5 K BMCRR D ^BMCADD2

GETANS ;

 W ! S DIR(0)="N^1:"_BMCHIGH_":0",DIR("A")="Enter REFERRAL FORM",DIR("B")=2 D ^DIR K DIR

 Q:$D(DIRUT)

 I Y=2 S BMCRR="" Q

 I Y=3 S BMCOUTR=1,BMCRR="" Q

 I Y=1 S BMCMINI=1,BMCRR="" Q

 I Y=4 S BMCMINIX=1,BMCRR="" Q

 S BMCRR=Y,BMCRR=$P(BMCSEL(BMCRR),U)

EDIT ; EDIT REFERRAL RECORD JUST ADDED

 S DDSFILE=90001,DA=BMCRIEN

 ;4.0 IHS/OIT/FCJ ADDED A NEW FORM FOR CALL IN REFERRALS

 ;S DR=$S($G(BMCMINI):"[BMCX REFERRAL ADD]",$G(BMCMINIX):"[BMCXX REFERRAL ADD]",1:"[BMC REFERRAL ADD]"),DDSPARM="C"

 S DR=$S($G(BMCMINI):"[BMCX REFERRAL ADD]",$G(BMCMINIX):"[BMCXX REFERRAL ADD]",$G(BMCOUTR):"[BMC REF ADD CALL-IN]",1:"[BMC REFERRAL ADD]"),DDSPARM="C"

 D DDS^BMCFMC

 I '$G(DDSCHANG) D DELETE S BMCQ=1 Q

 S Y=BMCRIEN

 D ^BMCREF              ; set standard variables from record

 ;6.1.04 IHS/ITSC/FCJ TEST FOR PROVIDER

 S X=$S(BMCRTYPE="I":$P(^BMCREF(BMCRIEN,0),U,8),BMCRTYPE="N":$P(^BMCREF(BMCRIEN,0),U,23),1:$P(^BMCREF(BMCRIEN,0),U,7))

 I 'X W !,"You must enter a Vendor, IHS Facility or In-House Clinic, depending on the",!,"referral type.",! D PAUSE^BMC G EDIT

 D DXPX                 ; get provisional dx's/px's

 ;7/27/04 IHS/OIT/FCJ cmt nxt lne no longer asking for Case cmts

 D:'$G(BMCMINI)&'$G(BMCMINIX) BOCOM   ; get Business Office comments except for MINIX and MINI

 D STATIC ;               set static fields

DELETE ; DELETE REFERRAL JUST ADDED BECAUSE OPERATOR DIDN'T FINISH

 W !!,"INCOMPLETE REFERRAL BEING DELETED!",!!

 S DIK="^BMCREF(",DA=BMCRIEN D ^DIK

 D PAUSE^BMC

DXPX ; GET PROVIDIONAL DIAGNOSES/PROCEDURES IF WANTED

 D DXPX^BMCADD1

CSECOM ;EP; GET CASE COMMENTS

W !

 S DIR("A")="Do you want to enter Case Review Comments"

 S BMCCTYP="C"

 D COMMENTS

MGDCARE ; Get Managed Care Committee Action

 D MGDCARE^BMCADD1

MEDCOM ;EP;MEDICAL HX/FINDINGS COMMENTS

W !

 S DIR("A")="Do you want to enter Medical HX and Findings Comments"

 S BMCCTYP="M"

 D COMMENTS

W !

BOCOM ;EP;BUSINESS OFFCIE COMMENTS

W !

 S DIR("A")="Do you want to enter Business Office/CHS Comments"

 S BMCCTYP="B"

 D COMMENTS

COMMENTS ;EP

 S DIR(0)="Y",DIR("B")="N",DIR("?")="Enter 'YES' to enter comments now."

 S:BMCCTYP="M" DIR("B")="Y"

 D ^DIR K DIR

 Q:$D(DIRUT)!'Y

 D COMMENTS^BMCADD1

STATIC ; STORE STATIC DATA

 D STATIC^BMCADD1

EOJ ; END OF JOB

 D ^BMCKILL

BMCADD    ; IHS/PHXAO/TMJ - ADD A NEW REFERRAL ;         [ 07/12/2006  3:48 PM ]

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**2,8,9,12*;JAN 09, 2006;Build 101

 +2       ;4.0*2 IHS/OIT/FCJ Marked EP for API routine

 +3       ;4.0*8 IHS/OIT/FCJ Added selecting a visit and adding a v ref entry

 +4       ;4.0*9 IHS/OIT/FCJ ADDED TEST FOR PREVIOUS REFERRALS

 +5       ;4.0*12 IHS/OIT/FCJ ADDED CALL IN BY AND CALL IN NOTIFICATION DATE And V Ref change to Visit provider

 +6       ;

 +7       ;IHS/OIT/FCJ Messages are no longer triggered.  Prompts

 +8       ;    user if they would like to send a message.

 +9       ;   CHANGED COMMENT CALL, BUSINESS OFF AND MED HX

 +10      ;   ARE NO LONGER CALLED FROM FORM. Called at the end of Data entry.

 +11      ;   CHANGED OPT 1 AND 4 DISPLAY NAMES

 +12      ;   Remove BO/Case/Manage care comments fr physician option

 +13      ;   Removed asking for Case comments

 +14      ;   Test for SR and add a new form for call-in's

 +15      ;

 +16      ; See ^BMCVDOC for system wide variables set by main menu

 +17      ; Subscripted BMCREC is EXTERNAL form.

 +18      ;   BMCREC("PAT NAME")=patient name

 +19      ;   BMCREC("REF DATE")=referral date

 +20      ;   BMCDFN=patient ien

 +21      ;   BMCRDATE=referral date in internal FileMan form

 +22      ;   BMCRNUMB=referral number

 +23      ;   BMCRIEN=referral ien

 +24      ;   BMCMODE=A for add, M for modify

 +25      ;   BMCRTYPE=type of referral (.04 field)

 +26      ;   BMCRIO=Inpatient or Outpatient (.14 field)

 +27      ;

START     ;

 +1        IF $GET(BMCPARM)=""

               DO PARMSET^BMC

 +2        FOR

               DO MAIN

               IF BMCQ

                   QUIT

               DO HDR^BMC

 +3        DO EOJ

 +4        QUIT

 +5       ;

MAIN      ;

 +1        SET BMCQ=0

 +2       ;BMC*4.0*8 ADDED BMCVDFN AND BMCSTRM

           SET BMCMODE="A"

           SET (BMCLOOK,BMCVDFN,BMCVRIE,BMCSTRM,BMCSNO,BMCSCOD)=""

 +3        SET APCDOVRR=""

 +4       ;              get patient being referred

           DO PATIENT

 +5        IF BMCQ

               QUIT

 +6        DO REFDISP

 +7        IF BMCQ=1

               DO GETDATE

               QUIT

 +8        DO ASK

 +9        IF BMCQ

               QUIT

 +10      ;

GETDATE   ;EP;Do Get Date if no existing Referrals

 +1       ;                 get date of referral

           DO DATE

 +2        IF BMCQ

               QUIT

 +3       ;               get next referral number

           DO NUMBER

 +4        IF BMCQ

               QUIT

 +5       ;                  add new referral record

           DO ADD

 +6        IF BMCQ

               QUIT

 +7       ;BMC*4.0*8 TEST FOR PCC LINK AND GO TO REQUIRE A VST

           IF BMCPCC

               IF '$GET(BMCOUTR)

                   DO DSPV^BMCADDP

                   IF BMCQ

                       DO DELETE

                       QUIT

 +8       ;                 edit referral record just added

           DO EDIT

 +9       ;BMC*4.0*8

           IF BMCQ

               QUIT

 +10      ;BMC*4.0*8 Add to V Ref file

           IF BMCPCC

               IF '$GET(BMCOUTR)

                   DO ADDVREF

 +11       QUIT

 +12      ;

PATIENT   ;EP; GET PATIENT

 +1        FOR

               DO PATIENT2

               IF BMCQ!($GET(BMCDFN))

                   QUIT

 +2        QUIT

 +3       ;

PATIENT2  ; ASK FOR PATIENT UNTIL USER SELECTS OR QUITS

 +1        SET BMCQ=1

 +2        SET DIC="^AUPNPAT("

           SET DIC(0)="AEMQ"

           DO DIC^BMCFMC

 +3        IF Y<1

               QUIT

 +4        SET BMCDFN=+Y

           SET BMCREC("PAT NAME")=$PIECE(^DPT(+Y,0),U)

 +5        SET BMCQ=0

 +6        IF $$DOD^AUPNPAT(BMCDFN)

               Begin DoDot:1

 +7                WRITE !!,"This patient is deceased."

 +8                SET DIR(0)="YO"

                   SET DIR("A")="Are you sure you want this patient"

                   SET DIR("B")="NO"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +9                WRITE !

               End DoDot:1

               IF 'Y

                   KILL BMCDFN,BMCREC("PAT NAME")

                   QUIT

 +10       QUIT

 +11      ;

ASK       ;EP;Ask to Continue

 +1        SET BMCQ=0

 +2        WRITE !!

           SET DIR(0)="Y"

           SET DIR("A")="Do you want to continue with adding a new referral"

           SET DIR("B")="Y"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               SET BMCQ=1

               QUIT

 +4        IF 'Y

               SET BMCQ=1

               QUIT

 +5        QUIT

 +6       ;

REFDISP   ;EP;Display if Patient has existing Referrals

 +1        WRITE !!,?25,"********************",!

 +2        WRITE ?25,"**LAST 5 REFERRALS**",!,?25,"********************",!

 +3        IF '$DATA(^BMCREF("AA",BMCDFN))

               WRITE !,?20,"**--NO EXISTING REFERRALS--**",!

               SET BMCQ=1

               QUIT

 +4        SET BMCQ=0

 +5       ;BMC*3.1*9 ADDED CT AND CT TO NXT LINE

           SET BMCDT=""

           SET CT=5

 +6        FOR I=1:1:5

               SET BMCDT=$ORDER(^BMCREF("AA",BMCDFN,BMCDT),-1)

               IF BMCDT=""

                   QUIT

               DO NEXT

               IF CT=0

                   QUIT

 +7        KILL CT

           QUIT

NEXT      ;2ND $O

 +1        SET BMCRIEN=""

 +2        FOR

               SET BMCRIEN=$ORDER(^BMCREF("AA",BMCDFN,BMCDT,BMCRIEN),-1)

               IF BMCRIEN'=+BMCRIEN

                   QUIT

               Begin DoDot:1

 +3                IF BMCDT=""

                       QUIT

 +4                IF BMCRIEN=""

                       QUIT

 +5       ;4.0 IHS/ITSC/FCJ TST FOR SR

                   IF $PIECE($GET(^BMCREF(BMCRIEN,1)),U)'=""

                       QUIT

 +6       ;BMC*3.1*9

                   IF CT=0

                       QUIT

 +7                DO START^BMCLKID1

 +8       ;BMC*3.1*9

                   SET CT=CT-1

               End DoDot:1

 +9        QUIT

 +10      ;

DATE      ; GET DATE OF REFERRAL

 +1        WRITE !

 +2        SET BMCQ=1

 +3        SET DIR(0)="90001,.01"

           SET DIR("B")="TODAY"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               QUIT

 +5        SET BMCRDATE=+Y

           SET BMCREC("REF DATE")=Y(0)

 +6        SET BMCQ=0

 +7        QUIT

 +8       ; Search index to determine if referral exists for patient/date.

 +9       ; If so, display message.

 +10      ;

 +11       IF $DATA(^BMCREF("AA",BMCDFN,BMCRDATE))

               Begin DoDot:1

 +12               WRITE !!,"A REFERRAL FOR '",BMCREC("PAT NAME"),"', ON '",BMCREC("REF DATE"),"' EXISTS.",!,"USE THE 'MODIFY' OPTION TO EDIT THE REFERRAL.",!

 +13               DO EOP^BMC

               End DoDot:1

               QUIT

 +14       SET BMCQ=0

 +15       QUIT

 +16      ;

PROV      ; GET REQUESTING PROVIDER

 +1        SET BMCPROV=""

           SET BMCQ=1

 +2       ; do not ask provider if outside referral

           IF $GET(BMCOUTR)

               SET BMCQ=0

               QUIT

 +3        SET DIR(0)="90001,.06"

           SET DIR("A")="Enter REQUESTING PROVIDER"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               QUIT

 +5        SET BMCPROV=+Y

           SET BMCRPROV=$PIECE(Y,U,2)

 +6        SET BMCQ=0

 +7        QUIT

CALLIN    ;GET CALL IN BY AND DATE  ;BMC*4.0*12 IHS/OIT/FCJ NEW SECTION

 +1        WRITE !

 +2        SET (BMCCDT,BMCCBY)=""

           SET BMCQ=1

 +3        SET DIR(0)="90001,103"

           SET DIR("A")="Enter Call in Notification date"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)!(+Y<1)

               QUIT

 +5        SET BMCCDT=Y

 +6        WRITE !

 +7        SET DIR(0)="90001,104"

           SET DIR("A")="Enter Call in Notification By"

           KILL DA

           DO ^DIR

           KILL DIR

 +8        IF $DATA(DIRUT)!(Y'?1A)

               QUIT

 +9        SET BMCCBY=Y

 +10       SET BMCQ=0

 +11       QUIT

NUMBER    ; GENERATE REFERRAL NUMBER

 +1        SET BMCQ=1

 +2        SET X=$$REFN^BMC

 +3        IF 'X

               QUIT

 +4        XECUTE $PIECE(^DD(90001,.02,0),U,5,99)

 +5        IF '$DATA(X)

               WRITE !,"Error generating new referral number.  Notify programmer.",!

               DO EOP^BMC

               QUIT

 +6        SET BMCRNUMB=X

 +7        SET BMCQ=0

 +8        QUIT

 +9       ;

ADD       ; ADD NEW REFERRAL RECORD

 +1        SET BMCQ=1

 +2        DO ADD2

           IF '$DATA(BMCRR)

               QUIT

           IF 1

 +3       IF '$TEST

               SET BMCRR=""

 +4        DO PROV

 +5        IF BMCQ

               QUIT

 +6       ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY

           IF $GET(BMCOUTR)

               DO CALLIN

 +7       ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY

           IF BMCQ

               QUIT

 +8        IF BMCRR=""

               Begin DoDot:1

 +9       ;BMC*4.0*8 SPLIT NXT LINE AND ADDED TOC STATUS FIELD 1304

 +10               SET DIC="^BMCREF("

                   SET DIC(0)="L"

                   SET DLAYGO=90001

                   SET X=BMCRDATE

 +11               SET DIC("DR")=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.06////"_BMCPROV_";.15////A;.25////"_DUZ_";.26////"_DT_";.27////"_DT_";1304////P"

 +12      ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY

                   IF $GET(BMCOUTR)

                       SET DIC("DR")=DIC("DR")_";103////"_BMCCDT_";104////"_BMCCBY

 +13               DO FILE^BMCFMC

 +14               IF Y<0

                       WRITE !,"Error creating REFERRAL.",!,"Notify programmer.",!

                       DO EOP^BMC

                       QUIT

 +15               WRITE !!,"REFERRAL number : ",BMCRNUMB,!

 +16               SET BMCRIEN=+Y

 +17               SET BMCQ=0

 +18               QUIT

               End DoDot:1

               QUIT

 +19      ;

RR        ;routine referral selected

 +1       ;create entry with .01

 +2       ;%rcr

 +3       ;re-index

 +4       ;call die with other fields

 +5       ;set BMCRIEN,BMCQ=0

 +6       ;override post selection action

           SET BMCOVRPS=""

 +7        SET DIC="^BMCREF("

           SET DIC(0)="L"

           SET DLAYGO=90001

           SET X=BMCRDATE

           DO FILE^BMCFMC

 +8       ;kill override variable

           KILL BMCOVRPS

 +9        IF Y<0

               WRITE !,"Error creating REFERRAL.",!,"Notify programmer.",!

               DO EOP^BMC

               QUIT

 +10       SET BMCRIEN=+Y

 +11      ;call %RCR to copy routine referral into the newly created

 +12      ;RCIS Referral entry

 +13      ;move 0 node

           SET %X="^BMCRTNRF("_BMCRR_","

           SET %Y="^BMCREF("_BMCRIEN_","

           DO %XY^%RCR

 +14      ;BMC*4.0*8

           SET BMCSCOD=""

           SET BMCSTRM=""

 +15      ;BMC*4.0*8

           SET BMCSCOD=$PIECE($GET(^BMCRTNRF(BMCRR,13)),U,3)

           IF BMCSCOD

               SET BMCSTRM=$PIECE($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)

 +16      ;BMC*4.0*8

           SET $PIECE(^BMCREF(BMCRIEN,13),U,3)=""

 +17      ;kill off nodes that don't belong

           KILL ^BMCREF(BMCRIEN,61),^BMCREF(BMCRIEN,62)

 +18       IF $DATA(^BMCREF(BMCRIEN,21,0))

               IF $PIECE(^BMCREF(BMCRIEN,21,0),U,2)[3221

                   SET $PIECE(^BMCREF(BMCRIEN,21,0),U,2)="90001.21PA"

 +19      ;*******IMPORTANT - in line above, if nodes are added to the routine referral definition file, you must add the node to the line above

 +20       SET $PIECE(^BMCREF(BMCRIEN,0),U)=BMCRDATE

 +21      ;reindex entry

           SET DA=BMCRIEN

           SET DIK="^BMCREF("

           DO IX1^DIK

 +22      ;BMC*4.0*8 IHS.OIT.FCJ ADDING TOC STATUS

 +23       SET DIE="^BMCREF("

           SET DR=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.06////"_BMCPROV_";.15////A;.25////"_DUZ_";.26////"_DT_";.27////"_DT_";1304////P"

 +24       DO DIE^BMCFMC

 +25       IF $DATA(Y)

               WRITE !!,"Error in editing referral entry.  NOTIFY PROGRAMMER."

               QUIT

 +26       SET Y=BMCRIEN

           DO ^BMCREF

 +27       SET BMCQ=0

 +28       QUIT

 +29      ;

ADDVREF   ;EP FR BMCADDFY AND BMCADDS;ADD ENTRY TO V REF FILE ;BMC*4.0*8 NEW SECTION

 +1        SET DIC="^AUPNVREF("

           SET DIC(0)="L"

           SET DLAYGO=9000010.59

           SET X=BMCSCOD

 +2       ;BMC*4.0*12 MODIFIED NEXT LINE TO SET VISIT PROVIDER ENCOUNTER IN V REF

 +3       ;S DIC("DR")=".02////"_BMCDFN_";.03////"_BMCVDFN_";.06////"_BMCRIEN_";1201////"_$$NOW^XLFDT_";1202////"_BMCPROV_";1204////"_BMCPROV_";1216////"_$$NOW^XLFDT

 +4        SET DIC("DR")=".02////"_BMCDFN_";.03////"_BMCVDFN_";.06////"_BMCRIEN_";1201////"_$$NOW^XLFDT_";1202////"_BMCPROV_";1204////"_$$PRIMPROV^APCLV(BMCVDFN,"I")_";1216////"_$$NOW^XLFDT

 +5        DO FILE^BMCFMC

 +6        IF +Y<0

               WRITE !,"Error creating V REFERRAL.",!,"Notify programmer.",!

               DO EOP^BMC

               QUIT

 +7        SET BMCVRIE=+Y

 +8       ;Now add V Referral pointer to RCIS REFERRAL

 +9        KILL DIC

 +10       SET DIE="^BMCREF("

           SET DA=BMCRIEN

 +11       SET DR="1303////"_BMCVRIE

 +12       DO ^DIE

 +13       IF $DATA(Y)

               WRITE !,"Error adding V REFERRAL in RCIS Referral file.",!,"Notify programmer."

 +14       KILL DIE

 +15       QUIT

 +16      ;

ADD2      ;add if routine referrals have been defined

 +1        KILL BMCDISP,BMCSEL,BMCHIGH,BMCRR,BMCOUTR,BMCMINI,BMCMINIX

 +2        SET BMCHIGH=1

           SET BMCSEL(1)="Mini Referral"

 +3        SET BMCHIGH=2

           SET BMCSEL(2)="Complete Referral (all referral data)"

 +4       ;BMC*4.0*12 REMOVED- BY OUTSITE FACILITY

           SET BMCHIGH=3

           SET BMCSEL(3)="Call In Notification"

 +5        SET BMCHIGH=4

           SET BMCSEL(4)="Abbreviated entry for clinicians"

 +6        IF $DATA(IOF)

               WRITE @IOF

 +7        WRITE !,"Please select the referral form you wish to use."

 +8        WRITE !!?5,"1.  ",BMCSEL(1)

 +9        WRITE !?5,"2.  ",BMCSEL(2)

 +10       WRITE !?5,"3.  ",BMCSEL(3)

 +11       WRITE !?5,"4.  ",BMCSEL(4)

 +12       SET (X,BMCRRC)=0

FOR

               SET X=$ORDER(^BMCRTNRF("B",X))

               IF X=""

                   QUIT

               SET BMCRRC=BMCRRC+1

 +13       IF BMCRRC<31

               WRITE !!?5,"Locally-defined Routine Referral Templates:",!

 +14       SET X=0

FOR

               SET X=$ORDER(^BMCRTNRF("B",X))

               IF X=""

                   QUIT

               SET Y=$ORDER(^BMCRTNRF("B",X,""))

               SET BMCHIGH=BMCHIGH+1

               SET BMCSEL(BMCHIGH)=Y_U_$EXTRACT($PIECE(^BMCRTNRF(Y,0),U))_$EXTRACT($$LOW^XLFSTR($PIECE(^BMCRTNRF(Y,0),U)),2,999)

L16       ;

 +1        IF BMCRRC<16

               Begin DoDot:1

 +2                SET I=4

FOR

                       SET I=$ORDER(BMCSEL(I))

                       IF I'=+I

                           QUIT

                       WRITE !?5,I,".  ",$PIECE(BMCSEL(I),U,2)

 +3                DO GETANS

               End DoDot:1

 +4        IF BMCRRC>15&(BMCRRC<31)

               Begin DoDot:1

 +5                SET BMCCUT=(BMCHIGH-3)/2

                   IF BMCCUT'=(BMCCUT\1)

                       SET BMCCUT=(BMCCUT\1)+1

 +6                SET I=4

                   SET J=1

                   SET K=1

FOR

                       SET I=$ORDER(BMCSEL(I))

                       IF I'=+I!($DATA(BMCDISP(I)))

                           QUIT

                       WRITE !?5,I,")  ",$PIECE(BMCSEL(I),U,2)

                       SET BMCDISP(I)=""

                       SET J=I+BMCCUT

                       IF $DATA(BMCSEL(J))

                           IF '$DATA(BMCDISP(J))

                               WRITE ?40,J,")  ",$PIECE(BMCSEL(J),U,2)

                               SET BMCDISP(J)=""

 +7                DO GETANS

               End DoDot:1

G30       ;

 +1        IF BMCRRC>30

               Begin DoDot:1

 +2                SET BMCSEL(5)="5.  Select a locally defined routine referral template from a list"

 +3                WRITE !!?5,BMCSEL(5),!

 +4                WRITE !

                   SET DIR(0)="N^1:"_BMCHIGH_":0"

                   SET DIR("A")="Enter REFERRAL FORM "

                   SET DIR("B")=2

                   DO ^DIR

                   KILL DIR

 +5                IF $DATA(DIRUT)

                       QUIT

 +6                IF Y=2

                       SET BMCRR=""

                       QUIT

 +7                IF Y=3

                       SET BMCOUTR=1

                       SET BMCRR=""

                       QUIT

 +8                IF Y=1

                       SET BMCMINI=1

                       SET BMCRR=""

                       QUIT

 +9                IF Y=4

                       SET BMCMINIX=1

                       SET BMCRR=""

                       QUIT

 +10               IF Y=5

                       KILL BMCRR

                       DO ^BMCADD2

               End DoDot:1

 +11       QUIT

GETANS    ;

 +1        WRITE !

           SET DIR(0)="N^1:"_BMCHIGH_":0"

           SET DIR("A")="Enter REFERRAL FORM"

           SET DIR("B")=2

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               QUIT

 +3        IF Y=2

               SET BMCRR=""

               QUIT

 +4        IF Y=3

               SET BMCOUTR=1

               SET BMCRR=""

               QUIT

 +5        IF Y=1

               SET BMCMINI=1

               SET BMCRR=""

               QUIT

 +6        IF Y=4

               SET BMCMINIX=1

               SET BMCRR=""

               QUIT

 +7        SET BMCRR=Y

           SET BMCRR=$PIECE(BMCSEL(BMCRR),U)

 +8        QUIT

EDIT      ; EDIT REFERRAL RECORD JUST ADDED

 +1        SET DDSFILE=90001

           SET DA=BMCRIEN

 +2       ;4.0 IHS/OIT/FCJ ADDED A NEW FORM FOR CALL IN REFERRALS

 +3       ;S DR=$S($G(BMCMINI):"[BMCX REFERRAL ADD]",$G(BMCMINIX):"[BMCXX REFERRAL ADD]",1:"[BMC REFERRAL ADD]"),DDSPARM="C"

 +4        SET DR=$SELECT($GET(BMCMINI):"[BMCX REFERRAL ADD]",$GET(BMCMINIX):"[BMCXX REFERRAL ADD]",$GET(BMCOUTR):"[BMC REF ADD CALL-IN]",1:"[BMC REFERRAL ADD]")

           SET DDSPARM="C"

 +5        DO DDS^BMCFMC

 +6        IF '$GET(DDSCHANG)

               DO DELETE

               SET BMCQ=1

               QUIT

 +7        SET Y=BMCRIEN

 +8       ; set standard variables from record

           DO ^BMCREF

 +9       ;6.1.04 IHS/ITSC/FCJ TEST FOR PROVIDER

 +10       SET X=$SELECT(BMCRTYPE="I":$PIECE(^BMCREF(BMCRIEN,0),U,8),BMCRTYPE="N":$PIECE(^BMCREF(BMCRIEN,0),U,23),1:$PIECE(^BMCREF(BMCRIEN,0),U,7))

 +11       IF 'X

               WRITE !,"You must enter a Vendor, IHS Facility or In-House Clinic, depending on the",!,"referral type.",!

               DO PAUSE^BMC

               GOTO EDIT

 +12      ; get provisional dx's/px's

           DO DXPX

 +13      ;7/27/04 IHS/OIT/FCJ cmt nxt lne no longer asking for Case cmts

 +14      ; get Business Office comments except for MINIX and MINI

           IF '$GET(BMCMINI)&'$GET(BMCMINIX)

               DO BOCOM

 +15      ;               set static fields

           DO STATIC

 +16       QUIT

 +17      ;

DELETE    ; DELETE REFERRAL JUST ADDED BECAUSE OPERATOR DIDN'T FINISH

 +1        WRITE !!,"INCOMPLETE REFERRAL BEING DELETED!",!!

 +2        SET DIK="^BMCREF("

           SET DA=BMCRIEN

           DO ^DIK

 +3        DO PAUSE^BMC

 +4        QUIT

 +5       ;

DXPX      ; GET PROVIDIONAL DIAGNOSES/PROCEDURES IF WANTED

 +1        DO DXPX^BMCADD1

 +2        QUIT

CSECOM    ;EP; GET CASE COMMENTS

 +1        WRITE !

 +2        SET DIR("A")="Do you want to enter Case Review Comments"

 +3        SET BMCCTYP="C"

 +4        DO COMMENTS

 +5       ;

MGDCARE   ; Get Managed Care Committee Action

 +1        DO MGDCARE^BMCADD1

 +2        QUIT

 +3       ;

MEDCOM    ;EP;MEDICAL HX/FINDINGS COMMENTS

 +1        WRITE !

 +2        SET DIR("A")="Do you want to enter Medical HX and Findings Comments"

 +3        SET BMCCTYP="M"

 +4        DO COMMENTS

 +5        WRITE !

 +6        QUIT

BOCOM     ;EP;BUSINESS OFFCIE COMMENTS

 +1        WRITE !

 +2        SET DIR("A")="Do you want to enter Business Office/CHS Comments"

 +3        SET BMCCTYP="B"

 +4        DO COMMENTS

 +5        QUIT

COMMENTS  ;EP

 +1        SET DIR(0)="Y"

           SET DIR("B")="N"

           SET DIR("?")="Enter 'YES' to enter comments now."

 +2        IF BMCCTYP="M"

               SET DIR("B")="Y"

 +3        DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)!'Y

               QUIT

 +5        DO COMMENTS^BMCADD1

 +6        QUIT

 +7       ;

STATIC    ; STORE STATIC DATA

 +1        DO STATIC^BMCADD1

 +2        QUIT

 +3       ;

EOJ       ; END OF JOB

 +1        DO ^BMCKILL

 +2        QUIT

BMCADD.m