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

IBNCPRR.m

Go to the documentation of this file. 
  1. IBNCPRR ;DALOI/AAT - Prescription Report for 3rd Party Billing cross check ;07/21/04
  1.  ;;2.0;INTEGRATED BILLING;**276,347**;21-MAR-94;Build 24
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. EN ;
  1.  N IBQ,IBSITE,IBWMC,IBENB,IBBDT,IBEDT,IBINS,IBSDE,IBSCR
  1.  S IBQ=0 ; quit flag
  1.  ; Prompts to the user:
  1.  D DIV Q:IBQ  ; Division
  1.  D WMC Q:IBQ  ; W/M/C criteria
  1.  D ENB Q:IBQ  ; ECME/NON-ECME/BOTH criteria
  1.  D DATE Q:IBQ  ; From-To date range
  1.  D INS Q:IBQ  ; Insurance company
  1.  D SDE Q:IBQ  ; Summary/Detailed/Excel criteria
  1.  D DEVICE Q:IBQ
  1.  D RUN
  1.  I IBQ'=2 D PAUSE2
  1.  Q
  1.  ;
  1. DIV N DIC,DIRUT
  1.  W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEQM" D DIC^PSODI(59,.DIC,) S IBSITE=+Y K Y
  1.  I $D(DIRUT) S IBQ=1 Q
  1.  I IBSITE'>0 S IBQ=1 Q
  1.  I $G(PSODIY) K PSODIY
  1.  Q
  1.  ;
  1. WMC N DIR,DIRUT,Y
  1.  W ! S DIR("B")="CMOP",DIR("A")="(W)INDOW/(M)AIL/(C)MOP: "
  1.  S DIR(0)="SA^W:WINDOW;M:MAIL;C:CMOP" D ^DIR
  1.  I $D(DIRUT) S IBQ=1 Q
  1.  S IBWMC=Y
  1.  Q
  1.  ;
  1. ENB N DIR,DIRUT,Y
  1.  W ! S DIR("B")="ECME BILLABLE",DIR("A")="(E)CME Billable/(N)on-ECME Billable/(B)OTH: "
  1.  S DIR(0)="SA^E:ECME BILLABLE;N:NON-ECME BILLABLE;B:BOTH" D ^DIR
  1.  I $D(DIRUT) S IBQ=1 Q
  1.  S IBENB=Y
  1.  Q
  1.  ;
  1. DATE ;
  1.  N %DT,Y
  1.  S (IBBDT,IBEDT)=DT
  1.  S %DT="AEX"
  1.  S %DT("A")="FROM RELEASE DATE: ",%DT("B")="TODAY"
  1.  W ! D ^%DT K %DT
  1.  I Y<0 S IBQ=1 Q
  1.  S IBBDT=+Y
  1.  S %DT="AEX"
  1.  S %DT("A")="TO RELEASE DATE: ",%DT("B")="TODAY" ;$$DAT2^IBOUTL(IBBDT)
  1.  D ^%DT K %DT
  1.  I Y<0 S IBQ=1 Q
  1.  S IBEDT=+Y
  1.  Q
  1.  ;
  1. INS N DIR,DIC,DIRUT,Y
  1.  W ! S DIR("B")="ALL",DIR("A")="(S)INGLE Insurance Company /(A)LL Insurance Companies: "
  1.  S DIR(0)="SA^S:SINGLE INSURANCE COMPANY;A:ALL" D ^DIR
  1.  I $D(DIRUT) S IBQ=1 Q
  1.  I Y="A" S IBINS=0 Q
  1.  ;
  1.  S DIC(0)="AEQM",DIC=36
  1.  W ! D ^DIC
  1.  I $D(DIRUT) S IBQ=1 Q
  1.  I Y'>0 S IBQ=1 Q
  1.  S IBINS=+Y
  1.  Q
  1.  ;
  1. SDE N DIR,DIRUT
  1.  S DIR("B")="SUMMARY",DIR("A")="(S)UMMARY/(D)ETAILED/(E)XCEL: "
  1.  S DIR(0)="SA^S:SUMMARY;D:DETAILED;E:EXCEL"
  1.  W ! D ^DIR
  1.  I $D(DIRUT) S IBQ=1 Q
  1.  S IBSDE=Y
  1.  Q
  1.  ;
  1. DEVICE ;
  1.  N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,POP,ZTSAVE
  1.  S %ZIS="QM"
  1.  W ! D ^%ZIS
  1.  I POP S IBQ=1 Q
  1.  S IBSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
  1.  ;
  1.  I $D(IO("Q")) D  S IBQ=1
  1.  . S ZTRTN="RUN^IBNCPRR"
  1.  . S ZTIO=ION
  1.  . S ZTSAVE("IB*")=""
  1.  . S ZTDESC="IB ECME CMOP REPORT"
  1.  . D ^%ZTLOAD
  1.  . W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
  1.  . D HOME^%ZIS
  1.  U IO
  1.  Q
  1.  ;
  1. RUN ;
  1.  N IBPAGE,REF
  1.  S REF=$NA(^TMP($J,"IBNCPRR"))
  1.  K @REF
  1.  S IBPAGE=0
  1.  D COLLECT  ; Collect the data in ^TMP
  1.  U IO
  1.  D REPORT
  1.  I 'IBSCR W !,@IOF
  1.  D ^%ZISC
  1.  K @REF
  1.  Q
  1.  ;
  1. REPORT ;
  1.  N IBDT,IBRX,IBFL,IBPN,DFN,IBD
  1.  D HDR
  1.  I '$D(@REF) W !,"No data meet the criteria."
  1.  S IBDT="" F  S IBDT=$O(@REF@(IBDT)) Q:IBDT=""  D  Q:IBQ
  1.  . S IBPN="" F  S IBPN=$O(@REF@(IBDT,IBPN)) Q:IBPN=""  D  Q:IBQ
  1.  .. S IBRX="" F  S IBRX=$O(@REF@(IBDT,IBPN,IBRX)) Q:IBRX=""  D  Q:IBQ
  1.  ... S IBFL="" F  S IBFL=$O(@REF@(IBDT,IBPN,IBRX,IBFL)) Q:IBFL=""  D  Q:IBQ
  1.  .... S IBD=$G(@REF@(IBDT,IBPN,IBRX,IBFL)) Q:IBD=""
  1.  .... I IBSDE="S" D WRLINE Q
  1.  .... I IBSDE="D" D WRLINE2 Q
  1.  .... I IBSDE="E" D WRLINE3 Q
  1.  ;
  1.  Q
  1.  ;
  1. WRLINE ; Write the summary report line
  1.  D CHKP Q:IBQ
  1.  W !,$$DAT3^IBOUTL(IBDT)," ",?12,$E(IBPN,1,23)," "
  1.  W ?36,$E($$FILE^IBRXUTL(IBRX,.01),1,11)," ",?48,IBFL
  1.  W ?51,$P(IBD,U,3)," " ; ECME number
  1.  W ?59,$P($G(^DGCR(399,+$P(IBD,U,4),0)),U)," " ; Bill #
  1.  W ?67,$E($P($G(^DIC(36,+$P(IBD,U,5),0)),U),1,13) ; Insurance
  1.  Q
  1.  ;
  1. WRLINE2 ; Write the detailed report line
  1.  N IBRXARR
  1.  D CHKP Q:IBQ
  1.  W !,$$DAT^IBNCPRR1(IBDT)," ",?10,$E(IBPN,1,18)," "
  1.  W ?29,$$SSN4^IBNCPRR1(+IBD)
  1.  W ?34,$E($$FILE^IBRXUTL(IBRX,.01),1,10)," "
  1.  W ?45,IBFL," "
  1.  W ?49,$$DAT^IBNCPRR1($P(IBD,U,2))," "
  1.  N DRGIFN,DRUGNM,SEQNUM
  1.  S DRGIFN=$$FILE^IBRXUTL(IBRX,6) D ZERO^IBRXUTL(DRGIFN) S DRUGNM=^TMP($J,"IBDRUG",DRGIFN,.01)
  1.  K ^TMP($J,"IBDRUG")
  1.  W ?60,$E(DRUGNM,1,20)
  1.  ; ECME#/Rx Status/Copay
  1.  D CHKP Q:IBQ
  1.  W !?5,"ECME#: ",$P(IBD,U,3),", Rx Status: ",$$FILE^IBRXUTL(IBRX,100,"E"),", Rx Copay: ",$$COPAY^IBNCPRR1(IBRX,IBFL)
  1.  ; Bill Number/Insurance/Group
  1.  I $P(IBD,U,4) D CHKP Q:IBQ  D
  1.  . W !?5,"Bill#: ",$P($G(^DGCR(399,+$P(IBD,U,4),0)),U)
  1.  . W ", Insurance: ",$E($P($G(^DIC(36,+$P(IBD,U,5),0)),U),1,20)
  1.  . ;W ", Group Ins.Plan: ?"
  1.  ; CMOP Transactions
  1.  I IBWMC="C" D  Q:IBQ
  1.  . N IBCMOP,IBZ,IBANY
  1.  . S IBANY=0
  1.  . S IBCMOP=0
  1.  . S DFN=$$FILE^IBRXUTL(IBRX,2)
  1.  . D RX^PSO52API(DFN,"IBRX",IBRX,,"C",,)
  1.  . F  S IBCMOP=$O(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP)) Q:'IBCMOP  D  Q:IBQ
  1.  .. S IBZ=$O(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,0)) Q:IBZ=""
  1.  .. I +$P(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,2),"^",1)'=IBFL Q  ; different refill
  1.  .. D CHKP Q:IBQ
  1.  .. N DR,DA,DIQ,DIC
  1.  .. S DR=400,DR(52.01)="1"
  1.  .. S DA=IBRX,DA(52.01)=IBCMOP
  1.  .. S DIQ="IBRXARR",DIQ(0)="E"
  1.  .. D DIQ^PSODI(52,52,.DR,.DA,.DIQ) S SEQNUM=$G(IBRXARR(52.01,DA(52.01),DR(52.01),DIQ(0)))
  1.  .. W !?5,"CMOP SEQUENCE# ",SEQNUM
  1.  .. W ", STATUS: ",$P(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,3),"^",2)
  1.  .. W ", NDC: ",$P(^TMP($J,"IBRX",DFN,IBRX,"C",IBCMOP,4),"^",1) S IBANY=1
  1.  .K ^TMP($J,"IBRX")
  1.  . I 'IBANY D CHKP Q:IBQ  W !?5,"NO CMOP TRANSACTIONS FOUND"
  1.  ;
  1.  ; Write activity log
  1.  N IBACT,IBFROM,IBTO,IBTMP
  1.  S IBFROM=IBDT,IBTO=$$NXTREFDT^IBNCPRR1(IBRX,IBFL)
  1.  I IBTO<IBFROM S IBTO=IBFROM
  1.  S DFN=$$FILE^IBRXUTL(IBRX,2),LIST="IBTMPARR",NODE="A"
  1.  D RX^PSO52API(DFN,LIST,IBRX,,NODE,,) Q:$P(^TMP($J,LIST,DFN,IBRX,"A",.01),"^",1)<0
  1.  S IBTMP=0
  1.  F  S IBTMP=$O(^TMP($J,LIST,DFN,IBRX,"A",IBTMP)) Q:IBTMP=""  D  Q:IBQ
  1.  . N IBZ,IBTXT
  1.  . I $P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.02),"^",1)'="B",$P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.02),"^",1)'="M" Q
  1.  . S IBZ=$P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.01),"^",1)
  1.  . I IBZ<IBFROM Q
  1.  . I IBZ>IBTO Q
  1.  . D CHKP Q:IBQ
  1.  . S IBTXT=$P(^TMP($J,LIST,DFN,IBRX,"A",IBTMP,.05),"^",1)
  1.  . S:$TR(IBTXT," ")="" IBTXT=$$EXTERNAL^DILFD(52.3,.02,,$P(IBZ,U,2))
  1.  . W !?5,$$DATTIM^IBNCPRR1(+IBZ),?21,$E(IBTXT,1,59)
  1.  K ^TMP($J,LIST)
  1.  D CHKP Q:IBQ
  1.  W !?5,"-------------------------------"
  1.  Q
  1.  ;
  1. WRLINE3 ; Write the Excel report line
  1.  W !,$$DAT^IBNCPRR1(IBDT),U,$E(IBPN,1,23),U
  1.  W $E($$FILE^IBRXUTL(IBRX,.01),1,11),U,IBFL,U
  1.  W $$DAT^IBNCPRR1($P(IBD,U,2)),U
  1.  W $P(IBD,U,3),U ; ECME number
  1.  W $P($G(^DGCR(399,+$P(IBD,U,4),0)),U),U ; Bill #
  1.  W $E($P($G(^DIC(36,+$P(IBD,U,5),0)),U),1,13) ; Insurance
  1.  Q
  1.  ;
  1. HDR ;
  1.  N LIST,IBSNAME
  1.  S LIST="HDRLIST"
  1.  S IBSNAME=""
  1.  D PSS^PSO59(IBSITE,,LIST)
  1.  I $G(^TMP($J,LIST,IBSITE,0))>0 S IBSNAME=^TMP($J,LIST,IBSITE,.01)
  1.  K ^TMP($J,LIST)
  1.  S IBPAGE=IBPAGE+1
  1.  W @IOF,?10,"IB THIRD PARTY BILLING PHARMACY CROSS-CHECK REPORT for "_IBSNAME,!
  1.  W ?10,$S(IBWMC="C":"CMOP",IBWMC="M":"MAIL",1:"WINDOW")," PRESCRIPTIONS" W ", ",$S(IBSDE="S":"SUMMARY",1:"DETAILED")
  1.  W !?10,"Released ",$$DAT3^IBOUTL(IBBDT)_" to "_$$DAT3^IBOUTL(IBEDT),?70,"Page: "_IBPAGE
  1.  I IBSDE="S" D
  1.  . W !!,"Rel.Date    Patient Name            Rx No   Fill#  ECME#   Bill    Insurance"
  1.  I IBSDE="D" D
  1.  . W !!,"Rel.Date  Patient Name       SSN  Rx No   Fill#  Fil.Date   Drug"
  1.  I IBSDE="E" D
  1.  . W !!,"Rel.Date^Patient Name^SSN^Rx No^Fill#^Fil.Date^ECME#^Bill"
  1.  I IBSDE'="E" D ULINE("=")
  1.  Q
  1.  ;
  1.  ;
  1. COLLECT ;
  1.  N IBDT,IBRX,IBFL,IBP,DFN,IBRXINS,IBZ,IBRXN,IBFLDT,IBPN,IBECN,IBECMBIL,IBRXSITE,IBBIL,IBFILD,LIST,CNT
  1.  S IBDT=IBBDT-.0001
  1.  ; Released Prescriptions/Refills
  1.  S LIST="IBRXARR"
  1.  D EXTRACT^PSO52EX(IBBDT,IBEDT,LIST)
  1.  S DTE=0,CNT=0
  1.  F  S DTE=$O(^TMP($J,LIST,"AL",DTE)) Q:'DTE  D
  1.  .S IBRX="" F  S IBRX=$O(^TMP($J,LIST,"AL",DTE,IBRX)) Q:'IBRX  D
  1.  ..S IBFIL="" F  S IBFIL=$O(^TMP($J,LIST,"AL",DTE,IBRX,IBFIL)) Q:IBFIL=""  D
  1.  ...S DFN=$$FILE^IBRXUTL(IBRX,2) ;Patient
  1.  ...S IBZ=$$RXZERO^IBRXUTL(DFN,IBRX)
  1.  ...S IBPN=$$FILE^IBRXUTL(IBRX,2,"E")
  1.  ...S IBRXSITE=$$FILE^IBRXUTL(IBRX,20)
  1.  ...I IBSITE'=IBRXSITE Q
  1.  ...I IBFIL=0 S IBFLDT=$$FILE^IBRXUTL(IBRX,22)
  1.  ...I IBFIL>0 S IBFLDT=$$SUBFILE^IBRXUTL(IBRX,IBFL,52,.01)
  1.  ...S:'IBFLDT IBFLDT=IBDT
  1.  ... S IBBIL=$$BILL^IBNCPBB(IBRXN,IBFLDT) ; IB Bill
  1.  ... S IBRXINS=$$BILLINS^IBNCPRR1(IBBIL)
  1.  ... I 'IBRXINS S IBRXINS=$$RXINS^IBNCPRR1(IBRX,IBFL)
  1.  ... S IBECMBIL=$$ECMEBIL^IBNCPDPU(DFN,IBFLDT) ; ECME Billable?
  1.  ... ; Apply filters:
  1.  ... I IBENB="E",'IBECMBIL Q
  1.  ... I IBENB="N",IBECMBIL Q
  1.  ... I IBINS,IBRXINS'=IBINS Q
  1.  ... ; Mail/Window/CMOP
  1.  ... I IBWMC'=$$RXWMC(IBRX) Q
  1.  ... S IBECN=$S(IBECMBIL:$$ECMENO^IBNCPRR1(IBRX),1:"")
  1.  ... S @REF@($P(IBDT,"."),IBPN,IBRX,IBFL)=DFN_U_IBFLDT_U_IBECN_U_IBBIL_U_IBRXINS
  1.  K ^TMP($J,LIST)
  1.  ;
  1.  ;;Partial Prescriptions
  1.  ;S IBRXN=0
  1.  ;S IBDT=IBBDT-.001 F  S IBDT=$O(^PSRX("ADP",IBDT)) Q:'IBDT!($P(IBDT,".")>IBEDT)  D
  1.  ;. F  S IBRX=$O(^PSRX("ADP",IBDT,IBRX)) Q:'IBRX  D
  1.  ;.. S IBP=0 F  S IBP=$O(^PSRX("ADP",IBDT,IBRX,IBP)) Q:'IBP  D
  1.  ;... I $G(^PSRX(IBRX,0))="" Q
  1.  ;... S IBPAR=1 D REF
  1.  Q
  1.  ;
  1.  ;
  1. RXWMC(IBRX) ;WMC
  1.  N IBZ,IBWM,DFN
  1.  S DFN=$$FILE^IBRXUTL(IBRX,2),NODE="C",LIST="IBCMOP"
  1.  D RX^PSO52API(DFN,LIST,IBRX,,NODE,,)
  1.  I ^TMP($J,LIST,DFN,IBRX,"C",0)'=-1 Q "C"
  1.  S IBZ=$$RXZERO^IBRXUTL($$FILE^IBRXUTL(IBRX,2),IBRX)
  1.  S IBWM=$P(IBZ,U,11)
  1.  I IBWM="" S IBWM="W" ;default
  1.  K ^TMP($J,LIST)
  1.  Q IBWM
  1.  ;
  1. CHKP ;Check for EOP
  1.  I $Y>(IOSL-4) D:IBSCR PAUSE Q:IBQ  D HDR
  1.  Q
  1.  ;
  1. PAUSE ;
  1.  N X U IO(0) W !!,"Press RETURN to continue, '^' to exit:" R X:DTIME S:'$T X="^" S:X["^" IBQ=2
  1.  U IO
  1.  Q
  1.  ;
  1. PAUSE2 ;
  1.  N X U IO(0) W !!,"Press RETURN to continue:" R X:DTIME S:'$T X="^" S:X["^" IBQ=2
  1.  U IO
  1.  Q
  1.  ;
  1. ULINE(X) ;line
  1.  D CHKP Q:IBQ
  1.  N I W ! F I=1:1:80 W $G(X,"-")
  1.  Q
  1.  ;
  1. RXSTAT(IBDFN,IBRX) ;
  1.  N IBS
  1.  ;instead of: S IBS=$P($G(^PSRX(IBRX,"STA")),U)
  1.  S IBS=$$RXSTATUS(IBDFN,IBRX)
  1.  Q $$EXTERNAL^DILFD(52,100,,IBS)
  1.  ;
  1. RXSTATUS(IBDFN,IBRX) ;
  1.  N X
  1.  K ^TMP($J,"IBNCPDP52")
  1.  D RX^PSO52API(IBDFN,"IBNCPDP52",IBRX,"","ST")
  1.  S X=+$G(^TMP($J,"IBNCPDP52",IBDFN,IBRX,100))
  1.  K ^TMP($J,"IBNCPDP52")
  1.  Q X
  1.          ;