RCDPURET ;WISC/RFJ-Receipt utilities (transactions) ;1 Jun 99
;;4.5;Accounts Receivable;**114,141,169,173,196,221,304,301,326,409**;Mar 20, 1995;Build 17
;;Per VA Directive 6402, this routine should not be modified.
;
;use of IBRFN in tag PB allowed by private IA 2031
Q
;
;
SELTRAN(DA) ; select a transaction for a receipt
; returns -1 for timeout or ^, 0 for no selection, or ien of trans
N %,DIC,DTOUT,DUOUT,RCDATA,X,Y
S DIC="^RCY(344,"_DA_",1,",DIC(0)="QEAM",DIC("A")="Select Receipt TRANSACTION #: "
S DIC("W")="S RCDATA=@(DIC_Y_"",0)"") W:$P(RCDATA,U,3) ?8,"" "",$P(@(U_$P($P(RCDATA,U,3),"";"",2)_+$P(RCDATA,U,3)_"",0)""),U) W ?40,"" $ "",$J($P(RCDATA,U,4),0,2)"
D ^DIC
I Y<0,'$G(DTOUT),'$G(DUOUT) S Y=0
Q +Y
;
; PRCA*4.5*326 - Add RCDUZ to parameters
ADDTRAN(RECTDA,RCDUZ) ; add transaction for receipt (in da)
N %DT,%T,D0,DA,DD,DI,DIC,DIE,DINUM,DLAYGO,DO,DQ,DR,X,Y
I '$D(^RCY(344,RECTDA,1,0)) S ^(0)="^344.01A^"
;
; find next transaction number
S X=$O(^RCY(344,RECTDA,1,9999999),-1)
F X=X+1:1 Q:'$D(^RCY(344,RECTDA,1,X,0))
S DINUM=X
;
S DA(1)=RECTDA
S DIC="^RCY(344,"_RECTDA_",1,",DIC(0)="L",DLAYGO=344.01
S DIC("DR")=".12////"_$S($G(RCDUZ):RCDUZ,1:DUZ)_";.06///TODAY;" ; PRCA*4.5*326 use RCDUZ passed in
D FILE^DICN
Q +Y
;
;
CSTRAN(RECTDA,RCPAYAMT,CSRECORD) ; add SUSPENSE transaction for receipt (in da) ;PRCA*4.5*301
;DA=1,DA(1)=21,DIC="^RCY(344,21,1,",DIE="^RCY(344,21,1,",DILN=21,DILOCKTM=3,DISYS=18
;DR=".09; (#.09) PATIENT NAME OR BILL NUMBER [9F]
; S Y=$S('$P(^RCY(344,DA(1),1,DA,0),U,9):"@1",1:"@2");
; @1;X RCXSUSP; (#.01) TRANSACTION [1N]
; 1.02; (#1.02) COMMENT [2F]
; S Y="@3";
; @2;
; X RCXAMONT; W !," Amount Owed: $",$J($$PAYDEF^RCDPURET($P(^RCY(344,DA(1),1,DA,0),U,9)),0,2)
; @3;
; .04; (#.04) PAYMENT AMOUNT [4N]
; .06; (#.06) DATE OF PAYMENT [6D]
; .14////100882" (#.14) EDITED BY [14P:200]
; CSDEP - Required input variable.
;
N %DT,%T,D0,DA,DD,DI,DIC,DIE,DINUM,DLAYGO,DO,DQ,DR,X,Y
I '$D(^RCY(344,RECTDA,1,0)) S ^(0)="^344.01A^"
;
; find next transaction number
S X=$O(^RCY(344,RECTDA,1,9999999),-1)
F X=X+1:1 Q:'$D(^RCY(344,RECTDA,1,X,0))
S DINUM=X
;
; set Payment Fields
K DD,DO
S DA(1)=RECTDA
S DA=DINUM
S DIE="^RCY(344,"_RECTDA_",1,"
K DIC
S DR=".01////"_DA_";.04////"_RCPAYAMT_";.06////"_$P(CSRECORD,U,6)_";.14////.5;"
S DR=DR_"1.02////"_$E(CSRECORD,1,9)_":"_$P(CSRECORD,U,8)_";.25////"_CSDEP_";"
S DIC("DR")=DR
D ^DIE
S $P(^RCY(344,RECTDA,1,0),U,3,4)=DA_U_($P(^RCY(344,RECTDA,1,0),U,4)+1)
D LASTEDIT^RCDPUREC(RECTDA)
Q
;
;
EDITTRAN(RECTDA,TRANDA) ; edit a receipt transaction
; returns 1 for success, or 0 (error message)
I '$D(^RCY(344,RECTDA,1,TRANDA,0)) Q 0
;
N %,%DT,%T,%Y,C,D,D0,D1,DA,DATA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DIU,DIV,DIW,DG,DQ,DR,DZ,RCAMOUNT,RCTYPE,RESULT,X,Y
N RCXAMONT,RCXSUSP,RCXSUSP1,RCXADJ,RCERA,RCADJ,RCXERA
;
; build dr string based on type of payment on receipt
S RCTYPE=$P($G(^RC(341.1,+$P(^RCY(344,RECTDA,0),"^",4),0)),"^",2)
S RCADJ=0,RCERA=+$O(^RCY(344.4,"AREC",RECTDA,0))
S DR=""
I RCERA,$D(^RCY(344.49,+RCERA,0)),$P(^RCY(344,RECTDA,1,TRANDA,0),"^",28) D ; Worklist has a dec adj associated with it
. N Z
. S Z=$$EXTERNAL^DILFD(344.01,.09,,$P($G(^RCY(344,RECTDA,1,TRANDA,0)),U,9))
. S RCADJ=1,RCXERA="W !,""NOTE: This payment has an EEOB Worklist dec adj associated with it."",!,""BILL NUMBER: "_Z_" (uneditable)""",DR="X RCXERA;"
E D
. ; patient name or bill number
. S DR=".09;"
S DR=DR_"S Y=$S('$P(^RCY(344,DA(1),1,DA,0),U,9):""@1"",1:""@2"");"
; ask comment if no acct (unapplied)
S RCXSUSP="W !?5,""NOTE: This payment will be posted to the station's suspense fund."""
;
; PRCA*4.5*304 - Force user to type something
; Check for the the existance of a comment. If none currently exists,
; go to new code to prompt user and enforce entry of a comment, otherwise
; use the existing field call to edit it.
S RCXSUSP1="S:$P($G(^RCY(344,DA(1),1,DA,1)),U,2)="""" Y=""@4"""
S DR=DR_"@1;X RCXSUSP;X RCXSUSP1;1.02R;S Y=""@3"";@4;1.02///^S X=$$GETRSN^RCDPURET;S Y=""@3"";"
;
; payment amount
S RCXAMONT="W !,"" Amount Owed: $"",$J($$PAYDEF^RCDPURET($P(^RCY(344,DA(1),1,DA,0),U,9)),0,2)"
S DR=DR_"@2;X RCXAMONT;@3;.04;"
; date of payment
S DR=DR_".06;"
; type of payment = district counsel(3), check(4), dept of justice (5),
; irs (11), lockbox (12), top payment (13), ogc-chk (19)
;
I RCTYPE=3!(RCTYPE=4)!(RCTYPE=5)!(RCTYPE=11)!(RCTYPE=12)!(RCTYPE=13)!(RCTYPE=19) D
. S DR=DR_".07d;" ; check number
. S DR=DR_".08d;" ; bank number
. S DR=DR_".1d;" ; date of check
; type of payment = credit card (7)
I RCTYPE=7 D
. S DR=DR_".11d;" ; credit card number
. S DR=DR_".02d;" ; confirmation number
;
S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
S DA=TRANDA,DA(1)=RECTDA
; edited by
S DR=DR_".14////"_DUZ
D ^DIE
D LASTEDIT^RCDPUREC(RECTDA)
;
; check for missing fields
S DATA=^RCY(344,RECTDA,1,TRANDA,0)
S RESULT=1
I RESULT,'$P(DATA,"^",4) S RESULT="Payment Amount is ZERO."
I RESULT,'$P(DATA,"^",6) S RESULT="Date of Payment NOT entered."
I RESULT,RCTYPE=13,$$TRACE($P(DATA,"^",3))="" S RESULT="TOP TRACE NUMBER NOT ENTERED"
I RESULT,RCTYPE=7,$P(DATA,"^",11)="" W !,"WARNING: Credit Card Number NOT entered."
I RESULT,$P(DATA,"^",6)<$P(DATA,"^",10) W !,"WARNING: Date of check is greater than the date of payment."
;
; if field is missing, delete the transaction
I 'RESULT D DELETRAN(RECTDA,TRANDA)
;
; if transaction okay, print receipt
I RESULT D RECEIPT^RCDPRECT(RECTDA,TRANDA)
;
Q RESULT
;
;
EDITACCT(RECTDA,TRANDA) ; edit the account on a receipt
N C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
S DR=".09;"
S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
S DA=TRANDA,DA(1)=RECTDA
D ^DIE
D LASTEDIT^RCDPUREC(RECTDA)
Q
;
;
DELEACCT(RECTDA,TRANDA) ; delete the account on a receipt
N D,D0,D1,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,X
S DR=".09///@;.03///@;"
S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
S DA=TRANDA,DA(1)=RECTDA
D ^DIE
D LASTEDIT^RCDPUREC(RECTDA)
;
;PRCA*4.5*304
;Update the Audit Log ans Suspense status back to Pending and In Suspense
D AUDIT^RCBEPAY(RECTDA,TRANDA,"I")
D SUSPDIS^RCBEPAY(RECTDA,TRANDA,"P")
Q
;
;
EDITFMS(RECTDA,TRANDA,DEFAULT) ; edit fms document number for clearing suspense
N C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
S DR=".26;"
I $G(DEFAULT)'="" S DR=".26////"_DEFAULT_";"
S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
S DA=TRANDA,DA(1)=RECTDA
D ^DIE
Q
;
;
MOVETRAN(RCOLDREC,RCOLDTRA,RCNEWREC) ; move a transactions data
N %DT,%T,D0,D1,DA,DG,DIC,DICR,DIK,DIU,RCNEWTRA,RESULT,X,Y
;
; add new transaction to 2nd receipt
W !,"Adding a NEW payment transaction to receipt "_$P(^RCY(344,RCNEWREC,0),"^")_": "
S RCNEWTRA=$$ADDTRAN(RCNEWREC)
I 'RCNEWTRA Q "Unable to ADD a new payment transaction."
;
W "# ",RCNEWTRA
;
; move data to selected receipt and re-index entry
S ^RCY(344,RCNEWREC,1,RCNEWTRA,0)=RCNEWTRA_"^"_$P(^RCY(344,RCOLDREC,1,RCOLDTRA,0),"^",2,99)
S DIK="^RCY(344,"_RCNEWREC_",1,",DA(1)=RCNEWREC,DA=RCNEWTRA
D IX^DIK
;
S RESULT=$$EDITTRAN(RCNEWREC,RCNEWTRA)
Q RESULT
;
;
CANCTRAN(RECTDA,RECTRAN) ; cancel a transaction
N D,D0,DA,DI,DIC,DIE,DQ,DR,RCDATA,X,Y
S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
S RCDATA="Cancelled by: "_$P(^VA(200,DUZ,0),"^")_" Amount: $ "_$J($P(^RCY(344,RECTDA,1,RECTRAN,0),"^",4),0,2)
S DR="1.01////^S X=RCDATA;.04////^S X=0;.05////^S X=0;1.02;"
S DA=RECTRAN,DA(1)=RECTDA
D ^DIE
D LASTEDIT^RCDPUREC(RECTDA)
Q
;
;
DELETRAN(RECTDA,TRANDA) ; delete a transaction
N %,D0,D1,DA,DIC,DICR,DIG,DIH,DIK,DIU,DIV,DIW,X,Y
S DIK="^RCY(344,"_RECTDA_",1,",DA(1)=RECTDA,DA=TRANDA
D ^DIK
D LASTEDIT^RCDPUREC(RECTDA)
Q
;
;
SETUNAPP(RECTDA,TRANDA,UNAPPNUM) ; store the unapplied deposit number
N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
S DR=".25////"_UNAPPNUM_";"
S DA=TRANDA,DA(1)=RECTDA
D ^DIE
Q
;
;
PAYDEF(DEBTOR) ; get default for payment amount (used in input templates for payments)
N X
I 'DEBTOR Q 0
I DEBTOR[";DPT(" S X=$$BAL^PRCAFN(DEBTOR)
I DEBTOR[";PRCA(430,",",112,107,102,"[(","_$P($G(^PRCA(430.3,+$P($G(^PRCA(430,+DEBTOR,0)),"^",8),0)),"^",3)_",") S X=$G(^PRCA(430,+DEBTOR,7)),X=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
Q +$G(X)
;
;
PENDPAY(DEBTOR) ; return pending payments for a debtor
; returns ^tmp($j,"rcdpurec","pp",rectda,tranda)=data in 344.01
; and the total pending payment dollars
N DATA,RECTDA,TOTAL,TRANDA
K ^TMP($J,"RCDPUREC","PP")
; look at open receipts
S RECTDA=0 F S RECTDA=$O(^RCY(344,"ASTAT",1,RECTDA)) Q:'RECTDA D
. S TRANDA=0 F S TRANDA=$O(^RCY(344,"AACCT",DEBTOR,RECTDA,TRANDA)) Q:'TRANDA D
. . S DATA=$G(^RCY(344,RECTDA,1,TRANDA,0)) I DATA="" Q
. . ; total paid = total processed
. . I +$P(DATA,"^",4)=+$P(DATA,"^",5) Q
. . S ^TMP($J,"RCDPUREC","PP",RECTDA,TRANDA)=DATA
. . S TOTAL=$G(TOTAL)+$P(DATA,"^",4)
Q +$G(TOTAL)
TRACE(DEBTOR) ;ENTER TOP TRACE NUMBER FOR TOP RECEIPTS
N TRACE,DIC,DIE,DR,DA
S TRACE="" G TRACEQ:'DEBTOR
S DA=$S(DEBTOR["DPT(":$O(^RCD(340,"B",DEBTOR,0)),1:$P($G(^PRCA(430,+DEBTOR,0)),U,9))
G TRACEQ:'DA
S (DIC,DIE)="^RCD(340,",DR=6.07 D ^DIE
S TRACE=$P($G(^RCD(340,DA,6)),"^",7)
TRACEQ Q TRACE
;
;PRCA*4.5*304 - Force user to enter a comment if item is in suspense
GETRSN() ;
;
N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,RCTODAY
;
; Get the Comment: Assume the end date is today.
F D Q:Y'=""
. S DIR("?")="ENTER THE REASON FOR PLACING THE RECEIPT ITEM INTO THE SUSPENSE FUND"
. S DIR(0)="FA^1:60",DIR("A")="COMMENT: " D ^DIR K DIR
. I $G(DTOUT)!$G(DUOUT) S Y="^" Q
. S Y=$$TRIM^XLFSTR(Y)
. I Y="" W !,"A comment is required when changing the status of an item in Suspense. Please",!,"try again." Q
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPURET 10197 printed Apr 09, 2024@20:51:12 Page 2
RCDPURET ;WISC/RFJ-Receipt utilities (transactions) ;1 Jun 99
+1 ;;4.5;Accounts Receivable;**114,141,169,173,196,221,304,301,326,409**;Mar 20, 1995;Build 17
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;use of IBRFN in tag PB allowed by private IA 2031
+5 QUIT
+6 ;
+7 ;
SELTRAN(DA) ; select a transaction for a receipt
+1 ; returns -1 for timeout or ^, 0 for no selection, or ien of trans
+2 NEW %,DIC,DTOUT,DUOUT,RCDATA,X,Y
+3 SET DIC="^RCY(344,"_DA_",1,"
SET DIC(0)="QEAM"
SET DIC("A")="Select Receipt TRANSACTION #: "
+4 SET DIC("W")="S RCDATA=@(DIC_Y_"",0)"") W:$P(RCDATA,U,3) ?8,"" "",$P(@(U_$P($P(RCDATA,U,3),"";"",2)_+$P(RCDATA,U,3)_"",0)""),U) W ?40,"" $ "",$J($P(RCDATA,U,4),0,2)"
+5 DO ^DIC
+6 IF Y<0
IF '$GET(DTOUT)
IF '$GET(DUOUT)
SET Y=0
+7 QUIT +Y
+8 ;
+9 ; PRCA*4.5*326 - Add RCDUZ to parameters
ADDTRAN(RECTDA,RCDUZ) ; add transaction for receipt (in da)
+1 NEW %DT,%T,D0,DA,DD,DI,DIC,DIE,DINUM,DLAYGO,DO,DQ,DR,X,Y
+2 IF '$DATA(^RCY(344,RECTDA,1,0))
SET ^(0)="^344.01A^"
+3 ;
+4 ; find next transaction number
+5 SET X=$ORDER(^RCY(344,RECTDA,1,9999999),-1)
+6 FOR X=X+1:1
if '$DATA(^RCY(344,RECTDA,1,X,0))
QUIT
+7 SET DINUM=X
+8 ;
+9 SET DA(1)=RECTDA
+10 SET DIC="^RCY(344,"_RECTDA_",1,"
SET DIC(0)="L"
SET DLAYGO=344.01
+11 ; PRCA*4.5*326 use RCDUZ passed in
SET DIC("DR")=".12////"_$SELECT($GET(RCDUZ):RCDUZ,1:DUZ)_";.06///TODAY;"
+12 DO FILE^DICN
+13 QUIT +Y
+14 ;
+15 ;
CSTRAN(RECTDA,RCPAYAMT,CSRECORD) ; add SUSPENSE transaction for receipt (in da) ;PRCA*4.5*301
+1 ;DA=1,DA(1)=21,DIC="^RCY(344,21,1,",DIE="^RCY(344,21,1,",DILN=21,DILOCKTM=3,DISYS=18
+2 ;DR=".09; (#.09) PATIENT NAME OR BILL NUMBER [9F]
+3 ; S Y=$S('$P(^RCY(344,DA(1),1,DA,0),U,9):"@1",1:"@2");
+4 ; @1;X RCXSUSP; (#.01) TRANSACTION [1N]
+5 ; 1.02; (#1.02) COMMENT [2F]
+6 ; S Y="@3";
+7 ; @2;
+8 ; X RCXAMONT; W !," Amount Owed: $",$J($$PAYDEF^RCDPURET($P(^RCY(344,DA(1),1,DA,0),U,9)),0,2)
+9 ; @3;
+10 ; .04; (#.04) PAYMENT AMOUNT [4N]
+11 ; .06; (#.06) DATE OF PAYMENT [6D]
+12 ; .14////100882" (#.14) EDITED BY [14P:200]
+13 ; CSDEP - Required input variable.
+14 ;
+15 NEW %DT,%T,D0,DA,DD,DI,DIC,DIE,DINUM,DLAYGO,DO,DQ,DR,X,Y
+16 IF '$DATA(^RCY(344,RECTDA,1,0))
SET ^(0)="^344.01A^"
+17 ;
+18 ; find next transaction number
+19 SET X=$ORDER(^RCY(344,RECTDA,1,9999999),-1)
+20 FOR X=X+1:1
if '$DATA(^RCY(344,RECTDA,1,X,0))
QUIT
+21 SET DINUM=X
+22 ;
+23 ; set Payment Fields
+24 KILL DD,DO
+25 SET DA(1)=RECTDA
+26 SET DA=DINUM
+27 SET DIE="^RCY(344,"_RECTDA_",1,"
+28 KILL DIC
+29 SET DR=".01////"_DA_";.04////"_RCPAYAMT_";.06////"_$PIECE(CSRECORD,U,6)_";.14////.5;"
+30 SET DR=DR_"1.02////"_$EXTRACT(CSRECORD,1,9)_":"_$PIECE(CSRECORD,U,8)_";.25////"_CSDEP_";"
+31 SET DIC("DR")=DR
+32 DO ^DIE
+33 SET $PIECE(^RCY(344,RECTDA,1,0),U,3,4)=DA_U_($PIECE(^RCY(344,RECTDA,1,0),U,4)+1)
+34 DO LASTEDIT^RCDPUREC(RECTDA)
+35 QUIT
+36 ;
+37 ;
EDITTRAN(RECTDA,TRANDA) ; edit a receipt transaction
+1 ; returns 1 for success, or 0 (error message)
+2 IF '$DATA(^RCY(344,RECTDA,1,TRANDA,0))
QUIT 0
+3 ;
+4 NEW %,%DT,%T,%Y,C,D,D0,D1,DA,DATA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DIU,DIV,DIW,DG,DQ,DR,DZ,RCAMOUNT,RCTYPE,RESULT,X,Y
+5 NEW RCXAMONT,RCXSUSP,RCXSUSP1,RCXADJ,RCERA,RCADJ,RCXERA
+6 ;
+7 ; build dr string based on type of payment on receipt
+8 SET RCTYPE=$PIECE($GET(^RC(341.1,+$PIECE(^RCY(344,RECTDA,0),"^",4),0)),"^",2)
+9 SET RCADJ=0
SET RCERA=+$ORDER(^RCY(344.4,"AREC",RECTDA,0))
+10 SET DR=""
+11 ; Worklist has a dec adj associated with it
IF RCERA
IF $DATA(^RCY(344.49,+RCERA,0))
IF $PIECE(^RCY(344,RECTDA,1,TRANDA,0),"^",28)
Begin DoDot:1
+12 NEW Z
+13 SET Z=$$EXTERNAL^DILFD(344.01,.09,,$PIECE($GET(^RCY(344,RECTDA,1,TRANDA,0)),U,9))
+14 SET RCADJ=1
SET RCXERA="W !,""NOTE: This payment has an EEOB Worklist dec adj associated with it."",!,""BILL NUMBER: "_Z_" (uneditable)"""
SET DR="X RCXERA;"
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 ; patient name or bill number
+17 SET DR=".09;"
End DoDot:1
+18 SET DR=DR_"S Y=$S('$P(^RCY(344,DA(1),1,DA,0),U,9):""@1"",1:""@2"");"
+19 ; ask comment if no acct (unapplied)
+20 SET RCXSUSP="W !?5,""NOTE: This payment will be posted to the station's suspense fund."""
+21 ;
+22 ; PRCA*4.5*304 - Force user to type something
+23 ; Check for the the existance of a comment. If none currently exists,
+24 ; go to new code to prompt user and enforce entry of a comment, otherwise
+25 ; use the existing field call to edit it.
+26 SET RCXSUSP1="S:$P($G(^RCY(344,DA(1),1,DA,1)),U,2)="""" Y=""@4"""
+27 SET DR=DR_"@1;X RCXSUSP;X RCXSUSP1;1.02R;S Y=""@3"";@4;1.02///^S X=$$GETRSN^RCDPURET;S Y=""@3"";"
+28 ;
+29 ; payment amount
+30 SET RCXAMONT="W !,"" Amount Owed: $"",$J($$PAYDEF^RCDPURET($P(^RCY(344,DA(1),1,DA,0),U,9)),0,2)"
+31 SET DR=DR_"@2;X RCXAMONT;@3;.04;"
+32 ; date of payment
+33 SET DR=DR_".06;"
+34 ; type of payment = district counsel(3), check(4), dept of justice (5),
+35 ; irs (11), lockbox (12), top payment (13), ogc-chk (19)
+36 ;
+37 IF RCTYPE=3!(RCTYPE=4)!(RCTYPE=5)!(RCTYPE=11)!(RCTYPE=12)!(RCTYPE=13)!(RCTYPE=19)
Begin DoDot:1
+38 ; check number
SET DR=DR_".07d;"
+39 ; bank number
SET DR=DR_".08d;"
+40 ; date of check
SET DR=DR_".1d;"
End DoDot:1
+41 ; type of payment = credit card (7)
+42 IF RCTYPE=7
Begin DoDot:1
+43 ; credit card number
SET DR=DR_".11d;"
+44 ; confirmation number
SET DR=DR_".02d;"
End DoDot:1
+45 ;
+46 SET (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
+47 SET DA=TRANDA
SET DA(1)=RECTDA
+48 ; edited by
+49 SET DR=DR_".14////"_DUZ
+50 DO ^DIE
+51 DO LASTEDIT^RCDPUREC(RECTDA)
+52 ;
+53 ; check for missing fields
+54 SET DATA=^RCY(344,RECTDA,1,TRANDA,0)
+55 SET RESULT=1
+56 IF RESULT
IF '$PIECE(DATA,"^",4)
SET RESULT="Payment Amount is ZERO."
+57 IF RESULT
IF '$PIECE(DATA,"^",6)
SET RESULT="Date of Payment NOT entered."
+58 IF RESULT
IF RCTYPE=13
IF $$TRACE($PIECE(DATA,"^",3))=""
SET RESULT="TOP TRACE NUMBER NOT ENTERED"
+59 IF RESULT
IF RCTYPE=7
IF $PIECE(DATA,"^",11)=""
WRITE !,"WARNING: Credit Card Number NOT entered."
+60 IF RESULT
IF $PIECE(DATA,"^",6)<$PIECE(DATA,"^",10)
WRITE !,"WARNING: Date of check is greater than the date of payment."
+61 ;
+62 ; if field is missing, delete the transaction
+63 IF 'RESULT
DO DELETRAN(RECTDA,TRANDA)
+64 ;
+65 ; if transaction okay, print receipt
+66 IF RESULT
DO RECEIPT^RCDPRECT(RECTDA,TRANDA)
+67 ;
+68 QUIT RESULT
+69 ;
+70 ;
EDITACCT(RECTDA,TRANDA) ; edit the account on a receipt
+1 NEW C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
+2 SET DR=".09;"
+3 SET (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
+4 SET DA=TRANDA
SET DA(1)=RECTDA
+5 DO ^DIE
+6 DO LASTEDIT^RCDPUREC(RECTDA)
+7 QUIT
+8 ;
+9 ;
DELEACCT(RECTDA,TRANDA) ; delete the account on a receipt
+1 NEW D,D0,D1,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,X
+2 SET DR=".09///@;.03///@;"
+3 SET (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
+4 SET DA=TRANDA
SET DA(1)=RECTDA
+5 DO ^DIE
+6 DO LASTEDIT^RCDPUREC(RECTDA)
+7 ;
+8 ;PRCA*4.5*304
+9 ;Update the Audit Log ans Suspense status back to Pending and In Suspense
+10 DO AUDIT^RCBEPAY(RECTDA,TRANDA,"I")
+11 DO SUSPDIS^RCBEPAY(RECTDA,TRANDA,"P")
+12 QUIT
+13 ;
+14 ;
EDITFMS(RECTDA,TRANDA,DEFAULT) ; edit fms document number for clearing suspense
+1 NEW C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
+2 SET DR=".26;"
+3 IF $GET(DEFAULT)'=""
SET DR=".26////"_DEFAULT_";"
+4 SET (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
+5 SET DA=TRANDA
SET DA(1)=RECTDA
+6 DO ^DIE
+7 QUIT
+8 ;
+9 ;
MOVETRAN(RCOLDREC,RCOLDTRA,RCNEWREC) ; move a transactions data
+1 NEW %DT,%T,D0,D1,DA,DG,DIC,DICR,DIK,DIU,RCNEWTRA,RESULT,X,Y
+2 ;
+3 ; add new transaction to 2nd receipt
+4 WRITE !,"Adding a NEW payment transaction to receipt "_$PIECE(^RCY(344,RCNEWREC,0),"^")_": "
+5 SET RCNEWTRA=$$ADDTRAN(RCNEWREC)
+6 IF 'RCNEWTRA
QUIT "Unable to ADD a new payment transaction."
+7 ;
+8 WRITE "# ",RCNEWTRA
+9 ;
+10 ; move data to selected receipt and re-index entry
+11 SET ^RCY(344,RCNEWREC,1,RCNEWTRA,0)=RCNEWTRA_"^"_$PIECE(^RCY(344,RCOLDREC,1,RCOLDTRA,0),"^",2,99)
+12 SET DIK="^RCY(344,"_RCNEWREC_",1,"
SET DA(1)=RCNEWREC
SET DA=RCNEWTRA
+13 DO IX^DIK
+14 ;
+15 SET RESULT=$$EDITTRAN(RCNEWREC,RCNEWTRA)
+16 QUIT RESULT
+17 ;
+18 ;
CANCTRAN(RECTDA,RECTRAN) ; cancel a transaction
+1 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,RCDATA,X,Y
+2 SET (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
+3 SET RCDATA="Cancelled by: "_$PIECE(^VA(200,DUZ,0),"^")_" Amount: $ "_$JUSTIFY($PIECE(^RCY(344,RECTDA,1,RECTRAN,0),"^",4),0,2)
+4 SET DR="1.01////^S X=RCDATA;.04////^S X=0;.05////^S X=0;1.02;"
+5 SET DA=RECTRAN
SET DA(1)=RECTDA
+6 DO ^DIE
+7 DO LASTEDIT^RCDPUREC(RECTDA)
+8 QUIT
+9 ;
+10 ;
DELETRAN(RECTDA,TRANDA) ; delete a transaction
+1 NEW %,D0,D1,DA,DIC,DICR,DIG,DIH,DIK,DIU,DIV,DIW,X,Y
+2 SET DIK="^RCY(344,"_RECTDA_",1,"
SET DA(1)=RECTDA
SET DA=TRANDA
+3 DO ^DIK
+4 DO LASTEDIT^RCDPUREC(RECTDA)
+5 QUIT
+6 ;
+7 ;
SETUNAPP(RECTDA,TRANDA,UNAPPNUM) ; store the unapplied deposit number
+1 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+2 SET (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
+3 SET DR=".25////"_UNAPPNUM_";"
+4 SET DA=TRANDA
SET DA(1)=RECTDA
+5 DO ^DIE
+6 QUIT
+7 ;
+8 ;
PAYDEF(DEBTOR) ; get default for payment amount (used in input templates for payments)
+1 NEW X
+2 IF 'DEBTOR
QUIT 0
+3 IF DEBTOR[";DPT("
SET X=$$BAL^PRCAFN(DEBTOR)
+4 IF DEBTOR[";PRCA(430,"
IF ",112,107,102,"[(","_$PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(430,+DEBTOR,0)),"^",8),0)),"^",3)_",")
SET X=$GET(^PRCA(430,+DEBTOR,7))
SET X=$PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5)
+5 QUIT +$GET(X)
+6 ;
+7 ;
PENDPAY(DEBTOR) ; return pending payments for a debtor
+1 ; returns ^tmp($j,"rcdpurec","pp",rectda,tranda)=data in 344.01
+2 ; and the total pending payment dollars
+3 NEW DATA,RECTDA,TOTAL,TRANDA
+4 KILL ^TMP($JOB,"RCDPUREC","PP")
+5 ; look at open receipts
+6 SET RECTDA=0
FOR
SET RECTDA=$ORDER(^RCY(344,"ASTAT",1,RECTDA))
if 'RECTDA
QUIT
Begin DoDot:1
+7 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^RCY(344,"AACCT",DEBTOR,RECTDA,TRANDA))
if 'TRANDA
QUIT
Begin DoDot:2
+8 SET DATA=$GET(^RCY(344,RECTDA,1,TRANDA,0))
IF DATA=""
QUIT
+9 ; total paid = total processed
+10 IF +$PIECE(DATA,"^",4)=+$PIECE(DATA,"^",5)
QUIT
+11 SET ^TMP($JOB,"RCDPUREC","PP",RECTDA,TRANDA)=DATA
+12 SET TOTAL=$GET(TOTAL)+$PIECE(DATA,"^",4)
End DoDot:2
End DoDot:1
+13 QUIT +$GET(TOTAL)
TRACE(DEBTOR) ;ENTER TOP TRACE NUMBER FOR TOP RECEIPTS
+1 NEW TRACE,DIC,DIE,DR,DA
+2 SET TRACE=""
if 'DEBTOR
GOTO TRACEQ
+3 SET DA=$SELECT(DEBTOR["DPT(":$ORDER(^RCD(340,"B",DEBTOR,0)),1:$PIECE($GET(^PRCA(430,+DEBTOR,0)),U,9))
+4 if 'DA
GOTO TRACEQ
+5 SET (DIC,DIE)="^RCD(340,"
SET DR=6.07
DO ^DIE
+6 SET TRACE=$PIECE($GET(^RCD(340,DA,6)),"^",7)
TRACEQ QUIT TRACE
+1 ;
+2 ;PRCA*4.5*304 - Force user to enter a comment if item is in suspense
GETRSN() ;
+1 ;
+2 NEW X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,RCTODAY
+3 ;
+4 ; Get the Comment: Assume the end date is today.
+5 FOR
Begin DoDot:1
+6 SET DIR("?")="ENTER THE REASON FOR PLACING THE RECEIPT ITEM INTO THE SUSPENSE FUND"
+7 SET DIR(0)="FA^1:60"
SET DIR("A")="COMMENT: "
DO ^DIR
KILL DIR
+8 IF $GET(DTOUT)!$GET(DUOUT)
SET Y="^"
QUIT
+9 SET Y=$$TRIM^XLFSTR(Y)
+10 IF Y=""
WRITE !,"A comment is required when changing the status of an item in Suspense. Please",!,"try again."
QUIT
End DoDot:1
if Y'=""
QUIT
+11 QUIT Y
