diff --git a/bcbsvt/check_x12s.php b/bcbsvt/check_x12s.php index 3267b1f0..728bdde4 100644 --- a/bcbsvt/check_x12s.php +++ b/bcbsvt/check_x12s.php @@ -1,37 +1,49 @@ setTimeout(300); // 5 minutes instead of default -$sftp->setKeepAlive(30); // Send keep-alive every 30 seconds +$sftp->setTimeout(300); // 5 minutes instead of default +$sftp->setKeepAlive(30); // send keep-alive every 30 seconds + if (!$sftp->login($cms_user, $cms_pass)) { - echo "login failed" . "\n"; + echo "login failed\n"; exit; -}; +} $path = '/Home/cms'; - -$files = $sftp->rawlist($path, true); -if (!is_array($files)) { +$raw = $sftp->rawlist($path); +if (!is_array($raw)) { throw new RuntimeException("rawlist failed: " . $sftp->getLastError()); } -usort($files, fn($a, $b) => $a->mtime <=> $b->mtime); - -if (!empty($files)) { - foreach ($files as $file) { - if (!empty($file)) { - $dt_utc = new DateTimeImmutable('@' . $file->mtime); // unix timestamp directly - $date = $dt_utc->setTimezone(new DateTimeZone('America/New_York')); - echo "file: " . $file->filename . " uploaded to 02 on " . - $date->format('Y-m-d h:i:s a') . "\n"; - } - } -} else { - // there's a test directory + +// read a field whether the entry is an object or an associative array +$prop = function ($entry, $key) { + if (is_object($entry)) return $entry->$key ?? null; + if (is_array($entry)) return $entry[$key] ?? null; + return null; +}; + +$files = []; +foreach ($raw as $name => $entry) { + if ($name === '.' || $name === '..') continue; + if ($prop($entry, 'type') === NET_SFTP_TYPE_DIRECTORY) continue; // 2 + $mtime = $prop($entry, 'mtime'); + if (!$mtime) continue; + $files[] = [ + 'filename' => $prop($entry, 'filename') ?? $name, + 'mtime' => $mtime, + ]; } + +usort($files, fn($a, $b) => $a['mtime'] <=> $b['mtime']); + +foreach ($files as $file) { + $dt_utc = new DateTimeImmutable('@' . $file['mtime']); + $date = $dt_utc->setTimezone(new DateTimeZone('America/New_York')); + echo "file: {$file['filename']} uploaded to 02 on " + . $date->format('Y-m-d h:i:s a') . "\n"; +} \ No newline at end of file diff --git a/copylib/rri/hisfile.cpy b/copylib/rri/hisfile.cpy new file mode 100644 index 00000000..02b5677c --- /dev/null +++ b/copylib/rri/hisfile.cpy @@ -0,0 +1,41 @@ + 01 HISFILE01. + 02 HISFILE-KEY. + 03 HS-KEY8 PIC X(8). + 03 HS-CLAIM PIC X(6). + 03 HS-REC-TYPE PIC X. + 03 HS-KEY4 PIC XXXX. + 02 HS-PATID. + 03 HS-PATID7 PIC X(7). + 03 HS-PATID1 PIC X. + 02 HS-SERVICE PIC X. + 02 HS-DIAG PIC X(5). + 02 HS-PROC PIC X(11). + 02 HS-MOD2 PIC XX. + 02 HS-MOD3 PIC XX. + 02 HS-MOD4 PIC XX. + 02 HS-AMOUNT PIC X(6). + 02 HS-DOCR PIC X(3). + 02 HS-DOCP PIC X(2). + 02 HS-PAYCODE PIC XXX. + 02 HS-STUD PIC X. + 02 HS-WORK PIC XX. + 02 HS-DAT1 PIC X(8). + 02 HS-RESULT PIC X. + 02 HS-ACT PIC X. + 02 HS-SORCREF PIC X. + 02 HS-COLLT PIC X. + 02 HS-AGE PIC X. + 02 HS-PAPER PIC X. + 02 HS-PLACE PIC X. + 02 HS-EPSDT PIC X. + 02 HS-DATE-T PIC X(8). + 02 HS-DATE-A PIC X(8). + 02 HS-DATE-E PIC X(8). + 02 HS-REC-STAT PIC X. + 02 HS-DX2 PIC X(5). + 02 HS-DX3 PIC X(5). + 02 HS-ACC-TYPE PIC X. + 02 HS-DATE-M PIC X(8). + 02 HS-ASSIGN PIC X. + 02 HS-NEIC-ASSIGN PIC X. + 02 HS-FUTURE PIC X(6). \ No newline at end of file diff --git a/php/rri/reads.php b/php/rri/reads.php index e9007fad..05b518bd 100644 --- a/php/rri/reads.php +++ b/php/rri/reads.php @@ -52,7 +52,7 @@ function getQualifyingLungFindings(string $note): array ]; } -function suggestIcd10Codes(Client $guzzle, string $interp, string $cpt): array +function suggestIcd10Codes(Client $guzzle, string $interp, string $cpt): ?array { $system = <<post('https://api.anthropic.com/v1/messages', [ - 'headers' => [ - 'x-api-key' => getenv('ANTHROPIC_API_KEY'), - 'anthropic-version' => '2023-06-01', - 'Content-Type' => 'application/json', - ], - 'timeout' => 30, - 'connect_timeout' => 10, - 'json' => [ - 'model' => 'claude-sonnet-4-20250514', - 'max_tokens' => 1024, - 'system' => $system, - 'messages' => [ - ['role' => 'user', 'content' => $user_message] + $attempts = 0; + $max_attempts = 3; + + while ($attempts < $max_attempts) { + try { + $response = $guzzle->post('https://api.anthropic.com/v1/messages', [ + 'headers' => [ + 'x-api-key' => getenv('ANTHROPIC_API_KEY'), + 'anthropic-version' => '2023-06-01', + 'Content-Type' => 'application/json', + ], + 'timeout' => 30, + 'connect_timeout' => 10, + 'json' => [ + 'model' => 'claude-sonnet-4-6', + 'max_tokens' => 2048, + 'system' => [ + [ + 'type' => 'text', + 'text' => $system, + 'cache_control' => ['type' => 'ephemeral'], + ], + ], + 'tools' => [ + [ + 'name' => 'submit_diagnosis_codes', + 'description' => 'Submit suggested ICD-10-CM diagnosis codes for the radiology report.', + 'input_schema' => [ + 'type' => 'object', + 'properties' => [ + 'codes' => [ + 'type' => 'array', + 'items' => [ + 'type' => 'object', + 'properties' => [ + 'code' => ['type' => 'string', 'description' => 'ICD-10-CM code'], + 'description' => ['type' => 'string', 'description' => 'Full code description'], + 'confidence' => ['type' => 'string', 'enum' => ['high', 'medium', 'low']], + 'rationale' => ['type' => 'string', 'description' => 'One sentence citing the specific finding or indication'], + 'specificity_check' => ['type' => 'string', 'description' => 'Text from report supporting code specificity'], + ], + 'required' => ['code', 'description', 'confidence', 'rationale'], + ], + ], + ], + 'required' => ['codes'], + ], + ], + ], + 'tool_choice' => ['type' => 'tool', 'name' => 'submit_diagnosis_codes'], + 'messages' => [ + ['role' => 'user', 'content' => $user_message], + ], ], - ], - ]); - $body = json_decode((string) $response->getBody(), true); - $raw = $body['content'][0]['text'] ?? '[]'; - return json_decode($raw, true) ?? []; - } catch (\GuzzleHttp\Exception\ConnectException $e) { - echo "Claude unavailable (connection timeout) \n"; - } catch (\GuzzleHttp\Exception\RequestException $e) { - echo "Claude request failed: " . $e->getMessage() . " \n"; - } catch (\Exception $e) { - echo "Claude error: " . $e->getMessage() . " \n"; + ]); + + $body = json_decode((string) $response->getBody(), true); + + // Cache verification — keep during rollout, remove later + $usage = $body['usage'] ?? []; + error_log(sprintf( + "Claude usage: input=%d, output=%d, cache_write=%d, cache_read=%d", + $usage['input_tokens'] ?? 0, + $usage['output_tokens'] ?? 0, + $usage['cache_creation_input_tokens'] ?? 0, + $usage['cache_read_input_tokens'] ?? 0, + )); + + if (($body['stop_reason'] ?? '') === 'max_tokens') { + error_log("Claude: response truncated at max_tokens, consider raising limit"); + } + + foreach ($body['content'] ?? [] as $block) { + if (($block['type'] ?? '') === 'tool_use' + && ($block['name'] ?? '') === 'submit_diagnosis_codes') { + return $block['input']['codes'] ?? []; + } + } + + error_log("Claude: no tool_use block found, stop_reason=" . ($body['stop_reason'] ?? 'null')); + return []; + + } catch (\GuzzleHttp\Exception\ConnectException $e) { + $attempts++; + if ($attempts < $max_attempts) { + sleep(2 ** $attempts); + continue; + } + error_log("Claude unavailable (connection timeout): " . $e->getMessage()); + return null; + + } catch (\GuzzleHttp\Exception\RequestException $e) { + $status = $e->hasResponse() ? $e->getResponse()->getStatusCode() : 0; + $detail = $e->hasResponse() + ? (string) $e->getResponse()->getBody() + : $e->getMessage(); + + if (in_array($status, [429, 529, 500, 502, 503, 504]) && $attempts < $max_attempts - 1) { + $attempts++; + if ($attempts < $max_attempts) { + sleep(2 ** $attempts); + } + continue; + } + error_log("Claude request failed ($status): $detail"); + return null; + + } catch (\Exception $e) { + error_log("Claude error: " . $e->getMessage()); + return null; + } } - return []; + + return null; } $filename = getenv('HOME') . "/W2" . getenv('tid') . $cms_user; @@ -220,6 +367,17 @@ function suggestIcd10Codes(Client $guzzle, string $interp, string $cpt): array $pdf_page_count = 0; + $icd10_valid = []; + $order_file = '/home/sidw/icd10_valid.txt'; + if ($ask_claude) { + if (is_readable($order_file)) { + foreach (file($order_file, FILE_IGNORE_NEW_LINES | FILE_SKIP_EMPTY_LINES) as $code) { + $icd10_valid[$code] = true; + } + } + //error_log("icd10_valid loaded: " . count($icd10_valid) . " codes from $order_file"); + } + foreach ($jsonObj['entry'] as $entry) { $cntr++; $coding_display = $entry['resource']['code']['coding'][0]['display']; @@ -272,16 +430,27 @@ function suggestIcd10Codes(Client $guzzle, string $interp, string $cpt): array $pdf->ezText($note, 10); $pdf_page_count++; } else { - echo $note . "\n"; + if (!$ask_claude) { + echo $note . "\n"; + } if ($ask_claude && str_contains($coding_display, $rri_cpt)) { $icd10_suggestions = suggestIcd10Codes($guzzle, $interp, $rri_cpt); - foreach ($icd10_suggestions as $s) { - echo sprintf("[%s] %s (%s) — \"%s\"\n", - $s['confidence'], - $s['code'], - $s['description'], - $s['rationale'] - ); + if ($icd10_suggestions === null) { + echo "(Claude unavailable — code manually)\n"; + } elseif (empty($icd10_suggestions)) { + echo "(no ICD-10 suggestions returned)\n"; + } else { + foreach ($icd10_suggestions as $s) { + $valid = isValidIcd10Code($s['code'], $icd10_valid); + $flag = $valid ? '' : ' *** VERIFY — not in current code set ***'; + echo sprintf("[%s] %s (%s) — \"%s\"%s\n", + $s['confidence'], + $s['code'], + $s['description'], + $s['rationale'], + $flag + ); + } } } } @@ -310,3 +479,9 @@ function suggestIcd10Codes(Client $guzzle, string $interp, string $cpt): array echo "No reports added to PDF, nothing saved.\n"; } } + +function isValidIcd10Code(string $code, array $icd10_valid): bool +{ + if (empty($icd10_valid)) return true; // file missing — don't block + return isset($icd10_valid[str_replace('.', '', $code)]); +} \ No newline at end of file diff --git a/python/vtmed_dnl_to_server.py b/python/vtmed_dnl_to_server.py old mode 100644 new mode 100755 index 55ca564d..4404e42f --- a/python/vtmed_dnl_to_server.py +++ b/python/vtmed_dnl_to_server.py @@ -1,3 +1,4 @@ +#!/opt/cms-venvs/vtmed/bin/python3 from playwright.sync_api import sync_playwright import sys import os diff --git a/python/vtmed_elig.py b/python/vtmed_elig.py old mode 100644 new mode 100755 index 21c5f950..85cf36b7 --- a/python/vtmed_elig.py +++ b/python/vtmed_elig.py @@ -1,3 +1,4 @@ +#!/opt/cms-venvs/vtmed/bin/python3 from playwright.sync_api import sync_playwright import sys import os diff --git a/python/vtmed_upl_from_server.py b/python/vtmed_upl_from_server.py old mode 100644 new mode 100755 index 3157d6be..584c05d6 --- a/python/vtmed_upl_from_server.py +++ b/python/vtmed_upl_from_server.py @@ -1,3 +1,4 @@ +#!/opt/cms-venvs/vtmed/bin/python3 from playwright.sync_api import sync_playwright import sys import time diff --git a/rri/chcrr/upperCase.php b/rri/chcrr/upperCase.php new file mode 100644 index 00000000..16233f99 --- /dev/null +++ b/rri/chcrr/upperCase.php @@ -0,0 +1,19 @@ +\n"); + exit(1); +} + +$in = fopen($argv[1], 'r'); +if ($in === false) { + fwrite(STDERR, "Cannot open {$argv[1]}\n"); + exit(1); +} +$out = fopen('output.csv', 'w'); + +while (($line = fgets($in)) !== false) { + fwrite($out, strtoupper($line)); +} + +fclose($in); +fclose($out); \ No newline at end of file diff --git a/rri/claims/npi5r3026.cob b/rri/claims/npi5r3026.cob new file mode 100644 index 00000000..2a514691 --- /dev/null +++ b/rri/claims/npi5r3026.cob @@ -0,0 +1,2622 @@ + * @package cms + * @link http://www.cmsvt.com + * @author s waite + * @copyright Copyright (c) 2020 cms + * @license https://github.com/openemr/openemr/blob/master/LICENSE GNU General Public License 3 + IDENTIFICATION DIVISION. + PROGRAM-ID. npi5r3026. + AUTHOR. SID WAITE. + DATE-COMPILED. TODAY. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT CHARCUR ASSIGN TO "S30" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS CHARCUR-KEY + ALTERNATE RECORD KEY IS CC-PAYCODE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT GARFILE ASSIGN TO "S35" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS G-GARNO + ALTERNATE RECORD KEY IS G-ACCT WITH DUPLICATES + LOCK MODE MANUAL. + SELECT PATFILE ASSIGN TO "S40" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS P-PATNO + ALTERNATE RECORD KEY IS P-GARNO WITH DUPLICATES + LOCK MODE MANUAL. + SELECT SEGFILE ASSIGN TO "S45" ORGANIZATION + LINE SEQUENTIAL. + SELECT FILEIN ASSIGN TO "S50" ORGANIZATION + LINE SEQUENTIAL. + SELECT ERRFILE ASSIGN TO "S55" ORGANIZATION + LINE SEQUENTIAL. + SELECT PARMFILE ASSIGN TO "S60" ORGANIZATION + LINE SEQUENTIAL. + SELECT REFPHY ASSIGN TO "S65" ORGANIZATION IS INDEXED + ACCESS IS DYNAMIC RECORD KEY IS REF-KEY + ALTERNATE RECORD KEY IS REF-BSNUM WITH DUPLICATES + ALTERNATE RECORD KEY IS REF-CRNUM WITH DUPLICATES + ALTERNATE RECORD KEY IS REF-UPIN WITH DUPLICATES + ALTERNATE RECORD KEY IS REF-CDNUM WITH DUPLICATES + ALTERNATE RECORD KEY IS REF-NAME WITH DUPLICATES + LOCK MODE MANUAL. + SELECT DIAGFILE ASSIGN TO "S70" ORGANIZATION IS INDEXED + ACCESS IS RANDOM RECORD KEY IS DIAG-KEY + ALTERNATE RECORD KEY IS DIAG-TITLE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT AUTHFILE ASSIGN TO "S75" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS AUTH-KEY + LOCK MODE MANUAL. + SELECT MPLRFILE ASSIGN TO "S80" ORGANIZATION IS INDEXED + ACCESS IS DYNAMIC RECORD KEY IS MPLR-KEY + LOCK MODE MANUAL. + SELECT INSFILE ASSIGN TO "S85" ORGANIZATION IS INDEXED + ACCESS IS DYNAMIC RECORD KEY IS INS-KEY + ALTERNATE RECORD KEY IS INS-NAME WITH DUPLICATES + ALTERNATE RECORD KEY IS INS-CITY WITH DUPLICATES + ALTERNATE RECORD KEY IS INS-ASSIGN WITH DUPLICATES + ALTERNATE RECORD KEY IS INS-CLAIMTYPE WITH DUPLICATES + ALTERNATE RECORD KEY IS INS-NEIC WITH DUPLICATES + ALTERNATE RECORD KEY IS INS-NEIC-ASSIGN WITH DUPLICATES + LOCK MODE MANUAL. + SELECT GAPFILE ASSIGN TO "S90" ORGANIZATION IS INDEXED + ACCESS IS DYNAMIC RECORD KEY IS GAPKEY + ALTERNATE RECORD KEY IS GAP-NAME WITH DUPLICATES + ALTERNATE RECORD KEY IS GAP-CITY WITH DUPLICATES + ALTERNATE RECORD KEY IS GAP-STATE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT PAYCUR ASSIGN TO "S95" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS PAYCUR-KEY + LOCK MODE MANUAL. + SELECT PLACEFILE ASSIGN TO "S100" ORGANIZATION + LINE SEQUENTIAL. + SELECT PARMFILE2 ASSIGN TO "S105" ORGANIZATION + LINE SEQUENTIAL. + SELECT HIPCLAIMFILE ASSIGN TO "S110" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS HIP-KEY + LOCK MODE MANUAL. + SELECT PROCFILE ASSIGN TO "S115" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS PROC-KEY + LOCK MODE MANUAL. + + DATA DIVISION. + FILE SECTION. + + FD PROCFILE + DATA RECORD PROCFILE01. + 01 PROCFILE01. + 02 PROC-KEY. + 03 PROC-KEY1 PIC X(4). + 03 PROC-KEY2 PIC X(7). + 02 PROC-TYPE PIC X. + 02 PROC-TITLE PIC X(28). + 02 PROC-AMOUNT PIC 9(4)V99. + FD HIPCLAIMFILE. + 01 HIPCLAIMFILE01. + 02 HIP-KEY PIC X. + 02 HIP-NUM PIC 9(9). + FD PLACEFILE. + 01 PLACEFILE01. + 02 DF1 PIC X. + 02 DF2 PIC X. + 02 DF3 PIC X(22). + 02 DF4 PIC X(18). + 02 DF5 PIC X(15). + 02 DF6 PIC XX. + 02 DF7 PIC X(9). + + FD PARMFILE. + 01 PARMFILE01 PIC X(75). + FD PARMFILE2. + 01 PARMFILE201 PIC X(15). + + FD ERRFILE. + 01 ERRFILE01. + 02 EF-1 PIC X(11). + 02 FILLER PIC X VALUE SPACE. + 02 EF-2 PIC X(9). + 02 FILLER PIC X VALUE SPACE. + 02 EF-3 PIC X(16). + 02 EF-4 PIC X(20). + 02 FILLER PIC X VALUE SPACE. + 02 EF-5 PIC X(10). + FD FILEIN. + 01 FILEIN01. + 02 FILEIN-KEY. + 03 FI-KEY8 PIC X(8). + 03 FI-KEY3 PIC XXX. + 02 FI-PATID. + 03 FI-PATID7 PIC X(7). + 03 FI-PATID8 PIC X. + 02 FI-CLAIM PIC X(6). + 02 FI-SERVICE PIC X. + 02 FI-DIAG PIC X(7). + 02 FI-PROC. + 03 FI-PROC0 PIC X(4). + 03 FI-PROC1 PIC X(5). + 03 FI-PROC2 PIC XX. + 02 FI-MOD2 PIC XX. + 02 FI-MOD3 PIC XX. + 02 FI-MOD4 PIC XX. + 02 FI-AMOUNT PIC S9(4)V99. + 02 FI-DOCR PIC X(3). + 02 FI-DOCP PIC 99. + 02 FI-PAYCODE PIC XXX. + 02 FI-STUD PIC X. + 02 FI-WORK PIC 99. + 02 FI-DAT1 PIC X(8). + 02 FI-RESULT PIC X. + 02 FI-ACTION PIC X. + 02 FI-SORCREF PIC X. + 02 FI-COLLT PIC X. + 02 FI-AGE PIC X. + 02 FI-PAPER PIC X. + 02 FI-PLACE PIC X. + 02 FI-IOPAT PIC X. + 02 FI-DATE-T PIC X(8). + 02 FI-DATE-A PIC X(8). + 02 FI-DATE-P PIC X(8). + 02 FI-REC-STAT PIC X. + 02 FI-DX2 PIC X(7). + 02 FI-DX3 PIC X(7). + 02 FI-ACC-TYPE PIC X. + 02 FI-DATE-M PIC X(8). + 02 FI-ASSIGN PIC X. + 02 FI-NEIC-ASSIGN PIC X. + 02 FI-DX4 PIC X(7). + 02 FI-DX5 PIC X(7). + 02 FI-DX6 PIC X(7). + 02 FI-FREQ PIC X. + 02 FI-FUTURE PIC X(5). + + FD SEGFILE. + 01 SEGFILE01 PIC X(160). + FD CHARCUR + BLOCK CONTAINS 3 RECORDS + DATA RECORD IS CHARCUR01. + 01 CHARCUR01. + 02 CHARCUR-KEY. + 03 CC-KEY8 PIC X(8). + 03 CC-KEY3 PIC XXX. + 02 CC-PATID. + 03 CC-PATID7 PIC X(7). + 03 CC-PATID8 PIC X. + 02 CC-CLAIM PIC X(6). + 02 CC-SERVICE PIC X. + 02 CC-DIAG PIC X(7). + 02 CC-PROC. + 03 CC-PROC0 PIC X(4). + 03 CC-PROC1 PIC X(5). + 03 CC-PROC2 PIC XX. + 02 CC-MOD2 PIC XX. + 02 CC-MOD3 PIC XX. + 02 CC-MOD4 PIC XX. + 02 CC-AMOUNT PIC S9(4)V99. + 02 CC-DOCR PIC X(3). + 02 CC-DOCP PIC X(2). + 02 CC-PAYCODE PIC XXX. + 02 CC-STUD PIC X. + 02 CC-WORK PIC XX. + 02 CC-DAT1 PIC X(8). + 02 CC-RESULT PIC X. + 02 CC-ACTION PIC X. + 02 CC-SORCREF PIC X. + 02 CC-COLLT PIC X. + 02 CC-AGE PIC X. + 02 CC-PAPER PIC X. + 02 CC-PLACE PIC X. + 02 CC-IOPAT PIC X. + 02 CC-DATE-T PIC X(8). + 02 CC-DATE-A PIC X(8). + 02 CC-DATE-P PIC X(8). + 02 CC-REC-STAT PIC X. + 02 CC-DX2 PIC X(7). + 02 CC-DX3 PIC X(7). + 02 CC-ACC-TYPE PIC X. + 02 CC-DATE-M PIC X(8). + 02 CC-ASSIGN PIC X. + 02 CC-NEIC-ASSIGN PIC X. + 02 CC-DX4 PIC X(7). + 02 CC-DX5 PIC X(7). + 02 CC-DX6 PIC X(7). + 02 CC-FREQ PIC X. + 02 CC-FUTURE PIC X(5). + FD GARFILE + BLOCK CONTAINS 3 RECORDS + DATA RECORD IS G-MASTER. + 01 G-MASTER. + 02 G-GARNO PIC X(8). + 02 G-GARNAME PIC X(24). + 02 G-BILLADD PIC X(22). + 02 G-STREET PIC X(22). + 02 G-CITY PIC X(18). + 02 G-STATE PIC X(2). + 02 G-ZIP PIC X(9). + 02 G-COLLT PIC X. + 02 G-PHONE PIC X(10). + 02 G-SEX PIC X. + 02 G-RELATE PIC X. + 02 G-MSTAT PIC X. + 02 G-DOB PIC X(8). + 02 G-DUNNING PIC X. + 02 G-ACCTSTAT PIC X. + 02 G-PR-MPLR PIC X(4). + 02 G-PRINS PIC XXX. + 02 G-PR-ASSIGN PIC X. + 02 G-PR-OFFICE PIC X(4). + 02 G-PR-GROUP PIC X(10). + 02 G-PRIPOL PIC X(16). + 02 G-PRNAME PIC X(24). + 02 G-PR-RELATE PIC X. + 02 G-SE-MPLR PIC X(4). + 02 G-SEINS PIC XXX. + 02 G-SE-ASSIGN PIC X. + 02 G-TRINSIND PIC X. + 02 G-TRINS PIC XXX. + 02 G-SE-GROUP PIC X(10). + 02 G-SECPOL PIC X(16). + 02 G-SENAME PIC X(24). + 02 G-SE-RELATE PIC X. + 02 G-COPAY PIC S9(5)V99. + 02 G-LASTBILL PIC X(8). + 02 G-ASSIGNM PIC X. + 02 G-PRIVATE PIC X. + 02 G-BILLCYCLE PIC X. + 02 G-DELETE PIC X. + 02 G-FILLER PIC XXX. + 02 G-ACCT PIC X(8). + 02 G-PRGRPNAME PIC X(15). + 02 G-SEGRPNAME PIC X(15). + + + + FD PAYCUR + * BLOCK CONTAINS 3 RECORDS + DATA RECORD IS PAYCUR01. + 01 PAYCUR01. + 02 PAYCUR-KEY. + 03 PC-KEY8 PIC X(8). + 03 PC-KEY3 PIC XXX. + 02 PC-AMOUNT PIC S9(4)V99. + 02 PC-PAYCODE PIC XXX. + 02 PC-DENIAL PIC XX. + 02 PC-CLAIM PIC X(6). + 02 PC-DATE-T PIC X(8). + 02 PC-DATE-E PIC X(8). + 02 PC-BATCH PIC X(6). + + FD INSFILE + * BLOCK CONTAINS 6 RECORDS + DATA RECORD IS INSFILE01. + 01 INSFILE01. + 02 INS-KEY PIC XXX. + 02 INS-NAME PIC X(22). + 02 INS-STREET PIC X(24). + 02 INS-CITY PIC X(15). + 02 INS-STATE PIC XX. + 02 INS-ZIP PIC X(9). + 02 INS-ASSIGN PIC X. + 02 INS-CLAIMTYPE PIC X. + 02 INS-NEIC PIC X(5). + 02 INS-NEICLEVEL PIC X. + 02 INS-NEIC-ASSIGN PIC X. + 02 INS-PPO PIC X. + 02 INS-PRVNUM PIC X(10). + 02 INS-HMO PIC X(3). + 02 INS-STATUS PIC X. + 02 INS-LEVEL PIC X. + 02 INS-LASTDATE PIC X(8). + 02 INS-CAID PIC XXX. + 02 INS-REFWARN PIC X. + 02 INS-FUTURE PIC X(8). + + FD PATFILE + * BLOCK CONTAINS 5 RECORDS + DATA RECORD IS P-MASTER. + 01 P-MASTER. + 02 P-PATNO PIC X(8). + 02 P-GARNO PIC X(8). + 02 P-PATNAME PIC X(24). + 02 P-SEX PIC X. + 02 P-RELATE PIC X. + 02 P-MSTAT PIC X. + 02 P-DOB PIC X(8). + + FD MPLRFILE. + 01 MPLRFILE01. + 02 MPLR-KEY PIC X(8). + 02 MPLR-NAME PIC X(22). + 02 MPLR-STREET PIC X(24). + 02 MPLR-CITY PIC X(15). + 02 MPLR-STATE PIC XX. + 02 MPLR-ZIP PIC X(9). + 02 MPLR-CLAIMNO PIC X(15). + 02 MPLR-TRINS PIC XXX. + 02 MPLR-TR-ASSIGN PIC X. + 02 MPLR-TR-GROUP PIC X(10). + 02 MPLR-TRIPOL PIC X(16). + 02 MPLR-TR-NAME PIC X(24). + 02 MPLR-TR-RELATE PIC X. + 02 MPLR-FUTURE PIC X(6). + + FD AUTHFILE + BLOCK CONTAINS 6 RECORDS + DATA RECORD IS AUTHFILE01. + 01 AUTHFILE01. + 02 AUTH-KEY. + 03 AUTH-KEY8 PIC X(8). + 03 AUTH-KEY6 PIC X(6). + 02 AUTH-NUM PIC X(15). + 02 AUTH-QNTY PIC XX. + 02 AUTH-DATE-E PIC X(8). + 02 AUTH-FILLER PIC XXX. + + FD REFPHY + * BLOCK CONTAINS 5 RECORDS + DATA RECORD IS REFPHY01. + 01 REFPHY01. + 02 REF-KEY PIC XXX. + 02 REF-BSNUM PIC X(5). + 02 REF-CRNUM PIC X(6). + 02 REF-UPIN PIC X(6). + 02 REF-CDNUM PIC X(7). + 02 REF-NAME PIC X(24). + 02 REF-NPI PIC X(10). + FD GAPFILE. + 01 GAPFILE01. + 02 GAPKEY PIC X(7). + 02 GAP-NAME PIC X(25). + 02 GAP-ADDR PIC X(22). + 02 GAP-CITY PIC X(15). + 02 GAP-STATE PIC XX. + 02 GAP-ZIP PIC X(9). + 02 GAP-TYPE PIC X. + 02 GAP-FUTURE PIC X(40). + FD DIAGFILE + BLOCK CONTAINS 15 RECORDS + DATA RECORD IS DIAG01. + 01 DIAG01. + 02 DIAG-KEY PIC X(7). + 02 DIAG-TITLE PIC X(61). + 02 DIAG-MEDB PIC X(5). + + WORKING-STORAGE SECTION. + 01 ISA01. + 02 ISA-0 PIC XXX VALUE "ISA". + 02 ISA-S0 PIC X VALUE "*". + 02 ISA-1 PIC XX. + 02 ISA-S1 PIC X VALUE "*". + 02 ISA-2 PIC X(10). + 02 ISA-S2 PIC X VALUE "*". + 02 ISA-3 PIC XX. + 02 ISA-S3 PIC X VALUE "*". + 02 ISA-4 PIC X(10). + 02 ISA-S4 PIC X VALUE "*". + 02 ISA-5 PIC XX. + 02 ISA-S5 PIC X VALUE "*". + 02 ISA-6 PIC X(15). + 02 ISA-S6 PIC X VALUE "*". + 02 ISA-7 PIC XX. + 02 ISA-S7 PIC X VALUE "*". + 02 ISA-8 PIC X(15). + 02 ISA-S8 PIC X VALUE "*". + 02 ISA-9 PIC X(6). + 02 ISA-S9 PIC X VALUE "*". + 02 ISA-10 PIC X(4). + 02 ISA-S10 PIC X VALUE "*". + 02 ISA-11 PIC X. + 02 ISA-S11 PIC X VALUE "*". + 02 ISA-12 PIC X(5). + 02 ISA-S12 PIC X VALUE "*". + 02 ISA-13 PIC X(9). + 02 ISA-S13 PIC X VALUE "*". + 02 ISA-14 PIC X. + 02 ISA-S14 PIC X VALUE "*". + 02 ISA-15 PIC X. + 02 ISA-S15 PIC X VALUE "*". + 02 ISA-16 PIC X. + 02 ISA-S16 PIC X VALUE "*". + 02 ISA-END PIC X VALUE "~". + 01 IEA01. + 02 IEA-0 PIC XXX VALUE "IEA". + 02 IEA-S0 PIC X VALUE "*". + 02 IEA-1 PIC X VALUE "1". + 02 IEA-END PIC X VALUE "~". + + 01 GS01. + 02 GS-0 PIC XX VALUE "GS". + 02 GS-S0 PIC X VALUE "*". + 02 GS-1 PIC XX VALUE "HC". + 02 GS-S1 PIC X VALUE "*". + 02 GS-2 PIC X(9) VALUE "0M4 ". + 02 GS-S2 PIC X VALUE "*". + 02 GS-3 PIC X(9) VALUE "EMEDNYBAT". + 02 GS-S3 PIC X VALUE "*". + 02 GS-4 PIC X(8). + 02 GS-S4 PIC X VALUE "*". + 02 GS-5 PIC X(4). + 02 GS-S5 PIC X VALUE "*". + 02 GS-NUM PIC X(9). + 02 GS-S6 PIC X VALUE "*". + 02 GS-7 PIC X VALUE "X". + 02 GS-S7 PIC X VALUE "*". + 02 GS-8 PIC X(12) VALUE "005010X222A1". + 02 GS-S8 PIC X VALUE "*". + 02 GS-END PIC X VALUE "~". + 01 ST01. + 02 ST-0 PIC XX VALUE "ST". + 02 ST-S0 PIC X VALUE "*". + 02 ST-1 PIC XXX VALUE "837". + 02 ST-S1 PIC X VALUE "*". + 02 ST-NUM PIC X(9). + 02 ST-S2 PIC X VALUE "*". + 02 ST-CONVENT-REF PIC X(12) VALUE "005010X222A1". + 02 ST-END PIC X VALUE "~". + 01 SE01. + 02 SE-0 PIC XX VALUE "SE". + 02 SE-S0 PIC X VALUE "*". + 02 SE-CNTR PIC X(9). + 02 SE-S1 PIC X VALUE "*". + 02 SE-NUM PIC X(9). + 02 SE-END PIC X VALUE "~". + 01 GE01. + 02 GE-0 PIC XX VALUE "GE". + 02 GE-S0 PIC X VALUE "*". + 02 GE-CNTR PIC 9 VALUE 1. + 02 GE-S1 PIC X VALUE "*". + 02 GE-NUM PIC X(9). + 02 GE-END PIC X VALUE "~". + + + 01 BHT01. + 02 BHT-0 PIC XXX VALUE "BHT". + 02 BHT-S0 PIC X VALUE "*". + 02 BHT-1 PIC X(4) VALUE "0019". + 02 BHT-S1 PIC X VALUE "*". + 02 BHT-2 PIC XX VALUE "00". + 02 BHT-S2 PIC X VALUE "*". + 02 BHT-NUM PIC X(9). + 02 BHT-S3 PIC X VALUE "*". + 02 BHT-DATE PIC X(8). + 02 BHT-S4 PIC X VALUE "*". + 02 BHT-TIME PIC X(4). + 02 BHT-S5 PIC X VALUE "*". + 02 BHT-6 PIC XX VALUE "CH". + 02 BHT-END PIC X VALUE "~". + 01 REF01. + 02 REF-0 PIC XXX VALUE "REF". + 02 REF-S0 PIC X VALUE "*". + 02 REF-CODE PIC X(30). + 02 REF-S1 PIC X VALUE "*". + 02 REF-ID PIC X(30). + 02 REF-S2 PIC X VALUE "*". + 02 REF-3 PIC XX VALUE SPACE. + 02 REF-S3 PIC X VALUE "*". + 02 REF-4 PIC XX VALUE SPACE. + 02 REF-S4 PIC X VALUE "*". + 02 REF-END PIC X VALUE "~". + 01 SAVE-DOCREF01. + 02 SAVE-DOCREF-0 PIC XXX VALUE "REF". + 02 SAVE-DOCREF-S0 PIC X VALUE "*". + 02 SAVE-DOCREF-CODE PIC X(30). + 02 SAVE-DOCREF-S1 PIC X VALUE "*". + 02 SAVE-DOCREF-ID PIC X(30). + 02 SAVE-DOCREF-S2 PIC X VALUE "*". + 02 SAVE-DOCREF-3 PIC XX VALUE SPACE. + 02 SAVE-DOCREF-S3 PIC X VALUE "*". + 02 SAVE-DOCREF-4 PIC XX VALUE SPACE. + 02 SAVE-DOCREF-S4 PIC X VALUE "*". + 02 SAVE-DOCREF-END PIC X VALUE "~". + + 01 SUBM01. + 02 SUBM-0 PIC XXX VALUE "NM1". + 02 SUBM-S0 PIC X VALUE "*". + 02 SUBM-1 PIC XX VALUE "41". + 02 SUBM-S1 PIC X VALUE "*". + 02 SUBM-2 PIC X VALUE "2". + 02 SUBM-S2 PIC X VALUE "*". + 02 SUBM-3 PIC X(25) VALUE "CARE MANAGEMENT SOLUTIONS". + 02 SUBM-S3 PIC X VALUE "*". + 02 SUBM-S4 PIC X VALUE "*". + 02 SUBM-S5 PIC X VALUE "*". + 02 SUBM-S51 PIC X VALUE "*". + 02 SUBM-S6 PIC X VALUE "*". + 02 SUBM-8 PIC XX VALUE "46". + 02 SUBM-S7 PIC X VALUE "*". + 02 SUBM-NUM PIC X(9) VALUE "0M4". + 02 SUBM-END PIC X VALUE "~". + 01 SUBPER01. + 02 SUBPER-0 PIC XXX VALUE "PER". + 02 SUBPER-S0 PIC X VALUE "*". + 02 SUBPER-1 PIC XX VALUE "IC". + 02 SUBPER-S1 PIC X VALUE "*". + 02 SUBPER-2 PIC X(9) VALUE "S WAITE". + 02 SUBPER-S2 PIC X VALUE "*". + 02 SUBPER-3 PIC XX VALUE "TE". + 02 SUBPER-S3 PIC X VALUE "*". + 02 SUBPER-4 PIC X(10) VALUE "8003718685". + 02 SUBPER-S4 PIC X VALUE "*". + 02 SUBPER-5 PIC XX VALUE "FX". + 02 SUBPER-S5 PIC X VALUE "*". + 02 SUBPER-6 PIC X(10) VALUE "8027705175". + 02 SUBPER-S6 PIC X VALUE "*". + 02 SUBPER-7 PIC XX VALUE "EM". + 02 SUBPER-S7 PIC X VALUE "*". + 02 SUBPER-8 PIC X(23) VALUE "stephen.waite@cmsvt.com". + 02 SUBPER-S9 PIC X VALUE "*". + 02 SUBPER-END PIC X VALUE "~". + 01 INSNM01. + 02 INSNM-1 PIC XXX VALUE "NM1". + 02 INSNM-S0 PIC X VALUE "*". + 02 INSNM-2 PIC XX VALUE "40". + 02 INSNM-S1 PIC X VALUE "*". + 02 INSNM-3 PIC X VALUE "2". + 02 INSNM-S2 PIC X VALUE "*". + 02 INSNM-NAME PIC X(35). + 02 INSNM-S3 PIC X VALUE "*". + 02 INSNM-S4 PIC X VALUE "*". + 02 INSNM-S5 PIC X VALUE "*". + 02 INSNM-S51 PIC X VALUE "*". + 02 INSNM-S6 PIC X VALUE "*". + 02 INSNM-8 PIC XX VALUE "46". + 02 INSNM-S7 PIC X VALUE "*". + 02 INSNM-NUM PIC X(9). + 02 INSNM-END PIC X VALUE "~". + 01 HL01. + 02 HL-0 PIC XX VALUE "HL". + 02 HL-S0 PIC X VALUE "*". + 02 HL-NUMX PIC X(5). + 02 HL-S1 PIC X VALUE "*". + 02 HL-PARENT PIC X(5). + 02 HL-S2 PIC X VALUE "*". + 02 HL-CODE PIC X(4). + 02 HL-S3 PIC X VALUE "*". + 02 HL-CHILD PIC X. + 02 HL-S4 PIC X VALUE "*". + 02 HL-END PIC X VALUE "~". + 01 PRV01. + 02 PRV-0 PIC XXX VALUE "PRV". + 02 PRV-S0 PIC X VALUE "*". + 02 PRV-1 PIC XX VALUE "BI". + 02 PRV-S1 PIC X VALUE "*". + 02 PRV-2 PIC XXX VALUE "PXC". + 02 PRV-S2 PIC X VALUE "*". + 02 PRV-TAX PIC X(10). + 02 PRV-END PIC X VALUE "~". + 01 PER01. + 02 PER-0 PIC XXX VALUE "PER". + 02 PER-S0 PIC X VALUE "*". + 02 PER-1 PIC XX VALUE "IC". + 02 PER-S1 PIC X VALUE "*". + 02 PER-CONTACT PIC X(30). + 02 PER-S2 PIC X VALUE "*". + 02 PER-3 PIC XX VALUE "TE". + 02 PER-STE PIC X VALUE "*". + 02 PER-PHONE PIC X(10). + 02 PER-S3 PIC X VALUE "*". + 02 PER-S4 PIC X VALUE "*". + 02 PER-S5 PIC X VALUE "*". + 02 PER-S6 PIC X VALUE "*". + 02 PER-S7 PIC X VALUE "*". + 02 PER-S8 PIC X VALUE "*". + 02 PER-S9 PIC X VALUE "*". + 02 PER-END PIC X VALUE "~". + 01 NM101. + 02 NM1-0 PIC XXX VALUE "NM1". + 02 NM1-S0 PIC X VALUE "*". + 02 NM1-1 PIC XXX. + 02 NM1-S1 PIC X VALUE "*". + 02 NM1-SOLO PIC X. + 02 NM1-S2 PIC X VALUE "*". + 02 NM1-NAMEL PIC X(40). + 02 NM1-S3 PIC X VALUE "*". + 02 NM1-NAMEF PIC X(25). + 02 NM1-S4 PIC X VALUE "*". + 02 NM1-NAMEM PIC X. + 02 NM1-S5 PIC X VALUE "*". + 02 NM1-S51 PIC X VALUE "*". + 02 NM1-NAMES PIC XXX. + 02 NM1-S6 PIC X VALUE "*". + 02 NM1-EINSS PIC XX. + 02 NM1-S7 PIC X VALUE "*". + 02 NM1-CODE PIC X(16). + 02 NM1-END PIC X VALUE "~". + 01 SAVE-DOCNM101. + 02 SAVE-DOCNM1-0 PIC XXX VALUE "NM1". + 02 SAVE-DOCNM1-S0 PIC X VALUE "*". + 02 SAVE-DOCNM1-1 PIC XXX. + 02 SAVE-DOCNM1-S1 PIC X VALUE "*". + 02 SAVE-DOCNM1-SOLO PIC X. + 02 SAVE-DOCNM1-S2 PIC X VALUE "*". + 02 SAVE-DOCNM1-NAMEL PIC X(40). + 02 SAVE-DOCNM1-S3 PIC X VALUE "*". + 02 SAVE-DOCNM1-NAMEF PIC X(25). + 02 SAVE-DOCNM1-S4 PIC X VALUE "*". + 02 SAVE-DOCNM1-NAMEM PIC X. + 02 SAVE-DOCNM1-S5 PIC X VALUE "*". + 02 SAVE-DOCNM1-S51 PIC X VALUE "*". + 02 SAVE-DOCNM1-NAMES PIC XXX. + 02 SAVE-DOCNM1-S6 PIC X VALUE "*". + 02 SAVE-DOCNM1-EINSS PIC XX. + 02 SAVE-DOCNM1-S7 PIC X VALUE "*". + 02 SAVE-DOCNM1-CODE PIC X(16). + 02 SAVE-DOCNM1-END PIC X VALUE "~". + + 01 RECNM101. + 02 RECNM1-0 PIC XXX VALUE "NM1". + 02 RECNM1-S0 PIC X VALUE "*". + 02 RECNM1-1 PIC XXX VALUE "40 ". + 02 RECNM1-S1 PIC X VALUE "*". + 02 RECNM1-SOLO PIC X VALUE "2". + 02 RECNM1-S2 PIC X VALUE "*". + 02 RECNM1-NAMEL PIC X(6) VALUE "NYSDOH". + 02 RECNM1-S3 PIC X VALUE "*". + 02 RECNM1-S4 PIC X VALUE "*". + 02 RECNM1-S5 PIC X VALUE "*". + 02 RECNM1-S51 PIC X VALUE "*". + 02 RECNM1-S6 PIC X VALUE "*". + 02 RECNM1-8 PIC XX VALUE "46". + 02 RECNM1-S7 PIC X VALUE "*". + 02 RECNM1-CODE PIC X(9) VALUE "141797357". + 02 RECNM1-END PIC X VALUE "~". + + 01 N301. + 02 N3-0 PIC XX VALUE "N3". + 02 N3-S0 PIC X VALUE "*". + 02 N3-STREET PIC X(24). + 02 N3-S1 PIC X VALUE "*". + 02 N3-BILLADD PIC X(24). + 02 N3-S2 PIC X VALUE "*". + 02 N3-END PIC X VALUE "~". + 01 N401. + 02 N4-0 PIC XX VALUE "N4". + 02 N4-S0 PIC X VALUE "*". + 02 N4-CITY PIC X(20). + 02 N4-S1 PIC X VALUE "*". + 02 N4-STATE PIC XX. + 02 N4-S2 PIC X VALUE "*". + 02 N4-ZIP PIC X(9). + 02 N4-S3 PIC X VALUE "*". + 02 N4-S4 PIC X VALUE "*". + 02 N4-S5 PIC X VALUE "*". + 02 N4-S6 PIC X VALUE "*". + 02 N4-END PIC X VALUE "~". + 01 SBR01. + 02 SBR-0 PIC XXX VALUE "SBR". + 02 SBR-S0 PIC X VALUE "*". + 02 SBR-PST PIC X. + 02 SBR-S1 PIC X VALUE "*". + 02 SBR-RELATE PIC XX. + 02 SBR-S2 PIC X VALUE "*". + 02 SBR-GROUP PIC X(16). + 02 SBR-S3 PIC X VALUE "*". + 02 SBR-GRNAME PIC X(22) VALUE SPACE. + 02 SBR-S4 PIC X VALUE "*". + 02 SBR-TYPE PIC XX. + 02 SBR-S5 PIC X VALUE "*". + 02 SBR-6 PIC X. + 02 SBR-S6 PIC X VALUE "*". + 02 SBR-7 PIC X. + 02 SBR-S7 PIC X VALUE "*". + 02 SBR-8 PIC X. + 02 SBR-S8 PIC X VALUE "*". + 02 SBR-INSCODE PIC XXX. + 02 SBR-S9 PIC X VALUE "*". + 02 SBR-END PIC X VALUE "~". + 01 DMG01. + 02 DMG-0 PIC XXX VALUE "DMG". + 02 DMG-S0 PIC X VALUE "*". + 02 DMG-1 PIC XX VALUE "D8". + 02 DMG-S1 PIC X VALUE "*". + 02 DMG-DOB PIC X(8). + 02 DMG-S2 PIC X VALUE "*". + 02 DMG-GENDER PIC X. + 02 DMG-S3 PIC X VALUE "*". + 02 DMG-S4 PIC X VALUE "*". + 02 DMG-S5 PIC X VALUE "*". + 02 DMG-S6 PIC X VALUE "*". + 02 DMG-S7 PIC X VALUE "*". + 02 DMG-S8 PIC X VALUE "*". + 02 DMG-S9 PIC X VALUE "*". + 02 DMG-END PIC X VALUE "~". + 01 PAT01. + 02 PAT-0 PIC XXX VALUE "PAT". + 02 PAT-S0 PIC X VALUE "*". + 02 PAT-RELATE PIC XX. + 02 PAT-S1 PIC X VALUE "*". + 02 PAT-LOCATE PIC X. + 02 PAT-S2 PIC X VALUE "*". + 02 PAT-EMPLOYM PIC XX. + 02 PAT-S3 PIC X VALUE "*". + 02 PAT-STUD PIC X. + 02 PAT-S4 PIC X VALUE "*". + 02 PAT-QUAL PIC XX . + 02 PAT-S5 PIC X VALUE "*". + 02 PAT-DATE PIC X(8). + 02 PAT-S6 PIC X VALUE "*". + 02 PAT-MEAS PIC XX. + 02 PAT-S7 PIC X VALUE "*". + 02 PAT-WT PIC X. + 02 PAT-S8 PIC X VALUE "*". + 02 PAT-PREGO PIC X. + 02 PAT-S9 PIC X VALUE "*". + 02 PAT-END PIC X VALUE "~". + + 01 CLM01. + 02 CLM-0 PIC XXX VALUE "CLM". + 02 CLM-S0 PIC X VALUE "*". + 02 CLM-1 PIC X(16). + 02 CLM-S1 PIC X VALUE "*". + 02 CLM-2 PIC X(8). + 02 CLM-S2 PIC X VALUE "*". + 02 CLM-3 PIC XX VALUE SPACE. + 02 CLM-S3 PIC X VALUE "*". + 02 CLM-4 PIC X VALUE SPACE. + 02 CLM-S4 PIC X VALUE "*". + 02 CLM-5 PIC XX. + 02 CLM-S52 PIC X VALUE ":". + 02 CLM-5-2 PIC X VALUE "B". + 02 CLM-COLON-PLACE PIC X VALUE ":". + 02 CLM-FREQ PIC X VALUE "1". + 02 CLM-S5 PIC X VALUE "*". + 02 CLM-6 PIC X VALUE "Y". + 02 CLM-S6 PIC X VALUE "*". + 02 CLM-7 PIC X VALUE "A". + 02 CLM-S7 PIC X VALUE "*". + 02 CLM-8 PIC X VALUE "Y". + 02 CLM-S8 PIC X VALUE "*". + 02 CLM-9 PIC X VALUE "Y". + 02 CLM-S9 PIC X VALUE "*". + 02 CLM-10 PIC X VALUE "P". + 02 CLM-S10 PIC X VALUE "*". + 02 CLM-11 PIC XX. + 02 CLM-COLON-ACCIDENT PIC X VALUE SPACE. + 02 CLM-S11 PIC X VALUE "*". + 02 CLM-12 PIC XXX. + 02 CLM-S12 PIC X VALUE "*". + 02 CLM-13 PIC X. + 02 CLM-S13 PIC X VALUE "*". + 02 CLM-14 PIC XXX. + 02 CLM-S14 PIC X VALUE "*". + 02 CLM-15 PIC X. + 02 CLM-S15 PIC X VALUE "*". + 02 CLM-16 PIC X. + 02 CLM-S16 PIC X VALUE "*". + 02 CLM-17 PIC XX. + 02 CLM-S17 PIC X VALUE "*". + 02 CLM-18 PIC X. + 02 CLM-S18 PIC X VALUE "*". + 02 CLM-19 PIC XX. + 02 CLM-S19 PIC X VALUE "*". + 02 CLM-20 PIC XX. + 02 CLM-END PIC X VALUE "~". + + 01 HI901. + 02 HI9-0 PIC XX VALUE "HI". + 02 HI9-S0 PIC X VALUE "*". + 02 HI9-1C PIC XXX VALUE "BK:". + 02 HI9-DX1 PIC X(5). + 02 HI9-DIAG-FILLER PIC X(108). + 02 HI9-END PIC X VALUE "~". + 01 HI1001. + 02 HI10-0 PIC XX VALUE "HI". + 02 HI10-S0 PIC X VALUE "*". + 02 HI10-1C PIC XXXX VALUE "ABK:". + 02 HI10-DX1 PIC X(7). + 02 HI10-DIAG-FILLER PIC X(144). + 02 HI10-END PIC X VALUE "~". + 01 CAS01. + 02 CAS-0 PIC XXX VALUE "CAS". + 02 CAS-S0 PIC X VALUE "*". + 02 CAS-1 PIC XX. + 02 CAS-S1 PIC X VALUE "*". + 02 CAS-2 PIC XXX. + 02 CAS-S2 PIC X VALUE "*". + 02 CAS-3 PIC X(8). + 02 CAS-S3 PIC X VALUE "*". + 02 CAS-4 PIC X. + 02 CAS-END PIC X VALUE "~". + 01 AMT01. + 02 AMT-0 PIC XXX VALUE "AMT". + 02 AMT-S0 PIC X VALUE "*". + 02 AMT-1 PIC XXX. + 02 AMT-S1 PIC X VALUE "*". + 02 AMT-2 PIC X(8). + 02 AMT-END PIC X VALUE "~". + 01 LX01. + 02 LX-0 PIC XX VALUE "LX". + 02 LX-S0 PIC X VALUE "*". + 02 LX-1 PIC XX. + 02 LX-END PIC X VALUE "~". + 01 SV101. + 02 SV1-0 PIC XXX VALUE "SV1". + 02 SV1-S0 PIC X VALUE "*". + 02 SV1-1 PIC XX VALUE "HC". + 02 SV1-S1 PIC X VALUE ":". + 02 SV1-PROC PIC X(5). + 02 SV1-MOD-FILLER PIC X(33). + 02 SV1-S6 PIC X VALUE "*". + 02 SV1-AMT PIC X(7). + 02 SV1-S7 PIC X VALUE "*". + 02 SV1-8 PIC XX VALUE "UN". + 02 SV1-S8 PIC X VALUE "*". + 02 SV1-WORK PIC XX. + 02 SV1-S9 PIC X VALUE "*". + 02 SV1-PLACE PIC XX. + 02 SV1-S10 PIC X VALUE "*". + 02 SV1-S11 PIC X VALUE "*". + 02 SV1-PT PIC X(36). + 02 SV1-S15 PIC X VALUE "*". + 02 SV1-S16 PIC X VALUE "*". + 02 SV1-EMER PIC X. + 02 SV1-S115 PIC XX VALUE "**". + 02 SV1-EPSDT PIC XX. + 02 SV1-S116 PIC X VALUE "*". + 02 SV1-FAMILY PIC X. + 02 SV1-S117 PIC XXX VALUE "***". + 02 SV1-COPAY PIC X. + 02 SV1-END PIC X VALUE "~". + 01 DTP01. + 02 DTP-0 PIC XXX VALUE "DTP". + 02 DTP-S0 PIC X VALUE "*". + 02 DTP-1 PIC XXX. + 02 DTP-S1 PIC X VALUE "*". + 02 DTP-2 PIC XX VALUE "D8". + 02 DTP-S2 PIC X VALUE "*". + 02 DTP-3 PIC X(8). + 02 DTP-END PIC X VALUE "~". + 01 SVD01. + 02 SVD-0 PIC XXX VALUE "SVD". + 02 SVD-S1 PIC X VALUE "*". + 02 SVD-1 PIC X(5). + 02 SVD-S3 PIC X VALUE "*". + 02 SVD-2 PIC X(8). + 02 SVD-S2 PIC X VALUE "*". + 02 SVD-3 PIC X(20). + 02 SVD-S34 PIC XX VALUE "**". + 02 SVD-4 PIC XX. + 02 SVD-END PIC X VALUE "~". + 01 OI01. + 02 OI-0 PIC XX VALUE "OI". + 02 OI-S12 PIC XXX VALUE "***". + 02 OI-3 PIC X VALUE "Y". + 02 OI-S4 PIC X VALUE "*". + 02 OI-4 PIC X VALUE "P". + 02 OI-S56 PIC XX VALUE "**". + 02 OI-6 PIC X VALUE "Y". + 02 OI-END PIC X VALUE "~". + 01 TEST-DATE. + 05 T-CC PIC XX. + 05 T-YY PIC XX. + 05 T-MM PIC XX. + 05 T-DD PIC XX. + 01 DISPLAY-DATE. + 05 T-MM PIC XX. + 05 FILLER PIC X VALUE "/". + 05 T-DD PIC XX. + 05 FILLER PIC X VALUE "/". + 05 T-CC PIC XX. + 05 T-YY PIC XX. + 01 ALF14. + 02 ALF14-3 PIC XXX. + 02 ALF14-9 PIC X(9). + 02 FILLER PIC XX. + 01 DATE-X PIC X(8). + 01 TIME-X. + 02 TIME-HHMM PIC X(4). + 02 FILLER PIC X(4). + 01 DDFLAG PIC 9. + 01 FLAG PIC 9. + 01 CLIA-FLAG PIC 9. + 01 ORDER-FLAG PIC 9. + 01 END-FLAG PIC 9 VALUE 0. + 01 GAP-FLAG PIC 9. + 01 CNTR PIC 99. + 01 DIAG-CNTR PIC 99. + 01 DX-CNTR-PT PIC 9. + 01 X PIC 99. + 01 DIAG-X PIC X(7). + 01 Y PIC 99. + 01 A PIC 99. + 01 B PIC 99. + 01 C PIC 999. + 01 D PIC 999. + 01 DIAG9-ARRAY01. + 02 DIAG9-ARRAY OCCURS 12 TIMES. + 03 DIAG9-BF PIC XXXX. + 03 DIAG9-CODE PIC X(5). + 01 DIAG10-ARRAY01. + 02 DIAG10-ARRAY OCCURS 12 TIMES. + 03 DIAG10-BF PIC XXXXX. + 03 DIAG10-CODE PIC X(7). + 01 MOD-ARRAY01. + 02 MOD-ARRAY OCCURS 4 TIMES. + 03 MOD-C PIC X. + 03 MOD-CODE PIC XX. + 01 DIAG-POINTER01. + 02 DIAG-POINTER OCCURS 12 TIMES. + 03 DIAG-PT PIC Z9. + 03 DIAG-C PIC X. + 01 DIAGTAB01. + 02 DIAGTAB PIC X(7) OCCURS 12 TIMES. + 01 FILETAB01. + 02 FILETAB PIC X(160) OCCURS 50 TIMES. + 01 TAB3601. + 02 TAB36 PIC X OCCURS 36 TIMES. + 01 tab11401. + 02 TAB114 PIC X OCCURS 114 TIMES. + 01 ALF114 PIC X(114). + 01 GROUP-3 PIC XXX. + 01 ALF1 PIC X. + 01 ALF-4. + 02 ALF-4-1 PIC XX. + 02 ALF-4-2 PIC XX. + 01 ALF10 PIC X(10). + 01 ALF20 PIC X(20). + 01 ALF5 PIC X(5). + 01 ALF7. + 02 ALF71 PIC XX. + 02 ALF72 PIC X(5). + 01 ALF9 PIC X(9). + 01 ALF-9 PIC X(9). + 01 ALFS PIC X(5). + 01 ALFS8 PIC X(8). + 01 ALFS9 PIC X(9). + 01 ALF5Z PIC ZZZZZ. + 01 ALF9Z PIC ZZZZZZZZZ. + 01 ALF5NUM PIC X(5). + 01 ALF9NUM PIC X(9). + 01 NUM7 PIC 9(5)V99. + 01 ALF8 PIC X(8). + 01 ALF8Z PIC ZZZZ9.99. + 01 ALF8NUM PIC X(8). + 01 NUM5 PIC 9(5). + 01 NUM9 PIC 9(9). + 01 NUM2 PIC 99. + 01 HL-NUMPARENT PIC 9(5). + 01 HL-NUM PIC 9(5) VALUE 0. + 01 DOC-TAB01. + 02 DOC-TAB02 OCCURS 90 TIMES. + 03 DOC-TAX PIC X(10). + 03 DOC-SS PIC X(9). + 03 DOC-NUM PIC X(9). + 03 DOC-LASTNAME PIC X(20). + 03 DOC-FIRSTNAME PIC X(10). + 03 DOC-MI PIC X. + 03 DOC-NPI PIC X(10). + 01 PARM01. + 02 PM-1 PIC XX. + 02 FILLER PIC X. + 02 PM-2 PIC X(10). + 02 FILLER PIC X. + 02 PM-3 PIC X(9). + 02 FILLER PIC X. + 02 PM-4 PIC X(8). + 02 FILLER PIC X. + 02 PM-5 PIC X(31). + 02 FILLER PIC X. + 02 PM-6 PIC X(10). + 01 EINSS PIC X(9). + 01 EINSS-TYPE PIC X. + 01 PARMLAST PIC X(15). + 01 PARMFIRST PIC X(15). + 01 PARMMIDDLE PIC X. + 01 ORG-NAME PIC X(40). + 01 ORG-CITY PIC X(30). + 01 ORG-STATE PIC XX. + 01 ORG-ZIP PIC X(9). + 01 INSTYPE-CODE PIC XXX. + 01 SUBMIT01. + 02 SUBMIT-1 PIC X(8). + 02 SUBMIT-2 PIC XX. + 01 TELE-PHONE PIC X(10). + 01 ORG-STREET PIC X(24). + 01 EIN-CODE PIC X(12). + 01 CONTACT-NAME PIC X(30). + 01 PLACE-TAB01. + 02 PLACE-TAB OCCURS 29 TIMES. + 03 PL-TAB PIC X. + 03 PL-NUM PIC X. + 03 PL-NAME PIC X(22). + 03 PL-STREET PIC X(18). + 03 PL-CITY PIC X(15). + 03 PL-STATE PIC XX. + 03 PL-ZIP PIC X(9). + 01 PLINDX PIC 99 VALUE 0. + 01 CC-PL PIC X. + 01 HL-NUMPRV-SAVE PIC X(5). + 01 HL-SBR-SAVE PIC X(5). + 01 X-RELATE PIC X. + 01 SBR-RELATEHOLD PIC X. + 01 SUB-RELATE PIC X. + 01 SUB-NAME PIC X(24). + 01 SUB-GROUP PIC X(12). + 01 SUB-POLICY PIC X(14). + 01 TOT-AMOUNT PIC 9(4)V99. + 01 PLACE-POINTER PIC 99. + 01 SAVE01 PIC X(160). + 01 X-MOD. + 02 X-MOD1 PIC XX. + 02 X-MOD2 PIC XX. + 02 X-MOD3 PIC XX. + 01 NAME-1 PIC X(24). + 01 NAME-2 PIC X(24). + 01 HOLD-FILEIN01. + 02 HOLD-FILEIN-KEY. + 03 HOLD-KEY8 PIC X(8). + 03 HOLD-KEY3 PIC XXX. + 02 HOLD-PATID. + 03 HOLD-PATID7 PIC X(7). + 03 HOLD-PATID8 PIC X. + 02 HOLD-CLAIM PIC X(6). + 02 HOLD-SERVICE PIC X. + 02 HOLD-DIAG PIC X(7). + 02 HOLD-PROC. + 03 HOLD-PROC0 PIC X(4). + 03 HOLD-PROC1 PIC X(5). + 03 HOLD-PROC2 PIC XX. + 02 HOLD-MOD2 PIC XX. + 02 HOLD-MOD3 PIC XX. + 02 HOLD-MOD4 PIC XX. + 02 HOLD-AMOUNT PIC S9(4)V99. + 02 HOLD-DOCR PIC X(3). + 02 HOLD-DOCP PIC 99. + 02 HOLD-PAYCODE PIC XXX. + 02 HOLD-STUD PIC X. + 02 HOLD-WORK PIC 99. + 02 HOLD-DAT1 PIC X(8). + 02 HOLD-RESULT PIC X. + 02 HOLD-ACTION PIC X. + 02 HOLD-SORCREF PIC X. + 02 HOLD-COLLT PIC X. + 02 HOLD-AGE PIC X. + 02 HOLD-PAPER PIC X. + 02 HOLD-PLACE PIC X. + 02 HOLD-IOPAT PIC X. + 02 HOLD-DATE-T PIC X(8). + 02 HOLD-DATE-A PIC X(8). + 02 HOLD-DATE-P PIC X(8). + 02 HOLD-REC-STAT PIC X. + 02 HOLD-DX2 PIC X(7). + 02 HOLD-DX3 PIC X(7). + 02 HOLD-ACC-TYPE PIC X. + 02 HOLD-DATE-M PIC X(8). + 02 HOLD-ASSIGN PIC X. + 02 HOLD-NEIC-ASSIGN PIC X. + 02 HOLD-DX4 PIC X(7). + 02 HOLD-DX5 PIC X(7). + 02 HOLD-DX6 PIC X(7). + 02 HOLD-FREQ PIC X. + 02 HOLD-FUTURE PIC X(5). + 01 MAMMO-FLAG PIC 9. + 01 mammo-code pic x(6). + 01 CLIA-NUM PIC X(12). + 01 GROUP-TAX PIC X(10). + 01 AGEX. + 02 AGEXYY PIC 9999. + 02 AGEXMMDD PIC XXXX. + 01 AGEY. + 02 AGEYYY PIC 9999. + 02 AGEYMMDD PIC XXXX. + 01 AGEZ PIC 999. + 01 CAS-DEDUC01. + 02 CAS-DEDUC PIC S9(4)V99 OCCURS 50 TIMES. + 01 CAS-REDUCE01. + 02 CAS-REDUCE PIC S9(4)V99 OCCURS 50 TIMES. + 01 CAS-ALLOWED01. + 02 CAS-ALLOWED PIC S9(4)V99 OCCURS 50 TIMES. + 01 CAS-PAID01. + 02 CAS-PAID PIC S9(4)V99 OCCURS 50 TIMES. + 01 CAS-PAYDATE01. + 02 CAS-PAYDATE PIC X(8) OCCURS 50 TIMES. + 01 CAS-DD01. + 02 CAS-DD PIC X OCCURS 50 TIMES. + + 01 CAS-TOT-REDUCE PIC 9(4)V99. + 01 CAS-TOT-CHARGE PIC 9(4)V99. + 01 CAS-TOT-ALLOWED PIC 9(4)V99. + 01 CAS-TOT-PAID PIC 9(4)V99. + 01 CLMBAL01. + 02 CLM-BAL PIC S9(4)V99 OCCURS 50 TIMES. + 01 REDUCE-FLAG PIC 9. + 01 PRIME-FLAG PIC 9. + 01 AMOUNT-X PIC S9(4)V99. + 01 MONTH-TABLE-CONS. + 05 FILLER PIC X(24) VALUE "312931303130313130313031". + 01 MONTH-TABLE REDEFINES MONTH-TABLE-CONS. + 05 DAYS-IN-MONTH OCCURS 12 TIMES PIC 99. + 01 X-DOB. + 02 X-YYYY PIC 9999. + 02 X-MM PIC 99. + 02 X-DD PIC 99. + 01 ANS PIC X. + 01 INSGROUP-CODE PIC X(12). + 01 INSGROUP-LEG PIC X(6). + 01 LASTREF PIC XXX. + 01 ZEF-7 PIC Z,ZZ9.99CR. + 01 CLAIM-ADJ-DATE PIC X(8). + + PROCEDURE DIVISION. + P0. + OPEN INPUT FILEIN GARFILE PATFILE INSFILE REFPHY + AUTHFILE MPLRFILE DIAGFILE PLACEFILE GAPFILE PARMFILE + PARMFILE2 PAYCUR PROCFILE. + OPEN OUTPUT SEGFILE ERRFILE. + OPEN I-O HIPCLAIMFILE + MOVE "A" TO HIP-KEY + READ HIPCLAIMFILE WITH LOCK INVALID + DISPLAY "BAD HIPCLAIMFILE" + GO TO P99. + COMPUTE NUM9 = HIP-NUM + PERFORM NUM-LEFT9 + MOVE ALF9NUM TO GS-NUM + MOVE ALF9NUM TO GE-NUM + ADD 1 TO HIP-NUM + OPEN I-O CHARCUR. + PERFORM ISA-1 THRU ISA-EXIT + PERFORM A0 THRU A0-EXIT. + MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM ISA01 + ACCEPT TIME-X FROM TIME + MOVE TIME-HHMM TO BHT-TIME GS-5. + ACCEPT BHT-DATE FROM CENTURY-DATE. + MOVE BHT-DATE TO GS-4. + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM GS01 + MOVE SPACE TO SEGFILE01 + + COMPUTE NUM9 = HIP-NUM + PERFORM NUM-LEFT9 + MOVE ALF9NUM TO ST-NUM + MOVE ALF9NUM TO SE-NUM + + + ADD 1 TO HIP-NUM + WRITE SEGFILE01 FROM ST01. + + COMPUTE NUM9 = HIP-NUM + PERFORM NUM-LEFT9 + MOVE ALF9NUM TO BHT-NUM + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM BHT01. + * MOVE SPACE TO REF-CODE REF-ID + * MOVE "87 " TO REF-CODE + * MOVE "005010X222A1" TO REF-ID + * MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM REF01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SUBM01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SUBPER01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM RECNM101. + + + P00. READ PLACEFILE AT END GO TO P000. + ADD 1 TO PLINDX. + MOVE DF1 TO PL-TAB(PLINDX) + MOVE DF2 TO PL-NUM(PLINDX) + MOVE DF3 TO PL-NAME(PLINDX) + MOVE DF4 TO PL-STREET(PLINDX) + MOVE DF5 TO PL-CITY(PLINDX) + MOVE DF6 TO PL-STATE(PLINDX) + MOVE DF7 TO PL-ZIP(PLINDX) + GO TO P00. + + P000. + READ FILEIN AT END GO TO P98. + MOVE FILEIN01 TO HOLD-FILEIN01 + PERFORM DF-SEARCH + PERFORM 2000A THRU 2000B + GO TO P0000-1. + + P0000. + MOVE SAVE01 TO HOLD-FILEIN01 FILEIN01 + PERFORM DF-SEARCH. + P0000-1. + MOVE 0 TO CNTR DIAG-CNTR TOT-AMOUNT MAMMO-FLAG + CLIA-FLAG + GO TO P1-1. + P1. READ FILEIN AT END MOVE 1 TO END-FLAG GO TO P2. + P1-1. + * IF CNTR > 0 GO TO P2. + IF DIAG-CNTR > 11 GO TO P2. + IF FI-PLACE = HOLD-PLACE + AND FI-KEY8 = HOLD-KEY8 + AND FI-PATID = HOLD-PATID + AND FI-DOCP = HOLD-DOCP + AND FI-DOCR = HOLD-DOCR + AND FI-DAT1 = HOLD-DAT1 + AND FI-ACC-TYPE = HOLD-ACC-TYPE + AND CNTR < 50 + PERFORM DIAG-1 THRU DIAG-EXIT + IF DIAG-CNTR > 12 GO TO P2 + END-IF + IF FI-SERVICE = "4" MOVE 1 TO CLIA-FLAG + END-IF + ADD 1 TO CNTR + MOVE FILEIN01 TO FILETAB(CNTR) + ADD FI-AMOUNT TO TOT-AMOUNT + GO TO P1. + P2. + MOVE FILEIN01 TO SAVE01 + PERFORM 2300CLM + PERFORM HI-DIAG THRU HI-DIAG-EXIT + PERFORM 2310D + PERFORM 2310E THRU 2310E-EXIT + PERFORM 2320A THRU 2320A-EXIT + MOVE 0 TO CAS-TOT-REDUCE + MOVE 0 TO CAS-TOT-CHARGE + MOVE 0 TO CAS-TOT-ALLOWED + MOVE 0 TO CAS-TOT-PAID + MOVE "0" TO DDFLAG + PERFORM CAS-TOT THRU CAS-TOT-EXIT + VARYING X FROM 1 BY 1 UNTIL X > CNTR + PERFORM 2320S THRU 2320S-EXIT + PERFORM 2400SRV THRU 2400SRV-EXIT + VARYING X FROM 1 BY 1 UNTIL X > CNTR + IF END-FLAG = 1 GO TO P98. + MOVE SAVE01 TO FILEIN01 + IF FI-DOCP NOT = HOLD-DOCP + MOVE FILEIN01 TO HOLD-FILEIN01 + PERFORM DOCP-1. + MOVE FILEIN01 TO HOLD-FILEIN01 + PERFORM 2000B + GO TO P0000. + + DIAG-1. + IF FI-DIAG = "0000000" GO TO DIAG-EXIT. + + MOVE FI-DIAG TO DIAG-X + MOVE 0 TO FLAG + PERFORM DIAG-2 VARYING X FROM 1 BY 1 UNTIL X > DIAG-CNTR + IF FLAG = 0 + ADD 1 TO DIAG-CNTR + MOVE FI-DIAG TO DIAGTAB(DIAG-CNTR). + + IF FI-DX2 = "0000000" GO TO DIAG-EXIT. + + MOVE FI-DX2 TO DIAG-X. + MOVE 0 TO FLAG + PERFORM DIAG-2 VARYING X FROM 1 BY 1 UNTIL X > DIAG-CNTR + IF FLAG = 0 + ADD 1 TO DIAG-CNTR + MOVE FI-DX2 TO DIAGTAB(DIAG-CNTR). + + IF FI-DX3 = "0000000" GO TO DIAG-EXIT. + + MOVE FI-DX3 TO DIAG-X + MOVE 0 TO FLAG + PERFORM DIAG-2 VARYING X FROM 1 BY 1 UNTIL X > DIAG-CNTR + IF FLAG = 0 + ADD 1 TO DIAG-CNTR + MOVE FI-DX3 TO DIAGTAB(DIAG-CNTR). + + IF FI-DX4 = "0000000" GO TO DIAG-EXIT. + + MOVE FI-DX4 TO DIAG-X + MOVE 0 TO FLAG + PERFORM DIAG-2 VARYING X FROM 1 BY 1 UNTIL X > DIAG-CNTR + IF FLAG = 0 + ADD 1 TO DIAG-CNTR + MOVE FI-DX4 TO DIAGTAB(DIAG-CNTR). + + DIAG-EXIT. EXIT. + DIAG-2. IF DIAGTAB(X) = DIAG-X + MOVE DIAG-CNTR TO X + MOVE 1 TO FLAG. + + + 2000A. + ADD 1 TO HL-NUM + MOVE HL-NUM TO HL-NUMPRV-SAVE + COMPUTE NUM5 = HL-NUM + PERFORM NUM-LEFT + MOVE ALF5NUM TO HL-NUMX + MOVE SPACE TO HL-PARENT + MOVE "20 " TO HL-CODE + MOVE "1" TO HL-CHILD + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM HL01 + MOVE GROUP-TAX TO PRV-TAX + MOVE SPACE TO SEGFILE01. + * WRITE SEGFILE01 FROM PRV01 + PERFORM DOCP-1. + + * BILLING PROVIDER/ADDRESS + 2010AA. + MOVE "85 " TO NM1-1 + MOVE "1" TO NM1-SOLO + MOVE "34" TO NM1-EINSS + MOVE SPACE TO NM1-CODE NM1-NAMEL NM1-NAMEF + NM1-NAMEM NM1-NAMES + MOVE DOC-LASTNAME(HOLD-DOCP) TO NM1-NAMEL + MOVE DOC-FIRSTNAME(HOLD-DOCP) TO NM1-NAMEF + MOVE DOC-MI(HOLD-DOCP) TO NM1-NAMEM + MOVE DOC-SS(HOLD-DOCP) TO NM1-CODE + MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM NM101. + * PERFORM PLACE-OF-SERVICE + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE PL-STREET(PLACE-POINTER) TO N3-STREET + MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM N301 + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE PL-CITY(PLACE-POINTER) TO N4-CITY + MOVE PL-STATE(PLACE-POINTER) TO N4-STATE + MOVE PL-ZIP(PLACE-POINTER) TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM N401. + MOVE SPACE TO REF-CODE REF-ID + MOVE DOC-NUM(HOLD-DOCP) TO REF-ID + MOVE INSTYPE-CODE TO REF-CODE + MOVE SPACE TO SEGFILE01. + * WRITE SEGFILE01 FROM REF01. + + MOVE CONTACT-NAME TO PER-CONTACT + MOVE TELE-PHONE TO PER-PHONE + MOVE SPACE TO SEGFILE01. + * WRITE SEGFILE01 FROM PER01. + + * PAY-TO PROVIDER/ADDRESS + 2010AB. + IF EINSS-TYPE = "E" + MOVE "2" TO NM1-SOLO + MOVE ORG-NAME TO NM1-NAMEL + MOVE SPACE TO NM1-NAMEF NM1-NAMEM NM1-NAMES + MOVE "24" TO NM1-EINSS + ELSE + MOVE "1" TO NM1-SOLO + MOVE PARMLAST TO NM1-NAMEL + MOVE PARMFIRST TO NM1-NAMEF + MOVE PARMMIDDLE TO NM1-NAMEM + MOVE "34" TO NM1-EINSS. + MOVE "XX" TO NM1-EINSS. + MOVE "85" TO NM1-1 + MOVE SPACE TO NM1-CODE + MOVE INSGROUP-CODE TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101 + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE ORG-STREET TO N3-STREET + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301 + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE ORG-CITY TO N4-CITY + MOVE ORG-STATE TO N4-STATE + MOVE ORG-ZIP TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401 + MOVE SPACE TO REF-CODE REF-ID + MOVE INSTYPE-CODE TO REF-CODE + MOVE INSGROUP-LEG TO REF-ID + MOVE SPACE TO SEGFILE01. + * WRITE SEGFILE01 FROM REF01. + MOVE SPACE TO REF-CODE REF-ID + IF EINSS-TYPE = "E" + MOVE "EI" TO REF-CODE + ELSE + MOVE "SY" TO REF-CODE. + MOVE EIN-CODE TO REF-ID + MOVE SPACE TO SEGFILE01. + WRITE SEGFILE01 FROM REF01. + 2000B. + ADD 1 TO HL-NUM + COMPUTE NUM5 = HL-NUM + PERFORM NUM-LEFT + MOVE ALF5NUM TO HL-NUMX + MOVE HL-NUMPRV-SAVE TO NUM5 + PERFORM NUM-LEFT + MOVE ALF5NUM TO HL-PARENT + MOVE "22 " TO HL-CODE + PERFORM SUBSCRIBER-1 THRU SUBSCRIBER-EXIT. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM HL01 + MOVE SPACE TO SEGFILE01 + MOVE SPACE TO SBR-GRNAME + WRITE SEGFILE01 FROM SBR01 + PERFORM 2010BA. + PERFORM 2010BB. + + 2010BA. + MOVE "IL " TO NM1-1 + MOVE "1" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + UNSTRING G-GARNAME DELIMITED BY "; " OR ";" INTO + NM1-NAMEL NM1-NAMEF NM1-NAMEM + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEL DELIMITED BY " " INTO NAME-1 NAME-2 + IF NAME-2 = "JR" OR "SR" OR "II" OR "III" + MOVE SPACE TO NM1-NAMEL NM1-NAMES + MOVE NAME-1 TO NM1-NAMEL + MOVE NAME-2 TO NM1-NAMES. + IF NM1-NAMEM = SPACE + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEF DELIMITED BY " " INTO NAME-1 NAME-2 + IF NAME-2 NOT = SPACE + MOVE SPACE TO NM1-NAMEF NM1-NAMEM + MOVE NAME-1 TO NM1-NAMEF + MOVE NAME-2 TO NM1-NAMEM + END-IF + END-IF. + MOVE SPACE TO NM1-CODE + MOVE G-SECPOL TO NM1-CODE + IF G-TRINS = HOLD-PAYCODE + MOVE MPLR-TRIPOL TO NM1-CODE + END-IF + MOVE "MI" TO NM1-EINSS + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE G-BILLADD TO N3-STREET + MOVE G-STREET TO N3-BILLADD + IF G-BILLADD = SPACE + MOVE G-STREET TO N3-STREET + MOVE SPACE TO N3-BILLADD. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301. + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE G-CITY TO N4-CITY + MOVE G-STATE TO N4-STATE + MOVE G-ZIP TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401. + MOVE G-DOB TO DMG-DOB + MOVE G-SEX TO DMG-GENDER + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DMG01. + 2010BB. + MOVE "PR " TO NM1-1 + MOVE "2" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + MOVE G-SEINS TO INS-KEY + READ INSFILE + INVALID + MOVE "NYSDOH" TO NM1-NAMEL + MOVE "PI" TO NM1-EINSS + MOVE "141797357" TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101 + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE "1 CSC WAY" TO N3-STREET + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301 + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE "RENSSELAER" TO N4-CITY + MOVE "NY" TO N4-STATE + MOVE "12144 " TO N4-ZIP + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401 + NOT INVALID + MOVE INS-NAME TO NM1-NAMEL + MOVE "PI" TO NM1-EINSS + MOVE INS-NEIC TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101 + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE INS-STREET TO N3-STREET + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301 + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE INS-CITY TO N4-CITY + MOVE INS-STATE TO N4-STATE + MOVE INS-ZIP TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999" TO N4-ZIP(6:4) + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401. + + 2300CLM. + MOVE HOLD-KEY8 TO SUBMIT-1 + MOVE SUBMIT01 TO CLM-1 + COMPUTE NUM7 = TOT-AMOUNT + PERFORM AMT-LEFT + MOVE ALF8NUM TO CLM-2 + MOVE SPACE TO CLM-11 CLM-COLON-ACCIDENT + IF HOLD-DAT1 NOT = ZEROES + PERFORM ACCIDENT-1 THRU ACCIDENT-EXIT. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM CLM01. + IF HOLD-DAT1 NOT = ZEROES + MOVE "439" TO DTP-1 + MOVE HOLD-DAT1 TO DTP-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DTP01. + IF (CLM-5 = "21" OR "61") + MOVE "435" TO DTP-1 + MOVE HOLD-DATE-M TO DTP-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DTP01. + IF (CLIA-FLAG = 1) + AND (CLIA-NUM NOT = SPACE) + MOVE SPACE TO REF-CODE + MOVE "X4" TO REF-CODE + MOVE SPACE TO REF-ID + MOVE CLIA-NUM TO REF-ID + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM REF01. + IF MAMMO-FLAG= 1 + MOVE SPACE TO REF-CODE REF-ID SEGFILE01 + MOVE "EW" TO REF-CODE + MOVE MAMMO-CODE TO REF-ID + WRITE SEGFILE01 FROM REF01. + + 2300CLM-EXIT. EXIT. + + + ACCIDENT-1. + MOVE "OA" TO CLM-11. + * MOVE ":" TO CLM-COLON-ACCIDENT. + ACCIDENT-EXIT. + EXIT. + 2310D. + IF HOLD-PLACE NOT = "2" + MOVE "77 " TO NM1-1 + IF HOLD-PLACE = "4" + MOVE "IL " TO NM1-1 + END-IF + MOVE "2" TO NM1-SOLO + MOVE PL-NAME(PLACE-POINTER) TO NM1-NAMEL + MOVE SPACE TO NM1-NAMEF NM1-NAMEM NM1-NAMES + MOVE " " TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101 + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE PL-STREET(PLACE-POINTER) TO N3-STREET + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301 + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE PL-CITY(PLACE-POINTER) TO N4-CITY + MOVE PL-STATE(PLACE-POINTER) TO N4-STATE + MOVE PL-ZIP(PLACE-POINTER) TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401. + + 2310E. + IF LASTREF = SPACE GO TO 2310E-EXIT. + MOVE LASTREF TO REF-KEY + READ REFPHY INVALID GO TO 2310E-1. + MOVE "DQ " TO NM1-1 + MOVE "1" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM + UNSTRING REF-NAME DELIMITED BY + "; " OR ";" OR " ; " OR " ," OR ", " OR " , " OR "," + INTO NM1-NAMEL NM1-NAMEF + MOVE SPACE TO NM1-NAMES NM1-EINSS NM1-CODE + MOVE "XX" TO NM1-EINSS + MOVE REF-NPI TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + GO TO 2310E-EXIT. + 2310E-1. + IF ORDER-FLAG = 1 + MOVE HOLD-DOCP TO NUM2 + MOVE "DQ " TO NM1-1 + MOVE "1" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM + MOVE DOC-LASTNAME(NUM2) TO NM1-NAMEL + MOVE DOC-FIRSTNAME(NUM2) TO NM1-NAMEF + MOVE SPACE TO NM1-NAMES NM1-EINSS NM1-CODE + MOVE "XX " TO NM1-EINSS + MOVE DOC-NPI(NUM2) TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + 2310E-EXIT. + EXIT. + + 2320A. + GO TO 2320A-EXIT. + IF G-SEINS = "001" OR "012" OR "075" OR "076" + GO TO 2320A-EXIT. + IF G-SEINS = "005" PERFORM CMP-1 + GO TO 2320A-EXIT. + IF G-SEINS = "004" OR "064" PERFORM CAID-1 + GO TO 2320A-EXIT. + MOVE 0 TO GAP-FLAG + IF G-SEINS = "062" PERFORM GAP-1 THRU GAP-1-EXIT. + 2320A-EXIT. EXIT. + CAS-TOT. + MOVE FILETAB(X) TO FILEIN01 + MOVE 0 TO CAS-REDUCE(X) CAS-PAID(X) + COMPUTE CLM-BAL(X) = FI-AMOUNT + MOVE SPACE TO CAS-PAYDATE(X) + MOVE 0 TO REDUCE-FLAG PRIME-FLAG DDFLAG + MOVE 0 TO CAS-REDUCE(X) CAS-PAID(X) + MOVE "0" TO CAS-DD(X) + MOVE FI-DATE-T TO CAS-PAYDATE(X) + MOVE FI-KEY8 TO PC-KEY8 + MOVE SPACE TO PC-KEY3 + START PAYCUR KEY NOT < PAYCUR-KEY + INVALID GO TO CAS-TOT-EXIT. + CAS-TOT-1. + READ PAYCUR NEXT AT END GO TO CAS-TOT-2. + IF PC-KEY8 NOT = FI-KEY8 GO TO CAS-TOT-2. + IF PC-CLAIM NOT = FI-CLAIM GO TO CAS-TOT-1. + IF (PC-PAYCODE = "001" OR "021" OR "022") go to cas-tot-1. + COMPUTE CLM-BAL(X) = CLM-BAL(X) + PC-AMOUNT. + IF (PC-PAYCODE = G-PRINS AND PC-DENIAL = "14") + OR (PC-PAYCODE = "014" OR "015") + MOVE 1 TO REDUCE-FLAG + COMPUTE CAS-REDUCE(X) = cas-reduce(x) + (-1 * PC-AMOUNT) + display g-garname + move pc-amount to zef-7 + * display zef-7 " pay-amount" + move cas-reduce(x) to zef-7 + * display zef-7 " cas-reduce" + * display pc-paycode " " pc-denial + * accept alf1 + + GO TO CAS-TOT-1 + END-IF + IF ((PC-PAYCODE = G-PRINS) + AND (PC-DENIAL = SPACE OR "DA" OR "DD" OR "DI" OR "TO" + or "CP")) + COMPUTE CAS-PAID(X) = CAS-PAID(X) + (-1 * PC-AMOUNT) + MOVE PC-DATE-T TO CAS-PAYDATE(X) CLAIM-ADJ-DATE + IF PC-DENIAL = "DD" + MOVE 1 TO CAS-DD(X) + END-IF + END-IF. + + GO TO CAS-TOT-1. + + CAS-TOT-2. + COMPUTE CAS-ALLOWED(X) = FI-AMOUNT - CAS-REDUCE(X) + ADD FI-AMOUNT TO CAS-TOT-CHARGE + ADD CAS-PAID(X) TO CAS-TOT-PAID. + ADD CAS-REDUCE(X) TO CAS-TOT-REDUCE + ADD CAS-ALLOWED(X) TO CAS-TOT-ALLOWED. + MOvE 0 TO CAS-DEDUC(X) + IF ((CAS-DD(X) = 1) OR (CAS-DD(X) = 0 AND CAS-PAID(X) = 0)) + compute CAS-DEDUC(X) = + FI-AMOUNT - CAS-PAID(X) - CAS-REDUCE(X) + MOVE 1 TO CAS-DD(X) + END-IF. + CAS-TOT-EXIT. EXIT. + 2320S. + MOVE "P" TO SBR-PST + MOVE "18" TO SBR-RELATE + MOVE " " TO SBR-GROUP + MOVE G-PRINS TO INS-KEY + MOVE " " TO SBR-TYPE + MOVE "MB " TO SBR-INSCODE + IF G-PRINS = "003" + MOVE "MB" TO SBR-INSCODE. + + READ INSFILE INVALID + MOVE "COMMERCIAL INS" TO INS-NAME + END-READ. + MOVE SPACE TO SBR-GRNAME + * MOVE INS-NAME TO SBR-GRNAME + * IF G-PRINS = "006" + * MOVE "OF " TO SBR-INSCODE. + * IF G-PRINS = "141" + * MOVE "CH " TO SBR-INSCODE. + * IF (G-PRINS = "002") OR (INS-CAID = "EE ") + * MOVE "BL " TO SBR-INSCODE. + MOVE SPACE TO SBR-6 SBR-7 SBR-8 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SBR01. + MOVE SPACE TO CAS-1 CAS-2 CAS-3 + * MOVE "CO" TO CAS-1 + * MOVE "45 " TO CAS-2 + * COMPUTE NUM7 = CAS-TOT-REDUCE + * PERFORM AMT-LEFT + * MOVE ALF8NUM TO CAS-3 + * MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM CAS01 + + + * MOVE SPACE TO AMT-1 AMT-2 + * MOVE "AAE" TO AMT-1 + * COMPUTE NUM7 = CAS-TOT-ALLOWED + * PERFORM AMT-LEFT + * MOVE ALF8NUM TO AMT-2 + * MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM AMT01 + + + MOVE SPACE TO AMT-1 AMT-2 + MOVE "D " TO AMT-1 + COMPUTE NUM7 = CAS-TOT-PAID + PERFORM AMT-LEFT + MOVE ALF8NUM TO AMT-2 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM AMT01 + + * MOVE "B6 " TO AMT-1 + * MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM AMT01 + + * IF PRIMARY INS SUBSCRIBER NOT = 2ND SUBSCRIBER + * MAKE UP DOB FOR DMG01 SEGMENT + IF (G-PR-RELATE NOT = G-SE-RELATE) + OR (G-GARNAME NOT = G-PRNAME) + UNSTRING G-PRNAME DELIMITED BY ";" INTO + NM1-NAMEL NM1-NAMEF + ELSE + MOVE G-DOB TO DMG-DOB + MOVE G-SEX TO DMG-GENDER. + MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM DMG01. + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM OI01. + + MOVE "IL " TO NM1-1 + MOVE "1" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + + IF (G-PR-RELATE NOT = G-SE-RELATE) + OR (G-GARNAME NOT = G-PRNAME) + UNSTRING G-PRNAME DELIMITED BY ";" INTO + NM1-NAMEL NM1-NAMEF + ELSE + UNSTRING G-GARNAME DELIMITED BY ";" INTO + NM1-NAMEL NM1-NAMEF. + + MOVE "MI" TO NM1-EINSS + MOVE G-PRIPOL TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE G-BILLADD TO N3-STREET + MOVE G-STREET TO N3-BILLADD + IF G-BILLADD = SPACE + MOVE G-STREET TO N3-STREET + MOVE SPACE TO N3-BILLADD. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301. + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE G-CITY TO N4-CITY + MOVE G-STATE TO N4-STATE + MOVE G-ZIP TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401. + * MOVE SPACE TO REF-CODE REF-ID + * MOVE "IG" TO REF-CODE + * MOVE G-PRIPOL TO REF-ID + * WRITE SEGFILE01 FROM REF01. + MOVE "PR " TO NM1-1 + MOVE "2" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + MOVE INS-NAME TO NM1-NAMEL + MOVE "PI" TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE ins-neic TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + + MOVE "573" TO DTP-1 + MOVE CLAIM-ADJ-DATE TO DTP-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DTP01. + + 2320S-EXIT. + EXIT. + + CMP-1. + MOVE "S" TO SBR-PST + MOVE G-SE-GROUP TO SBR-GROUP + MOVE "18" TO SBR-RELATE + MOVE " " TO SBR-TYPE. + MOVE SPACE TO SBR-6 SBR-7 SBR-8 + MOVE "BL" TO SBR-INSCODE. + IF G-SEINS = "006" + MOVE "OF" TO SBR-INSCODE + END-IF + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SBR01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM OI01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DMG01. + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + UNSTRING G-SENAME DELIMITED BY ";" INTO + NM1-NAMEL NM1-NAMEF NM1-NAMEM + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEL DELIMITED BY " " INTO NAME-1 NAME-2 + IF NAME-2 = "JR" OR "SR" OR "II" OR "III" + MOVE SPACE TO NM1-NAMEL NM1-NAMES + MOVE NAME-1 TO NM1-NAMEL + MOVE NAME-2 TO NM1-NAMES. + IF NM1-NAMEM = SPACE + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEF DELIMITED BY ALL " " INTO NAME-1 NAME-2 + IF NAME-2 NOT = SPACE + MOVE SPACE TO NM1-NAMEF NM1-NAMEM + MOVE NAME-1 TO NM1-NAMEF + MOVE NAME-2 TO NM1-NAMEM + END-IF + END-IF. + + MOVE "1" TO NM1-SOLO + MOVE "IL" TO NM1-1 + MOVE "MI" TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE G-SECPOL TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE G-BILLADD TO N3-STREET + MOVE G-STREET TO N3-BILLADD + IF G-BILLADD = SPACE + MOVE G-STREET TO N3-STREET + MOVE SPACE TO N3-BILLADD. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301. + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE G-CITY TO N4-CITY + MOVE G-STATE TO N4-STATE + MOVE G-ZIP TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401. + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + MOVE "MEDICOMP" TO NM1-NAMEL + MOVE "2" TO NM1-SOLO + MOVE "PR" TO NM1-1 + MOVE "PI" TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE "00026" TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + + CAID-1. + MOVE "S" TO SBR-PST + MOVE G-SE-GROUP TO SBR-GROUP + MOVE "18" TO SBR-RELATE + MOVE "MC" TO SBR-TYPE. + MOVE SPACE TO SBR-6 SBR-7 SBR-8 + MOVE "MC" TO SBR-INSCODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SBR01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM OI01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DMG01. + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + UNSTRING G-SENAME DELIMITED BY ";" INTO + NM1-NAMEL NM1-NAMEF NM1-NAMEM + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEL DELIMITED BY " " INTO NAME-1 NAME-2 + IF NAME-2 = "JR" OR "SR" OR "II" OR "III" + MOVE SPACE TO NM1-NAMEL NM1-NAMES + MOVE NAME-1 TO NM1-NAMEL + MOVE NAME-2 TO NM1-NAMES. + IF NM1-NAMEM = SPACE + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEF DELIMITED BY ALL " " INTO NAME-1 NAME-2 + IF NAME-2 NOT = SPACE + MOVE SPACE TO NM1-NAMEF NM1-NAMEM + MOVE NAME-1 TO NM1-NAMEF + MOVE NAME-2 TO NM1-NAMEM + END-IF + END-IF. + + MOVE "1" TO NM1-SOLO + MOVE "IL" TO NM1-1 + MOVE "MI" TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE G-SECPOL TO ALF9 + MOVE ALF9 TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE G-BILLADD TO N3-STREET + MOVE G-STREET TO N3-BILLADD + IF G-BILLADD = SPACE + MOVE G-STREET TO N3-STREET + MOVE SPACE TO N3-BILLADD. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301. + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE G-CITY TO N4-CITY + MOVE G-STATE TO N4-STATE + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + + MOVE G-ZIP TO N4-ZIP + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401. + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + MOVE "VT MEDICAID" TO NM1-NAMEL + MOVE "2" TO NM1-SOLO + MOVE "PR" TO NM1-1 + MOVE "PI" TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE "VTXIX" TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + GAP-1. + MOVE G-PR-GROUP TO GAPKEY + READ GAPFILE INVALID MOVE 1 TO GAP-FLAG GO TO GAP-1-EXIT. + MOVE "S" TO SBR-PST + MOVE G-SE-GROUP TO SBR-GROUP + IF G-RELATE = G-SE-RELATE + MOVE "18" TO SBR-RELATE + ELSE MOVE "01" TO SBR-RELATE. + IF GAP-TYPE = "X" + MOVE "MI" TO SBR-TYPE + ELSE MOVE " " TO SBR-TYPE. + MOVE SPACE TO SBR-6 SBR-7 SBR-8 + MOVE "CI" TO SBR-INSCODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SBR01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM OI01. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DMG01. + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + UNSTRING G-SENAME DELIMITED BY ";" INTO + NM1-NAMEL NM1-NAMEF NM1-NAMEM + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEL DELIMITED BY " " INTO NAME-1 NAME-2 + IF NAME-2 = "JR" OR "SR" OR "II" OR "III" OR "IV" + MOVE SPACE TO NM1-NAMEL NM1-NAMES + MOVE NAME-1 TO NM1-NAMEL + MOVE NAME-2 TO NM1-NAMES. + IF NM1-NAMEM = SPACE + MOVE SPACE TO NAME-1 NAME-2 + UNSTRING NM1-NAMEF DELIMITED BY ALL " " INTO NAME-1 NAME-2 + IF NAME-2 NOT = SPACE + MOVE SPACE TO NM1-NAMEF NM1-NAMEM + MOVE NAME-1 TO NM1-NAMEF + MOVE NAME-2 TO NM1-NAMEM + END-IF + END-IF. + MOVE "1" TO NM1-SOLO + MOVE "IL" TO NM1-1 + MOVE "MI" TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE G-SECPOL TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + MOVE SPACE TO N3-STREET N3-BILLADD + MOVE G-BILLADD TO N3-STREET + MOVE G-STREET TO N3-BILLADD + IF G-BILLADD = SPACE + MOVE G-STREET TO N3-STREET + MOVE SPACE TO N3-BILLADD. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N301. + MOVE SPACE TO N4-CITY N4-STATE N4-ZIP + MOVE G-CITY TO N4-CITY + MOVE G-STATE TO N4-STATE + MOVE G-ZIP TO N4-ZIP + IF N4-ZIP(6:4) = SPACE + MOVE "9999"TO N4-ZIP(6:4) + END-IF + + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM N401. + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM NM1-NAMES + MOVE GAP-NAME TO NM1-NAMEL + MOVE "2" TO NM1-SOLO + MOVE "PR" TO NM1-1 + MOVE "PI" TO NM1-EINSS + MOVE SPACE TO NM1-CODE + MOVE GAPKEY TO ALF7 + MOVE ALF72 TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + GAP-1-EXIT. EXIT. + 2400SRV. + MOVE FILETAB(X) TO FILEIN01 + MOVE FI-PROC1 TO SV1-PROC. + MOVE SPACE TO SV1-EPSDT + IF ((FI-PROC1 = "W9020") + OR (FI-PROC1 > "99380" AND < "99387") + OR (FI-PROC1 > "99390" AND < "99397")) + MOVE G-DOB TO AGEX + MOVE FI-DATE-T TO AGEY + COMPUTE AGEZ = AGEYYY - AGEXYY + IF AGEZ = 21 AND AGEXMMDD > AGEYMMDD + COMPUTE AGEZ = 20 + END-IF + IF AGEZ < 21 + MOVE "Y" TO SV1-EPSDT + MOVE "EP" TO FI-PROC2 + END-IF + END-IF. + MOVE SPACE TO SV1-FAMILY + IF ((HOLD-DATE-T < "20151001") + AND (CC-DIAG > "V25 " AND < "V2700")) + OR ((CC-DATE-T > "20150930") + AND (CC-DIAG > "Z2999 " AND < "Z3200 ")) + + MOVE "Y" TO SV1-FAMILY. + PERFORM SV-MOD + COMPUTE NUM7 = FI-AMOUNT + PERFORM AMT-LEFT + + MOVE ALF8NUM TO SV1-AMT + COMPUTE NUM5 = FI-WORK + PERFORM NUM-LEFT + MOVE ALF5NUM TO SV1-WORK + MOVE SPACE TO SV1-PLACE + + MOVE 0 TO DX-CNTR-PT + MOVE SPACE TO DIAG-POINTER01 + + IF NOT (FI-DIAG = SPACE OR "0000000") + MOVE FI-DIAG TO DIAG-X + PERFORM DIAG-3 VARYING A FROM 1 BY 1 UNTIL A > 12 + END-IF + + IF NOT (FI-DX2 = SPACE OR "0000000") + MOVE FI-DX2 TO DIAG-X + PERFORM DIAG-3 VARYING A FROM 1 BY 1 UNTIL A > 12 + END-IF + + IF NOT (FI-DX3 = SPACE OR "0000000") + MOVE FI-DX3 TO DIAG-X + PERFORM DIAG-3 VARYING A FROM 1 BY 1 UNTIL A > 12 + END-IF + + IF NOT (FI-DX4 = SPACE OR "0000000") + MOVE FI-DX4 TO DIAG-X + PERFORM DIAG-3 VARYING A FROM 1 BY 1 UNTIL A > 12 + END-IF + + MOVE SPACE TO DIAG-C(DX-CNTR-PT) + MOVE DIAG-POINTER01 TO SV1-PT + GO TO SV1-0. + + DIAG-3. + IF DIAGTAB(A) = DIAG-X + ADD 1 TO DX-CNTR-PT + MOVE A TO DIAG-PT(DX-CNTR-PT) + MOVE ":" TO DIAG-C(DX-CNTR-PT) + MOVE 12 TO A. + + + + + + SV1-0. + MOVE " " TO SV1-EMER + IF CLM-5 = "23" MOVE "Y" TO SV1-EMER. + COMPUTE NUM5 = X + PERFORM NUM-LEFT + MOVE ALF5NUM TO LX-1 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM LX01. + MOVE SPACE TO SV1-COPAY + IF NOT (sv1-proc(1:1) = "J" OR SV1-PROC(1:5) = "Q2039") + GO TO 2400SRV-1. + move sv1-proc to proc-key + read procfile invalid + go to 2400srv-1 + end-read + move space to sv1-mod-filler + string ":::::" proc-title + delimited by size into sv1-mod-filler. + 2400srv-1. + MOVE SPACE TO tab11401 + MOVE 0 TO D + PERFORM VARYING C FROM 1 BY 1 UNTIL C > 114 + IF SV101(C:1) NOT = " " + ADD 1 TO D + MOVE SV101(C:1) TO TAB114(D) + END-IF + END-PERFORM + MOVE tab11401 TO ALF114 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM ALF114. + + + + MOVE "472" TO DTP-1 + + MOVE FI-DATE-T TO DTP-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DTP01. + * MOVE SPACE TO REF-CODE REF-ID + * MOVE "6R" TO REF-CODE + * MOVE CR-ICN TO REF-ID + * MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM REF01. + + * MOVE SPACE TO AMT-1 AMT-2 + * MOVE "AAE" TO AMT-1 + * COMPUTE NUM7 = CAS-ALLOWED(X) + * PERFORM AMT-LEFT + * MOVE ALF8NUM TO AMT-2 + * MOVE SPACE TO SEGFILE01 + * WRITE SEGFILE01 FROM AMT01 + + MOVE INS-NEIC TO SVD-1 + COMPUTE NUM7 = CAS-PAID(X) + PERFORM AMT-LEFT + + * iEDI wants us to suppress leading zero + IF ALF8NUM = "0.00" + MOVE ".00" TO ALF8NUM + END-IF + + MOVE ALF8NUM TO SVD-2 + MOVE SPACE TO SVD-3 + STRING "HC:" SV1-PROC SV1-MOD-FILLER DELIMITED BY SIZE + INTO SVD-3 + MOVE SV1-WORK TO SVD-4 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SVD01 + + MOVE SPACE TO CAS-1 CAS-2 CAS-3 + MOVE "CO" TO CAS-1 + MOVE "45" TO CAS-2 + COMPUTE NUM7 = CAS-REDUCE(X) + PERFORM AMT-LEFT + MOVE ALF8NUM TO CAS-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM CAS01 + + IF CAS-DD(X) = "1" + MOVE SPACE TO CAS-1 CAS-2 CAS-3 + MOVE "PR" TO CAS-1 + MOVE "1 " TO CAS-2 + COMPUTE NUM7 = CLM-BAL(X) + PERFORM AMT-LEFT + MOVE ALF8NUM TO CAS-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM CAS01 + + ELSE + + MOVE SPACE TO CAS-1 CAS-2 CAS-3 + MOVE "PR" TO CAS-1 + MOVE "2 " TO CAS-2 + COMPUTE NUM7 = CLM-BAL(X) + PERFORM AMT-LEFT + MOVE ALF8NUM TO CAS-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM CAS01. + + + MOVE "573" TO DTP-1 + MOVE CAS-PAYDATE(X) TO DTP-3 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM DTP01 + MOVE FILEIN-KEY TO CHARCUR-KEY + READ CHARCUR WITH LOCK INVALID GO TO 2400SRV-EXIT. + IF CC-REC-STAT = "0" MOVE "2" TO CC-REC-STAT. + IF CC-REC-STAT = "1" MOVE "3" TO CC-REC-STAT. + MOVE "E" TO CC-PAPER. + MOVE BHT-DATE TO CC-DATE-A. + REWRITE CHARCUR01. + 2400SRV-EXIT. EXIT. + REF-1. + IF HOLD-DOCR = "000" GO TO REF-2. + MOVE HOLD-DOCR TO REF-KEY + READ REFPHY INVALID GO TO REF-2. + MOVE "DN " TO NM1-1 + MOVE "1" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM + UNSTRING REF-NAME DELIMITED BY ", " OR " ," + OR " , " OR "," OR ";" INTO NM1-NAMEL NM1-NAMEF + MOVE SPACE TO NM1-NAMES NM1-EINSS NM1-CODE + MOVE "XX" TO NM1-EINSS + MOVE REF-NPI TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + GO TO REF-1-EXIT. + REF-2. + MOVE "DN" TO NM1-1 + MOVE "1" TO NM1-SOLO + MOVE SPACE TO NM1-NAMEL NM1-NAMEF NM1-NAMEM + MOVE SPACE TO NM1-NAMES NM1-EINSS NM1-CODE + MOVE DOC-LASTNAME(HOLD-DOCP) TO NM1-NAMEL + MOVE DOC-FIRSTNAME(HOLD-DOCP) TO NM1-NAMEF + MOVE DOC-MI(HOLD-DOCP) TO NM1-NAMEM + MOVE "XX" TO NM1-EINSS + MOVE DOC-NPI(HOLD-DOCP) TO NM1-CODE + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM NM101. + REF-1-EXIT. EXIT. + + DOCP-1. + MOVE DOC-LASTNAME(HOLD-DOCP) TO SAVE-DOCNM1-NAMEL + MOVE DOC-FIRSTNAME(HOLD-DOCP) TO SAVE-DOCNM1-NAMEF + MOVE DOC-MI(HOLD-DOCP) TO SAVE-DOCNM1-NAMES + MOVE DOC-NPI(HOLD-DOCP) TO SAVE-DOCNM1-CODE + MOVE DOC-SS(HOLD-DOCP) TO SAVE-DOCREF-ID + MOVE "SY" TO SAVE-DOCREF-CODE + MOVE "82 " TO SAVE-DOCNM1-1 + MOVE "1" TO SAVE-DOCNM1-SOLO + MOVE SPACE TO SAVE-DOCNM1-NAMES + MOVE "XX" TO SAVE-DOCNM1-EINSS. + + SUBSCRIBER-1. + MOVE HOLD-KEY8 TO G-GARNO + READ GARFILE + INVALID DISPLAY "BAD BAD BAD" + GO TO P99. + IF G-TRINS NOT = "001" + MOVE "0" TO MPLR-TR-RELATE + MOVE G-GARNO TO MPLR-KEY + READ MPLRFILE + INVALID CONTINUE + END-READ + END-IF. + MOVE G-RELATE TO SUB-RELATE + MOVE G-GARNAME TO SUB-NAME + MOVE G-PRIPOL TO SUB-POLICY + MOVE SPACE TO SUB-GROUP + MOVE "P" TO SBR-PST + IF HOLD-PAYCODE = G-SEINS + MOVE "S" TO SBR-PST + MOVE G-SE-RELATE TO SUB-RELATE + MOVE G-SENAME TO SUB-NAME + MOVE G-SECPOL TO ALF-9 + MOVE ALF-9 TO SUB-POLICY + MOVE G-SE-GROUP TO SUB-GROUP + END-IF. + IF (HOLD-PAYCODE = G-TRINS) AND (MPLR-TR-RELATE NOT = "0") + MOVE "S" TO SBR-PST + MOVE MPLR-TR-RELATE TO SUB-RELATE + MOVE MPLR-TR-NAME TO SUB-NAME + MOVE MPLR-TRIPOL TO SUB-POLICY + MOVE MPLR-TR-GROUP TO SUB-GROUP + END-IF. + MOVE G-RELATE TO X-RELATE. + IF HOLD-PATID8 = "P" PERFORM PAT-READ. + IF X-RELATE = "0" + MOVE G-RELATE TO X-RELATE. + IF X-RELATE = SUB-RELATE + MOVE "18" TO SBR-RELATE + GO TO SUBSCRIBER-2. + IF (X-RELATE = "2" OR "K") + AND (SUB-RELATE = "2" OR "K") + MOVE "01" TO SBR-RELATEHOLD GO TO SUBSCRIBER-2. + IF (X-RELATE = "8" OR "Q") MOVE "29" TO SBR-RELATEHOLD + GO TO SUBSCRIBER-2. + IF (X-RELATE = "4" OR "M") MOVE "02" TO SBR-RELATEHOLD + GO TO SUBSCRIBER-2. + IF (X-RELATE = "5" OR "N") MOVE "17" TO SBR-RELATEHOLD + GO TO SUBSCRIBER-2. + SUBSCRIBER-2. + MOVE SPACE TO SBR-GROUP + MOVE "0 " TO HL-CHILD + * NEED TO USE MC FOR 026 + MOVE "MC" TO SBR-INSCODE + * MOVE "12" TO SBR-TYPE + IF SBR-PST = "S" + IF G-PRINS = "091" + MOVE "15" TO SBR-TYPE + END-IF + IF G-PRINS = "006" + MOVE "16" TO SBR-TYPE + END-IF + IF G-PRINS = "079" + MOVE "42" TO SBR-TYPE + END-IF + + IF HOLD-ACC-TYPE = "2" + MOVE "14" TO SBR-TYPE + END-IF + + IF HOLD-ACC-TYPE = "1" + MOVE "15" TO SBR-TYPE + END-IF + END-IF. + + SUBSCRIBER-EXIT. + EXIT. + + 2000B-PAT. + + + PAT-READ. + MOVE HOLD-PATID TO P-PATNO + READ PATFILE INVALID MOVE "0" TO P-RELATE. + MOVE P-RELATE TO X-RELATE. + NUM-LEFT. + MOVE NUM5 TO ALF5Z ALFS + MOVE SPACE TO ALF5NUM + MOVE ALF5Z TO ALF5 + UNSTRING ALF5 DELIMITED ALL " " INTO ALFS ALF5NUM. + NUM-LEFT9. + MOVE NUM9 TO ALF9Z + MOVE SPACE TO ALF9NUM + MOVE ALF9Z TO ALF9 ALFS9 + UNSTRING ALF9 DELIMITED ALL " " INTO ALFS9 ALF9NUM. + AMT-LEFT. + MOVE NUM7 TO ALF8Z + MOVE SPACE TO ALF8NUM ALFS8 + MOVE ALF8Z TO ALF8 + UNSTRING ALF8 DELIMITED ALL " " INTO ALFS8 ALF8NUM. + + 2000C. + * ISA RECORD. + ISA-1. + * AUTHORIZATION INFO QUALIFIER + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-1. + * AUTHORIZATION INFO + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-2. + * SECURITY INFO QUAL + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-3. + * SECURITY INFO + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-4. + * INTERCHANGE ID QUALIFIER + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-5. + * INTERCHANGE SENDER ID + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-6. + * INTERCHANGE ID QUALIFIER + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-7. + * INTERCHANGE RECEIVER ID + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-8. + * INTERCHANGE DATE + READ PARMFILE2 AT END GO TO A0-EXIT. + ACCEPT ISA-9 FROM DATE. + * INTERCHANGE TIME + READ PARMFILE2 AT END GO TO A0-EXIT. + ACCEPT TIME-X FROM TIME + MOVE TIME-HHMM TO ISA-10. + * INTERCHAGNE CONTROL STANDARDS ID + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-11. + * INTERCHANGE CONTROL VERSION CODE + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-12. + * INTERCHANGE CONTROL NUMBER + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-13. + * ACKNOWLEDGEMENT REQUESTED + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-14. + * USAGE INDICATOR + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-15. + * COMPONENT ELEMENT SEPARATOR + READ PARMFILE2 AT END GO TO A0-EXIT. + MOVE PARMFILE201 TO ISA-16. + ISA-EXIT. EXIT. + * TAX ID NUMBER + A0. + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO EIN-CODE. + * TAX ID TYPE + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO EINSS-TYPE. + * CONTACT NAME # + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO CONTACT-NAME. + * TELEPHONE # + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO TELE-PHONE. + * INSURANCE-CODE # + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO INSTYPE-CODE. + * INSURANCE-GROUP # + READ PARMFILE AT END GO TO A0-EXIT. + MOVE SPACE TO INSGROUP-CODE INSGROUP-LEG + UNSTRING PARMFILE01 DELIMITED BY " " INTO + INSGROUP-CODE INSGROUP-LEG. + * SUBMITER ID INDICATORS (2) + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO SUBMIT-2. + * ORGANIZATION NAME + READ PARMFILE AT END GO TO A0-EXIT. + IF EINSS-TYPE = "S" + MOVE SPACE TO PARMLAST PARMFIRST PARMMIDDLE + UNSTRING PARMFILE01 DELIMITED BY ";" + INTO PARMLAST PARMFIRST PARMMIDDLE + ELSE MOVE PARMFILE01 TO ORG-NAME. + * GROUP'S STREET + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO ORG-STREET + * GROUP'S CITY + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO ORG-CITY + * GROUP'S STATE + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO ORG-STATE + * GROUP'S ZIP CODE + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO ORG-ZIP + * GROUP 3-CHARACTER MNEMONIC CODE + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO GROUP-3. + * CLIA-NUMBER + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO mammo-code. + + * ACCT-TAXONOMY. + READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO GROUP-TAX. + + * INDIVIDUAL PROVIDER DATA + A1. READ PARMFILE AT END GO TO A0-EXIT. + MOVE PARMFILE01 TO PARM01 + MOVE PM-1 TO NUM2 + MOVE PM-2 TO DOC-TAX(NUM2) + MOVE PM-3 TO DOC-SS(NUM2) + MOVE PM-4 TO DOC-NUM(NUM2) + MOVE SPACE TO ALF20 ALF10 ALF1 + UNSTRING PM-5 DELIMITED BY ";" INTO ALF20 ALF10 ALF1 + MOVE ALF20 TO DOC-LASTNAME(NUM2) + MOVE ALF10 TO DOC-FIRSTNAME(NUM2) + MOVE ALF1 TO DOC-MI(NUM2) + MOVE PM-6 TO DOC-NPI(NUM2) + GO TO A1. + A0-EXIT. EXIT. + + DF-SEARCH. + MOVE 0 TO FLAG. + MOVE "1" TO CC-PL + MOVE "11" TO CLM-5 + PERFORM DF-SEARCH2 VARYING Y FROM 1 BY 1 UNTIL Y > PLINDX. + DF-SEARCH2. + IF HOLD-PLACE = PL-TAB(Y) + MOVE PL-NUM(Y) TO CC-PL + MOVE Y TO PLACE-POINTER + PERFORM PLACE-OF-SERVICE + MOVE PLINDX TO Y. + PLACE-OF-SERVICE. + IF CC-PL = "1" MOVE "11" TO CLM-5. + IF CC-PL = "3" MOVE "21" TO CLM-5. + IF CC-PL = "4" MOVE "32" TO CLM-5. + IF CC-PL = "5" MOVE "22" TO CLM-5. + IF CC-PL = "6" MOVE "81" TO CLM-5. + IF CC-PL = "7" MOVE "61" TO CLM-5. + IF CC-PL = "8" MOVE "99" TO CLM-5. + IF CC-PL = "E" MOVE "23" TO CLM-5 + IF CC-PL = "K" MOVE "31" TO CLM-5. + IF HOLD-PROC1 > "99200" AND < "99206" MOVE "11" TO CLM-5. + IF HOLD-PROC1 > "99210" AND < "99216" MOVE "11" TO CLM-5. + IF HOLD-PROC1 > "99216" AND < "99221" MOVE "22" TO CLM-5. + IF HOLD-PROC1 > "99220" AND < "99224" MOVE "21" TO CLM-5. + IF HOLD-PROC1 > "99230" AND < "99234" MOVE "21" TO CLM-5. + IF HOLD-PROC1 = "99238" MOVE "21" TO CLM-5. + IF HOLD-PROC1 > "99240" AND < "99246" MOVE "11" TO CLM-5. + IF HOLD-PROC1 > "99250" AND < "99256" MOVE "21" TO CLM-5. + IF HOLD-PROC1 > "99260" AND < "99264" MOVE "21" TO CLM-5. + IF HOLD-PROC1 > "99280" AND < "99289" MOVE "23" TO CLM-5. + IF HOLD-PROC1 > "99320" AND < "99324" MOVE "33" TO CLM-5. + IF HOLD-PROC1 > "99330" AND < "99334" MOVE "33" TO CLM-5. + + HI-DIAG. + IF HOLD-DATE-T > "20150930" GO TO HI-DIAG10. + MOVE HOLD-DIAG TO DIAG-KEY + READ DIAGFILE INVALID MOVE SPACE TO DIAG-MEDB. + MOVE DIAG-MEDB TO HI9-DX1 + MOVE SPACE TO HI9-DIAG-FILLER DIAG9-ARRAY01 + + PERFORM VARYING X FROM 2 BY 1 UNTIL X > DIAG-CNTR + MOVE DIAGTAB(X) TO DIAG-KEY + READ DIAGFILE INVALID CONTINUE + END-READ + MOVE "*BF:" TO DIAG9-BF(X - 1) + MOVE DIAG-MEDB TO DIAG9-CODE(X - 1) + END-PERFORM. + MOVE DIAG9-ARRAY01 TO HI9-DIAG-FILLER + WRITE SEGFILE01 FROM HI901. + GO TO HI-2. + HI-DIAG10. + MOVE HOLD-DIAG TO DIAG-KEY + READ DIAGFILE INVALID MOVE SPACE TO DIAG-MEDB. + MOVE DIAG-KEY TO HI10-DX1 + MOVE SPACE TO HI10-DIAG-FILLER DIAG10-ARRAY01 + + PERFORM VARYING X FROM 2 BY 1 UNTIL X > DIAG-CNTR + MOVE DIAGTAB(X) TO DIAG10-CODE(X - 1) + MOVE "*ABF:" TO DIAG10-BF(X - 1) + END-PERFORM. + MOVE DIAG10-ARRAY01 TO HI10-DIAG-FILLER + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM HI1001. + HI-2. + PERFORM REF-1 THRU REF-1-EXIT. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SAVE-DOCNM101 + MOVE SPACE TO SEGFILE01. + HI-DIAG-EXIT. + EXIT. + + SV-MOD. + MOVE SPACE TO SV1-MOD-FILLER MOD-ARRAY01 + MOVE FI-PROC2 TO X-MOD1 + MOVE FI-MOD2 TO X-MOD2 + MOVE FI-MOD3 TO X-MOD3 + IF X-MOD1 = SPACE AND X-MOD2 = SPACE + MOVE X-MOD3 TO X-MOD1 + MOVE SPACE TO X-MOD3. + IF X-MOD1 = SPACE + MOVE X-MOD2 TO X-MOD1 + MOVE X-MOD3 TO X-MOD2 + MOVE SPACE TO X-MOD3. + IF X-MOD2 = SPACE + MOVE X-MOD3 TO X-MOD2 + MOVE SPACE TO X-MOD3. + IF X-MOD1 NOT = SPACE + AND X-MOD2 = SPACE + MOVE X-MOD3 TO X-MOD2 + MOVE SPACE TO X-MOD3. + IF X-MOD1 NOT = SPACE + MOVE ":" TO MOD-C(1) + MOVE X-MOD1 TO MOD-CODE(1). + IF X-MOD2 NOT = SPACE + MOVE ":" TO MOD-C(2) + MOVE X-MOD2 TO MOD-CODE(2). + IF X-MOD3 NOT = SPACE + MOVE ":" TO MOD-C(3) + MOVE X-MOD3 TO MOD-CODE(3). + MOVE MOD-ARRAY01 TO SV1-MOD-FILLER. + + + + MAKE-IT-UP. + MOVE G-DOB TO X-DOB. + ADD 1 TO X-YYYY + COMPUTE X-MM = 12 + X-DD. + MAKE-IT-1. + IF X-MM > 12 + COMPUTE X-MM = X-MM - 12 + GO TO MAKE-IT-1 + END-IF + IF X-MM = 0 MOVE 1 TO X-MM. + COMPUTE X-DD = X-DD + 32 + (X-YYYY - 1900). + + MAKE-IT-2. + IF X-DD > DAYS-IN-MONTH(X-MM) + COMPUTE X-DD = X-DD - DAYS-IN-MONTH(X-MM) + GO TO MAKE-IT-2 + END-IF + IF X-DD < 1 MOVE 1 TO X-DD. + IF X-DD = 29 AND X-MM = 2 + MOVE 2 TO X-DD + MOVE 3 TO X-MM + END-IF + DISPLAY G-DOB " " G-SE-RELATE " " G-GARNAME + DISPLAY X-DOB " " G-PR-RELATE " " G-PRNAME. + * ACCEPT ANS + MOVE X-DOB TO DMG-DOB + MOVE "M" TO DMG-GENDER + IF G-PR-RELATE NOT NUMERIC + MOVE "F" TO DMG-GENDER. + MAKE-IT-UP-EXIT. + EXIT. + P98. + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM SE01 + MOVE SPACE TO SEGFILE01 + WRITE SEGFILE01 FROM GE01 + MOVE SPACE TO SEGFILE01. + * WRITE SEGFILE01 FROM IEA01. + + P99. + REWRITE HIPCLAIMFILE01. + CLOSE GARFILE HIPCLAIMFILE CHARCUR ERRFILE. + STOP RUN. diff --git a/rri/collt/rri750.cob b/rri/collt/rri750.cob new file mode 100644 index 00000000..b2c742ef --- /dev/null +++ b/rri/collt/rri750.cob @@ -0,0 +1,174 @@ + * @package cms + * @link http://www.cmsvt.com + * @author s waite + * @author Claude (Anthropic) + * @copyright Copyright (c) 2026 cms + * @license https://github.com/openemr/openemr/blob/master/LICENSE GNU General Public License 3 + IDENTIFICATION DIVISION. + PROGRAM-ID. rri750. + AUTHOR. SWAITE. + DATE-COMPILED. TODAY. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT GARFILE ASSIGN TO "S30" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS G-GARNO + ALTERNATE RECORD KEY IS G-ACCT WITH DUPLICATES + LOCK MODE MANUAL. + SELECT CHARCUR ASSIGN TO "S35" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS CHARCUR-KEY + ALTERNATE RECORD KEY IS CC-PAYCODE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT PAYCUR ASSIGN TO "S40" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS PAYCUR-KEY + LOCK MODE MANUAL. + SELECT FILEIN ASSIGN TO "S50" + ORGANIZATION LINE SEQUENTIAL. + SELECT PARMFILE ASSIGN TO "S55" + ORGANIZATION LINE SEQUENTIAL. + SELECT GAROUT ASSIGN TO "S60" + ORGANIZATION LINE SEQUENTIAL. + SELECT CHAROUT ASSIGN TO "S65" + ORGANIZATION LINE SEQUENTIAL. + SELECT PAYOUT ASSIGN TO "S70" + ORGANIZATION LINE SEQUENTIAL. + SELECT CHARNEW ASSIGN TO "S75" + ORGANIZATION LINE SEQUENTIAL. + SELECT PAYNEW ASSIGN TO "S80" + ORGANIZATION LINE SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD GARFILE. + COPY GARFILE.CPY. + FD CHARCUR. + COPY CHARCUR.CPY. + FD PAYCUR. + COPY PAYCUR.CPY. + FD FILEIN. + 01 FILEIN01 PIC X(8). + FD PARMFILE. + 01 PARMFILE01. + 02 PF1 PIC 9(8). + 02 PF2 PIC 9(8). + FD GAROUT. + 01 GAROUT01 PIC X(277). + FD CHAROUT. + 01 CHAROUT01 PIC X(160). + FD PAYOUT. + 01 PAYOUT01 PIC X(50). + FD CHARNEW. + 01 CHARNEW01 PIC X(160). + FD PAYNEW. + 01 PAYNEW01 PIC X(50). + WORKING-STORAGE SECTION. + 01 PHR01. + 02 PHR02 OCCURS 999 TIMES INDEXED BY PHR. + 03 PHR-KEY8 PIC X(8). + 03 PHR-KEY3 PIC 999. + 03 PHR-AMOUNT PIC S9(4)V99. + 03 PHR-PAYCODE PIC 999. + 03 PHR-DENIAL PIC XX. + 03 PHR-CLAIM PIC 9(6). + 03 PHR-DATE-T PIC 9(8). + 03 PHR-DATE-E PIC 9(8). + 03 PHR-BATCH PIC X(6). + 01 CLAIM-TOT PIC S9(6)V99. + 01 X USAGE IS INDEX. + 01 FLAGX PIC 9. + 01 GARFLAG PIC 9. + 77 ACCT-CNT PIC 9(7) VALUE ZERO. + 77 ARCH-CNT PIC 9(7) VALUE ZERO. + PROCEDURE DIVISION. + P0. + OPEN INPUT GARFILE PARMFILE FILEIN + OPEN OUTPUT GAROUT PAYOUT CHAROUT CHARNEW PAYNEW + OPEN INPUT PAYCUR CHARCUR. + READ PARMFILE AT END + DISPLAY "NO DELETE RANGE" + GO TO R20 + END-READ. + DISPLAY "PF1 (archive charges before): " PF1. + DISPLAY "PF2 (skip if activity after): " PF2. + P1. + READ FILEIN AT END GO TO R20. + ADD 1 TO ACCT-CNT. + IF FUNCTION MOD(ACCT-CNT, 1000) = 0 + DISPLAY ACCT-CNT " scanned, " ARCH-CNT " archived" + END-IF. + MOVE FILEIN01 TO G-GARNO. + START GARFILE KEY NOT < G-GARNO INVALID GO TO P1. + R0. + READ GARFILE NEXT AT END GO TO P1. + IF G-GARNO NOT = FILEIN01 GO TO P1. + SET PHR TO 1. + MOVE 0 TO GARFLAG. + MOVE G-GARNO TO PC-KEY8 + MOVE 000 TO PC-KEY3. + START PAYCUR KEY > PAYCUR-KEY INVALID GO TO R2. + R5. + READ PAYCUR NEXT AT END GO TO R2. + IF G-GARNO NOT = PC-KEY8 GO TO R2. + IF PHR > 999 + DISPLAY G-GARNO " " G-GARNAME " PHR OVERFLOW" + GO TO R0. + MOVE PC-KEY8 TO PHR-KEY8(PHR) + MOVE PC-KEY3 TO PHR-KEY3(PHR) + MOVE PC-AMOUNT TO PHR-AMOUNT(PHR) + MOVE PC-PAYCODE TO PHR-PAYCODE(PHR) + MOVE PC-DENIAL TO PHR-DENIAL(PHR) + MOVE PC-CLAIM TO PHR-CLAIM(PHR) + MOVE PC-DATE-T TO PHR-DATE-T(PHR) + MOVE PC-DATE-E TO PHR-DATE-E(PHR) + MOVE PC-BATCH TO PHR-BATCH(PHR) + SET PHR UP BY 1. + GO TO R5. + R2. + SET PHR DOWN BY 1. + MOVE G-GARNO TO CC-KEY8 + MOVE "000" TO CC-KEY3. + START CHARCUR KEY > CHARCUR-KEY INVALID GO TO R30. + R6. + READ CHARCUR NEXT AT END GO TO R30. + IF G-GARNO NOT = CC-KEY8 GO TO R30. + IF CC-DATE-T > PF1 + WRITE CHARNEW01 FROM CHARCUR01 + PERFORM A6 THRU A6-EXIT + VARYING X FROM 1 BY 1 UNTIL X > PHR + GO TO R6. + COMPUTE CLAIM-TOT = CC-AMOUNT + MOVE 0 TO FLAGX + PERFORM PH3 VARYING X FROM 1 BY 1 UNTIL X > PHR. + IF (CLAIM-TOT NOT = 0) OR (FLAGX NOT = 0) + WRITE CHARNEW01 FROM CHARCUR01 + PERFORM A6 THRU A6-EXIT + VARYING X FROM 1 BY 1 UNTIL X > PHR + GO TO R6. + PERFORM A5 THRU A5-EXIT + VARYING X FROM 1 BY 1 UNTIL X > PHR. + MOVE 1 TO GARFLAG. + WRITE CHAROUT01 FROM CHARCUR01. + GO TO R6. + PH3. + IF CC-CLAIM = PHR-CLAIM(X) + ADD PHR-AMOUNT(X) CLAIM-TOT GIVING CLAIM-TOT + IF PHR-DATE-T(X) > PF2 + MOVE 1 TO FLAGX. + A5. + IF PHR-CLAIM(X) NOT = CC-CLAIM GO TO A5-EXIT. + WRITE PAYOUT01 FROM PHR02(X). + A5-EXIT. EXIT. + A6. + IF PHR-CLAIM(X) NOT = CC-CLAIM GO TO A6-EXIT. + WRITE PAYNEW01 FROM PHR02(X). + A6-EXIT. EXIT. + R30. + IF GARFLAG = 1 + WRITE GAROUT01 FROM GARFILE01 + ADD 1 TO ARCH-CNT. + GO TO P1. + R20. + DISPLAY "Accounts scanned: " ACCT-CNT. + DISPLAY "Accounts archived (1+ charge): " ARCH-CNT. + CLOSE GARFILE CHARCUR PAYCUR FILEIN PARMFILE + GAROUT CHAROUT PAYOUT CHARNEW PAYNEW. + STOP RUN. \ No newline at end of file diff --git a/rri/collt/rrihist.cob b/rri/collt/rrihist.cob new file mode 100644 index 00000000..648a8cfc --- /dev/null +++ b/rri/collt/rrihist.cob @@ -0,0 +1,274 @@ + * @package cms + * @link http://www.cmsvt.com + * @author s waite + * @author Claude (Anthropic) + * @copyright Copyright (c) 2026 cms + * @license https://github.com/openemr/openemr/blob/master/LICENSE GNU General Public License 3 + IDENTIFICATION DIVISION. + PROGRAM-ID. rrihist. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT CHAROUT ASSIGN TO "S65" + ORGANIZATION LINE SEQUENTIAL. + SELECT HISFILE ASSIGN TO "S70" ORGANIZATION IS INDEXED + ACCESS IS DYNAMIC RECORD KEY IS HISFILE-KEY. + SELECT PAYOUT ASSIGN TO "S85" + ORGANIZATION LINE SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD CHAROUT. + 01 CHAROUT01. + 02 CO-KEY8 PIC X(8). + 02 CO-KEY3 PIC X(3). + 02 CO-PATID PIC X(8). + 02 CO-CLAIM PIC X(6). + 02 CO-SERVICE PIC X. + 02 CO-DIAG PIC X(7). + 02 CO-PROC PIC X(11). + 02 CO-MOD2 PIC XX. + 02 CO-MOD3 PIC XX. + 02 CO-MOD4 PIC XX. + 02 CO-AMOUNT PIC X(6). + 02 CO-DOCR PIC X(3). + 02 CO-DOCP PIC X(2). + 02 CO-PAYCODE PIC X(3). + 02 CO-STUD PIC X. + 02 CO-WORK PIC XX. + 02 CO-DAT1 PIC X(8). + 02 CO-RESULT PIC X. + 02 CO-ACT PIC X. + 02 CO-SORCREF PIC X. + 02 CO-COLLT PIC X. + 02 CO-AUTH PIC X. + 02 CO-PAPER PIC X. + 02 CO-PLACE PIC X. + 02 CO-EPSDT PIC X. + 02 CO-DATE-T PIC X(8). + 02 CO-DATE-A PIC X(8). + 02 CO-DATE-P PIC X(8). + 02 CO-REC-STAT PIC X. + 02 CO-DX2 PIC X(7). + 02 CO-DX3 PIC X(7). + 02 CO-ACC-TYPE PIC X. + 02 CO-DATE-M PIC X(8). + 02 CO-ASSIGN PIC X. + 02 CO-NEIC-ASSIGN PIC X. + 02 CO-DX4 PIC X(7). + 02 CO-QP1 PIC XX. + 02 CO-QP2 PIC XX. + 02 CO-VISITNO PIC X(7). + 02 CO-QP3 PIC XX. + 02 CO-FUTURE PIC X(7). + FD PAYOUT. + 01 PAYOUT01. + 02 PO-KEY8 PIC X(8). + 02 PO-KEY3 PIC X(3). + 02 PO-AMOUNT PIC X(6). + 02 PO-PAYCODE PIC X(3). + 02 PO-DENIAL PIC XX. + 02 PO-CLAIM PIC X(6). + 02 PO-DATE-T PIC X(8). + 02 PO-DATE-E PIC X(8). + 02 PO-BATCH PIC X(6). + FD HISFILE. + COPY HISFILE.CPY. + WORKING-STORAGE SECTION. + 01 PAYHIS01. + 02 PH-KEY. + 03 PH-KEY8 PIC X(8). + 03 PH-CLAIM PIC X(6). + 03 PH-REC-TYPE PIC X. + 03 PH-KEY4 PIC X(4). + 02 PC1. + 03 PC1-IND PIC X. + 03 PC1-AMOUNT PIC X(6). + 03 PC1-PAYCODE PIC X(3). + 03 PC1-DENIAL PIC XX. + 03 PC1-DATE-T PIC X(8). + 03 PC1-DATE-E PIC X(8). + 03 PC1-BATCH PIC X(6). + 02 PC1-PAD PIC X(10). + 02 PC2. + 03 PC2-IND PIC X. + 03 PC2-AMOUNT PIC X(6). + 03 PC2-PAYCODE PIC X(3). + 03 PC2-DENIAL PIC XX. + 03 PC2-DATE-T PIC X(8). + 03 PC2-DATE-E PIC X(8). + 03 PC2-BATCH PIC X(6). + 02 PH-FUTURE PIC X(38). + 01 PHR01. + 02 PHR02 OCCURS 999 TIMES. + 03 PHR-AMOUNT PIC X(6). + 03 PHR-PAYCODE PIC X(3). + 03 PHR-DENIAL PIC XX. + 03 PHR-CLAIM PIC X(6). + 03 PHR-DATE-T PIC X(8). + 03 PHR-DATE-E PIC X(8). + 03 PHR-BATCH PIC X(6). + 77 HOLD8 PIC X(8). + 77 PHR-CNT PIC 9(4) VALUE ZERO. + 77 PC-SLOT PIC 9 VALUE ZERO. + 77 KEY4 PIC 9(4) VALUE ZERO. + 77 PXR PIC 9(4). + 77 CHARS-CNT PIC 9(7) VALUE ZERO. + 77 PAYS-CNT PIC 9(7) VALUE ZERO. + 77 EOF-PAYOUT PIC X VALUE "N". + PROCEDURE DIVISION. + MAIN. + OPEN INPUT CHAROUT PAYOUT + OPEN I-O HISFILE. + MOVE LOW-VALUES TO HOLD8. + READ PAYOUT AT END MOVE "Y" TO EOF-PAYOUT END-READ. + + P00. + READ CHAROUT AT END GO TO P-DONE END-READ. + ADD 1 TO CHARS-CNT. + + IF CO-KEY8 NOT = HOLD8 + MOVE CO-KEY8 TO HOLD8 + MOVE 0 TO PHR-CNT + PERFORM LOAD-PHR. + + MOVE 0 TO KEY4. + P-CHRG-KEY. + ADD 1 TO KEY4. + MOVE CO-KEY8 TO HS-KEY8 + MOVE CO-CLAIM TO HS-CLAIM + MOVE "1" TO HS-REC-TYPE + MOVE KEY4 TO HS-KEY4. + READ HISFILE INVALID GO TO P-CHRG-WRITE. + GO TO P-CHRG-KEY. + + P-CHRG-WRITE. + MOVE SPACES TO HISFILE01. + MOVE CO-KEY8 TO HS-KEY8 + MOVE CO-CLAIM TO HS-CLAIM + MOVE "1" TO HS-REC-TYPE + MOVE KEY4 TO HS-KEY4. + MOVE CO-PATID(1:7) TO HS-PATID7 + MOVE CO-PATID(8:1) TO HS-PATID1 + MOVE CO-SERVICE TO HS-SERVICE + MOVE CO-DIAG(1:5) TO HS-DIAG + MOVE CO-PROC TO HS-PROC + MOVE CO-MOD2 TO HS-MOD2 + MOVE CO-MOD3 TO HS-MOD3 + MOVE CO-MOD4 TO HS-MOD4 + MOVE CO-AMOUNT TO HS-AMOUNT + MOVE CO-DOCR TO HS-DOCR + MOVE CO-DOCP TO HS-DOCP + MOVE CO-PAYCODE TO HS-PAYCODE + MOVE CO-STUD TO HS-STUD + MOVE CO-WORK TO HS-WORK + MOVE CO-DAT1 TO HS-DAT1 + MOVE CO-RESULT TO HS-RESULT + MOVE CO-ACT TO HS-ACT + MOVE CO-SORCREF TO HS-SORCREF + MOVE CO-COLLT TO HS-COLLT + MOVE CO-AUTH TO HS-AGE + MOVE CO-PAPER TO HS-PAPER + MOVE CO-PLACE TO HS-PLACE + MOVE CO-EPSDT TO HS-EPSDT + MOVE CO-DATE-T TO HS-DATE-T + MOVE CO-DATE-A TO HS-DATE-A + MOVE CO-DATE-P TO HS-DATE-E + MOVE CO-REC-STAT TO HS-REC-STAT + MOVE CO-DX2(1:5) TO HS-DX2 + MOVE CO-DX3(1:5) TO HS-DX3 + MOVE CO-ACC-TYPE TO HS-ACC-TYPE + MOVE CO-DATE-M TO HS-DATE-M + MOVE CO-ASSIGN TO HS-ASSIGN + MOVE CO-NEIC-ASSIGN TO HS-NEIC-ASSIGN + MOVE SPACES TO HS-FUTURE. + WRITE HISFILE01 INVALID KEY + DISPLAY "DUP CHARGE: " HS-KEY8 " " HS-CLAIM + " " HS-KEY4 + END-WRITE. + + MOVE 0 TO PC-SLOT. + PERFORM PACK-PAYS + VARYING PXR FROM 1 BY 1 UNTIL PXR > PHR-CNT. + + IF PC-SLOT = 1 + PERFORM WRITE-PAYHIS THRU P-PAY-WRITE. + + GO TO P00. + + LOAD-PHR. + IF EOF-PAYOUT = "N" AND PO-KEY8 = HOLD8 + ADD 1 TO PHR-CNT + IF PHR-CNT > 999 + DISPLAY "PHR OVERFLOW: " HOLD8 + ELSE + MOVE PO-AMOUNT TO PHR-AMOUNT(PHR-CNT) + MOVE PO-PAYCODE TO PHR-PAYCODE(PHR-CNT) + MOVE PO-DENIAL TO PHR-DENIAL(PHR-CNT) + MOVE PO-CLAIM TO PHR-CLAIM(PHR-CNT) + MOVE PO-DATE-T TO PHR-DATE-T(PHR-CNT) + MOVE PO-DATE-E TO PHR-DATE-E(PHR-CNT) + MOVE PO-BATCH TO PHR-BATCH(PHR-CNT) + END-IF + READ PAYOUT AT END MOVE "Y" TO EOF-PAYOUT END-READ + GO TO LOAD-PHR. + + PACK-PAYS. + IF PHR-CLAIM(PXR) = CO-CLAIM + IF PC-SLOT = 0 + MOVE "1" TO PC1-IND + MOVE PHR-AMOUNT(PXR) TO PC1-AMOUNT + MOVE PHR-PAYCODE(PXR) TO PC1-PAYCODE + MOVE PHR-DENIAL(PXR) TO PC1-DENIAL + MOVE PHR-DATE-T(PXR) TO PC1-DATE-T + MOVE PHR-DATE-E(PXR) TO PC1-DATE-E + MOVE PHR-BATCH(PXR) TO PC1-BATCH + MOVE SPACES TO PC1-PAD + MOVE "0" TO PC2-IND + MOVE "000000" TO PC2-AMOUNT + MOVE "000" TO PC2-PAYCODE + MOVE SPACES TO PC2-DENIAL + MOVE "00000000" TO PC2-DATE-T PC2-DATE-E + MOVE "000000" TO PC2-BATCH + MOVE 1 TO PC-SLOT + ADD 1 TO PAYS-CNT + ELSE + MOVE "2" TO PC2-IND + MOVE PHR-AMOUNT(PXR) TO PC2-AMOUNT + MOVE PHR-PAYCODE(PXR) TO PC2-PAYCODE + MOVE PHR-DENIAL(PXR) TO PC2-DENIAL + MOVE PHR-DATE-T(PXR) TO PC2-DATE-T + MOVE PHR-DATE-E(PXR) TO PC2-DATE-E + MOVE PHR-BATCH(PXR) TO PC2-BATCH + ADD 1 TO PAYS-CNT + PERFORM WRITE-PAYHIS THRU P-PAY-WRITE + END-IF + END-IF. + + WRITE-PAYHIS. + MOVE CO-KEY8 TO PH-KEY8 + MOVE CO-CLAIM TO PH-CLAIM + MOVE "2" TO PH-REC-TYPE + MOVE SPACES TO PH-FUTURE. + P-PAY-KEY. + ADD 1 TO KEY4. + MOVE KEY4 TO PH-KEY4 + MOVE PH-KEY8 TO HS-KEY8 + MOVE PH-CLAIM TO HS-CLAIM + MOVE "2" TO HS-REC-TYPE + MOVE KEY4 TO HS-KEY4. + READ HISFILE INVALID GO TO P-PAY-WRITE. + GO TO P-PAY-KEY. + P-PAY-WRITE. + WRITE HISFILE01 FROM PAYHIS01 INVALID KEY + DISPLAY "DUP PAY: " PH-KEY8 " " PH-CLAIM + " " PH-KEY4 + END-WRITE. + MOVE 0 TO PC-SLOT. + + P-DONE. + DISPLAY "Charges written: " CHARS-CNT. + DISPLAY "Payments packed: " PAYS-CNT. + DISPLAY "Press any key to exit..." + ACCEPT OMITTED. + CLOSE CHAROUT PAYOUT HISFILE. + STOP RUN. \ No newline at end of file diff --git a/rri/collt/wo001.cob b/rri/collt/wo001.cob new file mode 100644 index 00000000..8e590d85 --- /dev/null +++ b/rri/collt/wo001.cob @@ -0,0 +1,130 @@ + * @package cms + * @link http://www.cmsvt.com + * @author s waite + * @author Claude (Anthropic) + * @copyright Copyright (c) 2026 cms + * @license https://github.com/openemr/openemr/blob/master/LICENSE GNU General Public License 3 + IDENTIFICATION DIVISION. + PROGRAM-ID. wo001. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT GARFILE ASSIGN TO "S30" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS G-GARNO + ALTERNATE RECORD KEY IS G-ACCT WITH DUPLICATES + LOCK MODE MANUAL. + SELECT CHARCUR ASSIGN TO "S35" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS CHARCUR-KEY + ALTERNATE RECORD KEY IS CC-PAYCODE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT PAYCUR ASSIGN TO "S40" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS PAYCUR-KEY + LOCK MODE MANUAL. + SELECT PAYFILE ASSIGN TO "S45" ORGANIZATION IS INDEXED + ACCESS IS DYNAMIC RECORD KEY IS PAYFILE-KEY + LOCK MODE MANUAL. + SELECT INFILE ASSIGN TO "S50" + ORGANIZATION IS LINE SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD GARFILE. + COPY GARFILE.CPY. + FD CHARCUR. + COPY CHARCUR.CPY. + FD PAYCUR. + COPY PAYCUR.CPY. + FD PAYFILE. + COPY PAYFILE.CPY. + FD INFILE. + 01 INREC. + 05 IN-KEY8 PIC X(8). + 05 IN-KEY3 PIC X(3). + 05 FILLER PIC X(149). + WORKING-STORAGE SECTION. + 77 TOTALPAY PIC S9(7)V99 COMP-3 VALUE ZERO. + 77 WO-AMT PIC S9(7)V99 COMP-3. + 77 TODAY PIC X(8). + 77 XYZ PIC 9(3). + 77 ADJ-MODE PIC X. + 77 ADJ-PAYCODE PIC X(3). + 01 TIME-NOW. + 05 TN-HHMMSS PIC X(6). + 05 FILLER PIC X(2). + PROCEDURE DIVISION. + MAIN. + DISPLAY "Adjust mode (D=debit/owes, C=credit/owed): " + WITH NO ADVANCING. + ACCEPT ADJ-MODE. + IF ADJ-MODE = "D" + MOVE "014" TO ADJ-PAYCODE + ELSE IF ADJ-MODE = "C" + MOVE "015" TO ADJ-PAYCODE + ELSE + DISPLAY "Invalid mode." + STOP RUN. + OPEN INPUT INFILE CHARCUR PAYCUR GARFILE + OPEN I-O PAYFILE + ACCEPT TODAY FROM DATE YYYYMMDD. + P00. + READ INFILE AT END GO TO P-DONE END-READ. + MOVE IN-KEY8 TO CC-KEY8 + MOVE IN-KEY3 TO CC-KEY3. + READ CHARCUR INVALID KEY + DISPLAY "NO CHARGE: " IN-KEY8 " " IN-KEY3 + GO TO P00 + END-READ. + MOVE CC-KEY8 TO G-GARNO. + READ GARFILE INVALID KEY + DISPLAY "NO GAR: " CC-KEY8 + MOVE SPACES TO G-GARNAME + END-READ. + MOVE ZERO TO TOTALPAY + MOVE CC-KEY8 TO PC-KEY8 + MOVE LOW-VALUES TO PC-KEY3. + START PAYCUR KEY >= PAYCUR-KEY + INVALID KEY GO TO P-WO + END-START. + P1. + READ PAYCUR NEXT AT END GO TO P-WO END-READ. + IF PC-KEY8 NOT = CC-KEY8 GO TO P-WO. + IF PC-CLAIM NOT = CC-CLAIM GO TO P1. + ADD PC-AMOUNT TO TOTALPAY. + GO TO P1. + P-WO. + COMPUTE WO-AMT = CC-AMOUNT + TOTALPAY. + IF ADJ-MODE = "D" AND WO-AMT NOT > 0 + DISPLAY "SKIP " IN-KEY8 " " IN-KEY3 + " CLM=" CC-CLAIM " BAL=" WO-AMT + GO TO P00. + IF ADJ-MODE = "C" AND WO-AMT NOT < 0 + DISPLAY "SKIP " IN-KEY8 " " IN-KEY3 + " CLM=" CC-CLAIM " BAL=" WO-AMT + GO TO P00. + MOVE CC-KEY8 TO PD-KEY8 + MOVE ZERO TO XYZ. + P3. + ADD 1 TO XYZ. + MOVE XYZ TO PD-KEY3. + READ PAYFILE INVALID GO TO P4. + GO TO P3. + P4. + ACCEPT TIME-NOW FROM TIME. + MOVE G-GARNAME TO PD-NAME + COMPUTE PD-AMOUNT = 0 - WO-AMT + MOVE ADJ-PAYCODE TO PD-PAYCODE + MOVE "AA" TO PD-DENIAL + MOVE CC-CLAIM TO PD-CLAIM + MOVE CC-DATE-T TO PD-DATE-T + MOVE CC-DATE-T TO PD-DATE-E + MOVE TN-HHMMSS TO PD-ORDER + MOVE SPACES TO PD-BATCH. + WRITE PAYFILE01 INVALID KEY + DISPLAY "DUP: " PD-KEY8 " " PD-KEY3 + GO TO P00 + END-WRITE. + DISPLAY "WO " IN-KEY8 " " IN-KEY3 + " CLM=" CC-CLAIM " AMT=" WO-AMT. + GO TO P00. + P-DONE. + CLOSE INFILE CHARCUR PAYCUR GARFILE PAYFILE. + STOP RUN. \ No newline at end of file diff --git a/rri/collt/wo002.cob b/rri/collt/wo002.cob new file mode 100644 index 00000000..e7ab3c0c --- /dev/null +++ b/rri/collt/wo002.cob @@ -0,0 +1,115 @@ + * @package cms + * @link http://www.cmsvt.com + * @author s waite + * @author Claude (Anthropic) + * @copyright Copyright (c) 2026 cms + * @license https://github.com/openemr/openemr/blob/master/LICENSE GNU General Public License 3 + IDENTIFICATION DIVISION. + PROGRAM-ID. wo002. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT GARFILE ASSIGN TO "S30" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS G-GARNO + ALTERNATE RECORD KEY IS G-ACCT WITH DUPLICATES + LOCK MODE MANUAL. + SELECT CHARCUR ASSIGN TO "S35" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS CHARCUR-KEY + ALTERNATE RECORD KEY IS CC-PAYCODE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT PAYCUR ASSIGN TO "S40" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS PAYCUR-KEY + LOCK MODE MANUAL. + SELECT PAYFILE ASSIGN TO "S45" ORGANIZATION IS INDEXED + ACCESS IS DYNAMIC RECORD KEY IS PAYFILE-KEY + LOCK MODE MANUAL. + SELECT OWESFILE ASSIGN TO "S50" + ORGANIZATION IS LINE SEQUENTIAL. + SELECT OWEDFILE ASSIGN TO "S55" + ORGANIZATION IS LINE SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD GARFILE. + COPY GARFILE.CPY. + FD CHARCUR. + COPY CHARCUR.CPY. + FD PAYCUR. + COPY PAYCUR.CPY. + FD PAYFILE. + COPY PAYFILE.CPY. + FD OWESFILE. + 01 OWES-REC PIC X(160). + FD OWEDFILE. + 01 OWED-REC PIC X(160). + WORKING-STORAGE SECTION. + 77 TOTALPAY PIC S9(7)V99 COMP-3 VALUE ZERO. + 77 WO-AMT PIC S9(7)V99 COMP-3. + 77 TODAY PIC X(8). + 77 FROM-DATE PIC X(8). + 77 TO-DATE PIC X(8). + 77 CNT-OWES PIC 9(6) VALUE ZERO. + 77 CNT-OWED PIC 9(6) VALUE ZERO. + 77 CNT-ZERO PIC 9(6) VALUE ZERO. + PROCEDURE DIVISION. + MAIN. + DISPLAY "From date (YYYYMMDD): " WITH NO ADVANCING. + ACCEPT FROM-DATE. + DISPLAY "To date (YYYYMMDD): " WITH NO ADVANCING. + ACCEPT TO-DATE. + IF FROM-DATE = SPACES OR TO-DATE = SPACES + DISPLAY "Both dates required." + STOP RUN. + IF FROM-DATE > TO-DATE + DISPLAY "From date must be <= to date." + STOP RUN. + OPEN INPUT CHARCUR PAYCUR GARFILE + OPEN I-O PAYFILE + OPEN OUTPUT OWESFILE OWEDFILE + ACCEPT TODAY FROM DATE YYYYMMDD. + MOVE LOW-VALUES TO CHARCUR-KEY. + START CHARCUR KEY >= CHARCUR-KEY + INVALID KEY GO TO P-DONE + END-START. + P00. + READ CHARCUR NEXT AT END GO TO P-DONE END-READ. + IF CC-DATE-T < FROM-DATE GO TO P00. + IF CC-DATE-T > TO-DATE GO TO P00. + MOVE CC-KEY8 TO G-GARNO. + READ GARFILE INVALID KEY + DISPLAY "NO GAR: " CC-KEY8 + MOVE SPACES TO G-GARNAME + END-READ. + MOVE ZERO TO TOTALPAY + MOVE CC-KEY8 TO PC-KEY8 + MOVE LOW-VALUES TO PC-KEY3. + START PAYCUR KEY >= PAYCUR-KEY + INVALID KEY GO TO P-EVAL + END-START. + P1. + READ PAYCUR NEXT AT END GO TO P-EVAL END-READ. + IF PC-KEY8 NOT = CC-KEY8 GO TO P-EVAL. + IF PC-CLAIM NOT = CC-CLAIM GO TO P1. + ADD PC-AMOUNT TO TOTALPAY. + GO TO P1. + P-EVAL. + COMPUTE WO-AMT = CC-AMOUNT + TOTALPAY. + IF WO-AMT = 0 + ADD 1 TO CNT-ZERO + GO TO P00. + IF WO-AMT > 0 + WRITE OWES-REC FROM CHARCUR01 + ADD 1 TO CNT-OWES + DISPLAY "OWES " CC-KEY8 " " CC-KEY3 + " CLM=" CC-CLAIM " BAL=" WO-AMT + GO TO P00. + WRITE OWED-REC FROM CHARCUR01 + ADD 1 TO CNT-OWED + DISPLAY "OWED " CC-KEY8 " " CC-KEY3 + " CLM=" CC-CLAIM " BAL=" WO-AMT. + GO TO P00. + P-DONE. + DISPLAY "OWES (debit balances): " CNT-OWES. + DISPLAY "OWED (credit balances): " CNT-OWED. + DISPLAY "ZERO (paid in full): " CNT-ZERO. + CLOSE CHARCUR PAYCUR GARFILE PAYFILE OWESFILE OWEDFILE. + STOP RUN. \ No newline at end of file diff --git a/rri/collt/wo004.cob b/rri/collt/wo004.cob new file mode 100644 index 00000000..f65a7479 --- /dev/null +++ b/rri/collt/wo004.cob @@ -0,0 +1,54 @@ + * @package cms + * @link http://www.cmsvt.com + * @author s waite + * @author Claude (Anthropic) + * @copyright Copyright (c) 2026 cms + * @license https://github.com/openemr/openemr/blob/master/LICENSE GNU General Public License 3 + IDENTIFICATION DIVISION. + PROGRAM-ID. wo004. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT CHARCUR ASSIGN TO "S35" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS CHARCUR-KEY + ALTERNATE RECORD KEY IS CC-PAYCODE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT FILEOUT ASSIGN TO "S50" + ORGANIZATION IS LINE SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD CHARCUR. + COPY CHARCUR.CPY. + FD FILEOUT. + 01 FILEOUT01 PIC X(8). + WORKING-STORAGE SECTION. + 77 TO-DATE PIC X(8). + 77 HOLD8 PIC X(8). + 77 CNT PIC 9(7) VALUE ZERO. + PROCEDURE DIVISION. + MAIN. + DISPLAY "Archive charges on or before (YYYYMMDD): " + WITH NO ADVANCING. + ACCEPT TO-DATE. + IF TO-DATE = SPACES + DISPLAY "Date required." + STOP RUN. + OPEN INPUT CHARCUR + OPEN OUTPUT FILEOUT. + MOVE LOW-VALUES TO CHARCUR-KEY. + START CHARCUR KEY >= CHARCUR-KEY + INVALID KEY GO TO P-DONE + END-START. + MOVE LOW-VALUES TO HOLD8. + P00. + READ CHARCUR NEXT AT END GO TO P-DONE END-READ. + IF CC-DATE-T > TO-DATE GO TO P00. + IF CC-KEY8 = HOLD8 GO TO P00. + MOVE CC-KEY8 TO HOLD8. + WRITE FILEOUT01 FROM CC-KEY8. + ADD 1 TO CNT. + GO TO P00. + P-DONE. + DISPLAY "GARNOs written: " CNT. + CLOSE CHARCUR FILEOUT. + STOP RUN. \ No newline at end of file diff --git a/rri/collt/zeror001.cob b/rri/collt/zeror001.cob index 977a8bfa..d3863283 100644 --- a/rri/collt/zeror001.cob +++ b/rri/collt/zeror001.cob @@ -49,16 +49,16 @@ WORKING-STORAGE SECTION. 01 CLAIM-TOT PIC S9(6)V99. - 01 GARBACK PIC X(315). PROCEDURE DIVISION. P0. - OPEN INPUT GARFILE CHARCUR PAYCUR. - open output fileout. + OPEN I-O GARFILE CHARCUR + OPEN INPUT PAYCUR. + OPEN OUTPUT FILEOUT. R1. - READ GARFILE NEXT + READ GARFILE NEXT WITH LOCK AT END GO TO R99. @@ -98,58 +98,26 @@ GO TO R4. R5. - IF CLAIM-TOT NOT = 0 - IF G-DELETE NOT = "1" - MOVE "1" TO G-DELETE - PERFORM R6 thru r6-exit - end-if + IF CLAIM-TOT > 0 + IF G-DELETE NOT = "1" + MOVE "1" TO G-DELETE + REWRITE GARFILE01 + END-IF ELSE - IF G-DELETE NOT = SPACE - MOVE SPACE TO G-DELETE - PERFORM R6 thru r6-exit - end-if + IF G-DELETE NOT = SPACE + MOVE SPACE TO G-DELETE + REWRITE GARFILE01 + END-IF END-IF IF CLAIM-TOT NOT > 0 PERFORM R7 THRU R7-EXIT - CLOSE charcur - OPEN INPUT charcur END-IF GO TO R1. - R6. - MOVE GARFILE01 TO GARBACK - CLOSE GARFILE - OPEN I-O GARFILE - MOVE GARBACK(1:8) TO G-GARNO - READ GARFILE WITH LOCK - INVALID - DISPLAY "COULD NOT READ GARFILE WITH LOCK" - - END-READ - MOVE GARBACK TO GARFILE01 - * DISPLAY G-GARNO " " G-DELETE " " G-DUNNING - * DISPLAY " " - - REWRITE GARFILE01. - CLOSE GARFILE - OPEN INPUT GARFILE. - MOVE GARBACK(1:8) TO G-GARNO - START GARFILE KEY > G-GARNO - INVALID - DISPLAY "LAST GARNO? " G-GARNO - * ACCEPT OMITTED - GO TO R6-exit. - - R6-exit. - exit. - R7. - CLOSE CHARCUR - OPEN I-O CHARCUR - - MOVE GARBACK(1:8) TO CC-KEY8 + MOVE G-GARNO TO CC-KEY8 MOVE SPACE TO CC-KEY3 START CHARCUR KEY NOT < CHARCUR-KEY invalid @@ -162,10 +130,8 @@ GO TO R7-EXIT END-READ - if cc-key8 not = garback(1:8) go to r7-exit. - + if cc-key8 not = G-GARNO go to r7-exit. if cc-assign = "A" go to r7-1. - IF CC-date-a = "00000000" go to r7-1. move "00000000" to cc-date-a diff --git a/rri/fees/med007.cob b/rri/fees/med007.cob index 83bcb5c0..cd8d9e30 100644 --- a/rri/fees/med007.cob +++ b/rri/fees/med007.cob @@ -16,14 +16,7 @@ DATA DIVISION. FILE SECTION. FD FILEIN. - 01 FILEIN01. - 02 FI-1 PIC X. - 02 FILLER PIC X(5). - 02 FI-2 PIC X(5). - 02 FILLER PIC X(15). - 02 FI-3 PIC XX. - 02 FILLER PIC X(17). - 02 FI-4 PIC X(7). + 01 FILEIN01 PIC X(80). FD MEDFILE2020. 01 MEDFILE202001. 02 MED-KEY. @@ -43,6 +36,11 @@ 01 CENTX PIC XX. 01 RIGHT-4 pic X(4) JUST RIGHT. 01 X-AMT PIC 9(4)V99. + 01 WS-FILEIN. + 05 FI-1 PIC X. + 05 FI-2 PIC X(5). + 05 FI-3 PIC XX. + 05 FI-4 PIC X(7). PROCEDURE DIVISION. P0. OPEN OUTPUT MEDFILE2020 @@ -54,6 +52,13 @@ READ FILEIN AT END GO TO P99 END-READ + INITIALIZE WS-FILEIN + UNSTRING FILEIN01 DELIMITED BY "," + INTO FI-1 + FI-2 + FI-3 + FI-4 + END-UNSTRING. MOVE FI-4 TO FI-AMT MOVE FI-3 TO FI-MOD diff --git a/rri/posting/hipr136.cob b/rri/posting/hipr136.cob index 4be767fd..4d5cc6f3 100644 --- a/rri/posting/hipr136.cob +++ b/rri/posting/hipr136.cob @@ -971,6 +971,7 @@ OR CAS-2 = "27" OR CAS-2 = "29" OR CAS-2 = "96" + OR CAS-2 = "200" OR CAS-2 = "242" ) PERFORM P1-LOST-SVC diff --git a/rri/posting/hiproa.cob b/rri/posting/hiproa.cob index a7a8e31a..590e9104 100644 --- a/rri/posting/hiproa.cob +++ b/rri/posting/hiproa.cob @@ -101,7 +101,7 @@ 02 PF-3 PIC X(27). FD ERROR-FILE. - 01 ERROR-FILE01 PIC X(150). + 01 ERROR-FILE01 PIC X(175). FD FILEIN. 01 FILEIN01. @@ -185,6 +185,9 @@ 03 EF-DENIAL5 PIC XXX. 03 FILLER PIC X VALUE SPACE. 03 EF-DENIAL6 PIC XXX. + 02 FILLER PIC X VALUE SPACE. + 02 EF-AUTH PIC X(20) VALUE SPACE. + 01 ERR201. 02 EF2-NUM PIC ZZ9. 02 FILLER PIC XX VALUE SPACE. @@ -375,14 +378,14 @@ 01 CAS-CODE-CHECK PIC X(5). 88 INS-REDUCE-CODE VALUE "A1 " "A2 " "B6 " "B9 " "B10 " "B13 " "24 " "42 " - "45 " "59 " "131 " "253 " "P12 " "P23 " "P24 ". + "45 " "59 " "253 " "P12 " "P23 " "P24 ". 88 DUMP50-ANY-CODE VALUE "50 " "109 " "167 " "B13 ". 88 DUMP50-CO-CODE VALUE "4 " "7 " "11 " "16 " "18 " "22 " "29 " "31 " "55 " "58 " "95 " - "96 " "97 " "146 " "151 " "197 " "222 " "226 " - "234 " "242 " "252 " "273 " "284 " "288 " "A1 " - "B11 " "B20 " "P12 " "P14 ". + "96 " "97 " "131 " "146 " "151 " "197 " "222 " + "226 " "234 " "242 " "252 " "273 " "284 " "288 " + "A1 " "B11 " "B20 " "P12 " "P14 ". 88 DUMP50-OA-CODE VALUE "18 " "95 " "226 " "A1 " "B11 " "B13 " "P8 ". 88 DUMP50-PI-CODE VALUE "5 " "11 " "96 " "97 " @@ -393,6 +396,10 @@ 01 PAID-FLAG PIC 9 VALUE 0. 01 MISMATCH-FLAG PIC 9 VALUE 0. 01 SVC-TOTAL PIC S9(5)V99 VALUE 0. + 01 PRIOR-TOT PIC S9(7)V99 VALUE 0. + 01 CLP-AUTH PIC X(20) VALUE SPACE. + 01 SAVE-AUTH PIC X(20) VALUE SPACE. + 01 NSA-FLAG PIC 9 VALUE 0. PROCEDURE DIVISION. 0005-START. @@ -617,6 +624,7 @@ MOVE 0 TO LQ-CNTR MOVE 0 TO SVC-TOTAL MOVE 0 TO OVERPAY-FLAG PAID-FLAG MISMATCH-FLAG + MOVE SPACE TO CLP-AUTH MOVE ALL ZEROES TO ALLW-TAB01. P1-NM1. @@ -633,6 +641,7 @@ IF F1 = "SE*" MOVE FILEIN01 TO SAVEFILE01 + MOVE CLP-AUTH TO SAVE-AUTH GO TO P2-SVC-LOOP END-IF @@ -667,6 +676,14 @@ GO TO P1-NM1 END-IF + IF F1 = "REF" AND F2 = "*G1*" + MOVE SPACE TO REF01 + UNSTRING FILEIN01 DELIMITED BY "*" INTO + REF-0 REF-1 REF-2 + MOVE REF-2 TO CLP-AUTH + GO TO P1-NM1 + END-IF + GO TO P1-NM1. P1-SVC-LOOP. @@ -679,6 +696,7 @@ IF F1 = "CLP" OR "SE*" MOVE FILEIN01 TO SAVEFILE01 + MOVE CLP-AUTH TO SAVE-AUTH GO TO P2-SVC-LOOP END-IF. @@ -764,6 +782,8 @@ MOVE CLP-1 TO G-GARNO READ GARFILE INVALID + MOVE SPACE TO G-GARNAME + MOVE CLP-1 TO G-GARNO GO TO P3-SVC-LOOP END-READ @@ -840,6 +860,9 @@ MULTIPLY AMOUNT-X BY -1 GIVING PD-AMOUNT. PERFORM NO-SURPRISE. + IF NSA-FLAG = 1 + GO TO P5-SVC-LOOP-EXIT + END-IF MOVE FOUND-KEY(X) TO CHARCUR-KEY READ CHARCUR @@ -888,7 +911,8 @@ END-IF END-IF - IF CLP-2CLMSTAT = "1 " AND PAYORID = "43700" + IF CLP-2CLMSTAT = "1 " AND + (PAYORID = "43700" OR PAYORID = "58379") IF SVC-CNTR = 1 MOVE CLP-4TOTCLMPAY TO ALF8 ELSE @@ -1000,10 +1024,18 @@ COMPUTE CLAIM-TOT = CC-AMOUNT + PD-AMOUNT PERFORM S4 THRU S5 PERFORM CHECK-CLAIM-TOT THRU CHECK-CLAIM-TOT-EXIT + IF PAID-FLAG = 1 OR OVERPAY-FLAG = 1 + PERFORM P1-LOST-SVC + GO TO P5-SVC-LOOP-EXIT + END-IF MOVE PAYFILE01 TO PAYBACK PERFORM S4-PAYFILE THRU S4-PAYFILE-EXIT MOVE PAYBACK TO PAYFILE01 PERFORM CHECK-CLAIM-TOT THRU CHECK-CLAIM-TOT-EXIT + IF PAID-FLAG = 1 OR OVERPAY-FLAG = 1 + PERFORM P1-LOST-SVC + GO TO P5-SVC-LOOP-EXIT + END-IF ACCEPT ORDER-8 FROM TIME MOVE ORDER-6 TO PD-ORDER @@ -1341,11 +1373,14 @@ MOVE CORR TEST-DATE TO INPUT-DATE MOVE INPUT-DATE TO EF3 MOVE BPR-16 TO EF-PAYDATE + * NOTE THAT THE CLAIM IS ALREADY PAID OR OVER PAID + * err-178 NEEDS DATES IN THE EF-PAYDATE FIELD IF OVERPAY-FLAG = 1 - MOVE "OVERPAY " TO EF-PAYDATE - END-IF - IF PAID-FLAG = 1 - MOVE "PAID " TO EF-PAYDATE + MOVE "OVERPAY " TO EF-AUTH + ELSE IF PAID-FLAG = 1 + MOVE "PAID " TO EF-AUTH + ELSE + MOVE SAVE-AUTH TO EF-AUTH END-IF MOVE CLP-1 TO EF4 MOVE SPACE TO ALF8 @@ -1994,6 +2029,7 @@ * GO TO P1-CLP. NO-SURPRISE. + MOVE 0 TO NSA-FLAG PERFORM VARYING Y FROM 1 BY 1 UNTIL Y > LQ-CNTR IF LQ-SVC(Y) = X MOVE SPACE TO FILEIN01 @@ -2008,21 +2044,19 @@ invalid continue end-read + MOVE 1 TO NSA-FLAG PERFORM P1-LOST-SVC end-if end-if END-PERFORM. CHECK-CLAIM-TOT. - IF CLAIM-TOT = 0 + COMPUTE PRIOR-TOT = CLAIM-TOT - PD-AMOUNT + IF PRIOR-TOT <= 0 MOVE 1 TO PAID-FLAG - PERFORM P1-LOST-SVC - GO TO P5-SVC-LOOP-EXIT END-IF IF CLAIM-TOT < 0 MOVE 1 TO OVERPAY-FLAG - PERFORM P1-LOST-SVC - GO TO P5-SVC-LOOP-EXIT END-IF. CHECK-CLAIM-TOT-EXIT. diff --git a/rri/reports/adj197.cob b/rri/reports/adj197.cob new file mode 100644 index 00000000..f5637849 --- /dev/null +++ b/rri/reports/adj197.cob @@ -0,0 +1,214 @@ + * @package cms + * @link http://www.cmsvt.com + * @author s waite + * @copyright Copyright (c) 2026 cms + * @license https://github.com/openemr/openemr/blob/master/LICENSE GNU General Public License 3 + IDENTIFICATION DIVISION. + PROGRAM-ID. adj197. + * + * Reads CHARCUR charges with CC-PAYCODE = "197" (pending ins). + * For each, walks PAYCUR for the same account+claim and splits + * the (signed-negative) activity into two buckets: + * CASHPAID - everything except PC-DENIAL = "14" + * ADJ14 - the PC-DENIAL = "14" insurance adjustments + * Looks up the Medicare allowed amount from MEDFILE2020 keyed by + * CC-PROC1. DUE is the allowed plus the cash paid (CASHPAID is + * signed-negative). The "14" contractual adjustments are shown + * separately in INS-ADJ and are NOT netted into DUE: + * DUE-AMT = MED-AMT + CASHPAID + * where CASHPAID = TOTALPAY - ADJ14. + * Positive = still collectable up to allowed; negative = paid + * past the allowed (nothing to collect / possible refund). + * Report only. Posts nothing. + * + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT GARFILE ASSIGN TO "S30" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS G-GARNO + ALTERNATE RECORD KEY IS G-ACCT WITH DUPLICATES + LOCK MODE MANUAL. + SELECT CHARCUR ASSIGN TO "S35" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS CHARCUR-KEY + ALTERNATE RECORD KEY IS CC-PAYCODE WITH DUPLICATES + LOCK MODE MANUAL. + SELECT PAYCUR ASSIGN TO "S40" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS PAYCUR-KEY + LOCK MODE MANUAL. + SELECT MEDFILE2020 ASSIGN TO "S45" ORGANIZATION IS INDEXED + ACCESS MODE IS DYNAMIC RECORD KEY IS MED-KEY + LOCK MODE MANUAL. + SELECT REPORTF ASSIGN TO "S50" + ORGANIZATION IS LINE SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD GARFILE. + COPY GARFILE.CPY. + FD CHARCUR. + COPY CHARCUR.CPY. + FD PAYCUR. + COPY PAYCUR.CPY. + FD MEDFILE2020. + 01 MEDFILE202001. + 02 MED-KEY. + 03 MED-KEY1 PIC X(5). + 03 MED-KEY2 PIC XX. + 02 MED-AMT PIC 9(4)V99. + FD REPORTF. + 01 REPORT-REC PIC X(132). + WORKING-STORAGE SECTION. + 01 WS-WORK. + 05 TOTALPAY PIC S9(7)V99 VALUE 0. + 05 CASHPAID PIC S9(7)V99 VALUE 0. + 05 ADJ14 PIC S9(7)V99 VALUE 0. + 05 BALANCE PIC S9(7)V99 VALUE 0. + 05 DUE-AMT PIC S9(7)V99 VALUE 0. + 05 TOT-ADJ14 PIC S9(9)V99 VALUE 0. + 05 TOT-DUE PIC S9(9)V99 VALUE 0. + 05 WS-NAME PIC X(25) VALUE SPACES. + 01 WS-COUNTS. + 05 CNT-197 PIC 9(7) VALUE 0. + 05 CNT-RPT PIC 9(7) VALUE 0. + 05 CNT-NOBAL PIC 9(7) VALUE 0. + 05 CNT-NOFEE PIC 9(7) VALUE 0. + 01 HDR-1. + 05 FILLER PIC X(45) VALUE + "PENDING INS 197 - ADJUSTMENT TO MED ALLOWED". + 01 HDR-2. + 05 FILLER PIC X(2) VALUE SPACES. + 05 FILLER PIC X(10) VALUE "ACCOUNT". + 05 FILLER PIC X(8) VALUE "CLAIM". + 05 FILLER PIC X(9) VALUE "PROC". + 05 FILLER PIC X(11) VALUE " CHARGE". + 05 FILLER PIC X(12) VALUE " PAID". + 05 FILLER PIC X(12) VALUE " INS-ADJ". + 05 FILLER PIC X(12) VALUE " BALANCE". + 05 FILLER PIC X(11) VALUE " ALLOWED". + 05 FILLER PIC X(12) VALUE " DUE". + 05 FILLER PIC X(6) VALUE "NAME". + 01 DET-LINE. + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-ACCT PIC X(8). + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-CLAIM PIC X(6). + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-PROC PIC X(7). + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-CHARGE PIC ZZ,ZZ9.99. + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-PAID PIC -ZZ,ZZ9.99. + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-ADJ14 PIC -ZZ,ZZ9.99. + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-BAL PIC -ZZ,ZZ9.99. + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-ALLOW PIC ZZ,ZZ9.99. + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-DUE PIC -ZZ,ZZ9.99. + 05 FILLER PIC X(2) VALUE SPACES. + 05 DL-NAME PIC X(25). + 01 TOT-LINE. + 05 FILLER PIC X(20) VALUE "TOTAL INS-ADJ/DUE: ". + 05 TL-ADJ14 PIC -Z,ZZZ,ZZ9.99. + 05 FILLER PIC X(3) VALUE SPACES. + 05 TL-DUE PIC -Z,ZZZ,ZZ9.99. + PROCEDURE DIVISION. + MAIN. + OPEN INPUT GARFILE CHARCUR PAYCUR MEDFILE2020. + OPEN OUTPUT REPORTF. + WRITE REPORT-REC FROM HDR-1. + MOVE SPACES TO REPORT-REC. + WRITE REPORT-REC. + WRITE REPORT-REC FROM HDR-2. + MOVE "197" TO CC-PAYCODE. + START CHARCUR KEY NOT < CC-PAYCODE + INVALID KEY + DISPLAY "NO 197 CHARGES FOUND" + GO TO DONE + END-START. + NEXT-CHG. + READ CHARCUR NEXT AT END GO TO DONE END-READ. + IF CC-PAYCODE NOT = "197" GO TO DONE. + ADD 1 TO CNT-197. + * + * sum payments for this account + claim + * + MOVE 0 TO TOTALPAY. + MOVE 0 TO ADJ14. + MOVE CC-KEY8 TO PC-KEY8. + MOVE LOW-VALUES TO PC-KEY3. + START PAYCUR KEY NOT < PAYCUR-KEY + INVALID KEY GO TO EVAL + END-START. + PAY-LOOP. + READ PAYCUR NEXT AT END GO TO EVAL END-READ. + IF PC-KEY8 NOT = CC-KEY8 GO TO EVAL. + IF PC-CLAIM NOT = CC-CLAIM GO TO PAY-LOOP. + ADD PC-AMOUNT TO TOTALPAY. + IF PC-DENIAL = "14" + ADD PC-AMOUNT TO ADJ14. + GO TO PAY-LOOP. + EVAL. + COMPUTE BALANCE = CC-AMOUNT + TOTALPAY. + COMPUTE CASHPAID = TOTALPAY - ADJ14. + IF BALANCE NOT > 0 + ADD 1 TO CNT-NOBAL + GO TO NEXT-CHG. + * + * look up Medicare allowed by CC-PROC1 (cpt + modifier) + * + MOVE CC-PROC1 TO MED-KEY. + READ MEDFILE2020 + INVALID KEY + ADD 1 TO CNT-NOFEE + PERFORM WRITE-NOFEE + GO TO NEXT-CHG + END-READ. + COMPUTE DUE-AMT = MED-AMT + CASHPAID. + ADD 1 TO CNT-RPT. + ADD ADJ14 TO TOT-ADJ14. + ADD DUE-AMT TO TOT-DUE. + PERFORM WRITE-DETAIL. + GO TO NEXT-CHG. + WRITE-DETAIL. + MOVE SPACES TO WS-NAME. + MOVE CC-KEY8 TO G-GARNO. + READ GARFILE + INVALID KEY MOVE SPACES TO WS-NAME + NOT INVALID KEY MOVE G-GARNAME TO WS-NAME + END-READ. + MOVE CC-KEY8 TO DL-ACCT. + MOVE CC-CLAIM TO DL-CLAIM. + MOVE CC-PROC1 TO DL-PROC. + MOVE CC-AMOUNT TO DL-CHARGE. + MOVE CASHPAID TO DL-PAID. + MOVE ADJ14 TO DL-ADJ14. + MOVE BALANCE TO DL-BAL. + MOVE MED-AMT TO DL-ALLOW. + MOVE DUE-AMT TO DL-DUE. + MOVE WS-NAME TO DL-NAME. + WRITE REPORT-REC FROM DET-LINE. + WRITE-NOFEE. + MOVE CC-KEY8 TO DL-ACCT. + MOVE CC-CLAIM TO DL-CLAIM. + MOVE CC-PROC1 TO DL-PROC. + MOVE CC-AMOUNT TO DL-CHARGE. + MOVE CASHPAID TO DL-PAID. + MOVE ADJ14 TO DL-ADJ14. + MOVE BALANCE TO DL-BAL. + MOVE 0 TO DL-ALLOW. + MOVE 0 TO DL-DUE. + MOVE "*** NO FEE SCHEDULE ENTRY" TO DL-NAME. + WRITE REPORT-REC FROM DET-LINE. + DONE. + MOVE SPACES TO REPORT-REC. + WRITE REPORT-REC. + MOVE TOT-ADJ14 TO TL-ADJ14. + MOVE TOT-DUE TO TL-DUE. + WRITE REPORT-REC FROM TOT-LINE. + DISPLAY "197 CHARGES READ: " CNT-197. + DISPLAY "REPORTED (ADJ): " CNT-RPT. + DISPLAY "NO BALANCE DUE: " CNT-NOBAL. + DISPLAY "NO FEE SCHED ENTRY: " CNT-NOFEE. + CLOSE GARFILE CHARCUR PAYCUR MEDFILE2020 REPORTF. + STOP RUN. diff --git a/sidw/hip5140.cob b/sidw/hip5140.cob index d1e0b337..f8241f34 100644 --- a/sidw/hip5140.cob +++ b/sidw/hip5140.cob @@ -97,37 +97,27 @@ MOVE PARMFILE01 TO PROV-FED. READ PARMFILE AT END GO TO P99. MOVE PARMFILE01 TO PROV-LEG. - - P000. - perform p-read - - IF FI-1 NOT = "ISA" GO TO P000. - MOVE SPACE TO ISA01 - UNSTRING FILEIN01 DELIMITED BY "*" INTO - ISA-0 ISA-1 ISA-2 ISA-3 ISA-4 ISA-5 ISA-6 ISA-7 - ISA-8 ISA-9 ISA-10 ISA-11 ISA-12 ISA-13 - - MOVE FILEIN01 TO SAVE-TAB(1). - - P00. - perform p-read - - IF FI-1 NOT = "GS*" GO TO P00. - MOVE SPACE TO GS01 - UNSTRING FILEIN01 DELIMITED BY "*" INTO - GS-0 GS-1 GS-2 GS-3 GS-4 GS-5 GS-6 - - MOVE FILEIN01 TO SAVE-TAB(2). - - P0. - perform p-read - - IF FI-1 NOT = "ST*" GO TO P0. - - MOVE FILEIN01 TO SAVE-TAB(3). - MOVE 3 TO X. - + PERFORM P-READ. + IF FI-1 = "ISA" + MOVE SPACE TO ISA01 + UNSTRING FILEIN01 DELIMITED BY "*" INTO + ISA-0 ISA-1 ISA-2 ISA-3 ISA-4 ISA-5 ISA-6 ISA-7 + ISA-8 ISA-9 ISA-10 ISA-11 ISA-12 ISA-13 + MOVE FILEIN01 TO SAVE-TAB(1) + GO TO P0 + END-IF. + IF FI-1 = "GS*" + MOVE SPACE TO GS01 + UNSTRING FILEIN01 DELIMITED BY "*" INTO + GS-0 GS-1 GS-2 GS-3 GS-4 GS-5 GS-6 + MOVE FILEIN01 TO SAVE-TAB(2) + GO TO P0 + END-IF. + IF FI-1 NOT = "ST*" GO TO P0. + MOVE FILEIN01 TO SAVE-TAB(3). + MOVE 3 TO X. + P1-2. perform p-read.