Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCADD1

BMCADD1.m

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