- 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 Feb 18, 2025@23:09:51 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