BARDMRU ;IHS/OIT/FCJ - DEBT MANAGEMENT-UTILITY FOR REPORTS-CALCULATE BILLS
;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23**;OCT 26, 2005;Build 38
;New routine 5-12-2011 for Debt Letter Management
;
;P.OTT SEP 2012 IGNORE DUPLICATE BILL / NONEX CLAIM # (SAME LOGIC AS IN BARDMLP)
;P.OTT MAY 2013 ACTIVATE FILTER FOR INSTYPE; CHANGE STATUS TO PAID;
;P.OTT JULY 2013 HEAT118656 BELCOURT: SKIP UNDEF ENTRY IN ^BARBL
CALC ;EP;START OF SET OF ARRAY
;
D ^BARDMBS ;CHECK FOR OUTSTANDING BILLS
Q:$G(BARQ)
;
I IOST["C-",'$D(IO("S")) W !!,"Running calculations for report."
S BARCTQ=0,BARCT=0,CY=0
D BARSETUP ;SETUP ARRAY INS TYPE P.OTT
F BARL="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4" D
.S ^TMP("BARDM",$J,BARL)="0^0^0" ;bar*1.8*22 SDR
.Q:BARCTQ
.S CY=CY+1
.D A1
K BARCTQ
Q
BARSETUP ;P.OTT MAY 2013
NEW BARL,BARL1,BARL2,BARPIEN
S BARPIEN=DUZ(2)
K BARDINS
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)=""
Q
;
A1 ;
S BARDM=0 F S BARDM=$O(^BARDM(DUZ(2),"S","Q",BARL,BARDM)) Q:BARDM'?1N.N D Q:BARCTQ
. Q:$P(^BARDM(DUZ(2),BARDM,0),U,2)'="A" ;bar*1.8*22 SDR
. S BARDMC=0 F S BARDMC=$O(^BARDM(DUZ(2),"S","Q",BARL,BARDM,BARDMC)) Q:BARDMC'?1N.N D Q:BARCTQ
.. S BARAMTO=$P(^BARDM(DUZ(2),BARDM,100,BARDMC,0),U,6)
.. S BARBIEN=$P(^BARDM(DUZ(2),BARDM,0),U)
.. I '$D(^BARBL(DUZ(2),BARBIEN,0)) D Q ;HEAT118656 BELCOURT P.OTT
... I $P($G(^VA(200,DUZ,0)),U,4)'="@" Q
... W !,"MISSING DATA IN ^BARBL(",DUZ(2),",",BARBIEN
... Q
.. S BARDAC=$P(^BARBL(DUZ(2),BARBIEN,0),U,3),BARAMTB=$P(^(0),U,13),BARDBDT=$P(^(0),U,7)
.. S BARD3P=$P(^BARBL(DUZ(2),BARBIEN,0),U,17)
.. S BARD3PD=$P(^BARBL(DUZ(2),BARBIEN,0),U,22)
.. I '$D(^ABMDBILL(BARD3PD,BARD3P)) QUIT ;DUPLICATE BILL / NONEX CLAIM # P.OTT ADDED FROM BARDMLP
.. I $P(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0 D Q ;P.OTT MAY 2013
... W !,"Bill status of ",$P(^BARBL(DUZ(2),BARBIEN,0),U,1)," changed. Flagging DL as PAID."
... D PAID^BARDMRE(BARDM,BARDMC) Q
.. D INSTYP^BARDMU
.. S BARDI=$$VAL^XBDIQ1(90050.02,BARDAC,.01)
.. I '$D(BARDINS(BARDI))&'$D(BARDINS(BARDITY)) Q ;not insurer type or insurer we are looking for P.OTT MAY 2013
.. I BARRPT="Q" D RPTQ
.. ;SET TOTALS BY CYCLE
.. I BARRPT="C",CY'=1 D CYDAY Q:BARLQ=0
.. S $P(^TMP("BARDM",$J,BARL),U)=+$P($G(^TMP("BARDM",$J,BARL)),U)+1 ;bar*1.8*22 SDR
.. S $P(^TMP("BARDM",$J,BARL),U,2)=$P(^TMP("BARDM",$J,BARL),U,2)+BARAMTB
.. S $P(^TMP("BARDM",$J,BARL),U,3)=$P(^TMP("BARDM",$J,BARL),U,3)+BARAMTO
.. ;SET TOTALS BY INS TYPE
.. S:'$G(^TMP("BARDM",$J,BARL,BARDIT)) ^TMP("BARDM",$J,BARL,BARDIT)="0^0^0"
.. S $P(^TMP("BARDM",$J,BARL,BARDIT),U)=$P(^TMP("BARDM",$J,BARL,BARDIT),U)+1
.. S $P(^TMP("BARDM",$J,BARL,BARDIT),U,2)=$P(^TMP("BARDM",$J,BARL,BARDIT),U,2)+BARAMTB
.. S $P(^TMP("BARDM",$J,BARL,BARDIT),U,3)=$P(^TMP("BARDM",$J,BARL,BARDIT),U,3)+BARAMTO
.. ;SET TOTALS BY INS
.. S:'$G(^TMP("BARDM",$J,BARL,BARDIT,BARDI)) ^TMP("BARDM",$J,BARL,BARDIT,BARDI)="0^0^0"
.. S $P(^TMP("BARDM",$J,BARL,BARDIT,BARDI),U)=$P(^TMP("BARDM",$J,BARL,BARDIT,BARDI),U)+1
.. S $P(^TMP("BARDM",$J,BARL,BARDIT,BARDI),U,2)=$P(^TMP("BARDM",$J,BARL,BARDIT,BARDI),U,2)+BARAMTB
.. S $P(^TMP("BARDM",$J,BARL,BARDIT,BARDI),U,3)=$P(^TMP("BARDM",$J,BARL,BARDIT,BARDI),U,3)+BARAMTO
.. S BARCT=BARCT+1 I BARCT=BARPMX,BARRPT="C" S BARCTQ=1
.. S ^TMP("BARDM",$J,"DMIR-DET",BARL,BARDIT,BARDI,BARDM)=""
Q
RPTQ ;SET OTHER ITEMS FOR THE QUEUED LET REPORT
S ^TMP("BARDM",$J,BARL,BARDIT,BARDI,$E($P(^BARBL(DUZ(2),BARBIEN,0),U),1,8))=$P(^BARBL(DUZ(2),BARBIEN,1),U)_U_$P(^(1),U,2)_U_BARDBDT_U_BARAMTB_U_BARAMTO
Q
;
CYDAY ;EP;CYCLE DAY TEST
S BARLQ=0
S BARR=0
S BARR=$O(^BARDM(DUZ(2),BARDM,100,"B","CYCLE "_(CY-1),BARR))
S X2=$P(^BARDM(DUZ(2),BARDM,100,BARR,0),U,5)
S X1=DT
D ^%DTC
;COMPARE ABOVE DAYS (last print date-DT) WITH CYCLE DAYS TO PRINT NXT LETTER...
I (X+1)>(BARPCD(CY)-BARPCD(CY-1)) S BARLQ=1
Q ;EOR
BARDMRU ;IHS/OIT/FCJ - DEBT MANAGEMENT-UTILITY FOR REPORTS-CALCULATE BILLS
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23**;OCT 26, 2005;Build 38
+2 ;New routine 5-12-2011 for Debt Letter Management
+3 ;
+4 ;P.OTT SEP 2012 IGNORE DUPLICATE BILL / NONEX CLAIM # (SAME LOGIC AS IN BARDMLP)
+5 ;P.OTT MAY 2013 ACTIVATE FILTER FOR INSTYPE; CHANGE STATUS TO PAID;
+6 ;P.OTT JULY 2013 HEAT118656 BELCOURT: SKIP UNDEF ENTRY IN ^BARBL
CALC ;EP;START OF SET OF ARRAY
+1 ;
+2 ;CHECK FOR OUTSTANDING BILLS
DO ^BARDMBS
+3 IF $GET(BARQ)
QUIT
+4 ;
+5 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !!,"Running calculations for report."
+6 SET BARCTQ=0
SET BARCT=0
SET CY=0
+7 ;SETUP ARRAY INS TYPE P.OTT
DO BARSETUP
+8 FOR BARL="CYCLE 1","CYCLE 2","CYCLE 3","CYCLE 4"
Begin DoDot:1
+9 ;bar*1.8*22 SDR
SET ^TMP("BARDM",$JOB,BARL)="0^0^0"
+10 IF BARCTQ
QUIT
+11 SET CY=CY+1
+12 DO A1
End DoDot:1
+13 KILL BARCTQ
+14 QUIT
BARSETUP ;P.OTT MAY 2013
+1 NEW BARL,BARL1,BARL2,BARPIEN
+2 SET BARPIEN=DUZ(2)
+3 KILL BARDINS
+4 SET BARL=0
+5 FOR
SET BARL=$ORDER(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL))
IF BARL'?1N.N
QUIT
Begin DoDot:1
+6 SET BARL1=$PIECE(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL,0),U)
+7 SET BARL2=$$GET1^DIQ(90053.03,BARL1,".01","E")
+8 IF BARL2'=""
SET BARDINS(BARL2)=""
End DoDot:1
+9 QUIT
+10 ;
A1 ;
+1 SET BARDM=0
FOR
SET BARDM=$ORDER(^BARDM(DUZ(2),"S","Q",BARL,BARDM))
IF BARDM'?1N.N
QUIT
Begin DoDot:1
+2 ;bar*1.8*22 SDR
IF $PIECE(^BARDM(DUZ(2),BARDM,0),U,2)'="A"
QUIT
+3 SET BARDMC=0
FOR
SET BARDMC=$ORDER(^BARDM(DUZ(2),"S","Q",BARL,BARDM,BARDMC))
IF BARDMC'?1N.N
QUIT
Begin DoDot:2
+4 SET BARAMTO=$PIECE(^BARDM(DUZ(2),BARDM,100,BARDMC,0),U,6)
+5 SET BARBIEN=$PIECE(^BARDM(DUZ(2),BARDM,0),U)
+6 ;HEAT118656 BELCOURT P.OTT
IF '$DATA(^BARBL(DUZ(2),BARBIEN,0))
Begin DoDot:3
+7 IF $PIECE($GET(^VA(200,DUZ,0)),U,4)'="@"
QUIT
+8 WRITE !,"MISSING DATA IN ^BARBL(",DUZ(2),",",BARBIEN
+9 QUIT
End DoDot:3
QUIT
+10 SET BARDAC=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,3)
SET BARAMTB=$PIECE(^(0),U,13)
SET BARDBDT=$PIECE(^(0),U,7)
+11 SET BARD3P=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,17)
+12 SET BARD3PD=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,22)
+13 ;DUPLICATE BILL / NONEX CLAIM # P.OTT ADDED FROM BARDMLP
IF '$DATA(^ABMDBILL(BARD3PD,BARD3P))
QUIT
+14 ;P.OTT MAY 2013
IF $PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0
Begin DoDot:3
+15 WRITE !,"Bill status of ",$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,1)," changed. Flagging DL as PAID."
+16 DO PAID^BARDMRE(BARDM,BARDMC)
QUIT
End DoDot:3
QUIT
+17 DO INSTYP^BARDMU
+18 SET BARDI=$$VAL^XBDIQ1(90050.02,BARDAC,.01)
+19 ;not insurer type or insurer we are looking for P.OTT MAY 2013
IF '$DATA(BARDINS(BARDI))&'$DATA(BARDINS(BARDITY))
QUIT
+20 IF BARRPT="Q"
DO RPTQ
+21 ;SET TOTALS BY CYCLE
+22 IF BARRPT="C"
IF CY'=1
DO CYDAY
IF BARLQ=0
QUIT
+23 ;bar*1.8*22 SDR
SET $PIECE(^TMP("BARDM",$JOB,BARL),U)=+$PIECE($GET(^TMP("BARDM",$JOB,BARL)),U)+1
+24 SET $PIECE(^TMP("BARDM",$JOB,BARL),U,2)=$PIECE(^TMP("BARDM",$JOB,BARL),U,2)+BARAMTB
+25 SET $PIECE(^TMP("BARDM",$JOB,BARL),U,3)=$PIECE(^TMP("BARDM",$JOB,BARL),U,3)+BARAMTO
+26 ;SET TOTALS BY INS TYPE
+27 IF '$GET(^TMP("BARDM",$JOB,BARL,BARDIT))
SET ^TMP("BARDM",$JOB,BARL,BARDIT)="0^0^0"
+28 SET $PIECE(^TMP("BARDM",$JOB,BARL,BARDIT),U)=$PIECE(^TMP("BARDM",$JOB,BARL,BARDIT),U)+1
+29 SET $PIECE(^TMP("BARDM",$JOB,BARL,BARDIT),U,2)=$PIECE(^TMP("BARDM",$JOB,BARL,BARDIT),U,2)+BARAMTB
+30 SET $PIECE(^TMP("BARDM",$JOB,BARL,BARDIT),U,3)=$PIECE(^TMP("BARDM",$JOB,BARL,BARDIT),U,3)+BARAMTO
+31 ;SET TOTALS BY INS
+32 IF '$GET(^TMP("BARDM",$JOB,BARL,BARDIT,BARDI))
SET ^TMP("BARDM",$JOB,BARL,BARDIT,BARDI)="0^0^0"
+33 SET $PIECE(^TMP("BARDM",$JOB,BARL,BARDIT,BARDI),U)=$PIECE(^TMP("BARDM",$JOB,BARL,BARDIT,BARDI),U)+1
+34 SET $PIECE(^TMP("BARDM",$JOB,BARL,BARDIT,BARDI),U,2)=$PIECE(^TMP("BARDM",$JOB,BARL,BARDIT,BARDI),U,2)+BARAMTB
+35 SET $PIECE(^TMP("BARDM",$JOB,BARL,BARDIT,BARDI),U,3)=$PIECE(^TMP("BARDM",$JOB,BARL,BARDIT,BARDI),U,3)+BARAMTO
+36 SET BARCT=BARCT+1
IF BARCT=BARPMX
IF BARRPT="C"
SET BARCTQ=1
+37 SET ^TMP("BARDM",$JOB,"DMIR-DET",BARL,BARDIT,BARDI,BARDM)=""
End DoDot:2
IF BARCTQ
QUIT
End DoDot:1
IF BARCTQ
QUIT
+38 QUIT
RPTQ ;SET OTHER ITEMS FOR THE QUEUED LET REPORT
+1 SET ^TMP("BARDM",$JOB,BARL,BARDIT,BARDI,$EXTRACT($PIECE(^BARBL(DUZ(2),BARBIEN,0),U),1,8))=$PIECE(^BARBL(DUZ(2),BARBIEN,1),U)_U_$PIECE(^(1),U,2)_U_BARDBDT_U_BARAMTB_U_BARAMTO
+2 QUIT
+3 ;
CYDAY ;EP;CYCLE DAY TEST
+1 SET BARLQ=0
+2 SET BARR=0
+3 SET BARR=$ORDER(^BARDM(DUZ(2),BARDM,100,"B","CYCLE "_(CY-1),BARR))
+4 SET X2=$PIECE(^BARDM(DUZ(2),BARDM,100,BARR,0),U,5)
+5 SET X1=DT
+6 DO ^%DTC
+7 ;COMPARE ABOVE DAYS (last print date-DT) WITH CYCLE DAYS TO PRINT NXT LETTER...
+8 IF (X+1)>(BARPCD(CY)-BARPCD(CY-1))
SET BARLQ=1
+9 ;EOR
QUIT
