BARMPAS2 ; IHS/SD/LSL - Patient Account Statement Print ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**2,4,19,20,23,24**;OCT 26, 2005;Build 69
; IHS/SD/LSL - 5/13/03 - V1.7 Patch 2
; IHS/SD/LSL - 12/04/03 - V1.7 Patch 4 - IM 11692
; IHS/SD/POT HEAT80718 8/21/12 ADDED SORTING OPTION BY PATNAME ;BAR1.8*23
; IHS/SD/POT HEAT58041 BUG FIX IN SUMMARY BY DAYS DUE ;BAR1.8*23
; IHS/SD/POT ADDED NEW VA billing ;BAR1.8*23
; CHANGED 0->1 INDEX FOR "OB" ENTRY IN ^XTMP
; DROP PRE-PAYMENT IF POSTED TO A BILL (defunct)
; IHS/SD/POT HEAT144442 01/06/14 FIXED QUIT AFTER USER ENTERS ;BAR1.8*24
; IHS/SD/POT HEAT100207 2/18/14 FIXED AGE ;BAR1.8*24
Q
;
PRTASK ; EP - MOVED TO ^BARMPAS3
D PRTASK^BARMPAS3
Q
COMPUTE ;
; computed through tasked option
Q
; ***
PRINT ; EP
; Print Patient Account Statements.
S BARSRTBY=$G(^XTMP("BARPAS"_BARRUNDT,0,"SORTBY"),-1) ;P.OTT
I BARSRTBY<0 D Q
. W !!,"THIS BATCH OF STATEMENTS IS NOT COMPATIBLE WITH THE NEW FILE STRUCTURE."
. W !,"WILL RUN REIDEXING FIRST, THEN TRY AGAIN",!!
. D REINDEX^BARMPAS5("BARPAS"_BARRUNDT)
. K BARRUNDT
. D EOP^BARUTL(0)
. Q
I +$O(^XTMP("BARPAS"_BARRUNDT,0))=0 D Q ;P.OTT
. W !!!!!?25,"*** NO DATA TO PRINT ***"
K BARF1
S BARHOLD=DUZ(2)
S DUZ(2)=0 F S DUZ(2)=$O(^XTMP("BARPAS"_BARRUNDT,DUZ(2))) Q:'+DUZ(2) D Q:$G(BARF1) ;HEAT#144442
. S BARDUMMY="" F S BARDUMMY=$O(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY)) Q:BARDUMMY="" D Q:$G(BARF1)
. . S BARACDA=0 F S BARACDA=$O(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA)) Q:'+BARACDA D ACCT(BARACDA) Q:$G(BARF1)
S DUZ(2)=BARHOLD
Q
; ***
ACCT(BARACDA) ;
; For each patient account in XTMP do...
Q:($D(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA))'>1)
K BARTOTL ; Column Totals requested
S (BARTOTL("B"),BARTOTL("I"),BARTOTL("P"),BARTOTL("A"),BARTOTL("PR"))="",BARTOTL("IO")=""
S BARTOTL("DASH")="---------"
;K BARF1
S BARPG=0
D PGHDR^BARMPAS3 ; Patient Acct hdr and demographics
K BARBILL,BARBILLS
S BARACBAL=0
S VISLOC="" F S VISLOC=$O(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA,VISLOC)) Q:VISLOC="" D VISLOC Q:$G(BARF1)
D STMT ;STATEMENT
Q:$G(BARF1)
D AGE(BARACDA) ; Age bills
D SUM ; Print patient trailer
Q
VISLOC ;
S BARVDT="" F S BARVDT=$O(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA,VISLOC,BARVDT)) Q:'BARVDT D GETBIL Q:$G(BARF1)
Q
; End of New subscripts for sort
GETBIL ;
S BARBL=0 F S BARBL=$O(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA,VISLOC,BARVDT,BARBL)) Q:BARBL="" D ONEBILL Q:$G(BARF1)
Q
ONEBILL ;
S BARBNUM=+$$GET1^DIQ(90050.01,BARBL,.01) ; Only Bill # (no A/B)
S BARBILL(BARBNUM,BARBL)=""
S BARBILLS(VISLOC,BARVDT,BARBNUM,BARBL)=""
Q
STMT S BARBNUM=0 F S BARBNUM=$O(BARBILL(BARBNUM)) Q:BARBNUM'>0 D BILEROR Q:$G(BARF1)
S BARBNUM=0
;IHS/SD/PKD 1.8*19 9/13/10 new Local Array for output: BARBILLS
S VISLOC="" F S VISLOC=$O(BARBILLS(VISLOC)) Q:VISLOC="" D Q:$G(BARF1)
. W !!?5,"LOCATION: ",VISLOC
. S BARVDT="" F S BARVDT=$O(BARBILLS(VISLOC,BARVDT)) Q:'BARVDT D STMTP Q:$G(BARF1)
Q
STMTP ; added sorts for loc & dos
F S BARBNUM=$O(BARBILLS(VISLOC,BARVDT,BARBNUM)) Q:BARBNUM'>0 D Q:$G(BARF1)
. N BARBILLD,BARITOT,BARPTOT,BARATOT,BARPRSP,BARPTAC,BARPRV,BARNON,BARCXL
. S (BARBILLD,BARITOT,BARPTOT,BARATOT,BARPRSP,BARPTAC,BARINSOW,BARCXL)=0
. D BLDA
. S BARPBNUM=BARBNUM_" "
. S BARPBNUM=$O(^BARBL(DUZ(2),"B",BARPBNUM))
. Q:$D(BARBILL("X",BARPBNUM)) ;Trx Error code is now BARBIL("XTR",... pkd
. ; If bill cancelled (3PB) and no payments or ADJ have been made, quit
. I BARITOT=0&(BARPTOT=0)&(BARATOT=0)&(BARCXL) Q
. I BARITOT=0&(BARPTOT=0)&(BARATOT=0)&(BARBILLD=0) Q ; No amounts period/shouldn't get this far
. I BARBILLD=0 D ;If all bills for bill CXL'd, get Amt from "A" bill
. . N BLIEN,BLA
. . S BLA=$O(^BARBL(DUZ(2),"B",+BAR(.01)_"A"))
. . S BLIEN=$O(^BARBL(DUZ(2),"B",BLA,""))
. . S BARBILLD=$P(^BARBL(DUZ(2),BLIEN,0),U,13)
. D PG^BARMPAS3(10) ; IHS/SD/PKD 1.8*21 3/24/11 Statement Page Length
. Q:$G(BARF1)
. I $G(BARPRV)="" S BARPRV="***** "
. W !!,"SERVICE DATE: ",$$SHDT^BARDUTL(BAR(102,"I"))
. W ?30,"BILL #: ",BARBNUM
. W ?50,"PROVIDER: ",$E(BARPRV,1,20)
. W !?6,$J($FN(BARBILLD,"p",2),9)
. W ?18,$J($FN(BARITOT,"p",2),9),?30,$J($FN(BARPTOT,"p",2),9),?41,$J($FN(BARATOT,"p",2),9)
. W ?56,$J($FN(BARINSOW,"p",2),9)
. I (BARPTAC=1!(BARNON=1)!('BARCXL))&(BARPRSP) D
. . W ?69,$J($FN(BARPRSP,"p",2),9) S BARTOTL("PR")=BARTOTL("PR")+BARPRSP
. E W ?74,"**"
. ; May want to exclude some of these amts from totals if bill was cancelled
. S BARTOTL("B")=BARTOTL("B")+BARBILLD,BARTOTL("I")=BARTOTL("I")+BARITOT
. S BARTOTL("P")=BARTOTL("P")+BARPTOT,BARTOTL("A")=BARTOTL("A")+BARATOT
. S BARTOTL("IO")=BARTOTL("IO")+BARINSOW
Q
; ***
;
BILEROR ;
; test to eliminate bills with billed in error
S BARPBNUM=BARBNUM_" "
F II=1:1 S BARPBNUM=$O(^BARBL(DUZ(2),"B",BARPBNUM)) Q:(+BARPBNUM'=BARBNUM) D BILEROR2
Q
; ***
;
BILEROR2 ;
; test transactions for the bill
S BARBL=$O(^BARBL(DUZ(2),"B",BARPBNUM,0))
S BARTRDT=0,BARLPDA=0
S BARBILDT=$$GET1^DIQ(90050.01,BARBL,7,"I") ; Billed date
I BARBILDT'>0 S BARBILL("X",BARPBNUM)="" Q
F S BARTRDT=$O(^BARTR(DUZ(2),"AC",BARBL,BARTRDT)) Q:('BARTRDT)!(BARTRDT\1>BARDTE) D BILEROR3
Q
; ***
;
BILEROR3 ;
K BARTR
D ENP^XBDIQ1(90050.03,BARTRDT,".01;2;3;3.5;4;6;14;15;101;102;103","BARTR(","I")
S BARTTYP=BARTR(101,"I")
I BARTTYP'=39,BARTTYP'=43,BARTTYP'=40,BARTTYP'=49,BARTTYP'=107 Q
I BARTR(103)["ERROR" S BARBILL("XTR",BARBL,BARPBNUM,BARTRDT,"TRX ADJ 103 ERR")=""
Q
; ***
;
BLDA ;
S BARPBNUM=BARBNUM_" "
F II=1:1 S BARPBNUM=$O(^BARBL(DUZ(2),"B",BARPBNUM)) Q:(+BARPBNUM'=BARBNUM) D BLDA2 Q:$G(BARF1)
Q
; ***
;
BLDA2 ;
; profile bills from the first bill
S BARCXL=0
Q:$D(BARBILL("X",BARPBNUM)) ;donot process bills marked Error
S BARBL=$O(^BARBL(DUZ(2),"B",BARPBNUM,0))
K BAR
D ENP^XBDIQ1(90050.01,BARBL,".01;3;13;15;16;17;17.2;22;101;102;108;112;113;114","BAR(","I")
S BARBSTAT=BAR(17.2) ;Bill Status in TPB which can be diff from A/R
;If bill is in list & has pmts applied, it should print on stmt anyway
I BARBSTAT="CANCELLED" S BARCXL=1 ; if cancelled 1.8*19
S BARPTAC=$S(BARACDA=BAR(3,"I"):1,1:0) ; PT Resp if INSURER TYPE=NON-BEN or INSURER=SELF
N D0,X S D0=BAR(3,"I"),BARNON=0
S X=$$VAL^BARVPM(8) ;(STRING)
I X["NON-BEN"!(BARPTAC'=0) S BARPRSP=BARPRSP+BAR(15,"I"),BARNON=1
E S BARINSOW=BARINSOW+BAR(15,"I") ; Outstanding Insurance Amt
;if missing, Find Provider from 3Pbill
I BAR(113,"I")="" D ;
. N DUZ2,TPBIEN,PRV,DATA
. S TPIEN=BAR(17,"I"),DUZ2=BAR(22,"I"),PRV=0,BARPRV=""
. F S PRV=$O(^ABMDBILL(DUZ2,TPIEN,41,PRV)) Q:'PRV D Q:BARPRV'="" ; DATA=PROVIDER^TYPE
. . S DATA=^ABMDBILL(DUZ2,TPIEN,41,PRV,0)
. . Q:$P(DATA,U,2)'="A"&($P(DATA,U,2)'="R") ; Want Attending(A) or Rendering(R)
. . S BAR(113,"I")=+DATA
S:BAR(113,"I")'="" BARPRV=$P($E($P(^VA(200,BAR(113,"I"),0),U,1),1,9),",",1)
I BAR(113,"I")="" S BARPRV="None"
I BAR(113,"I")=""&(BAR(114,"I")=901) S BARPRV="Rx POS" ; Pharmacy
; END 1.8*19 get Provider
BILLED D ; Get Orig Billed Amt
. Q:BARCXL
. ; Get Billed Amt from first alpha bill
. Q:$G(BARORIG(+BAR(.01)))
. S BARORIG(+BAR(.01))=BAR(13,"I") ; 1st unCXL bill in series
. S BARBILLD=BARORIG(+BAR(.01)) ; Orig Bill Amount
Q:$G(BARF1)
D BLDA3
Q
; ***
CXL ; Use the alphabetically first bill that isn't cancelled FOR BILLED AMT
; don't think i need this subroutine ...
S BAR("3P LOC")=$$FIND3PB^BARUTL(DUZ(2),BAR)
Q:BAR("3P LOC")="" ; Bill not found 3PB
S BAR3PDUZ=$P(BAR("3P LOC"),",")
S BAR3PIEN=$P(BAR("3P LOC"),",",2)
S BARB3PB0=$G(^ABMDBILL(BAR3PDUZ,BAR3PIEN,0)) ; Need 3 pieces
S BARBSTAT=$P(BARB3PB0,U,4) ; Bill Status
Q
;
BLDA3 ;
; profile this bills transactions
S BARTRDT=0,BARLPDA=0
F S BARTRDT=$O(^BARTR(DUZ(2),"AC",BARBL,BARTRDT)) Q:('BARTRDT)!(BARTRDT\1>BARDTE) D BLDA4 Q:$G(BARF1)
Q
; ***
;
BLDA4 ;
K BARTR
D ENP^XBDIQ1(90050.03,BARTRDT,".01;2;3;3.5;3.6;3.7;4;5;6;14;15;101;102;103","BARTR(","I")
Q:(BARTR(102,"I")=13)!(BARTR(102,"I")=14) ;EXCLUDE ADJ CAT DEDUCTIBLE & CO-PAY
S BARTTYP=BARTR(101,"I")
I BARTTYP'=39,BARTTYP'=43,BARTTYP'=40,BARTTYP'=49,BARTTYP'=107 S II=II-1 Q
S BARBATCH=BARTR(14,"I")
S BARITM=BARTR(15,"I")
S BARCLIN=$$GET1^DIQ(90050.01,BARTR(4,"I"),112)
S BARCLIN=$E(BARCLIN,1,8)
S BARITYP=$$GET1^DIQ(90050.02,BARTR(6,"I"),1.08)
S:BARITYP["MEDICARE" BARTR(6)="MCARE"
S:BARITYP["MEDICAID" BARTR(6)="MCAID"
S BARDESC=$E(BARTR(101),1,3)_"/"_$S(BARACDA=BARTR(6,"I"):"PAT",1:$E(BARTR(6),1,5))
I BARTR(101)["PAY" D
. S BARBIENS=BARITM_","_BARBATCH_","
. S BARCHECK=$$GET1^DIQ(90051.1101,BARBIENS,11)
. S BARDESC=BARDESC_"/"_BARCHECK
. I BARACDA'=BARTR(6,"I") S BARITOT=BARITOT+BARTR(3.6)
. I BARACDA=BARTR(6,"I") S BARPTOT=BARPTOT+BARTR(3.6)
; Omit transactions that contain "ERROR" in ADJ TYP
;I BARTR(101)["ADJ" S BARATOT=BARATOT+BARTR(3.7)
I BARTR(101)["ADJ"&('$D(BARBILL("XTR",BARBL,BARPBNUM,BARTRDT))) S BARATOT=BARATOT+BARTR(3.7)
S BARCRD=$S(+BARTR(2):$J(BARTR(2),8,2),1:"")
S BARDBT=$S(+BARTR(3):$J(BARTR(3),8,2),1:"")
;D PG^BARMPAS3(18)
Q:$G(BARF1)
Q
; ***
;
AGE(BARACDA) ; EP
; AGE PAST BILLS
K BARAGE,BARBL
S (BARAGE)=0
F I=0:1:3 S BARAGE(I)=0 ; set up Age array
S BARBL=0 F S BARBL=$O(^XTMP("BARPAS"_BARRUNDT,DUZ(2),1,BARACDA,"OB",BARBL)) Q:BARBL'>0 D AGE2(BARBL)
QUIT
; ***
;
AGE2(BARBL) ;
K BAR
D ENP^XBDIQ1(90050.01,BARBL,".01;7;7.2;15","BAR(")
I $D(BARBILL("X",BAR(.01))) Q ; billed in error
I '$D(^BARBL(DUZ(2),"ABAL",BARACDA,BARBL)) Q ;HEAT#100207 FIXED AGE 2/18/2014
S X=BAR(7.2)\30
S:X>3 X=3
S BARAGE(X)=BARAGE(X)+BAR(15)
S BARAGE=BARAGE+BAR(15)
Q
; ***
;
SUM ; EP
; CALCULATE AND PRESENT SUMMARY
D PG^BARMPAS3(18)
S $P(BARLINE,"=",IOM-2)=""
S $P(BARBAR,"-",IOM-2)=""
N TAB W !! F TAB=6,18,30,41,56,69 W ?TAB,BARTOTL("DASH")
W !,?6,$J($FN(BARTOTL("B"),"p",2),9)
W ?18,$J($FN(BARTOTL("I"),"p",2),9)
W ?30,$J($FN(BARTOTL("P"),"p",2),9)
W ?41,$J($FN(BARTOTL("A"),"p",2),9)
W ?56,$J($FN(BARTOTL("IO"),"p",2),9)
W ?69,$J($FN(BARTOTL("PR"),"p",2),9)
D PREPAID
W !!
W !,BARBAR
W !,"Pre-payments:"
N BARCNT1
S BARCNT1=1
S BARPPAY=0 F S BARPPAY=$O(^XTMP("BAR",$J,"BARMPAS2",BARPPAY)) Q:('BARPPAY) D
. W !," ",BARCNT1,". Receipt #",$G(^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"RECEIPT"))
. W ?30,"$",$J($G(^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"CREDIT")),8)," FOR "
. W ?43,$$SDT^BARDUTL($G(^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"TODOS")))
. W ?60,$G(^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"PAYTYPE"))
.;;; I $G(^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"BILL"))>0 W !?40,"POSTED TO BILL# ",^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"BILL") ;P.OTT
. S BARCNT1=BARCNT1+1
W !,BARBAR
I BARPTMSG'="" W !,BARPTMSG
D PG^BARMPAS3(18)
W !,BARLINE,!,"** SUMMARY by days due**",!,BARBAR
W !,?1,"0-29 Days",?17,"30-59 Days",?32,"60-89 Days",?47,"90-120+ Days",?66,"TOTAL DUE"
W !,?1,"$",$J(BARAGE(0),8,2)
W ?17,"$",$J(BARAGE(1),8,2)
W ?32,"$",$J(BARAGE(2),8,2)
W ?47,"$",$J(BARAGE(3),8,2)
W ?66,"$",$J(BARAGE,9,2)
W !,BARLINE,!
D PG^BARMPAS3(10)
W !,?25,"+++PAYMENT DUE UPON RECEIPT+++",!
W !,"** Your Insurance has been billed. You may be responsible for all or "
W !,"a portion of the billed amount based on your scheduled benefits."
W !,"Statement reflects all transactions up to statement date."
W !!,"This statement is intended for the above named patient, if you have"
W !,"received this statement in error please notify us immediately.",!
Q
; ***
;
EXIT ; EP
;I $G(BARKILL)=0 K ^XTMP("BARPAS"_BARRUNDT) ;REPLACED WITH PURGE
D POUT^BARRUTL
Q
;
PREPAID ;
K ^XTMP("BAR",$J,"BARMPAS2")
N BARPPAY,BARCTYPE,BARVAR,BARTMP
S BARPPAY=0,BARCTYPE=""
F S BARPPAY=$O(^BARPPAY(DUZ(2),"E",BARDFN,BARPPAY)) Q:('BARPPAY) D
. ;;;S BARTMP=$P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,9)
. ;;;;data example: ^BARBL(1575,7086,0)="31708B-IHH-102369^2
. ;;;option 1: I BARTMP]"" S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"BILL")=+$P($G(^BARBL(DUZ(2),BARTMP,0)),U,1)
. ;;;option 2: I $P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,9)]"" Q ;P.OTT PREPAYMENT POSTED TO A BILL: DON'T DISPLAY
. S BARVAR=$P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,6)
. S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"RECEIPT")=$P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,1)
. S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"CREDIT")=$FN($P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,7),"p",2)
. S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"TODOS")=$P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,13)
. I ($P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["CC") D
. . S BARCTYPE=$S(BARVAR="V":"VISA",BARVAR="M":"MASTERCARD",BARVAR="D":"DISCOVER",BARVAR="C":"DINERS CLUB",BARVAR="A":"AMERICAN EXPRESS",1:"NOTFOUND")
. . S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"PAYTYPE")=BARCTYPE
. I ($P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["CA") D
. . S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"PAYTYPE")="CASH"
. I ($P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["CK") D
. . S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"PAYTYPE")="CHECK #"_$P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,4)
. ;Forgot Debit Card
. I ($P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["DB") S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"PAYTYPE")="DEBIT CARD"
Q
BARMPAS2 ; IHS/SD/LSL - Patient Account Statement Print ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**2,4,19,20,23,24**;OCT 26, 2005;Build 69
+2 ; IHS/SD/LSL - 5/13/03 - V1.7 Patch 2
+3 ; IHS/SD/LSL - 12/04/03 - V1.7 Patch 4 - IM 11692
+4 ; IHS/SD/POT HEAT80718 8/21/12 ADDED SORTING OPTION BY PATNAME ;BAR1.8*23
+5 ; IHS/SD/POT HEAT58041 BUG FIX IN SUMMARY BY DAYS DUE ;BAR1.8*23
+6 ; IHS/SD/POT ADDED NEW VA billing ;BAR1.8*23
+7 ; CHANGED 0->1 INDEX FOR "OB" ENTRY IN ^XTMP
+8 ; DROP PRE-PAYMENT IF POSTED TO A BILL (defunct)
+9 ; IHS/SD/POT HEAT144442 01/06/14 FIXED QUIT AFTER USER ENTERS ;BAR1.8*24
+10 ; IHS/SD/POT HEAT100207 2/18/14 FIXED AGE ;BAR1.8*24
+11 QUIT
+12 ;
PRTASK ; EP - MOVED TO ^BARMPAS3
+1 DO PRTASK^BARMPAS3
+2 QUIT
COMPUTE ;
+1 ; computed through tasked option
+2 QUIT
+3 ; ***
PRINT ; EP
+1 ; Print Patient Account Statements.
+2 ;P.OTT
SET BARSRTBY=$GET(^XTMP("BARPAS"_BARRUNDT,0,"SORTBY"),-1)
+3 IF BARSRTBY<0
Begin DoDot:1
+4 WRITE !!,"THIS BATCH OF STATEMENTS IS NOT COMPATIBLE WITH THE NEW FILE STRUCTURE."
+5 WRITE !,"WILL RUN REIDEXING FIRST, THEN TRY AGAIN",!!
+6 DO REINDEX^BARMPAS5("BARPAS"_BARRUNDT)
+7 KILL BARRUNDT
+8 DO EOP^BARUTL(0)
+9 QUIT
End DoDot:1
QUIT
+10 ;P.OTT
IF +$ORDER(^XTMP("BARPAS"_BARRUNDT,0))=0
Begin DoDot:1
+11 WRITE !!!!!?25,"*** NO DATA TO PRINT ***"
End DoDot:1
QUIT
+12 KILL BARF1
+13 SET BARHOLD=DUZ(2)
+14 ;HEAT#144442
SET DUZ(2)=0
FOR
SET DUZ(2)=$ORDER(^XTMP("BARPAS"_BARRUNDT,DUZ(2)))
IF '+DUZ(2)
QUIT
Begin DoDot:1
+15 SET BARDUMMY=""
FOR
SET BARDUMMY=$ORDER(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY))
IF BARDUMMY=""
QUIT
Begin DoDot:2
+16 SET BARACDA=0
FOR
SET BARACDA=$ORDER(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA))
IF '+BARACDA
QUIT
DO ACCT(BARACDA)
IF $GET(BARF1)
QUIT
End DoDot:2
IF $GET(BARF1)
QUIT
End DoDot:1
IF $GET(BARF1)
QUIT
+17 SET DUZ(2)=BARHOLD
+18 QUIT
+19 ; ***
ACCT(BARACDA) ;
+1 ; For each patient account in XTMP do...
+2 IF ($DATA(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA))'>1)
QUIT
+3 ; Column Totals requested
KILL BARTOTL
+4 SET (BARTOTL("B"),BARTOTL("I"),BARTOTL("P"),BARTOTL("A"),BARTOTL("PR"))=""
SET BARTOTL("IO")=""
+5 SET BARTOTL("DASH")="---------"
+6 ;K BARF1
+7 SET BARPG=0
+8 ; Patient Acct hdr and demographics
DO PGHDR^BARMPAS3
+9 KILL BARBILL,BARBILLS
+10 SET BARACBAL=0
+11 SET VISLOC=""
FOR
SET VISLOC=$ORDER(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA,VISLOC))
IF VISLOC=""
QUIT
DO VISLOC
IF $GET(BARF1)
QUIT
+12 ;STATEMENT
DO STMT
+13 IF $GET(BARF1)
QUIT
+14 ; Age bills
DO AGE(BARACDA)
+15 ; Print patient trailer
DO SUM
+16 QUIT
VISLOC ;
+1 SET BARVDT=""
FOR
SET BARVDT=$ORDER(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA,VISLOC,BARVDT))
IF 'BARVDT
QUIT
DO GETBIL
IF $GET(BARF1)
QUIT
+2 QUIT
+3 ; End of New subscripts for sort
GETBIL ;
+1 SET BARBL=0
FOR
SET BARBL=$ORDER(^XTMP("BARPAS"_BARRUNDT,DUZ(2),0,BARDUMMY,BARACDA,VISLOC,BARVDT,BARBL))
IF BARBL=""
QUIT
DO ONEBILL
IF $GET(BARF1)
QUIT
+2 QUIT
ONEBILL ;
+1 ; Only Bill # (no A/B)
SET BARBNUM=+$$GET1^DIQ(90050.01,BARBL,.01)
+2 SET BARBILL(BARBNUM,BARBL)=""
+3 SET BARBILLS(VISLOC,BARVDT,BARBNUM,BARBL)=""
+4 QUIT
STMT SET BARBNUM=0
FOR
SET BARBNUM=$ORDER(BARBILL(BARBNUM))
IF BARBNUM'>0
QUIT
DO BILEROR
IF $GET(BARF1)
QUIT
+1 SET BARBNUM=0
+2 ;IHS/SD/PKD 1.8*19 9/13/10 new Local Array for output: BARBILLS
+3 SET VISLOC=""
FOR
SET VISLOC=$ORDER(BARBILLS(VISLOC))
IF VISLOC=""
QUIT
Begin DoDot:1
+4 WRITE !!?5,"LOCATION: ",VISLOC
+5 SET BARVDT=""
FOR
SET BARVDT=$ORDER(BARBILLS(VISLOC,BARVDT))
IF 'BARVDT
QUIT
DO STMTP
IF $GET(BARF1)
QUIT
End DoDot:1
IF $GET(BARF1)
QUIT
+6 QUIT
STMTP ; added sorts for loc & dos
+1 FOR
SET BARBNUM=$ORDER(BARBILLS(VISLOC,BARVDT,BARBNUM))
IF BARBNUM'>0
QUIT
Begin DoDot:1
+2 NEW BARBILLD,BARITOT,BARPTOT,BARATOT,BARPRSP,BARPTAC,BARPRV,BARNON,BARCXL
+3 SET (BARBILLD,BARITOT,BARPTOT,BARATOT,BARPRSP,BARPTAC,BARINSOW,BARCXL)=0
+4 DO BLDA
+5 SET BARPBNUM=BARBNUM_" "
+6 SET BARPBNUM=$ORDER(^BARBL(DUZ(2),"B",BARPBNUM))
+7 ;Trx Error code is now BARBIL("XTR",... pkd
IF $DATA(BARBILL("X",BARPBNUM))
QUIT
+8 ; If bill cancelled (3PB) and no payments or ADJ have been made, quit
+9 IF BARITOT=0&(BARPTOT=0)&(BARATOT=0)&(BARCXL)
QUIT
+10 ; No amounts period/shouldn't get this far
IF BARITOT=0&(BARPTOT=0)&(BARATOT=0)&(BARBILLD=0)
QUIT
+11 ;If all bills for bill CXL'd, get Amt from "A" bill
IF BARBILLD=0
Begin DoDot:2
+12 NEW BLIEN,BLA
+13 SET BLA=$ORDER(^BARBL(DUZ(2),"B",+BAR(.01)_"A"))
+14 SET BLIEN=$ORDER(^BARBL(DUZ(2),"B",BLA,""))
+15 SET BARBILLD=$PIECE(^BARBL(DUZ(2),BLIEN,0),U,13)
End DoDot:2
+16 ; IHS/SD/PKD 1.8*21 3/24/11 Statement Page Length
DO PG^BARMPAS3(10)
+17 IF $GET(BARF1)
QUIT
+18 IF $GET(BARPRV)=""
SET BARPRV="***** "
+19 WRITE !!,"SERVICE DATE: ",$$SHDT^BARDUTL(BAR(102,"I"))
+20 WRITE ?30,"BILL #: ",BARBNUM
+21 WRITE ?50,"PROVIDER: ",$EXTRACT(BARPRV,1,20)
+22 WRITE !?6,$JUSTIFY($FNUMBER(BARBILLD,"p",2),9)
+23 WRITE ?18,$JUSTIFY($FNUMBER(BARITOT,"p",2),9),?30,$JUSTIFY($FNUMBER(BARPTOT,"p",2),9),?41,$JUSTIFY($FNUMBER(BARATOT,"p",2),9)
+24 WRITE ?56,$JUSTIFY($FNUMBER(BARINSOW,"p",2),9)
+25 IF (BARPTAC=1!(BARNON=1)!('BARCXL))&(BARPRSP)
Begin DoDot:2
+26 WRITE ?69,$JUSTIFY($FNUMBER(BARPRSP,"p",2),9)
SET BARTOTL("PR")=BARTOTL("PR")+BARPRSP
End DoDot:2
+27 IF '$TEST
WRITE ?74,"**"
+28 ; May want to exclude some of these amts from totals if bill was cancelled
+29 SET BARTOTL("B")=BARTOTL("B")+BARBILLD
SET BARTOTL("I")=BARTOTL("I")+BARITOT
+30 SET BARTOTL("P")=BARTOTL("P")+BARPTOT
SET BARTOTL("A")=BARTOTL("A")+BARATOT
+31 SET BARTOTL("IO")=BARTOTL("IO")+BARINSOW
End DoDot:1
IF $GET(BARF1)
QUIT
+32 QUIT
+33 ; ***
+34 ;
BILEROR ;
+1 ; test to eliminate bills with billed in error
+2 SET BARPBNUM=BARBNUM_" "
+3 FOR II=1:1
SET BARPBNUM=$ORDER(^BARBL(DUZ(2),"B",BARPBNUM))
IF (+BARPBNUM'=BARBNUM)
QUIT
DO BILEROR2
+4 QUIT
+5 ; ***
+6 ;
BILEROR2 ;
+1 ; test transactions for the bill
+2 SET BARBL=$ORDER(^BARBL(DUZ(2),"B",BARPBNUM,0))
+3 SET BARTRDT=0
SET BARLPDA=0
+4 ; Billed date
SET BARBILDT=$$GET1^DIQ(90050.01,BARBL,7,"I")
+5 IF BARBILDT'>0
SET BARBILL("X",BARPBNUM)=""
QUIT
+6 FOR
SET BARTRDT=$ORDER(^BARTR(DUZ(2),"AC",BARBL,BARTRDT))
IF ('BARTRDT)!(BARTRDT\1>BARDTE)
QUIT
DO BILEROR3
+7 QUIT
+8 ; ***
+9 ;
BILEROR3 ;
+1 KILL BARTR
+2 DO ENP^XBDIQ1(90050.03,BARTRDT,".01;2;3;3.5;4;6;14;15;101;102;103","BARTR(","I")
+3 SET BARTTYP=BARTR(101,"I")
+4 IF BARTTYP'=39
IF BARTTYP'=43
IF BARTTYP'=40
IF BARTTYP'=49
IF BARTTYP'=107
QUIT
+5 IF BARTR(103)["ERROR"
SET BARBILL("XTR",BARBL,BARPBNUM,BARTRDT,"TRX ADJ 103 ERR")=""
+6 QUIT
+7 ; ***
+8 ;
BLDA ;
+1 SET BARPBNUM=BARBNUM_" "
+2 FOR II=1:1
SET BARPBNUM=$ORDER(^BARBL(DUZ(2),"B",BARPBNUM))
IF (+BARPBNUM'=BARBNUM)
QUIT
DO BLDA2
IF $GET(BARF1)
QUIT
+3 QUIT
+4 ; ***
+5 ;
BLDA2 ;
+1 ; profile bills from the first bill
+2 SET BARCXL=0
+3 ;donot process bills marked Error
IF $DATA(BARBILL("X",BARPBNUM))
QUIT
+4 SET BARBL=$ORDER(^BARBL(DUZ(2),"B",BARPBNUM,0))
+5 KILL BAR
+6 DO ENP^XBDIQ1(90050.01,BARBL,".01;3;13;15;16;17;17.2;22;101;102;108;112;113;114","BAR(","I")
+7 ;Bill Status in TPB which can be diff from A/R
SET BARBSTAT=BAR(17.2)
+8 ;If bill is in list & has pmts applied, it should print on stmt anyway
+9 ; if cancelled 1.8*19
IF BARBSTAT="CANCELLED"
SET BARCXL=1
+10 ; PT Resp if INSURER TYPE=NON-BEN or INSURER=SELF
SET BARPTAC=$SELECT(BARACDA=BAR(3,"I"):1,1:0)
+11 NEW D0,X
SET D0=BAR(3,"I")
SET BARNON=0
+12 ;(STRING)
SET X=$$VAL^BARVPM(8)
+13 IF X["NON-BEN"!(BARPTAC'=0)
SET BARPRSP=BARPRSP+BAR(15,"I")
SET BARNON=1
+14 ; Outstanding Insurance Amt
IF '$TEST
SET BARINSOW=BARINSOW+BAR(15,"I")
+15 ;if missing, Find Provider from 3Pbill
+16 ;
IF BAR(113,"I")=""
Begin DoDot:1
+17 NEW DUZ2,TPBIEN,PRV,DATA
+18 SET TPIEN=BAR(17,"I")
SET DUZ2=BAR(22,"I")
SET PRV=0
SET BARPRV=""
+19 ; DATA=PROVIDER^TYPE
FOR
SET PRV=$ORDER(^ABMDBILL(DUZ2,TPIEN,41,PRV))
IF 'PRV
QUIT
Begin DoDot:2
+20 SET DATA=^ABMDBILL(DUZ2,TPIEN,41,PRV,0)
+21 ; Want Attending(A) or Rendering(R)
IF $PIECE(DATA,U,2)'="A"&($PIECE(DATA,U,2)'="R")
QUIT
+22 SET BAR(113,"I")=+DATA
End DoDot:2
IF BARPRV'=""
QUIT
End DoDot:1
+23 IF BAR(113,"I")'=""
SET BARPRV=$PIECE($EXTRACT($PIECE(^VA(200,BAR(113,"I"),0),U,1),1,9),",",1)
+24 IF BAR(113,"I")=""
SET BARPRV="None"
+25 ; Pharmacy
IF BAR(113,"I")=""&(BAR(114,"I")=901)
SET BARPRV="Rx POS"
+26 ; END 1.8*19 get Provider
BILLED ; Get Orig Billed Amt
Begin DoDot:1
+1 IF BARCXL
QUIT
+2 ; Get Billed Amt from first alpha bill
+3 IF $GET(BARORIG(+BAR(.01)))
QUIT
+4 ; 1st unCXL bill in series
SET BARORIG(+BAR(.01))=BAR(13,"I")
+5 ; Orig Bill Amount
SET BARBILLD=BARORIG(+BAR(.01))
End DoDot:1
+6 IF $GET(BARF1)
QUIT
+7 DO BLDA3
+8 QUIT
+9 ; ***
CXL ; Use the alphabetically first bill that isn't cancelled FOR BILLED AMT
+1 ; don't think i need this subroutine ...
+2 SET BAR("3P LOC")=$$FIND3PB^BARUTL(DUZ(2),BAR)
+3 ; Bill not found 3PB
IF BAR("3P LOC")=""
QUIT
+4 SET BAR3PDUZ=$PIECE(BAR("3P LOC"),",")
+5 SET BAR3PIEN=$PIECE(BAR("3P LOC"),",",2)
+6 ; Need 3 pieces
SET BARB3PB0=$GET(^ABMDBILL(BAR3PDUZ,BAR3PIEN,0))
+7 ; Bill Status
SET BARBSTAT=$PIECE(BARB3PB0,U,4)
+8 QUIT
+9 ;
BLDA3 ;
+1 ; profile this bills transactions
+2 SET BARTRDT=0
SET BARLPDA=0
+3 FOR
SET BARTRDT=$ORDER(^BARTR(DUZ(2),"AC",BARBL,BARTRDT))
IF ('BARTRDT)!(BARTRDT\1>BARDTE)
QUIT
DO BLDA4
IF $GET(BARF1)
QUIT
+4 QUIT
+5 ; ***
+6 ;
BLDA4 ;
+1 KILL BARTR
+2 DO ENP^XBDIQ1(90050.03,BARTRDT,".01;2;3;3.5;3.6;3.7;4;5;6;14;15;101;102;103","BARTR(","I")
+3 ;EXCLUDE ADJ CAT DEDUCTIBLE & CO-PAY
IF (BARTR(102,"I")=13)!(BARTR(102,"I")=14)
QUIT
+4 SET BARTTYP=BARTR(101,"I")
+5 IF BARTTYP'=39
IF BARTTYP'=43
IF BARTTYP'=40
IF BARTTYP'=49
IF BARTTYP'=107
SET II=II-1
QUIT
+6 SET BARBATCH=BARTR(14,"I")
+7 SET BARITM=BARTR(15,"I")
+8 SET BARCLIN=$$GET1^DIQ(90050.01,BARTR(4,"I"),112)
+9 SET BARCLIN=$EXTRACT(BARCLIN,1,8)
+10 SET BARITYP=$$GET1^DIQ(90050.02,BARTR(6,"I"),1.08)
+11 IF BARITYP["MEDICARE"
SET BARTR(6)="MCARE"
+12 IF BARITYP["MEDICAID"
SET BARTR(6)="MCAID"
+13 SET BARDESC=$EXTRACT(BARTR(101),1,3)_"/"_$SELECT(BARACDA=BARTR(6,"I"):"PAT",1:$EXTRACT(BARTR(6),1,5))
+14 IF BARTR(101)["PAY"
Begin DoDot:1
+15 SET BARBIENS=BARITM_","_BARBATCH_","
+16 SET BARCHECK=$$GET1^DIQ(90051.1101,BARBIENS,11)
+17 SET BARDESC=BARDESC_"/"_BARCHECK
+18 IF BARACDA'=BARTR(6,"I")
SET BARITOT=BARITOT+BARTR(3.6)
+19 IF BARACDA=BARTR(6,"I")
SET BARPTOT=BARPTOT+BARTR(3.6)
End DoDot:1
+20 ; Omit transactions that contain "ERROR" in ADJ TYP
+21 ;I BARTR(101)["ADJ" S BARATOT=BARATOT+BARTR(3.7)
+22 IF BARTR(101)["ADJ"&('$DATA(BARBILL("XTR",BARBL,BARPBNUM,BARTRDT)))
SET BARATOT=BARATOT+BARTR(3.7)
+23 SET BARCRD=$SELECT(+BARTR(2):$JUSTIFY(BARTR(2),8,2),1:"")
+24 SET BARDBT=$SELECT(+BARTR(3):$JUSTIFY(BARTR(3),8,2),1:"")
+25 ;D PG^BARMPAS3(18)
+26 IF $GET(BARF1)
QUIT
+27 QUIT
+28 ; ***
+29 ;
AGE(BARACDA) ; EP
+1 ; AGE PAST BILLS
+2 KILL BARAGE,BARBL
+3 SET (BARAGE)=0
+4 ; set up Age array
FOR I=0:1:3
SET BARAGE(I)=0
+5 SET BARBL=0
FOR
SET BARBL=$ORDER(^XTMP("BARPAS"_BARRUNDT,DUZ(2),1,BARACDA,"OB",BARBL))
IF BARBL'>0
QUIT
DO AGE2(BARBL)
+6 QUIT
+7 ; ***
+8 ;
AGE2(BARBL) ;
+1 KILL BAR
+2 DO ENP^XBDIQ1(90050.01,BARBL,".01;7;7.2;15","BAR(")
+3 ; billed in error
IF $DATA(BARBILL("X",BAR(.01)))
QUIT
+4 ;HEAT#100207 FIXED AGE 2/18/2014
IF '$DATA(^BARBL(DUZ(2),"ABAL",BARACDA,BARBL))
QUIT
+5 SET X=BAR(7.2)\30
+6 IF X>3
SET X=3
+7 SET BARAGE(X)=BARAGE(X)+BAR(15)
+8 SET BARAGE=BARAGE+BAR(15)
+9 QUIT
+10 ; ***
+11 ;
SUM ; EP
+1 ; CALCULATE AND PRESENT SUMMARY
+2 DO PG^BARMPAS3(18)
+3 SET $PIECE(BARLINE,"=",IOM-2)=""
+4 SET $PIECE(BARBAR,"-",IOM-2)=""
+5 NEW TAB
WRITE !!
FOR TAB=6,18,30,41,56,69
WRITE ?TAB,BARTOTL("DASH")
+6 WRITE !,?6,$JUSTIFY($FNUMBER(BARTOTL("B"),"p",2),9)
+7 WRITE ?18,$JUSTIFY($FNUMBER(BARTOTL("I"),"p",2),9)
+8 WRITE ?30,$JUSTIFY($FNUMBER(BARTOTL("P"),"p",2),9)
+9 WRITE ?41,$JUSTIFY($FNUMBER(BARTOTL("A"),"p",2),9)
+10 WRITE ?56,$JUSTIFY($FNUMBER(BARTOTL("IO"),"p",2),9)
+11 WRITE ?69,$JUSTIFY($FNUMBER(BARTOTL("PR"),"p",2),9)
+12 DO PREPAID
+13 WRITE !!
+14 WRITE !,BARBAR
+15 WRITE !,"Pre-payments:"
+16 NEW BARCNT1
+17 SET BARCNT1=1
+18 SET BARPPAY=0
FOR
SET BARPPAY=$ORDER(^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY))
IF ('BARPPAY)
QUIT
Begin DoDot:1
+19 WRITE !," ",BARCNT1,". Receipt #",$GET(^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"RECEIPT"))
+20 WRITE ?30,"$",$JUSTIFY($GET(^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"CREDIT")),8)," FOR "
+21 WRITE ?43,$$SDT^BARDUTL($GET(^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"TODOS")))
+22 WRITE ?60,$GET(^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"PAYTYPE"))
+23 ;;; I $G(^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"BILL"))>0 W !?40,"POSTED TO BILL# ",^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"BILL") ;P.OTT
+24 SET BARCNT1=BARCNT1+1
End DoDot:1
+25 WRITE !,BARBAR
+26 IF BARPTMSG'=""
WRITE !,BARPTMSG
+27 DO PG^BARMPAS3(18)
+28 WRITE !,BARLINE,!,"** SUMMARY by days due**",!,BARBAR
+29 WRITE !,?1,"0-29 Days",?17,"30-59 Days",?32,"60-89 Days",?47,"90-120+ Days",?66,"TOTAL DUE"
+30 WRITE !,?1,"$",$JUSTIFY(BARAGE(0),8,2)
+31 WRITE ?17,"$",$JUSTIFY(BARAGE(1),8,2)
+32 WRITE ?32,"$",$JUSTIFY(BARAGE(2),8,2)
+33 WRITE ?47,"$",$JUSTIFY(BARAGE(3),8,2)
+34 WRITE ?66,"$",$JUSTIFY(BARAGE,9,2)
+35 WRITE !,BARLINE,!
+36 DO PG^BARMPAS3(10)
+37 WRITE !,?25,"+++PAYMENT DUE UPON RECEIPT+++",!
+38 WRITE !,"** Your Insurance has been billed. You may be responsible for all or "
+39 WRITE !,"a portion of the billed amount based on your scheduled benefits."
+40 WRITE !,"Statement reflects all transactions up to statement date."
+41 WRITE !!,"This statement is intended for the above named patient, if you have"
+42 WRITE !,"received this statement in error please notify us immediately.",!
+43 QUIT
+44 ; ***
+45 ;
EXIT ; EP
+1 ;I $G(BARKILL)=0 K ^XTMP("BARPAS"_BARRUNDT) ;REPLACED WITH PURGE
+2 DO POUT^BARRUTL
+3 QUIT
+4 ;
PREPAID ;
+1 KILL ^XTMP("BAR",$JOB,"BARMPAS2")
+2 NEW BARPPAY,BARCTYPE,BARVAR,BARTMP
+3 SET BARPPAY=0
SET BARCTYPE=""
+4 FOR
SET BARPPAY=$ORDER(^BARPPAY(DUZ(2),"E",BARDFN,BARPPAY))
IF ('BARPPAY)
QUIT
Begin DoDot:1
+5 ;;;S BARTMP=$P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,9)
+6 ;;;;data example: ^BARBL(1575,7086,0)="31708B-IHH-102369^2
+7 ;;;option 1: I BARTMP]"" S ^XTMP("BAR",$J,"BARMPAS2",BARPPAY,"BILL")=+$P($G(^BARBL(DUZ(2),BARTMP,0)),U,1)
+8 ;;;option 2: I $P($G(^BARPPAY(DUZ(2),BARPPAY,0)),U,9)]"" Q ;P.OTT PREPAYMENT POSTED TO A BILL: DON'T DISPLAY
+9 SET BARVAR=$PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,6)
+10 SET ^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"RECEIPT")=$PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,1)
+11 SET ^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"CREDIT")=$FNUMBER($PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,7),"p",2)
+12 SET ^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"TODOS")=$PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,13)
+13 IF ($PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["CC")
Begin DoDot:2
+14 SET BARCTYPE=$SELECT(BARVAR="V":"VISA",BARVAR="M":"MASTERCARD",BARVAR="D":"DISCOVER",BARVAR="C":"DINERS CLUB",BARVAR="A":"AMERICAN EXPRESS",1:"NOTFOUND")
+15 SET ^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"PAYTYPE")=BARCTYPE
End DoDot:2
+16 IF ($PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["CA")
Begin DoDot:2
+17 SET ^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"PAYTYPE")="CASH"
End DoDot:2
+18 IF ($PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["CK")
Begin DoDot:2
+19 SET ^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"PAYTYPE")="CHECK #"_$PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,4)
End DoDot:2
+20 ;Forgot Debit Card
+21 IF ($PIECE($GET(^BARPPAY(DUZ(2),BARPPAY,0)),U,3)["DB")
SET ^XTMP("BAR",$JOB,"BARMPAS2",BARPPAY,"PAYTYPE")="DEBIT CARD"
End DoDot:1
+22 QUIT
