BPCRC3 ; IHS/OIT/MJL - 12/03/96 -REFERRED CARE ROUTINES ; [ 03/22/2006 8:59 AM ]
;;1.5;BPC;**2**;MAY 26, 2005
REFEDIT(RESULT,BPCFLAG,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC EDITREFERRAL
EN ;
S U="^",XWBWRAP=1,BPCS1="`",BPCS2="~",BPCS3="|" K RESULT
I BPCFLAG="" S RESULT(1)=-1,RESULT(2)="NO EDIT FLAG RECEIVED!" D KILL Q
I BPCPARAM="" S RESULT(1)=-1,RESULT(2)="NO PARAMETERS RECEIVED!" D KILL Q
I "AED"'[BPCFLAG S RESULT(1)=-1,RESULT(2)="PROPER EDIT FLAG NOT SENT!" D KILL Q
D:BPCFLAG="A" ADD D:BPCFLAG="E" EDIT D:BPCFLAG="D" DELETE D KILL
Q
KILL ;
K BPCCDAT,BPCCLIN,BPCCPT,BPCEBDAT,BPCEEDAT,BPCERR,BPCFAC,BPCFDR,BPCFIEN,BPCFLAG,BPCHXS,BPCICD,BPCIDAT,BPCIEN,BPCLEN,BPCLOS,BPCLSCAT,BPCNOVIS,BPCNPARM,BPCNUM,BPCPAD,BPCPARAM,BPCPARM,BPCPAYOR,BPCPIEN,BPCPRIOR
K BPCPRNAM,BPCPROV,BPCPTYPE,BPCPURP,BPCPVEND,BPCQ,BPCREFN,BPCROOT,BPCRTYPE,BPCSNDA,BPCSNOTE,BPCSUB,BPCTOIHS,BPCTOPRV,BPCUSR,BPCWDAYS,BPCX,BPCX1,BPCX2,BPCXR,BPCY,BPCYR,BPCS1,BPCS2
K BPCRIEN,BPCDRG,BPCDXS,BPCPRCS,BPCIENS,BPCS3,BPCDTA,BPCDXIEN,BPCNARR,BPCNIEN,BPCPXIEN
Q
ADD ;
S BPCERR=0
D REFNO Q:BPCERR
D GETDATA Q:BPCERR
D ADDREF I BPCERR S RESULT(1)=-1,RESULT(2)="ERROR OCCURRED WHILE SAVING DATA!" Q
S RESULT(1)=1,RESULT(2)=BPCRIEN_U_BPCREFN_U_BPCPURP_U_BPCPRNAM_U_BPCPROV_U_BPCIDAT_U_BPCEBDAT_U
Q
REFNO ;
S BPCFAC=$P(BPCPARAM,BPCS1,4) I BPCFAC="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="REQUESTING FACILITY NOT RECEIVED!" Q
S BPCPARM=$G(^BMCPARM(BPCFAC,0)) I BPCPARM="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO SITE PARAMETERS EXIST FOR REQUESTING FACILITY!" Q
S BPCX=$P($G(^AUTTLOC(BPCFAC,0)),U,10) I BPCX="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO FACILITY NUMBER AVAILABLE IN RCIS SITE PARAMETER FILE!" Q
S BPCYR=$P(BPCPARM,U,2) I BPCYR="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO FISCAL YEAR AVAILABLE IN RCIS SITE PARAMETER FILE!" Q
S (BPCY,BPCNUM)=$P(BPCPARM,U,7)+1,BPCLEN=$L(BPCNUM),BPCPAD=5-BPCLEN F BPCQ=1:1:BPCPAD S BPCNUM="0"_BPCNUM
S BPCREFN=BPCX_BPCYR_BPCNUM
I $L(BPCREFN)'=13!('(BPCREFN?13N)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="ERROR GENERATING NEW REFERRAL NUMBER!" Q
D SAVNUM
Q
;
SAVNUMEP ;
S BPCFAC=BGUV(BGUFILE,".01-P"),BPCY=BGUV(90001.31,.07)+1
SAVNUM ;
L +^BMCPARM(0):10 I '$T S BPCERR=1 Q
K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)",BPCFIEN=BPCFAC_","
S BPCFDA(1,90001.31,BPCFIEN,.07)=BPCY
D FILE^DIE("",BPCFDR,"BPCEMSG")
I $D(BPCEMSG("DIERR")) S BPCERR=1
L -^BMCPARM(0)
S BPCNPARM=$G(^BMCPARM(BPCFAC,0))
Q
ADDREF ;
L +^BMCREF(0):10 I '$T S BPCERR=1 Q
K BPCFDA,BPCEMSG S BPCFDR="BPCFDA(1)"
S BPCFDA(1,90001,"+1,",.01)=BPCIDAT
S BPCFDA(1,90001,"+1,",.02)=BPCREFN
S BPCFDA(1,90001,"+1,",.03)=BPCPIEN
S BPCFDA(1,90001,"+1,",.04)=BPCRTYPE
S BPCFDA(1,90001,"+1,",.05)=BPCFAC
S BPCFDA(1,90001,"+1,",.06)=BPCPROV
S BPCFDA(1,90001,"+1,",.07)=BPCPVEND
S BPCFDA(1,90001,"+1,",.08)=BPCTOIHS
S BPCFDA(1,90001,"+1,",.09)=BPCTOPRV
S BPCFDA(1,90001,"+1,",.11)=BPCPAYOR
S BPCFDA(1,90001,"+1,",.12)=BPCICD
S BPCFDA(1,90001,"+1,",.13)=BPCCPT
S BPCFDA(1,90001,"+1,",.14)=BPCPTYPE
S BPCFDA(1,90001,"+1,",.15)="A" ;STATUS OF REFERRAL
S BPCFDA(1,90001,"+1,",.21)=BPCDRG
S BPCFDA(1,90001,"+1,",.23)=BPCCLIN
S BPCFDA(1,90001,"+1,",.25)=BPCUSR
S BPCFDA(1,90001,"+1,",.26)=BPCCDAT
S BPCFDA(1,90001,"+1,",.27)=BPCCDAT ;DATE LAST MODIFIED
S BPCFDA(1,90001,"+1,",.32)=BPCPRIOR
S BPCFDA(1,90001,"+1,",.34)=BPCSNDA
S BPCFDA(1,90001,"+1,",1105)=BPCEBDAT
S BPCFDA(1,90001,"+1,",1107)=BPCEEDAT
S BPCFDA(1,90001,"+1,",1109)=BPCLOS
S BPCFDA(1,90001,"+1,",1111)=BPCNOVIS
S BPCFDA(1,90001,"+1,",1201)=BPCPURP
S BPCFDA(1,90001,"+1,",1301)=BPCSNOTE
S BPCFDA(1,90001,"+1,",1302)=BPCWDAYS
D DAT51
I BPCLSCAT'="" D ADDLSCAT
K BPCIEN D UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
I $D(BPCEMSG("DIERR")) S BPCERR=1
L -^BMCREF(0)
I 'BPCERR,BPCHXS'="" D ADDHX
I 'BPCERR S BPCRIEN=BPCIEN(1) D:BPCDXS'="" SETDXS
I 'BPCERR,BPCPRCS'="" D SETPRCS
Q
DAT51 ; SETS NODE 51 DATA
S BPCX=$G(^DPT(BPCPIEN,0))
S BPCFDA(1,90001,"+1,",5101)=$P(BPCX,U,1) ;NAME
S BPCFDA(1,90001,"+1,",5103)=$P(BPCX,U,3) ;DOB
S BPCFDA(1,90001,"+1,",5104)=$P(BPCX,U,9) ;SSN
S BPCFDA(1,90001,"+1,",5107)=$P(BPCX,U,2) ;SEX
S BPCFDA(1,90001,"+1,",5102)=$P($G(^AUPNPAT(BPCPIEN,41,BPCFAC,0)),U,2)
S BPCFDA(1,90001,"+1,",5113)=$P($G(^DIC(4,BPCFAC,0)),U,1)
S BPCFDA(1,90001,"+1,",5114)=$P($G(^AUTTLOC(BPCFAC,0)),U,10)
S BPCX=$G(^AUPNPAT(BPCPIEN,51)),BPCX1=$P(BPCX,U,18),BPCX2=$P(BPCX,U,8)
S:BPCX1'="" BPCFDA(1,90001,"+1,",5105)=BPCX1
S:BPCX2'="" BPCFDA(1,90001,"+1,",5106)=$P($G(^AUTTTRI(BPCX2,0)),U,2)
I BPCPVEND'="" D
. S BPCFDA(1,90001,"+1,",5108)=$P($G(^AUTTVNDR(BPCPVEND,0)),U,1)
. S BPCFDA(1,90001,"+1,",5109)=$P($G(^AUTTVNDR(BPCPVEND,11)),U,1)
S BPCFDA(1,90001,"+1,",5110)=$$MCR^AUPNPAT(BPCPIEN,BPCIDAT)
S BPCFDA(1,90001,"+1,",5111)=$$MCD^AUPNPAT(BPCPIEN,BPCIDAT)
S BPCFDA(1,90001,"+1,",5112)=$$PI^AUPNPAT(BPCPIEN,BPCIDAT)
Q
ADDHX ;
K ^BPCTMP($J)
Q:'$D(BPCIEN)
F BPCQ=1:1:$L(BPCHXS,BPCS2) S BPCX=$P(BPCHXS,BPCS2,BPCQ),^BPCTMP($J,BPCQ,0)=BPCX
S BPCROOT="^BPCTMP("_$J_")"
D WP^DIE(90001,BPCIEN(1)_",",1,"",BPCROOT,"BPCEMSG")
I $D(BPCEMSG("DIERR")) S BPCERR=1
K ^BPCTMP($J)
Q
ADDLSCAT ;
S BPCSUB=1 F BPCQ=1:1:$L(BPCLSCAT,BPCS2) S BPCX=$P(BPCLSCAT,BPCS2,BPCQ),BPCSUB=BPCSUB+1,BPCXR="BPCFDA(1,90001.21,"_""""_"+"_BPCSUB_",+1,"_""""_",.01)" S @BPCXR=BPCX
Q
SETDXS ;
D SETDXS^BPCRC5
Q
SETPRCS ;
D SETPRCS^BPCRC5
Q
GETDATA ;
S BPCIDAT=$P(BPCPARAM,BPCS1,1)
I BPCIDAT'="" S X=BPCIDAT D ^%DT S BPCIDAT=$S(Y'=-1:$P(Y,".",1),1:"")
I BPCIDAT="" S RESULT(1)=-1,RESULT(2)="INITIATED DATE NOT IN PROPER FORMAT!",BPCERR=1 Q
S BPCPIEN=$P(BPCPARAM,BPCS1,2) I BPCPIEN="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO PATIENT IEN SENT!" Q
I '$D(^DPT(BPCPIEN,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="IEN SENT IS NOT A DEFINED PATIENT IEN!" Q
S BPCRTYPE=$P(BPCPARAM,BPCS1,3) I "CION"'[BPCRTYPE S BPCERR=1,RESULT(1)=-1,RESULT(2)="REFERRAL TYPE CODE SENT IS NOT A PROPER REFERRAL TYPE CODE!" Q
I BPCFLAG="E" S BPCFAC=$P(BPCPARAM,BPCS1,4) I BPCFAC="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="REQUESTING FACILITY NOT RECEIVED!" Q
S BPCPROV=+$P(BPCPARAM,BPCS1,5) I 'BPCPROV S BPCERR=1,RESULT(1)=-1,RESULT(2)="REQUESTING PROVIDER SENT IS NOT ASSIGNED!" Q
I '$D(^VA(200,BPCPROV,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="REQUESTING PROVIDER SENT IS NOT DEFINED!" Q
S BPCPRNAM=$P(^VA(200,BPCPROV,0),U,1)
S BPCPVEND=$P(BPCPARAM,BPCS1,6) I BPCPVEND'="" I '$D(^AUTTVNDR(BPCPVEND,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="PRIMARY VENDOR SENT IS NOT DEFINED!" Q
S BPCTOIHS=$P(BPCPARAM,BPCS1,7) I BPCTOIHS'="" I '$D(^AUTTLOC(BPCTOIHS,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="TO IHS FACILITY SENT IS NOT DEFINED!" Q
S BPCTOPRV=$P(BPCPARAM,BPCS1,8) I BPCTOPRV'="" I '$D(^BMCLPRV(BPCTOPRV,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="TO OTHER PROVIDER SENT IS NOT DEFINED!" Q
S BPCPAYOR=$P(BPCPARAM,BPCS1,9) I BPCPAYOR="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO PRIMARY PAYOR SENT!" Q
S BPCPAYOR=+BPCPAYOR I BPCPAYOR<1!(BPCPAYOR>8) S BPCERR=1,RESULT(1)=-1,RESULT(2)="PRIMARY PAYOR SENT IS NOT CORRECT!" Q
S BPCICD=$P(BPCPARAM,BPCS1,10) I BPCICD'="" I '$D(^BMCTDXC(BPCICD,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="SENT ICD CATEGORY CODE IS NOT DEFINED!" Q
S BPCCPT=$P(BPCPARAM,BPCS1,11) I BPCCPT'="" I '$D(^BMCTSVC(BPCCPT,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="SEND CPT CATEGORY CODE IS NOT DEFINED!" Q
S BPCPTYPE=$P(BPCPARAM,BPCS1,12) I BPCPTYPE="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO PATIENT TYPE SENT!" Q
I "IO"'[BPCPTYPE S BPCERR=1,RESULT(1)=-1,RESULT(2)="PATIENT TYPE SENT IS NOT CORRECT!" Q
S BPCCLIN=$P(BPCPARAM,BPCS1,13) I BPCCLIN'="" I '$D(^DIC(40.7,BPCCLIN,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="CLINIC STOP SENT IS NOT DEFINED!" Q
S BPCUSR=$P(BPCPARAM,BPCS1,14) I BPCUSR'="" I '$D(^VA(200,BPCUSR,0)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="CREATED BY USER SENT IS NOT DEFINED!" Q
S BPCCDAT=$P(BPCPARAM,BPCS1,15)
I BPCCDAT'="" S X=BPCCDAT D ^%DT S BPCCDAT=$S(Y'=-1:$P(Y,".",1),1:"")
I BPCCDAT="" S RESULT(1)=-1,RESULT(2)="DATE CREATED NOT IN PROPER FORMAT!",BPCERR=1 Q
S BPCPRIOR=+$P(BPCPARAM,BPCS1,16) I BPCPRIOR<1!(BPCPRIOR>99) S BPCERR=1,RESULT(1)=-1,RESULT(2)="PRIORITY SENT IS NOT CORRECT!" Q
S BPCSNDA=$P(BPCPARAM,BPCS1,17) I BPCSNDA'="" I "01"'[BPCSNDA S BPCSNDA=""
S BPCEBDAT=$P(BPCPARAM,BPCS1,18) I BPCEBDAT'="" S X=BPCEBDAT D ^%DT S BPCEBDAT=$S(Y'=-1:$P(Y,".",1),1:"")
S BPCEEDAT=$P(BPCPARAM,BPCS1,19) I BPCEEDAT'="" S X=BPCEEDAT D ^%DT S BPCEEDAT=$S(Y'=-1:$P(Y,".",1),1:"")
S BPCLOS=$P(BPCPARAM,BPCS1,20),BPCNOVIS=$P(BPCPARAM,BPCS1,21)
S BPCPURP=$P(BPCPARAM,BPCS1,22) I BPCPURP="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO PURPOSE OF REFERRAL SENT!" Q
S BPCSNOTE=$P(BPCPARAM,BPCS1,23),BPCWDAYS=$P(BPCPARAM,BPCS1,24),BPCLSCAT=$P(BPCPARAM,BPCS1,25),BPCHXS=$P(BPCPARAM,BPCS1,26)
I BPCFLAG="E" S BPCREFN=$P(BPCPARAM,BPCS1,27),BPCRIEN=$P(BPCPARAM,BPCS1,31) I BPCRIEN="" S BPCERR=1,RESULT(1)=-1,RESULT(2)="NO REFERRAL IEN WAS SENT FOR THE EDIT!" Q
S BPCDRG=$P(BPCPARAM,BPCS1,28),BPCDXS=$P(BPCPARAM,BPCS1,29),BPCPRCS=$P(BPCPARAM,BPCS1,30)
Q
EDIT ;
S BPCERR=0
D GETDATA Q:BPCERR
I '$D(^BMCREF(BPCRIEN)) S BPCERR=1,RESULT(1)=-1,RESULT(2)="REFERRAL IEN SENT FOR EDIT IS INVALID!" Q
D EDIT^BPCRC6
Q
DELETE ;
Q
BPCRC3 ; IHS/OIT/MJL - 12/03/96 -REFERRED CARE ROUTINES ; [ 03/22/2006 8:59 AM ]
+1 ;;1.5;BPC;**2**;MAY 26, 2005
REFEDIT(RESULT,BPCFLAG,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC EDITREFERRAL
EN ;
+1 SET U="^"
SET XWBWRAP=1
SET BPCS1="`"
SET BPCS2="~"
SET BPCS3="|"
KILL RESULT
+2 IF BPCFLAG=""
SET RESULT(1)=-1
SET RESULT(2)="NO EDIT FLAG RECEIVED!"
DO KILL
QUIT
+3 IF BPCPARAM=""
SET RESULT(1)=-1
SET RESULT(2)="NO PARAMETERS RECEIVED!"
DO KILL
QUIT
+4 IF "AED"'[BPCFLAG
SET RESULT(1)=-1
SET RESULT(2)="PROPER EDIT FLAG NOT SENT!"
DO KILL
QUIT
+5 IF BPCFLAG="A"
DO ADD
IF BPCFLAG="E"
DO EDIT
IF BPCFLAG="D"
DO DELETE
DO KILL
+6 QUIT
KILL ;
+1 KILL BPCCDAT,BPCCLIN,BPCCPT,BPCEBDAT,BPCEEDAT,BPCERR,BPCFAC,BPCFDR,BPCFIEN,BPCFLAG,BPCHXS,BPCICD,BPCIDAT,BPCIEN,BPCLEN,BPCLOS,BPCLSCAT,BPCNOVIS,BPCNPARM,BPCNUM,BPCPAD,BPCPARAM,BPCPARM,BPCPAYOR,BPCPIEN,BPCPRIOR
+2 KILL BPCPRNAM,BPCPROV,BPCPTYPE,BPCPURP,BPCPVEND,BPCQ,BPCREFN,BPCROOT,BPCRTYPE,BPCSNDA,BPCSNOTE,BPCSUB,BPCTOIHS,BPCTOPRV,BPCUSR,BPCWDAYS,BPCX,BPCX1,BPCX2,BPCXR,BPCY,BPCYR,BPCS1,BPCS2
+3 KILL BPCRIEN,BPCDRG,BPCDXS,BPCPRCS,BPCIENS,BPCS3,BPCDTA,BPCDXIEN,BPCNARR,BPCNIEN,BPCPXIEN
+4 QUIT
ADD ;
+1 SET BPCERR=0
+2 DO REFNO
IF BPCERR
QUIT
+3 DO GETDATA
IF BPCERR
QUIT
+4 DO ADDREF
IF BPCERR
SET RESULT(1)=-1
SET RESULT(2)="ERROR OCCURRED WHILE SAVING DATA!"
QUIT
+5 SET RESULT(1)=1
SET RESULT(2)=BPCRIEN_U_BPCREFN_U_BPCPURP_U_BPCPRNAM_U_BPCPROV_U_BPCIDAT_U_BPCEBDAT_U
+6 QUIT
REFNO ;
+1 SET BPCFAC=$PIECE(BPCPARAM,BPCS1,4)
IF BPCFAC=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="REQUESTING FACILITY NOT RECEIVED!"
QUIT
+2 SET BPCPARM=$GET(^BMCPARM(BPCFAC,0))
IF BPCPARM=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO SITE PARAMETERS EXIST FOR REQUESTING FACILITY!"
QUIT
+3 SET BPCX=$PIECE($GET(^AUTTLOC(BPCFAC,0)),U,10)
IF BPCX=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO FACILITY NUMBER AVAILABLE IN RCIS SITE PARAMETER FILE!"
QUIT
+4 SET BPCYR=$PIECE(BPCPARM,U,2)
IF BPCYR=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO FISCAL YEAR AVAILABLE IN RCIS SITE PARAMETER FILE!"
QUIT
+5 SET (BPCY,BPCNUM)=$PIECE(BPCPARM,U,7)+1
SET BPCLEN=$LENGTH(BPCNUM)
SET BPCPAD=5-BPCLEN
FOR BPCQ=1:1:BPCPAD
SET BPCNUM="0"_BPCNUM
+6 SET BPCREFN=BPCX_BPCYR_BPCNUM
+7 IF $LENGTH(BPCREFN)'=13!('(BPCREFN?13N))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="ERROR GENERATING NEW REFERRAL NUMBER!"
QUIT
+8 DO SAVNUM
+9 QUIT
+10 ;
SAVNUMEP ;
+1 SET BPCFAC=BGUV(BGUFILE,".01-P")
SET BPCY=BGUV(90001.31,.07)+1
SAVNUM ;
+1 LOCK +^BMCPARM(0):10
IF '$TEST
SET BPCERR=1
QUIT
+2 KILL BPCFDA,BPCEMSG
SET BPCFDR="BPCFDA(1)"
SET BPCFIEN=BPCFAC_","
+3 SET BPCFDA(1,90001.31,BPCFIEN,.07)=BPCY
+4 DO FILE^DIE("",BPCFDR,"BPCEMSG")
+5 IF $DATA(BPCEMSG("DIERR"))
SET BPCERR=1
+6 LOCK -^BMCPARM(0)
+7 SET BPCNPARM=$GET(^BMCPARM(BPCFAC,0))
+8 QUIT
ADDREF ;
+1 LOCK +^BMCREF(0):10
IF '$TEST
SET BPCERR=1
QUIT
+2 KILL BPCFDA,BPCEMSG
SET BPCFDR="BPCFDA(1)"
+3 SET BPCFDA(1,90001,"+1,",.01)=BPCIDAT
+4 SET BPCFDA(1,90001,"+1,",.02)=BPCREFN
+5 SET BPCFDA(1,90001,"+1,",.03)=BPCPIEN
+6 SET BPCFDA(1,90001,"+1,",.04)=BPCRTYPE
+7 SET BPCFDA(1,90001,"+1,",.05)=BPCFAC
+8 SET BPCFDA(1,90001,"+1,",.06)=BPCPROV
+9 SET BPCFDA(1,90001,"+1,",.07)=BPCPVEND
+10 SET BPCFDA(1,90001,"+1,",.08)=BPCTOIHS
+11 SET BPCFDA(1,90001,"+1,",.09)=BPCTOPRV
+12 SET BPCFDA(1,90001,"+1,",.11)=BPCPAYOR
+13 SET BPCFDA(1,90001,"+1,",.12)=BPCICD
+14 SET BPCFDA(1,90001,"+1,",.13)=BPCCPT
+15 SET BPCFDA(1,90001,"+1,",.14)=BPCPTYPE
+16 ;STATUS OF REFERRAL
SET BPCFDA(1,90001,"+1,",.15)="A"
+17 SET BPCFDA(1,90001,"+1,",.21)=BPCDRG
+18 SET BPCFDA(1,90001,"+1,",.23)=BPCCLIN
+19 SET BPCFDA(1,90001,"+1,",.25)=BPCUSR
+20 SET BPCFDA(1,90001,"+1,",.26)=BPCCDAT
+21 ;DATE LAST MODIFIED
SET BPCFDA(1,90001,"+1,",.27)=BPCCDAT
+22 SET BPCFDA(1,90001,"+1,",.32)=BPCPRIOR
+23 SET BPCFDA(1,90001,"+1,",.34)=BPCSNDA
+24 SET BPCFDA(1,90001,"+1,",1105)=BPCEBDAT
+25 SET BPCFDA(1,90001,"+1,",1107)=BPCEEDAT
+26 SET BPCFDA(1,90001,"+1,",1109)=BPCLOS
+27 SET BPCFDA(1,90001,"+1,",1111)=BPCNOVIS
+28 SET BPCFDA(1,90001,"+1,",1201)=BPCPURP
+29 SET BPCFDA(1,90001,"+1,",1301)=BPCSNOTE
+30 SET BPCFDA(1,90001,"+1,",1302)=BPCWDAYS
+31 DO DAT51
+32 IF BPCLSCAT'=""
DO ADDLSCAT
+33 KILL BPCIEN
DO UPDATE^DIE("",BPCFDR,"BPCIEN","BPCEMSG")
+34 IF $DATA(BPCEMSG("DIERR"))
SET BPCERR=1
+35 LOCK -^BMCREF(0)
+36 IF 'BPCERR
IF BPCHXS'=""
DO ADDHX
+37 IF 'BPCERR
SET BPCRIEN=BPCIEN(1)
IF BPCDXS'=""
DO SETDXS
+38 IF 'BPCERR
IF BPCPRCS'=""
DO SETPRCS
+39 QUIT
DAT51 ; SETS NODE 51 DATA
+1 SET BPCX=$GET(^DPT(BPCPIEN,0))
+2 ;NAME
SET BPCFDA(1,90001,"+1,",5101)=$PIECE(BPCX,U,1)
+3 ;DOB
SET BPCFDA(1,90001,"+1,",5103)=$PIECE(BPCX,U,3)
+4 ;SSN
SET BPCFDA(1,90001,"+1,",5104)=$PIECE(BPCX,U,9)
+5 ;SEX
SET BPCFDA(1,90001,"+1,",5107)=$PIECE(BPCX,U,2)
+6 SET BPCFDA(1,90001,"+1,",5102)=$PIECE($GET(^AUPNPAT(BPCPIEN,41,BPCFAC,0)),U,2)
+7 SET BPCFDA(1,90001,"+1,",5113)=$PIECE($GET(^DIC(4,BPCFAC,0)),U,1)
+8 SET BPCFDA(1,90001,"+1,",5114)=$PIECE($GET(^AUTTLOC(BPCFAC,0)),U,10)
+9 SET BPCX=$GET(^AUPNPAT(BPCPIEN,51))
SET BPCX1=$PIECE(BPCX,U,18)
SET BPCX2=$PIECE(BPCX,U,8)
+10 IF BPCX1'=""
SET BPCFDA(1,90001,"+1,",5105)=BPCX1
+11 IF BPCX2'=""
SET BPCFDA(1,90001,"+1,",5106)=$PIECE($GET(^AUTTTRI(BPCX2,0)),U,2)
+12 IF BPCPVEND'=""
Begin DoDot:1
+13 SET BPCFDA(1,90001,"+1,",5108)=$PIECE($GET(^AUTTVNDR(BPCPVEND,0)),U,1)
+14 SET BPCFDA(1,90001,"+1,",5109)=$PIECE($GET(^AUTTVNDR(BPCPVEND,11)),U,1)
End DoDot:1
+15 SET BPCFDA(1,90001,"+1,",5110)=$$MCR^AUPNPAT(BPCPIEN,BPCIDAT)
+16 SET BPCFDA(1,90001,"+1,",5111)=$$MCD^AUPNPAT(BPCPIEN,BPCIDAT)
+17 SET BPCFDA(1,90001,"+1,",5112)=$$PI^AUPNPAT(BPCPIEN,BPCIDAT)
+18 QUIT
ADDHX ;
+1 KILL ^BPCTMP($JOB)
+2 IF '$DATA(BPCIEN)
QUIT
+3 FOR BPCQ=1:1:$LENGTH(BPCHXS,BPCS2)
SET BPCX=$PIECE(BPCHXS,BPCS2,BPCQ)
SET ^BPCTMP($JOB,BPCQ,0)=BPCX
+4 SET BPCROOT="^BPCTMP("_$JOB_")"
+5 DO WP^DIE(90001,BPCIEN(1)_",",1,"",BPCROOT,"BPCEMSG")
+6 IF $DATA(BPCEMSG("DIERR"))
SET BPCERR=1
+7 KILL ^BPCTMP($JOB)
+8 QUIT
ADDLSCAT ;
+1 SET BPCSUB=1
FOR BPCQ=1:1:$LENGTH(BPCLSCAT,BPCS2)
SET BPCX=$PIECE(BPCLSCAT,BPCS2,BPCQ)
SET BPCSUB=BPCSUB+1
SET BPCXR="BPCFDA(1,90001.21,"_""""_"+"_BPCSUB_",+1,"_""""_",.01)"
SET @BPCXR=BPCX
+2 QUIT
SETDXS ;
+1 DO SETDXS^BPCRC5
+2 QUIT
SETPRCS ;
+1 DO SETPRCS^BPCRC5
+2 QUIT
GETDATA ;
+1 SET BPCIDAT=$PIECE(BPCPARAM,BPCS1,1)
+2 IF BPCIDAT'=""
SET X=BPCIDAT
DO ^%DT
SET BPCIDAT=$SELECT(Y'=-1:$PIECE(Y,".",1),1:"")
+3 IF BPCIDAT=""
SET RESULT(1)=-1
SET RESULT(2)="INITIATED DATE NOT IN PROPER FORMAT!"
SET BPCERR=1
QUIT
+4 SET BPCPIEN=$PIECE(BPCPARAM,BPCS1,2)
IF BPCPIEN=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO PATIENT IEN SENT!"
QUIT
+5 IF '$DATA(^DPT(BPCPIEN,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="IEN SENT IS NOT A DEFINED PATIENT IEN!"
QUIT
+6 SET BPCRTYPE=$PIECE(BPCPARAM,BPCS1,3)
IF "CION"'[BPCRTYPE
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="REFERRAL TYPE CODE SENT IS NOT A PROPER REFERRAL TYPE CODE!"
QUIT
+7 IF BPCFLAG="E"
SET BPCFAC=$PIECE(BPCPARAM,BPCS1,4)
IF BPCFAC=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="REQUESTING FACILITY NOT RECEIVED!"
QUIT
+8 SET BPCPROV=+$PIECE(BPCPARAM,BPCS1,5)
IF 'BPCPROV
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="REQUESTING PROVIDER SENT IS NOT ASSIGNED!"
QUIT
+9 IF '$DATA(^VA(200,BPCPROV,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="REQUESTING PROVIDER SENT IS NOT DEFINED!"
QUIT
+10 SET BPCPRNAM=$PIECE(^VA(200,BPCPROV,0),U,1)
+11 SET BPCPVEND=$PIECE(BPCPARAM,BPCS1,6)
IF BPCPVEND'=""
IF '$DATA(^AUTTVNDR(BPCPVEND,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="PRIMARY VENDOR SENT IS NOT DEFINED!"
QUIT
+12 SET BPCTOIHS=$PIECE(BPCPARAM,BPCS1,7)
IF BPCTOIHS'=""
IF '$DATA(^AUTTLOC(BPCTOIHS,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="TO IHS FACILITY SENT IS NOT DEFINED!"
QUIT
+13 SET BPCTOPRV=$PIECE(BPCPARAM,BPCS1,8)
IF BPCTOPRV'=""
IF '$DATA(^BMCLPRV(BPCTOPRV,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="TO OTHER PROVIDER SENT IS NOT DEFINED!"
QUIT
+14 SET BPCPAYOR=$PIECE(BPCPARAM,BPCS1,9)
IF BPCPAYOR=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO PRIMARY PAYOR SENT!"
QUIT
+15 SET BPCPAYOR=+BPCPAYOR
IF BPCPAYOR<1!(BPCPAYOR>8)
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="PRIMARY PAYOR SENT IS NOT CORRECT!"
QUIT
+16 SET BPCICD=$PIECE(BPCPARAM,BPCS1,10)
IF BPCICD'=""
IF '$DATA(^BMCTDXC(BPCICD,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="SENT ICD CATEGORY CODE IS NOT DEFINED!"
QUIT
+17 SET BPCCPT=$PIECE(BPCPARAM,BPCS1,11)
IF BPCCPT'=""
IF '$DATA(^BMCTSVC(BPCCPT,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="SEND CPT CATEGORY CODE IS NOT DEFINED!"
QUIT
+18 SET BPCPTYPE=$PIECE(BPCPARAM,BPCS1,12)
IF BPCPTYPE=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO PATIENT TYPE SENT!"
QUIT
+19 IF "IO"'[BPCPTYPE
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="PATIENT TYPE SENT IS NOT CORRECT!"
QUIT
+20 SET BPCCLIN=$PIECE(BPCPARAM,BPCS1,13)
IF BPCCLIN'=""
IF '$DATA(^DIC(40.7,BPCCLIN,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="CLINIC STOP SENT IS NOT DEFINED!"
QUIT
+21 SET BPCUSR=$PIECE(BPCPARAM,BPCS1,14)
IF BPCUSR'=""
IF '$DATA(^VA(200,BPCUSR,0))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="CREATED BY USER SENT IS NOT DEFINED!"
QUIT
+22 SET BPCCDAT=$PIECE(BPCPARAM,BPCS1,15)
+23 IF BPCCDAT'=""
SET X=BPCCDAT
DO ^%DT
SET BPCCDAT=$SELECT(Y'=-1:$PIECE(Y,".",1),1:"")
+24 IF BPCCDAT=""
SET RESULT(1)=-1
SET RESULT(2)="DATE CREATED NOT IN PROPER FORMAT!"
SET BPCERR=1
QUIT
+25 SET BPCPRIOR=+$PIECE(BPCPARAM,BPCS1,16)
IF BPCPRIOR<1!(BPCPRIOR>99)
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="PRIORITY SENT IS NOT CORRECT!"
QUIT
+26 SET BPCSNDA=$PIECE(BPCPARAM,BPCS1,17)
IF BPCSNDA'=""
IF "01"'[BPCSNDA
SET BPCSNDA=""
+27 SET BPCEBDAT=$PIECE(BPCPARAM,BPCS1,18)
IF BPCEBDAT'=""
SET X=BPCEBDAT
DO ^%DT
SET BPCEBDAT=$SELECT(Y'=-1:$PIECE(Y,".",1),1:"")
+28 SET BPCEEDAT=$PIECE(BPCPARAM,BPCS1,19)
IF BPCEEDAT'=""
SET X=BPCEEDAT
DO ^%DT
SET BPCEEDAT=$SELECT(Y'=-1:$PIECE(Y,".",1),1:"")
+29 SET BPCLOS=$PIECE(BPCPARAM,BPCS1,20)
SET BPCNOVIS=$PIECE(BPCPARAM,BPCS1,21)
+30 SET BPCPURP=$PIECE(BPCPARAM,BPCS1,22)
IF BPCPURP=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO PURPOSE OF REFERRAL SENT!"
QUIT
+31 SET BPCSNOTE=$PIECE(BPCPARAM,BPCS1,23)
SET BPCWDAYS=$PIECE(BPCPARAM,BPCS1,24)
SET BPCLSCAT=$PIECE(BPCPARAM,BPCS1,25)
SET BPCHXS=$PIECE(BPCPARAM,BPCS1,26)
+32 IF BPCFLAG="E"
SET BPCREFN=$PIECE(BPCPARAM,BPCS1,27)
SET BPCRIEN=$PIECE(BPCPARAM,BPCS1,31)
IF BPCRIEN=""
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="NO REFERRAL IEN WAS SENT FOR THE EDIT!"
QUIT
+33 SET BPCDRG=$PIECE(BPCPARAM,BPCS1,28)
SET BPCDXS=$PIECE(BPCPARAM,BPCS1,29)
SET BPCPRCS=$PIECE(BPCPARAM,BPCS1,30)
+34 QUIT
EDIT ;
+1 SET BPCERR=0
+2 DO GETDATA
IF BPCERR
QUIT
+3 IF '$DATA(^BMCREF(BPCRIEN))
SET BPCERR=1
SET RESULT(1)=-1
SET RESULT(2)="REFERRAL IEN SENT FOR EDIT IS INVALID!"
QUIT
+4 DO EDIT^BPCRC6
+5 QUIT
DELETE ;
+1 QUIT
