RCDPEMA ;ALB/PJH - AUTO-POSTING RECEIPT CREATION ;Oct 15, 2014@12:37:52
;;4.5;Accounts Receivable;**298,304,318,321,326**;Mar 20, 1995;Build 26
;Per VA Directive 6402, this routine should not be modified.
;
RCPTDET(RCRZ,RECTDA1,RCLINES,RCER) ; Adds detail to a receipt based on file 344.49 and exceptions in array RCLINES
; RCRZ = ien of ERA entry in file 344.49
; RECTDA1 = ien of receipt entry in file 344
; RCER = error array returned if passed by reference
; RCLINES = array to indicate which scratchpad lines can be posted (assigned a receipt)
;
N DA,DIE,DR,Q,RCDUZ,RCLINE,RCOSEQ,RCQ,RCR,RCSPL,RCTRANDA,RCZ0,SEQLINES,RCSEQ,X,Y,Z,Z0,Z1
;
S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D
. S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0)),RCSEQ=$P(RCZ0,U)
. ;Check first line for prefix to see if ERA line is valid for auto-post
. I RCSEQ?1N.N,$P(RCZ0,U,9),$P($G(RCLINES($P(RCZ0,U,9))),U) S SEQLINES(RCSEQ)=""
. ;Skip WORKLIST lines that do not need associated receipt detail
. Q:'$D(SEQLINES(RCSEQ\1))
. I RCSEQ'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q
. I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q
. S RCOSEQ=$G(RCSPL(RCSEQ\1)) ; PRCA*4.5*326
. S RCDUZ=$$GET1^DIQ(344.41,RCOSEQ_","_RCRZ_",",6.01,"I") ; PRCA*4.5*326
. S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1,RCDUZ) ; PRCA*4.5*326 Pass RCDUZ
. ;
. I RCTRANDA'>0 D Q ; Error adding receipt detail - PRCA*4.5*318
.. S RCER(1)=$$SETERR^RCDPEM0(1) ; PRCA*4.5*318 - pass RCPROC value to $$SETERR
.. S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
. ;
. ;Store receipt line detail
. D DET(RCRZ,RCR,RECTDA1,RCTRANDA)
. S RCSPL(RCZ0\1,+RCZ0)=RCZ0
;
; Update A/R CORRECTED PAYMENT multiple with apportionment for split lines
S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D
.; Move EEOB if one claim entered-changed 10/19/11-see +25^RCDPEWL8
. S Z1=$O(RCSPL(Z,"")) Q:Z1=""
. I $O(RCSPL(Z,""),-1)=Z1,'$$SPLIT(Z,Z1,RCERA) Q ; No split occurred
. S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D
.. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec
.. Q:'Q
.. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspense
... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050
.. E D
... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050
. ; BEGIN - PRCA*4.5*321
. ;Move/Copy/Remove EEOB detail for split line
. N CLAIM,IEN3611,RCSPLIT,RCSUB,RCZSAV
. ; Sub-array of split claim detail for individual line
. M RCSPLIT=RCSPL(Z)
. ; Protect Z subscript variable from overwrite by triggers
. S RCZSAV=Z
. ; Get scratchpad line number for this ERA line
. S RCSUB=$O(^RCY(344.49,RCRZ,1,"ASEQ",Z,""))
. ; Original claim number from Scratchpad line
. S CLAIM=$$GET1^DIQ(344.491,RCSUB_","_RCRZ_",",.02)
. ; EOB for original claim from ERA line
. S IEN3611=$$GET1^DIQ(344.41,RCQ_","_RCRZ_",",.02,"I")
. ; Automatic Move/Copy/Remove EOB
. I $$AUTO^RCDPEM5(CLAIM,.RCSPLIT,RCERA,"A",IEN3611)
. ; Restore Z
. S Z=RCZSAV
. ; END - PRCA*4.5*321 ;
Q
;
SPLIT(Z,Z1,RCERA) ;Check if worklist was split to single claim
N SUB,NBILL,OBILL
;Find split line in scratchpad
S SUB=$O(^RCY(344.49,RCERA,1,"B",Z1,"")) Q:'SUB 0
;Get original claim number from scratchpad
S OBILL=$P($G(^RCY(344.49,RCERA,1,SUB-1,0)),U,2)
;New claim number
S NBILL=$P(RCSPL(Z,Z1),U,2)
;If new and old claim are not the same this is a move via split
I OBILL'="",OBILL'=NBILL Q 1
;Otherwise this is not a split
Q 0
;
DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
; RCZ = ien of entry file 344.49
; RCR = ien of entry in file 344.491
; RECTDA1 = ien of entry in file 344
; RCTRANDA = ien of entry in subfile 344.01
;
N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
S RC0=$G(^RCY(344.49,RCZ,0))
S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0))
S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0))
I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
S DR=DR_".04////"_(+$P(RCZ0,U,3))_";.27////"_RCR_";"
I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";"
I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";"
S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag
S RCCOM=$P(RCZ0,U,10)
I $P(RCUP,U,2)["**ADJ" S RCCOM=RCCOM_$S(RCCOM'="":"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA")
I RCCOM]"" S DR=DR_"1.02////"_$E(RCCOM,1,60)_";"
I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";"
S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1,"
D ^DIE
;Update comment history - PRCA*4.5*321
D:RCCOM]"" AUDIT^RCDPECH(RECTDA1,RCTRANDA,RCZ,RCR)
Q
; PRCA*4.5*326 Add RCDUZ parameter
BLDRCPT(RCERA,RCDUZ) ; Create a receipt for Auto Posting ERA with multiple Receipts - alpha char at the 10th character
; LAYGO new entry to AR BATCH PAYMENT file (#344)
; input - RCERA = Pointer to 344.4
; returns new IEN on success, else zero
; called by auto-post process (RCDPEAP)
;
N RECEIPT,TYPE,LASTREC
S TYPE=$E($G(^RC(341.1,+$O(^RC(341.1,"AC",14,0)),0))) ; ^RC(341.1,0) = AR EVENT TYPE
; retrieve the last receipt recorded on the ERA (if it exists)
S LASTREC=$$GETREC(RCERA)
; Make sure last receipt for the ERA is 10-chars long and the last char is between A - Y (can't be Z),
; Otherwise grab a new number and append "A"
I LASTREC'="",$L(LASTREC)=10,$A($E(LASTREC,10))>64,$A($E(LASTREC,10))<90 D
. S RECEIPT=$E(LASTREC,1,9)_$C($A($E(LASTREC,10))+1)
E D
. S RECEIPT=$$NEXT^RCDPUREC(TYPE_$E(DT,2,7))_"A"
;
; Prevents duplicate Receipt # entries from being filed
F Q:'$D(^RCY(344,"B",RECEIPT)) D
. S RECEIPT=$E(RECEIPT,1)_$E(1000001+$E(RECEIPT,2,7),2,7)_$E(RECEIPT,8,9)_"A"
;
L +^RCY(344,"B",RECEIPT):DILOCKTM E Q 0 ; if LOCK timeout return zero
;
; add entry to AR BATCH PAYMENT file (#344)
N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y
S DIC="^RCY(344,",DIC(0)="L",DLAYGO=344
; .02 = opened by .03 = date opened = transmission date
; .04 = type of payment
; .14 = status (set to 1:open)
S DIC("DR")=".02////"_$S($G(RCDUZ):RCDUZ,1:DUZ)_";.03///"_DT_";.04////14;.14////1;"
S X=RECEIPT
D FILE^DICN
L -^RCY(344,"B",RECEIPT)
I Y>0 Q +Y ; Y set by DICN, return new IEN
Q 0 ; entry not created
;
GETREC(RCERA) ; returns the receipt number
; input - RCERA = ien of entry in 344.4
; output - returns the receipt number in external form
N X,RECEIPT
S RECEIPT=""
S X=$O(^RCY(344.4,RCERA,1,"RECEIPT",""),-1) ; get last RECEIPT ien from 344.41 subfile
S:X RECEIPT=$P($G(^RCY(344,X,0)),U) ; get external form of receipt
Q RECEIPT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEMA 6969 printed Sep 23, 2025@19:20:57 Page 2
RCDPEMA ;ALB/PJH - AUTO-POSTING RECEIPT CREATION ;Oct 15, 2014@12:37:52
+1 ;;4.5;Accounts Receivable;**298,304,318,321,326**;Mar 20, 1995;Build 26
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
RCPTDET(RCRZ,RECTDA1,RCLINES,RCER) ; Adds detail to a receipt based on file 344.49 and exceptions in array RCLINES
+1 ; RCRZ = ien of ERA entry in file 344.49
+2 ; RECTDA1 = ien of receipt entry in file 344
+3 ; RCER = error array returned if passed by reference
+4 ; RCLINES = array to indicate which scratchpad lines can be posted (assigned a receipt)
+5 ;
+6 NEW DA,DIE,DR,Q,RCDUZ,RCLINE,RCOSEQ,RCQ,RCR,RCSPL,RCTRANDA,RCZ0,SEQLINES,RCSEQ,X,Y,Z,Z0,Z1
+7 ;
+8 SET RCR=0
FOR
SET RCR=$ORDER(^RCY(344.49,RCRZ,1,RCR))
if 'RCR
QUIT
Begin DoDot:1
+9 SET RCZ0=$GET(^RCY(344.49,RCRZ,1,RCR,0))
SET RCSEQ=$PIECE(RCZ0,U)
+10 ;Check first line for prefix to see if ERA line is valid for auto-post
+11 IF RCSEQ?1N.N
IF $PIECE(RCZ0,U,9)
IF $PIECE($GET(RCLINES($PIECE(RCZ0,U,9))),U)
SET SEQLINES(RCSEQ)=""
+12 ;Skip WORKLIST lines that do not need associated receipt detail
+13 if '$DATA(SEQLINES(RCSEQ\1))
QUIT
+14 IF RCSEQ'["."
SET RCSPL(+RCZ0)=$PIECE(RCZ0,U,9)
QUIT
+15 IF $SELECT(+$PIECE(RCZ0,U,3)=0:$PIECE($GET(^RCY(344.49,RCRZ,0)),U,3),1:$PIECE(RCZ0,U,3)<0)
SET RCSPL(RCZ0\1,+RCZ0)=RCZ0
QUIT
+16 ; PRCA*4.5*326
SET RCOSEQ=$GET(RCSPL(RCSEQ\1))
+17 ; PRCA*4.5*326
SET RCDUZ=$$GET1^DIQ(344.41,RCOSEQ_","_RCRZ_",",6.01,"I")
+18 ; PRCA*4.5*326 Pass RCDUZ
SET RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1,RCDUZ)
+19 ;
+20 ; Error adding receipt detail - PRCA*4.5*318
IF RCTRANDA'>0
Begin DoDot:2
+21 ; PRCA*4.5*318 - pass RCPROC value to $$SETERR
SET RCER(1)=$$SETERR^RCDPEM0(1)
+22 SET RCER($ORDER(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$PIECE($GET(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$PIECE(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD"
End DoDot:2
QUIT
+23 ;
+24 ;Store receipt line detail
+25 DO DET(RCRZ,RCR,RECTDA1,RCTRANDA)
+26 SET RCSPL(RCZ0\1,+RCZ0)=RCZ0
End DoDot:1
+27 ;
+28 ; Update A/R CORRECTED PAYMENT multiple with apportionment for split lines
+29 SET Z=0
FOR
SET Z=$ORDER(RCSPL(Z))
if 'Z
QUIT
SET RCQ=+$GET(RCSPL(Z))
IF RCQ
Begin DoDot:1
+30 ; Move EEOB if one claim entered-changed 10/19/11-see +25^RCDPEWL8
+31 SET Z1=$ORDER(RCSPL(Z,""))
if Z1=""
QUIT
+32 ; No split occurred
IF $ORDER(RCSPL(Z,""),-1)=Z1
IF '$$SPLIT(Z,Z1,RCERA)
QUIT
+33 SET Z1=0
FOR
SET Z1=$ORDER(RCSPL(Z,Z1))
if 'Z1
QUIT
SET Z0=$GET(RCSPL(Z,Z1))
Begin DoDot:2
+34 ; EOB detail rec
SET Q=+$PIECE($GET(^RCY(344.4,RCRZ,1,RCQ,0)),U,2)
+35 if 'Q
QUIT
+36 ; Suspense
IF '$PIECE(Z0,U,7)!($PIECE(Z0,U,2)="")
Begin DoDot:3
+37 ; IA 4050
DO SPL1^IBCEOBAR(Q,$SELECT($PIECE(Z0,U,2)="":"NO BILL",1:$PIECE(Z0,U,2)),"",$PIECE(Z0,U,6))
End DoDot:3
+38 IF '$TEST
Begin DoDot:3
+39 ; Add the split bill # ; IA 4050
DO SPL1^IBCEOBAR(Q,$PIECE(Z0,U,2),$PIECE(Z0,U,7),$PIECE(Z0,U,6))
End DoDot:3
End DoDot:2
+40 ; BEGIN - PRCA*4.5*321
+41 ;Move/Copy/Remove EEOB detail for split line
+42 NEW CLAIM,IEN3611,RCSPLIT,RCSUB,RCZSAV
+43 ; Sub-array of split claim detail for individual line
+44 MERGE RCSPLIT=RCSPL(Z)
+45 ; Protect Z subscript variable from overwrite by triggers
+46 SET RCZSAV=Z
+47 ; Get scratchpad line number for this ERA line
+48 SET RCSUB=$ORDER(^RCY(344.49,RCRZ,1,"ASEQ",Z,""))
+49 ; Original claim number from Scratchpad line
+50 SET CLAIM=$$GET1^DIQ(344.491,RCSUB_","_RCRZ_",",.02)
+51 ; EOB for original claim from ERA line
+52 SET IEN3611=$$GET1^DIQ(344.41,RCQ_","_RCRZ_",",.02,"I")
+53 ; Automatic Move/Copy/Remove EOB
+54 IF $$AUTO^RCDPEM5(CLAIM,.RCSPLIT,RCERA,"A",IEN3611)
+55 ; Restore Z
+56 SET Z=RCZSAV
+57 ; END - PRCA*4.5*321 ;
End DoDot:1
+58 QUIT
+59 ;
SPLIT(Z,Z1,RCERA) ;Check if worklist was split to single claim
+1 NEW SUB,NBILL,OBILL
+2 ;Find split line in scratchpad
+3 SET SUB=$ORDER(^RCY(344.49,RCERA,1,"B",Z1,""))
if 'SUB
QUIT 0
+4 ;Get original claim number from scratchpad
+5 SET OBILL=$PIECE($GET(^RCY(344.49,RCERA,1,SUB-1,0)),U,2)
+6 ;New claim number
+7 SET NBILL=$PIECE(RCSPL(Z,Z1),U,2)
+8 ;If new and old claim are not the same this is a move via split
+9 IF OBILL'=""
IF OBILL'=NBILL
QUIT 1
+10 ;Otherwise this is not a split
+11 QUIT 0
+12 ;
DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
+1 ; RCZ = ien of entry file 344.49
+2 ; RCR = ien of entry in file 344.491
+3 ; RECTDA1 = ien of entry in file 344
+4 ; RCTRANDA = ien of entry in subfile 344.01
+5 ;
+6 NEW DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
+7 SET RC0=$GET(^RCY(344.49,RCZ,0))
+8 SET RCZ0=$GET(^RCY(344.49,RCZ,1,RCR,0))
+9 SET DR=""
SET RCUP=+$ORDER(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0))
SET RCUP=$GET(^RCY(344.49,RCZ,1,RCUP,0))
+10 IF $PIECE(RCZ0,U,7)
SET DR=".09////^S X="_+$PIECE(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
+11 SET DR=DR_".04////"_(+$PIECE(RCZ0,U,3))_";.27////"_RCR_";"
+12 IF $PIECE(RC0,U,5)'=""
SET DR=DR_".1////"_$PIECE(RC0,U,5)_";"
+13 IF $PIECE(RC0,U,6)'=""
SET DR=DR_".08////"_$PIECE(RC0,U,6)_";"
+14 ; Update receipt line with dec adj flag
SET Z=0
FOR
SET Z=$ORDER(^RCY(344.49,RCZ,1,RCR,1,Z))
if 'Z
QUIT
IF $PIECE($GET(^(Z,0)),U,5)=1
SET DR=DR_".28////1;"
QUIT
+15 SET RCCOM=$PIECE(RCZ0,U,10)
+16 IF $PIECE(RCUP,U,2)["**ADJ"
SET RCCOM=RCCOM_$SELECT(RCCOM'="":"/",1:"")_$SELECT($PIECE($PIECE(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA")
+17 IF RCCOM]""
SET DR=DR_"1.02////"_$EXTRACT(RCCOM,1,60)_";"
+18 IF $PIECE($GET(^RCY(344.49,RCZ,0)),U,4)'=""
SET DR=DR_".07////"_$PIECE($GET(^RCY(344.49,RCZ,0)),U,4)_";"
+19 SET DA(1)=RECTDA1
SET DA=RCTRANDA
SET DIE="^RCY(344,"_DA(1)_",1,"
+20 DO ^DIE
+21 ;Update comment history - PRCA*4.5*321
+22 if RCCOM]""
DO AUDIT^RCDPECH(RECTDA1,RCTRANDA,RCZ,RCR)
+23 QUIT
+24 ; PRCA*4.5*326 Add RCDUZ parameter
BLDRCPT(RCERA,RCDUZ) ; Create a receipt for Auto Posting ERA with multiple Receipts - alpha char at the 10th character
+1 ; LAYGO new entry to AR BATCH PAYMENT file (#344)
+2 ; input - RCERA = Pointer to 344.4
+3 ; returns new IEN on success, else zero
+4 ; called by auto-post process (RCDPEAP)
+5 ;
+6 NEW RECEIPT,TYPE,LASTREC
+7 ; ^RC(341.1,0) = AR EVENT TYPE
SET TYPE=$EXTRACT($GET(^RC(341.1,+$ORDER(^RC(341.1,"AC",14,0)),0)))
+8 ; retrieve the last receipt recorded on the ERA (if it exists)
+9 SET LASTREC=$$GETREC(RCERA)
+10 ; Make sure last receipt for the ERA is 10-chars long and the last char is between A - Y (can't be Z),
+11 ; Otherwise grab a new number and append "A"
+12 IF LASTREC'=""
IF $LENGTH(LASTREC)=10
IF $ASCII($EXTRACT(LASTREC,10))>64
IF $ASCII($EXTRACT(LASTREC,10))<90
Begin DoDot:1
+13 SET RECEIPT=$EXTRACT(LASTREC,1,9)_$CHAR($ASCII($EXTRACT(LASTREC,10))+1)
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 SET RECEIPT=$$NEXT^RCDPUREC(TYPE_$EXTRACT(DT,2,7))_"A"
End DoDot:1
+16 ;
+17 ; Prevents duplicate Receipt # entries from being filed
+18 FOR
if '$DATA(^RCY(344,"B",RECEIPT))
QUIT
Begin DoDot:1
+19 SET RECEIPT=$EXTRACT(RECEIPT,1)_$EXTRACT(1000001+$EXTRACT(RECEIPT,2,7),2,7)_$EXTRACT(RECEIPT,8,9)_"A"
End DoDot:1
+20 ;
+21 ; if LOCK timeout return zero
LOCK +^RCY(344,"B",RECEIPT):DILOCKTM
IF '$TEST
QUIT 0
+22 ;
+23 ; add entry to AR BATCH PAYMENT file (#344)
+24 NEW %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y
+25 SET DIC="^RCY(344,"
SET DIC(0)="L"
SET DLAYGO=344
+26 ; .02 = opened by .03 = date opened = transmission date
+27 ; .04 = type of payment
+28 ; .14 = status (set to 1:open)
+29 SET DIC("DR")=".02////"_$SELECT($GET(RCDUZ):RCDUZ,1:DUZ)_";.03///"_DT_";.04////14;.14////1;"
+30 SET X=RECEIPT
+31 DO FILE^DICN
+32 LOCK -^RCY(344,"B",RECEIPT)
+33 ; Y set by DICN, return new IEN
IF Y>0
QUIT +Y
+34 ; entry not created
QUIT 0
+35 ;
GETREC(RCERA) ; returns the receipt number
+1 ; input - RCERA = ien of entry in 344.4
+2 ; output - returns the receipt number in external form
+3 NEW X,RECEIPT
+4 SET RECEIPT=""
+5 ; get last RECEIPT ien from 344.41 subfile
SET X=$ORDER(^RCY(344.4,RCERA,1,"RECEIPT",""),-1)
+6 ; get external form of receipt
if X
SET RECEIPT=$PIECE($GET(^RCY(344,X,0)),U)
+7 QUIT RECEIPT
