BAREDP12.m

BAREDP12 ; IHS/SD/SDR - AR ERA Batch/Item matching ; 01/30/2009

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

 Q

EN ;

 S BAR("PG")=0

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

 D SETHDR

 D HDB

 S BARI=0

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

 .S BARREC=$G(^BAREDI("I",DUZ(2),IMPDA,5,BARI,0))

 .S BARST=$P(BARREC,U,2)

 .Q:($P(BARREC,U,7)'="")

 .W !?1,$E(BARST,($L(BARST)-3),$L(BARST))  ;ST

 .I $P(BARREC,U,9) W "*" S BARPLB=1  ;PLB on chk

 .W ?12,$E($P(BARREC,U,6),1,25)  ;payer

 .W ?40,$P(BARREC,U)  ;Check#

 .W ?65,$J($FN($P(BARREC,U,3),",",2),12)

 I +$G(BARPLB)>0 W !!?1,"* - Indicates a PLB segment has been located on this check."

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

 D PAZ^BARRUTL

 Q

SETHDR ;

 ;Set up Rpt Hdr

 K BARPCIEN,BARPC,BARIIEN,BARAIEN

 K IMP

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

 S BAR("HD",0)="NOT FOUND REPORT"

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

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

 Q

HDB ;EP

 S BAR("COL")="W !,""ST"",?12,""PAYER"",?40,""CHECK# (TRN02)"",?65,""PAYMENT (BPR02)"""

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

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

 D WHD^BARRHD

 X BAR("COL")

 W !,BARDASH,!

 Q

BAREDP12  ; IHS/SD/SDR - AR ERA Batch/Item matching ; 01/30/2009

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

 +2        QUIT 

EN        ;

 +1        SET BAR("PG")=0

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

 +3        DO SETHDR

 +4        DO HDB

 +5        SET BARI=0

 +6        FOR 

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

               IF 'BARI

                   QUIT 

               Begin DoDot:1

 +7                SET BARREC=$GET(^BAREDI("I",DUZ(2),IMPDA,5,BARI,0))

 +8                SET BARST=$PIECE(BARREC,U,2)

 +9                IF ($PIECE(BARREC,U,7)'="")

                       QUIT 

 +10      ;ST

                   WRITE !?1,$EXTRACT(BARST,($LENGTH(BARST)-3),$LENGTH(BARST))

 +11      ;PLB on chk

                   IF $PIECE(BARREC,U,9)

                       WRITE "*"

                       SET BARPLB=1

 +12      ;payer

                   WRITE ?12,$EXTRACT($PIECE(BARREC,U,6),1,25)

 +13      ;Check#

                   WRITE ?40,$PIECE(BARREC,U)

 +14               WRITE ?65,$JUSTIFY($FNUMBER($PIECE(BARREC,U,3),",",2),12)

               End DoDot:1

 +15       IF +$GET(BARPLB)>0

               WRITE !!?1,"* - Indicates a PLB segment has been located on this check."

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

 +17       DO PAZ^BARRUTL

 +18       QUIT 

SETHDR    ;

 +1       ;Set up Rpt Hdr

 +2        KILL BARPCIEN,BARPC,BARIIEN,BARAIEN

 +3        KILL IMP

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

 +5        SET BAR("HD",0)="NOT FOUND REPORT"

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

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

 +8        QUIT 

HDB       ;EP

 +1        SET BAR("COL")="W !,""ST"",?12,""PAYER"",?40,""CHECK# (TRN02)"",?65,""PAYMENT (BPR02)"""

 +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