RCDMC90S ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY (SERVER) ;7/17/97 8:11 AM ; 10/24/96 3:21 PM [ 02/24/97 12:17 PM ]
V ;;4.5;Accounts Receivable;**45,121**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;Program to process server messages from DMC
;1) Will automatically delete DMC flags from local system for
; those patients submitted to DMC that are not being followed by
; DMC
;2) Will display message to DMX mailgroup when DMC receives a death
; notice in order that the local site can follow-up and have the
; death entry entered into the local patient file.
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
K ^TMP("RCDMC90S",$J) S XMA=0
READ1 X XMREC I $D(XMER) G PROC:XMER<0
S XMA=XMA+1
S ^TMP("RCDMC90S",$J,"READ",XMA)=XMRG
G READ1
PROC N DEBTOR,SSN,DDATE,LN,CNT,I,J,SITE,REC,ND,NAME,TYPE,SEQ,CNTR,LKUP,MSG
N XMDUZ,XMSUB,XMY,XMTEXT
K XMPOS,XMA,XMER,XMREC,XMRG
S CNT=2,CNTR=3,(SEQ,I)=0
F S I=$O(^TMP("RCDMC90S",$J,"READ",I)) Q:I="" S ND=$G(^(I)) D Q:$P(ND,"|",2)="~"
.I $P(ND,U)="DI" S SEQ=$P(ND,U,3)
.Q:$P(ND,"^")'?1N.N
.S REC=$P(ND,"|")
.S SSN=$P(REC,U,1),DEBTOR=+$P(REC,U,3),DDATE=$P(REC,U,4),TYPE=$P(REC,U,5)
.S LKUP=$$DEBT(DEBTOR,SSN)
.I 'LKUP D Q ;Invalid debtor check-patch *121
..S CNTR=CNTR+1
..S ^TMP("RCDMC90S",$J,"BUILD",CNTR)=" "_"DEBTOR: "_+$P(REC,U,3)_" SSN: "_$P(REC,U,1)
.S DEBTOR=$P(LKUP,U,2)
.;
.;Process good debtor numbers
.D CANC3^RCDMC90U(DEBTOR,1)
.S DFN=+$G(^RCD(340,DEBTOR,0)),NAME=$P(^DPT(DFN,0),U),LN=" "_$$LJ^XLFSTR(NAME,30)_" "_SSN
.S CNT=CNT+1,^TMP("RCDMC90S",$J,"REC",CNT)=LN_$S(TYPE="01":" INACTIVE BENEFIT",1:" DECEASED")
.I DDATE D
..S XMSUB="Death Notice Received From DMC"
..S XMY("G.DMR")="",XMDUZ="AR PACKAGE",XMTEXT="MSG("
..S MSG(1)="DMC has received a death notice for the following patient:"
..S MSG(2)=LN_" Date Of Death: "_$E(DDATE,1,2)_"/"_$E(DDATE,3,4)_"/"_$E(DDATE,7,8)
..S MSG(3)="Please follow up locally to have this information entered"
..S MSG(4)="into the local VAMC patient file."
..D ^XMD
..Q
.Q
;
MSG ;SEND LIST OF PATIENTS AUTOMATICALLY DELETED
S ^TMP("RCDMC90S",$J,"REC",1)="The following debtors will not be followed by DMC"
S ^TMP("RCDMC90S",$J,"REC",2)="and are being deleted from the DMC."
S XMSUB="Patients Deleted From DMC: (SEQ. #: "_SEQ_")"
S XMY("G.DMR")="",XMDUZ="AR PACKAGE",XMTEXT="^TMP(""RCDMC90S"","_$J_",""REC"","
D ^XMD
;
;Send list of invalid debtors
I $D(^TMP("RCDMC90S",$J,"BUILD")) D
.S ^TMP("RCDMC90S",$J,"BUILD",1)="The following debtors have invalid debtor numbers"
.S ^TMP("RCDMC90S",$J,"BUILD",2)="Please verify the debtors"
.S ^TMP("RCDMC90S",$J,"BUILD",3)=" "
.S XMSUB="Notice of Invalid Debtor Number"
.S XMY("G.DMR")=""
.S XMDUZ="AR PACKAGE"
.S XMTEXT="^TMP(""RCDMC90S"","_$J_",""BUILD"","
.D ^XMD
.Q
;
CLEANUP ; This cleans up the ^TMP global.
K ^TMP("RCDMC90S",$J)
Q
;
;
DEBT(DEBTOR,SSN) ;CHECK FOR VALID DEBTOR
N DFN,CHK S CHK=0
S DFN=+$G(^RCD(340,DEBTOR,0))
I DFN,SSN=$P($G(^DPT(DFN,0)),U,9) S CHK=1_U_DEBTOR
;
;Find debtor by SSN & match last 6 digits of debtor #
I 'CHK D
.N DEBTOR1
.S DFN=$O(^DPT("SSN",SSN,0))
.I DFN S DEBTOR1=$O(^RCD(340,"B",DFN_";DPT(",0)) D
..I DEBTOR1,$E(DEBTOR1,$L(DEBTOR1)-5,$L(DEBTOR1))=DEBTOR S CHK=1_U_DEBTOR1
DEBTQ Q CHK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDMC90S 3368 printed Nov 22, 2024@16:53:39 Page 2
RCDMC90S ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY (SERVER) ;7/17/97 8:11 AM ; 10/24/96 3:21 PM [ 02/24/97 12:17 PM ]
V ;;4.5;Accounts Receivable;**45,121**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;Program to process server messages from DMC
+3 ;1) Will automatically delete DMC flags from local system for
+4 ; those patients submitted to DMC that are not being followed by
+5 ; DMC
+6 ;2) Will display message to DMX mailgroup when DMC receives a death
+7 ; notice in order that the local site can follow-up and have the
+8 ; death entry entered into the local patient file.
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
+1 KILL ^TMP("RCDMC90S",$JOB)
SET XMA=0
READ1 XECUTE XMREC
IF $DATA(XMER)
if XMER<0
GOTO PROC
+1 SET XMA=XMA+1
+2 SET ^TMP("RCDMC90S",$JOB,"READ",XMA)=XMRG
+3 GOTO READ1
PROC NEW DEBTOR,SSN,DDATE,LN,CNT,I,J,SITE,REC,ND,NAME,TYPE,SEQ,CNTR,LKUP,MSG
+1 NEW XMDUZ,XMSUB,XMY,XMTEXT
+2 KILL XMPOS,XMA,XMER,XMREC,XMRG
+3 SET CNT=2
SET CNTR=3
SET (SEQ,I)=0
+4 FOR
SET I=$ORDER(^TMP("RCDMC90S",$JOB,"READ",I))
if I=""
QUIT
SET ND=$GET(^(I))
Begin DoDot:1
+5 IF $PIECE(ND,U)="DI"
SET SEQ=$PIECE(ND,U,3)
+6 if $PIECE(ND,"^")'?1N.N
QUIT
+7 SET REC=$PIECE(ND,"|")
+8 SET SSN=$PIECE(REC,U,1)
SET DEBTOR=+$PIECE(REC,U,3)
SET DDATE=$PIECE(REC,U,4)
SET TYPE=$PIECE(REC,U,5)
+9 SET LKUP=$$DEBT(DEBTOR,SSN)
+10 ;Invalid debtor check-patch *121
IF 'LKUP
Begin DoDot:2
+11 SET CNTR=CNTR+1
+12 SET ^TMP("RCDMC90S",$JOB,"BUILD",CNTR)=" "_"DEBTOR: "_+$PIECE(REC,U,3)_" SSN: "_$PIECE(REC,U,1)
End DoDot:2
QUIT
+13 SET DEBTOR=$PIECE(LKUP,U,2)
+14 ;
+15 ;Process good debtor numbers
+16 DO CANC3^RCDMC90U(DEBTOR,1)
+17 SET DFN=+$GET(^RCD(340,DEBTOR,0))
SET NAME=$PIECE(^DPT(DFN,0),U)
SET LN=" "_$$LJ^XLFSTR(NAME,30)_" "_SSN
+18 SET CNT=CNT+1
SET ^TMP("RCDMC90S",$JOB,"REC",CNT)=LN_$SELECT(TYPE="01":" INACTIVE BENEFIT",1:" DECEASED")
+19 IF DDATE
Begin DoDot:2
+20 SET XMSUB="Death Notice Received From DMC"
+21 SET XMY("G.DMR")=""
SET XMDUZ="AR PACKAGE"
SET XMTEXT="MSG("
+22 SET MSG(1)="DMC has received a death notice for the following patient:"
+23 SET MSG(2)=LN_" Date Of Death: "_$EXTRACT(DDATE,1,2)_"/"_$EXTRACT(DDATE,3,4)_"/"_$EXTRACT(DDATE,7,8)
+24 SET MSG(3)="Please follow up locally to have this information entered"
+25 SET MSG(4)="into the local VAMC patient file."
+26 DO ^XMD
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
if $PIECE(ND,"|",2)="~"
QUIT
+29 ;
MSG ;SEND LIST OF PATIENTS AUTOMATICALLY DELETED
+1 SET ^TMP("RCDMC90S",$JOB,"REC",1)="The following debtors will not be followed by DMC"
+2 SET ^TMP("RCDMC90S",$JOB,"REC",2)="and are being deleted from the DMC."
+3 SET XMSUB="Patients Deleted From DMC: (SEQ. #: "_SEQ_")"
+4 SET XMY("G.DMR")=""
SET XMDUZ="AR PACKAGE"
SET XMTEXT="^TMP(""RCDMC90S"","_$JOB_",""REC"","
+5 DO ^XMD
+6 ;
+7 ;Send list of invalid debtors
+8 IF $DATA(^TMP("RCDMC90S",$JOB,"BUILD"))
Begin DoDot:1
+9 SET ^TMP("RCDMC90S",$JOB,"BUILD",1)="The following debtors have invalid debtor numbers"
+10 SET ^TMP("RCDMC90S",$JOB,"BUILD",2)="Please verify the debtors"
+11 SET ^TMP("RCDMC90S",$JOB,"BUILD",3)=" "
+12 SET XMSUB="Notice of Invalid Debtor Number"
+13 SET XMY("G.DMR")=""
+14 SET XMDUZ="AR PACKAGE"
+15 SET XMTEXT="^TMP(""RCDMC90S"","_$JOB_",""BUILD"","
+16 DO ^XMD
+17 QUIT
End DoDot:1
+18 ;
CLEANUP ; This cleans up the ^TMP global.
+1 KILL ^TMP("RCDMC90S",$JOB)
+2 QUIT
+3 ;
+4 ;
DEBT(DEBTOR,SSN) ;CHECK FOR VALID DEBTOR
+1 NEW DFN,CHK
SET CHK=0
+2 SET DFN=+$GET(^RCD(340,DEBTOR,0))
+3 IF DFN
IF SSN=$PIECE($GET(^DPT(DFN,0)),U,9)
SET CHK=1_U_DEBTOR
+4 ;
+5 ;Find debtor by SSN & match last 6 digits of debtor #
+6 IF 'CHK
Begin DoDot:1
+7 NEW DEBTOR1
+8 SET DFN=$ORDER(^DPT("SSN",SSN,0))
+9 IF DFN
SET DEBTOR1=$ORDER(^RCD(340,"B",DFN_";DPT(",0))
Begin DoDot:2
+10 IF DEBTOR1
IF $EXTRACT(DEBTOR1,$LENGTH(DEBTOR1)-5,$LENGTH(DEBTOR1))=DEBTOR
SET CHK=1_U_DEBTOR1
End DoDot:2
End DoDot:1
DEBTQ QUIT CHK
