ABMERUTL ; IHS/ASDST/DMJ - EMC UTILITIES ;
;;2.6;IHS 3P BILLING SYSTEM;**3,6,9,10,19,21**;NOV 12, 2009;Build 379
;Original;DMJ;09/21/95 12:47 PM
;IHS/SD/SDR 2.5*8 IM14799 EA0 field 15 (pos 54) not populating correctly; Modified BCBS
; line tag to kill possible pre-existing value of ABME("LOC")
;IHS/SD/SDR-2.5*9 IM16962 Allow Receiver ID to be longer than 5 chars
;IHS/SD/SDR-2.5*10 IM20225/IM20271 Set replacement insurer correctly
;IHS/SD/SDR-2.6*3 HEAT7574 tribal self-insured changes
;IHS/SD/SDR-2.6*6 5010-made changes for multi-insurer GCNs
;IHS/SD/SDR-2.6*19 HEAT116949 Translated out spaces for CROSSOVER visit type check
;IHS/SD/SDR 2.6*21 HEAT115124 Added code to POS to check export mode 27 for overrides
;IHS/SD/SDR 2.6*21 HEAT284071 Added code to POS for ADA (34) overrides
;
FMT(X,Y) ; EP
;Format Variable
; INPUT: X = DATA STRING
; Y = FORMAT INSTRUCTONS
;OUTPUT: X = FORMATTED DATA
;
I $G(ABMP("NOFMT")) Q X ;No formatting
S $P(ABMP("SPACES")," ",130)="" ;130 spaces
S $P(ABMP("ZEROS"),"0",60)="" ;60 zeroes
I Y["J" D
.N I S I=$P(Y,"J",2)
.S I=$E(I)
.S X=$TR($J(X,1,I),".")
I Y["S" D
.S X=$TR(X,"-\/!@#$%&*.,")
S ABME("FILLER")=$S(Y["N":ABMP("ZEROS"),1:ABMP("SPACES"))
S X=$S(Y["R":ABME("FILLER")_X,1:X_ABME("FILLER"))
S X=$S(Y["R":$E(X,$L(X)+1-+Y,$L(X)),1:$E(X,1,+Y))
Q X
;
STRIP(X) ;EP strip trailing blanks
N I F I=$L(X):-1:1 D Q:$G(ABMLN)
.Q:$E(X,I)=" "
.S ABMLN=I
S X=$E(X,1,ABMLN)
K ABMLN
Q X
STRPL(X) ;EP strip leading blanks
N I
S ABMLEN=$L(X," ")
F I=1:1:ABMLEN D Q:$P(X," ",I)'=""
.Q:$P(X," ",I)'=""
S X=$P(X," ",I,ABMLEN)
K ABMLEN
Q X
DFMT ; EP Format Date Field
S Y=$E(Y,4,5)_$E(Y,6,7)_$E(Y,2,3)
Q
;
SET ; EP Set up some things
Q:$G(ABMP("SET")) ;Quit if already set up these vars
K ABMP("INS")
N I
F I=0:1:9 D
.S @("ABMB"_I)=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),I))
S ABMP("PDFN")=$P(ABMB0,"^",5) ;Patient IEN
S ABMP("LDFN")=$P(ABMB0,"^",3) ;Visit loc IEN
S ABMP("BTYP")=$P(ABMB0,"^",2) ;Bill type
S ABMP("EXP")=$P(ABMB0,"^",6) ;Export mode IEN
S ABMP("INS")=$P(ABMB0,"^",8) ;Active Ins IEN
S ABMP("VTYP")=$P(ABMB0,"^",7) ;Vtyp IEN
S ABMP("CLIN")=$P(ABMB0,"^",10) ;Clinic
S ABMP("CLIN")=$P($G(^DIC(40.7,+ABMP("CLIN"),0)),"^",2)
S ABMP("VDT")=$P(ABMB7,U) ;Service date from
;S ABMP("ITYPE")=$P($G(^AUTNINS(+ABMP("INS"),2)),U) ;abm*2.6*10 HEAT73780
S ABMP("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I") ;Type of insurer ;abm*2.6*10 HEAT73780
D ISET ;set up insurers
D PCN
D SOP
S ABMP("SET")=1 ;set variable set flag
Q
;
ISET ; EP
;Set up Insurers
;ABMP("INS",priority) = Insurer IEN ^ type of insurer ^ Insurer multiple IEN
K ABMCDNUM
S ABME("PRIO")=0
S ABME("INS#")=0
;Loop down priority
F S ABME("PRIO")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABME("PRIO"))) Q:'ABME("PRIO")!($G(ABMP("INS",3))) D
.N I
.S I=0
.;Loop entries
.F S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABME("PRIO"),I)) Q:'I!($G(ABMP("INS",3))) D
..;Quit if insurer unbillable
..Q:$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U,3)="U"
..S ABME("INS")=$S($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U,11)'="":$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U,11),1:$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U)) ;Insurer IEN
..;S ABME("ITYPE")=$P(^AUTNINS(ABME("INS"),2),U) ;abm*2.6*10 HEAT73780
..S ABME("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABME("INS"),".211","I"),1,"I") ;type of insurer ;abm*2.6*10 HEAT73780
..Q:"I"[ABME("ITYPE") ;Quit if indian patient
..;Quit if non-ben and not active insurer
..Q:"N"[ABME("ITYPE")&($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U,8)'=ABME("INS"))
..S ABME("INS#")=ABME("INS#")+1 ;increment counter
..S ABMP("INS",ABME("INS#"))=ABME("INS")_"^"_ABME("ITYPE")_"^"_I
..I ABME("ITYPE")="D"!(ABME("ITYPE")="K") D
...S ABMCDNUM=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),"^",6)
...S:'$G(ABMP("PDFN")) ABMP("PDFN")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",5)
...Q:$P($G(^AUPNMCD(+ABMCDNUM,0)),U)=ABMP("PDFN")
...D DBFX^ABMDEFIP(ABMP("BDFN"),I)
...S ABMCDNUM=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),"^",6)
I +$G(ABMP("INS"))'=0,($$RCID^ABMUTLP(ABMP("INS"))["61044") D
.Q:$P($G(ABMP("INS",1)),U)=ABMP("INS") ;61044 is primary
.Q:$P($G(^AUTNINS($P($G(ABMP("INS",1)),U),0)),U)'["MEDICARE" ;Medicare isn't primary
.Q:$$RCID^ABMUTLP($P($G(ABMP("INS",2)),U))'["61044" ;Medi-Cal is not secondary
.;Q:$P($G(^ABMDVTYP(ABMP("VTYP"),0)),U)'["CROSSOVER" ;vtyp must contain CROSSOVER ;abm*2.6*19 HEAT116949
.Q:$TR($P($G(^ABMDVTYP(ABMP("VTYP"),0)),U)," ")'["CROSSOVER" ;vtyp must contain CROSSOVER ;abm*2.6*19 HEAT116949
.S ABMP("INS",1)=ABMP("INS",2) ;move Medi-Cal to primary spot
.K ABMP("INS",2) ;remove Medi-Cal from secondary
Q
PCN ;EP Patient Control Number
S:'$G(ABMDUZ2) ABMDUZ2=DUZ(2)
S ABMP("PCN")=$P(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0),U)
S ABMSFX=$P($G(^ABMDPARM(+ABMP("LDFN"),1,2)),"^",4)
I ABMSFX'="" D
.S ABMP("PCN")=ABMP("PCN")_"-"_ABMSFX
I $P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,3) D
.S ABMP("HRN")=$P($G(^AUPNPAT(+ABMP("PDFN"),41,+ABMP("LDFN"),0)),"^",2)
.S:ABMP("HRN")="" ABMP("HRN")=$P($G(^AUPNPAT(+ABMP("PDFN"),41,DUZ(2),0)),"^",2)
.Q:ABMP("HRN")=""
.S ABMP("PCN")=ABMP("PCN")_"-"_ABMP("HRN")
K ABMSFX
Q
SOP ;EP Source of Pay
N X
S X=$F("HMDRPWCFNIK",ABMP("ITYPE"))
S ABMP("SOP")=$E(" IZDCFBHZAZD",X)
I ABMP("ITYPE")="P" D BCBS S:$G(ABMP("BCBS")) ABMP("SOP")="G"
Q
BCBS ; EP check if Blue Cross/Blue Shield
K ABME("LOC")
K ABMP("BCBS")
S ABMP("INAME")=$P($G(^AUTNINS(ABMP("INS"),0)),U)
N I
F I="B","C","S" D Q:'ABME("LOC")
.S ABME("LOC")=$F(ABMP("INAME"),I,$G(ABME("LOC")))
Q:'ABME("LOC")
S ABMP("BCBS")=1
Q
RCID(X) ;EP Receiver ID (X=Insurer IEN)
S Y=$P($G(^AUTNINS(X,0)),"^",8)
I +Y=400 D Q Y
.S Y="00400"
.I $G(ABMP("VTYP"))=999!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=22)) S Y="00900"
.I $G(ABMP("EXP"))>20 S Y="C"_Y
;start old abm*2.6*10 HEAT74059
;I Y=4001 D Q Y
;.S Y="04001"
;.;I $G(ABMP("VTYP"))=999!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=22)) S Y="04402" ;ASC ;abm*2.6*9 IHS/SD/AML 3/9/2012
;.I $G(ABMP("VTYP"))=999!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=22))!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=32)) S Y="04402" ;abm*2.6*9 IHS/SD/AML 3/9/2012 Mods for DSU
;.I $G(ABMP("CLIN"))="A3" S Y="04402" ;abm*2.6*10 IHS/SD/AML HEAT68447
;end old start new HEAT74059
I "^4001^4311^4211^4111^4411^"[("^"_Y_"^") D Q Y
.S Y="0"_Y
.I $G(ABMP("VTYP"))=999!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=22))!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=32))!($G(ABMP("CLIN"))="A3"!($G(ABMP("CLN"))="A3")) D
..S:Y="04001" Y="04402"
..S:Y="04311" Y="04312"
..S:Y="04211" Y="04212"
..S:Y="04111" Y="04112"
..S:Y="04411" Y=$S((DT<3121119):"04402",1:"04412")
;end new HEAT74059
Q Y
ENVY(X,Y) ;EP Envoy Payer ID (X=Insurer EIN,Y=Visit Type)
N ABM,I,Z
S Z=""
F I=1:1:3 S ABM(I)=$P($G(^AUTNINS(+X,5)),"^",I)
I Y=111 S Z=ABM(2)
I Y="H" S Z=ABM(2)
I Y=998 S Z=ABM(3)
I Y="D" S Z=ABM(3)
I Y=999 S Z=ABM(1)
I Y="M" S Z=ABM(1)
I Y=131 S Z=ABM(1)
I Z="" S Z=ABM(1)
S Z=$P($G(^ABMENVOY(+$G(Z),0)),U)
Q Z
MSG(X) ; EP
;Display message to terminal
Q:$G(ABMQUIET)
W !!,*7,X,!
F W ! Q:$Y+3>IOSL
S DIR(0)="E"
D ^DIR
K DIR
Q
;
PAYED ; EP
;Build Insurance Payment Array
K ABMP("PAYED")
N L
S L=+$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U)_" " ;Bill number
F S L=$O(^ABMDBILL(DUZ(2),"B",L)) Q:+L'=+$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U)!(L="") D
.N I
.S I=$O(^ABMDBILL(DUZ(2),"B",L,0)) ;IEN
.Q:$P(^ABMDBILL(DUZ(2),I,0),"^",4)="X" ;Quit if cancelled
.N K
.S K=$P(^ABMDBILL(DUZ(2),I,0),"^",8) ;Active insurer IEN
.;I $P($G(^ABMNINS(ABMP("LDFN"),K,0)),U,11)="Y"&($P($G(^AUTNINS(ABMP("INS"),2)),U)="R") S (ABMP("PAYED"),ABMP("PAYED",K))=$P(ABMB2,U) Q ;abm*2.6*3 HEAT7574
.I $P($G(^ABMNINS(ABMP("LDFN"),K,0)),U,11)="Y"&($P($G(^AUTNINS(ABMP("INS"),2)),U)="R") S (ABMP("PAYED"),ABMP("PAYED",K))=0 Q ;abm*2.6*10 COB billing
.N J
.S J=0
.F S J=$O(^ABMDBILL(DUZ(2),I,3,J)) Q:'J D
..N ABMPAY,ABMPDT,ABMZERO
..S ABMZERO=^ABMDBILL(DUZ(2),I,3,J,0)
..S ABMPDT=$P(ABMZERO,U) ;Payment date
..S ABMPAY=$P(ABMZERO,"^",2) ;Amt paid
..S ABMP("PAYED",K)=+$G(ABMP("PAYED",K))+ABMPAY ;Add amt paid per insurer
..S ABMP("PDT",K)=ABMPDT
..S ABMP("PAYED")=+$G(ABMP("PAYED"))+ABMPAY ;Add amt paid
Q
;
TCR(X) ; EP Total credits for bill
S ABM("TCREDITS")=0
S I=0
F S I=$O(^ABMDBILL(DUZ(2),X,3,I)) Q:'I D
.F J=2,3,4 S ABM("TCREDITS")=ABM("TCREDITS")+$P(^ABMDBILL(DUZ(2),X,3,I,0),"^",J)
S X=ABM("TCREDITS")
K ABM("TCREDITS")
Q X
;
UPC(X) ; EP Upper case
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q X
;
LWC(X) ; EP lower case
S X=$TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
Q X
;
SLN(X,Y) ; EP Provider state license number
;INPUT: X = PROVIDER
; Y = STATE
;OUTPUT: X = Provider state license number
; (If no number, grab the first one)
I '$G(Y) S Y=$P(^AUTTLOC(DUZ(2),0),"^",23) ;State IEN
I 'Y S Y=$P(^AUTTLOC(DUZ(2),0),"^",14) ;Mail address - State IEN
I 'Y S Y=999
N I
S I=$O(^VA(200,X,"PS1","B",Y,0))
I 'I S I=$O(^VA(200,X,"PS1",0))
I 'I S X="" Q X
S Y=$P(^VA(200,X,"PS1",I,0),U) ;Licensing state IEN
S X=$P(^VA(200,X,"PS1",I,0),"^",2) ;License#
S X=$P(^DIC(5,Y,0),"^",2)_"-"_X ;State - License
Q X
;
MCDBFX(X,Y) ;EP Fix BILL Insurance Multiple if broken pointer medicaid
; INPUT: X = IEN (CLAIM OR BILL)
; Y = INSURER IEN UNDER FIELD #13 (INS MULTIPLE)
;OUTPUT:
N ABMP
S ABMP("D0")=X
S ABMP("D1")=Y
S ABMP("ZERO")=^ABMDBILL(DUZ(2),ABMP("D0"),13,ABMP("D1"),0)
S ABMP("PDFN")=$P(^ABMDBILL(DUZ(2),ABMP("D0"),0),"^",5)
S ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("D0"),7),U)
D MGET
I $G(ABMP(1)) S $P(^ABMDBILL(DUZ(2),ABMP("D0"),13,ABMP("D1"),0),"^",6)=ABMP(1),$P(^(0),"^",7)=ABMP(2)
Q
;
MCDCFX(X,Y) ;EP Fix CLAIM Insurance Multiple if broken pointer, Medicaid
; INPUT: X = IEN (CLAIM OR BILL)
; Y = INSURER IEN UNDER FIELD #13 (INS MULTIPLE)
;OUTPUT:
N ABMP
S ABMP("D0")=X
S ABMP("D1")=Y
S ABMP("ZERO")=^ABMDCLM(DUZ(2),ABMP("D0"),13,ABMP("D1"),0)
S ABMP("PDFN")=$P(^ABMDCLM(DUZ(2),ABMP("D0"),0),U)
S ABMP("VDT")=$P(^ABMDCLM(DUZ(2),ABMP("D0"),0),"^",2)
D MGET
I $G(ABMP(1)) S $P(^ABMDCLM(DUZ(2),ABMP("D0"),13,ABMP("D1"),0),"^",6)=ABMP(1),$P(^(0),"^",7)=ABMP(2)
Q
;
MGET ; EP Get new pointer
S ABMP("INSCO")=$P(ABMP("ZERO"),U)
S ABMP("PTR")=$P(ABMP("ZERO"),"^",6)
Q:ABMP("PTR")=""
Q:$D(^AUPNMCD(ABMP("PTR"),0))
Q:$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INSCO"),".211","I"),1,"I")'="D" ;abm*2.6*10 HEAT73780
D 4^ABMDLCK2
S ABMP("PRI")=$O(ABML(0)) Q:'ABMP("PRI")
S ABMP("INS")=$O(ABML(ABMP("PRI"),0)) Q:'ABMP("INS")
Q:ABMP("INS")'=ABMP("INSCO")
N I
F I=1,2 S ABMP(I)=$P(ABML(ABMP("PRI"),ABMP("INS")),"^",I)
Q
;
S90 ;EP add 1 to record type counts
N I
S I=ABME("RTYPE")\10
S I=I*10
S I=I+30
S ABMRT(90,40)=+$G(ABMRT(90,40))+1
S ABMRT(90,I)=+$G(ABMRT(90,I))+1
S ABMRT(90,"RTOT")=+$G(ABMRT(90,"RTOT"))+1
Q
POS(X) ;EP place of service
;start old abm*2.6*10 HEAT53137
;S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",3,37,3,ABMP("VTYP")))
;I X="" S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",3,37,3,0))
;I X="" S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,37,3,ABMP("VTYP")))
;I X="" S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,37,3,0))
;end old start new HEAT53137
S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",3,37,3,ABMP("VTYP")))
I X="" S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",3,37,3,0))
I X="" S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",14,37,3,ABMP("VTYP")))
I X="" S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",14,37,3,0))
;end new HEAT53137
I X="" S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,37,3,ABMP("VTYP"))) ;abm*2.6*21 IHS/SD/SDR HEAT115124
I X="" S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,37,3,0)) ;abm*2.6*21 IHS/SD/SDR HEAT115124
;start new abm*2.6*21 IHS/SD/SDR HEAT284071
I +$G(ABMP("EXP"))=33 D ;ADA override
.S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",34,42,1,ABMP("VTYP")))
.I X="" S X=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",34,42,1,0))
;end new abm*2.6*21 IHS/SD/SDR HEAT284071
I X'="" Q X
S X=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),"^",6)
S:X="" X=$P($G(^ABMDPARM(DUZ(2),1,3)),"^",6)
S:X X=$P(^ABMDCODE(X,0),U)
I X=22,$E($G(ABMP("BTYP")),2)=1 S X=21
I X=21,$E($G(ABMP("BTYP")),2)>2 S X=22
I $G(ABMP("VTYP"))=831 S X=24 ;ASC
I $G(ABMP("CLIN"))=30 S X=23
I $G(ABMP("CLIN"))=11 S X=12
Q X
TOS(X) ;EP type of service (where x=multiple from 3P Bill File)
S Y="01"
S:X=21 Y="02"
S:X=23 Y=99
S:X=35 Y="04"
S:X=37 Y="05"
S:X=39 Y="07"
Q Y
SOP1(X) ;EP source of pay (x=ien insurer file)
;S ABMTYP=$P($G(^AUTNINS(+X,2)),U) ;abm*2.6*10 HEAT73780
S ABMTYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+X,".211","I"),1,"I") ;abm*2.6*10 HEAT73780
S Y=ABMTYP
I Y'="" D
.S Y=$F("HMDRPWCFNIK",ABMTYP)
.S Y=$E(" IZDCFBHZAZD",Y)
.I ABMTYP="P",$$BCBS1(X) S Y="G"
K ABMTYP
Q Y
BCBS1(X) ;EP check if blue cross/blue shield
S Y=0
S ABMNM=$P($G(^AUTNINS(+X,0)),U)
I ABMNM="" K ABMNM Q Y
N I
F I="B","C","S" D Q:'ABMLC
.S ABMLC=$F(ABMNM,I,$G(ABMLC))
I ABMLC S Y=1
K ABMNM,ABMLC
Q Y
NSN(X) ; EP next submission number
I $G(^ABMDTXST(0))<100000 S ^(0)=100000
L +^ABMDTXST(0):30 I '$T S X="" Q X
S X=^ABMDTXST(0)+1
S ^ABMDTXST(0)=X
L -^ABMDTXST(0)
Q X
TCN(X) ;EP Transmission Control Number
I $G(X)="" Q X
I '$D(^ABMDTXST(DUZ(2),X,0)) S X="" Q X
S DA=X
;start old abm*2.6*3 5PMS10005#2
;I $P($G(^ABMDTXST(DUZ(2),DA,1)),"^",6)="" D
;.S DIE="^ABMDTXST(DUZ(2),"
;.S DR=".16///"_$$NSN()
;.D ^DIE
;Q $P(^ABMDTXST(DUZ(2),DA,1),"^",6)
;end old start new 5PMS10005#2
I $G(ABMXMTDT)="" S X="" Q X
I +$O(^ABMDTXST(DUZ(2),X,3,"B",ABMXMTDT,0))=0 D
.S ABMP("XMIT")=X
.D GCNMULT("O","")
Q $P($G(^ABMDTXST(DUZ(2),X,3,$O(^ABMDTXST(DUZ(2),X,3,"B",ABMXMTDT,0)),0)),U,2)
;end new 5PMS10005#2
;
;start new abm*2.6*3 5PM10005#2
GCNMULT(ABMSTAT,ABMREASN) ;
N DIC,DIE,DA,DR,X,Y
;S ABMGCN=$$NSN() ;abm*2.6*6 5010
I +$G(ABMGCN)=0 S ABMGCN=$$NSN() ;abm*2.6*6 5010
S DA(1)=ABMP("XMIT")
S DIC="^ABMDTXST(DUZ(2),"_DA(1)_",3,"
S DIC("P")=$P(^DD(9002274.6,3,0),U,2)
S DIC(0)="L"
D NOW^%DTC
S (X,ABMXMTDT)=%
S DIC("DR")=".02////"_ABMGCN
S DIC("DR")=DIC("DR")_";.03////"_ABMSTAT
S DIC("DR")=DIC("DR")_";.04////"_DUZ
I +$G(ABM("CHIEN"))'=0 S DIC("DR")=DIC("DR")_";.07////"_+$G(ABM("CHIEN")) ;abm*2.6*6 5010
D ^DIC
Q:(+Y<0)
I $G(ABMREASN) D
.W !
.K DIC,DIE,DA,DR,X
.S DA(1)=ABMP("XMIT")
.S DA=+Y
.K Y
.S DIE="^ABMDTXST(DUZ(2),"_DA(1)_",3,"
.S DR=".05Reason for Recreate\Resend//"
.S DIE("NO^")=""
.D ^DIE
Q
;end new abm*2.6*3 5PMS10005#2
ABMERUTL ; IHS/ASDST/DMJ - EMC UTILITIES ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**3,6,9,10,19,21**;NOV 12, 2009;Build 379
+2 ;Original;DMJ;09/21/95 12:47 PM
+3 ;IHS/SD/SDR 2.5*8 IM14799 EA0 field 15 (pos 54) not populating correctly; Modified BCBS
+4 ; line tag to kill possible pre-existing value of ABME("LOC")
+5 ;IHS/SD/SDR-2.5*9 IM16962 Allow Receiver ID to be longer than 5 chars
+6 ;IHS/SD/SDR-2.5*10 IM20225/IM20271 Set replacement insurer correctly
+7 ;IHS/SD/SDR-2.6*3 HEAT7574 tribal self-insured changes
+8 ;IHS/SD/SDR-2.6*6 5010-made changes for multi-insurer GCNs
+9 ;IHS/SD/SDR-2.6*19 HEAT116949 Translated out spaces for CROSSOVER visit type check
+10 ;IHS/SD/SDR 2.6*21 HEAT115124 Added code to POS to check export mode 27 for overrides
+11 ;IHS/SD/SDR 2.6*21 HEAT284071 Added code to POS for ADA (34) overrides
+12 ;
FMT(X,Y) ; EP
+1 ;Format Variable
+2 ; INPUT: X = DATA STRING
+3 ; Y = FORMAT INSTRUCTONS
+4 ;OUTPUT: X = FORMATTED DATA
+5 ;
+6 ;No formatting
IF $GET(ABMP("NOFMT"))
QUIT X
+7 ;130 spaces
SET $PIECE(ABMP("SPACES")," ",130)=""
+8 ;60 zeroes
SET $PIECE(ABMP("ZEROS"),"0",60)=""
+9 IF Y["J"
Begin DoDot:1
+10 NEW I
SET I=$PIECE(Y,"J",2)
+11 SET I=$EXTRACT(I)
+12 SET X=$TRANSLATE($JUSTIFY(X,1,I),".")
End DoDot:1
+13 IF Y["S"
Begin DoDot:1
+14 SET X=$TRANSLATE(X,"-\/!@#$%&*.,")
End DoDot:1
+15 SET ABME("FILLER")=$SELECT(Y["N":ABMP("ZEROS"),1:ABMP("SPACES"))
+16 SET X=$SELECT(Y["R":ABME("FILLER")_X,1:X_ABME("FILLER"))
+17 SET X=$SELECT(Y["R":$EXTRACT(X,$LENGTH(X)+1-+Y,$LENGTH(X)),1:$EXTRACT(X,1,+Y))
+18 QUIT X
+19 ;
STRIP(X) ;EP strip trailing blanks
+1 NEW I
FOR I=$LENGTH(X):-1:1
Begin DoDot:1
+2 IF $EXTRACT(X,I)=" "
QUIT
+3 SET ABMLN=I
End DoDot:1
IF $GET(ABMLN)
QUIT
+4 SET X=$EXTRACT(X,1,ABMLN)
+5 KILL ABMLN
+6 QUIT X
STRPL(X) ;EP strip leading blanks
+1 NEW I
+2 SET ABMLEN=$LENGTH(X," ")
+3 FOR I=1:1:ABMLEN
Begin DoDot:1
+4 IF $PIECE(X," ",I)'=""
QUIT
End DoDot:1
IF $PIECE(X," ",I)'=""
QUIT
+5 SET X=$PIECE(X," ",I,ABMLEN)
+6 KILL ABMLEN
+7 QUIT X
DFMT ; EP Format Date Field
+1 SET Y=$EXTRACT(Y,4,5)_$EXTRACT(Y,6,7)_$EXTRACT(Y,2,3)
+2 QUIT
+3 ;
SET ; EP Set up some things
+1 ;Quit if already set up these vars
IF $GET(ABMP("SET"))
QUIT
+2 KILL ABMP("INS")
+3 NEW I
+4 FOR I=0:1:9
Begin DoDot:1
+5 SET @("ABMB"_I)=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),I))
End DoDot:1
+6 ;Patient IEN
SET ABMP("PDFN")=$PIECE(ABMB0,"^",5)
+7 ;Visit loc IEN
SET ABMP("LDFN")=$PIECE(ABMB0,"^",3)
+8 ;Bill type
SET ABMP("BTYP")=$PIECE(ABMB0,"^",2)
+9 ;Export mode IEN
SET ABMP("EXP")=$PIECE(ABMB0,"^",6)
+10 ;Active Ins IEN
SET ABMP("INS")=$PIECE(ABMB0,"^",8)
+11 ;Vtyp IEN
SET ABMP("VTYP")=$PIECE(ABMB0,"^",7)
+12 ;Clinic
SET ABMP("CLIN")=$PIECE(ABMB0,"^",10)
+13 SET ABMP("CLIN")=$PIECE($GET(^DIC(40.7,+ABMP("CLIN"),0)),"^",2)
+14 ;Service date from
SET ABMP("VDT")=$PIECE(ABMB7,U)
+15 ;S ABMP("ITYPE")=$P($G(^AUTNINS(+ABMP("INS"),2)),U) ;abm*2.6*10 HEAT73780
+16 ;Type of insurer ;abm*2.6*10 HEAT73780
SET ABMP("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")
+17 ;set up insurers
DO ISET
+18 DO PCN
+19 DO SOP
+20 ;set variable set flag
SET ABMP("SET")=1
+21 QUIT
+22 ;
ISET ; EP
+1 ;Set up Insurers
+2 ;ABMP("INS",priority) = Insurer IEN ^ type of insurer ^ Insurer multiple IEN
+3 KILL ABMCDNUM
+4 SET ABME("PRIO")=0
+5 SET ABME("INS#")=0
+6 ;Loop down priority
+7 FOR
SET ABME("PRIO")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABME("PRIO")))
IF 'ABME("PRIO")!($GET(ABMP("INS",3)))
QUIT
Begin DoDot:1
+8 NEW I
+9 SET I=0
+10 ;Loop entries
+11 FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABME("PRIO"),I))
IF 'I!($GET(ABMP("INS",3)))
QUIT
Begin DoDot:2
+12 ;Quit if insurer unbillable
+13 IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U,3)="U"
QUIT
+14 ;Insurer IEN
SET ABME("INS")=$SELECT($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U,11)'="":$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U,11),1:$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),U))
+15 ;S ABME("ITYPE")=$P(^AUTNINS(ABME("INS"),2),U) ;abm*2.6*10 HEAT73780
+16 ;type of insurer ;abm*2.6*10 HEAT73780
SET ABME("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABME("INS"),".211","I"),1,"I")
+17 ;Quit if indian patient
IF "I"[ABME("ITYPE")
QUIT
+18 ;Quit if non-ben and not active insurer
+19 IF "N"[ABME("ITYPE")&($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U,8)'=ABME("INS"))
QUIT
+20 ;increment counter
SET ABME("INS#")=ABME("INS#")+1
+21 SET ABMP("INS",ABME("INS#"))=ABME("INS")_"^"_ABME("ITYPE")_"^"_I
+22 IF ABME("ITYPE")="D"!(ABME("ITYPE")="K")
Begin DoDot:3
+23 SET ABMCDNUM=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),"^",6)
+24 IF '$GET(ABMP("PDFN"))
SET ABMP("PDFN")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",5)
+25 IF $PIECE($GET(^AUPNMCD(+ABMCDNUM,0)),U)=ABMP("PDFN")
QUIT
+26 DO DBFX^ABMDEFIP(ABMP("BDFN"),I)
+27 SET ABMCDNUM=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),"^",6)
End DoDot:3
End DoDot:2
End DoDot:1
+28 IF +$GET(ABMP("INS"))'=0
IF ($$RCID^ABMUTLP(ABMP("INS"))["61044")
Begin DoDot:1
+29 ;61044 is primary
IF $PIECE($GET(ABMP("INS",1)),U)=ABMP("INS")
QUIT
+30 ;Medicare isn't primary
IF $PIECE($GET(^AUTNINS($PIECE($GET(ABMP("INS",1)),U),0)),U)'["MEDICARE"
QUIT
+31 ;Medi-Cal is not secondary
IF $$RCID^ABMUTLP($PIECE($GET(ABMP("INS",2)),U))'["61044"
QUIT
+32 ;Q:$P($G(^ABMDVTYP(ABMP("VTYP"),0)),U)'["CROSSOVER" ;vtyp must contain CROSSOVER ;abm*2.6*19 HEAT116949
+33 ;vtyp must contain CROSSOVER ;abm*2.6*19 HEAT116949
IF $TRANSLATE($PIECE($GET(^ABMDVTYP(ABMP("VTYP"),0)),U)," ")'["CROSSOVER"
QUIT
+34 ;move Medi-Cal to primary spot
SET ABMP("INS",1)=ABMP("INS",2)
+35 ;remove Medi-Cal from secondary
KILL ABMP("INS",2)
End DoDot:1
+36 QUIT
PCN ;EP Patient Control Number
+1 IF '$GET(ABMDUZ2)
SET ABMDUZ2=DUZ(2)
+2 SET ABMP("PCN")=$PIECE(^ABMDBILL(ABMDUZ2,ABMP("BDFN"),0),U)
+3 SET ABMSFX=$PIECE($GET(^ABMDPARM(+ABMP("LDFN"),1,2)),"^",4)
+4 IF ABMSFX'=""
Begin DoDot:1
+5 SET ABMP("PCN")=ABMP("PCN")_"-"_ABMSFX
End DoDot:1
+6 IF $PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,3)
Begin DoDot:1
+7 SET ABMP("HRN")=$PIECE($GET(^AUPNPAT(+ABMP("PDFN"),41,+ABMP("LDFN"),0)),"^",2)
+8 IF ABMP("HRN")=""
SET ABMP("HRN")=$PIECE($GET(^AUPNPAT(+ABMP("PDFN"),41,DUZ(2),0)),"^",2)
+9 IF ABMP("HRN")=""
QUIT
+10 SET ABMP("PCN")=ABMP("PCN")_"-"_ABMP("HRN")
End DoDot:1
+11 KILL ABMSFX
+12 QUIT
SOP ;EP Source of Pay
+1 NEW X
+2 SET X=$FIND("HMDRPWCFNIK",ABMP("ITYPE"))
+3 SET ABMP("SOP")=$EXTRACT(" IZDCFBHZAZD",X)
+4 IF ABMP("ITYPE")="P"
DO BCBS
IF $GET(ABMP("BCBS"))
SET ABMP("SOP")="G"
+5 QUIT
BCBS ; EP check if Blue Cross/Blue Shield
+1 KILL ABME("LOC")
+2 KILL ABMP("BCBS")
+3 SET ABMP("INAME")=$PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)
+4 NEW I
+5 FOR I="B","C","S"
Begin DoDot:1
+6 SET ABME("LOC")=$FIND(ABMP("INAME"),I,$GET(ABME("LOC")))
End DoDot:1
IF 'ABME("LOC")
QUIT
+7 IF 'ABME("LOC")
QUIT
+8 SET ABMP("BCBS")=1
+9 QUIT
RCID(X) ;EP Receiver ID (X=Insurer IEN)
+1 SET Y=$PIECE($GET(^AUTNINS(X,0)),"^",8)
+2 IF +Y=400
Begin DoDot:1
+3 SET Y="00400"
+4 IF $GET(ABMP("VTYP"))=999!($GET(ABMP("BTYP"))=831&($GET(ABMP("EXP"))=22))
SET Y="00900"
+5 IF $GET(ABMP("EXP"))>20
SET Y="C"_Y
End DoDot:1
QUIT Y
+6 ;start old abm*2.6*10 HEAT74059
+7 ;I Y=4001 D Q Y
+8 ;.S Y="04001"
+9 ;.;I $G(ABMP("VTYP"))=999!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=22)) S Y="04402" ;ASC ;abm*2.6*9 IHS/SD/AML 3/9/2012
+10 ;.I $G(ABMP("VTYP"))=999!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=22))!($G(ABMP("BTYP"))=831&($G(ABMP("EXP"))=32)) S Y="04402" ;abm*2.6*9 IHS/SD/AML 3/9/2012 Mods for DSU
+11 ;.I $G(ABMP("CLIN"))="A3" S Y="04402" ;abm*2.6*10 IHS/SD/AML HEAT68447
+12 ;end old start new HEAT74059
+13 IF "^4001^4311^4211^4111^4411^"[("^"_Y_"^")
Begin DoDot:1
+14 SET Y="0"_Y
+15 IF $GET(ABMP("VTYP"))=999!($GET(ABMP("BTYP"))=831&($GET(ABMP("EXP"))=22))!($GET(ABMP("BTYP"))=831&($GET(ABMP("EXP"))=32))!($GET(ABMP("CLIN"))="A3"!($GET(ABMP("CLN"))="A3"))
Begin DoDot:2
+16 IF Y="04001"
SET Y="04402"
+17 IF Y="04311"
SET Y="04312"
+18 IF Y="04211"
SET Y="04212"
+19 IF Y="04111"
SET Y="04112"
+20 IF Y="04411"
SET Y=$SELECT((DT<3121119):"04402",1:"04412")
End DoDot:2
End DoDot:1
QUIT Y
+21 ;end new HEAT74059
+22 QUIT Y
ENVY(X,Y) ;EP Envoy Payer ID (X=Insurer EIN,Y=Visit Type)
+1 NEW ABM,I,Z
+2 SET Z=""
+3 FOR I=1:1:3
SET ABM(I)=$PIECE($GET(^AUTNINS(+X,5)),"^",I)
+4 IF Y=111
SET Z=ABM(2)
+5 IF Y="H"
SET Z=ABM(2)
+6 IF Y=998
SET Z=ABM(3)
+7 IF Y="D"
SET Z=ABM(3)
+8 IF Y=999
SET Z=ABM(1)
+9 IF Y="M"
SET Z=ABM(1)
+10 IF Y=131
SET Z=ABM(1)
+11 IF Z=""
SET Z=ABM(1)
+12 SET Z=$PIECE($GET(^ABMENVOY(+$GET(Z),0)),U)
+13 QUIT Z
MSG(X) ; EP
+1 ;Display message to terminal
+2 IF $GET(ABMQUIET)
QUIT
+3 WRITE !!,*7,X,!
+4 FOR
WRITE !
IF $Y+3>IOSL
QUIT
+5 SET DIR(0)="E"
+6 DO ^DIR
+7 KILL DIR
+8 QUIT
+9 ;
PAYED ; EP
+1 ;Build Insurance Payment Array
+2 KILL ABMP("PAYED")
+3 NEW L
+4 ;Bill number
SET L=+$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U)_" "
+5 FOR
SET L=$ORDER(^ABMDBILL(DUZ(2),"B",L))
IF +L'=+$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U)!(L="")
QUIT
Begin DoDot:1
+6 NEW I
+7 ;IEN
SET I=$ORDER(^ABMDBILL(DUZ(2),"B",L,0))
+8 ;Quit if cancelled
IF $PIECE(^ABMDBILL(DUZ(2),I,0),"^",4)="X"
QUIT
+9 NEW K
+10 ;Active insurer IEN
SET K=$PIECE(^ABMDBILL(DUZ(2),I,0),"^",8)
+11 ;I $P($G(^ABMNINS(ABMP("LDFN"),K,0)),U,11)="Y"&($P($G(^AUTNINS(ABMP("INS"),2)),U)="R") S (ABMP("PAYED"),ABMP("PAYED",K))=$P(ABMB2,U) Q ;abm*2.6*3 HEAT7574
+12 ;abm*2.6*10 COB billing
IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),K,0)),U,11)="Y"&($PIECE($GET(^AUTNINS(ABMP("INS"),2)),U)="R")
SET (ABMP("PAYED"),ABMP("PAYED",K))=0
QUIT
+13 NEW J
+14 SET J=0
+15 FOR
SET J=$ORDER(^ABMDBILL(DUZ(2),I,3,J))
IF 'J
QUIT
Begin DoDot:2
+16 NEW ABMPAY,ABMPDT,ABMZERO
+17 SET ABMZERO=^ABMDBILL(DUZ(2),I,3,J,0)
+18 ;Payment date
SET ABMPDT=$PIECE(ABMZERO,U)
+19 ;Amt paid
SET ABMPAY=$PIECE(ABMZERO,"^",2)
+20 ;Add amt paid per insurer
SET ABMP("PAYED",K)=+$GET(ABMP("PAYED",K))+ABMPAY
+21 SET ABMP("PDT",K)=ABMPDT
+22 ;Add amt paid
SET ABMP("PAYED")=+$GET(ABMP("PAYED"))+ABMPAY
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
TCR(X) ; EP Total credits for bill
+1 SET ABM("TCREDITS")=0
+2 SET I=0
+3 FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),X,3,I))
IF 'I
QUIT
Begin DoDot:1
+4 FOR J=2,3,4
SET ABM("TCREDITS")=ABM("TCREDITS")+$PIECE(^ABMDBILL(DUZ(2),X,3,I,0),"^",J)
End DoDot:1
+5 SET X=ABM("TCREDITS")
+6 KILL ABM("TCREDITS")
+7 QUIT X
+8 ;
UPC(X) ; EP Upper case
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT X
+3 ;
LWC(X) ; EP lower case
+1 SET X=$TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+2 QUIT X
+3 ;
SLN(X,Y) ; EP Provider state license number
+1 ;INPUT: X = PROVIDER
+2 ; Y = STATE
+3 ;OUTPUT: X = Provider state license number
+4 ; (If no number, grab the first one)
+5 ;State IEN
IF '$GET(Y)
SET Y=$PIECE(^AUTTLOC(DUZ(2),0),"^",23)
+6 ;Mail address - State IEN
IF 'Y
SET Y=$PIECE(^AUTTLOC(DUZ(2),0),"^",14)
+7 IF 'Y
SET Y=999
+8 NEW I
+9 SET I=$ORDER(^VA(200,X,"PS1","B",Y,0))
+10 IF 'I
SET I=$ORDER(^VA(200,X,"PS1",0))
+11 IF 'I
SET X=""
QUIT X
+12 ;Licensing state IEN
SET Y=$PIECE(^VA(200,X,"PS1",I,0),U)
+13 ;License#
SET X=$PIECE(^VA(200,X,"PS1",I,0),"^",2)
+14 ;State - License
SET X=$PIECE(^DIC(5,Y,0),"^",2)_"-"_X
+15 QUIT X
+16 ;
MCDBFX(X,Y) ;EP Fix BILL Insurance Multiple if broken pointer medicaid
+1 ; INPUT: X = IEN (CLAIM OR BILL)
+2 ; Y = INSURER IEN UNDER FIELD #13 (INS MULTIPLE)
+3 ;OUTPUT:
+4 NEW ABMP
+5 SET ABMP("D0")=X
+6 SET ABMP("D1")=Y
+7 SET ABMP("ZERO")=^ABMDBILL(DUZ(2),ABMP("D0"),13,ABMP("D1"),0)
+8 SET ABMP("PDFN")=$PIECE(^ABMDBILL(DUZ(2),ABMP("D0"),0),"^",5)
+9 SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("D0"),7),U)
+10 DO MGET
+11 IF $GET(ABMP(1))
SET $PIECE(^ABMDBILL(DUZ(2),ABMP("D0"),13,ABMP("D1"),0),"^",6)=ABMP(1)
SET $PIECE(^(0),"^",7)=ABMP(2)
+12 QUIT
+13 ;
MCDCFX(X,Y) ;EP Fix CLAIM Insurance Multiple if broken pointer, Medicaid
+1 ; INPUT: X = IEN (CLAIM OR BILL)
+2 ; Y = INSURER IEN UNDER FIELD #13 (INS MULTIPLE)
+3 ;OUTPUT:
+4 NEW ABMP
+5 SET ABMP("D0")=X
+6 SET ABMP("D1")=Y
+7 SET ABMP("ZERO")=^ABMDCLM(DUZ(2),ABMP("D0"),13,ABMP("D1"),0)
+8 SET ABMP("PDFN")=$PIECE(^ABMDCLM(DUZ(2),ABMP("D0"),0),U)
+9 SET ABMP("VDT")=$PIECE(^ABMDCLM(DUZ(2),ABMP("D0"),0),"^",2)
+10 DO MGET
+11 IF $GET(ABMP(1))
SET $PIECE(^ABMDCLM(DUZ(2),ABMP("D0"),13,ABMP("D1"),0),"^",6)=ABMP(1)
SET $PIECE(^(0),"^",7)=ABMP(2)
+12 QUIT
+13 ;
MGET ; EP Get new pointer
+1 SET ABMP("INSCO")=$PIECE(ABMP("ZERO"),U)
+2 SET ABMP("PTR")=$PIECE(ABMP("ZERO"),"^",6)
+3 IF ABMP("PTR")=""
QUIT
+4 IF $DATA(^AUPNMCD(ABMP("PTR"),0))
QUIT
+5 ;abm*2.6*10 HEAT73780
IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INSCO"),".211","I"),1,"I")'="D"
QUIT
+6 DO 4^ABMDLCK2
+7 SET ABMP("PRI")=$ORDER(ABML(0))
IF 'ABMP("PRI")
QUIT
+8 SET ABMP("INS")=$ORDER(ABML(ABMP("PRI"),0))
IF 'ABMP("INS")
QUIT
+9 IF ABMP("INS")'=ABMP("INSCO")
QUIT
+10 NEW I
+11 FOR I=1,2
SET ABMP(I)=$PIECE(ABML(ABMP("PRI"),ABMP("INS")),"^",I)
+12 QUIT
+13 ;
S90 ;EP add 1 to record type counts
+1 NEW I
+2 SET I=ABME("RTYPE")\10
+3 SET I=I*10
+4 SET I=I+30
+5 SET ABMRT(90,40)=+$GET(ABMRT(90,40))+1
+6 SET ABMRT(90,I)=+$GET(ABMRT(90,I))+1
+7 SET ABMRT(90,"RTOT")=+$GET(ABMRT(90,"RTOT"))+1
+8 QUIT
POS(X) ;EP place of service
+1 ;start old abm*2.6*10 HEAT53137
+2 ;S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",3,37,3,ABMP("VTYP")))
+3 ;I X="" S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",3,37,3,0))
+4 ;I X="" S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,37,3,ABMP("VTYP")))
+5 ;I X="" S X=$G(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,37,3,0))
+6 ;end old start new HEAT53137
+7 SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",3,37,3,ABMP("VTYP")))
+8 IF X=""
SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",3,37,3,0))
+9 IF X=""
SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",14,37,3,ABMP("VTYP")))
+10 IF X=""
SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",14,37,3,0))
+11 ;end new HEAT53137
+12 ;abm*2.6*21 IHS/SD/SDR HEAT115124
IF X=""
SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,37,3,ABMP("VTYP")))
+13 ;abm*2.6*21 IHS/SD/SDR HEAT115124
IF X=""
SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",27,37,3,0))
+14 ;start new abm*2.6*21 IHS/SD/SDR HEAT284071
+15 ;ADA override
IF +$GET(ABMP("EXP"))=33
Begin DoDot:1
+16 SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",34,42,1,ABMP("VTYP")))
+17 IF X=""
SET X=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",34,42,1,0))
End DoDot:1
+18 ;end new abm*2.6*21 IHS/SD/SDR HEAT284071
+19 IF X'=""
QUIT X
+20 SET X=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),"^",6)
+21 IF X=""
SET X=$PIECE($GET(^ABMDPARM(DUZ(2),1,3)),"^",6)
+22 IF X
SET X=$PIECE(^ABMDCODE(X,0),U)
+23 IF X=22
IF $EXTRACT($GET(ABMP("BTYP")),2)=1
SET X=21
+24 IF X=21
IF $EXTRACT($GET(ABMP("BTYP")),2)>2
SET X=22
+25 ;ASC
IF $GET(ABMP("VTYP"))=831
SET X=24
+26 IF $GET(ABMP("CLIN"))=30
SET X=23
+27 IF $GET(ABMP("CLIN"))=11
SET X=12
+28 QUIT X
TOS(X) ;EP type of service (where x=multiple from 3P Bill File)
+1 SET Y="01"
+2 IF X=21
SET Y="02"
+3 IF X=23
SET Y=99
+4 IF X=35
SET Y="04"
+5 IF X=37
SET Y="05"
+6 IF X=39
SET Y="07"
+7 QUIT Y
SOP1(X) ;EP source of pay (x=ien insurer file)
+1 ;S ABMTYP=$P($G(^AUTNINS(+X,2)),U) ;abm*2.6*10 HEAT73780
+2 ;abm*2.6*10 HEAT73780
SET ABMTYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+X,".211","I"),1,"I")
+3 SET Y=ABMTYP
+4 IF Y'=""
Begin DoDot:1
+5 SET Y=$FIND("HMDRPWCFNIK",ABMTYP)
+6 SET Y=$EXTRACT(" IZDCFBHZAZD",Y)
+7 IF ABMTYP="P"
IF $$BCBS1(X)
SET Y="G"
End DoDot:1
+8 KILL ABMTYP
+9 QUIT Y
BCBS1(X) ;EP check if blue cross/blue shield
+1 SET Y=0
+2 SET ABMNM=$PIECE($GET(^AUTNINS(+X,0)),U)
+3 IF ABMNM=""
KILL ABMNM
QUIT Y
+4 NEW I
+5 FOR I="B","C","S"
Begin DoDot:1
+6 SET ABMLC=$FIND(ABMNM,I,$GET(ABMLC))
End DoDot:1
IF 'ABMLC
QUIT
+7 IF ABMLC
SET Y=1
+8 KILL ABMNM,ABMLC
+9 QUIT Y
NSN(X) ; EP next submission number
+1 IF $GET(^ABMDTXST(0))<100000
SET ^(0)=100000
+2 LOCK +^ABMDTXST(0):30
IF '$TEST
SET X=""
QUIT X
+3 SET X=^ABMDTXST(0)+1
+4 SET ^ABMDTXST(0)=X
+5 LOCK -^ABMDTXST(0)
+6 QUIT X
TCN(X) ;EP Transmission Control Number
+1 IF $GET(X)=""
QUIT X
+2 IF '$DATA(^ABMDTXST(DUZ(2),X,0))
SET X=""
QUIT X
+3 SET DA=X
+4 ;start old abm*2.6*3 5PMS10005#2
+5 ;I $P($G(^ABMDTXST(DUZ(2),DA,1)),"^",6)="" D
+6 ;.S DIE="^ABMDTXST(DUZ(2),"
+7 ;.S DR=".16///"_$$NSN()
+8 ;.D ^DIE
+9 ;Q $P(^ABMDTXST(DUZ(2),DA,1),"^",6)
+10 ;end old start new 5PMS10005#2
+11 IF $GET(ABMXMTDT)=""
SET X=""
QUIT X
+12 IF +$ORDER(^ABMDTXST(DUZ(2),X,3,"B",ABMXMTDT,0))=0
Begin DoDot:1
+13 SET ABMP("XMIT")=X
+14 DO GCNMULT("O","")
End DoDot:1
+15 QUIT $PIECE($GET(^ABMDTXST(DUZ(2),X,3,$ORDER(^ABMDTXST(DUZ(2),X,3,"B",ABMXMTDT,0)),0)),U,2)
+16 ;end new 5PMS10005#2
+17 ;
+18 ;start new abm*2.6*3 5PM10005#2
GCNMULT(ABMSTAT,ABMREASN) ;
+1 NEW DIC,DIE,DA,DR,X,Y
+2 ;S ABMGCN=$$NSN() ;abm*2.6*6 5010
+3 ;abm*2.6*6 5010
IF +$GET(ABMGCN)=0
SET ABMGCN=$$NSN()
+4 SET DA(1)=ABMP("XMIT")
+5 SET DIC="^ABMDTXST(DUZ(2),"_DA(1)_",3,"
+6 SET DIC("P")=$PIECE(^DD(9002274.6,3,0),U,2)
+7 SET DIC(0)="L"
+8 DO NOW^%DTC
+9 SET (X,ABMXMTDT)=%
+10 SET DIC("DR")=".02////"_ABMGCN
+11 SET DIC("DR")=DIC("DR")_";.03////"_ABMSTAT
+12 SET DIC("DR")=DIC("DR")_";.04////"_DUZ
+13 ;abm*2.6*6 5010
IF +$GET(ABM("CHIEN"))'=0
SET DIC("DR")=DIC("DR")_";.07////"_+$GET(ABM("CHIEN"))
+14 DO ^DIC
+15 IF (+Y<0)
QUIT
+16 IF $GET(ABMREASN)
Begin DoDot:1
+17 WRITE !
+18 KILL DIC,DIE,DA,DR,X
+19 SET DA(1)=ABMP("XMIT")
+20 SET DA=+Y
+21 KILL Y
+22 SET DIE="^ABMDTXST(DUZ(2),"_DA(1)_",3,"
+23 SET DR=".05Reason for Recreate\Resend//"
+24 SET DIE("NO^")=""
+25 DO ^DIE
End DoDot:1
+26 QUIT
+27 ;end new abm*2.6*3 5PMS10005#2
