IBCEMSR5 ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
CALCPCT ; Calculate final percentages for the Summary Report
N IBDIV,IBACCUM,IBFT,IBPERCENT
S IBDIV=""
F S IBDIV=$O(IBLTMP(IBDIV)) Q:IBDIV="" D
. F IBACCUM="SPAA","SPAB","SSAA","SSAB" F IBFT=2,3 D
.. S IBLTMP(IBDIV,IBACCUM,IBFT)="0%"
. F IBFT=2,3 D
.. I +$G(IBLTMP(IBDIV,"SPA",IBFT)) D
... S IBPERCENT=$G(IBLTMP(IBDIV,"SPAC",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
... S IBLTMP(IBDIV,"SPAA",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
... S IBPERCENT=$G(IBLTMP(IBDIV,"SPACA",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
... S IBLTMP(IBDIV,"SPAB",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
.. I +$G(IBLTMP(IBDIV,"SSA",IBFT)) D
... S IBPERCENT=$G(IBLTMP(IBDIV,"SSAC",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
... S IBLTMP(IBDIV,"SSAA",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
... S IBPERCENT=$G(IBLTMP(IBDIV,"SSACA",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
... S IBLTMP(IBDIV,"SSAB",IBFT)=$S(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$J(IBPERCENT,0,0))_"%"
Q
;
NOSUB(IBIFN) ; Check for subsequent payer or balance due.
N IBPY,IBOAM,IBX,IBTXT
I $P($$BILL^RCJIBFN2(IBIFN),U,2)=22 D
. S IBPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R IA#380
. S IBOAM=+$G(^DGCR(399,IBIFN,"U1")) ; total charges for bill
. S IBX=$$EOB^IBCNSBL2(IBIFN,IBOAM,IBPY,.IBTXT)
Q '$D(IBTXT)
;
PROCSSED(IBIFN) ;CLAIM/BILL Requests Processed?
; Search dictionary 361.1 for this CLAIM/BILL#
; If at least one request is 'processed' the CLAIM/BILL is considered processed.
N IBPSD,IEN,IBZ
S IBPSD=0
S IEN=0 F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D Q:IBPSD
. S IBZ=$G(^IBM(361.1,IEN,0))
. I $P(IBZ,U,4)'=0 Q ; Scan for only Normal EOBs (Non-MRA)
. I $P(IBZ,U,13)=1 S IBPSD=1
Q IBPSD
;
DENIED(IBIFN) ;CLAIM/BILL Requests Denied?
; Search dictionary 361.1 for this CLAIM/BILL#
; If all request are 'denied' the CLAIM/BILL is considered denied.
N IBDEN,IEN,IBZ
S IBDEN=1
S IEN=0 F S IEN=$O(^IBM(361.1,"B",+$G(IBIFN),IEN)) Q:'IEN D Q:'IBDEN
. S IBZ=$G(^IBM(361.1,IEN,0))
. I $P(IBZ,U,4)'=0 Q ; Scan for only Normal EOBs (Non-MRA)
. I $P(IBZ,U,13)'=2 S IBDEN=0
Q IBDEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMSR5 2421 printed Dec 13, 2024@02:11:08 Page 2
IBCEMSR5 ;BI/ALB - non-MRA PRODUCTIVITY REPORT ;02/14/11
+1 ;;2.0;INTEGRATED BILLING;**447**;21-MAR-94;Build 80
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
CALCPCT ; Calculate final percentages for the Summary Report
+1 NEW IBDIV,IBACCUM,IBFT,IBPERCENT
+2 SET IBDIV=""
+3 FOR
SET IBDIV=$ORDER(IBLTMP(IBDIV))
if IBDIV=""
QUIT
Begin DoDot:1
+4 FOR IBACCUM="SPAA","SPAB","SSAA","SSAB"
FOR IBFT=2,3
Begin DoDot:2
+5 SET IBLTMP(IBDIV,IBACCUM,IBFT)="0%"
End DoDot:2
+6 FOR IBFT=2,3
Begin DoDot:2
+7 IF +$GET(IBLTMP(IBDIV,"SPA",IBFT))
Begin DoDot:3
+8 SET IBPERCENT=$GET(IBLTMP(IBDIV,"SPAC",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
+9 SET IBLTMP(IBDIV,"SPAA",IBFT)=$SELECT(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$JUSTIFY(IBPERCENT,0,0))_"%"
+10 SET IBPERCENT=$GET(IBLTMP(IBDIV,"SPACA",IBFT))*100/IBLTMP(IBDIV,"SPACL",IBFT)
+11 SET IBLTMP(IBDIV,"SPAB",IBFT)=$SELECT(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$JUSTIFY(IBPERCENT,0,0))_"%"
End DoDot:3
+12 IF +$GET(IBLTMP(IBDIV,"SSA",IBFT))
Begin DoDot:3
+13 SET IBPERCENT=$GET(IBLTMP(IBDIV,"SSAC",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
+14 SET IBLTMP(IBDIV,"SSAA",IBFT)=$SELECT(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$JUSTIFY(IBPERCENT,0,0))_"%"
+15 SET IBPERCENT=$GET(IBLTMP(IBDIV,"SSACA",IBFT))*100\IBLTMP(IBDIV,"SSACL",IBFT)
+16 SET IBLTMP(IBDIV,"SSAB",IBFT)=$SELECT(((IBPERCENT>0)&(IBPERCENT<1)):"<1",1:$JUSTIFY(IBPERCENT,0,0))_"%"
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
NOSUB(IBIFN) ; Check for subsequent payer or balance due.
+1 NEW IBPY,IBOAM,IBX,IBTXT
+2 IF $PIECE($$BILL^RCJIBFN2(IBIFN),U,2)=22
Begin DoDot:1
+3 ; payment on this bill from A/R IA#380
SET IBPY=$$TPR^PRCAFN(IBIFN)
+4 ; total charges for bill
SET IBOAM=+$GET(^DGCR(399,IBIFN,"U1"))
+5 SET IBX=$$EOB^IBCNSBL2(IBIFN,IBOAM,IBPY,.IBTXT)
End DoDot:1
+6 QUIT '$DATA(IBTXT)
+7 ;
PROCSSED(IBIFN) ;CLAIM/BILL Requests Processed?
+1 ; Search dictionary 361.1 for this CLAIM/BILL#
+2 ; If at least one request is 'processed' the CLAIM/BILL is considered processed.
+3 NEW IBPSD,IEN,IBZ
+4 SET IBPSD=0
+5 SET IEN=0
FOR
SET IEN=$ORDER(^IBM(361.1,"B",+$GET(IBIFN),IEN))
if 'IEN
QUIT
Begin DoDot:1
+6 SET IBZ=$GET(^IBM(361.1,IEN,0))
+7 ; Scan for only Normal EOBs (Non-MRA)
IF $PIECE(IBZ,U,4)'=0
QUIT
+8 IF $PIECE(IBZ,U,13)=1
SET IBPSD=1
End DoDot:1
if IBPSD
QUIT
+9 QUIT IBPSD
+10 ;
DENIED(IBIFN) ;CLAIM/BILL Requests Denied?
+1 ; Search dictionary 361.1 for this CLAIM/BILL#
+2 ; If all request are 'denied' the CLAIM/BILL is considered denied.
+3 NEW IBDEN,IEN,IBZ
+4 SET IBDEN=1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^IBM(361.1,"B",+$GET(IBIFN),IEN))
if 'IEN
QUIT
Begin DoDot:1
+6 SET IBZ=$GET(^IBM(361.1,IEN,0))
+7 ; Scan for only Normal EOBs (Non-MRA)
IF $PIECE(IBZ,U,4)'=0
QUIT
+8 IF $PIECE(IBZ,U,13)'=2
SET IBDEN=0
End DoDot:1
if 'IBDEN
QUIT
+9 QUIT IBDEN
