source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90U.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1RCDMC90U ;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 ]
2V ;;4.5;Accounts Receivable;**45,108,121,163**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4COMPILE(MAX,CNTR,LINES,TLINE) ;COMPILES CODESHEETS INTO MAILMAN MESSAGES
5 ;BUILDS MESSAGE ARRAY
6 N CNT,SEQ,REC,XMDUZ
7 S (SEQ,REC)=0
8 F CNT=1:1:CNTR D
9 .D:CNT#MAX=1
10 ..K ^XTMP("RCDMC90",$J,"BUILD") S SEQ=SEQ+1
11 ..S REC=0
12 ..Q
13 .S REC=REC+1,^XTMP("RCDMC90",$J,"BUILD",REC)=^XTMP("RCDMC90",$J,CNT)
14 .S:CNTR=CNT ^XTMP("RCDMC90",$J,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_(CNT/LINES)
15 .I $S(CNTR=CNT:1,CNT#MAX=0:1,1:0) D
16 ..N XMY,XMSUB
17 ..S XMDUZ="AR PACKAGE"
18 ..S:RCDOC="W" XMY("XXX@Q-DMX.MED.VA.GOV")=""
19 ..S:RCDOC="M" XMY("XXX@Q-DMR.MED.VA.GOV")=""
20 ..S XMSUB=SITE_"/DMC REPORT"_"/SEQ#: "_SEQ_"/"_$$NOW()
21 ..S XMTEXT="^XTMP(""RCDMC90"","_$J_",""BUILD"","
22 ..D ^XMD
23 ..Q
24 .Q
25 S XMDUZ="AR PACKAGE"
26 S:RCDOC="W" XMY("G.DMX")=""
27 S:RCDOC="M" XMY("G.DMR")=""
28 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)
29 S ^XTMP("RCDMC90",$J,"REC1",1)="Name Last4 Principle Interest Admin Total"
30 S ^XTMP("RCDMC90",$J,"REC1",2)="---- ----- --------- -------- ----- -----"
31 S ^XTMP("RCDMC90",$J,"REC1",RCNT+1)="Total Records Sent: "_(RCNT-2)
32 F I=1,2,3 D
33 .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)
34 .Q
35 S ^XTMP("RCDMC90",$J,"REC1",RCNT+5)="Total: "_$J($P(TLINE,U)+$P(TLINE,U,2)+$P(TLINE,U,3),15,2)
36 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)
37 S XMTEXT="^XTMP(""RCDMC90"","_$J_",""REC1"","
38 D ^XMD
39COMPQ Q
40PSEUDO(DFN,PSSN) ;Screens out patients with Pseudo-SSN's and sends mail message
41 N XMSUB,XMY,XMTEXT,MSG,XMDUZ
42 S XMSUB="Notice of debtor eligible for DMC with Pseudo-SSN"
43 S XMY("G.DMR")=""
44 S XMDUZ="AR PACKAGE",XMTEXT="MSG("
45 S MSG(1)="The following patient is eligible for DMC collection,"
46 S MSG(2)="but can not be submitted because of a Pseudo-SSN."
47 S MSG(3)="A valid SSN needs to be entered for this patient."
48 S MSG(4)=" "
49 S MSG(5)="Patient: "_$P(^DPT(DFN,0),U)_" Pseudo-SSN: "_PSSN
50 D ^XMD
51 Q
52NOW() N X,Y,%,%H
53 S %H=$H D YX^%DTC
54 Q Y
55REPORT ;PRINT REPORT
56 N DIC,DIS,L,BY,FR,TO,FLDS,PG,PRINTOT,ADMTOT,INTTOT,DIOEND
57 W !!,"DMC 90 DAY REFERRAL REPORT",!!
58 W !,"Select type of report"
59 S DIR(0)="SM^D:DETAILED;S:SUMMARY",DIR("A")="Enter Report Type"
60 S DIR("?")="Enter 'D' or 'S':"
61 S DIR("?",1)="A detailed report prints out current totals for each individual debtor at DMC."
62 S DIR("?",2)="A summary report prints out current totals of all accounts at DMC."
63 D ^DIR Q:(Y="")!(Y="^")
64 S L=0,(FR,TO)="",DIC=340
65 I Y="S" S BY=3.01,FLDS="[RCDMC90B]" G PRINT
66 S (PRINTOT,ADMTOT,INTTOT)=0
67 S DIS(0)="I $D(^RCD(340,""DMC"",1,D0))"
68 S BY=.01,FLDS="[RCDMC90A]"
69 S DIOEND="D PRNTOT^RCDMC90U"
70PRINT D EN1^DIP
71REPORTQ Q
72PRNTOT N DASH
73 S DASH="",$P(DASH,"-",81)=""
74 W !!,DASH
75 W !,?6,"TOTALS:",?26,"PRINCIPLE",?36,"$"_$J(PRINTOT,15,2)
76 W !,?26,"INTEREST",?36,"$"_$J(INTTOT,15,2),!,?26,"ADMIN",?36,"$"_$J(ADMTOT,15,2)
77 W !,?26,"TOTAL",?36,"$"_$J(PRINTOT+INTTOT+ADMTOT,15,2)
78 Q
79STARTUP ;Displays reminder message for mailgroups
80 N RCMSG S RCMSG(1)="Mailgroup 'DMR' to receive master transaction messages has been set up"
81 S RCMSG(2)="Mailgroup 'DMX' to receive weekly transacton messages have been sent up."
82 S RCMSG(3)="****Remember to add users to these mailgroups.****"
83 D MES^XPDUTL(.RCMSG)
84 Q
85LESSW ;ENTRY POINT FOR MENU OPTION TO ALLOW LESSER WITHHOLDING
86 N DIC,DIR,DEBTOR
87 W !,"DMC Lesser Withholding..."
88 S DIC=340,DIC(0)="AEQM",DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))"
89 D ^DIC G LESSWQ:Y<0 S DEBTOR=+Y
90LESSWA 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
91 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
92 S $P(^RCD(340,DEBTOR,3),U,9)=+Y
93LESSWQ Q
94CANC ;ENTRY POINT FOR MENU OPTION TO ALLOW VAMC TO CANCEL DMC WITHOLDING
95 W !,"Deletion of Debtor From DMC"
96 N DEBTOR,DIC,DIR,DELETE,Y
97CANC1 S DIC=340,DIC(0)="AEQM",DIC("A")="Enter Debtor To Be Removed From DMC: "
98 S DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))" D ^DIC G CANCQ:+Y<0 S DEBTOR=+Y
99 S DIR(0)="YA",DIR("A")="Are you sure you wish to delete this debtor from DMC? "
100 S DIR("B")="NO" D ^DIR G CANC1:'Y
101 S ^RCD(340,DEBTOR,3)="1^^^^^^^^^1"
102CANC2 S I=0 F S I=$O(^PRCA(430,"C",DEBTOR,I)) Q:I'?1N.N K ^PRCA(430,I,12)
103 G CANC1:'$G(DELETE)
104 K ^RCD(340,DEBTOR,3),^RCD(340,"DMC",1,DEBTOR)
105 Q
106CANC3(DEBTOR,DELETE) ;ENTRY POINT FOR AUTODELETION BY SERVER
107 N I
108 D CANC2
109CANCQ Q
110 ;
111ERROR(RCDOC,LKUP,DFN) ; send bulletin if address is not in correct format
112 N XMSUB,XMY,XMDUZ,XMTEXT,MSG
113 S XMSUB="Notice of Unknown/Corrupted Address to DMC"
114 S XMY("G.DMR")=""
115 S XMDUZ="AR PACKAGE"
116 S XMTEXT="MSG("
117 I RCDOC="M" S MSG(1)="Master Record-Monthly was not sent because:"
118 S MSG(2)="Address is "_$S(LKUP=2:"invalid",1:"unknown")_". Verify and re-enter"
119 S MSG(3)="address for the following patient: "
120 S MSG(4)=" "
121 S MSG(5)=" "_$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9)
122 I RCDOC="W" S MSG(6)=" ",MSG(7)="PLEASE NOTE: SENT WEEKLY UPDATE WITH ZERO BALANCE!"
123 D ^XMD
124ERRORQ Q
Note: See TracBrowser for help on using the repository browser.