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

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
 ;