BARDMU ;IHS/OIT/FCJ - DEBT MANAGEMENT UTILITY ROUTINE ; 26 May 2011 8:33 AM
;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23,24**;OCT 26, 2005;Build 69
;New routine 5-12-2011 for Debt Letter Management
;IHS/SD/POT JAN 2013 ADDED SORTING PARAMETER, PRT BILL DATE (TO SITE PARAMETERS) - BAR*1.8*.23
;IHS/SD/POT FEB 2013 CHANGED PTR TO INSURER TYPE - BAR*1.8*.23
;IHS/SD/POT JUL 2013 HEAT118656 BELCOURT: SKIP UNDEF ENTRY IN ^BARBL - BAR*1.8*.24
;IHS/SD/POT HEAT152452 2/10/2014 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*.24
PAR ;EP;SET LETTER PARAMETERS
S BARPIEN="",BARPNM=""
S BARPIEN=$P($G(^BAR(90052.05,DUZ(2),DUZ(2),0)),U,3) ;- BAR*1.8*.24
I BARPIEN="" D Q
. W !!!,$P(^DIC(4,DUZ(2),0),U)," IS NOT REGIONALLY SETUP"
. W !,"CONTACT YOUR A/R MANAGER",*7
. S BARQ=1
. D EOP
;END OF NEW CODE
S BARPNM=$P(^AUTTLOC(BARPIEN,0),U,2)
S BARPAR=^BAR(90052.06,BARPIEN,DUZ(2),17)
S BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18) ;bar*1.8*22 SDR
S (BARPSDI,Y)=$P(BARPAR,U)
I Y D DD^%DT S BARPSDX=Y
S BARPWO=$P(BARPAR,U,2),BARPNPI=$$VAL^XBDIQ1(90052.06,DUZ(2),1703)
S BARPDOB=$$VALI^XBDIQ1(90052.06,DUZ(2),1704)="Y"
S BARPBDT=$$VALI^XBDIQ1(90052.06,DUZ(2),1901)="Y" ;BILL DATE ;- BAR*1.8*.23
S BARPSRT=$$VALI^XBDIQ1(90052.06,DUZ(2),1902) ;SORT BY <NIL>,P(OLICY HOLDER), I(INSURANCE NAME)
;CYCLE LETTER AND PERIOD
S C=1
F I=1:2:8 S BARPCL(C)=$$VAL^XBDIQ1(90052.06,DUZ(2),1704+I),C=C+1
S C=1
F I=1:2:8 S BARPCD(C)=$$VAL^XBDIQ1(90052.06,DUZ(2),1705+I),C=C+1
;LAST RUN DATE FOR BILL SEARCH
S BARDRDT=$P($G(^BAR(90052.06,BARPIEN,DUZ(2),18)),U,7)
S BARPMX=$P($G(^BAR(90052.06,BARPIEN,DUZ(2),18)),U,8)
Q
;
INS ;EP;BAR DL SITE PARAM ACCOUNT OPTION
;ADD INSURER TYPES TO BE TESTED TO PRINT LETTERS
D PAR
S BARQ=0,BARCT=0
I $D(^BAR(90052.06,BARPIEN,DUZ(2),19)) S BARB=0 F S BARB=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB)) Q:BARB'?1N.N D
.S BARB1=$P(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB,0),U)
.S BARI(BARB1)=$P(^BAR(90053.03,BARB1,0),U,2),BARCT=BARCT+1
;
I '$D(^BAR(90052.06,BARPIEN,DUZ(2),19,0)) S ^(0)="^90052.0603P^^0"
S DIE="^BAR(90052.06,"_BARPIEN_",",DA=DUZ(2),DR=1900
W ! D ^DIE
I $D(^BAR(90052.06,BARPIEN,DUZ(2),19)) S BARB=0 F S BARB=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB)) Q:BARB'?1N.N D
.I $D(BARI($P(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB,0),U))) K BARI($P(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB,0),U)) S BARCT=BARCT-1
I BARCT>0 D DEL
K BARQ,BARI,DIE,DR,DA
;
ACC ;ACCOUNT SELECTION
;ADD ACCOUNTS TO BE TESTED TO PRINT LETTERS
S BARQ=0
S (DIE,DIC)="^BARAC("_DUZ(2)_",",DIC(0)="AEQZ",DR=7
F D Q:BARQ
.W ! D ^DIC
.I $D(Y),+Y<0 S BARQ=1 Q
.I $D(Y),+Y>0 S DA=+Y D ^DIE S $P(^BAR(90052.06,BARPIEN,DUZ(2),18,0),U,7)=0 I %="NO" S BARI(DA)=DA
D:$D(BARI) DELA
K BARQ,DIE,DIC,DA,DR
Q
;
DEL ;DELETE ENTRIES FROM BILL FILE IF LETTERS HAVE NOT BEEN PRINTED
W !,"Deleting entries from Bill file if letters do not exist for deleted Insurer type."
S BARB=0 F S BARB=$O(^BARDM(DUZ(2),"S","Q","CYCLE 1",BARB)) Q:BARB'?1N.N D
. S BARBIEN=$P(^BARDM(DUZ(2),BARB,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)
.D INSTYP
.S BARB1=0 F S BARB1=$O(BARI(BARB1)) Q:BARB1'?1N.N I BARI(BARB1)=BARDITY S DIK="^BARDM("_DUZ(2)_",",DA=BARB D ^DIK ;bar*1.8*22 SDR
.K DIK
Q
;
DELA ;DELETE ACCOUNTS
W !,"Deleting entries from Bill file if letters do not exist for deleted Account."
S BARB=0 F S BARB=$O(^BARDM(DUZ(2),"S","Q","CYCLE 1",BARB)) Q:BARB'?1N.N D
.S BARBIEN=$P(^BARDM(DUZ(2),BARB,0),U)
. I '$D(^BARBL(DUZ(2),BARBIEN,0)) D Q ;HEAT118656 BELCOURT P.OTT - BAR*1.8*.24
.. 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) I BARDAC=168 W !,BARB
. I $D(BARI(BARDAC)) S DIK="^BARDM("_DUZ(2)_",",DA=BARB D ^DIK
. K DIK
Q
;
INSTYP ;EP
;$$GET1^DIQ(9999999.18,BARIIEN,.211,"I")=21
;$$GET1^DIQ(9999999.18,BARIIEN,.211,"E")="VETERANS ADMINISTRATION"
;$$GET1^DIQ(9999999.18,BARIIEN,.211)="VETERANS ADMINISTRATION"
S BARDACI=0 ;ACCT .01 VAR POINTER
S BARDACG=0 ;ACCT .01 VAR GLB
S BARDITY=""
S BARDACI=$P($P(^BARAC(DUZ(2),BARDAC,0),U),";")
S BARDACG=$P($P(^BARAC(DUZ(2),BARDAC,0),U),";",2)
S BARDITY=$$GET1^DIQ(90050.02,BARDAC,"1.08","E") ;bar*1.8*22 SDR (=>MEDICARE FI)
I BARDACG="AUTNINS(" S BARDIT=$$VAL^XBDIQ1(9999999.18,BARDACI,.211) Q ;(=>MEDICARE FI)
S BARDIT=$S(BARDACG="VA(":"NEW PERSON",BARDACG="AUPNPAT(":"PATIENT","AUTTVNDR(":"VENDOR",1:"OTHER")
Q
;
ZIS ;EP;
W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) S BARQUIT="" Q
S BAROPT=Y
Q
RRDT ;EP;REPORT RUN DATE
D BARPSAT^BARUTL0
S Y=DT
D DD^%DT S BARRDT=Y
S BARPG=0 ;bar*1.8*22 SDR
Q
RTRN ;EP - ask usr to press RET
S BARDLQ=0
I IOST["C-",'$D(IO("S")) W ! S Y=$$DIR^XBDIR("E","Press RETURN To Continue ^ to Cancel...","","","",1) X ^%ZOSF("TRMRD") I Y=0!(Y=27)!(X=U) S BARDLQ=1
Q
SEL ;EP;SELECT BILL
S (BARQ,BARREQ)=0
S (DIE,DIC)="^BARDM("_DUZ(2)_","
S DIC("A")="Enter the Debt Management Bill: "
S DIC(0)="AEQ"
D ^DIC
I +Y<1 S BARQ=1 Q
S BARDM=+Y
Q
EOP ;EP
Q:$G(IOT)'["TRM"
Q:$E($G(IOST))'="C"
Q:$D(IO("S"))
Q:$D(ZTQUEUED)
K DIR
S DIR(0)="E"
S DIR("A")="Enter RETURN to continue"
D ^DIR
K DIR
Q
BARDMU ;IHS/OIT/FCJ - DEBT MANAGEMENT UTILITY ROUTINE ; 26 May 2011 8:33 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 ;IHS/SD/POT JAN 2013 ADDED SORTING PARAMETER, PRT BILL DATE (TO SITE PARAMETERS) - BAR*1.8*.23
+4 ;IHS/SD/POT FEB 2013 CHANGED PTR TO INSURER TYPE - BAR*1.8*.23
+5 ;IHS/SD/POT JUL 2013 HEAT118656 BELCOURT: SKIP UNDEF ENTRY IN ^BARBL - BAR*1.8*.24
+6 ;IHS/SD/POT HEAT152452 2/10/2014 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*.24
PAR ;EP;SET LETTER PARAMETERS
+1 SET BARPIEN=""
SET BARPNM=""
+2 ;- BAR*1.8*.24
SET BARPIEN=$PIECE($GET(^BAR(90052.05,DUZ(2),DUZ(2),0)),U,3)
+3 IF BARPIEN=""
Begin DoDot:1
+4 WRITE !!!,$PIECE(^DIC(4,DUZ(2),0),U)," IS NOT REGIONALLY SETUP"
+5 WRITE !,"CONTACT YOUR A/R MANAGER",*7
+6 SET BARQ=1
+7 DO EOP
End DoDot:1
QUIT
+8 ;END OF NEW CODE
+9 SET BARPNM=$PIECE(^AUTTLOC(BARPIEN,0),U,2)
+10 SET BARPAR=^BAR(90052.06,BARPIEN,DUZ(2),17)
+11 ;bar*1.8*22 SDR
SET BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18)
+12 SET (BARPSDI,Y)=$PIECE(BARPAR,U)
+13 IF Y
DO DD^%DT
SET BARPSDX=Y
+14 SET BARPWO=$PIECE(BARPAR,U,2)
SET BARPNPI=$$VAL^XBDIQ1(90052.06,DUZ(2),1703)
+15 SET BARPDOB=$$VALI^XBDIQ1(90052.06,DUZ(2),1704)="Y"
+16 ;BILL DATE ;- BAR*1.8*.23
SET BARPBDT=$$VALI^XBDIQ1(90052.06,DUZ(2),1901)="Y"
+17 ;SORT BY <NIL>,P(OLICY HOLDER), I(INSURANCE NAME)
SET BARPSRT=$$VALI^XBDIQ1(90052.06,DUZ(2),1902)
+18 ;CYCLE LETTER AND PERIOD
+19 SET C=1
+20 FOR I=1:2:8
SET BARPCL(C)=$$VAL^XBDIQ1(90052.06,DUZ(2),1704+I)
SET C=C+1
+21 SET C=1
+22 FOR I=1:2:8
SET BARPCD(C)=$$VAL^XBDIQ1(90052.06,DUZ(2),1705+I)
SET C=C+1
+23 ;LAST RUN DATE FOR BILL SEARCH
+24 SET BARDRDT=$PIECE($GET(^BAR(90052.06,BARPIEN,DUZ(2),18)),U,7)
+25 SET BARPMX=$PIECE($GET(^BAR(90052.06,BARPIEN,DUZ(2),18)),U,8)
+26 QUIT
+27 ;
INS ;EP;BAR DL SITE PARAM ACCOUNT OPTION
+1 ;ADD INSURER TYPES TO BE TESTED TO PRINT LETTERS
+2 DO PAR
+3 SET BARQ=0
SET BARCT=0
+4 IF $DATA(^BAR(90052.06,BARPIEN,DUZ(2),19))
SET BARB=0
FOR
SET BARB=$ORDER(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB))
IF BARB'?1N.N
QUIT
Begin DoDot:1
+5 SET BARB1=$PIECE(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB,0),U)
+6 SET BARI(BARB1)=$PIECE(^BAR(90053.03,BARB1,0),U,2)
SET BARCT=BARCT+1
End DoDot:1
+7 ;
+8 IF '$DATA(^BAR(90052.06,BARPIEN,DUZ(2),19,0))
SET ^(0)="^90052.0603P^^0"
+9 SET DIE="^BAR(90052.06,"_BARPIEN_","
SET DA=DUZ(2)
SET DR=1900
+10 WRITE !
DO ^DIE
+11 IF $DATA(^BAR(90052.06,BARPIEN,DUZ(2),19))
SET BARB=0
FOR
SET BARB=$ORDER(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB))
IF BARB'?1N.N
QUIT
Begin DoDot:1
+12 IF $DATA(BARI($PIECE(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB,0),U)))
KILL BARI($PIECE(^BAR(90052.06,BARPIEN,DUZ(2),19,BARB,0),U))
SET BARCT=BARCT-1
End DoDot:1
+13 IF BARCT>0
DO DEL
+14 KILL BARQ,BARI,DIE,DR,DA
+15 ;
ACC ;ACCOUNT SELECTION
+1 ;ADD ACCOUNTS TO BE TESTED TO PRINT LETTERS
+2 SET BARQ=0
+3 SET (DIE,DIC)="^BARAC("_DUZ(2)_","
SET DIC(0)="AEQZ"
SET DR=7
+4 FOR
Begin DoDot:1
+5 WRITE !
DO ^DIC
+6 IF $DATA(Y)
IF +Y<0
SET BARQ=1
QUIT
+7 IF $DATA(Y)
IF +Y>0
SET DA=+Y
DO ^DIE
SET $PIECE(^BAR(90052.06,BARPIEN,DUZ(2),18,0),U,7)=0
IF %="NO"
SET BARI(DA)=DA
End DoDot:1
IF BARQ
QUIT
+8 IF $DATA(BARI)
DO DELA
+9 KILL BARQ,DIE,DIC,DA,DR
+10 QUIT
+11 ;
DEL ;DELETE ENTRIES FROM BILL FILE IF LETTERS HAVE NOT BEEN PRINTED
+1 WRITE !,"Deleting entries from Bill file if letters do not exist for deleted Insurer type."
+2 SET BARB=0
FOR
SET BARB=$ORDER(^BARDM(DUZ(2),"S","Q","CYCLE 1",BARB))
IF BARB'?1N.N
QUIT
Begin DoDot:1
+3 SET BARBIEN=$PIECE(^BARDM(DUZ(2),BARB,0),U)
+4 ;HEAT118656 BELCOURT P.OTT
IF '$DATA(^BARBL(DUZ(2),BARBIEN,0))
Begin DoDot:2
+5 IF $PIECE($GET(^VA(200,DUZ,0)),U,4)'="@"
QUIT
+6 WRITE !,"MISSING DATA IN ^BARBL(",DUZ(2),",",BARBIEN
+7 QUIT
End DoDot:2
QUIT
+8 SET BARDAC=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,3)
+9 DO INSTYP
+10 ;bar*1.8*22 SDR
SET BARB1=0
FOR
SET BARB1=$ORDER(BARI(BARB1))
IF BARB1'?1N.N
QUIT
IF BARI(BARB1)=BARDITY
SET DIK="^BARDM("_DUZ(2)_","
SET DA=BARB
DO ^DIK
+11 KILL DIK
End DoDot:1
+12 QUIT
+13 ;
DELA ;DELETE ACCOUNTS
+1 WRITE !,"Deleting entries from Bill file if letters do not exist for deleted Account."
+2 SET BARB=0
FOR
SET BARB=$ORDER(^BARDM(DUZ(2),"S","Q","CYCLE 1",BARB))
IF BARB'?1N.N
QUIT
Begin DoDot:1
+3 SET BARBIEN=$PIECE(^BARDM(DUZ(2),BARB,0),U)
+4 ;HEAT118656 BELCOURT P.OTT - BAR*1.8*.24
IF '$DATA(^BARBL(DUZ(2),BARBIEN,0))
Begin DoDot:2
+5 IF $PIECE($GET(^VA(200,DUZ,0)),U,4)'="@"
QUIT
+6 WRITE !,"MISSING DATA IN ^BARBL(",DUZ(2),",",BARBIEN
+7 QUIT
End DoDot:2
QUIT
+8 SET BARDAC=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,3)
IF BARDAC=168
WRITE !,BARB
+9 IF $DATA(BARI(BARDAC))
SET DIK="^BARDM("_DUZ(2)_","
SET DA=BARB
DO ^DIK
+10 KILL DIK
End DoDot:1
+11 QUIT
+12 ;
INSTYP ;EP
+1 ;$$GET1^DIQ(9999999.18,BARIIEN,.211,"I")=21
+2 ;$$GET1^DIQ(9999999.18,BARIIEN,.211,"E")="VETERANS ADMINISTRATION"
+3 ;$$GET1^DIQ(9999999.18,BARIIEN,.211)="VETERANS ADMINISTRATION"
+4 ;ACCT .01 VAR POINTER
SET BARDACI=0
+5 ;ACCT .01 VAR GLB
SET BARDACG=0
+6 SET BARDITY=""
+7 SET BARDACI=$PIECE($PIECE(^BARAC(DUZ(2),BARDAC,0),U),";")
+8 SET BARDACG=$PIECE($PIECE(^BARAC(DUZ(2),BARDAC,0),U),";",2)
+9 ;bar*1.8*22 SDR (=>MEDICARE FI)
SET BARDITY=$$GET1^DIQ(90050.02,BARDAC,"1.08","E")
+10 ;(=>MEDICARE FI)
IF BARDACG="AUTNINS("
SET BARDIT=$$VAL^XBDIQ1(9999999.18,BARDACI,.211)
QUIT
+11 SET BARDIT=$SELECT(BARDACG="VA(":"NEW PERSON",BARDACG="AUPNPAT(":"PATIENT","AUTTVNDR(":"VENDOR",1:"OTHER")
+12 QUIT
+13 ;
ZIS ;EP;
+1 WRITE !
SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
SET BARQUIT=""
QUIT
+3 SET BAROPT=Y
+4 QUIT
RRDT ;EP;REPORT RUN DATE
+1 DO BARPSAT^BARUTL0
+2 SET Y=DT
+3 DO DD^%DT
SET BARRDT=Y
+4 ;bar*1.8*22 SDR
SET BARPG=0
+5 QUIT
RTRN ;EP - ask usr to press RET
+1 SET BARDLQ=0
+2 IF IOST["C-"
IF '$DATA(IO("S"))
WRITE !
SET Y=$$DIR^XBDIR("E","Press RETURN To Continue ^ to Cancel...","","","",1)
XECUTE ^%ZOSF("TRMRD")
IF Y=0!(Y=27)!(X=U)
SET BARDLQ=1
+3 QUIT
SEL ;EP;SELECT BILL
+1 SET (BARQ,BARREQ)=0
+2 SET (DIE,DIC)="^BARDM("_DUZ(2)_","
+3 SET DIC("A")="Enter the Debt Management Bill: "
+4 SET DIC(0)="AEQ"
+5 DO ^DIC
+6 IF +Y<1
SET BARQ=1
QUIT
+7 SET BARDM=+Y
+8 QUIT
EOP ;EP
+1 IF $GET(IOT)'["TRM"
QUIT
+2 IF $EXTRACT($GET(IOST))'="C"
QUIT
+3 IF $DATA(IO("S"))
QUIT
+4 IF $DATA(ZTQUEUED)
QUIT
+5 KILL DIR
+6 SET DIR(0)="E"
+7 SET DIR("A")="Enter RETURN to continue"
+8 DO ^DIR
+9 KILL DIR
+10 QUIT
