RCYDD1 ;WASH-ISC@ALTOONA,PA/RGY-DD CALL UTILITIES ;8/27/96 5:35 PM
V ;;4.5;Accounts Receivable;**9,48,128**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
PN ;Called by the input transform in field 344.01,.09
N RCY,RCY1,RCY2,Y
I $L(X)>20!($L(X)<1) K X Q
S RCY=X,X=$S($O(^PRCA(430,"B",X,0)):$O(^(0))_";PRCA(430,",$O(^PRCA(430,"D",X,0)):$O(^(0))_";PRCA(430,",1:X) I X[";PRCA(430," D DIS
I X=RCY S DIC="^DPT(",DIC(0)="EM" D ^DIC S X=+Y_";DPT("
I +$G(Y)<0,(RCYTYP=4) D
.S (X,Y)=$$REC^IBRFN(RCY),X=X_";PRCA(430,"
.I Y>0 D
..N DIR,DIRUT
..S DIR("A")="Is this TRICARE reference number - "_RCY,DIR("B")="No",DIR("A",1)=" "
..S RCY=X
..S DIR(0)="Y^O" D ^DIR S:'Y Y=-1
..I Y>0 S X=RCY W !!,$P($G(^PRCA(430,+X,0)),"^")," " D DIS
I +$G(Y)<0 K X Q
S RCY=X I RCY[";DPT(" D CHK(+RCY) G Q2
I $$IB^IBRUTL(+RCY) W *7," ... This bill appears to have other patient bills on 'hold'."
S X=$P($G(^RCD(340,+$P(^PRCA(430,+RCY,0),"^",9),0)),"^") I X[";DPT(" D CHK(+X)
Q2 S X=RCY Q
DIS ;DISPLAY BILL INFO
NEW RCY
S RCY=$P(^PRCA(430,+X,0),"^",9) W:RCY " ",$$NAM^RCFN01(RCY)
S RCY=$P(^PRCA(430,+X,0),"^",8) I RCY W " ",$P(^PRCA(430.3,RCY,0),"^") I $P(^(0),"^",3)'=102,$P($G(^RCD(340,+$P(^PRCA(430,+X,0),"^",9),0)),"^")'[";DPT(" W *7,!,"This bill is not in 'active' status."
S RCY=$G(^PRCA(430,+X,7)) W " $",$J($P(RCY,"^")+$P(RCY,"^",2)+$P(RCY,"^",3)+$P(RCY,"^",4)+$P(RCY,"^",5),1,2)
Q
PAY ;Called by the input transform of field 344.01,.04
NEW Y,I,AMT,PROC
S Y=$P($G(^RCY(344,DA(1),1,DA,0)),"^",3),AMT=0
S PROC=$P($G(^RCY(344,DA(1),0)),"^",11)
G:Y'[";PRCA(430," Q1
G:$P($G(^RCD(340,+$P($G(^PRCA(430,+Y,0)),"^",9),0)),"^")[";DPT(" Q1
S Y(1)=Y,Y=$G(^PRCA(430,+Y,7)) F I=1:1:5 S AMT=AMT+$P(Y,"^",I)
I X>AMT W *7," Payment amount greater than amount of bill!",*7
S AMT(1)=$$EOB^IBCNSBL2(+Y(1),+$P($G(^PRCA(430,+Y(1),0)),"^",3),$$PAID^PRCAFN1(+Y(1)))
I AMT(1) D
.W !!,$P(AMT(1),"^",2)," may also be billable.",*7,!
Q1 Q
DEF(DEB) ;Get default for payment amount (used in input templates for payments)
NEW X
S X=0 G:'$G(DEB) Q3
I DEB[";DPT(" S X=$$BAL^PRCAFN(DEB) G Q3
I DEB[";PRCA(430,",",112,107,102,"[(","_$P($G(^PRCA(430.3,+$P($G(^PRCA(430,+DEB,0)),"^",8),0)),"^",3)_",") S X=$G(^PRCA(430,+DEB,7)),X=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5) G Q3
Q3 Q "<"_$J(X,1,2)_">"
DOP ;Make sure date of payment not in future or more than one month ago
NEW DATE
S DATE=X,X2=DT,X1=X D ^%DTC
I X<-31!(X>0) K X G Q4
S X=DATE
Q4 Q
CHK(DFN) ;Check copay exemption status and RX potential charges
S X="IBARXEU" X ^%ZOSF("TEST") I $T S X=$$RXST^IBARXEU(DFN,DT) I X W *7,!?2,"* Patient is exempt from RX Copay: ",$P(X,"^",4)," *"
S X="PSOCOPAY" X ^%ZOSF("TEST") I $T S X=$$POT^PSOCOPAY(DFN) I X W *7,!?2,"* This patient has ",X,"-30 day RX's totaling $",(X*2),".00 that are potentially *"
I W !,"* billable. This represents any Window Rx's issued today. *"
Q
REC ;Called by the 344,.01 input transform. Make sure duplicate receipts cannot be created.
I $O(^RCY(344,"B",X,""))!$O(^PRCA(433,"AF",X,"")) K X W !,"Receipt already in use, please use another receipt number!" K X
Q
STAT(RCYC) ;Called by the 344,100 field to return status of receipt
NEW X,Y
D NOW^%DTC
S Y=$G(^RCY(344,RCYC,0)) S X="N/A" S:$P(Y,"^",2)]"" X="OPEN" S:$P(Y,"^",7)]"" X="APPROVED" S:$P(Y,"^",9)]"" X="POSTING"
I $P(Y,"^",10)]"" S X="POSTED" S:'$O(^RCY(344,RCYC,1,0)) X="VOIDED"
S:$P(Y,"^",5)>% X="QUEUED"
I $P(Y,"^",9)]"",$P(Y,"^",10)="" L +^RCY(344,RCYC,0):1 I $T L -^RCY(344,RCYC,0) S X="ERRORED"
Q X
NOT(REC) ;Called to calculate the number of transaction for a receipt (344,101)
NEW Y,TOT
S TOT=0
F Y=0:0 S Y=$O(^RCY(344,+$G(REC),1,Y)) Q:'Y S TOT=TOT+1
Q TOT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCYDD1 3775 printed Apr 09, 2024@20:55:06 Page 2
RCYDD1 ;WASH-ISC@ALTOONA,PA/RGY-DD CALL UTILITIES ;8/27/96 5:35 PM
V ;;4.5;Accounts Receivable;**9,48,128**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
PN ;Called by the input transform in field 344.01,.09
+1 NEW RCY,RCY1,RCY2,Y
+2 IF $LENGTH(X)>20!($LENGTH(X)<1)
KILL X
QUIT
+3 SET RCY=X
SET X=$SELECT($ORDER(^PRCA(430,"B",X,0)):$ORDER(^(0))_";PRCA(430,",$ORDER(^PRCA(430,"D",X,0)):$ORDER(^(0))_";PRCA(430,",1:X)
IF X[";PRCA(430,"
DO DIS
+4 IF X=RCY
SET DIC="^DPT("
SET DIC(0)="EM"
DO ^DIC
SET X=+Y_";DPT("
+5 IF +$GET(Y)<0
IF (RCYTYP=4)
Begin DoDot:1
+6 SET (X,Y)=$$REC^IBRFN(RCY)
SET X=X_";PRCA(430,"
+7 IF Y>0
Begin DoDot:2
+8 NEW DIR,DIRUT
+9 SET DIR("A")="Is this TRICARE reference number - "_RCY
SET DIR("B")="No"
SET DIR("A",1)=" "
+10 SET RCY=X
+11 SET DIR(0)="Y^O"
DO ^DIR
if 'Y
SET Y=-1
+12 IF Y>0
SET X=RCY
WRITE !!,$PIECE($GET(^PRCA(430,+X,0)),"^")," "
DO DIS
End DoDot:2
End DoDot:1
+13 IF +$GET(Y)<0
KILL X
QUIT
+14 SET RCY=X
IF RCY[";DPT("
DO CHK(+RCY)
GOTO Q2
+15 IF $$IB^IBRUTL(+RCY)
WRITE *7," ... This bill appears to have other patient bills on 'hold'."
+16 SET X=$PIECE($GET(^RCD(340,+$PIECE(^PRCA(430,+RCY,0),"^",9),0)),"^")
IF X[";DPT("
DO CHK(+X)
Q2 SET X=RCY
QUIT
DIS ;DISPLAY BILL INFO
+1 NEW RCY
+2 SET RCY=$PIECE(^PRCA(430,+X,0),"^",9)
if RCY
WRITE " ",$$NAM^RCFN01(RCY)
+3 SET RCY=$PIECE(^PRCA(430,+X,0),"^",8)
IF RCY
WRITE " ",$PIECE(^PRCA(430.3,RCY,0),"^")
IF $PIECE(^(0),"^",3)'=102
IF $PIECE($GET(^RCD(340,+$PIECE(^PRCA(430,+X,0),"^",9),0)),"^")'[";DPT("
WRITE *7,!,"This bill is not in 'active' status."
+4 SET RCY=$GET(^PRCA(430,+X,7))
WRITE " $",$JUSTIFY($PIECE(RCY,"^")+$PIECE(RCY,"^",2)+$PIECE(RCY,"^",3)+$PIECE(RCY,"^",4)+$PIECE(RCY,"^",5),1,2)
+5 QUIT
PAY ;Called by the input transform of field 344.01,.04
+1 NEW Y,I,AMT,PROC
+2 SET Y=$PIECE($GET(^RCY(344,DA(1),1,DA,0)),"^",3)
SET AMT=0
+3 SET PROC=$PIECE($GET(^RCY(344,DA(1),0)),"^",11)
+4 if Y'[";PRCA(430,"
GOTO Q1
+5 if $PIECE($GET(^RCD(340,+$PIECE($GET(^PRCA(430,+Y,0)),"^",9),0)),"^")[";DPT("
GOTO Q1
+6 SET Y(1)=Y
SET Y=$GET(^PRCA(430,+Y,7))
FOR I=1:1:5
SET AMT=AMT+$PIECE(Y,"^",I)
+7 IF X>AMT
WRITE *7," Payment amount greater than amount of bill!",*7
+8 SET AMT(1)=$$EOB^IBCNSBL2(+Y(1),+$PIECE($GET(^PRCA(430,+Y(1),0)),"^",3),$$PAID^PRCAFN1(+Y(1)))
+9 IF AMT(1)
Begin DoDot:1
+10 WRITE !!,$PIECE(AMT(1),"^",2)," may also be billable.",*7,!
End DoDot:1
Q1 QUIT
DEF(DEB) ;Get default for payment amount (used in input templates for payments)
+1 NEW X
+2 SET X=0
if '$GET(DEB)
GOTO Q3
+3 IF DEB[";DPT("
SET X=$$BAL^PRCAFN(DEB)
GOTO Q3
+4 IF DEB[";PRCA(430,"
IF ",112,107,102,"[(","_$PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(430,+DEB,0)),"^",8),0)),"^",3)_",")
SET X=$GET(^PRCA(430,+DEB,7))
SET X=$PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5)
GOTO Q3
Q3 QUIT "<"_$JUSTIFY(X,1,2)_">"
DOP ;Make sure date of payment not in future or more than one month ago
+1 NEW DATE
+2 SET DATE=X
SET X2=DT
SET X1=X
DO ^%DTC
+3 IF X<-31!(X>0)
KILL X
GOTO Q4
+4 SET X=DATE
Q4 QUIT
CHK(DFN) ;Check copay exemption status and RX potential charges
+1 SET X="IBARXEU"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=$$RXST^IBARXEU(DFN,DT)
IF X
WRITE *7,!?2,"* Patient is exempt from RX Copay: ",$PIECE(X,"^",4)," *"
+2 SET X="PSOCOPAY"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET X=$$POT^PSOCOPAY(DFN)
IF X
WRITE *7,!?2,"* This patient has ",X,"-30 day RX's totaling $",(X*2),".00 that are potentially *"
+3 IF $TEST
WRITE !,"* billable. This represents any Window Rx's issued today. *"
+4 QUIT
REC ;Called by the 344,.01 input transform. Make sure duplicate receipts cannot be created.
+1 IF $ORDER(^RCY(344,"B",X,""))!$ORDER(^PRCA(433,"AF",X,""))
KILL X
WRITE !,"Receipt already in use, please use another receipt number!"
KILL X
+2 QUIT
STAT(RCYC) ;Called by the 344,100 field to return status of receipt
+1 NEW X,Y
+2 DO NOW^%DTC
+3 SET Y=$GET(^RCY(344,RCYC,0))
SET X="N/A"
if $PIECE(Y,"^",2)]""
SET X="OPEN"
if $PIECE(Y,"^",7)]""
SET X="APPROVED"
if $PIECE(Y,"^",9)]""
SET X="POSTING"
+4 IF $PIECE(Y,"^",10)]""
SET X="POSTED"
if '$ORDER(^RCY(344,RCYC,1,0))
SET X="VOIDED"
+5 if $PIECE(Y,"^",5)>%
SET X="QUEUED"
+6 IF $PIECE(Y,"^",9)]""
IF $PIECE(Y,"^",10)=""
LOCK +^RCY(344,RCYC,0):1
IF $TEST
LOCK -^RCY(344,RCYC,0)
SET X="ERRORED"
+7 QUIT X
NOT(REC) ;Called to calculate the number of transaction for a receipt (344,101)
+1 NEW Y,TOT
+2 SET TOT=0
+3 FOR Y=0:0
SET Y=$ORDER(^RCY(344,+$GET(REC),1,Y))
if 'Y
QUIT
SET TOT=TOT+1
+4 QUIT TOT
