ABMUTL8 ; IHS/ASDST/DMJ - 837 UTILITIES ;
;;2.6;IHS Third Party Billing;**1,4,6,8,9,10,11,13,14,16,18**;NOV 12, 2009;Build 289
;Original;DMJ;09/21/95 12:47 PM
;V2.5 P5-837 mod. Use HRN in following priority order-visit loc/parent/loop satellites
;v2.5 p5-put POS, TOS by line item
;v2.5 p6-Make OVER works correctly
;v2.5 p8-IM13324/IM15558-Format 0 to 0.00
;v2.5 p8-IM12628-Remove special delimiter for CA
;v2.5 p8-task 6-Check value cd before formatting; can be dollar amt or zip
;v2.5 p9-IM14702/IM17968-Correct HRN lookup for satellites
;v2.5 p9-IM17270-Changed "~" to "-" to avoid delimiter issues
;v2.5 p9-IM16962-If BCBS/OK add CR/LF to delimiter; they can't do streamed data
;
;IHS/SD/SDR-v2.6 CSV
;IHS/SD/SDR-2.6*1 -HEAT2836 -Remove Dxs when inpt Medicare/RR
;IHS/SD/SDR-2.6*6 -5010 -added code to pull anesthesia charges
;IHS/SD/SDR-2.6*13 -Added check for new export mode 35
;IHS/SD/SDR-2.6*14 -ICD10 002F Changes for 837 qualifier ICD9 vs ICD10
;IHS/SD/SDR-2.6*14 -Updated DX^ABMCVAPI calls to be numeric
;IHS/SD/SDR-2.6*14 -split routine to ABMUTL8A due to size
;IHS/SD/SDR-2.6*14 -CR4072 -made correction to ICD10 check to be '=30 instead of =1
;IHS/SD/SDR-2.6*16 -HEAT217211 -Made change so it won't do the E-code change in DXSET2 if ICD code is an ICD-10 code.
;IHS/SD/SDR-2.6*16 -HEAT231506 -Updated so 837D will print DX codes.
;IHS/SD/SDR-2.6*18 -HEAT239392 -Made changes so E-code will be included appropriately. Was being dropped from file.
;
HRN(X) ;PEP - HRN
; First look at Visit Loc for HRN
; If not then look at Parent Loc for HRN
; If not, loop Satellite Locs for said parent until one is found.
I $G(ABMP("LDFN")) S HRN=$P($G(^AUPNPAT(+X,41,ABMP("LDFN"),0)),"^",2)
;Q:HRN HRN ;abm*2.6*10 HEAT61426
Q:($G(HRN)'="") HRN ;abm*2.6*10 HEAT61426
S ABMPAR=""
F S ABMPAR=$O(^BAR(90052.05,ABMPAR)) Q:ABMPAR=""!$D(^BAR(90052.05,ABMPAR,ABMP("LDFN")))
S ABMPAR=$P($G(^BAR(90052.05,ABMPAR,ABMP("LDFN"),0)),"^",3)
I $G(ABMPAR)'="" S HRN=$P($G(^AUPNPAT(X,41,ABMPAR,0)),"^",2)
Q:HRN HRN
I $G(ABMPAR)'="" D
.S ABMSAT=0
.F S ABMSAT=$O(^BAR(90052.05,ABMPAR,ABMSAT)) Q:ABMSAT="" D Q:HRN
..S HRN=$P($G(^AUPNPAT(X,41,ABMSAT,0)),"^",2)
Q HRN
DXP(X) ;EP - Primary DX
;x=bill ien
D DXSET(X)
S ABMDXP=$G(ABMDX(1))
Q ABMDXP
DXA(X) ;EP - Admitting DX
;x=bill ien
N ABMBTYP S ABMBTYP=$P(^ABMDBILL(DUZ(2),X,0),U,2)
S ABMDXA=$P($G(^ABMDBILL(DUZ(2),X,5)),U,9)
I ABMDXA="" Q ABMDXA ;abm*2.6*4 HEAT19688
S ABMDXA=$P($$DX^ABMCVAPI(+ABMDXA,ABMP("VDT")),U,2) ;CSV-c
I ABMDXA="" Q ABMDXA
S ABMDXA=$TR(ABMDXA,".")
;S:$E(ABMBTYP,2)<3 ABMDXA="BJ:"_ABMDXA ;abm*2.6*14 ICD10 002F
S:$E(ABMBTYP,2)<3 ABMDXA=$S(+$P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1:"ABJ",1:"BJ")_":"_ABMDXA ;abm*2.6*14 ICD10 002F
S:$E(ABMBTYP,2)>2 ABMDXA="ZZ:"_ABMDXA
Q ABMDXA
DXE(X) ;EP - E-Code
;x=bill ien
S ABMDXE=$P($G(^ABMDBILL(DUZ(2),X,8)),U,12)
I ABMDXE="" Q ABMDXE
;S ABMDXE="BN:"_$TR($P($$DX^ABMCVAPI(ABMDXE,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API call
S ABMDXE="BN:"_$TR($P($$DX^ABMCVAPI(+ABMDXE,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API call
Q ABMDXE
DXSET(X) ;EP - set dx array
;x=bill ien
;I +$G(ABMP("EXP"))=31!(+$G(ABMP("EXP"))=32) D DXSET2(X) Q ;abm*2.6*8 5010 ;abm*2.6*16 HEAT231506
I +$G(ABMP("EXP"))=31!(+$G(ABMP("EXP"))=32)!(+$G(ABMP("EXP"))=33) D DXSET2(X) Q ;abm*2.6*8 5010 ;abm*2.6*16 HEAT231506
K ABMDX
N I,J
S ABMCNT=0
S I=0
F S I=$O(^ABMDBILL(DUZ(2),X,17,"C",I)) Q:'I D
.S J=0
.F S J=$O(^ABMDBILL(DUZ(2),X,17,"C",I,J)) Q:'J D
..S ABMCNT=ABMCNT+1
..S:ABMCNT=1 ABMDX(ABMCNT)="BK"
..S:ABMCNT'=1 ABMDX(ABMCNT)="BF"
..;S $P(ABMDX(ABMCNT),":",2)=$TR($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API
..S $P(ABMDX(ABMCNT),":",2)=$TR($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API
;I $P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'="" S ABMDX("ADM")=$TR($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".") ;abm*2.6*8 5010 ;abm*2.6*14 update API
I +$P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'=0 S ABMDX("ADM")=$TR($P($$DX^ABMCVAPI(+$P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".") ;abm*2.6*14 update API
Q
;start new abm*2.6*8 5010
DXSET2(X) ;EP - set dx array
;x=bill ien
K ABMDX
K ABMDXE ;abm*2.6*10 HEAT67774
N I,J
S ABMCNT=0
S I=0
F S I=$O(^ABMDBILL(DUZ(2),X,17,"C",I)) Q:'I D
.S J=0
.F S J=$O(^ABMDBILL(DUZ(2),X,17,"C",I,J)) Q:'J D
..;Q:$E($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),1)="E" ;skip E-codes ;abm*2.6*14 ICD10 002F
..;I $E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)="E"&($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,20)'=30) Q ;skip E-codes ;abm*2.6*14 ICD10 002F and update API; CR4072 ;abm*2.6*18 HEAT239392
..;for next line skip E-codes ;abm*2.6*14 ICD10 002F; Update API; CR4072 ;abm*2.6*18 HEAT239392
..;I (+$P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'=0)&(+$P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,20)<30) Q ;skip admit DX if ICD9 Ecode ;removed line abm*2.6*18 HEAT239392
..;I ($E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)="E")&($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)<30) Q ;skip DX if ICD9 Ecode ;removed abm*2.6*18 HEAT239392
..;skip admit DX if ICD10 accident cd
..;abm*2.6*18 HEAT239392 removed next 2 lines in a2. ICD shouldn't be skipped here.
..;I (+$P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,20)=30)&("^V^W^X^Y^"[("^"_$E($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),1)_"^")) Q ;abm*2.6*18 HEAT239392
..;I (+$P($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)=30)&("^V^W^X^Y^"[("^"_$E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)_"^")) Q ;skip DX if ICD10 accident code ;abm*2.6*18 HEAT239392
..S ABMCNT=ABMCNT+1
..;S:ABMCNT=1 ABMDX(ABMCNT)="BK" ;abm*2.6*14 ICD10 002F
..S:ABMCNT=1 ABMDX(ABMCNT)=$S(+$P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1:"ABK",1:"BK") ;abm*2.6*14 ICD10 002F
..;S:ABMCNT'=1 ABMDX(ABMCNT)="BF" ;abm*2.6*14 ICD10 OO2F
..S:ABMCNT'=1 ABMDX(ABMCNT)=$S(+$P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1:"ABF",1:"BF") ;abm*2.6*14 ICD10 002F
..;S $P(ABMDX(ABMCNT),":",2)=$TR($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API
..S $P(ABMDX(ABMCNT),":",2)=$TR($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API
..I ABMP("EXP")=31,($P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)'="") S $P(ABMDX(ABMCNT),":",9)=$P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,5) ;abm*2.6*9 HEAT57041
;
S ABMCNT=0
S I=0
F S I=$O(^ABMDBILL(DUZ(2),X,17,"C",I)) Q:'I D
.S J=0
.F S J=$O(^ABMDBILL(DUZ(2),X,17,"C",I,J)) Q:'J D
..;Q:$E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E" ;skip E-codes ;abm*2.6*14 ICD10 002F
..;I $E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E"&($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,20)'=30) Q ;skip E-codes ;abm*2.6*14 ICD10 002F, update API; CR4072
..;I ($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,20)=30) Q ;abm*2.6*16 HEAT217211 ;abm*2.6*18 HEAT239392
..;I $E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E" Q ;abm*2.6*16 HEAT217211 ;abm*2.6*18 HEAT239392
..I ($E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E")&(+$P($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)<30) Q ;skip E-codes ;abm*2.6*18 HEAT239392
..I (+$P($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)=30)&("^V^W^X^Y^"'[("^"_$E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)_"^")) Q ;abm*2.6*18 HEAT239392
..S ABMCNT=ABMCNT+1
..;S ABMDXE(ABMCNT)="BN:"_$TR($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 ICD10 002F
..S ABMDXE(ABMCNT)=$S((+$P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1):"ABN:",1:"BN:")_$TR($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 ICD10 002F, updated API
..I $P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)'="" S $P(ABMDXE(ABMCNT),":",9)=$P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)
..I ABMP("EXP")=31,($P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)'="") S $P(ABMDX(ABMCNT),":",9)=$P($G(^ABMDBILL(DUZ(2),X,17,J,0)),U,5) ;abm*2.6*9 HEAT57041
;I $P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'="" S ABMDX("ADM")=$TR($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".") ;abm*2.6*8 5010 ;abm*2.6*14 ICD10 002F
;start new abm*2.6*14 ICD10 002F, update APIs
I $P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'="" D
.S ABMDX("ADM")=$TR($P($$DX^ABMCVAPI(+$P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".")
.S ABMDX("ADMTYP")=$P($$DX^ABMCVAPI(+$P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,20)
;end new ICD10 002F
Q
;end new abm*2.6*8
PXSET(X) ;EP -set px array
;x=bill ien
D PXSET^ABMUTL8A(X)
Q
OSSET(X) ;EP -occurrence span set
;x=bill ien
D OSSET^ABMUTL8A(X)
Q
OCSET(X) ;EP -occurrence set
;x=bill ien
D OCSET^ABMUTL8A(X)
Q
VASET(X) ;EP -value code set
;x=bill ien
K ABMVA
S ABMCNT=0
N I
S I=0
F S I=$O(^ABMDBILL(DUZ(2),X,55,I)) Q:'I D
.S ABMLINE=^ABMDBILL(DUZ(2),X,55,I,0)
.S ABMCNT=ABMCNT+1
.S ABMVA(ABMCNT)="BE"
.S $P(ABMVA(ABMCNT),":",2)=$P($G(^ABMDCODE(+$P(ABMLINE,U),0)),U)
.;start old abm*2.6*11 IHS/SD/AML HEAT89676
.;I $P(ABMVA(ABMCNT),":",2)'="A0" S $P(ABMVA(ABMCNT),":",5)=$FN($P(ABMLINE,U,2),"",2)
.;E S $P(ABMVA(ABMCNT),":",5)=$P(ABMLINE,U,2)
.;end old heat89676
.S $P(ABMVA(ABMCNT),":",5)=$P(ABMLINE,U,2) ;abm*2.6*11 IHS/SD/AML HEAT89676
Q
CDSET(X) ;EP - condition code set
;x=bill ien
D CDSET^ABMUTL8A(X)
Q
;start new abm*2.6*6 5010
ANES(X) ;EP - anesthesia charges set
D ANES^ABMUTL8A(X)
Q
;end new 5010
WR(X) ;EP - write to file
S ABMDELI="~"
S:$$RCID^ABMUTLP(ABMP("INS"))=730266607 ABMDELI="~"_$C(13)_$C(10)
S ABMSTRNG=$$STRIP(ABMREC(X))
Q:$L(ABMSTRNG,"*")<2
U IO
U:$G(ABMDEBUG) IO(0)
S ABMSTRNG=$TR(ABMSTRNG,"~","-")
W ABMSTRNG
W ABMDELI
W:$G(ABMDEBUG) !
S ABMSTOT=ABMSTOT+1
U IO(0)
K ABMR,ABMREC
Q
STRIP(X) ;EP - strip trailing null data elements
I $E(X,1,3)="ISA" Q X
N I
F I=$L(X,"*"):-1:1 Q:$P(X,"*",I)'=""
S Y=$P(X,"*",1,I)
Q Y
AN(X) ;EP - alpha numeric only
N I
F I=1:1:$L(X) D
.S ABMCHAR=$E(X,I)
.S ABMCHAR($A(ABMCHAR))=""
S I=0
F S I=$O(ABMCHAR(I)) Q:'I D
.I I>31&(I<34) Q
.I I>37&(I<59) Q
.I I=61!(I=63) Q
.I I>64&(I<91) Q
.I I>96&(I<123) Q
.S X=$TR(X,$C(I))
K ABMCHAR
Q X
PTAX(X) ;EP - provider taxonomy
;x=location ien
S X="261QP0904X"
Q X
OVER(ABMLN,ABMPCE) ;EP - get override values from 3P Insurer file
S ABMVALUE=""
N ABMOVTYP
;start old abm*2.6*10 HEAT53137
;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,ABMLN,ABMPCE,0)) S ABMOVTYP=0
;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,ABMLN,ABMPCE,ABMP("VTYP"))) S ABMOVTYP=ABMP("VTYP")
;end old start new HEAT53137,HEAT67605
;S ABMT("EXP")=$S(ABMP("EXP")=32:27,1:14) ;abm*2.6*13 export mode 35
S ABMT("EXP")=$S(ABMP("EXP")=32:35,1:14) ;abm*2.6*13 export mode 35
I $D(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",ABMT("EXP"),ABMLN,ABMPCE,0)) S ABMOVTYP=0
I $D(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",ABMT("EXP"),ABMLN,ABMPCE,ABMP("VTYP"))) S ABMOVTYP=ABMP("VTYP")
;end new HEAT53137
I $G(ABMOVTYP)="" Q ABMVALUE
;S ABMVALUE=^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,ABMLN,ABMPCE,ABMOVTYP) ;abm*2.6*10 HEAT53137
S ABMVALUE=^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",ABMT("EXP"),ABMLN,ABMPCE,ABMOVTYP) ;abm*2.6*10 HEAT53137, HEAT67605
Q ABMVALUE
;start new abm*2.6*6 5010
837 ;EP - override for 837 5010 formats
K ABME("VTYP")
;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),"N")) D ;do not send seg ;abm*2.6*10 HEAT53137
I $D(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),"N")) D ;do not send seg ;abm*2.6*10 HEAT53137
.S ABMREC(ABME("RTYPE"))=ABME("RTYPE")
.K ABMR(ABME("RTYPE"))
.S ABMR(ABME("RTYPE"),10)=ABME("RTYPE")
S ABMELE=""
;F S ABMELE=$O(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE)) Q:($G(ABMELE)="") D ;abm*2.6*10 HEAT53137
F S ABMELE=$O(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE)) Q:($G(ABMELE)="") D ;abm*2.6*10 HEAT53137
.;I $O(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,""))="S" Q ;abm*2.6*10 HEAT53137
.I $O(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,""))="S" Q ;abm*2.6*10 HEAT53137
.I ABMELE["01" S ABMELEM=2
.I ABMELE["02" S ABMELEM=3
.I ABMELE["03" S ABMELEM=4
.I ABMELE["04" S ABMELEM=5
.I ABMELE["05" S ABMELEM=6
.I ABMELE["06" S ABMELEM=7
.I ABMELE["07" S ABMELEM=8
.I ABMELE["08" S ABMELEM=9
.;I ABMELE["09" S ABMELEM=10 ;abm*2.6*9 HEAT59090
.I ABMELE["09" S ABMELEM=100 ;abm*2.6*9 HEAT59090
.I ABMELE["14" S ABMELEM=15 ;abm*2.6*10 HEAT74624
.I ABMELE["15" S ABMELEM=16 ;abm*2.6*9 HEAT58133
.S ABMR(ABME("RTYPE"),ABMELEM)=""
.S $P(ABMREC(ABME("RTYPE")),"*",$E(ABMELEM,1,$L(ABMELEM)-1))=""
;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"))) D ;seg override ;abm*2.6*10 HEAT53137
I $D(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"))) D ;seg override ;abm*2.6*10 HEAT53137
.S ABMELE=""
.;F S ABMELE=$O(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE)) Q:($G(ABMELE)="") D ;abm*2.6*10 HEAT53137
.F S ABMELE=$O(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE)) Q:($G(ABMELE)="") D ;abm*2.6*10 HEAT53137
..;start old abm*2.6*10 HEAT53137
..;S ABMVALUE=$G(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,0))
..;S:($G(ABMVALUE)="") ABMVALUE=$G(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,ABMP("VTYP")))
..;end old start new HEAT53137
..S ABMVALUE=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,0))
..S:($G(ABMVALUE)="") ABMVALUE=$G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,ABMP("VTYP")))
..;end new HEAT53137
..I ABMVALUE'="" D
...I ABMELE["01" S ABMELEM=2
...I ABMELE["02" S ABMELEM=3
...I ABMELE["03" S ABMELEM=4
...I ABMELE["04" S ABMELEM=5
...I ABMELE["05" S ABMELEM=6
...I ABMELE["06" S ABMELEM=7
...I ABMELE["07" S ABMELEM=8
...I ABMELE["08" S ABMELEM=9
...;I ABMELE["09" S ABMELEM=10 ;abm*2.6*9 HEAT59090
...I ABMELE["09" S ABMELEM=100 ;abm*2.6*9 HEAT59090
...I ABMELE["14" S ABMELEM=15 ;abm*2.6*10 HEAT74624
...;I ABMELE["15" S ABMELEM=160 ;abm*2.6*9 HEAT58133 ;abm*2.6*11 HEAT97792
...I ABMELE["15" S ABMELEM=16 ;abm*2.6*11 HEAT97792
...S ABMR(ABME("RTYPE"),ABMELEM)=ABMVALUE
...I ABME("RTYPE")="ISA",ABMELEM=7 S ABMVALUE=$$FMT^ABMERUTL((ABMVALUE),15) ;abm*2.6*10 IHS/SD/AML 03/23/2012 - If ISA06, ensure 15 chars for element
...I ABME("RTYPE")="ISA",ABMELEM=9 S ABMVALUE=$$FMT^ABMERUTL((ABMVALUE),15) ;abm*2.6*9 NOHEAT - ensure ISA08 15 chars
...S $P(ABMREC(ABME("RTYPE")),"*",$E(ABMELEM,1,$L(ABMELEM-1)))=ABMVALUE ;abm*2.6*10 HEAT74624
Q
;end new 5010
ABMUTL8 ; IHS/ASDST/DMJ - 837 UTILITIES ;
+1 ;;2.6;IHS Third Party Billing;**1,4,6,8,9,10,11,13,14,16,18**;NOV 12, 2009;Build 289
+2 ;Original;DMJ;09/21/95 12:47 PM
+3 ;V2.5 P5-837 mod. Use HRN in following priority order-visit loc/parent/loop satellites
+4 ;v2.5 p5-put POS, TOS by line item
+5 ;v2.5 p6-Make OVER works correctly
+6 ;v2.5 p8-IM13324/IM15558-Format 0 to 0.00
+7 ;v2.5 p8-IM12628-Remove special delimiter for CA
+8 ;v2.5 p8-task 6-Check value cd before formatting; can be dollar amt or zip
+9 ;v2.5 p9-IM14702/IM17968-Correct HRN lookup for satellites
+10 ;v2.5 p9-IM17270-Changed "~" to "-" to avoid delimiter issues
+11 ;v2.5 p9-IM16962-If BCBS/OK add CR/LF to delimiter; they can't do streamed data
+12 ;
+13 ;IHS/SD/SDR-v2.6 CSV
+14 ;IHS/SD/SDR-2.6*1 -HEAT2836 -Remove Dxs when inpt Medicare/RR
+15 ;IHS/SD/SDR-2.6*6 -5010 -added code to pull anesthesia charges
+16 ;IHS/SD/SDR-2.6*13 -Added check for new export mode 35
+17 ;IHS/SD/SDR-2.6*14 -ICD10 002F Changes for 837 qualifier ICD9 vs ICD10
+18 ;IHS/SD/SDR-2.6*14 -Updated DX^ABMCVAPI calls to be numeric
+19 ;IHS/SD/SDR-2.6*14 -split routine to ABMUTL8A due to size
+20 ;IHS/SD/SDR-2.6*14 -CR4072 -made correction to ICD10 check to be '=30 instead of =1
+21 ;IHS/SD/SDR-2.6*16 -HEAT217211 -Made change so it won't do the E-code change in DXSET2 if ICD code is an ICD-10 code.
+22 ;IHS/SD/SDR-2.6*16 -HEAT231506 -Updated so 837D will print DX codes.
+23 ;IHS/SD/SDR-2.6*18 -HEAT239392 -Made changes so E-code will be included appropriately. Was being dropped from file.
+24 ;
HRN(X) ;PEP - HRN
+1 ; First look at Visit Loc for HRN
+2 ; If not then look at Parent Loc for HRN
+3 ; If not, loop Satellite Locs for said parent until one is found.
+4 IF $GET(ABMP("LDFN"))
SET HRN=$PIECE($GET(^AUPNPAT(+X,41,ABMP("LDFN"),0)),"^",2)
+5 ;Q:HRN HRN ;abm*2.6*10 HEAT61426
+6 ;abm*2.6*10 HEAT61426
IF ($GET(HRN)'="")
QUIT HRN
+7 SET ABMPAR=""
+8 FOR
SET ABMPAR=$ORDER(^BAR(90052.05,ABMPAR))
IF ABMPAR=""!$DATA(^BAR(90052.05,ABMPAR,ABMP("LDFN")))
QUIT
+9 SET ABMPAR=$PIECE($GET(^BAR(90052.05,ABMPAR,ABMP("LDFN"),0)),"^",3)
+10 IF $GET(ABMPAR)'=""
SET HRN=$PIECE($GET(^AUPNPAT(X,41,ABMPAR,0)),"^",2)
+11 IF HRN
QUIT HRN
+12 IF $GET(ABMPAR)'=""
Begin DoDot:1
+13 SET ABMSAT=0
+14 FOR
SET ABMSAT=$ORDER(^BAR(90052.05,ABMPAR,ABMSAT))
IF ABMSAT=""
QUIT
Begin DoDot:2
+15 SET HRN=$PIECE($GET(^AUPNPAT(X,41,ABMSAT,0)),"^",2)
End DoDot:2
IF HRN
QUIT
End DoDot:1
+16 QUIT HRN
DXP(X) ;EP - Primary DX
+1 ;x=bill ien
+2 DO DXSET(X)
+3 SET ABMDXP=$GET(ABMDX(1))
+4 QUIT ABMDXP
DXA(X) ;EP - Admitting DX
+1 ;x=bill ien
+2 NEW ABMBTYP
SET ABMBTYP=$PIECE(^ABMDBILL(DUZ(2),X,0),U,2)
+3 SET ABMDXA=$PIECE($GET(^ABMDBILL(DUZ(2),X,5)),U,9)
+4 ;abm*2.6*4 HEAT19688
IF ABMDXA=""
QUIT ABMDXA
+5 ;CSV-c
SET ABMDXA=$PIECE($$DX^ABMCVAPI(+ABMDXA,ABMP("VDT")),U,2)
+6 IF ABMDXA=""
QUIT ABMDXA
+7 SET ABMDXA=$TRANSLATE(ABMDXA,".")
+8 ;S:$E(ABMBTYP,2)<3 ABMDXA="BJ:"_ABMDXA ;abm*2.6*14 ICD10 002F
+9 ;abm*2.6*14 ICD10 002F
IF $EXTRACT(ABMBTYP,2)<3
SET ABMDXA=$SELECT(+$PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1:"ABJ",1:"BJ")_":"_ABMDXA
+10 IF $EXTRACT(ABMBTYP,2)>2
SET ABMDXA="ZZ:"_ABMDXA
+11 QUIT ABMDXA
DXE(X) ;EP - E-Code
+1 ;x=bill ien
+2 SET ABMDXE=$PIECE($GET(^ABMDBILL(DUZ(2),X,8)),U,12)
+3 IF ABMDXE=""
QUIT ABMDXE
+4 ;S ABMDXE="BN:"_$TR($P($$DX^ABMCVAPI(ABMDXE,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API call
+5 ;CSV-c ;abm*2.6*14 update API call
SET ABMDXE="BN:"_$TRANSLATE($PIECE($$DX^ABMCVAPI(+ABMDXE,ABMP("VDT")),U,2),".")
+6 QUIT ABMDXE
DXSET(X) ;EP - set dx array
+1 ;x=bill ien
+2 ;I +$G(ABMP("EXP"))=31!(+$G(ABMP("EXP"))=32) D DXSET2(X) Q ;abm*2.6*8 5010 ;abm*2.6*16 HEAT231506
+3 ;abm*2.6*8 5010 ;abm*2.6*16 HEAT231506
IF +$GET(ABMP("EXP"))=31!(+$GET(ABMP("EXP"))=32)!(+$GET(ABMP("EXP"))=33)
DO DXSET2(X)
QUIT
+4 KILL ABMDX
+5 NEW I,J
+6 SET ABMCNT=0
+7 SET I=0
+8 FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),X,17,"C",I))
IF 'I
QUIT
Begin DoDot:1
+9 SET J=0
+10 FOR
SET J=$ORDER(^ABMDBILL(DUZ(2),X,17,"C",I,J))
IF 'J
QUIT
Begin DoDot:2
+11 SET ABMCNT=ABMCNT+1
+12 IF ABMCNT=1
SET ABMDX(ABMCNT)="BK"
+13 IF ABMCNT'=1
SET ABMDX(ABMCNT)="BF"
+14 ;S $P(ABMDX(ABMCNT),":",2)=$TR($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API
+15 ;CSV-c ;abm*2.6*14 update API
SET $PIECE(ABMDX(ABMCNT),":",2)=$TRANSLATE($PIECE($$DX^ABMCVAPI(+J,ABMP("VDT")),U,2),".")
End DoDot:2
End DoDot:1
+16 ;I $P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'="" S ABMDX("ADM")=$TR($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".") ;abm*2.6*8 5010 ;abm*2.6*14 update API
+17 ;abm*2.6*14 update API
IF +$PIECE($GET(^ABMDBILL(DUZ(2),X,5)),U,9)'=0
SET ABMDX("ADM")=$TRANSLATE($PIECE($$DX^ABMCVAPI(+$PIECE($GET(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".")
+18 QUIT
+19 ;start new abm*2.6*8 5010
DXSET2(X) ;EP - set dx array
+1 ;x=bill ien
+2 KILL ABMDX
+3 ;abm*2.6*10 HEAT67774
KILL ABMDXE
+4 NEW I,J
+5 SET ABMCNT=0
+6 SET I=0
+7 FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),X,17,"C",I))
IF 'I
QUIT
Begin DoDot:1
+8 SET J=0
+9 FOR
SET J=$ORDER(^ABMDBILL(DUZ(2),X,17,"C",I,J))
IF 'J
QUIT
Begin DoDot:2
+10 ;Q:$E($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),1)="E" ;skip E-codes ;abm*2.6*14 ICD10 002F
+11 ;I $E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)="E"&($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,20)'=30) Q ;skip E-codes ;abm*2.6*14 ICD10 002F and update API; CR4072 ;abm*2.6*18 HEAT239392
+12 ;for next line skip E-codes ;abm*2.6*14 ICD10 002F; Update API; CR4072 ;abm*2.6*18 HEAT239392
+13 ;I (+$P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'=0)&(+$P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,20)<30) Q ;skip admit DX if ICD9 Ecode ;removed line abm*2.6*18 HEAT239392
+14 ;I ($E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)="E")&($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)<30) Q ;skip DX if ICD9 Ecode ;removed abm*2.6*18 HEAT239392
+15 ;skip admit DX if ICD10 accident cd
+16 ;abm*2.6*18 HEAT239392 removed next 2 lines in a2. ICD shouldn't be skipped here.
+17 ;I (+$P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,20)=30)&("^V^W^X^Y^"[("^"_$E($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),1)_"^")) Q ;abm*2.6*18 HEAT239392
+18 ;I (+$P($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)=30)&("^V^W^X^Y^"[("^"_$E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)_"^")) Q ;skip DX if ICD10 accident code ;abm*2.6*18 HEAT239392
+19 SET ABMCNT=ABMCNT+1
+20 ;S:ABMCNT=1 ABMDX(ABMCNT)="BK" ;abm*2.6*14 ICD10 002F
+21 ;abm*2.6*14 ICD10 002F
IF ABMCNT=1
SET ABMDX(ABMCNT)=$SELECT(+$PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1:"ABK",1:"BK")
+22 ;S:ABMCNT'=1 ABMDX(ABMCNT)="BF" ;abm*2.6*14 ICD10 OO2F
+23 ;abm*2.6*14 ICD10 002F
IF ABMCNT'=1
SET ABMDX(ABMCNT)=$SELECT(+$PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1:"ABF",1:"BF")
+24 ;S $P(ABMDX(ABMCNT),":",2)=$TR($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 update API
+25 ;CSV-c ;abm*2.6*14 update API
SET $PIECE(ABMDX(ABMCNT),":",2)=$TRANSLATE($PIECE($$DX^ABMCVAPI(+J,ABMP("VDT")),U,2),".")
+26 ;abm*2.6*9 HEAT57041
IF ABMP("EXP")=31
IF ($PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)'="")
SET $PIECE(ABMDX(ABMCNT),":",9)=$PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)
End DoDot:2
End DoDot:1
+27 ;
+28 SET ABMCNT=0
+29 SET I=0
+30 FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),X,17,"C",I))
IF 'I
QUIT
Begin DoDot:1
+31 SET J=0
+32 FOR
SET J=$ORDER(^ABMDBILL(DUZ(2),X,17,"C",I,J))
IF 'J
QUIT
Begin DoDot:2
+33 ;Q:$E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E" ;skip E-codes ;abm*2.6*14 ICD10 002F
+34 ;I $E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E"&($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,20)'=30) Q ;skip E-codes ;abm*2.6*14 ICD10 002F, update API; CR4072
+35 ;I ($P($$DX^ABMCVAPI(+J,ABMP("VDT")),U,20)=30) Q ;abm*2.6*16 HEAT217211 ;abm*2.6*18 HEAT239392
+36 ;I $E($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E" Q ;abm*2.6*16 HEAT217211 ;abm*2.6*18 HEAT239392
+37 ;skip E-codes ;abm*2.6*18 HEAT239392
IF ($EXTRACT($PIECE($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)'="E")&(+$PIECE($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)<30)
QUIT
+38 ;abm*2.6*18 HEAT239392
IF (+$PIECE($$DX^ABMCVAPI(J,ABMP("VDT")),U,20)=30)&("^V^W^X^Y^"'[("^"_$EXTRACT($PIECE($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),1)_"^"))
QUIT
+39 SET ABMCNT=ABMCNT+1
+40 ;S ABMDXE(ABMCNT)="BN:"_$TR($P($$DX^ABMCVAPI(J,ABMP("VDT")),U,2),".") ;CSV-c ;abm*2.6*14 ICD10 002F
+41 ;CSV-c ;abm*2.6*14 ICD10 002F, updated API
SET ABMDXE(ABMCNT)=$SELECT((+$PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,6)=1):"ABN:",1:"BN:")_$TRANSLATE($PIECE($$DX^ABMCVAPI(+J,ABMP("VDT")),U,2),".")
+42 IF $PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)'=""
SET $PIECE(ABMDXE(ABMCNT),":",9)=$PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)
+43 ;abm*2.6*9 HEAT57041
IF ABMP("EXP")=31
IF ($PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)'="")
SET $PIECE(ABMDX(ABMCNT),":",9)=$PIECE($GET(^ABMDBILL(DUZ(2),X,17,J,0)),U,5)
End DoDot:2
End DoDot:1
+44 ;I $P($G(^ABMDBILL(DUZ(2),X,5)),U,9)'="" S ABMDX("ADM")=$TR($P($$DX^ABMCVAPI($P($G(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".") ;abm*2.6*8 5010 ;abm*2.6*14 ICD10 002F
+45 ;start new abm*2.6*14 ICD10 002F, update APIs
+46 IF $PIECE($GET(^ABMDBILL(DUZ(2),X,5)),U,9)'=""
Begin DoDot:1
+47 SET ABMDX("ADM")=$TRANSLATE($PIECE($$DX^ABMCVAPI(+$PIECE($GET(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,2),".")
+48 SET ABMDX("ADMTYP")=$PIECE($$DX^ABMCVAPI(+$PIECE($GET(^ABMDBILL(DUZ(2),X,5)),U,9),ABMP("VDT")),U,20)
End DoDot:1
+49 ;end new ICD10 002F
+50 QUIT
+51 ;end new abm*2.6*8
PXSET(X) ;EP -set px array
+1 ;x=bill ien
+2 DO PXSET^ABMUTL8A(X)
+3 QUIT
OSSET(X) ;EP -occurrence span set
+1 ;x=bill ien
+2 DO OSSET^ABMUTL8A(X)
+3 QUIT
OCSET(X) ;EP -occurrence set
+1 ;x=bill ien
+2 DO OCSET^ABMUTL8A(X)
+3 QUIT
VASET(X) ;EP -value code set
+1 ;x=bill ien
+2 KILL ABMVA
+3 SET ABMCNT=0
+4 NEW I
+5 SET I=0
+6 FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),X,55,I))
IF 'I
QUIT
Begin DoDot:1
+7 SET ABMLINE=^ABMDBILL(DUZ(2),X,55,I,0)
+8 SET ABMCNT=ABMCNT+1
+9 SET ABMVA(ABMCNT)="BE"
+10 SET $PIECE(ABMVA(ABMCNT),":",2)=$PIECE($GET(^ABMDCODE(+$PIECE(ABMLINE,U),0)),U)
+11 ;start old abm*2.6*11 IHS/SD/AML HEAT89676
+12 ;I $P(ABMVA(ABMCNT),":",2)'="A0" S $P(ABMVA(ABMCNT),":",5)=$FN($P(ABMLINE,U,2),"",2)
+13 ;E S $P(ABMVA(ABMCNT),":",5)=$P(ABMLINE,U,2)
+14 ;end old heat89676
+15 ;abm*2.6*11 IHS/SD/AML HEAT89676
SET $PIECE(ABMVA(ABMCNT),":",5)=$PIECE(ABMLINE,U,2)
End DoDot:1
+16 QUIT
CDSET(X) ;EP - condition code set
+1 ;x=bill ien
+2 DO CDSET^ABMUTL8A(X)
+3 QUIT
+4 ;start new abm*2.6*6 5010
ANES(X) ;EP - anesthesia charges set
+1 DO ANES^ABMUTL8A(X)
+2 QUIT
+3 ;end new 5010
WR(X) ;EP - write to file
+1 SET ABMDELI="~"
+2 IF $$RCID^ABMUTLP(ABMP("INS"))=730266607
SET ABMDELI="~"_$CHAR(13)_$CHAR(10)
+3 SET ABMSTRNG=$$STRIP(ABMREC(X))
+4 IF $LENGTH(ABMSTRNG,"*")<2
QUIT
+5 USE IO
+6 IF $GET(ABMDEBUG)
USE IO(0)
+7 SET ABMSTRNG=$TRANSLATE(ABMSTRNG,"~","-")
+8 WRITE ABMSTRNG
+9 WRITE ABMDELI
+10 IF $GET(ABMDEBUG)
WRITE !
+11 SET ABMSTOT=ABMSTOT+1
+12 USE IO(0)
+13 KILL ABMR,ABMREC
+14 QUIT
STRIP(X) ;EP - strip trailing null data elements
+1 IF $EXTRACT(X,1,3)="ISA"
QUIT X
+2 NEW I
+3 FOR I=$LENGTH(X,"*"):-1:1
IF $PIECE(X,"*",I)'=""
QUIT
+4 SET Y=$PIECE(X,"*",1,I)
+5 QUIT Y
AN(X) ;EP - alpha numeric only
+1 NEW I
+2 FOR I=1:1:$LENGTH(X)
Begin DoDot:1
+3 SET ABMCHAR=$EXTRACT(X,I)
+4 SET ABMCHAR($ASCII(ABMCHAR))=""
End DoDot:1
+5 SET I=0
+6 FOR
SET I=$ORDER(ABMCHAR(I))
IF 'I
QUIT
Begin DoDot:1
+7 IF I>31&(I<34)
QUIT
+8 IF I>37&(I<59)
QUIT
+9 IF I=61!(I=63)
QUIT
+10 IF I>64&(I<91)
QUIT
+11 IF I>96&(I<123)
QUIT
+12 SET X=$TRANSLATE(X,$CHAR(I))
End DoDot:1
+13 KILL ABMCHAR
+14 QUIT X
PTAX(X) ;EP - provider taxonomy
+1 ;x=location ien
+2 SET X="261QP0904X"
+3 QUIT X
OVER(ABMLN,ABMPCE) ;EP - get override values from 3P Insurer file
+1 SET ABMVALUE=""
+2 NEW ABMOVTYP
+3 ;start old abm*2.6*10 HEAT53137
+4 ;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,ABMLN,ABMPCE,0)) S ABMOVTYP=0
+5 ;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,ABMLN,ABMPCE,ABMP("VTYP"))) S ABMOVTYP=ABMP("VTYP")
+6 ;end old start new HEAT53137,HEAT67605
+7 ;S ABMT("EXP")=$S(ABMP("EXP")=32:27,1:14) ;abm*2.6*13 export mode 35
+8 ;abm*2.6*13 export mode 35
SET ABMT("EXP")=$SELECT(ABMP("EXP")=32:35,1:14)
+9 IF $DATA(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",ABMT("EXP"),ABMLN,ABMPCE,0))
SET ABMOVTYP=0
+10 IF $DATA(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",ABMT("EXP"),ABMLN,ABMPCE,ABMP("VTYP")))
SET ABMOVTYP=ABMP("VTYP")
+11 ;end new HEAT53137
+12 IF $GET(ABMOVTYP)=""
QUIT ABMVALUE
+13 ;S ABMVALUE=^ABMNINS(DUZ(2),ABMP("INS"),2,"AOVR",14,ABMLN,ABMPCE,ABMOVTYP) ;abm*2.6*10 HEAT53137
+14 ;abm*2.6*10 HEAT53137, HEAT67605
SET ABMVALUE=^ABMNINS(ABMP("LDFN"),ABMP("INS"),2,"AOVR",ABMT("EXP"),ABMLN,ABMPCE,ABMOVTYP)
+15 QUIT ABMVALUE
+16 ;start new abm*2.6*6 5010
837 ;EP - override for 837 5010 formats
+1 KILL ABME("VTYP")
+2 ;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),"N")) D ;do not send seg ;abm*2.6*10 HEAT53137
+3 ;do not send seg ;abm*2.6*10 HEAT53137
IF $DATA(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),"N"))
Begin DoDot:1
+4 SET ABMREC(ABME("RTYPE"))=ABME("RTYPE")
+5 KILL ABMR(ABME("RTYPE"))
+6 SET ABMR(ABME("RTYPE"),10)=ABME("RTYPE")
End DoDot:1
+7 SET ABMELE=""
+8 ;F S ABMELE=$O(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE)) Q:($G(ABMELE)="") D ;abm*2.6*10 HEAT53137
+9 ;abm*2.6*10 HEAT53137
FOR
SET ABMELE=$ORDER(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE))
IF ($GET(ABMELE)="")
QUIT
Begin DoDot:1
+10 ;I $O(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,""))="S" Q ;abm*2.6*10 HEAT53137
+11 ;abm*2.6*10 HEAT53137
IF $ORDER(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"ASEND",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,""))="S"
QUIT
+12 IF ABMELE["01"
SET ABMELEM=2
+13 IF ABMELE["02"
SET ABMELEM=3
+14 IF ABMELE["03"
SET ABMELEM=4
+15 IF ABMELE["04"
SET ABMELEM=5
+16 IF ABMELE["05"
SET ABMELEM=6
+17 IF ABMELE["06"
SET ABMELEM=7
+18 IF ABMELE["07"
SET ABMELEM=8
+19 IF ABMELE["08"
SET ABMELEM=9
+20 ;I ABMELE["09" S ABMELEM=10 ;abm*2.6*9 HEAT59090
+21 ;abm*2.6*9 HEAT59090
IF ABMELE["09"
SET ABMELEM=100
+22 ;abm*2.6*10 HEAT74624
IF ABMELE["14"
SET ABMELEM=15
+23 ;abm*2.6*9 HEAT58133
IF ABMELE["15"
SET ABMELEM=16
+24 SET ABMR(ABME("RTYPE"),ABMELEM)=""
+25 SET $PIECE(ABMREC(ABME("RTYPE")),"*",$EXTRACT(ABMELEM,1,$LENGTH(ABMELEM)-1))=""
End DoDot:1
+26 ;I $D(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"))) D ;seg override ;abm*2.6*10 HEAT53137
+27 ;seg override ;abm*2.6*10 HEAT53137
IF $DATA(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE")))
Begin DoDot:1
+28 SET ABMELE=""
+29 ;F S ABMELE=$O(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE)) Q:($G(ABMELE)="") D ;abm*2.6*10 HEAT53137
+30 ;abm*2.6*10 HEAT53137
FOR
SET ABMELE=$ORDER(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE))
IF ($GET(ABMELE)="")
QUIT
Begin DoDot:2
+31 ;start old abm*2.6*10 HEAT53137
+32 ;S ABMVALUE=$G(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,0))
+33 ;S:($G(ABMVALUE)="") ABMVALUE=$G(^ABMNINS(DUZ(2),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,ABMP("VTYP")))
+34 ;end old start new HEAT53137
+35 SET ABMVALUE=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,0))
+36 IF ($GET(ABMVALUE)="")
SET ABMVALUE=$GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),2.5,"A837",+ABMP("EXP"),ABMLOOP,ABME("RTYPE"),ABMELE,ABMP("VTYP")))
+37 ;end new HEAT53137
+38 IF ABMVALUE'=""
Begin DoDot:3
+39 IF ABMELE["01"
SET ABMELEM=2
+40 IF ABMELE["02"
SET ABMELEM=3
+41 IF ABMELE["03"
SET ABMELEM=4
+42 IF ABMELE["04"
SET ABMELEM=5
+43 IF ABMELE["05"
SET ABMELEM=6
+44 IF ABMELE["06"
SET ABMELEM=7
+45 IF ABMELE["07"
SET ABMELEM=8
+46 IF ABMELE["08"
SET ABMELEM=9
+47 ;I ABMELE["09" S ABMELEM=10 ;abm*2.6*9 HEAT59090
+48 ;abm*2.6*9 HEAT59090
IF ABMELE["09"
SET ABMELEM=100
+49 ;abm*2.6*10 HEAT74624
IF ABMELE["14"
SET ABMELEM=15
+50 ;I ABMELE["15" S ABMELEM=160 ;abm*2.6*9 HEAT58133 ;abm*2.6*11 HEAT97792
+51 ;abm*2.6*11 HEAT97792
IF ABMELE["15"
SET ABMELEM=16
+52 SET ABMR(ABME("RTYPE"),ABMELEM)=ABMVALUE
+53 ;abm*2.6*10 IHS/SD/AML 03/23/2012 - If ISA06, ensure 15 chars for element
IF ABME("RTYPE")="ISA"
IF ABMELEM=7
SET ABMVALUE=$$FMT^ABMERUTL((ABMVALUE),15)
+54 ;abm*2.6*9 NOHEAT - ensure ISA08 15 chars
IF ABME("RTYPE")="ISA"
IF ABMELEM=9
SET ABMVALUE=$$FMT^ABMERUTL((ABMVALUE),15)
+55 ;abm*2.6*10 HEAT74624
SET $PIECE(ABMREC(ABME("RTYPE")),"*",$EXTRACT(ABMELEM,1,$LENGTH(ABMELEM-1)))=ABMVALUE
End DoDot:3
End DoDot:2
End DoDot:1
+56 QUIT
+57 ;end new 5010
