BMCADD1 ; IHS/PHXAO/TMJ - add a referral part 2 ;
;;4.0;REFERRED CARE INFO SYSTEM;**3,9,10**;JAN 09, 2006;Build 101
;
;IHS/ITSC/FCJ ADD REQUEST TO SEND A MESSAGE
; MODIFIED COMMENTS SECTION, TO ALLOW
; BUS OFF AND MED HX TO CALL FROM BMCADD
;4.0*3 9.27.2007 IHS/OIT/FCJ Added test to send Alert to Physicians
;4.0*9 1-1-2013 IHS/OIT/FCJ Multiple changes for ICD-10
;
DXPX ;EP GET PROVIDIONAL DIAGNOSES/PROCEDURES IF WANTED
D MEDHX
Q:'BMCDXPR ; quit if site not entering dx/px
D DX
D PX
Q
;
MEDHX ; GET PROVISIONAL DIAGNOSES
W:$D(IOF) @IOF
W !?5,"Referral #: ",$$GETR^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 !!
D MEDCOM^BMCADD ;IHS/ITSC/FCJ ADDED FOR MED HX COM NO LONGER ON FORM
Q
DX ;EP FROM BMCMOD
I $G(BMCRR),$O(^BMCRTNRF(BMCRR,61,0)) D ADDDX,DX^BMCMOD Q ;template edit
I $G(BMCV)'="DX" D Q:$D(DIRUT)
.S DIR(0)="Y",DIR("A")="Do you want to enter a Provisional Diagnosis",DIR("B")="N",DIR("?")="Enter 'YES' to enter provisional diagnoses now."
.D ^DIR K DIR
.S BMCASK=Y
I $G(BMCASK)=1,BMCDXCPT=1 S BMCQ=0 D ^BMCDXSTF G DXASK ;stuffs dx if par=y
S BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N") S:+BMCDOS<1 BMCDOS=$P(^BMCREF(BMCRIEN,0),U) ;BMC*4.0*9
I BMCDOS<$$IMPDATE^LEXU("10D") S (BMCICD,BMCICD1)="ICD" ;BMC*4.0*9
E S (BMCICD,BMCICD1)="10D" ;BMC*4.0*9
S BMCLEX=+($$CSYS^LEXU(BMCICD)) ;Get Coding System ;BMC*4.0*9
I ($G(BMCASK)=1)!($G(BMCV)="DX") S BMCQ=0 F D Q:BMCQ
. S BMCLOOK=1
.;IHS/ITSC/FCJ ;MOD NXT SEC BMC*4.0*9 CHG TO LEXICON
. ;S DIC="^ICD9(",DIC(0)="AMEQ",DIC("A")="Enter ICD-9 DX code: "
. ;D ^DIC
. D CONFIG^LEXSET(BMCICD,BMCICD1,BMCDOS) ;BMC*4.0*9
. W !! S DIC("A")="Enter ICD DX code: " K X D ^LEXA1 ;BMC*4.0*9
. I +Y<0 S BMCQ=1 Q
. S X=$P($$CODEN^ICDEX($G(Y(+BMCLEX)),80),"~") ;BMC*4.0*9
. I +X<1 W !!,"INVALID CODE cannot add." Q
. K DIC,Y
. ;S X="`"_$P(Y,U),DIADD=1,DIC(0)="L",DIC="^BMCDX(",DLAYGO=90001.01 D ^DIC ;BMC*4.0*9
. S DIC(0)="L",DIC="^BMCDX(",DLAYGO=90001.01 D FILE^DICN
. I +Y<0 W !,"Unable to add DX code." S BMCQ=1 Q ;BMC*4.0*9
. S DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"
. S DIE="^BMCDX("
. D DIE^BMCFMC
. K BMCLOOK
. W !
K BMCDX,DIC,DIE,DR,DA,X,LEXQ,LEXVDT,ICDV,BMCLEX
DXASK ;
S BMCDXASK=0
D ^BMCRCHK
I BMCDXASK=1 D DX^BMCMOD S BMCDXASK=0
S BMCQ=0
Q
;
PX ; GET PROVISIONAL PROCEDURES
W !
I $G(BMCRR),$O(^BMCRTNRF(BMCRR,62,0)) D ADDPX,PROC^BMCMOD Q
S DIR(0)="Y",DIR("A")="Do you want to enter a Provisional Procedure",DIR("B")="N",DIR("?")="Enter 'YES' to enter provisional procedures now."
D ^DIR K DIR
Q:$D(DIRUT)
S BMCASK=Y
I BMCASK=1,BMCDXCPT=1 S BMCQ=0 D ^BMCPXSTF G PXASK
D PROC^BMCMOD ;BMC*4.0*9
;.;I BMCASK=1 S BMCQ=0 F D Q:BMCQ ;BMC*4.0*9
;. S BMCPXT="P"
;.;BMC*4.0*9 REWROTE NXT SECTION
;. S DIC="^ICPT(",DIC(0)="AMEQ",DIC("A")="Enter CPT Procedure code: "
;. D ^DIC
;. I Y=-1 S BMCQ=1 Q
;. ;S DIE="^BMCREF(",DA=BMCRIEN,DR="[BMC PROCEDURE ADD]"
;. ;D DIE^BMCFMC
;. S DIC(0)="L",DIC="^BMCPX(",DLAYGO=90001.02 D FILE^DICN
;. I +Y<0 W !,"Unable to add CPT Procedure code." S BMCQ=1 Q
;. S DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"
;. S DIE="^BMCPX("
;. D DIE^BMCFMC
;
PXASK ;Check Existence of Primary PX
S BMCPXASK=0
D ^BMCRCHK1
I BMCPXASK=1 D PROC^BMCMOD S BMCPXASK=0
S BMCQ=0
Q
;
;IHS/ITSC/FCJ MOD TO ALLOW FOR CALL BY BO COM AND MED HX COM FOR DATA ETRY
S BMCQ=0,BMCLOOK=1
S X=DT,DLAYGO=90001.03,DIADD=1,DIC(0)="L",DIC="^BMCCOM(" D ^DIC
S DA=+Y,DIE=DIC
;S DR=".01;.02////"_BMCDFN_";.03////"_BMCRIEN_";.04////"_DUZ_";.05////"_BMCCTYP_";1"
S DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////"_DUZ_";.05////"_BMCCTYP_";1"
D ^DIE
I '$D(^BMCCOM(DA,1)) S DIK="^BMCCOM(" D ^DIK
E S $P(^BMCCOM(DA,1,0),U,2)="90001.031"
K BMCLOOK,DIE,DR,DLAYGO,DIADD,DIC,DA
Q:BMCCTYP'="C"
S DIE="^BMCREF(",DA=BMCRIEN,DR=".31"
D DIE^BMCFMC
S BMCQ=0
Q
;
MGDCARE ;EP;Prompt for Managed Care Committee Action
W !
Q:BMCMGCR'=1
S DIR(0)="Y",DIR("A")="Do you want to enter Managed Care Committee Action",DIR("B")="N",DIR("?")="Enter 'YES' to enter Managed Care Committee Actions now."
D ^DIR K DIR
Q:$D(DIRUT)
I Y S BMCQ=0 D
. S BMCLOOK=1
. S DIE="^BMCREF(",DA=BMCRIEN,DR="[BMC COMMITTEE ACTION ADD]"
. D DIE^BMCFMC
S BMCQ=0
Q
;
STATIC ;EP - 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
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
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 K DIE,DR
D:'BMCPCC REFSNO ;BMC*4.0*9
W !,"Entry of Referral ",$P(^BMCREF(BMCRIEN,0),U,2)," is complete.",!
;IHS/ITSC/FCJ REQUEST TO SEND A MESSAGE NXT 4 LNES
I BMCCHSA,BMCRTYPE="C" D ENMM^BMCMM
I BMCIHSA,BMCRTYPE="I" D ENMM^BMCMM
I BMCOTHRA,BMCRTYPE="O" D ENMM^BMCMM
I BMCHOUSA,BMCRTYPE="N" D ENMM^BMCMM
;BMC 4.0*3 9.27.2007 IHS/OIT/FCJ ADDED NXT LINE TO TEST TO SEND ALERT TO PHYS
I ($P($G(^BMCPARM(DUZ(2),4100)),U,9)="Y")!($P($G(^BMCPARM(DUZ(2),4100)),U,10)="Y") NEW XQA S BMCRHDR="New" D PALRT1^BMCALERT
D EOP^BMC
Q
;
ADDDX ;EP auto stuff dx and proc from routine referral
W !,"Adding referral diagnoses.."
K BMCAR D ENPM^XBDIQ1(90001.61,BMCRR_",0",".01","BMCAR(","I")
Q:'$D(BMCAR)
;BMC*4.0*9 MODIFIED NXT SECTION FOR ICD-10 CHNGS, test for valid code vs dos
S BMCI=0,BMCDI=0,BMCTST=0 F S BMCI=$O(BMCAR(BMCI)) Q:BMCI'=+BMCI S BMCTST=0 D
.S BMCCDI=$G(BMCAR(BMCI,.01,"I")),BMCCD=$G(BMCAR(BMCI,.01)) I BMCCDI D
..I '(+($$STATCHK^ICDEX(BMCCD,BMCDOS,80))) S BMCTST=1 Q
..S X=BMCCDI,DLAYGO=90001.01,DIC="^BMCDX(",DIC(0)="L" K DD,DA,D0 D FILE^DICN D
...I Y=-1 W !!,"bad news -- error creating dx record - notify programmer" Q
...S DIE="^BMCDX(",DA=+Y,DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P" D ^DIE
...I $D(Y) W !!,"ADDING DX FAILED" Q
...D ^XBFMK
I BMCTST=1 W !,"INVALID ICD DX CODE FOR DATE OF SERVICE, Please Edit DX for Template" H 1
K BMCAR,X,BMCI
Q
ADDPX ;EP auto stuff proc from routine referral
W !,"Adding referral procedures.."
K BMCAR D ENPM^XBDIQ1(90001.62,BMCRR_",0",".01","BMCAR(","I")
Q:'$D(BMCAR)
S BMCI=0 F S BMCI=$O(BMCAR(BMCI)) Q:BMCI'=+BMCI S X=$G(BMCAR(BMCI,.01,"I")) I X S DLAYGO=90001.02,DIC="^BMCPX(",DIC(0)="L" K DD,DA,D0 D FILE^DICN D
.I Y=-1 W !!,"bad news -- error creating proc record - notify programmer" Q
.S DIE="^BMCPX(",DA=+Y,DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P" D ^DIE
.I $D(Y) W !!,"ADDING PROC FAILED" Q
.D ^XBFMK
K BMCAR,BMCI
Q
DXCAT ;EP From Add referrals, test for active DX Cat codes;BMC*4.0*9 NEW SUB
K HLP,DDSERROR
I '$D(DA) S BMCDOS="" Q ;BMC*3.1*10
S BMCDOS=$$GET^DDSVAL(90001,DA,1106,,"I")
S:'BMCDOS BMCDOS=$$GET^DDSVAL(90001,DA,1105,,"I")
S:'BMCDOS BMCDOS=$P(^BMCREF(BMCRIEN,0),U)
S BMCDOS=$P(BMCDOS,".") ;BMC 4.0*11
Q
DOSDX(Y) ;EP FR DD SCREEN FOR DX CATEGORY
I '$G(BMCDOS) S BMCDOS=DT
I ((($P(^BMCTDXC(Y,0),U,2)-1)<BMCDOS)&'$P(^(0),U,3))!((($P(^(0),U,2)-1)<BMCDOS)&($P(^(0),U,3)>BMCDOS)) Q 1
Q 0
;
REFSNO ;EP FR BMCMODS AND BMCADDS;BMC*4.0*9 ADD SNOMED CODE FOR SITE W/O PCC
;
S X=BMCSCOD,DIC="^BMCREF("
S DIADD=1,DIC(0)="L",LAYGO=90001 S:'$D(^BMCREF(BMCRIEN,22)) DIC("P")=90001.22
S DIC=DIC_BMCRIEN_",22,",DA(1)=BMCRIEN
D ^DIC
I +Y<0 W !,"The snomed clinical term was not added to the referral."
K DIC,DA
Q
BMCADD1 ; IHS/PHXAO/TMJ - add a referral part 2 ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3,9,10**;JAN 09, 2006;Build 101
+2 ;
+3 ;IHS/ITSC/FCJ ADD REQUEST TO SEND A MESSAGE
+4 ; MODIFIED COMMENTS SECTION, TO ALLOW
+5 ; BUS OFF AND MED HX TO CALL FROM BMCADD
+6 ;4.0*3 9.27.2007 IHS/OIT/FCJ Added test to send Alert to Physicians
+7 ;4.0*9 1-1-2013 IHS/OIT/FCJ Multiple changes for ICD-10
+8 ;
DXPX ;EP GET PROVIDIONAL DIAGNOSES/PROCEDURES IF WANTED
+1 DO MEDHX
+2 ; quit if site not entering dx/px
IF 'BMCDXPR
QUIT
+3 DO DX
+4 DO PX
+5 QUIT
+6 ;
MEDHX ; GET PROVISIONAL DIAGNOSES
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !?5,"Referral #: ",$$GETR^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 ;IHS/ITSC/FCJ ADDED FOR MED HX COM NO LONGER ON FORM
DO MEDCOM^BMCADD
+7 QUIT
DX ;EP FROM BMCMOD
+1 ;template edit
IF $GET(BMCRR)
IF $ORDER(^BMCRTNRF(BMCRR,61,0))
DO ADDDX
DO DX^BMCMOD
QUIT
+2 IF $GET(BMCV)'="DX"
Begin DoDot:1
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter a Provisional Diagnosis"
SET DIR("B")="N"
SET DIR("?")="Enter 'YES' to enter provisional diagnoses now."
+4 DO ^DIR
KILL DIR
+5 SET BMCASK=Y
End DoDot:1
IF $DATA(DIRUT)
QUIT
+6 ;stuffs dx if par=y
IF $GET(BMCASK)=1
IF BMCDXCPT=1
SET BMCQ=0
DO ^BMCDXSTF
GOTO DXASK
+7 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N")
IF +BMCDOS<1
SET BMCDOS=$PIECE(^BMCREF(BMCRIEN,0),U)
+8 ;BMC*4.0*9
IF BMCDOS<$$IMPDATE^LEXU("10D")
SET (BMCICD,BMCICD1)="ICD"
+9 ;BMC*4.0*9
IF '$TEST
SET (BMCICD,BMCICD1)="10D"
+10 ;Get Coding System ;BMC*4.0*9
SET BMCLEX=+($$CSYS^LEXU(BMCICD))
+11 IF ($GET(BMCASK)=1)!($GET(BMCV)="DX")
SET BMCQ=0
FOR
Begin DoDot:1
+12 SET BMCLOOK=1
+13 ;IHS/ITSC/FCJ ;MOD NXT SEC BMC*4.0*9 CHG TO LEXICON
+14 ;S DIC="^ICD9(",DIC(0)="AMEQ",DIC("A")="Enter ICD-9 DX code: "
+15 ;D ^DIC
+16 ;BMC*4.0*9
DO CONFIG^LEXSET(BMCICD,BMCICD1,BMCDOS)
+17 ;BMC*4.0*9
WRITE !!
SET DIC("A")="Enter ICD DX code: "
KILL X
DO ^LEXA1
+18 IF +Y<0
SET BMCQ=1
QUIT
+19 ;BMC*4.0*9
SET X=$PIECE($$CODEN^ICDEX($GET(Y(+BMCLEX)),80),"~")
+20 IF +X<1
WRITE !!,"INVALID CODE cannot add."
QUIT
+21 KILL DIC,Y
+22 ;S X="`"_$P(Y,U),DIADD=1,DIC(0)="L",DIC="^BMCDX(",DLAYGO=90001.01 D ^DIC ;BMC*4.0*9
+23 SET DIC(0)="L"
SET DIC="^BMCDX("
SET DLAYGO=90001.01
DO FILE^DICN
+24 ;BMC*4.0*9
IF +Y<0
WRITE !,"Unable to add DX code."
SET BMCQ=1
QUIT
+25 SET DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"
+26 SET DIE="^BMCDX("
+27 DO DIE^BMCFMC
+28 KILL BMCLOOK
+29 WRITE !
End DoDot:1
IF BMCQ
QUIT
+30 KILL BMCDX,DIC,DIE,DR,DA,X,LEXQ,LEXVDT,ICDV,BMCLEX
DXASK ;
+1 SET BMCDXASK=0
+2 DO ^BMCRCHK
+3 IF BMCDXASK=1
DO DX^BMCMOD
SET BMCDXASK=0
+4 SET BMCQ=0
+5 QUIT
+6 ;
PX ; GET PROVISIONAL PROCEDURES
+1 WRITE !
+2 IF $GET(BMCRR)
IF $ORDER(^BMCRTNRF(BMCRR,62,0))
DO ADDPX
DO PROC^BMCMOD
QUIT
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter a Provisional Procedure"
SET DIR("B")="N"
SET DIR("?")="Enter 'YES' to enter provisional procedures now."
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 SET BMCASK=Y
+7 IF BMCASK=1
IF BMCDXCPT=1
SET BMCQ=0
DO ^BMCPXSTF
GOTO PXASK
+8 ;BMC*4.0*9
DO PROC^BMCMOD
+9 ;.;I BMCASK=1 S BMCQ=0 F D Q:BMCQ ;BMC*4.0*9
+10 ;. S BMCPXT="P"
+11 ;.;BMC*4.0*9 REWROTE NXT SECTION
+12 ;. S DIC="^ICPT(",DIC(0)="AMEQ",DIC("A")="Enter CPT Procedure code: "
+13 ;. D ^DIC
+14 ;. I Y=-1 S BMCQ=1 Q
+15 ;. ;S DIE="^BMCREF(",DA=BMCRIEN,DR="[BMC PROCEDURE ADD]"
+16 ;. ;D DIE^BMCFMC
+17 ;. S DIC(0)="L",DIC="^BMCPX(",DLAYGO=90001.02 D FILE^DICN
+18 ;. I +Y<0 W !,"Unable to add CPT Procedure code." S BMCQ=1 Q
+19 ;. S DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"_";.05;.06"
+20 ;. S DIE="^BMCPX("
+21 ;. D DIE^BMCFMC
+22 ;
PXASK ;Check Existence of Primary PX
+1 SET BMCPXASK=0
+2 DO ^BMCRCHK1
+3 IF BMCPXASK=1
DO PROC^BMCMOD
SET BMCPXASK=0
+4 SET BMCQ=0
+5 QUIT
+6 ;
+1 ;IHS/ITSC/FCJ MOD TO ALLOW FOR CALL BY BO COM AND MED HX COM FOR DATA ETRY
+2 SET BMCQ=0
SET BMCLOOK=1
+3 SET X=DT
SET DLAYGO=90001.03
SET DIADD=1
SET DIC(0)="L"
SET DIC="^BMCCOM("
DO ^DIC
+4 SET DA=+Y
SET DIE=DIC
+5 ;S DR=".01;.02////"_BMCDFN_";.03////"_BMCRIEN_";.04////"_DUZ_";.05////"_BMCCTYP_";1"
+6 SET DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////"_DUZ_";.05////"_BMCCTYP_";1"
+7 DO ^DIE
+8 IF '$DATA(^BMCCOM(DA,1))
SET DIK="^BMCCOM("
DO ^DIK
+9 IF '$TEST
SET $PIECE(^BMCCOM(DA,1,0),U,2)="90001.031"
+10 KILL BMCLOOK,DIE,DR,DLAYGO,DIADD,DIC,DA
+11 IF BMCCTYP'="C"
QUIT
+12 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR=".31"
+13 DO DIE^BMCFMC
+14 SET BMCQ=0
+15 QUIT
+16 ;
MGDCARE ;EP;Prompt for Managed Care Committee Action
+1 WRITE !
+2 IF BMCMGCR'=1
QUIT
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter Managed Care Committee Action"
SET DIR("B")="N"
SET DIR("?")="Enter 'YES' to enter Managed Care Committee Actions now."
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 IF Y
SET BMCQ=0
Begin DoDot:1
+7 SET BMCLOOK=1
+8 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR="[BMC COMMITTEE ACTION ADD]"
+9 DO DIE^BMCFMC
End DoDot:1
+10 SET BMCQ=0
+11 QUIT
+12 ;
STATIC ;EP - STORE STATIC DATA
+1 WRITE !,"Storing static fields....",!
+2 SET BMCREC=^BMCREF(BMCRIEN,0)
+3 SET Y=^DPT(BMCDFN,0)
+4 ; name
SET DR="5101///"_$PIECE(Y,U)
+5 ; dob
SET DR=DR_";5103///"_$PIECE(Y,U,3)
+6 ; ssn
SET DR=DR_";5104///"_$PIECE(Y,U,9)
+7 ; sex
SET DR=DR_";5107///"_$PIECE(Y,U,2)
+8 SET %=$PIECE(BMCREC,U,5)
+9 IF %
Begin DoDot:1
+10 ; chart #
SET DR=DR_";5102///"_$PIECE($GET(^AUPNPAT(BMCDFN,41,%,0)),U,2)
+11 ; facility
SET DR=DR_";5113///"_$PIECE($GET(^DIC(4,%,0)),U)
+12 ; asufac
SET DR=DR_";5114///"_$PIECE($GET(^AUTTLOC(%,0)),U,10)
End DoDot:1
+13 SET Y=$GET(^AUPNPAT(BMCDFN,51))
+14 ; comm
IF $PIECE(Y,U,18)'=""
SET DR=DR_";5105///"_$PIECE(Y,U,18)
+15 ; tribe
IF $PIECE(Y,U,8)
SET DR=DR_";5106///"_$PIECE($GET(^AUTTTRI($PIECE(Y,U,8),0)),U,2)
+16 SET %=$PIECE(BMCREC,U,7)
+17 IF %
Begin DoDot:1
+18 ; vendor
SET DR=DR_";5108///"_$PIECE($GET(^AUTTVNDR(%,0)),U)
+19 ; ein
SET DR=DR_";5109///"_$PIECE($GET(^AUTTVNDR(%,51)),U)
End DoDot:1
+20 SET %=$PIECE(BMCREC,U)
+21 ; medicare
SET DR=DR_";5110///"_$$MCR^AUPNPAT(BMCDFN,%)
+22 ; medicaid
SET DR=DR_";5111///"_$$MCD^AUPNPAT(BMCDFN,%)
+23 ; private insurance
SET DR=DR_";5112///"_$$PI^AUPNPAT(BMCDFN,%)
+24 ;
+25 SET DIE="^BMCREF("
SET DA=BMCRIEN
+26 DO DIE^BMCFMC
KILL DIE,DR
+27 ;BMC*4.0*9
IF 'BMCPCC
DO REFSNO
+28 WRITE !,"Entry of Referral ",$PIECE(^BMCREF(BMCRIEN,0),U,2)," is complete.",!
+29 ;IHS/ITSC/FCJ REQUEST TO SEND A MESSAGE NXT 4 LNES
+30 IF BMCCHSA
IF BMCRTYPE="C"
DO ENMM^BMCMM
+31 IF BMCIHSA
IF BMCRTYPE="I"
DO ENMM^BMCMM
+32 IF BMCOTHRA
IF BMCRTYPE="O"
DO ENMM^BMCMM
+33 IF BMCHOUSA
IF BMCRTYPE="N"
DO ENMM^BMCMM
+34 ;BMC 4.0*3 9.27.2007 IHS/OIT/FCJ ADDED NXT LINE TO TEST TO SEND ALERT TO PHYS
+35 IF ($PIECE($GET(^BMCPARM(DUZ(2),4100)),U,9)="Y")!($PIECE($GET(^BMCPARM(DUZ(2),4100)),U,10)="Y")
NEW XQA
SET BMCRHDR="New"
DO PALRT1^BMCALERT
+36 DO EOP^BMC
+37 QUIT
+38 ;
ADDDX ;EP auto stuff dx and proc from routine referral
+1 WRITE !,"Adding referral diagnoses.."
+2 KILL BMCAR
DO ENPM^XBDIQ1(90001.61,BMCRR_",0",".01","BMCAR(","I")
+3 IF '$DATA(BMCAR)
QUIT
+4 ;BMC*4.0*9 MODIFIED NXT SECTION FOR ICD-10 CHNGS, test for valid code vs dos
+5 SET BMCI=0
SET BMCDI=0
SET BMCTST=0
FOR
SET BMCI=$ORDER(BMCAR(BMCI))
IF BMCI'=+BMCI
QUIT
SET BMCTST=0
Begin DoDot:1
+6 SET BMCCDI=$GET(BMCAR(BMCI,.01,"I"))
SET BMCCD=$GET(BMCAR(BMCI,.01))
IF BMCCDI
Begin DoDot:2
+7 IF '(+($$STATCHK^ICDEX(BMCCD,BMCDOS,80)))
SET BMCTST=1
QUIT
+8 SET X=BMCCDI
SET DLAYGO=90001.01
SET DIC="^BMCDX("
SET DIC(0)="L"
KILL DD,DA,D0
DO FILE^DICN
Begin DoDot:3
+9 IF Y=-1
WRITE !!,"bad news -- error creating dx record - notify programmer"
QUIT
+10 SET DIE="^BMCDX("
SET DA=+Y
SET DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"
DO ^DIE
+11 IF $DATA(Y)
WRITE !!,"ADDING DX FAILED"
QUIT
+12 DO ^XBFMK
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF BMCTST=1
WRITE !,"INVALID ICD DX CODE FOR DATE OF SERVICE, Please Edit DX for Template"
HANG 1
+14 KILL BMCAR,X,BMCI
+15 QUIT
ADDPX ;EP auto stuff proc from routine referral
+1 WRITE !,"Adding referral procedures.."
+2 KILL BMCAR
DO ENPM^XBDIQ1(90001.62,BMCRR_",0",".01","BMCAR(","I")
+3 IF '$DATA(BMCAR)
QUIT
+4 SET BMCI=0
FOR
SET BMCI=$ORDER(BMCAR(BMCI))
IF BMCI'=+BMCI
QUIT
SET X=$GET(BMCAR(BMCI,.01,"I"))
IF X
SET DLAYGO=90001.02
SET DIC="^BMCPX("
SET DIC(0)="L"
KILL DD,DA,D0
DO FILE^DICN
Begin DoDot:1
+5 IF Y=-1
WRITE !!,"bad news -- error creating proc record - notify programmer"
QUIT
+6 SET DIE="^BMCPX("
SET DA=+Y
SET DR=".02////"_BMCDFN_";.03////"_BMCRIEN_";.04////P"
DO ^DIE
+7 IF $DATA(Y)
WRITE !!,"ADDING PROC FAILED"
QUIT
+8 DO ^XBFMK
End DoDot:1
+9 KILL BMCAR,BMCI
+10 QUIT
DXCAT ;EP From Add referrals, test for active DX Cat codes;BMC*4.0*9 NEW SUB
+1 KILL HLP,DDSERROR
+2 ;BMC*3.1*10
IF '$DATA(DA)
SET BMCDOS=""
QUIT
+3 SET BMCDOS=$$GET^DDSVAL(90001,DA,1106,,"I")
+4 IF 'BMCDOS
SET BMCDOS=$$GET^DDSVAL(90001,DA,1105,,"I")
+5 IF 'BMCDOS
SET BMCDOS=$PIECE(^BMCREF(BMCRIEN,0),U)
+6 ;BMC 4.0*11
SET BMCDOS=$PIECE(BMCDOS,".")
+7 QUIT
DOSDX(Y) ;EP FR DD SCREEN FOR DX CATEGORY
+1 IF '$GET(BMCDOS)
SET BMCDOS=DT
+2 IF ((($PIECE(^BMCTDXC(Y,0),U,2)-1)<BMCDOS)&'$PIECE(^(0),U,3))!((($PIECE(^(0),U,2)-1)<BMCDOS)&($PIECE(^(0),U,3)>BMCDOS))
QUIT 1
+3 QUIT 0
+4 ;
REFSNO ;EP FR BMCMODS AND BMCADDS;BMC*4.0*9 ADD SNOMED CODE FOR SITE W/O PCC
+1 ;
+2 SET X=BMCSCOD
SET DIC="^BMCREF("
+3 SET DIADD=1
SET DIC(0)="L"
SET LAYGO=90001
IF '$DATA(^BMCREF(BMCRIEN,22))
SET DIC("P")=90001.22
+4 SET DIC=DIC_BMCRIEN_",22,"
SET DA(1)=BMCRIEN
+5 DO ^DIC
+6 IF +Y<0
WRITE !,"The snomed clinical term was not added to the referral."
+7 KILL DIC,DA
+8 QUIT
