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
Q
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
Q
;
PATIENT ; GET PATIENT
F D PATIENT2 I BMCQ!($G(BMCDFN)) Q
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 !
Q
;
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
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
Q
;
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
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)="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
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
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
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
;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
Q
;
STATIC ; STORE STATIC DATA
D STATIC^BMCADD1
Q
;
EOJ ; END OF JOB
D ^BMCKILL
Q
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
