Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBNCPDP4

IBNCPDP4.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;NCPDP PHASE III
  1. Q
  1. ;
  1. CLOSE(DFN,IBD) ; Close Claim Event
  1. N IBADT,IBTRKR,IBTRKRN,IBRXN,IBFIL,IBEABD,IBRES,IBLOCK,IBDUZ
  1. N IBRXTYP,IBCR,DA,DIE,DR,IBUSR
  1. S IBDUZ=.5
  1. S IBRES=1,IBLOCK=0
  1. ;
  1. I 'DFN S IBRES="0^No patient" G CLOSEQ
  1. S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G CLOSEQ
  1. S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G CLOSEQ
  1. S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G CLOSEQ
  1. S IBCR=+$G(IBD("CLOSE REASON")) I 'IBCR S IBRES="0^No close reason" G CLOSEQ
  1. I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G CLOSEQ
  1. S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
  1. S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
  1. L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
  1. ;
  1. ; closing secondary claims should not affect CT - esg 7/8/10
  1. I $G(IBD("RXCOB"))>1 D S IBRES=1 G CLOSEQ
  1. . N IBACT
  1. . ;
  1. . ; release copay charges off hold if OPECC said to do so
  1. . I '$G(IBD("RELEASE COPAY")) Q
  1. . S IBACT=+$$RELCOPAY^IBNCPNB(DFN,IBRXN,IBFIL,1,IBADT,0) ; release copay charges off hold
  1. . I IBACT=-1 D RELBUL^IBNCPEB(DFN,IBRXN,IBFIL,IBADT,IBACT,IBCR,$G(IBD("CLOSE COMMENT")),0,1) ; send msg if error
  1. . Q
  1. ;
  1. ; -- claims tracking info
  1. S IBTRKR=$G(^IBE(350.9,1,6))
  1. ; date can't be before parameters
  1. S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
  1. S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
  1. ;
  1. I 'IBTRKRN S IBRES="0^CT record not found" G CLOSEQ
  1. ;
  1. D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,$G(IBD("DROP TO PAPER")),$G(IBD("RELEASE COPAY")),$G(IBD("CLOSE COMMENT")),IBUSR)
  1. ;
  1. S DIE="^IBT(356,",DA=IBTRKRN
  1. ; add ECME #,ECME flag, remove total charges
  1. S DR="1.1///"_IBD("CLAIMID")_";1.11///2;.29////@"
  1. D ^DIE
  1. ;
  1. S IBRES=1 ; OK
  1. CLOSEQ ;
  1. D LOG^IBNCPDP2("CLOSE",IBRES)
  1. I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
  1. Q IBRES
  1. ;
  1. ;
  1. RELEASE(DFN,IBD) ;
  1. N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKR,IBTRKRN
  1. N IBEABD,IBNBR,DA,DIE,DR,IBUSR
  1. S IBLOCK=0
  1. I 'DFN S IBRES="0^No patient" G RELQ
  1. S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G RELQ
  1. S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G RELQ
  1. S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RELQ
  1. S IBRDT=+$G(IBD("RELEASE DATE"),-1) I 'IBRDT S IBRES="0^No release date" G RELQ
  1. I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G RELQ
  1. S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
  1. S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
  1. L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
  1. ; -- claims tracking info
  1. S IBTRKR=$G(^IBE(350.9,1,6))
  1. ; date can't be before parameters
  1. S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
  1. S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
  1. I 'IBTRKRN S IBRES="0^No CT record found." G RELQ
  1. ;
  1. ; Remove NBR from CT and set T+60 (if not billed yet)
  1. ; Set ECME flags in CT
  1. ;
  1. L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
  1. S DIE="^IBT(356,",DA=IBTRKRN,DR=""
  1. S IBNBR=+$P($G(^IBT(356,IBTRKRN,0)),U,19)
  1. ; Clean up "Rx not released"
  1. I IBNBR,$P($G(^IBE(356.8,IBNBR,0)),U)="PRESCRIPTION NOT RELEASED" S DR=DR_".19////@;",IBNBR=""
  1. ;
  1. ; Set EABD if no bill and no NBR
  1. I '$P($G(^IBT(356,IBTRKRN,0)),U,11),'IBNBR D
  1. . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
  1. . S:'IBEABD IBEABD=DT
  1. . S IBEABD=$$FMADD^XLFDT(IBEABD,60)
  1. . S DR=DR_".17////^S X=IBEABD;"
  1. ;
  1. ; Set ECME Flags
  1. S DR=DR_"1.1////"_IBD("CLAIMID")_";"
  1. ; Reject status will not be set here
  1. ;
  1. ; Check that the Date of Service is current
  1. I IBADT'=$P(^IBT(356,IBTRKRN,0),U,6) S DR=DR_".06////"_IBADT_";"
  1. ;
  1. D ^DIE
  1. S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited
  1. S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by
  1. D FILE^DIE("","IBFDA"),MSG^DIALOG()
  1. I IBLOCK2 L -^IBT(356,IBTRKRN)
  1. ;
  1. S IBRES=1
  1. RELQ ;
  1. D LOG^IBNCPDP2("RELEASE",IBRES)
  1. I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
  1. Q IBRES
  1. ;
  1. SUBMIT(DFN,IBD) ;
  1. N IBRES,IBLOCK,IBADT,IBRXN,IBFIL,IBRDT,IBNBR,IBFLAG,IBTRKR,IBTRKRN
  1. N IBRESP,DA,DIE,DR,IBUSR
  1. S IBLOCK=0
  1. I 'DFN S IBRES="0^No patient" G SUBQ
  1. S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G SUBQ
  1. S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G SUBQ
  1. S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G SUBQ
  1. S IBRESP=$G(IBD("RESPONSE")) I IBRESP="" S IBRES="0^No response from the payer" G SUBQ
  1. S IBRDT=+$G(IBD("RELEASE DATE"),-1)
  1. I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G SUBQ
  1. S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
  1. S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
  1. L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
  1. ;
  1. ; -- claims tracking info
  1. S IBTRKR=$G(^IBE(350.9,1,6))
  1. ; date can't be before parameters
  1. S $P(IBTRKR,"^")=$S('$P(IBTRKR,"^",4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
  1. S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
  1. ;
  1. ; If the Rx is not released - set NBR in CT
  1. I 'IBRDT,'$P($G(^IBT(356,IBTRKRN,0)),U,19) D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,"PRESCRIPTION NOT RELEASED","","","",IBUSR)
  1. ;
  1. ; If the Rx is released - clean up NBR in CT
  1. 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)
  1. ; Set ECME fields in CT
  1. S DIE="^IBT(356,",DA=IBTRKRN
  1. S IBFLAG=$S(IBRESP["REJECT":1,1:0)
  1. S DR="1.1///"_IBD("CLAIMID")_";1.11///"_IBFLAG
  1. D ^DIE
  1. S IBRES=1
  1. SUBQ ;
  1. D LOG^IBNCPDP2("SUBMIT",IBRES)
  1. I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
  1. Q IBRES
  1. ;
  1. ;
  1. REOPEN(DFN,IBD) ;
  1. N IBRES,IBADT,IBRXN,IBFIL,IBRDT,IBLOCK,IBLOCK2,IBTRKRN
  1. N IBEABD,IBNBR,DA,DIE,DR,IBUSR,IBEABD
  1. S (IBLOCK,IBLOCK2)=0
  1. I 'DFN S IBRES="0^No patient" G REOPQ
  1. S IBADT=+$G(IBD("DOS")) I 'IBADT S IBRES="0^No date of service" G REOPQ
  1. S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBRES="0^No Rx IEN" G REOPQ
  1. S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G REOPQ
  1. I '$L($G(IBD("CLAIMID"))) S IBRES="0^Missing ECME Number" G REOPQ
  1. S IBRDT=$$RXRLDT^PSOBPSUT(IBRXN,IBFIL) ; release date (if null is returned then Rx is not released)
  1. S IBD("BCID")=$$BCID(IBD("CLAIMID"),IBADT)
  1. S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
  1. L +^DGCR(399,"AG",IBD("BCID")):5 S IBLOCK=$T
  1. ;
  1. ; re-opening secondary claims should not affect CT - esg 7/9/10
  1. I $G(IBD("RXCOB"))>1 S IBRES=1 G REOPQ
  1. ;
  1. S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0)) ;get the claim entry associated with the Rx fill (or refill)
  1. L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
  1. S DIE="^IBT(356,",DA=IBTRKRN
  1. ;
  1. I IBRDT D ; if Rx released assign earliest autobill date
  1. . S IBEABD=$$EABD^IBTUTL($O(^IBE(356.6,"AC",4,0)),IBADT)
  1. . S:'IBEABD IBEABD=DT
  1. . S IBEABD=$$FMADD^XLFDT(IBEABD,60)
  1. ;
  1. N IBFDA
  1. S IBFDA(356,IBTRKRN_",",.19)=$S('IBRDT:$O(^IBE(356.8,"B","PRESCRIPTION NOT RELEASED","")),1:"@") ;non-billable reason
  1. D FILE^DIE("","IBFDA"),MSG^DIALOG()
  1. K IBFDA
  1. S IBFDA(356,IBTRKRN_",",.17)=$S('IBRDT:"@",1:IBEABD) ; earliest autobill date
  1. S IBFDA(356,IBTRKRN_",",1.08)="@" ;additional comments
  1. S IBFDA(356,IBTRKRN_",",1.11)=0 ; reject flag - reset to "no"
  1. S IBFDA(356,IBTRKRN_",",1.03)=DT ; date last edited
  1. S IBFDA(356,IBTRKRN_",",1.04)=IBUSR ; last edited by
  1. D FILE^DIE("","IBFDA"),MSG^DIALOG()
  1. ;
  1. S IBRES=1
  1. REOPQ ;
  1. D LOG^IBNCPDP2("REOPEN",IBRES)
  1. I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
  1. I IBLOCK2 L -^IBT(356,IBTRKRN)
  1. Q IBRES
  1. ;
  1. BCID(BCID,IBADT) ; build BCID
  1. Q BCID_";"_IBADT