Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPURET

RCDPURET.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;use of IBRFN in tag PB allowed by private IA 2031
  1. Q
  1. ;
  1. ;
  1. SELTRAN(DA) ; select a transaction for a receipt
  1. ; returns -1 for timeout or ^, 0 for no selection, or ien of trans
  1. N %,DIC,DTOUT,DUOUT,RCDATA,X,Y
  1. S DIC="^RCY(344,"_DA_",1,",DIC(0)="QEAM",DIC("A")="Select Receipt TRANSACTION #: "
  1. 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)"
  1. D ^DIC
  1. I Y<0,'$G(DTOUT),'$G(DUOUT) S Y=0
  1. Q +Y
  1. ;
  1. ; PRCA*4.5*326 - Add RCDUZ to parameters
  1. ADDTRAN(RECTDA,RCDUZ) ; add transaction for receipt (in da)
  1. N %DT,%T,D0,DA,DD,DI,DIC,DIE,DINUM,DLAYGO,DO,DQ,DR,X,Y
  1. I '$D(^RCY(344,RECTDA,1,0)) S ^(0)="^344.01A^"
  1. ;
  1. ; find next transaction number
  1. S X=$O(^RCY(344,RECTDA,1,9999999),-1)
  1. F X=X+1:1 Q:'$D(^RCY(344,RECTDA,1,X,0))
  1. S DINUM=X
  1. ;
  1. S DA(1)=RECTDA
  1. S DIC="^RCY(344,"_RECTDA_",1,",DIC(0)="L",DLAYGO=344.01
  1. S DIC("DR")=".12////"_$S($G(RCDUZ):RCDUZ,1:DUZ)_";.06///TODAY;" ; PRCA*4.5*326 use RCDUZ passed in
  1. D FILE^DICN
  1. Q +Y
  1. ;
  1. ;
  1. 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
  1. ;DR=".09; (#.09) PATIENT NAME OR BILL NUMBER [9F]
  1. ; S Y=$S('$P(^RCY(344,DA(1),1,DA,0),U,9):"@1",1:"@2");
  1. ; @1;X RCXSUSP; (#.01) TRANSACTION [1N]
  1. ; 1.02; (#1.02) COMMENT [2F]
  1. ; S Y="@3";
  1. ; @2;
  1. ; X RCXAMONT; W !," Amount Owed: $",$J($$PAYDEF^RCDPURET($P(^RCY(344,DA(1),1,DA,0),U,9)),0,2)
  1. ; @3;
  1. ; .04; (#.04) PAYMENT AMOUNT [4N]
  1. ; .06; (#.06) DATE OF PAYMENT [6D]
  1. ; .14////100882" (#.14) EDITED BY [14P:200]
  1. ; CSDEP - Required input variable.
  1. ;
  1. N %DT,%T,D0,DA,DD,DI,DIC,DIE,DINUM,DLAYGO,DO,DQ,DR,X,Y
  1. I '$D(^RCY(344,RECTDA,1,0)) S ^(0)="^344.01A^"
  1. ;
  1. ; find next transaction number
  1. S X=$O(^RCY(344,RECTDA,1,9999999),-1)
  1. F X=X+1:1 Q:'$D(^RCY(344,RECTDA,1,X,0))
  1. S DINUM=X
  1. ;
  1. ; set Payment Fields
  1. K DD,DO
  1. S DA(1)=RECTDA
  1. S DA=DINUM
  1. S DIE="^RCY(344,"_RECTDA_",1,"
  1. K DIC
  1. S DR=".01////"_DA_";.04////"_RCPAYAMT_";.06////"_$P(CSRECORD,U,6)_";.14////.5;"
  1. S DR=DR_"1.02////"_$E(CSRECORD,1,9)_":"_$P(CSRECORD,U,8)_";.25////"_CSDEP_";"
  1. S DIC("DR")=DR
  1. D ^DIE
  1. S $P(^RCY(344,RECTDA,1,0),U,3,4)=DA_U_($P(^RCY(344,RECTDA,1,0),U,4)+1)
  1. D LASTEDIT^RCDPUREC(RECTDA)
  1. Q
  1. ;
  1. ;
  1. EDITTRAN(RECTDA,TRANDA) ; edit a receipt transaction
  1. ; returns 1 for success, or 0 (error message)
  1. I '$D(^RCY(344,RECTDA,1,TRANDA,0)) Q 0
  1. ;
  1. 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
  1. N RCXAMONT,RCXSUSP,RCXSUSP1,RCXADJ,RCERA,RCADJ,RCXERA
  1. ;
  1. ; build dr string based on type of payment on receipt
  1. S RCTYPE=$P($G(^RC(341.1,+$P(^RCY(344,RECTDA,0),"^",4),0)),"^",2)
  1. S RCADJ=0,RCERA=+$O(^RCY(344.4,"AREC",RECTDA,0))
  1. S DR=""
  1. 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
  1. . N Z
  1. . S Z=$$EXTERNAL^DILFD(344.01,.09,,$P($G(^RCY(344,RECTDA,1,TRANDA,0)),U,9))
  1. . S RCADJ=1,RCXERA="W !,""NOTE: This payment has an EEOB Worklist dec adj associated with it."",!,""BILL NUMBER: "_Z_" (uneditable)""",DR="X RCXERA;"
  1. E D
  1. . ; patient name or bill number
  1. . S DR=".09;"
  1. S DR=DR_"S Y=$S('$P(^RCY(344,DA(1),1,DA,0),U,9):""@1"",1:""@2"");"
  1. ; ask comment if no acct (unapplied)
  1. S RCXSUSP="W !?5,""NOTE: This payment will be posted to the station's suspense fund."""
  1. ;
  1. ; PRCA*4.5*304 - Force user to type something
  1. ; Check for the the existance of a comment. If none currently exists,
  1. ; go to new code to prompt user and enforce entry of a comment, otherwise
  1. ; use the existing field call to edit it.
  1. S RCXSUSP1="S:$P($G(^RCY(344,DA(1),1,DA,1)),U,2)="""" Y=""@4"""
  1. S DR=DR_"@1;X RCXSUSP;X RCXSUSP1;1.02R;S Y=""@3"";@4;1.02///^S X=$$GETRSN^RCDPURET;S Y=""@3"";"
  1. ;
  1. ; payment amount
  1. S RCXAMONT="W !,"" Amount Owed: $"",$J($$PAYDEF^RCDPURET($P(^RCY(344,DA(1),1,DA,0),U,9)),0,2)"
  1. S DR=DR_"@2;X RCXAMONT;@3;.04;"
  1. ; date of payment
  1. S DR=DR_".06;"
  1. ; type of payment = district counsel(3), check(4), dept of justice (5),
  1. ; irs (11), lockbox (12), top payment (13), ogc-chk (19)
  1. ;
  1. I RCTYPE=3!(RCTYPE=4)!(RCTYPE=5)!(RCTYPE=11)!(RCTYPE=12)!(RCTYPE=13)!(RCTYPE=19) D
  1. . S DR=DR_".07d;" ; check number
  1. . S DR=DR_".08d;" ; bank number
  1. . S DR=DR_".1d;" ; date of check
  1. ; type of payment = credit card (7)
  1. I RCTYPE=7 D
  1. . S DR=DR_".11d;" ; credit card number
  1. . S DR=DR_".02d;" ; confirmation number
  1. ;
  1. S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
  1. S DA=TRANDA,DA(1)=RECTDA
  1. ; edited by
  1. S DR=DR_".14////"_DUZ
  1. D ^DIE
  1. D LASTEDIT^RCDPUREC(RECTDA)
  1. ;
  1. ; check for missing fields
  1. S DATA=^RCY(344,RECTDA,1,TRANDA,0)
  1. S RESULT=1
  1. I RESULT,'$P(DATA,"^",4) S RESULT="Payment Amount is ZERO."
  1. I RESULT,'$P(DATA,"^",6) S RESULT="Date of Payment NOT entered."
  1. I RESULT,RCTYPE=13,$$TRACE($P(DATA,"^",3))="" S RESULT="TOP TRACE NUMBER NOT ENTERED"
  1. I RESULT,RCTYPE=7,$P(DATA,"^",11)="" W !,"WARNING: Credit Card Number NOT entered."
  1. I RESULT,$P(DATA,"^",6)<$P(DATA,"^",10) W !,"WARNING: Date of check is greater than the date of payment."
  1. ;
  1. ; if field is missing, delete the transaction
  1. I 'RESULT D DELETRAN(RECTDA,TRANDA)
  1. ;
  1. ; if transaction okay, print receipt
  1. I RESULT D RECEIPT^RCDPRECT(RECTDA,TRANDA)
  1. ;
  1. Q RESULT
  1. ;
  1. ;
  1. EDITACCT(RECTDA,TRANDA) ; edit the account on a receipt
  1. N C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
  1. S DR=".09;"
  1. S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
  1. S DA=TRANDA,DA(1)=RECTDA
  1. D ^DIE
  1. D LASTEDIT^RCDPUREC(RECTDA)
  1. Q
  1. ;
  1. ;
  1. DELEACCT(RECTDA,TRANDA) ; delete the account on a receipt
  1. N D,D0,D1,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR,X
  1. S DR=".09///@;.03///@;"
  1. S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
  1. S DA=TRANDA,DA(1)=RECTDA
  1. D ^DIE
  1. D LASTEDIT^RCDPUREC(RECTDA)
  1. ;
  1. ;PRCA*4.5*304
  1. ;Update the Audit Log ans Suspense status back to Pending and In Suspense
  1. D AUDIT^RCBEPAY(RECTDA,TRANDA,"I")
  1. D SUSPDIS^RCBEPAY(RECTDA,TRANDA,"P")
  1. Q
  1. ;
  1. ;
  1. EDITFMS(RECTDA,TRANDA,DEFAULT) ; edit fms document number for clearing suspense
  1. N C,D,D0,D1,DA,DDH,DI,DIC,DICR,DIE,DIG,DIH,DIPGM,DISYS,DIU,DIV,DIW,DQ,DR,DZ,X
  1. S DR=".26;"
  1. I $G(DEFAULT)'="" S DR=".26////"_DEFAULT_";"
  1. S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
  1. S DA=TRANDA,DA(1)=RECTDA
  1. D ^DIE
  1. Q
  1. ;
  1. ;
  1. MOVETRAN(RCOLDREC,RCOLDTRA,RCNEWREC) ; move a transactions data
  1. N %DT,%T,D0,D1,DA,DG,DIC,DICR,DIK,DIU,RCNEWTRA,RESULT,X,Y
  1. ;
  1. ; add new transaction to 2nd receipt
  1. W !,"Adding a NEW payment transaction to receipt "_$P(^RCY(344,RCNEWREC,0),"^")_": "
  1. S RCNEWTRA=$$ADDTRAN(RCNEWREC)
  1. I 'RCNEWTRA Q "Unable to ADD a new payment transaction."
  1. ;
  1. W "# ",RCNEWTRA
  1. ;
  1. ; move data to selected receipt and re-index entry
  1. S ^RCY(344,RCNEWREC,1,RCNEWTRA,0)=RCNEWTRA_"^"_$P(^RCY(344,RCOLDREC,1,RCOLDTRA,0),"^",2,99)
  1. S DIK="^RCY(344,"_RCNEWREC_",1,",DA(1)=RCNEWREC,DA=RCNEWTRA
  1. D IX^DIK
  1. ;
  1. S RESULT=$$EDITTRAN(RCNEWREC,RCNEWTRA)
  1. Q RESULT
  1. ;
  1. ;
  1. CANCTRAN(RECTDA,RECTRAN) ; cancel a transaction
  1. N D,D0,DA,DI,DIC,DIE,DQ,DR,RCDATA,X,Y
  1. S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
  1. S RCDATA="Cancelled by: "_$P(^VA(200,DUZ,0),"^")_" Amount: $ "_$J($P(^RCY(344,RECTDA,1,RECTRAN,0),"^",4),0,2)
  1. S DR="1.01////^S X=RCDATA;.04////^S X=0;.05////^S X=0;1.02;"
  1. S DA=RECTRAN,DA(1)=RECTDA
  1. D ^DIE
  1. D LASTEDIT^RCDPUREC(RECTDA)
  1. Q
  1. ;
  1. ;
  1. DELETRAN(RECTDA,TRANDA) ; delete a transaction
  1. N %,D0,D1,DA,DIC,DICR,DIG,DIH,DIK,DIU,DIV,DIW,X,Y
  1. S DIK="^RCY(344,"_RECTDA_",1,",DA(1)=RECTDA,DA=TRANDA
  1. D ^DIK
  1. D LASTEDIT^RCDPUREC(RECTDA)
  1. Q
  1. ;
  1. ;
  1. SETUNAPP(RECTDA,TRANDA,UNAPPNUM) ; store the unapplied deposit number
  1. N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
  1. S (DIC,DIE)="^RCY(344,"_RECTDA_",1,"
  1. S DR=".25////"_UNAPPNUM_";"
  1. S DA=TRANDA,DA(1)=RECTDA
  1. D ^DIE
  1. Q
  1. ;
  1. ;
  1. PAYDEF(DEBTOR) ; get default for payment amount (used in input templates for payments)
  1. N X
  1. I 'DEBTOR Q 0
  1. I DEBTOR[";DPT(" S X=$$BAL^PRCAFN(DEBTOR)
  1. 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)
  1. Q +$G(X)
  1. ;
  1. ;
  1. PENDPAY(DEBTOR) ; return pending payments for a debtor
  1. ; returns ^tmp($j,"rcdpurec","pp",rectda,tranda)=data in 344.01
  1. ; and the total pending payment dollars
  1. N DATA,RECTDA,TOTAL,TRANDA
  1. K ^TMP($J,"RCDPUREC","PP")
  1. ; look at open receipts
  1. S RECTDA=0 F S RECTDA=$O(^RCY(344,"ASTAT",1,RECTDA)) Q:'RECTDA D
  1. . S TRANDA=0 F S TRANDA=$O(^RCY(344,"AACCT",DEBTOR,RECTDA,TRANDA)) Q:'TRANDA D
  1. . . S DATA=$G(^RCY(344,RECTDA,1,TRANDA,0)) I DATA="" Q
  1. . . ; total paid = total processed
  1. . . I +$P(DATA,"^",4)=+$P(DATA,"^",5) Q
  1. . . S ^TMP($J,"RCDPUREC","PP",RECTDA,TRANDA)=DATA
  1. . . S TOTAL=$G(TOTAL)+$P(DATA,"^",4)
  1. Q +$G(TOTAL)
  1. TRACE(DEBTOR) ;ENTER TOP TRACE NUMBER FOR TOP RECEIPTS
  1. N TRACE,DIC,DIE,DR,DA
  1. S TRACE="" G TRACEQ:'DEBTOR
  1. S DA=$S(DEBTOR["DPT(":$O(^RCD(340,"B",DEBTOR,0)),1:$P($G(^PRCA(430,+DEBTOR,0)),U,9))
  1. G TRACEQ:'DA
  1. S (DIC,DIE)="^RCD(340,",DR=6.07 D ^DIE
  1. S TRACE=$P($G(^RCD(340,DA,6)),"^",7)
  1. TRACEQ Q TRACE
  1. ;
  1. ;PRCA*4.5*304 - Force user to enter a comment if item is in suspense
  1. GETRSN() ;
  1. ;
  1. N X,Y,DTOUT,DUOUT,DIR,DIROUT,DIRUT,RCTODAY
  1. ;
  1. ; Get the Comment: Assume the end date is today.
  1. F D Q:Y'=""
  1. . S DIR("?")="ENTER THE REASON FOR PLACING THE RECEIPT ITEM INTO THE SUSPENSE FUND"
  1. . S DIR(0)="FA^1:60",DIR("A")="COMMENT: " D ^DIR K DIR
  1. . I $G(DTOUT)!$G(DUOUT) S Y="^" Q
  1. . S Y=$$TRIM^XLFSTR(Y)
  1. . I Y="" W !,"A comment is required when changing the status of an item in Suspense. Please",!,"try again." Q
  1. Q Y