IBNCPBB ;DALOI/AAT - ECME BACKBILLING ;24-JUN-2003
;;2.0;INTEGRATED BILLING;**276,347,384,435,575,624,712**;21-MAR-94;Build 14
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to file #9002313.29 in ICR #4222
; Reference to DIC^PSODI in ICR #4858
;
Q
EN ;[IB GENERATE ECME RX BILLS] entry
N IBMOD1,IBMOD3,IBPAT,IBRX,IBBDT,IBEDT,IBSEL,IBREF,IBPAUSE
S IBREF=$NA(^TMP($J,"IBNCPBB"))
S IBPAUSE=1
K @IBREF D
. N IBEXIT
. S IBEXIT=0
. D MODE I IBEXIT Q
. I IBMOD1="P" D SELECT I IBEXIT Q
. I IBMOD1="R" D SELECT2 I IBEXIT Q
. D CONFIRM I IBEXIT Q
. D PROCESS^IBNCPBB1 I IBEXIT Q
I IBPAUSE W ! D PAUSE()
K @IBREF
Q
;
CT(IBTRN) ;CT ENTRY
N IBBIL,IBBN,IBDELAY,IBEXIT,IBERR,IBFDT,IBFIL,IBPAT,IBQ
N IBRDT,IBRES,IBRX,IBRXN,IBSCRES,IBZ
S IBQ=0
D FULL^VALM1
W !!,"This option sends electronic Pharmacy Claims to the Payer"
S VALMBCK="R"
S IBZ=$G(^IBT(356,IBTRN,0)) Q:IBZ=""
S IBRX=$P(IBZ,U,8),IBFIL=$P(IBZ,U,10)
I 'IBRX D Q
. W !!,"This is not a Pharmacy Claims Tracking record",*7,!
. D PAUSE("Cannot submit to ECME")
;
;Release date:
I IBFIL=0 S IBRDT=$$FILE^IBRXUTL(IBRX,31)
E S IBRDT=$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,17)
I 'IBRDT D Q
. W !!,"The Prescription is not released.",!
. D PAUSE("Cannot submit to ECME")
; -- Drug DEA ROI check.
S IBPAT=$P(IBZ,U,2)
S IBDRUG=$$FILE^IBRXUTL(IBRX,6)
; Fill/Refill Date:
S IBFDT=$S('IBFIL:$$FILE^IBRXUTL(IBRX,22),1:$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01))
I $$INSUR^IBBAPI(IBPAT,IBFDT,"P",.IBANY,1) D I 'IBQ D PAUSE() Q ;Requires ROI
. S IBINS=+$G(IBANY("IBBAPI","INSUR",1,1))
. ; If the Date of Service is on or after the Mission Act
. ; implementation date, set IBQ=1 and don't check for ROI on file.
. I $$MACHK^IBNCPDR4(IBFDT) S IBQ=1 Q
. ; If there's an ROI on file (IBQ=1) then D ROICLN^IBNCPDR4
. S IBQ=$$ROICHK^IBNCPDR4(IBPAT,IBDRUG,IBINS,IBFDT)
. I IBQ=1 D ROICLN^IBNCPDR4(IBTRN)
. Q
;
S IBQ=0 I $$SC($P(IBZ,U,19)) D Q:IBQ ;575: Reset IBQ flag to 0
. N DIR,DIE,DA,DR,Y
. W !!,"The Rx is marked 'non-billable' in CT: ",$P($G(^IBE(356.8,+$P(IBZ,U,19),0)),U)
. W !,"If you continue, the NON-BILLABLE REASON will be deleted.",!
. S DIR(0)="Y",DIR("A")="Are you sure you want to bill this episode"
. S DIR("B")="NO"
. S DIR("?")="If you want to bill this Rx, enter 'Yes' - otherwise, enter 'No'"
. W ! D ^DIR K DIR
. I 'Y S IBQ=1 Q
. S DIE="^IBT(356,",DA=IBTRN,DR=".19///@" D ^DIE ;clean NB reason
. S IBSCRES(IBRX,IBFIL)=1 ; sc resolved flag
;
S IBZ=$G(^IBT(356,IBTRN,0)) ; refresh
I $P(IBZ,U,19) D Q
. W !!,"The Prescription is marked 'non-billable' in Claims Tracking",*7
. W !,"Reason non-billable: ",$P($G(^IBE(356.8,+$P(IBZ,U,19),0),"Unknown"),U),!
. D PAUSE("Cannot submit to ECME")
; Is the patient billable at the released date?
S IBRES=$$ECMEBIL^IBNCPDPU(IBPAT,IBFDT)
I 'IBRES D Q
. W !!,"The patient is not ECME Billable at the ",$S(IBFIL:"re",1:""),"fill date."
. W !,"Reason: ",$P(IBRES,U,2,255),!
. D PAUSE("Cannot submit to ECME")
;
S IBRXN=$$FILE^IBRXUTL(IBRX,.01)
S IBBIL=$$BILL(IBRXN,IBRDT)
I IBBIL,'$P($G(^DGCR(399,IBBIL,"S")),U,16) D Q
. W !!,"Rx# ",IBRXN," was previously billed."
. W !,"Please manually cancel the bill# ",$P($G(^DGCR(399,IBBIL,0)),U)," before submitting claim to ECME.",!
. D PAUSE("Cannot submit to ECME")
I IBBIL W !,"The bill# ",$P($G(^DGCR(399,IBBIL,0)),U)," has been cancelled.",!
;
S IBDELAY=$$DLYRC() ; get delay reason code with optional parameter, IB*2.0*435
;
D CONFRX(IBRXN) Q:$G(IBEXIT)
;
W !!,"Submitting Rx# ",IBRXN W:IBFIL ", Refill# ",IBFIL W " ..."
S IBRES=$$SUBMIT^IBNCPDPU(IBRX,IBFIL,IBDELAY) W !," ",$S(+IBRES=0:"S",1:"Not s")_"ent through ECME."
I +IBRES'=0 W !," *** ECME returned status: ",$$STAT(IBRES),!
I +IBRES=0 W !!,"The Rx have been submitted to ECME for electronic billing",!
D PAUSE()
Q
;
MODE ;
; IBMOD1: "P"-Single Patient, "R"-Single Rx
; IBMOD3 (if IBMOD1="P"): "U"-Unbilled, "A"-All Rx
; IBPAT (if IBMOD1="P"): Patient's DFN
; IBBDT,IBEDT (if IBMOD1="P"): From/To dates inclusive
N DIR,DIC,DIRUT,DUOUT,Y,PSOFILE
S (IBMOD1,IBMOD3)=""
S DIR(0)="S^P:SINGLE (P)ATIENT;R:SINGLE (R)X"
S DIR("A")="SINGLE (P)ATIENT, SINGLE (R)X"
S DIR("B")="P"
D ^DIR K DIR I $D(DIRUT) S IBEXIT=1,IBPAUSE=0 Q
S IBMOD1=Y
; Enter Rx
I IBMOD1="R" W ! S PSOFILE=52,DIC="^PSRX(",DIC(0)="AEQMN" D DIC^PSODI(PSOFILE,.DIC) S:$D(DUOUT) IBEXIT=1 S IBRX=$S(Y>0:+Y,1:0) S:'IBRX IBEXIT=1,IBPAUSE=0
K PSODIY
I IBMOD1="R" Q
;
I IBMOD1'="P" W !,"???" S IBEXIT=1 Q ; Invalid mode
;Enter Patient
S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC S:$D(DUOUT) IBEXIT=1 S IBPAT=$S(Y>0:+Y,1:0) S:'IBPAT IBEXIT=1,IBPAUSE=0
Q:IBEXIT
I '$$ECMEBIL^IBNCPDPU(IBPAT,DT) W *7,!!,"Warning! The patient is currently not ECME billable!"
;
D DATE I IBEXIT S IBPAUSE=0 Q
;
S DIR(0)="S^U:UNBILLED;A:ALL RX"
S DIR("A")="(U)NBILLED, (A)LL RX"
S DIR("B")="U"
D ^DIR K DIR I $D(DIRUT) S IBEXIT=1,IBPAUSE=0 Q
S IBMOD3=Y
Q
;
;begin/end date
DATE ;
N Y,%DT
S (IBBDT,IBEDT)=DT
W !
S %DT="AEX"
S %DT("A")="START WITH DATE: ",%DT("B")="TODAY"
D ^%DT K %DT
I Y'>0 S IBEXIT=1 Q
S IBBDT=+Y
S %DT="AEX"
S %DT("A")="GO TO DATE: ",%DT("B")="TODAY" ;$$DAT2^IBOUTL(IBBDT)
D ^%DT K %DT
I Y'>0 S IBEXIT=1 Q
S IBEDT=+Y
Q
;
SELECT ;Select from patient's list
; (IBPAT,IBBDT,IBEDT,IBMOD3)
N IBD,IBRX,IBZ,IBDATA,IBCNT,Y,PDFN,LIST,LIST2,NODE,RXNUMEXT,LIST,IBDATE,CNT1,CNT2,RFNUM
S CNT1=0,CNT2=0,IBCNT=0
S LIST="IBRXSELARR"
S NODE=2
D RX^PSO52API(IBPAT,LIST,,,NODE,,)
S RXNUMEXT=0 F S RXNUMEXT=$O(^TMP($J,LIST,"B",RXNUMEXT)) Q:'RXNUMEXT D
. S IBRX=0 F S IBRX=$O(^TMP($J,LIST,"B",RXNUMEXT,IBRX)) Q:'IBRX D
.. S IBDATE=$P(^TMP($J,LIST,IBPAT,IBRX,31),"^",1)
.. I (IBDATE>IBBDT)&(IBDATE<IBEDT) D
... S IBZ=$$RXZERO^IBRXUTL(IBPAT,IBRX) Q:IBZ=""
... I $P(IBZ,U,2)'=IBPAT Q
... I '$$FILE^IBRXUTL(IBRX,31) Q ; not released
... S IBDATA=$$RXDATA(IBRX,0)
... I ('$P(IBDATA,U,6))!(IBMOD3="A") S IBCNT=IBCNT+1,@IBREF@(IBCNT)=IBDATA
... S LIST2="IBCPBBRF"
... S NODE="R"
... D RX^PSO52API(IBPAT,LIST2,IBRX,,NODE,,)
... S RFNUM=0 F S RFNUM=$O(^TMP($J,LIST2,IBPAT,IBRX,"RF",RFNUM)) Q:RFNUM'>0 D:$$SUBFILE^IBRXUTL(IBRX,RFNUM,52,17)
.... S IBDATA=$$RXDATA(IBRX,RFNUM)
.... I $P(IBDATA,U,6),IBMOD3'="A" Q ; unbilled only
.... S IBCNT=IBCNT+1,@IBREF@(IBCNT)=IBDATA
... K ^TMP($J,LIST2)
K ^TMP($J,LIST)
D MKCHOICE
Q
SELECT2 ;Select from Rx list
; (IBRX)
N IBCNT,Y,PDFN,RIFN,LST
S RIFN=0
W ! S IBPAUSE=1
S PDFN=$$FILE^IBRXUTL(IBRX,2)
S LST="SEL2LST"
I $$RXZERO^IBRXUTL(PDFN,IBRX)="" W !,"The Rx does not exist. Please try again." S IBEXIT=1 Q
I $$FILE^IBRXUTL(IBRX,31)="" W !,"The Rx has not been released. Please try again." S IBEXIT=1 Q
S IBCNT=1,@IBREF@(IBCNT)=$$RXDATA(IBRX,0)
D RX^PSO52API(PDFN,LST,IBRX,,"R",,)
S RIFN=0 F S RIFN=$O(^TMP($J,LST,PDFN,IBRX,"RF",RIFN)) Q:RIFN'>0 D:$$SUBFILE^IBRXUTL(IBRX,RIFN,52,17)
.S IBCNT=IBCNT+1,@IBREF@(IBCNT)=$$RXDATA(IBRX,RIFN)
K ^TMP($J,LST)
D MKCHOICE
Q
;
MKCHOICE ;
N Y
W !
S Y=0 F S Y=$O(@IBREF@(Y)) Q:'Y D DISP(Y)
;
I $O(@IBREF@(0))="" S IBEXIT=1 W !!," No Rxs meet the entered criteria. Please try again." Q
I $O(@IBREF@(""),-1)=1 S IBSEL(1)="" Q ; one item only
F W !!,"Enter Line Item(s) to submit to ECME or (A)LL :" R IBSEL:DTIME S:'$T IBEXIT=1 Q:IBEXIT Q:IBSEL'["?" D
. W !?10,"Enter number(s) or item range(s) separated by comma."
. W !?10,"Example: 1,3,7-11"
Q:IBEXIT
I IBSEL'="",$TR(IBSEL,"al","AL")=$E("ALL",1,$L(IBSEL)),$L(IBSEL)<3 W $E("ALL",$L(IBSEL)+1,3) S IBSEL="ALL"
I IBSEL="" S IBEXIT=1 W " Nothing selected" Q
I IBSEL="^" S IBEXIT=1 W " Cancelled" Q
;Collect the required into the IBSEL(i) local array
D PARSE(.IBSEL)
I $O(IBSEL(0))="" S IBEXIT=1 W !!,"No item(s) match the selection." Q
Q
;
CONFIRM ;
N DIR,Y
W !
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Submit the selected RX(s) to ECME for electronic billing"
D ^DIR I Y'=1 S IBEXIT=1
Q
;
CONFRX(IBRX) ;
N DIR,Y
W !
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Submit the Rx# "_IBRX_" to ECME for electronic billing"
D ^DIR I Y'=1 S IBEXIT=1
Q
;
STAT(X) ;
I +X<6 Q $P(X,"^",2)
Q "Unknown Status"
;
BILL(IBRXN,IBDT) ;Bill IEN (if any) or null
N RES,X,IBZ
S IBDT=$P(IBDT,".")
S RES=""
S X="" F S X=$O(^IBA(362.4,"B",IBRXN,X),-1) Q:X="" D:X Q:RES
. S IBZ=$G(^IBA(362.4,X,0))
. I $P($P(IBZ,U,3),".")=IBDT,$P(IBZ,U,2) S RES=+$P(IBZ,U,2)
Q RES
;
;
RXDATA(IBRX,IBFIL) ;
;RxIEN^Rx#^Fill#^RelDate^DrugIEN^BillIEN
N IBRXN,IBDT,IBDRUG,IBBIL,DATRET
S IBRXN=$$FILE^IBRXUTL(IBRX,.01)
I IBFIL=0 S IBDT=$$FILE^IBRXUTL(IBRX,22)
E S IBDT=$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01)
S IBDT=$P(IBDT,".")
S IBDRUG=$$FILE^IBRXUTL(IBRX,6)
S IBBIL=$$BILL(IBRXN,IBDT)
S DATRET=IBRX_"^"_IBRXN_"^"_IBFIL_"^"_IBDT_"^"_IBDRUG_"^"_IBBIL
Q DATRET
;
DISP(IBITEM) ;
N IBD,IBBILN,IBDRUG,IBBIL
S IBD=$G(@IBREF@(IBITEM)) Q:IBD=""
W !,IBITEM," ",?4,$P(IBD,U,2)," ",?15,$P(IBD,U,3)," ",?20,$$DAT2^IBOUTL($P(IBD,U,4))," "
W ?32,$E($$DRUG^IBRXUTL1(+$P(IBD,U,5)),1,30)
S IBBIL=$P(IBD,U,6)
I IBBIL W ?64,$P($G(^DGCR(399,+IBBIL,0)),U) I $P($G(^DGCR(399,IBBIL,"S")),U,16) W "(canc)"
Q
;
PARSE(X) ;
N I,J,N
S X=$TR(X," ")
S X=$TR(X,";",",")
I $TR(IBSEL,"al","AL")="ALL" D Q
. F I=1:1 Q:'$D(@IBREF@(I)) S IBSEL(I)=""
F I=1:1:$L(X,",") S N=$P(X,",",I) D:N'=""
. I N'["-" D:N Q
. . I $D(@IBREF@(N)) S X(N)=""
. ; Processing range
. N N1,N2
. S N1=+$P(N,"-",1),N2=+$P(N,"-",2)
. F J=N1:$S(N2<N1:-1,1:1):N2 I $D(@IBREF@(J)) S X(J)=""
Q
;
PAUSE(MESSAGE) ;
D EN^DDIOL("","","!")
I $G(MESSAGE)'="" D EN^DDIOL(MESSAGE) D EN^DDIOL(". ","","?0")
D EN^DDIOL("Press RETURN to continue: ")
R %:DTIME
Q
;
SC(IEN) ;Service connected
N IBT
I 'IEN Q 0
S IBT=$P($G(^IBE(356.8,IEN,0)),U)
I IBT="NEEDS SC DETERMINATION" Q 1
I IBT="OTHER" Q 1
Q 0
;
;
DLYRC(DFLT) ; function, ask for NCPDP field 357-NV Delay Reason Code
; DFLT = optional default value (integer from 1-14)
; returns code or "^" on time-out, etc.
N IBDELAY,C,DIC,DIR,DIRUT,DIROUT,DUOUT,DTOUT,X,Y
S IBDELAY=""
I $G(DFLT)?1.2N,DFLT>0,DFLT<15 S DIR("B")=DFLT
S DIR("S")="I $P($G(^(0)),""^"",3)'=1"
S DIR(0)="PO^9002313.29:EMZ" D ^DIR K DIR ; IA# TBD
S IBDELAY=$S($D(DTOUT)!$D(DUOUT)!$D(DIROUT)!$D(DIRUT):"^",1:Y)
S IBDELAY=+$P((IBDELAY),"^",1)
Q IBDELAY
;
;IBNCPBB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPBB 10503 printed Apr 09, 2024@21:18:34 Page 2
IBNCPBB ;DALOI/AAT - ECME BACKBILLING ;24-JUN-2003
+1 ;;2.0;INTEGRATED BILLING;**276,347,384,435,575,624,712**;21-MAR-94;Build 14
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to file #9002313.29 in ICR #4222
+5 ; Reference to DIC^PSODI in ICR #4858
+6 ;
+7 QUIT
EN ;[IB GENERATE ECME RX BILLS] entry
+1 NEW IBMOD1,IBMOD3,IBPAT,IBRX,IBBDT,IBEDT,IBSEL,IBREF,IBPAUSE
+2 SET IBREF=$NAME(^TMP($JOB,"IBNCPBB"))
+3 SET IBPAUSE=1
+4 KILL @IBREF
Begin DoDot:1
+5 NEW IBEXIT
+6 SET IBEXIT=0
+7 DO MODE
IF IBEXIT
QUIT
+8 IF IBMOD1="P"
DO SELECT
IF IBEXIT
QUIT
+9 IF IBMOD1="R"
DO SELECT2
IF IBEXIT
QUIT
+10 DO CONFIRM
IF IBEXIT
QUIT
+11 DO PROCESS^IBNCPBB1
IF IBEXIT
QUIT
End DoDot:1
+12 IF IBPAUSE
WRITE !
DO PAUSE()
+13 KILL @IBREF
+14 QUIT
+15 ;
CT(IBTRN) ;CT ENTRY
+1 NEW IBBIL,IBBN,IBDELAY,IBEXIT,IBERR,IBFDT,IBFIL,IBPAT,IBQ
+2 NEW IBRDT,IBRES,IBRX,IBRXN,IBSCRES,IBZ
+3 SET IBQ=0
+4 DO FULL^VALM1
+5 WRITE !!,"This option sends electronic Pharmacy Claims to the Payer"
+6 SET VALMBCK="R"
+7 SET IBZ=$GET(^IBT(356,IBTRN,0))
if IBZ=""
QUIT
+8 SET IBRX=$PIECE(IBZ,U,8)
SET IBFIL=$PIECE(IBZ,U,10)
+9 IF 'IBRX
Begin DoDot:1
+10 WRITE !!,"This is not a Pharmacy Claims Tracking record",*7,!
+11 DO PAUSE("Cannot submit to ECME")
End DoDot:1
QUIT
+12 ;
+13 ;Release date:
+14 IF IBFIL=0
SET IBRDT=$$FILE^IBRXUTL(IBRX,31)
+15 IF '$TEST
SET IBRDT=$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,17)
+16 IF 'IBRDT
Begin DoDot:1
+17 WRITE !!,"The Prescription is not released.",!
+18 DO PAUSE("Cannot submit to ECME")
End DoDot:1
QUIT
+19 ; -- Drug DEA ROI check.
+20 SET IBPAT=$PIECE(IBZ,U,2)
+21 SET IBDRUG=$$FILE^IBRXUTL(IBRX,6)
+22 ; Fill/Refill Date:
+23 SET IBFDT=$SELECT('IBFIL:$$FILE^IBRXUTL(IBRX,22),1:$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01))
+24 ;Requires ROI
IF $$INSUR^IBBAPI(IBPAT,IBFDT,"P",.IBANY,1)
Begin DoDot:1
+25 SET IBINS=+$GET(IBANY("IBBAPI","INSUR",1,1))
+26 ; If the Date of Service is on or after the Mission Act
+27 ; implementation date, set IBQ=1 and don't check for ROI on file.
+28 IF $$MACHK^IBNCPDR4(IBFDT)
SET IBQ=1
QUIT
+29 ; If there's an ROI on file (IBQ=1) then D ROICLN^IBNCPDR4
+30 SET IBQ=$$ROICHK^IBNCPDR4(IBPAT,IBDRUG,IBINS,IBFDT)
+31 IF IBQ=1
DO ROICLN^IBNCPDR4(IBTRN)
+32 QUIT
End DoDot:1
IF 'IBQ
DO PAUSE()
QUIT
+33 ;
+34 ;575: Reset IBQ flag to 0
SET IBQ=0
IF $$SC($PIECE(IBZ,U,19))
Begin DoDot:1
+35 NEW DIR,DIE,DA,DR,Y
+36 WRITE !!,"The Rx is marked 'non-billable' in CT: ",$PIECE($GET(^IBE(356.8,+$PIECE(IBZ,U,19),0)),U)
+37 WRITE !,"If you continue, the NON-BILLABLE REASON will be deleted.",!
+38 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to bill this episode"
+39 SET DIR("B")="NO"
+40 SET DIR("?")="If you want to bill this Rx, enter 'Yes' - otherwise, enter 'No'"
+41 WRITE !
DO ^DIR
KILL DIR
+42 IF 'Y
SET IBQ=1
QUIT
+43 ;clean NB reason
SET DIE="^IBT(356,"
SET DA=IBTRN
SET DR=".19///@"
DO ^DIE
+44 ; sc resolved flag
SET IBSCRES(IBRX,IBFIL)=1
End DoDot:1
if IBQ
QUIT
+45 ;
+46 ; refresh
SET IBZ=$GET(^IBT(356,IBTRN,0))
+47 IF $PIECE(IBZ,U,19)
Begin DoDot:1
+48 WRITE !!,"The Prescription is marked 'non-billable' in Claims Tracking",*7
+49 WRITE !,"Reason non-billable: ",$PIECE($GET(^IBE(356.8,+$PIECE(IBZ,U,19),0),"Unknown"),U),!
+50 DO PAUSE("Cannot submit to ECME")
End DoDot:1
QUIT
+51 ; Is the patient billable at the released date?
+52 SET IBRES=$$ECMEBIL^IBNCPDPU(IBPAT,IBFDT)
+53 IF 'IBRES
Begin DoDot:1
+54 WRITE !!,"The patient is not ECME Billable at the ",$SELECT(IBFIL:"re",1:""),"fill date."
+55 WRITE !,"Reason: ",$PIECE(IBRES,U,2,255),!
+56 DO PAUSE("Cannot submit to ECME")
End DoDot:1
QUIT
+57 ;
+58 SET IBRXN=$$FILE^IBRXUTL(IBRX,.01)
+59 SET IBBIL=$$BILL(IBRXN,IBRDT)
+60 IF IBBIL
IF '$PIECE($GET(^DGCR(399,IBBIL,"S")),U,16)
Begin DoDot:1
+61 WRITE !!,"Rx# ",IBRXN," was previously billed."
+62 WRITE !,"Please manually cancel the bill# ",$PIECE($GET(^DGCR(399,IBBIL,0)),U)," before submitting claim to ECME.",!
+63 DO PAUSE("Cannot submit to ECME")
End DoDot:1
QUIT
+64 IF IBBIL
WRITE !,"The bill# ",$PIECE($GET(^DGCR(399,IBBIL,0)),U)," has been cancelled.",!
+65 ;
+66 ; get delay reason code with optional parameter, IB*2.0*435
SET IBDELAY=$$DLYRC()
+67 ;
+68 DO CONFRX(IBRXN)
if $GET(IBEXIT)
QUIT
+69 ;
+70 WRITE !!,"Submitting Rx# ",IBRXN
if IBFIL
WRITE ", Refill# ",IBFIL
WRITE " ..."
+71 SET IBRES=$$SUBMIT^IBNCPDPU(IBRX,IBFIL,IBDELAY)
WRITE !," ",$SELECT(+IBRES=0:"S",1:"Not s")_"ent through ECME."
+72 IF +IBRES'=0
WRITE !," *** ECME returned status: ",$$STAT(IBRES),!
+73 IF +IBRES=0
WRITE !!,"The Rx have been submitted to ECME for electronic billing",!
+74 DO PAUSE()
+75 QUIT
+76 ;
MODE ;
+1 ; IBMOD1: "P"-Single Patient, "R"-Single Rx
+2 ; IBMOD3 (if IBMOD1="P"): "U"-Unbilled, "A"-All Rx
+3 ; IBPAT (if IBMOD1="P"): Patient's DFN
+4 ; IBBDT,IBEDT (if IBMOD1="P"): From/To dates inclusive
+5 NEW DIR,DIC,DIRUT,DUOUT,Y,PSOFILE
+6 SET (IBMOD1,IBMOD3)=""
+7 SET DIR(0)="S^P:SINGLE (P)ATIENT;R:SINGLE (R)X"
+8 SET DIR("A")="SINGLE (P)ATIENT, SINGLE (R)X"
+9 SET DIR("B")="P"
+10 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBEXIT=1
SET IBPAUSE=0
QUIT
+11 SET IBMOD1=Y
+12 ; Enter Rx
+13 IF IBMOD1="R"
WRITE !
SET PSOFILE=52
SET DIC="^PSRX("
SET DIC(0)="AEQMN"
DO DIC^PSODI(PSOFILE,.DIC)
if $DATA(DUOUT)
SET IBEXIT=1
SET IBRX=$SELECT(Y>0:+Y,1:0)
if 'IBRX
SET IBEXIT=1
SET IBPAUSE=0
+14 KILL PSODIY
+15 IF IBMOD1="R"
QUIT
+16 ;
+17 ; Invalid mode
IF IBMOD1'="P"
WRITE !,"???"
SET IBEXIT=1
QUIT
+18 ;Enter Patient
+19 SET DIC="^DPT("
SET DIC(0)="AEQMN"
DO ^DIC
if $DATA(DUOUT)
SET IBEXIT=1
SET IBPAT=$SELECT(Y>0:+Y,1:0)
if 'IBPAT
SET IBEXIT=1
SET IBPAUSE=0
+20 if IBEXIT
QUIT
+21 IF '$$ECMEBIL^IBNCPDPU(IBPAT,DT)
WRITE *7,!!,"Warning! The patient is currently not ECME billable!"
+22 ;
+23 DO DATE
IF IBEXIT
SET IBPAUSE=0
QUIT
+24 ;
+25 SET DIR(0)="S^U:UNBILLED;A:ALL RX"
+26 SET DIR("A")="(U)NBILLED, (A)LL RX"
+27 SET DIR("B")="U"
+28 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBEXIT=1
SET IBPAUSE=0
QUIT
+29 SET IBMOD3=Y
+30 QUIT
+31 ;
+32 ;begin/end date
DATE ;
+1 NEW Y,%DT
+2 SET (IBBDT,IBEDT)=DT
+3 WRITE !
+4 SET %DT="AEX"
+5 SET %DT("A")="START WITH DATE: "
SET %DT("B")="TODAY"
+6 DO ^%DT
KILL %DT
+7 IF Y'>0
SET IBEXIT=1
QUIT
+8 SET IBBDT=+Y
+9 SET %DT="AEX"
+10 ;$$DAT2^IBOUTL(IBBDT)
SET %DT("A")="GO TO DATE: "
SET %DT("B")="TODAY"
+11 DO ^%DT
KILL %DT
+12 IF Y'>0
SET IBEXIT=1
QUIT
+13 SET IBEDT=+Y
+14 QUIT
+15 ;
SELECT ;Select from patient's list
+1 ; (IBPAT,IBBDT,IBEDT,IBMOD3)
+2 NEW IBD,IBRX,IBZ,IBDATA,IBCNT,Y,PDFN,LIST,LIST2,NODE,RXNUMEXT,LIST,IBDATE,CNT1,CNT2,RFNUM
+3 SET CNT1=0
SET CNT2=0
SET IBCNT=0
+4 SET LIST="IBRXSELARR"
+5 SET NODE=2
+6 DO RX^PSO52API(IBPAT,LIST,,,NODE,,)
+7 SET RXNUMEXT=0
FOR
SET RXNUMEXT=$ORDER(^TMP($JOB,LIST,"B",RXNUMEXT))
if 'RXNUMEXT
QUIT
Begin DoDot:1
+8 SET IBRX=0
FOR
SET IBRX=$ORDER(^TMP($JOB,LIST,"B",RXNUMEXT,IBRX))
if 'IBRX
QUIT
Begin DoDot:2
+9 SET IBDATE=$PIECE(^TMP($JOB,LIST,IBPAT,IBRX,31),"^",1)
+10 IF (IBDATE>IBBDT)&(IBDATE<IBEDT)
Begin DoDot:3
+11 SET IBZ=$$RXZERO^IBRXUTL(IBPAT,IBRX)
if IBZ=""
QUIT
+12 IF $PIECE(IBZ,U,2)'=IBPAT
QUIT
+13 ; not released
IF '$$FILE^IBRXUTL(IBRX,31)
QUIT
+14 SET IBDATA=$$RXDATA(IBRX,0)
+15 IF ('$PIECE(IBDATA,U,6))!(IBMOD3="A")
SET IBCNT=IBCNT+1
SET @IBREF@(IBCNT)=IBDATA
+16 SET LIST2="IBCPBBRF"
+17 SET NODE="R"
+18 DO RX^PSO52API(IBPAT,LIST2,IBRX,,NODE,,)
+19 SET RFNUM=0
FOR
SET RFNUM=$ORDER(^TMP($JOB,LIST2,IBPAT,IBRX,"RF",RFNUM))
if RFNUM'>0
QUIT
if $$SUBFILE^IBRXUTL(IBRX,RFNUM,52,17)
Begin DoDot:4
+20 SET IBDATA=$$RXDATA(IBRX,RFNUM)
+21 ; unbilled only
IF $PIECE(IBDATA,U,6)
IF IBMOD3'="A"
QUIT
+22 SET IBCNT=IBCNT+1
SET @IBREF@(IBCNT)=IBDATA
End DoDot:4
+23 KILL ^TMP($JOB,LIST2)
End DoDot:3
End DoDot:2
End DoDot:1
+24 KILL ^TMP($JOB,LIST)
+25 DO MKCHOICE
+26 QUIT
SELECT2 ;Select from Rx list
+1 ; (IBRX)
+2 NEW IBCNT,Y,PDFN,RIFN,LST
+3 SET RIFN=0
+4 WRITE !
SET IBPAUSE=1
+5 SET PDFN=$$FILE^IBRXUTL(IBRX,2)
+6 SET LST="SEL2LST"
+7 IF $$RXZERO^IBRXUTL(PDFN,IBRX)=""
WRITE !,"The Rx does not exist. Please try again."
SET IBEXIT=1
QUIT
+8 IF $$FILE^IBRXUTL(IBRX,31)=""
WRITE !,"The Rx has not been released. Please try again."
SET IBEXIT=1
QUIT
+9 SET IBCNT=1
SET @IBREF@(IBCNT)=$$RXDATA(IBRX,0)
+10 DO RX^PSO52API(PDFN,LST,IBRX,,"R",,)
+11 SET RIFN=0
FOR
SET RIFN=$ORDER(^TMP($JOB,LST,PDFN,IBRX,"RF",RIFN))
if RIFN'>0
QUIT
if $$SUBFILE^IBRXUTL(IBRX,RIFN,52,17)
Begin DoDot:1
+12 SET IBCNT=IBCNT+1
SET @IBREF@(IBCNT)=$$RXDATA(IBRX,RIFN)
End DoDot:1
+13 KILL ^TMP($JOB,LST)
+14 DO MKCHOICE
+15 QUIT
+16 ;
MKCHOICE ;
+1 NEW Y
+2 WRITE !
+3 SET Y=0
FOR
SET Y=$ORDER(@IBREF@(Y))
if 'Y
QUIT
DO DISP(Y)
+4 ;
+5 IF $ORDER(@IBREF@(0))=""
SET IBEXIT=1
WRITE !!," No Rxs meet the entered criteria. Please try again."
QUIT
+6 ; one item only
IF $ORDER(@IBREF@(""),-1)=1
SET IBSEL(1)=""
QUIT
+7 FOR
WRITE !!,"Enter Line Item(s) to submit to ECME or (A)LL :"
READ IBSEL:DTIME
if '$TEST
SET IBEXIT=1
if IBEXIT
QUIT
if IBSEL'["?"
QUIT
Begin DoDot:1
+8 WRITE !?10,"Enter number(s) or item range(s) separated by comma."
+9 WRITE !?10,"Example: 1,3,7-11"
End DoDot:1
+10 if IBEXIT
QUIT
+11 IF IBSEL'=""
IF $TRANSLATE(IBSEL,"al","AL")=$EXTRACT("ALL",1,$LENGTH(IBSEL))
IF $LENGTH(IBSEL)<3
WRITE $EXTRACT("ALL",$LENGTH(IBSEL)+1,3)
SET IBSEL="ALL"
+12 IF IBSEL=""
SET IBEXIT=1
WRITE " Nothing selected"
QUIT
+13 IF IBSEL="^"
SET IBEXIT=1
WRITE " Cancelled"
QUIT
+14 ;Collect the required into the IBSEL(i) local array
+15 DO PARSE(.IBSEL)
+16 IF $ORDER(IBSEL(0))=""
SET IBEXIT=1
WRITE !!,"No item(s) match the selection."
QUIT
+17 QUIT
+18 ;
CONFIRM ;
+1 NEW DIR,Y
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Submit the selected RX(s) to ECME for electronic billing"
+4 DO ^DIR
IF Y'=1
SET IBEXIT=1
+5 QUIT
+6 ;
CONFRX(IBRX) ;
+1 NEW DIR,Y
+2 WRITE !
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Submit the Rx# "_IBRX_" to ECME for electronic billing"
+4 DO ^DIR
IF Y'=1
SET IBEXIT=1
+5 QUIT
+6 ;
STAT(X) ;
+1 IF +X<6
QUIT $PIECE(X,"^",2)
+2 QUIT "Unknown Status"
+3 ;
BILL(IBRXN,IBDT) ;Bill IEN (if any) or null
+1 NEW RES,X,IBZ
+2 SET IBDT=$PIECE(IBDT,".")
+3 SET RES=""
+4 SET X=""
FOR
SET X=$ORDER(^IBA(362.4,"B",IBRXN,X),-1)
if X=""
QUIT
if X
Begin DoDot:1
+5 SET IBZ=$GET(^IBA(362.4,X,0))
+6 IF $PIECE($PIECE(IBZ,U,3),".")=IBDT
IF $PIECE(IBZ,U,2)
SET RES=+$PIECE(IBZ,U,2)
End DoDot:1
if RES
QUIT
+7 QUIT RES
+8 ;
+9 ;
RXDATA(IBRX,IBFIL) ;
+1 ;RxIEN^Rx#^Fill#^RelDate^DrugIEN^BillIEN
+2 NEW IBRXN,IBDT,IBDRUG,IBBIL,DATRET
+3 SET IBRXN=$$FILE^IBRXUTL(IBRX,.01)
+4 IF IBFIL=0
SET IBDT=$$FILE^IBRXUTL(IBRX,22)
+5 IF '$TEST
SET IBDT=$$SUBFILE^IBRXUTL(IBRX,IBFIL,52,.01)
+6 SET IBDT=$PIECE(IBDT,".")
+7 SET IBDRUG=$$FILE^IBRXUTL(IBRX,6)
+8 SET IBBIL=$$BILL(IBRXN,IBDT)
+9 SET DATRET=IBRX_"^"_IBRXN_"^"_IBFIL_"^"_IBDT_"^"_IBDRUG_"^"_IBBIL
+10 QUIT DATRET
+11 ;
DISP(IBITEM) ;
+1 NEW IBD,IBBILN,IBDRUG,IBBIL
+2 SET IBD=$GET(@IBREF@(IBITEM))
if IBD=""
QUIT
+3 WRITE !,IBITEM," ",?4,$PIECE(IBD,U,2)," ",?15,$PIECE(IBD,U,3)," ",?20,$$DAT2^IBOUTL($PIECE(IBD,U,4))," "
+4 WRITE ?32,$EXTRACT($$DRUG^IBRXUTL1(+$PIECE(IBD,U,5)),1,30)
+5 SET IBBIL=$PIECE(IBD,U,6)
+6 IF IBBIL
WRITE ?64,$PIECE($GET(^DGCR(399,+IBBIL,0)),U)
IF $PIECE($GET(^DGCR(399,IBBIL,"S")),U,16)
WRITE "(canc)"
+7 QUIT
+8 ;
PARSE(X) ;
+1 NEW I,J,N
+2 SET X=$TRANSLATE(X," ")
+3 SET X=$TRANSLATE(X,";",",")
+4 IF $TRANSLATE(IBSEL,"al","AL")="ALL"
Begin DoDot:1
+5 FOR I=1:1
if '$DATA(@IBREF@(I))
QUIT
SET IBSEL(I)=""
End DoDot:1
QUIT
+6 FOR I=1:1:$LENGTH(X,",")
SET N=$PIECE(X,",",I)
if N'=""
Begin DoDot:1
+7 IF N'["-"
if N
Begin DoDot:2
+8 IF $DATA(@IBREF@(N))
SET X(N)=""
End DoDot:2
QUIT
+9 ; Processing range
+10 NEW N1,N2
+11 SET N1=+$PIECE(N,"-",1)
SET N2=+$PIECE(N,"-",2)
+12 FOR J=N1:$SELECT(N2<N1:-1,1:1):N2
IF $DATA(@IBREF@(J))
SET X(J)=""
End DoDot:1
+13 QUIT
+14 ;
PAUSE(MESSAGE) ;
+1 DO EN^DDIOL("","","!")
+2 IF $GET(MESSAGE)'=""
DO EN^DDIOL(MESSAGE)
DO EN^DDIOL(". ","","?0")
+3 DO EN^DDIOL("Press RETURN to continue: ")
+4 READ %:DTIME
+5 QUIT
+6 ;
SC(IEN) ;Service connected
+1 NEW IBT
+2 IF 'IEN
QUIT 0
+3 SET IBT=$PIECE($GET(^IBE(356.8,IEN,0)),U)
+4 IF IBT="NEEDS SC DETERMINATION"
QUIT 1
+5 IF IBT="OTHER"
QUIT 1
+6 QUIT 0
+7 ;
+8 ;
DLYRC(DFLT) ; function, ask for NCPDP field 357-NV Delay Reason Code
+1 ; DFLT = optional default value (integer from 1-14)
+2 ; returns code or "^" on time-out, etc.
+3 NEW IBDELAY,C,DIC,DIR,DIRUT,DIROUT,DUOUT,DTOUT,X,Y
+4 SET IBDELAY=""
+5 IF $GET(DFLT)?1.2N
IF DFLT>0
IF DFLT<15
SET DIR("B")=DFLT
+6 SET DIR("S")="I $P($G(^(0)),""^"",3)'=1"
+7 ; IA# TBD
SET DIR(0)="PO^9002313.29:EMZ"
DO ^DIR
KILL DIR
+8 SET IBDELAY=$SELECT($DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT):"^",1:Y)
+9 SET IBDELAY=+$PIECE((IBDELAY),"^",1)
+10 QUIT IBDELAY
+11 ;
+12 ;IBNCPBB
