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

BPSOPR3.m

Go to the documentation of this file. 
  1. BPSOPR3 ;ALB/PHH - OPECC Productivity Report Print ;9/21/2015
  1.  ;;1.0;E CLAIMS MGMT ENGINE;**20**;JUN 2004;Build 27
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  Q
  1.  ;
  1. PRINT ; Entry point for printing the report
  1.  N BPSPG,BPSHDR,BPSIDX,BPSQUIT,DIR,DIRUT,DUOUT,DTOUT
  1.  ;
  1.  S BPSPG=1
  1.  ;
  1.  I 'BPEXCEL D
  1.  .D HDRINIT(.BPSHDR)
  1.  .D HDR(.BPSHDR,BPSPG)
  1.  ;
  1.  ; User chose to export the report to Excel
  1.  I BPEXCEL D
  1.  .W !,"DIVISION^USER^CURRENT STATUS^#TRANS IN DT RANGE^#TRANS TOTAL^ELIG^RX#^REF^ECME#^COB^DOS^TRANS DATE^PAID AMT"
  1.  ;
  1.  S (BPSIDX,BPSQUIT)=0
  1.  F  S BPSIDX=$O(@BPGLTMP@("REPORT",BPSIDX)) Q:'BPSIDX!(BPSQUIT)  D
  1.  .W !,@BPGLTMP@("REPORT",BPSIDX)
  1.  .Q:BPEXCEL
  1.  .I $Y>(IOSL-3) D
  1.  ..I $E(IOST,1,2)="C-" D
  1.  ...W !
  1.  ...S DIR(0)="E"
  1.  ...D ^DIR
  1.  ...K DIR
  1.  ...I $D(DIRUT)!($D(DUOUT)) S BPSQUIT=1 K DIRUT,DTOUT,DUOUT
  1.  ..Q:BPSQUIT
  1.  ..S BPSPG=BPSPG+1
  1.  ..D HDR(.BPSHDR,BPSPG)
  1.  ;
  1.  I 'BPEXCEL W !!?5,"*** End of Report ***"
  1.  W !
  1.  I '$D(ZTQUEUED) U 0 S DIR(0)="E" D ^DIR K DIR U IO
  1.  Q
  1.  ;
  1. HDR(BPSHDR,BPSPG) ; Print header
  1.  N BPSOHDR1,BPSTMP,X
  1.  ;
  1.  S (BPSOHDR1,BPSTMP)=BPSHDR(1)
  1.  D ADDCHAR(.BPSTMP," ",3-$L(BPSPG))
  1.  S BPSTMP=BPSTMP_BPSPG
  1.  S BPSHDR(1)=BPSTMP
  1.  ;
  1.  W @IOF
  1.  F X=1:1:9 W !,BPSHDR(X)
  1.  ;
  1.  S BPSHDR(1)=BPSOHDR1
  1.  Q
  1.  ;
  1. HDRINIT(BPSHDR) ; Setup header
  1.  N BPSRPTNM,BPSDTTM,HDR1,HDR2,X,BPSDIVNM,HDR3,HDR4,BPSUSRNM,HDR6,HDR7
  1.  ;
  1.  S BPSRPTNM="OPECC PRODUCTIVITY "_$S(BPSUMDET=1:"SUMMARY ",1:"DETAIL ")_"REPORT"
  1.  S BPSDTTM=$$HTE^XLFDT($H)
  1.  S HDR1=BPSRPTNM
  1.  D ADDCHAR(.HDR1," ",$S(BPSUMDET=1:53,1:54))
  1.  S HDR1=HDR1_"Print Date: "_BPSDTTM
  1.  D ADDCHAR(.HDR1," ",121-$L(HDR1))
  1.  S HDR1=HDR1_"Page:"
  1.  S BPSHDR(1)=HDR1
  1.  ;
  1.  S HDR2="DIVISION(S): "
  1.  I BPPHARM=0 S HDR2=HDR2_"ALL"
  1.  I BPPHARM=1 D
  1.  .S X=0
  1.  .F  S X=$O(BPPHARM(X)) Q:'X  S BPSDIVNM($P(BPPHARM(X),U,2))=""
  1.  .S X=""
  1.  .F  S X=$O(BPSDIVNM(X)) Q:X=""  D
  1.  ..S HDR2=HDR2_X_", "
  1.  .S HDR2=$E(HDR2,1,$L(HDR2)-2)
  1.  S BPSHDR(2)=$E(HDR2,1,129)
  1.  ;
  1.  S HDR3="ELIGIBILITY: "
  1.  I BPELIG=0 S HDR3=HDR3_"ALL"
  1.  I BPELIG=1 D
  1.  .S X=""
  1.  .F  S X=$O(BPELIG(X)) Q:X=""  D
  1.  ..S HDR3=HDR3_$S(X="V":"VETERAN",X="T":"TRICARE",X="C":"CHAMPVA",1:"")_", "
  1.  .S HDR3=$E(HDR3,1,$L(HDR3)-2)
  1.  S BPSHDR(3)=HDR3
  1.  ;
  1.  S HDR4="USERS: "
  1.  I BPUSER=0 S HDR4=HDR4_"ALL"
  1.  I BPUSER=1 D
  1.  .S X=0
  1.  .F  S X=$O(BPUSER(X)) Q:'X  S BPSUSRNM($P(BPUSER(X),U,2))=""
  1.  .S X=""
  1.  .F  S X=$O(BPSUSRNM(X)) Q:X=""  D
  1.  ..S HDR4=HDR4_X_", "
  1.  .S HDR4=$E(HDR4,1,$L(HDR4)-2)
  1.  S BPSHDR(4)=$E(HDR4,1,129)
  1.  ;
  1.  S BPSHDR(5)="ALL PRESCRIPTIONS BY TRANSACTION DATE: From "_$$FMTE^XLFDT(BPBEGDT,2)_" through "_$$FMTE^XLFDT(BPENDDT\1,2)
  1.  ;
  1.  S HDR6=""
  1.  D ADDCHAR(.HDR6,"=",129)
  1.  S BPSHDR(6)=HDR6
  1.  ;
  1.  S HDR7=""
  1.  D ADDCHAR(.HDR7," ",17)
  1.  S HDR7=HDR7_"CURRENT           # TRANSACTIONS"
  1.  S BPSHDR(7)=HDR7
  1.  ;
  1.  S BPSHDR(8)="USER             STATUS            DT RANGE  TOTAL    ELIG RX#         REF/ECME#       COB    DOS      TRANS DATE       PAID AMT"
  1.  ;
  1.  S BPSHDR(9)=HDR6
  1.  Q
  1.  ;
  1. ADDCHAR(BPSTXSTR,BPSCHAR,BPSCNT) ; Add characters to string
  1.  N X
  1.  Q:BPSCNT<1
  1.  F X=1:1:BPSCNT S BPSTXSTR=BPSTXSTR_BPSCHAR
  1.  Q
  1.  ;
  1. PROCESS(BP57) ; Process each Entry
  1.  N BPSCOB,BPRX,BPREF,BPSRXFC,BPSTRTYP,BPSDIV,BPSTATUS,BPSECME,BPSDOS
  1.  N BPSTRDT,BPSEC,BPSUSER,BPSPAMT,BPSRXFCI,BPSPRVST,BPSPRVAM,BPSPRVUT,BPSRJFND
  1.  ;
  1.  ; Get COB
  1.  S BPSCOB=$S($P($G(^BPSTL(BP57,0)),U,14):$P(^BPSTL(BP57,0),U,14),1:$E($P($P($G(^BPSTL(BP57,0)),U),".",2),5,5))
  1.  ;
  1.  ; Get RX#
  1.  S BPRX=+$P($G(^BPSTL(BP57,1)),U,11)
  1.  ;
  1.  ; Get REF - FILL NUMBER field #9 in 9002313.57
  1.  S BPREF=+$P($G(^BPSTL(BP57,1)),U)
  1.  ;
  1.  ; Unique ID for RX#-Fill#-COB to separate display line/counters
  1.  S BPSRXFC=BPRX_"-"_BPREF_"-"_BPSCOB
  1.  ;
  1.  ; Get Transaction Type
  1.  S BPSTRTYP=$P($G(^BPSTL(BP57,0)),U,15)
  1.  ; Skip eligibility verification transactions
  1.  I BPSTRTYP="E" Q
  1.  ;
  1.  ; Limit report to the following RX ACTION field #1201 values
  1.  I '$F(".BB.ERES.ERWV.ERNB.EREV.P2.P2S.","."_$P($G(^BPSTL(BP57,12)),U,1)_".") Q
  1.  ;
  1.  ; Check for correct BPS Pharmacy (DIVISION)
  1.  S BPSDIV=+$P($G(^BPSTL(BP57,1)),U,7)
  1.  I BPPHARM=1,'$D(BPPHARM(BPSDIV)) Q
  1.  S BPSDIV=$$GET1^DIQ(9002313.56,BPSDIV,.01)
  1.  I BPSDIV="" Q
  1.  ;
  1.  ; Get Status
  1.  S BPSTATUS=$P($P($$STATUS^BPSOSRX(BPRX,BPREF,0,,BPSCOB),U),"E ",2)
  1.  ;
  1.  ; Get ECME
  1.  S BPSECME=$$ECMENUM^BPSOPR2(BP57)
  1.  ;
  1.  ; Get Date of Service
  1.  S BPSDOS=$$DATTIM^BPSRPT1(+$P($G(^BPSTL(BP57,12)),U,2))
  1.  ;
  1.  ; Get Trans Date
  1.  S BPSTRDT=$P($G(^BPSTL(BP57,0)),U,8)
  1.  I BPSTRDT="" Q
  1.  ;
  1.  ; Check for Eligibility Code
  1.  S BPSEC=$P($G(^BPSTL(BP57,9)),U,4)
  1.  I BPSEC="" Q
  1.  I BPELIG=1,'$D(BPELIG(BPSEC)) Q
  1.  ;
  1.  ; Update general RXFC info
  1.  S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^")=+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^")+1
  1.  I BPSTATUS'="" S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^",3)=BPSTATUS
  1.  ;
  1.  ; Get User
  1.  S BPSUSER=+$P($G(^BPSTL(BP57,0)),U,10)
  1.  I BPUSER=1,'$D(BPUSER(BPSUSER)),'$D(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)) Q
  1.  S BPSUSER=$$GET1^DIQ(200,BPSUSER,.01)
  1.  I BPSUSER="" Q
  1.  ;
  1.  ; Get Paid Amount
  1.  S BPSPAMT=$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^",4),BPSRXFCI=""
  1.  I BPSPAMT="" D
  1.  .S BPSRXFCI=$$GETRXFCI^BPSOPR2(BPSDIV,BPRX,BPREF,BPSCOB)
  1.  .S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^",2)=$P(BPSRXFCI,"^",3)
  1.  .S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^",4)=$S($P(BPSRXFCI,"^")="":0,1:$P(BPSRXFCI,"^"))
  1.  .S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^",6)=$P(BPSRXFCI,"^",2)
  1.  .I $P(BPSRXFCI,"^",4)="N",$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^",3)="" S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^",3)="NON-BILLABLE"
  1.  .S BPSPAMT=$P(BPSRXFCI,"^")
  1.  I BPSPAMT=0 S BPSPAMT=""
  1.  ;
  1.  ; Set variables for Non-Billable entries
  1.  I BPSTATUS="",$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV)),"^",3)="NON-BILLABLE" S BPSTRTYP="N"
  1.  I BPSTRTYP="N" S (BPSECME,BPSDOS,BPSPAMT)="",BPSTATUS="NON-BILLABLE"
  1.  ;
  1.  ; Update RXFC info for specific division/user
  1.  I BPUSER=0!(BPUSER=1&($D(BPUSER(+$P($G(^BPSTL(BP57,0)),U,10))))) D
  1.  .S BPSPRVST=$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^")
  1.  .S BPSPRVAM=+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",6)
  1.  .S BPSPRVUT=+$P($G(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)),"^",13)+1
  1.  .S @BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER)=BPSTATUS_"^"_BPSEC_"^"_$$GET1^DIQ(52,BPRX,.01)_"^"_BPREF_"^"_BPSDOS_"^"_BPSPAMT_"^"_BPSECME_"^"_BPSCOB_"^"_BPSDIV_"^"_BPSUSER_"^"_BPSTRDT_"^"_BP57
  1.  .S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV,BPSUSER),"^",13)=BPSPRVUT
  1.  .S $P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",4)=+$P($G(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^",4)+1
  1.  .S $P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^")=+$P($G(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER)),"^")-(+BPSPRVAM)+(+BPSPAMT)
  1.  .;
  1.  .; Update count totals for Rejects found
  1.  .I BPSTATUS["PAYABLE"!(BPSTATUS["NON-BILLABLE") D
  1.  ..S BPSRJFND=$P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^",5)
  1.  ..I BPSRJFND="" D
  1.  ...S BPSRJFND=$$CALCREJ^BPSOPR2(BPSDIV,BPSUSER,BPRX,BPREF,BPSCOB)
  1.  ...S $P(@BPGLTMP@("DATA",BPSRXFC,BPSDIV),"^",5)=BPSRJFND
  1.  ..I BPSTATUS["PAYABLE" D
  1.  ...Q:BPSPRVST["PAYABLE"
  1.  ...I BPSRJFND D  Q
  1.  ....S $P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",3)=+($P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",3))+1
  1.  ...S $P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",2)=+($P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",2))+1
  1.  ..I BPSTATUS["NON-BILLABLE",BPSPRVST["PAYABLE" D
  1.  ...I BPSRJFND D  Q
  1.  ....S $P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",3)=+($P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",3))-1
  1.  ...S $P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",2)=+($P(@BPGLTMP@("USRTOT",BPSDIV,BPSUSER),"^",2))-1
  1.  Q
  1.  ;