- 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 Jan 18, 2025@03:12:21 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