source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90U.m@ 1073

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**;Mar 20, 1995

 ;;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.MED.VA.GOV")=""

 ..S:RCDOC="M" XMY("XXX@Q-DMR.MED.VA.GOV")=""

 ..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

 ;

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