BMCMINI ; IHS/PHXAO/TMJ - MINI ADD A NEW REFERRAL ;
;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
;ITSC/IHS/FCJ MOVED REQ TO SND MSG AFTER ENTRY OF REF
;
; 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=""
S APCDOVRR=""
D PATIENT ; get patient being referred
Q:BMCQ
D DATE ; get date of referral
Q:BMCQ
D NUMBER ; get next referral number
Q:BMCQ
D ADD ; add new referral record
Q:BMCQ
D EDIT ; edit referral record just added
Q
;
PATIENT ; 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
Q
;
DATE ; GET DATE OF REFERRAL
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
;commented out check on 2 on one day
; 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
;.Q
S BMCQ=0
Q
;
NUMBER ; GENERATE REFERRAL NUMBER
S BMCQ=1
S X=$$REFN^BMC
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
S DIC="^BMCREF(",DIC(0)="L",DLAYGO=90001,DIC("DR")=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.15////A;.25////"_DUZ_";.26////"_DT_";.27////"_DT,X=BMCRDATE
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
;
EDIT ; EDIT REFERRAL RECORD JUST ADDED
S DDSFILE=90001,DA=BMCRIEN,DR="[BMCX 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
;
D DXPX ; get provisional dx's/px's
;D COMMENTS ; get comments
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
Q:'BMCDXPR ; quit if site not entering dx/px
D DX
;D PX ;BMC*4.0*9
D PROC^BMCMOD ;BMC*4.0*9
Q
;
DX ; GET PROVISIONAL DIAGNOSES
W:$D(IOF) @IOF
W !?5,"Referral #: ",$$REFN^BMC
W !?5,"Referral Date: " S Y=$P(^BMCREF(BMCRIEN,0),U) D DD^%DT W Y
W ?40,"Patient Name: ",$P(^DPT(BMCDFN,0),U)
W !!
S DIR(0)="Y",DIR("A")="Do you want to enter a Provisional Diagnosis",DIR("B")="Y",DIR("?")="Enter 'YES' to enter provisional diagnoses now."
D ^DIR K DIR
Q:$D(DIRUT)
I Y S BMCQ=0 F D Q:BMCQ
. S BMCLOOK=1
. S BMCDXT="P"
. S DIE="^BMCREF(",DA=BMCRIEN,DR="[BMC DIAGNOSIS ADD]"
. D DIE^BMCFMC
. K BMCLOOK
. S:'$G(BMCDX) BMCQ=1
. K BMCDX
. Q
S BMCQ=0
Q
;
PX ; GET PROVISIONAL PROCEDURES
W !
S DIR(0)="Y",DIR("A")="Do you want to enter a Provisional Procedure",DIR("B")="Y",DIR("?")="Enter 'YES' to enter provisional procedures now."
D ^DIR K DIR
Q:$D(DIRUT)
I Y S BMCQ=0 F D Q:BMCQ
. S BMCLOOK=1
. S BMCPXT="P"
. S DIE="^BMCREF(",DA=BMCRIEN,DR="[BMC PROCEDURE ADD]"
. D DIE^BMCFMC
. K BMCLOOK
. S:'$G(BMCPX) BMCQ=1
. K BMCPX
. Q
S BMCQ=0
Q
;
W !
S DIR(0)="Y",DIR("A")="Do you want to enter Case Review Comments",DIR("B")="N",DIR("?")="Enter 'YES' to enter comments now."
D ^DIR K DIR
Q:$D(DIRUT)
I Y S BMCQ=0 D
. S BMCLOOK=1
. S DIE="^BMCREF(",DA=BMCRIEN,DR="[BMC COMMENTS ADD]"
. D DIE^BMCFMC
. K BMCLOOK
. S DIE="^BMCREF(",DA=BMCRIEN,DR=".31"
. D DIE^BMCFMC
. Q
S BMCQ=0
Q
;
STATIC ; STORE STATIC DATA
W !,"Storing static fields....",!
;
S BMCREC=^BMCREF(BMCRIEN,0)
S Y=^DPT(BMCDFN,0)
S DR="5101///"_$P(Y,U) ; name
S DR=DR_";5103///"_$P(Y,U,3) ; dob
S DR=DR_";5104///"_$P(Y,U,9) ; ssn
S DR=DR_";5107///"_$P(Y,U,2) ; sex
S %=$P(BMCREC,U,5)
I % D
. S DR=DR_";5102///"_$P($G(^AUPNPAT(BMCDFN,41,%,0)),U,2) ; chart #
. S DR=DR_";5113///"_$P($G(^DIC(4,%,0)),U) ; facility
. S DR=DR_";5114///"_$P($G(^AUTTLOC(%,0)),U,10) ; asufac
. Q
S Y=$G(^AUPNPAT(BMCDFN,51))
I $P(Y,U,18)'="" S DR=DR_";5105///"_$P(Y,U,18) ; comm
I $P(Y,U,8) S DR=DR_";5106///"_$P($G(^AUTTTRI($P(Y,U,8),0)),U,2) ; tribe
S %=$P(BMCREC,U,7)
I % D
. S DR=DR_";5108///"_$P($G(^AUTTVNDR(%,0)),U) ; vendor
. S DR=DR_";5109///"_$P($G(^AUTTVNDR(%,51)),U) ; ein
. Q
S %=$P(BMCREC,U)
S DR=DR_";5110///"_$$MCR^AUPNPAT(BMCDFN,%) ; medicare
S DR=DR_";5111///"_$$MCD^AUPNPAT(BMCDFN,%) ; medicaid
S DR=DR_";5112///"_$$PI^AUPNPAT(BMCDFN,%) ; private insurance
;
S DIE="^BMCREF(",DA=BMCRIEN
D DIE^BMCFMC
W !,"Entry of Referral ",$P(^BMCREF(BMCRIEN,0),U,2)," is complete.",!
;IHS/ITSC/FCJ ADD 4 LINES TO REQ TO SEND MESSAGE
I BMCCHSA,BMCRTYPE="C" D ENMM^BMCBULL
I BMCIHSA,BMCRTYPE="I" D ENMM^BMCBULL
I BMCOTHRA,BMCRTYPE="O" D ENMM^BMCBULL
I BMCHOUSA,BMCRTYPE="N" D ENMM^BMCBULL
D EOP^BMC
Q
;
EOJ ; END OF JOB
D ^BMCKILL
Q
BMCMINI ; IHS/PHXAO/TMJ - MINI ADD A NEW REFERRAL ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 101
+2 ;ITSC/IHS/FCJ MOVED REQ TO SND MSG AFTER ENTRY OF REF
+3 ;
+4 ; See ^BMCVDOC for system wide variables set by main menu
+5 ;
+6 ; Subscripted BMCREC is EXTERNAL form.
+7 ; BMCREC("PAT NAME")=patient name
+8 ; BMCREC("REF DATE")=referral date
+9 ; BMCDFN=patient ien
+10 ; BMCRDATE=referral date in internal FileMan form
+11 ; BMCRNUMB=referral number
+12 ; BMCRIEN=referral ien
+13 ; BMCMODE=A for add, M for modify
+14 ; BMCRTYPE=type of referral (.04 field)
+15 ; BMCRIO=Inpatient or Outpatient (.14 field)
+16 ;
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 SET BMCMODE="A"
SET BMCLOOK=""
+3 SET APCDOVRR=""
+4 ; get patient being referred
DO PATIENT
+5 IF BMCQ
QUIT
+6 ; get date of referral
DO DATE
+7 IF BMCQ
QUIT
+8 ; get next referral number
DO NUMBER
+9 IF BMCQ
QUIT
+10 ; add new referral record
DO ADD
+11 IF BMCQ
QUIT
+12 ; edit referral record just added
DO EDIT
+13 QUIT
+14 ;
PATIENT ; 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 !
+10 QUIT
End DoDot:1
IF 'Y
KILL BMCDFN,BMCREC("PAT NAME")
QUIT
+11 QUIT
+12 ;
DATE ; GET DATE OF REFERRAL
+1 SET BMCQ=1
+2 SET DIR(0)="90001,.01"
SET DIR("B")="TODAY"
KILL DA
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+3 SET BMCRDATE=+Y
SET BMCREC("REF DATE")=Y(0)
+4 SET BMCQ=0
+5 QUIT
+6 ;commented out check on 2 on one day
+7 ; Search index to determine if referral exists for patient/date.
+8 ; If so, display message.
+9 ;
+10 ;I $D(^BMCREF("AA",BMCDFN,BMCRDATE)) D Q
+11 ;.W !!,"A REFERRAL FOR '",BMCREC("PAT NAME"),"', ON '",BMCREC("REF DATE"),"' EXISTS.",!,"USE THE 'MODIFY' OPTION TO EDIT THE REFERRAL.",!
+12 ;.D EOP^BMC
+13 ;.Q
+14 SET BMCQ=0
+15 QUIT
+16 ;
NUMBER ; GENERATE REFERRAL NUMBER
+1 SET BMCQ=1
+2 SET X=$$REFN^BMC
+3 XECUTE $PIECE(^DD(90001,.02,0),U,5,99)
+4 IF '$DATA(X)
WRITE !,"Error generating new referral number. Notify programmer.",!
DO EOP^BMC
QUIT
+5 SET BMCRNUMB=X
+6 SET BMCQ=0
+7 QUIT
+8 ;
ADD ; ADD NEW REFERRAL RECORD
+1 SET BMCQ=1
+2 SET DIC="^BMCREF("
SET DIC(0)="L"
SET DLAYGO=90001
SET DIC("DR")=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.15////A;.25////"_DUZ_";.26////"_DT_";.27////"_DT
SET X=BMCRDATE
+3 DO FILE^BMCFMC
+4 IF Y<0
WRITE !,"Error creating REFERRAL.",!,"Notify programmer.",!
DO EOP^BMC
QUIT
+5 WRITE !!,"REFERRAL number : ",BMCRNUMB,!
+6 ;
+7 SET BMCRIEN=+Y
+8 SET BMCQ=0
+9 QUIT
+10 ;
EDIT ; EDIT REFERRAL RECORD JUST ADDED
+1 SET DDSFILE=90001
SET DA=BMCRIEN
SET DR="[BMCX REFERRAL ADD]"
SET DDSPARM="C"
+2 DO DDS^BMCFMC
+3 IF '$GET(DDSCHANG)
DO DELETE
SET BMCQ=1
QUIT
+4 SET Y=BMCRIEN
+5 ; set standard variables from record
DO ^BMCREF
+6 ;
+7 ; get provisional dx's/px's
DO DXPX
+8 ;D COMMENTS ; get comments
+9 ; set static fields
DO STATIC
+10 QUIT
+11 ;
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 ; quit if site not entering dx/px
IF 'BMCDXPR
QUIT
+2 DO DX
+3 ;D PX ;BMC*4.0*9
+4 ;BMC*4.0*9
DO PROC^BMCMOD
+5 QUIT
+6 ;
DX ; GET PROVISIONAL DIAGNOSES
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !?5,"Referral #: ",$$REFN^BMC
+3 WRITE !?5,"Referral Date: "
SET Y=$PIECE(^BMCREF(BMCRIEN,0),U)
DO DD^%DT
WRITE Y
+4 WRITE ?40,"Patient Name: ",$PIECE(^DPT(BMCDFN,0),U)
+5 WRITE !!
+6 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter a Provisional Diagnosis"
SET DIR("B")="Y"
SET DIR("?")="Enter 'YES' to enter provisional diagnoses now."
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
QUIT
+9 IF Y
SET BMCQ=0
FOR
Begin DoDot:1
+10 SET BMCLOOK=1
+11 SET BMCDXT="P"
+12 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR="[BMC DIAGNOSIS ADD]"
+13 DO DIE^BMCFMC
+14 KILL BMCLOOK
+15 IF '$GET(BMCDX)
SET BMCQ=1
+16 KILL BMCDX
+17 QUIT
End DoDot:1
IF BMCQ
QUIT
+18 SET BMCQ=0
+19 QUIT
+20 ;
PX ; GET PROVISIONAL PROCEDURES
+1 WRITE !
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter a Provisional Procedure"
SET DIR("B")="Y"
SET DIR("?")="Enter 'YES' to enter provisional procedures now."
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 IF Y
SET BMCQ=0
FOR
Begin DoDot:1
+6 SET BMCLOOK=1
+7 SET BMCPXT="P"
+8 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR="[BMC PROCEDURE ADD]"
+9 DO DIE^BMCFMC
+10 KILL BMCLOOK
+11 IF '$GET(BMCPX)
SET BMCQ=1
+12 KILL BMCPX
+13 QUIT
End DoDot:1
IF BMCQ
QUIT
+14 SET BMCQ=0
+15 QUIT
+16 ;
+1 WRITE !
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter Case Review Comments"
SET DIR("B")="N"
SET DIR("?")="Enter 'YES' to enter comments now."
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 IF Y
SET BMCQ=0
Begin DoDot:1
+6 SET BMCLOOK=1
+7 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR="[BMC COMMENTS ADD]"
+8 DO DIE^BMCFMC
+9 KILL BMCLOOK
+10 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR=".31"
+11 DO DIE^BMCFMC
+12 QUIT
End DoDot:1
+13 SET BMCQ=0
+14 QUIT
+15 ;
STATIC ; STORE STATIC DATA
+1 WRITE !,"Storing static fields....",!
+2 ;
+3 SET BMCREC=^BMCREF(BMCRIEN,0)
+4 SET Y=^DPT(BMCDFN,0)
+5 ; name
SET DR="5101///"_$PIECE(Y,U)
+6 ; dob
SET DR=DR_";5103///"_$PIECE(Y,U,3)
+7 ; ssn
SET DR=DR_";5104///"_$PIECE(Y,U,9)
+8 ; sex
SET DR=DR_";5107///"_$PIECE(Y,U,2)
+9 SET %=$PIECE(BMCREC,U,5)
+10 IF %
Begin DoDot:1
+11 ; chart #
SET DR=DR_";5102///"_$PIECE($GET(^AUPNPAT(BMCDFN,41,%,0)),U,2)
+12 ; facility
SET DR=DR_";5113///"_$PIECE($GET(^DIC(4,%,0)),U)
+13 ; asufac
SET DR=DR_";5114///"_$PIECE($GET(^AUTTLOC(%,0)),U,10)
+14 QUIT
End DoDot:1
+15 SET Y=$GET(^AUPNPAT(BMCDFN,51))
+16 ; comm
IF $PIECE(Y,U,18)'=""
SET DR=DR_";5105///"_$PIECE(Y,U,18)
+17 ; tribe
IF $PIECE(Y,U,8)
SET DR=DR_";5106///"_$PIECE($GET(^AUTTTRI($PIECE(Y,U,8),0)),U,2)
+18 SET %=$PIECE(BMCREC,U,7)
+19 IF %
Begin DoDot:1
+20 ; vendor
SET DR=DR_";5108///"_$PIECE($GET(^AUTTVNDR(%,0)),U)
+21 ; ein
SET DR=DR_";5109///"_$PIECE($GET(^AUTTVNDR(%,51)),U)
+22 QUIT
End DoDot:1
+23 SET %=$PIECE(BMCREC,U)
+24 ; medicare
SET DR=DR_";5110///"_$$MCR^AUPNPAT(BMCDFN,%)
+25 ; medicaid
SET DR=DR_";5111///"_$$MCD^AUPNPAT(BMCDFN,%)
+26 ; private insurance
SET DR=DR_";5112///"_$$PI^AUPNPAT(BMCDFN,%)
+27 ;
+28 SET DIE="^BMCREF("
SET DA=BMCRIEN
+29 DO DIE^BMCFMC
+30 WRITE !,"Entry of Referral ",$PIECE(^BMCREF(BMCRIEN,0),U,2)," is complete.",!
+31 ;IHS/ITSC/FCJ ADD 4 LINES TO REQ TO SEND MESSAGE
+32 IF BMCCHSA
IF BMCRTYPE="C"
DO ENMM^BMCBULL
+33 IF BMCIHSA
IF BMCRTYPE="I"
DO ENMM^BMCBULL
+34 IF BMCOTHRA
IF BMCRTYPE="O"
DO ENMM^BMCBULL
+35 IF BMCHOUSA
IF BMCRTYPE="N"
DO ENMM^BMCBULL
+36 DO EOP^BMC
+37 QUIT
+38 ;
EOJ ; END OF JOB
+1 DO ^BMCKILL
+2 QUIT
