RCDPEWL4 ;ALB/TMK/PJH - ELECTRONIC EOB WORKLIST ACTIONS ;Jun 06, 2014@19:11:19
;;4.5;Accounts Receivable;**173,208,269,298,303,318,326,349,367**;Mar 20, 1995;Build 11
;;Per VA Directive 6402, this routine should not be modified.
; RCSCR variable must be defined for this routine
Q
;
DISTADJ(RCFR,RCTO,RCAMT,RCCOM) ; Action that distributes an adjustment amount
; against another line item's payment
; Assumes RCSCR = ien of the entry in file 344.49
; RCFR = ien of entry in 344.491 that has a negative net
; RCTO = ien of entry in 344.491 that will be decremented
; RCAMT = the amount being adjusted (positive #)
; RCCOM = the comment to place on the decrease adjustment
;
N RCFRX,RCREF,RCFR0,RCFR1,RCFR10,RCTO0,RCTO1,RCTO10,RCY
N DA,DD,DIK,DR,DIC,DIE,DIK,DIR,DLAYGO,DO,NONVA,X,Y ; PRCA*4.5*326
I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
S RCFR0=$G(^RCY(344.49,RCSCR,1,RCFR,0)),RCTO0=$G(^RCY(344.49,RCSCR,1,RCTO,0)),RCFRX=+$O(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0)),RCFRX=$G(^RCY(344.49,RCSCR,1,RCFRX,0))
S RCREF=$P($P(RCFRX,U,2),"**ADJ",2),RCREF=$S(RCREF="":"",RCREF=0:$P(RCFRX,U,9),1:$P($G(^RCY(344.4,RCSCR,2,+RCREF,0)),U))
S RCFR1=+$O(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0)),RCTO1=+$O(^RCY(344.49,RCSCR,1,"B",RCTO0\1,0))
S RCFR10=$G(^RCY(344.49,RCSCR,1,RCFR1,0)),RCTO10=$G(^RCY(344.49,RCSCR,1,RCTO1,0))
S RCFR0=$G(^RCY(344.49,RCSCR,1,RCFR,0)),RCTO0=$G(^RCY(344.49,RCSCR,1,RCTO,0))
S DA(2)=RCSCR,DA(1)=RCFR
S DIC("DR")=".02////1;.03////"_RCAMT_";.04////"_$S($P(RCTO0,U,2)'="":$P(RCTO0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
S DIC("DR")=DIC("DR")_";.05////0;.06////0;.09////RETRACTED FUNDS DEDUCTED FROM OTHER PAYMENT ON THIS ERA",DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCFR,1,"B",""),-1)+1
D FILE^DICN K DIC,DD,DO,DLAYGO
S RCY=+Y
I RCY'>0 D Q
. S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
;
S DA(2)=RCSCR,DA(1)=RCTO
; BEGIN PRCA*4.5*326
; Check if the distribution is to a non-VA claim
S NONVA=0 I $P($G(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ",'$P(RCTO0,U,7) S NONVA=1
S DIC("DR")=".02////0;.03////"_$J(-RCAMT,"",2)
S DIC("DR")=DIC("DR")_";.04////"_$S($P(RCFR0,U,2)'="":$P(RCFR0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
; If a non-VA distribution the background action is set none - comment is fixed text concatenated with PLB comment
S DIC("DR")=DIC("DR")_";.05////"_$S(NONVA:0,$P($G(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ":"1;.08////0",1:0)
S DIC("DR")=DIC("DR")_";.06////0"_$S(RCCOM'="":";.09////"_RCCOM,1:"")
; END PRCA*4.5*326
;
S DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCTO,1,"B",""),-1)+1
D FILE^DICN K DIC,DD,DO,DLAYGO
S RCY=+Y
;
I RCY'>0 D Q
. N DA
. S DA(2)=RCSCR,DA(1)=RCFR,DA=RCY,DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1," D ^DIK
. S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
;
S DA(1)=RCSCR,DA=RCFR,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCFR0,U,6)+RCAMT,"",2)_";.08////"_$J($P(RCFR0,U,8)+RCAMT,"",2) D ^DIE
S DA=RCFR1,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCFR10,U,6)+RCAMT,"",2) D ^DIE
S DA(1)=RCSCR,DA=RCTO,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCTO0,U,6)-RCAMT,"",2)_";.03////"_$J($P(RCTO0,U,3)-RCAMT,"",2)_";.08////"_$J($P(RCTO0,U,8)-RCAMT,"",2) D ^DIE
S DA(1)=RCSCR,DA=RCTO1,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCTO10,U,6)-RCAMT,"",2)_";.03////"_$J($P(RCTO10,U,3)-RCAMT,"",2)_";.08////"_$J($P(RCTO10,U,8)-RCAMT,"",2) D ^DIE
;
; If the distribution is to a none-VA claim set the receipt line comment - this is picked up in DET^RCDPEM when the receipt is created
I NONVA S DA(1)=RCSCR,DA=RCTO,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".1///"_RCCOM D ^DIE ; PRCA*4.5*326
D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
Q
;
NEWREC ; Create a new receipt from scratch pad entry
N CT,DA,DIC,DIE,DIR,DR,RCDEP,RCER,RCHAC,RCOK,RCPAYTY,RCRECTDA,RCSTOP,RECTDA,X,Y,Z,Z0 ; PRCA*4.5*367
D FULL^VALM1
I $G(RCSCR("NOEDIT"))=2 D NOTAV^RCDPEWL2 G NEWRECQ
S (RCSTOP,RCOK)=0,VALMBCK="R"
S RECTDA=$P($G(^RCY(344.49,RCSCR,0)),U,2)
I 'RECTDA S RECTDA=$P($G(^RCY(344.4,RCSCR,0)),U,8)
; PRCA*4.5*303 - Corrected receipt number display to use RECTDA in the DIR("A",1) variable
I RECTDA D G NEWRECQ
. S DIR(0)="EA",DIR("A",1)="THIS ERA ALREADY HAS A RECEIPT - "_$P($G(^RCY(344,RECTDA,0)),U)_" - NO RECEIPT CREATED",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
S DIR("A",1)="THIS ACTION WILL CREATE THE RECEIPT FOR THIS ERA. ONCE THE RECEIPT IS",DIR("A",2)=" CREATED HERE, NO MORE AUTOMATIC ADJUSTMENTS MAY BE MADE FOR THIS ERA.",DIR("A",3)=" "
S DIR("A")="ARE YOU SURE YOU ARE READY TO CREATE THIS RECEIPT?: ",DIR("B")="NO",DIR(0)="YA"
W ! D ^DIR K DIR W !
I Y'=1 S DIR(0)="EA",DIR("A")="NO RECEIPT CREATED - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR G NEWRECQ
I $$HASADJ^RCDPEWL8(RCSCR,.RCOK) D G NEWRECQ
. S DIR(0)="EA",DIR("A",1)="AT LEAST ONE LINE ITEM WAS FOUND WITH A NEGATIVE PAYMENT AMOUNT",DIR("A")="NO RECEIPT CAN BE CREATED - PRESS RETURN TO CONTINUE " D ^DIR K DIR S RCSTOP=1
I 'RCOK S DIR(0)="EA",DIR("A")="NO RECEIPT CAN BE CREATED - NO POSTABLE LINE ITEMS WERE FOUND" W ! D ^DIR K DIR G NEWRECQ
;
S RCHAC=$$HACERA^RCDPEU(RCSCR)
S RCPAYTY=$S(RCHAC:17,$P($G(^RCY(344.4,+RCSCR,5)),U,2)="":14,1:4) ; PRCA*4.5*367 - Use CHAMPVA receipt type for CHAMPVA payments
S RCDEP=""
I RCPAYTY=4 D
. N RCOK1
. F D Q:RCOK1
.. S RCOK1=1
.. S DIC="^RCY(344.1,",DIC("S")="I $P(^(0),U,12)=1",DIC(0)="AEMQ" D ^DIC
.. Q:Y'>0
.. S RCDEP=+Y
.. I RCDEP,$$TOOOLD^RCDPEWLA(RCDEP) S RCOK1=0,RCDEP=""
S RECTDA=$$BLDRCPT^RCDPUREC(DT,+RCDEP_$S(RCPAYTY=4:"ERACHK",1:""),+$O(^RC(341.1,"AC",+RCPAYTY,0))) ; Note:ERA with paper check is type 4, but receipt needs to start with an 'E'
I 'RECTDA W ! S DIR(0)="EA",DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THE RECEIPT - NO RECEIPT ADDED",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR G NEWRECQ
;
D RCPTDET^RCDPEM(RCSCR,RECTDA,.RCER)
;PRCA*4.5*367 - Calculate Receipt Total for CHAMPVA Receipts
I RCHAC D
. N RCFDA,RCPTOT,I
. S (RCPTOT,I)=0
. F S I=$O(^RCY(344.49,RCSCR,1,I)) Q:'I D
.. Q:$P(^RCY(344.49,RCSCR,1,I,0),U)'["."
.. S RCPTOT=RCPTOT+$P(^RCY(344.49,RCSCR,1,I,0),U,3)
. S RCFDA(344,RECTDA_",",.22)=RCPTOT
. D FILE^DIE(,"RCFDA")
;
S DIE="^RCY(344.49,",DA=RCSCR,DR=".02////"_RECTDA D ^DIE
S DIE="^RCY(344.4,",DA=RCSCR,DR=".08////"_RECTDA D ^DIE
S Z=+$O(^RCY(344.31,"AERA",RCSCR,0))
S DIE="^RCY(344,",DA=RECTDA,DR=".18////"_RCSCR_$S(Z:";.17////"_Z,1:"")_$S(RCPAYTY=4:";.06////"_RCDEP,1:"")_$S($P($G(^RCY(344.31,Z,0)),U,15)'="":";.16////"_$P(^RCY(344.31,Z,0),U,15),1:"") D ^DIE
;
I $O(RCER(0)) D
. S CT=1,DIR(0)="EA",DIR("A",1)="THE FOLLOWING PROBLEMS OCCURRED WHILE ADDING THE RECEIPT: "
. S Z=0 F S Z=$O(RCER(Z)) Q:'Z S CT=CT+1,DIR("A",CT)=RCER(Z)
. S DIR("A")="PRESS RETURN TO CONTINUE "
. W ! D ^DIR K DIR
;
S DIR(0)="YA",DIR("A")="DO YOU WANT TO GO TO RECEIPT PROCESSING NOW? ",DIR("A",1)=" ",DIR("A",2)="RECEIPT "_$P($G(^RCY(344,+RECTDA,0)),U)_" HAS BEEN CREATED FOR THIS ERA",DIR("B")="YES" W ! D ^DIR K DIR
I Y=1 S RCRECTDA=RECTDA D EN^VALM("RCDP RECEIPT PROFILE")
S RCSCR=0
S VALMBCK="Q"
;
NEWRECQ Q
;
VRECPT ;EP - Protocol action - RCDPE EOB WL RECEIPT VIEW
; Preview receipt lines
; Assume RCSCR = ien from file 344.49 (and 344.4)
N DIR,RCOK,RCZ,X,Y,Z,Z0
D FULL^VALM1
S VALMBCK="R"
I $S($P($G(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0) D VR^RCDPEWLP(RCSCR) G VRECPTQ ; prca*4.5*298 auto-posted ERAs are handled differently
;
;
; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
; batches but just remove from execution.
; I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
;I $O(^RCY(344.49,RCSCR,3,0)) D Q:'RCOK
;. S RCOK=1
;. S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z I '$P($G(^(Z,0)),U,3) S RCOK=0 Q
;. I 'RCOK S DIR(0)="EA",DIR("A",1)="A RECEIPT CANNOT BE PREVIEWED UNTIL ALL BATCHES FOR THIS ERA ARE MARKED AS",DIR("A",2)="'READY TO POST'",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR
; end of prca*4.5*298
S Z=0 F S Z=$O(^RCY(344.49,RCSCR,1,Z)) Q:'Z I $P(Z,".",2) S Z0=$G(^(Z,0)) I $P(Z0,U,6)<0 S RCZ($P(Z0,U))=$P(Z0,U,2)_U_$P(Z0,U,6)
I $O(RCZ(""))'="" D
. W !,"THE FOLLOWING LINES HAVE A NET PAYMENT LESS THAN 0. THESE LINES MUST HAVE",!,"THIS NEGATIVE AMOUNT DISTRIBUTED TO OTHER LINE(S) IN THE ERA BEFORE A",!,"RECEIPT CAN BE CREATED."
. S Z="" F S Z=$O(RCZ(Z)) Q:Z="" W !,$J("",5)_$J(Z,10)_" "_$E($P(RCZ(Z),U)_$J("",15),1,15)_" "_$J(+$P(RCZ(Z),U,2),"",2)
. W !
. S DIR(0)="E" D ^DIR K DIR
;
I '$D(^XUSEC("RCDPEPP",DUZ)) D Q ; PRCA*4.5*349 - Added AM worklist preview
. D EN^VALM("RCDPE EOB RECEIPT PREVIEW AM"),VRECPTQ
D EN^VALM("RCDPE EOB RECEIPT PREVIEW")
VRECPTQ ;
S VALMBCK=$S('$G(RCSCR):"Q",1:"R")
Q
;
; PRCA*4.5*303 - Receipt Processing
RECPROC ;EP - Protocol action - RCDPE EON WORKLIST RECEIPT PROCESSING
; Receipt Processing
; Called by RCDPE EOB WORKLIST RECEIPT PROCESSING protocol
; Assume RCSCR is the IEN from file 344.49 (and 344.4)
; Variable RCRECTDA is needed by RECEIPT PROFILE so is not newed
; Variable RCDPFXIT is used by RCDPLPLM for immediate exit so newed it here so that does not happen
;
N ARRAY,RECIEN,RECEIPT,CNT,DIR,X,Y,DTOUT,DUOUT,DROUT,DIRUT,I,LIST,RCDPFXIT
D FULL^VALM1
S VALMBCK="R"
I '$D(^XUSEC("RCDPEPP",DUZ)) D Q ; PRCA*4.5*318 Added security key check
. W !!,"This action can only be taken by users that have the RCDPEPP security key.",!
. D PAUSE^VALM1
;
; Get list of receipts from the ERA detail multiple
S RECIEN=0,CNT=0
F S RECIEN=$O(^RCY(344.4,RCSCR,1,"RECEIPT",RECIEN)) Q:'RECIEN D
. S RECEIPT=$P($G(^RCY(344,RECIEN,0)),U)
. I RECEIPT]"" S CNT=CNT+1,ARRAY(CNT)=RECEIPT_"^"_RECIEN
;
; The array of receipts does not exist, this could be a non auto-posted ERA; so only 1 receipt will be assigned; retrieve at 344.4, .08
I '$D(ARRAY),$$GET1^DIQ(344.4,RCSCR_",",.08)'="" S CNT=1,ARRAY(1)=$$GET1^DIQ(344.4,RCSCR_",",.08,"E")_"^"_$$GET1^DIQ(344.4,RCSCR_",",.08,"I")
;
; No receipt - display mesage and quit
I CNT=0 K DIR S DIR("A",1)="No receipts exist for this ERA." G RECPROCQ
;
; One receipt - Use it
I CNT=1 S RCRECTDA=$P(ARRAY(1),U,2) G RECPROC1
;
; Multiple receipts - User needs to select
W !
S LIST=""
F I=1:1:CNT S LIST=LIST_$S(LIST]"":";",1:"")_I_":"_$P(ARRAY(I),U,1)
S DIR(0)="SO^"_LIST,DIR("A")="Select Receipt"
D ^DIR
I Y<1!(Y>CNT) K DIR S DIR("A",1)="No selection made" G RECPROCQ
S RCRECTDA=$P(ARRAY(Y),U,2)
RECPROC1 ;
D EN^VALM("RCDP RECEIPT PROFILE")
; If RCDPFXIT is set, exit option entirely was selected so quit back to the menu
I $G(RCDPFXIT) S VALMBCK="Q"
Q
;
RECPROCQ ;
; Display the message in DIR("A",1) and then press enter
S DIR(0)="EA",DIR("A")="Press ENTER to continue: "
W ! D ^DIR K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEWL4 11128 printed Oct 16, 2024@17:46:33 Page 2
RCDPEWL4 ;ALB/TMK/PJH - ELECTRONIC EOB WORKLIST ACTIONS ;Jun 06, 2014@19:11:19
+1 ;;4.5;Accounts Receivable;**173,208,269,298,303,318,326,349,367**;Mar 20, 1995;Build 11
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; RCSCR variable must be defined for this routine
+4 QUIT
+5 ;
DISTADJ(RCFR,RCTO,RCAMT,RCCOM) ; Action that distributes an adjustment amount
+1 ; against another line item's payment
+2 ; Assumes RCSCR = ien of the entry in file 344.49
+3 ; RCFR = ien of entry in 344.491 that has a negative net
+4 ; RCTO = ien of entry in 344.491 that will be decremented
+5 ; RCAMT = the amount being adjusted (positive #)
+6 ; RCCOM = the comment to place on the decrease adjustment
+7 ;
+8 NEW RCFRX,RCREF,RCFR0,RCFR1,RCFR10,RCTO0,RCTO1,RCTO10,RCY
+9 ; PRCA*4.5*326
NEW DA,DD,DIK,DR,DIC,DIE,DIK,DIR,DLAYGO,DO,NONVA,X,Y
+10 IF $GET(^TMP("RCBATCH_SELECTED",$JOB))
DO NOBATCH^RCDPEWL
QUIT
+11 SET RCFR0=$GET(^RCY(344.49,RCSCR,1,RCFR,0))
SET RCTO0=$GET(^RCY(344.49,RCSCR,1,RCTO,0))
SET RCFRX=+$ORDER(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0))
SET RCFRX=$GET(^RCY(344.49,RCSCR,1,RCFRX,0))
+12 SET RCREF=$PIECE($PIECE(RCFRX,U,2),"**ADJ",2)
SET RCREF=$SELECT(RCREF="":"",RCREF=0:$PIECE(RCFRX,U,9),1:$PIECE($GET(^RCY(344.4,RCSCR,2,+RCREF,0)),U))
+13 SET RCFR1=+$ORDER(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0))
SET RCTO1=+$ORDER(^RCY(344.49,RCSCR,1,"B",RCTO0\1,0))
+14 SET RCFR10=$GET(^RCY(344.49,RCSCR,1,RCFR1,0))
SET RCTO10=$GET(^RCY(344.49,RCSCR,1,RCTO1,0))
+15 SET RCFR0=$GET(^RCY(344.49,RCSCR,1,RCFR,0))
SET RCTO0=$GET(^RCY(344.49,RCSCR,1,RCTO,0))
+16 SET DA(2)=RCSCR
SET DA(1)=RCFR
+17 SET DIC("DR")=".02////1;.03////"_RCAMT_";.04////"_$SELECT($PIECE(RCTO0,U,2)'="":$PIECE(RCTO0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
+18 SET DIC("DR")=DIC("DR")_";.05////0;.06////0;.09////RETRACTED FUNDS DEDUCTED FROM OTHER PAYMENT ON THIS ERA"
SET DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
+19 SET DLAYGO=344.4911
SET DIC(0)="L"
SET X=+$ORDER(^RCY(344.49,RCSCR,1,RCFR,1,"B",""),-1)+1
+20 DO FILE^DICN
KILL DIC,DD,DO,DLAYGO
+21 SET RCY=+Y
+22 IF RCY'>0
Begin DoDot:1
+23 SET DIR(0)="EA"
SET DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED"
SET DIR("A")="PRESS RETURN TO CONTINUE "
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+24 ;
+25 SET DA(2)=RCSCR
SET DA(1)=RCTO
+26 ; BEGIN PRCA*4.5*326
+27 ; Check if the distribution is to a non-VA claim
+28 SET NONVA=0
IF $PIECE($GET(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ"
IF '$PIECE(RCTO0,U,7)
SET NONVA=1
+29 SET DIC("DR")=".02////0;.03////"_$JUSTIFY(-RCAMT,"",2)
+30 SET DIC("DR")=DIC("DR")_";.04////"_$SELECT($PIECE(RCFR0,U,2)'="":$PIECE(RCFR0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
+31 ; If a non-VA distribution the background action is set none - comment is fixed text concatenated with PLB comment
+32 SET DIC("DR")=DIC("DR")_";.05////"_$SELECT(NONVA:0,$PIECE($GET(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ":"1;.08////0",1:0)
+33 SET DIC("DR")=DIC("DR")_";.06////0"_$SELECT(RCCOM'="":";.09////"_RCCOM,1:"")
+34 ; END PRCA*4.5*326
+35 ;
+36 SET DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
+37 SET DLAYGO=344.4911
SET DIC(0)="L"
SET X=+$ORDER(^RCY(344.49,RCSCR,1,RCTO,1,"B",""),-1)+1
+38 DO FILE^DICN
KILL DIC,DD,DO,DLAYGO
+39 SET RCY=+Y
+40 ;
+41 IF RCY'>0
Begin DoDot:1
+42 NEW DA
+43 SET DA(2)=RCSCR
SET DA(1)=RCFR
SET DA=RCY
SET DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
DO ^DIK
+44 SET DIR(0)="EA"
SET DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED"
SET DIR("A")="PRESS RETURN TO CONTINUE "
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+45 ;
+46 SET DA(1)=RCSCR
SET DA=RCFR
SET DIE="^RCY(344.49,"_DA(1)_",1,"
SET DR=".06////"_$JUSTIFY($PIECE(RCFR0,U,6)+RCAMT,"",2)_";.08////"_$JUSTIFY($PIECE(RCFR0,U,8)+RCAMT,"",2)
DO ^DIE
+47 SET DA=RCFR1
SET DIE="^RCY(344.49,"_DA(1)_",1,"
SET DR=".06////"_$JUSTIFY($PIECE(RCFR10,U,6)+RCAMT,"",2)
DO ^DIE
+48 SET DA(1)=RCSCR
SET DA=RCTO
SET DIE="^RCY(344.49,"_DA(1)_",1,"
SET DR=".06////"_$JUSTIFY($PIECE(RCTO0,U,6)-RCAMT,"",2)_";.03////"_$JUSTIFY($PIECE(RCTO0,U,3)-RCAMT,"",2)_";.08////"_$JUSTIFY($PIECE(RCTO0,U,8)-RCAMT,"",2)
DO ^DIE
+49 SET DA(1)=RCSCR
SET DA=RCTO1
SET DIE="^RCY(344.49,"_DA(1)_",1,"
SET DR=".06////"_$JUSTIFY($PIECE(RCTO10,U,6)-RCAMT,"",2)_";.03////"_$JUSTIFY($PIECE(RCTO10,U,3)-RCAMT,"",2)_";.08////"_$JUSTIFY($PIECE(RCTO10,U,8)-RCAMT,"",2)
DO ^DIE
+50 ;
+51 ; If the distribution is to a none-VA claim set the receipt line comment - this is picked up in DET^RCDPEM when the receipt is created
+52 ; PRCA*4.5*326
IF NONVA
SET DA(1)=RCSCR
SET DA=RCTO
SET DIE="^RCY(344.49,"_DA(1)_",1,"
SET DR=".1///"_RCCOM
DO ^DIE
+53 DO BLD^RCDPEWL1($GET(^TMP($JOB,"RC_SORTPARM")))
+54 QUIT
+55 ;
NEWREC ; Create a new receipt from scratch pad entry
+1 ; PRCA*4.5*367
NEW CT,DA,DIC,DIE,DIR,DR,RCDEP,RCER,RCHAC,RCOK,RCPAYTY,RCRECTDA,RCSTOP,RECTDA,X,Y,Z,Z0
+2 DO FULL^VALM1
+3 IF $GET(RCSCR("NOEDIT"))=2
DO NOTAV^RCDPEWL2
GOTO NEWRECQ
+4 SET (RCSTOP,RCOK)=0
SET VALMBCK="R"
+5 SET RECTDA=$PIECE($GET(^RCY(344.49,RCSCR,0)),U,2)
+6 IF 'RECTDA
SET RECTDA=$PIECE($GET(^RCY(344.4,RCSCR,0)),U,8)
+7 ; PRCA*4.5*303 - Corrected receipt number display to use RECTDA in the DIR("A",1) variable
+8 IF RECTDA
Begin DoDot:1
+9 SET DIR(0)="EA"
SET DIR("A",1)="THIS ERA ALREADY HAS A RECEIPT - "_$PIECE($GET(^RCY(344,RECTDA,0)),U)_" - NO RECEIPT CREATED"
SET DIR("A")="PRESS RETURN TO CONTINUE"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO NEWRECQ
+10 SET DIR("A",1)="THIS ACTION WILL CREATE THE RECEIPT FOR THIS ERA. ONCE THE RECEIPT IS"
SET DIR("A",2)=" CREATED HERE, NO MORE AUTOMATIC ADJUSTMENTS MAY BE MADE FOR THIS ERA."
SET DIR("A",3)=" "
+11 SET DIR("A")="ARE YOU SURE YOU ARE READY TO CREATE THIS RECEIPT?: "
SET DIR("B")="NO"
SET DIR(0)="YA"
+12 WRITE !
DO ^DIR
KILL DIR
WRITE !
+13 IF Y'=1
SET DIR(0)="EA"
SET DIR("A")="NO RECEIPT CREATED - PRESS RETURN TO CONTINUE"
WRITE !
DO ^DIR
KILL DIR
GOTO NEWRECQ
+14 IF $$HASADJ^RCDPEWL8(RCSCR,.RCOK)
Begin DoDot:1
+15 SET DIR(0)="EA"
SET DIR("A",1)="AT LEAST ONE LINE ITEM WAS FOUND WITH A NEGATIVE PAYMENT AMOUNT"
SET DIR("A")="NO RECEIPT CAN BE CREATED - PRESS RETURN TO CONTINUE "
DO ^DIR
KILL DIR
SET RCSTOP=1
End DoDot:1
GOTO NEWRECQ
+16 IF 'RCOK
SET DIR(0)="EA"
SET DIR("A")="NO RECEIPT CAN BE CREATED - NO POSTABLE LINE ITEMS WERE FOUND"
WRITE !
DO ^DIR
KILL DIR
GOTO NEWRECQ
+17 ;
+18 SET RCHAC=$$HACERA^RCDPEU(RCSCR)
+19 ; PRCA*4.5*367 - Use CHAMPVA receipt type for CHAMPVA payments
SET RCPAYTY=$SELECT(RCHAC:17,$PIECE($GET(^RCY(344.4,+RCSCR,5)),U,2)="":14,1:4)
+20 SET RCDEP=""
+21 IF RCPAYTY=4
Begin DoDot:1
+22 NEW RCOK1
+23 FOR
Begin DoDot:2
+24 SET RCOK1=1
+25 SET DIC="^RCY(344.1,"
SET DIC("S")="I $P(^(0),U,12)=1"
SET DIC(0)="AEMQ"
DO ^DIC
+26 if Y'>0
QUIT
+27 SET RCDEP=+Y
+28 IF RCDEP
IF $$TOOOLD^RCDPEWLA(RCDEP)
SET RCOK1=0
SET RCDEP=""
End DoDot:2
if RCOK1
QUIT
End DoDot:1
+29 ; Note:ERA with paper check is type 4, but receipt needs to start with an 'E'
SET RECTDA=$$BLDRCPT^RCDPUREC(DT,+RCDEP_$SELECT(RCPAYTY=4:"ERACHK",1:""),+$ORDER(^RC(341.1,"AC",+RCPAYTY,0)))
+30 IF 'RECTDA
WRITE !
SET DIR(0)="EA"
SET DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THE RECEIPT - NO RECEIPT ADDED"
SET DIR("A")="PRESS RETURN TO CONTINUE"
WRITE !
DO ^DIR
KILL DIR
GOTO NEWRECQ
+31 ;
+32 DO RCPTDET^RCDPEM(RCSCR,RECTDA,.RCER)
+33 ;PRCA*4.5*367 - Calculate Receipt Total for CHAMPVA Receipts
+34 IF RCHAC
Begin DoDot:1
+35 NEW RCFDA,RCPTOT,I
+36 SET (RCPTOT,I)=0
+37 FOR
SET I=$ORDER(^RCY(344.49,RCSCR,1,I))
if 'I
QUIT
Begin DoDot:2
+38 if $PIECE(^RCY(344.49,RCSCR,1,I,0),U)'["."
QUIT
+39 SET RCPTOT=RCPTOT+$PIECE(^RCY(344.49,RCSCR,1,I,0),U,3)
End DoDot:2
+40 SET RCFDA(344,RECTDA_",",.22)=RCPTOT
+41 DO FILE^DIE(,"RCFDA")
End DoDot:1
+42 ;
+43 SET DIE="^RCY(344.49,"
SET DA=RCSCR
SET DR=".02////"_RECTDA
DO ^DIE
+44 SET DIE="^RCY(344.4,"
SET DA=RCSCR
SET DR=".08////"_RECTDA
DO ^DIE
+45 SET Z=+$ORDER(^RCY(344.31,"AERA",RCSCR,0))
+46 SET DIE="^RCY(344,"
SET DA=RECTDA
SET DR=".18////"_RCSCR_$SELECT(Z:";.17////"_Z,1:"")_$SELECT(RCPAYTY=4:";.06////"_RCDEP,1:"")_$SELECT($PIECE($GET(^RCY(344.31,Z,0)),U,15)'="":";.16////"_$PIECE(^RCY(344.31,Z,0),U,15),1:"")
DO ^DIE
+47 ;
+48 IF $ORDER(RCER(0))
Begin DoDot:1
+49 SET CT=1
SET DIR(0)="EA"
SET DIR("A",1)="THE FOLLOWING PROBLEMS OCCURRED WHILE ADDING THE RECEIPT: "
+50 SET Z=0
FOR
SET Z=$ORDER(RCER(Z))
if 'Z
QUIT
SET CT=CT+1
SET DIR("A",CT)=RCER(Z)
+51 SET DIR("A")="PRESS RETURN TO CONTINUE "
+52 WRITE !
DO ^DIR
KILL DIR
End DoDot:1
+53 ;
+54 SET DIR(0)="YA"
SET DIR("A")="DO YOU WANT TO GO TO RECEIPT PROCESSING NOW? "
SET DIR("A",1)=" "
SET DIR("A",2)="RECEIPT "_$PIECE($GET(^RCY(344,+RECTDA,0)),U)_" HAS BEEN CREATED FOR THIS ERA"
SET DIR("B")="YES"
WRITE !
DO ^DIR
KILL DIR
+55 IF Y=1
SET RCRECTDA=RECTDA
DO EN^VALM("RCDP RECEIPT PROFILE")
+56 SET RCSCR=0
+57 SET VALMBCK="Q"
+58 ;
NEWRECQ QUIT
+1 ;
VRECPT ;EP - Protocol action - RCDPE EOB WL RECEIPT VIEW
+1 ; Preview receipt lines
+2 ; Assume RCSCR = ien from file 344.49 (and 344.4)
+3 NEW DIR,RCOK,RCZ,X,Y,Z,Z0
+4 DO FULL^VALM1
+5 SET VALMBCK="R"
+6 ; prca*4.5*298 auto-posted ERAs are handled differently
IF $SELECT($PIECE($GET(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0)
DO VR^RCDPEWLP(RCSCR)
GOTO VRECPTQ
+7 ;
+8 ;
+9 ; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
+10 ; batches but just remove from execution.
+11 ; I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
+12 ;I $O(^RCY(344.49,RCSCR,3,0)) D Q:'RCOK
+13 ;. S RCOK=1
+14 ;. S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z I '$P($G(^(Z,0)),U,3) S RCOK=0 Q
+15 ;. I 'RCOK S DIR(0)="EA",DIR("A",1)="A RECEIPT CANNOT BE PREVIEWED UNTIL ALL BATCHES FOR THIS ERA ARE MARKED AS",DIR("A",2)="'READY TO POST'",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR
+16 ; end of prca*4.5*298
+17 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.49,RCSCR,1,Z))
if 'Z
QUIT
IF $PIECE(Z,".",2)
SET Z0=$GET(^(Z,0))
IF $PIECE(Z0,U,6)<0
SET RCZ($PIECE(Z0,U))=$PIECE(Z0,U,2)_U_$PIECE(Z0,U,6)
+18 IF $ORDER(RCZ(""))'=""
Begin DoDot:1
+19 WRITE !,"THE FOLLOWING LINES HAVE A NET PAYMENT LESS THAN 0. THESE LINES MUST HAVE",!,"THIS NEGATIVE AMOUNT DISTRIBUTED TO OTHER LINE(S) IN THE ERA BEFORE A",!,"RECEIPT CAN BE CREATED."
+20 SET Z=""
FOR
SET Z=$ORDER(RCZ(Z))
if Z=""
QUIT
WRITE !,$JUSTIFY("",5)_$JUSTIFY(Z,10)_" "_$EXTRACT($PIECE(RCZ(Z),U)_$JUSTIFY("",15),1,15)_" "_$JUSTIFY(+$PIECE(RCZ(Z),U,2),"",2)
+21 WRITE !
+22 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
+23 ;
+24 ; PRCA*4.5*349 - Added AM worklist preview
IF '$DATA(^XUSEC("RCDPEPP",DUZ))
Begin DoDot:1
+25 DO EN^VALM("RCDPE EOB RECEIPT PREVIEW AM")
DO VRECPTQ
End DoDot:1
QUIT
+26 DO EN^VALM("RCDPE EOB RECEIPT PREVIEW")
VRECPTQ ;
+1 SET VALMBCK=$SELECT('$GET(RCSCR):"Q",1:"R")
+2 QUIT
+3 ;
+4 ; PRCA*4.5*303 - Receipt Processing
RECPROC ;EP - Protocol action - RCDPE EON WORKLIST RECEIPT PROCESSING
+1 ; Receipt Processing
+2 ; Called by RCDPE EOB WORKLIST RECEIPT PROCESSING protocol
+3 ; Assume RCSCR is the IEN from file 344.49 (and 344.4)
+4 ; Variable RCRECTDA is needed by RECEIPT PROFILE so is not newed
+5 ; Variable RCDPFXIT is used by RCDPLPLM for immediate exit so newed it here so that does not happen
+6 ;
+7 NEW ARRAY,RECIEN,RECEIPT,CNT,DIR,X,Y,DTOUT,DUOUT,DROUT,DIRUT,I,LIST,RCDPFXIT
+8 DO FULL^VALM1
+9 SET VALMBCK="R"
+10 ; PRCA*4.5*318 Added security key check
IF '$DATA(^XUSEC("RCDPEPP",DUZ))
Begin DoDot:1
+11 WRITE !!,"This action can only be taken by users that have the RCDPEPP security key.",!
+12 DO PAUSE^VALM1
End DoDot:1
QUIT
+13 ;
+14 ; Get list of receipts from the ERA detail multiple
+15 SET RECIEN=0
SET CNT=0
+16 FOR
SET RECIEN=$ORDER(^RCY(344.4,RCSCR,1,"RECEIPT",RECIEN))
if 'RECIEN
QUIT
Begin DoDot:1
+17 SET RECEIPT=$PIECE($GET(^RCY(344,RECIEN,0)),U)
+18 IF RECEIPT]""
SET CNT=CNT+1
SET ARRAY(CNT)=RECEIPT_"^"_RECIEN
End DoDot:1
+19 ;
+20 ; The array of receipts does not exist, this could be a non auto-posted ERA; so only 1 receipt will be assigned; retrieve at 344.4, .08
+21 IF '$DATA(ARRAY)
IF $$GET1^DIQ(344.4,RCSCR_",",.08)'=""
SET CNT=1
SET ARRAY(1)=$$GET1^DIQ(344.4,RCSCR_",",.08,"E")_"^"_$$GET1^DIQ(344.4,RCSCR_",",.08,"I")
+22 ;
+23 ; No receipt - display mesage and quit
+24 IF CNT=0
KILL DIR
SET DIR("A",1)="No receipts exist for this ERA."
GOTO RECPROCQ
+25 ;
+26 ; One receipt - Use it
+27 IF CNT=1
SET RCRECTDA=$PIECE(ARRAY(1),U,2)
GOTO RECPROC1
+28 ;
+29 ; Multiple receipts - User needs to select
+30 WRITE !
+31 SET LIST=""
+32 FOR I=1:1:CNT
SET LIST=LIST_$SELECT(LIST]"":";",1:"")_I_":"_$PIECE(ARRAY(I),U,1)
+33 SET DIR(0)="SO^"_LIST
SET DIR("A")="Select Receipt"
+34 DO ^DIR
+35 IF Y<1!(Y>CNT)
KILL DIR
SET DIR("A",1)="No selection made"
GOTO RECPROCQ
+36 SET RCRECTDA=$PIECE(ARRAY(Y),U,2)
RECPROC1 ;
+1 DO EN^VALM("RCDP RECEIPT PROFILE")
+2 ; If RCDPFXIT is set, exit option entirely was selected so quit back to the menu
+3 IF $GET(RCDPFXIT)
SET VALMBCK="Q"
+4 QUIT
+5 ;
RECPROCQ ;
+1 ; Display the message in DIR("A",1) and then press enter
+2 SET DIR(0)="EA"
SET DIR("A")="Press ENTER to continue: "
+3 WRITE !
DO ^DIR
KILL DIR
+4 QUIT
