IBNCPDP4 ;DALOI/AAT - HANDLE ECME EVENTS ;20-JUN-2003
;;2.0;INTEGRATED BILLING;**276,342,405,384,411,435,452**;21-MAR-94;Build 26
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;NCPDP PHASE III
Q
;
CLOSE(DFN,IBD) ; Close Claim Event
N IBADT,IBTRKR,IBTRKRN,IBRXN,IBFIL,IBEABD,IBRES,IBLOCK,IBDUZ
N IBRXTYP,IBCR,DA,DIE,DR,IBUSR
S IBDUZ=.5
S IBRES=1,IBLOCK=0
;
I 'DFN S IBRES="0^No patient" G CLOSEQ
S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G CLOSEQ
S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G CLOSEQ
S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G CLOSEQ
S IBCR=+$G(IBD("CLOSE REASON")) I 'IBCR S IBRES="0^No close reason" G CLOSEQ
I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G CLOSEQ
S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
;
; closing secondary claims should not affect CT - esg 7/8/10
I $G(IBD("RXCOB"))>1 D S IBRES=1 G CLOSEQ
. N IBACT
. ;
. ; release copay charges off hold if OPECC said to do so
. I '$G(IBD("RELEASE COPAY")) Q
. S IBACT=+$$RELCOPAY^IBNCPNB(DFN,IBRXN,IBFIL,1,IBADT,0) ; release copay charges off hold
. I IBACT=-1 D RELBUL^IBNCPEB(DFN,IBRXN,IBFIL,IBADT,IBACT,IBCR,$G(IBD("CLOSE COMMENT")),0,1) ; send msg if error
. Q
;
; -- claims tracking info
S IBTRKR=$G(^IBE(350.9,1,6))
; date can't be before parameters
S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
;
I 'IBTRKRN S IBRES="0^CT record not found" G CLOSEQ
;
D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,$G(IBD("DROP TO PAPER")),$G(IBD("RELEASE COPAY")),$G(IBD("CLOSE COMMENT")),IBUSR)
;
S DIE="^IBT(356,",DA=IBTRKRN
; add ECME #,ECME flag, remove total charges
S DR="1.1///"_IBD("CLAIMID")_";1.11///2;.29////@"
D ^DIE
;
S IBRES=1 ; OK
CLOSEQ ;
D LOG^IBNCPDP2("CLOSE",IBRES)
I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
Q IBRES
;
;
RELEASE(DFN,IBD) ;
N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKR,IBTRKRN
N IBEABD,IBNBR,DA,DIE,DR,IBUSR
S IBLOCK=0
I 'DFN S IBRES="0^No patient" G RELQ
S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G RELQ
S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G RELQ
S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RELQ
S IBRDT=+$G(IBD("RELEASE DATE"),-1) I 'IBRDT S IBRES="0^No release date" G RELQ
I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G RELQ
S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
; -- claims tracking info
S IBTRKR=$G(^IBE(350.9,1,6))
; date can't be before parameters
S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
I 'IBTRKRN S IBRES="0^No CT record found." G RELQ
;
; Remove NBR from CT and set T+60 (if not billed yet)
; Set ECME flags in CT
;
L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
S DIE="^IBT(356,",DA=IBTRKRN,DR=""
S IBNBR=+$P($G(^IBT(356,IBTRKRN,0)),U,19)
; Clean up "Rx not released"
I IBNBR,$P($G(^IBE(356.8,IBNBR,0)),U)="PRESCRIPTION NOT RELEASED" S DR=DR_".19////@;",IBNBR=""
;
; Set EABD if no bill and no NBR
I '$P($G(^IBT(356,IBTRKRN,0)),U,11),'IBNBR D
. S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
. S:'IBEABD IBEABD=DT
. S IBEABD=$$FMADD^XLFDT(IBEABD,60)
. S DR=DR_".17////^S X=IBEABD;"
;
; Set ECME Flags
S DR=DR_"1.1////"_IBD("CLAIMID")_";"
; Reject status will not be set here
;
; Check that the Date of Service is current
I IBADT'=$P(^IBT(356,IBTRKRN,0),U,6) S DR=DR_".06////"_IBADT_";"
;
D ^DIE
S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited
S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by
D FILE^DIE("","IBFDA"),MSG^DIALOG()
I IBLOCK2 L -^IBT(356,IBTRKRN)
;
S IBRES=1
RELQ ;
D LOG^IBNCPDP2("RELEASE",IBRES)
I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
Q IBRES
;
SUBMIT(DFN,IBD) ;
N IBRES,IBLOCK,IBADT,IBRXN,IBFIL,IBRDT,IBNBR,IBFLAG,IBTRKR,IBTRKRN
N IBRESP,DA,DIE,DR,IBUSR
S IBLOCK=0
I 'DFN S IBRES="0^No patient" G SUBQ
S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G SUBQ
S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G SUBQ
S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G SUBQ
S IBRESP=$G(IBD("RESPONSE")) I IBRESP="" S IBRES="0^No response from the payer" G SUBQ
S IBRDT=+$G(IBD("RELEASE DATE"),-1)
I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G SUBQ
S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
;
; -- claims tracking info
S IBTRKR=$G(^IBE(350.9,1,6))
; date can't be before parameters
S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
;
; If the Rx is not released - set NBR in CT
I 'IBRDT,'$P($G(^IBT(356,IBTRKRN,0)),U,19) D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"PRESCRIPTION NOT RELEASED","","","",IBUSR)
;
; If the Rx is released - clean up NBR in CT
I IBRDT,$P($G(^IBE(356.8,+$P($G(^IBT(356,IBTRKRN,0)),U,19),0)),U)="PRESCRIPTION NOT RELEASED" D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"","","","",IBUSR)
; Set ECME fields in CT
S DIE="^IBT(356,",DA=IBTRKRN
S IBFLAG=$S(IBRESP["REJECT":1,1:0)
S DR="1.1///"_IBD("CLAIMID")_";1.11///"_IBFLAG
D ^DIE
S IBRES=1
SUBQ ;
D LOG^IBNCPDP2("SUBMIT",IBRES)
I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
Q IBRES
;
;
REOPEN(DFN,IBD) ;
N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKRN
N IBEABD,IBNBR,DA,DIE,DR,IBUSR,IBEABD
S (IBLOCK,IBLOCK2)=0
I 'DFN S IBRES="0^No patient" G REOPQ
S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G REOPQ
S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G REOPQ
S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G REOPQ
I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G REOPQ
S IBRDT=$$RXRLDT^PSOBPSUT(IBRXN,IBFIL) ; release date (if null is returned then Rx is not released)
S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
;
; re-opening secondary claims should not affect CT - esg 7/9/10
I $G(IBD("RXCOB"))>1 S IBRES=1 G REOPQ
;
S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) ;get the claim entry associated with the Rx fill (or refill)
L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
S DIE="^IBT(356,",DA=IBTRKRN
;
I IBRDT D ; if Rx released assign earliest autobill date
. S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
. S:'IBEABD IBEABD=DT
. S IBEABD=$$FMADD^XLFDT(IBEABD,60)
;
N IBFDA
S IBFDA(356,IBTRKRN_",",.19)=$S('IBRDT:$O(^IBE(356.8,"B","PRESCRIPTION NOT RELEASED","")),1:"@") ;non-billable reason
D FILE^DIE("","IBFDA"),MSG^DIALOG()
K IBFDA
S IBFDA(356,IBTRKRN_",",.17)=$S('IBRDT:"@",1:IBEABD) ; earliest autobill date
S IBFDA(356,IBTRKRN_",",1.08)="@" ;additional comments
S IBFDA(356,IBTRKRN_",",1.11)=0 ; reject flag - reset to "no"
S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited
S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by
D FILE^DIE("","IBFDA"),MSG^DIALOG()
;
S IBRES=1
REOPQ ;
D LOG^IBNCPDP2("REOPEN",IBRES)
I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
I IBLOCK2 L -^IBT(356,IBTRKRN)
Q IBRES
;
BCID(BCID,IBADT) ; build BCID
Q BCID_";"_IBADT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDP4 7702 printed Apr 09, 2024@21:06:51 Page 2
IBNCPDP4 ;DALOI/AAT - HANDLE ECME EVENTS ;20-JUN-2003
+1 ;;2.0;INTEGRATED BILLING;**276,342,405,384,411,435,452**;21-MAR-94;Build 26
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;NCPDP PHASE III
+5 QUIT
+6 ;
CLOSE(DFN,IBD) ; Close Claim Event
+1 NEW IBADT,IBTRKR,IBTRKRN,IBRXN,IBFIL,IBEABD,IBRES,IBLOCK,IBDUZ
+2 NEW IBRXTYP,IBCR,DA,DIE,DR,IBUSR
+3 SET IBDUZ=.5
+4 SET IBRES=1
SET IBLOCK=0
+5 ;
+6 IF 'DFN
SET IBRES="0^No patient"
GOTO CLOSEQ
+7 SET IBADT=+$GET(IBD("DOS"))
IF 'IBADT
SET IBRES="0^No date of service"
GOTO CLOSEQ
+8 SET IBRXN=+$GET(IBD("PRESCRIPTION"))
IF 'IBRXN
SET IBRES="0^No Rx IEN"
GOTO CLOSEQ
+9 SET IBFIL=+$GET(IBD("FILL NUMBER"),-1)
IF IBFIL<0
SET IBRES="0^No fill number"
GOTO CLOSEQ
+10 SET IBCR=+$GET(IBD("CLOSE REASON"))
IF 'IBCR
SET IBRES="0^No close reason"
GOTO CLOSEQ
+11 IF '$LENGTH($GET(IBD("CLAIMID")))
SET IBRES="0^Missing ECME Number"
GOTO CLOSEQ
+12 SET IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
+13 SET IBUSR=$SELECT(+$GET(IBD("USER"))=0:DUZ,1:IBD("USER"))
+14 LOCK +^DGCR(399,"AG",IBD("BCID")):5
SET IBLOCK=$TEST
+15 ;
+16 ; closing secondary claims should not affect CT - esg 7/8/10
+17 IF $GET(IBD("RXCOB"))>1
Begin DoDot:1
+18 NEW IBACT
+19 ;
+20 ; release copay charges off hold if OPECC said to do so
+21 IF '$GET(IBD("RELEASE COPAY"))
QUIT
+22 ; release copay charges off hold
SET IBACT=+$$RELCOPAY^IBNCPNB(DFN,IBRXN,IBFIL,1,IBADT,0)
+23 ; send msg if error
IF IBACT=-1
DO RELBUL^IBNCPEB(DFN,IBRXN,IBFIL,IBADT,IBACT,IBCR,$GET(IBD("CLOSE COMMENT")),0,1)
+24 QUIT
End DoDot:1
SET IBRES=1
GOTO CLOSEQ
+25 ;
+26 ; -- claims tracking info
+27 SET IBTRKR=$GET(^IBE(350.9,1,6))
+28 ; date can't be before parameters
+29 SET $PIECE(IBTRKR,"^")=$SELECT('$PIECE(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
+30 SET IBTRKRN=+$ORDER(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
+31 ;
+32 IF 'IBTRKRN
SET IBRES="0^CT record not found"
GOTO CLOSEQ
+33 ;
+34 DO NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,$GET(IBD("DROP TO PAPER")),$GET(IBD("RELEASE COPAY")),$GET(IBD("CLOSE COMMENT")),IBUSR)
+35 ;
+36 SET DIE="^IBT(356,"
SET DA=IBTRKRN
+37 ; add ECME #,ECME flag, remove total charges
+38 SET DR="1.1///"_IBD("CLAIMID")_";1.11///2;.29////@"
+39 DO ^DIE
+40 ;
+41 ; OK
SET IBRES=1
CLOSEQ ;
+1 DO LOG^IBNCPDP2("CLOSE",IBRES)
+2 IF IBLOCK
LOCK -^DGCR(399,"AG",IBD("BCID"))
+3 QUIT IBRES
+4 ;
+5 ;
RELEASE(DFN,IBD) ;
+1 NEW IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKR,IBTRKRN
+2 NEW IBEABD,IBNBR,DA,DIE,DR,IBUSR
+3 SET IBLOCK=0
+4 IF 'DFN
SET IBRES="0^No patient"
GOTO RELQ
+5 SET IBADT=+$GET(IBD("DOS"))
IF 'IBADT
SET IBRES="0^No date of service"
GOTO RELQ
+6 SET IBRXN=+$GET(IBD("PRESCRIPTION"))
IF 'IBRXN
SET IBRES="0^No Rx IEN"
GOTO RELQ
+7 SET IBFIL=+$GET(IBD("FILL NUMBER"),-1)
IF IBFIL<0
SET IBRES="0^No fill number"
GOTO RELQ
+8 SET IBRDT=+$GET(IBD("RELEASE DATE"),-1)
IF 'IBRDT
SET IBRES="0^No release date"
GOTO RELQ
+9 IF '$LENGTH($GET(IBD("CLAIMID")))
SET IBRES="0^Missing ECME Number"
GOTO RELQ
+10 SET IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
+11 SET IBUSR=$SELECT(+$GET(IBD("USER"))=0:DUZ,1:IBD("USER"))
+12 LOCK +^DGCR(399,"AG",IBD("BCID")):5
SET IBLOCK=$TEST
+13 ; -- claims tracking info
+14 SET IBTRKR=$GET(^IBE(350.9,1,6))
+15 ; date can't be before parameters
+16 SET $PIECE(IBTRKR,"^")=$SELECT('$PIECE(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
+17 SET IBTRKRN=+$ORDER(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
+18 IF 'IBTRKRN
SET IBRES="0^No CT record found."
GOTO RELQ
+19 ;
+20 ; Remove NBR from CT and set T+60 (if not billed yet)
+21 ; Set ECME flags in CT
+22 ;
+23 LOCK +^IBT(356,IBTRKRN):5
SET IBLOCK2=$TEST
+24 SET DIE="^IBT(356,"
SET DA=IBTRKRN
SET DR=""
+25 SET IBNBR=+$PIECE($GET(^IBT(356,IBTRKRN,0)),U,19)
+26 ; Clean up "Rx not released"
+27 IF IBNBR
IF $PIECE($GET(^IBE(356.8,IBNBR,0)),U)="PRESCRIPTION NOT RELEASED"
SET DR=DR_".19////@;"
SET IBNBR=""
+28 ;
+29 ; Set EABD if no bill and no NBR
+30 IF '$PIECE($GET(^IBT(356,IBTRKRN,0)),U,11)
IF 'IBNBR
Begin DoDot:1
+31 SET IBEABD=$$EABD^IBTUTL($ORDER(^IBE(356.6,"AC",4,0)),IBADT)
+32 if 'IBEABD
SET IBEABD=DT
+33 SET IBEABD=$$FMADD^XLFDT(IBEABD,60)
+34 SET DR=DR_".17////^S X=IBEABD;"
End DoDot:1
+35 ;
+36 ; Set ECME Flags
+37 SET DR=DR_"1.1////"_IBD("CLAIMID")_";"
+38 ; Reject status will not be set here
+39 ;
+40 ; Check that the Date of Service is current
+41 IF IBADT'=$PIECE(^IBT(356,IBTRKRN,0),U,6)
SET DR=DR_".06////"_IBADT_";"
+42 ;
+43 DO ^DIE
+44 ; date last edited
SET IBFDA(356,IBTRKRN_",",1.03)=DT
+45 ; last edited by
SET IBFDA(356,IBTRKRN_",",1.04)=IBUSR
+46 DO FILE^DIE("","IBFDA")
DO MSG^DIALOG()
+47 IF IBLOCK2
LOCK -^IBT(356,IBTRKRN)
+48 ;
+49 SET IBRES=1
RELQ ;
+1 DO LOG^IBNCPDP2("RELEASE",IBRES)
+2 IF IBLOCK
LOCK -^DGCR(399,"AG",IBD("BCID"))
+3 QUIT IBRES
+4 ;
SUBMIT(DFN,IBD) ;
+1 NEW IBRES,IBLOCK,IBADT,IBRXN,IBFIL,IBRDT,IBNBR,IBFLAG,IBTRKR,IBTRKRN
+2 NEW IBRESP,DA,DIE,DR,IBUSR
+3 SET IBLOCK=0
+4 IF 'DFN
SET IBRES="0^No patient"
GOTO SUBQ
+5 SET IBADT=+$GET(IBD("DOS"))
IF 'IBADT
SET IBRES="0^No date of service"
GOTO SUBQ
+6 SET IBRXN=+$GET(IBD("PRESCRIPTION"))
IF 'IBRXN
SET IBRES="0^No Rx IEN"
GOTO SUBQ
+7 SET IBFIL=+$GET(IBD("FILL NUMBER"),-1)
IF IBFIL<0
SET IBRES="0^No fill number"
GOTO SUBQ
+8 SET IBRESP=$GET(IBD("RESPONSE"))
IF IBRESP=""
SET IBRES="0^No response from the payer"
GOTO SUBQ
+9 SET IBRDT=+$GET(IBD("RELEASE DATE"),-1)
+10 IF '$LENGTH($GET(IBD("CLAIMID")))
SET IBRES="0^Missing ECME Number"
GOTO SUBQ
+11 SET IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
+12 SET IBUSR=$SELECT(+$GET(IBD("USER"))=0:DUZ,1:IBD("USER"))
+13 LOCK +^DGCR(399,"AG",IBD("BCID")):5
SET IBLOCK=$TEST
+14 ;
+15 ; -- claims tracking info
+16 SET IBTRKR=$GET(^IBE(350.9,1,6))
+17 ; date can't be before parameters
+18 SET $PIECE(IBTRKR,"^")=$SELECT('$PIECE(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
+19 SET IBTRKRN=+$ORDER(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
+20 ;
+21 ; If the Rx is not released - set NBR in CT
+22 IF 'IBRDT
IF '$PIECE($GET(^IBT(356,IBTRKRN,0)),U,19)
DO NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"PRESCRIPTION NOT RELEASED","","","",IBUSR)
+23 ;
+24 ; If the Rx is released - clean up NBR in CT
+25 IF IBRDT
IF $PIECE($GET(^IBE(356.8,+$PIECE($GET(^IBT(356,IBTRKRN,0)),U,19),0)),U)="PRESCRIPTION NOT RELEASED"
DO NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"","","","",IBUSR)
+26 ; Set ECME fields in CT
+27 SET DIE="^IBT(356,"
SET DA=IBTRKRN
+28 SET IBFLAG=$SELECT(IBRESP["REJECT":1,1:0)
+29 SET DR="1.1///"_IBD("CLAIMID")_";1.11///"_IBFLAG
+30 DO ^DIE
+31 SET IBRES=1
SUBQ ;
+1 DO LOG^IBNCPDP2("SUBMIT",IBRES)
+2 IF IBLOCK
LOCK -^DGCR(399,"AG",IBD("BCID"))
+3 QUIT IBRES
+4 ;
+5 ;
REOPEN(DFN,IBD) ;
+1 NEW IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKRN
+2 NEW IBEABD,IBNBR,DA,DIE,DR,IBUSR,IBEABD
+3 SET (IBLOCK,IBLOCK2)=0
+4 IF 'DFN
SET IBRES="0^No patient"
GOTO REOPQ
+5 SET IBADT=+$GET(IBD("DOS"))
IF 'IBADT
SET IBRES="0^No date of service"
GOTO REOPQ
+6 SET IBRXN=+$GET(IBD("PRESCRIPTION"))
IF 'IBRXN
SET IBRES="0^No Rx IEN"
GOTO REOPQ
+7 SET IBFIL=+$GET(IBD("FILL NUMBER"),-1)
IF IBFIL<0
SET IBRES="0^No fill number"
GOTO REOPQ
+8 IF '$LENGTH($GET(IBD("CLAIMID")))
SET IBRES="0^Missing ECME Number"
GOTO REOPQ
+9 ; release date (if null is returned then Rx is not released)
SET IBRDT=$$RXRLDT^PSOBPSUT(IBRXN,IBFIL)
+10 SET IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
+11 SET IBUSR=$SELECT(+$GET(IBD("USER"))=0:DUZ,1:IBD("USER"))
+12 LOCK +^DGCR(399,"AG",IBD("BCID")):5
SET IBLOCK=$TEST
+13 ;
+14 ; re-opening secondary claims should not affect CT - esg 7/9/10
+15 IF $GET(IBD("RXCOB"))>1
SET IBRES=1
GOTO REOPQ
+16 ;
+17 ;get the claim entry associated with the Rx fill (or refill)
SET IBTRKRN=+$ORDER(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
+18 LOCK +^IBT(356,IBTRKRN):5
SET IBLOCK2=$TEST
+19 SET DIE="^IBT(356,"
SET DA=IBTRKRN
+20 ;
+21 ; if Rx released assign earliest autobill date
IF IBRDT
Begin DoDot:1
+22 SET IBEABD=$$EABD^IBTUTL($ORDER(^IBE(356.6,"AC",4,0)),IBADT)
+23 if 'IBEABD
SET IBEABD=DT
+24 SET IBEABD=$$FMADD^XLFDT(IBEABD,60)
End DoDot:1
+25 ;
+26 NEW IBFDA
+27 ;non-billable reason
SET IBFDA(356,IBTRKRN_",",.19)=$SELECT('IBRDT:$ORDER(^IBE(356.8,"B","PRESCRIPTION NOT RELEASED","")),1:"@")
+28 DO FILE^DIE("","IBFDA")
DO MSG^DIALOG()
+29 KILL IBFDA
+30 ; earliest autobill date
SET IBFDA(356,IBTRKRN_",",.17)=$SELECT('IBRDT:"@",1:IBEABD)
+31 ;additional comments
SET IBFDA(356,IBTRKRN_",",1.08)="@"
+32 ; reject flag - reset to "no"
SET IBFDA(356,IBTRKRN_",",1.11)=0
+33 ; date last edited
SET IBFDA(356,IBTRKRN_",",1.03)=DT
+34 ; last edited by
SET IBFDA(356,IBTRKRN_",",1.04)=IBUSR
+35 DO FILE^DIE("","IBFDA")
DO MSG^DIALOG()
+36 ;
+37 SET IBRES=1
REOPQ ;
+1 DO LOG^IBNCPDP2("REOPEN",IBRES)
+2 IF IBLOCK
LOCK -^DGCR(399,"AG",IBD("BCID"))
+3 IF IBLOCK2
LOCK -^IBT(356,IBTRKRN)
+4 QUIT IBRES
+5 ;
BCID(BCID,IBADT) ; build BCID
+1 QUIT BCID_";"_IBADT
