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

IBCEMSR5.m

Go to the documentation of this file.
  1. IBCEMSR5 ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
  1. ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. Q
  1. ;
  1. CALCPCT ; Calculate final percentages for the Summary Report
  1. N IBDIV,IBACCUM,IBFT,IBPERCENT
  1. S IBDIV=""
  1. F S IBDIV=$O(IBLTMP(IBDIV)) Q:IBDIV="" D
  1. . F IBACCUM="SPAA","SPAB","SSAA","SSAB" F IBFT=2,3 D
  1. .. S IBLTMP(IBDIV,IBACCUM,IBFT)="0%"
  1. . F IBFT=2,3 D
  1. .. I +$G(IBLTMP(IBDIV,"SPA",IBFT)) D
  1. ... S IBPERCENT=$G(IBLTMP(IBDIV,"SPAC",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
  1. ... S IBLTMP(IBDIV,"SPAA",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
  1. ... S IBPERCENT=$G(IBLTMP(IBDIV,"SPACA",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
  1. ... S IBLTMP(IBDIV,"SPAB",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
  1. .. I +$G(IBLTMP(IBDIV,"SSA",IBFT)) D
  1. ... S IBPERCENT=$G(IBLTMP(IBDIV,"SSAC",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
  1. ... S IBLTMP(IBDIV,"SSAA",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
  1. ... S IBPERCENT=$G(IBLTMP(IBDIV,"SSACA",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
  1. ... S IBLTMP(IBDIV,"SSAB",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
  1. Q
  1. ;
  1. NOSUB(IBIFN) ; Check for subsequent payer or balance due.
  1. N IBPY,IBOAM,IBX,IBTXT
  1. I $P($$BILL^RCJIBFN2(IBIFN),U,2)=22 D
  1. . S IBPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R IA#380
  1. . S IBOAM=+$G(^DGCR(399,IBIFN,"U1")) ; total charges for bill
  1. . S IBX=$$EOB^IBCNSBL2(IBIFN,IBOAM,IBPY,.IBTXT)
  1. Q '$D(IBTXT)
  1. ;
  1. PROCSSED(IBIFN) ;CLAIM/BILL Requests Processed?
  1. ; Search dictionary 361.1 for this CLAIM/BILL#
  1. ; If at least one request is 'processed' the CLAIM/BILL is considered processed.
  1. N IBPSD,IEN,IBZ
  1. S IBPSD=0
  1. S IEN=0 F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D Q:IBPSD
  1. . S IBZ=$G(^IBM(361.1,IEN,0))
  1. . I $P(IBZ,U,4)'=0 Q ; Scan for only Normal EOBs (Non-MRA)
  1. . I $P(IBZ,U,13)=1 S IBPSD=1
  1. Q IBPSD
  1. ;
  1. DENIED(IBIFN) ;CLAIM/BILL Requests Denied?
  1. ; Search dictionary 361.1 for this CLAIM/BILL#
  1. ; If all request are 'denied' the CLAIM/BILL is considered denied.
  1. N IBDEN,IEN,IBZ
  1. S IBDEN=1
  1. S IEN=0 F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D Q:'IBDEN
  1. . S IBZ=$G(^IBM(361.1,IEN,0))
  1. . I $P(IBZ,U,4)'=0 Q ; Scan for only Normal EOBs (Non-MRA)
  1. . I $P(IBZ,U,13)'=2 S IBDEN=0
  1. Q IBDEN