BAR50P10 ; IHS/SD/LSL - NEW REPORT ERA CLAIMS ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,20,21,22**;OCT 26,2005;Build 38
;
; IHS/SD/LSL - 10/1/03 - V1.7 Patch 4 - HIPAA
; Routine Created
;
; IHS/SD/LSL - 02/26/04 - V1.7 Patch 5
; Change check to chk/eft
;
; IHS/SD/RTL - 04/8/05 - V1.8 Patch 1
; Can't view check detail in ERA Claim Report
; IHS/SD/SDR - 1/5/2011 - V1.8 P20 - Included new status Exception (E)
;
; ********************************************************************
;;
EN ; EP
D DISP ; Display File and Check choice
D INIT ; Initialize Variables
F D Q:+BARDONE Q:($D(BARINDX)&$D(BARTYP)&$D(BARMEDIA))
. D STATUS ; Ask which Claim status to report
. Q:'$D(BARINDX)
. F D Q:'$D(BARTYP) Q:($D(BARTYP)&$D(BARMEDIA))
. . D RPTYP ; Ask report type
. . Q:'$D(BARTYP)
. . F D Q:$D(DIRUT) Q:$D(BARMEDIA) ; Ask Browse or print
. . . D ASK
I ('$D(BARINDX)!('$D(BARTYP))!('$D(BARMEDIA))) D Q
. D PAZ^BARRUTL
. D XIT
D SETHDR ; Set up report header
I BARMEDIA="B" D BROWSE
E D PRINT
;D PAZ^BARRUTL
D XIT
Q
; ********************************************************************
;
DISP ;
; Display File and Check Choices for report
K IMP
D ENP^XBDIQ1(90056.02,IMPDA,".01;.05","IMP(")
W !,@IOF,!,"Reports for : ",?20,IMP(.01)
W !,?20,IMP(.05),?50,"CHK/EFT #: ",$E(BARCHK,1,23)
Q
; ********************************************************************
INIT ;
;
S BARDONE=0
S BAR("PRIVACY")=1 ; Privacy act applies (used BARRHD)
S $P(BARDASH,"-",81)=""
S $P(BARSTAR,"*",81)=""
F I=0,2 S BARCHK(I)=$G(^BARECHK(BARCKIEN,I))
S BARZ("C")="CLAIM UNMATCHED"
S BARZ("C","HDR")="= = = = = = = = = = = = C L A I M U N M A T C H E D = = = = = = = = = = ="
S BARZ("P")="POSTED"
S BARZ("P","HDR")="= = = = = = = = = = = = = = = = P O S T E D = = = = = = = = = = = = = = = ="
S BARZ("M")="MATCHED"
S BARZ("M","HDR")="= = = = = = = = = = = = = = = = M A T C H E D = = = = = = = = = = = = = = ="
S BARZ("N")="NOT TO POST"
S BARZ("N","HDR")="= = = = = = = = = = = = = = N O T T O P O S T = = = = = = = = = = = = ="
S BARZ("X")="CLAIM & REASON UNMATCHED"
S BARZ("X","HDR")="= = = = = = = C L A I M & R E A S O N U N M A T C H E D = = = = = = ="
S BARZ("R")="REASON UNMATCHED"
S BARZ("R","HDR")="= = = = = = = = = = = R E A S O N U N M A T C H E D = = = = = = = = = = ="
;start new code bar*1.8*20 REQ7
S BARZ("E")="EXCEPTION"
S BARZ("E","HDR")="= = = = = = = = = = = = = = = E X C E P T I O N= = = = = = = = = = = = = = ="
;end new code REQ7
;start new code bar*1.8*20
S BARZ("W")="MATCHED W/REASON NOT TO POST"
S BARZ("W","HDR")="= = = = = M A T C H E D W / R E A S O N N O T T O P O S T = = = = = ="
;end new code
Q
; ********************************************************************
;
STATUS ;
; Select claim status for reports
W !!,"Enter the list of Claim Status(s) you desire to print,"
W !,"and in the sequence to be printed out.",!
W !,"C - Claim Unmatched",?25,"R - Reason Unmatched",?50,"N - Not to Post"
W !,"M - Matched",?25,"P - Posted",?50,"X - Claim & Reason Unmatched"
;W !,"A - All Categories",!,?5,"Example: CRXN",! ;bar*1.8*20 REQ7
W !,"A - All Categories",?25,"E - Exception",!,?5,"Example: CRXN",! ;bar*1.8*20 REQ7
S BARBAD=0
K DIR,BARINDX
;S DIR(0)="FO^0:6" ;bar*1.8*20 REQ7
S DIR(0)="FO^0:7" ;bar*1.8*20 REQ7
D ^DIR
K DIR
S Y=$$UPC^BARUTL(Y) ;bar*1.8*20
I $L(Y)'>0 D Q
. W !!,"NONE SELECTED - EXITING",!
. S BARDONE=1
I Y="^" S BARDONE=1 Q
;S Z="CRNMPX" ;bar*1.8*20 REQ7
S Z="CRNMPXE" ;bar*1.8*20 REQ7
I Y="A" S Y=Z
;S Z="CRNMPX" ;bar*1.8*20 REQ7
S Z="CRNMPXE" ;bar*1.8*20 REQ7
F I=1:1:$L(Y) I Z'[$E(Y,I) D Q
. W !!,">>>BAD ENTRY<<<>>> ",Y
. S BARBAD=1
Q:+BARBAD
S BARINDX=Y
Q
; ********************************************************************
;
RPTYP ;
; Select Report Type
W !
K DIR,BARTYP
S DIR(0)="SOB^D:Detailed;B:Brief - One Line;S:Summary - Totals Only"
S DIR("A")="Select the type of report: "
D ^DIR
K DIR
I $D(DUOUT)!($D(DTOUT)) Q
Q:(",D,B,S,"'[(","_Y_","))
S BARTYP=Y
S BARTYP("NAME")=Y(0)
Q
; ********************************************************************
;
ASK ;
; Ask Browse or Print
K DIRUT,DIR,Y
S Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)
K DA
Q:$D(DIRUT)
S BARMEDIA=Y
S BARMEDIA("NAME")=Y(0)
Q
; ********************************************************************
;
SETHDR ;
; Set up Report Header lines
K BARPCIEN,BARPC,BARIIEN,BARAIEN
; Find payer contact.
; BARPC(Count)=#^type of number^name
S BARPCIEN=0
F S BARPCIEN=$O(^BARECHK(BARCKIEN,3,BARPCIEN)) Q:'+BARPCIEN D
. S BARPC(BARPCIEN)=$G(^BARECHK(BARCKIEN,3,BARPCIEN,0))
I '$D(BARPC) D
. I $P(BARCHK(0),U,3)="" S BARPC(1)="" Q
. I $P(BARCHK(0),U,4)="" S BARPC(1)="" Q
. S BARAIEN=$P($G(^BARCOL(DUZ(2),$P(BARCHK(0),U,3),1,$P(BARCHK(0),U,4),0)),U,7)
. I BARAIEN="" S BARPC(1)="" Q
. S BARIIEN=$P($G(^BARAC(DUZ(2),BARAIEN,0)),U,1)
. I BARIIEN'["AUTNINS" S BARPC(1)="" Q
. S BARPC(1)=$P($G(^AUTNINS(+BARIIEN,0)),U,6)
. I BARPC(1)="" S BARPC(1)="" Q
. S $P(BARPC(1),U,3)=$P($G(^AUTNINS(+BARIIEN,0)),U,9)
;
S BAR("HD",0)="ELECTRONIC CLAIM REPORT - "_$P(BARTYP("NAME")," ")
S BARTMP="FOR FILE NAME: "_IMP(.05)
D PAD
;S BAR("HD",1)=BARTMP_"CHECK/EFT TRACE: "_$E(BARCHK,1,12) ;bar*1.8*22 SDR
S BAR("HD",1)=BARTMP_"CHECK/EFT TRACE: "_$E(BARCHK,1,20) ;bar*1.8*22 SDR
;BAR*1.8*1 SRS ADDENDUM FOR BAR*1.8*1
S BARTMP=" "
D PAD
I $P(BARCHK(0),U,8)="XX" D
.S BAR("HD",1.5)=BARTMP_" NPI: "_$P(BARCHK(0),U,9)
E S BAR("HD",1.5)=BARTMP_" TIN: "_$P(BARCHK(0),U,11)
;END
S BAR("HD",2)="FOR RPMS FILE: "_IMP(.01)_" FOR "_$P(BARCHK(0),U,7)
S BAR("HD",3)=BARDASH
S BARTMP=$$GET1^DIQ(90056.22,BARCKIEN,.03)
S BARTMP="BATCH: "_$S(BARTMP="":"** No RPMS match **",1:BARTMP)
D PAD
S BAR("HD",4)=BARTMP_"ITEM # "_$P(BARCHK(0),U,4)
S BAR("HD",5)=BARDASH
;
S BARTMP=$P(BARCHK(2),U)
D PAD
S BAR("HD",6)=BARTMP ; Payer name (RA)
S BARTMP=$P(BARCHK(2),U,2)
D PAD
S BAR("HD",7)=BARTMP ; Payer Address (RA)
S BARLCNT=7
I $P(BARCHK(2),U,3)]"" D
. S BARLCNT=BARLCNT+1
. S BARTMP=$P(BARCHK(2),U,3)
. D PAD
. S BAR("HD",BARLCNT)=BARTMP ; Payer address 2 (RA)
S BARLCNT=BARLCNT+1
I $P(BARCHK(2),U,6)'["-",$L($P(BARCHK(2),U,6))>5 S $P(BARCHK(2),U,6)=$E($P(BARCHK(2),U,6),1,5)_"-"_$E($P(BARCHK(2),U,6),6,9)
S BARTMP=$P(BARCHK(2),U,4)_", "_$P(BARCHK(2),U,5)_" "_$P(BARCHK(2),U,6)
D PAD
S BAR("HD",BARLCNT)=BARTMP
S BAR("LVL")=BARLCNT
S I=$O(BARPC(0))
Q:BARPC(I)="" ; No payer contact info
S BAR("HD",6)=BAR("HD",6)_$S($P(BARPC(I),U,3)]"":$P(BARPC(I),U,3),1:"CUSTOMER SERVICE")
K I,J,K
S I=0
S BARLCNT=6
F S I=$O(BARPC(I)) Q:'+I!(BARLCNT>9) D
. S BARLCNT=BARLCNT+1
. S BARCTYP=$S($P(BARPC(I),U,2)="":"PH: ",$P(BARPC(I),U,2)="TE":"PH: ",$P(BARPC(I),U,2)="FX":"FX: ",1:"")
. S $P(BARPC(I),U)=$TR($P(BARPC(I),U),")-","")
. S BARTMP=$P(BARPC(I),U)
. I (BARCTYP="PH: "!(BARCTYP="FX: ")) D
. . I $L(BARTMP)=10 S $P(BARPC(I),U)="("_$E(BARTMP,1,3)_") "_$E(BARTMP,4,6)_"-"_$E(BARTMP,7,10)
. . I $L(BARTMP)=7 S $P(BARPC(I),U)=$E(BARTMP,1,3)_"-"_$E(BARTMP,4,7)
. I '$D(BAR("HD",BARLCNT)) D
. . S BARTMP=" "
. . D PAD
. . S BAR("HD",BARLCNT)=BARTMP
. S BAR("HD",BARLCNT)=BAR("HD",BARLCNT)_BARCTYP_$P(BARPC(I),U)
I BARLCNT>BAR("LVL") S BAR("LVL")=BARLCNT
Q
; ********************************************************************
;
PAD ;
; Fixed undefined error in detail report.
; (Reported previously in IM17021.)
;K L
N L,I ;IM17021
S L=$L(BARTMP)
;F I=L:1:50 S BARTMP=BARTMP_" " ;bar*1.8*22 SDR
F I=L:1:43 S BARTMP=BARTMP_" " ;bar*1.8*22 SDR
;K L,I ;IM17021
Q
; ********************************************************************
;
BROWSE ;
; Browse report to screen
; GET DEVICE (QUEUEING ALLOWED)
S XBFLD("BROWSE")=1
S BARIOSL=IOSL
S IOSL=600
D VIEWR^XBLM("PRINT^BAR50P11")
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^BAREDP11" ; Build tmp global with data
S BARQ("RP")="PRINT^BAREDP11" ; 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
; *********************************************************************
;
XIT ;
D ^BARVKL0
Q
BAR50P10 ; IHS/SD/LSL - NEW REPORT ERA CLAIMS ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,20,21,22**;OCT 26,2005;Build 38
+2 ;
+3 ; IHS/SD/LSL - 10/1/03 - V1.7 Patch 4 - HIPAA
+4 ; Routine Created
+5 ;
+6 ; IHS/SD/LSL - 02/26/04 - V1.7 Patch 5
+7 ; Change check to chk/eft
+8 ;
+9 ; IHS/SD/RTL - 04/8/05 - V1.8 Patch 1
+10 ; Can't view check detail in ERA Claim Report
+11 ; IHS/SD/SDR - 1/5/2011 - V1.8 P20 - Included new status Exception (E)
+12 ;
+13 ; ********************************************************************
+14 ;;
EN ; EP
+1 ; Display File and Check choice
DO DISP
+2 ; Initialize Variables
DO INIT
+3 FOR
Begin DoDot:1
+4 ; Ask which Claim status to report
DO STATUS
+5 IF '$DATA(BARINDX)
QUIT
+6 FOR
Begin DoDot:2
+7 ; Ask report type
DO RPTYP
+8 IF '$DATA(BARTYP)
QUIT
+9 ; Ask Browse or print
FOR
Begin DoDot:3
+10 DO ASK
End DoDot:3
IF $DATA(DIRUT)
QUIT
IF $DATA(BARMEDIA)
QUIT
End DoDot:2
IF '$DATA(BARTYP)
QUIT
IF ($DATA(BARTYP)&$DATA(BARMEDIA))
QUIT
End DoDot:1
IF +BARDONE
QUIT
IF ($DATA(BARINDX)&$DATA(BARTYP)&$DATA(BARMEDIA))
QUIT
+11 IF ('$DATA(BARINDX)!('$DATA(BARTYP))!('$DATA(BARMEDIA)))
Begin DoDot:1
+12 DO PAZ^BARRUTL
+13 DO XIT
End DoDot:1
QUIT
+14 ; Set up report header
DO SETHDR
+15 IF BARMEDIA="B"
DO BROWSE
+16 IF '$TEST
DO PRINT
+17 ;D PAZ^BARRUTL
+18 DO XIT
+19 QUIT
+20 ; ********************************************************************
+21 ;
DISP ;
+1 ; Display File and Check Choices for report
+2 KILL IMP
+3 DO ENP^XBDIQ1(90056.02,IMPDA,".01;.05","IMP(")
+4 WRITE !,@IOF,!,"Reports for : ",?20,IMP(.01)
+5 WRITE !,?20,IMP(.05),?50,"CHK/EFT #: ",$EXTRACT(BARCHK,1,23)
+6 QUIT
+7 ; ********************************************************************
INIT ;
+1 ;
+2 SET BARDONE=0
+3 ; Privacy act applies (used BARRHD)
SET BAR("PRIVACY")=1
+4 SET $PIECE(BARDASH,"-",81)=""
+5 SET $PIECE(BARSTAR,"*",81)=""
+6 FOR I=0,2
SET BARCHK(I)=$GET(^BARECHK(BARCKIEN,I))
+7 SET BARZ("C")="CLAIM UNMATCHED"
+8 SET BARZ("C","HDR")="= = = = = = = = = = = = C L A I M U N M A T C H E D = = = = = = = = = = ="
+9 SET BARZ("P")="POSTED"
+10 SET BARZ("P","HDR")="= = = = = = = = = = = = = = = = P O S T E D = = = = = = = = = = = = = = = ="
+11 SET BARZ("M")="MATCHED"
+12 SET BARZ("M","HDR")="= = = = = = = = = = = = = = = = M A T C H E D = = = = = = = = = = = = = = ="
+13 SET BARZ("N")="NOT TO POST"
+14 SET BARZ("N","HDR")="= = = = = = = = = = = = = = N O T T O P O S T = = = = = = = = = = = = ="
+15 SET BARZ("X")="CLAIM & REASON UNMATCHED"
+16 SET BARZ("X","HDR")="= = = = = = = C L A I M & R E A S O N U N M A T C H E D = = = = = = ="
+17 SET BARZ("R")="REASON UNMATCHED"
+18 SET BARZ("R","HDR")="= = = = = = = = = = = R E A S O N U N M A T C H E D = = = = = = = = = = ="
+19 ;start new code bar*1.8*20 REQ7
+20 SET BARZ("E")="EXCEPTION"
+21 SET BARZ("E","HDR")="= = = = = = = = = = = = = = = E X C E P T I O N= = = = = = = = = = = = = = ="
+22 ;end new code REQ7
+23 ;start new code bar*1.8*20
+24 SET BARZ("W")="MATCHED W/REASON NOT TO POST"
+25 SET BARZ("W","HDR")="= = = = = M A T C H E D W / R E A S O N N O T T O P O S T = = = = = ="
+26 ;end new code
+27 QUIT
+28 ; ********************************************************************
+29 ;
STATUS ;
+1 ; Select claim status for reports
+2 WRITE !!,"Enter the list of Claim Status(s) you desire to print,"
+3 WRITE !,"and in the sequence to be printed out.",!
+4 WRITE !,"C - Claim Unmatched",?25,"R - Reason Unmatched",?50,"N - Not to Post"
+5 WRITE !,"M - Matched",?25,"P - Posted",?50,"X - Claim & Reason Unmatched"
+6 ;W !,"A - All Categories",!,?5,"Example: CRXN",! ;bar*1.8*20 REQ7
+7 ;bar*1.8*20 REQ7
WRITE !,"A - All Categories",?25,"E - Exception",!,?5,"Example: CRXN",!
+8 SET BARBAD=0
+9 KILL DIR,BARINDX
+10 ;S DIR(0)="FO^0:6" ;bar*1.8*20 REQ7
+11 ;bar*1.8*20 REQ7
SET DIR(0)="FO^0:7"
+12 DO ^DIR
+13 KILL DIR
+14 ;bar*1.8*20
SET Y=$$UPC^BARUTL(Y)
+15 IF $LENGTH(Y)'>0
Begin DoDot:1
+16 WRITE !!,"NONE SELECTED - EXITING",!
+17 SET BARDONE=1
End DoDot:1
QUIT
+18 IF Y="^"
SET BARDONE=1
QUIT
+19 ;S Z="CRNMPX" ;bar*1.8*20 REQ7
+20 ;bar*1.8*20 REQ7
SET Z="CRNMPXE"
+21 IF Y="A"
SET Y=Z
+22 ;S Z="CRNMPX" ;bar*1.8*20 REQ7
+23 ;bar*1.8*20 REQ7
SET Z="CRNMPXE"
+24 FOR I=1:1:$LENGTH(Y)
IF Z'[$EXTRACT(Y,I)
Begin DoDot:1
+25 WRITE !!,">>>BAD ENTRY<<<>>> ",Y
+26 SET BARBAD=1
End DoDot:1
QUIT
+27 IF +BARBAD
QUIT
+28 SET BARINDX=Y
+29 QUIT
+30 ; ********************************************************************
+31 ;
RPTYP ;
+1 ; Select Report Type
+2 WRITE !
+3 KILL DIR,BARTYP
+4 SET DIR(0)="SOB^D:Detailed;B:Brief - One Line;S:Summary - Totals Only"
+5 SET DIR("A")="Select the type of report: "
+6 DO ^DIR
+7 KILL DIR
+8 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+9 IF (",D,B,S,"'[(","_Y_","))
QUIT
+10 SET BARTYP=Y
+11 SET BARTYP("NAME")=Y(0)
+12 QUIT
+13 ; ********************************************************************
+14 ;
ASK ;
+1 ; Ask Browse or Print
+2 KILL DIRUT,DIR,Y
+3 SET Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)
+4 KILL DA
+5 IF $DATA(DIRUT)
QUIT
+6 SET BARMEDIA=Y
+7 SET BARMEDIA("NAME")=Y(0)
+8 QUIT
+9 ; ********************************************************************
+10 ;
SETHDR ;
+1 ; Set up Report Header lines
+2 KILL BARPCIEN,BARPC,BARIIEN,BARAIEN
+3 ; Find payer contact.
+4 ; BARPC(Count)=#^type of number^name
+5 SET BARPCIEN=0
+6 FOR
SET BARPCIEN=$ORDER(^BARECHK(BARCKIEN,3,BARPCIEN))
IF '+BARPCIEN
QUIT
Begin DoDot:1
+7 SET BARPC(BARPCIEN)=$GET(^BARECHK(BARCKIEN,3,BARPCIEN,0))
End DoDot:1
+8 IF '$DATA(BARPC)
Begin DoDot:1
+9 IF $PIECE(BARCHK(0),U,3)=""
SET BARPC(1)=""
QUIT
+10 IF $PIECE(BARCHK(0),U,4)=""
SET BARPC(1)=""
QUIT
+11 SET BARAIEN=$PIECE($GET(^BARCOL(DUZ(2),$PIECE(BARCHK(0),U,3),1,$PIECE(BARCHK(0),U,4),0)),U,7)
+12 IF BARAIEN=""
SET BARPC(1)=""
QUIT
+13 SET BARIIEN=$PIECE($GET(^BARAC(DUZ(2),BARAIEN,0)),U,1)
+14 IF BARIIEN'["AUTNINS"
SET BARPC(1)=""
QUIT
+15 SET BARPC(1)=$PIECE($GET(^AUTNINS(+BARIIEN,0)),U,6)
+16 IF BARPC(1)=""
SET BARPC(1)=""
QUIT
+17 SET $PIECE(BARPC(1),U,3)=$PIECE($GET(^AUTNINS(+BARIIEN,0)),U,9)
End DoDot:1
+18 ;
+19 SET BAR("HD",0)="ELECTRONIC CLAIM REPORT - "_$PIECE(BARTYP("NAME")," ")
+20 SET BARTMP="FOR FILE NAME: "_IMP(.05)
+21 DO PAD
+22 ;S BAR("HD",1)=BARTMP_"CHECK/EFT TRACE: "_$E(BARCHK,1,12) ;bar*1.8*22 SDR
+23 ;bar*1.8*22 SDR
SET BAR("HD",1)=BARTMP_"CHECK/EFT TRACE: "_$EXTRACT(BARCHK,1,20)
+24 ;BAR*1.8*1 SRS ADDENDUM FOR BAR*1.8*1
+25 SET BARTMP=" "
+26 DO PAD
+27 IF $PIECE(BARCHK(0),U,8)="XX"
Begin DoDot:1
+28 SET BAR("HD",1.5)=BARTMP_" NPI: "_$PIECE(BARCHK(0),U,9)
End DoDot:1
+29 IF '$TEST
SET BAR("HD",1.5)=BARTMP_" TIN: "_$PIECE(BARCHK(0),U,11)
+30 ;END
+31 SET BAR("HD",2)="FOR RPMS FILE: "_IMP(.01)_" FOR "_$PIECE(BARCHK(0),U,7)
+32 SET BAR("HD",3)=BARDASH
+33 SET BARTMP=$$GET1^DIQ(90056.22,BARCKIEN,.03)
+34 SET BARTMP="BATCH: "_$SELECT(BARTMP="":"** No RPMS match **",1:BARTMP)
+35 DO PAD
+36 SET BAR("HD",4)=BARTMP_"ITEM # "_$PIECE(BARCHK(0),U,4)
+37 SET BAR("HD",5)=BARDASH
+38 ;
+39 SET BARTMP=$PIECE(BARCHK(2),U)
+40 DO PAD
+41 ; Payer name (RA)
SET BAR("HD",6)=BARTMP
+42 SET BARTMP=$PIECE(BARCHK(2),U,2)
+43 DO PAD
+44 ; Payer Address (RA)
SET BAR("HD",7)=BARTMP
+45 SET BARLCNT=7
+46 IF $PIECE(BARCHK(2),U,3)]""
Begin DoDot:1
+47 SET BARLCNT=BARLCNT+1
+48 SET BARTMP=$PIECE(BARCHK(2),U,3)
+49 DO PAD
+50 ; Payer address 2 (RA)
SET BAR("HD",BARLCNT)=BARTMP
End DoDot:1
+51 SET BARLCNT=BARLCNT+1
+52 IF $PIECE(BARCHK(2),U,6)'["-"
IF $LENGTH($PIECE(BARCHK(2),U,6))>5
SET $PIECE(BARCHK(2),U,6)=$EXTRACT($PIECE(BARCHK(2),U,6),1,5)_"-"_$EXTRACT($PIECE(BARCHK(2),U,6),6,9)
+53 SET BARTMP=$PIECE(BARCHK(2),U,4)_", "_$PIECE(BARCHK(2),U,5)_" "_$PIECE(BARCHK(2),U,6)
+54 DO PAD
+55 SET BAR("HD",BARLCNT)=BARTMP
+56 SET BAR("LVL")=BARLCNT
+57 SET I=$ORDER(BARPC(0))
+58 ; No payer contact info
IF BARPC(I)=""
QUIT
+59 SET BAR("HD",6)=BAR("HD",6)_$SELECT($PIECE(BARPC(I),U,3)]"":$PIECE(BARPC(I),U,3),1:"CUSTOMER SERVICE")
+60 KILL I,J,K
+61 SET I=0
+62 SET BARLCNT=6
+63 FOR
SET I=$ORDER(BARPC(I))
IF '+I!(BARLCNT>9)
QUIT
Begin DoDot:1
+64 SET BARLCNT=BARLCNT+1
+65 SET BARCTYP=$SELECT($PIECE(BARPC(I),U,2)="":"PH: ",$PIECE(BARPC(I),U,2)="TE":"PH: ",$PIECE(BARPC(I),U,2)="FX":"FX: ",1:"")
+66 SET $PIECE(BARPC(I),U)=$TRANSLATE($PIECE(BARPC(I),U),")-","")
+67 SET BARTMP=$PIECE(BARPC(I),U)
+68 IF (BARCTYP="PH: "!(BARCTYP="FX: "))
Begin DoDot:2
+69 IF $LENGTH(BARTMP)=10
SET $PIECE(BARPC(I),U)="("_$EXTRACT(BARTMP,1,3)_") "_$EXTRACT(BARTMP,4,6)_"-"_$EXTRACT(BARTMP,7,10)
+70 IF $LENGTH(BARTMP)=7
SET $PIECE(BARPC(I),U)=$EXTRACT(BARTMP,1,3)_"-"_$EXTRACT(BARTMP,4,7)
End DoDot:2
+71 IF '$DATA(BAR("HD",BARLCNT))
Begin DoDot:2
+72 SET BARTMP=" "
+73 DO PAD
+74 SET BAR("HD",BARLCNT)=BARTMP
End DoDot:2
+75 SET BAR("HD",BARLCNT)=BAR("HD",BARLCNT)_BARCTYP_$PIECE(BARPC(I),U)
End DoDot:1
+76 IF BARLCNT>BAR("LVL")
SET BAR("LVL")=BARLCNT
+77 QUIT
+78 ; ********************************************************************
+79 ;
PAD ;
+1 ; Fixed undefined error in detail report.
+2 ; (Reported previously in IM17021.)
+3 ;K L
+4 ;IM17021
NEW L,I
+5 SET L=$LENGTH(BARTMP)
+6 ;F I=L:1:50 S BARTMP=BARTMP_" " ;bar*1.8*22 SDR
+7 ;bar*1.8*22 SDR
FOR I=L:1:43
SET BARTMP=BARTMP_" "
+8 ;K L,I ;IM17021
+9 QUIT
+10 ; ********************************************************************
+11 ;
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("PRINT^BAR50P11")
+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^BAREDP11"
+3 ; Print reports from tmp global
SET BARQ("RP")="PRINT^BAREDP11"
+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
+9 ; *********************************************************************
+10 ;
XIT ;
+1 DO ^BARVKL0
+2 QUIT
