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

RCDPURED.m

Go to the documentation of this file. 
  1. RCDPURED ;WISC/RFJ - File 344 receipt/payment dd calls ;1 Jun 99
  1.  ;;4.5;Accounts Receivable;**114,169,174,196,202,244,268,271,304,301,312,319,321,375,371,409**;Mar 20, 1995;Build 17
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; Reference to $$REC^IBRFN supported by DBIA 2031
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1.  ;  ***** dd references from file 344 (receipts) *****
  1.  ;
  1.  ;
  1. DUPLCATE ;  called by input transform receipt number (.01)
  1.  ;  make sure no duplicate receipt numbers
  1.  I $O(^RCY(344,"B",X,"")) K X W !,"This is a duplicate receipt number." Q
  1.  I $O(^PRCA(433,"AF",X,"")) K X W !,"This receipt number has already been used and has been purged from the system. " K X Q
  1.  ;
  1.  ;PRCA*4.5*371 added next line to prevent spaces when creating a new receipt
  1.  I X[" " K X W !,"Blank Spaces are not allowed in receipt numbers." Q
  1.  Q
  1.  ;
  1.  ;
  1. PAYCOUNT(RCRECTDA) ;  called by computed field number of transactions (101)
  1.  ;  return the count of payments for the receipt
  1.  N COUNT,X
  1.  S COUNT=0
  1.  S X=0 F  S X=$O(^RCY(344,+$G(RCRECTDA),1,X)) Q:'X  S COUNT=COUNT+1
  1.  Q COUNT
  1.  ;
  1.  ;
  1. PAYTOTAL(RCRECTDA) ;  called by computed field total amount of receipts (.15)
  1.  ;  return the total dollars for payments entered for the receipt
  1.  N TOTAL,X,RCERAIEN,RCRECIPT,AMT,DEBIT ;PRCA319 - added RCERAIEN and RCRECIPT
  1.  S TOTAL=0
  1.  ;S X=0 F  S X=$O(^RCY(344,+$G(RCRECTDA),1,X)) Q:'X  S TOTAL=TOTAL+$P($G(^(X,0)),"^",4)
  1.  ;PRCA319 replaced line above with next section:
  1.  S RCERAIEN=$P($G(^RCY(344,+$G(RCRECTDA),0)),U,18)
  1.  I '$D(^RCY(344.4,+$G(RCERAIEN),1,"RECEIPT")) D  Q TOTAL ;not a multi receipt ERA 
  1.  .S X=0 F  S X=$O(^RCY(344,+$G(RCRECTDA),1,X)) Q:'X  D
  1.  .. ;PRCA*4.5*375 - Account for Credit/Debit flag when computing total amount on receipt
  1.  .. S AMT=$P($G(^RCY(344,+$G(RCRECTDA),1,X,0)),"^",4),DEBIT=$P($G(^RCY(344,+$G(RCRECTDA),1,X,0)),"^",29)
  1.  .. S:DEBIT="D" AMT=-AMT
  1.  .. S TOTAL=TOTAL+AMT
  1.  S RCRECIPT=0 F  S RCRECIPT=$O(^RCY(344.4,+$G(RCERAIEN),1,"RECEIPT",RCRECIPT)) Q:+RCRECIPT=0  D
  1.  . ;PRCA*4.5*375 - Account for Credit/Debit flag when computing total amount on receipt
  1.  . S X=0 F  S X=$O(^RCY(344,+$G(RCRECIPT),1,X)) Q:'X  D
  1.  .. S AMT=$P($G(^RCY(344,+$G(RCRECIPT),1,X,0)),"^",4),DEBIT=$P($G(^RCY(344,+$G(RCRECIPT),1,X,0)),"^",29)
  1.  .. S:DEBIT="D" AMT=-AMT
  1.  .. S TOTAL=TOTAL+AMT
  1.  ;PRCA319 end of added section
  1.  Q TOTAL
  1.  ;
  1.  ;
  1.  ;  ***** dd references from sub-file 344.01 (transactions) *****
  1.  ;
  1.  ;
  1. CHGAMT ;  called from the input transform on the transaction amount (.04)
  1.  ;  field.  if the amount is changed, this will create a new cancelled
  1.  ;  transaction showing the original amount before the change.
  1.  Q:$G(CSNOPROC)  ; prca*4.5*301 ; LEG
  1.  N ORIGDATA,TRANDA
  1.  S ORIGDATA=^RCY(344,DA(1),1,DA,0)
  1.  ;  no original payment amount
  1.  I '$P(ORIGDATA,"^",4) Q
  1.  ;  payment amount did not change
  1.  I +$P(ORIGDATA,"^",4)=+X Q
  1.  ;  payment amount increased
  1.  I $P(ORIGDATA,"^",4)<X Q
  1.  ;PRCA*4.5*304 - surpress new transaction if from Multiple split Link Payment.
  1.  ;  undeclared parameter RCSPRSS is defined (only defined in RCDPLPL4)
  1.  I $G(RCSPRSS) Q
  1.  ;  amount was changed
  1.  ;  enter a new transaction
  1.  S TRANDA=$$ADDTRAN^RCDPURET(DA(1))
  1.  I 'TRANDA W !,"  Unable to edit amount." K X Q
  1.  ;  copy the current data for the transaction
  1.  ;  do not use fileman, will overwrite variables
  1.  ;  set the cancel comment (field 1.01)
  1.  S $P(^RCY(344,DA(1),1,TRANDA,1),"^")="Amount $"_$P(ORIGDATA,"^",4)_" decreased in original trans#"_DA
  1.  ;  set the payment amount to zero (for cancelled)
  1.  S $P(ORIGDATA,"^",4)=0
  1.  S $P(ORIGDATA,"^",14)=DUZ
  1.  S $P(^RCY(344,DA(1),1,TRANDA,0),"^",2,99)=$P(ORIGDATA,"^",2,99)
  1.  Q
  1.  ;
  1.  ;
  1. PAYCHK ;  called from the input transform on the transaction amount (.04)
  1.  ;  field.  This will compare the amount paid with the amount owed
  1.  ;  for a bill.
  1.  Q:$G(CSNOPROC)  ; prca*4.5*301 ; LEG
  1.  N ACCOUNT,AMOUNT,OWED
  1.  S ACCOUNT=$P($G(^RCY(344,DA(1),1,DA,0)),"^",3)
  1.  ;  quit, account not a bill
  1.  I ACCOUNT'["PRCA(430," Q
  1.  ;  quit, account is a patient
  1.  I $P($G(^RCD(340,+$P($G(^PRCA(430,+ACCOUNT,0)),"^",9),0)),"^")[";DPT(" Q
  1.  ;  calculate amount owed for a bill
  1.  S OWED=$G(^PRCA(430,+ACCOUNT,7))
  1.  S OWED=$P(OWED,"^")+$P(OWED,"^",2)+$P(OWED,"^",3)+$P(OWED,"^",4)+$P(OWED,"^",5)
  1.  ;  compare amount paid (in x) with amount owed (if not processed 0;7)
  1.  I X>OWED,'$P($G(^RCY(344,DA(1),0)),"^",7) W "  WARNING: Payment amount greater than amount of bill!"
  1.  ;  check for other bills
  1.  S AMOUNT=$$EOB^IBCNSBL2(+ACCOUNT,+$P($G(^PRCA(430,+ACCOUNT,0)),"^",3),$$PAID^PRCAFN1(+ACCOUNT))
  1.  I AMOUNT W !!,$P(AMOUNT,"^",2)," may also be billable.",!
  1.  Q
  1.  ;
  1.  ;
  1. PNORBILL ;  called by the input transform in receipt file 344, transaction
  1.  ;  multiple (field 1), patient name or bill number (sub field .09)
  1.  S CSNOPROC=0 I $G(RCDCHKSW)=0,$G(HRCDCKSW) S RCDCHKSW=1 ; prca*4.5*301 ; LEG
  1.  I $L(X)>20!($L(X)<1) K X Q
  1.  ;
  1.  N DFN,RCBILL,RCINPUT,RCOUTPUT,Y,RCTYP,DIC,RCDISP,RCLKFLG,RCPAY,RCPMTTYP,RCMSG
  1.  ;
  1.  S RCINPUT=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ;  try and lookup on bill number
  1.  I $G(RCDCHKSW),$G(RCRECTDA),$G(RCTRANDA) S RCPMTTYP=$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",19)     ;prc*4.5*301
  1.  S X=$S($O(^PRCA(430,"B",RCINPUT,0)):$O(^(0))_";PRCA(430,",$O(^PRCA(430,"D",RCINPUT,0)):$O(^(0))_";PRCA(430,",1:RCINPUT)
  1.  I X[";PRCA(430," D DISPLAY(X)  ; PRCA*4.5*301; LEG
  1.  I '$G(RCDCHKSW),X[";PRCA(430," I $D(^PRCA(430,"TCSP",+X)) D  Q  ; PRCA*4.5*301
  1.  . W !," BILL HAS BEEN REFERRED TO CROSS-SERVICING.",!," NO MANUAL PAYMENTS ARE ALLOWED."
  1.  . S X="^",CSNOPROC=1
  1.  ;prca*4.5*301
  1.  I $G(RCDCHKSW),$G(RCPMTTYP),X[";PRCA(430," D  Q:CSNOPROC=1
  1.  . I RCPMTTYP=170,$D(^PRCA(430,"TCSP",+X)) Q
  1.  . I RCPMTTYP=170,'$D(^PRCA(430,"TCSP",+X)) S RCMSG=1 D ERRMSG Q
  1.  . I RCPMTTYP=168,$D(^PRCA(430,"TCSP",+X)) S RCMSG=3 D ERRMSG Q
  1.  . I RCPMTTYP=169,$D(^PRCA(430,"TCSP",+X)) S RCMSG=2 D ERRMSG Q
  1.  . I RCPMTTYP<168!(RCPMTTYP>170),$D(^PRCA(430,"TCSP",+X)) S RCMSG=4 D ERRMSG Q
  1.  ;  bill not found, try and lookup on patient
  1.  ;PRCA*4.5*304 - Echo info back to the user if not surpressed
  1.  I X=RCINPUT S DIC="^DPT(",DIC(0)=$S($G(RCSPRSS):"M",1:"EM") D ^DIC S X=+Y_";DPT("
  1.  ;  new value in variable X (output in X)
  1.  ;
  1.  ;PRCA*4.5*304 - allow EDI Lockbox payment type to look up bills by ECME and RX #'s
  1.  ;  patient not found, type of payment = check/mo or EDI LOCKBOX
  1.  S RCPAY=$P($G(^RCY(344,DA(1),0)),"^",4)
  1.  S RCLKFLG=$S(RCPAY=4:1,RCPAY=14:1,1:0)
  1.  I +$G(Y)<0 D                                   ; PRCA*4.5*409 Removed ,RCLKFLG from If statement
  1.  . S (X,Y)=$$REC^IBRFN(RCINPUT,.RCTYP,.RCDISP),(RCBILL,X)=X_";PRCA(430,"    ; DBIA 2031
  1.  . I Y>0 D
  1.  . . N DIR,DIQ2,DIRUT,DTOUT,DUOUT,RCPRM
  1.  . . S RCTYP=$G(RCTYP,1)
  1.  . . S RCPRM=$S(RCTYP=1:"TRICARE reference number",RCTYP=2:"ECME Rx reference number",RCTYP=3:"prescription number",1:"reference number")
  1.  . . S DIR("A")="Is this "_RCPRM_" - "_$S($G(RCDISP)'="":RCDISP,1:RCINPUT)
  1.  . . S DIR("B")="No",DIR("A",1)=" "
  1.  . . S DIR(0)="Y^O" D ^DIR S:'Y Y=-1
  1.  . . I Y'>0 Q
  1.  . . I '$G(RCSPRSS) W !!,$P($G(^PRCA(430,+RCBILL,0)),"^")," "  ;PRCA*4.5*304
  1.  . . D DISPLAY(RCBILL)
  1.  . . S X=RCBILL
  1.  ;  output in variable X
  1.  ;
  1.  I +$G(Y)<0 K X Q
  1.  ;
  1.  S RCOUTPUT=X
  1.  ;
  1.  ;  patient account, show messages and quit (output still in variable X)
  1.  I RCOUTPUT[";DPT(" D CHECKPAT(+RCOUTPUT) Q
  1.  ;
  1.  ;  bill account
  1.  I $$IB^IBRUTL(+RCOUTPUT) W " ... This bill appears to have other patient bills on 'hold'."
  1.  S X=$P($G(^RCD(340,+$P(^PRCA(430,+RCOUTPUT,0),"^",9),0)),"^")
  1.  I X[";DPT(" D CHECKPAT(+X)
  1.  S X=RCOUTPUT
  1.  Q
  1.  ;
  1.  ;
  1. CHECKPAT(DFN) ; check patient for other charges, etc., show message
  1.  N RCLIST,RCNODE,RCTYPE,RCPSO,RCX,RCREF,RCTOTAL,RCCOUNT
  1.  N X,Y,DI  ; need to protect FM within FM
  1.  S (RCTOTAL,RCCOUNT)=0
  1.  S X="IBARXEU" X ^%ZOSF("TEST")
  1.  I $T S X=$$RXST^IBARXEU(DFN,DT) I X D
  1.  . W !?2,"* Patient is exempt from RX Copay: ",$P(X,"^",4)," *"
  1.  S RCLIST="RCPSO52",RCNODE="0,2,R,I"
  1.  K ^TMP($J,RCLIST,DFN)
  1.  D RX^PSO52API(DFN,RCLIST,,,RCNODE,$$FMADD^XLFDT(DT,-1))
  1.  I $G(^TMP($J,RCLIST,DFN,0))<1 G CHECKQ
  1.  S RCPSO=0 F  S RCPSO=$O(^TMP($J,RCLIST,DFN,RCPSO)) Q:'RCPSO  D
  1.  . ; protect aginst tier 0 drugs
  1.  . I $G(^TMP($J,RCLIST,DFN,RCPSO,6)),$P($$CPTIER^PSNAPIS("",DT,+^(6)),"^")=0 Q
  1.  . ; original fills
  1.  . S RCTYPE=+$G(^TMP($J,RCLIST,DFN,RCPSO,105)) Q:'RCTYPE
  1.  . I +$G(^TMP($J,RCLIST,DFN,RCPSO,22))=DT,$P($G(^(11)),"^")="W",'$G(^(31)) D  Q
  1.  .. S RCX=$G(^TMP($J,RCLIST,DFN,RCPSO,8))
  1.  .. S RCX=RCX/30\1+$S(RCX#30:1,1:0)
  1.  .. S RCCOUNT=RCCOUNT+RCX
  1.  .. S RCTOTAL=RCTOTAL+($$ARCOST^IBAUTL(DFN,RCTYPE,RCPSO)*RCX)
  1.  . ; refills
  1.  . S RCREF=0 F  S RCREF=$O(^TMP($J,RCLIST,DFN,RCPSO,"RF",RCREF)) Q:'RCREF  I $P($G(^TMP($J,RCLIST,DFN,RCPSO,"RF",RCREF,.01)),"^")=DT,$P($G(^(2)),"^")="W",'$G(^(17)) D
  1.  .. S RCX=$G(^TMP($J,RCLIST,DFN,RCPSO,"RF",RCREF,1.1))
  1.  .. S RCX=RCX/30\1+$S(RCX#30:1,1:0)
  1.  .. S RCCOUNT=RCCOUNT+RCX
  1.  .. S RCTOTAL=RCTOTAL+($$ARCOST^IBAUTL(DFN,RCTYPE,RCPSO)*RCX)
  1.  I RCTOTAL D
  1.  . W !?2,"* This patient has ",RCCOUNT,"-30 day RX's totaling $",$FN(RCTOTAL,",",2)," that are potentially *"
  1.  . W !?2,"* billable. This represents any Window Rx's issued today. *"
  1.  ;
  1. CHECKQ ;
  1.  K ^TMP($J,RCLIST,DFN)
  1.  Q
  1.  ;
  1.  ;
  1. DISPLAY(RCBILLDA) ;  display bill
  1.  N DATA
  1.  S DATA=$P(^PRCA(430,+RCBILLDA,0),"^",9) W:DATA "  ",$$NAM^RCFN01(DATA)
  1.  S DATA=$P(^PRCA(430,+RCBILLDA,0),"^",8) I DATA D
  1.  .   W "   ",$P(^PRCA(430.3,DATA,0),"^")
  1.  .   I $P(^PRCA(430.3,DATA,0),"^",3)'=102,$P($G(^RCD(340,+$P(^PRCA(430,+RCBILLDA,0),"^",9),0)),"^")'[";DPT(" W !,"This bill is not in 'active' status."
  1.  S DATA=$G(^PRCA(430,+RCBILLDA,7)) W "   $",$J($P(DATA,"^")+$P(DATA,"^",2)+$P(DATA,"^",3)+$P(DATA,"^",4)+$P(DATA,"^",5),1,2)
  1.  Q
  1.  ;
  1. PAYDATE ;  called by the input transform in receipt file 344, transaction
  1.  ;  multiple (field 1), date of payment (sub field .06)
  1.  ;  date of payment not in future or more than one month ago
  1.  N DAYSDIFF
  1.  S DAYSDIFF=$$FMDIFF^XLFDT(X,DT)
  1.  I DAYSDIFF<-31!(DAYSDIFF>0) K X
  1.  Q
  1.  ;
  1.  ;
  1.  ;  ***** dd references from file 344.1 (deposits) *****
  1.  ;
  1.  ;
  1. RECTOTAL(RCDEPTDA) ;  called from computed field TOTAL AMT OF RECEIPTS (.18) in
  1.  ;  deposit file (344.1)
  1.  ;  this returns the total dollars paid for all receipts on deposit ticket
  1.  N RCRECTDA,TOTAL
  1.  S TOTAL=0
  1.  S RCRECTDA=0 F  S RCRECTDA=$O(^RCY(344,"AD",+RCDEPTDA,RCRECTDA)) Q:'RCRECTDA  D
  1.  .   S TOTAL=TOTAL+$$PAYTOTAL(RCRECTDA)
  1.  Q TOTAL
  1.  ;
  1.  ;
  1. RECCOUNT(RCDEPTDA) ;  called from computed field TOTAL RECEIPTS (100) in deposit file (344.1)
  1.  ;  this returns a count of the number of receipts on a deposit ticket
  1.  N RCRECTDA,COUNT
  1.  S COUNT=0
  1.  S RCRECTDA=0 F  S RCRECTDA=$O(^RCY(344,"AD",+RCDEPTDA,RCRECTDA)) Q:'RCRECTDA  D
  1.  .   S COUNT=COUNT+1
  1.  Q COUNT
  1. HLP09 ; PRCA*4.5*321 - Add executable help for file 4.01 field .09
  1.  W ?5,"To enter a TRICARE Authorization No, enter 'T.' followed by the number."
  1.  W !,?5,"To enter an ECME Rx Reference Number, enter 'E.' followed by the number."
  1.  W !,?5,"To enter an Prescription Number, enter 'R.' followed by the number."
  1.  Q
  1. ERRMSG ;prnt error message and set exit variables      ;prca*4.5*301
  1.  W !!,$P($T(LINKMSG+RCMSG),";",2),! S CSNOPROC=1,RCDCHKSW=0,HRCDCKSW=1 S X=0
  1.  Q
  1. LINKMSG ;Linking error messages      ;prca*4.5*301   
  1.  ;** Linking Treasury payment (170) to a non Cross-Servicing bill not allowed
  1.  ;** Linking a TOP payment (169) to a Cross-Servicing bill is not allowed
  1.  ;** Linking a DMC payment (168) to a Cross-Servicing bill is not allowed
  1.  ;** Linking a MISC payment to a Cross-Servicing bill is not allowed