ABMDESMU ; IHS/ASDST/DMJ - Summarized Claim Misc. Info ;
;;2.6;IHS 3P BILLING SYSTEM;**13,23**;NOV 12, 2009;Build 427
;
;IHS/DSD/LSL09/02/98 - Patch 2 - NOIS NDA-0898-180038 0.00 charges on HCFA because version 2.0 does not assume
; 1 for units. Modify code to set units to 1 if not already defined.
;IHS/ASDS/LSL - 07/28/00 - V2.4 Patch 3 - NOIS NDA-0700-180063
; Modified Supply section to quit if the item has been deleted from the Charge Master (Supply) file.
;
;IHS/SD/SDR V2.5 P2 - 5/9/02 - NOIS HQW-0302-100190 - Modified to display 2nd and 3rd modifiers and units
;IHS/SD/SDR v2.5 p5 - 5/18/04 - Modified to put POS and TOS by line item
;IHS/SD/SDR V2.5 P8 - IM10618/IM11164 - Prompt/display provider
;IHS/SD/SDR v2.5 p9 - task 1 - Use new service line provider multiple
;IHS/SD/SDR v2.5 p11 - NPI
;IHS/SD/SDR v2.5 p12 - IM25331 - Add provider taxonomy to CMS-1500 block 24K
;IHS/SD/SDR,AML v2.5 p13 - IM25899 - Alignment changes
;
;IHS/SD/SDR v2.6 CSV
;IHS/SD/SDR 2.6*13 - Added check for new export mode 35
;IHS/SD/AML 2.6*23 HEAT247169 If the export mode is 27 or 35 and there's a NDC print 'N4' and the NDC with the description
;
MISC ;EP for MISC charges
I $G(ABMP("VTYP",993)),'$G(ABMPRINT) Q:ABMP("VTYP",993)'=ABMP("EXP")
S ABMCAT=43 D PCK^ABMDESM1 Q:$G(ABMQUIT)
S ABMX=0 F ABMS("I")=ABMS("I"):1 S ABMX=$O(@(ABMP("GL")_"43,"_ABMX_")")) Q:'ABMX S ABMX("X")=ABMX D MISC1
Q
;
MISC1 S ABMX(0)=@(ABMP("GL")_"43,"_ABMX("X")_",0)")
S ABMZ("UNIT")=$P(ABMX(0),U,3)
S:'+ABMZ("UNIT") ABMZ("UNIT")=1
S ABMX("SUB")=(ABMZ("UNIT")*$P(ABMX(0),U,4))
S ABMS("TOT")=ABMS("TOT")+ABMX("SUB")
I $P(^ABMDEXP(ABMP("EXP"),0),U)'["UB" G MISCH
; ABMS(revn)=Totl Charge^units^Unit Charge^CPT Code
MISCU S ABMX("R")=$P(ABMX(0),U,2) Q:ABMX("R")=""
I $D(ABMS(ABMX("R"))) S $P(ABMS(ABMX("R")),U)=$P(ABMS(ABMX("R")),U)+ABMX("SUB")
E S ABMS(ABMX("R"))=ABMX("SUB")
Q
;
MISCH ;ABMS ARRAY FOR HCFA 1500
; ABMS(#)=Charge^date from^date to^CPT Code^Corr. ICD^units^typ serv^Description
S ABMS(ABMS("I"))=ABMX("SUB")
S ABMCAT=43 D HDT^ABMDESM1
S $P(ABMS(ABMS("I")),"^",5)=$P(ABMX(0),"^",6)
S $P(ABMS(ABMS("I")),U,6)=ABMZ("UNIT")
I $P(ABMX(0),"^",16) D
.S $P(ABMS(ABMS("I")),U,7)=$P($G(^ABMDCODE($P(ABMX(0),"^",16),0)),"^")
E S $P(ABMS(ABMS("I")),U,7)=1
S $P(ABMS(ABMS("I")),U,10)=$P($G(ABMX(0)),"^",15) ;POS
S ABMX("C")=$P(ABMX(0),U) D CPT
S ABMX("C")=$P(ABMX(0),U) D CPT S $P(ABMS(ABMS("I")),U,4)=ABMX("C")_$S($P(ABMX(0),U,5)]"":"-"_$P(ABMX(0),U,5),1:"")_$S($P(ABMX(0),U,8)]"":"-"_$P(ABMX(0),U,8),1:"")_$S($P(ABMX(0),U,9)]"":"-"_$P(ABMX(0),U,9),1:"")
;I ABMP("EXP")=27 D ;abm*2.6*13 export mode 35
I ABMP("EXP")=27!(ABMP("EXP")=35) D ;abm*2.6*13 export mode 35
.S ABMX("C")=$P(ABMX(0),U) D CPT S $P(ABMS(ABMS("I")),U,4)=ABMX("C")_$S($P(ABMX(0),U,5)]"":" "_$P(ABMX(0),U,5),1:"")_$S($P(ABMX(0),U,8)]"":" "_$P(ABMX(0),U,8),1:"")_$S($P(ABMX(0),U,9)]"":" "_$P(ABMX(0),U,9),1:"")
S $P(ABMS(ABMS("I")),U,8)=$P($$CPT^ABMCVAPI(+ABMX(0),ABMP("VDT")),U,3) ;CSV-c
S ABMX(0)=@(ABMP("GL")_"43,"_ABMX("X")_",0)")
S ABMDPRV=$O(@(ABMP("GL")_"43,"_ABMX_",""P"",""C"",""R"",0)"))
S:+ABMDPRV'=0 ABMDPRV=$P($G(@(ABMP("GL")_"43,"_ABMX_",""P"","_ABMDPRV_",0)")),U)
I $G(ABMDPRV)="" S ABMDPRV=$$GETPRV^ABMDFUTL
I +$G(ABMDPRV)'=0 D
.Q:'$$K24^ABMDFUTL
.S $P(ABMS(ABMS("I")),U,9)=$$K24N^ABMDFUTL(ABMDPRV)
.S $P(ABMS(ABMS("I")),U,11)=$P($$NPI^XUSNPI("Individual_ID",ABMDPRV),U)
.I $G(ABMP("NPIS"))="N" S $P(ABMS(ABMS("I")),U,9)=$$PTAX^ABMEEPRV(ABMDPRV)
S $P(ABMS(ABMS("I")),U,19)=$P(ABMX(0),"^",19) ;abm*2.6*23 IHS/SD/AML HEAT247169
I (ABMP("EXP")=27!(ABMP("EXP")=35))&($P(ABMS(ABMS("I")),U,19)'="") S $P(ABMS(ABMS("I")),U,8)="N4"_$P(ABMS(ABMS("I")),U,19)_" "_$P(ABMS(ABMS("I")),U,8) ;abm*2.6*23 IHS/SD/AML HEAT247169
Q
;
REVN ;EP for REVENUE charges
S ABMX("ER")=+$P($G(@(ABMP("GL")_"9)")),U,8) I 'ABMX("ER") Q
S ABMX("REV")=+$P($G(@(ABMP("GL")_"9)")),U,7) I 'ABMX("REV") Q
I $P(^ABMDEXP(ABMP("EXP"),0),U)["UB" S $P(ABMS(ABMX("REV")),U)=$S($D(ABMS(ABMX("REV"))):$P(ABMS(ABMX("REV")),U)+ABMX("ER"),1:ABMX("ER")) G TREVN
S ABMS(ABMS("I"))=ABMX("ER")
S X=$S($P($G(@(ABMP("GL")_"6)")),U)]"":$P(@(ABMP("GL")_"6)"),U),1:$P($G(@(ABMP("GL")_"7)")),U))
S $P(ABMS(ABMS("I")),U,2)=$$HDT^ABMDUTL(X)
S $P(ABMS(ABMS("I")),U,8)=$P(^AUTTREVN(ABMX("REV"),0),U,2)
S ABMS("I")=ABMS("I")+1
TREVN S ABMS("TOT")=ABMS("TOT")+ABMX("ER")
Q
;
ROO ;EP for R&B Charges
I $G(ABMP("VTYP",991)),'$G(ABMPRINT) Q:ABMP("VTYP",991)'=ABMP("EXP")
S ABMCAT=25 D PCK^ABMDESM1 Q:$G(ABMQUIT)
S ABMX=0 F ABMS("I")=ABMS("I"):1 S ABMX=$O(@(ABMP("GL")_"25,"_ABMX_")")) Q:'ABMX S ABMX("X")=ABMX D ROO1
Q
;
ROO1 S ABMX(0)=@(ABMP("GL")_"25,"_ABMX("X")_",0)")
S ABMZ("UNIT")=$P(ABMX(0),U,2)
S:'+ABMZ("UNIT") ABMZ("UNIT")=1
S ABMX("SUB")=(ABMZ("UNIT")*$P(ABMX(0),U,3))
S ABMS("TOT")=ABMS("TOT")+ABMX("SUB")
I $P(^ABMDEXP(ABMP("EXP"),0),U)'["UB" G ROOH
ROOU S ABMX("R")=$P(ABMX(0),U,1)
I $D(ABMS(ABMX("R"))) S $P(ABMS(ABMX("R")),U)=$P(ABMS(ABMX("R")),U)+ABMX("SUB"),$P(ABMS(ABMX("R")),U,2)=$P(ABMS(ABMX("R")),U,2)+ABMZ("UNIT")
E S ABMS(ABMX("R"))=ABMX("SUB")_U_ABMZ("UNIT")_U_$P(ABMX(0),U,3)
Q
;
ROOH S ABMS(ABMS("I"))=ABMX("SUB")
S ABMCAT=25 D HDT^ABMDESM1
S $P(ABMS(ABMS("I")),U,4)="R&B"
S $P(ABMS(ABMS("I")),U,6)=ABMZ("UNIT")
S $P(ABMS(ABMS("I")),U,8)=$P(^AUTTREVN(+ABMX(0),0),U,2)
Q
;
CPT I ABMX("C")]"" S ABMX("C")=$P($$CPT^ABMCVAPI(ABMX("C"),ABMP("VDT")),U,2) ;CSV-c
Q
SUP ;EP - for SUPPLY charges
S ABMCAT=45 D PCK^ABMDESM1 Q:$G(ABMQUIT)
N K S K=+$O(ABMS(99999),-1)
I $G(ABMP("CDFN")) D Q
.N I S I=0 F S I=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),45,I)) Q:'I D
..N J F J=1:1:7 S ABMX(J)=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),45,I,0),"^",J)
..D SSET
I $G(ABMP("BDFN")) D
.N I S I=0 F S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),45,I)) Q:'I D
..N J F J=1:1:7 S ABMX(J)=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),45,I,0),"^",J)
..D SSET
Q
SSET ;SET ABMS ARRAY
Q:'$D(^ABMCM(ABMX(1))) ; Item deleted from supply file
S:'+ABMX(3) ABMX(3)=1
S K=K+1
S:'ABMX(5) ABMX(5)=270
S ABMX("SUB")=ABMX(3)*ABMX(4)
S ABMS("TOT")=+$G(ABMS("TOT"))+ABMX("SUB")
I $P(^ABMDEXP(ABMP("EXP"),0),U)["UB" D SUB Q
S ABMS(K)=ABMX("SUB")
S $P(ABMS(K),"^",2)=$$HDT^ABMDUTL(ABMX(2))
S $P(ABMS(K),"^",3)=$P(ABMS(K),"^",2)
S $P(ABMS(K),"^",4)=$P($$CPT^ABMCVAPI(+ABMX(7),ABMP("VDT")),U,2) ;CSV-c
S $P(ABMS(K),"^",5)=ABMX(6)
S $P(ABMS(K),"^",6)=ABMX(3)
S $P(ABMS(K),"^",7)=9
S $P(ABMS(K),"^",8)=$P(^ABMCM(ABMX(1),0),U)
Q
SUB ;SET ABMS ARRAY FOR UB-92 TYPE FORM
S $P(ABMS(ABMX(5)),U)=+$P($G(ABMS(ABMX(5))),U)+ABMX("SUB")
Q
ABMDESMU ; IHS/ASDST/DMJ - Summarized Claim Misc. Info ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**13,23**;NOV 12, 2009;Build 427
+2 ;
+3 ;IHS/DSD/LSL09/02/98 - Patch 2 - NOIS NDA-0898-180038 0.00 charges on HCFA because version 2.0 does not assume
+4 ; 1 for units. Modify code to set units to 1 if not already defined.
+5 ;IHS/ASDS/LSL - 07/28/00 - V2.4 Patch 3 - NOIS NDA-0700-180063
+6 ; Modified Supply section to quit if the item has been deleted from the Charge Master (Supply) file.
+7 ;
+8 ;IHS/SD/SDR V2.5 P2 - 5/9/02 - NOIS HQW-0302-100190 - Modified to display 2nd and 3rd modifiers and units
+9 ;IHS/SD/SDR v2.5 p5 - 5/18/04 - Modified to put POS and TOS by line item
+10 ;IHS/SD/SDR V2.5 P8 - IM10618/IM11164 - Prompt/display provider
+11 ;IHS/SD/SDR v2.5 p9 - task 1 - Use new service line provider multiple
+12 ;IHS/SD/SDR v2.5 p11 - NPI
+13 ;IHS/SD/SDR v2.5 p12 - IM25331 - Add provider taxonomy to CMS-1500 block 24K
+14 ;IHS/SD/SDR,AML v2.5 p13 - IM25899 - Alignment changes
+15 ;
+16 ;IHS/SD/SDR v2.6 CSV
+17 ;IHS/SD/SDR 2.6*13 - Added check for new export mode 35
+18 ;IHS/SD/AML 2.6*23 HEAT247169 If the export mode is 27 or 35 and there's a NDC print 'N4' and the NDC with the description
+19 ;
MISC ;EP for MISC charges
+1 IF $GET(ABMP("VTYP",993))
IF '$GET(ABMPRINT)
IF ABMP("VTYP",993)'=ABMP("EXP")
QUIT
+2 SET ABMCAT=43
DO PCK^ABMDESM1
IF $GET(ABMQUIT)
QUIT
+3 SET ABMX=0
FOR ABMS("I")=ABMS("I"):1
SET ABMX=$ORDER(@(ABMP("GL")_"43,"_ABMX_")"))
IF 'ABMX
QUIT
SET ABMX("X")=ABMX
DO MISC1
+4 QUIT
+5 ;
MISC1 SET ABMX(0)=@(ABMP("GL")_"43,"_ABMX("X")_",0)")
+1 SET ABMZ("UNIT")=$PIECE(ABMX(0),U,3)
+2 IF '+ABMZ("UNIT")
SET ABMZ("UNIT")=1
+3 SET ABMX("SUB")=(ABMZ("UNIT")*$PIECE(ABMX(0),U,4))
+4 SET ABMS("TOT")=ABMS("TOT")+ABMX("SUB")
+5 IF $PIECE(^ABMDEXP(ABMP("EXP"),0),U)'["UB"
GOTO MISCH
+6 ; ABMS(revn)=Totl Charge^units^Unit Charge^CPT Code
MISCU SET ABMX("R")=$PIECE(ABMX(0),U,2)
IF ABMX("R")=""
QUIT
+1 IF $DATA(ABMS(ABMX("R")))
SET $PIECE(ABMS(ABMX("R")),U)=$PIECE(ABMS(ABMX("R")),U)+ABMX("SUB")
+2 IF '$TEST
SET ABMS(ABMX("R"))=ABMX("SUB")
+3 QUIT
+4 ;
MISCH ;ABMS ARRAY FOR HCFA 1500
+1 ; ABMS(#)=Charge^date from^date to^CPT Code^Corr. ICD^units^typ serv^Description
+2 SET ABMS(ABMS("I"))=ABMX("SUB")
+3 SET ABMCAT=43
DO HDT^ABMDESM1
+4 SET $PIECE(ABMS(ABMS("I")),"^",5)=$PIECE(ABMX(0),"^",6)
+5 SET $PIECE(ABMS(ABMS("I")),U,6)=ABMZ("UNIT")
+6 IF $PIECE(ABMX(0),"^",16)
Begin DoDot:1
+7 SET $PIECE(ABMS(ABMS("I")),U,7)=$PIECE($GET(^ABMDCODE($PIECE(ABMX(0),"^",16),0)),"^")
End DoDot:1
+8 IF '$TEST
SET $PIECE(ABMS(ABMS("I")),U,7)=1
+9 ;POS
SET $PIECE(ABMS(ABMS("I")),U,10)=$PIECE($GET(ABMX(0)),"^",15)
+10 SET ABMX("C")=$PIECE(ABMX(0),U)
DO CPT
+11 SET ABMX("C")=$PIECE(ABMX(0),U)
DO CPT
SET $PIECE(ABMS(ABMS("I")),U,4)=ABMX("C")_$SELECT($PIECE(ABMX(0),U,5)]"":"-"_$PIECE(ABMX(0),U,5),1:"")_$SELECT($PIECE(ABMX(0),U,8)]"":"-"_$PIECE(ABMX(0),U,8),1:"")_$SELECT($PIECE(ABMX(0),U,9)]"":"-"_$PIECE(ABMX(0),U,9),1:"")
+12 ;I ABMP("EXP")=27 D ;abm*2.6*13 export mode 35
+13 ;abm*2.6*13 export mode 35
IF ABMP("EXP")=27!(ABMP("EXP")=35)
Begin DoDot:1
+14 SET ABMX("C")=$PIECE(ABMX(0),U)
DO CPT
SET $PIECE(ABMS(ABMS("I")),U,4)=ABMX("C")_$SELECT($PIECE(ABMX(0),U,5)]"":" "_$PIECE(ABMX(0),U,5),1:"")_$SELECT($PIECE(ABMX(0),U,8)]"":" "_$PIECE(ABMX(0),U,8),1:"")_$SELECT($PIECE(ABMX(0),U,9)]"":" "_$PIECE(ABMX(0),U,9),1:"")
End DoDot:1
+15 ;CSV-c
SET $PIECE(ABMS(ABMS("I")),U,8)=$PIECE($$CPT^ABMCVAPI(+ABMX(0),ABMP("VDT")),U,3)
+16 SET ABMX(0)=@(ABMP("GL")_"43,"_ABMX("X")_",0)")
+17 SET ABMDPRV=$ORDER(@(ABMP("GL")_"43,"_ABMX_",""P"",""C"",""R"",0)"))
+18 IF +ABMDPRV'=0
SET ABMDPRV=$PIECE($GET(@(ABMP("GL")_"43,"_ABMX_",""P"","_ABMDPRV_",0)")),U)
+19 IF $GET(ABMDPRV)=""
SET ABMDPRV=$$GETPRV^ABMDFUTL
+20 IF +$GET(ABMDPRV)'=0
Begin DoDot:1
+21 IF '$$K24^ABMDFUTL
QUIT
+22 SET $PIECE(ABMS(ABMS("I")),U,9)=$$K24N^ABMDFUTL(ABMDPRV)
+23 SET $PIECE(ABMS(ABMS("I")),U,11)=$PIECE($$NPI^XUSNPI("Individual_ID",ABMDPRV),U)
+24 IF $GET(ABMP("NPIS"))="N"
SET $PIECE(ABMS(ABMS("I")),U,9)=$$PTAX^ABMEEPRV(ABMDPRV)
End DoDot:1
+25 ;abm*2.6*23 IHS/SD/AML HEAT247169
SET $PIECE(ABMS(ABMS("I")),U,19)=$PIECE(ABMX(0),"^",19)
+26 ;abm*2.6*23 IHS/SD/AML HEAT247169
IF (ABMP("EXP")=27!(ABMP("EXP")=35))&($PIECE(ABMS(ABMS("I")),U,19)'="")
SET $PIECE(ABMS(ABMS("I")),U,8)="N4"_$PIECE(ABMS(ABMS("I")),U,19)_" "_$PIECE(ABMS(ABMS("I")),U,8)
+27 QUIT
+28 ;
REVN ;EP for REVENUE charges
+1 SET ABMX("ER")=+$PIECE($GET(@(ABMP("GL")_"9)")),U,8)
IF 'ABMX("ER")
QUIT
+2 SET ABMX("REV")=+$PIECE($GET(@(ABMP("GL")_"9)")),U,7)
IF 'ABMX("REV")
QUIT
+3 IF $PIECE(^ABMDEXP(ABMP("EXP"),0),U)["UB"
SET $PIECE(ABMS(ABMX("REV")),U)=$SELECT($DATA(ABMS(ABMX("REV"))):$PIECE(ABMS(ABMX("REV")),U)+ABMX("ER"),1:ABMX("ER"))
GOTO TREVN
+4 SET ABMS(ABMS("I"))=ABMX("ER")
+5 SET X=$SELECT($PIECE($GET(@(ABMP("GL")_"6)")),U)]"":$PIECE(@(ABMP("GL")_"6)"),U),1:$PIECE($GET(@(ABMP("GL")_"7)")),U))
+6 SET $PIECE(ABMS(ABMS("I")),U,2)=$$HDT^ABMDUTL(X)
+7 SET $PIECE(ABMS(ABMS("I")),U,8)=$PIECE(^AUTTREVN(ABMX("REV"),0),U,2)
+8 SET ABMS("I")=ABMS("I")+1
TREVN SET ABMS("TOT")=ABMS("TOT")+ABMX("ER")
+1 QUIT
+2 ;
ROO ;EP for R&B Charges
+1 IF $GET(ABMP("VTYP",991))
IF '$GET(ABMPRINT)
IF ABMP("VTYP",991)'=ABMP("EXP")
QUIT
+2 SET ABMCAT=25
DO PCK^ABMDESM1
IF $GET(ABMQUIT)
QUIT
+3 SET ABMX=0
FOR ABMS("I")=ABMS("I"):1
SET ABMX=$ORDER(@(ABMP("GL")_"25,"_ABMX_")"))
IF 'ABMX
QUIT
SET ABMX("X")=ABMX
DO ROO1
+4 QUIT
+5 ;
ROO1 SET ABMX(0)=@(ABMP("GL")_"25,"_ABMX("X")_",0)")
+1 SET ABMZ("UNIT")=$PIECE(ABMX(0),U,2)
+2 IF '+ABMZ("UNIT")
SET ABMZ("UNIT")=1
+3 SET ABMX("SUB")=(ABMZ("UNIT")*$PIECE(ABMX(0),U,3))
+4 SET ABMS("TOT")=ABMS("TOT")+ABMX("SUB")
+5 IF $PIECE(^ABMDEXP(ABMP("EXP"),0),U)'["UB"
GOTO ROOH
ROOU SET ABMX("R")=$PIECE(ABMX(0),U,1)
+1 IF $DATA(ABMS(ABMX("R")))
SET $PIECE(ABMS(ABMX("R")),U)=$PIECE(ABMS(ABMX("R")),U)+ABMX("SUB")
SET $PIECE(ABMS(ABMX("R")),U,2)=$PIECE(ABMS(ABMX("R")),U,2)+ABMZ("UNIT")
+2 IF '$TEST
SET ABMS(ABMX("R"))=ABMX("SUB")_U_ABMZ("UNIT")_U_$PIECE(ABMX(0),U,3)
+3 QUIT
+4 ;
ROOH SET ABMS(ABMS("I"))=ABMX("SUB")
+1 SET ABMCAT=25
DO HDT^ABMDESM1
+2 SET $PIECE(ABMS(ABMS("I")),U,4)="R&B"
+3 SET $PIECE(ABMS(ABMS("I")),U,6)=ABMZ("UNIT")
+4 SET $PIECE(ABMS(ABMS("I")),U,8)=$PIECE(^AUTTREVN(+ABMX(0),0),U,2)
+5 QUIT
+6 ;
CPT ;CSV-c
IF ABMX("C")]""
SET ABMX("C")=$PIECE($$CPT^ABMCVAPI(ABMX("C"),ABMP("VDT")),U,2)
+1 QUIT
SUP ;EP - for SUPPLY charges
+1 SET ABMCAT=45
DO PCK^ABMDESM1
IF $GET(ABMQUIT)
QUIT
+2 NEW K
SET K=+$ORDER(ABMS(99999),-1)
+3 IF $GET(ABMP("CDFN"))
Begin DoDot:1
+4 NEW I
SET I=0
FOR
SET I=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),45,I))
IF 'I
QUIT
Begin DoDot:2
+5 NEW J
FOR J=1:1:7
SET ABMX(J)=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),45,I,0),"^",J)
+6 DO SSET
End DoDot:2
End DoDot:1
QUIT
+7 IF $GET(ABMP("BDFN"))
Begin DoDot:1
+8 NEW I
SET I=0
FOR
SET I=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),45,I))
IF 'I
QUIT
Begin DoDot:2
+9 NEW J
FOR J=1:1:7
SET ABMX(J)=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),45,I,0),"^",J)
+10 DO SSET
End DoDot:2
End DoDot:1
+11 QUIT
SSET ;SET ABMS ARRAY
+1 ; Item deleted from supply file
IF '$DATA(^ABMCM(ABMX(1)))
QUIT
+2 IF '+ABMX(3)
SET ABMX(3)=1
+3 SET K=K+1
+4 IF 'ABMX(5)
SET ABMX(5)=270
+5 SET ABMX("SUB")=ABMX(3)*ABMX(4)
+6 SET ABMS("TOT")=+$GET(ABMS("TOT"))+ABMX("SUB")
+7 IF $PIECE(^ABMDEXP(ABMP("EXP"),0),U)["UB"
DO SUB
QUIT
+8 SET ABMS(K)=ABMX("SUB")
+9 SET $PIECE(ABMS(K),"^",2)=$$HDT^ABMDUTL(ABMX(2))
+10 SET $PIECE(ABMS(K),"^",3)=$PIECE(ABMS(K),"^",2)
+11 ;CSV-c
SET $PIECE(ABMS(K),"^",4)=$PIECE($$CPT^ABMCVAPI(+ABMX(7),ABMP("VDT")),U,2)
+12 SET $PIECE(ABMS(K),"^",5)=ABMX(6)
+13 SET $PIECE(ABMS(K),"^",6)=ABMX(3)
+14 SET $PIECE(ABMS(K),"^",7)=9
+15 SET $PIECE(ABMS(K),"^",8)=$PIECE(^ABMCM(ABMX(1),0),U)
+16 QUIT
SUB ;SET ABMS ARRAY FOR UB-92 TYPE FORM
+1 SET $PIECE(ABMS(ABMX(5)),U)=+$PIECE($GET(ABMS(ABMX(5))),U)+ABMX("SUB")
+2 QUIT
