RCDPEAD2 ;AITC/CJE - AUTO-DECREASE REPORT ;Nov 23, 2014@12:48:50
;;4.5;Accounts Receivable;**326,345,349**;Mar 20, 1995;Build 44
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EXCEL(DATA,A1,A2,A3) ; Format EXCEL line
; Input: DATA - ERA line adjustment total
; A1,A2,A3 - ^TMP("RCDPEAP") subscripts
N CARCAMT,CCTR,DATA1
S CCTR=0
F S CCTR=$O(^TMP("RCDPEADP",$J,A1,A2,A3,CCTR)) Q:'CCTR D
. ;Display an EXCEL line for each CARC adjustment on the line
. S DATA1=$G(^TMP("RCDPEADP",$J,A1,A2,A3,CCTR)),CARCAMT=$P(DATA1,U,2)
. W !,$P(DATA,U,1,5)_U_CARCAMT_U_$P(DATA,U,7)_U_DATA1
Q
;
LINE(DIV) ; List selected stations
; Input: DIV() - Array of selected divisions
; Returns: Comma delimited list of selected divisions
N LINE,P,SUB
S LINE="",SUB="",P=0
F D Q:'SUB
. S SUB=$O(DIV(SUB))
. Q:'SUB
. S P=P+1,$P(LINE,", ",P)=$G(DIV(SUB))
Q LINE
;
CLAIM(EOBIEN) ; Gets the claim number from AR
; Input: EOBIEN - Internal IEN for file 361.1
; Returns: External Claim Number
N CLAIM,CLAIMIEN
Q:'$G(EOBIEN)>0 "(no EOB IEN)"
S CLAIMIEN=$$GET1^DIQ(361.1,EOBIEN,.01,"I") ; IEN for file 399
Q:'CLAIMIEN "(no Claim IEN)"
S CLAIM=$$GET1^DIQ(430,CLAIMIEN,.01,"I")
Q:CLAIM="" "(Claim not found)"
Q CLAIM ; Return claim (nnn-Knnnnnn)
;
; PRCA*4.5*345 - Moved function from RCDPEAD
ACTCARC(CODE,RCZERO,WHICH) ; EP from RCDPEAD - Is this CARC an active code for auto-decrease
; PRCA*4.5*345 - Added WHICH
; Input: CODE - CARC code being checked
; RCZERO - 0 = Claim line with payment, 1 = Claim line with no payment
; WHICH - 1 Medical Claim CARCs, 2 - RX Claim CARCs, 3 TRICARE Claim CARCS
; Returns: '0^NOT ACTIVE' if not active
; '1^{amount}' if active and the second piece is the decrease amount
N ACTIVE,AIEN,FIELD,XX
I $G(CODE)="" Q "0^NOT ACTIVE"
S AIEN=$O(^RCY(344.62,"B",CODE,""))
I AIEN="" Q "0^NOT ACTIVE"
;
; PRCA*4.5*349 - Parameterize for Medical, Rx and TRICARE
I WHICH=1 S FIELD=$S(RCZERO:.08,1:.02)
E I WHICH=2 S FIELD=2.01
E S FIELD=$S(RCZERO:3.07,1:3.01)
S ACTIVE=$$GET1^DIQ(344.62,AIEN,FIELD,"I") ; Quit if auto-decrease is off
;
I 'ACTIVE Q "0^NOT ACTIVE"
;
I WHICH=1 S FIELD=$S(RCZERO:.12,1:.06)
E I WHICH=2 S FIELD=2.05
E S FIELD=$S(RCZERO:3.11,1:3.05)
;
Q "1^"_$$GET1^DIQ(344.62,AIEN,FIELD)
; END PRCA*4.5*349
;
GETCARCS(RCEOB,RCCODES,FROMADP) ; EP from RCDPEAD - Extract the CARCs from an EOB at claim and line levels
; Input: RCEOB - Internal IEN for the explanation of benefits field (361.1)
; FROMADP - 1 if being called from COMPILE^RCDPEAD1, 0 otherwise
; Optional, default to 0
; Output: RCCODES - ^ delimitted string of CARC code information from the
; claim and claim ine levels for the specified EOB
; ^A1;A2;A3;A4^A1;A2;A3;A4^... Where
; A1 - CARC code
; A2 - Auto Decrease Amount
; A3 - Quantity (only returned if FROMADP=1)
; A4 - REASON (only returned if FROMADP=1)
N IENS,RCAMT,QUANT,REASON,RCCODE,RCI,RCJ,RCL
S:'$D(FROMADP) FROMADP=0
S RCI=0,RCCODES=""
;
; Get to the Codes at the claim level
F D Q:'RCI
. S RCI=$O(^IBM(361.1,RCEOB,10,RCI))
. Q:'RCI
. S RCJ=0
. F D Q:'RCJ
. . S RCJ=$O(^IBM(361.1,RCEOB,10,RCI,1,RCJ))
. . Q:'RCJ
. . S IENS=RCJ_","_RCI_","_RCEOB_","
. . S RCCODE=$$GET1^DIQ(361.111,IENS,.01,"I") ; CARC Code
. . Q:RCCODE=""
. . S RCAMT=$$GET1^DIQ(361.111,IENS,.02,"I") ; CARC Amount
. . I 'FROMADP S RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT Q
. . S QUANT=$$GET1^DIQ(361.111,IENS,.03,"I") ; CARC Quantity
. . S REASON=$$GET1^DIQ(361.111,IENS,.04,"I") ; CARC Reason
. . S:$L(REASON)>30 REASON=$E(REASON,1,27)_"..."
. . S RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT_";"_QUANT_";"_REASON
;
; Get Claim Line level CARCs
S RCL=0
F D Q:+RCL=0
. S RCL=$O(^IBM(361.1,RCEOB,15,RCL))
. Q:+RCL=0
. S RCI=0
. F D Q:+RCI=0
. . S RCI=$O(^IBM(361.1,RCEOB,15,RCL,1,RCI))
. . Q:+RCI=0
. . S RCJ=0
. . F D Q:+RCJ=0
. . . S RCJ=$O(^IBM(361.1,RCEOB,15,RCL,1,RCI,1,RCJ))
. . . Q:+RCJ=0
. . . S IENS=RCJ_","_RCI_","_RCL_","_RCEOB_","
. . . S RCCODE=$$GET1^DIQ(361.11511,IENS,.01,"I") ; CARC Code
. . . Q:RCCODE=""
. . . S RCAMT=$$GET1^DIQ(361.11511,IENS,.02,"I") ; CARC Amount
. . . I 'FROMADP S RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT Q
. . . S QUANT=$$GET1^DIQ(361.11511,IENS,.03,"I") ; CARC Quantity
. . . S REASON=$$GET1^DIQ(361.11511,IENS,.04,"I") ; CARC Reason
. . . S:$L(REASON)>30 REASON=$E(REASON,1,27)_"..."
. . . S RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT_";"_QUANT_";"_REASON
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEAD2 4845 printed Dec 13, 2024@01:44:12 Page 2
RCDPEAD2 ;AITC/CJE - AUTO-DECREASE REPORT ;Nov 23, 2014@12:48:50
+1 ;;4.5;Accounts Receivable;**326,345,349**;Mar 20, 1995;Build 44
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EXCEL(DATA,A1,A2,A3) ; Format EXCEL line
+1 ; Input: DATA - ERA line adjustment total
+2 ; A1,A2,A3 - ^TMP("RCDPEAP") subscripts
+3 NEW CARCAMT,CCTR,DATA1
+4 SET CCTR=0
+5 FOR
SET CCTR=$ORDER(^TMP("RCDPEADP",$JOB,A1,A2,A3,CCTR))
if 'CCTR
QUIT
Begin DoDot:1
+6 ;Display an EXCEL line for each CARC adjustment on the line
+7 SET DATA1=$GET(^TMP("RCDPEADP",$JOB,A1,A2,A3,CCTR))
SET CARCAMT=$PIECE(DATA1,U,2)
+8 WRITE !,$PIECE(DATA,U,1,5)_U_CARCAMT_U_$PIECE(DATA,U,7)_U_DATA1
End DoDot:1
+9 QUIT
+10 ;
LINE(DIV) ; List selected stations
+1 ; Input: DIV() - Array of selected divisions
+2 ; Returns: Comma delimited list of selected divisions
+3 NEW LINE,P,SUB
+4 SET LINE=""
SET SUB=""
SET P=0
+5 FOR
Begin DoDot:1
+6 SET SUB=$ORDER(DIV(SUB))
+7 if 'SUB
QUIT
+8 SET P=P+1
SET $PIECE(LINE,", ",P)=$GET(DIV(SUB))
End DoDot:1
if 'SUB
QUIT
+9 QUIT LINE
+10 ;
CLAIM(EOBIEN) ; Gets the claim number from AR
+1 ; Input: EOBIEN - Internal IEN for file 361.1
+2 ; Returns: External Claim Number
+3 NEW CLAIM,CLAIMIEN
+4 if '$GET(EOBIEN)>0
QUIT "(no EOB IEN)"
+5 ; IEN for file 399
SET CLAIMIEN=$$GET1^DIQ(361.1,EOBIEN,.01,"I")
+6 if 'CLAIMIEN
QUIT "(no Claim IEN)"
+7 SET CLAIM=$$GET1^DIQ(430,CLAIMIEN,.01,"I")
+8 if CLAIM=""
QUIT "(Claim not found)"
+9 ; Return claim (nnn-Knnnnnn)
QUIT CLAIM
+10 ;
+11 ; PRCA*4.5*345 - Moved function from RCDPEAD
ACTCARC(CODE,RCZERO,WHICH) ; EP from RCDPEAD - Is this CARC an active code for auto-decrease
+1 ; PRCA*4.5*345 - Added WHICH
+2 ; Input: CODE - CARC code being checked
+3 ; RCZERO - 0 = Claim line with payment, 1 = Claim line with no payment
+4 ; WHICH - 1 Medical Claim CARCs, 2 - RX Claim CARCs, 3 TRICARE Claim CARCS
+5 ; Returns: '0^NOT ACTIVE' if not active
+6 ; '1^{amount}' if active and the second piece is the decrease amount
+7 NEW ACTIVE,AIEN,FIELD,XX
+8 IF $GET(CODE)=""
QUIT "0^NOT ACTIVE"
+9 SET AIEN=$ORDER(^RCY(344.62,"B",CODE,""))
+10 IF AIEN=""
QUIT "0^NOT ACTIVE"
+11 ;
+12 ; PRCA*4.5*349 - Parameterize for Medical, Rx and TRICARE
+13 IF WHICH=1
SET FIELD=$SELECT(RCZERO:.08,1:.02)
+14 IF '$TEST
IF WHICH=2
SET FIELD=2.01
+15 IF '$TEST
SET FIELD=$SELECT(RCZERO:3.07,1:3.01)
+16 ; Quit if auto-decrease is off
SET ACTIVE=$$GET1^DIQ(344.62,AIEN,FIELD,"I")
+17 ;
+18 IF 'ACTIVE
QUIT "0^NOT ACTIVE"
+19 ;
+20 IF WHICH=1
SET FIELD=$SELECT(RCZERO:.12,1:.06)
+21 IF '$TEST
IF WHICH=2
SET FIELD=2.05
+22 IF '$TEST
SET FIELD=$SELECT(RCZERO:3.11,1:3.05)
+23 ;
+24 QUIT "1^"_$$GET1^DIQ(344.62,AIEN,FIELD)
+25 ; END PRCA*4.5*349
+26 ;
GETCARCS(RCEOB,RCCODES,FROMADP) ; EP from RCDPEAD - Extract the CARCs from an EOB at claim and line levels
+1 ; Input: RCEOB - Internal IEN for the explanation of benefits field (361.1)
+2 ; FROMADP - 1 if being called from COMPILE^RCDPEAD1, 0 otherwise
+3 ; Optional, default to 0
+4 ; Output: RCCODES - ^ delimitted string of CARC code information from the
+5 ; claim and claim ine levels for the specified EOB
+6 ; ^A1;A2;A3;A4^A1;A2;A3;A4^... Where
+7 ; A1 - CARC code
+8 ; A2 - Auto Decrease Amount
+9 ; A3 - Quantity (only returned if FROMADP=1)
+10 ; A4 - REASON (only returned if FROMADP=1)
+11 NEW IENS,RCAMT,QUANT,REASON,RCCODE,RCI,RCJ,RCL
+12 if '$DATA(FROMADP)
SET FROMADP=0
+13 SET RCI=0
SET RCCODES=""
+14 ;
+15 ; Get to the Codes at the claim level
+16 FOR
Begin DoDot:1
+17 SET RCI=$ORDER(^IBM(361.1,RCEOB,10,RCI))
+18 if 'RCI
QUIT
+19 SET RCJ=0
+20 FOR
Begin DoDot:2
+21 SET RCJ=$ORDER(^IBM(361.1,RCEOB,10,RCI,1,RCJ))
+22 if 'RCJ
QUIT
+23 SET IENS=RCJ_","_RCI_","_RCEOB_","
+24 ; CARC Code
SET RCCODE=$$GET1^DIQ(361.111,IENS,.01,"I")
+25 if RCCODE=""
QUIT
+26 ; CARC Amount
SET RCAMT=$$GET1^DIQ(361.111,IENS,.02,"I")
+27 IF 'FROMADP
SET RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT
QUIT
+28 ; CARC Quantity
SET QUANT=$$GET1^DIQ(361.111,IENS,.03,"I")
+29 ; CARC Reason
SET REASON=$$GET1^DIQ(361.111,IENS,.04,"I")
+30 if $LENGTH(REASON)>30
SET REASON=$EXTRACT(REASON,1,27)_"..."
+31 SET RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT_";"_QUANT_";"_REASON
End DoDot:2
if 'RCJ
QUIT
End DoDot:1
if 'RCI
QUIT
+32 ;
+33 ; Get Claim Line level CARCs
+34 SET RCL=0
+35 FOR
Begin DoDot:1
+36 SET RCL=$ORDER(^IBM(361.1,RCEOB,15,RCL))
+37 if +RCL=0
QUIT
+38 SET RCI=0
+39 FOR
Begin DoDot:2
+40 SET RCI=$ORDER(^IBM(361.1,RCEOB,15,RCL,1,RCI))
+41 if +RCI=0
QUIT
+42 SET RCJ=0
+43 FOR
Begin DoDot:3
+44 SET RCJ=$ORDER(^IBM(361.1,RCEOB,15,RCL,1,RCI,1,RCJ))
+45 if +RCJ=0
QUIT
+46 SET IENS=RCJ_","_RCI_","_RCL_","_RCEOB_","
+47 ; CARC Code
SET RCCODE=$$GET1^DIQ(361.11511,IENS,.01,"I")
+48 if RCCODE=""
QUIT
+49 ; CARC Amount
SET RCAMT=$$GET1^DIQ(361.11511,IENS,.02,"I")
+50 IF 'FROMADP
SET RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT
QUIT
+51 ; CARC Quantity
SET QUANT=$$GET1^DIQ(361.11511,IENS,.03,"I")
+52 ; CARC Reason
SET REASON=$$GET1^DIQ(361.11511,IENS,.04,"I")
+53 if $LENGTH(REASON)>30
SET REASON=$EXTRACT(REASON,1,27)_"..."
+54 SET RCCODES=RCCODES_"^"_RCCODE_";"_RCAMT_";"_QUANT_";"_REASON
End DoDot:3
if +RCJ=0
QUIT
End DoDot:2
if +RCI=0
QUIT
End DoDot:1
if +RCL=0
QUIT
+55 QUIT
