RCDMB1MT ;ALB/MR-REPAYMENT PLAN MONITOR ;16-AUG-00
;;4.5;Accounts Receivable;**167,171,188**;Mar 20, 1995
;
EN ; - Entry point for this program (Called by PRCABJ - AR Nightly Process)
N BILL,CNT,DATA,DFN,FLG,I,J,LINE,RCPT,PTDA,RCAR,RCAT,RCDA,RCDB,RCRP,RPDT
N TXT,TYPE,X
;
K ^TMP("RCDMBDAT",$J)
;
; - Find data required for report.
S RCDA=""
F S RCDA=$O(^PRCA(430,"AC",16,RCDA)) Q:'RCDA D
. S RCAR=$G(^PRCA(430,RCDA,0)) Q:'RCAR
. I '$P($G(^PRCA(430,RCDA,4)),"^") Q ; No Repayment Plan
. S RCAT=+$P(RCAR,"^",2) ; Gets AR category.
. S RCDB=$P(RCAR,"^",9) ; Gets the pointer to the Debtor file (#340)
. S RCPT=$$PAT(RCDB) Q:RCPT="" ; Gets patient info.
. S DFN=$P(RCPT,"^",4) ; Gets the pointer to the Patient file (#2)
. S RCRP=$$RP(RCDA,RCDB) ; Defaulted Repymt.Plan/New Bill entered
. I 'RCRP,'$P(RCRP,"^",2) Q ; Neither case was found
. ;
. ; - Sets the temporary global
. I $P(RCRP,"^") D ; Defaulted on the Repayment Plan
. . S ^TMP("RCDMBDAT",$J,1,DFN)=RCPT
. . S ^TMP("RCDMBDAT",$J,1,DFN,$P(RCAR,"^"))=""
. I $P(RCRP,"^",2) D ; Had a new bill entered
. . S ^TMP("RCDMBDAT",$J,2,DFN)=RCPT
. . S X=""
. . F S X=$O(^TMP("RCDMBDAT",$J,"BILL",X)) Q:X="" D
. . . S ^TMP("RCDMBDAT",$J,2,DFN,X)=""
. . K ^TMP("RCDMBDAT",$J,"BILL")
;
; - No cases to report were found
S LINE=0 I '$D(^TMP("RCDMBDAT",$J)) G SND
;
; - Formats and set the data on ^TMP("RCDMBMSG",$J)
K ^TMP("RCDMBMSG",$J)
S (TYPE,PTDA,BILL)="",LINE=1
F S TYPE=$O(^TMP("RCDMBDAT",$J,TYPE)) Q:TYPE="" D
. ;
. ; - Prints the Header (Name SSN...) and updates LINE
. D HDR(TYPE,.LINE) S CNT=0
. F S PTDA=$O(^TMP("RCDMBDAT",$J,TYPE,PTDA)) Q:PTDA="" D
. . S DATA=$G(^TMP("RCDMBDAT",$J,TYPE,PTDA))
. . S CNT=CNT+1,X=""
. . S $E(X,1)=$P(DATA,"^") ; Debtor Name
. . S $E(X,38)=$P(DATA,"^",2) ; SSN
. . S $E(X,51)=$P(DATA,"^",3) ; Phone Number
. . S FLG=0 I $P(DATA,"^",5)'="" S FLG=1 ; Date of Death
. . F S BILL=$O(^TMP("RCDMBDAT",$J,TYPE,PTDA,BILL)) Q:BILL="" D
. . . I FLG,X="" S $E(X,6)="DOD: "_$P(DATA,"^",5),FLG=0
. . . S $E(X,65)=BILL ; Bill Number
. . . S ^TMP("RCDMBMSG",$J,LINE)=X,X=""
. . . S LINE=LINE+1
. . I FLG D
. . . S ^TMP("RCDMBMSG",$J,LINE)=" DOD: "_$P(DATA,"^",5)
. . . S LINE=LINE+1
. I CNT'>1 Q
. S ^TMP("RCDMBMSG",$J,LINE)="",LINE=LINE+1 ; Skip a line
. S ^TMP("RCDMBMSG",$J,LINE)="Total of "_CNT_" debtor(s)",LINE=LINE+1
. S ^TMP("RCDMBMSG",$J,LINE)="",LINE=LINE+1 ; Skip a line
;
SND ; - If one of the two situations or none of them were found, it will
; informed in the e-mail
;
F I=1,2 D
. I $D(^TMP("RCDMBDAT",$J,I)) Q
. F J=1:1:3 S LINE=LINE+1,^TMP("RCDMBMSG",$J,LINE)=""
. I I=1 D Q
. . S ^TMP("RCDMBMSG",$J,LINE)="There were no debtors who defaulted on their repayment plan yesterday."
. S ^TMP("RCDMBMSG",$J,LINE)="There were no debtors with repayment plans who had new active bills yesterday."
;
D XMD ; Sends the Mailman message
;
ENQ K ^TMP("RCDMBDAT",$J),^TMP("RCDMBMSG",$J)
Q
;
XMD ; Sets the Mailman variables and send the message
N DUZ,XMSUB,XMDUZ,XMY,XMDUN,XMMG,XMSCR,XMTEXT,XMZ
;
S XMSUB="AR REPAYMENT PLAN MONITOR",XMDUZ="AR PACKAGE"
S XMY("G.RC REPAY PLANS")="",XMTEXT="^TMP(""RCDMBMSG"","_$J_","
;
D ^XMD
;
Q
;
PAT(DEB) ; - Returns Debtor information
; Input: DEB=AR pointer to Debtor file (#340)
; Output: Name ^ SSN ^ Phone Number ^ Pointer to Patient file ^
; Date of Death (MM/DD/YY)
;
N DEATH,DEBTOR,DFN,NAME,PHONE,SSN,VA,VADM,VAERR,VAPA
I 'DEB Q ""
S DEBTOR=$G(^RCD(340,DEB,0)) I $P(DEBTOR,"^")'["DPT" Q ""
S DFN=+DEBTOR
D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),DEATH=$P(VADM(6),".")
I DEATH'="" S DEATH=$$DAT(DEATH)
D ADD^VADPT S PHONE=VAPA(8)
;
Q (NAME_"^"_SSN_"^"_PHONE_"^"_DFN_"^"_DEATH)
;
RP(X,DEB) ; - Checks if a Repayment Plan became defaulted or if a new
; bill has been entered to a patient under a Repayment Plan established
; Input: X=Pointer to the AR file #430
; DEB=Pointer to the Detor file #340
; Output: Y=Defaulted? (1-YES/0-NO) ^ New bill entered? (1-YES/0-NO) ^
; Bill(s) # separated by "," (If piece 2 = 1)
;
N ARZ,DEF,ELM,I,NEW,NPMT,RCBL,RP,YST
;
S (DEF,NEW)=0
S RP=$G(^PRCA(430,X,4)),NPMT=$P(RP,"^",4),YST=$$HTFM^XLFDT($H-1,1)
;
; - Checks if the patient defaulted on his Repayment Plan
F I=1:1:NPMT D Q:DEF
. S ELM=$G(^PRCA(430,X,5,I,0)) Q:ELM=""
. I $P(ELM,"^",2) Q
. I $$FMDIFF^XLFDT(YST,$P(ELM,"^"))=1 D Q
. . S DEF=1
;
; Checks if a Bill became active for the debtor yesterday
S RCBL=""
F S RCBL=$O(^PRCA(430,"C",DEB,RCBL)) Q:RCBL="" D
. I RCBL=X Q
. S ARZ=$G(^PRCA(430,RCBL,0))
. I $P(ARZ,"^",8)'=16!($P(ARZ,"^",14)'=YST) Q
. S NEW=1,^TMP("RCDMBDAT",$J,"BILL",$P($G(^PRCA(430,RCBL,0)),"^"))=""
Q (DEF_"^"_NEW)
;
HDR(TP,LN) ; Sets the temporary global with the header of the E-mail
; Input: TP=Type of problem (1-Defaulted / 2-New bill)
; LN=Next line to be set on the ^TMP("RCDMBMSG",$J,LN) global
;
N X,I
I TP=1 D
. S ^TMP("RCDMBMSG",$J,LN)="The following debtors just defaulted on a Repayment Plan by not making a"
. S LN=LN+1
. S ^TMP("RCDMBMSG",$J,LN)="scheduled payment on or before the scheduled payment date: "
I TP=2 D
. F I=1,2 S ^TMP("RCDMBMSG",$J,LN)="",LN=LN+1
. S ^TMP("RCDMBMSG",$J,LN)="The following debtors with a Repayment Plan had a new active bill entered: "
;
S LN=LN+1,^TMP("RCDMBMSG",$J,LN)=""
S X="",$E(X,1)="Name",$E(X,38)="SSN",$E(X,51)="Phone Number"
S $E(X,65)=$S(TP=1:"Bill",1:"New Bill")
S LN=LN+1,^TMP("RCDMBMSG",$J,LN)=X
S X="",$P(X,"=",79)="" S LN=LN+1,^TMP("RCDMBMSG",$J,LN)=X
S LN=LN+1
Q
;
DAT(DAT) ;Changes date from FM to MM/DD/YYYY
N YR
S YR=DAT\10000+1700
Q $E(DAT,4,5)_"/"_$E(DAT,6,7)_"/"_YR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDMB1MT 5946 printed Nov 22, 2024@16:53:33 Page 2
RCDMB1MT ;ALB/MR-REPAYMENT PLAN MONITOR ;16-AUG-00
+1 ;;4.5;Accounts Receivable;**167,171,188**;Mar 20, 1995
+2 ;
EN ; - Entry point for this program (Called by PRCABJ - AR Nightly Process)
+1 NEW BILL,CNT,DATA,DFN,FLG,I,J,LINE,RCPT,PTDA,RCAR,RCAT,RCDA,RCDB,RCRP,RPDT
+2 NEW TXT,TYPE,X
+3 ;
+4 KILL ^TMP("RCDMBDAT",$JOB)
+5 ;
+6 ; - Find data required for report.
+7 SET RCDA=""
+8 FOR
SET RCDA=$ORDER(^PRCA(430,"AC",16,RCDA))
if 'RCDA
QUIT
Begin DoDot:1
+9 SET RCAR=$GET(^PRCA(430,RCDA,0))
if 'RCAR
QUIT
+10 ; No Repayment Plan
IF '$PIECE($GET(^PRCA(430,RCDA,4)),"^")
QUIT
+11 ; Gets AR category.
SET RCAT=+$PIECE(RCAR,"^",2)
+12 ; Gets the pointer to the Debtor file (#340)
SET RCDB=$PIECE(RCAR,"^",9)
+13 ; Gets patient info.
SET RCPT=$$PAT(RCDB)
if RCPT=""
QUIT
+14 ; Gets the pointer to the Patient file (#2)
SET DFN=$PIECE(RCPT,"^",4)
+15 ; Defaulted Repymt.Plan/New Bill entered
SET RCRP=$$RP(RCDA,RCDB)
+16 ; Neither case was found
IF 'RCRP
IF '$PIECE(RCRP,"^",2)
QUIT
+17 ;
+18 ; - Sets the temporary global
+19 ; Defaulted on the Repayment Plan
IF $PIECE(RCRP,"^")
Begin DoDot:2
+20 SET ^TMP("RCDMBDAT",$JOB,1,DFN)=RCPT
+21 SET ^TMP("RCDMBDAT",$JOB,1,DFN,$PIECE(RCAR,"^"))=""
End DoDot:2
+22 ; Had a new bill entered
IF $PIECE(RCRP,"^",2)
Begin DoDot:2
+23 SET ^TMP("RCDMBDAT",$JOB,2,DFN)=RCPT
+24 SET X=""
+25 FOR
SET X=$ORDER(^TMP("RCDMBDAT",$JOB,"BILL",X))
if X=""
QUIT
Begin DoDot:3
+26 SET ^TMP("RCDMBDAT",$JOB,2,DFN,X)=""
End DoDot:3
+27 KILL ^TMP("RCDMBDAT",$JOB,"BILL")
End DoDot:2
End DoDot:1
+28 ;
+29 ; - No cases to report were found
+30 SET LINE=0
IF '$DATA(^TMP("RCDMBDAT",$JOB))
GOTO SND
+31 ;
+32 ; - Formats and set the data on ^TMP("RCDMBMSG",$J)
+33 KILL ^TMP("RCDMBMSG",$JOB)
+34 SET (TYPE,PTDA,BILL)=""
SET LINE=1
+35 FOR
SET TYPE=$ORDER(^TMP("RCDMBDAT",$JOB,TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+36 ;
+37 ; - Prints the Header (Name SSN...) and updates LINE
+38 DO HDR(TYPE,.LINE)
SET CNT=0
+39 FOR
SET PTDA=$ORDER(^TMP("RCDMBDAT",$JOB,TYPE,PTDA))
if PTDA=""
QUIT
Begin DoDot:2
+40 SET DATA=$GET(^TMP("RCDMBDAT",$JOB,TYPE,PTDA))
+41 SET CNT=CNT+1
SET X=""
+42 ; Debtor Name
SET $EXTRACT(X,1)=$PIECE(DATA,"^")
+43 ; SSN
SET $EXTRACT(X,38)=$PIECE(DATA,"^",2)
+44 ; Phone Number
SET $EXTRACT(X,51)=$PIECE(DATA,"^",3)
+45 ; Date of Death
SET FLG=0
IF $PIECE(DATA,"^",5)'=""
SET FLG=1
+46 FOR
SET BILL=$ORDER(^TMP("RCDMBDAT",$JOB,TYPE,PTDA,BILL))
if BILL=""
QUIT
Begin DoDot:3
+47 IF FLG
IF X=""
SET $EXTRACT(X,6)="DOD: "_$PIECE(DATA,"^",5)
SET FLG=0
+48 ; Bill Number
SET $EXTRACT(X,65)=BILL
+49 SET ^TMP("RCDMBMSG",$JOB,LINE)=X
SET X=""
+50 SET LINE=LINE+1
End DoDot:3
+51 IF FLG
Begin DoDot:3
+52 SET ^TMP("RCDMBMSG",$JOB,LINE)=" DOD: "_$PIECE(DATA,"^",5)
+53 SET LINE=LINE+1
End DoDot:3
End DoDot:2
+54 IF CNT'>1
QUIT
+55 ; Skip a line
SET ^TMP("RCDMBMSG",$JOB,LINE)=""
SET LINE=LINE+1
+56 SET ^TMP("RCDMBMSG",$JOB,LINE)="Total of "_CNT_" debtor(s)"
SET LINE=LINE+1
+57 ; Skip a line
SET ^TMP("RCDMBMSG",$JOB,LINE)=""
SET LINE=LINE+1
End DoDot:1
+58 ;
SND ; - If one of the two situations or none of them were found, it will
+1 ; informed in the e-mail
+2 ;
+3 FOR I=1,2
Begin DoDot:1
+4 IF $DATA(^TMP("RCDMBDAT",$JOB,I))
QUIT
+5 FOR J=1:1:3
SET LINE=LINE+1
SET ^TMP("RCDMBMSG",$JOB,LINE)=""
+6 IF I=1
Begin DoDot:2
+7 SET ^TMP("RCDMBMSG",$JOB,LINE)="There were no debtors who defaulted on their repayment plan yesterday."
End DoDot:2
QUIT
+8 SET ^TMP("RCDMBMSG",$JOB,LINE)="There were no debtors with repayment plans who had new active bills yesterday."
End DoDot:1
+9 ;
+10 ; Sends the Mailman message
DO XMD
+11 ;
ENQ KILL ^TMP("RCDMBDAT",$JOB),^TMP("RCDMBMSG",$JOB)
+1 QUIT
+2 ;
XMD ; Sets the Mailman variables and send the message
+1 NEW DUZ,XMSUB,XMDUZ,XMY,XMDUN,XMMG,XMSCR,XMTEXT,XMZ
+2 ;
+3 SET XMSUB="AR REPAYMENT PLAN MONITOR"
SET XMDUZ="AR PACKAGE"
+4 SET XMY("G.RC REPAY PLANS")=""
SET XMTEXT="^TMP(""RCDMBMSG"","_$JOB_","
+5 ;
+6 DO ^XMD
+7 ;
+8 QUIT
+9 ;
PAT(DEB) ; - Returns Debtor information
+1 ; Input: DEB=AR pointer to Debtor file (#340)
+2 ; Output: Name ^ SSN ^ Phone Number ^ Pointer to Patient file ^
+3 ; Date of Death (MM/DD/YY)
+4 ;
+5 NEW DEATH,DEBTOR,DFN,NAME,PHONE,SSN,VA,VADM,VAERR,VAPA
+6 IF 'DEB
QUIT ""
+7 SET DEBTOR=$GET(^RCD(340,DEB,0))
IF $PIECE(DEBTOR,"^")'["DPT"
QUIT ""
+8 SET DFN=+DEBTOR
+9 DO DEM^VADPT
SET NAME=VADM(1)
SET SSN=$PIECE(VADM(2),"^",2)
SET DEATH=$PIECE(VADM(6),".")
+10 IF DEATH'=""
SET DEATH=$$DAT(DEATH)
+11 DO ADD^VADPT
SET PHONE=VAPA(8)
+12 ;
+13 QUIT (NAME_"^"_SSN_"^"_PHONE_"^"_DFN_"^"_DEATH)
+14 ;
RP(X,DEB) ; - Checks if a Repayment Plan became defaulted or if a new
+1 ; bill has been entered to a patient under a Repayment Plan established
+2 ; Input: X=Pointer to the AR file #430
+3 ; DEB=Pointer to the Detor file #340
+4 ; Output: Y=Defaulted? (1-YES/0-NO) ^ New bill entered? (1-YES/0-NO) ^
+5 ; Bill(s) # separated by "," (If piece 2 = 1)
+6 ;
+7 NEW ARZ,DEF,ELM,I,NEW,NPMT,RCBL,RP,YST
+8 ;
+9 SET (DEF,NEW)=0
+10 SET RP=$GET(^PRCA(430,X,4))
SET NPMT=$PIECE(RP,"^",4)
SET YST=$$HTFM^XLFDT($HOROLOG-1,1)
+11 ;
+12 ; - Checks if the patient defaulted on his Repayment Plan
+13 FOR I=1:1:NPMT
Begin DoDot:1
+14 SET ELM=$GET(^PRCA(430,X,5,I,0))
if ELM=""
QUIT
+15 IF $PIECE(ELM,"^",2)
QUIT
+16 IF $$FMDIFF^XLFDT(YST,$PIECE(ELM,"^"))=1
Begin DoDot:2
+17 SET DEF=1
End DoDot:2
QUIT
End DoDot:1
if DEF
QUIT
+18 ;
+19 ; Checks if a Bill became active for the debtor yesterday
+20 SET RCBL=""
+21 FOR
SET RCBL=$ORDER(^PRCA(430,"C",DEB,RCBL))
if RCBL=""
QUIT
Begin DoDot:1
+22 IF RCBL=X
QUIT
+23 SET ARZ=$GET(^PRCA(430,RCBL,0))
+24 IF $PIECE(ARZ,"^",8)'=16!($PIECE(ARZ,"^",14)'=YST)
QUIT
+25 SET NEW=1
SET ^TMP("RCDMBDAT",$JOB,"BILL",$PIECE($GET(^PRCA(430,RCBL,0)),"^"))=""
End DoDot:1
+26 QUIT (DEF_"^"_NEW)
+27 ;
HDR(TP,LN) ; Sets the temporary global with the header of the E-mail
+1 ; Input: TP=Type of problem (1-Defaulted / 2-New bill)
+2 ; LN=Next line to be set on the ^TMP("RCDMBMSG",$J,LN) global
+3 ;
+4 NEW X,I
+5 IF TP=1
Begin DoDot:1
+6 SET ^TMP("RCDMBMSG",$JOB,LN)="The following debtors just defaulted on a Repayment Plan by not making a"
+7 SET LN=LN+1
+8 SET ^TMP("RCDMBMSG",$JOB,LN)="scheduled payment on or before the scheduled payment date: "
End DoDot:1
+9 IF TP=2
Begin DoDot:1
+10 FOR I=1,2
SET ^TMP("RCDMBMSG",$JOB,LN)=""
SET LN=LN+1
+11 SET ^TMP("RCDMBMSG",$JOB,LN)="The following debtors with a Repayment Plan had a new active bill entered: "
End DoDot:1
+12 ;
+13 SET LN=LN+1
SET ^TMP("RCDMBMSG",$JOB,LN)=""
+14 SET X=""
SET $EXTRACT(X,1)="Name"
SET $EXTRACT(X,38)="SSN"
SET $EXTRACT(X,51)="Phone Number"
+15 SET $EXTRACT(X,65)=$SELECT(TP=1:"Bill",1:"New Bill")
+16 SET LN=LN+1
SET ^TMP("RCDMBMSG",$JOB,LN)=X
+17 SET X=""
SET $PIECE(X,"=",79)=""
SET LN=LN+1
SET ^TMP("RCDMBMSG",$JOB,LN)=X
+18 SET LN=LN+1
+19 QUIT
+20 ;
DAT(DAT) ;Changes date from FM to MM/DD/YYYY
+1 NEW YR
+2 SET YR=DAT\10000+1700
+3 QUIT $EXTRACT(DAT,4,5)_"/"_$EXTRACT(DAT,6,7)_"/"_YR
