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