- 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 Feb 18, 2025@23:16:21 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
