- 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 Jan 18, 2025@02:50:21 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