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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPRR 9684 printed Sep 23, 2025@20:01:23 Page 2
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
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ;
+1 NEW IBQ,IBSITE,IBWMC,IBENB,IBBDT,IBEDT,IBINS,IBSDE,IBSCR
+2 ; quit flag
SET IBQ=0
+3 ; Prompts to the user:
+4 ; Division
DO DIV
if IBQ
QUIT
+5 ; W/M/C criteria
DO WMC
if IBQ
QUIT
+6 ; ECME/NON-ECME/BOTH criteria
DO ENB
if IBQ
QUIT
+7 ; From-To date range
DO DATE
if IBQ
QUIT
+8 ; Insurance company
DO INS
if IBQ
QUIT
+9 ; Summary/Detailed/Excel criteria
DO SDE
if IBQ
QUIT
+10 DO DEVICE
if IBQ
QUIT
+11 DO RUN
+12 IF IBQ'=2
DO PAUSE2
+13 QUIT
+14 ;
DIV NEW DIC,DIRUT
+1 WRITE !
SET DIC("A")="Division: "
SET DIC=59
SET DIC(0)="AEQM"
DO DIC^PSODI(59,.DIC,)
SET IBSITE=+Y
KILL Y
+2 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+3 IF IBSITE'>0
SET IBQ=1
QUIT
+4 IF $GET(PSODIY)
KILL PSODIY
+5 QUIT
+6 ;
WMC NEW DIR,DIRUT,Y
+1 WRITE !
SET DIR("B")="CMOP"
SET DIR("A")="(W)INDOW/(M)AIL/(C)MOP: "
+2 SET DIR(0)="SA^W:WINDOW;M:MAIL;C:CMOP"
DO ^DIR
+3 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+4 SET IBWMC=Y
+5 QUIT
+6 ;
ENB NEW DIR,DIRUT,Y
+1 WRITE !
SET DIR("B")="ECME BILLABLE"
SET DIR("A")="(E)CME Billable/(N)on-ECME Billable/(B)OTH: "
+2 SET DIR(0)="SA^E:ECME BILLABLE;N:NON-ECME BILLABLE;B:BOTH"
DO ^DIR
+3 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+4 SET IBENB=Y
+5 QUIT
+6 ;
DATE ;
+1 NEW %DT,Y
+2 SET (IBBDT,IBEDT)=DT
+3 SET %DT="AEX"
+4 SET %DT("A")="FROM RELEASE DATE: "
SET %DT("B")="TODAY"
+5 WRITE !
DO ^%DT
KILL %DT
+6 IF Y<0
SET IBQ=1
QUIT
+7 SET IBBDT=+Y
+8 SET %DT="AEX"
+9 ;$$DAT2^IBOUTL(IBBDT)
SET %DT("A")="TO RELEASE DATE: "
SET %DT("B")="TODAY"
+10 DO ^%DT
KILL %DT
+11 IF Y<0
SET IBQ=1
QUIT
+12 SET IBEDT=+Y
+13 QUIT
+14 ;
INS NEW DIR,DIC,DIRUT,Y
+1 WRITE !
SET DIR("B")="ALL"
SET DIR("A")="(S)INGLE Insurance Company /(A)LL Insurance Companies: "
+2 SET DIR(0)="SA^S:SINGLE INSURANCE COMPANY;A:ALL"
DO ^DIR
+3 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+4 IF Y="A"
SET IBINS=0
QUIT
+5 ;
+6 SET DIC(0)="AEQM"
SET DIC=36
+7 WRITE !
DO ^DIC
+8 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+9 IF Y'>0
SET IBQ=1
QUIT
+10 SET IBINS=+Y
+11 QUIT
+12 ;
SDE NEW DIR,DIRUT
+1 SET DIR("B")="SUMMARY"
SET DIR("A")="(S)UMMARY/(D)ETAILED/(E)XCEL: "
+2 SET DIR(0)="SA^S:SUMMARY;D:DETAILED;E:EXCEL"
+3 WRITE !
DO ^DIR
+4 IF $DATA(DIRUT)
SET IBQ=1
QUIT
+5 SET IBSDE=Y
+6 QUIT
+7 ;
DEVICE ;
+1 NEW %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,POP,ZTSAVE
+2 SET %ZIS="QM"
+3 WRITE !
DO ^%ZIS
+4 IF POP
SET IBQ=1
QUIT
+5 SET IBSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+6 ;
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTRTN="RUN^IBNCPRR"
+9 SET ZTIO=ION
+10 SET ZTSAVE("IB*")=""
+11 SET ZTDESC="IB ECME CMOP REPORT"
+12 DO ^%ZTLOAD
+13 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+14 DO HOME^%ZIS
End DoDot:1
SET IBQ=1
+15 USE IO
+16 QUIT
+17 ;
RUN ;
+1 NEW IBPAGE,REF
+2 SET REF=$NAME(^TMP($JOB,"IBNCPRR"))
+3 KILL @REF
+4 SET IBPAGE=0
+5 ; Collect the data in ^TMP
DO COLLECT
+6 USE IO
+7 DO REPORT
+8 IF 'IBSCR
WRITE !,@IOF
+9 DO ^%ZISC
+10 KILL @REF
+11 QUIT
+12 ;
REPORT ;
+1 NEW IBDT,IBRX,IBFL,IBPN,DFN,IBD
+2 DO HDR
+3 IF '$DATA(@REF)
WRITE !,"No data meet the criteria."
+4 SET IBDT=""
FOR
SET IBDT=$ORDER(@REF@(IBDT))
if IBDT=""
QUIT
Begin DoDot:1
+5 SET IBPN=""
FOR
SET IBPN=$ORDER(@REF@(IBDT,IBPN))
if IBPN=""
QUIT
Begin DoDot:2
+6 SET IBRX=""
FOR
SET IBRX=$ORDER(@REF@(IBDT,IBPN,IBRX))
if IBRX=""
QUIT
Begin DoDot:3
+7 SET IBFL=""
FOR
SET IBFL=$ORDER(@REF@(IBDT,IBPN,IBRX,IBFL))
if IBFL=""
QUIT
Begin DoDot:4
+8 SET IBD=$GET(@REF@(IBDT,IBPN,IBRX,IBFL))
if IBD=""
QUIT
+9 IF IBSDE="S"
DO WRLINE
QUIT
+10 IF IBSDE="D"
DO WRLINE2
QUIT
+11 IF IBSDE="E"
DO WRLINE3
QUIT
End DoDot:4
if IBQ
QUIT
End DoDot:3
if IBQ
QUIT
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+12 ;
+13 QUIT
+14 ;
WRLINE ; Write the summary report line
+1 DO CHKP
if IBQ
QUIT
+2 WRITE !,$$DAT3^IBOUTL(IBDT)," ",?12,$EXTRACT(IBPN,1,23)," "
+3 WRITE ?36,$EXTRACT($$FILE^IBRXUTL(IBRX,.01),1,11)," ",?48,IBFL
+4 ; ECME number
WRITE ?51,$PIECE(IBD,U,3)," "
+5 ; Bill #
WRITE ?59,$PIECE($GET(^DGCR(399,+$PIECE(IBD,U,4),0)),U)," "
+6 ; Insurance
WRITE ?67,$EXTRACT($PIECE($GET(^DIC(36,+$PIECE(IBD,U,5),0)),U),1,13)
+7 QUIT
+8 ;
WRLINE2 ; Write the detailed report line
+1 NEW IBRXARR
+2 DO CHKP
if IBQ
QUIT
+3 WRITE !,$$DAT^IBNCPRR1(IBDT)," ",?10,$EXTRACT(IBPN,1,18)," "
+4 WRITE ?29,$$SSN4^IBNCPRR1(+IBD)
+5 WRITE ?34,$EXTRACT($$FILE^IBRXUTL(IBRX,.01),1,10)," "
+6 WRITE ?45,IBFL," "
+7 WRITE ?49,$$DAT^IBNCPRR1($PIECE(IBD,U,2))," "
+8 NEW DRGIFN,DRUGNM,SEQNUM
+9 SET DRGIFN=$$FILE^IBRXUTL(IBRX,6)
DO ZERO^IBRXUTL(DRGIFN)
SET DRUGNM=^TMP($JOB,"IBDRUG",DRGIFN,.01)
+10 KILL ^TMP($JOB,"IBDRUG")
+11 WRITE ?60,$EXTRACT(DRUGNM,1,20)
+12 ; ECME#/Rx Status/Copay
+13 DO CHKP
if IBQ
QUIT
+14 WRITE !?5,"ECME#: ",$PIECE(IBD,U,3),", Rx Status: ",$$FILE^IBRXUTL(IBRX,100,"E"),", Rx Copay: ",$$COPAY^IBNCPRR1(IBRX,IBFL)
+15 ; Bill Number/Insurance/Group
+16 IF $PIECE(IBD,U,4)
DO CHKP
if IBQ
QUIT
Begin DoDot:1
+17 WRITE !?5,"Bill#: ",$PIECE($GET(^DGCR(399,+$PIECE(IBD,U,4),0)),U)
+18 WRITE ", Insurance: ",$EXTRACT($PIECE($GET(^DIC(36,+$PIECE(IBD,U,5),0)),U),1,20)
+19 ;W ", Group Ins.Plan: ?"
End DoDot:1
+20 ; CMOP Transactions
+21 IF IBWMC="C"
Begin DoDot:1
+22 NEW IBCMOP,IBZ,IBANY
+23 SET IBANY=0
+24 SET IBCMOP=0
+25 SET DFN=$$FILE^IBRXUTL(IBRX,2)
+26 DO RX^PSO52API(DFN,"IBRX",IBRX,,"C",,)
+27 FOR
SET IBCMOP=$ORDER(^TMP($JOB,"IBRX",DFN,IBRX,"C",IBCMOP))
if 'IBCMOP
QUIT
Begin DoDot:2
+28 SET IBZ=$ORDER(^TMP($JOB,"IBRX",DFN,IBRX,"C",IBCMOP,0))
if IBZ=""
QUIT
+29 ; different refill
IF +$PIECE(^TMP($JOB,"IBRX",DFN,IBRX,"C",IBCMOP,2),"^",1)'=IBFL
QUIT
+30 DO CHKP
if IBQ
QUIT
+31 NEW DR,DA,DIQ,DIC
+32 SET DR=400
SET DR(52.01)="1"
+33 SET DA=IBRX
SET DA(52.01)=IBCMOP
+34 SET DIQ="IBRXARR"
SET DIQ(0)="E"
+35 DO DIQ^PSODI(52,52,.DR,.DA,.DIQ)
SET SEQNUM=$GET(IBRXARR(52.01,DA(52.01),DR(52.01),DIQ(0)))
+36 WRITE !?5,"CMOP SEQUENCE# ",SEQNUM
+37 WRITE ", STATUS: ",$PIECE(^TMP($JOB,"IBRX",DFN,IBRX,"C",IBCMOP,3),"^",2)
+38 WRITE ", NDC: ",$PIECE(^TMP($JOB,"IBRX",DFN,IBRX,"C",IBCMOP,4),"^",1)
SET IBANY=1
End DoDot:2
if IBQ
QUIT
+39 KILL ^TMP($JOB,"IBRX")
+40 IF 'IBANY
DO CHKP
if IBQ
QUIT
WRITE !?5,"NO CMOP TRANSACTIONS FOUND"
End DoDot:1
if IBQ
QUIT
+41 ;
+42 ; Write activity log
+43 NEW IBACT,IBFROM,IBTO,IBTMP
+44 SET IBFROM=IBDT
SET IBTO=$$NXTREFDT^IBNCPRR1(IBRX,IBFL)
+45 IF IBTO<IBFROM
SET IBTO=IBFROM
+46 SET DFN=$$FILE^IBRXUTL(IBRX,2)
SET LIST="IBTMPARR"
SET NODE="A"
+47 DO RX^PSO52API(DFN,LIST,IBRX,,NODE,,)
if $PIECE(^TMP($JOB,LIST,DFN,IBRX,"A",.01),"^",1)<0
QUIT
+48 SET IBTMP=0
+49 FOR
SET IBTMP=$ORDER(^TMP($JOB,LIST,DFN,IBRX,"A",IBTMP))
if IBTMP=""
QUIT
Begin DoDot:1
+50 NEW IBZ,IBTXT
+51 IF $PIECE(^TMP($JOB,LIST,DFN,IBRX,"A",IBTMP,.02),"^",1)'="B"
IF $PIECE(^TMP($JOB,LIST,DFN,IBRX,"A",IBTMP,.02),"^",1)'="M"
QUIT
+52 SET IBZ=$PIECE(^TMP($JOB,LIST,DFN,IBRX,"A",IBTMP,.01),"^",1)
+53 IF IBZ<IBFROM
QUIT
+54 IF IBZ>IBTO
QUIT
+55 DO CHKP
if IBQ
QUIT
+56 SET IBTXT=$PIECE(^TMP($JOB,LIST,DFN,IBRX,"A",IBTMP,.05),"^",1)
+57 if $TRANSLATE(IBTXT," ")=""
SET IBTXT=$$EXTERNAL^DILFD(52.3,.02,,$PIECE(IBZ,U,2))
+58 WRITE !?5,$$DATTIM^IBNCPRR1(+IBZ),?21,$EXTRACT(IBTXT,1,59)
End DoDot:1
if IBQ
QUIT
+59 KILL ^TMP($JOB,LIST)
+60 DO CHKP
if IBQ
QUIT
+61 WRITE !?5,"-------------------------------"
+62 QUIT
+63 ;
WRLINE3 ; Write the Excel report line
+1 WRITE !,$$DAT^IBNCPRR1(IBDT),U,$EXTRACT(IBPN,1,23),U
+2 WRITE $EXTRACT($$FILE^IBRXUTL(IBRX,.01),1,11),U,IBFL,U
+3 WRITE $$DAT^IBNCPRR1($PIECE(IBD,U,2)),U
+4 ; ECME number
WRITE $PIECE(IBD,U,3),U
+5 ; Bill #
WRITE $PIECE($GET(^DGCR(399,+$PIECE(IBD,U,4),0)),U),U
+6 ; Insurance
WRITE $EXTRACT($PIECE($GET(^DIC(36,+$PIECE(IBD,U,5),0)),U),1,13)
+7 QUIT
+8 ;
HDR ;
+1 NEW LIST,IBSNAME
+2 SET LIST="HDRLIST"
+3 SET IBSNAME=""
+4 DO PSS^PSO59(IBSITE,,LIST)
+5 IF $GET(^TMP($JOB,LIST,IBSITE,0))>0
SET IBSNAME=^TMP($JOB,LIST,IBSITE,.01)
+6 KILL ^TMP($JOB,LIST)
+7 SET IBPAGE=IBPAGE+1
+8 WRITE @IOF,?10,"IB THIRD PARTY BILLING PHARMACY CROSS-CHECK REPORT for "_IBSNAME,!
+9 WRITE ?10,$SELECT(IBWMC="C":"CMOP",IBWMC="M":"MAIL",1:"WINDOW")," PRESCRIPTIONS"
WRITE ", ",$SELECT(IBSDE="S":"SUMMARY",1:"DETAILED")
+10 WRITE !?10,"Released ",$$DAT3^IBOUTL(IBBDT)_" to "_$$DAT3^IBOUTL(IBEDT),?70,"Page: "_IBPAGE
+11 IF IBSDE="S"
Begin DoDot:1
+12 WRITE !!,"Rel.Date Patient Name Rx No Fill# ECME# Bill Insurance"
End DoDot:1
+13 IF IBSDE="D"
Begin DoDot:1
+14 WRITE !!,"Rel.Date Patient Name SSN Rx No Fill# Fil.Date Drug"
End DoDot:1
+15 IF IBSDE="E"
Begin DoDot:1
+16 WRITE !!,"Rel.Date^Patient Name^SSN^Rx No^Fill#^Fil.Date^ECME#^Bill"
End DoDot:1
+17 IF IBSDE'="E"
DO ULINE("=")
+18 QUIT
+19 ;
+20 ;
COLLECT ;
+1 NEW IBDT,IBRX,IBFL,IBP,DFN,IBRXINS,IBZ,IBRXN,IBFLDT,IBPN,IBECN,IBECMBIL,IBRXSITE,IBBIL,IBFILD,LIST,CNT
+2 SET IBDT=IBBDT-.0001
+3 ; Released Prescriptions/Refills
+4 SET LIST="IBRXARR"
+5 DO EXTRACT^PSO52EX(IBBDT,IBEDT,LIST)
+6 SET DTE=0
SET CNT=0
+7 FOR
SET DTE=$ORDER(^TMP($JOB,LIST,"AL",DTE))
if 'DTE
QUIT
Begin DoDot:1
+8 SET IBRX=""
FOR
SET IBRX=$ORDER(^TMP($JOB,LIST,"AL",DTE,IBRX))
if 'IBRX
QUIT
Begin DoDot:2
+9 SET IBFIL=""
FOR
SET IBFIL=$ORDER(^TMP($JOB,LIST,"AL",DTE,IBRX,IBFIL))
if IBFIL=""
QUIT
Begin DoDot:3
+10 ;Patient
SET DFN=$$FILE^IBRXUTL(IBRX,2)
+11 SET IBZ=$$RXZERO^IBRXUTL(DFN,IBRX)
+12 SET IBPN=$$FILE^IBRXUTL(IBRX,2,"E")
+13 SET IBRXSITE=$$FILE^IBRXUTL(IBRX,20)
+14 IF IBSITE'=IBRXSITE
QUIT
+15 IF IBFIL=0
SET IBFLDT=$$FILE^IBRXUTL(IBRX,22)
+16 IF IBFIL>0
SET IBFLDT=$$SUBFILE^IBRXUTL(IBRX,IBFL,52,.01)
+17 if 'IBFLDT
SET IBFLDT=IBDT
+18 ; IB Bill
SET IBBIL=$$BILL^IBNCPBB(IBRXN,IBFLDT)
+19 SET IBRXINS=$$BILLINS^IBNCPRR1(IBBIL)
+20 IF 'IBRXINS
SET IBRXINS=$$RXINS^IBNCPRR1(IBRX,IBFL)
+21 ; ECME Billable?
SET IBECMBIL=$$ECMEBIL^IBNCPDPU(DFN,IBFLDT)
+22 ; Apply filters:
+23 IF IBENB="E"
IF 'IBECMBIL
QUIT
+24 IF IBENB="N"
IF IBECMBIL
QUIT
+25 IF IBINS
IF IBRXINS'=IBINS
QUIT
+26 ; Mail/Window/CMOP
+27 IF IBWMC'=$$RXWMC(IBRX)
QUIT
+28 SET IBECN=$SELECT(IBECMBIL:$$ECMENO^IBNCPRR1(IBRX),1:"")
+29 SET @REF@($PIECE(IBDT,"."),IBPN,IBRX,IBFL)=DFN_U_IBFLDT_U_IBECN_U_IBBIL_U_IBRXINS
End DoDot:3
End DoDot:2
End DoDot:1
+30 KILL ^TMP($JOB,LIST)
+31 ;
+32 ;;Partial Prescriptions
+33 ;S IBRXN=0
+34 ;S IBDT=IBBDT-.001 F S IBDT=$O(^PSRX("ADP",IBDT)) Q:'IBDT!($P(IBDT,".")>IBEDT) D
+35 ;. F S IBRX=$O(^PSRX("ADP",IBDT,IBRX)) Q:'IBRX D
+36 ;.. S IBP=0 F S IBP=$O(^PSRX("ADP",IBDT,IBRX,IBP)) Q:'IBP D
+37 ;... I $G(^PSRX(IBRX,0))="" Q
+38 ;... S IBPAR=1 D REF
+39 QUIT
+40 ;
+41 ;
RXWMC(IBRX) ;WMC
+1 NEW IBZ,IBWM,DFN
+2 SET DFN=$$FILE^IBRXUTL(IBRX,2)
SET NODE="C"
SET LIST="IBCMOP"
+3 DO RX^PSO52API(DFN,LIST,IBRX,,NODE,,)
+4 IF ^TMP($JOB,LIST,DFN,IBRX,"C",0)'=-1
QUIT "C"
+5 SET IBZ=$$RXZERO^IBRXUTL($$FILE^IBRXUTL(IBRX,2),IBRX)
+6 SET IBWM=$PIECE(IBZ,U,11)
+7 ;default
IF IBWM=""
SET IBWM="W"
+8 KILL ^TMP($JOB,LIST)
+9 QUIT IBWM
+10 ;
CHKP ;Check for EOP
+1 IF $Y>(IOSL-4)
if IBSCR
DO PAUSE
if IBQ
QUIT
DO HDR
+2 QUIT
+3 ;
PAUSE ;
+1 NEW X
USE IO(0)
WRITE !!,"Press RETURN to continue, '^' to exit:"
READ X:DTIME
if '$TEST
SET X="^"
if X["^"
SET IBQ=2
+2 USE IO
+3 QUIT
+4 ;
PAUSE2 ;
+1 NEW X
USE IO(0)
WRITE !!,"Press RETURN to continue:"
READ X:DTIME
if '$TEST
SET X="^"
if X["^"
SET IBQ=2
+2 USE IO
+3 QUIT
+4 ;
ULINE(X) ;line
+1 DO CHKP
if IBQ
QUIT
+2 NEW I
WRITE !
FOR I=1:1:80
WRITE $GET(X,"-")
+3 QUIT
+4 ;
RXSTAT(IBDFN,IBRX) ;
+1 NEW IBS
+2 ;instead of: S IBS=$P($G(^PSRX(IBRX,"STA")),U)
+3 SET IBS=$$RXSTATUS(IBDFN,IBRX)
+4 QUIT $$EXTERNAL^DILFD(52,100,,IBS)
+5 ;
RXSTATUS(IBDFN,IBRX) ;
+1 NEW X
+2 KILL ^TMP($JOB,"IBNCPDP52")
+3 DO RX^PSO52API(IBDFN,"IBNCPDP52",IBRX,"","ST")
+4 SET X=+$GET(^TMP($JOB,"IBNCPDP52",IBDFN,IBRX,100))
+5 KILL ^TMP($JOB,"IBNCPDP52")
+6 QUIT X
+7 ;
