RCTOPU ;WASH IRMFO@ALTOONA,PA/TJK - TOP TRANSMISSION ;2/22/00 12:39 PM
V ;;4.5;Accounts Receivable;**141,400**;Mar 20, 1995;Build 13
;;Per VHA Directive 10-93-142, this routine should not be modified
;
REPORT ;print top report
N DIC,DIS,L,BY,FR,TO,FLDS,PG,PRINTOT,DIOEND
W !!,"TOP REFERRAL REPORT",!!
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Include Debtors At TOP With '0' Balance"
S DIR("?")="Answering Yes will include those debtors referred whose current TOP balance is '0'."
D ^DIR Q:(Y="")!(Y="^")
S L=0,(FR,TO)="",DIC=340,BY=.01,FLDS="[RCTOP REPORT]",PRINTOT=0
S DIS(0)="I $P($G(^RCD(340,D0,6)),U)"
S:'Y DIS(0)=DIS(0)_",$P(^(4),U,3)"
S DIOEND="D PRNTOT^RCTOPU"
PRINT D EN1^DIP
REPORTQ Q
;
PRNTOT ;place total amount on report
N DASH
S DASH="",$P(DASH,"-",81)=""
W !!,DASH
W !,?6,"TOTAL AMOUNT CURRENTLY REFERRED:",?50,"$"_$J(PRINTOT,15,2)
I $E(IOST,1,2)="C-" R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
PRNTOTQ Q
;
BILLREP ;prints individual bills and amounts that make up a TOP account
N DIC,DEBTOR,ZTSAVE,ZTDESC,ZTRTN
S DIC=340,DIC(0)="AEQM",DIC("S")="I $D(^RCD(340,""TOP"",+Y))" D ^DIC
Q:Y<1 S DEBTOR=+Y
S %ZIS="AEQ" D ^%ZIS G:POP BILLREPQ
I $D(IO("Q")) D G BILLREPQ
.S ZTSAVE("DEBTOR")=""
.S ZTRTN="BILLREPP^RCTOPU",ZTDESC="TOP BILL REPORT"
.D ^%ZTLOAD,^%ZISC
.Q
;
BILLREPP ;Call to build array of bills referred
U IO
N BILL,B14,B7,D4,FND,BAMT,TAMT,DIRUT,TNM,TID,TDT,DASH,CSTAT
S DASH="",$P(DASH,"-",81)="",D4=$G(^RCD(340,DEBTOR,4))
S TID=$S($P(D4,U,4)'="":$P(D4,U,4),1:$P(D4,U,1))
S TNM=$S($P(D4,U,5)'="":$P(D4,U,5),1:$P(D4,U,2))
S Y=$P(^RCD(340,DEBTOR,6),U,1) X ^DD("DD") S TDT=Y
S TAMT=$P(D4,U,3) D BILLREPH
S (FND,BILL)=0 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:('BILL)!($D(DIRUT)) D
.Q:'+$G(^PRCA(430,BILL,14))
.S FND=1 W !,$P(^PRCA(430,BILL,0),U) S CSTAT=$P(^(0),U,8),B7=$G(^(7))
.W ?14,$P(^PRCA(430.3,CSTAT,0),U,2)
.S BAMT=0 F I=1:1:5 S BAMT=BAMT+$P(B7,U,I)
.W ?20,$J(BAMT,10,2)
.F I=1:1:5 W $J($P(B7,U,I),10,2)
.;check for end of page here, if necessary form feed and print header
.I $Y+3>IOSL D
..I $E(IOST,1,2)="C-" S DIR(0)="E" K DIRUT D ^DIR Q:$D(DIRUT)
..D BILLREPH
.Q
I $E(IOST,1,2)="C-" R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
D ^%ZISC
BILLREPQ Q
;
BILLREPH ;header for TOP bill report
W @IOF
W !,"DEBTOR: "_TNM
W !,"TIN: "_TID," REFERRED TO TOP: "_TDT_" CURRENT TOP AMT: "_$J(TAMT,13,2)
W !,DASH
W !!,"BILL NO.",?14,"STAT",?27,"AMT",?36,"PRIN",?47,"INT",?55,"ADMIN",?65,"COURT",?72,"MARSHALL"
W !,"---- ---",?14,"----",?27,"---",?36,"----",?47,"---",?55,"-----",?65,"-----",?72,"--------"
Q
;
STOP ;Stop TOP Referral on a Debtor
N DIC,DIE,DA,DIR,Y,DEBTOR,REASON,COMMENT,EFFDT
S DIC=340,DIC(0)="AEQM" D ^DIC Q:Y<0
S DEBTOR=+Y
I $P($G(^RCD(340,DEBTOR,6)),U,2) G DELSTOP
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are You Sure You Want To Stop TOP Referral For This Debtor" D ^DIR
I 'Y W !,*7,"No Action Taken" Q
;
REASON ;ask referral reason
K DIR S DIR(0)="340,6.04" D ^DIR
Q:(Y="")!(Y=U)
S REASON=Y I REASON="O" D Q:COMMENT=U G REASON:COMMENT=""
.S COMMENT="",DIR(0)="340,6.05" D ^DIR S COMMENT=Y
.I COMMENT="" W !,"A Reason Of Other requires a comment to be entered"
.Q
I REASON'="O",$P($G(^RCD(340,DEBTOR,6)),U,5)'="" S $P(^(6),U,5)=""
;
I (REASON="N")!(REASON="R") D G STOPFILE
.S $P(^RCD(340,DEBTOR,6),U)=""
.K ^RCD(340,"TOP",DEBTOR)
.S (EFFDT,REASON,COMMENT)=""
.Q
;
;ask effective date (for 'waiver','banruptcy','other')
;
S DIR(0)="340,6.03",DIR("A")="Enter Effective Date" D ^DIR S EFFDT=Y
;
STOPFILE ;set stop referral data in file 340
S $P(^RCD(340,DEBTOR,6),U,2,5)="1^"_EFFDT_U_REASON_U_$G(COMMENT)
;
W !,"Stop TOP Referral Complete"
G STOPQ
;
DELSTOP ;Allows TOP Referral to be re-instituted for debtor
W !!,*7,"Referral to TOP has already been stopped for this debtor"
S DIR(0)="Y",DIR("A")="Do You Wish To Re-Institute TOP Referral for this Debtor",DIR("B")="NO" D ^DIR G EDSTOP:'Y
;
;reset file to allow top referral to be re-started
F I=2:1:5 S $P(^RCD(340,DEBTOR,6),U,I)=""
W !!,"Debtor Is Now Eligible To Be Referred To TOP" G STOPQ
;
EDSTOP S DIR(0)="Y",DIR("A")="Do You Wish To Edit The Stop Referral Data For This Debtor",DIR("B")="NO" D ^DIR G REASON:Y
STOPQ Q
;
REVERSE ;Refund Reversal
N DEBTOR,DIC,DIE,DR,BILL,TRACE,REFYR
W !!,"Refund Reversal Of TOP Refund"
S DIC=430,DIC(0)="AEQLMZ",DIC("S")="I $D(^PRCA(430,""TREF"",2,+Y))"
S DIC("A")="Enter Refund Bill To Be Reversed:" D ^DIC Q:Y<0
S DEBTOR=$P(Y(0),U,9),BILL=+Y
I 'DEBTOR W !!,*7,"No Debtor Attached To This Bill." Q
S TRACE=$P($G(^RCD(340,DEBTOR,6)),U,7),REFYR=$P($G(^PRCA(430,BILL,14)),U,4)
I 'TRACE W !!,*7,"There is no current TOP Trace Number for this debtor",!,"This should have been entered with the most recent TOP payment" Q
I 'REFYR W !!,*7,"There is no TOP Refund Year Entered for this bill",!,"This should have been entered when the refund was approved." Q
S DIR(0)="Y",DIR("A")="Are You Sure You Wish To Reverse This Refund"
S DIR("B")="NO" D ^DIR I 'Y W !!,"No Action Taken" Q
S DIE="^PRCA(430,",DA=BILL,DR="142///3;143///^S X=TRACE" D ^DIE
W !,"Reversal Will Be Transmitted With Next TOP Transmission"
REVERSEQ Q
;
UPDCODE ;Update Refund/Reversal Codes in File 348.2
W !,"TOP Refund/Refund Reversal Code Entry"
S DIC=348.2,DIC(0)="AEQML" D ^DIC
UPDCODEQ Q
;
STOPREF(DEBTOR,REASON,CMNT,EFDT) ; stop TOP referral for a given debtor (no user interaction) PRCA*4.5*400
;
; DEBTOR - file 340 ien
; REASON - stop referral reason, field 340/6.04 (internal)
; CMNT - stop referral comment, field 340/6.05
; EFDT - effective date, field 340/6.03 (internal)
;
; returns 1 on success, 0^[error message] otherwise
;
N DIERR,FDA,IENS,N6
I '$D(^RCD(340,DEBTOR,0)) Q "0^Invalid file 340 ien" ; invalid ien
S N6=$G(^RCD(340,DEBTOR,6))
I +$P(N6,U)'>0 Q "0^no TOP referral" ; no referral date
I $P(N6,U,2) Q "0^referral already stopped" ; referral already stopped
S CMNT=$G(CMNT) I REASON="O",CMNT="" Q "0^comment is required" ; "Other" reason requires comment
S IENS=DEBTOR_","
S FDA(340,IENS,6.02)=1
I (REASON="N")!(REASON="R") S FDA(340,IENS,6.01)="",(EFDT,REASON,CMNT)=""
S FDA(340,IENS,6.03)=EFDT
S FDA(340,IENS,6.04)=REASON
S FDA(340,IENS,6.05)=CMNT
L +^RCD(340,DEBTOR):5 I '$T Q "0^Unable to lock file 340 entry"
D FILE^DIE("","FDA","DIERR")
L -^RCD(340,DEBTOR)
I $D(DIERR("DIERR")) Q "0^"_$G(DIERR("DIERR",1,"TEXT",1))
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTOPU 6660 printed Dec 13, 2024@01:49:08 Page 2
RCTOPU ;WASH IRMFO@ALTOONA,PA/TJK - TOP TRANSMISSION ;2/22/00 12:39 PM
V ;;4.5;Accounts Receivable;**141,400**;Mar 20, 1995;Build 13
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified
+2 ;
REPORT ;print top report
+1 NEW DIC,DIS,L,BY,FR,TO,FLDS,PG,PRINTOT,DIOEND
+2 WRITE !!,"TOP REFERRAL REPORT",!!
+3 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Include Debtors At TOP With '0' Balance"
+4 SET DIR("?")="Answering Yes will include those debtors referred whose current TOP balance is '0'."
+5 DO ^DIR
if (Y="")!(Y="^")
QUIT
+6 SET L=0
SET (FR,TO)=""
SET DIC=340
SET BY=.01
SET FLDS="[RCTOP REPORT]"
SET PRINTOT=0
+7 SET DIS(0)="I $P($G(^RCD(340,D0,6)),U)"
+8 if 'Y
SET DIS(0)=DIS(0)_",$P(^(4),U,3)"
+9 SET DIOEND="D PRNTOT^RCTOPU"
PRINT DO EN1^DIP
REPORTQ QUIT
+1 ;
PRNTOT ;place total amount on report
+1 NEW DASH
+2 SET DASH=""
SET $PIECE(DASH,"-",81)=""
+3 WRITE !!,DASH
+4 WRITE !,?6,"TOTAL AMOUNT CURRENTLY REFERRED:",?50,"$"_$JUSTIFY(PRINTOT,15,2)
+5 IF $EXTRACT(IOST,1,2)="C-"
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
PRNTOTQ QUIT
+1 ;
BILLREP ;prints individual bills and amounts that make up a TOP account
+1 NEW DIC,DEBTOR,ZTSAVE,ZTDESC,ZTRTN
+2 SET DIC=340
SET DIC(0)="AEQM"
SET DIC("S")="I $D(^RCD(340,""TOP"",+Y))"
DO ^DIC
+3 if Y<1
QUIT
SET DEBTOR=+Y
+4 SET %ZIS="AEQ"
DO ^%ZIS
if POP
GOTO BILLREPQ
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 SET ZTSAVE("DEBTOR")=""
+7 SET ZTRTN="BILLREPP^RCTOPU"
SET ZTDESC="TOP BILL REPORT"
+8 DO ^%ZTLOAD
DO ^%ZISC
+9 QUIT
End DoDot:1
GOTO BILLREPQ
+10 ;
BILLREPP ;Call to build array of bills referred
+1 USE IO
+2 NEW BILL,B14,B7,D4,FND,BAMT,TAMT,DIRUT,TNM,TID,TDT,DASH,CSTAT
+3 SET DASH=""
SET $PIECE(DASH,"-",81)=""
SET D4=$GET(^RCD(340,DEBTOR,4))
+4 SET TID=$SELECT($PIECE(D4,U,4)'="":$PIECE(D4,U,4),1:$PIECE(D4,U,1))
+5 SET TNM=$SELECT($PIECE(D4,U,5)'="":$PIECE(D4,U,5),1:$PIECE(D4,U,2))
+6 SET Y=$PIECE(^RCD(340,DEBTOR,6),U,1)
XECUTE ^DD("DD")
SET TDT=Y
+7 SET TAMT=$PIECE(D4,U,3)
DO BILLREPH
+8 SET (FND,BILL)=0
FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if ('BILL)!($DATA(DIRUT))
QUIT
Begin DoDot:1
+9 if '+$GET(^PRCA(430,BILL,14))
QUIT
+10 SET FND=1
WRITE !,$PIECE(^PRCA(430,BILL,0),U)
SET CSTAT=$PIECE(^(0),U,8)
SET B7=$GET(^(7))
+11 WRITE ?14,$PIECE(^PRCA(430.3,CSTAT,0),U,2)
+12 SET BAMT=0
FOR I=1:1:5
SET BAMT=BAMT+$PIECE(B7,U,I)
+13 WRITE ?20,$JUSTIFY(BAMT,10,2)
+14 FOR I=1:1:5
WRITE $JUSTIFY($PIECE(B7,U,I),10,2)
+15 ;check for end of page here, if necessary form feed and print header
+16 IF $Y+3>IOSL
Begin DoDot:2
+17 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
KILL DIRUT
DO ^DIR
if $DATA(DIRUT)
QUIT
+18 DO BILLREPH
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF $EXTRACT(IOST,1,2)="C-"
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+21 DO ^%ZISC
BILLREPQ QUIT
+1 ;
BILLREPH ;header for TOP bill report
+1 WRITE @IOF
+2 WRITE !,"DEBTOR: "_TNM
+3 WRITE !,"TIN: "_TID," REFERRED TO TOP: "_TDT_" CURRENT TOP AMT: "_$JUSTIFY(TAMT,13,2)
+4 WRITE !,DASH
+5 WRITE !!,"BILL NO.",?14,"STAT",?27,"AMT",?36,"PRIN",?47,"INT",?55,"ADMIN",?65,"COURT",?72,"MARSHALL"
+6 WRITE !,"---- ---",?14,"----",?27,"---",?36,"----",?47,"---",?55,"-----",?65,"-----",?72,"--------"
+7 QUIT
+8 ;
STOP ;Stop TOP Referral on a Debtor
+1 NEW DIC,DIE,DA,DIR,Y,DEBTOR,REASON,COMMENT,EFFDT
+2 SET DIC=340
SET DIC(0)="AEQM"
DO ^DIC
if Y<0
QUIT
+3 SET DEBTOR=+Y
+4 IF $PIECE($GET(^RCD(340,DEBTOR,6)),U,2)
GOTO DELSTOP
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Are You Sure You Want To Stop TOP Referral For This Debtor"
DO ^DIR
+6 IF 'Y
WRITE !,*7,"No Action Taken"
QUIT
+7 ;
REASON ;ask referral reason
+1 KILL DIR
SET DIR(0)="340,6.04"
DO ^DIR
+2 if (Y="")!(Y=U)
QUIT
+3 SET REASON=Y
IF REASON="O"
Begin DoDot:1
+4 SET COMMENT=""
SET DIR(0)="340,6.05"
DO ^DIR
SET COMMENT=Y
+5 IF COMMENT=""
WRITE !,"A Reason Of Other requires a comment to be entered"
+6 QUIT
End DoDot:1
if COMMENT=U
QUIT
if COMMENT=""
GOTO REASON
+7 IF REASON'="O"
IF $PIECE($GET(^RCD(340,DEBTOR,6)),U,5)'=""
SET $PIECE(^(6),U,5)=""
+8 ;
+9 IF (REASON="N")!(REASON="R")
Begin DoDot:1
+10 SET $PIECE(^RCD(340,DEBTOR,6),U)=""
+11 KILL ^RCD(340,"TOP",DEBTOR)
+12 SET (EFFDT,REASON,COMMENT)=""
+13 QUIT
End DoDot:1
GOTO STOPFILE
+14 ;
+15 ;ask effective date (for 'waiver','banruptcy','other')
+16 ;
+17 SET DIR(0)="340,6.03"
SET DIR("A")="Enter Effective Date"
DO ^DIR
SET EFFDT=Y
+18 ;
STOPFILE ;set stop referral data in file 340
+1 SET $PIECE(^RCD(340,DEBTOR,6),U,2,5)="1^"_EFFDT_U_REASON_U_$GET(COMMENT)
+2 ;
+3 WRITE !,"Stop TOP Referral Complete"
+4 GOTO STOPQ
+5 ;
DELSTOP ;Allows TOP Referral to be re-instituted for debtor
+1 WRITE !!,*7,"Referral to TOP has already been stopped for this debtor"
+2 SET DIR(0)="Y"
SET DIR("A")="Do You Wish To Re-Institute TOP Referral for this Debtor"
SET DIR("B")="NO"
DO ^DIR
if 'Y
GOTO EDSTOP
+3 ;
+4 ;reset file to allow top referral to be re-started
+5 FOR I=2:1:5
SET $PIECE(^RCD(340,DEBTOR,6),U,I)=""
+6 WRITE !!,"Debtor Is Now Eligible To Be Referred To TOP"
GOTO STOPQ
+7 ;
EDSTOP SET DIR(0)="Y"
SET DIR("A")="Do You Wish To Edit The Stop Referral Data For This Debtor"
SET DIR("B")="NO"
DO ^DIR
if Y
GOTO REASON
STOPQ QUIT
+1 ;
REVERSE ;Refund Reversal
+1 NEW DEBTOR,DIC,DIE,DR,BILL,TRACE,REFYR
+2 WRITE !!,"Refund Reversal Of TOP Refund"
+3 SET DIC=430
SET DIC(0)="AEQLMZ"
SET DIC("S")="I $D(^PRCA(430,""TREF"",2,+Y))"
+4 SET DIC("A")="Enter Refund Bill To Be Reversed:"
DO ^DIC
if Y<0
QUIT
+5 SET DEBTOR=$PIECE(Y(0),U,9)
SET BILL=+Y
+6 IF 'DEBTOR
WRITE !!,*7,"No Debtor Attached To This Bill."
QUIT
+7 SET TRACE=$PIECE($GET(^RCD(340,DEBTOR,6)),U,7)
SET REFYR=$PIECE($GET(^PRCA(430,BILL,14)),U,4)
+8 IF 'TRACE
WRITE !!,*7,"There is no current TOP Trace Number for this debtor",!,"This should have been entered with the most recent TOP payment"
QUIT
+9 IF 'REFYR
WRITE !!,*7,"There is no TOP Refund Year Entered for this bill",!,"This should have been entered when the refund was approved."
QUIT
+10 SET DIR(0)="Y"
SET DIR("A")="Are You Sure You Wish To Reverse This Refund"
+11 SET DIR("B")="NO"
DO ^DIR
IF 'Y
WRITE !!,"No Action Taken"
QUIT
+12 SET DIE="^PRCA(430,"
SET DA=BILL
SET DR="142///3;143///^S X=TRACE"
DO ^DIE
+13 WRITE !,"Reversal Will Be Transmitted With Next TOP Transmission"
REVERSEQ QUIT
+1 ;
UPDCODE ;Update Refund/Reversal Codes in File 348.2
+1 WRITE !,"TOP Refund/Refund Reversal Code Entry"
+2 SET DIC=348.2
SET DIC(0)="AEQML"
DO ^DIC
UPDCODEQ QUIT
+1 ;
STOPREF(DEBTOR,REASON,CMNT,EFDT) ; stop TOP referral for a given debtor (no user interaction) PRCA*4.5*400
+1 ;
+2 ; DEBTOR - file 340 ien
+3 ; REASON - stop referral reason, field 340/6.04 (internal)
+4 ; CMNT - stop referral comment, field 340/6.05
+5 ; EFDT - effective date, field 340/6.03 (internal)
+6 ;
+7 ; returns 1 on success, 0^[error message] otherwise
+8 ;
+9 NEW DIERR,FDA,IENS,N6
+10 ; invalid ien
IF '$DATA(^RCD(340,DEBTOR,0))
QUIT "0^Invalid file 340 ien"
+11 SET N6=$GET(^RCD(340,DEBTOR,6))
+12 ; no referral date
IF +$PIECE(N6,U)'>0
QUIT "0^no TOP referral"
+13 ; referral already stopped
IF $PIECE(N6,U,2)
QUIT "0^referral already stopped"
+14 ; "Other" reason requires comment
SET CMNT=$GET(CMNT)
IF REASON="O"
IF CMNT=""
QUIT "0^comment is required"
+15 SET IENS=DEBTOR_","
+16 SET FDA(340,IENS,6.02)=1
+17 IF (REASON="N")!(REASON="R")
SET FDA(340,IENS,6.01)=""
SET (EFDT,REASON,CMNT)=""
+18 SET FDA(340,IENS,6.03)=EFDT
+19 SET FDA(340,IENS,6.04)=REASON
+20 SET FDA(340,IENS,6.05)=CMNT
+21 LOCK +^RCD(340,DEBTOR):5
IF '$TEST
QUIT "0^Unable to lock file 340 entry"
+22 DO FILE^DIE("","FDA","DIERR")
+23 LOCK -^RCD(340,DEBTOR)
+24 IF $DATA(DIERR("DIERR"))
QUIT "0^"_$GET(DIERR("DIERR",1,"TEXT",1))
+25 QUIT 1
