Wow!
I have attached my LSS line posting script as well (text file) I will
have to look at yours as it is different.
Thank you!
Mary
Mary Thompson
Special Project Manager
Children's Mercy Hospital
(816) 234-3940
Electronic mail from Mary Thompson, The Children's Mercy Hospital. This
communication is intended only for the use of the addressee. It may
contain information which is privileged or confidential under applicable
law. If you are not the intended recipient or the agent of the
recipient, you are hereby notified that any dissemination, copy or
disclosure of this communication is strictly prohibited. If you have
received this communication in error, please immediately notify The
Children's Mercy Hospital at 816-234-3940 or via return Internet
electronic mail at [EMAIL PROTECTED] and expunge this communication
without making any copies. Thank you for your cooperation.
-----Original Message-----
From: [EMAIL PROTECTED] [mailto:[EMAIL PROTECTED]
Sent: Friday, November 12, 2004 9:09 AM
To: [EMAIL PROTECTED]
Subject: Re: [Talk] Medicare remittance
Here are my routines to parse data.
I am also attaching the .frm file which contains the code so you can see
how it all fits together. In this case, the data is in a sql database
where each line is a record. Just modify it to read a text file and it
should work just as well. strRawData is each line. This assumes there
is
a line termination after each ~. If not, terminate the line at after
each
tilde. My approach is to create some tables and populate those tables,
then evaluate whether I should script. This is scripted into LSS, thus
service line level vs. claim level. So I have had to account for all
the
cas codes, if not, my math will not yield 0, only 1 service line, and
the
ucrn must be an LSS ucrn, not a Meditech. If all these conditions are
met,
I then script the entry into LSS.
(See attached file: frmLssEdi.frm)
Sub subParseData(strRawData As String, _
Optional strAccount As String, _
Optional strHcpcs As String)
Dim strRawDataSection As String
Dim intPos As Integer
Dim intStart As Integer
Dim intEnd As Integer
Dim intLen As Integer
Dim strCas As String
Select Case Left(strRawData, 3)
Case "ISA"
Exit Sub
Case "CLP"
intPos = 1
intEnd = InStr(intPos, strRawData, "~")
strRawDataSection = Left(strRawData, intEnd - 1)
rsAcct.AddNew
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsAcct!Account = funFirstElement(strRawDataSection, "*")
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsAcct!Reason = funFirstElement(strRawDataSection, "*")
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsAcct!TotalChg = CCur(funFirstElement(strRawDataSection,
"*", True))
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsAcct!Payment = CCur(funFirstElement(strRawDataSection,
"*",
True))
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsAcct!CoIns = CCur(funFirstElement(strRawDataSection,
"*",
True))
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
'rsAcct!SvcCount = funFirstElement(strRawDataSection, "*",
True)
'strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
intPos = intEnd + 1
intEnd = InStr(intPos, strRawData, "~")
intLen = intEnd - intPos
Do While intPos < Len(strRawData)
strRawDataSection = Mid(strRawData, intPos, intLen)
If rsSvc.recordCount > 0 Then
strHcpcs = Trim(rsSvc.Fields.Item("Hcpcs"))
End If
subParseData strRawDataSection,
Trim(rsAcct.Fields.Item("Account")), strHcpcs
intPos = intEnd + 1
intEnd = InStr(intPos, strRawData, "~")
intLen = intEnd - intPos
rsAcct!ZeroCalc = rsAcct!TotalChg - rsAcct!Payment -
rsAcct!CoIns - rsAcct!Adj
Loop
Case "SVC"
rsAcct!SvcCount = rsAcct!SvcCount + 1
strRawDataSection = strRawData
rsSvc.AddNew
rsSvc!Account = strAccount
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsSvc!Hcpcs = funFirstElement(strRawDataSection, "*")
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsSvc!TotalChg = funFirstElement(strRawDataSection, "*",
True)
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsSvc!Payment = funFirstElement(strRawDataSection, "*",
True)
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsSvc!Units = funFirstElement(strRawDataSection, "*",
True)
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
If strAccount = "030270135" Then
waithere = 0
End If
Case "CAS"
' If strHcpcs <> "" Then
strRawDataSection = strRawData
rsCas.AddNew
rsCas!Account = strAccount
rsCas!Hcpcs = strHcpcs
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsCas!Oc = funFirstElement(strRawDataSection, "*")
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsCas!Reason = funFirstElement(strRawDataSection, "*")
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsCas!amount = funFirstElement(strRawDataSection, "*",
True)
strCas = Trim(rsCas!Oc & rsCas!Reason)
If strAccount = "030270135" Then
waithere = 0
End If
For x = 1 To 100
If arrAdjCodes(x) = strCas Then
rsAcct!Adj = rsAcct!Adj + rsCas!amount
End If
Next x
rsAcct!ZeroCalc = rsAcct!TotalChg - rsAcct!Payment -
rsAcct!CoIns - rsAcct!Adj
Do While (strRawDataSection <> rsCas!amount) And
(strRawDataSection <> "")
strCas = rsCas!Oc
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsCas.AddNew
rsCas!Account = strAccount
rsCas!Hcpcs = strHcpcs
'strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsCas!Oc = strCas
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsCas!Reason = funFirstElement(strRawDataSection,
"*")
strRawDataSection = Mid(strRawDataSection,
Len(funFirstElement(strRawDataSection, "*")) + 2)
rsCas!amount = funFirstElement(strRawDataSection,
"*", True)
strCas = Trim(rsCas!Oc & rsCas!Reason)
For x = 1 To 100
If arrAdjCodes(x) = strCas Then
rsAcct!Adj = rsAcct!Adj + rsCas!amount
End If
Next x
rsAcct!ZeroCalc = rsAcct!TotalChg - rsAcct!Payment
-
rsAcct!CoIns - rsAcct!Adj
Loop
If chkDebug.Value = 1 Then
Print #fileNum, Left(rsAcct!Account, 10); _
Tab(12); strHcpcs; _
Tab(25); strCas; _
Tab(32); rsAcct!Reason; _
Tab(38); rsAcct!TotalChg; _
Tab(53); rsAcct!Payment; _
Tab(68); rsAcct!CoIns; _
Tab(83); rsAcct!Adj; _
Tab(100); rsAcct!SvcCount; _
Tab(113); rsAcct!ZeroCalc
End If
'End If
Case Else
End Select
End Sub
Function funFirstElement(strRaw As String, _
strDelim As String, _
Optional boolSendZero As Boolean) As String
Dim intEnd As String
intEnd = InStr(1, strRaw, strDelim)
If intEnd <> 0 Then
funFirstElement = Left(strRaw, intEnd - 1)
Else
funFirstElement = strRaw
End If
If funFirstElement = "" And boolSendZero = True Then funFirstElement
=
"0"
End Function
John
John Curtiss
Hutchinson Area Health Care
1095 Highway 15 South
Hutchinson MN 55350
320-234-4967
[EMAIL PROTECTED]
"Dobbs, Tom"
<[EMAIL PROTECTED]> To:
[EMAIL PROTECTED]
Sent by: cc:
[EMAIL PROTECTED] Subject: [Talk]
Medicare remittance
STATION.COM
11/11/2004 04:38 PM
Please respond to
Talk
Hi, Does anyone have an example to parse a Medicare Part A 835
remittance
file and post the payments into Meditech.
Thanks
Tom Dobbs
Programmer Analyst III
Information Technology Services
Ministry Health Care - Central Region
900 Illinois Avenue
Stevens Point, WI 54481
715.346.5157
[EMAIL PROTECTED]
Dim Account As String
Dim Name As String
Dim Part As String
Dim Quantity As String
Dim Zip As String
Dim ExcelApp As Object
Dim ExcelWasNotRunning As Boolean
Dim MyExcel As Boolean
Dim I As Integer
Const DataDir As String = "c:\bss65\"
Const strFileName As String = "LSSPOST.xls" 'CHANGE WITH EACH ONE
Const strSheet As String = "SheetH" ' CHECK FOR SHHET NAME
' define spreadsheet columns
Const ptAccount As Integer = 5
'Const ptName As Integer = 26
Const ptRemittance As Integer = 15
Const DOS As Integer = 6
Const PtICN As Integer = 8
Const Procedure As Integer = 9
Const Amount As Integer = 10
Const ptAdjust As Integer = 13
Const ptPayment As Integer = 11
Const ptNCReason As Integer = 13
Const ptCheckNo As Integer = 2
Const ptCheckDate As Integer = 4
Const ptRecStatus As Integer = 14
'define data variables
Dim strInsurance As String
Sub ObjectScript()
On Error GoTo scripterror
scripterror:
If Err = seDoEvents Then DoEvents_: Resume
If Err = seTimeOut Then End
If Err = seHalt Then Exit Sub
End Sub 'default
Sub HaltScript()
Halt_
End Sub
Sub LoadExcel()
On Error Resume Next
Err.Clear
Set ExcelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
ExcelWasNotRunning = True
Err.Clear
Set ExcelApp = CreateObject("Excel.Application")
If Err.Number <> 0 Then
MsgBox "Error: &Err.Description"
Else
MyExcel = True
End If
MyExcel = False
End If
ExcelApp.Workbooks.Open (DataDir & strFileName) 'This opens the workbook
ExcelApp.Worksheets(strSheet).Select 'This selects the worksheet you want to
work with
ExcelApp.Visible = True
ExcelApp.Workbooks.Visible = True
ExcelApp.DisplayAlerts = False
Activate ("Meditech")
I = 2 'CHANGE AS NEEDED
If Not ExcelApp.APPLICATION.CELLS(I, ptAccount) = "" Then
strInsurance = "MCDK"
Else
Exit Sub
End If
lssbatchload
Do While Not Trim(ExcelApp.APPLICATION.CELLS(I, ptAccount)) = "" 'Looking at
act number
ProcessLssDetail
ExcelApp.Save 'Saves after processing each record
I = I + 1
Loop
'
Pause "Entry #"
Key "{f11}"
Pause "Number"
Key "{f11}"
Pause "PBR BATCH MENU"
If ExcelWasNotRunning = True Then
ExcelApp.Save
ExcelApp.APPLICATION.Quit 'If not already running
End If
Set ExcelApp = Nothing
End Sub
Sub ExtractXLData()
Field1 = ExcelApp.APPLICATION.CELLS(1, 16)
Field2 = ExcelApp.APPLICATION.CELLS(2, 17)
ExcelApp.APPLICATION.CELLS(2, 18) = "done"
I = I + 1
End Sub
Sub ProcessLSS()
LssLogon
LoadExcel
'lssbatchload
'ProcessLssDetail
End Sub
Sub LSSLogout()
Pause " Entry # "
Key "{f10}{f11}"
Pause "Account "
Key "{f11}"
Enter ""
Pause "@8,12"
Key "[f10]"
Key Entry
Pause "[EMAIL PROTECTED],3"
Key "[f11]"
Pause "@1,55"
Key "[f11]"
End Sub
Sub LssLogon()
If Not Active("Medi") Then
Connect "C:\Program Files\Meditech\Workstation3.x\t.exe", stMeditech, "Medi"
End If
Do
Stable 0.4
PauseLoop "@1,35", "1~"
'PauseLoop "@7,17", "bar-mat~"
'PauseLoop "@8,17", "XXX~"
PauseLoop "@1,50", "4~"
PauseLoop "@1,71", "300~"
PauseLoop "@1,65", "20~"
PauseLoop "@1,55", "1~"
Loop Until At("Date")
End Sub
Sub lssbatchload()
'START BATCH HEADER
At ""
If Not At("Date") Then
LssLogon
End If
Pause "Date"
'Enter "080403" 'change date as needed
Pause "Journal "
'Enter "RCPFHPRA" 'cAN COMMENT THIS OUT FOR DIFFERENT BATCH
Pause "Number "
Enter "N"
Pause " Comment "
Enter ""
Pause "Select "
Enter "3"
Pause "Dft Ser Date "
'Enter "T"
Pause "Dft Insurance "
Enter "MCDK"
Pause " Copy Add Desc? "
Enter ""
Pause " 1 "
Enter "PMCDK"
Enter "AMCDK"
Pause " 3 "
Enter ""
Pause "Amount "
Enter "0"
Pause "Quantity "
Enter "0"
Pause "Txn Count "
Enter ""
Pause "Hash Total "
Enter ""
Pause "OK? "
Enter "y" 'End of batch header
End Sub
Sub ProcessLssDetail()
Dim r As Integer
Dim scrno As String
Dim blnFound As Boolean
Timeout = 30
On Error GoTo errh
HoldClaimNo = ExcelApp.APPLICATION.CELLS(I, ptAccount)
Pause " Entry #"
blnFound = False
Enter ""
Pause "Account "
Enter "." & ExcelApp.APPLICATION.CELLS(I, ptAccount)
C = 1
Do
C = C + 1
Stable 0.3
If C > 100 Then Err.Raise seTimeOut
If At("Invalid claim number") Then
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = "claim # not valid"
Enter
Key "{f10}"
Key "{f11}"
Pause "Exit?"
Enter "Y"
Exit Sub
End If
Loop Until At("Sel Txns By CLAIM")
Pause "Sel Txns By CLAIM"
Enter ""
Pause "Insurance "
Enter ""
Pause "Rcp/Adj Date"
Enter ""
Pause " 1 "
Enter ""
Pause " 1 "
Enter ""
Enter "ADJ code" & ExcelApp.APPLICATION.CELLS(I, ptRemittance) & "ICN" &
ExcelApp.APPLICATION.CELLS(I, PtICN)
Pause " 2 "
Enter ""
Pause " 2 "
Enter ""
Enter "ADJ code" & ExcelApp.APPLICATION.CELLS(I, ptRemittance) & "ICN" &
ExcelApp.APPLICATION.CELLS(I, PtICN) 'data from spreedsheet
Pause " 3 "
Enter ""
Pause "[EMAIL PROTECTED],1"
If At("@14,5") Then
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = "Blank claim detail"
GoTo nxtclaim
End If
Pause "@2,0"
Key "{pgdn}"
Pause "@14,5"
Stable 0.2
NXTChK:
blnFound = False
scrno = View(Row:=2, col:=7, length:=8)
If Trim$(scrno) = "" Then
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = "Blank claim detail" 'maybe
GoTo nxtclaim
End If
For r = 2 To 20
scrDATE = View(Row:=r, col:=7, length:=8) '09/30/02
scrproc = View(Row:=r, col:=16, length:=9) '49505
scramount = View(Row:=r, col:=45, length:=9) ' 1270.00
scrno = View(Row:=r, col:=1, length:=5) '8
If Trim(scrno) = "" Then
If blnFound Then
scrno = Trim$(View(Row:=2, col:=1, length:=5))
ENTERAMT Trim$(scrno)
If Trim$(ExcelApp.APPLICATION.CELLS(I, ptRecStatus)) = "" Then
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = "Done"
End If
I = I + 1
If Not Trim(ExcelApp.APPLICATION.CELLS(I, ptAccount)) = "" Then
If ExcelApp.APPLICATION.CELLS(I, ptAccount) <> HoldClaimNo Then
I = I - 1
GoTo nxtclaim
Else
blnFound = False
GoTo NXTChK
End If
Else
I = I - 1
GoTo nxtclaim
End If
Else
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = "NoMatch"
I = I + 1
If ExcelApp.APPLICATION.CELLS(I, ptAccount) <> HoldClaimNo Then
I = I - 1
GoTo nxtclaim
Else
blnFound = False
GoTo NXTChK
End If
End If
End If
If Trim(Format(scrDATE, "yyyymmdd")) =
Trim(ExcelApp.APPLICATION.CELLS(I, DOS)) And Trim$(scrproc) =
StrWord(ExcelApp.APPLICATION.CELLS(I, Procedure), 2, ":") And Trim$(scramount)
= Format(ExcelApp.APPLICATION.CELLS(I, Amount), "0.00") Then
blnFound = True
ENTERAMT Trim$(scrno)
I = I + 1
If Not Trim(ExcelApp.APPLICATION.CELLS(I, ptAccount)) = "" Then
If ExcelApp.APPLICATION.CELLS(I, ptAccount) <> HoldClaimNo Then
I = I - 1 'you need to put record back one to make sure it gets
processed
GoTo nxtclaim
Else
blnFound = False
GoTo NXTChK
End If
Else
I = I - 1
GoTo nxtclaim
End If
End If
Next r
errh:
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = fail
I = I + 1
If Not Trim(ExcelApp.APPLICATION.CELLS(I, ptAccount)) = "" Then
If ExcelApp.APPLICATION.CELLS(I, ptAccount) <> HoldClaimNo Then
I = I - 1 'you need to put record back one to make sure it gets
processed
GoTo nxtclaim
Else
GoTo NXTChK
End If
End If
'ENTERAMT scrno
nxtclaim:
Enter ""
If At("Force Claim?") Then
Enter "N"
End If
Pause "Ok? " ' back to work
Enter "y"
Do
Stable 0.5
PauseLoop "WARNING: Amounts not fully distributed.", "~"
Loop Until At(" Recompute Total Amounts Above From Detail? ")
Enter "y"
Pause "File? "
Enter "y"
'Pause "Entry # 2"
'Enter "" 'repeat as above
Exit Sub
End Sub
Sub ENTERAMT(scrno As String)
Pause "@0,5"
Enter Trim$(scrno)
Do
Stable 0.5
If At("Duplicate Entries") Then
Enter
Key "{LF}"
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = "Duplicate" 'maybe
Exit Sub
End If
Loop Until At("@0,22")
Enter Trim(ExcelApp.APPLICATION.CELLS(I, ptPayment))
Pause "@0,32"
ExcelApp.APPLICATION.CELLS(I, ptRecStatus) = "Done" 'maybe
If Trim(ExcelApp.APPLICATION.CELLS(I, ptPayment)) = "0" Then
Enter "0"
Else
Enter Trim(ExcelApp.APPLICATION.CELLS(I, Amount)) -
Trim(ExcelApp.APPLICATION.CELLS(I, ptPayment))
End If
Do
Stable 0.5
PauseLoop "@0,78", "~"
Stable 0.2
PauseLoop "@0,77", "~"
Stable 0.2
PauseLoop "@0,76", "~"
Stable 0.2
PauseLoop "@0,75", "~"
Stable 0.2
PauseLoop "@0,74", "~"
Stable 0.2
PauseLoop "@0,73", "~"
Stable 0.1
PauseLoop "@0,79", "~"
Loop Until At("@0,83")
Enter ""
End Sub
