BPCRC3.m

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