BARUFPRP ; IHS/SD/TPF - REPORT TO WRITE OUT REPORT FILE ;01/26/2009
;;1.8;IHS ACCOUNTS RECEIVABLE;**4,10,24**;OCT 26, 2005;Build 69
EN ;EP;NEW ROUTINE STANDALONE UTILITY TO WRITE OUT BARBOB FILE;MRS:02/04/2008
;
; ENTERS WITH
; BARU = CASHIER WHO CREATED BOB
; BARA = DUZ(2)
; BARB = BATCH IEN
; BARC = BATCH ITEM
; BARD = TRANSACTION
;
;JULY 2013 IHS/SD/POTT HEAT118656 BELCOURT SKIP UNDEF ENTRY IN ^BARCOL BAR*1.8*24
;
N BARA,BARB,BARC,BARD,BARTMP,BARTXT,BARU,BAREND
S BARU=DUZ
D OLD(.BARU)
I '$D(^BARBOB("BARZ",+BARU)) D
.; Ask user if want to create file
.W !
.K DIR
.S DIR(0)="Y"
.S DIR("A")="NO DATA IN BOB, DO YOU WANT TO GENERATE THE FILE NOW?"
.S DIR("B")="N"
.D ^DIR
.I Y=1 D
..D ASKFROM
..Q:BARFROM=""
..;W !!,"Please be have patience, this might take a few minutes" ;MRS:BAR*1.8*10 H2437
..W !!,"Please have patience, this might take a few minutes" ;MRS:BAR*1.8*10 H2437
..D PRE^BARUFEX5(BARFROM,DUZ)
..S BARU=DUZ
Q:'$D(^BARBOB("BARZ",+BARU))
;
BEGIN S %ZIS="MQ"
W !
D ^%ZIS
Q:POP
I $D(IO("Q")) D QUE Q
U IO
D HDR
S BARA=0 F S BARA=$O(^BARBOB("BARZ",BARU,BARA)) Q:'BARA D
.S BARB=0 F S BARB=$O(^BARBOB("BARZ",BARU,BARA,BARB)) Q:'BARB D
. . I '$D(^BARCOL(BARA,BARB)) D Q ;BELCOURT HEAT118656 BAR*1.8*24
. . . I $P($G(^VA(200,DUZ,0)),U,4)'="@" Q
. . . W !,"ENTRY IN COLLECTION BATCH FILE MISSING: BARCOL(",BARA,",",BARB
..S BARCOLB=$P(^BARCOL(BARA,BARB,0),U,1) ;A/R COLLECTION BATCH NAME
..S BARC=0
..F S BARC=$O(^BARBOB("BARZ",BARU,BARA,BARB,BARC)) Q:'BARC D
...S BARTMP=$G(^BARBOB("BARZ",BARU,BARA,BARB,BARC))
...S BARTXT="**REVERSAL BATCH**"
...S:BARTMP=1 BARTXT="**PAYMENTS ONLY**"
...S:BARTMP=2 BARTXT="**PAYMENT BATCH WITH MINUS CODE"
...S:BARTMP=3 BARTXT="**REVERSAL BATCH WITH MINUS CODE**"
...W !,BARA,U,BARCOLB,U,BARC,U,BARTXT
...S BARD=0
...F S BARD=$O(^BARBOB("BARZ",BARU,BARA,BARB,BARC,BARD)) Q:'BARD D
....S BARD0=^BARBOB("BARZ",BARU,BARA,BARB,BARC,BARD)
....S P1=$P(BARD0,U) ;DOLLAR AMOUNT
....S P2=$P(BARD0,U,2) ;SCHEDULE NUMBER
....S P3=$P(BARD0,U,3) ;BILL IEN
....S P4=$P(BARD0,U,4) ;BILL NUMBER
....S P5=$P(BARD0,U,5) ;PAIR FLAG (0,1,2,-3,-4,-6,-7,-25,-I)
....S P6=$P(BARD0,U,6) ;PAIRED COLL BATCH IEN
....S P7=$P(BARD0,U,7) ;PAIRED ITEM NUMBER
....S P8=$P(BARD0,U,8) ;PARIED TRANSACTION
....S:P6]"" P6=$P(^BARCOL(BARA,P6,0),U,1) ;A/R COLLECTION BATCH NAME
....W !,BARA,U,BARCOLB,U,BARC,U,BARD,U
....W P1,U,P2,U,P3,U,P4,U,P5,U,P6,U,P7,U,P8
D ^%ZISC
Q
HDR ;
W U_"BOB REPORT FOR ENDING DATE "_$G(^BARBOB("BARZ",BARU,"END"))
W !,"DUZ(2)",U,"COLLECTION BATCH",U,"BATCH ITEM NUMBER",U
W "TRANSACTION",U,"AMOUNT",U,"TDN/IPAC",U,"BILL IEN",U,"A/R BILL"
W U_"PAIR FLAG"_U_"PAIRED BATCH"_U_"PAIRED ITEM"_U_"PAIRED TX"
W !
Q
QUE ; EP - QUE 'NOT SENT' OR 'DELAY SEND' REPORT
S ZTRTN="^BARUFPRP"
S ZTDESC="BOB PAYMENT REPORT"
S ZTSAVE("XREF")=""
D ^%ZTLOAD
I $D(ZTSK)[0 W !!?5,"Report Cancelled!"
E W !!?5,"Report task #: ",$G(ZTSK)
D HOME^%ZIS
Q
OLD(OLDDUZ) ;FIND MOST RECENT
;^BARBOB("BARZ",1234,"BEGIN")=3080227.100406
; "COUNT")=24903
; "END")=3080227.100614
N A,OLDDT,OLDDUZ
S (OLDDT,OLDDUZ)=""
S A=0
F S A=$O(^BARBOB("BARZ",A)) Q:'A D
.S END=$G(^BARBOB("BARZ",A,"END"))
.I END>OLDDT S OLDDUZ=A
Q
ASKFROM ;EP - ASK FROM DATE
S BARFROM=""
K %DT
S %DT="AET"
S %DT("A")="Enter beginning session date: "
W !
D ^%DT
Q:X=""!(X[U)
I Y<0 W !,"INVALID DATE. TRY AGAIN!" H 2 G ASKFROM
S BARFROM=Y
Q ;EOR
BARUFPRP ; IHS/SD/TPF - REPORT TO WRITE OUT REPORT FILE ;01/26/2009
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,10,24**;OCT 26, 2005;Build 69
EN ;EP;NEW ROUTINE STANDALONE UTILITY TO WRITE OUT BARBOB FILE;MRS:02/04/2008
+1 ;
+2 ; ENTERS WITH
+3 ; BARU = CASHIER WHO CREATED BOB
+4 ; BARA = DUZ(2)
+5 ; BARB = BATCH IEN
+6 ; BARC = BATCH ITEM
+7 ; BARD = TRANSACTION
+8 ;
+9 ;JULY 2013 IHS/SD/POTT HEAT118656 BELCOURT SKIP UNDEF ENTRY IN ^BARCOL BAR*1.8*24
+10 ;
+11 NEW BARA,BARB,BARC,BARD,BARTMP,BARTXT,BARU,BAREND
+12 SET BARU=DUZ
+13 DO OLD(.BARU)
+14 IF '$DATA(^BARBOB("BARZ",+BARU))
Begin DoDot:1
+15 ; Ask user if want to create file
+16 WRITE !
+17 KILL DIR
+18 SET DIR(0)="Y"
+19 SET DIR("A")="NO DATA IN BOB, DO YOU WANT TO GENERATE THE FILE NOW?"
+20 SET DIR("B")="N"
+21 DO ^DIR
+22 IF Y=1
Begin DoDot:2
+23 DO ASKFROM
+24 IF BARFROM=""
QUIT
+25 ;W !!,"Please be have patience, this might take a few minutes" ;MRS:BAR*1.8*10 H2437
+26 ;MRS:BAR*1.8*10 H2437
WRITE !!,"Please have patience, this might take a few minutes"
+27 DO PRE^BARUFEX5(BARFROM,DUZ)
+28 SET BARU=DUZ
End DoDot:2
End DoDot:1
+29 IF '$DATA(^BARBOB("BARZ",+BARU))
QUIT
+30 ;
BEGIN SET %ZIS="MQ"
+1 WRITE !
+2 DO ^%ZIS
+3 IF POP
QUIT
+4 IF $DATA(IO("Q"))
DO QUE
QUIT
+5 USE IO
+6 DO HDR
+7 SET BARA=0
FOR
SET BARA=$ORDER(^BARBOB("BARZ",BARU,BARA))
IF 'BARA
QUIT
Begin DoDot:1
+8 SET BARB=0
FOR
SET BARB=$ORDER(^BARBOB("BARZ",BARU,BARA,BARB))
IF 'BARB
QUIT
Begin DoDot:2
+9 ;BELCOURT HEAT118656 BAR*1.8*24
IF '$DATA(^BARCOL(BARA,BARB))
Begin DoDot:3
+10 IF $PIECE($GET(^VA(200,DUZ,0)),U,4)'="@"
QUIT
+11 WRITE !,"ENTRY IN COLLECTION BATCH FILE MISSING: BARCOL(",BARA,",",BARB
End DoDot:3
QUIT
+12 ;A/R COLLECTION BATCH NAME
SET BARCOLB=$PIECE(^BARCOL(BARA,BARB,0),U,1)
+13 SET BARC=0
+14 FOR
SET BARC=$ORDER(^BARBOB("BARZ",BARU,BARA,BARB,BARC))
IF 'BARC
QUIT
Begin DoDot:3
+15 SET BARTMP=$GET(^BARBOB("BARZ",BARU,BARA,BARB,BARC))
+16 SET BARTXT="**REVERSAL BATCH**"
+17 IF BARTMP=1
SET BARTXT="**PAYMENTS ONLY**"
+18 IF BARTMP=2
SET BARTXT="**PAYMENT BATCH WITH MINUS CODE"
+19 IF BARTMP=3
SET BARTXT="**REVERSAL BATCH WITH MINUS CODE**"
+20 WRITE !,BARA,U,BARCOLB,U,BARC,U,BARTXT
+21 SET BARD=0
+22 FOR
SET BARD=$ORDER(^BARBOB("BARZ",BARU,BARA,BARB,BARC,BARD))
IF 'BARD
QUIT
Begin DoDot:4
+23 SET BARD0=^BARBOB("BARZ",BARU,BARA,BARB,BARC,BARD)
+24 ;DOLLAR AMOUNT
SET P1=$PIECE(BARD0,U)
+25 ;SCHEDULE NUMBER
SET P2=$PIECE(BARD0,U,2)
+26 ;BILL IEN
SET P3=$PIECE(BARD0,U,3)
+27 ;BILL NUMBER
SET P4=$PIECE(BARD0,U,4)
+28 ;PAIR FLAG (0,1,2,-3,-4,-6,-7,-25,-I)
SET P5=$PIECE(BARD0,U,5)
+29 ;PAIRED COLL BATCH IEN
SET P6=$PIECE(BARD0,U,6)
+30 ;PAIRED ITEM NUMBER
SET P7=$PIECE(BARD0,U,7)
+31 ;PARIED TRANSACTION
SET P8=$PIECE(BARD0,U,8)
+32 ;A/R COLLECTION BATCH NAME
IF P6]""
SET P6=$PIECE(^BARCOL(BARA,P6,0),U,1)
+33 WRITE !,BARA,U,BARCOLB,U,BARC,U,BARD,U
+34 WRITE P1,U,P2,U,P3,U,P4,U,P5,U,P6,U,P7,U,P8
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 DO ^%ZISC
+36 QUIT
HDR ;
+1 WRITE U_"BOB REPORT FOR ENDING DATE "_$GET(^BARBOB("BARZ",BARU,"END"))
+2 WRITE !,"DUZ(2)",U,"COLLECTION BATCH",U,"BATCH ITEM NUMBER",U
+3 WRITE "TRANSACTION",U,"AMOUNT",U,"TDN/IPAC",U,"BILL IEN",U,"A/R BILL"
+4 WRITE U_"PAIR FLAG"_U_"PAIRED BATCH"_U_"PAIRED ITEM"_U_"PAIRED TX"
+5 WRITE !
+6 QUIT
QUE ; EP - QUE 'NOT SENT' OR 'DELAY SEND' REPORT
+1 SET ZTRTN="^BARUFPRP"
+2 SET ZTDESC="BOB PAYMENT REPORT"
+3 SET ZTSAVE("XREF")=""
+4 DO ^%ZTLOAD
+5 IF $DATA(ZTSK)[0
WRITE !!?5,"Report Cancelled!"
+6 IF '$TEST
WRITE !!?5,"Report task #: ",$GET(ZTSK)
+7 DO HOME^%ZIS
+8 QUIT
OLD(OLDDUZ) ;FIND MOST RECENT
+1 ;^BARBOB("BARZ",1234,"BEGIN")=3080227.100406
+2 ; "COUNT")=24903
+3 ; "END")=3080227.100614
+4 NEW A,OLDDT,OLDDUZ
+5 SET (OLDDT,OLDDUZ)=""
+6 SET A=0
+7 FOR
SET A=$ORDER(^BARBOB("BARZ",A))
IF 'A
QUIT
Begin DoDot:1
+8 SET END=$GET(^BARBOB("BARZ",A,"END"))
+9 IF END>OLDDT
SET OLDDUZ=A
End DoDot:1
+10 QUIT
ASKFROM ;EP - ASK FROM DATE
+1 SET BARFROM=""
+2 KILL %DT
+3 SET %DT="AET"
+4 SET %DT("A")="Enter beginning session date: "
+5 WRITE !
+6 DO ^%DT
+7 IF X=""!(X[U)
QUIT
+8 IF Y<0
WRITE !,"INVALID DATE. TRY AGAIN!"
HANG 2
GOTO ASKFROM
+9 SET BARFROM=Y
+10 ;EOR
QUIT
