ABME5L4 ; IHS/ASDST/DMJ - Header
;;2.6;IHS Third Party Billing;**6,8,10,11,13,21**;NOV 12, 2009;Build 379
;Header Segments
;IHS/SD/SDR - 2.6*13 - Added DTP segments for Initial Treatment Date and Acute Manifestation Date
;IHS/SD/SDR - 2.6*21 - HEAT136508 - Made change so CLIA segment would print if lab code started with 'G'
;
START ;START HERE
K ABMOUTLB
S ABMLOOP="2300"
D ^ABME5CLM
D WR^ABMUTL8("CLM")
S ABMP("PDFN")=$P(ABMB0,U,5) ;Patient IEN
;I $P(ABMB8,U,6)'="" D ;onset of current illness or symptom ;abm*2.6*10 HEAT66142
I $P(ABMB8,U,6)'="",($P(ABMB8,U,3)'="") D ;onset of current illness or symptom abm*2.6*10 HEAT66142
.Q:$P(ABMB8,U,6)=$P(ABMB7,U) ;IHS/SD/SDR 5/21/12 HEAT69623
.Q:$P(ABMB8,U,6)=$P(ABMB6,U) ;IHS/SD/AML 6/13/2012
.D EP^ABME5DTP(431,"D8",$P(ABMB8,U,6))
.D WR^ABMUTL8("DTP")
;start new code abm*2.6*13 exp mode 35 (454)
I $P(ABMB8,"^",23) D
.D EP^ABME5DTP(454,"D8",$P(ABMB8,"^",23)) ;Initial Treatment Date
.D WR^ABMUTL8("DTP")
;end new code exp mode 35
;start new code abm*2.6*10 IHS/SD/AML HEAT79778
I $P(ABMB9,"^",11) D
.D EP^ABME5DTP(304,"D8",$P(ABMB9,"^",11)) ;Date last seen
.D WR^ABMUTL8("DTP")
.;end new code abm*2.6*10 IHS/SD/AML HEAT79778
;start new code abm*2.6*13 exp mode 35 (453)
I $P(ABMB7,"^",27) D
.D EP^ABME5DTP(453,"D8",$P(ABMB7,"^",27)) ;Acute Manifestation Date
.D WR^ABMUTL8("DTP")
;end new code exp mode 35
;I $P(ABMB8,U,2) D ;accident ;abm*2.6*10 HEAT66142
I $P(ABMB8,U,2),($P(ABMB8,U,3)'="") D ;accident ;abm*2.6*10 HEAT66142
.D EP^ABME8DTP(439,"D8",$P(ABMB8,U,2))
.D WR^ABMUTL8("DTP") ;abm*2.6*8 HEAT40129 - Write DPT segment if accident occurs
I $D(^ABMDBILL(DUZ(2),ABMP("BDFN"),51)) D
.S ABMP("51IEN")=0,ABMP("LMDT")=""
.F S ABMP("51IEN")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABMP("51IEN"))) Q:'ABMP("51IEN") D Q:($G(ABMP("LMDT"))'="")
..I $P($G(^ABMDCODE($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABMP("51IEN"),0),U),0)),U)=10 D
...S ABMP("LMDT")=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABMP("51IEN"),0)),U,2)
.I $G(ABMP("LMDT"))'="" D
..D EP^ABME5DTP(484,"D8",ABMP("LMDT"))
..D WR^ABMUTL8("DTP")
I $P(ABMB9,U,13)'="" D
.D EP^ABME5DTP(455,"D8",$P(ABMB9,U,13))
.D WR^ABMUTL8("DTP")
I $P(ABMB7,"^",14) D
.D EP^ABME5DTP(471,"D8",$P(ABMB7,"^",14))
.D WR^ABMUTL8("DTP")
I $P(ABMB7,U,15)'=""&($P(ABMB7,U,16)'="") D
.D EP^ABME5DTP(314,"RD8",$P(ABMB7,U,15),$P(ABMB7,U,16))
.D WR^ABMUTL8("DTP")
I $P(ABMB7,U,15)'=""&($P(ABMB7,U,16)="") D
.D EP^ABME5DTP(360,"D8",$P(ABMB7,U,15))
.D WR^ABMUTL8("DTP")
I $P(ABMB7,U,15)=""&($P(ABMB7,U,16)'="") D
.D EP^ABME5DTP(361,"D8",$P(ABMB7,U,16))
.D WR^ABMUTL8("DTP")
I $P(ABMB7,U,17) D
.D EP^ABME5DTP(297,"D8",$P(ABMB7,U,17))
.D WR^ABMUTL8("DTP")
I $P(ABMB7,U,18) D
.D EP^ABME5DTP(296,"D8",$P(ABMB7,U,18))
.D WR^ABMUTL8("DTP")
I $P(ABMB6,U),($E(ABMP("BTYP"),1,2)=11) 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),($E(ABMP("BTYP"),1,2)=11) D
.D EP^ABME8DTP("096","D8",$P(ABMB6,"^",3))
.D WR^ABMUTL8("DTP")
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")
I $P(ABMB7,U,22) D
.D EP^ABME5DTP(444,"D8",$P(ABMB7,U,22))
.D WR^ABMUTL8("DTP")
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
I $P(ABMB7,U,23) D
.D EP^ABME5AMT("F5")
.D WR^ABMUTL8("AMT")
I ABMP("CLIN")=72 D ;mammography
.Q:$P($G(^ABMDPARM(ABMP("LDFN"),1,5)),U,4)="" ;no cert#
.D EP^ABME5REF("EW")
.D WR^ABMUTL8("REF")
I $P(ABMB5,U,11)'="" D
.D EP^ABME5REF("9F")
.D WR^ABMUTL8("REF")
I $P(ABMB5,U,12)'="" D
.D EP^ABME5REF("G1")
.D WR^ABMUTL8("REF")
I $P(ABMB4,U,9)'="" D
.D EP^ABME5REF("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 ;abm*2.6*21 IHS/SD/SDR HEAT136508
...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") S ABMCHK=1 ;abm*2.6*21 IHS/SD/SDR HEAT136508
I ABMCHK=1 D
.S ABMCLIA="CLM"
.D EP^ABME5REF("X4","1CLM","1CLM")
.D WR^ABMUTL8("REF")
.K ABMCLIA,ABMCHK
D EP^ABME5REF("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^ABME5NTE("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^ABME5CR1
.D WR^ABMUTL8("CR1")
I $P(ABMB7,U,24)'="" D
.D EP^ABME5CR2
.D WR^ABMUTL8("CR2")
;ambulance certification
I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,15)="Y",($D(^ABMDBILL(DUZ(2),ABMP("BDFN"),14))) D
.D EP^ABME5CRC("AMB")
.D WR^ABMUTL8("CRC")
;patient condition info:vision
I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,21)'="" D
.D EP^ABME5CRC("VIS")
.D WR^ABMUTL8("CRC")
;EPSDT Referral
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^ABME5CRC("EPSDT")
.D WR^ABMUTL8("CRC")
;health care diagnosis code
D DXSET^ABMUTL8(ABMP("BDFN"))
;D EP^ABME5HI("BZ")
D EP^ABME5HI("BK")
D WR^ABMUTL8("HI")
;anesthesia related procedure
D ANES^ABMUTL8(ABMP("BDFN"))
D EP^ABME5HI("BP")
D WR^ABMUTL8("HI")
;condition information
;start old code abm*2.6*11 NOHEAT4
;D CDSET^ABMUTL8(ABMP("BDFN"))
;D EP^ABME8HI("BG")
;D WR^ABMUTL8("HI")
;end old code NOHEAT4
Q
ABME5L4 ; IHS/ASDST/DMJ - Header
+1 ;;2.6;IHS Third Party Billing;**6,8,10,11,13,21**;NOV 12, 2009;Build 379
+2 ;Header Segments
+3 ;IHS/SD/SDR - 2.6*13 - Added DTP segments for Initial Treatment Date and Acute Manifestation Date
+4 ;IHS/SD/SDR - 2.6*21 - HEAT136508 - Made change so CLIA segment would print if lab code started with 'G'
+5 ;
START ;START HERE
+1 KILL ABMOUTLB
+2 SET ABMLOOP="2300"
+3 DO ^ABME5CLM
+4 DO WR^ABMUTL8("CLM")
+5 ;Patient IEN
SET ABMP("PDFN")=$PIECE(ABMB0,U,5)
+6 ;I $P(ABMB8,U,6)'="" D ;onset of current illness or symptom ;abm*2.6*10 HEAT66142
+7 ;onset of current illness or symptom abm*2.6*10 HEAT66142
IF $PIECE(ABMB8,U,6)'=""
IF ($PIECE(ABMB8,U,3)'="")
Begin DoDot:1
+8 ;IHS/SD/SDR 5/21/12 HEAT69623
IF $PIECE(ABMB8,U,6)=$PIECE(ABMB7,U)
QUIT
+9 ;IHS/SD/AML 6/13/2012
IF $PIECE(ABMB8,U,6)=$PIECE(ABMB6,U)
QUIT
+10 DO EP^ABME5DTP(431,"D8",$PIECE(ABMB8,U,6))
+11 DO WR^ABMUTL8("DTP")
End DoDot:1
+12 ;start new code abm*2.6*13 exp mode 35 (454)
+13 IF $PIECE(ABMB8,"^",23)
Begin DoDot:1
+14 ;Initial Treatment Date
DO EP^ABME5DTP(454,"D8",$PIECE(ABMB8,"^",23))
+15 DO WR^ABMUTL8("DTP")
End DoDot:1
+16 ;end new code exp mode 35
+17 ;start new code abm*2.6*10 IHS/SD/AML HEAT79778
+18 IF $PIECE(ABMB9,"^",11)
Begin DoDot:1
+19 ;Date last seen
DO EP^ABME5DTP(304,"D8",$PIECE(ABMB9,"^",11))
+20 DO WR^ABMUTL8("DTP")
+21 ;end new code abm*2.6*10 IHS/SD/AML HEAT79778
End DoDot:1
+22 ;start new code abm*2.6*13 exp mode 35 (453)
+23 IF $PIECE(ABMB7,"^",27)
Begin DoDot:1
+24 ;Acute Manifestation Date
DO EP^ABME5DTP(453,"D8",$PIECE(ABMB7,"^",27))
+25 DO WR^ABMUTL8("DTP")
End DoDot:1
+26 ;end new code exp mode 35
+27 ;I $P(ABMB8,U,2) D ;accident ;abm*2.6*10 HEAT66142
+28 ;accident ;abm*2.6*10 HEAT66142
IF $PIECE(ABMB8,U,2)
IF ($PIECE(ABMB8,U,3)'="")
Begin DoDot:1
+29 DO EP^ABME8DTP(439,"D8",$PIECE(ABMB8,U,2))
+30 ;abm*2.6*8 HEAT40129 - Write DPT segment if accident occurs
DO WR^ABMUTL8("DTP")
End DoDot:1
+31 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),51))
Begin DoDot:1
+32 SET ABMP("51IEN")=0
SET ABMP("LMDT")=""
+33 FOR
SET ABMP("51IEN")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABMP("51IEN")))
IF 'ABMP("51IEN")
QUIT
Begin DoDot:2
+34 IF $PIECE($GET(^ABMDCODE($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABMP("51IEN"),0),U),0)),U)=10
Begin DoDot:3
+35 SET ABMP("LMDT")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABMP("51IEN"),0)),U,2)
End DoDot:3
End DoDot:2
IF ($GET(ABMP("LMDT"))'="")
QUIT
+36 IF $GET(ABMP("LMDT"))'=""
Begin DoDot:2
+37 DO EP^ABME5DTP(484,"D8",ABMP("LMDT"))
+38 DO WR^ABMUTL8("DTP")
End DoDot:2
End DoDot:1
+39 IF $PIECE(ABMB9,U,13)'=""
Begin DoDot:1
+40 DO EP^ABME5DTP(455,"D8",$PIECE(ABMB9,U,13))
+41 DO WR^ABMUTL8("DTP")
End DoDot:1
+42 IF $PIECE(ABMB7,"^",14)
Begin DoDot:1
+43 DO EP^ABME5DTP(471,"D8",$PIECE(ABMB7,"^",14))
+44 DO WR^ABMUTL8("DTP")
End DoDot:1
+45 IF $PIECE(ABMB7,U,15)'=""&($PIECE(ABMB7,U,16)'="")
Begin DoDot:1
+46 DO EP^ABME5DTP(314,"RD8",$PIECE(ABMB7,U,15),$PIECE(ABMB7,U,16))
+47 DO WR^ABMUTL8("DTP")
End DoDot:1
+48 IF $PIECE(ABMB7,U,15)'=""&($PIECE(ABMB7,U,16)="")
Begin DoDot:1
+49 DO EP^ABME5DTP(360,"D8",$PIECE(ABMB7,U,15))
+50 DO WR^ABMUTL8("DTP")
End DoDot:1
+51 IF $PIECE(ABMB7,U,15)=""&($PIECE(ABMB7,U,16)'="")
Begin DoDot:1
+52 DO EP^ABME5DTP(361,"D8",$PIECE(ABMB7,U,16))
+53 DO WR^ABMUTL8("DTP")
End DoDot:1
+54 IF $PIECE(ABMB7,U,17)
Begin DoDot:1
+55 DO EP^ABME5DTP(297,"D8",$PIECE(ABMB7,U,17))
+56 DO WR^ABMUTL8("DTP")
End DoDot:1
+57 IF $PIECE(ABMB7,U,18)
Begin DoDot:1
+58 DO EP^ABME5DTP(296,"D8",$PIECE(ABMB7,U,18))
+59 DO WR^ABMUTL8("DTP")
End DoDot:1
+60 IF $PIECE(ABMB6,U)
IF ($EXTRACT(ABMP("BTYP"),1,2)=11)
Begin DoDot:1
+61 ;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
+62 DO EP^ABME8DTP(435,"D8",$PIECE(ABMB6,U))
+63 DO WR^ABMUTL8("DTP")
End DoDot:1
+64 IF $PIECE(ABMB6,"^",3)
IF ($EXTRACT(ABMP("BTYP"),1,2)=11)
Begin DoDot:1
+65 DO EP^ABME8DTP("096","D8",$PIECE(ABMB6,"^",3))
+66 DO WR^ABMUTL8("DTP")
End DoDot:1
+67 IF $PIECE(ABMB7,U,19)
Begin DoDot:1
+68 DO EP^ABME5DTP("090","D8",$PIECE(ABMB7,U,19))
+69 DO WR^ABMUTL8("DTP")
End DoDot:1
+70 IF $PIECE(ABMB7,U,21)
Begin DoDot:1
+71 DO EP^ABME5DTP("091","D8",$PIECE(ABMB7,U,21))
+72 DO WR^ABMUTL8("DTP")
End DoDot:1
+73 IF $PIECE(ABMB7,U,22)
Begin DoDot:1
+74 DO EP^ABME5DTP(444,"D8",$PIECE(ABMB7,U,22))
+75 DO WR^ABMUTL8("DTP")
End DoDot:1
+76 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),71))
Begin DoDot:1
+77 KILL ABM71CNT
+78 SET ABM71IEN=0
+79 FOR
SET ABM71IEN=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),71,ABM71IEN))
IF +ABM71IEN=0
QUIT
Begin DoDot:2
+80 DO ^ABME8PWK
DO WR^ABMUTL8("PWK")
+81 SET ABM71CNT=+$GET(ABM71CNT)+1
End DoDot:2
IF $GET(ABM71CNT)=10
QUIT
End DoDot:1
+82 IF $PIECE(ABMB7,U,23)
Begin DoDot:1
+83 DO EP^ABME5AMT("F5")
+84 DO WR^ABMUTL8("AMT")
End DoDot:1
+85 ;mammography
IF ABMP("CLIN")=72
Begin DoDot:1
+86 ;no cert#
IF $PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,5)),U,4)=""
QUIT
+87 DO EP^ABME5REF("EW")
+88 DO WR^ABMUTL8("REF")
End DoDot:1
+89 IF $PIECE(ABMB5,U,11)'=""
Begin DoDot:1
+90 DO EP^ABME5REF("9F")
+91 DO WR^ABMUTL8("REF")
End DoDot:1
+92 IF $PIECE(ABMB5,U,12)'=""
Begin DoDot:1
+93 DO EP^ABME5REF("G1")
+94 DO WR^ABMUTL8("REF")
End DoDot:1
+95 IF $PIECE(ABMB4,U,9)'=""
Begin DoDot:1
+96 DO EP^ABME5REF("F8")
+97 DO WR^ABMUTL8("REF")
End DoDot:1
+98 DO ^ABMEHGRV
+99 SET ABMCHK=0
SET ABMJ=0
+100 FOR ABMI=27,37,43
Begin DoDot:1
+101 SET ABMJ=-1
+102 SET ABMJ=$ORDER(ABMRV(ABMI,ABMJ))
IF ABMJ=""
QUIT
Begin DoDot:2
+103 SET ABMK=0
+104 FOR
SET ABMK=$ORDER(ABMRV(ABMI,ABMJ,ABMK))
IF ABMK=""
QUIT
Begin DoDot:3
+105 ;I $P(ABMRV(ABMI,ABMJ,ABMK),U,2)>79999,($P(ABMRV(ABMI,ABMJ,ABMK),U,2)<90000) S ABMCHK=1 ;abm*2.6*21 IHS/SD/SDR HEAT136508
+106 ;abm*2.6*21 IHS/SD/SDR HEAT136508
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")
SET ABMCHK=1
End DoDot:3
End DoDot:2
End DoDot:1
+107 IF ABMCHK=1
Begin DoDot:1
+108 SET ABMCLIA="CLM"
+109 DO EP^ABME5REF("X4","1CLM","1CLM")
+110 DO WR^ABMUTL8("REF")
+111 KILL ABMCLIA,ABMCHK
End DoDot:1
+112 DO EP^ABME5REF("EA")
+113 DO WR^ABMUTL8("REF")
+114 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),61))!($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),10)),U)'="")
Begin DoDot:1
+115 DO EP^ABME5NTE("ADD")
+116 ;don't write NTE if no data except spaces
IF $TRANSLATE($GET(ABMR("NTE",30))," ")=""
QUIT
+117 DO WR^ABMUTL8("NTE")
End DoDot:1
+118 IF ABMP("CLIN")="A3"
Begin DoDot:1
+119 DO EP^ABME5CR1
+120 DO WR^ABMUTL8("CR1")
End DoDot:1
+121 IF $PIECE(ABMB7,U,24)'=""
Begin DoDot:1
+122 DO EP^ABME5CR2
+123 DO WR^ABMUTL8("CR2")
End DoDot:1
+124 ;ambulance certification
+125 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,15)="Y"
IF ($DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),14)))
Begin DoDot:1
+126 DO EP^ABME5CRC("AMB")
+127 DO WR^ABMUTL8("CRC")
End DoDot:1
+128 ;patient condition info:vision
+129 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U,21)'=""
Begin DoDot:1
+130 DO EP^ABME5CRC("VIS")
+131 DO WR^ABMUTL8("CRC")
End DoDot:1
+132 ;EPSDT Referral
+133 IF $DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,0))
Begin DoDot:1
+134 SET ABMSPIEN=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,0))
+135 IF +ABMSPIEN=0
QUIT
+136 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABMSPIEN,0)),U,2)=""
QUIT
+137 DO EP^ABME5CRC("EPSDT")
+138 DO WR^ABMUTL8("CRC")
End DoDot:1
+139 ;health care diagnosis code
+140 DO DXSET^ABMUTL8(ABMP("BDFN"))
+141 ;D EP^ABME5HI("BZ")
+142 DO EP^ABME5HI("BK")
+143 DO WR^ABMUTL8("HI")
+144 ;anesthesia related procedure
+145 DO ANES^ABMUTL8(ABMP("BDFN"))
+146 DO EP^ABME5HI("BP")
+147 DO WR^ABMUTL8("HI")
+148 ;condition information
+149 ;start old code abm*2.6*11 NOHEAT4
+150 ;D CDSET^ABMUTL8(ABMP("BDFN"))
+151 ;D EP^ABME8HI("BG")
+152 ;D WR^ABMUTL8("HI")
+153 ;end old code NOHEAT4
+154 QUIT
