BARPST5 ; IHS/SD/LSL - LIST TRANSACTION HISTORY OF A BILL ; 03/31/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,4,5,6,20,23,24**;OCT 26,2005;Build 69
;
; IHS/SD/SDR - 03/11/2002 - V1.6 Patch 2 - NOIS HQW-0801-100024
; Modified routine to output insurer field as well as Entry By,
; Complete entry for Transaction Type, and A/R Account. Also fixed
; line in CHKLINE to fix unrelated <DPARM> error if "^" out of bill
;
; IHS/SD/SDR - 4/4/2002 - V1.6 Patch 2 - NOIS HQW-0302-100166
; Modified so it won't display any of the following transaction
; types. They are causing confusion and are not necessary to
; display.
; COL BAT TO ACC POST - 115
; COL BAT TO ACC UN-DIST -116
; COL BAT TO FACILITY -117
; COL BAT TO UN-DIST -118
;
; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA
; Display PENDING and GENERAL INFORMATION (2 new Adjustment
; Categories) on the Transaction History. These categories
; should not affect the balance.
;
; IHS/SD/LSL - 10/17/03 - V1.7 Patch 4 - HIPAA
; Display "e" next to transactions that were posted via Post
; ERA Claims.
;
; IHS/SD/LSL - 02/13/04 - V1.7 Patch 5 - Remark Codes
; Display Remark Code and NCPDP Reject/Payment codes
; on Transaction on history
;
;IHS/SD/RLT - 02/15/05 - V1.8 Patch 1 - IM15887
; balances should not be affected by transaction
; types of PENDING or GENERAL INFORMATION but should always
; be displayed
; *********************************************************************
;
;** List Detail command from posting command prompt
;** lists details from a single bill
;
;
;IHS/SD/POT JUL 2012 HEAT# 76003 ADDED TR IEN - BAR*1.8*23
;IHS/SD/POT APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES - BAR*1.8*23
;IHS/SD/POT SEP 2013 FIXED INITIALS @ MESSAGES - BAR*1.8*23
;IHS/SD/POT OCT 2013 WRAP AND POSITION LONG MESSAGES 10/24/2013 - BAR*1.8*23
;IHS/SD/POT DEC 2013 ASSIGNED BARFLGRP="N" 12/12/13 DEFAULT VAL FOR EXT CALLS - BAR*1.8*23
;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*24
;IHS/SD/POT A/R P24 BETA: FIXING WRONGLY DISPLAYED TR TYPES 115,116,117,118 - BAR*1.8*24
EN(BARBLDA) ; EP - Display bill history
;
EN1 ;
N DIC,DR,BARCL,BARHLP,BARCLV,BARCLIT,BARITV,BARPSAT,BARSITE,BARSPAR,BARUSR
N BARVSIT,BAREOV,BARBL,BARTRX,BARTR,BARBAL,BARX,BARQ,BARTRDA,BARBAL,BARPTA,BARMSG ; - BAR*1.8*23
I $G(BARFLGRP)="" S BARFLGRP="N" ;DEFAULT VAL FOR EXT CALLS - BAR*1.8*23
S DR=".01;3;14;15;101;102;103;104;108"
S DIC=$$DIC^XBSFGBL(90050.01)
D ENP^XBDIQ1(DIC,BARBLDA,DR,"BARBL(","")
S BARBL(101,"I")=$$GET1^DIQ(90050.01,BARBLDA,101,"I")
; -------------------------------
;
GETPT ;
I 'BARBL(101,"I") S BARBL(101,"I")=$G(BARPAT)
I 'BARBL(101,"I") D G GETTX
.F BARJ=.111,.114,.115,.116,.131 S BARPTA(BARJ)=""
S DIC="^DPT("
S DR=".111;.114;.115;.116;.131"
D ENP^XBDIQ1(DIC,BARBL(101,"I"),DR,"BARPTA(","")
; -------------------------------
;
GETTX ;
S DR="2;3;6;13;14;15;101;102;103;107;108;110;111;112" ;BARHDR
S DIC=$$DIC^XBSFGBL(90050.03)
S BARTRDA=0
F S BARTRDA=$O(^BARTR(DUZ(2),"AC",BARBLDA,BARTRDA)) Q:'BARTRDA D
. I '$D(^BARTR(DUZ(2),BARTRDA)) K ^BARTR(DUZ(2),"AC",BARBLDA,BARTRDA) Q
. I $D(^BARTR(DUZ(2),"AM4",BARBLDA,BARTRDA)) I BARFLGRP="M"!(BARFLGRP="B")!(BARFLGRP="O") D Q ; - BAR*1.8*23
. . S BARMSG(BARTRDA)=""
. . S BARTRX(BARTRDA)="MESSAGE"
.S BARTEST=","_$P($G(^BARTR(DUZ(2),BARTRDA,1)),U)_","
. ;----start old code ---------------
. ;S BARTEST=BARTEST_$P($G(^BARTR(DUZ(2),BARTRDA,1)),U,2)_"," ;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*.24
. ; ;Q:BARTEST=",," ; No transaction type ;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*.24
. ; Q:BARTEST=",,," ; No transaction type ;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*.24
. ;I ",115,116,117,118,"[BARTEST Q
. ;--------new code-----------------
. I ",115,116,117,118,"[BARTEST Q
. I $P($G(^BARTR(DUZ(2),BARTRDA,1)),U)="" I $P($G(^BARTR(DUZ(2),BARTRDA,1)),U,2)="" QUIT ;both [tr.type;adj cat] nil
.W "."
.D ENP^XBDIQ1(DIC,BARTRDA,DR,"BARTRX(","1")
.S BARTRX(BARTRDA,12)=$$GET1^DIQ(90050.03,BARTRDA,12,"I")
.S BARTRX(BARTRDA,13)=$$GET1^DIQ(90050.03,BARTRDA,13,"I")
.S BARTRX(BARTRDA,14,"I")=$$GET1^DIQ(90050.03,BARTRDA,14,"I") ;BARHDR
.S BARTRX(BARTRDA,15,"I")=$$GET1^DIQ(90050.03,BARTRDA,15,"I") ;
.S BARTRX(BARTRDA,106)=$$GET1^DIQ(90050.03,BARTRDA,106,"I")
.S BARTRX(BARTRDA,110)=$$GET1^DIQ(90050.03,BARTRDA,110,"I") ;REVERSAL DATE;BARHDR
.S BARTRX(BARTRDA,111)=$$GET1^DIQ(90050.03,BARTRDA,111,"E") ;SCHEDULE NUMBER/IPAC;BARHDR ;IHS/SD/SDR BAR*1.8*6 4.2.3
.S BARTRX(BARTRDA,112)=$$GET1^DIQ(90050.03,BARTRDA,112,"E") ;IGNORE FLAG; SCR80 4.1.1
.S BARTRX(BARTRDA,501)=$$GET1^DIQ(90050.03,BARTRDA,501,"E") ;PAYMENT CREDIT APPLIED TO ;BAR*1.8*5 IHS/SD/TPF 6/17/2008
.S BARTRX(BARTRDA,502)=$$GET1^DIQ(90050.03,BARTRDA,502,"E") ;PAYMENT CREDIT APPLIED FROM ;BAR*1.8*5 IHS/SD/TPF 6/17/2008
;W !
D HEAD
S BARTRDA=0,BARBAL=0,BARQ=0,BARMCNT=0
F S BARTRDA=$O(BARTRX(BARTRDA)) Q:'BARTRDA D Q:BARQ
. S BARQ=$$CHKLINE()
. Q:BARQ
. I BARFLGRP="M"!(BARFLGRP="B")!(BARFLGRP="O") I $D(BARMSG(BARTRDA)) D MESSAGE(BARTRDA) S BARMCNT=BARMCNT+1 Q ; - BAR*1.8*23
. I $G(BARTRX(BARTRDA))="MESSAGE" Q
. I BARFLGRP="O" QUIT
. W !
. W $$SDT^BARDUTL($G(BARTRX(BARTRDA,12))) ;DT
. I $G(BARTRX(BARTRDA,13))'="" W ?11,$P($G(^VA(200,BARTRX(BARTRDA,13),0)),U,2) ;INITIALS
. S BARBATCH=$S($L($G(BARTRX(BARTRDA,14))):BARTRX(BARTRDA,14),1:"NO BATCH")
. S BARITEM=$S($L($G(BARTRX(BARTRDA,15))):BARTRX(BARTRDA,15),1:"")
. S:$G(BARTRX(BARTRDA,102))'="" BARTRX(BARTRDA,102)=$E(BARTRX(BARTRDA,102),1,19)_"/"_$E($G(BARTRX(BARTRDA,103)),1,19) ;bar*1.8*20
. S BARTT=$S($G(BARTRX(BARTRDA,101))["REFUND":BARTRX(BARTRDA,101),$L($G(BARTRX(BARTRDA,102))):BARTRX(BARTRDA,102),1:$G(BARTRX(BARTRDA,101)))
. S BARPRE=""
. I BARTRX(BARTRDA,106)="e" S BARPRE="e "
. I BARTT["PENDING" S BARPRE="* "
. I BARTRX(BARTRDA,106)="e",BARTT["PENDING" S BARPRE="*e "
. S BARTT=BARPRE_BARTT
.W ?15,BARTT ;TRTYPE
. I BARTT["REMARK" W ?45,BARTRX(BARTRDA,107)
. I BARTT["NCPDP" W ?45,BARTRX(BARTRDA,108)
. S (BARX,X)=$S($G(BARTRX(BARTRDA,2)):-BARTRX(BARTRDA,2),1:$G(BARTRX(BARTRDA,3)))
. S X2=2
. S X3=11
. D COMMA^%DTC
. I BARTT["PENDING" S X="**"_X_"**"
. W ?54,X
. N X
. I BARTT'["PENDING"&(BARTT'["GENERAL") D
. . S BARBAL=BARBAL+BARX
. S X=BARBAL,X2=2,X3=11 D COMMA^%DTC
. W ?68,X
. W !
. W ?15,BARTRX(BARTRDA,6) ; A/R Account
. W ?45,BARBATCH
. W ?67,$J(BARITEM,3,0)
. I BARTRX(BARTRDA,14,"I")'="",(BARTRX(BARTRDA,15,"I")'="") D
. .N IENS
. .S IENS=BARTRX(BARTRDA,15,"I")_","_BARTRX(BARTRDA,14,"I")_","
. .W !?15,$$GET1^DIQ(90051.1101,IENS,20,"E") ;SCHEDULE #\IPAC
. .K IENS
. I BARTT["REMARK" D
. . S BARMKDSC=$$GET1^DIQ(90050.03,BARTRDA,"107:.02")
. . W !?15,$E(BARMKDSC,1,40)
. . I $L(BARMKDSC)>40 W !?15,$E(BARMKDSC,41,80)
. I BARTT["NCPDP" D
. . S BARNCPDP=$$GET1^DIQ(90050.03,BARTRDA,"108:.02")
. . W !?15,$E(BARNCPDP,1,40)
. . I $L(BARNCPDP)>40 W !?15,$E(BARNCPDP,41,80)
. I $G(BARTRX(BARTRDA,110)) D
. . S Y=BARTRX(BARTRDA,110) X ^DD("DD")
. . W !?5,"REVERSAL DATE: ",Y ;BARHDR
. . W !?5,"REV TREASURY DEPOSIT NUMBER/IPAC: ",$G(BARTRX(BARTRDA,111))
. I $G(BARTRX(BARTRDA,112))]"" W !?15,BARTRX(BARTRDA,112)
. I BARTRX(BARTRDA,501)'="" W !?15,"PAYMENT CREDIT APPLIED TO: ",BARTRX(BARTRDA,501)
. I BARTRX(BARTRDA,502)'="" W !?15,"PAYMENT CREDIT APPLIED FROM: ",BARTRX(BARTRDA,502)
. I BARFLGRP="T"!(BARFLGRP="B") W !,?15,BARTRDA ; - BAR*1.8*23
Q:BARQ
I BARFLGRP="O",BARMCNT=0 W !!!,"NO MESSAGES FOUND.",!!
D EOP^BARUTL(1)
Q
; *********************************************************************
;
HEAD ;
W $$EN^BARVDF("IOF") ;,!
S X="List of Transactions for Bill "_BARBL(.01)
W ?80-$L(X)\2,X
W !!,"Patient: "_BARBL(101),?45,"Beg DOS : "_BARBL(102)
W !,"Address: "_$G(BARPTA(.111)),?45,"End DOS : "_BARBL(103)
W !,$G(BARPTA(.114))_", "_$G(BARPTA(.115))_" "_$G(BARPTA(.116))
W ?45,"LST STMT: "
W !!,"Phone #: "_$G(BARPTA(.131)),?45,"Insurer: "_$G(BARBL(3))
W !?45,"Balance: "_$J(BARBL(15),0,2)
W !!,"Trans Dt",?11,"By",?15,"Trans Type",?57,"Amount",?70,"Balance"
W !?15,"A/R Account",?45,"Batch",?67,"Item"
I BARFLGRP="T"!(BARFLGRP="B") W !?15,"Transaction #" ;,! ; - BAR*1.8*23
S BARDSH="",$P(BARDSH,"-",IOM)="" W !,BARDSH
Q
; *********************************************************************
;
CHKLINE() ;
; Q 0 = CONTINUE
; Q 1 = STOP
N X
I ($Y+4)<IOSL Q 0
I $E(IOST,1)="C" D I 'Y Q 1
.W !?(IOM-15),"continued==>"
.D EOP^BARUTL(0)
D HEAD
Q 0
;
MESSAGE(BARTRDA) ;
;^BARTR(DUZ(2),BARTRDA,10,0)="^^2^2^3120216"
;^BARTR(DUZ(2),BARTRDA,10,1,0)="ORIGINAL ON 3120216.120259, GCN: 101126"
;^BARTR(DUZ(2),BARTRDA,10,2,0)="REASON: "
N BARMSG1,BARMSG2,I,BARINIT,BARTXT,BARLINE,BAROK,BARST,BARWD
S BARWD=43-15-1,BARST=1
S BARINIT=$$SDT^BARDUTL(BARTRDA) ;DT
S BARMSG1=$P($G(^BARTR(DUZ(2),BARTRDA,10,0)),U,3)
S BARTXT=""
F I=1:1:BARMSG1 D ;------------------10/24/13----- - BAR*1.8*23
. S BARLINE=$G(^BARTR(DUZ(2),BARTRDA,10,I,0))
. I BARLINE]"" S BARTXT=BARTXT_" "_BARLINE
F I=1:1 Q:$E(BARTXT)'=" " S $E(BARTXT,1)=""
S BAROK=0 I BARTXT]"" D
. F I=1:1 D Q:BAROK
. . S BARLINE=$E(BARTXT,BARST,BARST+BARWD)
. . I BARLINE="" S BAROK=1 Q
. . W !
. . I I=1 D
. . . W BARINIT
. . . W ?11,$$INITIALS(BARTRDA)
. . S BARST=BARST+BARWD+1
. . W ?15,BARLINE
I BARFLGRP="B" W !?15,BARTRDA ; - BAR*1.8*23
Q
INITIALS(BARTRDA) ; - BAR*1.8*23
N BARTMP,BARTMP2,BARINIT
S BARTMP=$G(^BARTR(DUZ(2),BARTRDA,0)),BARINIT=$P(BARTMP,"^",13)
S BARTMP2=""
I BARINIT]"" S BARTMP2=$P($G(^VA(200,BARINIT,0)),U,2)
Q $E(BARTMP2,1,3)
;-EOR-
BARPST5 ; IHS/SD/LSL - LIST TRANSACTION HISTORY OF A BILL ; 03/31/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,4,5,6,20,23,24**;OCT 26,2005;Build 69
+2 ;
+3 ; IHS/SD/SDR - 03/11/2002 - V1.6 Patch 2 - NOIS HQW-0801-100024
+4 ; Modified routine to output insurer field as well as Entry By,
+5 ; Complete entry for Transaction Type, and A/R Account. Also fixed
+6 ; line in CHKLINE to fix unrelated <DPARM> error if "^" out of bill
+7 ;
+8 ; IHS/SD/SDR - 4/4/2002 - V1.6 Patch 2 - NOIS HQW-0302-100166
+9 ; Modified so it won't display any of the following transaction
+10 ; types. They are causing confusion and are not necessary to
+11 ; display.
+12 ; COL BAT TO ACC POST - 115
+13 ; COL BAT TO ACC UN-DIST -116
+14 ; COL BAT TO FACILITY -117
+15 ; COL BAT TO UN-DIST -118
+16 ;
+17 ; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA
+18 ; Display PENDING and GENERAL INFORMATION (2 new Adjustment
+19 ; Categories) on the Transaction History. These categories
+20 ; should not affect the balance.
+21 ;
+22 ; IHS/SD/LSL - 10/17/03 - V1.7 Patch 4 - HIPAA
+23 ; Display "e" next to transactions that were posted via Post
+24 ; ERA Claims.
+25 ;
+26 ; IHS/SD/LSL - 02/13/04 - V1.7 Patch 5 - Remark Codes
+27 ; Display Remark Code and NCPDP Reject/Payment codes
+28 ; on Transaction on history
+29 ;
+30 ;IHS/SD/RLT - 02/15/05 - V1.8 Patch 1 - IM15887
+31 ; balances should not be affected by transaction
+32 ; types of PENDING or GENERAL INFORMATION but should always
+33 ; be displayed
+34 ; *********************************************************************
+35 ;
+36 ;** List Detail command from posting command prompt
+37 ;** lists details from a single bill
+38 ;
+39 ;
+40 ;IHS/SD/POT JUL 2012 HEAT# 76003 ADDED TR IEN - BAR*1.8*23
+41 ;IHS/SD/POT APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES - BAR*1.8*23
+42 ;IHS/SD/POT SEP 2013 FIXED INITIALS @ MESSAGES - BAR*1.8*23
+43 ;IHS/SD/POT OCT 2013 WRAP AND POSITION LONG MESSAGES 10/24/2013 - BAR*1.8*23
+44 ;IHS/SD/POT DEC 2013 ASSIGNED BARFLGRP="N" 12/12/13 DEFAULT VAL FOR EXT CALLS - BAR*1.8*23
+45 ;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*24
+46 ;IHS/SD/POT A/R P24 BETA: FIXING WRONGLY DISPLAYED TR TYPES 115,116,117,118 - BAR*1.8*24
EN(BARBLDA) ; EP - Display bill history
+1 ;
EN1 ;
+1 NEW DIC,DR,BARCL,BARHLP,BARCLV,BARCLIT,BARITV,BARPSAT,BARSITE,BARSPAR,BARUSR
+2 ; - BAR*1.8*23
NEW BARVSIT,BAREOV,BARBL,BARTRX,BARTR,BARBAL,BARX,BARQ,BARTRDA,BARBAL,BARPTA,BARMSG
+3 ;DEFAULT VAL FOR EXT CALLS - BAR*1.8*23
IF $GET(BARFLGRP)=""
SET BARFLGRP="N"
+4 SET DR=".01;3;14;15;101;102;103;104;108"
+5 SET DIC=$$DIC^XBSFGBL(90050.01)
+6 DO ENP^XBDIQ1(DIC,BARBLDA,DR,"BARBL(","")
+7 SET BARBL(101,"I")=$$GET1^DIQ(90050.01,BARBLDA,101,"I")
+8 ; -------------------------------
+9 ;
GETPT ;
+1 IF 'BARBL(101,"I")
SET BARBL(101,"I")=$GET(BARPAT)
+2 IF 'BARBL(101,"I")
Begin DoDot:1
+3 FOR BARJ=.111,.114,.115,.116,.131
SET BARPTA(BARJ)=""
End DoDot:1
GOTO GETTX
+4 SET DIC="^DPT("
+5 SET DR=".111;.114;.115;.116;.131"
+6 DO ENP^XBDIQ1(DIC,BARBL(101,"I"),DR,"BARPTA(","")
+7 ; -------------------------------
+8 ;
GETTX ;
+1 ;BARHDR
SET DR="2;3;6;13;14;15;101;102;103;107;108;110;111;112"
+2 SET DIC=$$DIC^XBSFGBL(90050.03)
+3 SET BARTRDA=0
+4 FOR
SET BARTRDA=$ORDER(^BARTR(DUZ(2),"AC",BARBLDA,BARTRDA))
IF 'BARTRDA
QUIT
Begin DoDot:1
+5 IF '$DATA(^BARTR(DUZ(2),BARTRDA))
KILL ^BARTR(DUZ(2),"AC",BARBLDA,BARTRDA)
QUIT
+6 ; - BAR*1.8*23
IF $DATA(^BARTR(DUZ(2),"AM4",BARBLDA,BARTRDA))
IF BARFLGRP="M"!(BARFLGRP="B")!(BARFLGRP="O")
Begin DoDot:2
+7 SET BARMSG(BARTRDA)=""
+8 SET BARTRX(BARTRDA)="MESSAGE"
End DoDot:2
QUIT
+9 SET BARTEST=","_$PIECE($GET(^BARTR(DUZ(2),BARTRDA,1)),U)_","
+10 ;----start old code ---------------
+11 ;S BARTEST=BARTEST_$P($G(^BARTR(DUZ(2),BARTRDA,1)),U,2)_"," ;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*.24
+12 ; ;Q:BARTEST=",," ; No transaction type ;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*.24
+13 ; Q:BARTEST=",,," ; No transaction type ;IHS/SD/SDR belcourt HEAT118656 - BAR*1.8*.24
+14 ;I ",115,116,117,118,"[BARTEST Q
+15 ;--------new code-----------------
+16 IF ",115,116,117,118,"[BARTEST
QUIT
+17 ;both [tr.type;adj cat] nil
IF $PIECE($GET(^BARTR(DUZ(2),BARTRDA,1)),U)=""
IF $PIECE($GET(^BARTR(DUZ(2),BARTRDA,1)),U,2)=""
QUIT
+18 WRITE "."
+19 DO ENP^XBDIQ1(DIC,BARTRDA,DR,"BARTRX(","1")
+20 SET BARTRX(BARTRDA,12)=$$GET1^DIQ(90050.03,BARTRDA,12,"I")
+21 SET BARTRX(BARTRDA,13)=$$GET1^DIQ(90050.03,BARTRDA,13,"I")
+22 ;BARHDR
SET BARTRX(BARTRDA,14,"I")=$$GET1^DIQ(90050.03,BARTRDA,14,"I")
+23 ;
SET BARTRX(BARTRDA,15,"I")=$$GET1^DIQ(90050.03,BARTRDA,15,"I")
+24 SET BARTRX(BARTRDA,106)=$$GET1^DIQ(90050.03,BARTRDA,106,"I")
+25 ;REVERSAL DATE;BARHDR
SET BARTRX(BARTRDA,110)=$$GET1^DIQ(90050.03,BARTRDA,110,"I")
+26 ;SCHEDULE NUMBER/IPAC;BARHDR ;IHS/SD/SDR BAR*1.8*6 4.2.3
SET BARTRX(BARTRDA,111)=$$GET1^DIQ(90050.03,BARTRDA,111,"E")
+27 ;IGNORE FLAG; SCR80 4.1.1
SET BARTRX(BARTRDA,112)=$$GET1^DIQ(90050.03,BARTRDA,112,"E")
+28 ;PAYMENT CREDIT APPLIED TO ;BAR*1.8*5 IHS/SD/TPF 6/17/2008
SET BARTRX(BARTRDA,501)=$$GET1^DIQ(90050.03,BARTRDA,501,"E")
+29 ;PAYMENT CREDIT APPLIED FROM ;BAR*1.8*5 IHS/SD/TPF 6/17/2008
SET BARTRX(BARTRDA,502)=$$GET1^DIQ(90050.03,BARTRDA,502,"E")
End DoDot:1
+30 ;W !
+31 DO HEAD
+32 SET BARTRDA=0
SET BARBAL=0
SET BARQ=0
SET BARMCNT=0
+33 FOR
SET BARTRDA=$ORDER(BARTRX(BARTRDA))
IF 'BARTRDA
QUIT
Begin DoDot:1
+34 SET BARQ=$$CHKLINE()
+35 IF BARQ
QUIT
+36 ; - BAR*1.8*23
IF BARFLGRP="M"!(BARFLGRP="B")!(BARFLGRP="O")
IF $DATA(BARMSG(BARTRDA))
DO MESSAGE(BARTRDA)
SET BARMCNT=BARMCNT+1
QUIT
+37 IF $GET(BARTRX(BARTRDA))="MESSAGE"
QUIT
+38 IF BARFLGRP="O"
QUIT
+39 WRITE !
+40 ;DT
WRITE $$SDT^BARDUTL($GET(BARTRX(BARTRDA,12)))
+41 ;INITIALS
IF $GET(BARTRX(BARTRDA,13))'=""
WRITE ?11,$PIECE($GET(^VA(200,BARTRX(BARTRDA,13),0)),U,2)
+42 SET BARBATCH=$SELECT($LENGTH($GET(BARTRX(BARTRDA,14))):BARTRX(BARTRDA,14),1:"NO BATCH")
+43 SET BARITEM=$SELECT($LENGTH($GET(BARTRX(BARTRDA,15))):BARTRX(BARTRDA,15),1:"")
+44 ;bar*1.8*20
IF $GET(BARTRX(BARTRDA,102))'=""
SET BARTRX(BARTRDA,102)=$EXTRACT(BARTRX(BARTRDA,102),1,19)_"/"_$EXTRACT($GET(BARTRX(BARTRDA,103)),1,19)
+45 SET BARTT=$SELECT($GET(BARTRX(BARTRDA,101))["REFUND":BARTRX(BARTRDA,101),$LENGTH($GET(BARTRX(BARTRDA,102))):BARTRX(BARTRDA,102),1:$GET(BARTRX(BARTRDA,101)))
+46 SET BARPRE=""
+47 IF BARTRX(BARTRDA,106)="e"
SET BARPRE="e "
+48 IF BARTT["PENDING"
SET BARPRE="* "
+49 IF BARTRX(BARTRDA,106)="e"
IF BARTT["PENDING"
SET BARPRE="*e "
+50 SET BARTT=BARPRE_BARTT
+51 ;TRTYPE
WRITE ?15,BARTT
+52 IF BARTT["REMARK"
WRITE ?45,BARTRX(BARTRDA,107)
+53 IF BARTT["NCPDP"
WRITE ?45,BARTRX(BARTRDA,108)
+54 SET (BARX,X)=$SELECT($GET(BARTRX(BARTRDA,2)):-BARTRX(BARTRDA,2),1:$GET(BARTRX(BARTRDA,3)))
+55 SET X2=2
+56 SET X3=11
+57 DO COMMA^%DTC
+58 IF BARTT["PENDING"
SET X="**"_X_"**"
+59 WRITE ?54,X
+60 NEW X
+61 IF BARTT'["PENDING"&(BARTT'["GENERAL")
Begin DoDot:2
+62 SET BARBAL=BARBAL+BARX
End DoDot:2
+63 SET X=BARBAL
SET X2=2
SET X3=11
DO COMMA^%DTC
+64 WRITE ?68,X
+65 WRITE !
+66 ; A/R Account
WRITE ?15,BARTRX(BARTRDA,6)
+67 WRITE ?45,BARBATCH
+68 WRITE ?67,$JUSTIFY(BARITEM,3,0)
+69 IF BARTRX(BARTRDA,14,"I")'=""
IF (BARTRX(BARTRDA,15,"I")'="")
Begin DoDot:2
+70 NEW IENS
+71 SET IENS=BARTRX(BARTRDA,15,"I")_","_BARTRX(BARTRDA,14,"I")_","
+72 ;SCHEDULE #\IPAC
WRITE !?15,$$GET1^DIQ(90051.1101,IENS,20,"E")
+73 KILL IENS
End DoDot:2
+74 IF BARTT["REMARK"
Begin DoDot:2
+75 SET BARMKDSC=$$GET1^DIQ(90050.03,BARTRDA,"107:.02")
+76 WRITE !?15,$EXTRACT(BARMKDSC,1,40)
+77 IF $LENGTH(BARMKDSC)>40
WRITE !?15,$EXTRACT(BARMKDSC,41,80)
End DoDot:2
+78 IF BARTT["NCPDP"
Begin DoDot:2
+79 SET BARNCPDP=$$GET1^DIQ(90050.03,BARTRDA,"108:.02")
+80 WRITE !?15,$EXTRACT(BARNCPDP,1,40)
+81 IF $LENGTH(BARNCPDP)>40
WRITE !?15,$EXTRACT(BARNCPDP,41,80)
End DoDot:2
+82 IF $GET(BARTRX(BARTRDA,110))
Begin DoDot:2
+83 SET Y=BARTRX(BARTRDA,110)
XECUTE ^DD("DD")
+84 ;BARHDR
WRITE !?5,"REVERSAL DATE: ",Y
+85 WRITE !?5,"REV TREASURY DEPOSIT NUMBER/IPAC: ",$GET(BARTRX(BARTRDA,111))
End DoDot:2
+86 IF $GET(BARTRX(BARTRDA,112))]""
WRITE !?15,BARTRX(BARTRDA,112)
+87 IF BARTRX(BARTRDA,501)'=""
WRITE !?15,"PAYMENT CREDIT APPLIED TO: ",BARTRX(BARTRDA,501)
+88 IF BARTRX(BARTRDA,502)'=""
WRITE !?15,"PAYMENT CREDIT APPLIED FROM: ",BARTRX(BARTRDA,502)
+89 ; - BAR*1.8*23
IF BARFLGRP="T"!(BARFLGRP="B")
WRITE !,?15,BARTRDA
End DoDot:1
IF BARQ
QUIT
+90 IF BARQ
QUIT
+91 IF BARFLGRP="O"
IF BARMCNT=0
WRITE !!!,"NO MESSAGES FOUND.",!!
+92 DO EOP^BARUTL(1)
+93 QUIT
+94 ; *********************************************************************
+95 ;
HEAD ;
+1 ;,!
WRITE $$EN^BARVDF("IOF")
+2 SET X="List of Transactions for Bill "_BARBL(.01)
+3 WRITE ?80-$LENGTH(X)\2,X
+4 WRITE !!,"Patient: "_BARBL(101),?45,"Beg DOS : "_BARBL(102)
+5 WRITE !,"Address: "_$GET(BARPTA(.111)),?45,"End DOS : "_BARBL(103)
+6 WRITE !,$GET(BARPTA(.114))_", "_$GET(BARPTA(.115))_" "_$GET(BARPTA(.116))
+7 WRITE ?45,"LST STMT: "
+8 WRITE !!,"Phone #: "_$GET(BARPTA(.131)),?45,"Insurer: "_$GET(BARBL(3))
+9 WRITE !?45,"Balance: "_$JUSTIFY(BARBL(15),0,2)
+10 WRITE !!,"Trans Dt",?11,"By",?15,"Trans Type",?57,"Amount",?70,"Balance"
+11 WRITE !?15,"A/R Account",?45,"Batch",?67,"Item"
+12 ;,! ; - BAR*1.8*23
IF BARFLGRP="T"!(BARFLGRP="B")
WRITE !?15,"Transaction #"
+13 SET BARDSH=""
SET $PIECE(BARDSH,"-",IOM)=""
WRITE !,BARDSH
+14 QUIT
+15 ; *********************************************************************
+16 ;
CHKLINE() ;
+1 ; Q 0 = CONTINUE
+2 ; Q 1 = STOP
+3 NEW X
+4 IF ($Y+4)<IOSL
QUIT 0
+5 IF $EXTRACT(IOST,1)="C"
Begin DoDot:1
+6 WRITE !?(IOM-15),"continued==>"
+7 DO EOP^BARUTL(0)
End DoDot:1
IF 'Y
QUIT 1
+8 DO HEAD
+9 QUIT 0
+10 ;
MESSAGE(BARTRDA) ;
+1 ;^BARTR(DUZ(2),BARTRDA,10,0)="^^2^2^3120216"
+2 ;^BARTR(DUZ(2),BARTRDA,10,1,0)="ORIGINAL ON 3120216.120259, GCN: 101126"
+3 ;^BARTR(DUZ(2),BARTRDA,10,2,0)="REASON: "
+4 NEW BARMSG1,BARMSG2,I,BARINIT,BARTXT,BARLINE,BAROK,BARST,BARWD
+5 SET BARWD=43-15-1
SET BARST=1
+6 ;DT
SET BARINIT=$$SDT^BARDUTL(BARTRDA)
+7 SET BARMSG1=$PIECE($GET(^BARTR(DUZ(2),BARTRDA,10,0)),U,3)
+8 SET BARTXT=""
+9 ;------------------10/24/13----- - BAR*1.8*23
FOR I=1:1:BARMSG1
Begin DoDot:1
+10 SET BARLINE=$GET(^BARTR(DUZ(2),BARTRDA,10,I,0))
+11 IF BARLINE]""
SET BARTXT=BARTXT_" "_BARLINE
End DoDot:1
+12 FOR I=1:1
IF $EXTRACT(BARTXT)'=" "
QUIT
SET $EXTRACT(BARTXT,1)=""
+13 SET BAROK=0
IF BARTXT]""
Begin DoDot:1
+14 FOR I=1:1
Begin DoDot:2
+15 SET BARLINE=$EXTRACT(BARTXT,BARST,BARST+BARWD)
+16 IF BARLINE=""
SET BAROK=1
QUIT
+17 WRITE !
+18 IF I=1
Begin DoDot:3
+19 WRITE BARINIT
+20 WRITE ?11,$$INITIALS(BARTRDA)
End DoDot:3
+21 SET BARST=BARST+BARWD+1
+22 WRITE ?15,BARLINE
End DoDot:2
IF BAROK
QUIT
End DoDot:1
+23 ; - BAR*1.8*23
IF BARFLGRP="B"
WRITE !?15,BARTRDA
+24 QUIT
INITIALS(BARTRDA) ; - BAR*1.8*23
+1 NEW BARTMP,BARTMP2,BARINIT
+2 SET BARTMP=$GET(^BARTR(DUZ(2),BARTRDA,0))
SET BARINIT=$PIECE(BARTMP,"^",13)
+3 SET BARTMP2=""
+4 IF BARINIT]""
SET BARTMP2=$PIECE($GET(^VA(200,BARINIT,0)),U,2)
+5 QUIT $EXTRACT(BARTMP2,1,3)
+6 ;-EOR-
