RCDMC90U ;WASH IRMFO@ALTOONA,PA/TJK - DMC 90 DAY ;7/17/97 8:14 AM ; 10/24/96 3:21 PM [ 02/24/97 12:17 PM ]
V ;;4.5;Accounts Receivable;**45,108,121,163,400**;Mar 20, 1995;Build 13
;;Per VHA Directive 10-93-142, this routine should not be modified.
COMPILE(MAX,CNTR,LINES,TLINE) ;COMPILES CODESHEETS INTO MAILMAN MESSAGES
;BUILDS MESSAGE ARRAY
N CNT,SEQ,REC,XMDUZ
S (SEQ,REC)=0
F CNT=1:1:CNTR D
.D:CNT#MAX=1
..K ^XTMP("RCDMC90",$J,"BUILD") S SEQ=SEQ+1
..S REC=0
..Q
.S REC=REC+1,^XTMP("RCDMC90",$J,"BUILD",REC)=^XTMP("RCDMC90",$J,CNT)
.S:CNTR=CNT ^XTMP("RCDMC90",$J,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_(CNT/LINES)
.I $S(CNTR=CNT:1,CNT#MAX=0:1,1:0) D
..N XMY,XMSUB
..S XMDUZ="AR PACKAGE"
..S:RCDOC="W" XMY("XXX@Q-DMX.DOMAIN.EXT")=""
..S:RCDOC="M" XMY("XXX@Q-DMR.DOMAIN.EXT")=""
..S XMSUB=SITE_"/DMC REPORT"_"/SEQ#: "_SEQ_"/"_$$NOW()
..S XMTEXT="^XTMP(""RCDMC90"","_$J_",""BUILD"","
..D ^XMD
..Q
.Q
S XMDUZ="AR PACKAGE"
S:RCDOC="W" XMY("G.DMX")=""
S:RCDOC="M" XMY("G.DMR")=""
S XMSUB=$S(RCDOC="W":"WEEKLY UPDATE ",1:"MASTER FILE ")_"RECORDS SENT TO DMC ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S ^XTMP("RCDMC90",$J,"REC1",1)="Name Last4 Principle Interest Admin Total"
S ^XTMP("RCDMC90",$J,"REC1",2)="---- ----- --------- -------- ----- -----"
S ^XTMP("RCDMC90",$J,"REC1",RCNT+1)="Total Records Sent: "_(RCNT-2)
F I=1,2,3 D
.S ^XTMP("RCDMC90",$J,"REC1",RCNT+I+1)="Total "_$S(I=1:"Principle: ",I=2:"Interest: ",1:"Admin: ")_$J($P(TLINE,U,I),15,2)
.Q
S ^XTMP("RCDMC90",$J,"REC1",RCNT+5)="Total: "_$J($P(TLINE,U)+$P(TLINE,U,2)+$P(TLINE,U,3),15,2)
S X="",I=2 F S X=$O(^XTMP("RCDMC90",$J,"REC",X)) Q:X="" S I=I+1,^XTMP("RCDMC90",$J,"REC1",I)=^(X)
S XMTEXT="^XTMP(""RCDMC90"","_$J_",""REC1"","
D ^XMD
COMPQ Q
PSEUDO(DFN,PSSN) ;Screens out patients with Pseudo-SSN's and sends mail message
N XMSUB,XMY,XMTEXT,MSG,XMDUZ
S XMSUB="Notice of debtor eligible for DMC with Pseudo-SSN"
S XMY("G.DMR")=""
S XMDUZ="AR PACKAGE",XMTEXT="MSG("
S MSG(1)="The following patient is eligible for DMC collection,"
S MSG(2)="but can not be submitted because of a Pseudo-SSN."
S MSG(3)="A valid SSN needs to be entered for this patient."
S MSG(4)=" "
S MSG(5)="Patient: "_$P(^DPT(DFN,0),U)_" Pseudo-SSN: "_PSSN
D ^XMD
Q
NOW() N X,Y,%,%H
S %H=$H D YX^%DTC
Q Y
REPORT ;PRINT REPORT
N DIC,DIS,L,BY,FR,TO,FLDS,PG,PRINTOT,ADMTOT,INTTOT,DIOEND
W !!,"DMC 90 DAY REFERRAL REPORT",!!
W !,"Select type of report"
S DIR(0)="SM^D:DETAILED;S:SUMMARY",DIR("A")="Enter Report Type"
S DIR("?")="Enter 'D' or 'S':"
S DIR("?",1)="A detailed report prints out current totals for each individual debtor at DMC."
S DIR("?",2)="A summary report prints out current totals of all accounts at DMC."
D ^DIR Q:(Y="")!(Y="^")
S L=0,(FR,TO)="",DIC=340
I Y="S" S BY=3.01,FLDS="[RCDMC90B]" G PRINT
S (PRINTOT,ADMTOT,INTTOT)=0
S DIS(0)="I $D(^RCD(340,""DMC"",1,D0))"
S BY=.01,FLDS="[RCDMC90A]"
S DIOEND="D PRNTOT^RCDMC90U"
PRINT D EN1^DIP
REPORTQ Q
PRNTOT N DASH
S DASH="",$P(DASH,"-",81)=""
W !!,DASH
W !,?6,"TOTALS:",?26,"PRINCIPLE",?36,"$"_$J(PRINTOT,15,2)
W !,?26,"INTEREST",?36,"$"_$J(INTTOT,15,2),!,?26,"ADMIN",?36,"$"_$J(ADMTOT,15,2)
W !,?26,"TOTAL",?36,"$"_$J(PRINTOT+INTTOT+ADMTOT,15,2)
Q
STARTUP ;Displays reminder message for mailgroups
N RCMSG S RCMSG(1)="Mailgroup 'DMR' to receive master transaction messages has been set up"
S RCMSG(2)="Mailgroup 'DMX' to receive weekly transacton messages have been sent up."
S RCMSG(3)="****Remember to add users to these mailgroups.****"
D MES^XPDUTL(.RCMSG)
Q
LESSW ;ENTRY POINT FOR MENU OPTION TO ALLOW LESSER WITHHOLDING
N DIC,DIR,DEBTOR
W !,"DMC Lesser Withholding..."
S DIC=340,DIC(0)="AEQM",DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))"
D ^DIC G LESSWQ:Y<0 S DEBTOR=+Y
LESSWA S DIR(0)="340,3.09",DIR("B")=$S($P($G(^RCD(340,DEBTOR,3)),U,9):$J($P(^RCD(340,DEBTOR,3),U,9),0,2),1:"0.00") D ^DIR G LESSWQ:'Y
I +Y>$P(^RCD(340,DEBTOR,3),U,5) W !!,*7,"Amount entered exceeds the amount currently at DMC which is ",$P(^(3),U,5),!,"Re-enter lesser amount" G LESSWA
S $P(^RCD(340,DEBTOR,3),U,9)=+Y
LESSWQ Q
CANC ;ENTRY POINT FOR MENU OPTION TO ALLOW VAMC TO CANCEL DMC WITHOLDING
W !,"Deletion of Debtor From DMC"
N DEBTOR,DIC,DIR,DELETE,Y
CANC1 S DIC=340,DIC(0)="AEQM",DIC("A")="Enter Debtor To Be Removed From DMC: "
S DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))" D ^DIC G CANCQ:+Y<0 S DEBTOR=+Y
S DIR(0)="YA",DIR("A")="Are you sure you wish to delete this debtor from DMC? "
S DIR("B")="NO" D ^DIR G CANC1:'Y
S ^RCD(340,DEBTOR,3)="1^^^^^^^^^1"
CANC2 S I=0 F S I=$O(^PRCA(430,"C",DEBTOR,I)) Q:I'?1N.N K ^PRCA(430,I,12)
G CANC1:'$G(DELETE)
K ^RCD(340,DEBTOR,3),^RCD(340,"DMC",1,DEBTOR)
Q
CANC3(DEBTOR,DELETE) ;ENTRY POINT FOR AUTODELETION BY SERVER
N I
D CANC2
CANCQ Q
;
CANCDMC(DEBTOR) ; cancel DMC withholding (no user interaction) PRCA*4.5*400
;
; DEBTOR - file 340 ien
;
; returns 1 on success, 0^[error message] otherwise
;
N DIERR,FDA,IENS,N3,RCBILL,RES
I '$D(^RCD(340,DEBTOR,0)) Q "0^Invalid file 340 ien" ; invalid ien
S N3=$G(^RCD(340,DEBTOR,3))
I +$P(N3,U)'>0 Q "0^account is not at DMC" ; field 340/3.01 is not set
I $P(N3,U,10) Q "0^withholding already cancelled" ; field 340/3.1 is set
S IENS=DEBTOR_","
S FDA(340,IENS,3.02)=""
S FDA(340,IENS,3.03)=""
S FDA(340,IENS,3.05)=""
S FDA(340,IENS,3.06)=""
S FDA(340,IENS,3.07)=""
S FDA(340,IENS,3.08)=""
S FDA(340,IENS,3.09)=""
S FDA(340,IENS,3.1)=1
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))
S RES=1,RCBILL=0 F S RCBILL=$O(^PRCA(430,"C",DEBTOR,RCBILL)) Q:'RCBILL!('$P(RES,U)) D
.S IENS=RCBILL_"," K FDA
.S FDA(430,IENS,121)=""
.S FDA(430,IENS,122)=""
.S FDA(430,IENS,123)=""
.S FDA(430,IENS,124)=""
.L +^PRCA(430,RCBILL):5 I '$T S RES="0^Unable to lock file 430 entry"
.D FILE^DIE("","FDA","DIERR")
.L -^PRCA(430,RCBILL)
.I $D(DIERR("DIERR")) S RES="0^"_$G(DIERR("DIERR",1,"TEXT",1))
.Q
Q RES
;
ERROR(RCDOC,LKUP,DFN) ; send bulletin if address is not in correct format
N XMSUB,XMY,XMDUZ,XMTEXT,MSG
S XMSUB="Notice of Unknown/Corrupted Address to DMC"
S XMY("G.DMR")=""
S XMDUZ="AR PACKAGE"
S XMTEXT="MSG("
I RCDOC="M" S MSG(1)="Master Record-Monthly was not sent because:"
S MSG(2)="Address is "_$S(LKUP=2:"invalid",1:"unknown")_". Verify and re-enter"
S MSG(3)="address for the following patient: "
S MSG(4)=" "
S MSG(5)=" "_$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9)
I RCDOC="W" S MSG(6)=" ",MSG(7)="PLEASE NOTE: SENT WEEKLY UPDATE WITH ZERO BALANCE!"
D ^XMD
ERRORQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDMC90U 6893 printed Oct 16, 2024@17:44:18 Page 2
RCDMC90U ;WASH IRMFO@ALTOONA,PA/TJK - DMC 90 DAY ;7/17/97 8:14 AM ; 10/24/96 3:21 PM [ 02/24/97 12:17 PM ]
V ;;4.5;Accounts Receivable;**45,108,121,163,400**;Mar 20, 1995;Build 13
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
COMPILE(MAX,CNTR,LINES,TLINE) ;COMPILES CODESHEETS INTO MAILMAN MESSAGES
+1 ;BUILDS MESSAGE ARRAY
+2 NEW CNT,SEQ,REC,XMDUZ
+3 SET (SEQ,REC)=0
+4 FOR CNT=1:1:CNTR
Begin DoDot:1
+5 if CNT#MAX=1
Begin DoDot:2
+6 KILL ^XTMP("RCDMC90",$JOB,"BUILD")
SET SEQ=SEQ+1
+7 SET REC=0
+8 QUIT
End DoDot:2
+9 SET REC=REC+1
SET ^XTMP("RCDMC90",$JOB,"BUILD",REC)=^XTMP("RCDMC90",$JOB,CNT)
+10 if CNTR=CNT
SET ^XTMP("RCDMC90",$JOB,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_(CNT/LINES)
+11 IF $SELECT(CNTR=CNT:1,CNT#MAX=0:1,1:0)
Begin DoDot:2
+12 NEW XMY,XMSUB
+13 SET XMDUZ="AR PACKAGE"
+14 if RCDOC="W"
SET XMY("XXX@Q-DMX.DOMAIN.EXT")=""
+15 if RCDOC="M"
SET XMY("XXX@Q-DMR.DOMAIN.EXT")=""
+16 SET XMSUB=SITE_"/DMC REPORT"_"/SEQ#: "_SEQ_"/"_$$NOW()
+17 SET XMTEXT="^XTMP(""RCDMC90"","_$JOB_",""BUILD"","
+18 DO ^XMD
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 SET XMDUZ="AR PACKAGE"
+22 if RCDOC="W"
SET XMY("G.DMX")=""
+23 if RCDOC="M"
SET XMY("G.DMR")=""
+24 SET XMSUB=$SELECT(RCDOC="W":"WEEKLY UPDATE ",1:"MASTER FILE ")_"RECORDS SENT TO DMC ON "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+25 SET ^XTMP("RCDMC90",$JOB,"REC1",1)="Name Last4 Principle Interest Admin Total"
+26 SET ^XTMP("RCDMC90",$JOB,"REC1",2)="---- ----- --------- -------- ----- -----"
+27 SET ^XTMP("RCDMC90",$JOB,"REC1",RCNT+1)="Total Records Sent: "_(RCNT-2)
+28 FOR I=1,2,3
Begin DoDot:1
+29 SET ^XTMP("RCDMC90",$JOB,"REC1",RCNT+I+1)="Total "_$SELECT(I=1:"Principle: ",I=2:"Interest: ",1:"Admin: ")_$JUSTIFY($PIECE(TLINE,U,I),15,2)
+30 QUIT
End DoDot:1
+31 SET ^XTMP("RCDMC90",$JOB,"REC1",RCNT+5)="Total: "_$JUSTIFY($PIECE(TLINE,U)+$PIECE(TLINE,U,2)+$PIECE(TLINE,U,3),15,2)
+32 SET X=""
SET I=2
FOR
SET X=$ORDER(^XTMP("RCDMC90",$JOB,"REC",X))
if X=""
QUIT
SET I=I+1
SET ^XTMP("RCDMC90",$JOB,"REC1",I)=^(X)
+33 SET XMTEXT="^XTMP(""RCDMC90"","_$JOB_",""REC1"","
+34 DO ^XMD
COMPQ QUIT
PSEUDO(DFN,PSSN) ;Screens out patients with Pseudo-SSN's and sends mail message
+1 NEW XMSUB,XMY,XMTEXT,MSG,XMDUZ
+2 SET XMSUB="Notice of debtor eligible for DMC with Pseudo-SSN"
+3 SET XMY("G.DMR")=""
+4 SET XMDUZ="AR PACKAGE"
SET XMTEXT="MSG("
+5 SET MSG(1)="The following patient is eligible for DMC collection,"
+6 SET MSG(2)="but can not be submitted because of a Pseudo-SSN."
+7 SET MSG(3)="A valid SSN needs to be entered for this patient."
+8 SET MSG(4)=" "
+9 SET MSG(5)="Patient: "_$PIECE(^DPT(DFN,0),U)_" Pseudo-SSN: "_PSSN
+10 DO ^XMD
+11 QUIT
NOW() NEW X,Y,%,%H
+1 SET %H=$HOROLOG
DO YX^%DTC
+2 QUIT Y
REPORT ;PRINT REPORT
+1 NEW DIC,DIS,L,BY,FR,TO,FLDS,PG,PRINTOT,ADMTOT,INTTOT,DIOEND
+2 WRITE !!,"DMC 90 DAY REFERRAL REPORT",!!
+3 WRITE !,"Select type of report"
+4 SET DIR(0)="SM^D:DETAILED;S:SUMMARY"
SET DIR("A")="Enter Report Type"
+5 SET DIR("?")="Enter 'D' or 'S':"
+6 SET DIR("?",1)="A detailed report prints out current totals for each individual debtor at DMC."
+7 SET DIR("?",2)="A summary report prints out current totals of all accounts at DMC."
+8 DO ^DIR
if (Y="")!(Y="^")
QUIT
+9 SET L=0
SET (FR,TO)=""
SET DIC=340
+10 IF Y="S"
SET BY=3.01
SET FLDS="[RCDMC90B]"
GOTO PRINT
+11 SET (PRINTOT,ADMTOT,INTTOT)=0
+12 SET DIS(0)="I $D(^RCD(340,""DMC"",1,D0))"
+13 SET BY=.01
SET FLDS="[RCDMC90A]"
+14 SET DIOEND="D PRNTOT^RCDMC90U"
PRINT DO EN1^DIP
REPORTQ QUIT
PRNTOT NEW DASH
+1 SET DASH=""
SET $PIECE(DASH,"-",81)=""
+2 WRITE !!,DASH
+3 WRITE !,?6,"TOTALS:",?26,"PRINCIPLE",?36,"$"_$JUSTIFY(PRINTOT,15,2)
+4 WRITE !,?26,"INTEREST",?36,"$"_$JUSTIFY(INTTOT,15,2),!,?26,"ADMIN",?36,"$"_$JUSTIFY(ADMTOT,15,2)
+5 WRITE !,?26,"TOTAL",?36,"$"_$JUSTIFY(PRINTOT+INTTOT+ADMTOT,15,2)
+6 QUIT
STARTUP ;Displays reminder message for mailgroups
+1 NEW RCMSG
SET RCMSG(1)="Mailgroup 'DMR' to receive master transaction messages has been set up"
+2 SET RCMSG(2)="Mailgroup 'DMX' to receive weekly transacton messages have been sent up."
+3 SET RCMSG(3)="****Remember to add users to these mailgroups.****"
+4 DO MES^XPDUTL(.RCMSG)
+5 QUIT
LESSW ;ENTRY POINT FOR MENU OPTION TO ALLOW LESSER WITHHOLDING
+1 NEW DIC,DIR,DEBTOR
+2 WRITE !,"DMC Lesser Withholding..."
+3 SET DIC=340
SET DIC(0)="AEQM"
SET DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))"
+4 DO ^DIC
if Y<0
GOTO LESSWQ
SET DEBTOR=+Y
LESSWA SET DIR(0)="340,3.09"
SET DIR("B")=$SELECT($PIECE($GET(^RCD(340,DEBTOR,3)),U,9):$JUSTIFY($PIECE(^RCD(340,DEBTOR,3),U,9),0,2),1:"0.00")
DO ^DIR
if 'Y
GOTO LESSWQ
+1 IF +Y>$PIECE(^RCD(340,DEBTOR,3),U,5)
WRITE !!,*7,"Amount entered exceeds the amount currently at DMC which is ",$PIECE(^(3),U,5),!,"Re-enter lesser amount"
GOTO LESSWA
+2 SET $PIECE(^RCD(340,DEBTOR,3),U,9)=+Y
LESSWQ QUIT
CANC ;ENTRY POINT FOR MENU OPTION TO ALLOW VAMC TO CANCEL DMC WITHOLDING
+1 WRITE !,"Deletion of Debtor From DMC"
+2 NEW DEBTOR,DIC,DIR,DELETE,Y
CANC1 SET DIC=340
SET DIC(0)="AEQM"
SET DIC("A")="Enter Debtor To Be Removed From DMC: "
+1 SET DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))"
DO ^DIC
if +Y<0
GOTO CANCQ
SET DEBTOR=+Y
+2 SET DIR(0)="YA"
SET DIR("A")="Are you sure you wish to delete this debtor from DMC? "
+3 SET DIR("B")="NO"
DO ^DIR
if 'Y
GOTO CANC1
+4 SET ^RCD(340,DEBTOR,3)="1^^^^^^^^^1"
CANC2 SET I=0
FOR
SET I=$ORDER(^PRCA(430,"C",DEBTOR,I))
if I'?1N.N
QUIT
KILL ^PRCA(430,I,12)
+1 if '$GET(DELETE)
GOTO CANC1
+2 KILL ^RCD(340,DEBTOR,3),^RCD(340,"DMC",1,DEBTOR)
+3 QUIT
CANC3(DEBTOR,DELETE) ;ENTRY POINT FOR AUTODELETION BY SERVER
+1 NEW I
+2 DO CANC2
CANCQ QUIT
+1 ;
CANCDMC(DEBTOR) ; cancel DMC withholding (no user interaction) PRCA*4.5*400
+1 ;
+2 ; DEBTOR - file 340 ien
+3 ;
+4 ; returns 1 on success, 0^[error message] otherwise
+5 ;
+6 NEW DIERR,FDA,IENS,N3,RCBILL,RES
+7 ; invalid ien
IF '$DATA(^RCD(340,DEBTOR,0))
QUIT "0^Invalid file 340 ien"
+8 SET N3=$GET(^RCD(340,DEBTOR,3))
+9 ; field 340/3.01 is not set
IF +$PIECE(N3,U)'>0
QUIT "0^account is not at DMC"
+10 ; field 340/3.1 is set
IF $PIECE(N3,U,10)
QUIT "0^withholding already cancelled"
+11 SET IENS=DEBTOR_","
+12 SET FDA(340,IENS,3.02)=""
+13 SET FDA(340,IENS,3.03)=""
+14 SET FDA(340,IENS,3.05)=""
+15 SET FDA(340,IENS,3.06)=""
+16 SET FDA(340,IENS,3.07)=""
+17 SET FDA(340,IENS,3.08)=""
+18 SET FDA(340,IENS,3.09)=""
+19 SET FDA(340,IENS,3.1)=1
+20 LOCK +^RCD(340,DEBTOR):5
IF '$TEST
QUIT "0^Unable to lock file 340 entry"
+21 DO FILE^DIE("","FDA","DIERR")
+22 LOCK -^RCD(340,DEBTOR)
+23 IF $DATA(DIERR("DIERR"))
QUIT "0^"_$GET(DIERR("DIERR",1,"TEXT",1))
+24 SET RES=1
SET RCBILL=0
FOR
SET RCBILL=$ORDER(^PRCA(430,"C",DEBTOR,RCBILL))
if 'RCBILL!('$PIECE(RES,U))
QUIT
Begin DoDot:1
+25 SET IENS=RCBILL_","
KILL FDA
+26 SET FDA(430,IENS,121)=""
+27 SET FDA(430,IENS,122)=""
+28 SET FDA(430,IENS,123)=""
+29 SET FDA(430,IENS,124)=""
+30 LOCK +^PRCA(430,RCBILL):5
IF '$TEST
SET RES="0^Unable to lock file 430 entry"
+31 DO FILE^DIE("","FDA","DIERR")
+32 LOCK -^PRCA(430,RCBILL)
+33 IF $DATA(DIERR("DIERR"))
SET RES="0^"_$GET(DIERR("DIERR",1,"TEXT",1))
+34 QUIT
End DoDot:1
+35 QUIT RES
+36 ;
ERROR(RCDOC,LKUP,DFN) ; send bulletin if address is not in correct format
+1 NEW XMSUB,XMY,XMDUZ,XMTEXT,MSG
+2 SET XMSUB="Notice of Unknown/Corrupted Address to DMC"
+3 SET XMY("G.DMR")=""
+4 SET XMDUZ="AR PACKAGE"
+5 SET XMTEXT="MSG("
+6 IF RCDOC="M"
SET MSG(1)="Master Record-Monthly was not sent because:"
+7 SET MSG(2)="Address is "_$SELECT(LKUP=2:"invalid",1:"unknown")_". Verify and re-enter"
+8 SET MSG(3)="address for the following patient: "
+9 SET MSG(4)=" "
+10 SET MSG(5)=" "_$PIECE(^DPT(DFN,0),U)_" SSN: "_$PIECE(^(0),U,9)
+11 IF RCDOC="W"
SET MSG(6)=" "
SET MSG(7)="PLEASE NOTE: SENT WEEKLY UPDATE WITH ZERO BALANCE!"
+12 DO ^XMD
ERRORQ QUIT
