BARAST ; IHS/SD/LSL - ACCOUNT STATEMENT ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
W !
I '$D(^BAR(90052.03,"B","ACCOUNT STATEMENT HEADER")) D ALTR
I '$D(^BARAC(DUZ(2),"AC")) D Q
.W !!,"Accounts must be flagged first. Use the 'Flag Accounts option"
.W !,"to identifiy accounts to print statements for.",!
S ZTRTN="LOOP^BARAST"
; -------------------------------
;
DEV ;
; ask for printer device
S %ZIS="NQ"
S %ZIS("A")="Print Statements to Device: "
D ^%ZIS
Q:POP
I IO'=IO(0) D Q
.S ZTDESC="PRINT A/R ACCOUNT STATEMENTS"
.K ZTSK
.D ^%ZTLOAD
.Q:'$G(ZTSK)
.W !,"Task # ",ZTSK," queued.",!
I $D(IO("S")) D
. S IOP=ION
. D ^%ZIS
Q:$G(BARFL1)
; -------------------------------
;
LOOP ;EP
; loop though ac x-ref
S BAREDT=$$FMADD^XLFDT(DT,-1)
S BARBDT=$$FMADD^XLFDT(DT,-31)
S BARLDT=0
F S BARLDT=$O(^BARAC(DUZ(2),"AC",BARLDT)) Q:'BARLDT!(BARLDT>BARBDT) D
.S BARAC=0
.F S BARAC=$O(^BARAC(DUZ(2),"AC",BARLDT,BARAC)) Q:'BARAC D
..D ONE
..D FDT
; -------------------------------
;
KILL ;
; clean up
K BARAC,BARLDT,BAREDT,BARC,BARFL1
D:$D(IO("S")) ^%ZISC
Q
; *********************************************************************
;
RPR ; EP
; re-print one statement
W !
K DIC
S DIC="^BARAC(DUZ(2),"
S DIC(0)="AEMQ"
D ^DIC
Q:+Y<0
S DA(1)=+Y
S BARAC=+Y
S DIC="^BARAC(DUZ(2),DA(1),12,"
S DIC("S")="I '$P(^(0),""^"",2)"
D ^DIC
K DIC
Q:+Y<0
S DA=+Y
S ZTRTN="ONE^BARAST"
S BAREDT=$$FMADD^XLFDT(+Y,-1)
S BARFL1=1
N I
F I="BAREDT","BARLDT","BARFL1","BARAC" S ZTSAVE(I)=""
K ZTSK
D DEV
Q:$G(ZTSK)
D ONE
D KILL
Q
; *********************************************************************
;
ONE ;
; ONE ACCOUNT
K BARC
K DIQ
S DIC="^BARAC(DUZ(2),"
S DA=BARAC
S DIQ="BARC("
S DR=".01;1.01:1.06;301"
D EN^DIQ1
S BARLDT=$O(^BARAC(DUZ(2),BARAC,12,"B",BAREDT),-1)
S BARSBAL=$$BAL^BARUTL(BARAC,BARLDT-1)
S BAREBAL=BARSBAL
S BARPG=0
D HDR
S BARTOT=0,DA=0
F S DA=$O(^BARTR(DUZ(2),"AE",BARAC,DA)) Q:'DA D
.I $Y+6>IOSL D
..W !,?18,"CONT'D"
..D HDR
.S BARTDT=$P(^BARTR(DUZ(2),DA,0),"^",1)
.S BARDAY=$P(BARTDT,".",1)
.Q:BARDAY<BARLDT
.Q:BARDAY>BAREDT
.D TPRT
S BAREBAL=BARSBAL+BARTOT
D FTR
Q
; *********************************************************************
;
FDT ;file date in statement sub-file
S DA(1)=BARAC
S X=DT
S DIC="^BARAC(DUZ(2),DA(1),12,"
S DIC(0)="LX"
D ^DIC
Q:+Y<0
S DA=+Y
K ^BARAC(DUZ(2),"AC",BARLDT,BARAC)
Q
; *********************************************************************
;
TPRT ;LIST ONE TRANSACTION
K DIQ
S DIC="^BARTR(DUZ(2),"
S DIQ="BART("
S DR=".01;3.5;4;101"
D EN^DIQ1
S BART(90050.03,DA,3.5)=BART(90050.03,DA,3.5)*-1
S BARTOT=BARTOT+BART(90050.03,DA,3.5)
W !,$P(BART(90050.03,DA,.01),"@",1)
W ?15,$P(BART(90050.03,DA,4),"-",1,2)
W ?27,$E(BART(90050.03,DA,101),1,30)
W:BART(90050.03,DA,101)["PAYMENT" " - THANK YOU"
W ?65,$J($FN(BART(90050.03,DA,3.5),"P,",2),12)
Q
; *********************************************************************
;
HDR ;STATEMENT HEADER
S:'$D(BARDASH) $P(BARDASH,"-",80)=""
N DA
W $$EN^BARVDF("IOF")
S BARPG=BARPG+1
W !!,$$FMTE^XLFDT(DT),?20,"S T A T E M E N T O F A C C O U N T",?70,"Page: ",BARPG
S DA=$O(^BAR(90052.03,"B","ACCOUNT STATEMENT HEADER",0))
I DA W ! F I=1:1:10 D
.W:$D(^BAR(90052.03,DA,1,I,0)) !,^(0)
W !!,"FOR ACCOUNT: ",BARC(90050.02,BARAC,.01)
N I
F I=1.01,1.02,1.03,1.04,1.05,1.06 D
.Q:BARC(90050.02,BARAC,I)=""
.I I<1.05 W !,?13
.I I=1.05 W ", "
.I I=1.06 W " "
.W BARC(90050.02,BARAC,I)
W !!,"Statement Covers Period From: ",$$CDT^BARDUTL(BARLDT)," To: ",$$CDT^BARDUTL(BAREDT)
W !!,?40,"BEGINNING BALANCE: ",?65,$J($FN(BARSBAL,",P",2),12)
W !!,BARDASH
W !,?26,"T R A N S A C T I O N S "
W !,"Trans Date",?15,"Bill#",?27,"Description",?70,"Amount",!
Q
; *********************************************************************
;
FTR ;
; STATEMENT FOOTER
W !!,?18,"TOTAL:"
W ?65,$J($FN(BARTOT,",P",2),12)
W !,BARDASH
W !!,?46,"BALANCE DUE: ",?65,$J($FN(BAREBAL,",P",2),12)
W !!
Q
; *********************************************************************
;
ALTR ;EP - add the statement header text
S DIC="^BAR(90052.03,"
S DIC(0)="LX"
S X="ACCOUNT STATEMENT HEADER"
D ^DIC
Q:+Y<0
S DA=+Y
W $$EN^BARVDF("IOF")
W !!,"You may enter text that will appear at the top of the account"
W !,"statements. Typically this will be facility name and address,"
W !,"business office phone number, point of contact, and special"
W !,"messages. The statements will print up to 10 lines of text.",!
S DIE="^BAR(90052.03,"
S DR=100
D ^DIE
Q
; *********************************************************************
;
FLAG ;EP - flag accounts for statements
K DIR
S DIR("A")="Flag an individual account or loop? "
S DIR("B")=1
S DIR(0)="S^1:INDIVIDUAL;2:LOOP"
D ^DIR
K DIR
S BARANS=Y
I BARANS=1 F D Q:+$G(Y)<0
.K DIC
.S DIC="^BARAC(DUZ(2),"
.S DIC(0)="AEMQ"
.D ^DIC
.Q:+Y<0
.S BARAC=+Y
.S BARBDT=$$FMADD^XLFDT(DT,-31)
.S BARCNT=0
.D OFL
.W !!,"Account",$S(BARCNT=0:" already ",1:" "),"flagged.",!
I BARANS=2 D
.S DIC="^BARTBL("
.S DIC(0)="AEMQ"
.S DIC("S")="I $P(^(0),""^"",3)=""ACTY"""
.S DIC("A")="Select Type of Account: "
.S DIC("B")="PATIENT"
.D ^DIC
.K DIC
.Q:+Y<0
.S BARTYP=$P(Y,"^",2)
.S BARBDT=$$FMADD^XLFDT(DT,-31)
.S BARCNT=0,BARAC=0
.F S BARAC=$O(^BARAC(DUZ(2),"ATYP",BARTYP,BARAC)) Q:'BARAC D OFL
.W !!,BARCNT," accounts flagged."
.F W ! Q:$Y+4>IOSL
.D EOP^BARUTL(0)
K BARBDT,BARANS,BARAC,BARTYP,BARCNT
Q
; *********************************************************************
;
OFL ;set one
Q:$O(^BARAC(DUZ(2),BARAC,12,0))
S ^BARAC(DUZ(2),BARAC,12,0)="^90050.0212D^^"
S DA(1)=BARAC
S DIC="^BARAC(DUZ(2),DA(1),12,"
S DIC(0)="LX",X=BARBDT
D ^DIC
Q:+Y<0
S DA=+Y
S DIE=DIC
S DR=".02///1"
D ^DIE
S BARCNT=BARCNT+1
Q
BARAST ; IHS/SD/LSL - ACCOUNT STATEMENT ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 WRITE !
+3 IF '$DATA(^BAR(90052.03,"B","ACCOUNT STATEMENT HEADER"))
DO ALTR
+4 IF '$DATA(^BARAC(DUZ(2),"AC"))
Begin DoDot:1
+5 WRITE !!,"Accounts must be flagged first. Use the 'Flag Accounts option"
+6 WRITE !,"to identifiy accounts to print statements for.",!
End DoDot:1
QUIT
+7 SET ZTRTN="LOOP^BARAST"
+8 ; -------------------------------
+9 ;
DEV ;
+1 ; ask for printer device
+2 SET %ZIS="NQ"
+3 SET %ZIS("A")="Print Statements to Device: "
+4 DO ^%ZIS
+5 IF POP
QUIT
+6 IF IO'=IO(0)
Begin DoDot:1
+7 SET ZTDESC="PRINT A/R ACCOUNT STATEMENTS"
+8 KILL ZTSK
+9 DO ^%ZTLOAD
+10 IF '$GET(ZTSK)
QUIT
+11 WRITE !,"Task # ",ZTSK," queued.",!
End DoDot:1
QUIT
+12 IF $DATA(IO("S"))
Begin DoDot:1
+13 SET IOP=ION
+14 DO ^%ZIS
End DoDot:1
+15 IF $GET(BARFL1)
QUIT
+16 ; -------------------------------
+17 ;
LOOP ;EP
+1 ; loop though ac x-ref
+2 SET BAREDT=$$FMADD^XLFDT(DT,-1)
+3 SET BARBDT=$$FMADD^XLFDT(DT,-31)
+4 SET BARLDT=0
+5 FOR
SET BARLDT=$ORDER(^BARAC(DUZ(2),"AC",BARLDT))
IF 'BARLDT!(BARLDT>BARBDT)
QUIT
Begin DoDot:1
+6 SET BARAC=0
+7 FOR
SET BARAC=$ORDER(^BARAC(DUZ(2),"AC",BARLDT,BARAC))
IF 'BARAC
QUIT
Begin DoDot:2
+8 DO ONE
+9 DO FDT
End DoDot:2
End DoDot:1
+10 ; -------------------------------
+11 ;
KILL ;
+1 ; clean up
+2 KILL BARAC,BARLDT,BAREDT,BARC,BARFL1
+3 IF $DATA(IO("S"))
DO ^%ZISC
+4 QUIT
+5 ; *********************************************************************
+6 ;
RPR ; EP
+1 ; re-print one statement
+2 WRITE !
+3 KILL DIC
+4 SET DIC="^BARAC(DUZ(2),"
+5 SET DIC(0)="AEMQ"
+6 DO ^DIC
+7 IF +Y<0
QUIT
+8 SET DA(1)=+Y
+9 SET BARAC=+Y
+10 SET DIC="^BARAC(DUZ(2),DA(1),12,"
+11 SET DIC("S")="I '$P(^(0),""^"",2)"
+12 DO ^DIC
+13 KILL DIC
+14 IF +Y<0
QUIT
+15 SET DA=+Y
+16 SET ZTRTN="ONE^BARAST"
+17 SET BAREDT=$$FMADD^XLFDT(+Y,-1)
+18 SET BARFL1=1
+19 NEW I
+20 FOR I="BAREDT","BARLDT","BARFL1","BARAC"
SET ZTSAVE(I)=""
+21 KILL ZTSK
+22 DO DEV
+23 IF $GET(ZTSK)
QUIT
+24 DO ONE
+25 DO KILL
+26 QUIT
+27 ; *********************************************************************
+28 ;
ONE ;
+1 ; ONE ACCOUNT
+2 KILL BARC
+3 KILL DIQ
+4 SET DIC="^BARAC(DUZ(2),"
+5 SET DA=BARAC
+6 SET DIQ="BARC("
+7 SET DR=".01;1.01:1.06;301"
+8 DO EN^DIQ1
+9 SET BARLDT=$ORDER(^BARAC(DUZ(2),BARAC,12,"B",BAREDT),-1)
+10 SET BARSBAL=$$BAL^BARUTL(BARAC,BARLDT-1)
+11 SET BAREBAL=BARSBAL
+12 SET BARPG=0
+13 DO HDR
+14 SET BARTOT=0
SET DA=0
+15 FOR
SET DA=$ORDER(^BARTR(DUZ(2),"AE",BARAC,DA))
IF 'DA
QUIT
Begin DoDot:1
+16 IF $Y+6>IOSL
Begin DoDot:2
+17 WRITE !,?18,"CONT'D"
+18 DO HDR
End DoDot:2
+19 SET BARTDT=$PIECE(^BARTR(DUZ(2),DA,0),"^",1)
+20 SET BARDAY=$PIECE(BARTDT,".",1)
+21 IF BARDAY<BARLDT
QUIT
+22 IF BARDAY>BAREDT
QUIT
+23 DO TPRT
End DoDot:1
+24 SET BAREBAL=BARSBAL+BARTOT
+25 DO FTR
+26 QUIT
+27 ; *********************************************************************
+28 ;
FDT ;file date in statement sub-file
+1 SET DA(1)=BARAC
+2 SET X=DT
+3 SET DIC="^BARAC(DUZ(2),DA(1),12,"
+4 SET DIC(0)="LX"
+5 DO ^DIC
+6 IF +Y<0
QUIT
+7 SET DA=+Y
+8 KILL ^BARAC(DUZ(2),"AC",BARLDT,BARAC)
+9 QUIT
+10 ; *********************************************************************
+11 ;
TPRT ;LIST ONE TRANSACTION
+1 KILL DIQ
+2 SET DIC="^BARTR(DUZ(2),"
+3 SET DIQ="BART("
+4 SET DR=".01;3.5;4;101"
+5 DO EN^DIQ1
+6 SET BART(90050.03,DA,3.5)=BART(90050.03,DA,3.5)*-1
+7 SET BARTOT=BARTOT+BART(90050.03,DA,3.5)
+8 WRITE !,$PIECE(BART(90050.03,DA,.01),"@",1)
+9 WRITE ?15,$PIECE(BART(90050.03,DA,4),"-",1,2)
+10 WRITE ?27,$EXTRACT(BART(90050.03,DA,101),1,30)
+11 IF BART(90050.03,DA,101)["PAYMENT"
WRITE " - THANK YOU"
+12 WRITE ?65,$JUSTIFY($FNUMBER(BART(90050.03,DA,3.5),"P,",2),12)
+13 QUIT
+14 ; *********************************************************************
+15 ;
HDR ;STATEMENT HEADER
+1 IF '$DATA(BARDASH)
SET $PIECE(BARDASH,"-",80)=""
+2 NEW DA
+3 WRITE $$EN^BARVDF("IOF")
+4 SET BARPG=BARPG+1
+5 WRITE !!,$$FMTE^XLFDT(DT),?20,"S T A T E M E N T O F A C C O U N T",?70,"Page: ",BARPG
+6 SET DA=$ORDER(^BAR(90052.03,"B","ACCOUNT STATEMENT HEADER",0))
+7 IF DA
WRITE !
FOR I=1:1:10
Begin DoDot:1
+8 IF $DATA(^BAR(90052.03,DA,1,I,0))
WRITE !,^(0)
End DoDot:1
+9 WRITE !!,"FOR ACCOUNT: ",BARC(90050.02,BARAC,.01)
+10 NEW I
+11 FOR I=1.01,1.02,1.03,1.04,1.05,1.06
Begin DoDot:1
+12 IF BARC(90050.02,BARAC,I)=""
QUIT
+13 IF I<1.05
WRITE !,?13
+14 IF I=1.05
WRITE ", "
+15 IF I=1.06
WRITE " "
+16 WRITE BARC(90050.02,BARAC,I)
End DoDot:1
+17 WRITE !!,"Statement Covers Period From: ",$$CDT^BARDUTL(BARLDT)," To: ",$$CDT^BARDUTL(BAREDT)
+18 WRITE !!,?40,"BEGINNING BALANCE: ",?65,$JUSTIFY($FNUMBER(BARSBAL,",P",2),12)
+19 WRITE !!,BARDASH
+20 WRITE !,?26,"T R A N S A C T I O N S "
+21 WRITE !,"Trans Date",?15,"Bill#",?27,"Description",?70,"Amount",!
+22 QUIT
+23 ; *********************************************************************
+24 ;
FTR ;
+1 ; STATEMENT FOOTER
+2 WRITE !!,?18,"TOTAL:"
+3 WRITE ?65,$JUSTIFY($FNUMBER(BARTOT,",P",2),12)
+4 WRITE !,BARDASH
+5 WRITE !!,?46,"BALANCE DUE: ",?65,$JUSTIFY($FNUMBER(BAREBAL,",P",2),12)
+6 WRITE !!
+7 QUIT
+8 ; *********************************************************************
+9 ;
ALTR ;EP - add the statement header text
+1 SET DIC="^BAR(90052.03,"
+2 SET DIC(0)="LX"
+3 SET X="ACCOUNT STATEMENT HEADER"
+4 DO ^DIC
+5 IF +Y<0
QUIT
+6 SET DA=+Y
+7 WRITE $$EN^BARVDF("IOF")
+8 WRITE !!,"You may enter text that will appear at the top of the account"
+9 WRITE !,"statements. Typically this will be facility name and address,"
+10 WRITE !,"business office phone number, point of contact, and special"
+11 WRITE !,"messages. The statements will print up to 10 lines of text.",!
+12 SET DIE="^BAR(90052.03,"
+13 SET DR=100
+14 DO ^DIE
+15 QUIT
+16 ; *********************************************************************
+17 ;
FLAG ;EP - flag accounts for statements
+1 KILL DIR
+2 SET DIR("A")="Flag an individual account or loop? "
+3 SET DIR("B")=1
+4 SET DIR(0)="S^1:INDIVIDUAL;2:LOOP"
+5 DO ^DIR
+6 KILL DIR
+7 SET BARANS=Y
+8 IF BARANS=1
FOR
Begin DoDot:1
+9 KILL DIC
+10 SET DIC="^BARAC(DUZ(2),"
+11 SET DIC(0)="AEMQ"
+12 DO ^DIC
+13 IF +Y<0
QUIT
+14 SET BARAC=+Y
+15 SET BARBDT=$$FMADD^XLFDT(DT,-31)
+16 SET BARCNT=0
+17 DO OFL
+18 WRITE !!,"Account",$SELECT(BARCNT=0:" already ",1:" "),"flagged.",!
End DoDot:1
IF +$GET(Y)<0
QUIT
+19 IF BARANS=2
Begin DoDot:1
+20 SET DIC="^BARTBL("
+21 SET DIC(0)="AEMQ"
+22 SET DIC("S")="I $P(^(0),""^"",3)=""ACTY"""
+23 SET DIC("A")="Select Type of Account: "
+24 SET DIC("B")="PATIENT"
+25 DO ^DIC
+26 KILL DIC
+27 IF +Y<0
QUIT
+28 SET BARTYP=$PIECE(Y,"^",2)
+29 SET BARBDT=$$FMADD^XLFDT(DT,-31)
+30 SET BARCNT=0
SET BARAC=0
+31 FOR
SET BARAC=$ORDER(^BARAC(DUZ(2),"ATYP",BARTYP,BARAC))
IF 'BARAC
QUIT
DO OFL
+32 WRITE !!,BARCNT," accounts flagged."
+33 FOR
WRITE !
IF $Y+4>IOSL
QUIT
+34 DO EOP^BARUTL(0)
End DoDot:1
+35 KILL BARBDT,BARANS,BARAC,BARTYP,BARCNT
+36 QUIT
+37 ; *********************************************************************
+38 ;
OFL ;set one
+1 IF $ORDER(^BARAC(DUZ(2),BARAC,12,0))
QUIT
+2 SET ^BARAC(DUZ(2),BARAC,12,0)="^90050.0212D^^"
+3 SET DA(1)=BARAC
+4 SET DIC="^BARAC(DUZ(2),DA(1),12,"
+5 SET DIC(0)="LX"
SET X=BARBDT
+6 DO ^DIC
+7 IF +Y<0
QUIT
+8 SET DA=+Y
+9 SET DIE=DIC
+10 SET DR=".02///1"
+11 DO ^DIE
+12 SET BARCNT=BARCNT+1
+13 QUIT
