Routine: ABME8L4

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

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

ABME8L4.m