- 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
