ABME8L12 ; IHS/ASDST/DMJ - Header
;;2.6;IHS 3P BILLING SYSTEM;**6,8**;NOV 12, 2009
;Header Segments
;
; IHS/SD/SDR - v2.5 p8 - IM12246/IM17548 - Added code to do CLIA number REF segment
; IHS/SD/EFG - V2.5 P8 - IM16385 - Allow dental charges on 837P
; IHS/SD/SDR - v2.5 p8 - task 6 - Don't put rendering if ambulance
; IHS/SD/SDR - v2.5 p9 - task 1 - Added address for ordering provider
; IHS/SD/SDR - v2.5 p10 - IM20395 - Split out lines bundled by rev code
; IHS/SD/SDR - v2.5 p10 - IM20454 - Added flag for what loop
; IHS/SD/SDR - v2.5 p10 - IM19843 - Added code for SERVICE TO DATE/TIME
; IHS/SD/SDR - v2.5 p11 - NPI
; IHS/SD/SDR - v2.5 p11 - IM21946 - Changes for CLIA number
; IHS/SD/SDR - v2.5 p11 - IM23175 - G0107 needs CLIA number; treat as lab
; IHS/SD/SDR - v2.5 p12 - IM25247 - Add missing REF segment for TIN if NPI ONLY
; IHS/SD/SDR - abm*2.6*6 - HEAT29380 - G0103 needs CLIA number; treat as lab
;
EP ;START HERE
S ABMLXCNT=0
K ABM
D ^ABMEHGRV
S ABMI=0
F S ABMI=$O(ABMRV(ABMI)) Q:'+ABMI D
.S ABMJ=-1
.F S ABMJ=$O(ABMRV(ABMI,ABMJ)) Q:'+ABMJ D
..S ABMK=0
..F S ABMK=$O(ABMRV(ABMI,ABMJ,ABMK)) Q:'+ABMK D
...D LOOP
K ABMI,ABMJ,ABMK
Q
;
LOOP ;
S ABMLXCNT=ABMLXCNT+1
D EP^ABME8LX
D WR^ABMUTL8("LX")
D EP^ABME8SV1
D WR^ABMUTL8("SV1")
I $P(ABMRV(ABMI,ABMJ,ABMK),U,10) D
.I $P(ABMRV(ABMI,ABMJ,ABMK),U,27)'="",($P(ABMRV(ABMI,ABMJ,ABMK),U,10)'=$P(ABMRV(ABMI,ABMJ,ABMK),U,27)) D EP^ABME8DTP(472,"RD8",$P(ABMRV(ABMI,ABMJ,ABMK),U,10),$P(ABMRV(ABMI,ABMJ,ABMK),U,27))
.E D EP^ABME8DTP(472,"D8",$P(ABMRV(ABMI,ABMJ,ABMK),U,10))
I '$P(ABMRV(ABMI,ABMJ,ABMK),U,10) D
.D EP^ABME8DTP(472,"D8",$P(ABMB7,U))
D WR^ABMUTL8("DTP")
I ABMI=37 D ;lab multiple
.Q:$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,ABMJ,0)),U,21)="" ;no lab result
.D ^ABME8MEA
.D WR^ABMUTL8("MEA")
;I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>79999)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<90000))!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)="G0107") D ;abm*2.6*6 HEAT29380
;start new code abm*2.6*8 HEAT31238
;mammography cert number
I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>77050)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<77060)) D
.Q:ABMP("CLIN")=72 ;don't write if clinic is mammography; cert# already written for claim
.Q:$P($G(^ABMDPARM(ABMP("LDFN"),1,5)),U,4)="" ;no cert#
.D EP^ABME8REF("EW")
.D WR^ABMUTL8("REF")
;end new code HEAT31238
I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>79999)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<90000))!($E($P(ABMRV(ABMI,ABMJ,ABMK),U,2))="G") D ;abm*2.6*6 HEAT29380
.S ABMCLIA="SV"
.I $G(ABMOUTLB)'=1 D
..D EP^ABME8REF("X4","1SV","1SV")
..D WR^ABMUTL8("REF")
.I $G(ABMOUTLB)=1 D ;if reference lab
..D EP^ABME8REF("F4",1,1)
..D WR^ABMUTL8("REF")
;
; Loop 2420A - Rendering Physician
I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,13) D
.Q:$G(ABMP("VTYP"))=831&($G(ABMP("ITYPE"))="R") ;don't write provider info for ASC
.Q:$G(ABMP("CLIN"))="A3"
.S ABMLOOP="2420A"
.S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,13)
.Q:ABM("PRV")=$O(ABMP("PRV","D",0))
.D EP^ABME8NM1(82,ABM("PRV"))
.D WR^ABMUTL8("NM1")
.D EP^ABME8PRV("PE",ABM("PRV"))
.D WR^ABMUTL8("PRV")
.Q:$P($G(^AUTNINS(ABMP("INS"),0)),U)["OKLAHOMA MEDICAID"
.I ABMNPIU="N" D
..D EP^ABME8REF("EI",9999999.06,DUZ(2))
..Q:((ABMRCID="99999")!(ABMRCID="AHCCCS866004791")) ;AZ Medicaid
..D WR^ABMUTL8("REF")
.I ABMNPIU'="N" D
..D EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
..D WR^ABMUTL8("REF")
;
; Loop 2420B - Purchased Service Physician Name
I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,19) D
.S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,19)
.Q:ABM("PRV")=$O(ABMP("PRV","P",0))
.D EP^ABME8NM1("QB",ABM("PRV"))
.D WR^ABMUTL8("NM1")
.I ABMNPIU="N" D
..D EP^ABME8REF("EI",9999999.06,DUZ(2))
..D WR^ABMUTL8("REF")
.I ABMNPIU'="N" D
..D EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
..D WR^ABMUTL8("REF")
;
; Loop 2420C - Service Facility Location
I $G(ABMOUTLB)=1 D ;reference lab
.S ABMOTLBN=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0),"^",14)
.I $G(ABMOTLBN)'="" D
..D EP^ABME8NM1(77,ABMOTLBN)
..D WR^ABMUTL8("NM1")
..D EP^ABME8N3(9002274.35,ABMOTLBN)
..D WR^ABMUTL8("N3")
..D EP^ABME8N4(9002274.35,ABMOTLBN)
..D WR^ABMUTL8("N4")
;
; Loop 2420D - Supervising Physician Name
I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,20) D
.S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,20)
.Q:ABM("PRV")=$O(ABMP("PRV","S",0))
.D EP^ABME8NM1("DQ",ABM("PRV"))
.D WR^ABMUTL8("NM1")
.I ABMNPIU="N" D
..D EP^ABME8REF("EI",9999999.06,DUZ(2))
..D WR^ABMUTL8("REF")
.I ABMNPIU'="N" D
..D EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
..D WR^ABMUTL8("REF")
;
; Loop 2420E - Ordering Physician Name
I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,21) D
.S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,21)
.;NOTE:below line was added for patch 10 but removed during testing because site was
.;reporting payer was requiring it
.S ABMLOOP="2420E"
.D EP^ABME8NM1("DK",ABM("PRV"))
.D WR^ABMUTL8("NM1")
.D EP^ABME8N3(200,ABM("PRV"))
.D WR^ABMUTL8("N3")
.D EP^ABME8N4(200,ABM("PRV"))
.D WR^ABMUTL8("N4")
.I ABMNPIU="N" D
..D EP^ABME8REF("EI",9999999.06,DUZ(2))
..D WR^ABMUTL8("REF")
.I ABMNPIU'="N" D
..D EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
..D WR^ABMUTL8("REF")
.K ABMLOOP
;
; Loop 2420F Referring Provider Name
I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,18) D
.S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,18)
.Q:ABM("PRV")=$O(ABMP("PVR","F",0))
.D EP^ABME8NM1("DN",ABM("PRV"))
.D WR^ABMUTL8("NM1")
.D EP^ABME8PRV("RF")
.D WR^ABMUTL8("PRV",ABM("PRV"))
Q
ABME8L12 ; IHS/ASDST/DMJ - Header
+1 ;;2.6;IHS 3P BILLING SYSTEM;**6,8**;NOV 12, 2009
+2 ;Header Segments
+3 ;
+4 ; IHS/SD/SDR - v2.5 p8 - IM12246/IM17548 - Added code to do CLIA number REF segment
+5 ; IHS/SD/EFG - V2.5 P8 - IM16385 - Allow dental charges on 837P
+6 ; IHS/SD/SDR - v2.5 p8 - task 6 - Don't put rendering if ambulance
+7 ; IHS/SD/SDR - v2.5 p9 - task 1 - Added address for ordering provider
+8 ; IHS/SD/SDR - v2.5 p10 - IM20395 - Split out lines bundled by rev code
+9 ; IHS/SD/SDR - v2.5 p10 - IM20454 - Added flag for what loop
+10 ; IHS/SD/SDR - v2.5 p10 - IM19843 - Added code for SERVICE TO DATE/TIME
+11 ; IHS/SD/SDR - v2.5 p11 - NPI
+12 ; IHS/SD/SDR - v2.5 p11 - IM21946 - Changes for CLIA number
+13 ; IHS/SD/SDR - v2.5 p11 - IM23175 - G0107 needs CLIA number; treat as lab
+14 ; IHS/SD/SDR - v2.5 p12 - IM25247 - Add missing REF segment for TIN if NPI ONLY
+15 ; IHS/SD/SDR - abm*2.6*6 - HEAT29380 - G0103 needs CLIA number; treat as lab
+16 ;
EP ;START HERE
+1 SET ABMLXCNT=0
+2 KILL ABM
+3 DO ^ABMEHGRV
+4 SET ABMI=0
+5 FOR
SET ABMI=$ORDER(ABMRV(ABMI))
IF '+ABMI
QUIT
Begin DoDot:1
+6 SET ABMJ=-1
+7 FOR
SET ABMJ=$ORDER(ABMRV(ABMI,ABMJ))
IF '+ABMJ
QUIT
Begin DoDot:2
+8 SET ABMK=0
+9 FOR
SET ABMK=$ORDER(ABMRV(ABMI,ABMJ,ABMK))
IF '+ABMK
QUIT
Begin DoDot:3
+10 DO LOOP
End DoDot:3
End DoDot:2
End DoDot:1
+11 KILL ABMI,ABMJ,ABMK
+12 QUIT
+13 ;
LOOP ;
+1 SET ABMLXCNT=ABMLXCNT+1
+2 DO EP^ABME8LX
+3 DO WR^ABMUTL8("LX")
+4 DO EP^ABME8SV1
+5 DO WR^ABMUTL8("SV1")
+6 IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10)
Begin DoDot:1
+7 IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,27)'=""
IF ($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10)'=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,27))
DO EP^ABME8DTP(472,"RD8",$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10),$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,27))
+8 IF '$TEST
DO EP^ABME8DTP(472,"D8",$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10))
End DoDot:1
+9 IF '$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10)
Begin DoDot:1
+10 DO EP^ABME8DTP(472,"D8",$PIECE(ABMB7,U))
End DoDot:1
+11 DO WR^ABMUTL8("DTP")
+12 ;lab multiple
IF ABMI=37
Begin DoDot:1
+13 ;no lab result
IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,ABMJ,0)),U,21)=""
QUIT
+14 DO ^ABME8MEA
+15 DO WR^ABMUTL8("MEA")
End DoDot:1
+16 ;I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>79999)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<90000))!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)="G0107") D ;abm*2.6*6 HEAT29380
+17 ;start new code abm*2.6*8 HEAT31238
+18 ;mammography cert number
+19 IF (($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)>77050)&($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)<77060))
Begin DoDot:1
+20 ;don't write if clinic is mammography; cert# already written for claim
IF ABMP("CLIN")=72
QUIT
+21 ;no cert#
IF $PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,5)),U,4)=""
QUIT
+22 DO EP^ABME8REF("EW")
+23 DO WR^ABMUTL8("REF")
End DoDot:1
+24 ;end new code HEAT31238
+25 ;abm*2.6*6 HEAT29380
IF (($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)>79999)&($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)<90000))!($EXTRACT($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2))="G")
Begin DoDot:1
+26 SET ABMCLIA="SV"
+27 IF $GET(ABMOUTLB)'=1
Begin DoDot:2
+28 DO EP^ABME8REF("X4","1SV","1SV")
+29 DO WR^ABMUTL8("REF")
End DoDot:2
+30 ;if reference lab
IF $GET(ABMOUTLB)=1
Begin DoDot:2
+31 DO EP^ABME8REF("F4",1,1)
+32 DO WR^ABMUTL8("REF")
End DoDot:2
End DoDot:1
+33 ;
+34 ; Loop 2420A - Rendering Physician
+35 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,13)
Begin DoDot:1
+36 ;don't write provider info for ASC
IF $GET(ABMP("VTYP"))=831&($GET(ABMP("ITYPE"))="R")
QUIT
+37 IF $GET(ABMP("CLIN"))="A3"
QUIT
+38 SET ABMLOOP="2420A"
+39 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,13)
+40 IF ABM("PRV")=$ORDER(ABMP("PRV","D",0))
QUIT
+41 DO EP^ABME8NM1(82,ABM("PRV"))
+42 DO WR^ABMUTL8("NM1")
+43 DO EP^ABME8PRV("PE",ABM("PRV"))
+44 DO WR^ABMUTL8("PRV")
+45 IF $PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["OKLAHOMA MEDICAID"
QUIT
+46 IF ABMNPIU="N"
Begin DoDot:2
+47 DO EP^ABME8REF("EI",9999999.06,DUZ(2))
+48 ;AZ Medicaid
IF ((ABMRCID="99999")!(ABMRCID="AHCCCS866004791"))
QUIT
+49 DO WR^ABMUTL8("REF")
End DoDot:2
+50 IF ABMNPIU'="N"
Begin DoDot:2
+51 DO EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
+52 DO WR^ABMUTL8("REF")
End DoDot:2
End DoDot:1
+53 ;
+54 ; Loop 2420B - Purchased Service Physician Name
+55 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,19)
Begin DoDot:1
+56 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,19)
+57 IF ABM("PRV")=$ORDER(ABMP("PRV","P",0))
QUIT
+58 DO EP^ABME8NM1("QB",ABM("PRV"))
+59 DO WR^ABMUTL8("NM1")
+60 IF ABMNPIU="N"
Begin DoDot:2
+61 DO EP^ABME8REF("EI",9999999.06,DUZ(2))
+62 DO WR^ABMUTL8("REF")
End DoDot:2
+63 IF ABMNPIU'="N"
Begin DoDot:2
+64 DO EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
+65 DO WR^ABMUTL8("REF")
End DoDot:2
End DoDot:1
+66 ;
+67 ; Loop 2420C - Service Facility Location
+68 ;reference lab
IF $GET(ABMOUTLB)=1
Begin DoDot:1
+69 SET ABMOTLBN=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0),"^",14)
+70 IF $GET(ABMOTLBN)'=""
Begin DoDot:2
+71 DO EP^ABME8NM1(77,ABMOTLBN)
+72 DO WR^ABMUTL8("NM1")
+73 DO EP^ABME8N3(9002274.35,ABMOTLBN)
+74 DO WR^ABMUTL8("N3")
+75 DO EP^ABME8N4(9002274.35,ABMOTLBN)
+76 DO WR^ABMUTL8("N4")
End DoDot:2
End DoDot:1
+77 ;
+78 ; Loop 2420D - Supervising Physician Name
+79 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,20)
Begin DoDot:1
+80 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,20)
+81 IF ABM("PRV")=$ORDER(ABMP("PRV","S",0))
QUIT
+82 DO EP^ABME8NM1("DQ",ABM("PRV"))
+83 DO WR^ABMUTL8("NM1")
+84 IF ABMNPIU="N"
Begin DoDot:2
+85 DO EP^ABME8REF("EI",9999999.06,DUZ(2))
+86 DO WR^ABMUTL8("REF")
End DoDot:2
+87 IF ABMNPIU'="N"
Begin DoDot:2
+88 DO EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
+89 DO WR^ABMUTL8("REF")
End DoDot:2
End DoDot:1
+90 ;
+91 ; Loop 2420E - Ordering Physician Name
+92 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,21)
Begin DoDot:1
+93 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,21)
+94 ;NOTE:below line was added for patch 10 but removed during testing because site was
+95 ;reporting payer was requiring it
+96 SET ABMLOOP="2420E"
+97 DO EP^ABME8NM1("DK",ABM("PRV"))
+98 DO WR^ABMUTL8("NM1")
+99 DO EP^ABME8N3(200,ABM("PRV"))
+100 DO WR^ABMUTL8("N3")
+101 DO EP^ABME8N4(200,ABM("PRV"))
+102 DO WR^ABMUTL8("N4")
+103 IF ABMNPIU="N"
Begin DoDot:2
+104 DO EP^ABME8REF("EI",9999999.06,DUZ(2))
+105 DO WR^ABMUTL8("REF")
End DoDot:2
+106 IF ABMNPIU'="N"
Begin DoDot:2
+107 DO EP^ABME8REF(ABMP("RTYPE"),200,ABM("PRV"))
+108 DO WR^ABMUTL8("REF")
End DoDot:2
+109 KILL ABMLOOP
End DoDot:1
+110 ;
+111 ; Loop 2420F Referring Provider Name
+112 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,18)
Begin DoDot:1
+113 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,18)
+114 IF ABM("PRV")=$ORDER(ABMP("PVR","F",0))
QUIT
+115 DO EP^ABME8NM1("DN",ABM("PRV"))
+116 DO WR^ABMUTL8("NM1")
+117 DO EP^ABME8PRV("RF")
+118 DO WR^ABMUTL8("PRV",ABM("PRV"))
End DoDot:1
+119 QUIT
