Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPEMA

RCDPEMA.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. 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
  1. ; RECTDA1 = ien of receipt entry in file 344
  1. ; RCER = error array returned if passed by reference
  1. ; RCLINES = array to indicate which scratchpad lines can be posted (assigned a receipt)
  1. ;
  1. N DA,DIE,DR,Q,RCDUZ,RCLINE,RCOSEQ,RCQ,RCR,RCSPL,RCTRANDA,RCZ0,SEQLINES,RCSEQ,X,Y,Z,Z0,Z1
  1. ;
  1. S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D
  1. . S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0)),RCSEQ=$P(RCZ0,U)
  1. . ;Check first line for prefix to see if ERA line is valid for auto-post
  1. . I RCSEQ?1N.N,$P(RCZ0,U,9),$P($G(RCLINES($P(RCZ0,U,9))),U) S SEQLINES(RCSEQ)=""
  1. . ;Skip WORKLIST lines that do not need associated receipt detail
  1. . Q:'$D(SEQLINES(RCSEQ\1))
  1. . I RCSEQ'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q
  1. . 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
  1. . S RCOSEQ=$G(RCSPL(RCSEQ\1)) ; PRCA*4.5*326
  1. . S RCDUZ=$$GET1^DIQ(344.41,RCOSEQ_","_RCRZ_",",6.01,"I") ; PRCA*4.5*326
  1. . S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1,RCDUZ) ; PRCA*4.5*326 Pass RCDUZ
  1. . ;
  1. . I RCTRANDA'>0 D Q ; Error adding receipt detail - PRCA*4.5*318
  1. .. S RCER(1)=$$SETERR^RCDPEM0(1) ; PRCA*4.5*318 - pass RCPROC value to $$SETERR
  1. .. 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"
  1. . ;
  1. . ;Store receipt line detail
  1. . D DET(RCRZ,RCR,RECTDA1,RCTRANDA)
  1. . S RCSPL(RCZ0\1,+RCZ0)=RCZ0
  1. ;
  1. ; Update A/R CORRECTED PAYMENT multiple with apportionment for split lines
  1. S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D
  1. .; Move EEOB if one claim entered-changed 10/19/11-see +25^RCDPEWL8
  1. . S Z1=$O(RCSPL(Z,"")) Q:Z1=""
  1. . I $O(RCSPL(Z,""),-1)=Z1,'$$SPLIT(Z,Z1,RCERA) Q ; No split occurred
  1. . S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D
  1. .. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec
  1. .. Q:'Q
  1. .. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspense
  1. ... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050
  1. .. E D
  1. ... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050
  1. . ; BEGIN - PRCA*4.5*321
  1. . ;Move/Copy/Remove EEOB detail for split line
  1. . N CLAIM,IEN3611,RCSPLIT,RCSUB,RCZSAV
  1. . ; Sub-array of split claim detail for individual line
  1. . M RCSPLIT=RCSPL(Z)
  1. . ; Protect Z subscript variable from overwrite by triggers
  1. . S RCZSAV=Z
  1. . ; Get scratchpad line number for this ERA line
  1. . S RCSUB=$O(^RCY(344.49,RCRZ,1,"ASEQ",Z,""))
  1. . ; Original claim number from Scratchpad line
  1. . S CLAIM=$$GET1^DIQ(344.491,RCSUB_","_RCRZ_",",.02)
  1. . ; EOB for original claim from ERA line
  1. . S IEN3611=$$GET1^DIQ(344.41,RCQ_","_RCRZ_",",.02,"I")
  1. . ; Automatic Move/Copy/Remove EOB
  1. . I $$AUTO^RCDPEM5(CLAIM,.RCSPLIT,RCERA,"A",IEN3611)
  1. . ; Restore Z
  1. . S Z=RCZSAV
  1. . ; END - PRCA*4.5*321 ;
  1. Q
  1. ;
  1. SPLIT(Z,Z1,RCERA) ;Check if worklist was split to single claim
  1. N SUB,NBILL,OBILL
  1. ;Find split line in scratchpad
  1. S SUB=$O(^RCY(344.49,RCERA,1,"B",Z1,"")) Q:'SUB 0
  1. ;Get original claim number from scratchpad
  1. S OBILL=$P($G(^RCY(344.49,RCERA,1,SUB-1,0)),U,2)
  1. ;New claim number
  1. S NBILL=$P(RCSPL(Z,Z1),U,2)
  1. ;If new and old claim are not the same this is a move via split
  1. I OBILL'="",OBILL'=NBILL Q 1
  1. ;Otherwise this is not a split
  1. Q 0
  1. ;
  1. DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail
  1. ; RCZ = ien of entry file 344.49
  1. ; RCR = ien of entry in file 344.491
  1. ; RECTDA1 = ien of entry in file 344
  1. ; RCTRANDA = ien of entry in subfile 344.01
  1. ;
  1. N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0
  1. S RC0=$G(^RCY(344.49,RCZ,0))
  1. S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0))
  1. S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0))
  1. I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";"
  1. S DR=DR_".04////"_(+$P(RCZ0,U,3))_";.27////"_RCR_";"
  1. I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";"
  1. I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";"
  1. 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
  1. S RCCOM=$P(RCZ0,U,10)
  1. 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")
  1. I RCCOM]"" S DR=DR_"1.02////"_$E(RCCOM,1,60)_";"
  1. I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";"
  1. S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1,"
  1. D ^DIE
  1. ;Update comment history - PRCA*4.5*321
  1. D:RCCOM]"" AUDIT^RCDPECH(RECTDA1,RCTRANDA,RCZ,RCR)
  1. Q
  1. ; PRCA*4.5*326 Add RCDUZ parameter
  1. 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)
  1. ; input - RCERA = Pointer to 344.4
  1. ; returns new IEN on success, else zero
  1. ; called by auto-post process (RCDPEAP)
  1. ;
  1. N RECEIPT,TYPE,LASTREC
  1. S TYPE=$E($G(^RC(341.1,+$O(^RC(341.1,"AC",14,0)),0))) ; ^RC(341.1,0) = AR EVENT TYPE
  1. ; retrieve the last receipt recorded on the ERA (if it exists)
  1. S LASTREC=$$GETREC(RCERA)
  1. ; Make sure last receipt for the ERA is 10-chars long and the last char is between A - Y (can't be Z),
  1. ; Otherwise grab a new number and append "A"
  1. I LASTREC'="",$L(LASTREC)=10,$A($E(LASTREC,10))>64,$A($E(LASTREC,10))<90 D
  1. . S RECEIPT=$E(LASTREC,1,9)_$C($A($E(LASTREC,10))+1)
  1. E D
  1. . S RECEIPT=$$NEXT^RCDPUREC(TYPE_$E(DT,2,7))_"A"
  1. ;
  1. ; Prevents duplicate Receipt # entries from being filed
  1. F Q:'$D(^RCY(344,"B",RECEIPT)) D
  1. . S RECEIPT=$E(RECEIPT,1)_$E(1000001+$E(RECEIPT,2,7),2,7)_$E(RECEIPT,8,9)_"A"
  1. ;
  1. L +^RCY(344,"B",RECEIPT):DILOCKTM E Q 0 ; if LOCK timeout return zero
  1. ;
  1. ; add entry to AR BATCH PAYMENT file (#344)
  1. N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y
  1. S DIC="^RCY(344,",DIC(0)="L",DLAYGO=344
  1. ; .02 = opened by .03 = date opened = transmission date
  1. ; .04 = type of payment
  1. ; .14 = status (set to 1:open)
  1. S DIC("DR")=".02////"_$S($G(RCDUZ):RCDUZ,1:DUZ)_";.03///"_DT_";.04////14;.14////1;"
  1. S X=RECEIPT
  1. D FILE^DICN
  1. L -^RCY(344,"B",RECEIPT)
  1. I Y>0 Q +Y ; Y set by DICN, return new IEN
  1. Q 0 ; entry not created
  1. ;
  1. GETREC(RCERA) ; returns the receipt number
  1. ; input - RCERA = ien of entry in 344.4
  1. ; output - returns the receipt number in external form
  1. N X,RECEIPT
  1. S RECEIPT=""
  1. S X=$O(^RCY(344.4,RCERA,1,"RECEIPT",""),-1) ; get last RECEIPT ien from 344.41 subfile
  1. S:X RECEIPT=$P($G(^RCY(344,X,0)),U) ; get external form of receipt
  1. Q RECEIPT