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