ABMDTFEE ; IHS/SD/SDR - Table Maintenance of 3P CODES ;
;;2.6;IHS Third Party Billing;**1,2,21,27**;NOV 12, 2009;Build 486
;
;IHS/SD/SDR 2.6 CSV
;IHS/SD/SDR 2.6*1 NO HEAT - Populate owner of table
;IHS/SD/SDR 2.6*2 3PMS10003A - populate new effective dates multiple
;IHS/SD/SDR 2.6*21 HEAT135354 Fix so when CPT selected the effective fee, if there is one, will display; was just printing a dash, no description, and 0.00 for the fee no matter what was entered.
;IHS/SD/SDR 2.6*27 CR8894 Fixed so short descriptions and fees will print if ?? typed at any prompt. Fixed how entries were getting filed to use new
; DINUM methodology. It requires codes to be hardset into global and then edited.
;
S U="^" W !
FEE K DIC
S DIC="^ABMDFEE(",DIC(0)="QEAML"
S DIC("A")="Select FEE SCHEDULE: "
S:$P($G(^ABMDPARM(DUZ(2),1,0)),U,9)]"" DIC("B")=$P(^(0),U,9)
S DIC("S")="I DUZ(2)=$P($G(^ABMDFEE(X,0)),""^"",4)"
;S DIC("DR")=".02;.04////"_DUZ(2) ;abm*2.6*1 NO HEAT ;abm*2.6*27 IHS/SD/SDR CR8894
S DIC("DR")=".02;.06////C;.04////"_DUZ(2) ;abm*2.6*1 NO HEAT ;abm*2.6*27 IHS/SD/SDR CR8894
D ^DIC
G XIT:$D(DUOUT)!$D(DTOUT)
I +Y<1 G FEE
S ABM("FEE")=+Y
SEL W !!,"----- FEE SCHEDULE CATEGORIES -----",!
S DIR(0)="SO^1:MEDICAL FEES;2:SURGICAL FEES;3:RADIOLOGY FEES;4:LABORATORY FEES;5:ANESTHESIA FEES;6:DENTAL FEES;7:REVENUE CODE;8:HCPCS FEES;9:DRUG FEES;10:CHARGE MASTER"
S DIR("A")="Select Desired CATEGORY"
D ^DIR K DIR
G XIT:$D(DIROUT)!$D(DIRUT)
S ABM=+Y
;
S ABM("SUB")=$S(ABM=1:19,ABM=2:11,ABM=3:15,ABM=4:17,ABM=5:23,ABM=6:21,ABM=7:31,ABM=8:13,ABM=9:25,ABM=10:32)
EDIT ;
;start old abm*2.6*27 IHS/SD/SDR CR8894
;K DIC ;abm*2.6*2 3PMS10003A moved EDIT tag to here
;S DA(1)=ABM("FEE")
;;S (DIC,DIE)="^ABMDFEE("_DA(1)_","_ABM("SUB")_"," ;abm*2.6*2 3PMS10003A
;S DIC="^ABMDFEE("_DA(1)_","_ABM("SUB")_"," ;abm*2.6*2 3PMS10003A
;S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002274.01"_ABM("SUB")_"P"
;S ABM("DICS")=9002274.01_ABM("SUB") X:$D(^DD(ABM("DICS"),.01,12.1)) ^DD(ABM("DICS"),.01,12.1)
;;start old code abm*2.6*2 3PMS10003A
;;I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($G(^ABMDFEE(DA(1),31,Y,0)),U,2),"","",2),9)"
;;I ABM=6 S DIC("W")="W "" - "",$P($G(^AUTTADA(Y,0)),U,2),?65,$J($FN($P($G(^ABMDFEE(DA(1),21,Y,0)),U,2),"","",2),9)"
;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($G(^ABMDFEE(DA(1),ABM(""SUB""),Y,0)),U,2),"","",2),9)" ;CSV-c
;;S DR=".02"
;;end old code start new code 3PMS10003A
;I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),31,Y,DT),U),"","",2),9)"
;;I ABM=6 S DIC("W")="W "" - "",$P($G(^AUTTADA(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)" ;abm*2.6*27 IHS/SD/SDR CR8894
;I ABM=6 S DIC("W")="S ABMR(""CODE"")=$E(Y,2,5) W "" - "",$E($P($G(^AUTTADA($P(^ABMDFEE(DA(1),21,Y,0),U),0)),U,2),1,45),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)" ;abm*2.6*27 IHS/SD/SDR CR8894
;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)" ;CSV-c ;abm*2.6*21 IHS/SD/SDR HEAT135354
;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(X,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),$P($$CPT^ABMCVAPI(X,DT),U),DT),U),"","",2),9)" ;CSV-c ;abm*2.6*21 IHS/SD/SDR HEAT135354 ;abm*2.6*27 IHS/SD/SDR CR8894
;;start new abm*2.6*27 IHS/SD/SDR CR8894
;I "123458"[ABM D
;.S DIC("W")=" W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),$P($$CPT^ABMCVAPI(Y,DT),U),DT),U),"","",2),9)"
;I ABM=9 S DIC("W")="W ?50,$P($G(^PSDRUG(Y,2)),U,4),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
;I ABM=10 S DIC("W")="W ?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
;;end new abm*2.6*27 IHS/SD/SDR CR8894
;;end new code 3PMS10003A
;;
;W !! ;abm*2.6*2 3PMS10003A removed EDIT tag from here
;S DIC(0)="QLEAM"
;D ^DIC K DIC
;
;end old start new abm*2.6*27 IHS/SD/SDR CR8894
;
K DIC ;abm*2.6*2 3PMS10003A moved EDIT tag to here
S DIC="^ICPT("
I "^6^7^9^10^"[("^"_ABM_"^") D
.S DA(1)=ABM("FEE")
.S DIC="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
.I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),31,Y,DT),U),"","",2),9)"
.I ABM=6 S DIC("W")="S ABMR(""CODE"")=$E(Y,2,5) W "" - "",$E($P($G(^AUTTADA($P(^ABMDFEE(DA(1),21,Y,0),U),0)),U,2),1,45),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)"
.I ABM=9 S DIC("W")="W ?50,$P($G(^PSDRUG(Y,2)),U,4),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
.I ABM=10 S DIC("W")="W ?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
;
S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002274.01"_ABM("SUB")_"P"
S ABM("DICS")=9002274.01_ABM("SUB") X:$D(^DD(ABM("DICS"),.01,12.1)) ^DD(ABM("DICS"),.01,12.1)
;
W !!
S DIC(0)="QEAMI"
I "^6^7^9^10^"[("^"_ABM_"^") S DIC(0)="QLEAM"
D ^DIC K DIC
;end new abm*2.6*27 IHS/SD/SDR CR8894
;
G SEL:X=""!$D(DUOUT)!$D(DTOUT)
;
;start new abm*2.6*27 IHS/SD/SDR CR8894
I "123458"[(ABM) D
.S X=$TR(X," ")
.S ABMCODE=$$DINUM^ABMFOFS($P(Y,U,2))
.I '$D(^ABMDFEE(ABM("FEE"),ABM("SUB"),ABMCODE)) D
..S ^ABMDFEE(ABM("FEE"),ABM("SUB"),ABMCODE,0)=+Y
..S ^ABMDFEE(ABM("FEE"),ABM("SUB"),"C",ABMCODE,+Y)=""
..S ^ABMDFEE(ABM("FEE"),ABM("SUB"),"B",+Y,ABMCODE)=""
;
I "123458"[ABM D
.;W !,ABMCODE," - ",$E($P($$CPT^ABMCVAPI(+Y,DT),U,3),1,55),?65,$J($FN($P($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),+Y,DT),U),",",2),9)
.W !,X," - ",$E($P($$CPT^ABMCVAPI(+Y,DT),U,3),1,55),?65,$J($FN($P($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),+Y,DT),U),",",2),9)
;end new abm*2.6*27 IHS/SD/SDR CR8894
;
I +Y<1 G EDIT
;start old code 3PMS10003A
;S DA=+Y
;S ABM("LDATE")=$P(^ABMDFEE(DA(1),ABM("SUB"),DA,0),U,3)
;S:ABM("SUB")=21 ABM("LDATE")=$P(^(0),U,4)
;I ABM("LDATE") W !,"Last Updated: ",$$SDT^ABMDUTL(ABM("LDATE"))
;end old code start new code 3PMS10003A
EFFDT ;
;S ABMCODE=+Y ;abm*2.6*27 IHS/SD/SDR CR8894
I "^6^7^9^10^"[("^"_ABM_"^") S ABMCODE=+Y ;abm*2.6*27 IHS/SD/SDR CR8894
D ^XBFMK
S DA(2)=ABM("FEE")
S DA(1)=ABMCODE
S DIC="^ABMDFEE("_DA(2)_","_ABM("SUB")_","_DA(1)_",1,"
S DIC(0)="AELQ"
S DIC("P")=$P(^DD(9002274.01_ABM("SUB"),1,0),U,2)
D ^DIC
I $D(DTOUT)!$D(DUOUT) G EDIT ;abm*2.6*2
I Y<0 W "?? EFFECTIVE DATE REQUIRED" G EFFDT ;abm*2.6*2
S ABMENTRY=+Y
D ^XBFMK
S DA(2)=ABM("FEE")
S DA(1)=ABMCODE
S DIE="^ABMDFEE("_DA(2)_","_ABM("SUB")_","_DA(1)_",1,"
S DA=ABMENTRY
S DR=".02//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U)
;start old abm*2.6*27 IHS/SD/SDR CR8894
;S DR=DR_";.03//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,2)
;S DR=DR_";.04//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,3)
;end old start new abm*2.6*27 IHS/SD/SDR CR8894
S DR=DR_";.03//"_+$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,2)
S DR=DR_";.04//"_+$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,3)
;end new abm*2.6*27 IHS/SD/SDR CR8894
S DR=DR_";.05////"_DT_";.06////"_DUZ
;end new code 3PMS10003A
W !
D ^ABMDDIE
;start new code abm*2.6*2 3PMS10003A
D ^XBFMK
S DA(1)=ABM("FEE")
S DIE="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
S DA=ABMCODE
S DR=".02////"_$P($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),ABMCODE,DT),U)
D ^DIE
;this next part populates the UPDATE multiple
D ^XBFMK
S DA(1)=ABM("FEE")
S DIC="^ABMDFEE("_DA(1)_",1,"
S DIC(0)="MQL"
S DIC("P")=$P(^DD(9002274.01,1,0),U,2)
D NOW^%DTC
S X=%
S DIC("DR")=".02////"_DUZ
D ^DIC
;end new code 3PMS10003A
;start new abm*2.6*27 IHS/SD/SDR CR8894
S DA(1)=ABM("FEE")
S DA=ABMCODE
S DIK="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
D IX^DIK
;end new abm*2.6*27 IHS/SD/SDR CR8894
G EDIT
;
XIT K ABM,DIR,DIC,DIE
Q
ABMDTFEE ; IHS/SD/SDR - Table Maintenance of 3P CODES ;
+1 ;;2.6;IHS Third Party Billing;**1,2,21,27**;NOV 12, 2009;Build 486
+2 ;
+3 ;IHS/SD/SDR 2.6 CSV
+4 ;IHS/SD/SDR 2.6*1 NO HEAT - Populate owner of table
+5 ;IHS/SD/SDR 2.6*2 3PMS10003A - populate new effective dates multiple
+6 ;IHS/SD/SDR 2.6*21 HEAT135354 Fix so when CPT selected the effective fee, if there is one, will display; was just printing a dash, no description, and 0.00 for the fee no matter what was entered.
+7 ;IHS/SD/SDR 2.6*27 CR8894 Fixed so short descriptions and fees will print if ?? typed at any prompt. Fixed how entries were getting filed to use new
+8 ; DINUM methodology. It requires codes to be hardset into global and then edited.
+9 ;
+10 SET U="^"
WRITE !
FEE KILL DIC
+1 SET DIC="^ABMDFEE("
SET DIC(0)="QEAML"
+2 SET DIC("A")="Select FEE SCHEDULE: "
+3 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,0)),U,9)]""
SET DIC("B")=$PIECE(^(0),U,9)
+4 SET DIC("S")="I DUZ(2)=$P($G(^ABMDFEE(X,0)),""^"",4)"
+5 ;S DIC("DR")=".02;.04////"_DUZ(2) ;abm*2.6*1 NO HEAT ;abm*2.6*27 IHS/SD/SDR CR8894
+6 ;abm*2.6*1 NO HEAT ;abm*2.6*27 IHS/SD/SDR CR8894
SET DIC("DR")=".02;.06////C;.04////"_DUZ(2)
+7 DO ^DIC
+8 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO XIT
+9 IF +Y<1
GOTO FEE
+10 SET ABM("FEE")=+Y
SEL WRITE !!,"----- FEE SCHEDULE CATEGORIES -----",!
+1 SET DIR(0)="SO^1:MEDICAL FEES;2:SURGICAL FEES;3:RADIOLOGY FEES;4:LABORATORY FEES;5:ANESTHESIA FEES;6:DENTAL FEES;7:REVENUE CODE;8:HCPCS FEES;9:DRUG FEES;10:CHARGE MASTER"
+2 SET DIR("A")="Select Desired CATEGORY"
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DIROUT)!$DATA(DIRUT)
GOTO XIT
+5 SET ABM=+Y
+6 ;
+7 SET ABM("SUB")=$SELECT(ABM=1:19,ABM=2:11,ABM=3:15,ABM=4:17,ABM=5:23,ABM=6:21,ABM=7:31,ABM=8:13,ABM=9:25,ABM=10:32)
EDIT ;
+1 ;start old abm*2.6*27 IHS/SD/SDR CR8894
+2 ;K DIC ;abm*2.6*2 3PMS10003A moved EDIT tag to here
+3 ;S DA(1)=ABM("FEE")
+4 ;;S (DIC,DIE)="^ABMDFEE("_DA(1)_","_ABM("SUB")_"," ;abm*2.6*2 3PMS10003A
+5 ;S DIC="^ABMDFEE("_DA(1)_","_ABM("SUB")_"," ;abm*2.6*2 3PMS10003A
+6 ;S:'$D(@(DIC_"0)")) @(DIC_"0)")="^9002274.01"_ABM("SUB")_"P"
+7 ;S ABM("DICS")=9002274.01_ABM("SUB") X:$D(^DD(ABM("DICS"),.01,12.1)) ^DD(ABM("DICS"),.01,12.1)
+8 ;;start old code abm*2.6*2 3PMS10003A
+9 ;;I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($G(^ABMDFEE(DA(1),31,Y,0)),U,2),"","",2),9)"
+10 ;;I ABM=6 S DIC("W")="W "" - "",$P($G(^AUTTADA(Y,0)),U,2),?65,$J($FN($P($G(^ABMDFEE(DA(1),21,Y,0)),U,2),"","",2),9)"
+11 ;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($G(^ABMDFEE(DA(1),ABM(""SUB""),Y,0)),U,2),"","",2),9)" ;CSV-c
+12 ;;S DR=".02"
+13 ;;end old code start new code 3PMS10003A
+14 ;I ABM=7 S DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),31,Y,DT),U),"","",2),9)"
+15 ;;I ABM=6 S DIC("W")="W "" - "",$P($G(^AUTTADA(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)" ;abm*2.6*27 IHS/SD/SDR CR8894
+16 ;I ABM=6 S DIC("W")="S ABMR(""CODE"")=$E(Y,2,5) W "" - "",$E($P($G(^AUTTADA($P(^ABMDFEE(DA(1),21,Y,0),U),0)),U,2),1,45),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)" ;abm*2.6*27 IHS/SD/SDR CR8894
+17 ;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)" ;CSV-c ;abm*2.6*21 IHS/SD/SDR HEAT135354
+18 ;;I "123458"[ABM S DIC("W")="W "" - "",$P($$CPT^ABMCVAPI(X,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),$P($$CPT^ABMCVAPI(X,DT),U),DT),U),"","",2),9)" ;CSV-c ;abm*2.6*21 IHS/SD/SDR HEAT135354 ;abm*2.6*27 IHS/SD/SDR CR8894
+19 ;;start new abm*2.6*27 IHS/SD/SDR CR8894
+20 ;I "123458"[ABM D
+21 ;.S DIC("W")=" W "" - "",$P($$CPT^ABMCVAPI(Y,DT),U,3),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),$P($$CPT^ABMCVAPI(Y,DT),U),DT),U),"","",2),9)"
+22 ;I ABM=9 S DIC("W")="W ?50,$P($G(^PSDRUG(Y,2)),U,4),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
+23 ;I ABM=10 S DIC("W")="W ?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
+24 ;;end new abm*2.6*27 IHS/SD/SDR CR8894
+25 ;;end new code 3PMS10003A
+26 ;;
+27 ;W !! ;abm*2.6*2 3PMS10003A removed EDIT tag from here
+28 ;S DIC(0)="QLEAM"
+29 ;D ^DIC K DIC
+30 ;
+31 ;end old start new abm*2.6*27 IHS/SD/SDR CR8894
+32 ;
+33 ;abm*2.6*2 3PMS10003A moved EDIT tag to here
KILL DIC
+34 SET DIC="^ICPT("
+35 IF "^6^7^9^10^"[("^"_ABM_"^")
Begin DoDot:1
+36 SET DA(1)=ABM("FEE")
+37 SET DIC="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
+38 IF ABM=7
SET DIC("W")="W "" - "",$P($G(^AUTTREVN(Y,0)),U,2),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),31,Y,DT),U),"","",2),9)"
+39 IF ABM=6
SET DIC("W")="S ABMR(""CODE"")=$E(Y,2,5) W "" - "",$E($P($G(^AUTTADA($P(^ABMDFEE(DA(1),21,Y,0),U),0)),U,2),1,45),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),21,Y,DT),U),"","",2),9)"
+40 IF ABM=9
SET DIC("W")="W ?50,$P($G(^PSDRUG(Y,2)),U,4),?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
+41 IF ABM=10
SET DIC("W")="W ?65,$J($FN($P($$ONE^ABMFEAPI(DA(1),ABM(""SUB""),Y,DT),U),"","",2),9)"
End DoDot:1
+42 ;
+43 IF '$DATA(@(DIC_"0)"))
SET @(DIC_"0)")="^9002274.01"_ABM("SUB")_"P"
+44 SET ABM("DICS")=9002274.01_ABM("SUB")
IF $DATA(^DD(ABM("DICS"),.01,12.1))
XECUTE ^DD(ABM("DICS"),.01,12.1)
+45 ;
+46 WRITE !!
+47 SET DIC(0)="QEAMI"
+48 IF "^6^7^9^10^"[("^"_ABM_"^")
SET DIC(0)="QLEAM"
+49 DO ^DIC
KILL DIC
+50 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+51 ;
+52 IF X=""!$DATA(DUOUT)!$DATA(DTOUT)
GOTO SEL
+53 ;
+54 ;start new abm*2.6*27 IHS/SD/SDR CR8894
+55 IF "123458"[(ABM)
Begin DoDot:1
+56 SET X=$TRANSLATE(X," ")
+57 SET ABMCODE=$$DINUM^ABMFOFS($PIECE(Y,U,2))
+58 IF '$DATA(^ABMDFEE(ABM("FEE"),ABM("SUB"),ABMCODE))
Begin DoDot:2
+59 SET ^ABMDFEE(ABM("FEE"),ABM("SUB"),ABMCODE,0)=+Y
+60 SET ^ABMDFEE(ABM("FEE"),ABM("SUB"),"C",ABMCODE,+Y)=""
+61 SET ^ABMDFEE(ABM("FEE"),ABM("SUB"),"B",+Y,ABMCODE)=""
End DoDot:2
End DoDot:1
+62 ;
+63 IF "123458"[ABM
Begin DoDot:1
+64 ;W !,ABMCODE," - ",$E($P($$CPT^ABMCVAPI(+Y,DT),U,3),1,55),?65,$J($FN($P($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),+Y,DT),U),",",2),9)
+65 WRITE !,X," - ",$EXTRACT($PIECE($$CPT^ABMCVAPI(+Y,DT),U,3),1,55),?65,$JUSTIFY($FNUMBER($PIECE($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),+Y,DT),U),",",2),9)
End DoDot:1
+66 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+67 ;
+68 IF +Y<1
GOTO EDIT
+69 ;start old code 3PMS10003A
+70 ;S DA=+Y
+71 ;S ABM("LDATE")=$P(^ABMDFEE(DA(1),ABM("SUB"),DA,0),U,3)
+72 ;S:ABM("SUB")=21 ABM("LDATE")=$P(^(0),U,4)
+73 ;I ABM("LDATE") W !,"Last Updated: ",$$SDT^ABMDUTL(ABM("LDATE"))
+74 ;end old code start new code 3PMS10003A
EFFDT ;
+1 ;S ABMCODE=+Y ;abm*2.6*27 IHS/SD/SDR CR8894
+2 ;abm*2.6*27 IHS/SD/SDR CR8894
IF "^6^7^9^10^"[("^"_ABM_"^")
SET ABMCODE=+Y
+3 DO ^XBFMK
+4 SET DA(2)=ABM("FEE")
+5 SET DA(1)=ABMCODE
+6 SET DIC="^ABMDFEE("_DA(2)_","_ABM("SUB")_","_DA(1)_",1,"
+7 SET DIC(0)="AELQ"
+8 SET DIC("P")=$PIECE(^DD(9002274.01_ABM("SUB"),1,0),U,2)
+9 DO ^DIC
+10 ;abm*2.6*2
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EDIT
+11 ;abm*2.6*2
IF Y<0
WRITE "?? EFFECTIVE DATE REQUIRED"
GOTO EFFDT
+12 SET ABMENTRY=+Y
+13 DO ^XBFMK
+14 SET DA(2)=ABM("FEE")
+15 SET DA(1)=ABMCODE
+16 SET DIE="^ABMDFEE("_DA(2)_","_ABM("SUB")_","_DA(1)_",1,"
+17 SET DA=ABMENTRY
+18 SET DR=".02//"_$PIECE($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U)
+19 ;start old abm*2.6*27 IHS/SD/SDR CR8894
+20 ;S DR=DR_";.03//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,2)
+21 ;S DR=DR_";.04//"_$P($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,3)
+22 ;end old start new abm*2.6*27 IHS/SD/SDR CR8894
+23 SET DR=DR_";.03//"_+$PIECE($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,2)
+24 SET DR=DR_";.04//"_+$PIECE($$ONE^ABMFEAPI(DA(2),ABM("SUB"),ABMCODE,DT),U,3)
+25 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+26 SET DR=DR_";.05////"_DT_";.06////"_DUZ
+27 ;end new code 3PMS10003A
+28 WRITE !
+29 DO ^ABMDDIE
+30 ;start new code abm*2.6*2 3PMS10003A
+31 DO ^XBFMK
+32 SET DA(1)=ABM("FEE")
+33 SET DIE="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
+34 SET DA=ABMCODE
+35 SET DR=".02////"_$PIECE($$ONE^ABMFEAPI(ABM("FEE"),ABM("SUB"),ABMCODE,DT),U)
+36 DO ^DIE
+37 ;this next part populates the UPDATE multiple
+38 DO ^XBFMK
+39 SET DA(1)=ABM("FEE")
+40 SET DIC="^ABMDFEE("_DA(1)_",1,"
+41 SET DIC(0)="MQL"
+42 SET DIC("P")=$PIECE(^DD(9002274.01,1,0),U,2)
+43 DO NOW^%DTC
+44 SET X=%
+45 SET DIC("DR")=".02////"_DUZ
+46 DO ^DIC
+47 ;end new code 3PMS10003A
+48 ;start new abm*2.6*27 IHS/SD/SDR CR8894
+49 SET DA(1)=ABM("FEE")
+50 SET DA=ABMCODE
+51 SET DIK="^ABMDFEE("_DA(1)_","_ABM("SUB")_","
+52 DO IX^DIK
+53 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+54 GOTO EDIT
+55 ;
XIT KILL ABM,DIR,DIC,DIE
+1 QUIT
