BAREDPCS.m

BAREDPCS ; IHS/SD/SDR - ERA Check Summary Report ; 

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**20,21**;OCT 26,2005

 ; new routine

 ; *******************************************************************

EN ;

 D SELFL^BAREDP00  ;prompt for Import name/Check/EFT trace

 ;IHS/SD/TPF 8/22/2001 BAR*1.8*21

 I +$G(IMPDA)=0 Q  ;bar*1.8*21 SDR

 I TRNAME[("5010") D EN1^BAR50PCS Q

 ;END BAR*1.8*21

EN1 ;

 F  D  Q:$D(DIRUT)  Q:$D(BARMEDIA)                   ; Ask Browse or print

 .D ASK^BAREDP10  ;prompt for print/browse

 I ('$D(IMPDA)!('$D(BARMEDIA))) D  Q

 .D PAZ^BARRUTL

 .D XIT

 S $P(BARDASH,"-",81)=""

 S $P(BARSTAR,"*",81)=""

 D SETHDR                   ; Set up report header

 I BARMEDIA="B" D BROWSE

 I BARMEDIA="P" D PRINT

 D XIT

 Q

SETHDR ;

 ; Set up Report Header lines

 K BARPCIEN,BARPC,BARIIEN,BARAIEN

 K IMP

 D ENP^XBDIQ1(90056.02,IMPDA,".01;.05","IMP(")

 S BAR("HD",0)="ERA CHECK NUMBER AND CHECK AMOUNTS REPORT"

 S BAR("HD",1)="LOCATION: "_$$GET1^DIQ(4,DUZ(2),.01)

 S BAR("HD",2)="FOR FILE NAME: "_IMP(.05)

 S BARTMP=BAR("HD",2)  ;IHS/SD/TPF 7/27/2011 bar*1.8*21 HEAT42678

 D PAD

 S BAR("HD",3)="FOR RPMS FILE: "_IMP(.01)

 S BAR("HD",4)=BARDASH

 Q

PAD ;

 N L,I

 S L=$L(BARTMP)

 F I=L:1:50 S BARTMP=BARTMP_" "

 Q

BROWSE ;

 ; Browse report to screen

 ; GET DEVICE (QUEUEING ALLOWED)

 S XBFLD("BROWSE")=1

 S BARIOSL=IOSL

 S IOSL=600

 D VIEWR^XBLM("PRINTD^BAREDPCS")

 D FULL^VALM1

 W $$EN^BARVDF("IOF")

 D CLEAR^VALM1  ;clears out all list man stuff

 K XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF

 K VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP

 K VALMY,XQORS,XQORSPEW,VALMCOFF

 S IOSL=BARIOSL

 Q

 ; ********************************************************************

 ;

PRINT ;

 ; Print report to device.  Queuing allowed.

 S BARQ("RC")="COMPUTE^BAREDPCS"      ; Build tmp global with data

 S BARQ("RP")="PRINTD^BAREDPCS"       ; Print reports from tmp global

 S BARQ("NS")="BAR"                  ; Namespace for variables

 S ZTSAVE("IMPDA")=""

 S BARQ("RX")="POUT^BARRUTL"         ; Clean-up routine

 D ^BARDBQUE                         ; Double queuing

 Q

COMPUTE ;EP

 ; Compute line tag required by BARDBQUE but all processing

 ; is done under PRINT so just quit here

 Q

 ; ********************************************************************

 ;

PRINTD ; EP

 ; PRINT the report (Browse or Print)

 S BAR("PG")=0

 D DETAIL

 W !!!,"**This 835 ERA File contains "_BARTCHKS_" BPR segments totaling $"_$FN(BARTAMT,",",2)

 W !,"**Use the Check Posting Summary (CPS) to confirm checks have been batched",!

 I $G(BAR("F1"))="" D

 . W !,$$CJ^XLFSTR("* * E N D   O F   R E P O R T * *",IOM)

 . D PAZ^BARRUTL

 Q

 ; ********************************************************************

 ;

HD ; EP

 D PAZ^BARRUTL

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BAR("F1")=1 Q

 ; -------------------------------

 ;

HDB ; EP

 S BAR("COL")="W !,""SET"",?11,""PAYER"",?26,""CD"",?30,""PAYMENT"",?45,""CHECK"",?71,""CHK DATE"""

 S BAR("PG")=BAR("PG")+1

 I BAR("PG")>1 S BAR("LVL")=4

 D WHD^BARRHD

 X BAR("COL")

 W !,BARDASH

 Q

 ; ********************************************************************

 ;

DETAIL ;

 ; Print report in brief and detail format

 D HDB

 I $Y>(IOSL-5) D HD Q:$G(BAR("F1"))

 S BARCK=""

 K BARTAMT,BARAMT,BARTCHKS

 S BARCK=0,BARTCHKS=0,BARTAMT=0

 F  S BARCK=$O(^BAREDI("I",DUZ(2),IMPDA,5,BARCK)) Q:'BARCK  D  Q:$G(BAR("F1"))

 .Q:$G(BAR("F1"))

 .S BARCHK=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U)  ;check

 .S BARST=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,2)  ;trans set control#

 .S BARAMT=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,3)  ;check amount

 .S BARTCD=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,4)  ;trans handling code

 .S BARDT=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,5)  ;check issue date

 .S BARPYR=$P($G(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,6)  ;payer

 .W !,$E(BARST,($L(BARST)-3),$L(BARST)),?6,$E(BARPYR,1,18),?26,BARTCD,?28,$J($FN(BARAMT,",",2),12),?41,BARCHK,?71,$$SHDT^BARDUTL(BARDT)

 .S BARTCHKS=+$G(BARTCHKS)+1  ;count # of ERA checks

 .S BARTAMT=+$G(BARTAMT)+BARAMT  ;count total ERA amount

 Q

XIT ;

 D ^BARVKL0

 Q

BAREDPCS  ; IHS/SD/SDR - ERA Check Summary Report ; 

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**20,21**;OCT 26,2005

 +2       ; new routine

 +3       ; *******************************************************************

EN        ;

 +1       ;prompt for Import name/Check/EFT trace

           DO SELFL^BAREDP00

 +2       ;IHS/SD/TPF 8/22/2001 BAR*1.8*21

 +3       ;bar*1.8*21 SDR

           IF +$GET(IMPDA)=0

               QUIT 

 +4        IF TRNAME[("5010")

               DO EN1^BAR50PCS

               QUIT 

 +5       ;END BAR*1.8*21

EN1       ;

 +1       ; Ask Browse or print

           FOR 

               Begin DoDot:1

 +2       ;prompt for print/browse

                   DO ASK^BAREDP10

               End DoDot:1

               IF $DATA(DIRUT)

                   QUIT 

               IF $DATA(BARMEDIA)

                   QUIT 

 +3        IF ('$DATA(IMPDA)!('$DATA(BARMEDIA)))

               Begin DoDot:1

 +4                DO PAZ^BARRUTL

 +5                DO XIT

               End DoDot:1

               QUIT 

 +6        SET $PIECE(BARDASH,"-",81)=""

 +7        SET $PIECE(BARSTAR,"*",81)=""

 +8       ; Set up report header

           DO SETHDR

 +9        IF BARMEDIA="B"

               DO BROWSE

 +10       IF BARMEDIA="P"

               DO PRINT

 +11       DO XIT

 +12       QUIT 

SETHDR    ;

 +1       ; Set up Report Header lines

 +2        KILL BARPCIEN,BARPC,BARIIEN,BARAIEN

 +3        KILL IMP

 +4        DO ENP^XBDIQ1(90056.02,IMPDA,".01;.05","IMP(")

 +5        SET BAR("HD",0)="ERA CHECK NUMBER AND CHECK AMOUNTS REPORT"

 +6        SET BAR("HD",1)="LOCATION: "_$$GET1^DIQ(4,DUZ(2),.01)

 +7        SET BAR("HD",2)="FOR FILE NAME: "_IMP(.05)

 +8       ;IHS/SD/TPF 7/27/2011 bar*1.8*21 HEAT42678

           SET BARTMP=BAR("HD",2)

 +9        DO PAD

 +10       SET BAR("HD",3)="FOR RPMS FILE: "_IMP(.01)

 +11       SET BAR("HD",4)=BARDASH

 +12       QUIT 

PAD       ;

 +1        NEW L,I

 +2        SET L=$LENGTH(BARTMP)

 +3        FOR I=L:1:50

               SET BARTMP=BARTMP_" "

 +4        QUIT 

BROWSE    ;

 +1       ; Browse report to screen

 +2       ; GET DEVICE (QUEUEING ALLOWED)

 +3        SET XBFLD("BROWSE")=1

 +4        SET BARIOSL=IOSL

 +5        SET IOSL=600

 +6        DO VIEWR^XBLM("PRINTD^BAREDPCS")

 +7        DO FULL^VALM1

 +8        WRITE $$EN^BARVDF("IOF")

 +9       ;clears out all list man stuff

           DO CLEAR^VALM1

 +10       KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF

 +11       KILL VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP

 +12       KILL VALMY,XQORS,XQORSPEW,VALMCOFF

 +13       SET IOSL=BARIOSL

 +14       QUIT 

 +15      ; ********************************************************************

 +16      ;

PRINT     ;

 +1       ; Print report to device.  Queuing allowed.

 +2       ; Build tmp global with data

           SET BARQ("RC")="COMPUTE^BAREDPCS"

 +3       ; Print reports from tmp global

           SET BARQ("RP")="PRINTD^BAREDPCS"

 +4       ; Namespace for variables

           SET BARQ("NS")="BAR"

 +5        SET ZTSAVE("IMPDA")=""

 +6       ; Clean-up routine

           SET BARQ("RX")="POUT^BARRUTL"

 +7       ; Double queuing

           DO ^BARDBQUE

 +8        QUIT 

COMPUTE   ;EP

 +1       ; Compute line tag required by BARDBQUE but all processing

 +2       ; is done under PRINT so just quit here

 +3        QUIT 

 +4       ; ********************************************************************

 +5       ;

PRINTD    ; EP

 +1       ; PRINT the report (Browse or Print)

 +2        SET BAR("PG")=0

 +3        DO DETAIL

 +4        WRITE !!!,"**This 835 ERA File contains "_BARTCHKS_" BPR segments totaling $"_$FNUMBER(BARTAMT,",",2)

 +5        WRITE !,"**Use the Check Posting Summary (CPS) to confirm checks have been batched",!

 +6        IF $GET(BAR("F1"))=""

               Begin DoDot:1

 +7                WRITE !,$$CJ^XLFSTR("* * E N D   O F   R E P O R T * *",IOM)

 +8                DO PAZ^BARRUTL

               End DoDot:1

 +9        QUIT 

 +10      ; ********************************************************************

 +11      ;

HD        ; EP

 +1        DO PAZ^BARRUTL

 +2        IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               SET BAR("F1")=1

               QUIT 

 +3       ; -------------------------------

 +4       ;

HDB       ; EP

 +1        SET BAR("COL")="W !,""SET"",?11,""PAYER"",?26,""CD"",?30,""PAYMENT"",?45,""CHECK"",?71,""CHK DATE"""

 +2        SET BAR("PG")=BAR("PG")+1

 +3        IF BAR("PG")>1

               SET BAR("LVL")=4

 +4        DO WHD^BARRHD

 +5        XECUTE BAR("COL")

 +6        WRITE !,BARDASH

 +7        QUIT 

 +8       ; ********************************************************************

 +9       ;

DETAIL    ;

 +1       ; Print report in brief and detail format

 +2        DO HDB

 +3        IF $Y>(IOSL-5)

               DO HD

               IF $GET(BAR("F1"))

                   QUIT 

 +4        SET BARCK=""

 +5        KILL BARTAMT,BARAMT,BARTCHKS

 +6        SET BARCK=0

           SET BARTCHKS=0

           SET BARTAMT=0

 +7        FOR 

               SET BARCK=$ORDER(^BAREDI("I",DUZ(2),IMPDA,5,BARCK))

               IF 'BARCK

                   QUIT 

               Begin DoDot:1

 +8                IF $GET(BAR("F1"))

                       QUIT 

 +9       ;check

                   SET BARCHK=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U)

 +10      ;trans set control#

                   SET BARST=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,2)

 +11      ;check amount

                   SET BARAMT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,3)

 +12      ;trans handling code

                   SET BARTCD=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,4)

 +13      ;check issue date

                   SET BARDT=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,5)

 +14      ;payer

                   SET BARPYR=$PIECE($GET(^BAREDI("I",DUZ(2),IMPDA,5,BARCK,0)),U,6)

 +15               WRITE !,$EXTRACT(BARST,($LENGTH(BARST)-3),$LENGTH(BARST)),?6,$EXTRACT(BARPYR,1,18),?26,BARTCD,?28,$JUSTIFY($FNUMBER(BARAMT,",",2),12),?41,BARCHK,?71,$$SHDT^BARDUTL(BARDT)

 +16      ;count # of ERA checks

                   SET BARTCHKS=+$GET(BARTCHKS)+1

 +17      ;count total ERA amount

                   SET BARTAMT=+$GET(BARTAMT)+BARAMT

               End DoDot:1

               IF $GET(BAR("F1"))

                   QUIT 

 +18       QUIT 

XIT       ;

 +1        DO ^BARVKL0

 +2        QUIT