RCDPRPL4 ;WISC/RFJ/PJH-receipt profile listmanager options ;1 Apr 01
;;4.5;Accounts Receivable;**169,172,173,269,276,326,332**;Mar 20, 1995;Build 40
;;Per VA Directive 6402, this routine should not be modified.
Q
;
; this routine contains the entry points for receipt management
;
;
ONLINE ; allow the supervisor to mark the CR document as input on line
;
; Input - RCRECDA - IEN of CR receipt in #344
;
D FULL^VALM1
S VALMBCK="R"
;
; get fms document and status
N %,FMSDOC,GECSDATA
S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
;
W !!,"This option will allow you to mark a rejected Cash Receipt document as"
W !,"entered on line. This will prevent the document from being listed on"
W !,"the nightly mailman message used to help manage the receipts and deposits."
;
W !!,"FMS Cash Receipt Document: ",$P(FMSDOC,"^"),?48,"Status: ",$P(FMSDOC,"^",2)
;
I '$D(^XUSEC("PRCAY PAYMENT SUP",DUZ)) W !!,"You are not an owner of the supervisor PRCAY PAYMENT SUP security key." D QUIT Q
;
; cr accepted
I $E($P(FMSDOC,"^",2))="A" W !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document is ACCEPTED ??" D QUIT Q
;
; not been transmitted for 2 days
I $E($P(FMSDOC,"^",2))="T",$$FMDIFF^XLFDT(DT,$P(^RCY(344,RCRECTDA,0),"^",8))'>2 W !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document has NOT been TRANSMITTED for 2 days ??" D QUIT Q
;
; cr queued for transmission
I $E($P(FMSDOC,"^",2))="Q"!($E($P(FMSDOC,"^",2))="M") W !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document is waiting to be TRANSMITTED ??" D QUIT Q
;
; check to see if already marked as entered on line
I $E($P(FMSDOC,"^",2))="O" D Q
. I $$ASKSTAT("REMOVE")'=1 Q
. W !,"... removing CR status as entered on line ..."
. ; remove the ON-LINE status on field 201
. D EDITREC^RCDPUREC(RCRECTDA,"201///0")
. ; show the new status
. S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
. W !!,"FMS Cash Receipt Document: ",$P(FMSDOC,"^"),?48,"Status: ",$P(FMSDOC,"^",2)
. D QUIT
;
; ask to change the status to entered on line
I $$ASKSTAT("ENTER")'=1 D QUIT Q
;
; change the status to entered on line
W !!,"... changing status to entered on line ..."
W !,"... changing the generic code sheet stack file status to ACCEPTED ..."
;
; set the status to entered on line in field 201
D EDITREC^RCDPUREC(RCRECTDA,"201///1")
;
; set the generic code sheet status as accepted
; get the document ien
D DATA^GECSSGET($P(FMSDOC,"^"))
I $G(GECSDATA) D SETSTAT^GECSSTAA(GECSDATA,"A")
;
; show the new status
S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
W !!,"FMS Cash Receipt Document: ",$P(FMSDOC,"^"),?48,"Status: ",$P(FMSDOC,"^",2)
;
QUIT ; pause and rebuild the header
W !!,"press RETURN to continue: "
R %:DTIME
D HDR^RCDPRPLM
Q
;
;
ASKSTAT(ACTION) ; ask if its okay to remove or change the entered online status
; 1 is yes, otherwise no
N DIR,DIQ2,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="NO"
S DIR("A",1)=" Do you want to "_ACTION_" the status showing the Cash Receipt"
S DIR("A")=" document was entered ON LINE"
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q Y
;
ERAWL(RCSCR) ; Generate automatic dec adj from ERA Worklist in RCSCR
; RCADJ returned = 1 if passed by reference and adjustment successful
; returned = 2 if passed by ref and adjustments aborted
; returned = -1 if error
; returned = 0 if no WL adjustments found
N RCZ,RCZ0,Z00,V00,RCCOM,RC1,RCADJ,RCOK,WLA
S RC1=1,RCZ=0,RCADJ=0
F S RCZ=$O(^RCY(344.49,RCSCR,1,RCZ)) Q:'RCZ!(RCADJ=2) S V00=$G(^(RCZ,0)),RCZ0=0 F S RCZ0=$O(^RCY(344.49,RCSCR,1,RCZ,1,RCZ0)) Q:'RCZ0!(RCADJ=2) S Z00=$G(^(RCZ0,0)) Q:"12"'[+$P(Z00,U,5) D
. S RCCOM(1)=$P(Z00,U,9)
. I RC1,$P(Z00,U,5)=1 D Q:RCADJ=2
.. S RC1=0
.. S DIR(0)="YA",DIR("B")="YES",DIR("A",1)="Generating automatic decrease adjustments from EDI Lbox Worklist ...",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: "
.. D ^DIR K DIR
.. I Y'=1 S RCADJ=2
. I $P(Z00,U,8)=1 D Q ; previously done
.. I $P(Z00,U,5)=1 W !," Automatic decrease adj from ERA Worklist for bill #"_$P($G(^PRCA(430,+$P(V00,U,7),0)),U),!," for amount of "_$J(+$P(Z00,U,3),"",2)_" was previously completed" S RCADJ=1
. I $P(Z00,U,5)=1 D Q ; Decrease adj
.. S WLA=$$INCDEC^RCBEUTR1($P(V00,U,7),$P(Z00,U,3),.RCCOM,,,1) I 'WLA D
... ; PRCA276 - $$INCDEC can now return "0^1" which means a negative claim balance could have occurred if the decrease adjustment was applied to the claim
... S RCADJ=-1 W !," Could not perform automatic decrease adj from ERA Worklist for ",!," bill # "_$P($G(^PRCA(430,+$P(V00,U,7),0)),U)_" for amount of "_$J(+$P(Z00,U,3),"",2)
... I $P(WLA,U,2) D
.... S RCADJ=2
.... W !,"WARNING: Receipt cannot be processed.",!,"Processing this receipt will cause this bill to have a negative balance",!,"which is outside the scope of VA Accounting regulations."
.... W !,"Correct the error and reprocess this receipt."
.. E D ; success
... D UPD(RCSCR,RCZ,RCZ0)
... S RCADJ=1
... W !," EDI Lbox Worklist automatic dec adjustment made to "_$P($G(^PRCA(430,+$P(V00,U,7),0)),U)_": "_$J(+$P(Z00,U,3),"",2)
. I $P(Z00,U,5)=2 D Q ; Bill comment
.. D ADDCOMM^RCBEUTRA($P(V00,U,7),.RCCOM),UPD(RCSCR,RCZ,RCZ0)
;
Q $G(RCADJ)
;
UPD(RCSCR,Z,Z0) ; Mark as complete so it doesn't get done twice
N DA,DIE,DR
S DA(2)=RCSCR,DA(1)=Z,DA=Z0
S DIE="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,",DR=".08////1" D ^DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPRPL4 5588 printed Sep 23, 2025@19:22:26 Page 2
RCDPRPL4 ;WISC/RFJ/PJH-receipt profile listmanager options ;1 Apr 01
+1 ;;4.5;Accounts Receivable;**169,172,173,269,276,326,332**;Mar 20, 1995;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; this routine contains the entry points for receipt management
+6 ;
+7 ;
ONLINE ; allow the supervisor to mark the CR document as input on line
+1 ;
+2 ; Input - RCRECDA - IEN of CR receipt in #344
+3 ;
+4 DO FULL^VALM1
+5 SET VALMBCK="R"
+6 ;
+7 ; get fms document and status
+8 NEW %,FMSDOC,GECSDATA
+9 SET FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
+10 ;
+11 WRITE !!,"This option will allow you to mark a rejected Cash Receipt document as"
+12 WRITE !,"entered on line. This will prevent the document from being listed on"
+13 WRITE !,"the nightly mailman message used to help manage the receipts and deposits."
+14 ;
+15 WRITE !!,"FMS Cash Receipt Document: ",$PIECE(FMSDOC,"^"),?48,"Status: ",$PIECE(FMSDOC,"^",2)
+16 ;
+17 IF '$DATA(^XUSEC("PRCAY PAYMENT SUP",DUZ))
WRITE !!,"You are not an owner of the supervisor PRCAY PAYMENT SUP security key."
DO QUIT
QUIT
+18 ;
+19 ; cr accepted
+20 IF $EXTRACT($PIECE(FMSDOC,"^",2))="A"
WRITE !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document is ACCEPTED ??"
DO QUIT
QUIT
+21 ;
+22 ; not been transmitted for 2 days
+23 IF $EXTRACT($PIECE(FMSDOC,"^",2))="T"
IF $$FMDIFF^XLFDT(DT,$PIECE(^RCY(344,RCRECTDA,0),"^",8))'>2
WRITE !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document has NOT been TRANSMITTED for 2 days ??"
DO QUIT
QUIT
+24 ;
+25 ; cr queued for transmission
+26 IF $EXTRACT($PIECE(FMSDOC,"^",2))="Q"!($EXTRACT($PIECE(FMSDOC,"^",2))="M")
WRITE !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document is waiting to be TRANSMITTED ??"
DO QUIT
QUIT
+27 ;
+28 ; check to see if already marked as entered on line
+29 IF $EXTRACT($PIECE(FMSDOC,"^",2))="O"
Begin DoDot:1
+30 IF $$ASKSTAT("REMOVE")'=1
QUIT
+31 WRITE !,"... removing CR status as entered on line ..."
+32 ; remove the ON-LINE status on field 201
+33 DO EDITREC^RCDPUREC(RCRECTDA,"201///0")
+34 ; show the new status
+35 SET FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
+36 WRITE !!,"FMS Cash Receipt Document: ",$PIECE(FMSDOC,"^"),?48,"Status: ",$PIECE(FMSDOC,"^",2)
+37 DO QUIT
End DoDot:1
QUIT
+38 ;
+39 ; ask to change the status to entered on line
+40 IF $$ASKSTAT("ENTER")'=1
DO QUIT
QUIT
+41 ;
+42 ; change the status to entered on line
+43 WRITE !!,"... changing status to entered on line ..."
+44 WRITE !,"... changing the generic code sheet stack file status to ACCEPTED ..."
+45 ;
+46 ; set the status to entered on line in field 201
+47 DO EDITREC^RCDPUREC(RCRECTDA,"201///1")
+48 ;
+49 ; set the generic code sheet status as accepted
+50 ; get the document ien
+51 DO DATA^GECSSGET($PIECE(FMSDOC,"^"))
+52 IF $GET(GECSDATA)
DO SETSTAT^GECSSTAA(GECSDATA,"A")
+53 ;
+54 ; show the new status
+55 SET FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
+56 WRITE !!,"FMS Cash Receipt Document: ",$PIECE(FMSDOC,"^"),?48,"Status: ",$PIECE(FMSDOC,"^",2)
+57 ;
QUIT ; pause and rebuild the header
+1 WRITE !!,"press RETURN to continue: "
+2 READ %:DTIME
+3 DO HDR^RCDPRPLM
+4 QUIT
+5 ;
+6 ;
ASKSTAT(ACTION) ; ask if its okay to remove or change the entered online status
+1 ; 1 is yes, otherwise no
+2 NEW DIR,DIQ2,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="YO"
SET DIR("B")="NO"
+4 SET DIR("A",1)=" Do you want to "_ACTION_" the status showing the Cash Receipt"
+5 SET DIR("A")=" document was entered ON LINE"
+6 DO ^DIR
+7 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+8 QUIT Y
+9 ;
ERAWL(RCSCR) ; Generate automatic dec adj from ERA Worklist in RCSCR
+1 ; RCADJ returned = 1 if passed by reference and adjustment successful
+2 ; returned = 2 if passed by ref and adjustments aborted
+3 ; returned = -1 if error
+4 ; returned = 0 if no WL adjustments found
+5 NEW RCZ,RCZ0,Z00,V00,RCCOM,RC1,RCADJ,RCOK,WLA
+6 SET RC1=1
SET RCZ=0
SET RCADJ=0
+7 FOR
SET RCZ=$ORDER(^RCY(344.49,RCSCR,1,RCZ))
if 'RCZ!(RCADJ=2)
QUIT
SET V00=$GET(^(RCZ,0))
SET RCZ0=0
FOR
SET RCZ0=$ORDER(^RCY(344.49,RCSCR,1,RCZ,1,RCZ0))
if 'RCZ0!(RCADJ=2)
QUIT
SET Z00=$GET(^(RCZ0,0))
if "12"'[+$PIECE(Z00,U,5)
QUIT
Begin DoDot:1
+8 SET RCCOM(1)=$PIECE(Z00,U,9)
+9 IF RC1
IF $PIECE(Z00,U,5)=1
Begin DoDot:2
+10 SET RC1=0
+11 SET DIR(0)="YA"
SET DIR("B")="YES"
SET DIR("A",1)="Generating automatic decrease adjustments from EDI Lbox Worklist ..."
SET DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: "
+12 DO ^DIR
KILL DIR
+13 IF Y'=1
SET RCADJ=2
End DoDot:2
if RCADJ=2
QUIT
+14 ; previously done
IF $PIECE(Z00,U,8)=1
Begin DoDot:2
+15 IF $PIECE(Z00,U,5)=1
WRITE !," Automatic decrease adj from ERA Worklist for bill #"_$PIECE($GET(^PRCA(430,+$PIECE(V00,U,7),0)),U),!," for amount of "_$JUSTIFY(+$PIECE(Z00,U,3),"",2)_" was previously completed"
SET RCADJ=1
End DoDot:2
QUIT
+16 ; Decrease adj
IF $PIECE(Z00,U,5)=1
Begin DoDot:2
+17 SET WLA=$$INCDEC^RCBEUTR1($PIECE(V00,U,7),$PIECE(Z00,U,3),.RCCOM,,,1)
IF 'WLA
Begin DoDot:3
+18 ; PRCA276 - $$INCDEC can now return "0^1" which means a negative claim balance could have occurred if the decrease adjustment was applied to the claim
+19 SET RCADJ=-1
WRITE !," Could not perform automatic decrease adj from ERA Worklist for ",!," bill # "_$PIECE($GET(^PRCA(430,+$PIECE(V00,U,7),0)),U)_" for amount of "_$JUSTIFY(+$PIECE(Z00,U,3),"",2)
+20 IF $PIECE(WLA,U,2)
Begin DoDot:4
+21 SET RCADJ=2
+22 WRITE !,"WARNING: Receipt cannot be processed.",!,"Processing this receipt will cause this bill to have a negative balance",!,"which is outside the scope of VA Accounting regulations."
+23 WRITE !,"Correct the error and reprocess this receipt."
End DoDot:4
End DoDot:3
+24 ; success
IF '$TEST
Begin DoDot:3
+25 DO UPD(RCSCR,RCZ,RCZ0)
+26 SET RCADJ=1
+27 WRITE !," EDI Lbox Worklist automatic dec adjustment made to "_$PIECE($GET(^PRCA(430,+$PIECE(V00,U,7),0)),U)_": "_$JUSTIFY(+$PIECE(Z00,U,3),"",2)
End DoDot:3
End DoDot:2
QUIT
+28 ; Bill comment
IF $PIECE(Z00,U,5)=2
Begin DoDot:2
+29 DO ADDCOMM^RCBEUTRA($PIECE(V00,U,7),.RCCOM)
DO UPD(RCSCR,RCZ,RCZ0)
End DoDot:2
QUIT
End DoDot:1
+30 ;
+31 QUIT $GET(RCADJ)
+32 ;
UPD(RCSCR,Z,Z0) ; Mark as complete so it doesn't get done twice
+1 NEW DA,DIE,DR
+2 SET DA(2)=RCSCR
SET DA(1)=Z
SET DA=Z0
+3 SET DIE="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
SET DR=".08////1"
DO ^DIE
+4 QUIT
+5 ;
