ABMERUTL.m

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")