RCDPEM21.m

RCDPEM21 ;ALB/TMK/PJH - MANUAL MATCH TO PAPER EOB ;Jun 11, 2014@13:24:36

 ;;4.5;Accounts Receivable;**173,208,276,284,293,298,303,304,321,326**;Mar 20, 1995;Build 26

 ;;Per VA Directive 6402, this routine should not be modified.

 Q

 ;

 ; Called from [RCDPE ERA POSTED BY PAPER EOB]

 ;

 ; Begin PRCA*4.5*276 - PJH

POSTED ;

 N DIR,X,Y

 S DIR("A")="Select type of receipt to ERA link"

 S DIR("B")="M"

 S DIR(0)="S^M:Manually select receipt to post;"

 S DIR(0)=DIR(0)_"A:Automatic search for receipt to post"

 D ^DIR K DIR

 I Y="M" D MANUAL Q

 I Y="A" D AUTO

 Q

 ;

MANUAL ; Mark an ERA as posted when the data

 ; was previously posted using paper EOB information

 N DIC,DIE,DIR,DA,DR,ERA,RCPT,X,Y,%

 ; Must be unmatched or matched to paper check, must be accepted by FMS, must not be posted yet

 W !!,"THIS OPTION IS USED WHEN YOU HAVE POSTED AN ERA PAID WITH A PAPER CHECK",!,"BY USING THE PAPER EOB AND YOU DID NOT REFERENCE THE ERA IN THE RECEIPT",!!

MAN1 S DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0",DIC="^RCY(344.4,",DIC(0)="AEMQ"

 D ^DIC K DIC

 ;

 I Y'>0 G MANUALQ

 ;

 ;Check if ERA is already linked to a receipt

 I $$RCHECK(+Y) G MAN1

 S ERA=+Y

 ;

 S DIC="^RCY(344,",DIC(0)="AEMQ",DIC("A")="RECEIPT: ",DIC("S")="I $$FMS^RCDPEM21(Y,0)"

 D ^DIC K DIC

 I Y'>0 G MANUALQ

 S RCPT=+Y

 ;

 D NOW^%DTC

 ;Update Receipt #, EFT Match Status, Detail Post Status and Paper EOB

 S DIE="^RCY(344.4,",DR=".08////"_RCPT_";.09////2;.14////2;20.03////1",DA=ERA

 ;Update Date/Time Posted and User fields

 S DR=DR_";7.01///"_%_";7.02///"_DUZ

 D ^DIE

 I '$D(Y) D

 . S DIR(0)="EA",DIR("A",1)="ERA HAS BEEN MARKED AS POSTED USING PAPER EOB",DIR("A")="Press ENTER to continue: " D ^DIR K DIR

 ;

MANUALQ Q

 ;

 ;VISN 15 software - created by Karen Flores

 ;

AUTO ;Select ERA's for linking to receipt

 N EXIT

 S EXIT=0 F  D LNKERA Q:EXIT

 Q

 ;

RCHECK(RCSCR) ;Check if already linked to a receipt

 N REC,RNUM,RNAM,AMT

 S REC=$G(^RCY(344.4,RCSCR,0)),RNUM=$P(REC,U,8)

 ;Ignore check if zero amount ERA

 Q:'$P(REC,U,5) 0

 ;Check if already linked to a different receipt

 Q:'RNUM 0

 S RNAM=$P($G(^RCY(344,RNUM,0)),U)

 W !!,"ERA ",RCSCR," is already linked to receipt ",RNAM,!

 Q 1

 ;

LNKERA ;Select ERA

 N ABORT,DIC,DUOUT,DTOUT,REC,RCSCR,X,Y

 ;Must be unposted and either unmatched or matched to paper check

 S DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0"

 S DIC="^RCY(344.4,",DIC(0)="AEMQ" W ! D ^DIC K DIC

 S RCSCR=+Y I RCSCR'>0 S EXIT=1 Q

 ;Check if already linked to a different receipt

 Q:$$RCHECK(RCSCR)

 ;

 ;Finds receipt automatically from AR TRANSACTION file #433 

 N AMT,ART,ARTND1,ATTY,BILL,EOB,EOBND,FOUND,RCND,RCSCR1,RECEPT,TAMT

 N TRACE

 ;Trace# from ERA

 S TRACE=$P($G(^RCY(344.4,RCSCR,0)),U,2)

 ;Clear workfile

 K ^TMP("RCDPEM2",$J)

 ;

 S (FOUND,ABORT,RCSCR1)=0

 ;Scan claim lines in ERA for non zero bills

 F  S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:+RCSCR1=0!(FOUND)  D

 .S RCND=$G(^RCY(344.4,RCSCR,1,RCSCR1,0))

 .;Ignore bill if AMOUNT PAID is zero

 .S AMT=$P(RCND,"^",3) Q:+AMT=0

 .;Ignore if EOB has no EOB detail record

 .S EOB=+$P(RCND,"^",2) Q:'EOB

 .;Get EOB detail record

 .S EOBND=$G(^IBM(361.1,EOB,0))

 .;Extract Bill number from EOB detail

 .S BILL=$P(EOBND,"^",1) Q:BILL=""

 .;Ignore duplicate bills on ERA

 .Q:$D(^TMP("RCDPEM2",$J,BILL))

 .S ^TMP("RCDPEM2",$J,BILL)=""

 .;Search AR TRANSACTION file #433 for the bill - newest first

 .S ART=""

 .F  S ART=$O(^PRCA(433,"C",BILL,ART),-1) Q:+ART=0!(FOUND)  D

 ..S ARTND1=$G(^PRCA(433,ART,1))

 ..;Get transaction type

 ..S ATTY=$P(ARTND1,"^",2) Q:'ATTY

 ..;Ignore if not a payment

 ..S ATTY=$P($G(^PRCA(430.3,ATTY,0)),"^",1) Q:ATTY'["PAYMENT"

 ..;Get receipt number

 ..S RECEPT=$P(ARTND1,"^",3) Q:RECEPT=""

 ..;Ignore receipt if status is not 'ACCEPTED BY FMS'

 ..Q:'$$FMS(RECEPT,1)

 ..W !!,"PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)

 ..W !,"Bill number: ",$P($G(^DGCR(399,BILL,0)),U)

 ..W !,"Check #: ",$$CHQ(RECEPT,BILL)

 ..W !,"Trace #: ",TRACE

 ..W !,"DOS: ",$$FMTE^XLFDT($P($G(^DGCR(399,BILL,0)),U,3))

 ..S TAMT=+$P(ARTND1,"^",5)

 ..W !,"AR Transaction amount: ",TAMT

 ..W !,"RECEIPT#: ",RECEPT

 ..W !,"Date of Receipt: ",$$FMTE^XLFDT($$RCDATE^RCDPRU(RECEPT))

 ..W !,"Total Receipt AMOUNT: ",$J($$AMT^RCDPRU(RECEPT),2,2),!

 .. ; PRCA*4.5*284 Change default response from YES to NO

 ..S DIR(0)="Y",DIR("B")="NO"

 ..S DIR("A")="Link to update Remittance entry # "_RCSCR

 ..S DIR("A")=DIR("A")_" with receipt "_RECEPT

 ..D ^DIR K DIR

 ..;Aborted

 ..I $D(DUOUT)!$D(DTOUT) S ABORT=1,FOUND=1 Q

 ..;Attempt to update ERA - finish if successful

 ..I +Y>0 D UPDERA(RCSCR,RECEPT,.FOUND)

 ;Update failed

 I FOUND=0 W !!,"No matching payment transactions found for this ERA"

 ;Clear workfile

 K ^TMP("RCDPEM2",$J)

 Q

 ;

 ; Moved to RCDPRU because of size issues PRCA*4.5*303

UPDERA(DA,RECEPT,FOUND) ;Mark ERA as posted to paper EOB

 D UPDERA^RCDPRU(DA,RECEPT,.FOUND)

 Q FOUND

 ;

 ;Check FMS status

FMS(RECEPT,FLG) ;

 ; FLG = 1 if RECEPT contains receipt number

 ; FLG = 0 if RECEPT contains ien of the receipt

 N FMSDOCNO,RCRECTDA,RES

 S RES=0 I $G(RECEPT)="" G FMSX

 ;Get receipt IEN

 I 'FLG S RCRECTDA=RECEPT

 I FLG S RCRECTDA=$O(^RCY(344,"B",RECEPT,0))

 I 'RCRECTDA G FMSX

 ;Get FMS document number

 S FMSDOCNO=$$FMSSTAT^RCDPUREC(RCRECTDA)

 ;Ignore if not accepted

 I $P(FMSDOCNO,U,2)'="ACCEPTED BY FMS" G FMSX

 ;Otherwise can be linked

 S RES=1

FMSX ;

 Q RES

 ;

CHQ(RECEPT,BILL) ;Get check number for this bill

 N RCRECTDA,RCTRAN,RCCHK,PATBILL

 ;Get receipt IEN

 S RCRECTDA=$O(^RCY(344,"B",RECEPT,0)) Q:'RCRECTDA ""

 ;Scan Receipt looking for this bill IEN

 S RCTRAN=0,RCCHK=""

 F  S RCTRAN=$O(^RCY(344,RCRECTDA,1,RCTRAN)) Q:'RCTRAN  D  Q:RCCHK]""

 .;Check for match on bill IEN

 .S PATBILL=$P($G(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,3)

 .;Ignore Patient pointers or null field

 .Q:$P(PATBILL,";",2)'="PRCA(430,"

 .;Compare bill IEN399 to IEN430

 .Q:$P(PATBILL,";")'=BILL

 .;Get check number for this line

 .S RCCHK=$P($G(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,7)

 Q RCCHK

 ;

 ;; End PRCA*4.5*276 - PJH

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RCDPEM21   6132     printed  Apr 23, 2025@17:59:13                                                                                                                                                                                                    Page 2

RCDPEM21  ;ALB/TMK/PJH - MANUAL MATCH TO PAPER EOB ;Jun 11, 2014@13:24:36

 +1       ;;4.5;Accounts Receivable;**173,208,276,284,293,298,303,304,321,326**;Mar 20, 1995;Build 26

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3        QUIT 

 +4       ;

 +5       ; Called from [RCDPE ERA POSTED BY PAPER EOB]

 +6       ;

 +7       ; Begin PRCA*4.5*276 - PJH

POSTED    ;

 +1        NEW DIR,X,Y

 +2        SET DIR("A")="Select type of receipt to ERA link"

 +3        SET DIR("B")="M"

 +4        SET DIR(0)="S^M:Manually select receipt to post;"

 +5        SET DIR(0)=DIR(0)_"A:Automatic search for receipt to post"

 +6        DO ^DIR

           KILL DIR

 +7        IF Y="M"

               DO MANUAL

               QUIT 

 +8        IF Y="A"

               DO AUTO

 +9        QUIT 

 +10      ;

MANUAL    ; Mark an ERA as posted when the data

 +1       ; was previously posted using paper EOB information

 +2        NEW DIC,DIE,DIR,DA,DR,ERA,RCPT,X,Y,%

 +3       ; Must be unmatched or matched to paper check, must be accepted by FMS, must not be posted yet

 +4        WRITE !!,"THIS OPTION IS USED WHEN YOU HAVE POSTED AN ERA PAID WITH A PAPER CHECK",!,"BY USING THE PAPER EOB AND YOU DID NOT REFERENCE THE ERA IN THE RECEIPT",!!

MAN1       SET DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0"

           SET DIC="^RCY(344.4,"

           SET DIC(0)="AEMQ"

 +1        DO ^DIC

           KILL DIC

 +2       ;

 +3        IF Y'>0

               GOTO MANUALQ

 +4       ;

 +5       ;Check if ERA is already linked to a receipt

 +6        IF $$RCHECK(+Y)

               GOTO MAN1

 +7        SET ERA=+Y

 +8       ;

 +9        SET DIC="^RCY(344,"

           SET DIC(0)="AEMQ"

           SET DIC("A")="RECEIPT: "

           SET DIC("S")="I $$FMS^RCDPEM21(Y,0)"

 +10       DO ^DIC

           KILL DIC

 +11       IF Y'>0

               GOTO MANUALQ

 +12       SET RCPT=+Y

 +13      ;

 +14       DO NOW^%DTC

 +15      ;Update Receipt #, EFT Match Status, Detail Post Status and Paper EOB

 +16       SET DIE="^RCY(344.4,"

           SET DR=".08////"_RCPT_";.09////2;.14////2;20.03////1"

           SET DA=ERA

 +17      ;Update Date/Time Posted and User fields

 +18       SET DR=DR_";7.01///"_%_";7.02///"_DUZ

 +19       DO ^DIE

 +20       IF '$DATA(Y)

               Begin DoDot:1

 +21               SET DIR(0)="EA"

                   SET DIR("A",1)="ERA HAS BEEN MARKED AS POSTED USING PAPER EOB"

                   SET DIR("A")="Press ENTER to continue: "

                   DO ^DIR

                   KILL DIR

               End DoDot:1

 +22      ;

MANUALQ    QUIT 

 +1       ;

 +2       ;VISN 15 software - created by Karen Flores

 +3       ;

AUTO      ;Select ERA's for linking to receipt

 +1        NEW EXIT

 +2        SET EXIT=0

           FOR 

               DO LNKERA

               if EXIT

                   QUIT 

 +3        QUIT 

 +4       ;

RCHECK(RCSCR) ;Check if already linked to a receipt

 +1        NEW REC,RNUM,RNAM,AMT

 +2        SET REC=$GET(^RCY(344.4,RCSCR,0))

           SET RNUM=$PIECE(REC,U,8)

 +3       ;Ignore check if zero amount ERA

 +4        if '$PIECE(REC,U,5)

               QUIT 0

 +5       ;Check if already linked to a different receipt

 +6        if 'RNUM

               QUIT 0

 +7        SET RNAM=$PIECE($GET(^RCY(344,RNUM,0)),U)

 +8        WRITE !!,"ERA ",RCSCR," is already linked to receipt ",RNAM,!

 +9        QUIT 1

 +10      ;

LNKERA    ;Select ERA

 +1        NEW ABORT,DIC,DUOUT,DTOUT,REC,RCSCR,X,Y

 +2       ;Must be unposted and either unmatched or matched to paper check

 +3        SET DIC("S")="I ""02""[+$P(^(0),U,9),$P(^(0),U,14)=0"

 +4        SET DIC="^RCY(344.4,"

           SET DIC(0)="AEMQ"

           WRITE !

           DO ^DIC

           KILL DIC

 +5        SET RCSCR=+Y

           IF RCSCR'>0

               SET EXIT=1

               QUIT 

 +6       ;Check if already linked to a different receipt

 +7        if $$RCHECK(RCSCR)

               QUIT 

 +8       ;

 +9       ;Finds receipt automatically from AR TRANSACTION file #433 

 +10       NEW AMT,ART,ARTND1,ATTY,BILL,EOB,EOBND,FOUND,RCND,RCSCR1,RECEPT,TAMT

 +11       NEW TRACE

 +12      ;Trace# from ERA

 +13       SET TRACE=$PIECE($GET(^RCY(344.4,RCSCR,0)),U,2)

 +14      ;Clear workfile

 +15       KILL ^TMP("RCDPEM2",$JOB)

 +16      ;

 +17       SET (FOUND,ABORT,RCSCR1)=0

 +18      ;Scan claim lines in ERA for non zero bills

 +19       FOR 

               SET RCSCR1=$ORDER(^RCY(344.4,RCSCR,1,RCSCR1))

               if +RCSCR1=0!(FOUND)

                   QUIT 

               Begin DoDot:1

 +20               SET RCND=$GET(^RCY(344.4,RCSCR,1,RCSCR1,0))

 +21      ;Ignore bill if AMOUNT PAID is zero

 +22               SET AMT=$PIECE(RCND,"^",3)

                   if +AMT=0

                       QUIT 

 +23      ;Ignore if EOB has no EOB detail record

 +24               SET EOB=+$PIECE(RCND,"^",2)

                   if 'EOB

                       QUIT 

 +25      ;Get EOB detail record

 +26               SET EOBND=$GET(^IBM(361.1,EOB,0))

 +27      ;Extract Bill number from EOB detail

 +28               SET BILL=$PIECE(EOBND,"^",1)

                   if BILL=""

                       QUIT 

 +29      ;Ignore duplicate bills on ERA

 +30               if $DATA(^TMP("RCDPEM2",$JOB,BILL))

                       QUIT 

 +31               SET ^TMP("RCDPEM2",$JOB,BILL)=""

 +32      ;Search AR TRANSACTION file #433 for the bill - newest first

 +33               SET ART=""

 +34               FOR 

                       SET ART=$ORDER(^PRCA(433,"C",BILL,ART),-1)

                       if +ART=0!(FOUND)

                           QUIT 

                       Begin DoDot:2

 +35                       SET ARTND1=$GET(^PRCA(433,ART,1))

 +36      ;Get transaction type

 +37                       SET ATTY=$PIECE(ARTND1,"^",2)

                           if 'ATTY

                               QUIT 

 +38      ;Ignore if not a payment

 +39                       SET ATTY=$PIECE($GET(^PRCA(430.3,ATTY,0)),"^",1)

                           if ATTY'["PAYMENT"

                               QUIT 

 +40      ;Get receipt number

 +41                       SET RECEPT=$PIECE(ARTND1,"^",3)

                           if RECEPT=""

                               QUIT 

 +42      ;Ignore receipt if status is not 'ACCEPTED BY FMS'

 +43                       if '$$FMS(RECEPT,1)

                               QUIT 

 +44                       WRITE !!,"PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)

 +45                       WRITE !,"Bill number: ",$PIECE($GET(^DGCR(399,BILL,0)),U)

 +46                       WRITE !,"Check #: ",$$CHQ(RECEPT,BILL)

 +47                       WRITE !,"Trace #: ",TRACE

 +48                       WRITE !,"DOS: ",$$FMTE^XLFDT($PIECE($GET(^DGCR(399,BILL,0)),U,3))

 +49                       SET TAMT=+$PIECE(ARTND1,"^",5)

 +50                       WRITE !,"AR Transaction amount: ",TAMT

 +51                       WRITE !,"RECEIPT#: ",RECEPT

 +52                       WRITE !,"Date of Receipt: ",$$FMTE^XLFDT($$RCDATE^RCDPRU(RECEPT))

 +53                       WRITE !,"Total Receipt AMOUNT: ",$JUSTIFY($$AMT^RCDPRU(RECEPT),2,2),!

 +54      ; PRCA*4.5*284 Change default response from YES to NO

 +55                       SET DIR(0)="Y"

                           SET DIR("B")="NO"

 +56                       SET DIR("A")="Link to update Remittance entry # "_RCSCR

 +57                       SET DIR("A")=DIR("A")_" with receipt "_RECEPT

 +58                       DO ^DIR

                           KILL DIR

 +59      ;Aborted

 +60                       IF $DATA(DUOUT)!$DATA(DTOUT)

                               SET ABORT=1

                               SET FOUND=1

                               QUIT 

 +61      ;Attempt to update ERA - finish if successful

 +62                       IF +Y>0

                               DO UPDERA(RCSCR,RECEPT,.FOUND)

                       End DoDot:2

               End DoDot:1

 +63      ;Update failed

 +64       IF FOUND=0

               WRITE !!,"No matching payment transactions found for this ERA"

 +65      ;Clear workfile

 +66       KILL ^TMP("RCDPEM2",$JOB)

 +67       QUIT 

 +68      ;

 +69      ; Moved to RCDPRU because of size issues PRCA*4.5*303

UPDERA(DA,RECEPT,FOUND) ;Mark ERA as posted to paper EOB

 +1        DO UPDERA^RCDPRU(DA,RECEPT,.FOUND)

 +2        QUIT FOUND

 +3       ;

 +4       ;Check FMS status

FMS(RECEPT,FLG) ;

 +1       ; FLG = 1 if RECEPT contains receipt number

 +2       ; FLG = 0 if RECEPT contains ien of the receipt

 +3        NEW FMSDOCNO,RCRECTDA,RES

 +4        SET RES=0

           IF $GET(RECEPT)=""

               GOTO FMSX

 +5       ;Get receipt IEN

 +6        IF 'FLG

               SET RCRECTDA=RECEPT

 +7        IF FLG

               SET RCRECTDA=$ORDER(^RCY(344,"B",RECEPT,0))

 +8        IF 'RCRECTDA

               GOTO FMSX

 +9       ;Get FMS document number

 +10       SET FMSDOCNO=$$FMSSTAT^RCDPUREC(RCRECTDA)

 +11      ;Ignore if not accepted

 +12       IF $PIECE(FMSDOCNO,U,2)'="ACCEPTED BY FMS"

               GOTO FMSX

 +13      ;Otherwise can be linked

 +14       SET RES=1

FMSX      ;

 +1        QUIT RES

 +2       ;

CHQ(RECEPT,BILL) ;Get check number for this bill

 +1        NEW RCRECTDA,RCTRAN,RCCHK,PATBILL

 +2       ;Get receipt IEN

 +3        SET RCRECTDA=$ORDER(^RCY(344,"B",RECEPT,0))

           if 'RCRECTDA

               QUIT ""

 +4       ;Scan Receipt looking for this bill IEN

 +5        SET RCTRAN=0

           SET RCCHK=""

 +6        FOR 

               SET RCTRAN=$ORDER(^RCY(344,RCRECTDA,1,RCTRAN))

               if 'RCTRAN

                   QUIT 

               Begin DoDot:1

 +7       ;Check for match on bill IEN

 +8                SET PATBILL=$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,3)

 +9       ;Ignore Patient pointers or null field

 +10               if $PIECE(PATBILL,";",2)'="PRCA(430,"

                       QUIT 

 +11      ;Compare bill IEN399 to IEN430

 +12               if $PIECE(PATBILL,";")'=BILL

                       QUIT 

 +13      ;Get check number for this line

 +14               SET RCCHK=$PIECE($GET(^RCY(344,RCRECTDA,1,RCTRAN,0)),U,7)

               End DoDot:1

               if RCCHK]""

                   QUIT 

 +15       QUIT RCCHK

 +16      ;

 +17      ;; End PRCA*4.5*276 - PJH

 +18      ;