RCTOPD ;WASH IRMFO/ALTOONA,PA/TJK - TOP TRANSMISSION ;2/11/00 3:34 PM
V ;;4.5;Accounts Receivable;**141,187,224,236,229,301,315,337,338,343**;Mar 20, 1995;Build 59
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*337 Keep XTMP work file for 5 days
;
ENTER ;Entry point from nightly process
Q:'$D(RCDOC)
N DEBTOR,BILL,DEBTOR0,B0,B6,B7,RC151DT,PRIN,INT,ADMIN,B4,B14 ;PRCA*4.5*343 - P121DT change to P151DT - previously changed by *315
N EFFDT,DFN,CNTR,SITE,LN,FN,MN,DOB,SITE,F60DT,VADM,DEBTOR4,DEBTOR6
N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,RCNT,REPAY,X1,X2
N ERROR,ADDR,CAT,BILLDT,P10YDT,CURRTOT,HOLD,SITECD,RCNEW,ACTDT
;
;initialize temporary global, variables
;
K ^XTMP("RCTOPD") S ^XTMP("RCTOPD",0)=$$FMADD^XLFDT(DT,5)_"^"_DT ;PRCA*4.5*315 Allow global to be purged in 5 days
S SITE=$E($$SITE^RCMSITE(),1,3),SITECD=$P(^RC(342,1,3),U,5)
S X1=DT,X2=-151 D C^%DTC S (RC151DT,EFFDT)=X ; PRCA*4.5*343 - change from 121 to 151 days
S X1=DT,X2=-3650 D C^%DTC S P10YDT=X
S X1=DT,X2=+60 D C^%DTC S F60DT=X
S ACTDT=3150801 ;activation date for all sites except beckley, little rock, upstate ny
S:SITE=598 ACTDT=3150201 ;activation date for little rock
S:SITE=517 ACTDT=3150201 ;activation date for beckley
S:SITE=528 ACTDT=3150201 ;activation date for upstate ny
S (CNTR(1),CNTR(2),CNTR(4),DEBTOR,RCNT)=0
;
;branch if recertification document
I RCDOC="Y" D RECERT G EXIT
;
;branch to do update documents
D UPDATE I RCDOC="U" G EXIT
;
;master sheet compilation
;
F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D
.N X,RCDFN
.S RCDFN=$G(^RCD(340,DEBTOR,0))
.I $P(RCDFN,";",2)["DPT",$$EMERES^PRCAUTL(+RCDFN)]"" Q ;stop the master sheet compilation for hurricane Katrina sites (patients)
.Q:$D(^RCD(340,"TOP",DEBTOR))
.; quit if debtor address marked unknown
.Q:$P($G(^RCD(340,+DEBTOR,1)),"^",9)=1
.S DEBTOR6=$G(^RCD(340,DEBTOR,6)),DEBTOR0=$G(^(0)),HOLD=0,RCNEW=1
.I $P(DEBTOR6,U,2),'$P(DEBTOR6,U,3) Q
.S QUIT=1,FILE=$$FILE(DEBTOR0) Q:'FILE
.S EFFDT=RC151DT
.D PROC(DEBTOR,.QUIT,FILE,.HOLD,.EFFDT) Q:QUIT
.D EN1^RCTOP2(DEBTOR,"M",FILE)
.D EN1^RCTOP1(DEBTOR,TOTAL,"M",EFFDT,0,FILE)
.;set hold date in file for employee, ex-employee, vendor records
.;Austin holds these for 60 days before transmitting to TOP
.I $G(HOLD) S $P(^RCD(340,DEBTOR,6),U,6)=F60DT
.Q
;compile documents into mail messages--sets referral date in 430
D COMPILE
EXIT K RCDOC,^TMP("RCTOPD"),XMDUZ D KVAR^VADPT
Q
;
UPDATE ;weekly update compilation
F S DEBTOR=$O(^RCD(340,"TOP",DEBTOR)) Q:DEBTOR'?1N.N D
.S QUIT=1,DEBTOR0=^RCD(340,DEBTOR,0),DEBTOR6=^(6),DEBTOR4=^(4),FILE=$$FILE(DEBTOR0),EFFDT=$P(DEBTOR4,U,6),RCNEW=0
.D EN1^RCTOP2(DEBTOR,"U",FILE)
.D PROC(DEBTOR,.QUIT,FILE,0,.EFFDT) I QUIT D Q
..;process type 4 document if necessary
..S TAXID=$$TAXID^RCTOP1(DEBTOR,FILE),OTAXID=$P(DEBTOR4,U)
..S NAME=$$NAME^RCTOP1(+DEBTOR0,FILE),ONAME=$P(DEBTOR4,U,2),NAME=$P(NAME,U)
..I NAME=ONAME,TAXID=OTAXID Q
..D EN1^RCTOP4(NAME,TAXID,DEBTOR4,DEBTOR,FILE)
..Q
.D EN1^RCTOP1(DEBTOR,TOTAL,"U",EFFDT,0,FILE)
.Q
;refund/refund reversal documents
D REFDOC
;compile documents into mail messages--sets referral date in 430
D:$G(RCDOC)="U" COMPILE
Q
;
RECERT ;send yearly recertification documents
F S DEBTOR=$O(^RCD(340,"TOP",DEBTOR)) Q:DEBTOR'?1N.N D
.S DEBTOR4=$G(^RCD(340,DEBTOR,4)),TOTAL=$P(DEBTOR4,U,3),EFFDT=$P(DEBTOR4,U,6),DEBTOR0=$G(^(0)),FILE=$$FILE(DEBTOR0)
.I TOTAL D EN1^RCTOP1(DEBTOR,TOTAL,"Y",EFFDT,0,FILE)
.Q
;compile documents into mail messages
D COMPILE
Q
;
REFDOC ; refund, refund reversal documents
N CODE,BILL,DEBTOR,TOTAL,EFFDT,FILE,RFCODE
F RFCODE=1,3 S CODE=$S(RFCODE=1:"R",1:"RV") D
.S BILL=0 F S BILL=$O(^PRCA(430,"TREF",RFCODE,BILL)) Q:'BILL D
..S DEBTOR=$P($G(^PRCA(430,BILL,0)),U,9) Q:'DEBTOR
..S TOTAL=$P($G(^(7)),U,18) Q:'TOTAL ;NAKED TO LINE ABOVE
..S EFFDT=$P($G(^RCD(340,+DEBTOR,4)),U,6),FILE=$$FILE(^(0))
..D EN1^RCTOP1(DEBTOR,TOTAL,CODE,EFFDT,BILL,FILE)
..Q
.Q
Q
;
COMPILE ;compiles documents into mail messages and transmits them
;builds message array
N CNT,SEQ,REC,XMDUZ,DOCTYPE,LRTYPE,XMSUB,XMTEXT,XMY,TSEQ,DOCAMT
S (SEQ,TSEQ)=0
F I=1,2,4 S TSEQ=TSEQ+($G(CNTR(I))\150)+$S($G(CNTR(I))#150:1,1:0)
F DOCTYPE=1,2,4 D:$D(^XTMP("RCTOPD",$J,DOCTYPE)) COMPILE1(DOCTYPE,CNTR(DOCTYPE))
D USRMSG
Q
COMPILE1(DOCTYPE,CNTR) ; compiles each type of document separately
S RCNT=RCNT+CNTR
I '$G(LRTYPE) F I=1,2,4 S:$D(^XTMP("RCTOPD",$J,I)) LRTYPE=I
F CNT=1:1:CNTR D
.D:CNT#150=1
..K ^XTMP("RCTOPD",$J,"BUILD") S SEQ=SEQ+1
..S REC=1,DOCAMT=0
..Q
.S REC=REC+1,^XTMP("RCTOPD",$J,"BUILD",REC)=^XTMP("RCTOPD",$J,DOCTYPE,CNT)_U S:DOCTYPE=1 DOCAMT=DOCAMT+($E(^(REC),135,146)/100)
.I CNTR=CNT,LRTYPE=DOCTYPE S ^XTMP("RCTOPD",$J,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_RCNT
.I $S(CNTR=CNT:1,CNT#150=0:1,1:0) D
..S ^XTMP("RCTOPD",$J,"BUILD",1)=SITE_U_$TR($J(SEQ,2)," ",0)_U_$TR($J(TSEQ,2)," ",0)_U_(REC-1)_U_DOCAMT_U
..S XMDUZ="AR PACKAGE"
..S XMY("XXX@Q-TOP.DOMAIN.EXT")=""
..S XMY("G.TOP")=""
..S XMSUB=SITE_"/TOP TRANSMISSION/SEQ#: "_SEQ_"/"_$$NOW()
..S XMTEXT="^XTMP(""RCTOPD"","_$J_",""BUILD"","
..D ^XMD
..Q
.Q
Q
;
USRMSG ;sends mailman message of documents sent to user
N XMY,XMDUZ,XMSUB,X,RCNT
S XMDUZ="AR PACKAGE",XMY("G.TOP")=""
S XMSUB="TOP "_$S(RCDOC="M":"MASTER/UPDATE",RCDOC="U":"UPDATE",1:"RECERTIFICATION")_" RECORDS SENT ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S ^XTMP("RCTOPD",$J,"REC1",1)="Name TIN TYPE AMOUNT"
S ^XTMP("RCTOPD",$J,"REC1",2)="---- --- ---- ------"
S X="",RCNT=3 F S X=$O(^XTMP("RCTOPD",$J,"REC",X)) Q:X="" S ^XTMP("RCTOPD",$J,"REC1",RCNT)=^(X),RCNT=RCNT+1
S ^XTMP("RCTOPD",$J,"REC1",RCNT)="Total Records: "_(RCNT-3)
S XMTEXT="^XTMP(""RCTOPD"","_$J_",""REC1"","
D ^XMD
;
THIRD ;sends mailman message to user if no third letter found
Q:'$D(^XTMP("RCTOPD",$J,"THIRD"))
K ^XTMP("RCTOPD",$J,"REC1")
S XMDUZ="AR PACKAGE",XMY("G.TOP")=""
N TCT,TDEB,TDEB0,TBIL,TSP,FST
S XMSUB="TOP QUALIFIED/NO 3RD LETTER SENT ON "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
S ^XTMP("RCTOPD",$J,"REC1",1)="The following list of debtor bills were not sent to TOP."
S ^XTMP("RCTOPD",$J,"REC1",2)="Please review debtor's account to determine why the third"
S ^XTMP("RCTOPD",$J,"REC1",3)="notice letter has not been sent:"
S ^XTMP("RCTOPD",$J,"REC1",4)="Name Bill #"
S ^XTMP("RCTOPD",$J,"REC1",5)="---- ------"
S TCT=6,TSP=0,TDEB=""
F S TDEB=$O(^XTMP("RCTOPD",$J,"THIRD",TDEB)) Q:TDEB="" D
.S FST=1,TBIL=""
.I FST,TCT'=6 S ^XTMP("RCTOPD",$J,"REC1",TCT)="",TCT=TCT+1,TSP=TSP+1
.F S TBIL=$O(^XTMP("RCTOPD",$J,"THIRD",TDEB,TBIL)) Q:TBIL="" D
..S TDEB0=$S(FST:TDEB,1:"")
..S ^XTMP("RCTOPD",$J,"REC1",TCT)=TDEB0_$J(" ",35-$L(TDEB0))_TBIL
..S TCT=TCT+1,FST=0
S ^XTMP("RCTOPD",$J,"REC1",TCT)="Total records: "_(TCT-(6+TSP))
S XMTEXT="^XTMP(""RCTOPD"","_$J_",""REC1"","
D ^XMD
COMPQ Q
;
PROC(DEBTOR,QUIT,FILE,HOLD,EFFDT) ;process bills for a specific debtor
K ^TMP("RCTOPD",$J,"BILL")
S DEBTOR0=$G(^RCD(340,DEBTOR,0))
Q:'FILE
I FILE=2 S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000"
S (BILL,TOTAL,REPAY)=0
I RCNEW,FILE=440 S HOLD=1
I 'RCNEW,$P(^RCD(340,DEBTOR,6),U,2),'$P(^(6),U,3) G TOTAL
I RCNEW,$D(^RCD(340,"DMC",1,DEBTOR)) G TOTAL
F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D
.I FILE=2,+VADM(6) S TOTAL=0,REPAY=1 Q
.S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B14=$G(^(14))
.Q:$P(B0,U,8)'=16
.Q:B4
.Q:'$P(B0,U,2)
.S CAT=$P($G(^PRCA(430.2,$P(B0,U,2),0)),U,7)
.;*** PRCA*4.5*338 start
.Q:'CAT
.;Check the Refer to TOP field to see if this should be referred, based on AR Category
.;S BILLDT=$P(B6,U,21) ; PRCA*4.5*343 - change BILLDT to LETTER1(#61) field
.Q:'$$RFCHK(CAT,"N",1.02,$P(B6,U,21)) ;PRCA*4.5*338
.;*** PRCA*4.5*338 end
.Q:$D(^PRCA(430,"TCSP",BILL)) ;cross-serviced bills
.;check for DOJ referral here
.I $P(B6,U,4),($P(B6,U,5)="DOJ") Q
.S BILLDT=$P(B6,U,1) I (BILLDT<P10YDT)!(BILLDT>RC151DT)!(BILLDT<$P(DEBTOR6,U,3)) Q ; PRCA*4.5*343 - change BILLDT from DATE ACCOUNT ACTIVATED (#60) to LETTER1(#61)
.I '$P(B6,U,3) D Q
..;no 3rd letter being sent
..N TDEB,TFIL
..S TDEB=$G(^RCD(340,DEBTOR,0)),TFIL=$$FILE(TDEB),TDEB=$$NAME^RCTOP1(+TDEB,TFIL),TDEB=$P(TDEB,U,2),^XTMP("RCTOPD",$J,"THIRD",TDEB,$P(B0,U))=""
.I RCNEW,CAT>12,CAT<15 S HOLD=1
.I BILLDT,BILLDT<EFFDT S EFFDT=BILLDT
.S TOTAL=TOTAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5)
.S ^TMP("RCTOPD",$J,"BILL",BILL)=""
.Q
;
TOTAL ;set transmission total, reset quit variable
N RCSWINFO S RCSWINFO=$$SWSTAT^IBBAPI() ;PRCA*4.5*229
I RCNEW,'+RCSWINFO Q:TOTAL<25 ;PRCA*4.5*229
I RCNEW,+RCSWINFO Q:TOTAL'>0 ;PRCA*4.5*229
;
I 'RCNEW S:TOTAL<25 TOTAL=0 S CURRTOT=$P($G(^RCD(340,DEBTOR,4)),U,3) Q:CURRTOT=TOTAL S TOTAL=TOTAL-CURRTOT
S QUIT=0
PROCQ Q
;
NOW() ;compiles current date,time
N X,Y,%,%H
S %H=$H D YX^%DTC
Q Y
;
FILE(DEBTOR0) ;gets file number for debtor
S FILE=$P($P(DEBTOR0,U),";",2)
S FILE=$S(FILE["DPT(":2,FILE["PRC(440":440,FILE["VA(200":200,1:0)
FILEQ Q FILE
;
;PRCA*4.5*338
RFCHK(RCXCAT,RCIENFLG,RCXRFCD,RCXDT) ;Check to see if bill can be referred to requested collections program
;
;Input:
; RCXCAT - (Required) AR Category to check.
; RCXIENFLG - Is the AR Category an IEN (I) or a number (N).
; RCXRFCD - (Required) FileMan Field number for the Referral type being checked.
; 1.01 - DMC
; 1.02 - TOP
; 1.03 - CS
; RCXDT - (Required) Date of service to be checked.
;
N RCXFLG,RCXCTIEN,RCXSPDT
;
; Set the initial split date for the TOP and CS referral programs
S RCXSPDT=3150801
; Get the category IEN.
S RCXCTIEN=RCXCAT ;Initially assume it is an IEN
; Update to IEN if AR Category is the Category Number
I RCIENFLG="N" S RCXCTIEN=$O(^PRCA(430.2,"AC",RCXCAT,""))
; Quit if Category not found
Q:RCXCTIEN="" 0
;
; Extract the flag for the category from the AR Category file (430.2), using the field number sent in
S RCXCTIEN=RCXCTIEN_","
S RCXFLG=$$GET1^DIQ(430.2,RCXCTIEN,RCXRFCD,"I")
I RCXFLG<2 Q RCXFLG
I RCXFLG=2,(RCXDT<RCXSPDT) Q 1
I RCXFLG=3,(RCXDT'<RCXSPDT) Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTOPD 10880 printed Nov 22, 2024@16:59:18 Page 2
RCTOPD ;WASH IRMFO/ALTOONA,PA/TJK - TOP TRANSMISSION ;2/11/00 3:34 PM
V ;;4.5;Accounts Receivable;**141,187,224,236,229,301,315,337,338,343**;Mar 20, 1995;Build 59
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRCA*4.5*337 Keep XTMP work file for 5 days
+4 ;
ENTER ;Entry point from nightly process
+1 if '$DATA(RCDOC)
QUIT
+2 ;PRCA*4.5*343 - P121DT change to P151DT - previously changed by *315
NEW DEBTOR,BILL,DEBTOR0,B0,B6,B7,RC151DT,PRIN,INT,ADMIN,B4,B14
+3 NEW EFFDT,DFN,CNTR,SITE,LN,FN,MN,DOB,SITE,F60DT,VADM,DEBTOR4,DEBTOR6
+4 NEW PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,RCNT,REPAY,X1,X2
+5 NEW ERROR,ADDR,CAT,BILLDT,P10YDT,CURRTOT,HOLD,SITECD,RCNEW,ACTDT
+6 ;
+7 ;initialize temporary global, variables
+8 ;
+9 ;PRCA*4.5*315 Allow global to be purged in 5 days
KILL ^XTMP("RCTOPD")
SET ^XTMP("RCTOPD",0)=$$FMADD^XLFDT(DT,5)_"^"_DT
+10 SET SITE=$EXTRACT($$SITE^RCMSITE(),1,3)
SET SITECD=$PIECE(^RC(342,1,3),U,5)
+11 ; PRCA*4.5*343 - change from 121 to 151 days
SET X1=DT
SET X2=-151
DO C^%DTC
SET (RC151DT,EFFDT)=X
+12 SET X1=DT
SET X2=-3650
DO C^%DTC
SET P10YDT=X
+13 SET X1=DT
SET X2=+60
DO C^%DTC
SET F60DT=X
+14 ;activation date for all sites except beckley, little rock, upstate ny
SET ACTDT=3150801
+15 ;activation date for little rock
if SITE=598
SET ACTDT=3150201
+16 ;activation date for beckley
if SITE=517
SET ACTDT=3150201
+17 ;activation date for upstate ny
if SITE=528
SET ACTDT=3150201
+18 SET (CNTR(1),CNTR(2),CNTR(4),DEBTOR,RCNT)=0
+19 ;
+20 ;branch if recertification document
+21 IF RCDOC="Y"
DO RECERT
GOTO EXIT
+22 ;
+23 ;branch to do update documents
+24 DO UPDATE
IF RCDOC="U"
GOTO EXIT
+25 ;
+26 ;master sheet compilation
+27 ;
+28 FOR
SET DEBTOR=$ORDER(^PRCA(430,"C",DEBTOR))
if DEBTOR'?1N.N
QUIT
Begin DoDot:1
+29 NEW X,RCDFN
+30 SET RCDFN=$GET(^RCD(340,DEBTOR,0))
+31 ;stop the master sheet compilation for hurricane Katrina sites (patients)
IF $PIECE(RCDFN,";",2)["DPT"
IF $$EMERES^PRCAUTL(+RCDFN)]""
QUIT
+32 if $DATA(^RCD(340,"TOP",DEBTOR))
QUIT
+33 ; quit if debtor address marked unknown
+34 if $PIECE($GET(^RCD(340,+DEBTOR,1)),"^",9)=1
QUIT
+35 SET DEBTOR6=$GET(^RCD(340,DEBTOR,6))
SET DEBTOR0=$GET(^(0))
SET HOLD=0
SET RCNEW=1
+36 IF $PIECE(DEBTOR6,U,2)
IF '$PIECE(DEBTOR6,U,3)
QUIT
+37 SET QUIT=1
SET FILE=$$FILE(DEBTOR0)
if 'FILE
QUIT
+38 SET EFFDT=RC151DT
+39 DO PROC(DEBTOR,.QUIT,FILE,.HOLD,.EFFDT)
if QUIT
QUIT
+40 DO EN1^RCTOP2(DEBTOR,"M",FILE)
+41 DO EN1^RCTOP1(DEBTOR,TOTAL,"M",EFFDT,0,FILE)
+42 ;set hold date in file for employee, ex-employee, vendor records
+43 ;Austin holds these for 60 days before transmitting to TOP
+44 IF $GET(HOLD)
SET $PIECE(^RCD(340,DEBTOR,6),U,6)=F60DT
+45 QUIT
End DoDot:1
+46 ;compile documents into mail messages--sets referral date in 430
+47 DO COMPILE
EXIT KILL RCDOC,^TMP("RCTOPD"),XMDUZ
DO KVAR^VADPT
+1 QUIT
+2 ;
UPDATE ;weekly update compilation
+1 FOR
SET DEBTOR=$ORDER(^RCD(340,"TOP",DEBTOR))
if DEBTOR'?1N.N
QUIT
Begin DoDot:1
+2 SET QUIT=1
SET DEBTOR0=^RCD(340,DEBTOR,0)
SET DEBTOR6=^(6)
SET DEBTOR4=^(4)
SET FILE=$$FILE(DEBTOR0)
SET EFFDT=$PIECE(DEBTOR4,U,6)
SET RCNEW=0
+3 DO EN1^RCTOP2(DEBTOR,"U",FILE)
+4 DO PROC(DEBTOR,.QUIT,FILE,0,.EFFDT)
IF QUIT
Begin DoDot:2
+5 ;process type 4 document if necessary
+6 SET TAXID=$$TAXID^RCTOP1(DEBTOR,FILE)
SET OTAXID=$PIECE(DEBTOR4,U)
+7 SET NAME=$$NAME^RCTOP1(+DEBTOR0,FILE)
SET ONAME=$PIECE(DEBTOR4,U,2)
SET NAME=$PIECE(NAME,U)
+8 IF NAME=ONAME
IF TAXID=OTAXID
QUIT
+9 DO EN1^RCTOP4(NAME,TAXID,DEBTOR4,DEBTOR,FILE)
+10 QUIT
End DoDot:2
QUIT
+11 DO EN1^RCTOP1(DEBTOR,TOTAL,"U",EFFDT,0,FILE)
+12 QUIT
End DoDot:1
+13 ;refund/refund reversal documents
+14 DO REFDOC
+15 ;compile documents into mail messages--sets referral date in 430
+16 if $GET(RCDOC)="U"
DO COMPILE
+17 QUIT
+18 ;
RECERT ;send yearly recertification documents
+1 FOR
SET DEBTOR=$ORDER(^RCD(340,"TOP",DEBTOR))
if DEBTOR'?1N.N
QUIT
Begin DoDot:1
+2 SET DEBTOR4=$GET(^RCD(340,DEBTOR,4))
SET TOTAL=$PIECE(DEBTOR4,U,3)
SET EFFDT=$PIECE(DEBTOR4,U,6)
SET DEBTOR0=$GET(^(0))
SET FILE=$$FILE(DEBTOR0)
+3 IF TOTAL
DO EN1^RCTOP1(DEBTOR,TOTAL,"Y",EFFDT,0,FILE)
+4 QUIT
End DoDot:1
+5 ;compile documents into mail messages
+6 DO COMPILE
+7 QUIT
+8 ;
REFDOC ; refund, refund reversal documents
+1 NEW CODE,BILL,DEBTOR,TOTAL,EFFDT,FILE,RFCODE
+2 FOR RFCODE=1,3
SET CODE=$SELECT(RFCODE=1:"R",1:"RV")
Begin DoDot:1
+3 SET BILL=0
FOR
SET BILL=$ORDER(^PRCA(430,"TREF",RFCODE,BILL))
if 'BILL
QUIT
Begin DoDot:2
+4 SET DEBTOR=$PIECE($GET(^PRCA(430,BILL,0)),U,9)
if 'DEBTOR
QUIT
+5 ;NAKED TO LINE ABOVE
SET TOTAL=$PIECE($GET(^(7)),U,18)
if 'TOTAL
QUIT
+6 SET EFFDT=$PIECE($GET(^RCD(340,+DEBTOR,4)),U,6)
SET FILE=$$FILE(^(0))
+7 DO EN1^RCTOP1(DEBTOR,TOTAL,CODE,EFFDT,BILL,FILE)
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
COMPILE ;compiles documents into mail messages and transmits them
+1 ;builds message array
+2 NEW CNT,SEQ,REC,XMDUZ,DOCTYPE,LRTYPE,XMSUB,XMTEXT,XMY,TSEQ,DOCAMT
+3 SET (SEQ,TSEQ)=0
+4 FOR I=1,2,4
SET TSEQ=TSEQ+($GET(CNTR(I))\150)+$SELECT($GET(CNTR(I))#150:1,1:0)
+5 FOR DOCTYPE=1,2,4
if $DATA(^XTMP("RCTOPD",$JOB,DOCTYPE))
DO COMPILE1(DOCTYPE,CNTR(DOCTYPE))
+6 DO USRMSG
+7 QUIT
COMPILE1(DOCTYPE,CNTR) ; compiles each type of document separately
+1 SET RCNT=RCNT+CNTR
+2 IF '$GET(LRTYPE)
FOR I=1,2,4
if $DATA(^XTMP("RCTOPD",$JOB,I))
SET LRTYPE=I
+3 FOR CNT=1:1:CNTR
Begin DoDot:1
+4 if CNT#150=1
Begin DoDot:2
+5 KILL ^XTMP("RCTOPD",$JOB,"BUILD")
SET SEQ=SEQ+1
+6 SET REC=1
SET DOCAMT=0
+7 QUIT
End DoDot:2
+8 SET REC=REC+1
SET ^XTMP("RCTOPD",$JOB,"BUILD",REC)=^XTMP("RCTOPD",$JOB,DOCTYPE,CNT)_U
if DOCTYPE=1
SET DOCAMT=DOCAMT+($EXTRACT(^(REC),135,146)/100)
+9 IF CNTR=CNT
IF LRTYPE=DOCTYPE
SET ^XTMP("RCTOPD",$JOB,"BUILD",REC+1)="END OF TRANSMISSION FOR SITE# "_SITE_": TOTAL RECORDS: "_RCNT
+10 IF $SELECT(CNTR=CNT:1,CNT#150=0:1,1:0)
Begin DoDot:2
+11 SET ^XTMP("RCTOPD",$JOB,"BUILD",1)=SITE_U_$TRANSLATE($JUSTIFY(SEQ,2)," ",0)_U_$TRANSLATE($JUSTIFY(TSEQ,2)," ",0)_U_(REC-1)_U_DOCAMT_U
+12 SET XMDUZ="AR PACKAGE"
+13 SET XMY("XXX@Q-TOP.DOMAIN.EXT")=""
+14 SET XMY("G.TOP")=""
+15 SET XMSUB=SITE_"/TOP TRANSMISSION/SEQ#: "_SEQ_"/"_$$NOW()
+16 SET XMTEXT="^XTMP(""RCTOPD"","_$JOB_",""BUILD"","
+17 DO ^XMD
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
USRMSG ;sends mailman message of documents sent to user
+1 NEW XMY,XMDUZ,XMSUB,X,RCNT
+2 SET XMDUZ="AR PACKAGE"
SET XMY("G.TOP")=""
+3 SET XMSUB="TOP "_$SELECT(RCDOC="M":"MASTER/UPDATE",RCDOC="U":"UPDATE",1:"RECERTIFICATION")_" RECORDS SENT ON "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+4 SET ^XTMP("RCTOPD",$JOB,"REC1",1)="Name TIN TYPE AMOUNT"
+5 SET ^XTMP("RCTOPD",$JOB,"REC1",2)="---- --- ---- ------"
+6 SET X=""
SET RCNT=3
FOR
SET X=$ORDER(^XTMP("RCTOPD",$JOB,"REC",X))
if X=""
QUIT
SET ^XTMP("RCTOPD",$JOB,"REC1",RCNT)=^(X)
SET RCNT=RCNT+1
+7 SET ^XTMP("RCTOPD",$JOB,"REC1",RCNT)="Total Records: "_(RCNT-3)
+8 SET XMTEXT="^XTMP(""RCTOPD"","_$JOB_",""REC1"","
+9 DO ^XMD
+10 ;
THIRD ;sends mailman message to user if no third letter found
+1 if '$DATA(^XTMP("RCTOPD",$JOB,"THIRD"))
QUIT
+2 KILL ^XTMP("RCTOPD",$JOB,"REC1")
+3 SET XMDUZ="AR PACKAGE"
SET XMY("G.TOP")=""
+4 NEW TCT,TDEB,TDEB0,TBIL,TSP,FST
+5 SET XMSUB="TOP QUALIFIED/NO 3RD LETTER SENT ON "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+6 SET ^XTMP("RCTOPD",$JOB,"REC1",1)="The following list of debtor bills were not sent to TOP."
+7 SET ^XTMP("RCTOPD",$JOB,"REC1",2)="Please review debtor's account to determine why the third"
+8 SET ^XTMP("RCTOPD",$JOB,"REC1",3)="notice letter has not been sent:"
+9 SET ^XTMP("RCTOPD",$JOB,"REC1",4)="Name Bill #"
+10 SET ^XTMP("RCTOPD",$JOB,"REC1",5)="---- ------"
+11 SET TCT=6
SET TSP=0
SET TDEB=""
+12 FOR
SET TDEB=$ORDER(^XTMP("RCTOPD",$JOB,"THIRD",TDEB))
if TDEB=""
QUIT
Begin DoDot:1
+13 SET FST=1
SET TBIL=""
+14 IF FST
IF TCT'=6
SET ^XTMP("RCTOPD",$JOB,"REC1",TCT)=""
SET TCT=TCT+1
SET TSP=TSP+1
+15 FOR
SET TBIL=$ORDER(^XTMP("RCTOPD",$JOB,"THIRD",TDEB,TBIL))
if TBIL=""
QUIT
Begin DoDot:2
+16 SET TDEB0=$SELECT(FST:TDEB,1:"")
+17 SET ^XTMP("RCTOPD",$JOB,"REC1",TCT)=TDEB0_$JUSTIFY(" ",35-$LENGTH(TDEB0))_TBIL
+18 SET TCT=TCT+1
SET FST=0
End DoDot:2
End DoDot:1
+19 SET ^XTMP("RCTOPD",$JOB,"REC1",TCT)="Total records: "_(TCT-(6+TSP))
+20 SET XMTEXT="^XTMP(""RCTOPD"","_$JOB_",""REC1"","
+21 DO ^XMD
COMPQ QUIT
+1 ;
PROC(DEBTOR,QUIT,FILE,HOLD,EFFDT) ;process bills for a specific debtor
+1 KILL ^TMP("RCTOPD",$JOB,"BILL")
+2 SET DEBTOR0=$GET(^RCD(340,DEBTOR,0))
+3 if 'FILE
QUIT
+4 IF FILE=2
SET DFN=+DEBTOR0
DO DEM^VADPT
if $EXTRACT(VADM(2),1,5)="00000"
QUIT
+5 SET (BILL,TOTAL,REPAY)=0
+6 IF RCNEW
IF FILE=440
SET HOLD=1
+7 IF 'RCNEW
IF $PIECE(^RCD(340,DEBTOR,6),U,2)
IF '$PIECE(^(6),U,3)
GOTO TOTAL
+8 IF RCNEW
IF $DATA(^RCD(340,"DMC",1,DEBTOR))
GOTO TOTAL
+9 FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL'?1N.N
QUIT
Begin DoDot:1
+10 IF FILE=2
IF +VADM(6)
SET TOTAL=0
SET REPAY=1
QUIT
+11 SET B0=$GET(^PRCA(430,BILL,0))
SET B4=$GET(^(4))
SET B6=$GET(^(6))
SET B7=$GET(^(7))
SET B14=$GET(^(14))
+12 if $PIECE(B0,U,8)'=16
QUIT
+13 if B4
QUIT
+14 if '$PIECE(B0,U,2)
QUIT
+15 SET CAT=$PIECE($GET(^PRCA(430.2,$PIECE(B0,U,2),0)),U,7)
+16 ;*** PRCA*4.5*338 start
+17 if 'CAT
QUIT
+18 ;Check the Refer to TOP field to see if this should be referred, based on AR Category
+19 ;S BILLDT=$P(B6,U,21) ; PRCA*4.5*343 - change BILLDT to LETTER1(#61) field
+20 ;PRCA*4.5*338
if '$$RFCHK(CAT,"N",1.02,$PIECE(B6,U,21))
QUIT
+21 ;*** PRCA*4.5*338 end
+22 ;cross-serviced bills
if $DATA(^PRCA(430,"TCSP",BILL))
QUIT
+23 ;check for DOJ referral here
+24 IF $PIECE(B6,U,4)
IF ($PIECE(B6,U,5)="DOJ")
QUIT
+25 ; PRCA*4.5*343 - change BILLDT from DATE ACCOUNT ACTIVATED (#60) to LETTER1(#61)
SET BILLDT=$PIECE(B6,U,1)
IF (BILLDT<P10YDT)!(BILLDT>RC151DT)!(BILLDT<$PIECE(DEBTOR6,U,3))
QUIT
+26 IF '$PIECE(B6,U,3)
Begin DoDot:2
+27 ;no 3rd letter being sent
+28 NEW TDEB,TFIL
+29 SET TDEB=$GET(^RCD(340,DEBTOR,0))
SET TFIL=$$FILE(TDEB)
SET TDEB=$$NAME^RCTOP1(+TDEB,TFIL)
SET TDEB=$PIECE(TDEB,U,2)
SET ^XTMP("RCTOPD",$JOB,"THIRD",TDEB,$PIECE(B0,U))=""
End DoDot:2
QUIT
+30 IF RCNEW
IF CAT>12
IF CAT<15
SET HOLD=1
+31 IF BILLDT
IF BILLDT<EFFDT
SET EFFDT=BILLDT
+32 SET TOTAL=TOTAL+$PIECE(B7,U)+$PIECE(B7,U,2)+$PIECE(B7,U,3)+$PIECE(B7,U,4)+$PIECE(B7,U,5)
+33 SET ^TMP("RCTOPD",$JOB,"BILL",BILL)=""
+34 QUIT
End DoDot:1
+35 ;
TOTAL ;set transmission total, reset quit variable
+1 ;PRCA*4.5*229
NEW RCSWINFO
SET RCSWINFO=$$SWSTAT^IBBAPI()
+2 ;PRCA*4.5*229
IF RCNEW
IF '+RCSWINFO
if TOTAL<25
QUIT
+3 ;PRCA*4.5*229
IF RCNEW
IF +RCSWINFO
if TOTAL'>0
QUIT
+4 ;
+5 IF 'RCNEW
if TOTAL<25
SET TOTAL=0
SET CURRTOT=$PIECE($GET(^RCD(340,DEBTOR,4)),U,3)
if CURRTOT=TOTAL
QUIT
SET TOTAL=TOTAL-CURRTOT
+6 SET QUIT=0
PROCQ QUIT
+1 ;
NOW() ;compiles current date,time
+1 NEW X,Y,%,%H
+2 SET %H=$HOROLOG
DO YX^%DTC
+3 QUIT Y
+4 ;
FILE(DEBTOR0) ;gets file number for debtor
+1 SET FILE=$PIECE($PIECE(DEBTOR0,U),";",2)
+2 SET FILE=$SELECT(FILE["DPT(":2,FILE["PRC(440":440,FILE["VA(200":200,1:0)
FILEQ QUIT FILE
+1 ;
+2 ;PRCA*4.5*338
RFCHK(RCXCAT,RCIENFLG,RCXRFCD,RCXDT) ;Check to see if bill can be referred to requested collections program
+1 ;
+2 ;Input:
+3 ; RCXCAT - (Required) AR Category to check.
+4 ; RCXIENFLG - Is the AR Category an IEN (I) or a number (N).
+5 ; RCXRFCD - (Required) FileMan Field number for the Referral type being checked.
+6 ; 1.01 - DMC
+7 ; 1.02 - TOP
+8 ; 1.03 - CS
+9 ; RCXDT - (Required) Date of service to be checked.
+10 ;
+11 NEW RCXFLG,RCXCTIEN,RCXSPDT
+12 ;
+13 ; Set the initial split date for the TOP and CS referral programs
+14 SET RCXSPDT=3150801
+15 ; Get the category IEN.
+16 ;Initially assume it is an IEN
SET RCXCTIEN=RCXCAT
+17 ; Update to IEN if AR Category is the Category Number
+18 IF RCIENFLG="N"
SET RCXCTIEN=$ORDER(^PRCA(430.2,"AC",RCXCAT,""))
+19 ; Quit if Category not found
+20 if RCXCTIEN=""
QUIT 0
+21 ;
+22 ; Extract the flag for the category from the AR Category file (430.2), using the field number sent in
+23 SET RCXCTIEN=RCXCTIEN_","
+24 SET RCXFLG=$$GET1^DIQ(430.2,RCXCTIEN,RCXRFCD,"I")
+25 IF RCXFLG<2
QUIT RCXFLG
+26 IF RCXFLG=2
IF (RCXDT<RCXSPDT)
QUIT 1
+27 IF RCXFLG=3
IF (RCXDT'<RCXSPDT)
QUIT 1
+28 QUIT 0
