ABMP2627 ; IHS/SD/SDR - 3P BILLING 2.6 Patch 27 POST INSTALL ;
;;2.6;IHS Third Party Billing;**27**;NOV 12, 2009;Build 486
;
;IHS/SD/SDR 2.6*27 CR8894 Clean up of fee tables to use new method of storing entries
;1 UPDATED
;11 SURGICAL (CPT CODE)
;13 HCPCS CODE
;15 RADIOLOGY (CPT CODE)
;17 LABORATORY (CPT CODE)
;19 MEDICAL (CPT CODE)
;21 DENTAL (ADA CODE)
;23 ANESTHESIA (CPT CODE)
;25 DRUG
;31 REVENUE CODE
;32 CHARGE MASTER
;
POST ;EP
K ^ABMFTWC ;this is the fee table working copy, used to save/merge CPTs and then put back into 3P Fee Table (^ABMDFEE)
D OOO ;place add/edit fee options out of order for now
M ^ABMFTMP("ABM-FT")=^ABMDFEE ;backup of complete 3P Fee Table file
D FTLST ;returns ABM("FTLST",ABMFT); find all fee tables currently being reference in 3P Parameters and 3P Insurer file
D SKIPFT ;mark fee tables SKIPPED if they aren't on above list
;loop thru list and try to fix each fee table
S ABMFT=0
F S ABMFT=$O(ABM("FTLST",ABMFT)) Q:'ABMFT D
.K ^ABMDFEE(ABMFT,"C") ;kill this xref right away; broken pointers can't be fixed but will be re-indexed after process
.D PROCESS
D REINDEX ;re-index all fee tables when done, even though they may not be complete just yet
D COMPLETE ;check if any fee tables are completely done and mark them so
D FTCHK^ABMCUFE ;checks if all fee tables are complete; if so, activates/deactivates menu accordingly
D BMES^XPDUTL("Use the CUFE option to review any fees that need user intervention")
Q
OOO ;
;this tag will mark the following options out of order until the P27 CLEANUP is populated COMPLETED or SKIPPED for
; all fee tables
;EDFE Fee Schedule Maintenance [ABMD TM FEE MAINT]
;DTFE Transfer Drug Prices from Drug File [ABMD TM FEE DRUG]
;FIFE Import Foreign Fee Schedule [ABMD TM FEE FOREIGN]
;IDFE Increase/Decrease Fee Schedule [ABMD TM FEE PERCENT]
;
F ABMA="ABMD TM FEE MAINT","ABMD TM FEE DRUG","ABMD TM FEE FOREIGN","ABMD TM FEE PERCENT" D
.S DA=$O(^DIC(19,"B",ABMA,0))
.S DIE="^DIC(19,"
.S DR="2////USE 'CUFE' TO CLEANUP FEE TABLE AND REACTIVATE"
.D ^DIE
;
;This section will only apply to test sites that install the patch multiple times; if this isn't done the CUFE option could be out of order
S DA=$O(^DIC(19,"B","ABMD TM CLEANUP FEE TABLE",0))
S DIE="^DIC(19,"
S DR="2////@"
D ^DIE
Q
FTLST ;EP
D BMES^XPDUTL("Looking for active fee schedules...")
K ABM("FTLST")
;find all 3P Parameter fee tables
S ABMDUZ=0
F S ABMDUZ=$O(^ABMDPARM(ABMDUZ)) Q:'ABMDUZ D
.S ABMIEN=0
.F S ABMIEN=$O(^ABMDPARM(ABMDUZ,ABMIEN)) Q:'ABMIEN D ;this really should be '1' all the time, but just in case we'll loop thru them
..S ABMFT=$P($G(^ABMDPARM(ABMDUZ,ABMIEN,0)),U,9)
..I ABMFT="" Q ;no fee table entered
..I $G(^ABMDFEE(ABMFT,0))="" Q ;there no fee table with that number
..S ABM("FTLST",ABMFT)=1
;find all 3P Insurer entries
S ABMDUZ=0
F S ABMDUZ=$O(^ABMNINS(ABMDUZ)) Q:'ABMDUZ D ;looping thru just in case different from 3P Parm
.S ABMIEN=0
.F S ABMIEN=$O(^ABMNINS(ABMDUZ,ABMIEN)) Q:'ABMIEN D
..S ABMVT=0
..F S ABMVT=$O(^ABMNINS(ABMDUZ,ABMIEN,1,ABMVT)) Q:'ABMVT D
...S ABMFT=$P($G(^ABMNINS(ABMDUZ,ABMIEN,1,ABMVT,0)),U,5)
...I ABMFT="" Q ;no fee table entered
...I $G(^ABMDFEE(ABMFT,0))="" Q ;there no fee table with that number
...S ABM("FTLST",ABMFT)=1
Q
SKIPFT ;EP
D BMES^XPDUTL("SKIPPED (OLD) inactive fee schedules...")
S ABMF=0
F S ABMF=$O(^ABMDFEE(ABMF)) Q:'ABMF D
.I +$G(ABM("FTLST",ABMF))=1 Q ;don't label fee tables that are on list (active)
.I $G(^ABMDFEE(ABMF,0))="" Q ;this is an insurer/parameter reference to a fee table that doesn't exist
.S DIE="^ABMDFEE("
.S DA=ABMF
.S DR=".06////S"
.D ^DIE
Q
PROCESS ;EP
D BMES^XPDUTL("Reviewing fee schedule #"_ABMFT_" entries...")
S ABMF("FTEDT")=$P($G(^ABMDFEE(ABMFT,0)),U,5) ;fee table effective date
F ABMMLT=11,13,15,17,19,23 D ;only CPT multiples
.K ^ABMDFEE(ABMFT,ABMMLT,-1) ;there are a few -1s that should be removed
.D MES^XPDUTL($S(ABMMLT=11:"Surgical",ABMMLT=13:"HCPCS",ABMMLT=15:"Radiology",ABMMLT=17:"Laboratory",ABMMLT=19:"Medical",ABMMLT=23:"Anesthesia",1:"")_"...")
.S ABMF("IEN")=0
.F S ABMF("IEN")=$O(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))) Q:'ABMF("IEN") D
..I $G(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0))="" K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q ;there's no zero node so entry is incomplete
..I $D(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),1))<1 K ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q ;there aren't any effective dates associated with CPT so entry is incomplete - skip it
..S ABMF("CPT")=$P($G(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0)),U) ;this is the CPT pointer or maybe a CPT code
..I (($G(ABMF("CPT"))'="")&($G(^ICPT(ABMF("CPT"),0))="")) S ABMF("CPT")=$O(^ICPT("B",ABMF("IEN"),0))
..I ABMF("CPT")="" S ABMF("CPT")=$O(^ICPT("B",ABMF("IEN"),0)) ;it's a CPT; lookup CPT to get IEN
..I ABMF("CPT")="" K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q ;there's no pointer, remove entry and quit
..I (($G(^ICPT(ABMF("CPT"),0))="")&($G(^ICPT(ABMF("IEN"),0))="")) K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q ;the pointer is bad, there's no CPT at that pointer
..;S ABMF("CPT")=$S(($P($G(^ICPT(ABMF("IEN"),0)),U)'=""):$P($G(^ICPT(ABMF("IEN"),0)),U),1:$P($G(^ICPT(ABMF("CPT"),0)),U)) ;actual CPT code
..S ABMACPT=$$ACTIVCPT(ABMF("CPT"))
..S ABMF("DCPT")=ABMACPT ;CPT data
..I ($P(ABMF("DCPT"),U)<1) K ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) Q ;no such CPT so this will contain '-1^NO SUCH ENTRY' or if inactive will contain '0'
..S $P(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0),U)=ABMF("CPT") ;this is the CPT IEN of whatever entry was found for the CPT
..S ABMF("DCPT")=$$DINUM^ABMFOFS($P(ABMF("DCPT"),U,2)) ;DINUM CPT for fee table
..S ABMF("DCCNT")=+$G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")))+1 ;increment counter
..M ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"))=^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")) ;merge whole entry into wc global
..S ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"))=ABMF("DCCNT") ;DINUM CPT counter
.K ^ABMDFEE(ABMFT,ABMMLT) ;remove entire multiple
.S ^ABMDFEE(ABMFT,ABMMLT,0)="^9002274.01"_ABMMLT_"P^^" ;reset subfile zero node
;
;
;now look thru working copy global and put back as many entries as I can without intervention
;anything left in ABMFTWC after this code will need user intervention using the CUFE option
S ABMMLT=0
F S ABMMLT=$O(^ABMFTWC(ABMFT,ABMMLT)) Q:'ABMMLT D
.S ABMF("DCPT")=0
.F S ABMF("DCPT")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"))) Q:'ABMF("DCPT") D
..;the CPT was only found once - put back in fee table and stop
..I $G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")))=1 D
...S ABMF("CPT")=$P(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0),U)
...;S $P(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0),U)=$P($$ACTIVCPT(ABMF("CPT")),U) ;make .01 field active CPT pointer
...D MERGE
..;if it gets here there are multiple entries for the same CPT; check if dates are same but fees different - that's an issue
..K ABMF("FEECK")
..S ABMFEEC=0
..S ABMF("DCCNT")=0
..F S ABMF("DCCNT")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"))) Q:'ABMF("DCCNT") D
...;
...S ABMF("CPTEDIEN")=0
...F S ABMF("CPTEDIEN")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"))) Q:'ABMF("CPTEDIEN") D
....S ABMF("FEEREC")=$G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"),0))
....S ABMF("FEEDT")=$P(ABMF("FEEREC"),U) ;fee eff dt
....S ABMF("FEE")=$P(ABMF("FEEREC"),U,2) ;fee
....I ($D(ABMF("FEECK",ABMF("FEEDT")))>0)&($G(ABMF("FEECK",ABMF("FEEDT")))'=ABMF("FEE")) D Q ;if I find an eff dt with a different fee
.....S ^ABMFTWC(ABMFT,"FIX",ABMMLT,ABMF("DCPT"))=1 ;what CPT needs intervention
.....S ABMFEEC=1
....S ABMF("FEECK",ABMF("FEEDT"))=ABMF("FEE") ;add to array if it wasn't there already
..;
..I ABMFEEC=1 S ^ABMFTWC(ABMFT,"FIX",ABMMLT)=+$G(^ABMFTWC(ABMFT,"FIX",ABMMLT))+1 ;count how many need user intervention
..I +$G(^ABMFTWC(ABMFT,"FIX",ABMMLT,ABMF("DCPT")))'=0 Q ;stop here if user intervention needed for CPT
..D MERGE ;merge entries back into fee table
Q
;
ACTIVCPT(ABMCPT) ;EP
S ABMF("CPTEDT")=""
I ($G(ABMF("DCPT"))'="")&($G(ABMFT)'="") S ABMF("CPTEDT")=$P($G(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,1,1,0)),U)
I ABMF("CPTEDT")="" S ABMF("CPTEDT")=$P($G(^ABMDFEE(ABMFT,0)),U,5) ;CPT effective date
I ABMF("CPTEDT")="" S ABMF("CPTEDT")=ABMF("FTEDT") ;if no CPT eff date use fee table eff date
I ABMF("CPTEDT")="" S ABMF("CPTEDT")=DT ;use today if there's still no eff date
S ABMACPT=$$CPT^ABMCVAPI(ABMCPT,ABMF("CPTEDT"))
I ABMACPT=0 S ABMACPT=$$CPT^ABMCVAPI(ABMCPT,DT) ;try again with today's date
Q ABMACPT
;
MERGE ;EP
;the next two lines are the zero nodes for the CPT and for effective date
M ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0)
M ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),1,0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,1,0)
;
S ABMF("DCCNT")=0
F S ABMF("DCCNT")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"))) Q:'ABMF("DCCNT") D
.S ABMF("CPTEDIEN")=0
.S ABMF("NEWCPTEDIEN")=1
.F S ABMF("CPTEDIEN")=$O(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"))) Q:'ABMF("CPTEDIEN") D
..M ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),1,ABMF("NEWCPTEDIEN"),0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"),0)
..S ABMF("NEWCPTEDIEN")=+$G(ABMF("NEWCPTEDIEN"))+1
D DELWCE
Q
DELWCE ;
K ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")) ;remove entry from working copy file after all entries have been merged
Q
;
REINDEX ;EP -re-index everything when done
D BMES^XPDUTL("Reindexing fee schedules...")
D ^XBFMK
S ABMT("FT")=0
F S ABMT("FT")=$O(^ABMDFEE(ABMT("FT"))) Q:'ABMT("FT") D
.S DIK="^ABMDFEE("
.S DA=ABMT("FT")
.D IX^DIK
Q
;
COMPLETE ;EP-mark any that are complete
;ABM("FTLST",ABMF)
S ABMF=0
F S ABMF=$O(ABM("FTLST",ABMF)) Q:'ABMF D
.I $D(^ABMFTWC(ABMF)) Q ;skip anything that is still in working copy global
.S DIE="^ABMDFEE("
.S DA=ABMF
.S DR=".06////C"
.D ^DIE
Q
ABMP2627 ; IHS/SD/SDR - 3P BILLING 2.6 Patch 27 POST INSTALL ;
+1 ;;2.6;IHS Third Party Billing;**27**;NOV 12, 2009;Build 486
+2 ;
+3 ;IHS/SD/SDR 2.6*27 CR8894 Clean up of fee tables to use new method of storing entries
+4 ;1 UPDATED
+5 ;11 SURGICAL (CPT CODE)
+6 ;13 HCPCS CODE
+7 ;15 RADIOLOGY (CPT CODE)
+8 ;17 LABORATORY (CPT CODE)
+9 ;19 MEDICAL (CPT CODE)
+10 ;21 DENTAL (ADA CODE)
+11 ;23 ANESTHESIA (CPT CODE)
+12 ;25 DRUG
+13 ;31 REVENUE CODE
+14 ;32 CHARGE MASTER
+15 ;
POST ;EP
+1 ;this is the fee table working copy, used to save/merge CPTs and then put back into 3P Fee Table (^ABMDFEE)
KILL ^ABMFTWC
+2 ;place add/edit fee options out of order for now
DO OOO
+3 ;backup of complete 3P Fee Table file
MERGE ^ABMFTMP("ABM-FT")=^ABMDFEE
+4 ;returns ABM("FTLST",ABMFT); find all fee tables currently being reference in 3P Parameters and 3P Insurer file
DO FTLST
+5 ;mark fee tables SKIPPED if they aren't on above list
DO SKIPFT
+6 ;loop thru list and try to fix each fee table
+7 SET ABMFT=0
+8 FOR
SET ABMFT=$ORDER(ABM("FTLST",ABMFT))
IF 'ABMFT
QUIT
Begin DoDot:1
+9 ;kill this xref right away; broken pointers can't be fixed but will be re-indexed after process
KILL ^ABMDFEE(ABMFT,"C")
+10 DO PROCESS
End DoDot:1
+11 ;re-index all fee tables when done, even though they may not be complete just yet
DO REINDEX
+12 ;check if any fee tables are completely done and mark them so
DO COMPLETE
+13 ;checks if all fee tables are complete; if so, activates/deactivates menu accordingly
DO FTCHK^ABMCUFE
+14 DO BMES^XPDUTL("Use the CUFE option to review any fees that need user intervention")
+15 QUIT
OOO ;
+1 ;this tag will mark the following options out of order until the P27 CLEANUP is populated COMPLETED or SKIPPED for
+2 ; all fee tables
+3 ;EDFE Fee Schedule Maintenance [ABMD TM FEE MAINT]
+4 ;DTFE Transfer Drug Prices from Drug File [ABMD TM FEE DRUG]
+5 ;FIFE Import Foreign Fee Schedule [ABMD TM FEE FOREIGN]
+6 ;IDFE Increase/Decrease Fee Schedule [ABMD TM FEE PERCENT]
+7 ;
+8 FOR ABMA="ABMD TM FEE MAINT","ABMD TM FEE DRUG","ABMD TM FEE FOREIGN","ABMD TM FEE PERCENT"
Begin DoDot:1
+9 SET DA=$ORDER(^DIC(19,"B",ABMA,0))
+10 SET DIE="^DIC(19,"
+11 SET DR="2////USE 'CUFE' TO CLEANUP FEE TABLE AND REACTIVATE"
+12 DO ^DIE
End DoDot:1
+13 ;
+14 ;This section will only apply to test sites that install the patch multiple times; if this isn't done the CUFE option could be out of order
+15 SET DA=$ORDER(^DIC(19,"B","ABMD TM CLEANUP FEE TABLE",0))
+16 SET DIE="^DIC(19,"
+17 SET DR="2////@"
+18 DO ^DIE
+19 QUIT
FTLST ;EP
+1 DO BMES^XPDUTL("Looking for active fee schedules...")
+2 KILL ABM("FTLST")
+3 ;find all 3P Parameter fee tables
+4 SET ABMDUZ=0
+5 FOR
SET ABMDUZ=$ORDER(^ABMDPARM(ABMDUZ))
IF 'ABMDUZ
QUIT
Begin DoDot:1
+6 SET ABMIEN=0
+7 ;this really should be '1' all the time, but just in case we'll loop thru them
FOR
SET ABMIEN=$ORDER(^ABMDPARM(ABMDUZ,ABMIEN))
IF 'ABMIEN
QUIT
Begin DoDot:2
+8 SET ABMFT=$PIECE($GET(^ABMDPARM(ABMDUZ,ABMIEN,0)),U,9)
+9 ;no fee table entered
IF ABMFT=""
QUIT
+10 ;there no fee table with that number
IF $GET(^ABMDFEE(ABMFT,0))=""
QUIT
+11 SET ABM("FTLST",ABMFT)=1
End DoDot:2
End DoDot:1
+12 ;find all 3P Insurer entries
+13 SET ABMDUZ=0
+14 ;looping thru just in case different from 3P Parm
FOR
SET ABMDUZ=$ORDER(^ABMNINS(ABMDUZ))
IF 'ABMDUZ
QUIT
Begin DoDot:1
+15 SET ABMIEN=0
+16 FOR
SET ABMIEN=$ORDER(^ABMNINS(ABMDUZ,ABMIEN))
IF 'ABMIEN
QUIT
Begin DoDot:2
+17 SET ABMVT=0
+18 FOR
SET ABMVT=$ORDER(^ABMNINS(ABMDUZ,ABMIEN,1,ABMVT))
IF 'ABMVT
QUIT
Begin DoDot:3
+19 SET ABMFT=$PIECE($GET(^ABMNINS(ABMDUZ,ABMIEN,1,ABMVT,0)),U,5)
+20 ;no fee table entered
IF ABMFT=""
QUIT
+21 ;there no fee table with that number
IF $GET(^ABMDFEE(ABMFT,0))=""
QUIT
+22 SET ABM("FTLST",ABMFT)=1
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
SKIPFT ;EP
+1 DO BMES^XPDUTL("SKIPPED (OLD) inactive fee schedules...")
+2 SET ABMF=0
+3 FOR
SET ABMF=$ORDER(^ABMDFEE(ABMF))
IF 'ABMF
QUIT
Begin DoDot:1
+4 ;don't label fee tables that are on list (active)
IF +$GET(ABM("FTLST",ABMF))=1
QUIT
+5 ;this is an insurer/parameter reference to a fee table that doesn't exist
IF $GET(^ABMDFEE(ABMF,0))=""
QUIT
+6 SET DIE="^ABMDFEE("
+7 SET DA=ABMF
+8 SET DR=".06////S"
+9 DO ^DIE
End DoDot:1
+10 QUIT
PROCESS ;EP
+1 DO BMES^XPDUTL("Reviewing fee schedule #"_ABMFT_" entries...")
+2 ;fee table effective date
SET ABMF("FTEDT")=$PIECE($GET(^ABMDFEE(ABMFT,0)),U,5)
+3 ;only CPT multiples
FOR ABMMLT=11,13,15,17,19,23
Begin DoDot:1
+4 ;there are a few -1s that should be removed
KILL ^ABMDFEE(ABMFT,ABMMLT,-1)
+5 DO MES^XPDUTL($SELECT(ABMMLT=11:"Surgical",ABMMLT=13:"HCPCS",ABMMLT=15:"Radiology",ABMMLT=17:"Laboratory",ABMMLT=19:"Medical",ABMMLT=23:"Anesthesia",1:"")_"...")
+6 SET ABMF("IEN")=0
+7 FOR
SET ABMF("IEN")=$ORDER(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN")))
IF 'ABMF("IEN")
QUIT
Begin DoDot:2
+8 ;there's no zero node so entry is incomplete
IF $GET(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0))=""
KILL ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))
QUIT
+9 ;there aren't any effective dates associated with CPT so entry is incomplete - skip it
IF $DATA(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),1))<1
KILL ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))
QUIT
+10 ;this is the CPT pointer or maybe a CPT code
SET ABMF("CPT")=$PIECE($GET(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0)),U)
+11 IF (($GET(ABMF("CPT"))'="")&($GET(^ICPT(ABMF("CPT"),0))=""))
SET ABMF("CPT")=$ORDER(^ICPT("B",ABMF("IEN"),0))
+12 ;it's a CPT; lookup CPT to get IEN
IF ABMF("CPT")=""
SET ABMF("CPT")=$ORDER(^ICPT("B",ABMF("IEN"),0))
+13 ;there's no pointer, remove entry and quit
IF ABMF("CPT")=""
KILL ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))
QUIT
+14 ;the pointer is bad, there's no CPT at that pointer
IF (($GET(^ICPT(ABMF("CPT"),0))="")&($GET(^ICPT(ABMF("IEN"),0))=""))
KILL ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))
QUIT
+15 ;S ABMF("CPT")=$S(($P($G(^ICPT(ABMF("IEN"),0)),U)'=""):$P($G(^ICPT(ABMF("IEN"),0)),U),1:$P($G(^ICPT(ABMF("CPT"),0)),U)) ;actual CPT code
+16 SET ABMACPT=$$ACTIVCPT(ABMF("CPT"))
+17 ;CPT data
SET ABMF("DCPT")=ABMACPT
+18 ;no such CPT so this will contain '-1^NO SUCH ENTRY' or if inactive will contain '0'
IF ($PIECE(ABMF("DCPT"),U)<1)
KILL ^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))
QUIT
+19 ;this is the CPT IEN of whatever entry was found for the CPT
SET $PIECE(^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"),0),U)=ABMF("CPT")
+20 ;DINUM CPT for fee table
SET ABMF("DCPT")=$$DINUM^ABMFOFS($PIECE(ABMF("DCPT"),U,2))
+21 ;increment counter
SET ABMF("DCCNT")=+$GET(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")))+1
+22 ;merge whole entry into wc global
MERGE ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"))=^ABMDFEE(ABMFT,ABMMLT,ABMF("IEN"))
+23 ;DINUM CPT counter
SET ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"))=ABMF("DCCNT")
End DoDot:2
+24 ;remove entire multiple
KILL ^ABMDFEE(ABMFT,ABMMLT)
+25 ;reset subfile zero node
SET ^ABMDFEE(ABMFT,ABMMLT,0)="^9002274.01"_ABMMLT_"P^^"
End DoDot:1
+26 ;
+27 ;
+28 ;now look thru working copy global and put back as many entries as I can without intervention
+29 ;anything left in ABMFTWC after this code will need user intervention using the CUFE option
+30 SET ABMMLT=0
+31 FOR
SET ABMMLT=$ORDER(^ABMFTWC(ABMFT,ABMMLT))
IF 'ABMMLT
QUIT
Begin DoDot:1
+32 SET ABMF("DCPT")=0
+33 FOR
SET ABMF("DCPT")=$ORDER(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")))
IF 'ABMF("DCPT")
QUIT
Begin DoDot:2
+34 ;the CPT was only found once - put back in fee table and stop
+35 IF $GET(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT")))=1
Begin DoDot:3
+36 SET ABMF("CPT")=$PIECE(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0),U)
+37 ;S $P(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0),U)=$P($$ACTIVCPT(ABMF("CPT")),U) ;make .01 field active CPT pointer
+38 DO MERGE
End DoDot:3
+39 ;if it gets here there are multiple entries for the same CPT; check if dates are same but fees different - that's an issue
+40 KILL ABMF("FEECK")
+41 SET ABMFEEC=0
+42 SET ABMF("DCCNT")=0
+43 FOR
SET ABMF("DCCNT")=$ORDER(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT")))
IF 'ABMF("DCCNT")
QUIT
Begin DoDot:3
+44 ;
+45 SET ABMF("CPTEDIEN")=0
+46 FOR
SET ABMF("CPTEDIEN")=$ORDER(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN")))
IF 'ABMF("CPTEDIEN")
QUIT
Begin DoDot:4
+47 SET ABMF("FEEREC")=$GET(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"),0))
+48 ;fee eff dt
SET ABMF("FEEDT")=$PIECE(ABMF("FEEREC"),U)
+49 ;fee
SET ABMF("FEE")=$PIECE(ABMF("FEEREC"),U,2)
+50 ;if I find an eff dt with a different fee
IF ($DATA(ABMF("FEECK",ABMF("FEEDT")))>0)&($GET(ABMF("FEECK",ABMF("FEEDT")))'=ABMF("FEE"))
Begin DoDot:5
+51 ;what CPT needs intervention
SET ^ABMFTWC(ABMFT,"FIX",ABMMLT,ABMF("DCPT"))=1
+52 SET ABMFEEC=1
End DoDot:5
QUIT
+53 ;add to array if it wasn't there already
SET ABMF("FEECK",ABMF("FEEDT"))=ABMF("FEE")
End DoDot:4
End DoDot:3
+54 ;
+55 ;count how many need user intervention
IF ABMFEEC=1
SET ^ABMFTWC(ABMFT,"FIX",ABMMLT)=+$GET(^ABMFTWC(ABMFT,"FIX",ABMMLT))+1
+56 ;stop here if user intervention needed for CPT
IF +$GET(^ABMFTWC(ABMFT,"FIX",ABMMLT,ABMF("DCPT")))'=0
QUIT
+57 ;merge entries back into fee table
DO MERGE
End DoDot:2
End DoDot:1
+58 QUIT
+59 ;
ACTIVCPT(ABMCPT) ;EP
+1 SET ABMF("CPTEDT")=""
+2 IF ($GET(ABMF("DCPT"))'="")&($GET(ABMFT)'="")
SET ABMF("CPTEDT")=$PIECE($GET(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,1,1,0)),U)
+3 ;CPT effective date
IF ABMF("CPTEDT")=""
SET ABMF("CPTEDT")=$PIECE($GET(^ABMDFEE(ABMFT,0)),U,5)
+4 ;if no CPT eff date use fee table eff date
IF ABMF("CPTEDT")=""
SET ABMF("CPTEDT")=ABMF("FTEDT")
+5 ;use today if there's still no eff date
IF ABMF("CPTEDT")=""
SET ABMF("CPTEDT")=DT
+6 SET ABMACPT=$$CPT^ABMCVAPI(ABMCPT,ABMF("CPTEDT"))
+7 ;try again with today's date
IF ABMACPT=0
SET ABMACPT=$$CPT^ABMCVAPI(ABMCPT,DT)
+8 QUIT ABMACPT
+9 ;
MERGE ;EP
+1 ;the next two lines are the zero nodes for the CPT and for effective date
+2 MERGE ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,0)
+3 MERGE ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),1,0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),1,1,0)
+4 ;
+5 SET ABMF("DCCNT")=0
+6 FOR
SET ABMF("DCCNT")=$ORDER(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT")))
IF 'ABMF("DCCNT")
QUIT
Begin DoDot:1
+7 SET ABMF("CPTEDIEN")=0
+8 SET ABMF("NEWCPTEDIEN")=1
+9 FOR
SET ABMF("CPTEDIEN")=$ORDER(^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN")))
IF 'ABMF("CPTEDIEN")
QUIT
Begin DoDot:2
+10 MERGE ^ABMDFEE(ABMFT,ABMMLT,ABMF("DCPT"),1,ABMF("NEWCPTEDIEN"),0)=^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"),ABMF("DCCNT"),1,ABMF("CPTEDIEN"),0)
+11 SET ABMF("NEWCPTEDIEN")=+$GET(ABMF("NEWCPTEDIEN"))+1
End DoDot:2
End DoDot:1
+12 DO DELWCE
+13 QUIT
DELWCE ;
+1 ;remove entry from working copy file after all entries have been merged
KILL ^ABMFTWC(ABMFT,ABMMLT,ABMF("DCPT"))
+2 QUIT
+3 ;
REINDEX ;EP -re-index everything when done
+1 DO BMES^XPDUTL("Reindexing fee schedules...")
+2 DO ^XBFMK
+3 SET ABMT("FT")=0
+4 FOR
SET ABMT("FT")=$ORDER(^ABMDFEE(ABMT("FT")))
IF 'ABMT("FT")
QUIT
Begin DoDot:1
+5 SET DIK="^ABMDFEE("
+6 SET DA=ABMT("FT")
+7 DO IX^DIK
End DoDot:1
+8 QUIT
+9 ;
COMPLETE ;EP-mark any that are complete
+1 ;ABM("FTLST",ABMF)
+2 SET ABMF=0
+3 FOR
SET ABMF=$ORDER(ABM("FTLST",ABMF))
IF 'ABMF
QUIT
Begin DoDot:1
+4 ;skip anything that is still in working copy global
IF $DATA(^ABMFTWC(ABMF))
QUIT
+5 SET DIE="^ABMDFEE("
+6 SET DA=ABMF
+7 SET DR=".06////C"
+8 DO ^DIE
End DoDot:1
+9 QUIT
