ABME8L4 ; IHS/ASDST/DMJ - Header
;;2.6;IHS Third Party Billing;**1,9**;NOV 12, 2009
;Header Segments
;
; IHS/SD/SDR v2.5 p8 - IM12246/IM17548 Added code to put CLIA number REF segment
; IHS/SD/SDR - v2.5 p8 - task 6 Added code for CR1 and CRC segments (ambulance)
; IHS/SD/SDR - v2.5 p9 - IM18032 Put Medicaid Resubmission Number as REF*F8
; IHS/SD/SDR - v2.5 p9 - IM19203 Use Block 19 for NTE segment
; IHS/SD/SDR - v2.5 p10 - IM20076 Added code for EPSDT CRC segment
; IHS/SD/SDR - v2.5 p10 - IM20323/IM20433 error <SUBSCR>40+48^ABME8NM1
; IHS/SD/SDR - v2.5 p10 - IM20395 Split out lines bundled by rev code
; IHS/SD/SDR - v2.5 p11 - IM21946 Correction to CLIA
; IHS/SD/SDR - v2.5 p12 - NO IM Added DTP*454 for Init. treatment date
; IHS/SD/SDR - abm*2.6*1 - HEAT4158 - do REF*EW if mammography
; IHS/SD/SDR - abm*2.6*1 - HEAT6439 - Added PWK for claim attachments
; IHS/SD/SDR - 2.6*9 - HEAT39583 - added assumed care and relinquished care dates
;
START ;START HERE
K ABMOUTLB
D ^ABME8CLM
D WR^ABMUTL8("CLM")
I $P(ABMB9,"^",11) D
.D EP^ABME8DTP(304,"D8",$P(ABMB9,"^",11))
.D WR^ABMUTL8("DTP")
I $P(ABMB8,"^",6) D
.D EP^ABME8DTP(431,"D8",$P(ABMB8,"^",6))
.D WR^ABMUTL8("DTP")
I $P(ABMB8,"^",9) D
.D EP^ABME8DTP(438,"D8",$P(ABMB8,"^",9))
.D WR^ABMUTL8("DTP")
I $P(ABMB8,"^",7) D
.D EP^ABME8DTP(454,"D8",$P(ABMB8,"^",7))
.D WR^ABMUTL8("DTP")
I $P(ABMB8,"^",2) D
.I '$P(ABMB8,"^",4) D
..D EP^ABME8DTP(439,"D8",$P(ABMB8,"^",2))
.I $P(ABMB8,"^",4) D
..D EP^ABME8DTP(439,"DT",$P(ABMB8,"^",2)_"."_$P(ABMB8,"^",4))
.D WR^ABMUTL8("DTP")
I $P(ABMB9,"^",2) D
.D EP^ABME8DTP(296,"D8",$P(ABMB9,"^",2))
.D WR^ABMUTL8("DTP")
I $P(ABMB6,U) D
.Q:$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,4)="Y"&($E($G(ABMP("BTYP")),1,2)'="11") ;dme billing
.D EP^ABME8DTP(435,"D8",$P(ABMB6,U))
.D WR^ABMUTL8("DTP")
I $P(ABMB6,"^",3) D
.D EP^ABME8DTP("096","D8",$P(ABMB6,"^",3))
.D WR^ABMUTL8("DTP")
;start new code abm*2.6*9 HEAT39583
I $P(ABMB7,U,19) D
.D EP^ABME5DTP("090","D8",$P(ABMB7,U,19))
.D WR^ABMUTL8("DTP")
I $P(ABMB7,U,21) D
.D EP^ABME5DTP("091","D8",$P(ABMB7,U,21))
.D WR^ABMUTL8("DTP")
;end new code HEAT39583
;start new code abm*2.6*1 HEAT6439
I $D(^ABMDBILL(DUZ(2),ABMP("BDFN"),71)) D
.K ABM71CNT
.S ABM71IEN=0
.F S ABM71IEN=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),71,ABM71IEN)) Q:+ABM71IEN=0 D Q:$G(ABM71CNT)=10
..D ^ABME8PWK,WR^ABMUTL8("PWK")
..S ABM71CNT=+$G(ABM71CNT)+1
;end new code HEAT6439
I $P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,11)'="" D
.D ^ABME8CN1
.D WR^ABMUTL8("CN1")
I $P(ABMB9,"^",9) D
.D EP^ABME8AMT("F5")
.D WR^ABMUTL8("AMT")
I $P(ABMB5,"^",8)'="" D
.D EP^ABME8REF("G4")
.D WR^ABMUTL8("REF")
;start new code abm*2.6*1 HEAT4158
I ABMP("CLIN")=72 D ;mammography
.Q:$P($G(^ABMDPARM(ABMP("LDFN"),1,5)),U,4)="" ;no cert#
.D EP^ABME8REF("EW")
.D WR^ABMUTL8("REF")
;end new code HEAT4158
I $P(ABMB5,"^",11)'="" D
.D EP^ABME8REF("9F")
.D WR^ABMUTL8("REF")
I $P(ABMB5,"^",12)'="" D
.D EP^ABME8REF("G1")
.D WR^ABMUTL8("REF")
I $P(ABMB4,U,9)'="" D
.D EP^ABME8REF("F8")
.D WR^ABMUTL8("REF")
D ^ABMEHGRV
S ABMCHK=0,ABMJ=0
F ABMI=27,37,43 D
.S ABMJ=-1
.S ABMJ=$O(ABMRV(ABMI,ABMJ)) Q:ABMJ="" D
..S ABMK=0
..F S ABMK=$O(ABMRV(ABMI,ABMJ,ABMK)) Q:ABMK="" D
...I $P(ABMRV(ABMI,ABMJ,ABMK),U,2)>79999,($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<90000) S ABMCHK=1
I ABMCHK=1 D
.S ABMCLIA="CLM"
.D EP^ABME8REF("X4","1CLM","1CLM")
.D WR^ABMUTL8("REF")
.K ABMCLIA,ABMCHK
D EP^ABME8REF("EA")
D WR^ABMUTL8("REF")
I $D(^ABMDBILL(DUZ(2),ABMP("BDFN"),61))!($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),10)),U)'="") D
.D EP^ABME8NTE("ADD")
.Q:$TR($G(ABMR("NTE",30))," ")="" ;don't write NTE if no data except spaces
.D WR^ABMUTL8("NTE")
I ABMP("CLIN")="A3" D
.D EP^ABME8CR1
.D WR^ABMUTL8("CR1")
.D EP^ABME8CRC
.D WR^ABMUTL8("CRC")
I $D(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,0)) D
.S ABMSPIEN=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,0))
.Q:+ABMSPIEN=0
.Q:$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABMSPIEN,0)),U,2)=""
.D EP^ABME8CRC
.D WR^ABMUTL8("CRC")
D DXSET^ABMUTL8(ABMP("BDFN"))
D EP^ABME8HI("BZ")
D WR^ABMUTL8("HI")
Q
ABME8L4 ; IHS/ASDST/DMJ - Header
+1 ;;2.6;IHS Third Party Billing;**1,9**;NOV 12, 2009
+2 ;Header Segments
+3 ;
+4 ; IHS/SD/SDR v2.5 p8 - IM12246/IM17548 Added code to put CLIA number REF segment
+5 ; IHS/SD/SDR - v2.5 p8 - task 6 Added code for CR1 and CRC segments (ambulance)
+6 ; IHS/SD/SDR - v2.5 p9 - IM18032 Put Medicaid Resubmission Number as REF*F8
+7 ; IHS/SD/SDR - v2.5 p9 - IM19203 Use Block 19 for NTE segment
+8 ; IHS/SD/SDR - v2.5 p10 - IM20076 Added code for EPSDT CRC segment
+9 ; IHS/SD/SDR - v2.5 p10 - IM20323/IM20433 error <SUBSCR>40+48^ABME8NM1
+10 ; IHS/SD/SDR - v2.5 p10 - IM20395 Split out lines bundled by rev code
+11 ; IHS/SD/SDR - v2.5 p11 - IM21946 Correction to CLIA
+12 ; IHS/SD/SDR - v2.5 p12 - NO IM Added DTP*454 for Init. treatment date
+13 ; IHS/SD/SDR - abm*2.6*1 - HEAT4158 - do REF*EW if mammography
+14 ; IHS/SD/SDR - abm*2.6*1 - HEAT6439 - Added PWK for claim attachments
+15 ; IHS/SD/SDR - 2.6*9 - HEAT39583 - added assumed care and relinquished care dates
+16 ;
START ;START HERE
+1 KILL ABMOUTLB
+2 DO ^ABME8CLM
+3 DO WR^ABMUTL8("CLM")
+4 IF $PIECE(ABMB9,"^",11)
Begin DoDot:1
+5 DO EP^ABME8DTP(304,"D8",$PIECE(ABMB9,"^",11))
+6 DO WR^ABMUTL8("DTP")
End DoDot:1
+7 IF $PIECE(ABMB8,"^",6)
Begin DoDot:1
+8 DO EP^ABME8DTP(431,"D8",$PIECE(ABMB8,"^",6))
+9 DO WR^ABMUTL8("DTP")
End DoDot:1
+10 IF $PIECE(ABMB8,"^",9)
Begin DoDot:1
+11 DO EP^ABME8DTP(438,"D8",$PIECE(ABMB8,"^",9))
+12 DO WR^ABMUTL8("DTP")
End DoDot:1
+13 IF $PIECE(ABMB8,"^",7)
Begin DoDot:1
+14 DO EP^ABME8DTP(454,"D8",$PIECE(ABMB8,"^",7))
+15 DO WR^ABMUTL8("DTP")
End DoDot:1
+16 IF $PIECE(ABMB8,"^",2)
Begin DoDot:1
+17 IF '$PIECE(ABMB8,"^",4)
Begin DoDot:2
+18 DO EP^ABME8DTP(439,"D8",$PIECE(ABMB8,"^",2))
End DoDot:2
+19 IF $PIECE(ABMB8,"^",4)
Begin DoDot:2
+20 DO EP^ABME8DTP(439,"DT",$PIECE(ABMB8,"^",2)_"."_$PIECE(ABMB8,"^",4))
End DoDot:2
+21 DO WR^ABMUTL8("DTP")
End DoDot:1
+22 IF $PIECE(ABMB9,"^",2)
Begin DoDot:1
+23 DO EP^ABME8DTP(296,"D8",$PIECE(ABMB9,"^",2))
+24 DO WR^ABMUTL8("DTP")
End DoDot:1
+25 IF $PIECE(ABMB6,U)
Begin DoDot:1
+26 ;dme billing
IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,4)="Y"&($EXTRACT($GET(ABMP("BTYP")),1,2)'="11")
QUIT
+27 DO EP^ABME8DTP(435,"D8",$PIECE(ABMB6,U))
+28 DO WR^ABMUTL8("DTP")
End DoDot:1
+29 IF $PIECE(ABMB6,"^",3)
Begin DoDot:1
+30 DO EP^ABME8DTP("096","D8",$PIECE(ABMB6,"^",3))
+31 DO WR^ABMUTL8("DTP")
End DoDot:1
+32 ;start new code abm*2.6*9 HEAT39583
+33 IF $PIECE(ABMB7,U,19)
Begin DoDot:1
+34 DO EP^ABME5DTP("090","D8",$PIECE(ABMB7,U,19))
+35 DO WR^ABMUTL8("DTP")
End DoDot:1
+36 IF $PIECE(ABMB7,U,21)
Begin DoDot:1
+37 DO EP^ABME5DTP("091","D8",$PIECE(ABMB7,U,21))
+38 DO WR^ABMUTL8("DTP")
End DoDot:1
+39 ;end new code HEAT39583
+40 ;start new code abm*2.6*1 HEAT6439
+41 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),71))
Begin DoDot:1
+42 KILL ABM71CNT
+43 SET ABM71IEN=0
+44 FOR
SET ABM71IEN=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),71,ABM71IEN))
IF +ABM71IEN=0
QUIT
Begin DoDot:2
+45 DO ^ABME8PWK
DO WR^ABMUTL8("PWK")
+46 SET ABM71CNT=+$GET(ABM71CNT)+1
End DoDot:2
IF $GET(ABM71CNT)=10
QUIT
End DoDot:1
+47 ;end new code HEAT6439
+48 IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,11)'=""
Begin DoDot:1
+49 DO ^ABME8CN1
+50 DO WR^ABMUTL8("CN1")
End DoDot:1
+51 IF $PIECE(ABMB9,"^",9)
Begin DoDot:1
+52 DO EP^ABME8AMT("F5")
+53 DO WR^ABMUTL8("AMT")
End DoDot:1
+54 IF $PIECE(ABMB5,"^",8)'=""
Begin DoDot:1
+55 DO EP^ABME8REF("G4")
+56 DO WR^ABMUTL8("REF")
End DoDot:1
+57 ;start new code abm*2.6*1 HEAT4158
+58 ;mammography
IF ABMP("CLIN")=72
Begin DoDot:1
+59 ;no cert#
IF $PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,5)),U,4)=""
QUIT
+60 DO EP^ABME8REF("EW")
+61 DO WR^ABMUTL8("REF")
End DoDot:1
+62 ;end new code HEAT4158
+63 IF $PIECE(ABMB5,"^",11)'=""
Begin DoDot:1
+64 DO EP^ABME8REF("9F")
+65 DO WR^ABMUTL8("REF")
End DoDot:1
+66 IF $PIECE(ABMB5,"^",12)'=""
Begin DoDot:1
+67 DO EP^ABME8REF("G1")
+68 DO WR^ABMUTL8("REF")
End DoDot:1
+69 IF $PIECE(ABMB4,U,9)'=""
Begin DoDot:1
+70 DO EP^ABME8REF("F8")
+71 DO WR^ABMUTL8("REF")
End DoDot:1
+72 DO ^ABMEHGRV
+73 SET ABMCHK=0
SET ABMJ=0
+74 FOR ABMI=27,37,43
Begin DoDot:1
+75 SET ABMJ=-1
+76 SET ABMJ=$ORDER(ABMRV(ABMI,ABMJ))
IF ABMJ=""
QUIT
Begin DoDot:2
+77 SET ABMK=0
+78 FOR
SET ABMK=$ORDER(ABMRV(ABMI,ABMJ,ABMK))
IF ABMK=""
QUIT
Begin DoDot:3
+79 IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)>79999
IF ($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)<90000)
SET ABMCHK=1
End DoDot:3
End DoDot:2
End DoDot:1
+80 IF ABMCHK=1
Begin DoDot:1
+81 SET ABMCLIA="CLM"
+82 DO EP^ABME8REF("X4","1CLM","1CLM")
+83 DO WR^ABMUTL8("REF")
+84 KILL ABMCLIA,ABMCHK
End DoDot:1
+85 DO EP^ABME8REF("EA")
+86 DO WR^ABMUTL8("REF")
+87 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),61))!($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),10)),U)'="")
Begin DoDot:1
+88 DO EP^ABME8NTE("ADD")
+89 ;don't write NTE if no data except spaces
IF $TRANSLATE($GET(ABMR("NTE",30))," ")=""
QUIT
+90 DO WR^ABMUTL8("NTE")
End DoDot:1
+91 IF ABMP("CLIN")="A3"
Begin DoDot:1
+92 DO EP^ABME8CR1
+93 DO WR^ABMUTL8("CR1")
+94 DO EP^ABME8CRC
+95 DO WR^ABMUTL8("CRC")
End DoDot:1
+96 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,0))
Begin DoDot:1
+97 SET ABMSPIEN=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,0))
+98 IF +ABMSPIEN=0
QUIT
+99 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABMSPIEN,0)),U,2)=""
QUIT
+100 DO EP^ABME8CRC
+101 DO WR^ABMUTL8("CRC")
End DoDot:1
+102 DO DXSET^ABMUTL8(ABMP("BDFN"))
+103 DO EP^ABME8HI("BZ")
+104 DO WR^ABMUTL8("HI")
+105 QUIT
