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
Q
;
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
Q
;
PATIENT ;EP; GET PATIENT
F D PATIENT2 I BMCQ!($G(BMCDFN)) Q
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 !
Q
;
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
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
Q
;
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
Q
; 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
Q
;
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
Q
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
Q
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
Q
;
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
Q
;
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
Q
;
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
Q
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)
Q
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
Q
;
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
Q
;
DXPX ; GET PROVIDIONAL DIAGNOSES/PROCEDURES IF WANTED
D DXPX^BMCADD1
Q
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
Q
;
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 !
Q
BOCOM ;EP;BUSINESS OFFCIE COMMENTS
W !
S DIR("A")="Do you want to enter Business Office/CHS Comments"
S BMCCTYP="B"
D COMMENTS
Q
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
Q
;
STATIC ; STORE STATIC DATA
D STATIC^BMCADD1
Q
;
EOJ ; END OF JOB
D ^BMCKILL
Q
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
+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
