ABMDTASC ; IHS/ASDST/DMJ - UPDATE ASC FEE TABLE ;
;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009
; IHS/SD/SDR - v2.5 p9 - IM12137 - Added code to put group 9 prompts in
; IHS/SD/SDR - v2.6 CSV
; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to populated effective dates
;
START ;START
W !!,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")
W " We recommend doing a global save of global ^ABMDFEE before proceeding.",!!
S DIC="^ABMDFEE(",DIC(0)="AEMNQ"
S DIC("A")="Enter the Number of your ASC Fee Schedule: "
S DIC("B")=2
D ^DIC K DIC
Q:+Y<0 S ABMJ=+Y
D CURRATE
D RATE
Q:$D(DUOUT)!$D(DTOUT)
S $P(ABMEQ,"=",80)=""
W !!,ABMEQ,!
F ABMI=1:1:9 W !,"Rate for ASC Payment Group ",ABMI,": $",ABM(ABMI)
S DIR(0)="Y"
S DIR("A")="Continue"
S DIR("B")="NO"
D ^DIR K DIR
Q:Y'=1
;start new code abm*2.6*2 3PMS10003A
D ^XBFMK
S DIR(0)="D"
S DIR("A")="What is the effective date? "
S DIR("B")="TODAY"
D ^DIR K DIR
Q:$D(DIRUT)
S ABMEDT=Y
;end new code 3PMS10003A
D LOOP
K ABMPG,ABMEQ
;start new code abm*2.6*2 3PMS10003A
D ^XBFMK
S DA(1)=ABMJ
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_";.06////Y"
D ^DIC
;end new code 3PMS10003A
W !!,"Finished.",!!
S DIR(0)="E" D ^DIR K DIR
Q
CURRATE ;
S ABMI=9999
F S ABMI=$O(^ICPT(ABMI)) Q:ABMI>69999 D
.S ABMPG=$P($$IHSCPT^ABMCVAPI(ABMI,""),U,6) ;CSV-c
.Q:'ABMPG
.Q:ABMPG>9
.Q:'$D(^ABMDFEE(ABMJ,11,ABMI,0))
.S ABMRATE(+ABMPG)=$P($G(^ABMDFEE(ABMJ,11,ABMI,0)),U,2)
W !!,"CURRENT RATES"
F ABMI=1:1:9 W !,?3,"Rate for ASC Payment Group ",ABMI,":$",+$G(ABMRATE(ABMI))
W !
K ABMRATE
Q
RATE ;ENTER RATES FOR THE ASC PAYMENT GROUPS
K DUOUT,DTOUT
S DIR(0)="N"
W !,"NEW RATES"
F ABMI=1:1:9 D Q:$D(DUOUT)!$D(DTOUT)
.S DIR("A")="Enter Rate for ASC Payment Group #"_ABMI
.D ^DIR
.Q:$D(DUOUT)!$D(DTOUT)
.S ABM(ABMI)=Y
K DIR
Q
LOOP ;LOOP THROUGH CPT SURGERY
S ABMI=9999
F S ABMI=$O(^ICPT(ABMI)) Q:ABMI>69999 D
.S ABMPG=$P($$IHSCPT^ABMCVAPI(ABMI,""),U,6) ;CSV-c
.Q:'ABMPG
.Q:ABMPG>9
.;I '$D(^ABMDFEE(ABMJ,11,ABMI,0)) D NEW Q:+Y<0 ;abm*2.6*2 3PMS10003A
.I '$D(^ABMDFEE(ABMJ,11,ABMI,0)) D NEW ;abm*2.6*2 3PMS10003A
.S $P(^ABMDFEE(ABMJ,11,ABMI,0),U,2)=ABM(+ABMPG)
.D EFFDT ;abm*2.6*2 3PMS10003A
.W "."
Q
NEW ;NEW ENTRY IN FEE TABLE
S ^ABMDFEE(ABMJ,11,ABMI,0)=ABMI
S ^ABMDFEE(ABMJ,11,"B",ABMI,ABMI)=""
Q
;start new code abm*2.6*2 3PMS10003A
EFFDT ;
D ^XBFMK
S DA(2)=ABMJ
S DA(1)=ABMI
S DIC="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"
S DIC(0)="L"
S DIC("P")=$P(^DD(9002274.0111,1,0),U,2)
S X=ABMEDT
D ^DIC
S ABMENTRY=+Y
D ^XBFMK
S DA(2)=ABMJ
S DA(1)=ABMI
S DIE="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"
S DA=ABMENTRY
S DR=".02////"_ABM(+ABMPG)
S DR=DR_";.05////"_DT_";.06////"_DUZ
D ^DIE
Q
;end new code 3PMS10003A
ABMDTASC ; IHS/ASDST/DMJ - UPDATE ASC FEE TABLE ;
+1 ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009
+2 ; IHS/SD/SDR - v2.5 p9 - IM12137 - Added code to put group 9 prompts in
+3 ; IHS/SD/SDR - v2.6 CSV
+4 ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to populated effective dates
+5 ;
START ;START
+1 WRITE !!,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")
+2 WRITE " We recommend doing a global save of global ^ABMDFEE before proceeding.",!!
+3 SET DIC="^ABMDFEE("
SET DIC(0)="AEMNQ"
+4 SET DIC("A")="Enter the Number of your ASC Fee Schedule: "
+5 SET DIC("B")=2
+6 DO ^DIC
KILL DIC
+7 IF +Y<0
QUIT
SET ABMJ=+Y
+8 DO CURRATE
+9 DO RATE
+10 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+11 SET $PIECE(ABMEQ,"=",80)=""
+12 WRITE !!,ABMEQ,!
+13 FOR ABMI=1:1:9
WRITE !,"Rate for ASC Payment Group ",ABMI,": $",ABM(ABMI)
+14 SET DIR(0)="Y"
+15 SET DIR("A")="Continue"
+16 SET DIR("B")="NO"
+17 DO ^DIR
KILL DIR
+18 IF Y'=1
QUIT
+19 ;start new code abm*2.6*2 3PMS10003A
+20 DO ^XBFMK
+21 SET DIR(0)="D"
+22 SET DIR("A")="What is the effective date? "
+23 SET DIR("B")="TODAY"
+24 DO ^DIR
KILL DIR
+25 IF $DATA(DIRUT)
QUIT
+26 SET ABMEDT=Y
+27 ;end new code 3PMS10003A
+28 DO LOOP
+29 KILL ABMPG,ABMEQ
+30 ;start new code abm*2.6*2 3PMS10003A
+31 DO ^XBFMK
+32 SET DA(1)=ABMJ
+33 SET DIC="^ABMDFEE("_DA(1)_",1,"
+34 SET DIC(0)="MQL"
+35 SET DIC("P")=$PIECE(^DD(9002274.01,1,0),U,2)
+36 DO NOW^%DTC
+37 SET X=%
+38 SET DIC("DR")=".02////"_DUZ_";.06////Y"
+39 DO ^DIC
+40 ;end new code 3PMS10003A
+41 WRITE !!,"Finished.",!!
+42 SET DIR(0)="E"
DO ^DIR
KILL DIR
+43 QUIT
CURRATE ;
+1 SET ABMI=9999
+2 FOR
SET ABMI=$ORDER(^ICPT(ABMI))
IF ABMI>69999
QUIT
Begin DoDot:1
+3 ;CSV-c
SET ABMPG=$PIECE($$IHSCPT^ABMCVAPI(ABMI,""),U,6)
+4 IF 'ABMPG
QUIT
+5 IF ABMPG>9
QUIT
+6 IF '$DATA(^ABMDFEE(ABMJ,11,ABMI,0))
QUIT
+7 SET ABMRATE(+ABMPG)=$PIECE($GET(^ABMDFEE(ABMJ,11,ABMI,0)),U,2)
End DoDot:1
+8 WRITE !!,"CURRENT RATES"
+9 FOR ABMI=1:1:9
WRITE !,?3,"Rate for ASC Payment Group ",ABMI,":$",+$GET(ABMRATE(ABMI))
+10 WRITE !
+11 KILL ABMRATE
+12 QUIT
RATE ;ENTER RATES FOR THE ASC PAYMENT GROUPS
+1 KILL DUOUT,DTOUT
+2 SET DIR(0)="N"
+3 WRITE !,"NEW RATES"
+4 FOR ABMI=1:1:9
Begin DoDot:1
+5 SET DIR("A")="Enter Rate for ASC Payment Group #"_ABMI
+6 DO ^DIR
+7 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+8 SET ABM(ABMI)=Y
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+9 KILL DIR
+10 QUIT
LOOP ;LOOP THROUGH CPT SURGERY
+1 SET ABMI=9999
+2 FOR
SET ABMI=$ORDER(^ICPT(ABMI))
IF ABMI>69999
QUIT
Begin DoDot:1
+3 ;CSV-c
SET ABMPG=$PIECE($$IHSCPT^ABMCVAPI(ABMI,""),U,6)
+4 IF 'ABMPG
QUIT
+5 IF ABMPG>9
QUIT
+6 ;I '$D(^ABMDFEE(ABMJ,11,ABMI,0)) D NEW Q:+Y<0 ;abm*2.6*2 3PMS10003A
+7 ;abm*2.6*2 3PMS10003A
IF '$DATA(^ABMDFEE(ABMJ,11,ABMI,0))
DO NEW
+8 SET $PIECE(^ABMDFEE(ABMJ,11,ABMI,0),U,2)=ABM(+ABMPG)
+9 ;abm*2.6*2 3PMS10003A
DO EFFDT
+10 WRITE "."
End DoDot:1
+11 QUIT
NEW ;NEW ENTRY IN FEE TABLE
+1 SET ^ABMDFEE(ABMJ,11,ABMI,0)=ABMI
+2 SET ^ABMDFEE(ABMJ,11,"B",ABMI,ABMI)=""
+3 QUIT
+4 ;start new code abm*2.6*2 3PMS10003A
EFFDT ;
+1 DO ^XBFMK
+2 SET DA(2)=ABMJ
+3 SET DA(1)=ABMI
+4 SET DIC="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"
+5 SET DIC(0)="L"
+6 SET DIC("P")=$PIECE(^DD(9002274.0111,1,0),U,2)
+7 SET X=ABMEDT
+8 DO ^DIC
+9 SET ABMENTRY=+Y
+10 DO ^XBFMK
+11 SET DA(2)=ABMJ
+12 SET DA(1)=ABMI
+13 SET DIE="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"
+14 SET DA=ABMENTRY
+15 SET DR=".02////"_ABM(+ABMPG)
+16 SET DR=DR_";.05////"_DT_";.06////"_DUZ
+17 DO ^DIE
+18 QUIT
+19 ;end new code 3PMS10003A
