ABMDF28Q ; IHS/SD/SDR - PRINT UB-04 ;
;;2.6;IHS Third Party Billing;**27**;NOV 12, 2009;Build 486
;IHS/SD/SDR 2.6*27 CR8897 Split from ABMDF28Y.
;
K I,J,L
S I=0
S ABMFND=0
F S I=$O(ABMRV(I)) Q:'I D Q:ABMFND=1
.S J=-1
.F S J=$O(ABMRV(I,J)) Q:($G(J)="") D Q:ABMFND=1
..I J="T1015" D K ABMRV(I,J)
...S L=0
...F S L=$O(ABMRV(I,J,L)) Q:'L D
....I $P($G(^ABMDVTYP(ABMP("VTYP"),0)),U)["EPSDT",(+$P($G(ABMRV(I,J,L)),U,2)=0) D
....;S $P(ABMRV(I,J,L),U,9)="OUTPATIENT CLINIC" ;abm*2.6*27 IHS/SD/SDR CR8897
....I (($$RCID^ABMUTLP(ABMP("INS"))'["61044")&(ABMP("VTYP")'=142)&(ABMP("BTYP")'=731)) S $P(ABMRV(I,J,L),U,9)="OUTPATIENT CLINIC" ;abm*2.6*27 IHS/SD/SDR CR8897
....S:J'="ZZTOT" ABMRV("ZZTOT")=ABMRV("ZZTOT")+$P(ABMRV(I,J,L),U,6)
....;Grand tot noncov'd chgs
....S:J'="ZZTOT" ABMRV("NCTOT")=ABMRV("NCTOT")+$P(ABMRV(I,J,L),U,7)
....;if not itemized bill & not done, accumulate tots
....I 'ABMITMZ,J'="ZZTOT" D
.....S $P(ABMRV(I,"ZZTOT",1),U)=I ;IEN to REV CODE
.....S:$D(ABMP("CPT")) $P(ABMRV(I,"ZZTOT",1),"^",2)=ABMP("CPT") ;CPT code
.....N K
.....;Accumulate tots per rev code
.....F K=5:1:7 S $P(ABMRV(I,"ZZTOT",1),U,K)=$P(ABMRV(I,"ZZTOT",1),U,K)+$P(ABMRV(I,J,L),U,K)
.....S $P(ABMRV(I,"ZZTOT",1),U,8)=$P(ABMRV(I,J,L),U,8) ;unit chg
.....S $P(ABMRV(I,"ZZTOT",1),U,3)=$P(ABMRV(I,J,L),U,3)
....I 'ABMITMZ,J'="ZZTOT" Q
....I ABMITMZ,J="ZZTOT" Q ;If itemized & done, Q
....W !
....S ABMCTR=ABMCTR+1 ;Cnt items
....;S ABMDE=$$GETREV^ABMDUTL(I)_"^^4R" ;Rev code ;abm*2.6*23 HEAT347035
....S ABMDE=$S(($P(ABMRV(I,J,L),U)'=0):$$GETREV^ABMDUTL($P(ABMRV(I,J,L),U)),1:"")_"^^4R" ;Rev code ;abm*2.6*23 HEAT347035
....I L["." S ABMDE=""
....;I $$RCID^ABMERUTL(ABMP("INS"))'=61004!((ABMP("VDT")>3100630)&($P($G(^AUTNINS(ABMP("INS"),0)),U)="EAPC")) D WRT^ABMDF28W ;#42 ;abm*2.6*4 HEAT12271 ;abm*2.6*21 HEAT268438
....;I $$RCID^ABMERUTL(ABMP("INS"))'["61044"!((ABMP("VDT")>3100630)&($P($G(^AUTNINS(ABMP("INS"),0)),U)="EAPC")) D WRT^ABMDF28W ;#42 ;abm*2.6*21 HEAT268438 ;abm*2.6*23 HEAT347035
....;I (+$P(ABMRV(I,J,L),U,6)'=0) D WRT^ABMDF28W ;abm*2.6*23 IHS/SD/SDR HEAT347035 ;abm*2.6*27 IHS/SD/SDR CR8897
....;start new abm*2.6*27 IHS/SD/SDR CR8897
....I (($$RCID^ABMUTLP(ABMP("INS")))["61044") D
.....I $P(ABMRV(I,J,L),U)=0 Q ;don't do anything if there's no rev code
.....I ((ABMPOS=1)&((ABMP("BTYP")=731)!(ABMP("VTYP")'=142))) S ABMDE=$$GETREV^ABMDUTL($P(ABMRV(I,J,L),U))_"^^4"
.....I '($D(ABMP("FLAT"))&(+$P(ABMRV(I,J,L),U,6)'=0)) S ABMDE=$$GETREV^ABMDUTL($P(ABMRV(I,J,L),U))_"^^4"
.....I (ABMPOS'=1)&(ABMP("BTYP")'=731)&(ABMP("VTYP")'=142) S ABMDE="^^4"
.....I +$G(ABMDIAL)=1 S ABMDE="^^4"
.....D WRT^ABMDF28W
....I ($$RCID^ABMERUTL(ABMP("INS"))'["61044") D WRT^ABMDF28W
....;end new abm*2.6*27 IHS/SD/SDR CR8897
....I ((ABMP("VDT")>3100630)&($P($G(^AUTNINS(ABMP("INS"),0)),U)="EAPC")) D WRT^ABMDF28W ;#42 ;abm*2.6*21 HEAT268438 ;abm*2.6*23 HEAT347035
....;If desc is blank, get it from vtyp in INS file
....I $P(ABMRV(I,J,L),U,9)="" D
.....S ABMDE=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,9)
.....;S:ABMDE="" ABMDE=$P($G(^AUTTREVN(I,0)),U,2) ;std abbrev ;abm*2.6*23 HEAT347035
.....S:ABMDE="" ABMDE=$P($G(^AUTTREVN($P(ABMRV(I,J,L),U),0)),U,2) ;std abbrev ;abm*2.6*23 HEAT347035
.....S ABMDE=ABMDE_"^5^24" ;Desc
.....I (($$RCID^ABMUTLP(ABMP("INS"))["61044")&(+$P(ABMRV(I,J,L),U,6)=0)) S ABMDE="^^5^24" ;don't print description for Medi-Cal when charge amt is 0 ;abm*2.6*23 HEAT347035
.....D WRT^ABMDF28W ;#43
....I $P(ABMRV(I,J,L),U,9)'="" D ;if desc, use it
.....S ABMDE=$P(ABMRV(I,J,L),U,9)_"^5^24" ;Desc
.....I ((+$G(ABMDIAL)=1)&(($$RCID^ABMUTLP(ABMP("INS")))["61044")) S ABMDE="MAINTENANCE DIALYSIS WITH^5^25" ;abm*2.6*21 HEAT240744
.....I (($$RCID^ABMUTLP(ABMP("INS"))["61044")&(+$P(ABMRV(I,J,L),U,6)=0)) S ABMDE="^^5^24" ;don't print description for Medi-Cal when charge amt is 0 ;abm*2.6*23 HEAT347035
.....D WRT^ABMDF28W ;#43
....;
....; HCPCS/rates--#44
....S ABMMODL=$S($P(ABMRV(I,J,L),U,3)]"":$P(ABMRV(I,J,L),U,3),1:"")
....S ABMMODL=ABMMODL_$S($P(ABMRV(I,J,L),U,4)]"":$P(ABMRV(I,J,L),U,4),1:"")
....S ABMMODL=ABMMODL_$S($P(ABMRV(I,J,L),U,12)]"":$P(ABMRV(I,J,L),U,12),1:"")
....S ABMDE=$S($L($P(ABMRV(I,J,L),U,2))>3:$P(ABMRV(I,J,L),U,2)_ABMMODL_"^30^14",$P(ABMRV(I,J,L),U,8)&(+$P(ABMRV(I,J,L),U,2)'=0):$J($P(ABMRV(I,J,L),U,8),1,2)_"^30^14R",+ABMMODL:$J(ABMMODL,1,2)_"^30^14",1:"")
....;make 2-digit CPT print for Medi-Cal
....;I $$RCID^ABMUTLP(ABMP("INS"))["61044" D ;abm*2.6*23 HEAT347035 ;abm*2.6*27 IHS/SD/SDR CR8897
....S ABMCAFLG=0 ;abm*2.6*27 IHS/SD/SDR CR8897
....I $$RCID^ABMUTLP(ABMP("INS"))["61044" D I ABMCAFLG=1 Q ;abm*2.6*27 IHS/SD/SDR CR8897
.....I (ABMP("BTYP")=731)&(ABMP("VTYP")=142) S ABMCAFLG=1 D 23PRT^ABMDF28S ;abm*2.6*27 IHS/SD/SDR CR8897
.....S ABMDE=$S($P(ABMRV(I,J,L),U,2)'="":$P(ABMRV(I,J,L),U,2)_ABMMODL_"^30^14",$P(ABMRV(I,J,L),U,8)&(+$P(ABMRV(I,J,L),U,2)'=0):$J($P(ABMRV(I,J,L),U,8),1,2)_"^30^14R",+ABMMODL:$J(ABMMODL,1,2)_"^30^14",1:"") ;abm*2.6*23 HEAT347035
.....;I (ABMP("BTYP")=731)&(ABMITMZ)&(+$G(ABMCPTM)=0) S ABMDE="^30^14" ;abm*2.6*27 IHS/SD/AML CR8897
....I $P($G(ABMRV(I,J,L)),U,14)'="",($P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,24)="Y") S ABMDE="RX"_$P(ABMRV(I,J,L),U,14)_"^30^9"
....I ABMDE=""&($D(ABMP("FLAT"))!((I>99)&(I<250))) S ABMDE=$J($S($D(ABMP("FLAT")):$P(ABMP("FLAT"),U),1:$P(ABMRV(I,J,L),U,8)),1,2)_"^30^14" ;def flat rate
....I $$RCID^ABMERUTL(ABMP("INS"))=99999&(ABMP("VTYP")=997) S ABMDE=$S(ABMCTR=1:$J($P(ABMP("FLAT"),U),1,2),1:"")_"^30^14" ;abm*2.6*20 HEAT262141
....D WRT^ABMDF28W
....S ABMDE=$$MDY^ABMDUTL($P(ABMRV(I,J,L),U,10))_"^45^6" ;DOS
....D WRT^ABMDF28W ;#45
....S ABMDE=$P(ABMRV(I,J,L),U,5)_"^52^7R" ;Tot units/item
....D WRT^ABMDF28W ;#46
....S ABMDE=$FN($P(ABMRV(I,J,L),U,6),"T",2)
....S ABMDE=$TR(ABMDE,".")_"^61^9R" ;Tot chg per item
....I L["." S ABMDE=""
....D WRT^ABMDF28W ;#47
....S ABMDE=$FN($P(ABMRV(I,J,L),U,7),"T",2)
....I +ABMDE D
.....S ABMDE=$TR(ABMDE,".")_"^71^9R" ;Tot noncover chgs/item
.....D WRT^ABMDF28W ;#48
....;start old abm*2.6*27 IHS/SD/SDR CR8897
....;I $G(ABMRV(I,J,L,1))'="" D Z6004PRT^ABMDF28S ;abm*2.6*21 HEAT240744
....;I $G(ABMRV(I,J,L,1))'="" D 23PRT^ABMDF28S ;abm*2.6*27 IHS/SD/AML CR8897
....;end old start new abm*2.6*27 IHS/SD/SDR CR8897
....I ($$RCID^ABMUTLP(ABMP("INS"))["61044") D
.....I (($P(ABMRV(I,J,L),U,2)="Z6004")&($G(ABMRV(I,J,L,1))'="")&(ABMP("VTYP")'=142)) D Z6004PRT^ABMDF28S
.....;I (ABMP("BTYP")=731)&(ABMP("VTYP")=142) D 23PRT^ABMDF28S
....;
....I ($$RCID^ABMUTLP(ABMP("INS"))["61044")&(+$G(ABMITMZ)) D
.....I ((ABMPOS=1)&(ABMP("BTYP")=731)&(ABMP("VTYP")'=142)) D CALYRTC^ABMDF28S
....;end new abm*2.6*27 IHS/SD/SDR CR8897
...S ABMFND=1
;end new HEAT117086
ABMDF28Q ; IHS/SD/SDR - PRINT UB-04 ;
+1 ;;2.6;IHS Third Party Billing;**27**;NOV 12, 2009;Build 486
+2 ;IHS/SD/SDR 2.6*27 CR8897 Split from ABMDF28Y.
+3 ;
+4 KILL I,J,L
+5 SET I=0
+6 SET ABMFND=0
+7 FOR
SET I=$ORDER(ABMRV(I))
IF 'I
QUIT
Begin DoDot:1
+8 SET J=-1
+9 FOR
SET J=$ORDER(ABMRV(I,J))
IF ($GET(J)="")
QUIT
Begin DoDot:2
+10 IF J="T1015"
Begin DoDot:3
+11 SET L=0
+12 FOR
SET L=$ORDER(ABMRV(I,J,L))
IF 'L
QUIT
Begin DoDot:4
+13 IF $PIECE($GET(^ABMDVTYP(ABMP("VTYP"),0)),U)["EPSDT"
IF (+$PIECE($GET(ABMRV(I,J,L)),U,2)=0)
Begin DoDot:5
End DoDot:5
+14 ;S $P(ABMRV(I,J,L),U,9)="OUTPATIENT CLINIC" ;abm*2.6*27 IHS/SD/SDR CR8897
+15 ;abm*2.6*27 IHS/SD/SDR CR8897
IF (($$RCID^ABMUTLP(ABMP("INS"))'["61044")&(ABMP("VTYP")'=142)&(ABMP("BTYP")'=731))
SET $PIECE(ABMRV(I,J,L),U,9)="OUTPATIENT CLINIC"
+16 IF J'="ZZTOT"
SET ABMRV("ZZTOT")=ABMRV("ZZTOT")+$PIECE(ABMRV(I,J,L),U,6)
+17 ;Grand tot noncov'd chgs
+18 IF J'="ZZTOT"
SET ABMRV("NCTOT")=ABMRV("NCTOT")+$PIECE(ABMRV(I,J,L),U,7)
+19 ;if not itemized bill & not done, accumulate tots
+20 IF 'ABMITMZ
IF J'="ZZTOT"
Begin DoDot:5
+21 ;IEN to REV CODE
SET $PIECE(ABMRV(I,"ZZTOT",1),U)=I
+22 ;CPT code
IF $DATA(ABMP("CPT"))
SET $PIECE(ABMRV(I,"ZZTOT",1),"^",2)=ABMP("CPT")
+23 NEW K
+24 ;Accumulate tots per rev code
+25 FOR K=5:1:7
SET $PIECE(ABMRV(I,"ZZTOT",1),U,K)=$PIECE(ABMRV(I,"ZZTOT",1),U,K)+$PIECE(ABMRV(I,J,L),U,K)
+26 ;unit chg
SET $PIECE(ABMRV(I,"ZZTOT",1),U,8)=$PIECE(ABMRV(I,J,L),U,8)
+27 SET $PIECE(ABMRV(I,"ZZTOT",1),U,3)=$PIECE(ABMRV(I,J,L),U,3)
End DoDot:5
+28 IF 'ABMITMZ
IF J'="ZZTOT"
QUIT
+29 ;If itemized & done, Q
IF ABMITMZ
IF J="ZZTOT"
QUIT
+30 WRITE !
+31 ;Cnt items
SET ABMCTR=ABMCTR+1
+32 ;S ABMDE=$$GETREV^ABMDUTL(I)_"^^4R" ;Rev code ;abm*2.6*23 HEAT347035
+33 ;Rev code ;abm*2.6*23 HEAT347035
SET ABMDE=$SELECT(($PIECE(ABMRV(I,J,L),U)'=0):$$GETREV^ABMDUTL($PIECE(ABMRV(I,J,L),U)),1:"")_"^^4R"
+34 IF L["."
SET ABMDE=""
+35 ;I $$RCID^ABMERUTL(ABMP("INS"))'=61004!((ABMP("VDT")>3100630)&($P($G(^AUTNINS(ABMP("INS"),0)),U)="EAPC")) D WRT^ABMDF28W ;#42 ;abm*2.6*4 HEAT12271 ;abm*2.6*21 HEAT268438
+36 ;I $$RCID^ABMERUTL(ABMP("INS"))'["61044"!((ABMP("VDT")>3100630)&($P($G(^AUTNINS(ABMP("INS"),0)),U)="EAPC")) D WRT^ABMDF28W ;#42 ;abm*2.6*21 HEAT268438 ;abm*2.6*23 HEAT347035
+37 ;I (+$P(ABMRV(I,J,L),U,6)'=0) D WRT^ABMDF28W ;abm*2.6*23 IHS/SD/SDR HEAT347035 ;abm*2.6*27 IHS/SD/SDR CR8897
+38 ;start new abm*2.6*27 IHS/SD/SDR CR8897
+39 IF (($$RCID^ABMUTLP(ABMP("INS")))["61044")
Begin DoDot:5
+40 ;don't do anything if there's no rev code
IF $PIECE(ABMRV(I,J,L),U)=0
QUIT
+41 IF ((ABMPOS=1)&((ABMP("BTYP")=731)!(ABMP("VTYP")'=142)))
SET ABMDE=$$GETREV^ABMDUTL($PIECE(ABMRV(I,J,L),U))_"^^4"
+42 IF '($DATA(ABMP("FLAT"))&(+$PIECE(ABMRV(I,J,L),U,6)'=0))
SET ABMDE=$$GETREV^ABMDUTL($PIECE(ABMRV(I,J,L),U))_"^^4"
+43 IF (ABMPOS'=1)&(ABMP("BTYP")'=731)&(ABMP("VTYP")'=142)
SET ABMDE="^^4"
+44 IF +$GET(ABMDIAL)=1
SET ABMDE="^^4"
+45 DO WRT^ABMDF28W
End DoDot:5
+46 IF ($$RCID^ABMERUTL(ABMP("INS"))'["61044")
DO WRT^ABMDF28W
+47 ;end new abm*2.6*27 IHS/SD/SDR CR8897
+48 ;#42 ;abm*2.6*21 HEAT268438 ;abm*2.6*23 HEAT347035
IF ((ABMP("VDT")>3100630)&($PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)="EAPC"))
DO WRT^ABMDF28W
+49 ;If desc is blank, get it from vtyp in INS file
+50 IF $PIECE(ABMRV(I,J,L),U,9)=""
Begin DoDot:5
+51 SET ABMDE=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,9)
+52 ;S:ABMDE="" ABMDE=$P($G(^AUTTREVN(I,0)),U,2) ;std abbrev ;abm*2.6*23 HEAT347035
+53 ;std abbrev ;abm*2.6*23 HEAT347035
IF ABMDE=""
SET ABMDE=$PIECE($GET(^AUTTREVN($PIECE(ABMRV(I,J,L),U),0)),U,2)
+54 ;Desc
SET ABMDE=ABMDE_"^5^24"
+55 ;don't print description for Medi-Cal when charge amt is 0 ;abm*2.6*23 HEAT347035
IF (($$RCID^ABMUTLP(ABMP("INS"))["61044")&(+$PIECE(ABMRV(I,J,L),U,6)=0))
SET ABMDE="^^5^24"
+56 ;#43
DO WRT^ABMDF28W
End DoDot:5
+57 ;if desc, use it
IF $PIECE(ABMRV(I,J,L),U,9)'=""
Begin DoDot:5
+58 ;Desc
SET ABMDE=$PIECE(ABMRV(I,J,L),U,9)_"^5^24"
+59 ;abm*2.6*21 HEAT240744
IF ((+$GET(ABMDIAL)=1)&(($$RCID^ABMUTLP(ABMP("INS")))["61044"))
SET ABMDE="MAINTENANCE DIALYSIS WITH^5^25"
+60 ;don't print description for Medi-Cal when charge amt is 0 ;abm*2.6*23 HEAT347035
IF (($$RCID^ABMUTLP(ABMP("INS"))["61044")&(+$PIECE(ABMRV(I,J,L),U,6)=0))
SET ABMDE="^^5^24"
+61 ;#43
DO WRT^ABMDF28W
End DoDot:5
+62 ;
+63 ; HCPCS/rates--#44
+64 SET ABMMODL=$SELECT($PIECE(ABMRV(I,J,L),U,3)]"":$PIECE(ABMRV(I,J,L),U,3),1:"")
+65 SET ABMMODL=ABMMODL_$SELECT($PIECE(ABMRV(I,J,L),U,4)]"":$PIECE(ABMRV(I,J,L),U,4),1:"")
+66 SET ABMMODL=ABMMODL_$SELECT($PIECE(ABMRV(I,J,L),U,12)]"":$PIECE(ABMRV(I,J,L),U,12),1:"")
+67 SET ABMDE=$SELECT($LENGTH($PIECE(ABMRV(I,J,L),U,2))>3:$PIECE(ABMRV(I,J,L),U,2)_ABMMODL_"^30^14",$PIECE(ABMRV(I,J,L),U,8)&(+$PIECE(ABMRV(I,J,L),U,2)'=0):$JUSTIFY($PIECE(ABMRV(I,J,L),U,8),1,2)_"^30^14R",+ABMMODL:$J
USTIFY(ABMMODL,1,2)_"^30^14",1:"")
+68 ;make 2-digit CPT print for Medi-Cal
+69 ;I $$RCID^ABMUTLP(ABMP("INS"))["61044" D ;abm*2.6*23 HEAT347035 ;abm*2.6*27 IHS/SD/SDR CR8897
+70 ;abm*2.6*27 IHS/SD/SDR CR8897
SET ABMCAFLG=0
+71 ;abm*2.6*27 IHS/SD/SDR CR8897
IF $$RCID^ABMUTLP(ABMP("INS"))["61044"
Begin DoDot:5
+72 ;abm*2.6*27 IHS/SD/SDR CR8897
IF (ABMP("BTYP")=731)&(ABMP("VTYP")=142)
SET ABMCAFLG=1
DO 23PRT^ABMDF28S
+73 ;abm*2.6*23 HEAT347035
SET ABMDE=$SELECT($PIECE(ABMRV(I,J,L),U,2)'="":$PIECE(ABMRV(I,J,L),U,2)_ABMMODL_"^30^14",$PIECE(ABMRV(I,J,L),U,8)&(+$PIECE(ABMRV(I,J,L),U,2)'=0):$JUSTIFY($PIECE(ABMRV(I,J,L),U,8),1,2)_"^30^14R",+ABMMODL:$
JUSTIFY(ABMMODL,1,2)_"^30^14",1:"")
+74 ;I (ABMP("BTYP")=731)&(ABMITMZ)&(+$G(ABMCPTM)=0) S ABMDE="^30^14" ;abm*2.6*27 IHS/SD/AML CR8897
End DoDot:5
IF ABMCAFLG=1
QUIT
+75 IF $PIECE($GET(ABMRV(I,J,L)),U,14)'=""
IF ($PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,24)="Y")
SET ABMDE="RX"_$PIECE(ABMRV(I,J,L),U,14)_"^30^9"
+76 ;def flat rate
IF ABMDE=""&($DATA(ABMP("FLAT"))!((I>99)&(I<250)))
SET ABMDE=$JUSTIFY($SELECT($DATA(ABMP("FLAT")):$PIECE(ABMP("FLAT"),U),1:$PIECE(ABMRV(I,J,L),U,8)),1,2)_"^30^14"
+77 ;abm*2.6*20 HEAT262141
IF $$RCID^ABMERUTL(ABMP("INS"))=99999&(ABMP("VTYP")=997)
SET ABMDE=$SELECT(ABMCTR=1:$JUSTIFY($PIECE(ABMP("FLAT"),U),1,2),1:"")_"^30^14"
+78 DO WRT^ABMDF28W
+79 ;DOS
SET ABMDE=$$MDY^ABMDUTL($PIECE(ABMRV(I,J,L),U,10))_"^45^6"
+80 ;#45
DO WRT^ABMDF28W
+81 ;Tot units/item
SET ABMDE=$PIECE(ABMRV(I,J,L),U,5)_"^52^7R"
+82 ;#46
DO WRT^ABMDF28W
+83 SET ABMDE=$FNUMBER($PIECE(ABMRV(I,J,L),U,6),"T",2)
+84 ;Tot chg per item
SET ABMDE=$TRANSLATE(ABMDE,".")_"^61^9R"
+85 IF L["."
SET ABMDE=""
+86 ;#47
DO WRT^ABMDF28W
+87 SET ABMDE=$FNUMBER($PIECE(ABMRV(I,J,L),U,7),"T",2)
+88 IF +ABMDE
Begin DoDot:5
+89 ;Tot noncover chgs/item
SET ABMDE=$TRANSLATE(ABMDE,".")_"^71^9R"
+90 ;#48
DO WRT^ABMDF28W
End DoDot:5
+91 ;start old abm*2.6*27 IHS/SD/SDR CR8897
+92 ;I $G(ABMRV(I,J,L,1))'="" D Z6004PRT^ABMDF28S ;abm*2.6*21 HEAT240744
+93 ;I $G(ABMRV(I,J,L,1))'="" D 23PRT^ABMDF28S ;abm*2.6*27 IHS/SD/AML CR8897
+94 ;end old start new abm*2.6*27 IHS/SD/SDR CR8897
+95 IF ($$RCID^ABMUTLP(ABMP("INS"))["61044")
Begin DoDot:5
+96 IF (($PIECE(ABMRV(I,J,L),U,2)="Z6004")&($GET(ABMRV(I,J,L,1))'="")&(ABMP("VTYP")'=142))
DO Z6004PRT^ABMDF28S
+97 ;I (ABMP("BTYP")=731)&(ABMP("VTYP")=142) D 23PRT^ABMDF28S
End DoDot:5
+98 ;
+99 IF ($$RCID^ABMUTLP(ABMP("INS"))["61044")&(+$GET(ABMITMZ))
Begin DoDot:5
+100 IF ((ABMPOS=1)&(ABMP("BTYP")=731)&(ABMP("VTYP")'=142))
DO CALYRTC^ABMDF28S
End DoDot:5
+101 ;end new abm*2.6*27 IHS/SD/SDR CR8897
End DoDot:4
+102 SET ABMFND=1
End DoDot:3
KILL ABMRV(I,J)
End DoDot:2
IF ABMFND=1
QUIT
End DoDot:1
IF ABMFND=1
QUIT
+103 ;end new HEAT117086
