- 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 Feb 18, 2025@23:51:09 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