ABMFOFS ; IHS/ASDST/DMJ - UPDATE FEE TABLE FROM FOREIGN FILE ;
;;2.6;IHS Third Party Billing;**1,2,27**;NOV 12, 2009;Build 486
;
;IHS/SD/SDR 2.5*10 IM20355 Modified default to be Read
;
;IHS/SD/SDR 2.6*1 NO HEAT corrected cnts for categories and display
;IHS/SD/SDR 2.6*2 3PMS10003A Effective dates added to fee sched
;IHS/SD/SDR 2.6*27 CR8894 Change FILE and DFILE tags to file entries correctly using DINUM to CPT instead of first found IEN for CPT.
; Issue results from multiple entries in CPT file for a CPT code.
;
START ;START HERE
W !!,"FEE SCHEDULE UPDATE FROM FOREIGN FILE"
W !!,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")," It is advisable to do a global save of global ^ABMDFEE prior to"
W !,"running this procedure.",!
S DIR(0)="Y",DIR("A")="Continue",DIR("B")="NO"
D ^DIR K DIR
Q:Y'=1
S DIC="^ABMDFEE("
S DIC(0)="AEMQ"
S DIC("A")="Enter Fee Schedule to Update: "
S DIC("B")=1
D ^DIC K DIC
Q:Y<0
S ABMTB=+Y
;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
D ^XBFMK
S DIR(0)="N^0:200"
S DIR("A")="What percentile are you loading? "
D ^DIR K DIR
Q:$D(DIRUT)
S ABMPRCNT=Y
;end new code 3PMS10003A
DF ;DESCRIBE FLAT FILE
W !!,"FOREIGN HOST FILE DESCRIPTION",!
S DIR(0)="FA",DIR("A")="What is the host file record delimiter? ",DIR("B")="," D ^DIR K DIR Q:$D(DIRUT) S ABMDLM=Y
S DIR(0)="NA",DIR("A")="Which piece of the host file record contains the cpt code? ",DIR("B")=1 D ^DIR K DIR Q:$D(DIRUT) S ABMCPC=Y
S DIR(0)="NA",DIR("A")="Which piece of the host file record contains the price? ",DIR("B")=2 D ^DIR K DIR Q:$D(DIRUT) S ABMPPC=Y
W !!,"Some providers of fee schedules (Medicode for example) break out"
W !,"the professional and technical portions into separate records."
W !,"The next section will determine how to identify the different"
W !,"record types.",!
;start old code abm*2.6*2 3PMS10003A
;S DIR(0)="Y",DIR("A")="Include only certain record types",DIR("B")="NO" D ^DIR K DIR
;I Y=1 D
;.S DIR(0)="NA",DIR("A")="Examine piece: ",DIR("B")=4 D ^DIR K DIR
;.Q:'Y
;.S ABMIPC=+Y
;.S DIR(0)="F^1:30",DIR("A")="for value ",DIR("B")="G" D ^DIR K DIR
;.Q:Y=""
;.S ABMIVAL=Y
;end old code start new code
W !,"This section will load the different record types (global/technical/professional)"
;global
S DIR(0)="NA",DIR("A")="What column is the record type located in: ",DIR("B")=4 D ^DIR K DIR
Q:'Y
S ABMIPC=+Y
S DIR(0)="F^1:30",DIR("A")="Indicate value that identifies GLOBAL charge ",DIR("B")="G" D ^DIR K DIR
Q:Y=""
S ABMGVAL=Y
;technical
S DIR(0)="F^1:30",DIR("A")="Indicate value that identifies TECHNICAL charge ",DIR("B")="TC" D ^DIR K DIR
Q:Y=""
S ABMTVAL=Y
;professional
S DIR(0)="F^1:30",DIR("A")="Indicate value that identifies PROFESSIONAL charge ",DIR("B")="26" D ^DIR K DIR
Q:Y=""
S ABMPVAL=Y
K ABMCNT
;end new code 3PMS10003A
BY ;BYPASS WITH ABMTB DEFINED
I '$G(DT) S DT=$$HTFM^XLFDT($H)\1
W !!,"OPEN AND READ FOREIGN FILE",!
S %ZIS("HFSMODE")="R"
S %ZIS("B")="HOST FILE SERVER" D ^%ZIS Q:POP
F ABMCNT=1:1 D Q:$$STATUS^%ZISH
.U IO R X:DTIME Q:$$STATUS^%ZISH
.;I $G(ABMIVAL)'="" Q:($$TRIM^ABMUTLP($P(X,ABMDLM,ABMIPC),"R"," ")'=ABMIVAL) ;abm*2.6*2 3PMS10003A
.S ABMIVAL=$$TRIM^ABMUTLP($P(X,ABMDLM,ABMIPC),"LR"," ") ;abm*2.6*2 3PMS10003A
.S ABMCODE=$P(X,ABMDLM,ABMCPC)
.;start old code abm*2.6*2 3PMS10003A
.;S ABMCODE=$TR(ABMCODE,"""")
.;Q:$L(ABMCODE)<4
.;I $L(ABMCODE)=4,'$D(^AUTTADA("B",ABMCODE)) Q
.;I $L(ABMCODE)'=4,'$D(^ICPT("B",ABMCODE)) Q
.;end old code start new code 3PMS10003A
.S ABMCODE=$TR(ABMCODE," """)
.I $L(ABMCODE)<4 D Q
..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
.I $L(ABMCODE)=4,'$D(^AUTTADA("B",ABMCODE)) D Q
..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
.I $L(ABMCODE)'=4,'$D(^ICPT("B",ABMCODE)) D Q
..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
.;end new code 3PMS10003A
.I ((ABMIVAL'="")&(("^"_ABMGVAL_"^"_ABMTVAL_"^"_ABMPVAL_"^")'[("^"_ABMIVAL_"^"))) D Q
..I DUZ(0)["@" U 0 W !,ABMCODE_" "_ABMIVAL
.S ABMPRICE=$P(X,ABMDLM,ABMPPC)
.;S ABMPRICE=+$TR(ABMPRICE,"$"",") ;abm*2.6*2 3PMS10003A
.S ABMPRICE=+$TR(ABMPRICE,"$"", ") ;abm*2.6*2 3PMS10003A
.D SEC
.D:ABMSC'=21 FILE
.D:ABMSC=21 DFILE
.I '(ABMCNT#10) U IO(0) W "."
D HK
Q
SEC ;WHAT SECTION?
I $L(ABMCODE)=4 S ABMSC=21 Q
I ABMCODE?1U4N S ABMSC=13 Q
I ABMCODE?4N1U S ABMSC=13 Q ;abm*2.6*27 IHS/SD/SDR CR8894
I ABMCODE<10000 S ABMSC=23 Q
I ABMCODE<70000 S ABMSC=11 Q
I ABMCODE<80000 S ABMSC=15 Q
I ABMCODE<90000 S ABMSC=17 Q
S ABMSC=19
I '$D(^ABMDFEE(ABMTB,ABMSC)) D
.S ^ABMDFEE(ABMTB,ABMSC,0)="^9002274.01"_ABMSC_"P^^"
Q
FILE ;FILE CODE
;start old abm*2.6*27 IHS/SD/SDR CR8894
;S ABMPTR=$O(^ICPT("B",ABMCODE,0))
;Q:'ABMPTR
;;S ^ABMDFEE(ABMTB,ABMSC,ABMPTR,0)=ABMPTR_"^"_ABMPRICE_"^"_DT ;abm*2.6*2 3PMS10003A
;S:ABMIVAL="G"!(ABMIVAL="") ^ABMDFEE(ABMTB,ABMSC,ABMPTR,0)=ABMPTR_"^"_ABMPRICE_"^"_DT ;abm*2.6*2 3PMS10003A
;S ^ABMDFEE(ABMTB,ABMSC,"B",ABMPTR,ABMPTR)=""
;end old start new abm*2.6*27 IHS/SD/SDR CR8894
S ABMPTR=$P($$CPT^ABMCVAPI(ABMCODE,ABMEDT),U) ;returns CPT active at time of effective date
Q:+ABMPTR=0
S ABMCD=$$DINUM(ABMCODE) ;abm*2.6*27 IHS/SD/SDR CR8894
S:ABMIVAL="G"!(ABMIVAL="") ^ABMDFEE(ABMTB,ABMSC,ABMCD,0)=ABMPTR_"^"_ABMPRICE_"^"_DT ;abm*2.6*2 3PMS10003A
S ^ABMDFEE(ABMTB,ABMSC,"B",ABMCODE,ABMPTR)=""
;end new abm*2.6*27 IHS/SD/SDR CR8894
S ABMCNT(ABMSC)=+$G(ABMCNT(ABMSC))+1 ;abm*2.6*1 NO HEAT
D EFFDT ;abm*2.6*2 3PMS10003A
Q
;start new abm*2.6*27 IHS/SD/SDR CR8894
DINUM(ABMCODE) ;PEP - DINUM CPT for fee table
I +$G(ABMCODE)=ABMCODE D Q ABMCODE ;5-digit code, leave it
I (($A($E(ABMCODE))>64)&($A($E(ABMCODE))<91)) S ABMCD=$A($E(ABMCODE))_$E(ABMCODE,2,5) Q ABMCD
I (($A($E(ABMCODE,5))>64)&($A($E(ABMCODE,5))<91)) S ABMCD=$E(+ABMCODE,1,4)_"."_$A($E(ABMCODE,5)) Q ABMCD
S ABMCD=+$G(ABMCODE) Q ABMCD
Q ABMCODE
;end new abm*2.6*27 IHS/SD/SDR CR8894
DFILE ;FILE ADA CODE IN DENTAL SECTION
S ABMPTR=$O(^AUTTADA("B",ABMCODE,0))
Q:'ABMPTR
;S ^ABMDFEE(ABMTB,21,1_ABMCODE,0)=ABMPTR_"^"_ABMPRICE_"^"_ABMCODE_"^"_DT ;abm*2.6*2 3PMS10003A
S:ABMIVAL="G"!(ABMIVAL="") ^ABMDFEE(ABMTB,21,1_ABMCODE,0)=ABMPTR_"^"_ABMPRICE_"^"_ABMCODE_"^"_DT ;abm*2.6*2 3PMS10003A
S ^ABMDFEE(ABMTB,21,"B",ABMPTR,1_ABMCODE)=""
S ABMCNT(21)=+$G(ABMCNT(21))+1 ;abm*2.6*1 NO HEAT
D EFFDT ;abm*2.6*2 3PMS10003A
Q
;start new code abm*2.6*2 3PMS10003A
EFFDT ;
D ^XBFMK
S DA(2)=ABMTB
;S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMPTR) ;abm*2.6*27 IHS/SD/SDR CR8894
S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMCD) ;abm*2.6*27 IHS/SD/SDR CR8894
S DIC="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
S DIC(0)="L"
S DIC("P")=$P(^DD(9002274.01_ABMSC,1,0),U,2)
S X=ABMEDT
D ^DIC
S ABMENTRY=+Y
D ^XBFMK
S DA(2)=ABMTB
;S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMPTR) ;abm*2.6*27 IHS/SD/SDR CR8894
S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMCD) ;abm*2.6*27 IHS/SD/SDR CR8894
S DIE="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
S DA=ABMENTRY
I ((ABMIVAL=ABMGVAL)!($G(ABMIVAL)="")) S DR=".02////"_ABMPRICE
I (ABMIVAL=ABMTVAL) S DR=".03////"_ABMPRICE
I (ABMIVAL=ABMPVAL) S DR=".04////"_ABMPRICE
I $G(DR)'="" S DR=DR_";.05////"_DT_";.06////"_DUZ
D ^DIE
S ABMCNT(ABMSC,$S(($G(ABMIVAL)'=""):ABMIVAL,1:"G"))=+$G(ABMCNT(ABMSC,$S(($G(ABMIVAL)'=""):ABMIVAL,1:"G")))+1
Q
;end new code 3PMS10003A
HK ;HOUSE CLEANING
D ^%ZISC
;start new code abm*2.6*2 3PMS10003A
W !!,"Will now ensure all global charges are populated where applicable..."
S ABMSC=0
F S ABMSC=$O(^ABMDFEE(ABMTB,ABMSC)) Q:(+$G(ABMSC)=0) D
.S ABMCD=0
.F S ABMCD=$O(^ABMDFEE(ABMTB,ABMSC,ABMCD)) Q:(+$G(ABMCD)=0) D
..I $D(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,"B",ABMEDT)) D
...S ABMEDFN=$O(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,"B",ABMEDT,0))
...Q:(+$P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,2)'=0) ;already has global charge
...I (+$P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,3)'=0)&(+$P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,4)'=0) D
....D ^XBFMK
....S DA(2)=ABMTB
....S DA(1)=ABMCD
....S DIE="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
....S DA=ABMEDFN
....S DR=".02////"_($P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,3)+($P($G(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,4)))
....D ^DIE
;end new code 3PMS10003A
;W !!,ABMCNT," records updated.",! ;abm*2.6*1 NO HEAT
;start new code abm*2.6*1 NO HEAT
W !!,"Records updated by category"
S ABMRCNT=0
F S ABMRCNT=$O(ABMCNT(ABMRCNT)) Q:'ABMRCNT D
.W !?3,$G(ABMCNT(ABMRCNT)),?10
.I ABMRCNT=11 W "SURGICAL "
.I ABMRCNT=13 W "HCPCS "
.I ABMRCNT=15 W "RADIOLOGY "
.I ABMRCNT=17 W "LABORATORY "
.I ABMRCNT=19 W "MEDICAL "
.I ABMRCNT=21 W "DENTAL "
.I ABMRCNT=23 W "ANESTHESIA "
.I ABMRCNT=25 W "DRUG "
.;start new code abm*2.6*2 3PMS10003A
.S ABMIVAL=""
.F S ABMIVAL=$O(ABMCNT(ABMRCNT,ABMIVAL)) Q:($G(ABMIVAL)="") D
..W !?5,ABMIVAL,?8,$G(ABMCNT(ABMRCNT,ABMIVAL))
.;end new code 3PMS10003A
;end new code NO HEAT
;start new code abm*2.6*2 3PMS10003A
D ^XBFMK
S DA(1)=ABMTB
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_";.03////"_ABMPRCNT
D ^DIC
;end new code 3PMS10003A
;start new abm*2.6*27 IHS/SD/SDR CR8894
;mark fee table as complete for p27 cleanup
D ^XBFMK
S DIE="^ABMDFEE("
S DA=ABMTB
S DR=".06////C"
D ^DIE
;re-cross reference entire fee table
S DIK="^ABMDFEE("
S DA=ABMTB
D IX^DIK
;end new abm*2.6*27 IHS/SD/SDR CR8894
S DIR(0)="E" D ^DIR K DIR
K ABMSC,ABMCODE,ABMPRICE,ABMDLM,ABMCPC,ABMPPC,ABMCNT,ABMIPC,ABMIVAL
Q
ABMFOFS ; IHS/ASDST/DMJ - UPDATE FEE TABLE FROM FOREIGN FILE ;
+1 ;;2.6;IHS Third Party Billing;**1,2,27**;NOV 12, 2009;Build 486
+2 ;
+3 ;IHS/SD/SDR 2.5*10 IM20355 Modified default to be Read
+4 ;
+5 ;IHS/SD/SDR 2.6*1 NO HEAT corrected cnts for categories and display
+6 ;IHS/SD/SDR 2.6*2 3PMS10003A Effective dates added to fee sched
+7 ;IHS/SD/SDR 2.6*27 CR8894 Change FILE and DFILE tags to file entries correctly using DINUM to CPT instead of first found IEN for CPT.
+8 ; Issue results from multiple entries in CPT file for a CPT code.
+9 ;
START ;START HERE
+1 WRITE !!,"FEE SCHEDULE UPDATE FROM FOREIGN FILE"
+2 WRITE !!,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")," It is advisable to do a global save of global ^ABMDFEE prior to"
+3 WRITE !,"running this procedure.",!
+4 SET DIR(0)="Y"
SET DIR("A")="Continue"
SET DIR("B")="NO"
+5 DO ^DIR
KILL DIR
+6 IF Y'=1
QUIT
+7 SET DIC="^ABMDFEE("
+8 SET DIC(0)="AEMQ"
+9 SET DIC("A")="Enter Fee Schedule to Update: "
+10 SET DIC("B")=1
+11 DO ^DIC
KILL DIC
+12 IF Y<0
QUIT
+13 SET ABMTB=+Y
+14 ;start new code abm*2.6*2 3PMS10003A
+15 DO ^XBFMK
+16 SET DIR(0)="D"
+17 SET DIR("A")="What is the effective date? "
+18 SET DIR("B")="TODAY"
+19 DO ^DIR
KILL DIR
+20 IF $DATA(DIRUT)
QUIT
+21 SET ABMEDT=Y
+22 DO ^XBFMK
+23 SET DIR(0)="N^0:200"
+24 SET DIR("A")="What percentile are you loading? "
+25 DO ^DIR
KILL DIR
+26 IF $DATA(DIRUT)
QUIT
+27 SET ABMPRCNT=Y
+28 ;end new code 3PMS10003A
DF ;DESCRIBE FLAT FILE
+1 WRITE !!,"FOREIGN HOST FILE DESCRIPTION",!
+2 SET DIR(0)="FA"
SET DIR("A")="What is the host file record delimiter? "
SET DIR("B")=","
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
SET ABMDLM=Y
+3 SET DIR(0)="NA"
SET DIR("A")="Which piece of the host file record contains the cpt code? "
SET DIR("B")=1
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
SET ABMCPC=Y
+4 SET DIR(0)="NA"
SET DIR("A")="Which piece of the host file record contains the price? "
SET DIR("B")=2
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
SET ABMPPC=Y
+5 WRITE !!,"Some providers of fee schedules (Medicode for example) break out"
+6 WRITE !,"the professional and technical portions into separate records."
+7 WRITE !,"The next section will determine how to identify the different"
+8 WRITE !,"record types.",!
+9 ;start old code abm*2.6*2 3PMS10003A
+10 ;S DIR(0)="Y",DIR("A")="Include only certain record types",DIR("B")="NO" D ^DIR K DIR
+11 ;I Y=1 D
+12 ;.S DIR(0)="NA",DIR("A")="Examine piece: ",DIR("B")=4 D ^DIR K DIR
+13 ;.Q:'Y
+14 ;.S ABMIPC=+Y
+15 ;.S DIR(0)="F^1:30",DIR("A")="for value ",DIR("B")="G" D ^DIR K DIR
+16 ;.Q:Y=""
+17 ;.S ABMIVAL=Y
+18 ;end old code start new code
+19 WRITE !,"This section will load the different record types (global/technical/professional)"
+20 ;global
+21 SET DIR(0)="NA"
SET DIR("A")="What column is the record type located in: "
SET DIR("B")=4
DO ^DIR
KILL DIR
+22 IF 'Y
QUIT
+23 SET ABMIPC=+Y
+24 SET DIR(0)="F^1:30"
SET DIR("A")="Indicate value that identifies GLOBAL charge "
SET DIR("B")="G"
DO ^DIR
KILL DIR
+25 IF Y=""
QUIT
+26 SET ABMGVAL=Y
+27 ;technical
+28 SET DIR(0)="F^1:30"
SET DIR("A")="Indicate value that identifies TECHNICAL charge "
SET DIR("B")="TC"
DO ^DIR
KILL DIR
+29 IF Y=""
QUIT
+30 SET ABMTVAL=Y
+31 ;professional
+32 SET DIR(0)="F^1:30"
SET DIR("A")="Indicate value that identifies PROFESSIONAL charge "
SET DIR("B")="26"
DO ^DIR
KILL DIR
+33 IF Y=""
QUIT
+34 SET ABMPVAL=Y
+35 KILL ABMCNT
+36 ;end new code 3PMS10003A
BY ;BYPASS WITH ABMTB DEFINED
+1 IF '$GET(DT)
SET DT=$$HTFM^XLFDT($HOROLOG)\1
+2 WRITE !!,"OPEN AND READ FOREIGN FILE",!
+3 SET %ZIS("HFSMODE")="R"
+4 SET %ZIS("B")="HOST FILE SERVER"
DO ^%ZIS
IF POP
QUIT
+5 FOR ABMCNT=1:1
Begin DoDot:1
+6 USE IO
READ X:DTIME
IF $$STATUS^%ZISH
QUIT
+7 ;I $G(ABMIVAL)'="" Q:($$TRIM^ABMUTLP($P(X,ABMDLM,ABMIPC),"R"," ")'=ABMIVAL) ;abm*2.6*2 3PMS10003A
+8 ;abm*2.6*2 3PMS10003A
SET ABMIVAL=$$TRIM^ABMUTLP($PIECE(X,ABMDLM,ABMIPC),"LR"," ")
+9 SET ABMCODE=$PIECE(X,ABMDLM,ABMCPC)
+10 ;start old code abm*2.6*2 3PMS10003A
+11 ;S ABMCODE=$TR(ABMCODE,"""")
+12 ;Q:$L(ABMCODE)<4
+13 ;I $L(ABMCODE)=4,'$D(^AUTTADA("B",ABMCODE)) Q
+14 ;I $L(ABMCODE)'=4,'$D(^ICPT("B",ABMCODE)) Q
+15 ;end old code start new code 3PMS10003A
+16 SET ABMCODE=$TRANSLATE(ABMCODE," """)
+17 IF $LENGTH(ABMCODE)<4
Begin DoDot:2
+18 IF DUZ(0)["@"
USE 0
WRITE !,ABMCODE_" "_ABMIVAL
End DoDot:2
QUIT
+19 IF $LENGTH(ABMCODE)=4
IF '$DATA(^AUTTADA("B",ABMCODE))
Begin DoDot:2
+20 IF DUZ(0)["@"
USE 0
WRITE !,ABMCODE_" "_ABMIVAL
End DoDot:2
QUIT
+21 IF $LENGTH(ABMCODE)'=4
IF '$DATA(^ICPT("B",ABMCODE))
Begin DoDot:2
+22 IF DUZ(0)["@"
USE 0
WRITE !,ABMCODE_" "_ABMIVAL
End DoDot:2
QUIT
+23 ;end new code 3PMS10003A
+24 IF ((ABMIVAL'="")&(("^"_ABMGVAL_"^"_ABMTVAL_"^"_ABMPVAL_"^")'[("^"_ABMIVAL_"^")))
Begin DoDot:2
+25 IF DUZ(0)["@"
USE 0
WRITE !,ABMCODE_" "_ABMIVAL
End DoDot:2
QUIT
+26 SET ABMPRICE=$PIECE(X,ABMDLM,ABMPPC)
+27 ;S ABMPRICE=+$TR(ABMPRICE,"$"",") ;abm*2.6*2 3PMS10003A
+28 ;abm*2.6*2 3PMS10003A
SET ABMPRICE=+$TRANSLATE(ABMPRICE,"$"", ")
+29 DO SEC
+30 IF ABMSC'=21
DO FILE
+31 IF ABMSC=21
DO DFILE
+32 IF '(ABMCNT#10)
USE IO(0)
WRITE "."
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+33 DO HK
+34 QUIT
SEC ;WHAT SECTION?
+1 IF $LENGTH(ABMCODE)=4
SET ABMSC=21
QUIT
+2 IF ABMCODE?1U4N
SET ABMSC=13
QUIT
+3 ;abm*2.6*27 IHS/SD/SDR CR8894
IF ABMCODE?4N1U
SET ABMSC=13
QUIT
+4 IF ABMCODE<10000
SET ABMSC=23
QUIT
+5 IF ABMCODE<70000
SET ABMSC=11
QUIT
+6 IF ABMCODE<80000
SET ABMSC=15
QUIT
+7 IF ABMCODE<90000
SET ABMSC=17
QUIT
+8 SET ABMSC=19
+9 IF '$DATA(^ABMDFEE(ABMTB,ABMSC))
Begin DoDot:1
+10 SET ^ABMDFEE(ABMTB,ABMSC,0)="^9002274.01"_ABMSC_"P^^"
End DoDot:1
+11 QUIT
FILE ;FILE CODE
+1 ;start old abm*2.6*27 IHS/SD/SDR CR8894
+2 ;S ABMPTR=$O(^ICPT("B",ABMCODE,0))
+3 ;Q:'ABMPTR
+4 ;;S ^ABMDFEE(ABMTB,ABMSC,ABMPTR,0)=ABMPTR_"^"_ABMPRICE_"^"_DT ;abm*2.6*2 3PMS10003A
+5 ;S:ABMIVAL="G"!(ABMIVAL="") ^ABMDFEE(ABMTB,ABMSC,ABMPTR,0)=ABMPTR_"^"_ABMPRICE_"^"_DT ;abm*2.6*2 3PMS10003A
+6 ;S ^ABMDFEE(ABMTB,ABMSC,"B",ABMPTR,ABMPTR)=""
+7 ;end old start new abm*2.6*27 IHS/SD/SDR CR8894
+8 ;returns CPT active at time of effective date
SET ABMPTR=$PIECE($$CPT^ABMCVAPI(ABMCODE,ABMEDT),U)
+9 IF +ABMPTR=0
QUIT
+10 ;abm*2.6*27 IHS/SD/SDR CR8894
SET ABMCD=$$DINUM(ABMCODE)
+11 ;abm*2.6*2 3PMS10003A
IF ABMIVAL="G"!(ABMIVAL="")
SET ^ABMDFEE(ABMTB,ABMSC,ABMCD,0)=ABMPTR_"^"_ABMPRICE_"^"_DT
+12 SET ^ABMDFEE(ABMTB,ABMSC,"B",ABMCODE,ABMPTR)=""
+13 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+14 ;abm*2.6*1 NO HEAT
SET ABMCNT(ABMSC)=+$GET(ABMCNT(ABMSC))+1
+15 ;abm*2.6*2 3PMS10003A
DO EFFDT
+16 QUIT
+17 ;start new abm*2.6*27 IHS/SD/SDR CR8894
DINUM(ABMCODE) ;PEP - DINUM CPT for fee table
+1 ;5-digit code, leave it
IF +$GET(ABMCODE)=ABMCODE
Begin DoDot:1
End DoDot:1
QUIT ABMCODE
+2 IF (($ASCII($EXTRACT(ABMCODE))>64)&($ASCII($EXTRACT(ABMCODE))<91))
SET ABMCD=$ASCII($EXTRACT(ABMCODE))_$EXTRACT(ABMCODE,2,5)
QUIT ABMCD
+3 IF (($ASCII($EXTRACT(ABMCODE,5))>64)&($ASCII($EXTRACT(ABMCODE,5))<91))
SET ABMCD=$EXTRACT(+ABMCODE,1,4)_"."_$ASCII($EXTRACT(ABMCODE,5))
QUIT ABMCD
+4 SET ABMCD=+$GET(ABMCODE)
QUIT ABMCD
+5 QUIT ABMCODE
+6 ;end new abm*2.6*27 IHS/SD/SDR CR8894
DFILE ;FILE ADA CODE IN DENTAL SECTION
+1 SET ABMPTR=$ORDER(^AUTTADA("B",ABMCODE,0))
+2 IF 'ABMPTR
QUIT
+3 ;S ^ABMDFEE(ABMTB,21,1_ABMCODE,0)=ABMPTR_"^"_ABMPRICE_"^"_ABMCODE_"^"_DT ;abm*2.6*2 3PMS10003A
+4 ;abm*2.6*2 3PMS10003A
IF ABMIVAL="G"!(ABMIVAL="")
SET ^ABMDFEE(ABMTB,21,1_ABMCODE,0)=ABMPTR_"^"_ABMPRICE_"^"_ABMCODE_"^"_DT
+5 SET ^ABMDFEE(ABMTB,21,"B",ABMPTR,1_ABMCODE)=""
+6 ;abm*2.6*1 NO HEAT
SET ABMCNT(21)=+$GET(ABMCNT(21))+1
+7 ;abm*2.6*2 3PMS10003A
DO EFFDT
+8 QUIT
+9 ;start new code abm*2.6*2 3PMS10003A
EFFDT ;
+1 DO ^XBFMK
+2 SET DA(2)=ABMTB
+3 ;S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMPTR) ;abm*2.6*27 IHS/SD/SDR CR8894
+4 ;abm*2.6*27 IHS/SD/SDR CR8894
SET DA(1)=$SELECT(ABMSC=21:1_ABMCODE,1:ABMCD)
+5 SET DIC="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
+6 SET DIC(0)="L"
+7 SET DIC("P")=$PIECE(^DD(9002274.01_ABMSC,1,0),U,2)
+8 SET X=ABMEDT
+9 DO ^DIC
+10 SET ABMENTRY=+Y
+11 DO ^XBFMK
+12 SET DA(2)=ABMTB
+13 ;S DA(1)=$S(ABMSC=21:1_ABMCODE,1:ABMPTR) ;abm*2.6*27 IHS/SD/SDR CR8894
+14 ;abm*2.6*27 IHS/SD/SDR CR8894
SET DA(1)=$SELECT(ABMSC=21:1_ABMCODE,1:ABMCD)
+15 SET DIE="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
+16 SET DA=ABMENTRY
+17 IF ((ABMIVAL=ABMGVAL)!($GET(ABMIVAL)=""))
SET DR=".02////"_ABMPRICE
+18 IF (ABMIVAL=ABMTVAL)
SET DR=".03////"_ABMPRICE
+19 IF (ABMIVAL=ABMPVAL)
SET DR=".04////"_ABMPRICE
+20 IF $GET(DR)'=""
SET DR=DR_";.05////"_DT_";.06////"_DUZ
+21 DO ^DIE
+22 SET ABMCNT(ABMSC,$SELECT(($GET(ABMIVAL)'=""):ABMIVAL,1:"G"))=+$GET(ABMCNT(ABMSC,$SELECT(($GET(ABMIVAL)'=""):ABMIVAL,1:"G")))+1
+23 QUIT
+24 ;end new code 3PMS10003A
HK ;HOUSE CLEANING
+1 DO ^%ZISC
+2 ;start new code abm*2.6*2 3PMS10003A
+3 WRITE !!,"Will now ensure all global charges are populated where applicable..."
+4 SET ABMSC=0
+5 FOR
SET ABMSC=$ORDER(^ABMDFEE(ABMTB,ABMSC))
IF (+$GET(ABMSC)=0)
QUIT
Begin DoDot:1
+6 SET ABMCD=0
+7 FOR
SET ABMCD=$ORDER(^ABMDFEE(ABMTB,ABMSC,ABMCD))
IF (+$GET(ABMCD)=0)
QUIT
Begin DoDot:2
+8 IF $DATA(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,"B",ABMEDT))
Begin DoDot:3
+9 SET ABMEDFN=$ORDER(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,"B",ABMEDT,0))
+10 ;already has global charge
IF (+$PIECE($GET(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,2)'=0)
QUIT
+11 IF (+$PIECE($GET(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,3)'=0)&(+$PIECE($GET(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,4)'=0)
Begin DoDot:4
+12 DO ^XBFMK
+13 SET DA(2)=ABMTB
+14 SET DA(1)=ABMCD
+15 SET DIE="^ABMDFEE("_DA(2)_","_ABMSC_","_DA(1)_",1,"
+16 SET DA=ABMEDFN
+17 SET DR=".02////"_($PIECE($GET(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,3)+($PIECE($GET(^ABMDFEE(ABMTB,ABMSC,ABMCD,1,ABMEDFN,0)),U,4)))
+18 DO ^DIE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;end new code 3PMS10003A
+20 ;W !!,ABMCNT," records updated.",! ;abm*2.6*1 NO HEAT
+21 ;start new code abm*2.6*1 NO HEAT
+22 WRITE !!,"Records updated by category"
+23 SET ABMRCNT=0
+24 FOR
SET ABMRCNT=$ORDER(ABMCNT(ABMRCNT))
IF 'ABMRCNT
QUIT
Begin DoDot:1
+25 WRITE !?3,$GET(ABMCNT(ABMRCNT)),?10
+26 IF ABMRCNT=11
WRITE "SURGICAL "
+27 IF ABMRCNT=13
WRITE "HCPCS "
+28 IF ABMRCNT=15
WRITE "RADIOLOGY "
+29 IF ABMRCNT=17
WRITE "LABORATORY "
+30 IF ABMRCNT=19
WRITE "MEDICAL "
+31 IF ABMRCNT=21
WRITE "DENTAL "
+32 IF ABMRCNT=23
WRITE "ANESTHESIA "
+33 IF ABMRCNT=25
WRITE "DRUG "
+34 ;start new code abm*2.6*2 3PMS10003A
+35 SET ABMIVAL=""
+36 FOR
SET ABMIVAL=$ORDER(ABMCNT(ABMRCNT,ABMIVAL))
IF ($GET(ABMIVAL)="")
QUIT
Begin DoDot:2
+37 WRITE !?5,ABMIVAL,?8,$GET(ABMCNT(ABMRCNT,ABMIVAL))
End DoDot:2
+38 ;end new code 3PMS10003A
End DoDot:1
+39 ;end new code NO HEAT
+40 ;start new code abm*2.6*2 3PMS10003A
+41 DO ^XBFMK
+42 SET DA(1)=ABMTB
+43 SET DIC="^ABMDFEE("_DA(1)_",1,"
+44 SET DIC(0)="MQL"
+45 SET DIC("P")=$PIECE(^DD(9002274.01,1,0),U,2)
+46 DO NOW^%DTC
+47 SET X=%
+48 SET DIC("DR")=".02////"_DUZ_";.03////"_ABMPRCNT
+49 DO ^DIC
+50 ;end new code 3PMS10003A
+51 ;start new abm*2.6*27 IHS/SD/SDR CR8894
+52 ;mark fee table as complete for p27 cleanup
+53 DO ^XBFMK
+54 SET DIE="^ABMDFEE("
+55 SET DA=ABMTB
+56 SET DR=".06////C"
+57 DO ^DIE
+58 ;re-cross reference entire fee table
+59 SET DIK="^ABMDFEE("
+60 SET DA=ABMTB
+61 DO IX^DIK
+62 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+63 SET DIR(0)="E"
DO ^DIR
KILL DIR
+64 KILL ABMSC,ABMCODE,ABMPRICE,ABMDLM,ABMCPC,ABMPPC,ABMCNT,ABMIPC,ABMIVAL
+65 QUIT
