RCDPRPL1 ;WISC/RFJ-receipt profile listmanager options ;1 Jun 99
;;4.5;Accounts Receivable;**114,321**;Mar 20, 1995;Build 48
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
; this routine contains the entry points for payment transactions
;
;
ENTRTRAN ; option: enter a payment transaction
; this option can only be selected for unapproved receipts
; screen placed in protocol file and below as backup
D FULL^VALM1
S VALMBCK="R"
;
I '$$LOCKREC^RCDPRPLU(RCRECTDA) Q
;
N %,RCTRANDA,RCTYPE
S RCTYPE=$P($G(^RC(341.1,+$P(^RCY(344,RCRECTDA,0),"^",4),0)),"^",2)
;
W !
W !," Type of payment: ",$P($G(^RC(341.1,+$P(^RCY(344,RCRECTDA,0),"^",4),0)),"^")
W !,"Adding a NEW payment transaction: "
S RCTRANDA=$$ADDTRAN^RCDPURET(RCRECTDA)
I 'RCTRANDA D Q
. S VALMSG="Unable to ADD a new payment transaction."
. D WRITE^RCDPRPLU(VALMSG)
. L -^RCY(344,RCRECTDA)
;
W "# ",RCTRANDA
S %=$$EDITTRAN^RCDPURET(RCRECTDA,RCTRANDA)
I '% D Q
. S VALMSG=%
. D WRITE^RCDPRPLU(VALMSG)
. L -^RCY(344,RCRECTDA)
;
S VALMSG="Transaction # "_RCTRANDA_" has been ADDED."
;
D INIT^RCDPRPLM
L -^RCY(344,RCRECTDA)
Q
;
;
EDITTRAN ; option: edit a payment transaction
; this option can only be selected for unapproved receipts
; screen placed in protocol file and below as backup
D FULL^VALM1
S VALMBCK="R"
;
N %,RCEEOB,RCTRANDA ; prca*4.5*321 - added RCEEOB
; select the payment transaction
S RCTRANDA=$$SELPAY(RCRECTDA) I RCTRANDA<1 Q
;
I '$$LOCKREC^RCDPRPLU(RCRECTDA) Q
;
; transaction is cancelled, cannot edit
I '$P(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",4),$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,1)),"^")'="" D Q
. S VALMSG="Payment Transaction "_RCTRANDA_" is CANCELLED."
. D WRITE^RCDPRPLU(VALMSG)
. L -^RCY(344,RCRECTDA)
;
W !!,"Editing Payment: ",RCTRANDA
S %=$$EDITTRAN^RCDPURET(RCRECTDA,RCTRANDA)
I '% S VALMSG="Transaction DELETED." D WRITE^RCDPRPLU(VALMSG)
; BEGIN - PRCA*4.5*321
I % D
. ; Option to restore suspense EEOB
. S RCEEOB=$$EEOB^RCDPEM5(RCRECTDA,RCTRANDA)
. ; Update EEOB claim number and restore to active status
. D:RCEEOB>0 RESTORE^RCDPEM5(RCRECTDA,RCTRANDA,RCEEOB,"R")
; END - PRCA*4.5*321
;
D INIT^RCDPRPLM
L -^RCY(344,RCRECTDA)
Q
;
;
CANCTRAN ; option: cancel a transaction
; this option can only be selected for unapproved receipts
; screen placed in protocol file and below as backup
D FULL^VALM1
S VALMBCK="R"
;
N RCTRANDA
; select the payment transaction
S RCTRANDA=$$SELPAY(RCRECTDA) I RCTRANDA<1 Q
;
I '$$LOCKREC^RCDPRPLU(RCRECTDA) Q
;
; check to see if already cancelled
I $P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4)=0,$P($G(^(1)),"^")'="" D Q
. S VALMSG="Payment Transaction "_RCTRANDA_" is already CANCELLED."
. D WRITE^RCDPRPLU(VALMSG)
. L -^RCY(344,RCRECTDA)
;
; ask to cancel
I $$ASKCANC(RCTRANDA)=1 D
. D CANCTRAN^RCDPURET(RCRECTDA,RCTRANDA)
. S VALMSG="Transaction # "_RCTRANDA_" has been CANCELLED"
;
D INIT^RCDPRPLM
L -^RCY(344,RCRECTDA)
Q
;
;
MOVETRAN ; move a transaction from one receipt to another
D FULL^VALM1
S VALMBCK="R"
;
N RCNEWREC,RCNEWTRA,RCTRANDA
; select the payment transaction
S RCTRANDA=$$SELPAY(RCRECTDA) I RCTRANDA<1 Q
;
I '$$LOCKREC^RCDPRPLU(RCRECTDA) Q
;
; transaction is cancelled, cannot edit
I '$P(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",4),$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,1)),"^")'="" D Q
. S VALMSG="Payment Transaction "_RCTRANDA_" is CANCELLED."
. D WRITE^RCDPRPLU(VALMSG)
. D UNLOCK
;
; select the receipt to move transaction to (can add new one)
F D Q:RCNEWREC
. W !!,"Select the RECEIPT to move the payment transaction #"_RCTRANDA_" to:"
. S RCNEWREC=$$SELRECT^RCDPUREC(1)
. I RCNEWREC<1 S RCNEWREC=-1 Q
. I RCNEWREC=RCRECTDA W !,"Cannot copy transaction to same receipt." S RCNEWREC=0 Q
. I '$$CHECKREC^RCDPRPLU(RCNEWREC) W !,"Cannot copy to a receipt which is CLOSED." S RCNEWREC=0 Q
I RCNEWREC<1 D UNLOCK Q
;
I '$$LOCKREC^RCDPRPLU(RCNEWREC) D UNLOCK Q
;
W !
I $P($G(^RCY(344,RCNEWREC,0)),"^",4)'=$P(^RCY(344,RCRECTDA,0),"^",4) W !,"WARNING, receipt types of payment are not the same type of payment."
;
I $$ASKMOVE(RCNEWREC)'=1 D UNLOCK Q
;
; MOVETRAN will add the new transaction, and allow the user to
; edit the data. returns error message if not successful or
; returns the transaction number.
S RCNEWTRA=$$MOVETRAN^RCDPURET(RCRECTDA,RCTRANDA,RCNEWREC)
I 'RCNEWTRA D Q
. S VALMSG=%
. D WRITE^RCDPRPLU(VALMSG)
. D UNLOCK
;
; delete the transaction just moved
D DELETRAN^RCDPURET(RCRECTDA,RCTRANDA)
;
D INIT^RCDPRPLM
S VALMSG="Transaction # "_RCTRANDA_" has been MOVED/DELETED."
;
UNLOCK ; unlock receipts
L -^RCY(344,RCRECTDA)
I $G(RCNEWREC)>0 L -^RCY(344,RCNEWREC)
Q
;
;
SELPAY(RCRECTDA) ; select the payment transaction for the receipt (from listmanager options)
N RCTRANDA
; if no payments, quit
I '$O(^RCY(344,RCRECTDA,1,0)) S VALMSG="There are NO payments." Q 0
; if only one payment, select that one automatically
I $P($G(^RCY(344,RCRECTDA,1,0)),"^",4)=1 S RCTRANDA=$O(^RCY(344,RCRECTDA,1,0))
; select the payment transaction
I '$G(RCTRANDA) W ! S RCTRANDA=$$SELTRAN^RCDPURET(RCRECTDA)
Q RCTRANDA
;
;
ASKCANC(RCTRANDA) ; ask if it's okay to cancel a transaction
; 1 is yes, otherwise no
N DIR,DIQ2,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")=" Are you sure you want to CANCEL transaction # "_RCTRANDA
W ! D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q Y
;
;
ASKMOVE(RECTDA) ; ask if its okay to move the transaction
; 1 is yes, otherwise no
N DIR,DIQ2,DTOUT,DUOUT,X,Y
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")=" Are you sure you want to MOVE this payment to receipt "_$P($G(^RCY(344,RECTDA,0)),"^")
D ^DIR
I $G(DTOUT)!($G(DUOUT)) S Y=-1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPRPL1 5981 printed Sep 23, 2025@19:22:24 Page 2
RCDPRPL1 ;WISC/RFJ-receipt profile listmanager options ;1 Jun 99
+1 ;;4.5;Accounts Receivable;**114,321**;Mar 20, 1995;Build 48
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; this routine contains the entry points for payment transactions
+6 ;
+7 ;
ENTRTRAN ; option: enter a payment transaction
+1 ; this option can only be selected for unapproved receipts
+2 ; screen placed in protocol file and below as backup
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 ;
+6 IF '$$LOCKREC^RCDPRPLU(RCRECTDA)
QUIT
+7 ;
+8 NEW %,RCTRANDA,RCTYPE
+9 SET RCTYPE=$PIECE($GET(^RC(341.1,+$PIECE(^RCY(344,RCRECTDA,0),"^",4),0)),"^",2)
+10 ;
+11 WRITE !
+12 WRITE !," Type of payment: ",$PIECE($GET(^RC(341.1,+$PIECE(^RCY(344,RCRECTDA,0),"^",4),0)),"^")
+13 WRITE !,"Adding a NEW payment transaction: "
+14 SET RCTRANDA=$$ADDTRAN^RCDPURET(RCRECTDA)
+15 IF 'RCTRANDA
Begin DoDot:1
+16 SET VALMSG="Unable to ADD a new payment transaction."
+17 DO WRITE^RCDPRPLU(VALMSG)
+18 LOCK -^RCY(344,RCRECTDA)
End DoDot:1
QUIT
+19 ;
+20 WRITE "# ",RCTRANDA
+21 SET %=$$EDITTRAN^RCDPURET(RCRECTDA,RCTRANDA)
+22 IF '%
Begin DoDot:1
+23 SET VALMSG=%
+24 DO WRITE^RCDPRPLU(VALMSG)
+25 LOCK -^RCY(344,RCRECTDA)
End DoDot:1
QUIT
+26 ;
+27 SET VALMSG="Transaction # "_RCTRANDA_" has been ADDED."
+28 ;
+29 DO INIT^RCDPRPLM
+30 LOCK -^RCY(344,RCRECTDA)
+31 QUIT
+32 ;
+33 ;
EDITTRAN ; option: edit a payment transaction
+1 ; this option can only be selected for unapproved receipts
+2 ; screen placed in protocol file and below as backup
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 ;
+6 ; prca*4.5*321 - added RCEEOB
NEW %,RCEEOB,RCTRANDA
+7 ; select the payment transaction
+8 SET RCTRANDA=$$SELPAY(RCRECTDA)
IF RCTRANDA<1
QUIT
+9 ;
+10 IF '$$LOCKREC^RCDPRPLU(RCRECTDA)
QUIT
+11 ;
+12 ; transaction is cancelled, cannot edit
+13 IF '$PIECE(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",4)
IF $PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,1)),"^")'=""
Begin DoDot:1
+14 SET VALMSG="Payment Transaction "_RCTRANDA_" is CANCELLED."
+15 DO WRITE^RCDPRPLU(VALMSG)
+16 LOCK -^RCY(344,RCRECTDA)
End DoDot:1
QUIT
+17 ;
+18 WRITE !!,"Editing Payment: ",RCTRANDA
+19 SET %=$$EDITTRAN^RCDPURET(RCRECTDA,RCTRANDA)
+20 IF '%
SET VALMSG="Transaction DELETED."
DO WRITE^RCDPRPLU(VALMSG)
+21 ; BEGIN - PRCA*4.5*321
+22 IF %
Begin DoDot:1
+23 ; Option to restore suspense EEOB
+24 SET RCEEOB=$$EEOB^RCDPEM5(RCRECTDA,RCTRANDA)
+25 ; Update EEOB claim number and restore to active status
+26 if RCEEOB>0
DO RESTORE^RCDPEM5(RCRECTDA,RCTRANDA,RCEEOB,"R")
End DoDot:1
+27 ; END - PRCA*4.5*321
+28 ;
+29 DO INIT^RCDPRPLM
+30 LOCK -^RCY(344,RCRECTDA)
+31 QUIT
+32 ;
+33 ;
CANCTRAN ; option: cancel a transaction
+1 ; this option can only be selected for unapproved receipts
+2 ; screen placed in protocol file and below as backup
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 ;
+6 NEW RCTRANDA
+7 ; select the payment transaction
+8 SET RCTRANDA=$$SELPAY(RCRECTDA)
IF RCTRANDA<1
QUIT
+9 ;
+10 IF '$$LOCKREC^RCDPRPLU(RCRECTDA)
QUIT
+11 ;
+12 ; check to see if already cancelled
+13 IF $PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4)=0
IF $PIECE($GET(^(1)),"^")'=""
Begin DoDot:1
+14 SET VALMSG="Payment Transaction "_RCTRANDA_" is already CANCELLED."
+15 DO WRITE^RCDPRPLU(VALMSG)
+16 LOCK -^RCY(344,RCRECTDA)
End DoDot:1
QUIT
+17 ;
+18 ; ask to cancel
+19 IF $$ASKCANC(RCTRANDA)=1
Begin DoDot:1
+20 DO CANCTRAN^RCDPURET(RCRECTDA,RCTRANDA)
+21 SET VALMSG="Transaction # "_RCTRANDA_" has been CANCELLED"
End DoDot:1
+22 ;
+23 DO INIT^RCDPRPLM
+24 LOCK -^RCY(344,RCRECTDA)
+25 QUIT
+26 ;
+27 ;
MOVETRAN ; move a transaction from one receipt to another
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 ;
+4 NEW RCNEWREC,RCNEWTRA,RCTRANDA
+5 ; select the payment transaction
+6 SET RCTRANDA=$$SELPAY(RCRECTDA)
IF RCTRANDA<1
QUIT
+7 ;
+8 IF '$$LOCKREC^RCDPRPLU(RCRECTDA)
QUIT
+9 ;
+10 ; transaction is cancelled, cannot edit
+11 IF '$PIECE(^RCY(344,RCRECTDA,1,RCTRANDA,0),"^",4)
IF $PIECE($GET(^RCY(344,RCRECTDA,1,RCTRANDA,1)),"^")'=""
Begin DoDot:1
+12 SET VALMSG="Payment Transaction "_RCTRANDA_" is CANCELLED."
+13 DO WRITE^RCDPRPLU(VALMSG)
+14 DO UNLOCK
End DoDot:1
QUIT
+15 ;
+16 ; select the receipt to move transaction to (can add new one)
+17 FOR
Begin DoDot:1
+18 WRITE !!,"Select the RECEIPT to move the payment transaction #"_RCTRANDA_" to:"
+19 SET RCNEWREC=$$SELRECT^RCDPUREC(1)
+20 IF RCNEWREC<1
SET RCNEWREC=-1
QUIT
+21 IF RCNEWREC=RCRECTDA
WRITE !,"Cannot copy transaction to same receipt."
SET RCNEWREC=0
QUIT
+22 IF '$$CHECKREC^RCDPRPLU(RCNEWREC)
WRITE !,"Cannot copy to a receipt which is CLOSED."
SET RCNEWREC=0
QUIT
End DoDot:1
if RCNEWREC
QUIT
+23 IF RCNEWREC<1
DO UNLOCK
QUIT
+24 ;
+25 IF '$$LOCKREC^RCDPRPLU(RCNEWREC)
DO UNLOCK
QUIT
+26 ;
+27 WRITE !
+28 IF $PIECE($GET(^RCY(344,RCNEWREC,0)),"^",4)'=$PIECE(^RCY(344,RCRECTDA,0),"^",4)
WRITE !,"WARNING, receipt types of payment are not the same type of payment."
+29 ;
+30 IF $$ASKMOVE(RCNEWREC)'=1
DO UNLOCK
QUIT
+31 ;
+32 ; MOVETRAN will add the new transaction, and allow the user to
+33 ; edit the data. returns error message if not successful or
+34 ; returns the transaction number.
+35 SET RCNEWTRA=$$MOVETRAN^RCDPURET(RCRECTDA,RCTRANDA,RCNEWREC)
+36 IF 'RCNEWTRA
Begin DoDot:1
+37 SET VALMSG=%
+38 DO WRITE^RCDPRPLU(VALMSG)
+39 DO UNLOCK
End DoDot:1
QUIT
+40 ;
+41 ; delete the transaction just moved
+42 DO DELETRAN^RCDPURET(RCRECTDA,RCTRANDA)
+43 ;
+44 DO INIT^RCDPRPLM
+45 SET VALMSG="Transaction # "_RCTRANDA_" has been MOVED/DELETED."
+46 ;
UNLOCK ; unlock receipts
+1 LOCK -^RCY(344,RCRECTDA)
+2 IF $GET(RCNEWREC)>0
LOCK -^RCY(344,RCNEWREC)
+3 QUIT
+4 ;
+5 ;
SELPAY(RCRECTDA) ; select the payment transaction for the receipt (from listmanager options)
+1 NEW RCTRANDA
+2 ; if no payments, quit
+3 IF '$ORDER(^RCY(344,RCRECTDA,1,0))
SET VALMSG="There are NO payments."
QUIT 0
+4 ; if only one payment, select that one automatically
+5 IF $PIECE($GET(^RCY(344,RCRECTDA,1,0)),"^",4)=1
SET RCTRANDA=$ORDER(^RCY(344,RCRECTDA,1,0))
+6 ; select the payment transaction
+7 IF '$GET(RCTRANDA)
WRITE !
SET RCTRANDA=$$SELTRAN^RCDPURET(RCRECTDA)
+8 QUIT RCTRANDA
+9 ;
+10 ;
ASKCANC(RCTRANDA) ; ask if it's okay to cancel a transaction
+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")=" Are you sure you want to CANCEL transaction # "_RCTRANDA
+5 WRITE !
DO ^DIR
+6 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+7 QUIT Y
+8 ;
+9 ;
ASKMOVE(RECTDA) ; ask if its okay to move the transaction
+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")=" Are you sure you want to MOVE this payment to receipt "_$PIECE($GET(^RCY(344,RECTDA,0)),"^")
+5 DO ^DIR
+6 IF $GET(DTOUT)!($GET(DUOUT))
SET Y=-1
+7 QUIT Y
