Routine: BMCADDFY

BMCADDFY ; IHS/PHXAO/TMJ - ADD A NEW REFERRAL FOR A SPECIFIC FISCAL YEAR ;      [ 01/09/2006  3:51 PM ]

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

 ;IHS/OIT/FCJ REMOVE AUTO SEND MSGS ;ADD TYP OF COM

 ;    ;CHNGD COM CALL, BO & MED HX, WILL NOT BE CALLED FR FORM,

 ;    ;CHNGD OPT 1 & 4 DSPLY NAMES

 ;    Rmvd asking for Case com;Tst for SR;add new form for call-ins

 ;BMC*4.0*8 7.2.13 IHS.OIT.FCJ TST FOR REF NUMBER ALREADY USED

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

 ; 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,BMCMODE="A",(BMCLOOK,BMCVDFN,BMCSTRM,BMCSNO,BMCSCOD)="" ;BMC*4.0*10 ADDED BMCVDFN AND BMCSTRM

 ;S BMCQ=0,BMCMODE="A",(BMCLOOK,BMCVDFN,BMCSTRM)="" ;BMC*4.0*8 ADDED BMCVDFN AND BMCSTRM

 S APCDOVRR=""

 D PATIENT ;      get pat being referred

 Q:BMCQ

 D REFDISP

 I BMCQ=1 G GETDATE

 D ASK

 Q:BMCQ

GETDATE ;Do Get Date if no existing Refs

 D DATE ;         get date of ref

 Q:BMCQ

 D NUMBER ;       get next ref number

 Q:BMCQ

 D ADD ;          add new ref

 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 ref record just added

 Q:BMCQ                                        ;BMC*4.0*8

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

PATIENT ; GET PATIENT

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

PATIENT2 ;ASK FOR PAT 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 ;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 ;Display if Pat has existing Refs

 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,BMCDT="",CT=5  ;BMC*4.0*9 ADDED CT TO NXT 3 LINES

 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/OIT/FCJ TST FOR SR

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

 .D START^BMCLKID1

 .S CT=CT-1  ;S I=I+1 ;limit display to 5 referrals ;BMC*4.0*9

DATE ;GET DT OF REF

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 Q

 ;Search index if ref exists for patient/date, 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 Q

PROV ;GET REQ PROV

 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 Q

NUMBER ;GENERATE REF NUMBER

 W !!,?5,"You will now be asked for a 2-Digit Fiscal Year and a Referral Number.",!

 W ?5,"The last 10 Referrals for that Fiscal Year will be displayed on screen.",!

 W ?5,"Enter the next desired number for that Fiscal Year (1-5 Characters)",!

 S BMCQ=1

 S DIR(0)="F^2:2^K:X'?2N X",DIR("A")="Enter the Desired Fiscal Year",DIR("?")="Enter the 2 Digit Fiscal Year - 2001=01 - 2002=02 etc." KILL DA D ^DIR KILL DIR

 S BMCFY=Y

 I '$D(BMCFY) D EOP^BMC Q

 S BMCSUFAC=$$ASF^BMC

 Q:'BMCSUFAC

 S BMCSTART=BMCSUFAC_BMCFY

 Q:'BMCSTART

SHOW ;Display last 5-10 Referrals #

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

 W ?10,"**LAST 10 REFERRALS FOR FISCAL YEAR "_BMCFY_"**",!,?25,"********************",!

 I '$D(^BMCREF("FY",BMCSTART)) W !,?10,"**--NO EXISTING REFERRALS FOR THIS FISCAL YEAR--**",! S BMCQ=1 Q

 S BMCQ=0,BMCIEN="",I=0

 F  S BMCIEN=$O(^BMCREF("FY",BMCSTART,BMCIEN),-1) Q:(BMCIEN="")!(I=10)  D

 . Q:BMCIEN=""

 . Q:$P($G(^BMCREF(BMCIEN,1)),U,1)'=""

 . W !,?10,$P($G(^BMCREF(BMCIEN,0)),U,2)

 .S I=I+1

REFNUM ;Get Referral Number Choice

W !

 S DIR(0)="F^1:5",DIR("A")="Enter the Desired Referral Number",DIR("?")="Enter a whole number-Do NOT preceed with Zero's 1-5 characters in length" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D EOP^BMC G NUMBER

 S BMCRNUM=+Y

 I BMCRNUM<1 G REFNUM

 I 'BMCRNUM D EOP^BMC Q

 S X=$$REFNFY^BMC

 Q:'X

 I $D(^BMCREF("C",X)) W !,"Referral number already used, try another number.",! G REFNUM     ;BMC*4.0*8 IHS.OIT.FCJ PREVENT USING THE SAME NUMBER

 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,BMCQ=0 Q

ADD ; ADD NEW REFERRAL RECORD

 S BMCQ=1

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

 E  S BMCRR=""

 D PROV Q:BMCQ

 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"

 .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

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 ref 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($$DESC^BSTSAPI(BMCSCOD),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

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)="Referral initiated by outside 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

 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

 ;IHS/OIT/FCJ no longer asking for Case cmts

 D:'$G(BMCMINI)&'$G(BMCMINIX) BOCOM^BMCADD   ; get Business Office comments except for MINIX and MINI ; NO LONGER ON FORM

 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

 ;IHS/OIT/FCJ ADDED TYPE OF COMMENT NXT LINE

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

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

 D ^DIR K DIR

 Q:$D(DIRUT)!'Y

 D COMMENTS^BMCADD1

STATIC ; STORE STATIC DATA

 D STATIC^BMCADD1

EOJ ; END OF JOB

 D ^BMCKILL

BMCADDFY  ; IHS/PHXAO/TMJ - ADD A NEW REFERRAL FOR A SPECIFIC FISCAL YEAR ;      [ 01/09/2006  3:51 PM ]

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

 +2       ;IHS/OIT/FCJ REMOVE AUTO SEND MSGS ;ADD TYP OF COM

 +3       ;    ;CHNGD COM CALL, BO & MED HX, WILL NOT BE CALLED FR FORM,

 +4       ;    ;CHNGD OPT 1 & 4 DSPLY NAMES

 +5       ;    Rmvd asking for Case com;Tst for SR;add new form for call-ins

 +6       ;BMC*4.0*8 7.2.13 IHS.OIT.FCJ TST FOR REF NUMBER ALREADY USED

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

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

 +9       ; Subscripted BMCREC is EXTERNAL form.

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

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

 +12      ;   BMCDFN=patient ien

 +13      ;   BMCRDATE=referral date in internal FileMan form

 +14      ;   BMCRNUMB=referral number

 +15      ;   BMCRIEN=referral ien

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

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

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

 +19      ;

START     ;

 +1        IF $GET(BMCPARM)=""

               DO PARMSET^BMC

 +2        FOR

               DO MAIN

               IF BMCQ

                   QUIT

               DO HDR^BMC

 +3        DO EOJ

 +4        QUIT

MAIN      ;

 +1       ;BMC*4.0*10 ADDED BMCVDFN AND BMCSTRM

           SET BMCQ=0

           SET BMCMODE="A"

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

 +2       ;S BMCQ=0,BMCMODE="A",(BMCLOOK,BMCVDFN,BMCSTRM)="" ;BMC*4.0*8 ADDED BMCVDFN AND BMCSTRM

 +3        SET APCDOVRR=""

 +4       ;      get pat being referred

           DO PATIENT

 +5        IF BMCQ

               QUIT

 +6        DO REFDISP

 +7        IF BMCQ=1

               GOTO GETDATE

 +8        DO ASK

 +9        IF BMCQ

               QUIT

 +10      ;

GETDATE   ;Do Get Date if no existing Refs

 +1       ;         get date of ref

           DO DATE

 +2        IF BMCQ

               QUIT

 +3       ;       get next ref number

           DO NUMBER

 +4        IF BMCQ

               QUIT

 +5       ;          add new ref

           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 ref 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^BMCADD

 +11       QUIT

 +12      ;

PATIENT   ; GET PATIENT

 +1        FOR

               DO PATIENT2

               IF BMCQ!($GET(BMCDFN))

                   QUIT

 +2        QUIT

 +3       ;

PATIENT2  ;ASK FOR PAT UNTIL USER SELECTS OR QUITS

 +1        SET BMCQ=1

           SET DIC="^AUPNPAT("

           SET DIC(0)="AEMQ"

           DO DIC^BMCFMC

 +2        IF Y<1

               QUIT

 +3        SET BMCDFN=+Y

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

 +4        SET BMCQ=0

 +5        IF $$DOD^AUPNPAT(BMCDFN)

               Begin DoDot:1

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

 +7                SET DIR(0)="YO"

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

                   SET DIR("B")="NO"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +8                WRITE !

               End DoDot:1

               IF 'Y

                   KILL BMCDFN,BMCREC("PAT NAME")

                   QUIT

 +9        QUIT

 +10      ;

ASK       ;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   ;Display if Pat has existing Refs

 +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       ;BMC*4.0*9 ADDED CT TO NXT 3 LINES

           SET BMCQ=0

           SET BMCDT=""

           SET CT=5

 +5        FOR I=1:1:5

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

               IF BMCDT=""

                   QUIT

               DO NEXT

               IF CT=0

                   QUIT

 +6        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/OIT/FCJ TST FOR SR

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

                       QUIT

 +6       ;BMC*4.0*9

                   IF CT=0

                       QUIT

 +7                DO START^BMCLKID1

 +8       ;S I=I+1 ;limit display to 5 referrals ;BMC*4.0*9

                   SET CT=CT-1

               End DoDot:1

 +9        QUIT

 +10      ;

DATE      ;GET DT OF REF

 +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

           QUIT

 +7       ;Search index if ref exists for patient/date, display message.

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

               Begin DoDot:1

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

 +10               DO EOP^BMC

               End DoDot:1

               QUIT

 +11       SET BMCQ=0

           QUIT

 +12      ;

PROV      ;GET REQ PROV

 +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

           QUIT

NUMBER    ;GENERATE REF NUMBER

 +1        WRITE !!,?5,"You will now be asked for a 2-Digit Fiscal Year and a Referral Number.",!

 +2        WRITE ?5,"The last 10 Referrals for that Fiscal Year will be displayed on screen.",!

 +3        WRITE ?5,"Enter the next desired number for that Fiscal Year (1-5 Characters)",!

 +4       ;

 +5        SET BMCQ=1

 +6        SET DIR(0)="F^2:2^K:X'?2N X"

           SET DIR("A")="Enter the Desired Fiscal Year"

           SET DIR("?")="Enter the 2 Digit Fiscal Year - 2001=01 - 2002=02 etc."

           KILL DA

           DO ^DIR

           KILL DIR

 +7        SET BMCFY=Y

 +8        IF '$DATA(BMCFY)

               DO EOP^BMC

               QUIT

 +9       ;

 +10       SET BMCSUFAC=$$ASF^BMC

 +11       IF 'BMCSUFAC

               QUIT

 +12       SET BMCSTART=BMCSUFAC_BMCFY

 +13       IF 'BMCSTART

               QUIT

SHOW      ;Display last 5-10 Referrals #

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

 +2        WRITE ?10,"**LAST 10 REFERRALS FOR FISCAL YEAR "_BMCFY_"**",!,?25,"********************",!

 +3        IF '$DATA(^BMCREF("FY",BMCSTART))

               WRITE !,?10,"**--NO EXISTING REFERRALS FOR THIS FISCAL YEAR--**",!

               SET BMCQ=1

               QUIT

 +4        SET BMCQ=0

           SET BMCIEN=""

           SET I=0

 +5        FOR

               SET BMCIEN=$ORDER(^BMCREF("FY",BMCSTART,BMCIEN),-1)

               IF (BMCIEN="")!(I=10)

                   QUIT

               Begin DoDot:1

 +6                IF BMCIEN=""

                       QUIT

 +7                IF $PIECE($GET(^BMCREF(BMCIEN,1)),U,1)'=""

                       QUIT

 +8                WRITE !,?10,$PIECE($GET(^BMCREF(BMCIEN,0)),U,2)

 +9                SET I=I+1

               End DoDot:1

 +10      ;

REFNUM    ;Get Referral Number Choice

 +1        WRITE !

 +2        SET DIR(0)="F^1:5"

           SET DIR("A")="Enter the Desired Referral Number"

           SET DIR("?")="Enter a whole number-Do NOT preceed with Zero's 1-5 characters in length"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               DO EOP^BMC

               GOTO NUMBER

 +4        SET BMCRNUM=+Y

 +5        IF BMCRNUM<1

               GOTO REFNUM

 +6        IF 'BMCRNUM

               DO EOP^BMC

               QUIT

 +7       ;

 +8        SET X=$$REFNFY^BMC

 +9        IF 'X

               QUIT

 +10      ;BMC*4.0*8 IHS.OIT.FCJ PREVENT USING THE SAME NUMBER

           IF $DATA(^BMCREF("C",X))

               WRITE !,"Referral number already used, try another number.",!

               GOTO REFNUM

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

 +12       IF '$DATA(X)

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

               DO EOP^BMC

               QUIT

 +13       SET BMCRNUMB=X

           SET BMCQ=0

           QUIT

 +14      ;

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

           IF BMCQ

               QUIT

 +5        IF BMCRR=""

               Begin DoDot:1

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

 +7                SET DIC="^BMCREF("

                   SET DIC(0)="L"

                   SET DLAYGO=90001

                   SET X=BMCRDATE

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

 +9                DO FILE^BMCFMC

 +10               IF Y<0

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

                       DO EOP^BMC

                       QUIT

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

 +12               SET BMCRIEN=+Y

 +13               SET BMCQ=0

               End DoDot:1

               QUIT

RR        ;routine referral selected

 +1       ;create entry with .01 ;%rcr

 +2       ;re-index ;call die with other fields

 +3       ;set BMCRIEN,BMCQ=0

 +4       ;override post selection action

           SET BMCOVRPS=""

 +5        SET DIC="^BMCREF("

           SET DIC(0)="L"

           SET DLAYGO=90001

           SET X=BMCRDATE

           DO FILE^BMCFMC

 +6       ;kill override variable

           KILL BMCOVRPS

 +7        IF Y<0

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

               DO EOP^BMC

               QUIT

 +8        SET BMCRIEN=+Y

 +9       ;call %RCR to copy routine ref into the newly created

 +10      ;RCIS Referral entry

 +11      ;move 0 node

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

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

           DO %XY^%RCR

 +12      ;BMC*4.0*8

           SET BMCSCOD=""

           SET BMCSTRM=""

 +13      ;BMC*4.0*8

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

           IF BMCSCOD

               SET BMCSTRM=$PIECE($$DESC^BSTSAPI(BMCSCOD),U,2)

 +14      ;BMC*4.0*8

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

 +15      ;kill off nodes that don't belong

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

 +16       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"

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

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

 +19      ;reindex entry

           SET DA=BMCRIEN

           SET DIK="^BMCREF("

           DO IX1^DIK

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

 +21       SET DIE="^BMCREF("

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

 +22       DO DIE^BMCFMC

 +23       IF $DATA(Y)

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

               QUIT

 +24       SET Y=BMCRIEN

           DO ^BMCREF

 +25       SET BMCQ=0

 +26       QUIT

 +27      ;

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        SET BMCHIGH=3

           SET BMCSEL(3)="Referral initiated by outside facility"

 +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        IF BMCRRC<16

               Begin DoDot:1

 +1                SET I=4

FOR

                       SET I=$ORDER(BMCSEL(I))

                       IF I'=+I

                           QUIT

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

 +2                DO GETANS

               End DoDot:1

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

               Begin DoDot:1

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

                   IF BMCCUT'=(BMCCUT\1)

                       SET BMCCUT=(BMCCUT\1)+1

 +5                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)=""

 +6                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        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))

 +10       IF 'X

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

               DO PAUSE^BMC

               GOTO EDIT

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

           DO DXPX

 +12      ;IHS/OIT/FCJ no longer asking for Case cmts

 +13      ; get Business Office comments except for MINIX and MINI ; NO LONGER ON FORM

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

               DO BOCOM^BMCADD

 +14      ;               set static fields

           DO STATIC

 +15       QUIT

 +16      ;

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

 +3       ;IHS/OIT/FCJ ADDED TYPE OF COMMENT NXT LINE

 +4        SET BMCCTYP="C"

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

 +5        SET DIR(0)="Y"

           SET DIR("B")="N"

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

 +6        DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)!'Y

               QUIT

 +8        DO COMMENTS^BMCADD1

 +9        QUIT

 +10      ;

STATIC    ; STORE STATIC DATA

 +1        DO STATIC^BMCADD1

 +2        QUIT

 +3       ;

EOJ       ; END OF JOB

 +1        DO ^BMCKILL

 +2        QUIT

BMCADDFY.m