Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BARMPAS2

BARMPAS2.m

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