ABMPPADJ ; IHS/SD/SDR - Prior Payments/Adjustments page (CE);
;;2.6;IHS 3P BILLING SYSTEM;**4,6,8,9,10,19,21,23**;NOV 12, 2009;Build 427
; split routine to ABMPPAD1 because of size
;
;IHS/SD/SDR - v2.5 p13 - NO IM
;
;IHS/SD/SDR 2.6*6 5010 - added export mode 32
;IHS/SD/SDR 2.6*19 HEAT168248 - Added code to put each SAR only once with the total amt. In split routine, ABMPPAD3
;IHS/SD/SDR 2.6*21 HEAT118718 - Check for replacement insurer
;IHS/SD/SDR 2.6*23 CR9730 Added call for PRINT ORDER CHARGE SCREEN page
;
;ABMPL(Insurer priority, Insurer IEN)=
; P1=13 multiple IEN
; P2=Billing status
;ABMPP(Insurer IEN, "P" or "A", Counter)=
; P1=Amount
; P2=Adj Category
; P3=Trans. Type
; P4=Std Adj. Reason
; P5=billable?(Y/N)
; P6=Payment multiple IEN
DISPCK ; chk if no complete insurer OR if 2 export modes on claim; don't do if either is true
;
;if medicaid insurer type, UB-04 or 837I, itemized, and they chose to display print order screen
I (ABMP("ITYP")="D")&("^28^31^"[("^"_ABMP("EXP")_"^"))&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),0)),U,12)=1)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,24)="Y") D PRTORD^ABMDEOK1 ;abm*2.6*23 IHS/SD/SDR CR9730
K ABMTFLAG,ABMSFLG,ABMMFLG
K ABMPM
N ABMPP
S ABMA=0
K ABMAFLG,ABMMFLG
F S ABMA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMA)) Q:+ABMA=0 D
.S ABMAI=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMA,0)),U)
.Q:ABMAI="" ;abm*2.6*10 HEAT74239
.I $P($G(^ABMNINS(ABMP("LDFN"),ABMAI,0)),U,11)="Y",($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMA,0)),U,3)="C") S ABMAFLG=1
.I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMAI,".211","I"),1,"I")="R",($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,8)=ABMAI) S ABMMFLG=1 ;abm*2.6*9 tribal self-insured ;abm*2.6*10 HEAT73780
I $G(ABMAFLG)=1,($G(ABMMFLG)=1) Q ;don't do COB page cuz there is a tribal insurer and Medicare
K ABMAFLG,ABMMFLG
D DISPCK^ABMPPAD1
GATHER Q:$G(ABMCHK)=1 ;quit if no complete insurer or 2 export modes on claim
K ABMPM,ABMPP
D SETVAR^ABMPPAD1
S ABMPHRN=$P($G(^AUPNPAT(ABMP("PDFN"),41,DUZ(2),0)),U,2)
S ABMBSUF=$P($G(^ABMDPARM(ABMP("LDFN"),1,2)),U,4)
;loop thru active bills
S ABMBSTA=""
F S ABMBSTA=$O(^ABMDBILL(DUZ(2),"AS",ABMP("CDFN"),ABMBSTA)) Q:ABMBSTA="" D
.Q:ABMBSTA="X"
.S ABMBFIEN=0
.F S ABMBFIEN=$O(^ABMDBILL(DUZ(2),"AS",ABMP("CDFN"),ABMBSTA,ABMBFIEN)) Q:+ABMBFIEN=0 D
..S ABMBNUM=$P($G(^ABMDBILL(DUZ(2),ABMBFIEN,0)),U)
..;get previous payments
..S ABMPIEN=0,ABMTFLAG=0
..F S ABMPIEN=$O(^ABMDBILL(DUZ(2),ABMBFIEN,3,ABMPIEN)) Q:+ABMPIEN=0 D
...S ABMLN=+$G(ABMLN)+1
...S ABMPREC=$G(^ABMDBILL(DUZ(2),ABMBFIEN,3,ABMPIEN,0))
...;check if summary or split out entries; if split set flag so it won't
...;get trans from A/R again
...S ABMBINS=$P($G(^ABMDBILL(DUZ(2),ABMBFIEN,0)),U,8) ;abm*2.6*6
...I $P($G(^ABMDBILL(DUZ(2),ABMBFIEN,2)),U)'=(+$P(ABMPREC,U,3)+($P(ABMPREC,U,4))+($P(ABMPREC,U,6))+($P(ABMPREC,U,7))+($P(ABMPREC,U,9))+($P(ABMPREC,U,10))+($P(ABMPREC,U,12))+($P(ABMPREC,U,13))+($P(ABMPREC,U,14))) D
....S ABMTFLAG=1
....S ABMOPDT=$P(ABMPREC,U)
....I +$P(ABMPREC,U,10)'=0 S ABMCAT="P",ABMAMT=$P(ABMPREC,U,10)
....E D
.....S ABMCAT="A"
.....S ABMADJC=$P(ABMPREC,U,15)
.....S ABMADJT=$P(ABMPREC,U,16)
.....S ABMSAR=$P(ABMPREC,U,17)
.....I ABMADJC=3 S ABMAMT=$P(ABMPREC,U,6)
.....I ABMADJC=4 S ABMAMT=$P(ABMPREC,U,7)
.....I ABMADJC=13 S ABMAMT=$P(ABMPREC,U,3)
.....I ABMADJC=14 S ABMAMT=$P(ABMPREC,U,4)
.....I ABMADJC=15 S ABMAMT=$P(ABMPREC,U,9)
.....I ABMADJC=16 S ABMAMT=$P(ABMPREC,U,12)
.....I ABMADJC=19 S ABMAMT=$P(ABMPREC,U,13)
.....I ABMADJC=20 S ABMAMT=$P(ABMPREC,U,14)
....S ABMBINS=$P($G(^ABMDBILL(DUZ(2),ABMBFIEN,0)),U,8)
....;start new abm*2.6*21 IHS/SD/SDR HEAT118718
....I '$D(^ABMDBILL(DUZ(2),ABMBFIEN,13,"B",ABMBINS)) D ;means it is a replacement insruer
.....S ABMTIEN=0,ABMTFLG=0
.....F S ABMTIEN=$O(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN)) Q:'ABMTIEN D Q:ABMTFLG
......I $P($G(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U,11)=ABMBINS D ;this is our replacement
.......S ABMBINS=$P($G(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U)
.......S ABMTFLG=1
.....K ABMTIEN,ABMTFLG
....;end new abm*2.6*21 IHS/SD/SDR HEAT118718
....Q:(+$G(ABMAMT)=0)&(($G(ABMCAT)="A")&(+$G(ABMADJC)=0)) ;stop <UNDEF>GATHER+42 error
....S ABMPP(ABMBINS,ABMCAT,ABMLN)=ABMAMT_$S(ABMCAT="A":"^"_ABMADJC_"^"_ABMADJT_"^"_ABMSAR,1:"")
....I ABMCAT="P" S $P(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="N"
....I ABMCAT="A",(ABMADJC=13!(ABMADJC=14)) S $P(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="Y"
....I ABMCAT="A",(ABMADJC'=13&(ABMADJC'=14)) S $P(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="N"
....S $P(ABMPP(ABMBINS,ABMCAT,ABMLN),U,6)=ABMPIEN ;save payment IEN w/trans
...S ABMILST(ABMBINS,ABMBFIEN)="" ;abm*2.6*6 5010
...I $P($G(^ABMDBILL(DUZ(2),ABMBFIEN,2)),U)=(+$P(ABMPREC,U,3)+($P(ABMPREC,U,4))+($P(ABMPREC,U,6))+($P(ABMPREC,U,7))+($P(ABMPREC,U,9))+($P(ABMPREC,U,10))+($P(ABMPREC,U,12))+($P(ABMPREC,U,13))+($P(ABMPREC,U,14))) D
....S ABMOPDT=$P($G(^ABMDBILL(DUZ(2),ABMBFIEN,3,ABMPIEN,0)),U) ;original pymt dt
....K ^ABMDBILL(DUZ(2),ABMBFIEN,3) ;remove summary entry; individual entries will be filed later
..Q:($G(ABMTFLAG)=1) ;trans split; skip next part
..;get trans for those bills
..I $P($G(^ABMDPARM(ABMP("LDFN"),1,2)),U,4)'="" S ABMBNUM=$G(ABMBNUM)_"-"_ABMBSUF
..I $P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,3)=1 S ABMBNUM=$G(ABMBNUM)_"-"_ABMPHRN
..;
..S ABMHOLD=DUZ(2)
..S ABMSAT=ABMP("LDFN") ;Satellite = 3P Visit loc
..S ABMPAR=0 ;Parent
..; check site active at DOS to ensure bill added to correct site
..S DA=0
..F S DA=$O(^BAR(90052.06,DA)) Q:DA'>0 D Q:ABMPAR
...Q:'$D(^BAR(90052.06,DA,DA)) ; Pos Parent UNDEF Site Parameter
...Q:'$D(^BAR(90052.05,DA,ABMSAT)) ; Satellite UNDEF Parent/Satellit
...Q:+$P($G(^BAR(90052.05,DA,ABMSAT,0)),U,5) ; Par/Sat not usable
...; Q if sat NOT active at DOS
...I ABMP("VDT")<$P($G(^BAR(90052.05,DA,ABMSAT,0)),U,6) Q
...; Q if sat became NOT active before DOS
...I $P($G(^BAR(90052.05,DA,ABMSAT,0)),U,7),(ABMP("VDT")>$P($G(^BAR(90052.05,DA,ABMSAT,0)),U,7)) Q
...S ABMPAR=$S(ABMSAT:$P($G(^BAR(90052.05,DA,ABMSAT,0)),U,3),1:"")
..Q:+ABMPAR=0
..S DUZ(2)=ABMPAR
..S ABMAIEN=$O(^BARBL(DUZ(2),"B",ABMBNUM,0))
..I +$G(ABMAIEN)=0 S:+$G(ABMHOLD)'=0 DUZ(2)=ABMHOLD K ABMHOLD Q ;there isn't an A/R bill w/this number
..Q:$P($G(^BARAC(DUZ(2),$P($G(^BARBL(DUZ(2),ABMAIEN,0)),U,3),0)),U)'["AUTNINS" ;abm*2.6*10 HEAT70085
..S ABMBINS=+$P($G(^BARAC(DUZ(2),$P($G(^BARBL(DUZ(2),ABMAIEN,0)),U,3),0)),U) ;abm*2.6*10 HEAT70085
..;start new abm*2.6*21 IHS/SD/SDR HEAT118718
..I '$D(^ABMDBILL(DUZ(2),ABMBFIEN,13,"B",ABMBINS)) D ;means it is a replacement insruer
...S ABMTIEN=0,ABMTFLG=0
...F S ABMTIEN=$O(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN)) Q:'ABMTIEN D Q:ABMTFLG
....I $P($G(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U,11)=ABMBINS D ;this is our replacement
.....S ABMBINS=$P($G(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U)
.....S ABMTFLG=1
...K ABMTIEN,ABMTFLG
...S ABMILST(ABMBINS,ABMBFIEN)=""
..;end new abm*2.6*21 IHS/SD/SDR HEAT118718
..S ABMTRIEN=0,ABMLN=1
..F S ABMTRIEN=$O(^BARTR(DUZ(2),"AC",ABMAIEN,ABMTRIEN)) Q:ABMTRIEN="" D
...S ABMREC=$G(^BARTR(DUZ(2),ABMTRIEN,0))
...I $G(ABMOPDT)="" S ABMOPDT=$P($P(ABMREC,U),".")
...Q:+$P(ABMREC,U,2)=0&(+$P(ABMREC,U,3)=0)
...;S ABMBINS=$P(ABMREC,U,6) ;abm*2.6*10 HEAT70085
...;Q:$P($G(^BARAC(DUZ(2),ABMBINS,0)),U)'["AUTNINS" ;abm*2.6*10 HEAT70085
...;S ABMBINS=+$P($G(^BARAC(DUZ(2),ABMBINS,0)),U) ;abm*2.6*10 HEAT70085
...S ABMTTYP=$P($G(^BARTR(DUZ(2),ABMTRIEN,1)),U,1)
...S ABMADJC=$P($G(^BARTR(DUZ(2),ABMTRIEN,1)),U,2)
...S ABMCAT=""
...I ABMTTYP=40 S ABMCAT="P"
...I "^3^4^13^14^15^16^19^20^"[("^"_ABMADJC_"^") S ABMCAT="A",ABMTTYP=$P($G(^BARTR(DUZ(2),ABMTRIEN,1)),U,3)
...Q:ABMCAT=""
...S ABMPP(ABMBINS,ABMCAT,ABMLN)=$S(+$P(ABMREC,U,2)'=0&(ABMCAT="A"):$P(ABMREC,U,2),+$P(ABMREC,U,2)'=0&(ABMCAT="P"):$P(ABMREC,U,2),1:$P(ABMREC,U,3))_"^"_ABMADJC_"^"_ABMTTYP
...I ABMCAT="A",$D(^BARADJ("C",ABMADJC,ABMTTYP)) S $P(ABMPP(ABMBINS,ABMCAT,ABMLN),U,4)=$O(^BARADJ("C",ABMADJC,ABMTTYP,0)) ;abm*2.6*4 NOHEAT
...I ABMCAT="P" S $P(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="N",ABMLN=ABMLN+1 Q
...S $P(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="Y",ABMLN=ABMLN+1
..I +$G(ABMHOLD)'=0 S DUZ(2)=ABMHOLD K ABMHOLD
..D ^ABMPPAD3 ;split routine abm*2.6*19 IHS/SD/SDR HEAT168248
..I ABMTFLAG=0 D ^ABMPPFLR ;do filer if trans not split
;D ^ABMPPAD3 ;split routine abm*2.6*19 IHS/SD/SDR HEAT168248
S ABMTFLAG=1
DISP K ABMSFLG,ABMMFLG
D SETVAR^ABMPPAD1
S ABMDASH="",$P(ABMDASH,"-",80)=""
S ABMZ("TITL")="PRIOR PAYMENTS/ADJUSTMENTS"
S ABMP("SCRN")="A"
S ABMZ("PG")="A"
I '$D(ABMP("DDL")) D SUM^ABMDE1 I 1
E S ABMC("CONT")="" D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) XIT
;
S ABMINS=0
F S ABMINS=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS)) Q:+ABMINS=0 D
.S ABMIIEN=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U)
.S ABMPRI=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,2)
.S ABMSTAT=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,3)
.Q:ABMSTAT'="I"&(ABMSTAT'="C")
.S ABMPL(ABMPRI,ABMIIEN)=ABMINS_"^"_ABMSTAT
;
S ABMPM("TOT")=ABMP("TOT")-(+$G(ABMP("NC")))
S ABMP("CBAMT")=0
S ABMIPRI=0
F S ABMIPRI=$O(ABMPL(ABMIPRI)) Q:+ABMIPRI=0 D
.S ABMIIEN=0
.F S ABMIIEN=$O(ABMPL(ABMIPRI,ABMIIEN)) Q:+ABMIIEN=0 D
..S ABMCAT=""
..F S ABMCAT=$O(ABMPP(ABMIIEN,ABMCAT)) Q:ABMCAT="" D
...S ABMLN=0
...F S ABMLN=$O(ABMPP(ABMIIEN,ABMCAT,ABMLN)) Q:+ABMLN=0 D
....I $P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,5)="Y" S ABMP("CBAMT")=ABMP("CBAMT")+($FN($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U),"-"))
....I ABMCAT="P" S ABMPM("PD")=+$G(ABMPM("PD"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
....I ABMCAT="A" D
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=3 ABMPM("WO")=+$G(ABMPM("WO"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=4 ABMPM("NONC")=+$G(ABMPM("NONC"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=13 ABMPM("DED")=+$G(ABMPM("DED"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=14 ABMPM("COI")=+$G(ABMPM("COI"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=15 ABMPM("PENS")=+$G(ABMPM("PENS"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=16 ABMPM("GRP")=+$G(ABMPM("GRP"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=19 ABMPM("REF")=+$G(ABMPM("REF"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
.....S:$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=20 ABMPM("PCR")=+$G(ABMPM("PCR"))+($P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
;
W !,"Payment Amount....: " S ABMNFLG=1 W $$DOLAMT(ABMPM("PD")) K ABMNFLG
W ?40,"ORIGINAL BILL AMOUNT: ",$J(+$G(ABMP("OBAMT")),10,2)
W !,"Deductible Amount.: ",$$DOLAMT(ABMPM("DED"))
W ?40,"Current Charges.....: ",$J(+$G(ABMPM("TOT")),10,2)
W !,"Co-pay/ins Amount.: ",$$DOLAMT(ABMPM("COI"))
W ?40,"Current Bill Amount.: ",$$EN^ABMVDF("HIN"),$J(+$G(ABMP("CBAMT")),10,2),$$EN^ABMVDF("HIF")
W !,"Write Off.........: ",$$DOLAMT(ABMPM("WO"))
W !,"Non-Covered Amount: ",$$DOLAMT(ABMPM("NONC"))
W !,"Penalty Amount....: ",$$DOLAMT(ABMPM("PENS"))
W !,"Grouper Allowance.: ",$$DOLAMT(ABMPM("GRP"))
W !,"Refund............: ",$$DOLAMT(ABMPM("REF"))
W !,"Payment Credits...: ",$$DOLAMT(ABMPM("PCR"))
;
S ABMPRI=0
F S ABMPRI=$O(ABMPL(ABMPRI)) Q:+ABMPRI=0 D
.S ABMIIEN=0
.S ABMPRIS=ABMPRI
.F S ABMIIEN=$O(ABMPL(ABMPRI,ABMIIEN)) Q:+ABMIIEN=0 D
..S ABMSTAT=$P(ABMPL(ABMPRI,ABMIIEN),U,2)
..S ABMINS=$P(ABMPL(ABMPRI,ABMIIEN),U)
..S ABMSTAT=$S(ABMSTAT="F":"FLAGGED",ABMSTAT="I":"ACTIVE",ABMSTAT="P":"PENDING",ABMSTAT="U":"UNBILLABLE",ABMSTAT="C":"COMPLETED",ABMSTAT="B":"BILLED",ABMSTAT="L":"PARTIAL",1:"")
..W !!,"["_ABMPRI_"] INSURER: ",$E($P($G(^AUTNINS(ABMIIEN,0)),U),1,27)
..W ?40,"PRIORITY ORDER: ",ABMPRI
..W ?62,"STATUS: ",$S(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVN"),1:""),ABMSTAT,$S(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVF"),1:"")
..S ABMCOV=0
..F S ABMCOV=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV)) Q:+ABMCOV=0 D
...I $P($G(^AUTNINS(ABMIIEN,0)),U)["MEDICARE" D
....W !?14,"COVERAGE TYPE: ",$P($G(^AUTTPIC(ABMCOV,0)),U)
....S ABMCOV=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV))
....I +ABMCOV'=0 W ", ",$P($G(^AUTTPIC(ABMCOV,0)),U)
...E W !?14,"COVERAGE TYPE: ",$P($G(^AUTTPIC(ABMCOV,0)),U)
..S ABMCAT=""
..F S ABMCAT=$O(ABMPP(ABMIIEN,ABMCAT),-1) Q:ABMCAT="" D
...S ABMLN=0
...F S ABMLN=$O(ABMPP(ABMIIEN,ABMCAT,ABMLN)) Q:+ABMLN=0 D
....Q:+$P(ABMPP(ABMIIEN,ABMCAT,ABMLN),U)=0
....I +$G(ABMLNSV)<ABMLN S ABMLNSV=ABMLN
....S ABMDAMT=$P($G(ABMPP(ABMIIEN,ABMCAT,ABMLN)),U)
....I ABMCAT="P" S ABMNFLG=1
....S ABMDAMT=$$DOLAMT(ABMDAMT)
....K ABMNFLG
....I ABMCAT="P" W !?6,"PAYMENT: ",ABMDAMT
....E D
.....W !?3,"ADJUSTMENT: ",ABMDAMT
.....S ABMPREC=$G(ABMPP(ABMIIEN,ABMCAT,ABMLN))
.....I $P(ABMPREC,U,2)'="" W ?28,"[",$P(ABMPREC,U,2),"] ",$E($P($G(^BAR(90052.01,$P(ABMPREC,U,2),0)),U),1,18)
.....I $P(ABMPREC,U,3)'="" W ?48,"[",$P(ABMPREC,U,3),"] ",$E($P($G(^BARTBL($P(ABMPREC,U,3),0)),U),1,18)
.....I $P($G(ABMPREC),U,4)'="" D
......W ?75,"["_$P(^BARADJ($P($G(ABMPREC),U,4),0),U)_"]"
......I $P(^BARADJ($P(ABMPREC,U,4),0),U,3)'=$P(ABMPREC,U,2) S ABMMFLG=1
......I $P(^BARADJ($P(ABMPREC,U,4),0),U,4)'=$P(ABMPREC,U,3) S ABMMFLG=1
.....I $P($G(ABMPREC),U,4)="",($P(ABMPREC,U)'=0) S ABMSFLG=1
W !,ABMDASH,!
;I ((ABMP("EXP")=21)!(ABMP("EXP")=22)!(ABMP("EXP")=23)) D ;abm*2.6*6 5010
;I ((ABMP("EXP")=21)!(ABMP("EXP")=22)!(ABMP("EXP")=23)!(ABMP("EXP")=32)) D ;abm*2.6*6 5010 ;abm*2.6*8 5010
I ((ABMP("EXP")=21)!(ABMP("EXP")=22)!(ABMP("EXP")=23)!(ABMP("EXP")=31)!(ABMP("EXP")=32)!(ABMP("EXP")=33)) D ;abm*2.6*6 5010 ;abm*2.6*8 5010
.I $G(ABMSFLG)=1 W "ERROR: STANDARD ADJUSTMENT CODE NOT ENTERED FOR ADJUSTMENT",!
.I $G(ABMMFLG)=1 W "ERROR: STANDARD ADJUSTMENT REASON DOESN'T MATCH ADJUSTMENT CATEGORY/REASON",!
.I ABMP("CBAMT")<0 W "ERROR: NEGATIVE BALANCE ON BILL NOT ALLOWED",! S ABMSFLG=1
.I $G(ABMSFLG)=1!($G(ABMMFLG)=1) W ABMDASH,!
W "**Use the EDIT option to populate the Standard Adjustment Reason Code**",!
E K ABMSFLG,ABMMFLG ;remove flag for other checks of this error
;
S ABMP("OPT")="AEQ"
S ABMP("DFLT")="Q"
D SEL^ABMDEOPT
I "AE"'[$E(Y) G XIT
G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
S ABM("DO")=$S($E(Y)="A":"ADD",$E(Y)="E":"EDIT",1:"XIT") D @ABM("DO") G DISP
XIT ;
D XIT^ABMPPAD1
Q
DOLAMT(AMT) ;
Q $S(($E(AMT,1)="-"!($G(ABMNFLG)=1))&(AMT'=0):"("_$J($S($E(AMT)="-":$E(AMT,2,$L(AMT)),1:AMT),10,2)_")",1:$J(+$G(AMT),11,2))
ADD ;
D ADD^ABMPPAD1
Q:($G(ABMEFLG)=1)
D EDIT2
Q
EDIT ;
D EDIT^ABMPPAD1
Q:($G(ABMEFLG)=1) ;tried to edit active insurer OR no trans selected
EDIT2 ;
D EDIT2^ABMPPAD1
D ^ABMPPFLR
Q
ABMPPADJ ; IHS/SD/SDR - Prior Payments/Adjustments page (CE);
+1 ;;2.6;IHS 3P BILLING SYSTEM;**4,6,8,9,10,19,21,23**;NOV 12, 2009;Build 427
+2 ; split routine to ABMPPAD1 because of size
+3 ;
+4 ;IHS/SD/SDR - v2.5 p13 - NO IM
+5 ;
+6 ;IHS/SD/SDR 2.6*6 5010 - added export mode 32
+7 ;IHS/SD/SDR 2.6*19 HEAT168248 - Added code to put each SAR only once with the total amt. In split routine, ABMPPAD3
+8 ;IHS/SD/SDR 2.6*21 HEAT118718 - Check for replacement insurer
+9 ;IHS/SD/SDR 2.6*23 CR9730 Added call for PRINT ORDER CHARGE SCREEN page
+10 ;
+11 ;ABMPL(Insurer priority, Insurer IEN)=
+12 ; P1=13 multiple IEN
+13 ; P2=Billing status
+14 ;ABMPP(Insurer IEN, "P" or "A", Counter)=
+15 ; P1=Amount
+16 ; P2=Adj Category
+17 ; P3=Trans. Type
+18 ; P4=Std Adj. Reason
+19 ; P5=billable?(Y/N)
+20 ; P6=Payment multiple IEN
DISPCK ; chk if no complete insurer OR if 2 export modes on claim; don't do if either is true
+1 ;
+2 ;if medicaid insurer type, UB-04 or 837I, itemized, and they chose to display print order screen
+3 ;abm*2.6*23 IHS/SD/SDR CR9730
IF (ABMP("ITYP")="D")&("^28^31^"[("^"_ABMP("EXP")_"^"))&($PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),0)),U,12)=1)&($PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,24)="Y")
DO PRTORD^ABMDEOK1
+4 KILL ABMTFLAG,ABMSFLG,ABMMFLG
+5 KILL ABMPM
+6 NEW ABMPP
+7 SET ABMA=0
+8 KILL ABMAFLG,ABMMFLG
+9 FOR
SET ABMA=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMA))
IF +ABMA=0
QUIT
Begin DoDot:1
+10 SET ABMAI=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMA,0)),U)
+11 ;abm*2.6*10 HEAT74239
IF ABMAI=""
QUIT
+12 IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMAI,0)),U,11)="Y"
IF ($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMA,0)),U,3)="C")
SET ABMAFLG=1
+13 ;abm*2.6*9 tribal self-insured ;abm*2.6*10 HEAT73780
IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMAI,".211","I"),1,"I")="R"
IF ($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,8)=ABMAI)
SET ABMMFLG=1
End DoDot:1
+14 ;don't do COB page cuz there is a tribal insurer and Medicare
IF $GET(ABMAFLG)=1
IF ($GET(ABMMFLG)=1)
QUIT
+15 KILL ABMAFLG,ABMMFLG
+16 DO DISPCK^ABMPPAD1
GATHER ;quit if no complete insurer or 2 export modes on claim
IF $GET(ABMCHK)=1
QUIT
+1 KILL ABMPM,ABMPP
+2 DO SETVAR^ABMPPAD1
+3 SET ABMPHRN=$PIECE($GET(^AUPNPAT(ABMP("PDFN"),41,DUZ(2),0)),U,2)
+4 SET ABMBSUF=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,2)),U,4)
+5 ;loop thru active bills
+6 SET ABMBSTA=""
+7 FOR
SET ABMBSTA=$ORDER(^ABMDBILL(DUZ(2),"AS",ABMP("CDFN"),ABMBSTA))
IF ABMBSTA=""
QUIT
Begin DoDot:1
+8 IF ABMBSTA="X"
QUIT
+9 SET ABMBFIEN=0
+10 FOR
SET ABMBFIEN=$ORDER(^ABMDBILL(DUZ(2),"AS",ABMP("CDFN"),ABMBSTA,ABMBFIEN))
IF +ABMBFIEN=0
QUIT
Begin DoDot:2
+11 SET ABMBNUM=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,0)),U)
+12 ;get previous payments
+13 SET ABMPIEN=0
SET ABMTFLAG=0
+14 FOR
SET ABMPIEN=$ORDER(^ABMDBILL(DUZ(2),ABMBFIEN,3,ABMPIEN))
IF +ABMPIEN=0
QUIT
Begin DoDot:3
+15 SET ABMLN=+$GET(ABMLN)+1
+16 SET ABMPREC=$GET(^ABMDBILL(DUZ(2),ABMBFIEN,3,ABMPIEN,0))
+17 ;check if summary or split out entries; if split set flag so it won't
+18 ;get trans from A/R again
+19 ;abm*2.6*6
SET ABMBINS=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,0)),U,8)
+20 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,2)),U)'=(+$PIECE(ABMPREC,U,3)+($PIECE(ABMPREC,U,4))+($PIECE(ABMPREC,U,6))+($PIECE(ABMPREC,U,7))+($PIECE(ABMPREC,U,9))+($PIECE(ABMPREC,U,10))+($PIECE(ABMPREC,U,12))+($PIECE(ABMPREC
,U,13))+($PIECE(ABMPREC,U,14)))
Begin DoDot:4
+21 SET ABMTFLAG=1
+22 SET ABMOPDT=$PIECE(ABMPREC,U)
+23 IF +$PIECE(ABMPREC,U,10)'=0
SET ABMCAT="P"
SET ABMAMT=$PIECE(ABMPREC,U,10)
+24 IF '$TEST
Begin DoDot:5
+25 SET ABMCAT="A"
+26 SET ABMADJC=$PIECE(ABMPREC,U,15)
+27 SET ABMADJT=$PIECE(ABMPREC,U,16)
+28 SET ABMSAR=$PIECE(ABMPREC,U,17)
+29 IF ABMADJC=3
SET ABMAMT=$PIECE(ABMPREC,U,6)
+30 IF ABMADJC=4
SET ABMAMT=$PIECE(ABMPREC,U,7)
+31 IF ABMADJC=13
SET ABMAMT=$PIECE(ABMPREC,U,3)
+32 IF ABMADJC=14
SET ABMAMT=$PIECE(ABMPREC,U,4)
+33 IF ABMADJC=15
SET ABMAMT=$PIECE(ABMPREC,U,9)
+34 IF ABMADJC=16
SET ABMAMT=$PIECE(ABMPREC,U,12)
+35 IF ABMADJC=19
SET ABMAMT=$PIECE(ABMPREC,U,13)
+36 IF ABMADJC=20
SET ABMAMT=$PIECE(ABMPREC,U,14)
End DoDot:5
+37 SET ABMBINS=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,0)),U,8)
+38 ;start new abm*2.6*21 IHS/SD/SDR HEAT118718
+39 ;means it is a replacement insruer
IF '$DATA(^ABMDBILL(DUZ(2),ABMBFIEN,13,"B",ABMBINS))
Begin DoDot:5
+40 SET ABMTIEN=0
SET ABMTFLG=0
+41 FOR
SET ABMTIEN=$ORDER(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN))
IF 'ABMTIEN
QUIT
Begin DoDot:6
+42 ;this is our replacement
IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U,11)=ABMBINS
Begin DoDot:7
+43 SET ABMBINS=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U)
+44 SET ABMTFLG=1
End DoDot:7
End DoDot:6
IF ABMTFLG
QUIT
+45 KILL ABMTIEN,ABMTFLG
End DoDot:5
+46 ;end new abm*2.6*21 IHS/SD/SDR HEAT118718
+47 ;stop <UNDEF>GATHER+42 error
IF (+$GET(ABMAMT)=0)&(($GET(ABMCAT)="A")&(+$GET(ABMADJC)=0))
QUIT
+48 SET ABMPP(ABMBINS,ABMCAT,ABMLN)=ABMAMT_$SELECT(ABMCAT="A":"^"_ABMADJC_"^"_ABMADJT_"^"_ABMSAR,1:"")
+49 IF ABMCAT="P"
SET $PIECE(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="N"
+50 IF ABMCAT="A"
IF (ABMADJC=13!(ABMADJC=14))
SET $PIECE(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="Y"
+51 IF ABMCAT="A"
IF (ABMADJC'=13&(ABMADJC'=14))
SET $PIECE(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="N"
+52 ;save payment IEN w/trans
SET $PIECE(ABMPP(ABMBINS,ABMCAT,ABMLN),U,6)=ABMPIEN
End DoDot:4
+53 ;abm*2.6*6 5010
SET ABMILST(ABMBINS,ABMBFIEN)=""
+54 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,2)),U)=(+$PIECE(ABMPREC,U,3)+($PIECE(ABMPREC,U,4))+($PIECE(ABMPREC,U,6))+($PIECE(ABMPREC,U,7))+($PIECE(ABMPREC,U,9))+($PIECE(ABMPREC,U,10))+($PIECE(ABMPREC,U,12))+($PIECE(ABMPREC,
U,13))+($PIECE(ABMPREC,U,14)))
Begin DoDot:4
+55 ;original pymt dt
SET ABMOPDT=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,3,ABMPIEN,0)),U)
+56 ;remove summary entry; individual entries will be filed later
KILL ^ABMDBILL(DUZ(2),ABMBFIEN,3)
End DoDot:4
End DoDot:3
+57 ;trans split; skip next part
IF ($GET(ABMTFLAG)=1)
QUIT
+58 ;get trans for those bills
+59 IF $PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,2)),U,4)'=""
SET ABMBNUM=$GET(ABMBNUM)_"-"_ABMBSUF
+60 IF $PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,3)=1
SET ABMBNUM=$GET(ABMBNUM)_"-"_ABMPHRN
+61 ;
+62 SET ABMHOLD=DUZ(2)
+63 ;Satellite = 3P Visit loc
SET ABMSAT=ABMP("LDFN")
+64 ;Parent
SET ABMPAR=0
+65 ; check site active at DOS to ensure bill added to correct site
+66 SET DA=0
+67 FOR
SET DA=$ORDER(^BAR(90052.06,DA))
IF DA'>0
QUIT
Begin DoDot:3
+68 ; Pos Parent UNDEF Site Parameter
IF '$DATA(^BAR(90052.06,DA,DA))
QUIT
+69 ; Satellite UNDEF Parent/Satellit
IF '$DATA(^BAR(90052.05,DA,ABMSAT))
QUIT
+70 ; Par/Sat not usable
IF +$PIECE($GET(^BAR(90052.05,DA,ABMSAT,0)),U,5)
QUIT
+71 ; Q if sat NOT active at DOS
+72 IF ABMP("VDT")<$PIECE($GET(^BAR(90052.05,DA,ABMSAT,0)),U,6)
QUIT
+73 ; Q if sat became NOT active before DOS
+74 IF $PIECE($GET(^BAR(90052.05,DA,ABMSAT,0)),U,7)
IF (ABMP("VDT")>$PIECE($GET(^BAR(90052.05,DA,ABMSAT,0)),U,7))
QUIT
+75 SET ABMPAR=$SELECT(ABMSAT:$PIECE($GET(^BAR(90052.05,DA,ABMSAT,0)),U,3),1:"")
End DoDot:3
IF ABMPAR
QUIT
+76 IF +ABMPAR=0
QUIT
+77 SET DUZ(2)=ABMPAR
+78 SET ABMAIEN=$ORDER(^BARBL(DUZ(2),"B",ABMBNUM,0))
+79 ;there isn't an A/R bill w/this number
IF +$GET(ABMAIEN)=0
IF +$GET(ABMHOLD)'=0
SET DUZ(2)=ABMHOLD
KILL ABMHOLD
QUIT
+80 ;abm*2.6*10 HEAT70085
IF $PIECE($GET(^BARAC(DUZ(2),$PIECE($GET(^BARBL(DUZ(2),ABMAIEN,0)),U,3),0)),U)'["AUTNINS"
QUIT
+81 ;abm*2.6*10 HEAT70085
SET ABMBINS=+$PIECE($GET(^BARAC(DUZ(2),$PIECE($GET(^BARBL(DUZ(2),ABMAIEN,0)),U,3),0)),U)
+82 ;start new abm*2.6*21 IHS/SD/SDR HEAT118718
+83 ;means it is a replacement insruer
IF '$DATA(^ABMDBILL(DUZ(2),ABMBFIEN,13,"B",ABMBINS))
Begin DoDot:3
+84 SET ABMTIEN=0
SET ABMTFLG=0
+85 FOR
SET ABMTIEN=$ORDER(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN))
IF 'ABMTIEN
QUIT
Begin DoDot:4
+86 ;this is our replacement
IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U,11)=ABMBINS
Begin DoDot:5
+87 SET ABMBINS=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBFIEN,13,ABMTIEN,0)),U)
+88 SET ABMTFLG=1
End DoDot:5
End DoDot:4
IF ABMTFLG
QUIT
+89 KILL ABMTIEN,ABMTFLG
+90 SET ABMILST(ABMBINS,ABMBFIEN)=""
End DoDot:3
+91 ;end new abm*2.6*21 IHS/SD/SDR HEAT118718
+92 SET ABMTRIEN=0
SET ABMLN=1
+93 FOR
SET ABMTRIEN=$ORDER(^BARTR(DUZ(2),"AC",ABMAIEN,ABMTRIEN))
IF ABMTRIEN=""
QUIT
Begin DoDot:3
+94 SET ABMREC=$GET(^BARTR(DUZ(2),ABMTRIEN,0))
+95 IF $GET(ABMOPDT)=""
SET ABMOPDT=$PIECE($PIECE(ABMREC,U),".")
+96 IF +$PIECE(ABMREC,U,2)=0&(+$PIECE(ABMREC,U,3)=0)
QUIT
+97 ;S ABMBINS=$P(ABMREC,U,6) ;abm*2.6*10 HEAT70085
+98 ;Q:$P($G(^BARAC(DUZ(2),ABMBINS,0)),U)'["AUTNINS" ;abm*2.6*10 HEAT70085
+99 ;S ABMBINS=+$P($G(^BARAC(DUZ(2),ABMBINS,0)),U) ;abm*2.6*10 HEAT70085
+100 SET ABMTTYP=$PIECE($GET(^BARTR(DUZ(2),ABMTRIEN,1)),U,1)
+101 SET ABMADJC=$PIECE($GET(^BARTR(DUZ(2),ABMTRIEN,1)),U,2)
+102 SET ABMCAT=""
+103 IF ABMTTYP=40
SET ABMCAT="P"
+104 IF "^3^4^13^14^15^16^19^20^"[("^"_ABMADJC_"^")
SET ABMCAT="A"
SET ABMTTYP=$PIECE($GET(^BARTR(DUZ(2),ABMTRIEN,1)),U,3)
+105 IF ABMCAT=""
QUIT
+106 SET ABMPP(ABMBINS,ABMCAT,ABMLN)=$SELECT(+$PIECE(ABMREC,U,2)'=0&(ABMCAT="A"):$PIECE(ABMREC,U,2),+$PIECE(ABMREC,U,2)'=0&(ABMCAT="P"):$PIECE(ABMREC,U,2),1:$PIECE(ABMREC,U,3))_"^"_ABMADJC_"^"_ABMTTYP
+107 ;abm*2.6*4 NOHEAT
IF ABMCAT="A"
IF $DATA(^BARADJ("C",ABMADJC,ABMTTYP))
SET $PIECE(ABMPP(ABMBINS,ABMCAT,ABMLN),U,4)=$ORDER(^BARADJ("C",ABMADJC,ABMTTYP,0))
+108 IF ABMCAT="P"
SET $PIECE(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="N"
SET ABMLN=ABMLN+1
QUIT
+109 SET $PIECE(ABMPP(ABMBINS,ABMCAT,ABMLN),U,5)="Y"
SET ABMLN=ABMLN+1
End DoDot:3
+110 IF +$GET(ABMHOLD)'=0
SET DUZ(2)=ABMHOLD
KILL ABMHOLD
+111 ;split routine abm*2.6*19 IHS/SD/SDR HEAT168248
DO ^ABMPPAD3
+112 ;do filer if trans not split
IF ABMTFLAG=0
DO ^ABMPPFLR
End DoDot:2
End DoDot:1
+113 ;D ^ABMPPAD3 ;split routine abm*2.6*19 IHS/SD/SDR HEAT168248
+114 SET ABMTFLAG=1
DISP KILL ABMSFLG,ABMMFLG
+1 DO SETVAR^ABMPPAD1
+2 SET ABMDASH=""
SET $PIECE(ABMDASH,"-",80)=""
+3 SET ABMZ("TITL")="PRIOR PAYMENTS/ADJUSTMENTS"
+4 SET ABMP("SCRN")="A"
+5 SET ABMZ("PG")="A"
+6 IF '$DATA(ABMP("DDL"))
DO SUM^ABMDE1
IF 1
+7 IF '$TEST
SET ABMC("CONT")=""
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
+8 ;
+9 SET ABMINS=0
+10 FOR
SET ABMINS=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS))
IF +ABMINS=0
QUIT
Begin DoDot:1
+11 SET ABMIIEN=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U)
+12 SET ABMPRI=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,2)
+13 SET ABMSTAT=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,0)),U,3)
+14 IF ABMSTAT'="I"&(ABMSTAT'="C")
QUIT
+15 SET ABMPL(ABMPRI,ABMIIEN)=ABMINS_"^"_ABMSTAT
End DoDot:1
+16 ;
+17 SET ABMPM("TOT")=ABMP("TOT")-(+$GET(ABMP("NC")))
+18 SET ABMP("CBAMT")=0
+19 SET ABMIPRI=0
+20 FOR
SET ABMIPRI=$ORDER(ABMPL(ABMIPRI))
IF +ABMIPRI=0
QUIT
Begin DoDot:1
+21 SET ABMIIEN=0
+22 FOR
SET ABMIIEN=$ORDER(ABMPL(ABMIPRI,ABMIIEN))
IF +ABMIIEN=0
QUIT
Begin DoDot:2
+23 SET ABMCAT=""
+24 FOR
SET ABMCAT=$ORDER(ABMPP(ABMIIEN,ABMCAT))
IF ABMCAT=""
QUIT
Begin DoDot:3
+25 SET ABMLN=0
+26 FOR
SET ABMLN=$ORDER(ABMPP(ABMIIEN,ABMCAT,ABMLN))
IF +ABMLN=0
QUIT
Begin DoDot:4
+27 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,5)="Y"
SET ABMP("CBAMT")=ABMP("CBAMT")+($FNUMBER($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U),"-"))
+28 IF ABMCAT="P"
SET ABMPM("PD")=+$GET(ABMPM("PD"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+29 IF ABMCAT="A"
Begin DoDot:5
+30 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=3
SET ABMPM("WO")=+$GET(ABMPM("WO"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+31 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=4
SET ABMPM("NONC")=+$GET(ABMPM("NONC"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+32 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=13
SET ABMPM("DED")=+$GET(ABMPM("DED"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+33 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=14
SET ABMPM("COI")=+$GET(ABMPM("COI"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+34 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=15
SET ABMPM("PENS")=+$GET(ABMPM("PENS"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+35 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=16
SET ABMPM("GRP")=+$GET(ABMPM("GRP"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+36 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=19
SET ABMPM("REF")=+$GET(ABMPM("REF"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
+37 IF $PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U,2)=20
SET ABMPM("PCR")=+$GET(ABMPM("PCR"))+($PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U))
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+38 ;
+39 WRITE !,"Payment Amount....: "
SET ABMNFLG=1
WRITE $$DOLAMT(ABMPM("PD"))
KILL ABMNFLG
+40 WRITE ?40,"ORIGINAL BILL AMOUNT: ",$JUSTIFY(+$GET(ABMP("OBAMT")),10,2)
+41 WRITE !,"Deductible Amount.: ",$$DOLAMT(ABMPM("DED"))
+42 WRITE ?40,"Current Charges.....: ",$JUSTIFY(+$GET(ABMPM("TOT")),10,2)
+43 WRITE !,"Co-pay/ins Amount.: ",$$DOLAMT(ABMPM("COI"))
+44 WRITE ?40,"Current Bill Amount.: ",$$EN^ABMVDF("HIN"),$JUSTIFY(+$GET(ABMP("CBAMT")),10,2),$$EN^ABMVDF("HIF")
+45 WRITE !,"Write Off.........: ",$$DOLAMT(ABMPM("WO"))
+46 WRITE !,"Non-Covered Amount: ",$$DOLAMT(ABMPM("NONC"))
+47 WRITE !,"Penalty Amount....: ",$$DOLAMT(ABMPM("PENS"))
+48 WRITE !,"Grouper Allowance.: ",$$DOLAMT(ABMPM("GRP"))
+49 WRITE !,"Refund............: ",$$DOLAMT(ABMPM("REF"))
+50 WRITE !,"Payment Credits...: ",$$DOLAMT(ABMPM("PCR"))
+51 ;
+52 SET ABMPRI=0
+53 FOR
SET ABMPRI=$ORDER(ABMPL(ABMPRI))
IF +ABMPRI=0
QUIT
Begin DoDot:1
+54 SET ABMIIEN=0
+55 SET ABMPRIS=ABMPRI
+56 FOR
SET ABMIIEN=$ORDER(ABMPL(ABMPRI,ABMIIEN))
IF +ABMIIEN=0
QUIT
Begin DoDot:2
+57 SET ABMSTAT=$PIECE(ABMPL(ABMPRI,ABMIIEN),U,2)
+58 SET ABMINS=$PIECE(ABMPL(ABMPRI,ABMIIEN),U)
+59 SET ABMSTAT=$SELECT(ABMSTAT="F":"FLAGGED",ABMSTAT="I":"ACTIVE",ABMSTAT="P":"PENDING",ABMSTAT="U":"UNBILLABLE",ABMSTAT="C":"COMPLETED",ABMSTAT="B":"BILLED",ABMSTAT="L":"PARTIAL",1:"")
+60 WRITE !!,"["_ABMPRI_"] INSURER: ",$EXTRACT($PIECE($GET(^AUTNINS(ABMIIEN,0)),U),1,27)
+61 WRITE ?40,"PRIORITY ORDER: ",ABMPRI
+62 WRITE ?62,"STATUS: ",$SELECT(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVN"),1:""),ABMSTAT,$SELECT(ABMSTAT="COMPLETED":$$EN^ABMVDF("RVF"),1:"")
+63 SET ABMCOV=0
+64 FOR
SET ABMCOV=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV))
IF +ABMCOV=0
QUIT
Begin DoDot:3
+65 IF $PIECE($GET(^AUTNINS(ABMIIEN,0)),U)["MEDICARE"
Begin DoDot:4
+66 WRITE !?14,"COVERAGE TYPE: ",$PIECE($GET(^AUTTPIC(ABMCOV,0)),U)
+67 SET ABMCOV=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINS,11,ABMCOV))
+68 IF +ABMCOV'=0
WRITE ", ",$PIECE($GET(^AUTTPIC(ABMCOV,0)),U)
End DoDot:4
+69 IF '$TEST
WRITE !?14,"COVERAGE TYPE: ",$PIECE($GET(^AUTTPIC(ABMCOV,0)),U)
End DoDot:3
+70 SET ABMCAT=""
+71 FOR
SET ABMCAT=$ORDER(ABMPP(ABMIIEN,ABMCAT),-1)
IF ABMCAT=""
QUIT
Begin DoDot:3
+72 SET ABMLN=0
+73 FOR
SET ABMLN=$ORDER(ABMPP(ABMIIEN,ABMCAT,ABMLN))
IF +ABMLN=0
QUIT
Begin DoDot:4
+74 IF +$PIECE(ABMPP(ABMIIEN,ABMCAT,ABMLN),U)=0
QUIT
+75 IF +$GET(ABMLNSV)<ABMLN
SET ABMLNSV=ABMLN
+76 SET ABMDAMT=$PIECE($GET(ABMPP(ABMIIEN,ABMCAT,ABMLN)),U)
+77 IF ABMCAT="P"
SET ABMNFLG=1
+78 SET ABMDAMT=$$DOLAMT(ABMDAMT)
+79 KILL ABMNFLG
+80 IF ABMCAT="P"
WRITE !?6,"PAYMENT: ",ABMDAMT
+81 IF '$TEST
Begin DoDot:5
+82 WRITE !?3,"ADJUSTMENT: ",ABMDAMT
+83 SET ABMPREC=$GET(ABMPP(ABMIIEN,ABMCAT,ABMLN))
+84 IF $PIECE(ABMPREC,U,2)'=""
WRITE ?28,"[",$PIECE(ABMPREC,U,2),"] ",$EXTRACT($PIECE($GET(^BAR(90052.01,$PIECE(ABMPREC,U,2),0)),U),1,18)
+85 IF $PIECE(ABMPREC,U,3)'=""
WRITE ?48,"[",$PIECE(ABMPREC,U,3),"] ",$EXTRACT($PIECE($GET(^BARTBL($PIECE(ABMPREC,U,3),0)),U),1,18)
+86 IF $PIECE($GET(ABMPREC),U,4)'=""
Begin DoDot:6
+87 WRITE ?75,"["_$PIECE(^BARADJ($PIECE($GET(ABMPREC),U,4),0),U)_"]"
+88 IF $PIECE(^BARADJ($PIECE(ABMPREC,U,4),0),U,3)'=$PIECE(ABMPREC,U,2)
SET ABMMFLG=1
+89 IF $PIECE(^BARADJ($PIECE(ABMPREC,U,4),0),U,4)'=$PIECE(ABMPREC,U,3)
SET ABMMFLG=1
End DoDot:6
+90 IF $PIECE($GET(ABMPREC),U,4)=""
IF ($PIECE(ABMPREC,U)'=0)
SET ABMSFLG=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+91 WRITE !,ABMDASH,!
+92 ;I ((ABMP("EXP")=21)!(ABMP("EXP")=22)!(ABMP("EXP")=23)) D ;abm*2.6*6 5010
+93 ;I ((ABMP("EXP")=21)!(ABMP("EXP")=22)!(ABMP("EXP")=23)!(ABMP("EXP")=32)) D ;abm*2.6*6 5010 ;abm*2.6*8 5010
+94 ;abm*2.6*6 5010 ;abm*2.6*8 5010
IF ((ABMP("EXP")=21)!(ABMP("EXP")=22)!(ABMP("EXP")=23)!(ABMP("EXP")=31)!(ABMP("EXP")=32)!(ABMP("EXP")=33))
Begin DoDot:1
+95 IF $GET(ABMSFLG)=1
WRITE "ERROR: STANDARD ADJUSTMENT CODE NOT ENTERED FOR ADJUSTMENT",!
+96 IF $GET(ABMMFLG)=1
WRITE "ERROR: STANDARD ADJUSTMENT REASON DOESN'T MATCH ADJUSTMENT CATEGORY/REASON",!
+97 IF ABMP("CBAMT")<0
WRITE "ERROR: NEGATIVE BALANCE ON BILL NOT ALLOWED",!
SET ABMSFLG=1
+98 IF $GET(ABMSFLG)=1!($GET(ABMMFLG)=1)
WRITE ABMDASH,!
End DoDot:1
+99 WRITE "**Use the EDIT option to populate the Standard Adjustment Reason Code**",!
+100 ;remove flag for other checks of this error
IF '$TEST
KILL ABMSFLG,ABMMFLG
+101 ;
+102 SET ABMP("OPT")="AEQ"
+103 SET ABMP("DFLT")="Q"
+104 DO SEL^ABMDEOPT
+105 IF "AE"'[$EXTRACT(Y)
GOTO XIT
+106 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO XIT
+107 SET ABM("DO")=$SELECT($EXTRACT(Y)="A":"ADD",$EXTRACT(Y)="E":"EDIT",1:"XIT")
DO @ABM("DO")
GOTO DISP
XIT ;
+1 DO XIT^ABMPPAD1
+2 QUIT
DOLAMT(AMT) ;
+1 QUIT $SELECT(($EXTRACT(AMT,1)="-"!($GET(ABMNFLG)=1))&(AMT'=0):"("_$JUSTIFY($SELECT($EXTRACT(AMT)="-":$EXTRACT(AMT,2,$LENGTH(AMT)),1:AMT),10,2)_")",1:$JUSTIFY(+$GET(AMT),11,2))
ADD ;
+1 DO ADD^ABMPPAD1
+2 IF ($GET(ABMEFLG)=1)
QUIT
+3 DO EDIT2
+4 QUIT
EDIT ;
+1 DO EDIT^ABMPPAD1
+2 ;tried to edit active insurer OR no trans selected
IF ($GET(ABMEFLG)=1)
QUIT
EDIT2 ;
+1 DO EDIT2^ABMPPAD1
+2 DO ^ABMPPFLR
+3 QUIT
