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

BPSRPT1.m

Go to the documentation of this file. 
  1. BPSRPT1 ;BHAM ISC/BEE - ECME REPORTS ;14-FEB-05
  1.  ;;1.0;E CLAIMS MGMT ENGINE;**1,5,7,8,10,11,19,20,23,24,28**;JUN 2004;Build 22
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; Reference to COLLECT^IBNCPEV3 supported by ICR 6131
  1.  ;
  1.  Q
  1.  ;
  1.  ; ECME Report Compile Routine - Looping/Filtering Routine
  1.  ;
  1.  ;  Input Variables:
  1.  ;               BPRTYPE - Type of Report (1-10)
  1.  ;               BPGLTMP - Temporary storage global
  1.  ;  BPPHARM/BPPHARM(ptr) - Set to 0 for all pharmacies, if set to 1 array
  1.  ;                         of internal pointers of selected pharmacies
  1.  ;              BPSUMDET - (1) Summary or (0) Detail format
  1.  ;              BPINSINF - Set to 0 for all insurances or list of file 36 IENs
  1.  ;                 BPMWC - A-ALL,M-Mail,W-Window,C-CMOP Prescriptions
  1.  ;               BPRTBCK - 1-ALL,2-RealTime,3-Backbill Claim Submission,4-PRO Option,5-Resubmission
  1.  ;               BPRLNRL - 1-ALL,2-RELEASED,3-NOT RELEASED
  1.  ;                 BPDUP - 0-ALL,S-Duplicate of Approved,D-Duplicate of Paid,Q-Duplicate of Capture
  1.  ;                BPDRUG - DRUG to report on (ptr to #50)
  1.  ;               BPDRGCL - DRUG CLASS to report on (0 for ALL)
  1.  ;               BPBEGDT - Beginning Date
  1.  ;               BPENDDT - Ending Date
  1.  ;               BPCCRSN - Set to 0 for all closed claim reasons or ptr to #356.8
  1.  ;              BPAUTREV - 0-ALL,1-Auto Reversed
  1.  ;               BPACREJ - 0-ALL,1-REJECTED,2-ACCEPTED
  1.  ;               BPNBSTS - Non-Billable Status
  1.  ;    BPELIG1/BPELIG1(x) - Array of multiple eligibilities
  1.  ;                BPALRC - A-All or R:Most recent
  1.  ;              
  1. COLLECT(BPGLTMP) N BP02,BP57,BP59,BPENDDT1,BPLDT02,BPLDT57,X,Y,OK,BPIX
  1.  ;
  1.  ;Check Variables
  1.  S OK=1
  1.  S:'$G(BPBEGDT) BPBEGDT=0
  1.  S:'$G(BPENDDT) BPENDDT=9999999
  1.  S BPENDDT=BPENDDT+0.9
  1.  I $G(BPRTYPE)=""!($G(BPGLTMP)="")!($G(BPPHARM)="")!($G(BPSUMDET)="")!($G(BPINSINF)="")!($G(BPMWC)="")!($G(BPRTBCK)="") S OK=-1 G EXIT
  1.  ;
  1.  ; For the Non-Billable Status report, we need to loop through the IB NCPDP EVENT LOG instead 
  1.  ;   of BPS Claim/BPS Transaction data
  1.  I BPRTYPE=9 Q $$COLLECT^IBNCPEV3(BPBEGDT,BPENDDT,BPMWC,BPRLNRL,BPDRUG,BPDRGCL,BPALRC,.BPPHARM,.BPINSINF,.BPNBSTS,.BPELIG1,BPGLTMP,BPPAT,BPBILL,$G(BPMIN),$G(BPMAX))
  1.  ;
  1.  ;Loop through BPS CLAIMS
  1.  ;
  1.  ;First look for fill/refill cross reference
  1.  ;Loop through Date of Service Index in BPS CLAIMS file and find link to 
  1.  ;claim in BPS TRANSACTION.  Process earliest Date of Service entry found in
  1.  ;BPS TRANSACTION
  1.  ;
  1.  ;Choose Index to Loop through (different for Closed Claims)
  1.  S BPIX="AF" S:BPRTYPE=7 BPIX="AG"
  1.  ;
  1.  S BPLDT02=$S(BPIX="AF":$$FM2YMD(BPBEGDT-0.00001),1:BPBEGDT) S:BPLDT02="" BPLDT02=0
  1.  S BPENDDT1=$S(BPIX="AF":$$FM2YMD(BPENDDT),1:BPENDDT_".9999999999") S:BPENDDT1="" BPENDDT1=99999999
  1.  F  S BPLDT02=+$O(^BPSC(BPIX,BPLDT02)) Q:BPLDT02=0!(BPLDT02>BPENDDT1)  D
  1.  . S BP02=0 F  S BP02=$O(^BPSC(BPIX,BPLDT02,BP02)) Q:+BP02=0  D
  1.  . . S BP59=+$O(^BPST("AE",BP02,0))
  1.  . . Q:BP59=0
  1.  . . I $D(@BPGLTMP@("FILE59",BP59)) Q
  1.  . . S @BPGLTMP@("FILE59",BP59)=BPLDT02_"^02"
  1.  . . D PROCESS(BP59)
  1.  ;
  1.  ;#9002313.59 has only one entry per claim with, which has a date 
  1.  ;  of the latest update for the claim
  1.  ;#9002313.57 has more than one entries per claim and keep all 
  1.  ;  changes made the claim
  1.  ;so we have to go thru #9002313.57 to find the earliest date 
  1.  ;related to the claim to check it against BPBEGDT
  1.  S BPLDT57=BPBEGDT-0.00001
  1.  F  S BPLDT57=+$O(^BPSTL("AH",BPLDT57)) Q:BPLDT57=0!(BPLDT57>BPENDDT)  D
  1.  . S BP57=0 F  S BP57=$O(^BPSTL("AH",BPLDT57,BP57)) Q:+BP57=0  D
  1.  . . S BP59=+$G(^BPSTL(BP57,0))
  1.  . . I $D(@BPGLTMP@("FILE59",BP59)) Q
  1.  . . S @BPGLTMP@("FILE59",BP59)=BPLDT57_"^57"
  1.  . . D PROCESS(BP59)
  1.  ;
  1.  ;Remove Portion of Scratch Global
  1. EXIT K @BPGLTMP@("FILE59")
  1.  Q OK
  1.  ;
  1.  ;Convert FB date to YYYYMMDD
  1. FM2YMD(BPFMDT) N Y,Y1
  1.  S Y=$E(BPFMDT,2,3),Y1=$E(BPFMDT,1,1) S Y=$S(Y1=3:"20"_Y,Y1=2:"19"_Y,1:"")
  1.  Q:Y Y_$E(BPFMDT,4,7)
  1.  Q ""
  1.  ;
  1.  ;Process each Entry
  1.  ;
  1. PROCESS(BP59) ;
  1.  N BPBILLED,BPBCK,BPBCKXBPDFN,BPREF,BPPAYBL,BPPLAN,BPREJ,BPRLSDT,BPRX,BPRXDC,BPRXDRG,BPSTATUS,BPSEQ,BPSTOP
  1.  N BPDUPREC,BPDUPST,BPDUPPAY,BPSPOS,BPSRESP
  1.  ;
  1.  S BPSEQ=$$COB59^BPSUTIL2(BP59)
  1.  ;
  1.  ;Get ABSBRXI - ptr to #52
  1.  S BPRX=+$P($G(^BPST(BP59,1)),U,11)
  1.  ;
  1.  ;Get ABSBRXR - Prescription Number IEN
  1.  S BPREF=+$P($G(^BPST(BP59,1)),U)
  1.  ;
  1.  ;Get PATIENT - ptr to #2
  1.  S BPDFN=+$P($G(^BPST(BP59,0)),U,6)
  1.  ; 
  1.  ; Skip eligibility verification transactions
  1.  I $P($G(^BPST(BP59,0)),U,15)="E" G XPROC
  1.  ;
  1.  ;Check for correct BPS Pharmacy (DIVISION)
  1.  I $G(BPPHARM)=1,$$CHKPHRM(BP59)=0 G XPROC
  1.  ;
  1.  ;Check for Display 1-ALL,2-RELEASED,3-NOT RELEASED
  1.  S BPRLSDT=$$RELEASED(BPRX,BPREF)
  1.  I BPRLNRL'=1 I ((BPRLNRL=2)&(BPRLSDT=0))!((BPRLNRL=3)&(BPRLSDT)) G XPROC
  1.  ;
  1.  ;Get Status
  1.  S BPSTATUS=$$STATUS^BPSRPT6(BPRX,BPREF,BPSEQ)
  1.  ;
  1.  ;if REVERSAL
  1.  I BPRTYPE=4,BPSTATUS'["REVERSAL" G XPROC  ; exclude non-reversed
  1.  I BPRTYPE=4,$$CLOSED02^BPSSCR03($P(^BPST(BP59,0),U,4))=1 G XPROC  ; exclude closed claims for Reversal Report
  1.  ;
  1.  ;if PAYABLE
  1.  S BPPAYBL=BPSTATUS["PAYABLE"
  1.  I BPRTYPE=1,'BPPAYBL G XPROC  ; exclude non-payable
  1.  I BPRTYPE=1,BPSTATUS["REVERSAL" G XPROC  ; reversed
  1.  ;
  1.  ;if REJECTED
  1.  S BPREJ=BPSTATUS["REJECTED"
  1.  I BPRTYPE=2,BPSTATUS["REVERSAL" G XPROC ; exclude rejected reversals
  1.  I BPRTYPE=2,'BPREJ G XPROC  ; exclude non-rejected
  1.  ;
  1.  ;if SUBMITTED NOT RELEASED exclude released ones
  1.  I BPRTYPE=3,BPRLSDT'=0 G XPROC
  1.  I BPRTYPE=3,'BPPAYBL G XPROC  ; exclude non-payable
  1.  ;
  1.  ;Auto Reverse Check
  1.  I BPRTYPE=4,BPAUTREV,'$$AUTOREV(BP59) G XPROC
  1.  ;
  1.  ;if CLOSED
  1.  I BPRTYPE=7,'$$CLSCLM(BP59) G XPROC  ;exclude open claims
  1.  ;I BPRTYPE=7,BPSTATUS'["REJECTED" G XPROC  ;exclude non-rejected closed claims
  1.  ;
  1.  ;if Spending Account Report, check Pricing Segment for data
  1.  I BPRTYPE=8,'$$PRICING^BPSRPT5(BP59) G XPROC
  1.  ;
  1.  ;if Recent Transactions, exclude closed claims
  1.  I BPRTYPE=5,$$CLSCLM(BP59) G XPROC
  1.  ;
  1.  ;If Totals by Date, include only rejects and payables
  1.  I BPRTYPE=6,BPSTATUS'["REJECTED",BPSTATUS'["PAYABLE" G XPROC  ; Reversed
  1.  ;
  1. DUP ;If Duplicate Claims Report check TRANSACTION RESPONSE STATUS in file #9002313.0301
  1.  ; if the Claim has a Duplicate Status, get the Patient Payment Amount
  1.  I BPRTYPE=10 D  I 'BPDUPREC G XPROC
  1.  . S BPDUPREC=0
  1.  . D RESP59^BPSRPT2(BP59,.BPSRESP,.BPSPOS)
  1.  . I (BPSRESP="")!(BPSPOS="") Q
  1.  . S BPDUPST=$$GET1^DIQ(9002313.0301,BPSPOS_","_BPSRESP_",",112,"I")
  1.  . I BPDUPST="" Q
  1.  . I BPDUP=0 I "(,S,D,Q,)"[BPDUPST S BPDUPREC=1
  1.  . I BPDUP'=0 I BPDUP[BPDUPST S BPDUPREC=1
  1.  . I BPDUPREC S BPDUPPAY=$$GETPPAY^BPSRPT2(BPSRESP,BPSPOS)
  1.  ;
  1.  ;Realtime/Backbill/PRO Option/Resubmission Check
  1.  S BPBCK=$$RTBCK(BP59)
  1.  ;
  1.  ; BPBCK   = 1 Backbill / 2 PRO / 5 Resub / 0 Realtime
  1.  ; BPRTBCK = 3 Backbill / 4 PRO / 5 Resub / 2 Realtime
  1.  ;
  1.  S BPBCKX=$S(BPBCK=1:3,BPBCK=2:4,BPBCK=5:5,BPBCK=0:2,1:"") ;convert to BPRTBCK value
  1.  ;
  1.  ; If user doesn't want all transmission types (BPRTBCK'=1),
  1.  ; then figure out if this transaction is OK
  1.  I BPRTBCK'=1,BPRTBCK'[BPBCKX G XPROC
  1.  ;
  1.  ;Check for MAIL/WINDOW/CMOP/ALL
  1.  I BPMWC'="A",BPMWC'[$$MWC^BPSRPT6(BPRX,BPREF) G XPROC
  1.  ;
  1.  ;Check for selected insurance
  1.  S BPPLAN=$$INSNAM^BPSRPT6(BP59)
  1.  I BPINSINF'=0,'$$CHKINS^BPSSCRCU($P(BPPLAN,U,1),BPINSINF) G XPROC
  1.  S BPPLAN=$P(BPPLAN,U,2)
  1.  ; 
  1.  ;Check for selected drug
  1.  S BPRXDRG=$$GETDRUG^BPSRPT6(BPRX)
  1.  I BPRXDRG=0 G XPROC
  1.  I BPDRUG D  I BPSTOP=0 G XPROC
  1.  . S BPSTOP=0
  1.  . F I=1:1:$L(BPDRUG,",") I BPRXDRG=$P(BPDRUG,",",I) S BPSTOP=1 Q
  1.  ;
  1.  ;Check for selected drug classes
  1.  I BPDRGCL'=0 S BPRXDC=$$DRGCLNAM^BPSRPT6($$GETDRGCL^BPSRPT6(BPRXDRG),99) D  I BPSTOP=0 G XPROC
  1.  . S BPSTOP=0
  1.  . F I=1:1:$L(BPDRGCL,";") I BPRXDC=$P(BPDRGCL,";",I) S BPSTOP=1 Q
  1.  ;
  1.  ;Check for selected Close Reason
  1.  I BPCCRSN D  I BPSTOP=0 G XPROC
  1.  . S BPSTOP=0
  1.  . F I=1:1:$L(BPCCRSN,",") I $P(BPCCRSN,",",I)=$P($$CLRSN^BPSRPT7(BP59),U) S BPSTOP=1 Q
  1.  ;
  1.  ;Check for Accepted/Rejected
  1.  I BPACREJ=1,BPSTATUS'["REJECTED" G XPROC
  1.  I BPACREJ=2,BPSTATUS'["ACCEPTED" G XPROC
  1.  ;
  1.  ;Check for Specific Reject Code
  1.  I BPREJCD'=0 D  I BPSTOP=0 G XPROC
  1.  . S BPSTOP=0
  1.  . F I=1:1:$L(BPREJCD,",") I $$CKREJ(BP59,$P(BPREJCD,",",I)) S BPSTOP=1 Q
  1.  ;
  1.  ;;Check for Eligibility Code
  1.  ;;I BPELIG'=0,BPELIG'=$$ELIGCODE^BPSSCR05(BP59) G XPROC
  1.  ;
  1.  ;Check for Eligibility Codes, when one or more is selected (BPELIG1=1)
  1.  I (",1,2,3,4,7,9,10,")[(","_BPRTYPE_","),BPELIG1'=0 S ELIG=$$ELIGCODE^BPSSCR05(BP59) G:$G(ELIG)="" XPROC I '$D(BPELIG1(ELIG)) G XPROC
  1.  ;
  1.  ;Check for selected Prescribers
  1.  I BPRESC'=0 D  I BPSTOP=0 G XPROC
  1.  . S BPSTOP=0
  1.  . F I=1:1:$L(BPRESC,",") I $$CKPRESC(BP59,$P(BPRESC,",",I)) S BPSTOP=1 Q
  1.  ;
  1.  ;Check for selected Patients
  1.  I BPQSTPAT'=0,$G(BPPAT)'="" D  I BPSTOP=0 G XPROC
  1.  . S BPSTOP=0
  1.  . F I=1:1:$L(BPPAT,",") I $P(BPPAT,",",I)=$$GET1^DIQ(9002313.59,BP59,5,"I") S BPSTOP=1 Q
  1.  ;
  1.  ; Check for Billed Amount
  1.  I $G(BPBILL)'=0 S BPBILLED=$$GET1^DIQ(9002313.59,BP59,505) I (BPBILLED<BPMIN)!(BPBILLED>BPMAX) G XPROC
  1.  ;
  1.  ;Check Open/Closed claim
  1.  I BPOPCL'=0,((BPOPCL=2)&($$CLOSED02^BPSSCR03($P(^BPST(BP59,0),U,4))=1))!((BPOPCL=1)&($$CLOSED02^BPSSCR03($P(^BPST(BP59,0),U,4))'=1)) G XPROC
  1.  ;
  1.  ;Save Entry for Report
  1.  D SETTMP^BPSRPT2(BPGLTMP,BPDFN,BPRX,BPREF,BP59,BPBEGDT,BPENDDT,.BPPHARM,BPSUMDET,BPPLAN,BPRLSDT,BPPAYBL,BPREJ,BPRXDRG,$P(BPSTATUS,U),$G(BPDUPST),$G(BPDUPPAY))
  1.  ;
  1. XPROC Q
  1.  ;
  1.  ;Check if selected BPS PHARMACY
  1.  ;
  1.  ; Defined Variable: BPPHARM(ptr) - List of BPS Pharmacies to Report on
  1.  ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59)
  1.  ; 
  1.  ; Returned Value -> 0 = Entry not in list of selected pharmacies
  1.  ;                   1 = Entry is in list of selected pharmacies
  1. CHKPHRM(BP59) N PHARM
  1.  S PHARM=+$P($G(^BPST(BP59,1)),"^",7)
  1.  S PHARM=$S($D(BPPHARM(PHARM)):1,1:0)
  1.  Q PHARM
  1.  ;
  1.  ;Determine whether claim is Released or Not Released
  1.  ;
  1.  ; Input Variables: BPRX - ptr to PRESCRIPTION (#52)
  1.  ;                 BPREF - refill # (0-No Refills,1-1st Refill, 2-2nd, ...) 
  1.  ;
  1.  ; Return Value ->             0 = Not Released
  1.  ;                 released date = Released
  1.  ;                 
  1. RELEASED(BPRX,BPREF) N RDT
  1.  ;
  1.  I BPREF=0 S RDT=$$RXRELDT^BPSRPT6(BPRX)\1
  1.  I BPREF'=0 S RDT=$$REFRELDT^BPSRPT6(BPRX,BPREF)\1
  1.  Q RDT
  1.  ;
  1.  ;Determine if claim was Auto Reversed
  1.  ;
  1.  ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59)
  1.  ; Return Value -> 1 = Auto Reversed
  1.  ;                 0 = Not Auto Reversed
  1.  ;
  1. AUTOREV(BP59) N AR,BP02
  1.  S BP02=+$P($G(^BPST(BP59,0)),U,4)
  1.  S AR=+$P($G(^BPSC(BP02,0)),U,7)
  1.  Q AR
  1.  ;
  1.  ;Determine if claim was closed
  1.  ;
  1.  ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59)
  1.  ; Return Value -> 1 = Closed
  1.  ;                 0 = Not Closed
  1.  ;                 
  1. CLSCLM(BP59) N BP02,CL
  1.  S BP02=+$P($G(^BPST(BP59,0)),U,4)
  1.  S CL=+$G(^BPSC(BP02,900))
  1.  Q CL
  1.  ;
  1.  ;Determine whether claim is Realtime or Backbilled or PRO Option or Resubmission
  1.  ;
  1.  ; Input Variable: BP59 - Lookup to BPS TRANSACTION (#59)
  1.  ; Return Value -> 5 = Resubmission
  1.  ;                 2 = PRO Option
  1.  ;                 1 = Backbilled
  1.  ;                 0 = Realtime
  1. RTBCK(BP59) N BB
  1.  S BB=$P($G(^BPST(BP59,12)),U,1)
  1.  S BB=$S(BB="BB":1,BB="P2":2,BB="P2S":2,BB="ERES":5,BB="ERWV":5,BB="ERNB":5,1:0)
  1.  Q BB
  1.  ;
  1.  ;Determine if the Prescriber for claim was one of the Prescribers selected
  1.  ;
  1.  ; Input Variables: BPS59 - Lookup to BPS TRANSACTION (#59)
  1.  ;                  BPSRESC - string of Prescribers selected separated by a comma
  1.  ;
  1.  ; Return Value -> 1 = Prescriber is on the list of selected Prescribers 
  1.  ;                 0 = RX and/or Prescriber not found, or the Prescriber for this
  1.  ;                     transaction isn't one of the selected Prescribers
  1.  ;
  1. CKPRESC(BPS59,BPSPRESC) ;
  1.  ; 
  1.  N BPSFND,BPSRX,BPSRXPRSC
  1.  ;
  1.  S BPSFND=0  ; Initialize to zero.
  1.  ;
  1.  ; get the prescription number ien from the BPS TRANSACTION file
  1.  S BPSRX=$$GET1^DIQ(9002313.59,BPS59,1.11,"I")
  1.  ;
  1.  ; if the prescription number didn't exist 
  1.  I BPSRX="" G CKPRESCX
  1.  ;
  1.  ; get the prescriber ien from the PRESCRIPTION file
  1.  S BPSRXPRSC=$$GET1^DIQ(52,BPSRX,4,"I")
  1.  ;
  1.  ; if the prescriber didn't exist BPRESC 
  1.  I BPSRXPRSC="" G CKPRESCX
  1.  ;
  1.  ; The Prescriber for this transaction is one of the Prescribers selected
  1.  I BPSPRESC[BPSRXPRSC S BPSFND=1
  1.  ;
  1. CKPRESCX ;
  1.  Q BPSFND
  1.  ;
  1.  ;Screen Pause 1
  1.  ;
  1.  ; Return variable - BPQ = 0 Continue
  1.  ;                          2 Quit
  1. PAUSE N X
  1.  U IO(0) W !!,"Press RETURN to continue, '^' to exit:"
  1.  R X:$G(DTIME) S:'$T X="^" S:X["^" BPQ=2
  1.  U IO
  1.  Q
  1.  ;
  1.  ;Screen Pause 2
  1.  ;
  1.  ; Return variable - BPQ = 0 Continue
  1.  ;                         2 Quit
  1. PAUSE2 N X
  1.  U IO(0) W !!,"Press RETURN to continue:"
  1.  R X:$G(DTIME) S:'$T X="^" S:X["^" BPQ=2
  1.  U IO
  1.  Q
  1.  ;
  1.  ;Get ECME#
  1.  ;
  1.  ;BP59 - ptr to 9002313.59
  1.  ;output :
  1.  ;ECME number from 9002313.02
  1.  ; 7 or 12 digits of the prescription IEN file 52
  1.  ; or 12 spaces
  1. ECMENUM(BP59) ;*/
  1.  Q $$ECMENUM^BPSSCRU2(BP59)
  1.  ;
  1.  ;Convert FM date or date.time to displayable (mm/dd/yy HH:MM) format
  1.  ;
  1. DATTIM(X) N DATE,BPT,BPM,BPH,BPAP
  1.  S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
  1.  S BPT=$P(X,".",2) S:$L(BPT)<4 BPT=BPT_$E("0000",1,4-$L(BPT))
  1.  S BPH=$E(BPT,1,2),BPM=$E(BPT,3,4)
  1.  S BPAP="AM" I BPH>12 S BPH=BPH-12,BPAP="PM" S:$L(BPH)<2 BPH="0"_BPH
  1.  I BPT S:'BPH BPH=12 S DATE=DATE_" "_BPH_":"_BPM_BPAP
  1.  Q $G(DATE)
  1.  ;
  1.  ;Display RT-Realtime,BB-Backbill,P2-PRO Option, RS-Resubmission or " "
  1.  ;
  1. RTBCKNAM(BPINDEX) Q $S(BPINDEX=0:"RT",BPINDEX=1:"BB",BPINDEX=2:"P2",BPINDEX=5:"RS",1:" ")
  1.  ;
  1.  ;See for Specific Reject Code
  1.  ;
  1. CKREJ(BP59,BPREJCD) N FREJ,I,REJ,X
  1.  S FREJ=0
  1.  S X=$$REJTEXT^BPSRPT2(BP59,.REJ)
  1.  S X="" F  S X=$O(REJ(X)) Q:X=""  D  Q:FREJ=1
  1.  .S REJ=$P($G(REJ(X)),":") Q:REJ=""
  1.  .S I="" F  S I=$O(^BPSF(9002313.93,"B",REJ,I)) Q:I=""  I I=BPREJCD S FREJ=1
  1.  Q FREJ