RCDPRU2 ;AITC/CJE - CARC REPORT ON PAYER OR CARC CODE ;
;;4.5;Accounts Receivable;**321**;;Build 48
;;Per VA Directive 6402, this routine should not be modified.
Q
; PRCA*4.5*321 - CARC and Payer report utilities
;
; Moved from RCDPARC to RCDPRU then to RCDPRU2 - PRCA*4.5*321
SUM(ARRAY,IEN,BILL,CARC,PAYER,BAMT,PAMT,DESC,AAMT,SORT) ; EP
; Count Claims and summarize for the report
; IEN: IEN from 361.1 file; BILL: The K-Bill number; ITEM: Top level sort item PAYER or CARC to summarize;
; BAMT: Billed Amount; PAMT: Paid Amount ; AAMT: Adjustment Amount;
; LVL: second level sort (CARC/Payer) ; SORT: "C" is CARC or "P" is Payer first level sort,
N ITEM,LVL
I SORT="C" S ITEM=CARC,LVL=PAYER
E S ITEM=PAYER,LVL=CARC
;
D:$G(@ARRAY@("~~SUM",ITEM,IEN))'=1 ; If we already counted this claim for CARC or Payer skip
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM"),U,1)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM")),U,1)+1 ; Count claims
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM"),U,2)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM")),U,2)+BAMT ; Summarize amount billed
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM"),U,3)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM")),U,3)+PAMT ; Summarize amount paid
; Always add in the adjustment (this is a different adjustment each time procedure is called)
S $P(@ARRAY@("REPORT",ITEM,"~~SUM"),U,4)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM")),U,4)+AAMT ; Summarize amount adjusted
S:SORT="C" $P(@ARRAY@("REPORT",ITEM,"~~SUM"),U,5)=$G(DESC) ; CARC Description
I (SORT="C")&($G(LVL)'="") D:$G(@ARRAY@("~~SUM",ITEM,IEN))'=1
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,1)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,1)+1 ; Count claims
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,2)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,2)+BAMT ; Summarize amount billed
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,3)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,3)+PAMT ; Summarize amount paid
;I $G(LVL)'="" D:$G(@ARRAY@("~~SUM",LVL,IEN))'=1
I (SORT="P")&($G(LVL)'="") D:$G(@ARRAY@("~~SUM",ITEM,IEN,LVL))'=1
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,1)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,1)+1 ; Count claims
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,2)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,2)+BAMT ; Summarize amount billed
. S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,3)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,3)+PAMT ; Summarize amount paid
; Always add in the adjustment (this is a different adjustment each time procedure is called)
S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,4)=$P($G(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,4)+AAMT ; Summarize amount adjusted
I SORT="P",$G(LVL)'="" S $P(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,5)=DESC ; CARC Description
; Get grand totals for report
D:$G(@ARRAY@("~~SUM",BILL))'=1
. S $P(@ARRAY@("~~SUM","CLAIMS"),U,1)=$P($G(@ARRAY@("~~SUM","CLAIMS")),U,1)+1
. S $P(@ARRAY@("~~SUM","CLAIMS"),U,2)=$P($G(@ARRAY@("~~SUM","CLAIMS")),U,2)+BAMT
. S $P(@ARRAY@("~~SUM","CLAIMS"),U,3)=$P($G(@ARRAY@("~~SUM","CLAIMS")),U,3)+PAMT
; May have more than one adjustment on a bill
I $G(@ARRAY@("~~SUM",BILL,ITEM))'=1 S $P(@ARRAY@("~~SUM","CLAIMS"),U,4)=$P($G(@ARRAY@("~~SUM","CLAIMS")),U,4)+AAMT ;W "BILL: ",BILL," ITEM: ",ITEM," Adj: ",AAMT,!
; Set markers so we don't double count a claim
S @ARRAY@("~~SUM",ITEM,BILL)=1,@ARRAY@("~~SUM",ITEM,IEN)=1,@ARRAY@("~~SUM",ITEM,IEN,LVL)=1,@ARRAY@("~~SUM",BILL)=1,@ARRAY@("~~SUM",LVL,BILL)=1,@ARRAY@("~~SUM",LVL,IEN)=1
Q
;
PAYTIN(PY,L) ; EP
; Truncate Payer/TIN string to L characters for reports
; Input: PY = Payer/TIN string
; L = Maximum length allowed
; Return: Payer/TIN string truncated to length L
N RETURN,XX,YY,ZZ
S RETURN=PY
I $L(PY)>L D
. S ZZ=$L(PY,"/"),XX=$P(PY,"/",1,ZZ-1),YY=$P(PY,"/",ZZ)
. S XX=$E(XX,1,L-($L(YY)+1)),RETURN=XX_"/"_YY
Q RETURN
;
PAYTINS(PY,RETURN) ; Get all PAYER/TIN strings for the TIN in PY
; Input: PY String with Payer Name/TIN in it
; Output: RETURN passed by reference, array of Payer Name/TINS with same TIN as input PY
N COUNT,NAME,TIN,ZZ
K RETURN
S COUNT=0
S TIN=$P(PY,"/",$L(PY,"/"))
S ZZ="" F S ZZ=$O(^RCY(344.6,"C",TIN_" ",ZZ)) Q:ZZ="" D
. S NAME=$$GET1^DIQ(344.6,ZZ_",",.01,"E")
. I NAME'="" D ;
. . S COUNT=COUNT+1
. . S RETURN(COUNT)=NAME_"/"_TIN
Q
;
PAYLIST(ARRAY,TYPE,RETURN) ; Expand list of payers to include ones with the same TIN
; Input: ARRAY - array of payer names or IENS
; TYPE - E=External (Payer Name array) or I=Internal (IEN array)
; Output: RETURN array passed by reference
N KEY,ZZ
S KEY=""
F S KEY=$O(ARRAY(KEY)) Q:KEY="" D ;
. I TYPE="I" D ;
. . D TINLIST(KEY,.RETURN,TYPE)
. I TYPE="E" D ;
. S ZZ=""
. F S ZZ=$O(^RCY(344.6,"B",KEY,ZZ)) Q:ZZ="" D ;
. . D TINLIST(ZZ,.RETURN,TYPE)
Q
TINLIST(PIEN,RETURN,TYPE) ; Given a payer IEN from #344.6, get list of payers with the same TIN
; Input: PIEN - Payer IEN (#344.6)
; ARRAY - array of payer names or IENS
; TYPE - E=External (Payer Name array) or I=Internal (IEN array)
; Output: ARRAY passed by reference with modified entries
N TIN,PNAME,ZZ
S TIN=$$GET1^DIQ(344.6,PIEN_",",.02,"E")
I TIN="" Q
S ZZ=""
F S ZZ=$O(^RCY(344.6,"C",TIN_" ",ZZ)) Q:ZZ="" D
. I TYPE="E" D ;
. . S PNAME=$$GET1^DIQ(344.6,ZZ_",",.01,"E")
. . I PNAME'="" S RETURN(PNAME)=1
. E D
. . S RETURN(ZZ)=1
Q
;
CHK(TYPE,ITEM,ARRAY) ; Check to see if this ITEM is included for processing
; If all are included no need to check further
Q:$G(ARRAY(TYPE))="ALL" 1
Q:$G(ITEM)="" 0
Q:$G(ARRAY(TYPE,ITEM))=1 1
Q 0
;
;
GPAYR(TIN) ; First payer name derived from TIN - PRCA*4.5*321
; Input: TIN - Payer ID
; Return: The first payer name related to TIN
; *Note more than one entry in 344.6 may have this TIN but for sort by name
; purposes we have to select one of them.
N RETURN,ZZ
S ZZ=$O(^RCY(344.6,"C",TIN_" ",""))
I ZZ Q $$GET1^DIQ(344.6,ZZ_",",.01,"E")
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPRU2 5983 printed Oct 16, 2024@17:47:19 Page 2
RCDPRU2 ;AITC/CJE - CARC REPORT ON PAYER OR CARC CODE ;
+1 ;;4.5;Accounts Receivable;**321**;;Build 48
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ; PRCA*4.5*321 - CARC and Payer report utilities
+5 ;
+6 ; Moved from RCDPARC to RCDPRU then to RCDPRU2 - PRCA*4.5*321
SUM(ARRAY,IEN,BILL,CARC,PAYER,BAMT,PAMT,DESC,AAMT,SORT) ; EP
+1 ; Count Claims and summarize for the report
+2 ; IEN: IEN from 361.1 file; BILL: The K-Bill number; ITEM: Top level sort item PAYER or CARC to summarize;
+3 ; BAMT: Billed Amount; PAMT: Paid Amount ; AAMT: Adjustment Amount;
+4 ; LVL: second level sort (CARC/Payer) ; SORT: "C" is CARC or "P" is Payer first level sort,
+5 NEW ITEM,LVL
+6 IF SORT="C"
SET ITEM=CARC
SET LVL=PAYER
+7 IF '$TEST
SET ITEM=PAYER
SET LVL=CARC
+8 ;
+9 ; If we already counted this claim for CARC or Payer skip
if $GET(@ARRAY@("~~SUM",ITEM,IEN))'=1
Begin DoDot:1
+10 ; Count claims
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM"),U,1)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM")),U,1)+1
+11 ; Summarize amount billed
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM"),U,2)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM")),U,2)+BAMT
+12 ; Summarize amount paid
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM"),U,3)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM")),U,3)+PAMT
End DoDot:1
+13 ; Always add in the adjustment (this is a different adjustment each time procedure is called)
+14 ; Summarize amount adjusted
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM"),U,4)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM")),U,4)+AAMT
+15 ; CARC Description
if SORT="C"
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM"),U,5)=$GET(DESC)
+16 IF (SORT="C")&($GET(LVL)'="")
if $GET(@ARRAY@("~~SUM",ITEM,IEN))'=1
Begin DoDot:1
+17 ; Count claims
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,1)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,1)+1
+18 ; Summarize amount billed
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,2)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,2)+BAMT
+19 ; Summarize amount paid
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,3)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,3)+PAMT
End DoDot:1
+20 ;I $G(LVL)'="" D:$G(@ARRAY@("~~SUM",LVL,IEN))'=1
+21 IF (SORT="P")&($GET(LVL)'="")
if $GET(@ARRAY@("~~SUM",ITEM,IEN,LVL))'=1
Begin DoDot:1
+22 ; Count claims
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,1)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,1)+1
+23 ; Summarize amount billed
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,2)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,2)+BAMT
+24 ; Summarize amount paid
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,3)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,3)+PAMT
End DoDot:1
+25 ; Always add in the adjustment (this is a different adjustment each time procedure is called)
+26 ; Summarize amount adjusted
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,4)=$PIECE($GET(@ARRAY@("REPORT",ITEM,"~~SUM",LVL)),U,4)+AAMT
+27 ; CARC Description
IF SORT="P"
IF $GET(LVL)'=""
SET $PIECE(@ARRAY@("REPORT",ITEM,"~~SUM",LVL),U,5)=DESC
+28 ; Get grand totals for report
+29 if $GET(@ARRAY@("~~SUM",BILL))'=1
Begin DoDot:1
+30 SET $PIECE(@ARRAY@("~~SUM","CLAIMS"),U,1)=$PIECE($GET(@ARRAY@("~~SUM","CLAIMS")),U,1)+1
+31 SET $PIECE(@ARRAY@("~~SUM","CLAIMS"),U,2)=$PIECE($GET(@ARRAY@("~~SUM","CLAIMS")),U,2)+BAMT
+32 SET $PIECE(@ARRAY@("~~SUM","CLAIMS"),U,3)=$PIECE($GET(@ARRAY@("~~SUM","CLAIMS")),U,3)+PAMT
End DoDot:1
+33 ; May have more than one adjustment on a bill
+34 ;W "BILL: ",BILL," ITEM: ",ITEM," Adj: ",AAMT,!
IF $GET(@ARRAY@("~~SUM",BILL,ITEM))'=1
SET $PIECE(@ARRAY@("~~SUM","CLAIMS"),U,4)=$PIECE($GET(@ARRAY@("~~SUM","CLAIMS")),U,4)+AAMT
+35 ; Set markers so we don't double count a claim
+36 SET @ARRAY@("~~SUM",ITEM,BILL)=1
SET @ARRAY@("~~SUM",ITEM,IEN)=1
SET @ARRAY@("~~SUM",ITEM,IEN,LVL)=1
SET @ARRAY@("~~SUM",BILL)=1
SET @ARRAY@("~~SUM",LVL,BILL)=1
SET @ARRAY@("~~SUM",LVL,IEN)=1
+37 QUIT
+38 ;
PAYTIN(PY,L) ; EP
+1 ; Truncate Payer/TIN string to L characters for reports
+2 ; Input: PY = Payer/TIN string
+3 ; L = Maximum length allowed
+4 ; Return: Payer/TIN string truncated to length L
+5 NEW RETURN,XX,YY,ZZ
+6 SET RETURN=PY
+7 IF $LENGTH(PY)>L
Begin DoDot:1
+8 SET ZZ=$LENGTH(PY,"/")
SET XX=$PIECE(PY,"/",1,ZZ-1)
SET YY=$PIECE(PY,"/",ZZ)
+9 SET XX=$EXTRACT(XX,1,L-($LENGTH(YY)+1))
SET RETURN=XX_"/"_YY
End DoDot:1
+10 QUIT RETURN
+11 ;
PAYTINS(PY,RETURN) ; Get all PAYER/TIN strings for the TIN in PY
+1 ; Input: PY String with Payer Name/TIN in it
+2 ; Output: RETURN passed by reference, array of Payer Name/TINS with same TIN as input PY
+3 NEW COUNT,NAME,TIN,ZZ
+4 KILL RETURN
+5 SET COUNT=0
+6 SET TIN=$PIECE(PY,"/",$LENGTH(PY,"/"))
+7 SET ZZ=""
FOR
SET ZZ=$ORDER(^RCY(344.6,"C",TIN_" ",ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+8 SET NAME=$$GET1^DIQ(344.6,ZZ_",",.01,"E")
+9 ;
IF NAME'=""
Begin DoDot:2
+10 SET COUNT=COUNT+1
+11 SET RETURN(COUNT)=NAME_"/"_TIN
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
PAYLIST(ARRAY,TYPE,RETURN) ; Expand list of payers to include ones with the same TIN
+1 ; Input: ARRAY - array of payer names or IENS
+2 ; TYPE - E=External (Payer Name array) or I=Internal (IEN array)
+3 ; Output: RETURN array passed by reference
+4 NEW KEY,ZZ
+5 SET KEY=""
+6 ;
FOR
SET KEY=$ORDER(ARRAY(KEY))
if KEY=""
QUIT
Begin DoDot:1
+7 ;
IF TYPE="I"
Begin DoDot:2
+8 DO TINLIST(KEY,.RETURN,TYPE)
End DoDot:2
+9 ;
IF TYPE="E"
Begin DoDot:2
End DoDot:2
+10 SET ZZ=""
+11 ;
FOR
SET ZZ=$ORDER(^RCY(344.6,"B",KEY,ZZ))
if ZZ=""
QUIT
Begin DoDot:2
+12 DO TINLIST(ZZ,.RETURN,TYPE)
End DoDot:2
End DoDot:1
+13 QUIT
TINLIST(PIEN,RETURN,TYPE) ; Given a payer IEN from #344.6, get list of payers with the same TIN
+1 ; Input: PIEN - Payer IEN (#344.6)
+2 ; ARRAY - array of payer names or IENS
+3 ; TYPE - E=External (Payer Name array) or I=Internal (IEN array)
+4 ; Output: ARRAY passed by reference with modified entries
+5 NEW TIN,PNAME,ZZ
+6 SET TIN=$$GET1^DIQ(344.6,PIEN_",",.02,"E")
+7 IF TIN=""
QUIT
+8 SET ZZ=""
+9 FOR
SET ZZ=$ORDER(^RCY(344.6,"C",TIN_" ",ZZ))
if ZZ=""
QUIT
Begin DoDot:1
+10 ;
IF TYPE="E"
Begin DoDot:2
+11 SET PNAME=$$GET1^DIQ(344.6,ZZ_",",.01,"E")
+12 IF PNAME'=""
SET RETURN(PNAME)=1
End DoDot:2
+13 IF '$TEST
Begin DoDot:2
+14 SET RETURN(ZZ)=1
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
CHK(TYPE,ITEM,ARRAY) ; Check to see if this ITEM is included for processing
+1 ; If all are included no need to check further
+2 if $GET(ARRAY(TYPE))="ALL"
QUIT 1
+3 if $GET(ITEM)=""
QUIT 0
+4 if $GET(ARRAY(TYPE,ITEM))=1
QUIT 1
+5 QUIT 0
+6 ;
+7 ;
GPAYR(TIN) ; First payer name derived from TIN - PRCA*4.5*321
+1 ; Input: TIN - Payer ID
+2 ; Return: The first payer name related to TIN
+3 ; *Note more than one entry in 344.6 may have this TIN but for sort by name
+4 ; purposes we have to select one of them.
+5 NEW RETURN,ZZ
+6 SET ZZ=$ORDER(^RCY(344.6,"C",TIN_" ",""))
+7 IF ZZ
QUIT $$GET1^DIQ(344.6,ZZ_",",.01,"E")
+8 QUIT ""
