RCTCS1 ;HAF/ASF-CROSS-SERVICING S/R ;03/17/19 3:34 PM
;;4.5;Accounts Receivable;**350**;Mar 26, 2019;Build 66
;;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ;entry
N %,BILLN,CBAL,CNT,CSTAT,DA,DIC,DIK,DNAME,G1,GOTBILL,HDR1,LASTDT,LASTIEN,LSUB,RCBILLDA,RCG,RCTCB,RCTCNO
N RCTCNO,RCTCNR,RET,SEPLINE,SSN,X,Y
K DIR
S DIR(0)="S^B:Stop/Reactivate TCSP Referral for a Bill;D:Stop/Reactivate TCSP Referral for a Debtor"
S DIR("B")="B" D ^DIR Q:$D(DIRUT)
I Y="B" D STOP^RCTCSPU Q ;--> out
D DSEL ;select debtor
I DEBTOR="" W !,"Debtor must be selected",! Q ;--> out
D SHOWB ;disply bills for debtor
D DEBSTAT(DEBTOR) ;get debtor status
Q:'$D(RCDSTAT) ;required info
D REUPS:$G(RCDSTAT("STOP FLAG"))="S"
D REUPR:$G(RCDSTAT("STOP FLAG"))="R"
D SETS:$G(RCDSTAT("STOP FLAG"))="R"!($G(RCDSTAT("STOP FLAG"))="")
D SETR:$G(RCDSTAT("STOP FLAG"))="S"
Q
DSEL ;Pick patient only
S DEBTOR=""
S DIC="^RCD(340,",DIC(0)="AEQZ"
S DIC("V")="I +Y(0)=2"
S DIC("S")="I $P(^(0),U,1)["";DPT("""
D ^DIC Q:Y<0
S DEBTOR=+Y
S SSN=$P(^DPT(+Y(0),0),U,9)
Q
SHOWB ;
S RET=0,HDR1=1
S RCTCB=0 F S RCTCB=$O(^PRCA(430,"C",DEBTOR,RCTCB)) Q:RCTCB'>0!RET D
. S RCBILLDA=RCTCB,GOTBILL=$P(^PRCA(430,RCTCB,0),U) ;bill
. S CSTAT=$$GET1^DIQ(430,RCTCB_",",8)
. I (CSTAT'="ACTIVE")&(CSTAT'="OPEN") Q ; only active and open
. I HDR1 D BILLHEAD S HDR1=0
. D DISPLAY ;W !,INFOLN,!?6,INFOLN1
. ;D STOP^RCTCSPU
. ;I $D(DUOUT) S RET=1
. Q
Q
;
DISPLAY ;Display Info for each BILL
S DNAME=$$GET1^DIQ(430,RCTCB_",",9) W !,DNAME
W ?32,SSN
S BILLN=$$GET1^DIQ(430,RCTCB_",",.01) W ?43,BILLN
W ?58,CSTAT
S CBAL=$$GET1^DIQ(430,RCTCB_",",11) W ?74,CBAL
;
Q
TMP ;
S SEPLINE="-",$P(SEPLINE,"-",80)=""
W !,"Bill",?13,"Debtor",?40,"Current Bal",!?8,"CURRENT STATUS",?30,"CATEGORY",!,SEPLINE
Q
BILLHEAD ;bill header
S SEPLINE="-",$P(SEPLINE,"-",80)="" W !,SEPLINE
W !,"Debtor Name",?32,"SSN",?43,"Bill #",?58,"AR Status",?74,"Amount"
W !,SEPLINE
Q
DEBSTAT(DEBTOR) ;Debtor TSP Status
K RCDSTAT
S LASTDT=$O(^RCD(340,DEBTOR,8,"C",99999999),-1)
I LASTDT>0 D ;has new style TCP
. S LASTIEN=$O(^RCD(340,DEBTOR,8,"C",LASTDT,0))
. S G1=^RCD(340,DEBTOR,8,LASTIEN,0)
. S RCDSTAT("STOP FLAG")=$P(G1,U,1)
. S RCDSTAT("DATE")=$P(G1,U,2)
. S RCDSTAT("USER")=$P(G1,U,3)
. S RCDSTAT("REASON")=$P(G1,U,4)
.S RCDSTAT("COMMENT")=$P(G1,U,5)
I LASTDT'>0 D ;check for old stop
. S RCDSTAT("STOP FLAG")=$$GET1^DIQ(340,DEBTOR_",",6.02)
. S RCDSTAT("DATE")=$$GET1^DIQ(340,DEBTOR_",",6.03)
. ; S RCDSTAT("USER")=$P(G1,U,3)
. S RCDSTAT("REASON")=$$GET1^DIQ(340,DEBTOR_",",6.04)
.S RCDSTAT("COMMENT")=$$GET1^DIQ(340,DEBTOR_",",6.05)
Q ;RCDSTAT
REUPS ;already set to stop
W !!,"Referral to Cross-Servicing has already been stopped for this debtor"
W !,"Stop Cross-Servicing referral effective date: " S Y=RCDSTAT("DATE") X ^DD("DD") W Y
W !,"Stop Cross-Servicing referral reason: "
S X=RCDSTAT("REASON") W $S(X="D":"DMC Eligible",X="H":"High risk veteran",X="B":"Bankruptcy",X="T":"Treasury Error",X="O":"Other",1:1)
I RCDSTAT("REASON")="O" W !,"Stop Cross-Servicing referral reason Other: ",RCDSTAT("COMMENT")
W !,"Cross-Servicing referral stopped by : ",$P(^VA(200,RCDSTAT("USER"),0),U)
Q
REUPR ;already re-active
W !!,"Referral to Cross-Servicing has already been reactivated for this debtor"
W !,"Reactivated Cross-Servicing referral effective date: " S Y=RCDSTAT("DATE") X ^DD("DD") W Y
W !,"Cross-Servicing referral reactivated by : ",$P(^VA(200,RCDSTAT("USER"),0),U)
Q
SETS ;set the stop
W !!,"Are You Sure You Want To Stop Cross-Servicing Referral for this Debtor?"
K DIR S DIR(0)="Y",DIR("B")="NO" D ^DIR
Q:'Y ;out if not Y or dirut
K DIR S DIR("A")="Enter Required Stop Reason"
S DIR(0)="S^D:DMC Eligible;H:High risk veteran;B:Bankruptcy;T:Treasury Error;O:Other"
D ^DIR Q:$D(DIRUT)
S RCTCNR=Y,RCTCNO=""
K DIR
I RCTCNR="O" S DIR(0)="F^3:100",DIR("A")="Enter 'Other' Reason" D ^DIR Q:$D(DIRUT)
S RCTCNO=Y
S LSUB=0,CNT=1 F S LSUB=$O(^RCD(340,DEBTOR,8,LSUB)) Q:LSUB'>0 S CNT=LSUB+1
D NOW^%DTC
S ^RCD(340,DEBTOR,8,CNT,0)="S"_U_%_U_DUZ_U_RCTCNR_U_RCTCNO
S ^RCD(340,DEBTOR,8,0)="^340.08SA"
S ^RCD(340,DEBTOR,8,"C",%,CNT)=""
W !!,"Stop Cross-Servicing Referral Complete"
W !!,"*** End of Stop Cross-Servicing Referral ***"
I $E(IOST,1,2)="C-",'$D(DIRUT) R !!,"Type <Enter> to continue or '^' to exit:",X:DTIME
Q
SETR ;reactivate
W !!,"Are You Sure You Want To Reactivate Cross-Servicing Referral for this Debtor?"
K DIR S DIR(0)="Y",DIR("B")="NO" D ^DIR
Q:'Y ;out if not Y or dirut
S LSUB=0,CNT=1 F S LSUB=$O(^RCD(340,DEBTOR,8,LSUB)) Q:LSUB'>0 S CNT=LSUB+1
D NOW^%DTC
S ^RCD(340,DEBTOR,8,CNT,0)="R"_U_%_U_DUZ_U
S ^RCD(340,DEBTOR,8,"C",%,CNT)=""
W !!,"Reactivate Cross-Servicing Referral complete"
W !,"All eligible bills for this Debtor are now to be Referred to Cross-Servicing"
W !!,"*** End of Reactivate Cross-Servicing Referral ***"
I $E(IOST,1,2)="C-",'$D(DIRUT) R !!,"Type <Enter> to continue or '^' to exit:",X:DTIME
Q
SITE(SITE) ;Status from file 342
N G,EFFEC,RCDT,N,N1,RCSTAT
S RCSTAT=0,RCDT=0
S N1=$O(^RC(342,0)) S N=0,RCDT=0 F S N=$O(^RC(342,N1,40,N)) Q:N'>0 D
. S G=^RC(342,N1,40,N,0),EFFEC=$P(G,U,2)
. I EFFEC>RCDT S RCDT=EFFEC,RCSTAT=$P(G,U)
Q RCSTAT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCS1 5362 printed Dec 13, 2024@01:48:40 Page 2
RCTCS1 ;HAF/ASF-CROSS-SERVICING S/R ;03/17/19 3:34 PM
+1 ;;4.5;Accounts Receivable;**350**;Mar 26, 2019;Build 66
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ;entry
+1 NEW %,BILLN,CBAL,CNT,CSTAT,DA,DIC,DIK,DNAME,G1,GOTBILL,HDR1,LASTDT,LASTIEN,LSUB,RCBILLDA,RCG,RCTCB,RCTCNO
+2 NEW RCTCNO,RCTCNR,RET,SEPLINE,SSN,X,Y
+3 KILL DIR
+4 SET DIR(0)="S^B:Stop/Reactivate TCSP Referral for a Bill;D:Stop/Reactivate TCSP Referral for a Debtor"
+5 SET DIR("B")="B"
DO ^DIR
if $DATA(DIRUT)
QUIT
+6 ;--> out
IF Y="B"
DO STOP^RCTCSPU
QUIT
+7 ;select debtor
DO DSEL
+8 ;--> out
IF DEBTOR=""
WRITE !,"Debtor must be selected",!
QUIT
+9 ;disply bills for debtor
DO SHOWB
+10 ;get debtor status
DO DEBSTAT(DEBTOR)
+11 ;required info
if '$DATA(RCDSTAT)
QUIT
+12 if $GET(RCDSTAT("STOP FLAG"))="S"
DO REUPS
+13 if $GET(RCDSTAT("STOP FLAG"))="R"
DO REUPR
+14 if $GET(RCDSTAT("STOP FLAG"))="R"!($GET(RCDSTAT("STOP FLAG"))="")
DO SETS
+15 if $GET(RCDSTAT("STOP FLAG"))="S"
DO SETR
+16 QUIT
DSEL ;Pick patient only
+1 SET DEBTOR=""
+2 SET DIC="^RCD(340,"
SET DIC(0)="AEQZ"
+3 SET DIC("V")="I +Y(0)=2"
+4 SET DIC("S")="I $P(^(0),U,1)["";DPT("""
+5 DO ^DIC
if Y<0
QUIT
+6 SET DEBTOR=+Y
+7 SET SSN=$PIECE(^DPT(+Y(0),0),U,9)
+8 QUIT
SHOWB ;
+1 SET RET=0
SET HDR1=1
+2 SET RCTCB=0
FOR
SET RCTCB=$ORDER(^PRCA(430,"C",DEBTOR,RCTCB))
if RCTCB'>0!RET
QUIT
Begin DoDot:1
+3 ;bill
SET RCBILLDA=RCTCB
SET GOTBILL=$PIECE(^PRCA(430,RCTCB,0),U)
+4 SET CSTAT=$$GET1^DIQ(430,RCTCB_",",8)
+5 ; only active and open
IF (CSTAT'="ACTIVE")&(CSTAT'="OPEN")
QUIT
+6 IF HDR1
DO BILLHEAD
SET HDR1=0
+7 ;W !,INFOLN,!?6,INFOLN1
DO DISPLAY
+8 ;D STOP^RCTCSPU
+9 ;I $D(DUOUT) S RET=1
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
DISPLAY ;Display Info for each BILL
+1 SET DNAME=$$GET1^DIQ(430,RCTCB_",",9)
WRITE !,DNAME
+2 WRITE ?32,SSN
+3 SET BILLN=$$GET1^DIQ(430,RCTCB_",",.01)
WRITE ?43,BILLN
+4 WRITE ?58,CSTAT
+5 SET CBAL=$$GET1^DIQ(430,RCTCB_",",11)
WRITE ?74,CBAL
+6 ;
+7 QUIT
TMP ;
+1 SET SEPLINE="-"
SET $PIECE(SEPLINE,"-",80)=""
+2 WRITE !,"Bill",?13,"Debtor",?40,"Current Bal",!?8,"CURRENT STATUS",?30,"CATEGORY",!,SEPLINE
+3 QUIT
BILLHEAD ;bill header
+1 SET SEPLINE="-"
SET $PIECE(SEPLINE,"-",80)=""
WRITE !,SEPLINE
+2 WRITE !,"Debtor Name",?32,"SSN",?43,"Bill #",?58,"AR Status",?74,"Amount"
+3 WRITE !,SEPLINE
+4 QUIT
DEBSTAT(DEBTOR) ;Debtor TSP Status
+1 KILL RCDSTAT
+2 SET LASTDT=$ORDER(^RCD(340,DEBTOR,8,"C",99999999),-1)
+3 ;has new style TCP
IF LASTDT>0
Begin DoDot:1
+4 SET LASTIEN=$ORDER(^RCD(340,DEBTOR,8,"C",LASTDT,0))
+5 SET G1=^RCD(340,DEBTOR,8,LASTIEN,0)
+6 SET RCDSTAT("STOP FLAG")=$PIECE(G1,U,1)
+7 SET RCDSTAT("DATE")=$PIECE(G1,U,2)
+8 SET RCDSTAT("USER")=$PIECE(G1,U,3)
+9 SET RCDSTAT("REASON")=$PIECE(G1,U,4)
+10 SET RCDSTAT("COMMENT")=$PIECE(G1,U,5)
End DoDot:1
+11 ;check for old stop
IF LASTDT'>0
Begin DoDot:1
+12 SET RCDSTAT("STOP FLAG")=$$GET1^DIQ(340,DEBTOR_",",6.02)
+13 SET RCDSTAT("DATE")=$$GET1^DIQ(340,DEBTOR_",",6.03)
+14 ; S RCDSTAT("USER")=$P(G1,U,3)
+15 SET RCDSTAT("REASON")=$$GET1^DIQ(340,DEBTOR_",",6.04)
+16 SET RCDSTAT("COMMENT")=$$GET1^DIQ(340,DEBTOR_",",6.05)
End DoDot:1
+17 ;RCDSTAT
QUIT
REUPS ;already set to stop
+1 WRITE !!,"Referral to Cross-Servicing has already been stopped for this debtor"
+2 WRITE !,"Stop Cross-Servicing referral effective date: "
SET Y=RCDSTAT("DATE")
XECUTE ^DD("DD")
WRITE Y
+3 WRITE !,"Stop Cross-Servicing referral reason: "
+4 SET X=RCDSTAT("REASON")
WRITE $SELECT(X="D":"DMC Eligible",X="H":"High risk veteran",X="B":"Bankruptcy",X="T":"Treasury Error",X="O":"Other",1:1)
+5 IF RCDSTAT("REASON")="O"
WRITE !,"Stop Cross-Servicing referral reason Other: ",RCDSTAT("COMMENT")
+6 WRITE !,"Cross-Servicing referral stopped by : ",$PIECE(^VA(200,RCDSTAT("USER"),0),U)
+7 QUIT
REUPR ;already re-active
+1 WRITE !!,"Referral to Cross-Servicing has already been reactivated for this debtor"
+2 WRITE !,"Reactivated Cross-Servicing referral effective date: "
SET Y=RCDSTAT("DATE")
XECUTE ^DD("DD")
WRITE Y
+3 WRITE !,"Cross-Servicing referral reactivated by : ",$PIECE(^VA(200,RCDSTAT("USER"),0),U)
+4 QUIT
SETS ;set the stop
+1 WRITE !!,"Are You Sure You Want To Stop Cross-Servicing Referral for this Debtor?"
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+3 ;out if not Y or dirut
if 'Y
QUIT
+4 KILL DIR
SET DIR("A")="Enter Required Stop Reason"
+5 SET DIR(0)="S^D:DMC Eligible;H:High risk veteran;B:Bankruptcy;T:Treasury Error;O:Other"
+6 DO ^DIR
if $DATA(DIRUT)
QUIT
+7 SET RCTCNR=Y
SET RCTCNO=""
+8 KILL DIR
+9 IF RCTCNR="O"
SET DIR(0)="F^3:100"
SET DIR("A")="Enter 'Other' Reason"
DO ^DIR
if $DATA(DIRUT)
QUIT
+10 SET RCTCNO=Y
+11 SET LSUB=0
SET CNT=1
FOR
SET LSUB=$ORDER(^RCD(340,DEBTOR,8,LSUB))
if LSUB'>0
QUIT
SET CNT=LSUB+1
+12 DO NOW^%DTC
+13 SET ^RCD(340,DEBTOR,8,CNT,0)="S"_U_%_U_DUZ_U_RCTCNR_U_RCTCNO
+14 SET ^RCD(340,DEBTOR,8,0)="^340.08SA"
+15 SET ^RCD(340,DEBTOR,8,"C",%,CNT)=""
+16 WRITE !!,"Stop Cross-Servicing Referral Complete"
+17 WRITE !!,"*** End of Stop Cross-Servicing Referral ***"
+18 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(DIRUT)
READ !!,"Type <Enter> to continue or '^' to exit:",X:DTIME
+19 QUIT
SETR ;reactivate
+1 WRITE !!,"Are You Sure You Want To Reactivate Cross-Servicing Referral for this Debtor?"
+2 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
+3 ;out if not Y or dirut
if 'Y
QUIT
+4 SET LSUB=0
SET CNT=1
FOR
SET LSUB=$ORDER(^RCD(340,DEBTOR,8,LSUB))
if LSUB'>0
QUIT
SET CNT=LSUB+1
+5 DO NOW^%DTC
+6 SET ^RCD(340,DEBTOR,8,CNT,0)="R"_U_%_U_DUZ_U
+7 SET ^RCD(340,DEBTOR,8,"C",%,CNT)=""
+8 WRITE !!,"Reactivate Cross-Servicing Referral complete"
+9 WRITE !,"All eligible bills for this Debtor are now to be Referred to Cross-Servicing"
+10 WRITE !!,"*** End of Reactivate Cross-Servicing Referral ***"
+11 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(DIRUT)
READ !!,"Type <Enter> to continue or '^' to exit:",X:DTIME
+12 QUIT
SITE(SITE) ;Status from file 342
+1 NEW G,EFFEC,RCDT,N,N1,RCSTAT
+2 SET RCSTAT=0
SET RCDT=0
+3 SET N1=$ORDER(^RC(342,0))
SET N=0
SET RCDT=0
FOR
SET N=$ORDER(^RC(342,N1,40,N))
if N'>0
QUIT
Begin DoDot:1
+4 SET G=^RC(342,N1,40,N,0)
SET EFFEC=$PIECE(G,U,2)
+5 IF EFFEC>RCDT
SET RCDT=EFFEC
SET RCSTAT=$PIECE(G,U)
End DoDot:1
+6 QUIT RCSTAT
+7 ;
