Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDMC90U

RCDMC90U.m

Go to the documentation of this file.
  1. 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 ]
  1. 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.
  1. COMPILE(MAX,CNTR,LINES,TLINE) ;COMPILES CODESHEETS INTO MAILMAN MESSAGES
  1. ;BUILDS MESSAGE ARRAY
  1. N CNT,SEQ,REC,XMDUZ
  1. S (SEQ,REC)=0
  1. F CNT=1:1:CNTR D
  1. .D:CNT#MAX=1
  1. ..K ^XTMP("RCDMC90",$J,"BUILD") S SEQ=SEQ+1
  1. ..S REC=0
  1. ..Q
  1. .S REC=REC+1,^XTMP("RCDMC90",$J,"BUILD",REC)=^XTMP("RCDMC90",$J,CNT)
  1. .S:CNTR=CNT ^XTMP("RCDMC90",$J,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_(CNT/LINES)
  1. .I $S(CNTR=CNT:1,CNT#MAX=0:1,1:0) D
  1. ..N XMY,XMSUB
  1. ..S XMDUZ="AR PACKAGE"
  1. ..S:RCDOC="W" XMY("XXX@Q-DMX.DOMAIN.EXT")=""
  1. ..S:RCDOC="M" XMY("XXX@Q-DMR.DOMAIN.EXT")=""
  1. ..S XMSUB=SITE_"/DMC REPORT"_"/SEQ#: "_SEQ_"/"_$$NOW()
  1. ..S XMTEXT="^XTMP(""RCDMC90"","_$J_",""BUILD"","
  1. ..D ^XMD
  1. ..Q
  1. .Q
  1. S XMDUZ="AR PACKAGE"
  1. S:RCDOC="W" XMY("G.DMX")=""
  1. S:RCDOC="M" XMY("G.DMR")=""
  1. 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)
  1. S ^XTMP("RCDMC90",$J,"REC1",1)="Name Last4 Principle Interest Admin Total"
  1. S ^XTMP("RCDMC90",$J,"REC1",2)="---- ----- --------- -------- ----- -----"
  1. S ^XTMP("RCDMC90",$J,"REC1",RCNT+1)="Total Records Sent: "_(RCNT-2)
  1. F I=1,2,3 D
  1. .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)
  1. .Q
  1. S ^XTMP("RCDMC90",$J,"REC1",RCNT+5)="Total: "_$J($P(TLINE,U)+$P(TLINE,U,2)+$P(TLINE,U,3),15,2)
  1. 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)
  1. S XMTEXT="^XTMP(""RCDMC90"","_$J_",""REC1"","
  1. D ^XMD
  1. COMPQ Q
  1. PSEUDO(DFN,PSSN) ;Screens out patients with Pseudo-SSN's and sends mail message
  1. N XMSUB,XMY,XMTEXT,MSG,XMDUZ
  1. S XMSUB="Notice of debtor eligible for DMC with Pseudo-SSN"
  1. S XMY("G.DMR")=""
  1. S XMDUZ="AR PACKAGE",XMTEXT="MSG("
  1. S MSG(1)="The following patient is eligible for DMC collection,"
  1. S MSG(2)="but can not be submitted because of a Pseudo-SSN."
  1. S MSG(3)="A valid SSN needs to be entered for this patient."
  1. S MSG(4)=" "
  1. S MSG(5)="Patient: "_$P(^DPT(DFN,0),U)_" Pseudo-SSN: "_PSSN
  1. D ^XMD
  1. Q
  1. NOW() N X,Y,%,%H
  1. S %H=$H D YX^%DTC
  1. Q Y
  1. REPORT ;PRINT REPORT
  1. N DIC,DIS,L,BY,FR,TO,FLDS,PG,PRINTOT,ADMTOT,INTTOT,DIOEND
  1. W !!,"DMC 90 DAY REFERRAL REPORT",!!
  1. W !,"Select type of report"
  1. S DIR(0)="SM^D:DETAILED;S:SUMMARY",DIR("A")="Enter Report Type"
  1. S DIR("?")="Enter 'D' or 'S':"
  1. S DIR("?",1)="A detailed report prints out current totals for each individual debtor at DMC."
  1. S DIR("?",2)="A summary report prints out current totals of all accounts at DMC."
  1. D ^DIR Q:(Y="")!(Y="^")
  1. S L=0,(FR,TO)="",DIC=340
  1. I Y="S" S BY=3.01,FLDS="[RCDMC90B]" G PRINT
  1. S (PRINTOT,ADMTOT,INTTOT)=0
  1. S DIS(0)="I $D(^RCD(340,""DMC"",1,D0))"
  1. S BY=.01,FLDS="[RCDMC90A]"
  1. S DIOEND="D PRNTOT^RCDMC90U"
  1. PRINT D EN1^DIP
  1. REPORTQ Q
  1. PRNTOT N DASH
  1. S DASH="",$P(DASH,"-",81)=""
  1. W !!,DASH
  1. W !,?6,"TOTALS:",?26,"PRINCIPLE",?36,"$"_$J(PRINTOT,15,2)
  1. W !,?26,"INTEREST",?36,"$"_$J(INTTOT,15,2),!,?26,"ADMIN",?36,"$"_$J(ADMTOT,15,2)
  1. W !,?26,"TOTAL",?36,"$"_$J(PRINTOT+INTTOT+ADMTOT,15,2)
  1. Q
  1. STARTUP ;Displays reminder message for mailgroups
  1. N RCMSG S RCMSG(1)="Mailgroup 'DMR' to receive master transaction messages has been set up"
  1. S RCMSG(2)="Mailgroup 'DMX' to receive weekly transacton messages have been sent up."
  1. S RCMSG(3)="****Remember to add users to these mailgroups.****"
  1. D MES^XPDUTL(.RCMSG)
  1. Q
  1. LESSW ;ENTRY POINT FOR MENU OPTION TO ALLOW LESSER WITHHOLDING
  1. N DIC,DIR,DEBTOR
  1. W !,"DMC Lesser Withholding..."
  1. S DIC=340,DIC(0)="AEQM",DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))"
  1. D ^DIC G LESSWQ:Y<0 S DEBTOR=+Y
  1. 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
  1. 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
  1. S $P(^RCD(340,DEBTOR,3),U,9)=+Y
  1. LESSWQ Q
  1. CANC ;ENTRY POINT FOR MENU OPTION TO ALLOW VAMC TO CANCEL DMC WITHOLDING
  1. W !,"Deletion of Debtor From DMC"
  1. N DEBTOR,DIC,DIR,DELETE,Y
  1. CANC1 S DIC=340,DIC(0)="AEQM",DIC("A")="Enter Debtor To Be Removed From DMC: "
  1. S DIC("S")="I $D(^RCD(340,""DMC"",1,+Y))" D ^DIC G CANCQ:+Y<0 S DEBTOR=+Y
  1. S DIR(0)="YA",DIR("A")="Are you sure you wish to delete this debtor from DMC? "
  1. S DIR("B")="NO" D ^DIR G CANC1:'Y
  1. S ^RCD(340,DEBTOR,3)="1^^^^^^^^^1"
  1. CANC2 S I=0 F S I=$O(^PRCA(430,"C",DEBTOR,I)) Q:I'?1N.N K ^PRCA(430,I,12)
  1. G CANC1:'$G(DELETE)
  1. K ^RCD(340,DEBTOR,3),^RCD(340,"DMC",1,DEBTOR)
  1. Q
  1. CANC3(DEBTOR,DELETE) ;ENTRY POINT FOR AUTODELETION BY SERVER
  1. N I
  1. D CANC2
  1. CANCQ Q
  1. ;
  1. CANCDMC(DEBTOR) ; cancel DMC withholding (no user interaction) PRCA*4.5*400
  1. ;
  1. ; DEBTOR - file 340 ien
  1. ;
  1. ; returns 1 on success, 0^[error message] otherwise
  1. ;
  1. N DIERR,FDA,IENS,N3,RCBILL,RES
  1. I '$D(^RCD(340,DEBTOR,0)) Q "0^Invalid file 340 ien" ; invalid ien
  1. S N3=$G(^RCD(340,DEBTOR,3))
  1. I +$P(N3,U)'>0 Q "0^account is not at DMC" ; field 340/3.01 is not set
  1. I $P(N3,U,10) Q "0^withholding already cancelled" ; field 340/3.1 is set
  1. S IENS=DEBTOR_","
  1. S FDA(340,IENS,3.02)=""
  1. S FDA(340,IENS,3.03)=""
  1. S FDA(340,IENS,3.05)=""
  1. S FDA(340,IENS,3.06)=""
  1. S FDA(340,IENS,3.07)=""
  1. S FDA(340,IENS,3.08)=""
  1. S FDA(340,IENS,3.09)=""
  1. S FDA(340,IENS,3.1)=1
  1. L +^RCD(340,DEBTOR):5 I '$T Q "0^Unable to lock file 340 entry"
  1. D FILE^DIE("","FDA","DIERR")
  1. L -^RCD(340,DEBTOR)
  1. I $D(DIERR("DIERR")) Q "0^"_$G(DIERR("DIERR",1,"TEXT",1))
  1. S RES=1,RCBILL=0 F S RCBILL=$O(^PRCA(430,"C",DEBTOR,RCBILL)) Q:'RCBILL!('$P(RES,U)) D
  1. .S IENS=RCBILL_"," K FDA
  1. .S FDA(430,IENS,121)=""
  1. .S FDA(430,IENS,122)=""
  1. .S FDA(430,IENS,123)=""
  1. .S FDA(430,IENS,124)=""
  1. .L +^PRCA(430,RCBILL):5 I '$T S RES="0^Unable to lock file 430 entry"
  1. .D FILE^DIE("","FDA","DIERR")
  1. .L -^PRCA(430,RCBILL)
  1. .I $D(DIERR("DIERR")) S RES="0^"_$G(DIERR("DIERR",1,"TEXT",1))
  1. .Q
  1. Q RES
  1. ;
  1. ERROR(RCDOC,LKUP,DFN) ; send bulletin if address is not in correct format
  1. N XMSUB,XMY,XMDUZ,XMTEXT,MSG
  1. S XMSUB="Notice of Unknown/Corrupted Address to DMC"
  1. S XMY("G.DMR")=""
  1. S XMDUZ="AR PACKAGE"
  1. S XMTEXT="MSG("
  1. I RCDOC="M" S MSG(1)="Master Record-Monthly was not sent because:"
  1. S MSG(2)="Address is "_$S(LKUP=2:"invalid",1:"unknown")_". Verify and re-enter"
  1. S MSG(3)="address for the following patient: "
  1. S MSG(4)=" "
  1. S MSG(5)=" "_$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9)
  1. I RCDOC="W" S MSG(6)=" ",MSG(7)="PLEASE NOTE: SENT WEEKLY UPDATE WITH ZERO BALANCE!"
  1. D ^XMD
  1. ERRORQ Q