ABME5L12 ; IHS/ASDST/DMJ - Header
;;2.6;IHS Third Party Billing System;**6,8,9,10,11,22,23,25**;NOV 12, 2009;Build 444
;Header Segments
;IHS/SD/SDR 2.6*22 HEAT335246 check new parameter for itemized but with the flat rate on first line, zeros for the rest
;IHS/SD/AML 2.6*23 HEAT247169 if the subfile is 43 and there's a NDC print segments LIN and CTP for medication
;IHS/SD/SDR 2.6*25 CR10008 commented out code that writes purchased service provider loop; piece 19 of array is used for something else, and we don't
; capture the purchased service provider at this time anyway.
;
EP ;START HERE
S ABMLXCNT=0
K ABM
D ^ABMEHGRV
S ABMITMZ=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",12) ;abm*2.6*22 IHS/SD/SDR HEAT335246
I +ABMITMZ&($P($G(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y")&(+$G(ABMP("FLAT"))'=0) D START^ABMEHGR4 ;abm*2.6*22 IHS/SD/SDR HEAT335246
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
S ABMLOOP=2400
D EP^ABME5LX
D WR^ABMUTL8("LX")
D EP^ABME5SV1
D WR^ABMUTL8("SV1")
I +$P(ABMRV(ABMI,ABMJ,ABMK),U,33) D
.D EP^ABME5SV5
.D WR^ABMUTL8("SV5")
;PWK segment goes here
I $P(ABMRV(ABMI,ABMJ,ABMK),U,10) D
.I $P(ABMRV(ABMI,ABMJ,ABMK),U,27)'="",($P($P(ABMRV(ABMI,ABMJ,ABMK),U,10),".")'=$P($P(ABMRV(ABMI,ABMJ,ABMK),U,27),".")) D EP^ABME5DTP(472,"RD8",$P(ABMRV(ABMI,ABMJ,ABMK),U,10),$P(ABMRV(ABMI,ABMJ,ABMK),U,27))
.E D EP^ABME5DTP(472,"D8",$P(ABMRV(ABMI,ABMJ,ABMK),U,10))
I '$P(ABMRV(ABMI,ABMJ,ABMK),U,10) D
.D EP^ABME5DTP(472,"D8",$P(ABMB7,U))
D WR^ABMUTL8("DTP")
I $P(ABMRV(ABMI,ABMJ,ABMK),U,32)'="" D
.D EP^ABME5DTP(471,"D8",$P(ABMRV(ABMI,ABMJ,ABMK),U,32))
.D WR^ABMUTL8("DTP")
I ABMI=37,$P(ABMRV(ABMI,ABMJ,ABMK),U,34)'="" D
.D EP^ABME5DTP(738,"D8",$P(ABMRV(ABMI,ABMJ,ABMK),U,34))
.D WR^ABMUTL8("DTP")
I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,18)>1 D
.D EP^ABME5QTY("PT")
.D WR^ABMUTL8("QTY")
I ABMI=37 D ;lab multiple
.Q:$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,ABMJ,0)),U,21)="" ;no lab result
.D ^ABME5MEA
.D WR^ABMUTL8("MEA")
;D EP^ABME5REF("6R","") ;line item control number ;abm*2.6*11 HEAT92070
;D WR^ABMUTL8("REF") ;abm*2.6*11 HEAT92070
;start new code abm*2.6*11 HEAT92070
I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,38)'="" D
.D EP^ABME5REF("6R","")
.D WR^ABMUTL8("REF") ;line item control number
;end new code HEAT92070
;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 ;abm*2.6*10 HEAT65066
;I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>77050)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<77060))!$P(ABMRV(ABMI,ABMJ,ABMK),U,2)=76083!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)=76092)!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)="G0202") D ;abm*2.6*10 HEAT65066 ;abm*2.6*11 IHS/SD/AML HEAT95824
I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>77050)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<77060))!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)=76083)!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)=76092)!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)="G0202") D ;abm*2.6*11 IHS/SD/AML HEAT95824
.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))="G0107") D ;abm*2.6*8 HEAT40295
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*8 HEAT40295
.Q:ABMI'=37 ;abm*2.6*10 HEAT73027
.;Q:($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)="") ;abm*2.6*10 HEAT72789 ;abm*2.6*11 HEAT85498
.S ABMCLIA="SV"
.I $G(ABMOUTLB)'=1 D
..;I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)'="",($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)=($P($G(ABMB9),U,22))) Q ;abm*2.6*8 ;abm*2.6*11 HEAT85498
..I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)="" Q ;abm*2.6*11 HEAT85498
..I ($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)=($P($G(ABMB9),U,22))) Q ;abm*2.6*11 HEAT85498
..D EP^ABME5REF("X4","1SV","1SV")
..Q:$G(ABMR("REF",30))="" ;abm*2.6*9 HEAT64640
..D WR^ABMUTL8("REF")
.I $G(ABMOUTLB)=1 D ;if reference lab
..;I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,14)'="",($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,14)=($P($G(ABMB9),U,23))) Q ;abm*2.6*10 HEAT72789
..D EP^ABME5REF("F4",1,1)
..D WR^ABMUTL8("REF")
;D EP^ABME5REF("BT") ;immunization batch number
;D WR^ABMUTL8("REF")
;Loop 2410 - Drug Identification
S ABMLOOP=2410
I ABMI=23 D
.I $P($P(ABMRV(ABMI,ABMJ,ABMK),U,9)," ")'="" D
..D EP^ABME5LIN
..D WR^ABMUTL8("LIN")
.I +$P(ABMRV(ABMI,ABMJ,ABMK),U,5)!($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),0)),U,14)="Y") D ;abm*2.6*22 IHS/SD/SDR HEAT335246
..D EP^ABME5CTP
..D WR^ABMUTL8("CTP")
.;I $P(ABMRV(ABMI,ABMJ,ABMK),U,13)'="" D ;abm*2.6*10 HEAT78446
.I $P(ABMRV(ABMI,ABMJ,ABMK),U,28)'="" D ;abm*2.6*10 HEAT78446
..;D EP^ABME5REF("XZ",$P(ABMRV(ABMI,ABMJ,ABMK),U,13)) ;abm*2.6*10 HEAT78446
..D EP^ABME5REF("XZ",$P(ABMRV(ABMI,ABMJ,ABMK),U,28)) ;abm*2.6*10 HEAT78446
..D WR^ABMUTL8("REF")
;start new abm*2.6*23 IHS/SD/AML HEAT247169
;add NDC for page 8H
I ABMI=43 D
.I $P(ABMRV(ABMI,ABMJ,ABMK),U,19)'="" D
..D EP^ABME5LIN
..D WR^ABMUTL8("LIN")
..D EP^ABME5CTP
..D WR^ABMUTL8("CTP")
;end new abm*2.6*23 IHS/SD/AML HEAT247169
;
; Loop 2420A - Rendering Physician
S ABMLOOP="2420A"
;I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,13) D ;abm*2.6*9 NOHEAT
I ((ABMI'=23&$P($G(ABMRV(ABMI,ABMJ,ABMK)),U,13))!(ABMI=23&$P($G(ABMRV(ABMI,ABMJ,ABMK)),U,22))) D ;abm*2.6*9 NOHEAT
.Q:$G(ABMP("VTYP"))=831&($G(ABMP("ITYPE"))="R") ;don't write provider info for ASC
.Q:$G(ABMP("CLIN"))="A3"
.;S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,13) ;abm*2.6*9 NOHEAT
.S ABM("PRV")=$S(ABMI'=23:$P(ABMRV(ABMI,ABMJ,ABMK),U,13),1:$P(ABMRV(ABMI,ABMJ,ABMK),U,22)) ;abm*2.6*9 NOHEAT
.Q:ABM("PRV")=$O(ABMP("PRV","D",0))
.Q:$D(ABMP("PRV","A",ABM("PRV")))!($D(ABMP("PRV","R",ABM("PRV"))))
.D EP^ABME5NM1(82,ABM("PRV"))
.D WR^ABMUTL8("NM1")
.D EP^ABME5PRV("PE",ABM("PRV"))
.D WR^ABMUTL8("PRV")
.Q:$P($G(^AUTNINS(ABMP("INS"),0)),U)["OKLAHOMA MEDICAID"
.;D EP^ABME5REF("EI",9999999.06,DUZ(2))
.;Q:((ABMRCID="99999")!(ABMRCID="AHCCCS866004791")) ;AZ Medicaid
.;D WR^ABMUTL8("REF")
;
; Loop 2420B - Purchased Service Physician Name
S ABMLOOP="2420B"
;abm*2.6*25 IHS/SD/SDR 12/18/17 - note about below code. Should be changed from p19 since that is being used for something else.
; that is what is causing the error to occur, but we don't capture a purchased service provider at this time.
;I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,19) D ;abm*2.6*25 IHS/SD/SDR CR10008
;.S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,19)
;.Q:ABM("PRV")=$O(ABMP("PRV","P",0))
;.D EP^ABME5NM1("QB",ABM("PRV"))
;.D WR^ABMUTL8("NM1")
;.;D EP^ABME5REF("EI",9999999.06,DUZ(2))
;.;D WR^ABMUTL8("REF")
;
; Loop 2420C - Service Facility Location
S ABMLOOP="2420C"
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^ABME5NM1(77,ABMOTLBN)
..D WR^ABMUTL8("NM1")
..D EP^ABME5N3(9002274.35,ABMOTLBN)
..D WR^ABMUTL8("N3")
..D EP^ABME5N4(9002274.35,ABMOTLBN)
..D WR^ABMUTL8("N4")
;
; Loop 2420D - Supervising Physician Name
S ABMLOOP="2420D"
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^ABME5NM1("DQ",ABM("PRV"))
.D WR^ABMUTL8("NM1")
.;D EP^ABME5REF("EI",9999999.06,DUZ(2))
.;D WR^ABMUTL8("REF")
;
; Loop 2420E - Ordering Physician Name
S ABMLOOP="2420E"
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^ABME5NM1("DK",ABM("PRV"))
.D WR^ABMUTL8("NM1")
.D EP^ABME5N3(200,ABM("PRV"))
.D WR^ABMUTL8("N3")
.D EP^ABME5N4(200,ABM("PRV"))
.D WR^ABMUTL8("N4")
.;D EP^ABME5REF("EI",9999999.06,DUZ(2))
.;D WR^ABMUTL8("REF")
.K ABMLOOP
;
; Loop 2420F Referring Provider Name
S ABMLOOP="2420F"
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^ABME5NM1("DN",ABM("PRV"))
.D WR^ABMUTL8("NM1")
.;D EP^ABME5REF("EI",9999999.06,DUZ(2))
.;D WR^ABMUTL8("REF")
Q
ABME5L12 ; IHS/ASDST/DMJ - Header
+1 ;;2.6;IHS Third Party Billing System;**6,8,9,10,11,22,23,25**;NOV 12, 2009;Build 444
+2 ;Header Segments
+3 ;IHS/SD/SDR 2.6*22 HEAT335246 check new parameter for itemized but with the flat rate on first line, zeros for the rest
+4 ;IHS/SD/AML 2.6*23 HEAT247169 if the subfile is 43 and there's a NDC print segments LIN and CTP for medication
+5 ;IHS/SD/SDR 2.6*25 CR10008 commented out code that writes purchased service provider loop; piece 19 of array is used for something else, and we don't
+6 ; capture the purchased service provider at this time anyway.
+7 ;
EP ;START HERE
+1 SET ABMLXCNT=0
+2 KILL ABM
+3 DO ^ABMEHGRV
+4 ;abm*2.6*22 IHS/SD/SDR HEAT335246
SET ABMITMZ=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),"^",12)
+5 ;abm*2.6*22 IHS/SD/SDR HEAT335246
IF +ABMITMZ&($PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),0)),U,14)="Y")&(+$GET(ABMP("FLAT"))'=0)
DO START^ABMEHGR4
+6 SET ABMI=0
+7 FOR
SET ABMI=$ORDER(ABMRV(ABMI))
IF '+ABMI
QUIT
Begin DoDot:1
+8 SET ABMJ=-1
+9 FOR
SET ABMJ=$ORDER(ABMRV(ABMI,ABMJ))
IF '+ABMJ
QUIT
Begin DoDot:2
+10 SET ABMK=0
+11 FOR
SET ABMK=$ORDER(ABMRV(ABMI,ABMJ,ABMK))
IF '+ABMK
QUIT
Begin DoDot:3
+12 DO LOOP
End DoDot:3
End DoDot:2
End DoDot:1
+13 KILL ABMI,ABMJ,ABMK
+14 QUIT
+15 ;
LOOP ;
+1 SET ABMLXCNT=ABMLXCNT+1
+2 SET ABMLOOP=2400
+3 DO EP^ABME5LX
+4 DO WR^ABMUTL8("LX")
+5 DO EP^ABME5SV1
+6 DO WR^ABMUTL8("SV1")
+7 IF +$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,33)
Begin DoDot:1
+8 DO EP^ABME5SV5
+9 DO WR^ABMUTL8("SV5")
End DoDot:1
+10 ;PWK segment goes here
+11 IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10)
Begin DoDot:1
+12 IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,27)'=""
IF ($PIECE($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10),".")'=$PIECE($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,27),"."))
DO EP^ABME5DTP(472,"RD8",$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10),$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,27))
+13 IF '$TEST
DO EP^ABME5DTP(472,"D8",$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10))
End DoDot:1
+14 IF '$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,10)
Begin DoDot:1
+15 DO EP^ABME5DTP(472,"D8",$PIECE(ABMB7,U))
End DoDot:1
+16 DO WR^ABMUTL8("DTP")
+17 IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,32)'=""
Begin DoDot:1
+18 DO EP^ABME5DTP(471,"D8",$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,32))
+19 DO WR^ABMUTL8("DTP")
End DoDot:1
+20 IF ABMI=37
IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,34)'=""
Begin DoDot:1
+21 DO EP^ABME5DTP(738,"D8",$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,34))
+22 DO WR^ABMUTL8("DTP")
End DoDot:1
+23 IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,18)>1
Begin DoDot:1
+24 DO EP^ABME5QTY("PT")
+25 DO WR^ABMUTL8("QTY")
End DoDot:1
+26 ;lab multiple
IF ABMI=37
Begin DoDot:1
+27 ;no lab result
IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,ABMJ,0)),U,21)=""
QUIT
+28 DO ^ABME5MEA
+29 DO WR^ABMUTL8("MEA")
End DoDot:1
+30 ;D EP^ABME5REF("6R","") ;line item control number ;abm*2.6*11 HEAT92070
+31 ;D WR^ABMUTL8("REF") ;abm*2.6*11 HEAT92070
+32 ;start new code abm*2.6*11 HEAT92070
+33 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,38)'=""
Begin DoDot:1
+34 DO EP^ABME5REF("6R","")
+35 ;line item control number
DO WR^ABMUTL8("REF")
End DoDot:1
+36 ;end new code HEAT92070
+37 ;start new code abm*2.6*8 HEAT31238
+38 ;mammography cert number
+39 ;I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>77050)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<77060)) D ;abm*2.6*10 HEAT65066
+40 ;I (($P(ABMRV(ABMI,ABMJ,ABMK),U,2)>77050)&($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<77060))!$P(ABMRV(ABMI,ABMJ,ABMK),U,2)=76083!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)=76092)!($P(ABMRV(ABMI,ABMJ,ABMK),U,2)="G0202") D ;abm*2.6*10 HEAT65066 ;abm*2.6*11 IHS/SD/AML H
EAT95824
+41 ;abm*2.6*11 IHS/SD/AML HEAT95824
IF (($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)>77050)&($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)<77060))!($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)=76083)!($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)=76092)!($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,2)="G0202")
Begin DoDot:1
+42 ;don't write if clinic is mammography; cert# already written for claim
IF ABMP("CLIN")=72
QUIT
+43 ;no cert#
IF $PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,5)),U,4)=""
QUIT
+44 DO EP^ABME8REF("EW")
+45 DO WR^ABMUTL8("REF")
End DoDot:1
+46 ;end new code HEAT31238
+47 ;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))="G0107") D ;abm*2.6*8 HEAT40295
+48 ;abm*2.6*8 HEAT40295
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
+49 ;abm*2.6*10 HEAT73027
IF ABMI'=37
QUIT
+50 ;Q:($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)="") ;abm*2.6*10 HEAT72789 ;abm*2.6*11 HEAT85498
+51 SET ABMCLIA="SV"
+52 IF $GET(ABMOUTLB)'=1
Begin DoDot:2
+53 ;I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)'="",($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)=($P($G(ABMB9),U,22))) Q ;abm*2.6*8 ;abm*2.6*11 HEAT85498
+54 ;abm*2.6*11 HEAT85498
IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)=""
QUIT
+55 ;abm*2.6*11 HEAT85498
IF ($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,13)=($PIECE($GET(ABMB9),U,22)))
QUIT
+56 DO EP^ABME5REF("X4","1SV","1SV")
+57 ;abm*2.6*9 HEAT64640
IF $GET(ABMR("REF",30))=""
QUIT
+58 DO WR^ABMUTL8("REF")
End DoDot:2
+59 ;if reference lab
IF $GET(ABMOUTLB)=1
Begin DoDot:2
+60 ;I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,14)'="",($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0)),U,14)=($P($G(ABMB9),U,23))) Q ;abm*2.6*10 HEAT72789
+61 DO EP^ABME5REF("F4",1,1)
+62 DO WR^ABMUTL8("REF")
End DoDot:2
End DoDot:1
+63 ;D EP^ABME5REF("BT") ;immunization batch number
+64 ;D WR^ABMUTL8("REF")
+65 ;Loop 2410 - Drug Identification
+66 SET ABMLOOP=2410
+67 IF ABMI=23
Begin DoDot:1
+68 IF $PIECE($PIECE(ABMRV(ABMI,ABMJ,ABMK),U,9)," ")'=""
Begin DoDot:2
+69 DO EP^ABME5LIN
+70 DO WR^ABMUTL8("LIN")
End DoDot:2
+71 ;abm*2.6*22 IHS/SD/SDR HEAT335246
IF +$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,5)!($PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),0)),U,14)="Y")
Begin DoDot:2
+72 DO EP^ABME5CTP
+73 DO WR^ABMUTL8("CTP")
End DoDot:2
+74 ;I $P(ABMRV(ABMI,ABMJ,ABMK),U,13)'="" D ;abm*2.6*10 HEAT78446
+75 ;abm*2.6*10 HEAT78446
IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,28)'=""
Begin DoDot:2
+76 ;D EP^ABME5REF("XZ",$P(ABMRV(ABMI,ABMJ,ABMK),U,13)) ;abm*2.6*10 HEAT78446
+77 ;abm*2.6*10 HEAT78446
DO EP^ABME5REF("XZ",$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,28))
+78 DO WR^ABMUTL8("REF")
End DoDot:2
End DoDot:1
+79 ;start new abm*2.6*23 IHS/SD/AML HEAT247169
+80 ;add NDC for page 8H
+81 IF ABMI=43
Begin DoDot:1
+82 IF $PIECE(ABMRV(ABMI,ABMJ,ABMK),U,19)'=""
Begin DoDot:2
+83 DO EP^ABME5LIN
+84 DO WR^ABMUTL8("LIN")
+85 DO EP^ABME5CTP
+86 DO WR^ABMUTL8("CTP")
End DoDot:2
End DoDot:1
+87 ;end new abm*2.6*23 IHS/SD/AML HEAT247169
+88 ;
+89 ; Loop 2420A - Rendering Physician
+90 SET ABMLOOP="2420A"
+91 ;I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,13) D ;abm*2.6*9 NOHEAT
+92 ;abm*2.6*9 NOHEAT
IF ((ABMI'=23&$PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,13))!(ABMI=23&$PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,22)))
Begin DoDot:1
+93 ;don't write provider info for ASC
IF $GET(ABMP("VTYP"))=831&($GET(ABMP("ITYPE"))="R")
QUIT
+94 IF $GET(ABMP("CLIN"))="A3"
QUIT
+95 ;S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,13) ;abm*2.6*9 NOHEAT
+96 ;abm*2.6*9 NOHEAT
SET ABM("PRV")=$SELECT(ABMI'=23:$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,13),1:$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,22))
+97 IF ABM("PRV")=$ORDER(ABMP("PRV","D",0))
QUIT
+98 IF $DATA(ABMP("PRV","A",ABM("PRV")))!($DATA(ABMP("PRV","R",ABM("PRV"))))
QUIT
+99 DO EP^ABME5NM1(82,ABM("PRV"))
+100 DO WR^ABMUTL8("NM1")
+101 DO EP^ABME5PRV("PE",ABM("PRV"))
+102 DO WR^ABMUTL8("PRV")
+103 IF $PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["OKLAHOMA MEDICAID"
QUIT
+104 ;D EP^ABME5REF("EI",9999999.06,DUZ(2))
+105 ;Q:((ABMRCID="99999")!(ABMRCID="AHCCCS866004791")) ;AZ Medicaid
+106 ;D WR^ABMUTL8("REF")
End DoDot:1
+107 ;
+108 ; Loop 2420B - Purchased Service Physician Name
+109 SET ABMLOOP="2420B"
+110 ;abm*2.6*25 IHS/SD/SDR 12/18/17 - note about below code. Should be changed from p19 since that is being used for something else.
+111 ; that is what is causing the error to occur, but we don't capture a purchased service provider at this time.
+112 ;I $P($G(ABMRV(ABMI,ABMJ,ABMK)),U,19) D ;abm*2.6*25 IHS/SD/SDR CR10008
+113 ;.S ABM("PRV")=$P(ABMRV(ABMI,ABMJ,ABMK),U,19)
+114 ;.Q:ABM("PRV")=$O(ABMP("PRV","P",0))
+115 ;.D EP^ABME5NM1("QB",ABM("PRV"))
+116 ;.D WR^ABMUTL8("NM1")
+117 ;.;D EP^ABME5REF("EI",9999999.06,DUZ(2))
+118 ;.;D WR^ABMUTL8("REF")
+119 ;
+120 ; Loop 2420C - Service Facility Location
+121 SET ABMLOOP="2420C"
+122 ;reference lab
IF $GET(ABMOUTLB)=1
Begin DoDot:1
+123 SET ABMOTLBN=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),ABMI,ABMJ,0),"^",14)
+124 IF $GET(ABMOTLBN)'=""
Begin DoDot:2
+125 DO EP^ABME5NM1(77,ABMOTLBN)
+126 DO WR^ABMUTL8("NM1")
+127 DO EP^ABME5N3(9002274.35,ABMOTLBN)
+128 DO WR^ABMUTL8("N3")
+129 DO EP^ABME5N4(9002274.35,ABMOTLBN)
+130 DO WR^ABMUTL8("N4")
End DoDot:2
End DoDot:1
+131 ;
+132 ; Loop 2420D - Supervising Physician Name
+133 SET ABMLOOP="2420D"
+134 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,20)
Begin DoDot:1
+135 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,20)
+136 IF ABM("PRV")=$ORDER(ABMP("PRV","S",0))
QUIT
+137 DO EP^ABME5NM1("DQ",ABM("PRV"))
+138 DO WR^ABMUTL8("NM1")
+139 ;D EP^ABME5REF("EI",9999999.06,DUZ(2))
+140 ;D WR^ABMUTL8("REF")
End DoDot:1
+141 ;
+142 ; Loop 2420E - Ordering Physician Name
+143 SET ABMLOOP="2420E"
+144 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,21)
Begin DoDot:1
+145 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,21)
+146 ;NOTE:below line was added for patch 10 but removed during testing because site was
+147 ;reporting payer was requiring it
+148 SET ABMLOOP="2420E"
+149 DO EP^ABME5NM1("DK",ABM("PRV"))
+150 DO WR^ABMUTL8("NM1")
+151 DO EP^ABME5N3(200,ABM("PRV"))
+152 DO WR^ABMUTL8("N3")
+153 DO EP^ABME5N4(200,ABM("PRV"))
+154 DO WR^ABMUTL8("N4")
+155 ;D EP^ABME5REF("EI",9999999.06,DUZ(2))
+156 ;D WR^ABMUTL8("REF")
+157 KILL ABMLOOP
End DoDot:1
+158 ;
+159 ; Loop 2420F Referring Provider Name
+160 SET ABMLOOP="2420F"
+161 IF $PIECE($GET(ABMRV(ABMI,ABMJ,ABMK)),U,18)
Begin DoDot:1
+162 SET ABM("PRV")=$PIECE(ABMRV(ABMI,ABMJ,ABMK),U,18)
+163 IF ABM("PRV")=$ORDER(ABMP("PVR","F",0))
QUIT
+164 DO EP^ABME5NM1("DN",ABM("PRV"))
+165 DO WR^ABMUTL8("NM1")
+166 ;D EP^ABME5REF("EI",9999999.06,DUZ(2))
+167 ;D WR^ABMUTL8("REF")
End DoDot:1
+168 QUIT
