Routine: ABMDESMU

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

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")

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

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")

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

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)

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)

CPT I ABMX("C")]"" S ABMX("C")=$P($$CPT^ABMCVAPI(ABMX("C"),ABMP("VDT")),U,2)  ;CSV-c

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

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)

SUB ;SET ABMS ARRAY FOR UB-92 TYPE FORM

 S $P(ABMS(ABMX(5)),U)=+$P($G(ABMS(ABMX(5))),U)+ABMX("SUB")

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

ABMDESMU.m