source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEDC.m@ 1088

IBCEDC  ;ALB/ESG - EDI CLAIM STATUS REPORT COMPILE ;13-DEC-2007
        ;;2.0;INTEGRATED BILLING;**377**;21-MAR-94;Build 23
        ;;Per VHA Directive 2004-038, this routine should not be modified.
        ;
        Q
        ;
EN      ; Compile entry point - Queued Job Entry Point
        NEW BCHIEN,COUNT,DT1,DT2,IBIFN,IBLTRDT,IEN
        K ^TMP($J,"IBCEDC")
        I '$D(ZTQUEUED) W !!,"Compiling EDI Claim Status Report.  Please wait "
        ;
        I IBMETHOD="C" G EN1     ; specific claims selected
        ;
        ; get dates and loop thru ALT area
        S DT1=$G(^TMP($J,"IBCEDS","ALTDT"))
        S DT2=$P(DT1,U,2),DT1=$P(DT1,U,1)
        S IBLTRDT=$O(^IBA(364.1,"ALT",DT1),-1)  ; get starting point
        F  S IBLTRDT=$O(^IBA(364.1,"ALT",IBLTRDT)) Q:'IBLTRDT!(IBLTRDT\1>DT2)!$G(ZTSTOP)  D
        . S BCHIEN=0
        . F  S BCHIEN=$O(^IBA(364.1,"ALT",IBLTRDT,BCHIEN)) Q:'BCHIEN!$G(ZTSTOP)  D
        .. S IEN=0
        .. F  S IEN=$O(^IBA(364,"C",BCHIEN,IEN)) Q:'IEN!$G(ZTSTOP)  D COMPILE(IEN)
        .. Q
        . Q
        G RPT
        ;
        ;
EN1     ; specific claims selected so loop thru all EDI claims in file 364
        ; for these claims
        ;
        S IBIFN=0
        F  S IBIFN=$O(^TMP($J,"IBCEDS","CLAIM",IBIFN)) Q:'IBIFN!$G(ZTSTOP)  D
        . S IEN=0
        . F  S IEN=$O(^IBA(364,"B",IBIFN,IEN)) Q:'IEN!$G(ZTSTOP)  D
        .. S BCHIEN=+$P($G(^IBA(364,IEN,0)),U,2)         ; batch ien
        .. S IBLTRDT=$P($G(^IBA(364.1,BCHIEN,1)),U,3)    ; date/time last transmitted
        .. D COMPILE(IEN)
        .. Q
        . Q
        G RPT
        ;
        ;
RPT     ; print the report and close things down
        D PRINT^IBCEDP                          ; print report
        D ^%ZISC                                ; close the device
        K ^TMP($J,"IBCEDS"),^TMP($J,"IBCEDC")   ; clean up scratch globals
        I $D(ZTQUEUED) S ZTREQ="@"              ; purge the task record
        ;
EX      ; routine exit point
        ;
        Q
        ;
COMPILE(IEN)    ; gather and compile EDI claim data for one EDI claim
        ; IEN - 364 ien
        NEW AR,DIV,IB0,IBAGE,IBAGEDT,IBARSTAT,IBCURBAL,IBDIV,IBDIVID,IBEDIST
        NEW IBEXTCLM,IBIFN,IBPAY,IBS,IBSGD,IBSTAT,IBZ,INS,STAT,SV1,SV2,SV3
        S COUNT=$G(COUNT)+1
        I COUNT#1000=0 D  I $G(ZTSTOP) G COMPX
        . I $D(ZTQUEUED),$$S^%ZTLOAD() S ZTSTOP=1 Q   ; check for TM stop request
        . I '$D(ZTQUEUED) W "."                       ; display progress indicator
        . Q
        S IBZ=$G(^IBA(364,IEN,0)) I IBZ="" G COMPX
        S IBIFN=+IBZ
        S IB0=$G(^DGCR(399,IBIFN,0)) I IB0="" G COMPX
        S DIV=+$P(IB0,U,22)                           ; division ien
        S INS=+$$FINDINS^IBCEF1(IBIFN,$P(IBZ,U,8))    ; insurance company ien for this EDI transmission
        S STAT=$P(IBZ,U,3)                            ; edi status code
        S AR=$P($$BILL^RCJIBFN2(IBIFN),U,2)           ; current AR status ien
        S IBARSTAT=$P($G(^PRCA(430.3,AR,0)),U,2)      ; current AR status abbr/sort value
        ;
        I IBMETHOD="R",'$$CHECK(IB0,DIV,INS,STAT,IBARSTAT) G COMPX   ; failed selection criteria checks
        ;
        S IBPAY=$P($G(^DIC(36,INS,0)),U,1)_U_INS  ; payer name^insurance company ien
        S IBDIVID=$P($G(^DG(40.8,DIV,0)),U,2)     ; division id#
        S IBDIV=IBDIVID                           ; division sort value
        S IBEXTCLM=$P(IB0,U,1)                    ; claim#
        S IBEDIST=STAT                            ; edi status sort value
        S IBCURBAL=$G(^DGCR(399,IBIFN,"U1"))
        S IBCURBAL=$P(IBCURBAL,U,1)-$P(IBCURBAL,U,2)   ; current balance (total charges - offset)
        ;
        ; calculate age
        S IBS=$G(^DGCR(399,IBIFN,"S"))
        ; if the payer is Medicare and an MRA request date exists then use that date
        I $$MCRWNR^IBEFUNC(INS),$P(IBS,U,7) S IBAGEDT=$P(IBS,U,7)
        E  S IBAGEDT=$P(IBS,U,10)     ; otherwise use the Authorization Date
        I 'IBAGEDT S IBAGEDT=$P(IBS,U,1)   ; if error, use date entered
        I 'IBAGEDT S IBAGEDT=$P($G(^DGCR(399,IBIFN,"U")),U,1)    ; if error again, use from date on claim
        S IBAGE=$$FMDIFF^XLFDT(DT,IBAGEDT)
        ;
        ; capture IB status abbr
        S IBSTAT=$P(IB0,U,13)
        S IBSTAT=$S(IBSTAT=2:"REQ MRA",IBSTAT=4:"PRNT/TX",IBSTAT=7:"CANCEL",1:$$EXTERNAL^DILFD(399,.13,,IBSTAT))
        ;
        ; Build the scratch global
        S IBSGD=IBEXTCLM_U_$$FT^IBCEF(IBIFN)_U_$$INPAT^IBCEF(IBIFN)_U_$P(IBZ,U,8)_U_STAT_U_IBLTRDT_U_IBAGE_U_+$P(IBZ,U,2)
        S IBSGD=IBSGD_U_IBCURBAL_U_DIV_U_IBARSTAT_U_INS_U_IBSTAT
        S SV1=$$SV^IBCEDS1($G(IBSORT1),IEN)
        S SV2=$$SV^IBCEDS1($G(IBSORT2),IEN)
        S SV3=$$SV^IBCEDS1($G(IBSORT3),IEN)
        S ^TMP($J,"IBCEDC",SV1,SV2,SV3,IEN)=IBSGD
        ;
COMPX   ;
        Q
        ;
CHECK(IB0,DIV,INS,STAT,IBARSTAT)        ; check to see if EDI claim passes the selection criteria
        ; function value =1 if passed checks
        ; function value =0 if failed checks
        NEW OK,EDI,PROFID,INSTID S OK=0
        I STAT="" S STAT="~~~~"
        I $D(^TMP($J,"IBCEDS","DIV")),'$D(^TMP($J,"IBCEDS","DIV",DIV)) S OK=0 G CHECKX    ; division check
        I $D(^TMP($J,"IBCEDS","EDI")),'$D(^TMP($J,"IBCEDS","EDI",STAT)) S OK=0 G CHECKX   ; EDI status check
        ;
        ; IB cancelled claim check
        I $P(IB0,U,13)=7,'$G(^TMP($J,"IBCEDS","CANCEL")) S OK=0 G CHECKX
        ;
        ; AR cancelled claim check
        I $F(".CB.CN.","."_IBARSTAT_"."),'$G(^TMP($J,"IBCEDS","CANCEL")) S OK=0 G CHECKX
        ;
        ; payer check
        I $D(^TMP($J,"IBCEDS","INS")) D  I 'OK G CHECKX
        . S OK=0
        . I 'INS Q   ; don't include if the payer isn't valid
        . I $D(^TMP($J,"IBCEDS","INS",1,INS)) S OK=1 Q
        . I '$D(^TMP($J,"IBCEDS","INS",2)) Q
        . S EDI=$$UP^XLFSTR($G(^DIC(36,INS,3)))
        . S PROFID=$P(EDI,U,2),INSTID=$P(EDI,U,4)
        . I PROFID'="",$D(^TMP($J,"IBCEDS","INS",2,PROFID)) S OK=1 Q
        . I INSTID'="",$D(^TMP($J,"IBCEDS","INS",2,INSTID)) S OK=1 Q
        . Q
        ;
        ; all checks passed OK
        S OK=1
        ;
CHECKX  ;
        Q OK
        ;