BARDMBS ; IHS/OIT/FCJ - DEBT MANAGEMENT BILL SEARCH ; 26 May 2011 8:41 AM
;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23,24**;OCT 26, 2005;Build 69
;New routine 5-12-2011 for Debt Letter Management
;
;Search the A/R Bill file for overdue bills and
;and queue letters for overdue bills.
;IHS/SD/POT JULY 2013 FIXED BAREND IN DATE "AG" LOOP - BAR*1.8*.23
;IHS/SD/POT HEAT152452 2/10/2014 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*.24
ST ;
;
D PAR^BARDMU
G:$G(BARQ) XIT ;P.OTT HEAT152452 2/10/2014 - BAR*1.8*.24
D VAR
I $G(BARRPT)'="C" D PARCHK
G:$G(BARQ) XIT
I IOST["C-",'$D(IO("S")) W !!,"Searching for overdue bills..."
;S BARPSDI-EFF DT,BARDRDT-RUN DATE
;start new code bar*1.8*22 SDR
S X1=BARDRDT
S X2=-(BARPCD(1)-1)
D C^%DTC
S BARDRDT=X
K X,X1,X2
;end new code bar*1.8*22 SDR
S BARDRDT=$S(BARDRDT<1:BARPSDI,1:BARDRDT) ;OR EFFECTIVE DATE OR THE LAST TIME RAN, UPDATING INS LIST WILL RESET RUN DATE
;start old code bar*1.8*22 SDR
;F S BARDADT=$O(^BARBL(DUZ(2),"AG",BARDADT)) Q:BARDADT="" D
;.Q:BARDADT'<BARDMDT
;end old code start new code bar*1.8*22 SDR
F S BARDRDT=$O(^BARBL(DUZ(2),"AG",BARDRDT)) Q:BARDRDT=""!(BARDRDT\1>BARDADT) D ;- BAR*1.8*.23
.Q:BARDRDT'<BARDADT
.;end new code bar*1.8*22 SDR
.D CHKBIL
;I IOST["C-",'$D(IO("S")) W !!,"Number of NEW overdue bills found: ",CNT ;bar*1.8*22 SDR
I IOST["C-",'$D(IO("S")) W !!,"Number of NEW overdue bills found: ",BARCNT ;bar*1.8*22 SDR
S DIE="^BAR(90052.06,"_BARPIEN_",",DA=DUZ(2)
S DR="1807///"_DT
D ^DIE
XIT ;
;K BARDADT,BARDMDT,CNT,SUBCNT,DIR,DIE,DR,DA ;bar*1.8*22 SDR
K BARDADT,BARDMDT,BARCNT,BARSBCNT,DIR,DIE,DR,DA ;bar*1.8*22 SDR
Q
;
VAR ;
;W $$EN^BARVDF("IOF") ;bar*1.8*22 SDR
I IOST["C-",'$D(IO("S")) W $$EN^BARVDF("IOF") ;bar*1.8*22 SDR
;S CNT=0 ;bar*1.8*22 SDR
S BARCNT=0 ;bar*1.8*22 SDR
;S SUBCNT=0 ;bar*1.8*22 SDR
S BARSBCNT=0 ;bar*1.8*22 SDR
K DIR
;
;CALCULATES LETTER 1 PRINT DATE
S X1=DT
S X2=-(BARPCD(1)-1)
D C^%DTC
S (BARDADT,BARDMDT)=X
K X,X1,X2
;
;SET UP ARRAY FOR INS TYPE
;start old code bar*1.8*22 SDR
;S L=0
;F S L=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,L)) Q:L'?1N.N D
;.S L1=$P(^BAR(90052.06,BARPIEN,DUZ(2),19,L,0),U)
;.S L2=$P($G(^BAR(90053.03,L1,0)),U,2)
;.I L2'="" S BARDINS(L2)=""
;end old code start new code
S BARL=0
F S BARL=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL)) Q:BARL'?1N.N D
.S BARL1=$P(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL,0),U)
.S BARL2=$$GET1^DIQ(90053.03,BARL1,".01","E")
.I BARL2'="" S BARDINS(BARL2)=""
;end new code
Q
;
PARCHK ;CHECK FOR REQUIRED PARAMETERS
S BARQ=0
S BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18)
;start old code bar*1.8*22 SDR
;F L=1:1:4 I (BARPCD(L)="")!(BARPCL(L)="") S BARQ=1 D ERRMSG Q
;F L=1,13,14 I $P(BARPAR,U,L)="" S BARQ=1 D ERRMSG Q
;F L=1,3,4,5,6,8 I $P(BARPAR1,U,L)="" S BARQ=1 D ERRMSG Q
;end old code start new code
F BARL=1:1:4 I (BARPCD(BARL)="")!(BARPCL(BARL)="") S BARQ=1 D ERRMSG Q
F BARL=1,13,14 I $P(BARPAR,U,BARL)="" S BARQ=1 D ERRMSG Q
F BARL=1,3,4,5,6,8 I $P(BARPAR1,U,BARL)="" S BARQ=1 D ERRMSG Q
;end new code
Q
ERRMSG ;
W !?5,"All of the Required parameters are not set up. You will need to set",!,"these up to continue.",!
D RTRN^BARDMU
Q
;
CHKBIL ;
;CHECKS FOR BILL AMOUNT > 0
S BARBIEN=0
;F S BARBIEN=$O(^BARBL(DUZ(2),"AG",BARDADT,BARBIEN)) Q:BARBIEN="" D ;bar*1.8*22 SDR
F S BARBIEN=$O(^BARBL(DUZ(2),"AG",BARDRDT,BARBIEN)) Q:BARBIEN="" D ;bar*1.8*22 SDR
.;S SUBCNT=SUBCNT+1 ;bar*1.8*22 SDR
.S BARSBCNT=BARSBCNT+1 ;bar*1.8*22 SDR
.;I IOST["C-",'$D(IO("S")),SUBCNT#1000 W "." ;bar*1.8*22 SDR
.I IOST["C-",'$D(IO("S")),BARSBCNT#1000 W "." ;bar*1.8*22 SDR
.;CHECK IF BILL ALREADY IN BARDM
.Q:$D(^BARDM(DUZ(2),"B",BARBIEN))
.;CHECKS FOR BILL AMOUNT > 0
.Q:$P(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0
.;CHECKS FOR ACCOUNT AND INSURER TYPE
.; BARDAC=0 ;ACCT POINTER
.S BARDAC=$P(^BARBL(DUZ(2),BARBIEN,0),U,3)
.;TEST ACCOUNT FOR TSI TRANSMISSION
.;I $D(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC)) S R=$O(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0)) Q:$P(^BAR(90052.06,BARPIEN,DUZ(2),13,R,0),U,2)=0 ;bar*1.8*22 SDR
.I $D(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC)) S BARR=$O(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0)) Q:$P(^BAR(90052.06,BARPIEN,DUZ(2),13,BARR,0),U,2)=0 ;bar*1.8*22 SDR
.Q:$P(^BARAC(DUZ(2),BARDAC,0),U,7)="N"
.I $P(^BARAC(DUZ(2),BARDAC,0),U,7)="Y" D ADD Q ;TEST ACCT=YES
.;TEST INSURANCE TYPE
.D INSTYP^BARDMU
.I BARDITY'="",$D(BARDINS(BARDITY)) D ADD Q
Q
;
ADD ;ADD BILL TO A/R DEBT MAN
K DD,DO,DINUM
S (DIE,DIC)="^BARDM("_DUZ(2)_",",DIC(0)="L",X=BARBIEN
D FILE^DICN
S:+Y>0 BARDIEN=+Y
I +Y<0 W !,"ERROR ADDING BILL NUMBER: ",$P(^BARBL(DUZ(2),BARBIEN,0),U) Q
S DR=".02///A"
D ^DIE
;ADD SUB ENTRY STATUS
S DA(1)=BARDIEN
S DIC="^BARDM("_DUZ(2)_","_BARDIEN_",50,",DIC(0)="L",X=DT
S DIC("P")=$P(^DD(90053.05,50,0),U,2)
D FILE^DICN
S:+Y>0 DA=+Y
I +Y<0 W !,"ERROR ADDING STATUS COMMENTS ENTRY " Q
S DIE=DIC
S DR=".02///"_DUZ_";.03///A"
D ^DIE
;ADD LETTER TO SUB-RECORD
S DA(1)=BARDIEN
S DIC="^BARDM("_DUZ(2)_","_BARDIEN_",100,",DIC(0)="L",X="CYCLE 1"
S DIC("P")=$P(^DD(90053.05,100,0),U,2)
D FILE^DICN
S:+Y>0 DA=+Y
I +Y<0 W !,"ERROR ADDING CYCLE ENTRY TO DEBT BILL: ",$P(^BARBL(DUZ(2),BARBIL,0),U) Q
S DIE=DIC
S DR=".02///"_BARPCL(1)_";.03///Q"_";.06///"_$P(^BARBL(DUZ(2),BARBIEN,0),U,15)
D ^DIE
;Q WRITE ERROR MESSAGE
;S CNT=CNT+1 ;bar*1.8*22 SDR
S BARCNT=BARCNT+1 ;bar*1.8*22 SDR
K DIC,DIE,DR,DA
Q
;
BARDMBS ; IHS/OIT/FCJ - DEBT MANAGEMENT BILL SEARCH ; 26 May 2011 8:41 AM
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23,24**;OCT 26, 2005;Build 69
+2 ;New routine 5-12-2011 for Debt Letter Management
+3 ;
+4 ;Search the A/R Bill file for overdue bills and
+5 ;and queue letters for overdue bills.
+6 ;IHS/SD/POT JULY 2013 FIXED BAREND IN DATE "AG" LOOP - BAR*1.8*.23
+7 ;IHS/SD/POT HEAT152452 2/10/2014 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*.24
ST ;
+1 ;
+2 DO PAR^BARDMU
+3 ;P.OTT HEAT152452 2/10/2014 - BAR*1.8*.24
IF $GET(BARQ)
GOTO XIT
+4 DO VAR
+5 IF $GET(BARRPT)'="C"
DO PARCHK
+6 IF $GET(BARQ)
GOTO XIT
+7 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!,"Searching for overdue bills..."
+8 ;S BARPSDI-EFF DT,BARDRDT-RUN DATE
+9 ;start new code bar*1.8*22 SDR
+10 SET X1=BARDRDT
+11 SET X2=-(BARPCD(1)-1)
+12 DO C^%DTC
+13 SET BARDRDT=X
+14 KILL X,X1,X2
+15 ;end new code bar*1.8*22 SDR
+16 ;OR EFFECTIVE DATE OR THE LAST TIME RAN, UPDATING INS LIST WILL RESET RUN DATE
SET BARDRDT=$SELECT(BARDRDT<1:BARPSDI,1:BARDRDT)
+17 ;start old code bar*1.8*22 SDR
+18 ;F S BARDADT=$O(^BARBL(DUZ(2),"AG",BARDADT)) Q:BARDADT="" D
+19 ;.Q:BARDADT'<BARDMDT
+20 ;end old code start new code bar*1.8*22 SDR
+21 ;- BAR*1.8*.23
FOR
SET BARDRDT=$ORDER(^BARBL(DUZ(2),"AG",BARDRDT))
IF BARDRDT=""!(BARDRDT\1>BARDADT)
QUIT
Begin DoDot:1
+22 IF BARDRDT'<BARDADT
QUIT
+23 ;end new code bar*1.8*22 SDR
+24 DO CHKBIL
End DoDot:1
+25 ;I IOST["C-",'$D(IO("S")) W !!,"Number of NEW overdue bills found: ",CNT ;bar*1.8*22 SDR
+26 ;bar*1.8*22 SDR
IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!,"Number of NEW overdue bills found: ",BARCNT
+27 SET DIE="^BAR(90052.06,"_BARPIEN_","
SET DA=DUZ(2)
+28 SET DR="1807///"_DT
+29 DO ^DIE
XIT ;
+1 ;K BARDADT,BARDMDT,CNT,SUBCNT,DIR,DIE,DR,DA ;bar*1.8*22 SDR
+2 ;bar*1.8*22 SDR
KILL BARDADT,BARDMDT,BARCNT,BARSBCNT,DIR,DIE,DR,DA
+3 QUIT
+4 ;
VAR ;
+1 ;W $$EN^BARVDF("IOF") ;bar*1.8*22 SDR
+2 ;bar*1.8*22 SDR
IF IOST["C-"
IF '$DATA(IO("S"))
WRITE $$EN^BARVDF("IOF")
+3 ;S CNT=0 ;bar*1.8*22 SDR
+4 ;bar*1.8*22 SDR
SET BARCNT=0
+5 ;S SUBCNT=0 ;bar*1.8*22 SDR
+6 ;bar*1.8*22 SDR
SET BARSBCNT=0
+7 KILL DIR
+8 ;
+9 ;CALCULATES LETTER 1 PRINT DATE
+10 SET X1=DT
+11 SET X2=-(BARPCD(1)-1)
+12 DO C^%DTC
+13 SET (BARDADT,BARDMDT)=X
+14 KILL X,X1,X2
+15 ;
+16 ;SET UP ARRAY FOR INS TYPE
+17 ;start old code bar*1.8*22 SDR
+18 ;S L=0
+19 ;F S L=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,L)) Q:L'?1N.N D
+20 ;.S L1=$P(^BAR(90052.06,BARPIEN,DUZ(2),19,L,0),U)
+21 ;.S L2=$P($G(^BAR(90053.03,L1,0)),U,2)
+22 ;.I L2'="" S BARDINS(L2)=""
+23 ;end old code start new code
+24 SET BARL=0
+25 FOR
SET BARL=$ORDER(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL))
IF BARL'?1N.N
QUIT
Begin DoDot:1
+26 SET BARL1=$PIECE(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL,0),U)
+27 SET BARL2=$$GET1^DIQ(90053.03,BARL1,".01","E")
+28 IF BARL2'=""
SET BARDINS(BARL2)=""
End DoDot:1
+29 ;end new code
+30 QUIT
+31 ;
PARCHK ;CHECK FOR REQUIRED PARAMETERS
+1 SET BARQ=0
+2 SET BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18)
+3 ;start old code bar*1.8*22 SDR
+4 ;F L=1:1:4 I (BARPCD(L)="")!(BARPCL(L)="") S BARQ=1 D ERRMSG Q
+5 ;F L=1,13,14 I $P(BARPAR,U,L)="" S BARQ=1 D ERRMSG Q
+6 ;F L=1,3,4,5,6,8 I $P(BARPAR1,U,L)="" S BARQ=1 D ERRMSG Q
+7 ;end old code start new code
+8 FOR BARL=1:1:4
IF (BARPCD(BARL)="")!(BARPCL(BARL)="")
SET BARQ=1
DO ERRMSG
QUIT
+9 FOR BARL=1,13,14
IF $PIECE(BARPAR,U,BARL)=""
SET BARQ=1
DO ERRMSG
QUIT
+10 FOR BARL=1,3,4,5,6,8
IF $PIECE(BARPAR1,U,BARL)=""
SET BARQ=1
DO ERRMSG
QUIT
+11 ;end new code
+12 QUIT
ERRMSG ;
+1 WRITE !?5,"All of the Required parameters are not set up. You will need to set",!,"these up to continue.",!
+2 DO RTRN^BARDMU
+3 QUIT
+4 ;
CHKBIL ;
+1 ;CHECKS FOR BILL AMOUNT > 0
+2 SET BARBIEN=0
+3 ;F S BARBIEN=$O(^BARBL(DUZ(2),"AG",BARDADT,BARBIEN)) Q:BARBIEN="" D ;bar*1.8*22 SDR
+4 ;bar*1.8*22 SDR
FOR
SET BARBIEN=$ORDER(^BARBL(DUZ(2),"AG",BARDRDT,BARBIEN))
IF BARBIEN=""
QUIT
Begin DoDot:1
+5 ;S SUBCNT=SUBCNT+1 ;bar*1.8*22 SDR
+6 ;bar*1.8*22 SDR
SET BARSBCNT=BARSBCNT+1
+7 ;I IOST["C-",'$D(IO("S")),SUBCNT#1000 W "." ;bar*1.8*22 SDR
+8 ;bar*1.8*22 SDR
IF IOST["C-"
IF '$DATA(IO("S"))
IF BARSBCNT#1000
WRITE "."
+9 ;CHECK IF BILL ALREADY IN BARDM
+10 IF $DATA(^BARDM(DUZ(2),"B",BARBIEN))
QUIT
+11 ;CHECKS FOR BILL AMOUNT > 0
+12 IF $PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0
QUIT
+13 ;CHECKS FOR ACCOUNT AND INSURER TYPE
+14 ; BARDAC=0 ;ACCT POINTER
+15 SET BARDAC=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,3)
+16 ;TEST ACCOUNT FOR TSI TRANSMISSION
+17 ;I $D(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC)) S R=$O(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0)) Q:$P(^BAR(90052.06,BARPIEN,DUZ(2),13,R,0),U,2)=0 ;bar*1.8*22 SDR
+18 ;bar*1.8*22 SDR
IF $DATA(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC))
SET BARR=$ORDER(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0))
IF $PIECE(^BAR(90052.06,BARPIEN,DUZ(2),13,BARR,0),U,2)=0
QUIT
+19 IF $PIECE(^BARAC(DUZ(2),BARDAC,0),U,7)="N"
QUIT
+20 ;TEST ACCT=YES
IF $PIECE(^BARAC(DUZ(2),BARDAC,0),U,7)="Y"
DO ADD
QUIT
+21 ;TEST INSURANCE TYPE
+22 DO INSTYP^BARDMU
+23 IF BARDITY'=""
IF $DATA(BARDINS(BARDITY))
DO ADD
QUIT
End DoDot:1
+24 QUIT
+25 ;
ADD ;ADD BILL TO A/R DEBT MAN
+1 KILL DD,DO,DINUM
+2 SET (DIE,DIC)="^BARDM("_DUZ(2)_","
SET DIC(0)="L"
SET X=BARBIEN
+3 DO FILE^DICN
+4 IF +Y>0
SET BARDIEN=+Y
+5 IF +Y<0
WRITE !,"ERROR ADDING BILL NUMBER: ",$PIECE(^BARBL(DUZ(2),BARBIEN,0),U)
QUIT
+6 SET DR=".02///A"
+7 DO ^DIE
+8 ;ADD SUB ENTRY STATUS
+9 SET DA(1)=BARDIEN
+10 SET DIC="^BARDM("_DUZ(2)_","_BARDIEN_",50,"
SET DIC(0)="L"
SET X=DT
+11 SET DIC("P")=$PIECE(^DD(90053.05,50,0),U,2)
+12 DO FILE^DICN
+13 IF +Y>0
SET DA=+Y
+14 IF +Y<0
WRITE !,"ERROR ADDING STATUS COMMENTS ENTRY "
QUIT
+15 SET DIE=DIC
+16 SET DR=".02///"_DUZ_";.03///A"
+17 DO ^DIE
+18 ;ADD LETTER TO SUB-RECORD
+19 SET DA(1)=BARDIEN
+20 SET DIC="^BARDM("_DUZ(2)_","_BARDIEN_",100,"
SET DIC(0)="L"
SET X="CYCLE 1"
+21 SET DIC("P")=$PIECE(^DD(90053.05,100,0),U,2)
+22 DO FILE^DICN
+23 IF +Y>0
SET DA=+Y
+24 IF +Y<0
WRITE !,"ERROR ADDING CYCLE ENTRY TO DEBT BILL: ",$PIECE(^BARBL(DUZ(2),BARBIL,0),U)
QUIT
+25 SET DIE=DIC
+26 SET DR=".02///"_BARPCL(1)_";.03///Q"_";.06///"_$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)
+27 DO ^DIE
+28 ;Q WRITE ERROR MESSAGE
+29 ;S CNT=CNT+1 ;bar*1.8*22 SDR
+30 ;bar*1.8*22 SDR
SET BARCNT=BARCNT+1
+31 KILL DIC,DIE,DR,DA
+32 QUIT
+33 ;
