- 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 Feb 18, 2025@23:12:51 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 ""
