BPSOPR2 ;ALB/PHH - OPECC Productivity Report Compiler ;9/21/2015
;;1.0;E CLAIMS MGMT ENGINE;**20**;JUN 2004;Build 27
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
COMPILE ; Entry point for the compile to build the scratch global
; This may be a background task if the job is queued.
;
D FIND
D SORT
D BUILD
;
D PRINT^BPSOPR3 ; print report
D ^%ZISC ; close the device
K @BPGLTMP ; kill scratch
I $D(ZTQUEUED) S ZTREQ="@" ; purge the task
Q
;
BUILD ; Build report
N BPSSHDR,BPSIDX,S1,S2,BPSRXFC,DATA,BPSDIV,BPSTRDT,BPSUSER,BPSLINE
;
D SUBINIT(.BPSSHDR)
;
S BPSIDX=1
;
; Export the report to Excel
I BPEXCEL D
.; Data is as follows:
.; DIVISION^USER^CURRENT STATUS^#TRANS IN DT RANGE^#TRANS TOTAL^ELIG^RX#^REF^ECME#^COB^DOS^TRANS DATE^PAID AMT
.;
.S S1=""
.F S S1=$O(@BPGLTMP@("SORT",S1)) Q:S1="" D
..S S2=0
..F S S2=$O(@BPGLTMP@("SORT",S1,S2)) Q:'S2 D
...S BPSRXFC=""
...F S BPSRXFC=$O(@BPGLTMP@("SORT",S1,S2,BPSRXFC)) Q:BPSRXFC="" D
....S DATA=@BPGLTMP@("SORT",S1,S2,BPSRXFC)
....S BPSDIV=$P(DATA,U,9),BPSTRDT=$P(DATA,U,11),BPSUSER=$P(DATA,U,10)
....S BPSLINE=BPSDIV_"^"
....S BPSLINE=BPSLINE_BPSUSER_"^"
....S BPSLINE=BPSLINE_$P(DATA,U)_"^"
....S BPSLINE=BPSLINE_+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13)_"^"
....S BPSLINE=BPSLINE_+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^")_"^"
....S BPSLINE=BPSLINE_$S($P(DATA,U,2)="V":"VET",$P(DATA,U,2)="T":"TRI",$P(DATA,U,2)="C":"CVA",1:"")_"^"
....S BPSLINE=BPSLINE_$P(DATA,U,3)_"^"
....S BPSLINE=BPSLINE_$P(DATA,U,4)_"^"
....S BPSLINE=BPSLINE_$P(DATA,U,7)_"^"
....S BPSLINE=BPSLINE_$S($P(DATA,U,8)=1:"P",$P(DATA,U,8)=2:"S",$P(DATA,U,8)=3:"T",1:"")_"^"
....S BPSLINE=BPSLINE_$P(DATA,U,5)_"^"
....S BPSLINE=BPSLINE_$$DATTIM^BPSRPT1((BPSTRDT\1))_"^"
....I $P(DATA,U)'="NON-BILLABLE" D
.....S BPSLINE=BPSLINE_$S($P(DATA,U,6)="":"0.00",1:$P(DATA,U,6))
....S @BPGLTMP@("REPORT",BPSIDX)=BPSLINE,BPSIDX=BPSIDX+1
;
I 'BPEXCEL D
.S S1=""
.F S S1=$O(@BPGLTMP@("SORT",S1)) Q:S1="" D
..S BPSLINE=$S(BPSSORD=1:"USER NAME: "_S1,1:"DIVISION: "_S1)
..S @BPGLTMP@("REPORT",BPSIDX)=BPSLINE,BPSIDX=BPSIDX+1
..S BPSLINE=""
..D ADDCHAR^BPSOPR3(.BPSLINE,"-",129)
..S @BPGLTMP@("REPORT",BPSIDX)=BPSLINE,BPSIDX=BPSIDX+1
..S S2=0
..F S S2=$O(@BPGLTMP@("SORT",S1,S2)) Q:'S2 D
...S BPSRXFC=""
...F S BPSRXFC=$O(@BPGLTMP@("SORT",S1,S2,BPSRXFC)) Q:BPSRXFC="" D
....S DATA=@BPGLTMP@("SORT",S1,S2,BPSRXFC)
....S BPSDIV=$P(DATA,U,9),BPSTRDT=$P(DATA,U,11),BPSUSER=$P(DATA,U,10)
....;
....; Print details
....I BPSUMDET=0 D
.....S BPSLINE=$E(BPSUSER,1,15)
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",17-$L(BPSLINE))
.....S BPSLINE=BPSLINE_$E($P(DATA,U),1,19)
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",37-$L(BPSLINE))
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",4-$L(+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13)))
.....S BPSLINE=BPSLINE_+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13)
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",6-$L(+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^")))
.....S BPSLINE=BPSLINE_+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^")
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",7)
.....S BPSLINE=BPSLINE_$S($P(DATA,U,2)="V":"VET",$P(DATA,U,2)="T":"TRI",$P(DATA,U,2)="C":"CVA",1:" ")
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",2)
.....S BPSLINE=BPSLINE_$P(DATA,U,3)
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",71-$L(BPSLINE))
.....S BPSLINE=BPSLINE_$P(DATA,U,4)_"/"
.....S BPSLINE=BPSLINE_$P(DATA,U,7)_" "
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",12-$L($P(DATA,U,7)))
.....S BPSLINE=BPSLINE_$S($P(DATA,U,8)=1:"P",$P(DATA,U,8)=2:"S",$P(DATA,U,8)=3:"T",1:" ")
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",3)
.....S BPSLINE=BPSLINE_$P(DATA,U,5)_" "
.....D ADDCHAR^BPSOPR3(.BPSLINE," ",9-$L($P(DATA,U,5)))
.....S BPSLINE=BPSLINE_$$DATTIM^BPSRPT1((BPSTRDT\1))_" "
.....I $P(DATA,U)'="NON-BILLABLE" D
......D ADDCHAR^BPSOPR3(.BPSLINE," ",15-$L($S($P(DATA,U,6)="":"0.00",1:$P(DATA,U,6))))
......S BPSLINE=BPSLINE_$S($P(DATA,U,6)="":"0.00",1:$P(DATA,U,6))
.....S @BPGLTMP@("REPORT",BPSIDX)=BPSLINE,BPSIDX=BPSIDX+1
..;
..; Print subtotals
..D PRTSGHDR(.BPSSHDR,.BPSIDX,S1)
..I BPSSORD=0 D PRTSGTOT(.BPSIDX,S1)
..I BPSSORD=1 D PRTSGTOT(.BPSIDX,"",S1)
..S DATA=""
..D ADDCHAR^BPSOPR3(.DATA," ",129)
..S @BPGLTMP@("REPORT",BPSIDX)=DATA,BPSIDX=BPSIDX+1
..S DATA=""
..D ADDCHAR^BPSOPR3(.DATA," ",129)
..S @BPGLTMP@("REPORT",BPSIDX)=DATA,BPSIDX=BPSIDX+1
..S DATA=""
..D ADDCHAR^BPSOPR3(.DATA,"-",129)
..S @BPGLTMP@("REPORT",BPSIDX)=DATA,BPSIDX=BPSIDX+1
.;
.I '$D(@BPGLTMP@("REPORT"))!(BPSIDX=1) Q
.S DATA=""
.D ADDCHAR^BPSOPR3(.DATA,"-",129)
.I @BPGLTMP@("REPORT",BPSIDX-1)=DATA D
..K @BPGLTMP@("REPORT",BPSIDX-1) S BPSIDX=BPSIDX-1
..K @BPGLTMP@("REPORT",BPSIDX-1) S BPSIDX=BPSIDX-1
..K @BPGLTMP@("REPORT",BPSIDX-1) S BPSIDX=BPSIDX-1
.;
.; Print summary
.D PRTSGHDR(.BPSSHDR,.BPSIDX)
.D PRTSGTOT(.BPSIDX)
;
I '$D(@BPGLTMP@("REPORT"))!(BPSIDX=1) D
.S @BPGLTMP@("REPORT",BPSIDX)="No data available for date range."
Q
;
PRTSGTOT(BPSIDX,BPSDIV,BPSUSER) ; Print grand/subtotals
N X,BPSUSRNM,BPSDIV1
;
Q:BPSIDX=""
S BPSDIV=$G(BPSDIV,"")
S BPSUSER=$G(BPSUSER,"")
;
I BPSUSER="",BPUSER=1 D
.S X=0
.F S X=$O(BPUSER(X)) Q:'X S BPSUSRNM($P(BPUSER(X),U,2))=""
.;
.S BPSUSER=""
.F S BPSUSER=$O(BPSUSRNM(BPSUSER)) Q:BPSUSER="" D
..D PRTUTOT(.BPSIDX,BPSDIV,BPSUSER)
;
I BPSUSER="",BPUSER=0 D
.S BPSDIV1=""
.F S BPSDIV1=$O(@BPGLTMP@("USRTOT",BPSDIV1)) Q:BPSDIV1="" D
..S BPSUSER=""
..F S BPSUSER=$O(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER)) Q:BPSUSER="" D
...S BPSUSRNM(BPSUSER)=""
.;
.S BPSUSER=""
.F S BPSUSER=$O(BPSUSRNM(BPSUSER)) Q:BPSUSER="" D
..D PRTUTOT(.BPSIDX,BPSDIV,BPSUSER)
;
I BPSUSER'="" D
.D PRTUTOT(.BPSIDX,BPSDIV,BPSUSER)
Q
;
PRTUTOT(BPSIDX,BPSDIV,BPSUSER) ; Print user totals
N BPSPYNR,BPSPYREJ,BPSTAMT,BPSTTRN,BPSDIV1,BPSLINE
;
Q:BPSIDX=""
S BPSDIV=$G(BPSDIV,"")
Q:BPSUSER=""
;
S (BPSPYNR,BPSPYREJ,BPSTAMT,BPSTTRN)=0
I BPSDIV'="" D
.S BPSPYNR=+$P($G(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^",2)
.S BPSPYREJ=+$P($G(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^",3)
.S BPSTAMT=+$P($G(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^")
I BPSDIV="" D
.S BPSDIV1=""
.F S BPSDIV1=$O(@BPGLTMP@("USRTOT",BPSDIV1)) Q:BPSDIV1="" D
..Q:'$D(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER))
..S BPSPYNR=BPSPYNR+$P($G(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER)),"^",2)
..S BPSPYREJ=BPSPYREJ+$P($G(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER)),"^",3)
..S BPSTAMT=BPSTAMT+(+$P($G(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER)),"^"))
S BPSTTRN=$$TOTTRN(BPSDIV,BPSUSER)
;
S BPSLINE=$E(BPSUSER,1,15)
D ADDCHAR^BPSOPR3(.BPSLINE," ",17-$L(BPSLINE))
S BPSLINE=BPSLINE_BPSPYREJ
D ADDCHAR^BPSOPR3(.BPSLINE," ",41-$L(BPSLINE))
S BPSLINE=BPSLINE_BPSPYNR
D ADDCHAR^BPSOPR3(.BPSLINE," ",69-$L(BPSLINE))
D ADDCHAR^BPSOPR3(.BPSLINE," ",5-$L(BPSTTRN))
S BPSLINE=BPSLINE_BPSTTRN
D ADDCHAR^BPSOPR3(.BPSLINE," ",89-$L(BPSLINE))
S BPSTAMT=$J(BPSTAMT,7,2)
D ADDCHAR^BPSOPR3(.BPSLINE," ",15-$L(BPSTAMT))
S BPSLINE=BPSLINE_BPSTAMT
;
I BPSDIV'="",'$D(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)) Q
S @BPGLTMP@("REPORT",BPSIDX)=BPSLINE,BPSIDX=BPSIDX+1
Q
;
TOTTRN(BPSDIV,BPSUSER) ; Get total transactions for a user
N BPSCNT,BPSTRDT,BPSRXFC,BPSDIV1
;
S BPSDIV=$G(BPSDIV,"")
Q:BPSUSER=""
;
S BPSCNT=0
I BPSDIV'="" D
.S BPSRXFC=""
.F S BPSRXFC=$O(@BPGLTMP@("DATA",BPSRXFC)) Q:BPSRXFC="" D
..S BPSCNT=BPSCNT+(+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13))
I BPSDIV="" D
.S BPSRXFC=""
.F S BPSRXFC=$O(@BPGLTMP@("DATA",BPSRXFC)) Q:BPSRXFC="" D
..S BPSDIV1=""
..F S BPSDIV1=$O(@BPGLTMP@("DATA",BPSRXFC,BPSDIV1)) Q:BPSDIV1="" D
...Q:'$D(@BPGLTMP@("DATA",BPSRXFC,BPSDIV1,BPSUSER))
...S BPSCNT=BPSCNT+(+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV1,BPSUSER)),"^",13))
Q BPSCNT
;
PRTSGHDR(BPSSHDR,BPSIDX,BPSSGHTX) ; Print subtotals/grand header
N BPSLINE,BPSCNT
;
S BPSSGHTX=$G(BPSSGHTX,"")
S BPSSHDR(2)=$S(BPSSGHTX="":"GRAND TOTAL",1:"SUBTOTALS FOR "_BPSSGHTX)
;
F BPSCNT=1:1:4 D
.S BPSLINE=BPSSHDR(BPSCNT)
.S @BPGLTMP@("REPORT",BPSIDX)=BPSLINE,BPSIDX=BPSIDX+1
Q
;
SUBINIT(BPSSHDR) ; Set up subtotals header
S BPSSHDR(1)=""
S BPSSHDR(3)=" REJECTED AND NOT REJECTED AND PAYABLE"
S BPSSHDR(4)="USER RESOLVED TO PAYABLE (POSSIBLE BACK-BILL) TRANS IN DT RANGE AMOUNT PAID"
Q
;
FIND ; Find records
N BPLDT57,BP57
K @BPGLTMP
;
I 'BPEXCEL,'$D(ZTQUEUED) U 0 W !!,"Compiling OPECC Productivity Report. Please wait ... ",! U IO
;
; Check Variables
S:'$G(BPBEGDT) BPBEGDT=0
S:'$G(BPENDDT) BPENDDT=9999999
S BPENDDT=BPENDDT+0.9
;
; Loop through BPS LOG OF TRANSACTIONS file #9002313.57
S BPLDT57=BPBEGDT-0.00001
F S BPLDT57=+$O(^BPSTL("AH",BPLDT57)) Q:BPLDT57=0!(BPLDT57>BPENDDT) D
.S BP57=0
.F S BP57=$O(^BPSTL("AH",BPLDT57,BP57)) Q:'BP57 D PROCESS^BPSOPR3(BP57)
Q
;
CALCREJ(BPSDIV,BPSUSER,BPRX,BPREF,BPSCOB) ; Calculate reject counts
; Returns 1 if reject found, otherwise returns 0
N BP57,BPSRCNT
;
S (BP57,BPSRCNT)=0
F S BP57=$O(^BPSTL("AEC",BPRX,BP57)) Q:'BP57!(BPSRCNT) D
.I BPSUSER'=$P($G(^VA(200,+$P($G(^BPSTL(BP57,0)),U,10),0)),U) Q
.I BPSDIV'=$P($G(^BPS(9002313.56,+$P($G(^BPSTL(BP57,1)),U,7),0)),U) Q
.I BPREF'=+$P($G(^BPSTL(BP57,1)),U) Q
.I BPSCOB'=$P($G(^BPSTL(BP57,0)),U,14) Q
.I $G(^BPSTL(BP57,2))'["Rejected" Q
.S BPSRCNT=1
Q BPSRCNT
;
; Returns ECME number from 9002313.02 as:
; 7 or 12 digits of the prescription IEN file 52
; or 12 spaces
N BPST0,PC,PF,BPST4,PR,X
;
S BPST0=$G(^BPSTL(BP57,0)),PC=$P(BPST0,U,4),PF=$P(BPST0,U,9)
S BPST4=$G(^BPSTL(BP57,4)),PR=$P(BPST4,U,1)
I PR]"" S PC=PR ;This is a reversal
I PC=""!(PF="") Q $$FORMAT^BPSSCRU2("",12," ",1)
S X=$P($G(^BPSC(PC,400,PF,400)),U,2)
I X="" Q $$FORMAT^BPSSCRU2(X,12," ",1)
Q $E(X,3,14)
;
GETRXFCI(BPSDIV,BPRX,BPREF,BPSCOB) ; Get general RXFC info
; Returns: paid amount ^ total transactions ^ IEN of 57 ^ transaction
; type of last matching BP57 found
;
N BPRETVAL,BP57,BPSPAMT,BPSTOTTN,BPSEC,BPSTRTYP
;
S BPRETVAL="0^0^0^",(BP57,BPSPAMT,BPSTOTTN)=0,(BPSEC,BPSTRTYP)=""
F S BP57=$O(^BPSTL("AEC",BPRX,BP57)) Q:'BP57 D
.Q:BPSDIV'=$P($G(^BPS(9002313.56,+$P($G(^BPSTL(BP57,1)),U,7),0)),U)
.Q:BPREF'=+$P($G(^BPSTL(BP57,1)),U)
.Q:BPSCOB'=$P($G(^BPSTL(BP57,0)),U,14)
.Q:$P($G(^BPSTL(BP57,0)),U,15)="E"
.I '$F(".BB.ERES.ERWV.ERNB.EREV.P2.P2S.","."_$P($G(^BPSTL(BP57,12)),U,1)_".") Q
.Q:$P($G(^BPSTL(BP57,0)),U,8)=""
.S BPSEC=$P($G(^BPSTL(BP57,9)),U,4)
.Q:BPSEC=""
.I BPELIG=1,'$D(BPELIG(BPSEC)) Q
.S BPSPAMT=$$TOTAMNT^BPSSCRLG(+$P($G(^BPSTL(BP57,0)),U,5))
.S BPSTOTTN=BPSTOTTN+1
.S BPSTRTYP=$P($G(^BPSTL(BP57,0)),U,15)
.S BPRETVAL=BPSPAMT_"^"_BPSTOTTN_"^"_BP57_"^"_BPSTRTYP
Q BPRETVAL
;
SORT ; Sort report based on divison or user
N BPSRXFC,BPSDIV,BPSUSER,DATA,S1,S2,S3
;
S BPSRXFC=""
F S BPSRXFC=$O(@BPGLTMP@("DATA",BPSRXFC)) Q:BPSRXFC="" D
.S BPSDIV=""
.F S BPSDIV=$O(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)) Q:BPSDIV="" D
..S BPSUSER=""
..F S BPSUSER=$O(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)) Q:BPSUSER="" D
...S DATA=@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)
...S S1=$S(BPSSORD=1:$P(DATA,"^",10),1:$P(DATA,"^",9))
...S S2=$P(DATA,"^",11)
...S S3=BPSRXFC
...S @BPGLTMP@("SORT",S1,S2,S3)=DATA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOPR2 11570 printed Sep 23, 2025@19:27:36 Page 2
BPSOPR2 ;ALB/PHH - OPECC Productivity Report Compiler ;9/21/2015
+1 ;;1.0;E CLAIMS MGMT ENGINE;**20**;JUN 2004;Build 27
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
COMPILE ; Entry point for the compile to build the scratch global
+1 ; This may be a background task if the job is queued.
+2 ;
+3 DO FIND
+4 DO SORT
+5 DO BUILD
+6 ;
+7 ; print report
DO PRINT^BPSOPR3
+8 ; close the device
DO ^%ZISC
+9 ; kill scratch
KILL @BPGLTMP
+10 ; purge the task
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+11 QUIT
+12 ;
BUILD ; Build report
+1 NEW BPSSHDR,BPSIDX,S1,S2,BPSRXFC,DATA,BPSDIV,BPSTRDT,BPSUSER,BPSLINE
+2 ;
+3 DO SUBINIT(.BPSSHDR)
+4 ;
+5 SET BPSIDX=1
+6 ;
+7 ; Export the report to Excel
+8 IF BPEXCEL
Begin DoDot:1
+9 ; Data is as follows:
+10 ; DIVISION^USER^CURRENT STATUS^#TRANS IN DT RANGE^#TRANS TOTAL^ELIG^RX#^REF^ECME#^COB^DOS^TRANS DATE^PAID AMT
+11 ;
+12 SET S1=""
+13 FOR
SET S1=$ORDER(@BPGLTMP@("SORT",S1))
if S1=""
QUIT
Begin DoDot:2
+14 SET S2=0
+15 FOR
SET S2=$ORDER(@BPGLTMP@("SORT",S1,S2))
if 'S2
QUIT
Begin DoDot:3
+16 SET BPSRXFC=""
+17 FOR
SET BPSRXFC=$ORDER(@BPGLTMP@("SORT",S1,S2,BPSRXFC))
if BPSRXFC=""
QUIT
Begin DoDot:4
+18 SET DATA=@BPGLTMP@("SORT",S1,S2,BPSRXFC)
+19 SET BPSDIV=$PIECE(DATA,U,9)
SET BPSTRDT=$PIECE(DATA,U,11)
SET BPSUSER=$PIECE(DATA,U,10)
+20 SET BPSLINE=BPSDIV_"^"
+21 SET BPSLINE=BPSLINE_BPSUSER_"^"
+22 SET BPSLINE=BPSLINE_$PIECE(DATA,U)_"^"
+23 SET BPSLINE=BPSLINE_+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13)_"^"
+24 SET BPSLINE=BPSLINE_+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^")_"^"
+25 SET BPSLINE=BPSLINE_$SELECT($PIECE(DATA,U,2)="V":"VET",$PIECE(DATA,U,2)="T":"TRI",$PIECE(DATA,U,2)="C":"CVA",1:"")_"^"
+26 SET BPSLINE=BPSLINE_$PIECE(DATA,U,3)_"^"
+27 SET BPSLINE=BPSLINE_$PIECE(DATA,U,4)_"^"
+28 SET BPSLINE=BPSLINE_$PIECE(DATA,U,7)_"^"
+29 SET BPSLINE=BPSLINE_$SELECT($PIECE(DATA,U,8)=1:"P",$PIECE(DATA,U,8)=2:"S",$PIECE(DATA,U,8)=3:"T",1:"")_"^"
+30 SET BPSLINE=BPSLINE_$PIECE(DATA,U,5)_"^"
+31 SET BPSLINE=BPSLINE_$$DATTIM^BPSRPT1((BPSTRDT\1))_"^"
+32 IF $PIECE(DATA,U)'="NON-BILLABLE"
Begin DoDot:5
+33 SET BPSLINE=BPSLINE_$SELECT($PIECE(DATA,U,6)="":"0.00",1:$PIECE(DATA,U,6))
End DoDot:5
+34 SET @BPGLTMP@("REPORT",BPSIDX)=BPSLINE
SET BPSIDX=BPSIDX+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;
+36 IF 'BPEXCEL
Begin DoDot:1
+37 SET S1=""
+38 FOR
SET S1=$ORDER(@BPGLTMP@("SORT",S1))
if S1=""
QUIT
Begin DoDot:2
+39 SET BPSLINE=$SELECT(BPSSORD=1:"USER NAME: "_S1,1:"DIVISION: "_S1)
+40 SET @BPGLTMP@("REPORT",BPSIDX)=BPSLINE
SET BPSIDX=BPSIDX+1
+41 SET BPSLINE=""
+42 DO ADDCHAR^BPSOPR3(.BPSLINE,"-",129)
+43 SET @BPGLTMP@("REPORT",BPSIDX)=BPSLINE
SET BPSIDX=BPSIDX+1
+44 SET S2=0
+45 FOR
SET S2=$ORDER(@BPGLTMP@("SORT",S1,S2))
if 'S2
QUIT
Begin DoDot:3
+46 SET BPSRXFC=""
+47 FOR
SET BPSRXFC=$ORDER(@BPGLTMP@("SORT",S1,S2,BPSRXFC))
if BPSRXFC=""
QUIT
Begin DoDot:4
+48 SET DATA=@BPGLTMP@("SORT",S1,S2,BPSRXFC)
+49 SET BPSDIV=$PIECE(DATA,U,9)
SET BPSTRDT=$PIECE(DATA,U,11)
SET BPSUSER=$PIECE(DATA,U,10)
+50 ;
+51 ; Print details
+52 IF BPSUMDET=0
Begin DoDot:5
+53 SET BPSLINE=$EXTRACT(BPSUSER,1,15)
+54 DO ADDCHAR^BPSOPR3(.BPSLINE," ",17-$LENGTH(BPSLINE))
+55 SET BPSLINE=BPSLINE_$EXTRACT($PIECE(DATA,U),1,19)
+56 DO ADDCHAR^BPSOPR3(.BPSLINE," ",37-$LENGTH(BPSLINE))
+57 DO ADDCHAR^BPSOPR3(.BPSLINE," ",4-$LENGTH(+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13)))
+58 SET BPSLINE=BPSLINE_+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13)
+59 DO ADDCHAR^BPSOPR3(.BPSLINE," ",6-$LENGTH(+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^")))
+60 SET BPSLINE=BPSLINE_+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^")
+61 DO ADDCHAR^BPSOPR3(.BPSLINE," ",7)
+62 SET BPSLINE=BPSLINE_$SELECT($PIECE(DATA,U,2)="V":"VET",$PIECE(DATA,U,2)="T":"TRI",$PIECE(DATA,U,2)="C":"CVA",1:" ")
+63 DO ADDCHAR^BPSOPR3(.BPSLINE," ",2)
+64 SET BPSLINE=BPSLINE_$PIECE(DATA,U,3)
+65 DO ADDCHAR^BPSOPR3(.BPSLINE," ",71-$LENGTH(BPSLINE))
+66 SET BPSLINE=BPSLINE_$PIECE(DATA,U,4)_"/"
+67 SET BPSLINE=BPSLINE_$PIECE(DATA,U,7)_" "
+68 DO ADDCHAR^BPSOPR3(.BPSLINE," ",12-$LENGTH($PIECE(DATA,U,7)))
+69 SET BPSLINE=BPSLINE_$SELECT($PIECE(DATA,U,8)=1:"P",$PIECE(DATA,U,8)=2:"S",$PIECE(DATA,U,8)=3:"T",1:" ")
+70 DO ADDCHAR^BPSOPR3(.BPSLINE," ",3)
+71 SET BPSLINE=BPSLINE_$PIECE(DATA,U,5)_" "
+72 DO ADDCHAR^BPSOPR3(.BPSLINE," ",9-$LENGTH($PIECE(DATA,U,5)))
+73 SET BPSLINE=BPSLINE_$$DATTIM^BPSRPT1((BPSTRDT\1))_" "
+74 IF $PIECE(DATA,U)'="NON-BILLABLE"
Begin DoDot:6
+75 DO ADDCHAR^BPSOPR3(.BPSLINE," ",15-$LENGTH($SELECT($PIECE(DATA,U,6)="":"0.00",1:$PIECE(DATA,U,6))))
+76 SET BPSLINE=BPSLINE_$SELECT($PIECE(DATA,U,6)="":"0.00",1:$PIECE(DATA,U,6))
End DoDot:6
+77 SET @BPGLTMP@("REPORT",BPSIDX)=BPSLINE
SET BPSIDX=BPSIDX+1
End DoDot:5
End DoDot:4
End DoDot:3
+78 ;
+79 ; Print subtotals
+80 DO PRTSGHDR(.BPSSHDR,.BPSIDX,S1)
+81 IF BPSSORD=0
DO PRTSGTOT(.BPSIDX,S1)
+82 IF BPSSORD=1
DO PRTSGTOT(.BPSIDX,"",S1)
+83 SET DATA=""
+84 DO ADDCHAR^BPSOPR3(.DATA," ",129)
+85 SET @BPGLTMP@("REPORT",BPSIDX)=DATA
SET BPSIDX=BPSIDX+1
+86 SET DATA=""
+87 DO ADDCHAR^BPSOPR3(.DATA," ",129)
+88 SET @BPGLTMP@("REPORT",BPSIDX)=DATA
SET BPSIDX=BPSIDX+1
+89 SET DATA=""
+90 DO ADDCHAR^BPSOPR3(.DATA,"-",129)
+91 SET @BPGLTMP@("REPORT",BPSIDX)=DATA
SET BPSIDX=BPSIDX+1
End DoDot:2
+92 ;
+93 IF '$DATA(@BPGLTMP@("REPORT"))!(BPSIDX=1)
QUIT
+94 SET DATA=""
+95 DO ADDCHAR^BPSOPR3(.DATA,"-",129)
+96 IF @BPGLTMP@("REPORT",BPSIDX-1)=DATA
Begin DoDot:2
+97 KILL @BPGLTMP@("REPORT",BPSIDX-1)
SET BPSIDX=BPSIDX-1
+98 KILL @BPGLTMP@("REPORT",BPSIDX-1)
SET BPSIDX=BPSIDX-1
+99 KILL @BPGLTMP@("REPORT",BPSIDX-1)
SET BPSIDX=BPSIDX-1
End DoDot:2
+100 ;
+101 ; Print summary
+102 DO PRTSGHDR(.BPSSHDR,.BPSIDX)
+103 DO PRTSGTOT(.BPSIDX)
End DoDot:1
+104 ;
+105 IF '$DATA(@BPGLTMP@("REPORT"))!(BPSIDX=1)
Begin DoDot:1
+106 SET @BPGLTMP@("REPORT",BPSIDX)="No data available for date range."
End DoDot:1
+107 QUIT
+108 ;
PRTSGTOT(BPSIDX,BPSDIV,BPSUSER) ; Print grand/subtotals
+1 NEW X,BPSUSRNM,BPSDIV1
+2 ;
+3 if BPSIDX=""
QUIT
+4 SET BPSDIV=$GET(BPSDIV,"")
+5 SET BPSUSER=$GET(BPSUSER,"")
+6 ;
+7 IF BPSUSER=""
IF BPUSER=1
Begin DoDot:1
+8 SET X=0
+9 FOR
SET X=$ORDER(BPUSER(X))
if 'X
QUIT
SET BPSUSRNM($PIECE(BPUSER(X),U,2))=""
+10 ;
+11 SET BPSUSER=""
+12 FOR
SET BPSUSER=$ORDER(BPSUSRNM(BPSUSER))
if BPSUSER=""
QUIT
Begin DoDot:2
+13 DO PRTUTOT(.BPSIDX,BPSDIV,BPSUSER)
End DoDot:2
End DoDot:1
+14 ;
+15 IF BPSUSER=""
IF BPUSER=0
Begin DoDot:1
+16 SET BPSDIV1=""
+17 FOR
SET BPSDIV1=$ORDER(@BPGLTMP@("USRTOT",BPSDIV1))
if BPSDIV1=""
QUIT
Begin DoDot:2
+18 SET BPSUSER=""
+19 FOR
SET BPSUSER=$ORDER(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER))
if BPSUSER=""
QUIT
Begin DoDot:3
+20 SET BPSUSRNM(BPSUSER)=""
End DoDot:3
End DoDot:2
+21 ;
+22 SET BPSUSER=""
+23 FOR
SET BPSUSER=$ORDER(BPSUSRNM(BPSUSER))
if BPSUSER=""
QUIT
Begin DoDot:2
+24 DO PRTUTOT(.BPSIDX,BPSDIV,BPSUSER)
End DoDot:2
End DoDot:1
+25 ;
+26 IF BPSUSER'=""
Begin DoDot:1
+27 DO PRTUTOT(.BPSIDX,BPSDIV,BPSUSER)
End DoDot:1
+28 QUIT
+29 ;
PRTUTOT(BPSIDX,BPSDIV,BPSUSER) ; Print user totals
+1 NEW BPSPYNR,BPSPYREJ,BPSTAMT,BPSTTRN,BPSDIV1,BPSLINE
+2 ;
+3 if BPSIDX=""
QUIT
+4 SET BPSDIV=$GET(BPSDIV,"")
+5 if BPSUSER=""
QUIT
+6 ;
+7 SET (BPSPYNR,BPSPYREJ,BPSTAMT,BPSTTRN)=0
+8 IF BPSDIV'=""
Begin DoDot:1
+9 SET BPSPYNR=+$PIECE($GET(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^",2)
+10 SET BPSPYREJ=+$PIECE($GET(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^",3)
+11 SET BPSTAMT=+$PIECE($GET(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^")
End DoDot:1
+12 IF BPSDIV=""
Begin DoDot:1
+13 SET BPSDIV1=""
+14 FOR
SET BPSDIV1=$ORDER(@BPGLTMP@("USRTOT",BPSDIV1))
if BPSDIV1=""
QUIT
Begin DoDot:2
+15 if '$DATA(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER))
QUIT
+16 SET BPSPYNR=BPSPYNR+$PIECE($GET(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER)),"^",2)
+17 SET BPSPYREJ=BPSPYREJ+$PIECE($GET(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER)),"^",3)
+18 SET BPSTAMT=BPSTAMT+(+$PIECE($GET(@BPGLTMP@("USRTOT",BPSDIV1,BPSUSER)),"^"))
End DoDot:2
End DoDot:1
+19 SET BPSTTRN=$$TOTTRN(BPSDIV,BPSUSER)
+20 ;
+21 SET BPSLINE=$EXTRACT(BPSUSER,1,15)
+22 DO ADDCHAR^BPSOPR3(.BPSLINE," ",17-$LENGTH(BPSLINE))
+23 SET BPSLINE=BPSLINE_BPSPYREJ
+24 DO ADDCHAR^BPSOPR3(.BPSLINE," ",41-$LENGTH(BPSLINE))
+25 SET BPSLINE=BPSLINE_BPSPYNR
+26 DO ADDCHAR^BPSOPR3(.BPSLINE," ",69-$LENGTH(BPSLINE))
+27 DO ADDCHAR^BPSOPR3(.BPSLINE," ",5-$LENGTH(BPSTTRN))
+28 SET BPSLINE=BPSLINE_BPSTTRN
+29 DO ADDCHAR^BPSOPR3(.BPSLINE," ",89-$LENGTH(BPSLINE))
+30 SET BPSTAMT=$JUSTIFY(BPSTAMT,7,2)
+31 DO ADDCHAR^BPSOPR3(.BPSLINE," ",15-$LENGTH(BPSTAMT))
+32 SET BPSLINE=BPSLINE_BPSTAMT
+33 ;
+34 IF BPSDIV'=""
IF '$DATA(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER))
QUIT
+35 SET @BPGLTMP@("REPORT",BPSIDX)=BPSLINE
SET BPSIDX=BPSIDX+1
+36 QUIT
+37 ;
TOTTRN(BPSDIV,BPSUSER) ; Get total transactions for a user
+1 NEW BPSCNT,BPSTRDT,BPSRXFC,BPSDIV1
+2 ;
+3 SET BPSDIV=$GET(BPSDIV,"")
+4 if BPSUSER=""
QUIT
+5 ;
+6 SET BPSCNT=0
+7 IF BPSDIV'=""
Begin DoDot:1
+8 SET BPSRXFC=""
+9 FOR
SET BPSRXFC=$ORDER(@BPGLTMP@("DATA",BPSRXFC))
if BPSRXFC=""
QUIT
Begin DoDot:2
+10 SET BPSCNT=BPSCNT+(+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13))
End DoDot:2
End DoDot:1
+11 IF BPSDIV=""
Begin DoDot:1
+12 SET BPSRXFC=""
+13 FOR
SET BPSRXFC=$ORDER(@BPGLTMP@("DATA",BPSRXFC))
if BPSRXFC=""
QUIT
Begin DoDot:2
+14 SET BPSDIV1=""
+15 FOR
SET BPSDIV1=$ORDER(@BPGLTMP@("DATA",BPSRXFC,BPSDIV1))
if BPSDIV1=""
QUIT
Begin DoDot:3
+16 if '$DATA(@BPGLTMP@("DATA",BPSRXFC,BPSDIV1,BPSUSER))
QUIT
+17 SET BPSCNT=BPSCNT+(+$PIECE($GET(@BPGLTMP@("DATA",BPSRXFC,BPSDIV1,BPSUSER)),"^",13))
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT BPSCNT
+19 ;
PRTSGHDR(BPSSHDR,BPSIDX,BPSSGHTX) ; Print subtotals/grand header
+1 NEW BPSLINE,BPSCNT
+2 ;
+3 SET BPSSGHTX=$GET(BPSSGHTX,"")
+4 SET BPSSHDR(2)=$SELECT(BPSSGHTX="":"GRAND TOTAL",1:"SUBTOTALS FOR "_BPSSGHTX)
+5 ;
+6 FOR BPSCNT=1:1:4
Begin DoDot:1
+7 SET BPSLINE=BPSSHDR(BPSCNT)
+8 SET @BPGLTMP@("REPORT",BPSIDX)=BPSLINE
SET BPSIDX=BPSIDX+1
End DoDot:1
+9 QUIT
+10 ;
SUBINIT(BPSSHDR) ; Set up subtotals header
+1 SET BPSSHDR(1)=""
+2 SET BPSSHDR(3)=" REJECTED AND NOT REJECTED AND PAYABLE"
+3 SET BPSSHDR(4)="USER RESOLVED TO PAYABLE (POSSIBLE BACK-BILL) TRANS IN DT RANGE AMOUNT PAID"
+4 QUIT
+5 ;
FIND ; Find records
+1 NEW BPLDT57,BP57
+2 KILL @BPGLTMP
+3 ;
+4 IF 'BPEXCEL
IF '$DATA(ZTQUEUED)
USE 0
WRITE !!,"Compiling OPECC Productivity Report. Please wait ... ",!
USE IO
+5 ;
+6 ; Check Variables
+7 if '$GET(BPBEGDT)
SET BPBEGDT=0
+8 if '$GET(BPENDDT)
SET BPENDDT=9999999
+9 SET BPENDDT=BPENDDT+0.9
+10 ;
+11 ; Loop through BPS LOG OF TRANSACTIONS file #9002313.57
+12 SET BPLDT57=BPBEGDT-0.00001
+13 FOR
SET BPLDT57=+$ORDER(^BPSTL("AH",BPLDT57))
if BPLDT57=0!(BPLDT57>BPENDDT)
QUIT
Begin DoDot:1
+14 SET BP57=0
+15 FOR
SET BP57=$ORDER(^BPSTL("AH",BPLDT57,BP57))
if 'BP57
QUIT
DO PROCESS^BPSOPR3(BP57)
End DoDot:1
+16 QUIT
+17 ;
CALCREJ(BPSDIV,BPSUSER,BPRX,BPREF,BPSCOB) ; Calculate reject counts
+1 ; Returns 1 if reject found, otherwise returns 0
+2 NEW BP57,BPSRCNT
+3 ;
+4 SET (BP57,BPSRCNT)=0
+5 FOR
SET BP57=$ORDER(^BPSTL("AEC",BPRX,BP57))
if 'BP57!(BPSRCNT)
QUIT
Begin DoDot:1
+6 IF BPSUSER'=$PIECE($GET(^VA(200,+$PIECE($GET(^BPSTL(BP57,0)),U,10),0)),U)
QUIT
+7 IF BPSDIV'=$PIECE($GET(^BPS(9002313.56,+$PIECE($GET(^BPSTL(BP57,1)),U,7),0)),U)
QUIT
+8 IF BPREF'=+$PIECE($GET(^BPSTL(BP57,1)),U)
QUIT
+9 IF BPSCOB'=$PIECE($GET(^BPSTL(BP57,0)),U,14)
QUIT
+10 IF $GET(^BPSTL(BP57,2))'["Rejected"
QUIT
+11 SET BPSRCNT=1
End DoDot:1
+12 QUIT BPSRCNT
+13 ;
+1 ; Returns ECME number from 9002313.02 as:
+2 ; 7 or 12 digits of the prescription IEN file 52
+3 ; or 12 spaces
+4 NEW BPST0,PC,PF,BPST4,PR,X
+5 ;
+6 SET BPST0=$GET(^BPSTL(BP57,0))
SET PC=$PIECE(BPST0,U,4)
SET PF=$PIECE(BPST0,U,9)
+7 SET BPST4=$GET(^BPSTL(BP57,4))
SET PR=$PIECE(BPST4,U,1)
+8 ;This is a reversal
IF PR]""
SET PC=PR
+9 IF PC=""!(PF="")
QUIT $$FORMAT^BPSSCRU2("",12," ",1)
+10 SET X=$PIECE($GET(^BPSC(PC,400,PF,400)),U,2)
+11 IF X=""
QUIT $$FORMAT^BPSSCRU2(X,12," ",1)
+12 QUIT $EXTRACT(X,3,14)
+13 ;
GETRXFCI(BPSDIV,BPRX,BPREF,BPSCOB) ; Get general RXFC info
+1 ; Returns: paid amount ^ total transactions ^ IEN of 57 ^ transaction
+2 ; type of last matching BP57 found
+3 ;
+4 NEW BPRETVAL,BP57,BPSPAMT,BPSTOTTN,BPSEC,BPSTRTYP
+5 ;
+6 SET BPRETVAL="0^0^0^"
SET (BP57,BPSPAMT,BPSTOTTN)=0
SET (BPSEC,BPSTRTYP)=""
+7 FOR
SET BP57=$ORDER(^BPSTL("AEC",BPRX,BP57))
if 'BP57
QUIT
Begin DoDot:1
+8 if BPSDIV'=$PIECE($GET(^BPS(9002313.56,+$PIECE($GET(^BPSTL(BP57,1)),U,7),0)),U)
QUIT
+9 if BPREF'=+$PIECE($GET(^BPSTL(BP57,1)),U)
QUIT
+10 if BPSCOB'=$PIECE($GET(^BPSTL(BP57,0)),U,14)
QUIT
+11 if $PIECE($GET(^BPSTL(BP57,0)),U,15)="E"
QUIT
+12 IF '$FIND(".BB.ERES.ERWV.ERNB.EREV.P2.P2S.","."_$PIECE($GET(^BPSTL(BP57,12)),U,1)_".")
QUIT
+13 if $PIECE($GET(^BPSTL(BP57,0)),U,8)=""
QUIT
+14 SET BPSEC=$PIECE($GET(^BPSTL(BP57,9)),U,4)
+15 if BPSEC=""
QUIT
+16 IF BPELIG=1
IF '$DATA(BPELIG(BPSEC))
QUIT
+17 SET BPSPAMT=$$TOTAMNT^BPSSCRLG(+$PIECE($GET(^BPSTL(BP57,0)),U,5))
+18 SET BPSTOTTN=BPSTOTTN+1
+19 SET BPSTRTYP=$PIECE($GET(^BPSTL(BP57,0)),U,15)
+20 SET BPRETVAL=BPSPAMT_"^"_BPSTOTTN_"^"_BP57_"^"_BPSTRTYP
End DoDot:1
+21 QUIT BPRETVAL
+22 ;
SORT ; Sort report based on divison or user
+1 NEW BPSRXFC,BPSDIV,BPSUSER,DATA,S1,S2,S3
+2 ;
+3 SET BPSRXFC=""
+4 FOR
SET BPSRXFC=$ORDER(@BPGLTMP@("DATA",BPSRXFC))
if BPSRXFC=""
QUIT
Begin DoDot:1
+5 SET BPSDIV=""
+6 FOR
SET BPSDIV=$ORDER(@BPGLTMP@("DATA",BPSRXFC,BPSDIV))
if BPSDIV=""
QUIT
Begin DoDot:2
+7 SET BPSUSER=""
+8 FOR
SET BPSUSER=$ORDER(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER))
if BPSUSER=""
QUIT
Begin DoDot:3
+9 SET DATA=@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)
+10 SET S1=$SELECT(BPSSORD=1:$PIECE(DATA,"^",10),1:$PIECE(DATA,"^",9))
+11 SET S2=$PIECE(DATA,"^",11)
+12 SET S3=BPSRXFC
+13 SET @BPGLTMP@("SORT",S1,S2,S3)=DATA
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
