=============================================================================
Run Date: MAY 04, 2017                     Designation: PRCA*4.5*313
Package : PRCA - ACCOUNTS RECEIVABLE          Priority: Mandatory
Version : 4.5                                   Status: Under Development
=============================================================================

Associated patches: (v)XMDB*1*0        install with patch       `PRCA*4.5*313'
                    (u)PRCA*4.5*307<<= must be installed BEFORE `PRCA*4.5*313'

Subject: PATIENT STATEMENT ENHANCEMENT - Phase Two

Category: 
  - Other
  - Routine
  - Data Dictionary
  - Enhancement (Mandatory)

Description:
============

  *************************************************************************
     This patch supports changes to the Veterans Health Information
     System and Technology Architecture (VistA) for the Patient Statement
     Enhancements Project (PSE).
   
     It is imperative that these patches be installed no later than the
     compliance date. Your understanding and support is appreciated.
  *************************************************************************
   
 The Chief Business Office (CBO) requested modifications to the VistA
 Accounts Receivable (AR) package to remedy deficiencies identified with
 patient statements. The main goals of this project include the 
 remediation and enhancement of the AR application software to correct
 these discrepancies. Additionally this project will perform the initial
 development of the VistA AR enhancements to create a single, consolidated
 patient statement, self-service options for payment, and other 
 modifications.
  
 This patch modifies the Account Receivable (AR) v4.5 application as
 described below:
  
 1. Change the schedule of printing Patient Statements to send patients
 with the first letters of the last name on the same day every month. The
 day of the month for each letter combination is contained in the
 Post-Installation section.
  
 2. Update the Patient Statement Build and Transmit code to create and send
 the appropriate statements with an updated format. The Build and Transmit
 will occur two days prior to the listed date to allow for processing by
 the Consolidated Co-payment Processing Center (CCPC) and the Consolidated
 Billing Statement System (CBSS) for printing on the assigned date.
  
 3. Receive and process the Print Acknowledgements from CCPC using current
 procedures.
  
 4. Create and transmit a Nightly Patient Update to provide CBSS with the
 oldest bill balance and amount for each Veteran on a nightly basis.
  
 5. Provide CBSS Nightly Account Update Program, as a menu option to run
 the Nightly Patient Update from the PRCA ACCOUNTS MANAGEMENT Menu.
  
 6. Update the following menu options to work with the multiple statement
 date:
  
   a. CCPC Statement Errors              [RCCPC ERROR]
   b. CCPC Totals                        [RCCPC TOTALS REPORT]
   c. Reprint Patient Statements         [PRCAE PR STATEMENT]
   d. Build CCPC file for transmission   [RCCPC BUILD]
   e. Transmit CCPC messages             [RCCPC TRANSMIT]
  
 7. The Auto-Correct Patient Discrepancy Report has been updated to 
 include a new Auto-Correct Reason sort order. The report now defaults to 
 the Auto-Correct Reason sort order and the four existing sort orders have 
 been rearranged and ordered below this new sort order.  
  
 Additionally, the report sort description that appears on the page 
 headers has been updated to be more descriptive.
  
 8. Build and Transmit a yearly Annual Patient Payment Summary (APPS) 
 Statement file for every Patient payment made in the previous year. 
 Payment in Full (34) and Payment in Part (2) will be the only Accounts 
 Receivable Transaction Types sent in the file. The Build will begin 
 automatically on January 2nd of each year for the previous year.  
 Transmission will be based upon the VistA Site Code and will occur at 
 02:00 hours from January 3rd to January 12th. Transmission will be to a
 new queue at CCPC.
  
 9. Three new options have been added to the Follow-up Letter Menu 
 [PRCAE FOLLOW-UP].
  
  Build and Transmit Annual Payment File [RCCPC APPS BUILD AND TRANS] will
  allow manual creation and transmission of the APPS Statement file.
  
  Retransmit Current Annual Payment File [RCCPC APPS RETRANS] will allow
  manual re-transmission of the APPS Statement File.
  
  Annual Payment File Consistency Check (RCCPC APPS DATA CHECK) will allow 
  Validation of the APPS Statement File data for the current calendar year 
  to the present date.  
  
 10. For the Increase Adjustment [PRCAC TR INCREASE] and Decrease 
 Adjustment [PRCAC TR DECREASE] options, the default answer for the "Do 
 you want to FIX the balance discrepancy ? YES//" prompt has been changed 
 from YES to NO.
  
 Example:
 Do you want to FIX the balance discrepancy ? NO//
  
 Patch Components
 ================
  
 Files & Fields Associated:
 File Name (#)                     Field Name (#)                 New/Mod/Del
 ------------------------------    -----------------------------  -----------
 AR DEBTOR (#340)                  DEBTOR (#.01)                      Mod
                                   STATEMENT DAY (#.03)               Mod
                                   CURRENT CBS DEBT AMOUNT (#7.06)    New
  
 AR EVENT (#341)                   CCPC STATEMENT DATE (#6.01)        Mod
  
 AR TRANSMISSION RECORDS (#349)    STATEMENT DATE (#.09)              Mod
  
 AR TRANSMISSION TYPE (#349.1)     LAST MESSAGE ACK (#41)             Del
                                   FINAL MESSAGE ACK (#42)            Del
                                   LAST MESSAGE NUMBER (#43)          Del
                                   MESSAGE ACKNOWLEDGEMENT (#40)      New
                                   LAST MESSAGE ACK (#349.141,.01)    New
                                   FINAL MESSAGE ACK (#349.141,.02)   New
                                   LAST MESSAGE NUMBER (#349.141,.03) New
                                   PATIENT STATEMENT DATE             New
                                   (#349.141,.04)
                                   ACK MESSAGES (#50)                 Mod
                                   PATIENT STATEMENT DATE             New
                                   (#349.151,.04)
  
 AR CBSS STATEMENTS (#349.2)       PATIENT (#.01)                     Mod
                                   SSN (#.02)                         Mod
                                   PATIENT NAME (#.03)                Mod
                                   INVALID STATEMENT ERROR (#.12)     Mod
                                   CBSS FILE BUILD (#.18)             Mod
                                   PATIENT STATEMENT DATE (#.19)      New
                                   ERROR CODE(S) (#51)                Mod
                                   CBSS PRINTED (#61)                 Mod
                                   INTEGRATION CONTROL NUMBER (#81)   New
                                   ICN CHECKSUM (#82)                 New
                                   AR FLAG (#83)                      New
                                   DATE OF LATEST BILL (#84)          New
  
 AR ANNUAL PAYMENT STATEMENT FILE  PS SEGMENT NUMBER (#.01)           New
 (#349.5)                          YEAR (#.02)                        New
                                   DATE/TIME BUILD STARTED (#.03)     New
                                   DATE/TIME BUILD ENDED (#.04)       New
                                   DATE/TIME TRANSMIT STARTED (#.05)  New
                                   DATE/TIME TRANSMIT ENDED (#.06)    New
                                   STATEMENT FILE LINES (#1)          New
                                   STATEMENT FILE LINES (#349.51,.01) New
  
 Forms Associated:
  
 Form Name       File #  New/Modified/Deleted
 ---------       ------  --------------------
 N/A
  
 Mail Groups Associated:
  
 Mail Group Name New/Modified/Deleted
 --------------- --------------------
 N/A
  
 Options Associated:
  
 Option Name                    Type        New/Modified/Deleted
 -----------                 -----------    --------------------
 PRCA CBS NIGHTLY UPDATE     Run Routine           New
 RCCPC APPS BUILD AND TRANS  Action                New
 RCCPC APPS RETRANS          Action                New                  
 RCCPC APPS DATA CHECK       Action                New 
  
 Protocols Associated:
  
 Protocol Name   New/Modified/Deleted
 -------------   -------------------- 
 N/A
  
 Security Keys Associated:
  
 Security Key Name                     New/Modified/Deleted
 -----------------                     --------------------
 RCCPC APPS BUILD AND TRANS                   New
  
 Templates Associated:
  
 Template Name   Type    File Name (Number)  New/Modified/Deleted 
 -------------   ----    ------------------  --------------------
 N/A
  
 Additional Information:
 N/A
  
 New Service Requests (NSRs):
 ----------------------------  
 N/A
  
 Patient Safety Issues (PSIs):
 -----------------------------
 N/A
  
 Defect Tracking System Ticket(s) & Overview:
 --------------------------------------------
 N/A
  
 Problem:
 -------
 N/A
  
 Resolution:
 ----------
 N/A
  
 Test Sites:
 ----------
 Bay Pines VA HCS
 James A. Haley VAMC 
  
 Software and Documentation Retrieval Instructions:
 ---------------------------------------------------- 
 Software being released as a host file and/or documentation describing 
 the new functionality introduced by this patch are available.
  
 The preferred method is to retrieve files from download.DNS      .DNS   .
 This transmits the files from the first available server. Sites may 
 also elect to retrieve files directly from a specific server. 
  
 Sites may retrieve the software and/or documentation directly using 
 Secure File Transfer Protocol (SFTP) from the ANONYMOUS.SOFTWARE 
 directory at the following OI Field Offices:
  
 Albany: DNS.URL       
 Hines:  DNS     .URL         
 Salt Lake City: DNS.URL       
  
 Documentation can also be found on the VA Software Documentation Library 
 at: http://URL            /
  
 Title   File Name       FTP Mode
 -----------------------------------------------------------------------
 <Documentation title>
  
 Patch Installation:
  
 Pre/Post Installation Overview:
 -------------------------------
 The Pre-Installation removes elements from the AR Transaction and AR 
 Transaction Type files. The Post-Installation removes current monthly 
 Patient Statement Data, resets each Debtor's Patient Statement date to 
 the date matching the last name of the patient, and insures the Patient 
 Statement and Nightly Update queues are set to the proper domains.
  
 Pre-Installation Instructions:
 ------------------------------
 The Pre-Installation removes elements from the AR Transmission Records 
 and AR Transmission Type files.
  
 The AR TRANSMISSION RECORDS file (#349) will have the STATEMENT DATE field
 (#.09) removed prior to entering a New Style Cross-Reference.
  
 The AR TRANSMISSION TYPE file (#349.1) will have the LAST MESSAGE ACK 
 field (#41), FINAL MESSAGE ACK field (#42), and the LAST MESSAGE NUMBER 
 field (#43) removed. These elements will be replaced with a multiple
 record MESSAGE ACKNOWLEDGEMENT field (#349.141) during the data dictionary
 load.
  
 This patch may be installed with users on the system although it is 
 recommended that it be installed during non-peak hours to minimize
 potential disruption to users. This patch should take less than 30 
 minutes to install.
  
 No Menu Options need to be disabled during this installation.
  
 Installation Instructions:
 --------------------------
 This patch modifies the Account Receivable (AR) v4.5 application for a 
 single, consolidated patient statement.
   
    1. Choose the PackMan message containing this patch.  
   
    2. Choose the INSTALL/CHECK MESSAGE PackMan option.  
   
    3. From the Kernel Installation and Distribution System Menu, select
       the Installation Menu. From this menu, you may elect to use the
       following options. When prompted for the INSTALL NAME enter the
       patch PRCA*4.5*313.
   
       a. Backup a Transport Global - This option will create a backup
          message of any routines exported with this patch. It will not
          backup any other changes such as DDs or templates.
  
       b. Compare Transport Global to Current System - This option will
          allow you to view all changes that will be made when this
          patch is installed. It compares all components of this patch
          routines, DDs, templates, etc.
  
       c. Verify Checksums in Transport Global - This option will allow
          you to ensure the integrity of the routines that are in the
          transport global.
   
    4. From the Installation Menu, select the Install Package(s)
       option and choose the patch to install.
  
    5. When prompted 'Want KIDS to Rebuild Menu Trees Upon Completion
       of Install? YES//' reply 'YES' unless your system rebuilds menu 
       trees nightly using TaskMan. Answering Yes during normal business
       hours could affect users on the system and installation times will
       increase.
   
    7. When Prompted "Want KIDS to INHIBIT LOGONs during the install? 
        NO//", respond NO.  
   
    8. When Prompted "Want to DISABLE Scheduled Options, Menu Options, and 
        Protocols? NO//", respond NO.
   
    9. When prompted "Delay Install (Minutes):  (0-60): 0//"  enter an
       appropriate number of minutes to delay the installation in 
       order to give users enough time to exit the disabled options
       before the installation starts.
  
   10. When prompted "Device: Home//"  respond with the correct device.
  
 Post-Installation Instructions:
 -------------------------------
 The Post-Installation removes current monthly Patient Statement Data, 
 resets each Debtor's Patient Statement date to the date matching the last 
 name of the Patient, and insures the Patient Statement and Nightly Update 
 transmission queues are set to the proper domains.
  
 The previous month's Patient Statement data is removed at each site prior 
 to the creation of the current month's data. To implement 16 days during 
 the month for alphabetically based Patient Statements, all data must be 
 removed. This is performed during the Post-Install. Should a site feel 
 it requires these older Patient Statements, a Reprint Patient Statements 
 [PRCAE PR STATEMENT] may be performed. It is STRONGLY RECOMMENDED, due to
 the size of this file, each site run a single reprint to a single MailMan
 account and share that data until the patient's new statement prints
 within the next 31 days.
  
 The Post-Installation will reset each AR Debtor's account that processes 
 Patient Statements with the Patient Statement Date corresponding to the 
 table provided. The letters use the Patient's Last Name. The SITE 
 STATEMENT DATE field (#.11) in the AR SITE PARAMENTER file (#342) is set
 to Null to prevent a possible transmission using the previous format.
  
 Day of the Month        Letters of last name
 ----------------        --------------------
  1                      A,BA,BU
  2                      B EXCLUDE (BA,BU)
  4                      CI,CR,CU,D
  6                      C EXCLUDE (CI,CR,CU)
  7                      E,F,I,Q
  8                      G,HE
 10                      H EXCLUDE HE
 12                      J,K
 14                      L,O
 15                      M EXCLUDE (MC,MI)
 17                      MC,MI,N,TI-TZ
 19                      R,TA-TE
 21                      S EXCLUDE (SC,SH,SI,SM)
 22                      SC,SH,SI,SM,TF-TH,V
 24                      P,U,X,Y,Z
 26                      W
  
 VistA MailMan is used to send the Patient Statement and Nightly Update
 files. The addresses for these transmissions are taken from the AR 
 TRANSMISSION TYPE file (#349.1). The Post-Installation validates and
 updates the CCPC Domain and Addressee for both transmission types. As the
 Nightly Update and Annual Patient Payment Summery transmissions are sent
 to a new Domain, Patch XMDB*1.0*0 a required Patch must have been
 previously loaded.

Routine Information:
====================
The second line of each of these routines now looks like:
 ;;4.5;Accounts Receivable;**[Patch List]**;Mar 20, 1995;Build 118

The checksums below are new checksums, and
 can be checked with CHECK1^XTSUMBLD.

Routine Name: PRCA313P
    Before:       n/a   After: B20491359  **313**
Routine Name: PRCAACR
    Before:       n/a   After:B124955572  **307,313**
Routine Name: PRCAACR1
    Before:       n/a   After:B151271441  **307,313**
Routine Name: PRCACPS1
    Before:       n/a   After: B19128158  **313**
Routine Name: PRCAG
    Before: B22016512   After: B48028538  **149,165,198,313**
Routine Name: RCBEADJ
    Before: B77125147   After: B77106309  **169,172,204,173,208,233,298,
                                           301,313**
Routine Name: RCCPCAP
    Before:       n/a   After: B41793332  **313**
Routine Name: RCCPCAR
    Before:       n/a   After: B47488689  **313**
Routine Name: RCCPCAT
    Before:       n/a   After: B34521600  **313**
Routine Name: RCCPCBJ
    Before:  B6288491   After:  B9440906  **34,76,130,153,166,195,217,
                                           237,307,313**
Routine Name: RCCPCFN1
    Before:       n/a   After:  B7181774  **313**
Routine Name: RCCPCML
    Before: B47881024   After: B67061934  **34,80,93,118,133,140,160,165,
                                           187,195,206,223,260,313**
Routine Name: RCCPCML1
    Before:  B6682335   After:  B8980051  **160,313**
Routine Name: RCCPCPS
    Before: B80898915   After:B129514785  **34,70,80,48,104,116,149,170,
                                           181,190,223,237,219,265,301,
                                           313**
Routine Name: RCCPCPS1
    Before: B37370113   After: B65443378  **34,48,104,170,176,192,265,313**
Routine Name: RCCPCSE
    Before:  B5810439   After: B16507603  **34,313**
Routine Name: RCCPCSV
    Before:  B5199490   After: B11825361  **34,70,87,313**
Routine Name: RCCPCSV1
    Before: B32017096   After: B43313841  **34,70,76,130,153,313**
Routine Name: RCCPCT
    Before:  B2489697   After: B29330001  **34,313**
 
Routine list of preceding patches: 87, 198, 260, 301, 307

=============================================================================
User Information:
Entered By  : ENFINGER,MARK                 Date Entered  : MAY 04, 2016
Completed By:                               Date Completed: 
Released By :                               Date Released : 
=============================================================================

Packman Mail Message:
=====================

$END TXT
$KID PRCA*4.5*313
**INSTALL NAME**
PRCA*4.5*313
"BLD",10111,0)
PRCA*4.5*313^ACCOUNTS RECEIVABLE^0^3170504^y
"BLD",10111,1,0)
^^1^1^3160811^^^^
"BLD",10111,1,1,0)
Consolidated Patient Statement
"BLD",10111,4,0)
^9.64PA^349.5^6
"BLD",10111,4,340,0)
340
"BLD",10111,4,340,2,0)
^9.641^340^1
"BLD",10111,4,340,2,340,0)
AR DEBTOR  (File-top level)
"BLD",10111,4,340,2,340,1,0)
^9.6411^.03^3
"BLD",10111,4,340,2,340,1,.01,0)
DEBTOR
"BLD",10111,4,340,2,340,1,.03,0)
STATEMENT DAY
"BLD",10111,4,340,2,340,1,7.06,0)
CURRENT CBS DEBT AMOUNT
"BLD",10111,4,340,222)
y^n^p^^^^n^^n
"BLD",10111,4,340,224)

"BLD",10111,4,341,0)
341
"BLD",10111,4,341,2,0)
^9.641^341^1
"BLD",10111,4,341,2,341,0)
AR EVENT  (File-top level)
"BLD",10111,4,341,2,341,1,0)
^9.6411^6.01^1
"BLD",10111,4,341,2,341,1,6.01,0)
CCPC STATEMENT DATE
"BLD",10111,4,341,222)
y^n^p^^^^n^^n
"BLD",10111,4,341,224)

"BLD",10111,4,349,0)
349
"BLD",10111,4,349,2,0)
^9.641^349^1
"BLD",10111,4,349,2,349,0)
AR TRANSMISSION RECORDS  (File-top level)
"BLD",10111,4,349,2,349,1,0)
^9.6411^.09^1
"BLD",10111,4,349,2,349,1,.09,0)
STATEMENT DATE
"BLD",10111,4,349,222)
y^n^p^^^^n^^n
"BLD",10111,4,349,224)

"BLD",10111,4,349.1,0)
349.1
"BLD",10111,4,349.1,222)
y^n^f^^^^n^^n
"BLD",10111,4,349.1,224)

"BLD",10111,4,349.2,0)
349.2
"BLD",10111,4,349.2,2,0)
^9.641^349.2^1
"BLD",10111,4,349.2,2,349.2,0)
AR CBSS STATEMENTS  (File-top level)
"BLD",10111,4,349.2,2,349.2,1,0)
^9.6411^61^12
"BLD",10111,4,349.2,2,349.2,1,.01,0)
PATIENT
"BLD",10111,4,349.2,2,349.2,1,.02,0)
SSN
"BLD",10111,4,349.2,2,349.2,1,.03,0)
PATIENT NAME
"BLD",10111,4,349.2,2,349.2,1,.12,0)
INVALID STATEMENT ERROR
"BLD",10111,4,349.2,2,349.2,1,.18,0)
CBSS FILE BUILT
"BLD",10111,4,349.2,2,349.2,1,.19,0)
PATIENT STATEMENT DATE
"BLD",10111,4,349.2,2,349.2,1,51,0)
ERROR CODE(S)
"BLD",10111,4,349.2,2,349.2,1,61,0)
CBSS PRINTED
"BLD",10111,4,349.2,2,349.2,1,81,0)
INTEGRATION CONTROL NUMBER
"BLD",10111,4,349.2,2,349.2,1,82,0)
ICN CHECKSUM
"BLD",10111,4,349.2,2,349.2,1,83,0)
AR FLAG
"BLD",10111,4,349.2,2,349.2,1,84,0)
DATE OF LATEST BILL
"BLD",10111,4,349.2,222)
y^n^p^^^^n^^n
"BLD",10111,4,349.2,224)

"BLD",10111,4,349.5,0)
349.5
"BLD",10111,4,349.5,222)
y^n^f^^^^n^^n
"BLD",10111,4,349.5,224)

"BLD",10111,4,"APDD",340,340)

"BLD",10111,4,"APDD",340,340,.01)

"BLD",10111,4,"APDD",340,340,.03)

"BLD",10111,4,"APDD",340,340,7.06)

"BLD",10111,4,"APDD",341,341)

"BLD",10111,4,"APDD",341,341,6.01)

"BLD",10111,4,"APDD",349,349)

"BLD",10111,4,"APDD",349,349,.09)

"BLD",10111,4,"APDD",349.2,349.2)

"BLD",10111,4,"APDD",349.2,349.2,.01)

"BLD",10111,4,"APDD",349.2,349.2,.02)

"BLD",10111,4,"APDD",349.2,349.2,.03)

"BLD",10111,4,"APDD",349.2,349.2,.12)

"BLD",10111,4,"APDD",349.2,349.2,.18)

"BLD",10111,4,"APDD",349.2,349.2,.19)

"BLD",10111,4,"APDD",349.2,349.2,51)

"BLD",10111,4,"APDD",349.2,349.2,61)

"BLD",10111,4,"APDD",349.2,349.2,81)

"BLD",10111,4,"APDD",349.2,349.2,82)

"BLD",10111,4,"APDD",349.2,349.2,83)

"BLD",10111,4,"APDD",349.2,349.2,84)

"BLD",10111,4,"B",340,340)

"BLD",10111,4,"B",341,341)

"BLD",10111,4,"B",349,349)

"BLD",10111,4,"B",349.1,349.1)

"BLD",10111,4,"B",349.2,349.2)

"BLD",10111,4,"B",349.5,349.5)

"BLD",10111,6)
2^
"BLD",10111,6.3)
118
"BLD",10111,"ABPKG")
n
"BLD",10111,"INI")
PRE^PRCA313P
"BLD",10111,"INID")
^y^y
"BLD",10111,"INIT")
EN^PRCA313P
"BLD",10111,"KRN",0)
^9.67PA^779.2^20
"BLD",10111,"KRN",.4,0)
.4
"BLD",10111,"KRN",.4,"NM",0)
^9.68A^^0
"BLD",10111,"KRN",.401,0)
.401
"BLD",10111,"KRN",.402,0)
.402
"BLD",10111,"KRN",.402,"NM",0)
^9.68A^^0
"BLD",10111,"KRN",.403,0)
.403
"BLD",10111,"KRN",.5,0)
.5
"BLD",10111,"KRN",.84,0)
.84
"BLD",10111,"KRN",3.6,0)
3.6
"BLD",10111,"KRN",3.8,0)
3.8
"BLD",10111,"KRN",3.8,"NM",0)
^9.68A^^0
"BLD",10111,"KRN",9.2,0)
9.2
"BLD",10111,"KRN",9.8,0)
9.8
"BLD",10111,"KRN",9.8,"NM",0)
^9.68A^24^19
"BLD",10111,"KRN",9.8,"NM",5,0)
RCCPCBJ^^0^B9440906
"BLD",10111,"KRN",9.8,"NM",6,0)
PRCACPS1^^0^B19128158
"BLD",10111,"KRN",9.8,"NM",7,0)
RCCPCFN1^^0^B7181774
"BLD",10111,"KRN",9.8,"NM",8,0)
RCCPCML^^0^B67061934
"BLD",10111,"KRN",9.8,"NM",9,0)
RCCPCSV^^0^B11825361
"BLD",10111,"KRN",9.8,"NM",10,0)
RCCPCPS^^0^B129514785
"BLD",10111,"KRN",9.8,"NM",11,0)
RCCPCPS1^^0^B65443378
"BLD",10111,"KRN",9.8,"NM",12,0)
RCCPCSV1^^0^B43313841
"BLD",10111,"KRN",9.8,"NM",13,0)
RCCPCML1^^0^B8980051
"BLD",10111,"KRN",9.8,"NM",14,0)
RCCPCSE^^0^B16507603
"BLD",10111,"KRN",9.8,"NM",15,0)
RCCPCT^^0^B29330001
"BLD",10111,"KRN",9.8,"NM",17,0)
PRCAG^^0^B48028538
"BLD",10111,"KRN",9.8,"NM",18,0)
PRCA313P^^0^B20491359
"BLD",10111,"KRN",9.8,"NM",19,0)
PRCAACR^^0^B124955572
"BLD",10111,"KRN",9.8,"NM",20,0)
PRCAACR1^^0^B151271441
"BLD",10111,"KRN",9.8,"NM",21,0)
RCCPCAP^^0^B41793332
"BLD",10111,"KRN",9.8,"NM",22,0)
RCCPCAT^^0^B34521600
"BLD",10111,"KRN",9.8,"NM",23,0)
RCCPCAR^^0^B47488689
"BLD",10111,"KRN",9.8,"NM",24,0)
RCBEADJ^^0^B77106309
"BLD",10111,"KRN",9.8,"NM","B","PRCA313P",18)

"BLD",10111,"KRN",9.8,"NM","B","PRCAACR",19)

"BLD",10111,"KRN",9.8,"NM","B","PRCAACR1",20)

"BLD",10111,"KRN",9.8,"NM","B","PRCACPS1",6)

"BLD",10111,"KRN",9.8,"NM","B","PRCAG",17)

"BLD",10111,"KRN",9.8,"NM","B","RCBEADJ",24)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCAP",21)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCAR",23)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCAT",22)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCBJ",5)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCFN1",7)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCML",8)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCML1",13)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCPS",10)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCPS1",11)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCSE",14)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCSV",9)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCSV1",12)

"BLD",10111,"KRN",9.8,"NM","B","RCCPCT",15)

"BLD",10111,"KRN",19,0)
19
"BLD",10111,"KRN",19,"NM",0)
^9.68A^8^5
"BLD",10111,"KRN",19,"NM",4,0)
PRCA CBS NIGHTLY UPDATE^^0
"BLD",10111,"KRN",19,"NM",5,0)
PRCAE FOLLOW-UP^^2
"BLD",10111,"KRN",19,"NM",6,0)
RCCPC APPS BUILD AND TRANS^^0
"BLD",10111,"KRN",19,"NM",7,0)
RCCPC APPS RETRANS^^0
"BLD",10111,"KRN",19,"NM",8,0)
RCCPC APPS DATA CHECK^^0
"BLD",10111,"KRN",19,"NM","B","PRCA CBS NIGHTLY UPDATE",4)

"BLD",10111,"KRN",19,"NM","B","PRCAE FOLLOW-UP",5)

"BLD",10111,"KRN",19,"NM","B","RCCPC APPS BUILD AND TRANS",6)

"BLD",10111,"KRN",19,"NM","B","RCCPC APPS DATA CHECK",8)

"BLD",10111,"KRN",19,"NM","B","RCCPC APPS RETRANS",7)

"BLD",10111,"KRN",19.1,0)
19.1
"BLD",10111,"KRN",19.1,"NM",0)
^9.68A^1^1
"BLD",10111,"KRN",19.1,"NM",1,0)
RCCPC APPS BUILD AND TRANS^^0
"BLD",10111,"KRN",19.1,"NM","B","RCCPC APPS BUILD AND TRANS",1)

"BLD",10111,"KRN",101,0)
101
"BLD",10111,"KRN",409.61,0)
409.61
"BLD",10111,"KRN",771,0)
771
"BLD",10111,"KRN",779.2,0)
779.2
"BLD",10111,"KRN",870,0)
870
"BLD",10111,"KRN",8989.51,0)
8989.51
"BLD",10111,"KRN",8989.52,0)
8989.52
"BLD",10111,"KRN",8994,0)
8994
"BLD",10111,"KRN","B",.4,.4)

"BLD",10111,"KRN","B",.401,.401)

"BLD",10111,"KRN","B",.402,.402)

"BLD",10111,"KRN","B",.403,.403)

"BLD",10111,"KRN","B",.5,.5)

"BLD",10111,"KRN","B",.84,.84)

"BLD",10111,"KRN","B",3.6,3.6)

"BLD",10111,"KRN","B",3.8,3.8)

"BLD",10111,"KRN","B",9.2,9.2)

"BLD",10111,"KRN","B",9.8,9.8)

"BLD",10111,"KRN","B",19,19)

"BLD",10111,"KRN","B",19.1,19.1)

"BLD",10111,"KRN","B",101,101)

"BLD",10111,"KRN","B",409.61,409.61)

"BLD",10111,"KRN","B",771,771)

"BLD",10111,"KRN","B",779.2,779.2)

"BLD",10111,"KRN","B",870,870)

"BLD",10111,"KRN","B",8989.51,8989.51)

"BLD",10111,"KRN","B",8989.52,8989.52)

"BLD",10111,"KRN","B",8994,8994)

"BLD",10111,"QDEF")
^^^^^^^^YES
"BLD",10111,"QUES",0)
^9.62^^
"BLD",10111,"REQB",0)
^9.611^2^2
"BLD",10111,"REQB",1,0)
PRCA*4.5*307^2
"BLD",10111,"REQB",2,0)
XMDB*1.0*0^2
"BLD",10111,"REQB","B","PRCA*4.5*307",1)

"BLD",10111,"REQB","B","XMDB*1.0*0",2)

"FIA",340)
AR DEBTOR
"FIA",340,0)
^RCD(340,
"FIA",340,0,0)
340V
"FIA",340,0,1)
y^n^p^^^^n^^n
"FIA",340,0,10)

"FIA",340,0,11)

"FIA",340,0,"RLRO")

"FIA",340,0,"VR")
4.5^PRCA
"FIA",340,340)
1
"FIA",340,340,.01)

"FIA",340,340,.03)

"FIA",340,340,7.06)

"FIA",341)
AR EVENT
"FIA",341,0)
^RC(341,
"FIA",341,0,0)
341I
"FIA",341,0,1)
y^n^p^^^^n^^n
"FIA",341,0,10)

"FIA",341,0,11)

"FIA",341,0,"RLRO")

"FIA",341,0,"VR")
4.5^PRCA
"FIA",341,341)
1
"FIA",341,341,6.01)

"FIA",349)
AR TRANSMISSION RECORDS
"FIA",349,0)
^RCT(349,
"FIA",349,0,0)
349I
"FIA",349,0,1)
y^n^p^^^^n^^n
"FIA",349,0,10)

"FIA",349,0,11)

"FIA",349,0,"RLRO")

"FIA",349,0,"VR")
4.5^PRCA
"FIA",349,349)
1
"FIA",349,349,.09)

"FIA",349.1)
AR TRANSMISSION TYPE
"FIA",349.1,0)
^RCT(349.1,
"FIA",349.1,0,0)
349.1I
"FIA",349.1,0,1)
y^n^f^^^^n^^n
"FIA",349.1,0,10)

"FIA",349.1,0,11)

"FIA",349.1,0,"RLRO")

"FIA",349.1,0,"VR")
4.5^PRCA
"FIA",349.1,349.1)
0
"FIA",349.1,349.11)
0
"FIA",349.1,349.12)
0
"FIA",349.1,349.141)
0
"FIA",349.1,349.151)
0
"FIA",349.1,349.161)
0
"FIA",349.2)
AR CBSS STATEMENTS
"FIA",349.2,0)
^RCPS(349.2,
"FIA",349.2,0,0)
349.2I
"FIA",349.2,0,1)
y^n^p^^^^n^^n
"FIA",349.2,0,10)

"FIA",349.2,0,11)

"FIA",349.2,0,"RLRO")

"FIA",349.2,0,"VR")
4.5^PRCA
"FIA",349.2,349.2)
1
"FIA",349.2,349.2,.01)

"FIA",349.2,349.2,.02)

"FIA",349.2,349.2,.03)

"FIA",349.2,349.2,.12)

"FIA",349.2,349.2,.18)

"FIA",349.2,349.2,.19)

"FIA",349.2,349.2,51)

"FIA",349.2,349.2,61)

"FIA",349.2,349.2,81)

"FIA",349.2,349.2,82)

"FIA",349.2,349.2,83)

"FIA",349.2,349.2,84)

"FIA",349.5)
AR ANNUAL PAYMENT STATEMENT
"FIA",349.5,0)
^RCAP(349.5,
"FIA",349.5,0,0)
349.5
"FIA",349.5,0,1)
y^n^f^^^^n^^n
"FIA",349.5,0,10)

"FIA",349.5,0,11)

"FIA",349.5,0,"RLRO")

"FIA",349.5,0,"VR")
4.5^PRCA
"FIA",349.5,349.5)
0
"FIA",349.5,349.51)
0
"INI")
PRE^PRCA313P
"INIT")
EN^PRCA313P
"IX",349,349,"SDT",0)
349^SDT^Patient Statement Day of the Month^R^^F^IR^I^349^^^^^LS
"IX",349,349,"SDT",.1,0)
^^1^1^3161007^
"IX",349,349,"SDT",.1,1,0)
This cross-reference is the Patient Statement Day of the Month.
"IX",349,349,"SDT",1)
S ^RCT(349,"SDT",$E(X,1,2),DA)=""
"IX",349,349,"SDT",2)
K ^RCT(349,"SDT",$E(X,1,2),DA)
"IX",349,349,"SDT",2.5)
K ^RCT(349,"SDT")
"IX",349,349,"SDT",11.1,0)
^.114IA^1^1
"IX",349,349,"SDT",11.1,1,0)
1^F^349^.09^2^1^F
"IX",349,349,"SDT",11.1,1,2)
S X=+$E(X,6,7)
"IX",349.1,349.141,"STDT4",0)
349.141^STDT4^Patient Statement Date and Last Message ACK^R^^R^IR^I^349.141^^^^
^LS
"IX",349.1,349.141,"STDT4",.1,0)
^^2^2^3161007^
"IX",349.1,349.141,"STDT4",.1,1,0)
This cross-reference is used to sort by the Patient Statement Date and the
"IX",349.1,349.141,"STDT4",.1,2,0)
Last Message ACK. 
"IX",349.1,349.141,"STDT4",1)
S ^RCT(349.1,DA(1),4,"STDT4",$E(X(1),1,7),$E(X(2),1,3),DA)=""
"IX",349.1,349.141,"STDT4",2)
K ^RCT(349.1,DA(1),4,"STDT4",$E(X(1),1,7),$E(X(2),1,3),DA)
"IX",349.1,349.141,"STDT4",2.5)
K ^RCT(349.1,DA(1),4,"STDT4")
"IX",349.1,349.141,"STDT4",11.1,0)
^.114IA^2^2
"IX",349.1,349.141,"STDT4",11.1,1,0)
1^F^349.141^.04^7^1^F
"IX",349.1,349.141,"STDT4",11.1,1,3)

"IX",349.1,349.141,"STDT4",11.1,2,0)
2^F^349.141^.01^3^2^F
"IX",349.1,349.141,"STDT4",11.1,2,3)

"IX",349.1,349.151,"STDT5",0)
349.151^STDT5^Patient Statement Date Index^R^^F^IR^I^349.151^^^^^LS
"IX",349.1,349.151,"STDT5",.1,0)
^^1^1^3161006^
"IX",349.1,349.151,"STDT5",.1,1,0)
This cross-reference is used to sort by the Patient Statement Date.
"IX",349.1,349.151,"STDT5",1)
S ^RCT(349.1,DA(1),5,"STDT5",$E(X,1,7),DA)=""
"IX",349.1,349.151,"STDT5",2)
K ^RCT(349.1,DA(1),5,"STDT5",$E(X,1,7),DA)
"IX",349.1,349.151,"STDT5",2.5)
K ^RCT(349.1,DA(1),5,"STDT5")
"IX",349.1,349.151,"STDT5",11.1,0)
^.114IA^1^1
"IX",349.1,349.151,"STDT5",11.1,1,0)
1^F^349.151^.04^7^1^F
"IX",349.2,349.2,"AD",0)
349.2^AD^Patient Statement Errors^R^^F^IR^I^349.2^^^^^S
"IX",349.2,349.2,"AD",.1,0)
^^2^2^3161007^
"IX",349.2,349.2,"AD",.1,1,0)
This is the cross-reference to find patient statement errors that are
"IX",349.2,349.2,"AD",.1,2,0)
returned from CBSS.
"IX",349.2,349.2,"AD",1)
S ^RCPS(349.2,"AD",$E(X,1,1),DA)=""
"IX",349.2,349.2,"AD",2)
K ^RCPS(349.2,"AD",$E(X,1,1),DA)
"IX",349.2,349.2,"AD",2.5)
K ^RCPS(349.2,"AD")
"IX",349.2,349.2,"AD",11.1,0)
^.114IA^1^1
"IX",349.2,349.2,"AD",11.1,1,0)
1^F^349.2^51^1^1^F
"IX",349.2,349.2,"AD",11.1,1,1)

"IX",349.2,349.2,"AD",11.1,1,2)
S X="E"
"IX",349.2,349.2,"STDT",0)
349.2^STDT^Patient Statement Date^R^^F^IR^I^349.2^^^^^LS
"IX",349.2,349.2,"STDT",.1,0)
^^2^2^3161007^
"IX",349.2,349.2,"STDT",.1,1,0)
Date Patient Statement will display on printed version.  This date is
"IX",349.2,349.2,"STDT",.1,2,0)
standardly two days after the statement is transmitted.
"IX",349.2,349.2,"STDT",1)
S ^RCPS(349.2,"STDT",$E(X,1,7),DA)=""
"IX",349.2,349.2,"STDT",2)
K ^RCPS(349.2,"STDT",$E(X,1,7),DA)
"IX",349.2,349.2,"STDT",2.5)
K ^RCPS(349.2,"STDT")
"IX",349.2,349.2,"STDT",11.1,0)
^.114IA^1^1
"IX",349.2,349.2,"STDT",11.1,1,0)
1^F^349.2^.19^7^1^F
"KRN",19,3026,-1)
2^5
"KRN",19,3026,0)
PRCAE FOLLOW-UP^Follow-up Letter Menu^^M^1^^^^^^^53
"KRN",19,3026,10,0)
^19.01IP^19^15
"KRN",19,3026,10,17,0)
11666^^14
"KRN",19,3026,10,17,"^")
RCCPC APPS BUILD AND TRANS
"KRN",19,3026,10,18,0)
11667^^15
"KRN",19,3026,10,18,"^")
RCCPC APPS RETRANS
"KRN",19,3026,10,19,0)
11668^^16
"KRN",19,3026,10,19,"^")
RCCPC APPS DATA CHECK
"KRN",19,3026,"U")
FOLLOW-UP LETTER MENU
"KRN",19,11657,-1)
0^4
"KRN",19,11657,0)
PRCA CBS NIGHTLY UPDATE^CBS Nightly Account Update Program^^R^^^^^^^^
"KRN",19,11657,1,0)
^^2^2^3160622^
"KRN",19,11657,1,1,0)
This option runs the Consolidated Billing System
"KRN",19,11657,1,2,0)
Nightly Account Update program.
"KRN",19,11657,25)
ENTER^PRCACPS1
"KRN",19,11657,"U")
CBS NIGHTLY ACCOUNT UPDATE PRO
"KRN",19,11666,-1)
0^6
"KRN",19,11666,0)
RCCPC APPS BUILD AND TRANS^Build and Transmit Annual Payment File^^A^^RCCPC APP
S BUILD AND TRANS^^^^^^^^1
"KRN",19,11666,1,0)
^19.06^3^3^3170502^^^
"KRN",19,11666,1,1,0)
This option will build the Annual Payment Statement file for the previous
"KRN",19,11666,1,2,0)
year for every patient who has one or more payments in the previous year
"KRN",19,11666,1,3,0)
and transmit the file to AITC.
"KRN",19,11666,20)
D MANBLD^RCCPCAT
"KRN",19,11666,"U")
BUILD AND TRANSMIT ANNUAL PAYM
"KRN",19,11667,-1)
0^7
"KRN",19,11667,0)
RCCPC APPS RETRANS^Retransmit Current Annual Payment File^^A^^RCCPC APPS BUILD 
AND TRANS^^^^^^^^1
"KRN",19,11667,1,0)
^19.06^3^3^3170502^^^^
"KRN",19,11667,1,1,0)
This option should only to be used when AITC has requested the current
"KRN",19,11667,1,2,0)
Annual Payment Statement file be retransmitted. This file will include
"KRN",19,11667,1,3,0)
every patient who has one or more payments in the previous year.
"KRN",19,11667,20)
D RETRANS^RCCPCAT
"KRN",19,11667,"U")
RETRANSMIT CURRENT ANNUAL PAYM
"KRN",19,11668,-1)
0^8
"KRN",19,11668,0)
RCCPC APPS DATA CHECK^Annual Payment File Consistency Check^^A^^^^^^^^^^1
"KRN",19,11668,1,0)
^^5^5^3170321^
"KRN",19,11668,1,1,0)
AR data is extracted from the VistA sites and is sent to CBSS who then
"KRN",19,11668,1,2,0)
consolidates the data into the annual payment statement. The VistA data 
"KRN",19,11668,1,3,0)
needs to be validated prior to its transmission. This menu option will
"KRN",19,11668,1,4,0)
produce a report detailing which APPS data needs to be reviewed and
"KRN",19,11668,1,5,0)
updated prior to its transmission to CBSS.
"KRN",19,11668,20)
D MANBLD^RCCPCAR
"KRN",19,11668,"U")
ANNUAL PAYMENT FILE CONSISTENC
"KRN",19.1,600,-1)
0^1
"KRN",19.1,600,0)
RCCPC APPS BUILD AND TRANS
"KRN",19.1,600,1,0)
^^8^8^3170502^
"KRN",19.1,600,1,1,0)
This is a key for the AR menu options 'RCCPC APPS BUILD AND TRANS' and
"KRN",19.1,600,1,2,0)
'RCCPC APPS RETRANS'.
"KRN",19.1,600,1,3,0)
 
"KRN",19.1,600,1,4,0)
The 'RCCPC APPS BUILD AND TRANS' option runs the Annual Payment Statement 
"KRN",19.1,600,1,5,0)
File Build and Transmit for the previous year and sends the data to AITC.
"KRN",19.1,600,1,6,0)
 
"KRN",19.1,600,1,7,0)
The 'RCCPC APPS RETRANS' option Re-Transmits the current Annual Payment 
"KRN",19.1,600,1,8,0)
Statement File data to AITC.
"MBREQ")
0
"ORD",3,19.1)
19.1;3;;;KEY^XPDTA1;KEYF1^XPDIA1;KEYE1^XPDIA1;KEYF2^XPDIA1;;KEYDEL^XPDIA1
"ORD",3,19.1,0)
SECURITY KEY
"ORD",18,19)
19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA
"ORD",18,19,0)
OPTION
"PKG",53,-1)
1^1
"PKG",53,0)
ACCOUNTS RECEIVABLE^PRCA^FMS
"PKG",53,20,0)
^9.402P^1^1
"PKG",53,20,1,0)
2^^PRCAMRG
"PKG",53,20,1,1)

"PKG",53,20,"B",2,1)

"PKG",53,22,0)
^9.49I^1^1
"PKG",53,22,1,0)
4.5^3051119^2960627
"PKG",53,22,1,"PAH",1,0)
313^3170504^85
"PKG",53,22,1,"PAH",1,1,0)
^^1^1^3170504
"PKG",53,22,1,"PAH",1,1,1,0)
Consolidated Patient Statement
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
YES
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
19
"RTN","PRCA313P")
0^18^B20491359^n/a
"RTN","PRCA313P",1,0)
PRCA313P ;ALB/BDB - PATCH PRCA*4.5*313 POST-INSTALL ROUTINE ; 11/2/15 4:15pm
"RTN","PRCA313P",2,0)
 ;;4.5;Accounts Receivable;**313**;Mar 20, 1995;Build 118
"RTN","PRCA313P",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCA313P",4,0)
 ; This routine queues the Patient Statement Auto-Correction Program
"RTN","PRCA313P",5,0)
 ;
"RTN","PRCA313P",6,0)
 Q
"RTN","PRCA313P",7,0)
EN ;Entry point for PRCA*4.5*313 post-install
"RTN","PRCA313P",8,0)
 ; 
"RTN","PRCA313P",9,0)
 ; Delete DD previous monthly data
"RTN","PRCA313P",10,0)
 D CLEANUP
"RTN","PRCA313P",11,0)
 ; Set Patient Statement days
"RTN","PRCA313P",12,0)
 D STDT
"RTN","PRCA313P",13,0)
 ; Set AR Transaction Types
"RTN","PRCA313P",14,0)
 D SET3491
"RTN","PRCA313P",15,0)
 ;
"RTN","PRCA313P",16,0)
 Q 
"RTN","PRCA313P",17,0)
 ;
"RTN","PRCA313P",18,0)
STDT  ; Entry point for PRCA*4.5*313 set of Patient Statement date dependent up
on the Patient Last Name
"RTN","PRCA313P",19,0)
 D BMES^XPDUTL("Starting Patient Statement Date Reset.")
"RTN","PRCA313P",20,0)
 N DEBT,DIE
"RTN","PRCA313P",21,0)
 S DIE="^RCD(340,"
"RTN","PRCA313P",22,0)
 S DEBT=""
"RTN","PRCA313P",23,0)
 F  S DEBT=$O(^RCD(340,"AB","DPT(",DEBT)) Q:DEBT=""  D
"RTN","PRCA313P",24,0)
 . N PAT,DPT,NAME,DA,DR
"RTN","PRCA313P",25,0)
 . S PAT=$P($G(^RCD(340,DEBT,0)),U)
"RTN","PRCA313P",26,0)
 . S DPT=$P(PAT,";",1)
"RTN","PRCA313P",27,0)
 . S NAME=$P($G(^DPT(DPT,0)),U)
"RTN","PRCA313P",28,0)
 . S DA=DEBT
"RTN","PRCA313P",29,0)
 . S DR=".03////"_+$$ACSET^RCCPCFN1(NAME)
"RTN","PRCA313P",30,0)
 . D ^DIE
"RTN","PRCA313P",31,0)
 ;
"RTN","PRCA313P",32,0)
 ; Set cross-reference in AR Event (341) if Patient Statement date exists
"RTN","PRCA313P",33,0)
 N DA,DIK
"RTN","PRCA313P",34,0)
 S DIK="^RC(341,"
"RTN","PRCA313P",35,0)
 S DA="" F  S DA=$O(^RC(341,DA)) Q:DA=""  I $G(^RC(341,DA,6))'="" D IX1^DIK
"RTN","PRCA313P",36,0)
 ;
"RTN","PRCA313P",37,0)
 D BMES^XPDUTL("Patient Statement Date Reset Complete.")
"RTN","PRCA313P",38,0)
 Q
"RTN","PRCA313P",39,0)
 ;
"RTN","PRCA313P",40,0)
CLEANUP  ;  PRCA*4.5*313
"RTN","PRCA313P",41,0)
 ; Remove site statement date
"RTN","PRCA313P",42,0)
 D BMES^XPDUTL("Starting Patient Statement Cleanup.")
"RTN","PRCA313P",43,0)
 N DA,DR,DIE,X,RCT
"RTN","PRCA313P",44,0)
 S DA=1
"RTN","PRCA313P",45,0)
 S DR=".11///@"
"RTN","PRCA313P",46,0)
 S DIE="^RC(342,"
"RTN","PRCA313P",47,0)
 D ^DIE
"RTN","PRCA313P",48,0)
 ;
"RTN","PRCA313P",49,0)
 ; Remove all monthly data
"RTN","PRCA313P",50,0)
 S DIK="^RCT(349,"
"RTN","PRCA313P",51,0)
 S DA=0 F  S DA=$O(^RCT(349,DA)) Q:DA=""  D ^DIK
"RTN","PRCA313P",52,0)
 S ^RCT(349,0)="AR TRANSMISSION RECORDS^349I^^"
"RTN","PRCA313P",53,0)
 S DIK="^RCPS(349.2,"
"RTN","PRCA313P",54,0)
 S DA=0 F  S DA=$O(^RCPS(349.2,DA)) Q:DA=""  D ^DIK
"RTN","PRCA313P",55,0)
 S ^RCPS(349.2,0)="AR CBSS STATEMENTS^349.2I^^"
"RTN","PRCA313P",56,0)
 F X="PA","IS" S RCT=$O(^RCT(349.1,"B",X,0)) Q:'RCT  K ^RCT(349.1,+RCT,4),^RCT(
349.1,+RCT,5)
"RTN","PRCA313P",57,0)
 ;
"RTN","PRCA313P",58,0)
 D BMES^XPDUTL("Patient Statement Cleanup complete.")
"RTN","PRCA313P",59,0)
 Q
"RTN","PRCA313P",60,0)
 ;
"RTN","PRCA313P",61,0)
SET3491  ; PRCA*4.5*313
"RTN","PRCA313P",62,0)
 ; Set values for Production or Test AR Transmission Type
"RTN","PRCA313P",63,0)
 N PROD,CC,CP,CA,IEN,TT,TTVAL
"RTN","PRCA313P",64,0)
 ;
"RTN","PRCA313P",65,0)
 D BMES^XPDUTL("Starting AR Transaction Type Update.")
"RTN","PRCA313P",66,0)
 ;
"RTN","PRCA313P",67,0)
 ; Set whether environment is Production or Test and define expected/new values
"RTN","PRCA313P",68,0)
 S PROD=$$PROD^XUPROD
"RTN","PRCA313P",69,0)
 S (CC(1),CP(1),CA(1))="XXX"
"RTN","PRCA313P",70,0)
 S CC(3)="Q-"_$S(PROD:"CBS",1:"CCT")_"URL        "
"RTN","PRCA313P",71,0)
 S CP(3)="Q-"_$S(PROD:"CPP",1:"CPT")_"URL        "
"RTN","PRCA313P",72,0)
 S CA(3)="Q-"_$S(PROD:"CAP",1:"CAT")_"URL        "
"RTN","PRCA313P",73,0)
 ;
"RTN","PRCA313P",74,0)
 ; Validate Domains are available.  Write error if not
"RTN","PRCA313P",75,0)
 I '$D(^DIC(4.2,"B",CC(3)))!('$D(^DIC(4.2,"B",CP(3))))!('$D(^DIC(4.2,"B",CA(3))
)) D  Q
"RTN","PRCA313P",76,0)
 . N LINE S $P(LINE,"*",79)=""
"RTN","PRCA313P",77,0)
 . D BMES^XPDUTL(LINE)
"RTN","PRCA313P",78,0)
 . D MES^XPDUTL("Domains for PRCA*4.5*313 have not been fully set up.")
"RTN","PRCA313P",79,0)
 . D MES^XPDUTL("Please establish Domains for: ")
"RTN","PRCA313P",80,0)
 . D MES^XPDUTL("CCPC PATIENT STATEMENTS, PATIENT STATEMENT UPDATE, and ANNUAL 
PAYMENT STATEMENTS.")
"RTN","PRCA313P",81,0)
 . D BMES^XPDUTL(LINE)
"RTN","PRCA313P",82,0)
 ;
"RTN","PRCA313P",83,0)
 ; Validate 'PS', 'PU', and 'PY' are set for Patient Statement, Nightly Update,
 and Annual Payment Statement
"RTN","PRCA313P",84,0)
 F TT="PS","PU","PY" S IEN=$O(^RCT(349.1,"B",TT,0)) D
"RTN","PRCA313P",85,0)
 . N DOMAIN,I
"RTN","PRCA313P",86,0)
 . I TT="PS" M DOMAIN=CC
"RTN","PRCA313P",87,0)
 . I TT="PU" M DOMAIN=CP
"RTN","PRCA313P",88,0)
 . I TT="PY" M DOMAIN=CA
"RTN","PRCA313P",89,0)
 . ; If no IEN create new level one and three with cross-references
"RTN","PRCA313P",90,0)
 . I IEN="" D SET1(TT,.DOMAIN) Q
"RTN","PRCA313P",91,0)
 . ; If no 3 level or it is not set to expected value reset 3 level
"RTN","PRCA313P",92,0)
 . I IEN'="" D
"RTN","PRCA313P",93,0)
 . F I=1,3 S TTVAL(I)=$P($G(^RCT(349.1,IEN,3)),U,I)
"RTN","PRCA313P",94,0)
 . I DOMAIN(1)_DOMAIN(3)'=TTVAL(1)_TTVAL(3) D SET3(IEN,.DOMAIN)
"RTN","PRCA313P",95,0)
 ;
"RTN","PRCA313P",96,0)
 D BMES^XPDUTL("AR Transaction Type Update complete.")
"RTN","PRCA313P",97,0)
 ;
"RTN","PRCA313P",98,0)
 Q
"RTN","PRCA313P",99,0)
 ;
"RTN","PRCA313P",100,0)
SET1(TT,DOMAIN)  ; PRCA*4.5*313
"RTN","PRCA313P",101,0)
 ; Set both the 1 and 3 level for 349.1
"RTN","PRCA313P",102,0)
 ; New and Set Field values for DIC(4.2
"RTN","PRCA313P",103,0)
 N TTNAME,ZZ,DIC,Y
"RTN","PRCA313P",104,0)
 I TT="PS" S TTNAME="CCPC PATIENT STATEMENT"
"RTN","PRCA313P",105,0)
 I TT="PU" S TTNAME="PATIENT STATEMENT UPDATE"
"RTN","PRCA313P",106,0)
 I TT="PY" S TTNAME="ANNUAL PAYMENT STATEMENTS"
"RTN","PRCA313P",107,0)
 ;
"RTN","PRCA313P",108,0)
 ; Set 1 level values
"RTN","PRCA313P",109,0)
 S DIC="^RCT(349.1,",DIC(0)="L"
"RTN","PRCA313P",110,0)
 S X=TT
"RTN","PRCA313P",111,0)
 S DIC("DR")=".02///"_TTNAME_";.03///"_1_";"
"RTN","PRCA313P",112,0)
 D FILE^DICN
"RTN","PRCA313P",113,0)
 S IEN=+Y
"RTN","PRCA313P",114,0)
 ;
"RTN","PRCA313P",115,0)
 ; Set 3 level
"RTN","PRCA313P",116,0)
 D SET3(IEN,.DOMAIN)
"RTN","PRCA313P",117,0)
 ;
"RTN","PRCA313P",118,0)
 Q
"RTN","PRCA313P",119,0)
SET3(IEN,DOMAIN)  ; PRCA*4.5*313
"RTN","PRCA313P",120,0)
 ; Set 3 level for 349.1
"RTN","PRCA313P",121,0)
 S DOMAIN("IEN")=$O(^DIC(4.2,"B",DOMAIN(3),0))
"RTN","PRCA313P",122,0)
 S ^RCT(349.1,IEN,3)=DOMAIN(1)_U_DOMAIN("IEN")_U_DOMAIN(3)
"RTN","PRCA313P",123,0)
 ; PRCA*4.5*313 - Set Cross-References for this IEN
"RTN","PRCA313P",124,0)
 S DA=IEN,DIK="^RCT(349.1," D IX1^DIK
"RTN","PRCA313P",125,0)
 ;
"RTN","PRCA313P",126,0)
 Q
"RTN","PRCA313P",127,0)
 ;
"RTN","PRCA313P",128,0)
PRE  ; Pre-install actions for the Data Dictionary
"RTN","PRCA313P",129,0)
 ;
"RTN","PRCA313P",130,0)
 D BMES^XPDUTL("Starting Pre-Install Changes.")
"RTN","PRCA313P",131,0)
 ;
"RTN","PRCA313P",132,0)
 N DIK,DA
"RTN","PRCA313P",133,0)
 ; Remove DD for 349.1, elements 41, 42, and 43 - new elements are entered duri
ng regular install
"RTN","PRCA313P",134,0)
 S DIK="^DD(349.1,",DA(1)=349.1
"RTN","PRCA313P",135,0)
 F DA=41,42,43 D ^DIK
"RTN","PRCA313P",136,0)
 ;
"RTN","PRCA313P",137,0)
 ; Remove DD for 349, element .09 to change from old to new Style Cross Referen
ce.
"RTN","PRCA313P",138,0)
 S DIK="^DD(349,",DA(1)=349
"RTN","PRCA313P",139,0)
 S DA=.09 D ^DIK
"RTN","PRCA313P",140,0)
 ;
"RTN","PRCA313P",141,0)
 D BMES^XPDUTL("Pre-Install Changes complete.")
"RTN","PRCA313P",142,0)
 Q
"RTN","PRCAACR")
0^19^B124955572^n/a
"RTN","PRCAACR",1,0)
PRCAACR ;ALBANY/BDB-PATIENT STATEMENTS AUTO-CORRECTION REPORT ;09/21/15 3:34 PM
"RTN","PRCAACR",2,0)
 ;;4.5;Accounts Receivable;**307,313**;Mar 20, 1995;Build 118
"RTN","PRCAACR",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCAACR",4,0)
 ;
"RTN","PRCAACR",5,0)
 Q
"RTN","PRCAACR",6,0)
 ;
"RTN","PRCAACR",7,0)
PSACRT ; report, prints sorted individual transactions that have been auto-corr
ected
"RTN","PRCAACR",8,0)
 N DIC,PAGE,BY,DHD,FILENUM,FLDS,FR,L,TO,PRCABDT,PRCAEDT,PRCASORT
"RTN","PRCAACR",9,0)
 W !
"RTN","PRCAACR",10,0)
PSDATE ;
"RTN","PRCAACR",11,0)
 ; Determine if Auto Correct process is currently running
"RTN","PRCAACR",12,0)
 N PRCASTRT,QUIT,X,X1,X2,Y
"RTN","PRCAACR",13,0)
 S PRCASTRT=$G(^XTMP("PRCACPS",0)),QUIT=""
"RTN","PRCAACR",14,0)
 ; QUIT if Auto Correct process is currently running
"RTN","PRCAACR",15,0)
 I PRCASTRT'="" D  Q:QUIT
"RTN","PRCAACR",16,0)
 .S Y=$P(PRCASTRT,U,2)
"RTN","PRCAACR",17,0)
 .D DD^%DT
"RTN","PRCAACR",18,0)
 .S PRCASTRT=Y
"RTN","PRCAACR",19,0)
 .W !!,"The Patient Statement Auto-Correction Program is currently running."
"RTN","PRCAACR",20,0)
 .W !,"It was started at ",PRCASTRT," and can take up to 1 hour to complete."
"RTN","PRCAACR",21,0)
 .W !!,"If you choose to continue with this report, it may not reflect all of t
he"
"RTN","PRCAACR",22,0)
 .W !,"changes from this latest run of the Patient Statement Auto-Correction Pr
ogram."
"RTN","PRCAACR",23,0)
 .W !
"RTN","PRCAACR",24,0)
 .S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="NO"
"RTN","PRCAACR",25,0)
 .D ^DIR
"RTN","PRCAACR",26,0)
 .W !
"RTN","PRCAACR",27,0)
 .; Quit if ^, ^^, Timeout or No
"RTN","PRCAACR",28,0)
 .I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(Y=0) S QUIT=1
"RTN","PRCAACR",29,0)
 .; Send MailMan message to PRCACPS mail group if Yes
"RTN","PRCAACR",30,0)
 .I Y=1 D PRCAMAIL^PRCACPS(PRCASTRT)
"RTN","PRCAACR",31,0)
 .K DTOUT,DUOUT,DIROUT
"RTN","PRCAACR",32,0)
 ;
"RTN","PRCAACR",33,0)
 N DIROUT,DIS,DTOUT,DUOUT
"RTN","PRCAACR",34,0)
 S DIR("A")="Date Range: FROM: ",DIR("B")="T-7"
"RTN","PRCAACR",35,0)
 S DIR("?")="The default date is T-7.  Future dates may not be entered."
"RTN","PRCAACR",36,0)
 S DIR(0)="DO" D ^DIR
"RTN","PRCAACR",37,0)
 S:Y'="" PRCABDT=Y
"RTN","PRCAACR",38,0)
 I $D(DIRUT)&'Y K DIRUT Q
"RTN","PRCAACR",39,0)
 I PRCABDT>DT G PSDATE
"RTN","PRCAACR",40,0)
 W "(",Y(0),")"
"RTN","PRCAACR",41,0)
 K DIR,X,Y
"RTN","PRCAACR",42,0)
 S DIR(0)="DO"
"RTN","PRCAACR",43,0)
 S DIR("A")="Date Range:   TO: ",DIR("B")="T"
"RTN","PRCAACR",44,0)
 S DIR("?")="The default date is T, but any date may be entered."
"RTN","PRCAACR",45,0)
 D ^DIR S:Y="" Y=DT
"RTN","PRCAACR",46,0)
 I $D(DIRUT)&'Y K DIRUT Q
"RTN","PRCAACR",47,0)
 W "(",Y(0),")"
"RTN","PRCAACR",48,0)
 S PRCAEDT=Y
"RTN","PRCAACR",49,0)
 I PRCABDT>PRCAEDT G PSDATE
"RTN","PRCAACR",50,0)
 K DIR
"RTN","PRCAACR",51,0)
 S DIR(0)="S^1:Auto-Correct Reason;2:Debtor Name;3:Bill Number;4:Transaction Nu
mber;5:Auto-Correct Date",DIR("A")="Sort by"
"RTN","PRCAACR",52,0)
 S DIR("B")=1
"RTN","PRCAACR",53,0)
 D ^DIR K DIR
"RTN","PRCAACR",54,0)
 S PRCASORT=Y
"RTN","PRCAACR",55,0)
 Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
"RTN","PRCAACR",56,0)
 ;
"RTN","PRCAACR",57,0)
 ; Prompt for device
"RTN","PRCAACR",58,0)
 W !
"RTN","PRCAACR",59,0)
 N ZTRTN,ZTDESC,ZTSAVE
"RTN","PRCAACR",60,0)
 K IOP,%ZIS,POP,IO("Q")
"RTN","PRCAACR",61,0)
 S %ZIS="Q"
"RTN","PRCAACR",62,0)
 D ^%ZIS Q:POP
"RTN","PRCAACR",63,0)
 ; If Queued
"RTN","PRCAACR",64,0)
 I $D(IO("Q")) D  Q
"RTN","PRCAACR",65,0)
 .K IO("Q")
"RTN","PRCAACR",66,0)
 .I $G(IOST)["P-MES" S ZTRTN="PRT^PRCAACR1"
"RTN","PRCAACR",67,0)
 .I $G(IOST)'["P-MES" S ZTRTN="PRT^PRCAACR"
"RTN","PRCAACR",68,0)
 .S ZTSAVE("PRCABDT")="",ZTSAVE("PRCAEDT")="",ZTSAVE("PRCASORT")=""
"RTN","PRCAACR",69,0)
 .D ^%ZTLOAD
"RTN","PRCAACR",70,0)
 .D HOME^%ZIS
"RTN","PRCAACR",71,0)
 .I $D(ZTSK)[0 W !!?5,"Report cancelled!"
"RTN","PRCAACR",72,0)
 .E  W !!?5,"Report queued!"
"RTN","PRCAACR",73,0)
 .K POP
"RTN","PRCAACR",74,0)
 ;
"RTN","PRCAACR",75,0)
 ;Print Report if not QUEUED
"RTN","PRCAACR",76,0)
PRT ;
"RTN","PRCAACR",77,0)
 ; If not queued and output sent to P-MES
"RTN","PRCAACR",78,0)
 I $G(IOST)["P-MES" D PRT^PRCAACR1 Q
"RTN","PRCAACR",79,0)
 ;If not queued and output not sent to P-MES
"RTN","PRCAACR",80,0)
 U IO
"RTN","PRCAACR",81,0)
 K ^TMP("PRCAACR",$J)
"RTN","PRCAACR",82,0)
 S PAGE=0
"RTN","PRCAACR",83,0)
 S DASH="",$P(DASH,"-",79)=""
"RTN","PRCAACR",84,0)
 S DIS(0)="I $D(^PRCA(433,""TACD"",PRCATSRT,D0))",L=0
"RTN","PRCAACR",85,0)
 N PRCATSRT,PRCATN,PRCAACD,PRCAACR,PRCABN,PRCADATA,PRCADTR,PRCASSN,PRCAACTF,PRC
ATNTF
"RTN","PRCAACR",86,0)
 S PRCATSRT=PRCABDT-.00001
"RTN","PRCAACR",87,0)
 ; Loop through the specified date range
"RTN","PRCAACR",88,0)
 F  S PRCATSRT=$O(^PRCA(433,"TACD",PRCATSRT)) Q:PRCATSRT=""!(PRCATSRT>PRCAEDT) 
 D
"RTN","PRCAACR",89,0)
 .S PRCATN=""
"RTN","PRCAACR",90,0)
 .; Loop through the transactions for the current date
"RTN","PRCAACR",91,0)
 .F  S PRCATN=$O(^PRCA(433,"TACD",PRCATSRT,PRCATN)) Q:'PRCATN  D
"RTN","PRCAACR",92,0)
 ..; Load associated data fields for report
"RTN","PRCAACR",93,0)
 ..S PRCATNTF=PRCATN ; Transaction Number Ticket Flag
"RTN","PRCAACR",94,0)
 ..S PRCABN=$P(^PRCA(433,PRCATN,0),U,2)
"RTN","PRCAACR",95,0)
 ..S PRCADTR=$$GET1^DIQ(430,PRCABN_",",9) ; (#9) DEBTOR
"RTN","PRCAACR",96,0)
 ..S PRCASSN=$G(^PRCA(430,PRCABN,0)) ; Load 0 Node
"RTN","PRCAACR",97,0)
 ..S PRCASSN=$P(PRCASSN,U,9) ; get IEN of Debtor
"RTN","PRCAACR",98,0)
 ..S PRCABN=$$GET1^DIQ(433,PRCATN_",",.03) ; (#.03) BILL NUMBER
"RTN","PRCAACR",99,0)
 ..S PRCASSN=$$GET1^DIQ(340,PRCASSN_",",110) ; SSN
"RTN","PRCAACR",100,0)
 ..S PRCAACD=$$GET1^DIQ(433,PRCATN_",",94,"I") ;(#94) AUTO-CORRECTION DATE
"RTN","PRCAACR",101,0)
 ..S PRCAACR=$$GET1^DIQ(433,PRCATN_",",96) ;(#96) AUTO-CORRECTION TYPE OF ERROR
"RTN","PRCAACR",102,0)
 ..S PRCAACR=$E(PRCAACR,1,14)
"RTN","PRCAACR",103,0)
 ..S PRCAACTF=$$GET1^DIQ(433,PRCATN_",",97) ;(#97)AUTO-CORRECTION TICKET FLAG
"RTN","PRCAACR",104,0)
 ..; If Ticket Flag is set, reset Transaction Number to null
"RTN","PRCAACR",105,0)
 ..I PRCAACTF="YES" S PRCATNTF=""
"RTN","PRCAACR",106,0)
 ..;
"RTN","PRCAACR",107,0)
 ..; Store in ^TMP sorted by Auto-Correct Reason, Debtor, #Bill Number
"RTN","PRCAACR",108,0)
 ..I PRCASORT=1 D  Q
"RTN","PRCAACR",109,0)
 ...S ^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)=PRCAACR_U_PRCADTR_U_PRCABN_U_PR
CATNTF_U_PRCAACD_U_PRCASSN
"RTN","PRCAACR",110,0)
 ..;
"RTN","PRCAACR",111,0)
 ..; Store in ^TMP sorted by Debtor, Bill Number and Transaction #
"RTN","PRCAACR",112,0)
 ..I PRCASORT=2 D  Q
"RTN","PRCAACR",113,0)
 ...S ^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)=PRCADTR_U_PRCABN_U_PRCASSN_U_PRC
ATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR",114,0)
 ..;
"RTN","PRCAACR",115,0)
 ..; Store in ^TMP sorted by Bill Number, Debtor and Transaction #
"RTN","PRCAACR",116,0)
 ..I PRCASORT=3 D  Q
"RTN","PRCAACR",117,0)
 ...S ^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)=PRCABN_U_PRCADTR_U_PRCASSN_U_PRC
ATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR",118,0)
 ..;
"RTN","PRCAACR",119,0)
 ..; Store in ^TMP sorted by Transaction, Debtor and Bill Number
"RTN","PRCAACR",120,0)
 ..I PRCASORT=4 D  Q
"RTN","PRCAACR",121,0)
 ...S ^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)=PRCATNTF_U_PRCADTR_U_PRCABN_U_PR
CASSN_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR",122,0)
 ..;
"RTN","PRCAACR",123,0)
 ..; Store in ^TMP sorted by Auto-Correct Reason, Debtor, #Bill Number and Tran
saction Number
"RTN","PRCAACR",124,0)
 ..I PRCASORT=5 D  Q
"RTN","PRCAACR",125,0)
 ...S ^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)=PRCAACD_U_PRCADTR_U_PRCA
BN_U_PRCASSN_U_PRCATNTF_U_PRCAACR
"RTN","PRCAACR",126,0)
 ;
"RTN","PRCAACR",127,0)
 ;
"RTN","PRCAACR",128,0)
 N QUIT ; QUIT before end of report
"RTN","PRCAACR",129,0)
 S QUIT=""
"RTN","PRCAACR",130,0)
 ; Display Auto-Correct data sorted by Auto Correction Reason
"RTN","PRCAACR",131,0)
 I PRCASORT=1 D
"RTN","PRCAACR",132,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)=PRCAACR_U_PRCADTR_U_P
RCABN_U_PRCATNTF_U_PRCAACD_U_PRCASSN
"RTN","PRCAACR",133,0)
 .; Display Auto Correction Reason header
"RTN","PRCAACR",134,0)
 .N Y
"RTN","PRCAACR",135,0)
 .D PSACRTP1
"RTN","PRCAACR",136,0)
 .S PRCAACR=""
"RTN","PRCAACR",137,0)
 .F  S PRCAACR=$O(^TMP("PRCAACR",$J,PRCAACR)) Q:PRCAACR=""  D  Q:QUIT
"RTN","PRCAACR",138,0)
 ..S PRCADTR=""
"RTN","PRCAACR",139,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCAACR,PRCADTR)) Q:PRCADTR=""  D  Q:QUIT
"RTN","PRCAACR",140,0)
 ...S PRCABN=""
"RTN","PRCAACR",141,0)
 ...F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)) Q:'PRCABN  D  Q:Q
UIT
"RTN","PRCAACR",142,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)
"RTN","PRCAACR",143,0)
 ....S Y=$P(PRCADATA,U,5)
"RTN","PRCAACR",144,0)
 ....D DD^%DT
"RTN","PRCAACR",145,0)
 ....S $P(PRCADATA,U,5)=Y
"RTN","PRCAACR",146,0)
 ....W !,$P(PRCADATA,U,1),?16,$E($P(PRCADATA,U,2),1,18),?36,$E($P(PRCADATA,U,6)
,6,9),?42,$E($P(PRCADATA,U,3),1,11),?55,$J($P(PRCADATA,U,4),9),?66,$P(PRCADATA,
U,5)
"RTN","PRCAACR",147,0)
 ....I $Y>(IOSL-3) D
"RTN","PRCAACR",148,0)
 .....I $E(IOST,1,2)="C-" D  Q:QUIT
"RTN","PRCAACR",149,0)
 ......D PRTC
"RTN","PRCAACR",150,0)
 ......I $D(DIRUT)!($D(DTOUT)) S QUIT=1
"RTN","PRCAACR",151,0)
 .....D PSACRTP1
"RTN","PRCAACR",152,0)
 ;
"RTN","PRCAACR",153,0)
 ; Display Auto-Correct data sorted by Debtor
"RTN","PRCAACR",154,0)
 I PRCASORT=2 D
"RTN","PRCAACR",155,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)=PRCADTR_U_PRCABN_U_PRC
ASSN_U_PRCATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR",156,0)
 .; Display Debtor header
"RTN","PRCAACR",157,0)
 .D PSACRTP2
"RTN","PRCAACR",158,0)
 .S PRCADTR=""
"RTN","PRCAACR",159,0)
 .F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCADTR)) Q:PRCADTR=""  D  Q:QUIT
"RTN","PRCAACR",160,0)
 ..S PRCABN=""
"RTN","PRCAACR",161,0)
 ..F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCADTR,PRCABN)) Q:'PRCABN  D  Q:QUIT
"RTN","PRCAACR",162,0)
 ...S PRCATN=""
"RTN","PRCAACR",163,0)
 ...F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)) Q:'PRCATN  D  Q:QU
IT
"RTN","PRCAACR",164,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)
"RTN","PRCAACR",165,0)
 ....S $P(PRCADATA,U,5)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR",166,0)
 ....W !,$E($P(PRCADATA,U,1),1,18),?20,$P(PRCADATA,U,2),?33,$E($P(PRCADATA,U,3)
,6,9),?39,$J($P(PRCADATA,U,4),9),?50,$P(PRCADATA,U,5),?64,$P(PRCADATA,U,6)
"RTN","PRCAACR",167,0)
 ....I $Y>(IOSL-3) D
"RTN","PRCAACR",168,0)
 .....I $E(IOST,1,2)="C-" D  Q:QUIT
"RTN","PRCAACR",169,0)
 ......D PRTC
"RTN","PRCAACR",170,0)
 ......I $D(DIRUT)!($D(DTOUT)) S QUIT=1
"RTN","PRCAACR",171,0)
 .....D PSACRTP2
"RTN","PRCAACR",172,0)
 ;
"RTN","PRCAACR",173,0)
 ; Display Auto-Correct data sorted by AUTO-C DATE
"RTN","PRCAACR",174,0)
 I PRCASORT=3 D
"RTN","PRCAACR",175,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)=PRCABN_U_PRCADTR_U_PRC
ASSN_U_PRCATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR",176,0)
 .; Display Bill Number header
"RTN","PRCAACR",177,0)
 .D PSACRTP3
"RTN","PRCAACR",178,0)
 .S PRCABN=""
"RTN","PRCAACR",179,0)
 .F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCABN)) Q:'PRCABN  D  Q:QUIT
"RTN","PRCAACR",180,0)
 ..S PRCADTR=""
"RTN","PRCAACR",181,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCABN,PRCADTR)) Q:PRCADTR=""  D  Q:QUIT
"RTN","PRCAACR",182,0)
 ...S PRCATN=""
"RTN","PRCAACR",183,0)
 ...F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)) Q:'PRCATN  D  Q:QU
IT
"RTN","PRCAACR",184,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)
"RTN","PRCAACR",185,0)
 ....S $P(PRCADATA,U,5)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR",186,0)
 ....W !,$P(PRCADATA,U,1),?13,$E($P(PRCADATA,U,2),1,18),?33,$E($P(PRCADATA,U,3)
,6,9),?39,$J($P(PRCADATA,U,4),9),?50,$P(PRCADATA,U,5),?64,$P(PRCADATA,U,6)
"RTN","PRCAACR",187,0)
 ....I $Y>(IOSL-3) D
"RTN","PRCAACR",188,0)
 .....I $E(IOST,1,2)="C-" D  Q:QUIT
"RTN","PRCAACR",189,0)
 ......D PRTC
"RTN","PRCAACR",190,0)
 ......I $D(DIRUT)!($D(DTOUT)) S QUIT=1
"RTN","PRCAACR",191,0)
 .....D PSACRTP3
"RTN","PRCAACR",192,0)
 ;
"RTN","PRCAACR",193,0)
 ; Display Auto-Correct data sorted by Transaction Number
"RTN","PRCAACR",194,0)
 I PRCASORT=4 D
"RTN","PRCAACR",195,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)=PRCATNTF_U_PRCADTR_U_P
RCABN_U_PRCASSN_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR",196,0)
 .; Display AUTO-C DATE header
"RTN","PRCAACR",197,0)
 .D PSACRTP4
"RTN","PRCAACR",198,0)
 .S PRCATN=""
"RTN","PRCAACR",199,0)
 .F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCATN)) Q:'PRCATN  D  Q:QUIT
"RTN","PRCAACR",200,0)
 ..S PRCADTR=""
"RTN","PRCAACR",201,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCATN,PRCADTR)) Q:PRCADTR=""  D  Q:QUIT
"RTN","PRCAACR",202,0)
 ...S PRCABN=""
"RTN","PRCAACR",203,0)
 ...F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)) Q:'PRCABN  D  Q:QU
IT
"RTN","PRCAACR",204,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)
"RTN","PRCAACR",205,0)
 ....S $P(PRCADATA,U,5)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR",206,0)
 ....W !,$J($P(PRCADATA,U,1),9),?11,$E($P(PRCADATA,U,2),1,18),?31,$P(PRCADATA,U
,3),?44,$E($P(PRCADATA,U,4),6,9),?50,$P(PRCADATA,U,5),?64,$P(PRCADATA,U,6)
"RTN","PRCAACR",207,0)
 ....I $Y>(IOSL-3) D
"RTN","PRCAACR",208,0)
 .....I $E(IOST,1,2)="C-" D  Q:QUIT
"RTN","PRCAACR",209,0)
 ......D PRTC
"RTN","PRCAACR",210,0)
 ......I $D(DIRUT)!($D(DTOUT)) S QUIT=1
"RTN","PRCAACR",211,0)
 .....D PSACRTP4
"RTN","PRCAACR",212,0)
 ;
"RTN","PRCAACR",213,0)
 ; Display Auto-Correct data sorted by Auto-Correct date
"RTN","PRCAACR",214,0)
 I PRCASORT=5 D
"RTN","PRCAACR",215,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)=PRCAACD_U_PRCA
DTR_U_PRCABN_U_PRCASSN_U_PRCATNTF_U_PRCAACR
"RTN","PRCAACR",216,0)
 .; Display AUTO-C DATE header
"RTN","PRCAACR",217,0)
 .D PSACRTP5
"RTN","PRCAACR",218,0)
 .S PRCAACD=""
"RTN","PRCAACR",219,0)
 .F  S PRCAACD=$O(^TMP("PRCAACR",$J,PRCAACD)) Q:PRCAACD=""  D  Q:QUIT
"RTN","PRCAACR",220,0)
 ..S PRCADTR=""
"RTN","PRCAACR",221,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCAACD,PRCADTR)) Q:PRCADTR=""  D  Q:QUIT
"RTN","PRCAACR",222,0)
 ...S PRCABN=""
"RTN","PRCAACR",223,0)
 ...F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN)) Q:'PRCABN  D  Q:Q
UIT
"RTN","PRCAACR",224,0)
 ....S PRCATN=""
"RTN","PRCAACR",225,0)
 ....F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)) Q:'PRCATN
  D  Q:QUIT
"RTN","PRCAACR",226,0)
 .....S PRCADATA=^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)
"RTN","PRCAACR",227,0)
 .....S $P(PRCADATA,U,1)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR",228,0)
 .....W !,$P(PRCADATA,U,1),?14,$E($P(PRCADATA,U,2),1,18),?34,$P(PRCADATA,U,3),?
47,$E($P(PRCADATA,U,4),6,9),?53,$J($P(PRCADATA,U,5),9),?64,$P(PRCADATA,U,6)
"RTN","PRCAACR",229,0)
 .....I $Y>(IOSL-3) D
"RTN","PRCAACR",230,0)
 ......I $E(IOST,1,2)="C-" D  Q:QUIT
"RTN","PRCAACR",231,0)
 .......D PRTC
"RTN","PRCAACR",232,0)
 .......I $D(DIRUT)!($D(DTOUT)) S QUIT=1
"RTN","PRCAACR",233,0)
 ......D PSACRTP5
"RTN","PRCAACR",234,0)
 D ^%ZISC
"RTN","PRCAACR",235,0)
 I $E(IOST,1,2)="C-",'$D(DUOUT),('$D(DTOUT)) W ! S DIR(0)="E" D ^DIR
"RTN","PRCAACR",236,0)
 K X,Y,DASH,D0
"RTN","PRCAACR",237,0)
 Q
"RTN","PRCAACR",238,0)
 ;
"RTN","PRCAACR",239,0)
PRTC ; Press Return To Continue
"RTN","PRCAACR",240,0)
 S DIR(0)="E" D ^DIR
"RTN","PRCAACR",241,0)
 Q
"RTN","PRCAACR",242,0)
 ;
"RTN","PRCAACR",243,0)
PSACRTP1 ; header for patient statement auto-correction report 1
"RTN","PRCAACR",244,0)
 W @IOF
"RTN","PRCAACR",245,0)
 S PAGE=PAGE+1
"RTN","PRCAACR",246,0)
 W "PAGE "_PAGE,?8,"AUTO-CORRECTED BILLS (SORTED BY AUTO-CORRECTION REASON)",?6
6,$$UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR",247,0)
 W !,DASH,!
"RTN","PRCAACR",248,0)
 W !,"AUTO-C REASON",?16,"DEBTOR",?36,"SSN",?42,"BILL NO.",?55,"TRANS NUM",?66,
"AUTO-C DATE"
"RTN","PRCAACR",249,0)
 W !,"--------------",?16,"------------------",?36,"----",?42,"-----------",?55
,"---------",?66,"------------"
"RTN","PRCAACR",250,0)
 Q 
"RTN","PRCAACR",251,0)
 ;
"RTN","PRCAACR",252,0)
PSACRTP2 ; header for patient statement auto-correction report 2
"RTN","PRCAACR",253,0)
 W @IOF
"RTN","PRCAACR",254,0)
 S PAGE=PAGE+1
"RTN","PRCAACR",255,0)
 W "PAGE "_PAGE,?8,"AUTO-CORRECTED BILLS (SORTED BY DEBTOR)",?66,$$UPPER^VALM1(
$$FMTE^XLFDT(DT))
"RTN","PRCAACR",256,0)
 W !,DASH,!
"RTN","PRCAACR",257,0)
 W !,"DEBTOR",?20,"BILL NO.",?33,"SSN",?39,"TRANS NUM",?50,"AUTO-C DATE",?64,"A
UTO-C REASON"
"RTN","PRCAACR",258,0)
 W !,"------------------",?20,"-----------",?33,"----",?39,"---------",?50,"---
---------",?64,"--------------"
"RTN","PRCAACR",259,0)
 Q
"RTN","PRCAACR",260,0)
 ;
"RTN","PRCAACR",261,0)
PSACRTP3 ; header for patient statement auto-correction report 3
"RTN","PRCAACR",262,0)
 W @IOF
"RTN","PRCAACR",263,0)
 S PAGE=PAGE+1
"RTN","PRCAACR",264,0)
 W "PAGE "_PAGE,?8,"AUTO-CORRECTED BILLS (SORTED BY BILL #)",?66,$$UPPER^VALM1(
$$FMTE^XLFDT(DT))
"RTN","PRCAACR",265,0)
 W !,DASH,!
"RTN","PRCAACR",266,0)
 W !,"BILL NO.",?13,"DEBTOR",?33,"SSN",?39,"TRANS NUM",?50,"AUTO-C DATE",?64,"A
UTO-C REASON"
"RTN","PRCAACR",267,0)
 W !,"-----------",?13,"------------------",?33,"----",?39,"---------",?50,"---
---------",?64,"--------------"
"RTN","PRCAACR",268,0)
 Q
"RTN","PRCAACR",269,0)
 ;
"RTN","PRCAACR",270,0)
PSACRTP4 ; header for patient statement auto-correction report 4
"RTN","PRCAACR",271,0)
 W @IOF
"RTN","PRCAACR",272,0)
 S PAGE=PAGE+1
"RTN","PRCAACR",273,0)
 W "PAGE "_PAGE,?8,"AUTO-CORRECTED BILLS (SORTED BY TRANSACTION NUMBER)",?66,$$
UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR",274,0)
 W !,DASH,!
"RTN","PRCAACR",275,0)
 W !,"TRANS NUM",?11,"DEBTOR",?31,"BILL NO.",?44,"SSN",?50,"AUTO-C DATE",?64,"A
UTO-C REASON"
"RTN","PRCAACR",276,0)
 W !,"---------",?11,"------------------",?31,"-----------",?44,"----",?50,"---
---------",?64,"--------------"
"RTN","PRCAACR",277,0)
 Q
"RTN","PRCAACR",278,0)
 ;
"RTN","PRCAACR",279,0)
PSACRTP5 ; header for patient statement auto-correction report 5
"RTN","PRCAACR",280,0)
 W @IOF
"RTN","PRCAACR",281,0)
 S PAGE=PAGE+1
"RTN","PRCAACR",282,0)
 W "PAGE "_PAGE,?8,"AUTO-CORRECTED BILLS (SORTED BY AUTO-CORRECTION DATE)",?66,
$$UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR",283,0)
 W !,DASH,!
"RTN","PRCAACR",284,0)
 W !,"AUTO-C DATE",?14,"DEBTOR",?34,"BILL NO.",?47,"SSN",?53,"TRANS NUM",?64,"A
UTO-C REASON"
"RTN","PRCAACR",285,0)
 W !,"------------",?14,"------------------",?34,"-----------",?47,"----",?53,"
---------",?64,"--------------"
"RTN","PRCAACR",286,0)
 Q
"RTN","PRCAACR",287,0)
 ;
"RTN","PRCAACR",288,0)
EXIT ;
"RTN","PRCAACR",289,0)
 Q
"RTN","PRCAACR1")
0^20^B151271441^n/a
"RTN","PRCAACR1",1,0)
PRCAACR1 ;ALBANY/BDB-PATIENT STATEMENTS AUTO-CORRECTION REPORT ;09/21/15 3:34 P
M
"RTN","PRCAACR1",2,0)
 ;;4.5;Accounts Receivable;**307,313**;Mar 20, 1995;Build 118
"RTN","PRCAACR1",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCAACR1",4,0)
 ;
"RTN","PRCAACR1",5,0)
 Q
"RTN","PRCAACR1",6,0)
 ;Print Report when Queued to P-MES
"RTN","PRCAACR1",7,0)
PRT ;
"RTN","PRCAACR1",8,0)
 U IO
"RTN","PRCAACR1",9,0)
 ; build array of transaction auto-corrected
"RTN","PRCAACR1",10,0)
 K ^TMP("PRCAACR1",$J)
"RTN","PRCAACR1",11,0)
 N DASH,PAGE
"RTN","PRCAACR1",12,0)
 S PAGE=0
"RTN","PRCAACR1",13,0)
 S DASH="",$P(DASH,"-",79)=""
"RTN","PRCAACR1",14,0)
 N PRCATSRT,PRCATN,PRCAACD,PRCAACR,PRCABN,PRCADATA,PRCADTR,PRCASSN,PRCAIEN,PRCA
ACTF,PRCATNTF,PRCATEMP
"RTN","PRCAACR1",15,0)
 S PRCATSRT=PRCABDT-.00001,PRCAIEN=0
"RTN","PRCAACR1",16,0)
 ; Loop through the specified date range
"RTN","PRCAACR1",17,0)
 F  S PRCATSRT=$O(^PRCA(433,"TACD",PRCATSRT)) Q:PRCATSRT=""!(PRCATSRT>PRCAEDT) 
 D
"RTN","PRCAACR1",18,0)
 .S PRCATN=""
"RTN","PRCAACR1",19,0)
 .; Loop through the transactions for the current date
"RTN","PRCAACR1",20,0)
 .F  S PRCATN=$O(^PRCA(433,"TACD",PRCATSRT,PRCATN)) Q:'PRCATN  D
"RTN","PRCAACR1",21,0)
 ..; Load associated data fields for report
"RTN","PRCAACR1",22,0)
 ..S PRCATNTF=PRCATN ; Transaction Number Ticket Flag
"RTN","PRCAACR1",23,0)
 ..S PRCABN=$P(^PRCA(433,PRCATN,0),U,2)
"RTN","PRCAACR1",24,0)
 ..S PRCADTR=$$GET1^DIQ(430,PRCABN_",",9) ; (#9) DEBTOR
"RTN","PRCAACR1",25,0)
 ..S PRCASSN=$G(^PRCA(430,PRCABN,0)) ; Load 0 Node
"RTN","PRCAACR1",26,0)
 ..S PRCASSN=$P(PRCASSN,U,9) ; get IEN of Debtor
"RTN","PRCAACR1",27,0)
 ..S PRCABN=$$GET1^DIQ(433,PRCATN_",",.03) ; (#.03) BILL NUMBER
"RTN","PRCAACR1",28,0)
 ..S PRCASSN=$$GET1^DIQ(340,PRCASSN_",",110) ; SSN
"RTN","PRCAACR1",29,0)
 ..S PRCASSN=$E(PRCASSN,6,9)
"RTN","PRCAACR1",30,0)
 ..S PRCAACD=$$GET1^DIQ(433,PRCATN_",",94,"I") ;(#94) AUTO-CORRECTION DATE
"RTN","PRCAACR1",31,0)
 ..S PRCAACR=$$GET1^DIQ(433,PRCATN_",",96) ;(#96) AUTO-CORRECTION TYPE OF ERROR
"RTN","PRCAACR1",32,0)
 ..S PRCAACR=$E(PRCAACR,1,14)
"RTN","PRCAACR1",33,0)
 ..S PRCAACTF=$$GET1^DIQ(433,PRCATN_",",97) ;(#97)AUTO-CORRECTION TICKET FLAG
"RTN","PRCAACR1",34,0)
 ..; If Ticket Flag is set, reset Transaction Number to null
"RTN","PRCAACR1",35,0)
 ..I PRCAACTF="YES" S PRCATNTF=""
"RTN","PRCAACR1",36,0)
 ..;
"RTN","PRCAACR1",37,0)
  ..; Store in ^TMP sorted by Auto-Correct Reason, Debtor and Bill Number #
"RTN","PRCAACR1",38,0)
 ..I PRCASORT=1 D  Q
"RTN","PRCAACR1",39,0)
 ...S ^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)=PRCAACR_U_PRCADTR_U_PRCABN_U_PR
CATNTF_U_PRCAACD_U_PRCASSN
"RTN","PRCAACR1",40,0)
 ..;
"RTN","PRCAACR1",41,0)
 ..; Store in ^TMP sorted by Debtor, Bill Number and Transaction #
"RTN","PRCAACR1",42,0)
 ..I PRCASORT=2 D  Q
"RTN","PRCAACR1",43,0)
 ...S ^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)=PRCADTR_U_PRCABN_U_PRCASSN_U_PRC
ATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR1",44,0)
 ..;
"RTN","PRCAACR1",45,0)
 ..; Store in ^TMP sorted by Bill Number, Debtor and Transaction #
"RTN","PRCAACR1",46,0)
 ..I PRCASORT=3 D  Q
"RTN","PRCAACR1",47,0)
 ...S ^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)=PRCABN_U_PRCADTR_U_PRCASSN_U_PRC
ATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR1",48,0)
 ..;
"RTN","PRCAACR1",49,0)
 ..; Store in ^TMP sorted by Transaction, Debtor and #Bill Number
"RTN","PRCAACR1",50,0)
 ..I PRCASORT=4 D  Q
"RTN","PRCAACR1",51,0)
 ...S ^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)=PRCATNTF_U_PRCADTR_U_PRCABN_U_PR
CASSN_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR1",52,0)
 ..;
"RTN","PRCAACR1",53,0)
 ..; Store in ^TMP sorted by Auto-Correct Date, Debtor, #Bill Number and Transa
ction Number
"RTN","PRCAACR1",54,0)
 ..I PRCASORT=5 D  Q
"RTN","PRCAACR1",55,0)
 ...S ^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)=PRCAACD_U_PRCADTR_U_PRCA
BN_U_PRCASSN_U_PRCATNTF_U_PRCAACR
"RTN","PRCAACR1",56,0)
 ..Q
"RTN","PRCAACR1",57,0)
 ;
"RTN","PRCAACR1",58,0)
 ; Display Auto-Correct data sorted by Bill Number
"RTN","PRCAACR1",59,0)
 I PRCASORT=1 D
"RTN","PRCAACR1",60,0)
 .; Print Header
"RTN","PRCAACR1",61,0)
 .D PSACRTP1
"RTN","PRCAACR1",62,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)=PRCAACR_U_PRCADTR_U_P
RCABN_U_PRCATNTF_U_PRCAACD_U_PRCASSN
"RTN","PRCAACR1",63,0)
 .S PRCAACR=""
"RTN","PRCAACR1",64,0)
 .N Y
"RTN","PRCAACR1",65,0)
 .F  S PRCAACR=$O(^TMP("PRCAACR",$J,PRCAACR)) Q:PRCAACR=""  D
"RTN","PRCAACR1",66,0)
 ..S PRCADTR=""
"RTN","PRCAACR1",67,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCAACR,PRCADTR)) Q:PRCADTR=""  D
"RTN","PRCAACR1",68,0)
 ...S PRCABN=""
"RTN","PRCAACR1",69,0)
 ...F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)) Q:'PRCABN  D
"RTN","PRCAACR1",70,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCAACR,PRCADTR,PRCABN)
"RTN","PRCAACR1",71,0)
 ....S Y=$P(PRCADATA,U,5)
"RTN","PRCAACR1",72,0)
 ....D DD^%DT
"RTN","PRCAACR1",73,0)
 ....S $P(PRCADATA,U,5)=Y
"RTN","PRCAACR1",74,0)
 ....S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",75,0)
 ....; Add Auto-Correct Reason
"RTN","PRCAACR1",76,0)
 ....S PRCATEMP=$E($P(PRCADATA,U,1),1,14),$E(PRCATEMP,16)=" "
"RTN","PRCAACR1",77,0)
 ....; Add 18 chars of Debtor's name
"RTN","PRCAACR1",78,0)
 ....S PRCATEMP=PRCATEMP_$E($P(PRCADATA,U,2),1,18),$E(PRCATEMP,36)=" "
"RTN","PRCAACR1",79,0)
 ....; Add SSN
"RTN","PRCAACR1",80,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,6),$E(PRCATEMP,42)=" "
"RTN","PRCAACR1",81,0)
 ....; Add Bill Number
"RTN","PRCAACR1",82,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,3),$E(PRCATEMP,55)=" "
"RTN","PRCAACR1",83,0)
 ....; Add Transaction Number
"RTN","PRCAACR1",84,0)
 ....S PRCATEMP=PRCATEMP_$J($P(PRCADATA,U,4),9),$E(PRCATEMP,66)=" "
"RTN","PRCAACR1",85,0)
 ....; Add Auto-Correct Date
"RTN","PRCAACR1",86,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,5),$E(PRCATEMP,74)=" "
"RTN","PRCAACR1",87,0)
 ....S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCATEMP
"RTN","PRCAACR1",88,0)
 ....Q
"RTN","PRCAACR1",89,0)
 ;
"RTN","PRCAACR1",90,0)
 ; Store in ^TMP sorted by Debtor, Bill Number and Transaction #
"RTN","PRCAACR1",91,0)
 I PRCASORT=2 D
"RTN","PRCAACR1",92,0)
 .; Print Header
"RTN","PRCAACR1",93,0)
 .D PSACRTP2
"RTN","PRCAACR1",94,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)=PRCADTR_U_PRCABN_U_PRC
ASSN_U_PRCATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR1",95,0)
 .S PRCADTR=""
"RTN","PRCAACR1",96,0)
 .F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCADTR)) Q:PRCADTR=""  D
"RTN","PRCAACR1",97,0)
 ..S PRCABN=""
"RTN","PRCAACR1",98,0)
 ..F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCADTR,PRCABN)) Q:'PRCABN  D
"RTN","PRCAACR1",99,0)
 ...S PRCATN=""
"RTN","PRCAACR1",100,0)
 ...F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)) Q:'PRCATN  D
"RTN","PRCAACR1",101,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCADTR,PRCABN,PRCATN)
"RTN","PRCAACR1",102,0)
 ....S $P(PRCADATA,U,5)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR1",103,0)
 ....S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",104,0)
 ....; Add 18 chars of Debtor's name
"RTN","PRCAACR1",105,0)
 ....S PRCATEMP=$E($P(PRCADATA,U,1),1,18),$E(PRCATEMP,20)=" "
"RTN","PRCAACR1",106,0)
 ....; Add Bill Number
"RTN","PRCAACR1",107,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,2),$E(PRCATEMP,33)=" "
"RTN","PRCAACR1",108,0)
 ....; Add SSN
"RTN","PRCAACR1",109,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,3),$E(PRCATEMP,39)=" "
"RTN","PRCAACR1",110,0)
 ....; Add Transaction Number
"RTN","PRCAACR1",111,0)
 ....S PRCATEMP=PRCATEMP_$J($P(PRCADATA,U,4),9),$E(PRCATEMP,50)=" "
"RTN","PRCAACR1",112,0)
 ....; Add Auto-Correct Date
"RTN","PRCAACR1",113,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,5),$E(PRCATEMP,64)=" "
"RTN","PRCAACR1",114,0)
 ....; Add Auto-Correct Reason
"RTN","PRCAACR1",115,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,6)
"RTN","PRCAACR1",116,0)
 ....S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCATEMP
"RTN","PRCAACR1",117,0)
 ....Q
"RTN","PRCAACR1",118,0)
 ;
"RTN","PRCAACR1",119,0)
 ; Store in ^TMP sorted by Auto-Correct Date, Debtor, Bill Number and Transacti
on #
"RTN","PRCAACR1",120,0)
 I PRCASORT=3 D
"RTN","PRCAACR1",121,0)
 .; Print Header
"RTN","PRCAACR1",122,0)
 .D PSACRTP3
"RTN","PRCAACR1",123,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)=PRCABN_U_PRCADTR_U_PRC
ASSN_U_PRCATNTF_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR1",124,0)
 .S PRCABN=""
"RTN","PRCAACR1",125,0)
 .F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCABN)) Q:'PRCABN  D
"RTN","PRCAACR1",126,0)
 ..S PRCADTR=""
"RTN","PRCAACR1",127,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCABN,PRCADTR)) Q:PRCADTR=""  D
"RTN","PRCAACR1",128,0)
 ...S PRCATN=""
"RTN","PRCAACR1",129,0)
 ...F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)) Q:'PRCATN  D
"RTN","PRCAACR1",130,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCABN,PRCADTR,PRCATN)
"RTN","PRCAACR1",131,0)
 ....S $P(PRCADATA,U,5)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR1",132,0)
 ....S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",133,0)
 ....; Add Bill Number
"RTN","PRCAACR1",134,0)
 ....S PRCATEMP=$P(PRCADATA,U,1),$E(PRCATEMP,13)=" "
"RTN","PRCAACR1",135,0)
 ....; Add 18 chars of Debtor's name
"RTN","PRCAACR1",136,0)
 ....S PRCATEMP=PRCATEMP_$E($P(PRCADATA,U,2),1,18),$E(PRCATEMP,33)=" "
"RTN","PRCAACR1",137,0)
 ....; Add SSN
"RTN","PRCAACR1",138,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,3),$E(PRCATEMP,39)=" "
"RTN","PRCAACR1",139,0)
 ....; Add Transaction Number
"RTN","PRCAACR1",140,0)
 ....S PRCATEMP=PRCATEMP_$J($P(PRCADATA,U,4),9),$E(PRCATEMP,50)=" "
"RTN","PRCAACR1",141,0)
 ....; Add Auto-Correct Date
"RTN","PRCAACR1",142,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,5),$E(PRCATEMP,64)=" "
"RTN","PRCAACR1",143,0)
 ....; Add Auto-Correct Reason
"RTN","PRCAACR1",144,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,6)
"RTN","PRCAACR1",145,0)
 ....S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCATEMP
"RTN","PRCAACR1",146,0)
 ....Q
"RTN","PRCAACR1",147,0)
 ;
"RTN","PRCAACR1",148,0)
 ; Store in ^TMP sorted by Transaction, Debtor and #Bill Number
"RTN","PRCAACR1",149,0)
 I PRCASORT=4 D
"RTN","PRCAACR1",150,0)
 .; Print Header
"RTN","PRCAACR1",151,0)
 .D PSACRTP4
"RTN","PRCAACR1",152,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)=PRCATNTF_U_PRCADTR_U_P
RCABN_U_PRCASSN_U_PRCAACD_U_PRCAACR
"RTN","PRCAACR1",153,0)
 .S PRCATN=""
"RTN","PRCAACR1",154,0)
 .F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCATN)) Q:'PRCATN  D
"RTN","PRCAACR1",155,0)
 ..S PRCADTR=""
"RTN","PRCAACR1",156,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCATN,PRCADTR)) Q:PRCADTR=""  D
"RTN","PRCAACR1",157,0)
 ...S PRCABN=""
"RTN","PRCAACR1",158,0)
 ...F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)) Q:'PRCABN  D
"RTN","PRCAACR1",159,0)
 ....S PRCADATA=^TMP("PRCAACR",$J,PRCATN,PRCADTR,PRCABN)
"RTN","PRCAACR1",160,0)
 ....S $P(PRCADATA,U,5)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR1",161,0)
 ....S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",162,0)
 ....; Add Transaction Number
"RTN","PRCAACR1",163,0)
 ....S PRCATEMP=$J($P(PRCADATA,U,1),9),$E(PRCATEMP,11)=" "
"RTN","PRCAACR1",164,0)
 ....; Add 18 chars of Debtor's name
"RTN","PRCAACR1",165,0)
 ....S PRCATEMP=PRCATEMP_$E($P(PRCADATA,U,2),1,18),$E(PRCATEMP,31)=" "
"RTN","PRCAACR1",166,0)
 ....; Add Bill Number
"RTN","PRCAACR1",167,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,3),$E(PRCATEMP,44)=" "
"RTN","PRCAACR1",168,0)
 ....; Add SSN
"RTN","PRCAACR1",169,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,4),$E(PRCATEMP,50)=" "
"RTN","PRCAACR1",170,0)
 ....; Add Auto-Correct Date
"RTN","PRCAACR1",171,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,5),$E(PRCATEMP,64)=" "
"RTN","PRCAACR1",172,0)
 ....; Add Auto-Correct Reason
"RTN","PRCAACR1",173,0)
 ....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,6)
"RTN","PRCAACR1",174,0)
 ....S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCATEMP
"RTN","PRCAACR1",175,0)
 ....Q
"RTN","PRCAACR1",176,0)
 ;
"RTN","PRCAACR1",177,0)
 ; Display Auto-Correct data sorted by Auto-Correct Reason
"RTN","PRCAACR1",178,0)
 I PRCASORT=5 D
"RTN","PRCAACR1",179,0)
 .; Print Header
"RTN","PRCAACR1",180,0)
 .D PSACRTP5
"RTN","PRCAACR1",181,0)
 .; Data Layout ^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)=PRCAACD_U_PRCA
DTR_U_PRCABN_U_PRCASSN_U_PRCATNTF_U_PRCAACR
"RTN","PRCAACR1",182,0)
 .S PRCAACD=""
"RTN","PRCAACR1",183,0)
 .F  S PRCAACD=$O(^TMP("PRCAACR",$J,PRCAACD)) Q:PRCAACD=""  D
"RTN","PRCAACR1",184,0)
 ..S PRCADTR=""
"RTN","PRCAACR1",185,0)
 ..F  S PRCADTR=$O(^TMP("PRCAACR",$J,PRCAACD,PRCADTR)) Q:PRCADTR=""  D
"RTN","PRCAACR1",186,0)
 ...S PRCABN=""
"RTN","PRCAACR1",187,0)
 ...F  S PRCABN=$O(^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN)) Q:'PRCABN  D
"RTN","PRCAACR1",188,0)
 ....S PRCATN=""
"RTN","PRCAACR1",189,0)
 ....F  S PRCATN=$O(^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)) Q:'PRCATN
  D
"RTN","PRCAACR1",190,0)
 .....S PRCADATA=^TMP("PRCAACR",$J,PRCAACD,PRCADTR,PRCABN,PRCATN)
"RTN","PRCAACR1",191,0)
 .....S $P(PRCADATA,U,1)=$$GET1^DIQ(433,PRCATN_",",94)
"RTN","PRCAACR1",192,0)
 .....S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",193,0)
 .....; Add Auto-Correct Date
"RTN","PRCAACR1",194,0)
 .....S PRCATEMP=$P(PRCADATA,U,1),$E(PRCATEMP,14)=" "
"RTN","PRCAACR1",195,0)
 .....; Add 18 chars of Debtor's name
"RTN","PRCAACR1",196,0)
 .....S PRCATEMP=PRCATEMP_$E($P(PRCADATA,U,2),1,18),$E(PRCATEMP,34)=" "
"RTN","PRCAACR1",197,0)
 .....; Add Bill Number
"RTN","PRCAACR1",198,0)
 .....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,3),$E(PRCATEMP,47)=" "
"RTN","PRCAACR1",199,0)
 .....; Add SSN
"RTN","PRCAACR1",200,0)
 .....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,4),$E(PRCATEMP,53)=" "
"RTN","PRCAACR1",201,0)
 .....; Add Transaction Number
"RTN","PRCAACR1",202,0)
 .....S PRCATEMP=PRCATEMP_$J($P(PRCADATA,U,5),9),$E(PRCATEMP,64)=" "
"RTN","PRCAACR1",203,0)
 .....; Add Auto-Correct Reason
"RTN","PRCAACR1",204,0)
 .....S PRCATEMP=PRCATEMP_$P(PRCADATA,U,6)
"RTN","PRCAACR1",205,0)
 .....S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCATEMP
"RTN","PRCAACR1",206,0)
 .....Q 
"RTN","PRCAACR1",207,0)
 ;
"RTN","PRCAACR1",208,0)
 ; Send MailMan message with No Forward
"RTN","PRCAACR1",209,0)
 N XMTO,XMSUBJ,XMBODY,XMINSTR,XMDUZ
"RTN","PRCAACR1",210,0)
 I PRCASORT=1 S XMSUBJ="AUTO-CORRECTED BILLS (SORTED BY AUTO-CORRECTION REASON)
"
"RTN","PRCAACR1",211,0)
 I PRCASORT=2 S XMSUBJ="AUTO-CORRECTED BILLS (SORTED BY DEBTOR)"
"RTN","PRCAACR1",212,0)
 I PRCASORT=3 S XMSUBJ="AUTO-CORRECTED BILLS (SORTED BY BILL #)"
"RTN","PRCAACR1",213,0)
 I PRCASORT=4 S XMSUBJ="AUTO-CORRECTED BILLS (SORTED BY TRANSACTION NUMBER)"
"RTN","PRCAACR1",214,0)
 I PRCASORT=5 S XMSUBJ="AUTO-CORRECTED BILLS (SORTED BY AUTO-CORRECTION DATE)"
"RTN","PRCAACR1",215,0)
 S XMTO(DUZ)=""
"RTN","PRCAACR1",216,0)
 S XMBODY="^TMP(""PRCAACR1"",$J)"
"RTN","PRCAACR1",217,0)
 S XMINSTR("FLAGS")="X"
"RTN","PRCAACR1",218,0)
 S XMDUZ=DUZ
"RTN","PRCAACR1",219,0)
 D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,.XMINSTR)
"RTN","PRCAACR1",220,0)
 D HOME^%ZIS
"RTN","PRCAACR1",221,0)
 K IO("Q"),POP
"RTN","PRCAACR1",222,0)
 K ^TMP("PRCAACR",$J)
"RTN","PRCAACR1",223,0)
 K ^TMP("PRCAACR1",$J)
"RTN","PRCAACR1",224,0)
 K PRCABDT,PRCAEDT,PRCASORT
"RTN","PRCAACR1",225,0)
 Q
"RTN","PRCAACR1",226,0)
 ;
"RTN","PRCAACR1",227,0)
PSACRTP1 ; header for patient statement auto-correction report 1
"RTN","PRCAACR1",228,0)
 S PAGE=PAGE+1
"RTN","PRCAACR1",229,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",230,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",231,0)
 S PRCADATA="PAGE "_PAGE,$E(PRCADATA,9)=""
"RTN","PRCAACR1",232,0)
 S PRCADATA=PRCADATA_"AUTO-CORRECTED BILLS (SORTED BY AUTO-CORRECTION REASON)"
"RTN","PRCAACR1",233,0)
 S $E(PRCADATA,66)="",PRCADATA=PRCADATA_$$UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR1",234,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",235,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",236,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",237,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=DASH
"RTN","PRCAACR1",238,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",239,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",240,0)
 S PRCADATA="AUTO-C REASON   DEBTOR              SSN   BILL NO.     TRANS NUM  
AUTO-C DATE"
"RTN","PRCAACR1",241,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",242,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",243,0)
 S PRCADATA="--------------  ------------------  ----  -----------  ---------  
------------"
"RTN","PRCAACR1",244,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",245,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",246,0)
 Q
"RTN","PRCAACR1",247,0)
 ;
"RTN","PRCAACR1",248,0)
PSACRTP2 ; header for patient statement auto-correction report 2
"RTN","PRCAACR1",249,0)
 S PAGE=PAGE+1
"RTN","PRCAACR1",250,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",251,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",252,0)
 S PRCADATA="PAGE "_PAGE,$E(PRCADATA,9)=""
"RTN","PRCAACR1",253,0)
 S PRCADATA=PRCADATA_"AUTO-CORRECTED BILLS (SORTED BY DEBTOR)"
"RTN","PRCAACR1",254,0)
 S $E(PRCADATA,66)="",PRCADATA=PRCADATA_$$UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR1",255,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",256,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",257,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",258,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=DASH
"RTN","PRCAACR1",259,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",260,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",261,0)
 S PRCADATA="DEBTOR              BILL NO.     SSN   TRANS NUM  AUTO-C DATE   AU
TO-C REASON"
"RTN","PRCAACR1",262,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",263,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",264,0)
 S PRCADATA="------------------  -----------  ----  ---------  ------------  --
------------"
"RTN","PRCAACR1",265,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",266,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",267,0)
 Q
"RTN","PRCAACR1",268,0)
 ;
"RTN","PRCAACR1",269,0)
PSACRTP3 ; header for patient statement auto-correction report 3
"RTN","PRCAACR1",270,0)
 S PAGE=PAGE+1
"RTN","PRCAACR1",271,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",272,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",273,0)
 S PRCADATA="PAGE "_PAGE,$E(PRCADATA,9)=""
"RTN","PRCAACR1",274,0)
 S PRCADATA=PRCADATA_"AUTO-CORRECTED BILLS (SORTED BY BILL #)"
"RTN","PRCAACR1",275,0)
 S $E(PRCADATA,66)="",PRCADATA=PRCADATA_$$UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR1",276,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",277,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",278,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",279,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=DASH
"RTN","PRCAACR1",280,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",281,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",282,0)
 S PRCADATA="BILL NO.     DEBTOR              SSN   TRANS NUM  AUTO-C DATE   AU
TO-C REASON"
"RTN","PRCAACR1",283,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",284,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",285,0)
 S PRCADATA="-----------  ------------------  ----  ---------  ------------  --
------------"
"RTN","PRCAACR1",286,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",287,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",288,0)
 Q
"RTN","PRCAACR1",289,0)
 ;
"RTN","PRCAACR1",290,0)
PSACRTP4 ; header for patient statement auto-correction report 4
"RTN","PRCAACR1",291,0)
 S PAGE=PAGE+1
"RTN","PRCAACR1",292,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",293,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",294,0)
 S PRCADATA="PAGE "_PAGE,$E(PRCADATA,9)=""
"RTN","PRCAACR1",295,0)
 S PRCADATA=PRCADATA_"AUTO-CORRECTED BILLS (SORTED BY TRANSACTION NUMBER)"
"RTN","PRCAACR1",296,0)
 S $E(PRCADATA,66)="",PRCADATA=PRCADATA_$$UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR1",297,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",298,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",299,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",300,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=DASH
"RTN","PRCAACR1",301,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",302,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",303,0)
 S PRCADATA="TRANS NUM  DEBTOR              BILL NO.     SSN   AUTO-C DATE   AU
TO-C REASON"
"RTN","PRCAACR1",304,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",305,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",306,0)
 S PRCADATA="---------  ------------------  -----------  ----  ------------  --
------------"
"RTN","PRCAACR1",307,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",308,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",309,0)
 Q
"RTN","PRCAACR1",310,0)
 ;
"RTN","PRCAACR1",311,0)
PSACRTP5 ; header for patient statement auto-correction report 5
"RTN","PRCAACR1",312,0)
 S PAGE=PAGE+1
"RTN","PRCAACR1",313,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",314,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",315,0)
 S PRCADATA="PAGE "_PAGE,$E(PRCADATA,9)=""
"RTN","PRCAACR1",316,0)
 S PRCADATA=PRCADATA_"AUTO-CORRECTED BILLS (SORTED BY AUTO-CORRECTION DATE)"
"RTN","PRCAACR1",317,0)
 S $E(PRCADATA,66)="",PRCADATA=PRCADATA_$$UPPER^VALM1($$FMTE^XLFDT(DT))
"RTN","PRCAACR1",318,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",319,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",320,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",321,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=DASH
"RTN","PRCAACR1",322,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",323,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=""
"RTN","PRCAACR1",324,0)
 S PRCADATA="AUTO-C DATE   DEBTOR              BILL NO.     SSN   TRANS NUM  AU
TO-C REASON"
"RTN","PRCAACR1",325,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",326,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",327,0)
 S PRCADATA="------------  ------------------  -----------  ----  ---------  --
------------"
"RTN","PRCAACR1",328,0)
 S PRCAIEN=PRCAIEN+1
"RTN","PRCAACR1",329,0)
 S ^TMP("PRCAACR1",$J,PRCAIEN)=PRCADATA
"RTN","PRCAACR1",330,0)
 Q
"RTN","PRCAACR1",331,0)
 ;
"RTN","PRCAACR1",332,0)
EXIT ;
"RTN","PRCAACR1",333,0)
 Q
"RTN","PRCACPS1")
0^6^B19128158^n/a
"RTN","PRCACPS1",1,0)
PRCACPS1 ;ALBANY/BDB-PATIENT STATEMENTS UPDATE ;03/25/16 3:34 PM
"RTN","PRCACPS1",2,0)
 ;;4.5;Accounts Receivable;**313**;Mar 20, 1995;Build 118
"RTN","PRCACPS1",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","PRCACPS1",4,0)
 ;
"RTN","PRCACPS1",5,0)
 Q
"RTN","PRCACPS1",6,0)
 ;
"RTN","PRCACPS1",7,0)
ENTER ;called by the cbs nightly account update program option
"RTN","PRCACPS1",8,0)
 N ZTDTH,ZTIO,ZTDESC,ZTRTN,ZTSK,ZTSAVE,RCFULL
"RTN","PRCACPS1",9,0)
 S RCFULL=1 ;run the full debtor list
"RTN","PRCACPS1",10,0)
 W !,"Queue the patient statement update program to run:"
"RTN","PRCACPS1",11,0)
 S ZTDESC="Consolidated Billing Statement Update"
"RTN","PRCACPS1",12,0)
 S ZTRTN="DEBTOR^PRCACPS1",ZTIO="",ZTSAVE("RCFULL")=""
"RTN","PRCACPS1",13,0)
 D ^%ZTLOAD
"RTN","PRCACPS1",14,0)
 Q
"RTN","PRCACPS1",15,0)
 ;
"RTN","PRCACPS1",16,0)
DEBTOR ;called by rccpcbj
"RTN","PRCACPS1",17,0)
 N DEBTOR,X,DEBTOR0,DEBTOR1,DEBTOR7,CBSSTOT,BALDT
"RTN","PRCACPS1",18,0)
 K ^XTMP("RCCBSS",$J)
"RTN","PRCACPS1",19,0)
 S ^XTMP("RCCBSS",$J,0)=$$FMADD^XLFDT(DT,3)_"^"_DT
"RTN","PRCACPS1",20,0)
 S DEBTOR=0
"RTN","PRCACPS1",21,0)
 F  S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N  D
"RTN","PRCACPS1",22,0)
 .S DEBTOR0=$G(^RCD(340,DEBTOR,0)),DEBTOR1=$G(^(1)),DEBTOR7=$G(^(7)),BALDT=""
"RTN","PRCACPS1",23,0)
 .Q:$P(DEBTOR0,"^")'["DPT("
"RTN","PRCACPS1",24,0)
 .I +$$GETICN^MPIF001(+DEBTOR0)<0 Q  ;quit if no icn
"RTN","PRCACPS1",25,0)
 .S BALDT=$$BILLS(DEBTOR) Q:$P(BALDT,U,2)=9999999
"RTN","PRCACPS1",26,0)
 .D RECPD
"RTN","PRCACPS1",27,0)
 D COMPILE
"RTN","PRCACPS1",28,0)
 K ^XTMP("RCCBSS",$J)
"RTN","PRCACPS1",29,0)
 Q
"RTN","PRCACPS1",30,0)
 ;
"RTN","PRCACPS1",31,0)
RECPD(BILL) ;add a new account update
"RTN","PRCACPS1",32,0)
 N REC,RCDFN
"RTN","PRCACPS1",33,0)
 S RCDFN=+DEBTOR0
"RTN","PRCACPS1",34,0)
 S REC="PD^"_$$GETICN^MPIF001(RCDFN)_"^"
"RTN","PRCACPS1",35,0)
 S REC=REC_$$SITE^RCMSITE_$$UP^XLFSTR($S(($$SSN^RCFN01(DEBTOR)]"")&($$NAM^RCFN0
1(DEBTOR)]""):$TR($E($$SSN^RCFN01(DEBTOR),1,9)_$E($P($$NAM^RCFN01(DEBTOR),","),
1,5)," ",""),1:""))_"^"
"RTN","PRCACPS1",36,0)
 S REC=REC_RCDFN_"^"
"RTN","PRCACPS1",37,0)
 S BALDT=$$BILLS(DEBTOR)
"RTN","PRCACPS1",38,0)
 S CBSSTOT=+$P(DEBTOR7,U,6)
"RTN","PRCACPS1",39,0)
 I '$G(RCFULL) Q:CBSSTOT=+BALDT
"RTN","PRCACPS1",40,0)
 S $P(^RCD(340,DEBTOR,7),U,6)=+BALDT
"RTN","PRCACPS1",41,0)
 S REC=REC_$$HEX(+BALDT)_"^"_$P(BALDT,U,2)_"^|"
"RTN","PRCACPS1",42,0)
 S ^XTMP("RCCBSS",$J,DEBTOR)=REC
"RTN","PRCACPS1",43,0)
 Q
"RTN","PRCACPS1",44,0)
 ;
"RTN","PRCACPS1",45,0)
BILLS(DEBTOR) ;get oldest bill date
"RTN","PRCACPS1",46,0)
 N BALTOT,BILL,BN0,PRPDT,OLDDT
"RTN","PRCACPS1",47,0)
 S BILL=""
"RTN","PRCACPS1",48,0)
 S BALTOT=0,OLDDT=9999999
"RTN","PRCACPS1",49,0)
 F  S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N  D
"RTN","PRCACPS1",50,0)
 .Q:$D(^PRCA(430,"TCSP",BILL))  ;cs check
"RTN","PRCACPS1",51,0)
 .S BN0=$G(^PRCA(430,BILL,0))
"RTN","PRCACPS1",52,0)
 .I $P(BN0,U,8)'=16 Q  ;not active
"RTN","PRCACPS1",53,0)
 .S BALTOT=BALTOT+$$GET1^DIQ(430,BILL,11)
"RTN","PRCACPS1",54,0)
 .S PRPDT=$P(^PRCA(430,BILL,0),U,10) I +PRPDT,OLDDT>PRPDT S OLDDT=PRPDT
"RTN","PRCACPS1",55,0)
 Q BALTOT_U_$S(OLDDT'=9999999:$$DTMDY(OLDDT),1:"")
"RTN","PRCACPS1",56,0)
 ;
"RTN","PRCACPS1",57,0)
COMPILE ;
"RTN","PRCACPS1",58,0)
 N RCMSG,DCNTR,REC,RECC,AMOUNT,RCNTR,ACTION,SEQ,SEQTOT
"RTN","PRCACPS1",59,0)
 S DCNTR=0,REC=1,RECC=0,AMOUNT=0,SEQ=1,SEQTOT=0
"RTN","PRCACPS1",60,0)
 F  S DCNTR=$O(^XTMP("RCCBSS",$J,DCNTR)) S:+DCNTR'>0 SEQTOT=SEQ Q:+DCNTR'>0  D
"RTN","PRCACPS1",61,0)
 .I REC>450 D
"RTN","PRCACPS1",62,0)
 ..S ^XTMP("RCCBSS",$J,"BUILD",SEQ,REC)=^XTMP("RCCBSS",$J,"BUILD",SEQ,REC)_"~"
"RTN","PRCACPS1",63,0)
 ..D HEADER
"RTN","PRCACPS1",64,0)
 ..D AITCMSG
"RTN","PRCACPS1",65,0)
 ..S REC=0,SEQ=SEQ+1
"RTN","PRCACPS1",66,0)
 ..Q
"RTN","PRCACPS1",67,0)
 .S REC=REC+1
"RTN","PRCACPS1",68,0)
 .S ^XTMP("RCCBSS",$J,"BUILD",SEQ,REC)=^XTMP("RCCBSS",$J,DCNTR)
"RTN","PRCACPS1",69,0)
 .Q
"RTN","PRCACPS1",70,0)
 Q:'$D(^XTMP("RCCBSS",$J,"BUILD",SEQ))
"RTN","PRCACPS1",71,0)
 S ^XTMP("RCCBSS",$J,"BUILD",SEQ,REC)=^XTMP("RCCBSS",$J,"BUILD",SEQ,REC)_"~"
"RTN","PRCACPS1",72,0)
 D HEADER
"RTN","PRCACPS1",73,0)
 D AITCMSG
"RTN","PRCACPS1",74,0)
 Q
"RTN","PRCACPS1",75,0)
 ;
"RTN","PRCACPS1",76,0)
AITCMSG ;
"RTN","PRCACPS1",77,0)
 N XMY,XMDUZ,XMSUB,XMTEXT
"RTN","PRCACPS1",78,0)
 S SITE=$E($$SITE^RCMSITE(),1,3)
"RTN","PRCACPS1",79,0)
 S XMDUZ="AR PACKAGE"
"RTN","PRCACPS1",80,0)
 ;S XMY("XXX@Q-CPTURL        ")=""
"RTN","PRCACPS1",81,0)
 S X=$O(^RCT(349.1,"B","PU",0))
"RTN","PRCACPS1",82,0)
 I X,$P($G(^RCT(349.1,+X,0)),"^",3) S X=$P($G(^RCT(349.1,+X,3)),"^")_"@"_$P($G(
^RCT(349.1,+X,3)),"^",3) S:$P(X,"@",2)]"" XMY(X)=""
"RTN","PRCACPS1",83,0)
 S XMY("G.PRCACPS")=""
"RTN","PRCACPS1",84,0)
 S XMSUB=SITE_"/CBSS TRANSMISSION/BATCH#: "_SEQ
"RTN","PRCACPS1",85,0)
 S XMTEXT="^XTMP(""RCCBSS"","_$J_",""BUILD"","_SEQ_","
"RTN","PRCACPS1",86,0)
 D ^XMD
"RTN","PRCACPS1",87,0)
 K ^XTMP("RCCBSS",$J,"BUILD",SEQ)
"RTN","PRCACPS1",88,0)
 Q
"RTN","PRCACPS1",89,0)
 ;
"RTN","PRCACPS1",90,0)
HEADER ;
"RTN","PRCACPS1",91,0)
 ;increment batch sequence number, build new header
"RTN","PRCACPS1",92,0)
 N RCMSG,SITE
"RTN","PRCACPS1",93,0)
 S SITE=$E($$SITE^RCMSITE(),1,3)
"RTN","PRCACPS1",94,0)
 S RCMSG="PU"_"^"_SEQ_"^"_SEQTOT_"^"_(REC-1)_"^"_SITE_"^"_$$DTMDY(DT)_"^|"
"RTN","PRCACPS1",95,0)
 S ^XTMP("RCCBSS",$J,"BUILD",SEQ,1)=RCMSG
"RTN","PRCACPS1",96,0)
 Q
"RTN","PRCACPS1",97,0)
 ;
"RTN","PRCACPS1",98,0)
HEX(AMT) ;sets up amount formatted as 999999999V99S w/no leading blanks and tra
iling sign
"RTN","PRCACPS1",99,0)
 I $G(AMT)'?.1"-".N.1".".N S AMT="" G Q
"RTN","PRCACPS1",100,0)
 S AMT=$TR($J(AMT,9,2)," ","")
"RTN","PRCACPS1",101,0)
 I $E(AMT)="-" S AMT=$E(AMT,2,99)_$E(AMT,1)
"RTN","PRCACPS1",102,0)
 E  S AMT=AMT_"+"
"RTN","PRCACPS1",103,0)
 S AMT=$P(AMT,".")_$P(AMT,".",2)
"RTN","PRCACPS1",104,0)
Q Q AMT
"RTN","PRCACPS1",105,0)
 ;
"RTN","PRCACPS1",106,0)
DTMDY(DAT) ;Changes date from fm to mmddyyyy format
"RTN","PRCACPS1",107,0)
 N YR
"RTN","PRCACPS1",108,0)
 I '$G(DAT) G QDAT
"RTN","PRCACPS1",109,0)
 S YR=$E(($E(DAT,1,3)+1700),1,2)
"RTN","PRCACPS1",110,0)
 Q $E(DAT,4,5)_$E(DAT,6,7)_$G(YR)_$E(DAT,2,3)
"RTN","PRCACPS1",111,0)
QDAT Q ""
"RTN","PRCACPS1",112,0)
 ;
"RTN","PRCACPS1",113,0)
BLANK(X) ;returns 'x' blank spaces
"RTN","PRCACPS1",114,0)
 N BLANK
"RTN","PRCACPS1",115,0)
 S BLANK="",$P(BLANK," ",X+1)=""
"RTN","PRCACPS1",116,0)
 Q BLANK
"RTN","PRCACPS1",117,0)
 ;
"RTN","PRCACPS1",118,0)
RJZF(X,Y) ;right justify zero fill width Y
"RTN","PRCACPS1",119,0)
 S X=$E("000000000000",1,Y-$L(X))_X
"RTN","PRCACPS1",120,0)
 Q X
"RTN","PRCACPS1",121,0)
 ;
"RTN","PRCACPS1",122,0)
LJSF(X,Y) ;left justified space filled
"RTN","PRCACPS1",123,0)
 S X=$E(X,1,Y)
"RTN","PRCACPS1",124,0)
 S X=X_$$BLANK(Y-$L(X))
"RTN","PRCACPS1",125,0)
 Q X
"RTN","PRCACPS1",126,0)
 ;
"RTN","PRCACPS1",127,0)
JD() ; returns today's Julian date YDOY
"RTN","PRCACPS1",128,0)
 N XMDDD,XMNOW,XMDT
"RTN","PRCACPS1",129,0)
 S XMNOW=$$NOW^XLFDT
"RTN","PRCACPS1",130,0)
 S XMDT=$E(XMNOW,1,7)
"RTN","PRCACPS1",131,0)
 S XMDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(XMDT,$E(XMDT,1,3)_"0101",1)+1,3,"0")
"RTN","PRCACPS1",132,0)
 Q $E(DT,3)_XMDDD
"RTN","PRCACPS1",133,0)
 ;
"RTN","PRCACPS1",134,0)
AMOUNT(X) ;changes amount to zero filled, right justified
"RTN","PRCACPS1",135,0)
 S:X<0 X=-X
"RTN","PRCACPS1",136,0)
 S X=$TR($J(X,0,2),".")
"RTN","PRCACPS1",137,0)
 S X=$E("000000000000",1,14-$L(X))_X
"RTN","PRCACPS1",138,0)
 Q X
"RTN","PRCACPS1",139,0)
 ;
"RTN","PRCAG")
0^17^B48028538^B22016512
"RTN","PRCAG",1,0)
PRCAG ;WASH-ISC@ALTOONA,PA/CMS-Reprint Statement/Letter Option Entries ;8/23/93
  2:42 PM
"RTN","PRCAG",2,0)
V ;;4.5;Accounts Receivable;**149,165,198,313**;Mar 20, 1995;Build 118
"RTN","PRCAG",3,0)
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
"RTN","PRCAG",4,0)
REP ;ENTRY FROM REPRINT PAT STATEMENT
"RTN","PRCAG",5,0)
 NEW BEG,END,DAT,DATE,DEB,DIC,HDAT,IOP,SITE,TYP,X,Y,ZTDESC,ZTRTN,ZTSAVE,SDT,%ZI
S,POP,ZTIO
"RTN","PRCAG",6,0)
 W !!
"RTN","PRCAG",7,0)
ADT  ; PRCA*4.5*313 - Build and print a list of available dates for Patient Sta
tements within the last month
"RTN","PRCAG",8,0)
 W !,"These dates in the previous month contain Patient Statements: "
"RTN","PRCAG",9,0)
 S DAT="" F  S DAT=$O(^RCPS(349.2,"STDT",DAT)) Q:DAT=""  I $D(^RC(341,"STDT",DA
T)) W !,$$DATE^RCCPCPS1(DAT)
"RTN","PRCAG",10,0)
 W !!
"RTN","PRCAG",11,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PRCAG",12,0)
 S DIR(0)="DAO^^K:'$D(^RC(341,""STDT"",Y)) X"
"RTN","PRCAG",13,0)
 S DIR("A")="Enter a Patient Statement date from list above: "
"RTN","PRCAG",14,0)
 S DIR("?")="Enter a Patient Statement date from list above or ^ to exit."
"RTN","PRCAG",15,0)
 D ^DIR
"RTN","PRCAG",16,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","PRCAG",17,0)
 S SDT=Y
"RTN","PRCAG",18,0)
 W !!,"NOTE: The range is in print order not alphabetic!",!
"RTN","PRCAG",19,0)
 S X=""
"RTN","PRCAG",20,0)
 S BEG=$O(^RC(341,"STDT",SDT,""))
"RTN","PRCAG",21,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PRCAG",22,0)
 S DIR(0)="YAO"
"RTN","PRCAG",23,0)
 S DIR("B")="N"
"RTN","PRCAG",24,0)
 S DIR("A")="Do you want to Start with a Specific Patient? "
"RTN","PRCAG",25,0)
 D ^DIR
"RTN","PRCAG",26,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","PRCAG",27,0)
 I Y=0 S X=""
"RTN","PRCAG",28,0)
 I Y=1 S X=$$SELNAME(SDT)
"RTN","PRCAG",29,0)
 I X=-1 Q
"RTN","PRCAG",30,0)
 I X'="" S BEG=X
"RTN","PRCAG",31,0)
 ; PRCA*4.5*313 - Use statement date cross-reference to provide a patient list
"RTN","PRCAG",32,0)
 S X=""
"RTN","PRCAG",33,0)
 S END=$O(^RC(341,"STDT",SDT,""),-1)
"RTN","PRCAG",34,0)
 W !,"Ending Patient Bill must be printed after the Starting Patient Bill.",!
"RTN","PRCAG",35,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PRCAG",36,0)
 S DIR(0)="YAO"
"RTN","PRCAG",37,0)
 S DIR("B")="N"
"RTN","PRCAG",38,0)
 S DIR("A")="Do you want to End with a Specific Patient? "
"RTN","PRCAG",39,0)
 D ^DIR
"RTN","PRCAG",40,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","PRCAG",41,0)
 I Y=0 S X=""
"RTN","PRCAG",42,0)
 I Y=1 S X=$$SELNAME(SDT)
"RTN","PRCAG",43,0)
 I X=-1 Q
"RTN","PRCAG",44,0)
 I X'="" S END=X
"RTN","PRCAG",45,0)
 I END>0,END<BEG W *7,!,"Ending bill is before starting bill!" G ADT
"RTN","PRCAG",46,0)
 S HDAT=9999999-SDT
"RTN","PRCAG",47,0)
REPD W !! S %ZIS="QN",IOP="Q",%ZIS("B")=$P($G(^RC(342,1,0)),U,8) D ^%ZIS G:POP 
REPQ
"RTN","PRCAG",48,0)
 I '$D(IO("Q")) W !!,*7,"YOU MUST QUEUE THIS OUTPUT",! G REPD
"RTN","PRCAG",49,0)
 S ZTRTN="REP^PRCAGS",ZTDESC="Reprint AR Patient Statements",ZTSAVE("BEG")="",Z
TSAVE("END")="",ZTSAVE("HDAT")="" D ^%ZTLOAD
"RTN","PRCAG",50,0)
REPQ ; PRCA*4.5*313 - Kill TMP($J Lists prior to quit
"RTN","PRCAG",51,0)
 D ^%ZISC
"RTN","PRCAG",52,0)
 K ^TMP($J,"LISTNAME"),^TMP($J,"LISTCNT")
"RTN","PRCAG",53,0)
 Q
"RTN","PRCAG",54,0)
UB ;ENTRY FROM REPRINT UB BILLS
"RTN","PRCAG",55,0)
 S ETY="UB" ;set event type to UB and use REB sub-routine
"RTN","PRCAG",56,0)
REB ;ENTRY FROM REPRINT FOLLOW-UP LETTERS
"RTN","PRCAG",57,0)
 NEW BEG,END,DAT,DATE,DEB,DIC,IOP,SITE,TYP,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT,DA,DIR,D
TOUT
"RTN","PRCAG",58,0)
 D SITE^PRCAGU
"RTN","PRCAG",59,0)
 S:'$D(ETY) ETY="FL"
"RTN","PRCAG",60,0)
REBDT S %DT="AEXP",%DT(0)="-NOW",%DT("A")="Enter a Date to Reprint: " D ^%DT G:
Y<1 REBQ
"RTN","PRCAG",61,0)
 S Y=$P(Y,".")
"RTN","PRCAG",62,0)
 I $P($O(^RC(341,"C",Y)),".")'=Y W !!,*7,"No notifications sent on that date",!
 G REBDT
"RTN","PRCAG",63,0)
 S DAT=9999999-Y
"RTN","PRCAG",64,0)
 W !!,"Press return at the 'Bill:' prompts to reprint all ",ETY," Letters",!,"f
or the date selected or select a start and/or end point."
"RTN","PRCAG",65,0)
 W !,"Do not select bills that print on the Patient Statement."
"RTN","PRCAG",66,0)
 W !,"NOTE: The range is in print order not alphabetic!",!
"RTN","PRCAG",67,0)
 N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
"RTN","PRCAG",68,0)
 S DIC="^PRCA(430,",DIC(0)="AEMNQ",DIC("A")="Start from Bill: ",DIC("S")="I "",
18,25,5,24,1,2,3,4,23,22,""'[("",""_$P(^(0),U,2)_"","")" D ^DIC I ($D(DTOUT))!(
X["^") G REBQ
"RTN","PRCAG",69,0)
 S BEG=0,Y=+Y
"RTN","PRCAG",70,0)
 I Y>0 S BEG=-1,DEB=+$P($G(^PRCA(430,Y,0)),U,9),TYP=+$O(^RC(341.1,"AC",$S(ETY="
UB":9,1:10),0)) F DATE=DAT-.0001:0 S DATE=$O(^RC(341,"AD",DEB,TYP,DATE)) Q:$P(D
ATE,".")'=DAT  D
"RTN","PRCAG",71,0)
 .F DA=0:0 S DA=$O(^RC(341,"AD",DEB,TYP,DATE,DA)) Q:'DA  I +$G(^RC(341,DA,5))=Y
 S BEG=DA,DEB=0 Q
"RTN","PRCAG",72,0)
 .Q
"RTN","PRCAG",73,0)
 I BEG=0 S BEG=$O(^RC(341,"C",+$O(^RC(341,"C",9999999-DAT)),0)) S:'BEG BEG=-1
"RTN","PRCAG",74,0)
 I BEG<0 W *7,!," Sorry, not found!" G REBDT
"RTN","PRCAG",75,0)
 S DIC("A")="End after Bill: " D ^DIC I ($D(DTOUT))!(X["^") G REBQ
"RTN","PRCAG",76,0)
 S END="*",Y=+Y
"RTN","PRCAG",77,0)
 I Y>0 S END=-1,DEB=+$P($G(^PRCA(430,Y,0)),U,9),TYP=+$O(^RC(341.1,"AC",$S(ETY="
UB":9,1:10),0)) F DATE=DAT-.0001:0 S DATE=$O(^RC(341,"AD",DEB,TYP,DATE)) Q:$P(D
ATE,".")'=DAT  D
"RTN","PRCAG",78,0)
 .F DA=0:0 S DA=$O(^RC(341,"AD",DEB,TYP,DATE,DA)) Q:'DA  I +$G(^RC(341,DA,5))=Y
 S END=DA,DEB=0 Q
"RTN","PRCAG",79,0)
 .Q
"RTN","PRCAG",80,0)
 I END<0 W *7,!," Sorry, not found!" G REBDT
"RTN","PRCAG",81,0)
 I END'="*",END<BEG W *7,!,"Ending bill is before starting bill!" G REBDT
"RTN","PRCAG",82,0)
 W !!
"RTN","PRCAG",83,0)
REBD I ETY="UB" S ZTIO="" G REBD1
"RTN","PRCAG",84,0)
 S %ZIS("B")=$P($G(^RC(342,1,0)),U,8),%ZIS="QN",IOP="Q" D ^%ZIS G:POP REBQ
"RTN","PRCAG",85,0)
 I '$D(IO("Q")) W !!,*7,"YOU MUST QUEUE THIS OUTPUT",! G REBD
"RTN","PRCAG",86,0)
REBD1 S ZTRTN="BILL^PRCAGS",ZTSAVE("BEG")="",ZTSAVE("END")="",ZTSAVE("DAT")="",
ZTSAVE("SITE")="",ZTSAVE("ETY")=""
"RTN","PRCAG",87,0)
 S ZTDESC=$S(ETY="UB":"AR Reprint UB Letters",1:"Reprint AR Follow-up Letters")
 D ^%ZTLOAD
"RTN","PRCAG",88,0)
REBQ K ETY D ^%ZISC Q
"RTN","PRCAG",89,0)
PRDT ;ENTRY FROM PRINT STATEMENT/LETTER BY DATE OPTION
"RTN","PRCAG",90,0)
 D PRDT^PRCAGP
"RTN","PRCAG",91,0)
 Q
"RTN","PRCAG",92,0)
SELNAME(SDT)  ; PRCA^4.5^313 - Create a list and then select a patient name
"RTN","PRCAG",93,0)
 ; There are three values to Return from this tag
"RTN","PRCAG",94,0)
 ;   IEN  -- Number from list of Selected Patient
"RTN","PRCAG",95,0)
 ;   Null -- No Patient Selected from list - used to begin or end Selection lis
t
"RTN","PRCAG",96,0)
 ;   -1   -- Quit processing from called tag
"RTN","PRCAG",97,0)
 N IEN,CNT,NAME
"RTN","PRCAG",98,0)
 W !,"Please wait while we build the patient list.",!
"RTN","PRCAG",99,0)
 K ^TMP($J,"LISTNAME")
"RTN","PRCAG",100,0)
 S (IEN,CNT)=0
"RTN","PRCAG",101,0)
 F  S IEN=$O(^RC(341,"STDT",SDT,IEN)) Q:IEN=""  D
"RTN","PRCAG",102,0)
 . N PAT,NAME
"RTN","PRCAG",103,0)
 . S PAT=$P(^RCD(340,$P(^RC(341,IEN,0),"^",5),0),";")
"RTN","PRCAG",104,0)
 . S NAME=$P(^DPT(PAT,0),U)
"RTN","PRCAG",105,0)
 . S ^TMP($J,"LISTNAME",NAME)=IEN
"RTN","PRCAG",106,0)
 ; Quit the listing if no names to display
"RTN","PRCAG",107,0)
 I '$D(^TMP($J,"LISTNAME")) D  Q -1
"RTN","PRCAG",108,0)
 . W !,"There are no names to display for this date."
"RTN","PRCAG",109,0)
 . S DIR(0)="E" D ^DIR
"RTN","PRCAG",110,0)
 W !,"Please enter all or part of Patient Name: " R NAME:DTIME
"RTN","PRCAG",111,0)
 I NAME="^" Q -1
"RTN","PRCAG",112,0)
 I NAME="" Q NAME
"RTN","PRCAG",113,0)
 I $G(NAME)'="",$D(^TMP($J,"LISTNAME",NAME)) S IEN=^(NAME) Q IEN
"RTN","PRCAG",114,0)
 W !!,"Patient Name is not an exact match."
"RTN","PRCAG",115,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PRCAG",116,0)
 S DIR(0)="YAO"
"RTN","PRCAG",117,0)
 S DIR("B")="N"
"RTN","PRCAG",118,0)
 S DIR("A")="Would you like a list of Patient Names for "_$$DATE^RCCPCPS1(SDT)_
"? "
"RTN","PRCAG",119,0)
 D ^DIR
"RTN","PRCAG",120,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q -1
"RTN","PRCAG",121,0)
 I Y=0 N QUIT D  I QUIT'=0 Q QUIT
"RTN","PRCAG",122,0)
 . W !,"All of the Patient Statements for this date will now print."
"RTN","PRCAG",123,0)
 . N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PRCAG",124,0)
 . S DIR(0)="YAO"
"RTN","PRCAG",125,0)
 . S DIR("B")="Y"
"RTN","PRCAG",126,0)
 . S DIR("A")="Is this correct? "
"RTN","PRCAG",127,0)
 . D ^DIR
"RTN","PRCAG",128,0)
 . S QUIT=Y
"RTN","PRCAG",129,0)
 . I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S QUIT=-1
"RTN","PRCAG",130,0)
 . I QUIT=1 S QUIT=""
"RTN","PRCAG",131,0)
 ; Select Name - If Zero (0) is returned keep trying 
"RTN","PRCAG",132,0)
 F  S IEN=$$SELNM1 I IEN'=0 Q
"RTN","PRCAG",133,0)
 Q IEN
"RTN","PRCAG",134,0)
SELNM1()  ; Select name
"RTN","PRCAG",135,0)
 N DIRUT,XCNT,DIR,CNT
"RTN","PRCAG",136,0)
 K ^TMP($J,"LISTCNT")
"RTN","PRCAG",137,0)
 S CNT=0,NAME=""
"RTN","PRCAG",138,0)
 W @IOF,"Number",?20,"Patient Name"
"RTN","PRCAG",139,0)
 F  S NAME=$O(^TMP($J,"LISTNAME",NAME)) Q:NAME=""  D  I $D(DIRUT) Q
"RTN","PRCAG",140,0)
 . S CNT=CNT+1
"RTN","PRCAG",141,0)
 . S ^TMP($J,"LISTCNT",CNT,NAME)=^TMP($J,"LISTNAME",NAME)
"RTN","PRCAG",142,0)
 . W !,CNT,?20,NAME
"RTN","PRCAG",143,0)
 . I ($Y+3)>IOSL D  Q:$D(DIRUT)
"RTN","PRCAG",144,0)
 . . S DIR(0)="E" D ^DIR
"RTN","PRCAG",145,0)
 . . I X="^" Q
"RTN","PRCAG",146,0)
 . . W @IOF
"RTN","PRCAG",147,0)
 . . W "Number",?20,"Patient Name"
"RTN","PRCAG",148,0)
 W !,"Please enter number of selected Patient Name: " R XCNT:DTIME
"RTN","PRCAG",149,0)
 I XCNT="^" Q -1
"RTN","PRCAG",150,0)
 I XCNT=""  N QUIT D  Q QUIT
"RTN","PRCAG",151,0)
 . W !,"All of the Patient Statements for this date will now print."
"RTN","PRCAG",152,0)
 . N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PRCAG",153,0)
 . S DIR(0)="YAO"
"RTN","PRCAG",154,0)
 . S DIR("B")="Y"
"RTN","PRCAG",155,0)
 . S DIR("A")="No Patient Selected. "
"RTN","PRCAG",156,0)
 . S DIR("A",1)="Is this correct? "
"RTN","PRCAG",157,0)
 . D ^DIR
"RTN","PRCAG",158,0)
 . S QUIT=Y
"RTN","PRCAG",159,0)
 . I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) S QUIT=-1
"RTN","PRCAG",160,0)
 . I QUIT=1 S QUIT=""
"RTN","PRCAG",161,0)
 S CNT=XCNT
"RTN","PRCAG",162,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","PRCAG",163,0)
 S DIR(0)="YAO"
"RTN","PRCAG",164,0)
 S DIR("B")="Y"
"RTN","PRCAG",165,0)
 S DIR("A")="...OK? "
"RTN","PRCAG",166,0)
 S DIR("A",1)=""
"RTN","PRCAG",167,0)
 S DIR("A",2)=$O(^TMP($J,"LISTCNT",CNT,0))
"RTN","PRCAG",168,0)
 D ^DIR
"RTN","PRCAG",169,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q -1
"RTN","PRCAG",170,0)
 ; If user answered No, then try again
"RTN","PRCAG",171,0)
 I Y=0 Q Y
"RTN","PRCAG",172,0)
 S NAME=$O(^TMP($J,"LISTCNT",CNT,0))
"RTN","PRCAG",173,0)
 Q ^TMP($J,"LISTCNT",CNT,NAME)
"RTN","RCBEADJ")
0^24^B77106309^B77125147
"RTN","RCBEADJ",1,0)
RCBEADJ ;WISC/RFJ-adjustment ;Jun 06, 2014@19:11:19
"RTN","RCBEADJ",2,0)
 ;;4.5;Accounts Receivable;**169,172,204,173,208,233,298,301,313**;Mar 20, 1995
;Build 118
"RTN","RCBEADJ",3,0)
 ;Per VA Directive 6402, this routine should not be modified.
"RTN","RCBEADJ",4,0)
 Q
"RTN","RCBEADJ",5,0)
 ;
"RTN","RCBEADJ",6,0)
 ;
"RTN","RCBEADJ",7,0)
DECREASE ;  menu option: create a decrease adjustment
"RTN","RCBEADJ",8,0)
 D ADJUST("DECREASE")
"RTN","RCBEADJ",9,0)
 Q
"RTN","RCBEADJ",10,0)
 ;
"RTN","RCBEADJ",11,0)
 ;
"RTN","RCBEADJ",12,0)
INCREASE ;  menu option: create an increase adjustment
"RTN","RCBEADJ",13,0)
 D ADJUST("INCREASE")
"RTN","RCBEADJ",14,0)
 Q
"RTN","RCBEADJ",15,0)
 ;
"RTN","RCBEADJ",16,0)
ADJUST(RCBETYPE,RCEDI) ;  create an adjustment
"RTN","RCBEADJ",17,0)
 ;  rcbetype = INCREASE for increase or DECREASE for decrease
"RTN","RCBEADJ",18,0)
 ;  rcedi = the ien of the bill selected via the EDI Worklist;ien of 
"RTN","RCBEADJ",19,0)
 ;    XX      the ERA entry or null/undefined if bill should be selected
"RTN","RCBEADJ",20,0)
 N RCBILLDA
"RTN","RCBEADJ",21,0)
 F  D  Q:RCBILLDA<0!$G(RCEDI)
"RTN","RCBEADJ",22,0)
 .   K RCTRANDA,RCLIST
"RTN","RCBEADJ",23,0)
 .   ;
"RTN","RCBEADJ",24,0)
 .   ;  select a bill
"RTN","RCBEADJ",25,0)
 .   S RCBILLDA=$S('$G(RCEDI):$$GETABILL^RCBEUBIL,1:+RCEDI)
"RTN","RCBEADJ",26,0)
 .   I RCBILLDA<1 Q
"RTN","RCBEADJ",27,0)
 .   I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="INCREASE") W !,"BILL HAS BEEN 
REFERRED TO CROSS-SERVICING.",!,"NO MANUAL INCREASE ADJUSTMENTS ARE ALLOWED." Q
  ;prca*4.5*301
"RTN","RCBEADJ",28,0)
 .   I $D(^PRCA(430,"TCSP",RCBILLDA)),(RCBETYPE="DECREASE") S %=2 W !!,"IS THIS
 ACTION BEING PERFORMED DUE TO THE CLAIMS MATCHING PROCESS? " D YN^DICN Q:(%<0)
!(%=2)  ;prca*4.5*301
"RTN","RCBEADJ",29,0)
 .   ;
"RTN","RCBEADJ",30,0)
 .   ;  adjust the bill
"RTN","RCBEADJ",31,0)
 .   D ADJBILL(RCBETYPE,RCBILLDA,$P($G(RCEDI),";",2))
"RTN","RCBEADJ",32,0)
 Q
"RTN","RCBEADJ",33,0)
 ;
"RTN","RCBEADJ",34,0)
ADJBILL(RCBETYPE,RCBILLDA,RCEDIWL) ;  adjust a bill
"RTN","RCBEADJ",35,0)
 ; RCEDIWL = ien of ERA entry if called from worklist
"RTN","RCBEADJ",36,0)
 N RCAMOUNT,RCBALANC,RCDATA7,RCLIST,RCONTADJ,RCTRANDA,TOTALCAL,TOTALSTO,I,X,Y
"RTN","RCBEADJ",37,0)
 ;  lock the bill
"RTN","RCBEADJ",38,0)
 L +^PRCA(430,RCBILLDA):5 E  W !,"ANOTHER USER IS CURRENTLY WORKING WITH THIS B
ILL." Q
"RTN","RCBEADJ",39,0)
 ;
"RTN","RCBEADJ",40,0)
 ;  show data for the bill
"RTN","RCBEADJ",41,0)
 D SHOWBILL^RCWROFF1(RCBILLDA)
"RTN","RCBEADJ",42,0)
 ;
"RTN","RCBEADJ",43,0)
 ;  check the balance of the bill
"RTN","RCBEADJ",44,0)
 W !!,"Checking the bill's balance ..."
"RTN","RCBEADJ",45,0)
 S RCBALANC=$$OUTOFBAL^RCBDBBAL(RCBILLDA)
"RTN","RCBEADJ",46,0)
 I RCBALANC="" W " IN Balance!"
"RTN","RCBEADJ",47,0)
 ;
"RTN","RCBEADJ",48,0)
 ;  out of balance, ask to fix it
"RTN","RCBEADJ",49,0)
 I RCBALANC'="" D  I RCBILLDA<1 D UNLOCK Q
"RTN","RCBEADJ",50,0)
 .   S TOTALCAL=$P(RCBALANC,"^")+$P(RCBALANC,"^",2)+$P(RCBALANC,"^",3)+$P(RCBAL
ANC,"^",4)+$P(RCBALANC,"^",5)
"RTN","RCBEADJ",51,0)
 .   S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",52,0)
 .   S TOTALSTO=$P(RCDATA7,"^")+$P(RCDATA7,"^",2)+$P(RCDATA7,"^",3)+$P(RCDATA7,
"^",4)+$P(RCDATA7,"^",5)
"RTN","RCBEADJ",53,0)
 .   W " OUT of Balance!"
"RTN","RCBEADJ",54,0)
 .   W !!,"                  BALANCE:",$J("Calculated",12),$J("Stored",12)
"RTN","RCBEADJ",55,0)
 .   W !,"                  ------- ",$J("------------",12),$J("------------",1
2)
"RTN","RCBEADJ",56,0)
 .   W !,"        Principal Balance:",$J($P(RCBALANC,"^",1),12,2),$J($P(RCDATA7
,"^",1),12,2)
"RTN","RCBEADJ",57,0)
 .   I +$P(RCBALANC,"^",1)'=+$P(RCDATA7,"^",1) W "  <<-- OUT OF BALANCE"
"RTN","RCBEADJ",58,0)
 .   W !,"         Interest Balance:",$J($P(RCBALANC,"^",2),12,2),$J($P(RCDATA7
,"^",2),12,2)
"RTN","RCBEADJ",59,0)
 .   I +$P(RCBALANC,"^",2)'=+$P(RCDATA7,"^",2) W "  <<-- OUT OF BALANCE"
"RTN","RCBEADJ",60,0)
 .   W !,"            Admin Balance:",$J($P(RCBALANC,"^",3),12,2),$J($P(RCDATA7
,"^",3),12,2)
"RTN","RCBEADJ",61,0)
 .   I +$P(RCBALANC,"^",3)'=+$P(RCDATA7,"^",3) W "  <<-- OUT OF BALANCE"
"RTN","RCBEADJ",62,0)
 .   W !,"               MF Balance:",$J($P(RCBALANC,"^",4),12,2),$J($P(RCDATA7
,"^",4),12,2)
"RTN","RCBEADJ",63,0)
 .   I +$P(RCBALANC,"^",4)'=+$P(RCDATA7,"^",4) W "  <<-- OUT OF BALANCE"
"RTN","RCBEADJ",64,0)
 .   W !,"               CC Balance:",$J($P(RCBALANC,"^",5),12,2),$J($P(RCDATA7
,"^",5),12,2)
"RTN","RCBEADJ",65,0)
 .   I +$P(RCBALANC,"^",5)'=+$P(RCDATA7,"^",5) W "  <<-- OUT OF BALANCE"
"RTN","RCBEADJ",66,0)
 .   W !,"                  ------- ",$J("-------------",12),$J("-------------"
,12)
"RTN","RCBEADJ",67,0)
 .   W !,"                    TOTAL:",$J(TOTALCAL,12,2),$J(TOTALSTO,12,2)
"RTN","RCBEADJ",68,0)
 .   I +TOTALCAL'=+TOTALSTO W "  <<-- OUT OF BALANCE"
"RTN","RCBEADJ",69,0)
 .   ;
"RTN","RCBEADJ",70,0)
 .   ;  ask to fix the balances
"RTN","RCBEADJ",71,0)
 .   S Y=$$ASKFIX I Y'=1 W !,"  NOTE: You must fix the Balance Discrepancy befo
re processing an adjustment!" S RCBILLDA=0 Q
"RTN","RCBEADJ",72,0)
 .   ;
"RTN","RCBEADJ",73,0)
 .   ;  fix it
"RTN","RCBEADJ",74,0)
 .   S $P(RCDATA7,"^",1)=+$P(RCBALANC,"^",1) ; principal
"RTN","RCBEADJ",75,0)
 .   S $P(RCDATA7,"^",2)=+$P(RCBALANC,"^",2) ; interest
"RTN","RCBEADJ",76,0)
 .   S $P(RCDATA7,"^",3)=+$P(RCBALANC,"^",3) ; admin
"RTN","RCBEADJ",77,0)
 .   S $P(RCDATA7,"^",4)=+$P(RCBALANC,"^",4) ; marshal fee
"RTN","RCBEADJ",78,0)
 .   S $P(RCDATA7,"^",5)=+$P(RCBALANC,"^",5) ; court cost
"RTN","RCBEADJ",79,0)
 .   S $P(^PRCA(430,RCBILLDA,7),"^",1,5)=$P(RCDATA7,"^",1,5)
"RTN","RCBEADJ",80,0)
 .   ;
"RTN","RCBEADJ",81,0)
 .   W !,"  Balance Discrepancy FIXED!"
"RTN","RCBEADJ",82,0)
 ;
"RTN","RCBEADJ",83,0)
 ;  if the principal balance is zero, do not allow it to be adjusted
"RTN","RCBEADJ",84,0)
 ;  ask to close/cancel it
"RTN","RCBEADJ",85,0)
 I RCBETYPE="DECREASE",'$G(^PRCA(430,RCBILLDA,7)) W !!,"Note: This bill has NO 
PRINCIPAL BALANCE to decrease !" D INTADMIN(RCBILLDA),UNLOCK Q
"RTN","RCBEADJ",86,0)
 ;
"RTN","RCBEADJ",87,0)
 ; If entry is from EDI Lockbox worklist, display total adjustments in ERA
"RTN","RCBEADJ",88,0)
 N AP D
"RTN","RCBEADJ",89,0)
 .N BILL,EOB,ERA,SEQ S ERA="",AP=0
"RTN","RCBEADJ",90,0)
 .F  S ERA=$O(^RCY(344.4,"AP",1,ERA)) Q:'ERA  D  Q:AP
"RTN","RCBEADJ",91,0)
 ..S SEQ=0
"RTN","RCBEADJ",92,0)
 ..F  S SEQ=$O(^RCY(344.4,"AP",1,ERA,SEQ)) Q:'SEQ  D  Q:AP
"RTN","RCBEADJ",93,0)
 ...S EOB=$P($G(^RCY(344.4,ERA,1,SEQ,0)),U,2) Q:'EOB
"RTN","RCBEADJ",94,0)
 ...S:$P($G(^IBM(361.1,EOB,0)),U)=RCBILLDA AP=1 ;IA #4051
"RTN","RCBEADJ",95,0)
 ;
"RTN","RCBEADJ",96,0)
 ;  Ask to enter transaction even though it is marked for autopost PRCA*4.5*298
"RTN","RCBEADJ",97,0)
 I RCBETYPE="DECREASE",AP S Y=$$ASKAUPO() I Y'=1 W !,"Exiting bill adjustment."
 D UNLOCK Q
"RTN","RCBEADJ",98,0)
 ;
"RTN","RCBEADJ",99,0)
 ;  ask to enter adjustment amount
"RTN","RCBEADJ",100,0)
 S RCAMOUNT=$$AMOUNT(RCBILLDA,RCBETYPE)
"RTN","RCBEADJ",101,0)
 I RCAMOUNT<0 D UNLOCK Q
"RTN","RCBEADJ",102,0)
 ;
"RTN","RCBEADJ",103,0)
 ;  if decrease, make negative
"RTN","RCBEADJ",104,0)
 I RCBETYPE="DECREASE" S RCAMOUNT=-RCAMOUNT
"RTN","RCBEADJ",105,0)
 ;
"RTN","RCBEADJ",106,0)
 ;  ask if it is a contract adjustment
"RTN","RCBEADJ",107,0)
 I RCBETYPE="DECREASE","^9^28^29^30^32^"[("^"_$P($G(^PRCA(430,RCBILLDA,0)),"^",
2)_"^") S RCONTADJ=$$ASKCONT I RCONTADJ<0 D UNLOCK Q
"RTN","RCBEADJ",108,0)
 ;
"RTN","RCBEADJ",109,0)
 ;  show what the new transaction will look like
"RTN","RCBEADJ",110,0)
 S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",111,0)
 W !!,"If you process the transaction, the bill will look like:"
"RTN","RCBEADJ",112,0)
 W !,"Current Principal Balance: ",$J($P(RCDATA7,"^"),11,2)
"RTN","RCBEADJ",113,0)
 W !,"  NEW ",RCBETYPE," Adjustment: ",$J(RCAMOUNT,11,2)
"RTN","RCBEADJ",114,0)
 W !,"                           -----------"
"RTN","RCBEADJ",115,0)
 W !,"    NEW Principal Balance: ",$J($P(RCDATA7,"^")+RCAMOUNT,11,2)
"RTN","RCBEADJ",116,0)
 ;
"RTN","RCBEADJ",117,0)
 ;  ask to enter transaction
"RTN","RCBEADJ",118,0)
 S Y=$$ASKOK(RCBETYPE) I Y'=1 D UNLOCK Q
"RTN","RCBEADJ",119,0)
 ;
"RTN","RCBEADJ",120,0)
ADDADJ ;  add adjustment
"RTN","RCBEADJ",121,0)
 S RCTRANDA=$$INCDEC^RCBEUTR1(RCBILLDA,RCAMOUNT,"","","",$G(RCONTADJ))
"RTN","RCBEADJ",122,0)
 I 'RCTRANDA W !,"  *** W A R N I N G: Adjustment NOT Processed! ***" D UNLOCK 
Q
"RTN","RCBEADJ",123,0)
 I RCTRANDA W !,"  Adjustment Transaction: ",RCTRANDA," has been added."
"RTN","RCBEADJ",124,0)
 I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D
 DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs decrease adjustment
"RTN","RCBEADJ",125,0)
 I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD
^%DT W !!,"   * * * * Transmission will be held until "_Y_" * * * *"
"RTN","RCBEADJ",126,0)
 ;
"RTN","RCBEADJ",127,0)
 ;  ask to enter a comment
"RTN","RCBEADJ",128,0)
 W !!,"Enter a comment for the ",RCBETYPE," Adjustment:"
"RTN","RCBEADJ",129,0)
 S Y=$$EDIT433^RCBEUTRA(RCTRANDA,"41;")
"RTN","RCBEADJ",130,0)
 ;
"RTN","RCBEADJ",131,0)
 ;  ask to exempt interest and admin charges
"RTN","RCBEADJ",132,0)
 I RCBETYPE="DECREASE" D INTADMIN(RCBILLDA)
"RTN","RCBEADJ",133,0)
 ;
"RTN","RCBEADJ",134,0)
 ;  notification of subsequent payer bulletin
"RTN","RCBEADJ",135,0)
 S RCDATA7=$G(^PRCA(430,RCBILLDA,7)),X=0
"RTN","RCBEADJ",136,0)
 F I=1:1:5 S X=X+$P(RCDATA7,"^",I)
"RTN","RCBEADJ",137,0)
 I RCDATA7'="",'X D
"RTN","RCBEADJ",138,0)
 .   N PRCABN,PRCAEN,PRCAMT
"RTN","RCBEADJ",139,0)
 .   S PRCABN=RCBILLDA,PRCAEN=RCTRANDA,PRCAMT=+$P($G(^PRCA(433,RCTRANDA,1)),"^"
,5)
"RTN","RCBEADJ",140,0)
 .   D EOB^PRCADJ
"RTN","RCBEADJ",141,0)
 ;
"RTN","RCBEADJ",142,0)
 ;  unlock and ask the next bill to adjust
"RTN","RCBEADJ",143,0)
 D UNLOCK
"RTN","RCBEADJ",144,0)
 Q
"RTN","RCBEADJ",145,0)
 ;
"RTN","RCBEADJ",146,0)
 ;
"RTN","RCBEADJ",147,0)
UNLOCK ;  unlock bill and transaction
"RTN","RCBEADJ",148,0)
 L -^PRCA(430,RCBILLDA)
"RTN","RCBEADJ",149,0)
 I $G(RCTRANDA) L -^PRCA(433,RCTRANDA)
"RTN","RCBEADJ",150,0)
 Q
"RTN","RCBEADJ",151,0)
 ;
"RTN","RCBEADJ",152,0)
 ;
"RTN","RCBEADJ",153,0)
INTADMIN(RCBILLDA) ;  ask and adjust the interest and admin
"RTN","RCBEADJ",154,0)
 N RCAMOUNT,RCTRANDA,Y
"RTN","RCBEADJ",155,0)
 ;
"RTN","RCBEADJ",156,0)
 ;  check to see if there is interest and admin charges
"RTN","RCBEADJ",157,0)
 S RCAMOUNT=$G(^PRCA(430,RCBILLDA,7))
"RTN","RCBEADJ",158,0)
 I '$P(RCAMOUNT,"^",2),'$P(RCAMOUNT,"^",3),'$P(RCAMOUNT,"^",4),'$P(RCAMOUNT,"^"
,5) Q
"RTN","RCBEADJ",159,0)
 ;
"RTN","RCBEADJ",160,0)
 ;  only ask if there is no principal
"RTN","RCBEADJ",161,0)
 I RCAMOUNT Q
"RTN","RCBEADJ",162,0)
 ;
"RTN","RCBEADJ",163,0)
 W !!,"You have the option to automatically EXEMPT the interest"
"RTN","RCBEADJ",164,0)
 W !,"and administrative charges.  This will close the bill."
"RTN","RCBEADJ",165,0)
 S Y=$$ASKEXEMP I Y'=1 Q
"RTN","RCBEADJ",166,0)
 ;
"RTN","RCBEADJ",167,0)
 W !!,"Creating an EXEMPT transaction ..."
"RTN","RCBEADJ",168,0)
 S RCTRANDA=$$EXEMPT^RCBEUTR2(RCBILLDA,$P(RCAMOUNT,"^",2)_"^"_$P(RCAMOUNT,"^",3
)_"^^"_$P(RCAMOUNT,"^",4)_"^"_$P(RCAMOUNT,"^",5))
"RTN","RCBEADJ",169,0)
 I 'RCTRANDA W !,"  *** W A R N I N G: EXEMPTION NOT Processed! ***" Q
"RTN","RCBEADJ",170,0)
 I RCTRANDA W !,"   Exempt Transaction: ",RCTRANDA," has been added."
"RTN","RCBEADJ",171,0)
INTC35B ;Check if CS5B entry needed for exempt transaction
"RTN","RCBEADJ",172,0)
 I RCTRANDA,'$G(RCEDIWL),(RCBETYPE="DECREASE"),$D(^PRCA(430,"TCSP",RCBILLDA)) D
 DECADJ^RCTCSPU(RCBILLDA,RCTRANDA) ;prca*4.5*301 add cs exempt
"RTN","RCBEADJ",173,0)
 I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD
^%DT W !!,"   * * * * Transmission will be held until "_Y_" * * * *"
"RTN","RCBEADJ",174,0)
 ;
"RTN","RCBEADJ",175,0)
 W !,"  Current Bill Status: ",$P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILLDA,0)),
"^",8),0)),"^")
"RTN","RCBEADJ",176,0)
 Q
"RTN","RCBEADJ",177,0)
 ;
"RTN","RCBEADJ",178,0)
ASKOK(RCBETYPE) ;  ask record decrease or increase transaction
"RTN","RCBEADJ",179,0)
 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",180,0)
 S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",181,0)
 S DIR("A")="Are you sure you want to enter this "_RCBETYPE_" adjustment "
"RTN","RCBEADJ",182,0)
 W ! D ^DIR
"RTN","RCBEADJ",183,0)
 I $G(DTOUT)!($G(DUOUT)) S Y=-1
"RTN","RCBEADJ",184,0)
 Q Y
"RTN","RCBEADJ",185,0)
 ;
"RTN","RCBEADJ",186,0)
ASKAUPO() ;  ask record even though marked for auto post PRCA*4.5*298
"RTN","RCBEADJ",187,0)
 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",188,0)
 S DIR(0)="YOA",DIR("B")="NO"
"RTN","RCBEADJ",189,0)
 S DIR("A")="Marked for Auto-Post. Are you sure? (Y/N) "
"RTN","RCBEADJ",190,0)
 W ! D ^DIR
"RTN","RCBEADJ",191,0)
 I $G(DTOUT)!($G(DUOUT)) S Y=-1
"RTN","RCBEADJ",192,0)
 Q Y
"RTN","RCBEADJ",193,0)
 ;
"RTN","RCBEADJ",194,0)
ASKFIX() ;  ask to fix bill's balance
"RTN","RCBEADJ",195,0)
 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",196,0)
 S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",197,0)
 S DIR("A")="  Do you want to FIX the balance discrepancy "
"RTN","RCBEADJ",198,0)
 W ! D ^DIR
"RTN","RCBEADJ",199,0)
 I $G(DTOUT)!($G(DUOUT)) S Y=-1
"RTN","RCBEADJ",200,0)
 Q Y
"RTN","RCBEADJ",201,0)
 ;
"RTN","RCBEADJ",202,0)
 ;
"RTN","RCBEADJ",203,0)
ASKEXEMP() ;  ask to record an exempt transaction
"RTN","RCBEADJ",204,0)
 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",205,0)
 S DIR(0)="YO",DIR("B")="NO"
"RTN","RCBEADJ",206,0)
 S DIR("A")="  Would you like to EXEMPT the interest and admin charges "
"RTN","RCBEADJ",207,0)
 D ^DIR
"RTN","RCBEADJ",208,0)
 I $G(DTOUT)!($G(DUOUT)) S Y=-1
"RTN","RCBEADJ",209,0)
 Q Y
"RTN","RCBEADJ",210,0)
 ;
"RTN","RCBEADJ",211,0)
 ;
"RTN","RCBEADJ",212,0)
ASKCONT() ;  ask if contract adjustment
"RTN","RCBEADJ",213,0)
 N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
"RTN","RCBEADJ",214,0)
 S DIR(0)="YO",DIR("B")="YES"
"RTN","RCBEADJ",215,0)
 S DIR("A")="  Is this a CONTRACT adjustment "
"RTN","RCBEADJ",216,0)
 W ! D ^DIR
"RTN","RCBEADJ",217,0)
 I $G(DTOUT)!($G(DUOUT)) S Y=-1
"RTN","RCBEADJ",218,0)
 Q Y
"RTN","RCBEADJ",219,0)
 ;
"RTN","RCBEADJ",220,0)
ADJNUM(RCBILLDA) ;  get next adjustment number for a bill
"RTN","RCBEADJ",221,0)
 N %,ADJUST,DATA1,RCTRANDA
"RTN","RCBEADJ",222,0)
 S RCTRANDA=0
"RTN","RCBEADJ",223,0)
 F  S RCTRANDA=$O(^PRCA(433,"C",RCBILLDA,RCTRANDA)) Q:'RCTRANDA  S DATA1=$G(^PR
CA(433,RCTRANDA,1)) I $P(DATA1,"^",4),$P(DATA1,"^",2)=1!($P(DATA1,"^",2)=35) S 
ADJUST=$P(DATA1,"^",4)+1
"RTN","RCBEADJ",224,0)
 Q ADJUST
"RTN","RCBEADJ",225,0)
 ;
"RTN","RCBEADJ",226,0)
 ;
"RTN","RCBEADJ",227,0)
AMOUNT(RCBILLDA,RCBETYPE) ;  enter the adjustment amount for a bill
"RTN","RCBEADJ",228,0)
 N DIR,DIRUT,DTOUT,DUOUT,PRINBAL,X,Y
"RTN","RCBEADJ",229,0)
 S PRINBAL=+$P($G(^PRCA(430,RCBILLDA,7)),"^")
"RTN","RCBEADJ",230,0)
 I RCBETYPE="INCREASE" S PRINBAL=9999999.99
"RTN","RCBEADJ",231,0)
 W !!,"Enter the ",RCBETYPE," Adjustment AMOUNT, from .01 to ",$J(PRINBAL,0,2),
"."
"RTN","RCBEADJ",232,0)
 S DIR(0)="NAO^.01:"_PRINBAL_":2"
"RTN","RCBEADJ",233,0)
 S DIR("A")="  "_RCBETYPE_" PRINCIPAL BALANCE BY: "
"RTN","RCBEADJ",234,0)
 D ^DIR
"RTN","RCBEADJ",235,0)
 I $G(DTOUT)!($G(DUOUT)) S Y=-1
"RTN","RCBEADJ",236,0)
 Q $S(Y'="":Y,1:-1)
"RTN","RCBEADJ",237,0)
 ;
"RTN","RCCPCAP")
0^21^B41793332^n/a
"RTN","RCCPCAP",1,0)
RCCPCAP ;ALB/TGH - PATCH PRCA*4.5*ANNUAL PAYMENT BUILD ; 2/3/2016 11:30 am
"RTN","RCCPCAP",2,0)
 ;;4.5;Accounts Receivable;**313**;Feb 20, 2017;Build 118
"RTN","RCCPCAP",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCAP",4,0)
EN(YEAR,SOURCE,DTTIME)  ;  Build the payment statements for Year entered
"RTN","RCCPCAP",5,0)
 ; Year is the first three numbers of the Internal Date format and must be earl
ier than current Year
"RTN","RCCPCAP",6,0)
 ; Source will be used to determine whether to schedule or immediately start Tr
ansmit after Build
"RTN","RCCPCAP",7,0)
 ; DTTIME is the Transmit date and time in Internal time from Build and Transmi
t menu option
"RTN","RCCPCAP",8,0)
 ;
"RTN","RCCPCAP",9,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCAP",10,0)
 L +^RCAP(349.5):DILOCKTM I '$T W *7,*7,!,"Annual Payment is already being run 
or transmitted.  Try again later." Q
"RTN","RCCPCAP",11,0)
 ;
"RTN","RCCPCAP",12,0)
 N %,%I,%H,STARTDT,ENDDT,LINE,PSSEG,PSCNTR,EXIT,DEBTOR,END,NEXT,SIZE
"RTN","RCCPCAP",13,0)
 ;
"RTN","RCCPCAP",14,0)
 ; Initialize Incoming Variables - YEAR will be to Year before Current
"RTN","RCCPCAP",15,0)
 ; Source will be to "B"ackground, and DTTIME to its current value, including N
ULL
"RTN","RCCPCAP",16,0)
 I $G(YEAR)="" S YEAR=$E(DT,1,3)-1
"RTN","RCCPCAP",17,0)
 I $G(SOURCE)="" S SOURCE="B"
"RTN","RCCPCAP",18,0)
 S DTTIME=$G(DTTIME)
"RTN","RCCPCAP",19,0)
 ;
"RTN","RCCPCAP",20,0)
 ; Remove previous entries from file prior to building new file
"RTN","RCCPCAP",21,0)
 K ^RCAP(349.5)
"RTN","RCCPCAP",22,0)
 S ^RCAP(349.5,0)="AR ANNUAL PAYMENT STATEMENT^349.5^^"
"RTN","RCCPCAP",23,0)
 ;
"RTN","RCCPCAP",24,0)
 ; Set Start and End Dates
"RTN","RCCPCAP",25,0)
 S STARTDT=YEAR_"0100"
"RTN","RCCPCAP",26,0)
 S ENDDT=YEAR_1232
"RTN","RCCPCAP",27,0)
 S (DEBTOR,END)=""
"RTN","RCCPCAP",28,0)
 F PSCNTR=1:1 Q:END  D
"RTN","RCCPCAP",29,0)
 . S (NEXT,SIZE,LINE)=0
"RTN","RCCPCAP",30,0)
 . D SETPS(PSCNTR,YEAR)
"RTN","RCCPCAP",31,0)
 . N LASTPD
"RTN","RCCPCAP",32,0)
 . F  S DEBTOR=$O(^PRCA(433,"ATD",DEBTOR)) Q:DEBTOR=""  D  I NEXT Q
"RTN","RCCPCAP",33,0)
 .. N SSN
"RTN","RCCPCAP",34,0)
 .. ; Quit if the debtor is not a patient
"RTN","RCCPCAP",35,0)
 .. I '$D(^RCD(340,"AB","DPT(",DEBTOR)) Q
"RTN","RCCPCAP",36,0)
 .. ; Quit if a test patient SSN contains a "P" or is Null
"RTN","RCCPCAP",37,0)
 .. S SSN=$$SSN^RCFN01(DEBTOR)
"RTN","RCCPCAP",38,0)
 .. I SSN["P"!(SSN=-1) Q
"RTN","RCCPCAP",39,0)
 .. N PHSET,PHCNTR,PHSEG,DATE,LTBDT
"RTN","RCCPCAP",40,0)
 .. S (PHSET,PHCNTR,LTBDT)=0
"RTN","RCCPCAP",41,0)
 .. S DATE=STARTDT
"RTN","RCCPCAP",42,0)
 .. F  S DATE=$O(^PRCA(433,"ATD",DEBTOR,DATE)) Q:DATE=""  Q:DATE>ENDDT  D
"RTN","RCCPCAP",43,0)
 ... ; Recheck and Quit if the date is not within the Year
"RTN","RCCPCAP",44,0)
 ... I DATE<STARTDT!(DATE>ENDDT) Q
"RTN","RCCPCAP",45,0)
 ... ; Set Final Date for this Debtor to determine final transaction
"RTN","RCCPCAP",46,0)
 ... N TRANS
"RTN","RCCPCAP",47,0)
 ... S TRANS=""
"RTN","RCCPCAP",48,0)
 ... F  S TRANS=$O(^PRCA(433,"ATD",DEBTOR,DATE,TRANS)) Q:TRANS=""  D
"RTN","RCCPCAP",49,0)
 .... ; Quit if the Transaction Type is not Payment in Part(2) or Payment in Fu
ll(34)
"RTN","RCCPCAP",50,0)
 .... I $P(^PRCA(433,TRANS,1),U,2)'=2&($P(^PRCA(433,TRANS,1),U,2)'=34) Q
"RTN","RCCPCAP",51,0)
 .... ; Set PH Record if first time for this Debtor
"RTN","RCCPCAP",52,0)
 .... I 'PHSET D SETPH(DEBTOR,SSN,PSCNTR) S PHSET=1
"RTN","RCCPCAP",53,0)
 .... ; Set PD Record for each Payment Transaction
"RTN","RCCPCAP",54,0)
 .... D SETPD(DEBTOR,DATE,TRANS,PSCNTR)
"RTN","RCCPCAP",55,0)
 .. ; 
"RTN","RCCPCAP",56,0)
 .. ; After completing each Debtor, if the Size is over 30K, set Next to create
 a new PS Record,
"RTN","RCCPCAP",57,0)
 .. ; set Message Delimiter at the end of the PD record, and set End Date and T
ime
"RTN","RCCPCAP",58,0)
 .. I SIZE>30000 D
"RTN","RCCPCAP",59,0)
 ... S ^RCAP(349.5,PSCNTR,1,LASTPD,0)=^RCAP(349.5,PSCNTR,1,LASTPD,0)_"~"
"RTN","RCCPCAP",60,0)
 ... S NEXT=1
"RTN","RCCPCAP",61,0)
 ... D NOW^%DTC
"RTN","RCCPCAP",62,0)
 ... S $P(^RCAP(349.5,PSCNTR,0),U,4)=%
"RTN","RCCPCAP",63,0)
 .. ;
"RTN","RCCPCAP",64,0)
 .. ; If the last Debtor in ATD has processed set End to stop processing, if Ti
lde not final
"RTN","RCCPCAP",65,0)
 .. ; character, set Tilde to Last PD record, and set End Date and time
"RTN","RCCPCAP",66,0)
 . I DEBTOR="" D
"RTN","RCCPCAP",67,0)
 .. S END=1
"RTN","RCCPCAP",68,0)
 .. I $E(^RCAP(349.5,PSCNTR,1,LASTPD,0),$L(^RCAP(349.5,PSCNTR,1,LASTPD,0)))'="~
" S ^RCAP(349.5,PSCNTR,1,LASTPD,0)=^RCAP(349.5,PSCNTR,1,LASTPD,0)_"~"
"RTN","RCCPCAP",69,0)
 .. D NOW^%DTC
"RTN","RCCPCAP",70,0)
 .. S $P(^RCAP(349.5,PSCNTR,0),U,4)=%
"RTN","RCCPCAP",71,0)
 ;
"RTN","RCCPCAP",72,0)
 ; PRCA*4.5*313 - Unlock prior to transmission
"RTN","RCCPCAP",73,0)
 L -^RCAP(349.5):DILOCKTM
"RTN","RCCPCAP",74,0)
 ;
"RTN","RCCPCAP",75,0)
 ; If the Source is Background (B) determine the date and time from the schedul
e based upon site code
"RTN","RCCPCAP",76,0)
 I SOURCE="B" S DTTIME=$$SCHED^RCCPCAT($$SITE^RCMSITE)
"RTN","RCCPCAP",77,0)
 D EN^RCCPCAT(DTTIME)
"RTN","RCCPCAP",78,0)
 ;
"RTN","RCCPCAP",79,0)
 Q
"RTN","RCCPCAP",80,0)
 ;
"RTN","RCCPCAP",81,0)
SETPS(PSCNTR,YEAR)  ; Get and Set Data for PS Record into 349.5
"RTN","RCCPCAP",82,0)
 ; Set Year and Build Start Date and Time
"RTN","RCCPCAP",83,0)
 N PS,DR,DA,DIE,DIC,X,PRCAFDA
"RTN","RCCPCAP",84,0)
 S DIC="^RCAP(349.5,",X=PSCNTR,DA=.01,DIC(0)="" D FILE^DICN
"RTN","RCCPCAP",85,0)
 D NOW^%DTC
"RTN","RCCPCAP",86,0)
 S $P(^RCAP(349.5,PSCNTR,0),U,2,3)=YEAR_U_%
"RTN","RCCPCAP",87,0)
 ; Increment Line number
"RTN","RCCPCAP",88,0)
 S LINE=LINE+1
"RTN","RCCPCAP",89,0)
 ; Set PSSEG for this Segment to PS Counter
"RTN","RCCPCAP",90,0)
 S PSSEG(PSCNTR)=PSCNTR
"RTN","RCCPCAP",91,0)
 ; Pieces 3 and 6 will be updated during the creation of other PS and PH segmen
ts
"RTN","RCCPCAP",92,0)
 S PS="PS"_U_PSCNTR_U_PSCNTR_U_$$SITE^RCMSITE_U_$$FP^RCCPCFN_U_0_U_20_$E(YEAR,2
,3)_U_$$DAT^RCCPCFN(DT)_U_"}"
"RTN","RCCPCAP",93,0)
 ; Update File
"RTN","RCCPCAP",94,0)
 S PRCAFDA(349.51,"+"_(LINE)_","_PSCNTR_",",.01)=PS
"RTN","RCCPCAP",95,0)
 D UPDATE^DIE("","PRCAFDA","LINE")
"RTN","RCCPCAP",96,0)
 ; Add length to SIZE
"RTN","RCCPCAP",97,0)
 S SIZE=SIZE+$L(PS)
"RTN","RCCPCAP",98,0)
 ; Update all previous PS Segments piece 3 with current counter
"RTN","RCCPCAP",99,0)
 N I
"RTN","RCCPCAP",100,0)
 S I=0
"RTN","RCCPCAP",101,0)
 F  S I=$O(PSSEG(I)) Q:I=PSCNTR  S $P(^RCAP(349.5,I,1,1,0),U,3)=PSCNTR
"RTN","RCCPCAP",102,0)
 ;
"RTN","RCCPCAP",103,0)
 Q
"RTN","RCCPCAP",104,0)
 ;
"RTN","RCCPCAP",105,0)
SETPH(DEBTOR,SSN,PSCNTR)  ; Get and Set Data for PH Record into 349.5
"RTN","RCCPCAP",106,0)
 N PH,SITE,PATNAME,ADDRESS,I,ARFLAG,ARADDR,COUNTRY,DFN,ICN,DR,DA,DIE,POSTCODE,P
RCAFDA
"RTN","RCCPCAP",107,0)
 ; Increment Line number
"RTN","RCCPCAP",108,0)
 S LINE=LINE+1
"RTN","RCCPCAP",109,0)
 ; Increment PH Counter
"RTN","RCCPCAP",110,0)
 S PHCNTR=PHCNTR+1
"RTN","RCCPCAP",111,0)
 ; Set PHSEG for this Segment to Line
"RTN","RCCPCAP",112,0)
 S PHSEG(PHCNTR)=LINE
"RTN","RCCPCAP",113,0)
 ; Get DFN and ICN for Debtor and Patient - If the ICN returns a -1 in the firs
t piece 
"RTN","RCCPCAP",114,0)
 ; send a Null value as the ICN
"RTN","RCCPCAP",115,0)
 S DFN=+$P($G(^RCD(340,DEBTOR,0)),U)
"RTN","RCCPCAP",116,0)
 S ICN=$$GETICN^MPIF001(DFN)
"RTN","RCCPCAP",117,0)
 S ICN=$S(+ICN'=-1:ICN,1:"")
"RTN","RCCPCAP",118,0)
 ; Get Account Number  --  Site code and SSN
"RTN","RCCPCAP",119,0)
 S SITE=$$SITE^RCMSITE
"RTN","RCCPCAP",120,0)
 S PH="PH"_U_SITE_SSN
"RTN","RCCPCAP",121,0)
 ; Get Patient Name
"RTN","RCCPCAP",122,0)
 S PATNAME=$$NAM^RCFN01(DEBTOR)
"RTN","RCCPCAP",123,0)
 S PH=PH_$E($P(PATNAME,","),1,5)_U_$E($P(PATNAME,","),1,20)_U_$E($P($P(PATNAME,
",",2)," "),1,10)_U_$E($P(PATNAME," ",2),1,10)
"RTN","RCCPCAP",124,0)
 ; If Country is not '1' get Country Name and Postal Code
"RTN","RCCPCAP",125,0)
 S COUNTRY=$P($G(^DPT(+$P(^RCD(340,DEBTOR,0),U),.11)),U,10)
"RTN","RCCPCAP",126,0)
 S COUNTRY=$S(COUNTRY=1:"",1:$$GET1^DIQ(779.004,COUNTRY,"POSTAL NAME"))
"RTN","RCCPCAP",127,0)
 ; Get Address and ARFLAG
"RTN","RCCPCAP",128,0)
 S ADDRESS=$P($$DADD^RCAMADD(DEBTOR,1),U,1,6)
"RTN","RCCPCAP",129,0)
 F I=1:1:4 S $P(ADDRESS,U,I)=$E($P(ADDRESS,U,I),1,40)
"RTN","RCCPCAP",130,0)
 ; If the Country is Null the State and Zip Code will be used
"RTN","RCCPCAP",131,0)
 ; If the Country is Not Null, the State will be FX and the 
"RTN","RCCPCAP",132,0)
 ; Zip Code will be Null
"RTN","RCCPCAP",133,0)
 S $P(ADDRESS,U,5)=$S(COUNTRY="":$E($P(ADDRESS,U,5),1,2),1:"FX")
"RTN","RCCPCAP",134,0)
 S $P(ADDRESS,U,6)=$S(COUNTRY="":$E($P(ADDRESS,U,6),1,9),1:"")
"RTN","RCCPCAP",135,0)
 S PH=PH_U_ADDRESS
"RTN","RCCPCAP",136,0)
 S ARFLAG="N"
"RTN","RCCPCAP",137,0)
 S ARADDR=$P($G(^RCD(340,DEBTOR,1)),U,1,6)
"RTN","RCCPCAP",138,0)
 I ($P(ARADDR,U)'=""),($P(ARADDR,U,4)'=""),($P(ARADDR,U,5)'=""),(($P(ARADDR,U,6
)'="")) S ARFLAG="Y"
"RTN","RCCPCAP",139,0)
 S PH=PH_U_$E(COUNTRY,1,11)
"RTN","RCCPCAP",140,0)
 ; Set DFN and ICN for Debtor and Patient with Null space for Total Amount Rece
ived
"RTN","RCCPCAP",141,0)
 S PH=PH_U_U_SITE_DFN_U_ICN
"RTN","RCCPCAP",142,0)
 ; Set ARFLAG from above
"RTN","RCCPCAP",143,0)
 S PH=PH_U_ARFLAG
"RTN","RCCPCAP",144,0)
 ; Set Null spaces for Last Bill Prepared Date for Debtor and Number of PD Segm
ents
"RTN","RCCPCAP",145,0)
 ; and then Record Delimiter
"RTN","RCCPCAP",146,0)
 S PH=PH_U_U_U_"}"
"RTN","RCCPCAP",147,0)
 ; Update file
"RTN","RCCPCAP",148,0)
 S PRCAFDA(349.51,"+"_(LINE)_","_PSCNTR_",",.01)=PH
"RTN","RCCPCAP",149,0)
 D UPDATE^DIE("","PRCAFDA","LINE")
"RTN","RCCPCAP",150,0)
 ; Add length to SIZE
"RTN","RCCPCAP",151,0)
 S SIZE=SIZE+$L(PH)
"RTN","RCCPCAP",152,0)
 ; Increment PS segment piece 6 with another PH record
"RTN","RCCPCAP",153,0)
 S $P(^RCAP(349.5,PSSEG(PSCNTR),1,1,0),U,6)=$P(^RCAP(349.5,PSSEG(PSCNTR),1,1,0)
,U,6)+1
"RTN","RCCPCAP",154,0)
 Q
"RTN","RCCPCAP",155,0)
 ;
"RTN","RCCPCAP",156,0)
SETPD(DEBTOR,DATE,TRANS,PSCNTR)  ; Get and Set Data for PD Record into 349.5
"RTN","RCCPCAP",157,0)
 N DR,DA,DIE,PD,AMT,PHTOT,BILL,CURBDT,PRCAFDA
"RTN","RCCPCAP",158,0)
 ; Get Transaction Amount - Quit if Amount is zero or null
"RTN","RCCPCAP",159,0)
 S AMT=$P($G(^PRCA(433,TRANS,1)),U,5)
"RTN","RCCPCAP",160,0)
 I 'AMT Q
"RTN","RCCPCAP",161,0)
 ; Format Amount
"RTN","RCCPCAP",162,0)
 S AMT=$TR($J(AMT,9,2)," ","")
"RTN","RCCPCAP",163,0)
 S AMT=$P(AMT,".")_$P(AMT,".",2)
"RTN","RCCPCAP",164,0)
 ;
"RTN","RCCPCAP",165,0)
 S LINE=LINE+1
"RTN","RCCPCAP",166,0)
 S LASTPD=LINE
"RTN","RCCPCAP",167,0)
 ; Format and Set Date Entered, Amount, and Delimiter
"RTN","RCCPCAP",168,0)
 S PD="PD"_U_$$DAT^RCCPCFN(DATE)_U_AMT_U_"}"
"RTN","RCCPCAP",169,0)
 ; 
"RTN","RCCPCAP",170,0)
 ; Add length to SIZE
"RTN","RCCPCAP",171,0)
 S SIZE=SIZE+$L(PD)
"RTN","RCCPCAP",172,0)
 ; 
"RTN","RCCPCAP",173,0)
 ; Update file
"RTN","RCCPCAP",174,0)
 S PRCAFDA(349.51,"+"_(LINE)_","_PSCNTR_",",.01)=PD
"RTN","RCCPCAP",175,0)
 D UPDATE^DIE("","PRCAFDA","LINE")
"RTN","RCCPCAP",176,0)
 ; 
"RTN","RCCPCAP",177,0)
 ; Get current PH Total, add Amount, then reset to PH Segment
"RTN","RCCPCAP",178,0)
 S PHTOT=$P(^RCAP(349.5,PSSEG(PSCNTR),1,PHSEG(PHCNTR),0),U,13)
"RTN","RCCPCAP",179,0)
 S PHTOT=PHTOT+AMT
"RTN","RCCPCAP",180,0)
 S $P(^RCAP(349.5,PSSEG(PSCNTR),1,PHSEG(PHCNTR),0),U,13)=PHTOT
"RTN","RCCPCAP",181,0)
 ;
"RTN","RCCPCAP",182,0)
 ; Determine the Current Bill Date and if greater than LTBDT, Latest Bill Date,
 
"RTN","RCCPCAP",183,0)
 ; set to PH Segment and LTBDT
"RTN","RCCPCAP",184,0)
 S BILL=$P($G(^PRCA(433,TRANS,0)),U,2)
"RTN","RCCPCAP",185,0)
 S CURBDT=$P($G(^PRCA(430,BILL,0)),U,10)
"RTN","RCCPCAP",186,0)
 I CURBDT>LTBDT S $P(^RCAP(349.5,PSSEG(PSCNTR),1,PHSEG(PHCNTR),0),U,17)=$$DAT^R
CCPCFN(CURBDT),LTBDT=CURBDT
"RTN","RCCPCAP",187,0)
 ;
"RTN","RCCPCAP",188,0)
 ; Increment PH segment piece 18 with another PD record
"RTN","RCCPCAP",189,0)
 S $P(^RCAP(349.5,PSSEG(PSCNTR),1,PHSEG(PHCNTR),0),U,18)=$P(^RCAP(349.5,PSSEG(P
SCNTR),1,PHSEG(PHCNTR),0),U,18)+1
"RTN","RCCPCAP",190,0)
 Q
"RTN","RCCPCAP",191,0)
 ;
"RTN","RCCPCAR")
0^23^B47488689^n/a
"RTN","RCCPCAR",1,0)
RCCPCAR ;ALB/TGH - PATCH PRCA*4.5*ANNUAL PAYMENT REPORT ; 2/3/2016 11:30 am
"RTN","RCCPCAR",2,0)
 ;;4.5;Accounts Receivable;**313**;Feb 20, 2017;Build 118
"RTN","RCCPCAR",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCAR",4,0)
EN(YEAR)  ;  Report errors for the payment statements for Year entered
"RTN","RCCPCAR",5,0)
 ; Year is the first three numbers of the Internal Date format
"RTN","RCCPCAR",6,0)
 ;
"RTN","RCCPCAR",7,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCAR",8,0)
 L +^TMP($J,"MSG"):DILOCKTM I '$T D  Q
"RTN","RCCPCAR",9,0)
 . W *7,*7,!,"Annual Payment Error Report is already being run or transmitted."
"RTN","RCCPCAR",10,0)
 . W !,"Try again later."
"RTN","RCCPCAR",11,0)
 ;
"RTN","RCCPCAR",12,0)
 K ^TMP($J,"MSG")
"RTN","RCCPCAR",13,0)
 N STARTDT,ENDDT,LINE,DEBTOR,PATSSN
"RTN","RCCPCAR",14,0)
 ;
"RTN","RCCPCAR",15,0)
 ; Initialize YEAR to current year if Null
"RTN","RCCPCAR",16,0)
 I $G(YEAR)="" S YEAR=$E(DT,1,3)
"RTN","RCCPCAR",17,0)
 ; 
"RTN","RCCPCAR",18,0)
 ; Set Start and End Dates
"RTN","RCCPCAR",19,0)
 S STARTDT=YEAR_"0100"
"RTN","RCCPCAR",20,0)
 S ENDDT=YEAR_1232
"RTN","RCCPCAR",21,0)
 S LINE=0
"RTN","RCCPCAR",22,0)
 S DEBTOR=""
"RTN","RCCPCAR",23,0)
 F  S DEBTOR=$O(^PRCA(433,"ATD",DEBTOR)) Q:DEBTOR=""  D
"RTN","RCCPCAR",24,0)
 . ; Quit if the debtor is not a patient
"RTN","RCCPCAR",25,0)
 . I '$D(^RCD(340,"AB","DPT(",DEBTOR)) Q
"RTN","RCCPCAR",26,0)
 . N DATE,PATERROR,PHSET
"RTN","RCCPCAR",27,0)
 . S (PHSET,PATERROR)=0
"RTN","RCCPCAR",28,0)
 . S DATE=STARTDT
"RTN","RCCPCAR",29,0)
 . F  S DATE=$O(^PRCA(433,"ATD",DEBTOR,DATE)) Q:DATE=""  Q:DATE>ENDDT  D
"RTN","RCCPCAR",30,0)
 .. ; Recheck and Quit if the date is not within the Year
"RTN","RCCPCAR",31,0)
 .. I DATE<STARTDT!(DATE>ENDDT) Q
"RTN","RCCPCAR",32,0)
 .. ; Set Final Date for this Debtor to determine final transaction
"RTN","RCCPCAR",33,0)
 .. N TRANS
"RTN","RCCPCAR",34,0)
 .. S TRANS=""
"RTN","RCCPCAR",35,0)
 .. F  S TRANS=$O(^PRCA(433,"ATD",DEBTOR,DATE,TRANS)) Q:TRANS=""  D
"RTN","RCCPCAR",36,0)
 ... ; Quit if the Transaction Type is not Payment in Part(2) or Payment in Ful
l(34)
"RTN","RCCPCAR",37,0)
 ... I $P(^PRCA(433,TRANS,1),U,2)'=2&($P(^PRCA(433,TRANS,1),U,2)'=34) Q
"RTN","RCCPCAR",38,0)
 ... ; Check PH Record if first time for this Debtor
"RTN","RCCPCAR",39,0)
 ... I 'PHSET D CHECKPH(DEBTOR) S PHSET=1
"RTN","RCCPCAR",40,0)
 ... ; Check PD Record for each Payment Transaction
"RTN","RCCPCAR",41,0)
 ... D CHECKPD(DEBTOR,DATE,TRANS)
"RTN","RCCPCAR",42,0)
 ;
"RTN","RCCPCAR",43,0)
 ; If there are any errors Send MailMan Message with Errors in ^TMP($J,"MSG")
"RTN","RCCPCAR",44,0)
 I $D(^TMP($J,"MSG")) D TRANSMIT
"RTN","RCCPCAR",45,0)
 ; If there are no errors Send MailMan Message with No Errors Line
"RTN","RCCPCAR",46,0)
 I '$D(^TMP($J,"MSG")) D
"RTN","RCCPCAR",47,0)
 . S ^TMP($J,"MSG",1,0)="No annual patient payment data inconsistencies found."
"RTN","RCCPCAR",48,0)
 . D TRANSMIT
"RTN","RCCPCAR",49,0)
 ;
"RTN","RCCPCAR",50,0)
 K ^TMP($J,"MSG")
"RTN","RCCPCAR",51,0)
 ; PRCA*4.5*313 - Unlock following transmission
"RTN","RCCPCAR",52,0)
 L -^TMP($J,"MSG"):DILOCKTM
"RTN","RCCPCAR",53,0)
 Q
"RTN","RCCPCAR",54,0)
 ;
"RTN","RCCPCAR",55,0)
CHECKPH(DEBTOR)  ; Check Data for PH Record
"RTN","RCCPCAR",56,0)
 N SSN,PATNAME,I,ARADDR,ADDRER,DFN,ICN,BILLDATE,COUNTRY,ST
"RTN","RCCPCAR",57,0)
 ;
"RTN","RCCPCAR",58,0)
 ; Get and Check DFN for Debtor.  If DFN is Null or does not start with a numbe
r
"RTN","RCCPCAR",59,0)
 ; write Error with Debtor Number and then Quit, as other data is dependent upo
n DFN
"RTN","RCCPCAR",60,0)
 S DFN=+$P(^RCD(340,DEBTOR,0),U)
"RTN","RCCPCAR",61,0)
 I 'DFN D SETERROR("Debtor Number: "_DEBTOR,"Missing DFN") Q
"RTN","RCCPCAR",62,0)
 ;
"RTN","RCCPCAR",63,0)
 ; Get Patient Name and SSN
"RTN","RCCPCAR",64,0)
 S PATNAME=$$NAM^RCFN01(DEBTOR)
"RTN","RCCPCAR",65,0)
 S SSN=$$SSN^RCFN01(DEBTOR)
"RTN","RCCPCAR",66,0)
 S PATSSN=PATNAME_"  LAST-4: "_$E(SSN,6,9)
"RTN","RCCPCAR",67,0)
 ;
"RTN","RCCPCAR",68,0)
 ; Get and Check DFN and ICN for Debtor and Patient
"RTN","RCCPCAR",69,0)
 I $L(DFN)>8 D SETERROR(PATSSN,"Invalid DFN")
"RTN","RCCPCAR",70,0)
 S ICN=$$GETICN^MPIF001(DFN)
"RTN","RCCPCAR",71,0)
 I +ICN=-1!($L(ICN)>17) D SETERROR(PATSSN,"Missing or Invalid ICN")
"RTN","RCCPCAR",72,0)
 ; 
"RTN","RCCPCAR",73,0)
 ; Check Patient Name and SSN
"RTN","RCCPCAR",74,0)
 I SSN=""!(SSN'?9N) D SETERROR(PATSSN,"Missing or Invalid SSN")
"RTN","RCCPCAR",75,0)
 I $P(PATNAME,",")="" D SETERROR(PATSSN,"Missing or Invalid Last Name")
"RTN","RCCPCAR",76,0)
 I $P($P(PATNAME,",",2)," ")="" D SETERROR(PATSSN,"Missing or Invalid First Nam
e")
"RTN","RCCPCAR",77,0)
 ;
"RTN","RCCPCAR",78,0)
 ; Get and Check Address
"RTN","RCCPCAR",79,0)
 S ARADDR=$P($$DADD^RCAMADD(DEBTOR,1),U,1,6)
"RTN","RCCPCAR",80,0)
 F I=1,4 I $P(ARADDR,U,I)=""!($L($P(ARADDR,U,I))>40!('$L($TR($P(ARADDR,U,I)," "
,"")))) D
"RTN","RCCPCAR",81,0)
 . S ADDRER(I)=$S(I=1:"Address Line 1",I=4:"City")
"RTN","RCCPCAR",82,0)
 . D SETERROR(PATSSN,"Missing or Invalid "_ADDRER(I))
"RTN","RCCPCAR",83,0)
 N ADDRER
"RTN","RCCPCAR",84,0)
 F I=2,3 I $L($P(ARADDR,U,I))>40 D
"RTN","RCCPCAR",85,0)
 . S ADDRER(I)=$S(I=2:"Address Line 2",I=3:"Address Line 3")
"RTN","RCCPCAR",86,0)
 . D SETERROR(PATSSN,"Invalid "_ADDRER(I))
"RTN","RCCPCAR",87,0)
 ;
"RTN","RCCPCAR",88,0)
 ; If the Zip Code is Null from DADD^RCMADD set Piece 6 of ARADDR to Piece 6 of
 .11
"RTN","RCCPCAR",89,0)
 I $P(ARADDR,U,6)="" S $P(ARADDR,U,6)=$P($G(^DPT(DFN,.11)),U,6)
"RTN","RCCPCAR",90,0)
 ;
"RTN","RCCPCAR",91,0)
 ; If Country is not '1' get Country Name for use in validating the State and Z
ip Code
"RTN","RCCPCAR",92,0)
 S COUNTRY=$P($G(^DPT(DFN,.11)),U,10)
"RTN","RCCPCAR",93,0)
 S COUNTRY=$S(COUNTRY=1:"",1:$$GET1^DIQ(779.004,COUNTRY,"POSTAL NAME"))
"RTN","RCCPCAR",94,0)
 ; State has three Error conditions
"RTN","RCCPCAR",95,0)
 ; If the State is Not Null and is not 2 characters 
"RTN","RCCPCAR",96,0)
 ; If the State is Not Null and is not a Valid US State
"RTN","RCCPCAR",97,0)
 ; If the State is Not Null and the Country is Not Null
"RTN","RCCPCAR",98,0)
 ; If the State is Null and the Country is Null
"RTN","RCCPCAR",99,0)
 I $P(ARADDR,U,5)'="",$L($P(ARADDR,U,5))'=2 D SETERROR(PATSSN,"Missing or Inval
id State")
"RTN","RCCPCAR",100,0)
 S ST=$O(^DIC(5,"C",$P(ARADDR,U,5),""))
"RTN","RCCPCAR",101,0)
 I $P(ARADDR,U,5)'="",ST="" D SETERROR(PATSSN,"Missing or Invalid State")
"RTN","RCCPCAR",102,0)
 I $P(ARADDR,U,5)'="",ST'="",$P(^DIC(5,ST,0),U,6)'=1 D SETERROR(PATSSN,"Missing
 or Invalid State")
"RTN","RCCPCAR",103,0)
 I $P(ARADDR,U,5)'=""&(COUNTRY'="") D SETERROR(PATSSN,"Missing or Invalid State
")
"RTN","RCCPCAR",104,0)
 I $P(ARADDR,U,5)=""&(COUNTRY="") D SETERROR(PATSSN,"Missing or Invalid State")
"RTN","RCCPCAR",105,0)
 ; Zip Code has three Error conditions
"RTN","RCCPCAR",106,0)
 ; If the Zip Code is Not Null and is not 5 to 9 Numerics
"RTN","RCCPCAR",107,0)
 ; If the Zip Code is Not Null and the Country is Not Null
"RTN","RCCPCAR",108,0)
 ; If the Zip Code is Null and the Country is Null
"RTN","RCCPCAR",109,0)
 I $P(ARADDR,U,6)'=""&($P(ARADDR,U,6)'?5.9N) D SETERROR(PATSSN,"Missing or Inva
lid Zip Code")
"RTN","RCCPCAR",110,0)
 I $P(ARADDR,U,6)'=""&(COUNTRY'="") D SETERROR(PATSSN,"Missing or Invalid Zip C
ode")
"RTN","RCCPCAR",111,0)
 I $P(ARADDR,U,6)=""&(COUNTRY="") D SETERROR(PATSSN,"Missing or Invalid Zip Cod
e")
"RTN","RCCPCAR",112,0)
 Q
"RTN","RCCPCAR",113,0)
 ;
"RTN","RCCPCAR",114,0)
CHECKPD(DEBTOR,DATE,TRANS)  ; Get and Set Data for PD Record into 349.5
"RTN","RCCPCAR",115,0)
 N AMT
"RTN","RCCPCAR",116,0)
 ; Get and Check Transaction Amount
"RTN","RCCPCAR",117,0)
 S AMT=$P(^PRCA(433,TRANS,1),U,5)
"RTN","RCCPCAR",118,0)
 ; Format Amount
"RTN","RCCPCAR",119,0)
 S AMT=$TR($J(AMT,9,2)," ","")
"RTN","RCCPCAR",120,0)
 S AMT=$P(AMT,".")_$P(AMT,".",2)
"RTN","RCCPCAR",121,0)
 I 'AMT!($L(AMT)>10) D SETERROR(PATSSN,"Amount in Transaction "_TRANS_" Invalid
")
"RTN","RCCPCAR",122,0)
 ;
"RTN","RCCPCAR",123,0)
 ; Get and Check Transaction Date
"RTN","RCCPCAR",124,0)
 I $P(DATE,".")'?7N.N D SETERROR(PATSSN,"Date for Transaction "_TRANS_" Invalid
")
"RTN","RCCPCAR",125,0)
 Q
"RTN","RCCPCAR",126,0)
 ;
"RTN","RCCPCAR",127,0)
SETERROR(PATSSN,ERROR)  ; Set the error into TMP($J,"MSG",LINE,0) for transmiss
ion
"RTN","RCCPCAR",128,0)
 ; If the first time thru for this patient set the Name and SSN in message
"RTN","RCCPCAR",129,0)
 ; with a blank line above the Patient Data for spacing
"RTN","RCCPCAR",130,0)
 I 'PATERROR D
"RTN","RCCPCAR",131,0)
 . S LINE=LINE+1,^TMP($J,"MSG",LINE,0)=""
"RTN","RCCPCAR",132,0)
 . S LINE=LINE+1,^TMP($J,"MSG",LINE,0)=PATSSN
"RTN","RCCPCAR",133,0)
 . S PATERROR=1
"RTN","RCCPCAR",134,0)
 ; Write Error to next line with a double space in front
"RTN","RCCPCAR",135,0)
 S LINE=LINE+1 S ^TMP($J,"MSG",LINE,0)="  "_ERROR
"RTN","RCCPCAR",136,0)
 Q
"RTN","RCCPCAR",137,0)
 ;
"RTN","RCCPCAR",138,0)
TRANSMIT ;set up and send mail message - copied from RCCPCML
"RTN","RCCPCAR",139,0)
 N L,XMDUZ,XMSUB,XMY,XMZ,Z,ERROR,NM,PSN,RTY
"RTN","RCCPCAR",140,0)
 S XMSUB=$$SITE^RCMSITE()_" ANNUAL PAYMENT ERROR REPORT "_20_$E(YEAR,2,3)_" TO 
CURRENT DATE"
"RTN","RCCPCAR",141,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCAR",142,0)
 I $O(^XMB(3.8,"B","RCCPC STATEMENTS","")),$P($G(^RC(342,1,0)),U,12) S XMY("G.R
CCPC STATEMENTS")=""
"RTN","RCCPCAR",143,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCAR",144,0)
 D XMZ^XMA2
"RTN","RCCPCAR",145,0)
 I XMZ<1 S RTY=RTY+1 G TRANSMIT:RTY<4 S ERROR=5,NM=0 D ERROR Q
"RTN","RCCPCAR",146,0)
 S (L,L(1))=0 F  S L(1)=$O(^TMP($J,"MSG",L(1))) Q:'L(1)  I $D(^TMP($J,"MSG",L(1
),0)) S L=L+1,^XMB(3.9,+XMZ,2,L,0)=^TMP($J,"MSG",L(1),0)
"RTN","RCCPCAR",147,0)
 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_L_U_L_U_DT
"RTN","RCCPCAR",148,0)
 D ENT1^XMD
"RTN","RCCPCAR",149,0)
 D NOW^%DTC
"RTN","RCCPCAR",150,0)
 Q
"RTN","RCCPCAR",151,0)
 ;
"RTN","RCCPCAR",152,0)
ERROR  ;ERROR FILE - Copied from RCCPCML
"RTN","RCCPCAR",153,0)
 I NM=0 S ^TMP($J,"ERROR",ERROR,NM)="" Q
"RTN","RCCPCAR",154,0)
 Q
"RTN","RCCPCAR",155,0)
 ;
"RTN","RCCPCAR",156,0)
MANBLD  ; Build and Transmit the Annual Payment Statement Consistency Checker
"RTN","RCCPCAR",157,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCAR",158,0)
 L +^TMP($J,"MSG"):DILOCKTM I '$T D  Q
"RTN","RCCPCAR",159,0)
 . W *7,*7,!,"Annual Payment Error Report is already being run or transmitted."
"RTN","RCCPCAR",160,0)
 . W !,"Try again later."
"RTN","RCCPCAR",161,0)
 ; PRCA*4.5*313 - Unlock prior to preparing and transmitting
"RTN","RCCPCAR",162,0)
 L -^TMP($J,"MSG"):DILOCKTM
"RTN","RCCPCAR",163,0)
 ;
"RTN","RCCPCAR",164,0)
 N YEAR,DATE,DIR,X,ZTIO,ZTRTN,ZTDESC,ZTDTH,ZTSK,QDT,%,%H
"RTN","RCCPCAR",165,0)
 S YEAR=20_$E(DT,2,3)
"RTN","RCCPCAR",166,0)
 S DIR(0)="YAO"
"RTN","RCCPCAR",167,0)
 S DIR("B")="N"
"RTN","RCCPCAR",168,0)
 S DIR("A")="Do you want to Run and Transmit the Consistency Checker for "_YEAR
_" to the current date? "
"RTN","RCCPCAR",169,0)
 S DIR("??")="^D MANHLP^RCCPCAR"
"RTN","RCCPCAR",170,0)
 D ^DIR
"RTN","RCCPCAR",171,0)
 I $E(X)'="Y" Q
"RTN","RCCPCAR",172,0)
 S ZTIO="",ZTRTN="EN^RCCPCAR("_$E(DT,1,3)_")"
"RTN","RCCPCAR",173,0)
 S ZTDESC="Annual Payment Statement File Consistency Checker"
"RTN","RCCPCAR",174,0)
 S ZTDTH="" D ^%ZTLOAD Q:$G(ZTSK)=""
"RTN","RCCPCAR",175,0)
 S %H=ZTSK("D") D YMD^%DTC S QDT=X_%
"RTN","RCCPCAR",176,0)
 Q
"RTN","RCCPCAR",177,0)
 ;
"RTN","RCCPCAR",178,0)
MANHLP  ; "??" Help for MANBLD
"RTN","RCCPCAR",179,0)
 W !,"Enter 'N' or Return to Quit. 'Y' to Run and Transmit the Consistency Chec
ker."
"RTN","RCCPCAR",180,0)
 Q
"RTN","RCCPCAT")
0^22^B34521600^n/a
"RTN","RCCPCAT",1,0)
RCCPCAT ;ALB/TGH - PATCH PRCA*4.5*ANNUAL PAYMENT TRANSMIT ; 2/3/2016 11:30 am
"RTN","RCCPCAT",2,0)
 ;;4.5;Accounts Receivable;**313**;Feb 20, 2017;Build 118
"RTN","RCCPCAT",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCAT",4,0)
EN(DTTIME)  ;Schedule the Transmit
"RTN","RCCPCAT",5,0)
 N ZTDESC,ZTASK,ZTDTH,ZTIO,ZTRTN
"RTN","RCCPCAT",6,0)
 S ZTIO="",ZTRTN="TRANSMIT^RCCPCAT"
"RTN","RCCPCAT",7,0)
 S ZTDESC="ANNUAL PAYMENT STATEMENT TRANSMISSION"
"RTN","RCCPCAT",8,0)
 ; Initialize Transmit date and time
"RTN","RCCPCAT",9,0)
 I DTTIME="" S DTTIME=%H
"RTN","RCCPCAT",10,0)
 S ZTDTH=DTTIME
"RTN","RCCPCAT",11,0)
 D ^%ZTLOAD Q:$G(ZTSK)=""
"RTN","RCCPCAT",12,0)
 Q
"RTN","RCCPCAT",13,0)
 ;
"RTN","RCCPCAT",14,0)
TRANSMIT  ; Send Annual Payment Statement Files to AITC from RCAP(349.5
"RTN","RCCPCAT",15,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCAT",16,0)
 L +^RCAP(349.5):DILOCKTM I '$T W *7,*7,!,"Annual Payment is already being run 
or transmitted.  Try again later." Q
"RTN","RCCPCAT",17,0)
 ;
"RTN","RCCPCAT",18,0)
 K ^TMP($J,"MSG")
"RTN","RCCPCAT",19,0)
 N PSCNTR,%,%I,%H,YEAR
"RTN","RCCPCAT",20,0)
 S YEAR=20_$E($P(^RCAP(349.5,1,0),U,2),2,3)
"RTN","RCCPCAT",21,0)
 S PSCNTR=0
"RTN","RCCPCAT",22,0)
 F  S PSCNTR=$O(^RCAP(349.5,PSCNTR)) Q:'PSCNTR  D
"RTN","RCCPCAT",23,0)
 . ; Set Transmit Start Date and Time
"RTN","RCCPCAT",24,0)
 . D NOW^%DTC
"RTN","RCCPCAT",25,0)
 . S $P(^RCAP(349.5,PSCNTR,0),U,5)=%
"RTN","RCCPCAT",26,0)
 . ; Merge all PS elements into TMP MSG file
"RTN","RCCPCAT",27,0)
 . M ^TMP($J,"MSG")=^RCAP(349.5,PSCNTR,1)
"RTN","RCCPCAT",28,0)
 . D MAIL
"RTN","RCCPCAT",29,0)
 . ; Set Transmit End Date and Time
"RTN","RCCPCAT",30,0)
 . D NOW^%DTC
"RTN","RCCPCAT",31,0)
 . S $P(^RCAP(349.5,PSCNTR,0),U,6)=%
"RTN","RCCPCAT",32,0)
 ;
"RTN","RCCPCAT",33,0)
 ; PRCA*4.5*313 - Unlock prior to quit
"RTN","RCCPCAT",34,0)
 L -^RCAP(349.5):DILOCKTM
"RTN","RCCPCAT",35,0)
 Q
"RTN","RCCPCAT",36,0)
 ;
"RTN","RCCPCAT",37,0)
MAIL ;set up and send mail message - copied from RCCPCML
"RTN","RCCPCAT",38,0)
 N L,XMDUZ,XMSUB,XMY,XMZ,Z,ERROR,NM,PSN,RTY,X
"RTN","RCCPCAT",39,0)
 S XMSUB=$$SITE^RCMSITE()_" ANNUAL PAYMENT TRANSMISSION "_YEAR
"RTN","RCCPCAT",40,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCAT",41,0)
 I $O(^XMB(3.8,"B","RCCPC STATEMENTS","")),$P($G(^RC(342,1,0)),U,12) S XMY("G.R
CCPC STATEMENTS")=""
"RTN","RCCPCAT",42,0)
 S X=$O(^RCT(349.1,"B","PY",0))
"RTN","RCCPCAT",43,0)
 I X,$P($G(^RCT(349.1,+X,0)),U,3) S X=$P($G(^RCT(349.1,+X,3)),U)_"@"_$P($G(^RCT
(349.1,+X,3)),U,3) S:$P(X,"@",2)]"" XMY(X)=""
"RTN","RCCPCAT",44,0)
 I $P(X,"@",2)']"" D  Q
"RTN","RCCPCAT",45,0)
 .S ERROR=6,NM=0 D ERROR
"RTN","RCCPCAT",46,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCAT",47,0)
 D XMZ^XMA2
"RTN","RCCPCAT",48,0)
 I XMZ<1 S RTY=RTY+1 G MAIL:RTY<4 S ERROR=5,NM=0 D ERROR Q
"RTN","RCCPCAT",49,0)
 S (L,L(1))=0 F  S L(1)=$O(^TMP($J,"MSG",L(1))) Q:'L(1)  I $D(^TMP($J,"MSG",L(1
),0)) S L=L+1,^XMB(3.9,+XMZ,2,L,0)=^TMP($J,"MSG",L(1),0)
"RTN","RCCPCAT",50,0)
 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_L_U_L_U_DT
"RTN","RCCPCAT",51,0)
 D ENT1^XMD
"RTN","RCCPCAT",52,0)
 D NOW^%DTC
"RTN","RCCPCAT",53,0)
 K ^TMP($J,"MSG")
"RTN","RCCPCAT",54,0)
 Q
"RTN","RCCPCAT",55,0)
 ;
"RTN","RCCPCAT",56,0)
SCHED(SITE)  ; Determine the date and time for Transmit based upon Site Code an
d table AITC provided
"RTN","RCCPCAT",57,0)
 ; Time will always be 2:00 AM
"RTN","RCCPCAT",58,0)
 I SITE>401&(SITE<520) S DTTIME=$E(DT,1,5)_"03.020000" Q DTTIME
"RTN","RCCPCAT",59,0)
 I SITE>519&(SITE<541) S DTTIME=$E(DT,1,5)_"04.020000" Q DTTIME
"RTN","RCCPCAT",60,0)
 I SITE>540&(SITE<559) S DTTIME=$E(DT,1,5)_"05.020000" Q DTTIME
"RTN","RCCPCAT",61,0)
 I SITE>560&(SITE<581) S DTTIME=$E(DT,1,5)_"06.020000" Q DTTIME
"RTN","RCCPCAT",62,0)
 I SITE>580&(SITE<599) S DTTIME=$E(DT,1,5)_"07.020000" Q DTTIME
"RTN","RCCPCAT",63,0)
 I SITE>599&(SITE<620) S DTTIME=$E(DT,1,5)_"08.020000" Q DTTIME
"RTN","RCCPCAT",64,0)
 I SITE>619&(SITE<641) S DTTIME=$E(DT,1,5)_"09.020000" Q DTTIME
"RTN","RCCPCAT",65,0)
 I SITE>641&(SITE<658) S DTTIME=$E(DT,1,5)_"10.020000" Q DTTIME
"RTN","RCCPCAT",66,0)
 I SITE>657&(SITE<675) S DTTIME=$E(DT,1,5)_"11.020000" Q DTTIME
"RTN","RCCPCAT",67,0)
 I SITE>674&(SITE<758) S DTTIME=$E(DT,1,5)_"12.020000" Q DTTIME
"RTN","RCCPCAT",68,0)
 S DTTIME=""
"RTN","RCCPCAT",69,0)
 Q DTTIME
"RTN","RCCPCAT",70,0)
 ;
"RTN","RCCPCAT",71,0)
MANBLD  ; Build and Transmit the Annual Payment Statement after initial yearly 
transmission
"RTN","RCCPCAT",72,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCAT",73,0)
 L +^RCAP(349.5):DILOCKTM I '$T D MENUERR Q
"RTN","RCCPCAT",74,0)
 ; PRCA*4.5*313 - Unlock prior to transmitting
"RTN","RCCPCAT",75,0)
 L -^RCAP(349.5):DILOCKTM
"RTN","RCCPCAT",76,0)
 ;
"RTN","RCCPCAT",77,0)
 N YEAR,DATE,DIR,X,ZTIO,ZTRTN,ZTDESC,ZTDTH,ZTSK,QDT
"RTN","RCCPCAT",78,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCAT",79,0)
 S YEAR=$P($G(^RCAP(349.5,1,0)),U,2)
"RTN","RCCPCAT",80,0)
 S YEAR("EXT")=20_$E(YEAR,2,3)
"RTN","RCCPCAT",81,0)
 S DATE=+$P($G(^RCAP(349.5,1,0)),U,6)
"RTN","RCCPCAT",82,0)
 S DATE=$S(DATE'="":$$SLH^RCFN01(DATE),1:"")
"RTN","RCCPCAT",83,0)
 W !!,"The Annual Payment File for "_YEAR("EXT")_" was transmitted on "_DATE_".
"
"RTN","RCCPCAT",84,0)
 S DIR(0)="YAO"
"RTN","RCCPCAT",85,0)
 S DIR("B")="N"
"RTN","RCCPCAT",86,0)
 S DIR("A")="Do you want to Build and Transmit the file for "_YEAR("EXT")_" aga
in? "
"RTN","RCCPCAT",87,0)
 S DIR("??")="^D MANHLP^RCCPCAT"
"RTN","RCCPCAT",88,0)
 D ^DIR
"RTN","RCCPCAT",89,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCAT",90,0)
 I $E(X)'="Y" Q
"RTN","RCCPCAT",91,0)
 W !!,">> PLEASE CONTACT CUSTOMER SUPPORT BEFORE PROCEEDING <<",!!
"RTN","RCCPCAT",92,0)
 S ZTIO="",ZTRTN="EN^RCCPCAP("_YEAR_","_"""F"""_","_""""""_")"
"RTN","RCCPCAT",93,0)
 S ZTDESC="Build Annual Payment Statement File"
"RTN","RCCPCAT",94,0)
 S ZTDTH="" D ^%ZTLOAD Q:$G(ZTSK)=""
"RTN","RCCPCAT",95,0)
 S %H=ZTSK("D") D YMD^%DTC S QDT=X_%
"RTN","RCCPCAT",96,0)
 Q
"RTN","RCCPCAT",97,0)
 ;
"RTN","RCCPCAT",98,0)
RETRANS  ; Retransmit the existing file and allow user to select date and time
"RTN","RCCPCAT",99,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCAT",100,0)
 L +^RCAP(349.5):DILOCKTM I '$T D MENUERR Q
"RTN","RCCPCAT",101,0)
 ; PRCA*4.5*313 - Unlock prior to retransmitting
"RTN","RCCPCAT",102,0)
 L -^RCAP(349.5):DILOCKTM
"RTN","RCCPCAT",103,0)
 ;
"RTN","RCCPCAT",104,0)
 N YEAR,DATE,DIR,X,ZTIO,ZTRTN,ZTDESC,ZTDTH,ZTSK,QDT
"RTN","RCCPCAT",105,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCAT",106,0)
 S YEAR=$P($G(^RCAP(349.5,1,0)),U,2)
"RTN","RCCPCAT",107,0)
 S YEAR("EXT")=20_$E(YEAR,2,3)
"RTN","RCCPCAT",108,0)
 S DATE=$P($G(^RCAP(349.5,$P(^RCAP(349.5,0),U,4),0)),U,6)
"RTN","RCCPCAT",109,0)
 S DATE=$S(DATE'="":$$SLH^RCFN01(DATE),1:"")
"RTN","RCCPCAT",110,0)
 W !!,"The Annual Payment File for "_YEAR("EXT")_" was transmitted on "_DATE_".
"
"RTN","RCCPCAT",111,0)
 S DIR(0)="YAO"
"RTN","RCCPCAT",112,0)
 S DIR("B")="N"
"RTN","RCCPCAT",113,0)
 S DIR("A")="Do you want to Retransmit the existing file for "_YEAR("EXT")_" ag
ain? "
"RTN","RCCPCAT",114,0)
 S DIR("??")="^D RETHLP^RCCPCAT"
"RTN","RCCPCAT",115,0)
 D ^DIR
"RTN","RCCPCAT",116,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCAT",117,0)
 I $E(X)'="Y" Q
"RTN","RCCPCAT",118,0)
 W !!,">> PLEASE CONTACT CUSTOMER SUPPORT BEFORE PROCEEDING <<",!!
"RTN","RCCPCAT",119,0)
 S ZTIO="",ZTRTN="TRANSMIT^RCCPCAT"
"RTN","RCCPCAT",120,0)
 S ZTDESC="Retransmit Annual Payment Statement File"
"RTN","RCCPCAT",121,0)
 S ZTDTH="" D ^%ZTLOAD Q:$G(ZTSK)=""
"RTN","RCCPCAT",122,0)
 S %H=ZTSK("D") D YMD^%DTC S QDT=X_%
"RTN","RCCPCAT",123,0)
 Q
"RTN","RCCPCAT",124,0)
 ;
"RTN","RCCPCAT",125,0)
ERROR  ;ERROR FILE - Copied from RCCPCML
"RTN","RCCPCAT",126,0)
 I NM=0 S ^TMP($J,"ERROR",ERROR,NM)="" Q
"RTN","RCCPCAT",127,0)
 Q
"RTN","RCCPCAT",128,0)
 ;
"RTN","RCCPCAT",129,0)
MENUERR  ; Print error to screen if Annual Payment File has not completed for t
his year
"RTN","RCCPCAT",130,0)
 N YEAR
"RTN","RCCPCAT",131,0)
 S YEAR=20_$E(DT,2,3)-1
"RTN","RCCPCAT",132,0)
 W !!,"The Build and Transmit of the Annual Payment File for "_YEAR_" has not c
ompleted."
"RTN","RCCPCAT",133,0)
 W !,"You may not use this option until it completes.",!
"RTN","RCCPCAT",134,0)
 D PAUSE^VALM1
"RTN","RCCPCAT",135,0)
 Q
"RTN","RCCPCAT",136,0)
 ;
"RTN","RCCPCAT",137,0)
MANHLP  ; "??" Help for MANBLD and RETRANS
"RTN","RCCPCAT",138,0)
 W !,"Enter 'N' or Return to Quit. 'Y' to Build and Retransmit file."
"RTN","RCCPCAT",139,0)
 Q
"RTN","RCCPCAT",140,0)
 ;
"RTN","RCCPCAT",141,0)
RETHLP  ; "??" Help for MANBLD and RETRANS
"RTN","RCCPCAT",142,0)
 W !,"Enter 'N' or Return to Quit. 'Y' to Retransmit file."
"RTN","RCCPCAT",143,0)
 Q
"RTN","RCCPCBJ")
0^5^B9440906^B6288491
"RTN","RCCPCBJ",1,0)
RCCPCBJ ;WASH-ISC@ALTOONA,PA/NYB-Background Driver for CCPC ;1/7/97  9:42 AM
"RTN","RCCPCBJ",2,0)
 ;;4.5;Accounts Receivable;**34,76,130,153,166,195,217,237,307,313**;Mar 20, 19
95;Build 118
"RTN","RCCPCBJ",3,0)
 ;;Per VHA Directive 6402, this routine should not be modified.
"RTN","RCCPCBJ",4,0)
EN ;Starts the background job for CCPC 5 days before statement day
"RTN","RCCPCBJ",5,0)
 N X,X1,X2,X3,ZTRTN,ZTIO,ZTDTH,ZTSK,ZTDESC,SDT,RCFULL
"RTN","RCCPCBJ",6,0)
 ;D ACK  PRCA*4.5*313 - Moved into OPEN 
"RTN","RCCPCBJ",7,0)
 D  ;run the cbs nightly account update program everyday
"RTN","RCCPCBJ",8,0)
 .N ZTDESC,ZTASK,ZTDTH,ZTIO,ZTRTN
"RTN","RCCPCBJ",9,0)
 .S RCFULL=0 ;do not send the full debtor list
"RTN","RCCPCBJ",10,0)
 .S ZTIO="",ZTRTN="DEBTOR^PRCACPS1"
"RTN","RCCPCBJ",11,0)
 .S ZTDESC="CBS NIGHTLY ACCOUNT UPDATE PROGRAM",ZTDTH=$H
"RTN","RCCPCBJ",12,0)
 .D ^%ZTLOAD
"RTN","RCCPCBJ",13,0)
 ;
"RTN","RCCPCBJ",14,0)
 I $$DOW^XLFDT(DT,1)=3 D  ;run the cbs auto-correction program on Wednesdays
"RTN","RCCPCBJ",15,0)
 .N ZTDESC,ZTASK,ZTDTH,ZTIO,ZTRTN
"RTN","RCCPCBJ",16,0)
 .S ZTIO="",ZTRTN="START^PRCACPS",ZTSAVE("RCFULL")=""
"RTN","RCCPCBJ",17,0)
 .S ZTDESC="PATIENT STATEMENTS AUTO-CORRECTION PROGRAM",ZTDTH=$H
"RTN","RCCPCBJ",18,0)
 .D ^%ZTLOAD
"RTN","RCCPCBJ",19,0)
 ;
"RTN","RCCPCBJ",20,0)
 ; PRCA*4.5*313 - Run the Annual Payment Statement Build and Transmit 
"RTN","RCCPCBJ",21,0)
 ; on January 2nd of each year for the previous year
"RTN","RCCPCBJ",22,0)
 I $E(DT,4,7)="0102" D
"RTN","RCCPCBJ",23,0)
 . N ZTIO,ZTRTN,ZTDESC,ZTDTH
"RTN","RCCPCBJ",24,0)
 . S ZTIO="",ZTRTN="EN^RCCPCAP",ZTDTH=$H
"RTN","RCCPCBJ",25,0)
 . S ZTDESC="ANNUAL PAYMENT STATEMENT BUILD AND TRANSMIT"
"RTN","RCCPCBJ",26,0)
 . D ^%ZTLOAD
"RTN","RCCPCBJ",27,0)
 ;
"RTN","RCCPCBJ",28,0)
 ; PRCA*4.5*313 - Run the Annual Payment Error Report on March, June, September
 and 
"RTN","RCCPCBJ",29,0)
 ; December 15th
"RTN","RCCPCBJ",30,0)
 I $E(DT,4,5)="03"!($E(DT,4,5)="06")!($E(DT,4,5)="09")!($E(DT,4,5)=12) D
"RTN","RCCPCBJ",31,0)
 . I $E(DT,6,7)'=15 Q
"RTN","RCCPCBJ",32,0)
 . N ZTIO,ZTRTN,ZTDESC,ZTDTH
"RTN","RCCPCBJ",33,0)
 . S ZTIO="",ZTRTN="EN^RCCPCAR",ZTDTH=$H
"RTN","RCCPCBJ",34,0)
 . S ZTDESC="ANNUAL PAYMENT ERROR REPORT"
"RTN","RCCPCBJ",35,0)
 . D ^%ZTLOAD
"RTN","RCCPCBJ",36,0)
 ;
"RTN","RCCPCBJ",37,0)
 I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINA
D
"RTN","RCCPCBJ",38,0)
 ;
"RTN","RCCPCBJ",39,0)
 ; PRCA*4.5*313 - Set Statement Date to two days in future and save for Job
"RTN","RCCPCBJ",40,0)
 S X1=DT,X2=2 D C^%DTC S SDT=X
"RTN","RCCPCBJ",41,0)
 S ZTSAVE("SDT")=SDT
"RTN","RCCPCBJ",42,0)
 S ZTIO="",ZTRTN="OPEN^RCCPCBJ",ZTDESC="CBSS PATIENT STATEMENT"
"RTN","RCCPCBJ",43,0)
 S ZTDTH=$H D ^%ZTLOAD
"RTN","RCCPCBJ",44,0)
 Q
"RTN","RCCPCBJ",45,0)
OPEN ;Update Open status bills to Active or Cancellation status
"RTN","RCCPCBJ",46,0)
 N DAY,BN,DEBTOR,DA,DIE,DR,P,AMT,DATE
"RTN","RCCPCBJ",47,0)
 N ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH
"RTN","RCCPCBJ",48,0)
 ; PRCA*4.5*313 - Check the acknowledgement for previous month
"RTN","RCCPCBJ",49,0)
 D TRANCHK^RCCPCSV1
"RTN","RCCPCBJ",50,0)
 ; PRCA*4.5*313 - Set DATE and day of month from SDT and process that date's de
btors
"RTN","RCCPCBJ",51,0)
 S DATE=SDT,DAY=+$E(SDT,6,7),DEBTOR=""
"RTN","RCCPCBJ",52,0)
 F  S DEBTOR=$O(^RCD(340,"AC",DAY,DEBTOR)) Q:'DEBTOR  D
"RTN","RCCPCBJ",53,0)
 .S BN=0 F  S BN=$O(^PRCA(430,"AS",DEBTOR,$O(^PRCA(430.3,"AC",112,0)),BN)) Q:'B
N  D
"RTN","RCCPCBJ",54,0)
 ..S AMT=0 F P=1:1:5 S AMT=$P($G(^PRCA(430,+BN,7)),"^",P)+AMT
"RTN","RCCPCBJ",55,0)
 ..I $P($G(^PRCA(430,+BN,0)),"^",2)=$O(^PRCA(430.2,"AC",33,0)),AMT Q
"RTN","RCCPCBJ",56,0)
 ..S DIE="^PRCA(430,",DA=+BN,DR="8////^S X="_$S(AMT:$O(^PRCA(430.3,"AC",102,0))
,1:$O(^PRCA(430.3,"AC",111,0))) D ^DIE K DA,DIE,DR
"RTN","RCCPCBJ",57,0)
 ..Q
"RTN","RCCPCBJ",58,0)
 .Q
"RTN","RCCPCBJ",59,0)
 ;
"RTN","RCCPCBJ",60,0)
 ;  update patient accounts with interest and admin
"RTN","RCCPCBJ",61,0)
 N RCLASDAT
"RTN","RCCPCBJ",62,0)
 S RCLASDAT=DATE
"RTN","RCCPCBJ",63,0)
 I DT>3010101 D FIRSTPTY^RCBECHGS
"RTN","RCCPCBJ",64,0)
 ; PRCA*4.5*313 - Added SDT to process and send
"RTN","RCCPCBJ",65,0)
 D EN^RCCPCPS(SDT)
"RTN","RCCPCBJ",66,0)
 D REFUND
"RTN","RCCPCBJ",67,0)
 D EN^RCCPCML(SDT)
"RTN","RCCPCBJ",68,0)
 Q
"RTN","RCCPCBJ",69,0)
 ;
"RTN","RCCPCBJ",70,0)
 ;
"RTN","RCCPCBJ",71,0)
REFUND ;Update Open status PREPAYMENT bills to REFUND REVIEW
"RTN","RCCPCBJ",72,0)
 ; PRCA*4.5*313 - Changed DAY to statement date
"RTN","RCCPCBJ",73,0)
 S DEBTOR=0,DAY=SDT
"RTN","RCCPCBJ",74,0)
 F  S DEBTOR=$O(^RCD(340,"AC",DAY,DEBTOR)) Q:'DEBTOR  D
"RTN","RCCPCBJ",75,0)
 .S BN=0 F  S BN=$O(^PRCA(430,"AS",DEBTOR,$O(^PRCA(430.3,"AC",112,0)),BN)) Q:'B
N  D
"RTN","RCCPCBJ",76,0)
 ..I $P($G(^PRCA(430,+BN,0)),"^",2)=$O(^PRCA(430.2,"AC",33,0)) S X=$$EN^PRCARFU
(+BN)
"RTN","RCCPCBJ",77,0)
 ..Q
"RTN","RCCPCBJ",78,0)
 .Q
"RTN","RCCPCBJ",79,0)
 Q
"RTN","RCCPCBJ",80,0)
 ;
"RTN","RCCPCBJ",81,0)
ACK ;CHECK FOR ACKNOWLEDGEMENTS  PRCA*4.5*313 - No longer used
"RTN","RCCPCBJ",82,0)
 N DEB,MSG,NO,RCX,X,X1,X2
"RTN","RCCPCBJ",83,0)
 S X1=$$STD^RCCPCFN,X2=DT D ^%DTC I X>3 D
"RTN","RCCPCBJ",84,0)
 . D TRANCHK^RCCPCSV1
"RTN","RCCPCBJ",85,0)
 Q
"RTN","RCCPCFN1")
0^7^B7181774^n/a
"RTN","RCCPCFN1",1,0)
RCCPCFN1 ;ALB/TGH-Additional Function calls for CBSS ;12/31/96  9:27 AM
"RTN","RCCPCFN1",2,0)
 ;;4.5;Accounts Receivable;**313**;Mar 31, 2016;Build 118
"RTN","RCCPCFN1",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCFN1",4,0)
ACSET(NAME)  ; Determine the day of the month for each new debtor to have their
 patient statement sent
"RTN","RCCPCFN1",5,0)
 ; by the site to CBSS for consolidation.
"RTN","RCCPCFN1",6,0)
 ; Input:  NAME = Patient's Name
"RTN","RCCPCFN1",7,0)
 ; Output: DAY/GROUP = day of month for patient statement transmission and grou
p number
"RTN","RCCPCFN1",8,0)
 ;         0  = if invalid first character of last name
"RTN","RCCPCFN1",9,0)
 ;
"RTN","RCCPCFN1",10,0)
 N LTR,GROUP,DAY,I
"RTN","RCCPCFN1",11,0)
 ;
"RTN","RCCPCFN1",12,0)
 ; Quit if the patient name is not cross-referenced in the Patient File (#2) - 
return 0
"RTN","RCCPCFN1",13,0)
 I $G(NAME)="" Q 0
"RTN","RCCPCFN1",14,0)
 I '$D(^DPT("B",NAME)) Q 0
"RTN","RCCPCFN1",15,0)
 ;
"RTN","RCCPCFN1",16,0)
 F I=1,2 S LTR(I)=$E(NAME,I)
"RTN","RCCPCFN1",17,0)
 I "AB"[LTR(1) S GROUP=1,DAY=$$GRP1(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",18,0)
 I "CD"[LTR(1) S GROUP=2,DAY=$$GRP2(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",19,0)
 I "EFIQ"[LTR(1) S GROUP=3,DAY=$$GRP3(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",20,0)
 I "GH"[LTR(1) S GROUP=4,DAY=$$GRP4(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",21,0)
 I "JK"[LTR(1) S GROUP=5,DAY=$$GRP5(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",22,0)
 I "LO"[LTR(1) S GROUP=6,DAY=$$GRP6(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",23,0)
 I "MN"[LTR(1) S GROUP=7,DAY=$$GRP7(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",24,0)
 I "T"[LTR(1) S GROUP=8,DAY=$$GRP8(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",25,0)
 I "R"[LTR(1) S GROUP=9,DAY=$$GRP9(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",26,0)
 I "SV"[LTR(1) S GROUP=10,DAY=$$GRP10(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",27,0)
 I "PUXYZ"[LTR(1) S GROUP=11,DAY=$$GRP11(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",28,0)
 I "W"[LTR(1) S GROUP=12,DAY=$$GRP12(.LTR)  Q DAY_"/"_GROUP
"RTN","RCCPCFN1",29,0)
 ;
"RTN","RCCPCFN1",30,0)
 Q 0
"RTN","RCCPCFN1",31,0)
 ;
"RTN","RCCPCFN1",32,0)
GRP1(LTR)  ;AB
"RTN","RCCPCFN1",33,0)
 ;
"RTN","RCCPCFN1",34,0)
 I LTR(1)="A" S DAY=1
"RTN","RCCPCFN1",35,0)
 I LTR(1)="B" D
"RTN","RCCPCFN1",36,0)
 . I "AU"[LTR(2) S DAY=1
"RTN","RCCPCFN1",37,0)
 . I "AU"'[LTR(2) S DAY=2
"RTN","RCCPCFN1",38,0)
 ;
"RTN","RCCPCFN1",39,0)
 Q DAY
"RTN","RCCPCFN1",40,0)
 ;
"RTN","RCCPCFN1",41,0)
GRP2(LTR)  ;CD
"RTN","RCCPCFN1",42,0)
 ;
"RTN","RCCPCFN1",43,0)
 I LTR(1)="D" S DAY=4
"RTN","RCCPCFN1",44,0)
 I LTR(1)="C" D
"RTN","RCCPCFN1",45,0)
 . I "IRU"[LTR(2) S DAY=4
"RTN","RCCPCFN1",46,0)
 . I "IRU"'[LTR(2) S DAY=6
"RTN","RCCPCFN1",47,0)
 ;
"RTN","RCCPCFN1",48,0)
 Q DAY
"RTN","RCCPCFN1",49,0)
 ;
"RTN","RCCPCFN1",50,0)
GRP3(LTR)  ;EFIQ
"RTN","RCCPCFN1",51,0)
 ;
"RTN","RCCPCFN1",52,0)
 S DAY=7
"RTN","RCCPCFN1",53,0)
 ;
"RTN","RCCPCFN1",54,0)
 Q DAY
"RTN","RCCPCFN1",55,0)
 ;
"RTN","RCCPCFN1",56,0)
GRP4(LTR)  ;GH
"RTN","RCCPCFN1",57,0)
 ;
"RTN","RCCPCFN1",58,0)
 I LTR(1)="G" S DAY=8
"RTN","RCCPCFN1",59,0)
 I LTR(1)="H" D
"RTN","RCCPCFN1",60,0)
 . I "E"[LTR(2) S DAY=8
"RTN","RCCPCFN1",61,0)
 . I "E"'[LTR(2) S DAY=10
"RTN","RCCPCFN1",62,0)
 ;
"RTN","RCCPCFN1",63,0)
 Q DAY
"RTN","RCCPCFN1",64,0)
 ;
"RTN","RCCPCFN1",65,0)
GRP5(LTR)  ;JK
"RTN","RCCPCFN1",66,0)
 ;
"RTN","RCCPCFN1",67,0)
 S DAY=12
"RTN","RCCPCFN1",68,0)
 ;
"RTN","RCCPCFN1",69,0)
 Q DAY
"RTN","RCCPCFN1",70,0)
 ;
"RTN","RCCPCFN1",71,0)
GRP6(LTR)  ;LO
"RTN","RCCPCFN1",72,0)
 ;
"RTN","RCCPCFN1",73,0)
 S DAY=14
"RTN","RCCPCFN1",74,0)
 ;
"RTN","RCCPCFN1",75,0)
 Q DAY
"RTN","RCCPCFN1",76,0)
 ;
"RTN","RCCPCFN1",77,0)
GRP7(LTR)  ;MN
"RTN","RCCPCFN1",78,0)
 ;
"RTN","RCCPCFN1",79,0)
 I LTR(1)="N" S DAY=17
"RTN","RCCPCFN1",80,0)
 I LTR(1)="M" D
"RTN","RCCPCFN1",81,0)
 . I "CI"[LTR(2) S DAY=17
"RTN","RCCPCFN1",82,0)
 . I "CI"'[LTR(2) S DAY=15
"RTN","RCCPCFN1",83,0)
 ;
"RTN","RCCPCFN1",84,0)
 Q DAY
"RTN","RCCPCFN1",85,0)
 ;
"RTN","RCCPCFN1",86,0)
GRP8(LTR)  ;T
"RTN","RCCPCFN1",87,0)
 ;
"RTN","RCCPCFN1",88,0)
 I "ABCDE"[LTR(2) S DAY=19
"RTN","RCCPCFN1",89,0)
 I "FGH"[LTR(2) S DAY=22
"RTN","RCCPCFN1",90,0)
 I "ABCDEFGH"'[LTR(2) S DAY=17
"RTN","RCCPCFN1",91,0)
 ;
"RTN","RCCPCFN1",92,0)
 Q DAY
"RTN","RCCPCFN1",93,0)
 ;
"RTN","RCCPCFN1",94,0)
GRP9(LTR)  ;R
"RTN","RCCPCFN1",95,0)
 ;
"RTN","RCCPCFN1",96,0)
 S DAY=19
"RTN","RCCPCFN1",97,0)
 ;
"RTN","RCCPCFN1",98,0)
 Q DAY
"RTN","RCCPCFN1",99,0)
 ;
"RTN","RCCPCFN1",100,0)
GRP10(LTR)  ;SV
"RTN","RCCPCFN1",101,0)
 ;
"RTN","RCCPCFN1",102,0)
 I LTR(1)="V" S DAY=22
"RTN","RCCPCFN1",103,0)
 I LTR(1)="S" D
"RTN","RCCPCFN1",104,0)
 . I "CHIM"[LTR(2) S DAY=22
"RTN","RCCPCFN1",105,0)
 . I "CHIM"'[LTR(2) S DAY=21
"RTN","RCCPCFN1",106,0)
 ;
"RTN","RCCPCFN1",107,0)
 Q DAY
"RTN","RCCPCFN1",108,0)
 ;
"RTN","RCCPCFN1",109,0)
GRP11(LTR)  ;PUXYZ
"RTN","RCCPCFN1",110,0)
 ;
"RTN","RCCPCFN1",111,0)
 S DAY=24
"RTN","RCCPCFN1",112,0)
 ;
"RTN","RCCPCFN1",113,0)
 Q DAY
"RTN","RCCPCFN1",114,0)
 ;
"RTN","RCCPCFN1",115,0)
GRP12(LTR)  ;W
"RTN","RCCPCFN1",116,0)
 ;
"RTN","RCCPCFN1",117,0)
 S DAY=26
"RTN","RCCPCFN1",118,0)
 ;
"RTN","RCCPCFN1",119,0)
 Q DAY
"RTN","RCCPCML")
0^8^B67061934^B47881024
"RTN","RCCPCML",1,0)
RCCPCML ;WASH-ISC@ALTOONA,PA/LDB-Send CCPC transmission ;12/19/96  4:16 PM
"RTN","RCCPCML",2,0)
V ;;4.5;Accounts Receivable;**34,80,93,118,133,140,160,165,187,195,206,223,260,
313**;Mar 20, 1995;Build 118
"RTN","RCCPCML",3,0)
 ;;Per VHA Directive 6402, this routine should not be modified.
"RTN","RCCPCML",4,0)
TRAN ;call from RCCPC TRANSMIT option to interactively allow transmission of CC
PC mesages
"RTN","RCCPCML",5,0)
 ; PRCA*4.5*313 - Rewritten to use Patient Statement Date entry
"RTN","RCCPCML",6,0)
 N SDT,X,Y,ZTRTN,ZTSAVE,ZTDESC,ZTIO,IEN
"RTN","RCCPCML",7,0)
 I '$D(^XUSEC("RCCPC TRANSMIT",DUZ)) W *7,*7,!,"You do not have access to do th
is." Q
"RTN","RCCPCML",8,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCML",9,0)
 L +^RCPS(349.2):DILOCKTM I '$T W *7,*7,!,"Another date is being run or transmi
tted.  Try again later." Q
"RTN","RCCPCML",10,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCML",11,0)
 S DIR(0)="DAO^^K:'$D(^RCPS(349.2,""STDT"",Y)) X"
"RTN","RCCPCML",12,0)
 S DIR("A")="Enter statement date as it will appear on these statements: "
"RTN","RCCPCML",13,0)
 S DIR("?")="Enter statement date as it will appear on these statements or ^ to
 exit."
"RTN","RCCPCML",14,0)
 D ^DIR
"RTN","RCCPCML",15,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) L -^RCPS(349.2):DILOCKTM Q
"RTN","RCCPCML",16,0)
 ; PRCA*4.5*313 - Changed to allow for separate dates for statements based upon
 last name
"RTN","RCCPCML",17,0)
 S SDT=Y
"RTN","RCCPCML",18,0)
 ; PRCA*4.5*313 - Unlock prior to quitting
"RTN","RCCPCML",19,0)
 ;I '$D(^RCPS(349.2,"STDT",SDT)) W !,"There is not a CCPC file for this date." 
L -^RCPS(349.2):DILOCKTM Q
"RTN","RCCPCML",20,0)
 ; PRCA*4.5*313 - Unlock prior to quitting
"RTN","RCCPCML",21,0)
 S IEN=$O(^RCPS(349.2,"STDT",SDT,0)) I '$P($P($G(^RCPS(349.2,IEN,0)),"^",10),".
") D  Q
"RTN","RCCPCML",22,0)
 . W !,"Your CBSS statement file (349.2) is corrupted. Please rebuild it."
"RTN","RCCPCML",23,0)
 . L -^RCPS(349.2):DILOCKTM
"RTN","RCCPCML",24,0)
 ; PRCA*4.5*313 - Unlock prior to jobbing off
"RTN","RCCPCML",25,0)
 L -^RCPS(349.2):DILOCKTM
"RTN","RCCPCML",26,0)
 ; PRCA*4.5*313 - Allows for multiple statement dates
"RTN","RCCPCML",27,0)
 S ZTSAVE("SDT")=SDT,ZTRTN="RETRAN^RCCPCML",ZTIO="",ZTDESC="Re-transmit CBSS pa
tient statements -user activated"
"RTN","RCCPCML",28,0)
 D ^%ZTLOAD
"RTN","RCCPCML",29,0)
 Q
"RTN","RCCPCML",30,0)
 ;
"RTN","RCCPCML",31,0)
EN(SDT) ;called from background job - PRCA*4.5*313 Added SDT for background job
 call
"RTN","RCCPCML",32,0)
 N DA,DIK,LPRINT
"RTN","RCCPCML",33,0)
 D NOW^%DTC
"RTN","RCCPCML",34,0)
RETRAN N DA,DIK,ERROR,RCT,X,X1,DEB
"RTN","RCCPCML",35,0)
 ; PRCA*4.5*313 - Provides error for incomplete build of 349.2
"RTN","RCCPCML",36,0)
 S (ERROR,X)=0 F  S X=$O(^RCPS(349.2,"STDT",SDT,X)) Q:'X  I $G(^RCPS(349.2,X,6)
) S ERROR=1,NM=0 D ERROR Q
"RTN","RCCPCML",37,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with Error.
"RTN","RCCPCML",38,0)
 L +^RCPS(349.2):DILOCKTM I '$T S ERROR=11,NM=0 D ERROR
"RTN","RCCPCML",39,0)
 I $G(ERROR) D EXIT Q
"RTN","RCCPCML",40,0)
 K ^TMP($J)
"RTN","RCCPCML",41,0)
 ; PRCA*4.5*313 - Removes existing 349 for this date
"RTN","RCCPCML",42,0)
 S X1=0 F  S X1=$O(^RCT(349,"SDT",+$E(SDT,6,7),X1)) Q:X1=""  I $P($G(^RCT(349,X
1,0)),U,2)="PS" S DA=X1,DIK="^RCT(349," D ^DIK
"RTN","RCCPCML",43,0)
 F X="PA","IS","IT" S RCT=$O(^RCT(349.1,"B",X,0)) I RCT K ^RCT(349.1,+RCT,4,+$E
(SDT,6,7))
"RTN","RCCPCML",44,0)
 N %,ADD,AMT,ERROR,L,LN,M,MSG,MCT,MPT1,MTOT,NM,P,PD,PD0,PSN,PT,PT0,PHCT,RCM,RTY
,TAMT,TMSG,SZ,TRDESC
"RTN","RCCPCML",45,0)
 D DT^DICRW
"RTN","RCCPCML",46,0)
 S (ERROR,RTY)=0
"RTN","RCCPCML",47,0)
 S X=$O(^RCT(349.1,"B","PS",0))
"RTN","RCCPCML",48,0)
 I X,$P($G(^RCT(349.1,+X,0)),"^",3) S X=$P($G(^RCT(349.1,+X,3)),"^",3)
"RTN","RCCPCML",49,0)
 I X']"" S ERROR=6,NM=0 D ERROR,EXIT Q
"RTN","RCCPCML",50,0)
 D PHCT I 'PHCT S ERROR=1,NM=0 D ERROR,EXIT Q
"RTN","RCCPCML",51,0)
 S MTOT=$O(^TMP($J,"MCT",""),-1)
"RTN","RCCPCML",52,0)
 ; PRCA*4.5*313 - Reset MTOT and MCT(1) for multiple dates on one day
"RTN","RCCPCML",53,0)
 S MCT(1)=$O(^TMP($J,"MCT",""))
"RTN","RCCPCML",54,0)
 S MTOT=MTOT-(MCT(1)-1)
"RTN","RCCPCML",55,0)
 S MCT(1)=0
"RTN","RCCPCML",56,0)
 S MCT=0 F  S MCT=$O(^TMP($J,"MCT",MCT)) Q:'MCT  D PS
"RTN","RCCPCML",57,0)
EXIT D ERRML^RCCPCML1
"RTN","RCCPCML",58,0)
 K SDT,^TMP($J)
"RTN","RCCPCML",59,0)
 ; PRCA*4.5*313 - Unlock prior to exiting
"RTN","RCCPCML",60,0)
 L -^RCPS(349.2):DILOCKTM
"RTN","RCCPCML",61,0)
 Q
"RTN","RCCPCML",62,0)
 ;
"RTN","RCCPCML",63,0)
F349 ;Get PS segment entry
"RTN","RCCPCML",64,0)
 N DA,D0,DIC,DLAYGO,X
"RTN","RCCPCML",65,0)
 S ERROR=0 K DD,DO S DIC="^RCT(349,",DIC(0)="L",DLAYGO=349,X="PS."_$TR($$FMTE^X
LFDT(DT,"2D"),"/",".")_"."_RCM D FILE^DICN
"RTN","RCCPCML",66,0)
 I Y<0 S RTY=RTY+1 G F349:RTY<4 S ERROR=2,NM=0 D ERROR Q
"RTN","RCCPCML",67,0)
 S PSN=+Y
"RTN","RCCPCML",68,0)
 Q
"RTN","RCCPCML",69,0)
 ;
"RTN","RCCPCML",70,0)
PS ;Build PS,PH,PD segments and messages
"RTN","RCCPCML",71,0)
 S PSN=$O(^TMP($J,"MCT",MCT,0))
"RTN","RCCPCML",72,0)
 ; PRCA*4.5*313 - Increment Counter for internal storage
"RTN","RCCPCML",73,0)
 S MCT(1)=MCT(1)+1
"RTN","RCCPCML",74,0)
 ; PRCA*4.5*313 - Update to new formatting
"RTN","RCCPCML",75,0)
 S $P(^RCT(349,+PSN,0),"^",3,10)=MCT(1)_"^"_MTOT_"^"_$$SITE^RCMSITE()_"^"_$$FP^
RCCPCFN_"^"_+^TMP($J,"MCT",MCT)_"^"_$P(^TMP($J,"MCT",MCT),"^",2)_"^"_$$DAT^RCCP
CFN(SDT)_"^"_$$DAT^RCCPCFN(DT)
"RTN","RCCPCML",76,0)
 S LN=+PSN,^TMP($J,"MSG",LN)=$P($G(^RCT(349,+PSN,0)),"^",2,10)_"^|"
"RTN","RCCPCML",77,0)
 ; Reformat Statement Date to Internal Format
"RTN","RCCPCML",78,0)
 S $P(^RCT(349,+PSN,0),"^",9)=SDT
"RTN","RCCPCML",79,0)
 S MPT1=$P(^TMP($J,"MCT",MCT),"^",3)
"RTN","RCCPCML",80,0)
 ; PRCA*4.5*313 - Subtract number of records from last record to find number be
fore file starting point
"RTN","RCCPCML",81,0)
 S PT=MPT1-$P(^TMP($J,"MCT",MCT),"^",1)
"RTN","RCCPCML",82,0)
 F  S PT=$O(^RCPS(349.2,"STDT",SDT,PT)) Q:PT=""  Q:PT=$O(^RCPS(349.2,+($P(^TMP(
$J,"MCT",MCT),"^",3))))  D
"RTN","RCCPCML",83,0)
 .Q:$D(^TMP($J,"ERRPT",+PT))
"RTN","RCCPCML",84,0)
 .S PT0=^RCPS(349.2,+PT,0)
"RTN","RCCPCML",85,0)
 . ; PRCA*4.5*313 - Set DEB from PTO
"RTN","RCCPCML",86,0)
 . S DEB=$P(PT0,"^")
"RTN","RCCPCML",87,0)
 .S LN=LN+1 S ^TMP($J,"MSG",LN)="PH^"_$$SITE^RCMSITE_$$KEY^RCCPCFN(+PT)_"^"_$$N
M^RCCPCFN(+PT)_"^"
"RTN","RCCPCML",88,0)
 .S ADD=$G(^RCPS(349.2,+PT,1))
"RTN","RCCPCML",89,0)
 .;
"RTN","RCCPCML",90,0)
 .;Remove special characters causing problems (WIM-0402-20728)
"RTN","RCCPCML",91,0)
 .I ADD["~" S ADD=$TR(ADD,"~","") ;Remove tilde
"RTN","RCCPCML",92,0)
 .I ADD["|" S ADD=$TR(ADD,"|","") ;Remove the pipe symbol
"RTN","RCCPCML",93,0)
 .;
"RTN","RCCPCML",94,0)
 .;Debtor needs large print (font) IF LPRINT=1
"RTN","RCCPCML",95,0)
 .S LPRINT=$G(^RCPS(349.2,+PT,7)) S:LPRINT="" LPRINT=0
"RTN","RCCPCML",96,0)
 .;
"RTN","RCCPCML",97,0)
 .F P=1:1:7 S $P(^TMP($J,"MSG",LN),"^",P+5)=$S($P(ADD,"^",P)]"":$P(ADD,"^",P),1
:"")
"RTN","RCCPCML",98,0)
 .S ^TMP($J,"MSG",LN)=^TMP($J,"MSG",LN)_"^"
"RTN","RCCPCML",99,0)
 .S LN=LN+1
"RTN","RCCPCML",100,0)
 .F X=4:1:8 S $P(AMT,"^",X-3)=$$HEX^RCCPCFN($P(PT0,"^",X))
"RTN","RCCPCML",101,0)
 .S ^TMP($J,"MSG",LN)=AMT_"^"_$G(^RCPS(349.2,+PT,3))_"^"_$G(^RCPS(349.2,+PT,4))
_"^"_$O(^RCPS(349.2,+PT,2,""),-1)
"RTN","RCCPCML",102,0)
 .S LN=LN+1 I $P($G(^RCD(340,+DEB,0)),";") S ^TMP($J,"MSG",LN)="^"_$$SITE^RCMSI
TE_$$RJ^XLFSTR($TR($P(^RCD(340,+DEB,0),";"),".",""),13,0)
"RTN","RCCPCML",103,0)
 .; PRCA*5.4*313 - Set ICN with Checksum, AR Flag, and Date of Latest Bill ino 
PH data
"RTN","RCCPCML",104,0)
 .N PT8 S PT8=$G(^RCPS(349.2,+PT,8))
"RTN","RCCPCML",105,0)
 .S ^TMP($J,"MSG",LN)=$G(^TMP($J,"MSG",LN))_"^"_LPRINT_"^"_$P(PT8,"^")_"V"_$P(P
T8,"^",2,3)_"^"_$$DAT^RCCPCFN($P(PT8,"^",4))_"^|"
"RTN","RCCPCML",106,0)
 .S $P(^RCPS(349.2,+PT,0),"^",11)=+PSN
"RTN","RCCPCML",107,0)
 .S PD=0 F  S PD=$O(^RCPS(349.2,+PT,2,PD)) Q:'PD  I $D(^(PD,0)) S PD0=^(0) D
"RTN","RCCPCML",108,0)
 ..S AMT(0)=$$HEX^RCCPCFN($P(PD0,"^",3))
"RTN","RCCPCML",109,0)
 ..;Replace special characters causing problem (PRCA*260)
"RTN","RCCPCML",110,0)
 ..S TRDESC=$P(PD0,"^",2)
"RTN","RCCPCML",111,0)
 ..I TRDESC["~" S TRDESC=$TR(TRDESC,"~"," ")  ;Replace tilde
"RTN","RCCPCML",112,0)
 ..I TRDESC["|" S TRDESC=$TR(TRDESC,"|"," ")  ;Replace the pipe symbol
"RTN","RCCPCML",113,0)
 ..S LN=LN+1,^TMP($J,"MSG",LN)="PD^"_$$DAT^RCCPCFN(+PD0)_"^"_TRDESC_"^"_AMT(0)_
"^"_$P(PD0,"^",4)_"^|"
"RTN","RCCPCML",114,0)
 S LN=LN+1,^TMP($J,"MSG",LN)="~"
"RTN","RCCPCML",115,0)
 ; PRCA*4.5*313 - Set all cross-references for File
"RTN","RCCPCML",116,0)
 S DA=+PSN,DIK="^RCT(349," D IX1^DIK
"RTN","RCCPCML",117,0)
 ;
"RTN","RCCPCML",118,0)
MAIL ;set up mail message
"RTN","RCCPCML",119,0)
 N L,XMDUZ,XMSUB,XMY,XMZ,Z
"RTN","RCCPCML",120,0)
 S XMSUB=$$SITE^RCMSITE()_" CBSS TRANSMISSION "_SDT
"RTN","RCCPCML",121,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCML",122,0)
 I $O(^XMB(3.8,"B","RCCPC STATEMENTS","")),$P($G(^RC(342,1,0)),"^",12) S XMY("G
.RCCPC STATEMENTS")=""
"RTN","RCCPCML",123,0)
 S X=$O(^RCT(349.1,"B","PS",0))
"RTN","RCCPCML",124,0)
 I X,$P($G(^RCT(349.1,+X,0)),"^",3) S X=$P($G(^RCT(349.1,+X,3)),"^")_"@"_$P($G(
^RCT(349.1,+X,3)),"^",3) S:$P(X,"@",2)]"" XMY(X)=""
"RTN","RCCPCML",125,0)
 I $P(X,"@",2)']"" D  Q
"RTN","RCCPCML",126,0)
 .S ERROR=6,NM=0 D ERROR
"RTN","RCCPCML",127,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCML",128,0)
 D XMZ^XMA2
"RTN","RCCPCML",129,0)
 I XMZ<1 S RTY=RTY+1 G MAIL:RTY<4 S ERROR=5,NM=0 D ERROR Q
"RTN","RCCPCML",130,0)
 S $P(^RCT(349,+PSN,0),"^",11,12)=DT_"^"_XMZ
"RTN","RCCPCML",131,0)
 S (L,L(1))=0 F  S L(1)=$O(^TMP($J,"MSG",L(1))) Q:'L(1)  S L=L+1,^XMB(3.9,+XMZ,
2,L,0)=^TMP($J,"MSG",L(1))
"RTN","RCCPCML",132,0)
 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_L_"^"_L_"^"_DT
"RTN","RCCPCML",133,0)
 D ENT1^XMD
"RTN","RCCPCML",134,0)
 D NOW^%DTC
"RTN","RCCPCML",135,0)
 S $P(^RCT(349,+PSN,0),"^",11,12)=%_"^"_XMZ
"RTN","RCCPCML",136,0)
 K ^TMP($J,"MSG")
"RTN","RCCPCML",137,0)
 Q
"RTN","RCCPCML",138,0)
 ;
"RTN","RCCPCML",139,0)
PHCT ;PH count
"RTN","RCCPCML",140,0)
 S (ERROR,PT,PHCT,TAMT,SZ)=0,RCM=1
"RTN","RCCPCML",141,0)
 ; PRCA*4.5*313 - If last record is for this date reset RCM to next value
"RTN","RCCPCML",142,0)
 N FINAL
"RTN","RCCPCML",143,0)
 S FINAL=$O(^RCT(349,"@"),-1)
"RTN","RCCPCML",144,0)
 I FINAL,$P($P(^RCT(349,FINAL,0),"^"),".",2,4)=$TR($$FMTE^XLFDT(DT,"2D"),"/",".
") S RCM=$P($P(^RCT(349,FINAL,0),"^"),".",5)+1
"RTN","RCCPCML",145,0)
 F  S PT=$O(^RCPS(349.2,"STDT",SDT,PT)) Q:'PT  S ERROR=0 D  I ERROR,(ERROR<3) Q
"RTN","RCCPCML",146,0)
 .; PRCA*4.5*313 - Set DEB to Debtor number
"RTN","RCCPCML",147,0)
 .S DEB=$P($G(^RCPS(349.2,PT,0)),"^")
"RTN","RCCPCML",148,0)
 .S SZ(1)=0 D ERRCHK Q:ERROR
"RTN","RCCPCML",149,0)
 .S PT0=^RCPS(349.2,+PT,0)
"RTN","RCCPCML",150,0)
 .S PHCT=PHCT+1
"RTN","RCCPCML",151,0)
 .S SZ=550+SZ,SZ(1)=550
"RTN","RCCPCML",152,0)
 .S:$G(^RCPS(349.2,+PT,1))]"" SZ=SZ+$L(^(1)),SZ(1)=SZ(1)+$L(^(1))
"RTN","RCCPCML",153,0)
 .S:$G(^RCPS(349.2,+PT,3))]"" SZ=SZ+$L(^(3))+1,SZ(1)=SZ(1)+$L(^(3))+1
"RTN","RCCPCML",154,0)
 .S:$G(^RCPS(349.2,+PT,4))]"" SZ=SZ+$L(^(4))+1,SZ(1)=SZ(1)+$L(^(4))+1
"RTN","RCCPCML",155,0)
 .S X=0 F  S X=$O(^RCPS(349.2,+PT,2,X)) Q:'X  I $D(^(X,0)) S SZ=$L(^(0))+SZ,SZ(
1)=SZ(1)+$L(^(0))
"RTN","RCCPCML",156,0)
 .S TAMT=TAMT+$P(^RCPS(349.2,+PT,0),"^",8)
"RTN","RCCPCML",157,0)
 .I SZ>27000 D
"RTN","RCCPCML",158,0)
 ..S RTY=0 D F349 Q:ERROR
"RTN","RCCPCML",159,0)
 ..S TAMT=TAMT-$P(PT0,"^",8)
"RTN","RCCPCML",160,0)
 ..S TAMT=$$HEX^RCCPCFN(TAMT)
"RTN","RCCPCML",161,0)
 ..S ^TMP($J,"MCT",RCM)=(PHCT-1)_"^"_TAMT_"^"_$O(^RCPS(349.2,"STDT",SDT,PT),-1)
_"^"_(SZ-SZ(1))
"RTN","RCCPCML",162,0)
 ..S ^TMP($J,"MCT",RCM,+PSN)=""
"RTN","RCCPCML",163,0)
 ..S RCM=RCM+1,PHCT=1
"RTN","RCCPCML",164,0)
 ..S SZ=SZ(1)
"RTN","RCCPCML",165,0)
 ..S TAMT=$P(PT0,"^",8)
"RTN","RCCPCML",166,0)
 I 'PT,$O(^RCPS(349.2,"STDT",SDT,0)) D
"RTN","RCCPCML",167,0)
 .S RTY=0 D F349 Q:ERROR  S ^TMP($J,"MCT",RCM)=PHCT_"^"_$$HEX^RCCPCFN(TAMT)_"^"
_$O(^RCPS(349.2,"STDT",SDT,PT),-1)
"RTN","RCCPCML",168,0)
 .S ^TMP($J,"MCT",RCM,+PSN)=""
"RTN","RCCPCML",169,0)
 Q
"RTN","RCCPCML",170,0)
 ;
"RTN","RCCPCML",171,0)
ERROR ;ERROR FILE
"RTN","RCCPCML",172,0)
 I NM=0 S ^TMP($J,"ERROR",ERROR,NM)="" Q
"RTN","RCCPCML",173,0)
 N SSN
"RTN","RCCPCML",174,0)
 S SSN=$$SSN^RCFN01(+DEB)
"RTN","RCCPCML",175,0)
 I SSN'=-1 S ^TMP($J,"ERROR",ERROR,NM,SSN)=""
"RTN","RCCPCML",176,0)
 Q
"RTN","RCCPCML",177,0)
 ;
"RTN","RCCPCML",178,0)
ERRCHK ;Error check
"RTN","RCCPCML",179,0)
 I '$D(^RCPS(349.2,+PT,0)) S ERROR=1,NM=0 D ERROR Q
"RTN","RCCPCML",180,0)
 S PT(1)=PT,PT=$O(^RCPS(349.2,"STDT",SDT,0)) I '$P(^RCPS(349.2,PT,0),"^",18) S 
ERROR=1,NM=0 D ERROR S PT=PT(1) Q
"RTN","RCCPCML",181,0)
 S PT=PT(1)
"RTN","RCCPCML",182,0)
 I $$KEY^RCCPCFN(+PT)']"" S ERROR=4,NM=$$NAM^RCFN01(+DEB) D ERROR S ^TMP($J,"ER
RPT",+PT)="" Q
"RTN","RCCPCML",183,0)
 I '$D(^RCPS(349.2,"AKEY",$$KEY^RCCPCFN(+PT))) S ERROR=4,NM=$$NAM^RCFN01(+DEB) 
D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
"RTN","RCCPCML",184,0)
 S ADD=$G(^RCPS(349.2,+PT,1))
"RTN","RCCPCML",185,0)
 F P=1:1:7 S ADD(P)=$S($P(ADD,"^",P)]"":$P(ADD,"^",P),1:"")
"RTN","RCCPCML",186,0)
 I ADD(1)="",ADD(2)="",ADD(3)="",ADD(4)="",ADD(5)="",ADD(6)="" S ERROR=8,NM=$$N
AM^RCFN01(+DEB) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
"RTN","RCCPCML",187,0)
 I ADD(1)="",(ADD(2)=""),(ADD(3)=""),(ADD(6)="") S ERROR=8,NM=$$NAM^RCFN01(+DEB
) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
"RTN","RCCPCML",188,0)
 I ADD(4)=""!(ADD(5)="")!(ADD(6)="") S ERROR=8,NM=$$NAM^RCFN01(+DEB) D ERROR S 
^TMP($J,"ERRPT",+PT)=""
"RTN","RCCPCML",189,0)
 F ADD=1:1:6 I ADD(ADD)'?.ANP S ERROR=10,NM=$$NAM^RCFN01(+DEB),^TMP($J,"ERRPT",
+PT)="" D ERROR Q
"RTN","RCCPCML",190,0)
 I $P($G(^RCD(340,+DEB,1)),"^",9) S ^TMP($J,"ERRPT",+PT)="",ERROR=9,NM=$$NAM^RC
FN01(+DEB) D ERROR
"RTN","RCCPCML",191,0)
 Q
"RTN","RCCPCML1")
0^13^B8980051^B6682335
"RTN","RCCPCML1",1,0)
RCCPCML1 ;ALB@ALTOONA,PA/LDB - Send CCPC transmission (cont.);8/25/00  4:16 PM
"RTN","RCCPCML1",2,0)
V ;;4.5;Accounts Receivable;**160,313**;Mar 20, 1995;Build 118
"RTN","RCCPCML1",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCML1",4,0)
ERRML ;ERROR MESSAGES
"RTN","RCCPCML1",5,0)
 N CT,ERROR,LN,PT,SP,XMDUZ,XMTEXT,XMSUB,XMY
"RTN","RCCPCML1",6,0)
 K ^TMP($J,"ERRMSG")
"RTN","RCCPCML1",7,0)
 S (ERROR,LN)=0 F  S ERROR=$O(^TMP($J,"ERROR",ERROR)) Q:'ERROR  D
"RTN","RCCPCML1",8,0)
 . ; PRCA*4.5*313 - Add header identifying the Statement Date
"RTN","RCCPCML1",9,0)
 . I LN=0 S LN=LN+1 D
"RTN","RCCPCML1",10,0)
 . . N Y
"RTN","RCCPCML1",11,0)
 . . S Y=SDT X ^DD("DD")
"RTN","RCCPCML1",12,0)
 . . S ^TMP($J,"ERRMSG",LN)="ERRORS FOR PATIENT STATEMENT DATE: "_Y
"RTN","RCCPCML1",13,0)
 .S LN=LN+1 S ^TMP($J,"ERRMSG",LN)=" "
"RTN","RCCPCML1",14,0)
 .S LN=LN+1 S ^TMP($J,"ERRMSG",LN)=$P($T(ERRMSG+ERROR),";;",2)
"RTN","RCCPCML1",15,0)
 .S LN=LN+1 S ^TMP($J,"ERRMSG",LN)=" "
"RTN","RCCPCML1",16,0)
 .S CT=0,PT="" F  S PT=$O(^TMP($J,"ERROR",ERROR,PT)) Q:PT=""  D
"RTN","RCCPCML1",17,0)
 ..S CT=CT+1,LN=LN+1
"RTN","RCCPCML1",18,0)
 ..I PT=0 S ^TMP($J,"ERRMSG",LN)=" " Q
"RTN","RCCPCML1",19,0)
 ..N Y I PT'=0 D 
"RTN","RCCPCML1",20,0)
 ...S PT(1)="" F  S PT(1)=$O(^TMP($J,"ERROR",ERROR,PT,PT(1))) Q:PT(1)=""  D 
"RTN","RCCPCML1",21,0)
 ....S ^TMP($J,"ERRMSG",LN)=$S($L(CT)<2:" "_CT,1:CT)_". "
"RTN","RCCPCML1",22,0)
 ....S SP="                              ",Y=PT,Y=PT_$E(SP,$L(PT),30)
"RTN","RCCPCML1",23,0)
 ....S ^TMP($J,"ERRMSG",LN)=^TMP($J,"ERRMSG",LN)_Y_PT(1)
"RTN","RCCPCML1",24,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCML1",25,0)
 I $O(^XMB(3.8,"B","RCCPC STATEMENTS",0)) S XMY("G.RCCPC STATEMENTS")=""
"RTN","RCCPCML1",26,0)
 E  S XMY($G(DUZ))=""
"RTN","RCCPCML1",27,0)
 ; PRCA*4.5*313 - Change CCPC to CBSS and add Statement Date
"RTN","RCCPCML1",28,0)
 N Y S Y=SDT D DD^%DT S SDT=Y
"RTN","RCCPCML1",29,0)
 S XMSUB="CBSS ERRORS FOUND DURING TRANSMISSION"
"RTN","RCCPCML1",30,0)
 S XMTEXT="^TMP($J,""ERRMSG"","
"RTN","RCCPCML1",31,0)
 D ^XMD
"RTN","RCCPCML1",32,0)
 K ^TMP($J,"ERRMSG")
"RTN","RCCPCML1",33,0)
 Q
"RTN","RCCPCML1",34,0)
 ;
"RTN","RCCPCML1",35,0)
ERRMSG  ;Error messages   PRCA*4.5*313 - Change CCPC to CBSS
"RTN","RCCPCML1",36,0)
1 ;;CBSS transmission process found no records or an incomplete file. Contact I
RM.
"RTN","RCCPCML1",37,0)
2 ;;No CBSS transmission records transmitted. Check file 349. Contact IRM.
"RTN","RCCPCML1",38,0)
3 ;;Corrupted PH segment has been encountered for the following patient(s):
"RTN","RCCPCML1",39,0)
4 ;;No key field in CBSS file for the following patient(s):
"RTN","RCCPCML1",40,0)
5 ;;Mailman message creation aborted. Please contact IRM.
"RTN","RCCPCML1",41,0)
6 ;;No transmission sent. Define REMOTE DOMAIN in AR TRANSMISSION TYPE file (34
9.1).
"RTN","RCCPCML1",42,0)
7 ;;Print Acknowledgements exist. Transmission cannot be resent.
"RTN","RCCPCML1",43,0)
8 ;;Address information is missing for the following patient(s):
"RTN","RCCPCML1",44,0)
9 ;;Address is marked as ADDRESS UNKNOWN for the following patient(s):
"RTN","RCCPCML1",45,0)
10 ;;Corrupted Address. Re-enter address information for the following patient(
s):
"RTN","RCCPCML1",46,0)
11 ;;File did not build or transmit due to another build or transmission runnin
g.
"RTN","RCCPCPS")
0^10^B129514785^B80898915
"RTN","RCCPCPS",1,0)
RCCPCPS ;WASH-ISC@ALTOONA,PA/NYB-Build Patient Statement File ;12/19/96  4:14 P
M
"RTN","RCCPCPS",2,0)
 ;;4.5;Accounts Receivable;**34,70,80,48,104,116,149,170,181,190,223,237,219,26
5,301,313**;Mar 20,1995;Build 118
"RTN","RCCPCPS",3,0)
 ;;Per VHA Directive 6402, this routine should not be modified.
"RTN","RCCPCPS",4,0)
EN(SDT)  ; PRCA*4.5*313 - For use when called by Background Job
"RTN","RCCPCPS",5,0)
 ;
"RTN","RCCPCPS",6,0)
EN1 ;FOR USE WHEN BUILDING PS FILE (SDT MUST BE AVAILABLE AS A LOCAL VARIABLE)
"RTN","RCCPCPS",7,0)
 N CCPC,CNT,DAT,DEB,DIK,END,INADFL,LDT1,LDT3,PCC,PRN,RCDATE,RCT,SVADM,SVAMT,SVI
NT,SVOTH,SITE,TXT,VAR,X,%,REP,ERROR,NM
"RTN","RCCPCPS",8,0)
 N RCINFULL,RCINPART S COMM=0
"RTN","RCCPCPS",9,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCPS",10,0)
 L +^RCPS(349.2):DILOCKTM I '$T D  Q
"RTN","RCCPCPS",11,0)
 . D NOW^%DTC S Y=% D DD^%DT
"RTN","RCCPCPS",12,0)
 . W Y W !!,"Another date is being run or transmitted.  Try again later."
"RTN","RCCPCPS",13,0)
 . S ERROR=11,NM=0 D ERROR^RCCPCML,ERRML^RCCPCML1
"RTN","RCCPCPS",14,0)
 ; PRCA*4.5*313 - Clear data for date being created
"RTN","RCCPCPS",15,0)
 D KILL^RCCPCPS1(SDT)
"RTN","RCCPCPS",16,0)
 ; PRCA*4.5*313 - Set date to a month ago and kill data for that date
"RTN","RCCPCPS",17,0)
 N OLDDT
"RTN","RCCPCPS",18,0)
 S OLDDT=$$MONTHAGO^RCCPCPS1(SDT)
"RTN","RCCPCPS",19,0)
 ; PRCA*4.5*313 - Moved to KILL^RCCPCPS1
"RTN","RCCPCPS",20,0)
 D KILL^RCCPCPS1(OLDDT)
"RTN","RCCPCPS",21,0)
 ;
"RTN","RCCPCPS",22,0)
 D DT^DICRW,SITE^PRCAGU
"RTN","RCCPCPS",23,0)
 I '$D(SITE) W !!,"AR SITE PARAMETER ENTRIES NOT DEFINED!",?50 D  Q
"RTN","RCCPCPS",24,0)
 . D NOW^%DTC S Y=% D DD^%DT W Y
"RTN","RCCPCPS",25,0)
 . W !!,"COULD NOT PROCESS AR PATIENT STATEMENTS"
"RTN","RCCPCPS",26,0)
 . ; PRCA*4.5*313 - Unlock prior to exiting
"RTN","RCCPCPS",27,0)
 . L -^RCPS(349.2):DILOCKTM
"RTN","RCCPCPS",28,0)
 ;
"RTN","RCCPCPS",29,0)
 ; PRCA*4.5*313 - Clear ICN Error temporary storage
"RTN","RCCPCPS",30,0)
 K ^TMP("ICNERROR",$J)
"RTN","RCCPCPS",31,0)
 D NOW^%DTC S END=%
"RTN","RCCPCPS",32,0)
 S LDT1=$$FPS^RCAMFN01(DT,-1),RCDATE=DT
"RTN","RCCPCPS",33,0)
 S (CNT,DEB)=0,PRN=1
"RTN","RCCPCPS",34,0)
 F  S DEB=$O(^RCD(340,"AC",+$E(SDT,6,7),DEB)) Q:DEB=""  I $D(^RCD(340,"AB","DPT
(",DEB)) D
"RTN","RCCPCPS",35,0)
 .   N AMT,BBAL,BEG,BN,CAT,DESC,ETY,FC,ND,PAT,PBAL,PC,PSIEN
"RTN","RCCPCPS",36,0)
 .   N PDAT,PEND,ST,SVINT,SVADM,SVOTH,ADDR,ARFLAG,DIC,FLBPD1,ICN
"RTN","RCCPCPS",37,0)
 .   I $L(+$$SSN^RCFN01(DEB))<5 Q
"RTN","RCCPCPS",38,0)
 .   ;Check for Emergency Response Indicator (ERI) Flag.
"RTN","RCCPCPS",39,0)
 .   N RCDFN S RCDFN=+($P($G(^RCD(340,DEB,0)),"^",1)) I $$EMERES^PRCAUTL(RCDFN)
]"" Q
"RTN","RCCPCPS",40,0)
 .   ; initialize variables for CS - PRCA*4.5*301
"RTN","RCCPCPS",41,0)
 .   N CSBB,CSTCH,CSTPC,CSPREV S (CSBB,CSTCH,CSTPC)=0
"RTN","RCCPCPS",42,0)
 .   ; PRCA^4.5*313 - If ICN is null set to send error email
"RTN","RCCPCPS",43,0)
 .   S ICN=$$GETICN^MPIF001(RCDFN)
"RTN","RCCPCPS",44,0)
 .   I $P(ICN,U)=-1 S ^TMP("ICNERROR",$J,RCDFN)="" Q
"RTN","RCCPCPS",45,0)
 .   S FLBPD1=$$FLBPD1
"RTN","RCCPCPS",46,0)
 .   I FLBPD1="" Q
"RTN","RCCPCPS",47,0)
 .   I $P(^PRCA(430,FLBPD1,0),U,10)="" Q
"RTN","RCCPCPS",48,0)
 .   S INADFL=0
"RTN","RCCPCPS",49,0)
 .   S (SVADM,SVAMT,SVINT,SVOTH)=0
"RTN","RCCPCPS",50,0)
 .   N REF,SBAL,TBAL,TN,TTY,X,Y
"RTN","RCCPCPS",51,0)
 .   K ^TMP("PRCAGT",$J)
"RTN","RCCPCPS",52,0)
 .   S BEG=+$$LST^RCFN01(DEB,2)
"RTN","RCCPCPS",53,0)
 .   S LDT3=$S(BEG>0:$$FPS^RCAMFN01($P(BEG,"."),-3),1:0)
"RTN","RCCPCPS",54,0)
 .   I $P(BEG,".")'<$P(RCDATE,".") Q
"RTN","RCCPCPS",55,0)
 .   D NOW^%DTC S END=%
"RTN","RCCPCPS",56,0)
 .   I BEG<1 S PDAT="",BEG=0,PBAL=0
"RTN","RCCPCPS",57,0)
 .   I BEG S PDAT=BEG,BEG=9999999.999999-BEG,PBAL=0 D PBAL^PRCAGU(DEB,.BEG,.PBA
L) ;get prev bal
"RTN","RCCPCPS",58,0)
 .   D EN^PRCAGT(DEB,BEG,.END)
"RTN","RCCPCPS",59,0)
 .   S TBAL=0 D TBAL^PRCAGT(DEB,.TBAL) ;get trans bal
"RTN","RCCPCPS",60,0)
 .   S BBAL=0 D BBAL^PRCAGU(DEB,.BBAL) ;get bill bal
"RTN","RCCPCPS",61,0)
 .   ; entire account has been referred to CS - PRCA*4.5*301
"RTN","RCCPCPS",62,0)
 .   I CSBB,CSBB'<BBAL Q
"RTN","RCCPCPS",63,0)
 .   S X=$$PRE^PRCAGU(DEB) S PEND=$P(X,U,2),X=+X I X,BBAL D REF^PRCAGD(DEB,X,$G
(REP)) Q
"RTN","RCCPCPS",64,0)
 .   I BBAL=0,PEND,-PEND=PBAL+TBAL Q
"RTN","RCCPCPS",65,0)
 .   I BBAL'=(PBAL+TBAL) D EN^PRCAGD(DEB,BBAL,TBAL,PBAL,BEG,$G(REP)) Q
"RTN","RCCPCPS",66,0)
 .   I BBAL'>0,'$D(^TMP("PRCAGT",$J,DEB)) Q
"RTN","RCCPCPS",67,0)
 .   I BBAL=0,$G(SITE("ZERO")) Q
"RTN","RCCPCPS",68,0)
 .   I BBAL<0,BBAL>-.99 Q
"RTN","RCCPCPS",69,0)
 .   I BBAL'<0,'$D(^XTMP("PRCAGU",$J,DEB)),'COMM Q  ;third letter printed,not c
omment
"RTN","RCCPCPS",70,0)
 .   S TBAL=TBAL+PBAL
"RTN","RCCPCPS",71,0)
 .   ;adjust amounts to be filed in 349.2 for CS bills - PRCA*4.5*301
"RTN","RCCPCPS",72,0)
 .   S TBAL=TBAL-CSBB ; reduce the total bill balance by CS balance
"RTN","RCCPCPS",73,0)
 .   S CSPREV=CSBB-(CSTCH+CSTPC) ; compute the CS previous balance as the diffe
rence between the bill balance and the transaction balance
"RTN","RCCPCPS",74,0)
 .   S PBAL=PBAL-CSPREV ; reduce the previous balance by the CS previous balanc
e
"RTN","RCCPCPS",75,0)
 .   S TBAL("CH")=TBAL("CH")-CSTCH ; reduce total charges by CS charges
"RTN","RCCPCPS",76,0)
 .   S TBAL("PC")=TBAL("PC")-CSTPC ; reduce total credits by CS credits
"RTN","RCCPCPS",77,0)
 .   ;
"RTN","RCCPCPS",78,0)
 .   I '$D(^RCPS(349.2,0)) S ^(0)="AR CBSS STATEMENTS^349.2I^^"
"RTN","RCCPCPS",79,0)
 .   S DIC="^RCPS(349.2,",X=DEB,DA=.01,DIC(0)="" D FILE^DICN
"RTN","RCCPCPS",80,0)
 .   S PSIEN=+Y
"RTN","RCCPCPS",81,0)
 .   S ^RCPS(349.2,PSIEN,0)=DEB_"^"_$$SSN^RCFN01(DEB)_"^"
"RTN","RCCPCPS",82,0)
 .   S ADDR=$$DADD^RCAMADD(DEB,1) ;get patient's address, confidential if appli
cable
"RTN","RCCPCPS",83,0)
 .   S ARFLAG="N" N X
"RTN","RCCPCPS",84,0)
 .   S X=$P($G(^RCD(340,DEB,1)),U,1,6) I ($P(X,U)'=""),($P(X,U,4)'=""),($P(X,U,
5)'=""),(($P(X,U,6)'="")) S ARFLAG="Y"
"RTN","RCCPCPS",85,0)
 .   S ^RCPS(349.2,PSIEN,1)=$P(ADDR,"^",1,6)
"RTN","RCCPCPS",86,0)
 .   S ST=$P(ADDR,"^",5)
"RTN","RCCPCPS",87,0)
 .   S ^RCPS(349.2,PSIEN,7)=$P(^RCD(340,DEB,0),U,7) ;large print
"RTN","RCCPCPS",88,0)
 .   ; PRCA*4.5*313 - Add four new elements for CBSS
"RTN","RCCPCPS",89,0)
 .   S $P(^RCPS(349.2,PSIEN,8),U)=$P(ICN,"V")
"RTN","RCCPCPS",90,0)
 .   S $P(^RCPS(349.2,PSIEN,8),U,2)=$P(ICN,"V",2)
"RTN","RCCPCPS",91,0)
 .   S $P(^RCPS(349.2,PSIEN,8),U,3)=ARFLAG
"RTN","RCCPCPS",92,0)
 .   S $P(^RCPS(349.2,PSIEN,8),U,4)=""
"RTN","RCCPCPS",93,0)
 .   I FLBPD1 S $P(^RCPS(349.2,PSIEN,8),U,4)=$P(^PRCA(430,FLBPD1,0),U,10)
"RTN","RCCPCPS",94,0)
 .   I $G(ST)'="" S ST=$O(^DIC(5,"C",ST,0))
"RTN","RCCPCPS",95,0)
 .   I $G(ST)>90,'$P($G(^DIC(5,ST,0)),"^",6) S FC=$P($G(^DIC(5,ST,0)),"^")
"RTN","RCCPCPS",96,0)
 .   S $P(^RCPS(349.2,PSIEN,1),"^",7)=$G(FC) S:$G(FC)]"" $P(^RCPS(349.2,PSIEN,1
),"^",5)="FX"
"RTN","RCCPCPS",97,0)
 .   S:$G(FC)]"" $P(^RCPS(349.2,PSIEN,1),"^",6)=$P(ADDR,"^",8)
"RTN","RCCPCPS",98,0)
 .   D NOW^%DTC S $P(^RCPS(349.2,PSIEN,0),"^",10)=%
"RTN","RCCPCPS",99,0)
 .   S $P(^RCPS(349.2,PSIEN,0),"^",3)=$$NAM^RCFN01(DEB)
"RTN","RCCPCPS",100,0)
 .   S $P(^RCPS(349.2,PSIEN,0),"^",4,7)=$S(TBAL'>0:0,1:TBAL)_"^"_PBAL_"^"_TBAL(
"CH")_"^"_TBAL("PC"),$P(^(0),"^",8)=PBAL+TBAL("CH")+TBAL("PC")+TBAL("RF")
"RTN","RCCPCPS",101,0)
 .   S $P(^RCPS(349.2,PSIEN,0),"^",13,17)=BBAL("PB")_"^"_BBAL("INT")_"^"_BBAL("
ADM")_"^"_BBAL("MF")_"^"_BBAL("CT")
"RTN","RCCPCPS",102,0)
 .   ;
"RTN","RCCPCPS",103,0)
 .   N RCBILLDA,RCDATA1,RCDEBTDA,RCDESC,RCPSDA,RCTOTAL,RCTRANDA,RCTRDATE,VALUE,
RCCOM1,RCCOM2,RCCOM3
"RTN","RCCPCPS",104,0)
 .   S RCDEBTDA=DEB
"RTN","RCCPCPS",105,0)
 .   I '$D(^RCPS(349.2,PSIEN,2,0)) S ^(0)="^^^"
"RTN","RCCPCPS",106,0)
 .   ;
"RTN","RCCPCPS",107,0)
 .   S RCCOM1=$E($TR($G(SITE("COM1")),"~|^",""),1,80),(RCCOM2,RCCOM3)=""
"RTN","RCCPCPS",108,0)
 .   ; Add second comment line for the GMT-reduced status
"RTN","RCCPCPS",109,0)
 .   I $$GMT^PRCAGST(RCDEBTDA) S RCCOM2="REDUCTION OF INPATIENT COPAYMENT DUE T
O GEOGRAPHIC MEANS TEST STATUS"
"RTN","RCCPCPS",110,0)
 .   I TBAL'>0 S RCCOM3=" *THIS IS NOT A BILL*"
"RTN","RCCPCPS",111,0)
 .   I RCCOM1'="",RCCOM2'="" S $E(RCCOM1,80)=" " ;Make sure GMT message will be
 printed on separate line.
"RTN","RCCPCPS",112,0)
 .   S ^RCPS(349.2,PSIEN,3)=RCCOM1_RCCOM2_RCCOM3
"RTN","RCCPCPS",113,0)
 .   ;
"RTN","RCCPCPS",114,0)
 .   S RCPSDA=0 ; this variable used to set the description on the PS segment
"RTN","RCCPCPS",115,0)
 .   S RCTRDATE=0 F  S RCTRDATE=$O(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE)) Q:'RCTR
DATE  S RCBILLDA=0 F  S RCBILLDA=$O(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBILLDA
)) Q:'RCBILLDA  D
"RTN","RCCPCPS",116,0)
 .   .   ; skip CS bills/transactions - PRCA*4.5*301
"RTN","RCCPCPS",117,0)
 .   .   Q:$D(^PRCA(430,"TCSP",RCBILLDA))
"RTN","RCCPCPS",118,0)
 .   .   I $P($G(^RCPS(349.2,PSIEN,0)),"^",8)<0 S PC(75)=75
"RTN","RCCPCPS",119,0)
 .   .   I $P($G(^PRCA(430,RCBILLDA,6)),"^",2)]"",($P($G(^PRCA(430,RCBILLDA,7))
,"^")>0) S PC(1)="01"
"RTN","RCCPCPS",120,0)
 .   .   S CAT=$P($G(^PRCA(430,RCBILLDA,0)),"^",2)
"RTN","RCCPCPS",121,0)
 .   .   S PC=$P($G(^PRCA(430.2,CAT,0)),"^",14)
"RTN","RCCPCPS",122,0)
 .   .   F X=1:1:100 I $P(PC,",",X)'="" S PCC=$P(PC,",",X),PC(+PCC)=PCC Q:PCC="
"
"RTN","RCCPCPS",123,0)
 .   .   S PC="",X=0 F  S X=$O(PC(X)) Q:X=""  I $G(PC(X))'="" S PC=PC_PC(X)
"RTN","RCCPCPS",124,0)
 .   .   S $P(^RCPS(349.2,PSIEN,4),"^")=PC
"RTN","RCCPCPS",125,0)
 .   .   ;
"RTN","RCCPCPS",126,0)
 .   .   I $D(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBILLDA,0)) S AMT=+^(0) I AMT
 D
"RTN","RCCPCPS",127,0)
 .   .   .   ;  get the description for the bill
"RTN","RCCPCPS",128,0)
 .   .   .   K RCDESC D BILLDESC^RCCPCPS1(RCBILLDA)
"RTN","RCCPCPS",129,0)
 .   .   .   ;
"RTN","RCCPCPS",130,0)
 .   .   .   ;  store the description in file 349.2, PS segment
"RTN","RCCPCPS",131,0)
 .   .   .   S RCPSDA=RCPSDA+1
"RTN","RCCPCPS",132,0)
 .   .   .   S $P(^RCPS(349.2,PSIEN,2,RCPSDA,0),"^",1,4)=$P(RCTRDATE,".")_"^"_$
G(RCDESC(1))_"^"_$G(AMT)_"^"_$P($G(^PRCA(430,RCBILLDA,0)),"^")
"RTN","RCCPCPS",133,0)
 .   .   .   F X=2:1 Q:$G(RCDESC(X))=""  S RCPSDA=RCPSDA+1,^RCPS(349.2,PSIEN,2,
RCPSDA,0)="^"_RCDESC(X)_"^^"
"RTN","RCCPCPS",134,0)
 .   .   ;
"RTN","RCCPCPS",135,0)
 .   .   S RCTRANDA=0 F  S RCTRANDA=$O(^TMP("PRCAGT",$J,RCDEBTDA,RCTRDATE,RCBIL
LDA,RCTRANDA)) D:'RCTRANDA NO Q:'RCTRANDA  D
"RTN","RCCPCPS",136,0)
 .   .   .   ;  get the description for the transaction
"RTN","RCCPCPS",137,0)
 .   .   .   K RCDESC D TRANDESC^RCCPCPS1(RCTRANDA),RCDESC
"RTN","RCCPCPS",138,0)
 .   .   .   ;  if it is an interest/admin charge, summarize it below
"RTN","RCCPCPS",139,0)
 .   .   .   I $G(RCDESC(1))["INTEREST" Q
"RTN","RCCPCPS",140,0)
 .   .   .   ;  get the value of the transaction for the statement
"RTN","RCCPCPS",141,0)
 .   .   .   S VALUE=$$TRANVALU^RCDPBTLM(RCTRANDA)
"RTN","RCCPCPS",142,0)
 .   .   .   S VALUE=$P(VALUE,"^",2)+$P(VALUE,"^",3)+$P(VALUE,"^",4)+$P(VALUE,"
^",5)+$P(VALUE,"^",6)
"RTN","RCCPCPS",143,0)
 .   .   .   ;  if it is a suspended (47) or unsuspended (46) transaction, show
 value
"RTN","RCCPCPS",144,0)
 .   .   .   ;  make suspended charges appear as negative
"RTN","RCCPCPS",145,0)
 .   .   .   S RCDATA1=$G(^PRCA(433,RCTRANDA,1))
"RTN","RCCPCPS",146,0)
 .   .   .   I $P(RCDATA1,"^",2)=47!($P(RCDATA1,"^",2)=46) S VALUE=$P(RCDATA1,"
^",5) I $P(RCDATA1,"^",2)=47 S VALUE=-VALUE
"RTN","RCCPCPS",147,0)
 .   .   .   ;  if it is an amended bill, show value
"RTN","RCCPCPS",148,0)
 .   .   .   I $P(RCDATA1,"^",2)=33 S VALUE=$P(RCDATA1,"^",5)
"RTN","RCCPCPS",149,0)
 .   .   .   ;  store the description in file 349.2, PS segment
"RTN","RCCPCPS",150,0)
 .   .   .   S RCPSDA=RCPSDA+1
"RTN","RCCPCPS",151,0)
 .   .   .   S $P(^RCPS(349.2,PSIEN,2,RCPSDA,0),"^",1,5)=$P(RCTRDATE,".")_"^"_$
G(RCDESC(1))_"^"_VALUE_"^"_$P($G(^PRCA(430,RCBILLDA,0)),"^")
"RTN","RCCPCPS",152,0)
 .   .   .   F X=2:1 Q:$G(RCDESC(X))=""  S RCPSDA=RCPSDA+1,^RCPS(349.2,PSIEN,2,
RCPSDA,0)="^"_RCDESC(X)_"^^"
"RTN","RCCPCPS",153,0)
 .   .   .   ;
"RTN","RCCPCPS",154,0)
 .   .   .   ;  for comment transaction ... not sure what this is for ?
"RTN","RCCPCPS",155,0)
 .   .   .   I $P(RCDATA1,"^",2)=45,$P($G(^PRCA(433,RCTRANDA,5)),"^",2)["your w
aiver rights" S ^RCPS(349.2,PSIEN,4)="0150"
"RTN","RCCPCPS",156,0)
 .   ;
"RTN","RCCPCPS",157,0)
 .   ;  if interest, admin, or other, add them here
"RTN","RCCPCPS",158,0)
 .   S X=$G(RCTOTAL("INT"))+$G(RCTOTAL("ADM"))+$G(RCTOTAL("OTH"))
"RTN","RCCPCPS",159,0)
 .   I X>0 D
"RTN","RCCPCPS",160,0)
 .   .   S RCDESC="INTEREST/ADM. CHARGE (Int:"_$J($G(RCTOTAL("INT")),1,2)_" Adm
:"_$J($G(RCTOTAL("ADM")),1,2)_" Other:"_$J($G(RCTOTAL("OTH")),1,2)_")"
"RTN","RCCPCPS",161,0)
 .   .   S RCPSDA=RCPSDA+1
"RTN","RCCPCPS",162,0)
 .   .   S ^RCPS(349.2,PSIEN,2,RCPSDA,0)="^"_RCDESC_"^"_$J(X,1,2)
"RTN","RCCPCPS",163,0)
 .   .   S ^RCPS(349.2,PSIEN,2,0)="^^"_RCPSDA_"^"_RCPSDA
"RTN","RCCPCPS",164,0)
 .   ;
"RTN","RCCPCPS",165,0)
 .   ; PRCA*4.5*313 - Set statement date into cross-reference
"RTN","RCCPCPS",166,0)
 .   S $P(^RCPS(349.2,PSIEN,0),U,19)=SDT
"RTN","RCCPCPS",167,0)
 .   ;
"RTN","RCCPCPS",168,0)
 .   ;  set 0th node
"RTN","RCCPCPS",169,0)
 .   I RCPSDA S ^RCPS(349.2,PSIEN,2,0)="^^"_RCPSDA_"^"_RCPSDA
"RTN","RCCPCPS",170,0)
 .   ;
"RTN","RCCPCPS",171,0)
 .   ; PRCA*4.5*313 - Set Cross-References for this Debtor
"RTN","RCCPCPS",172,0)
 .   S DA=PSIEN,DIK="^RCPS(349.2," D IX1^DIK
"RTN","RCCPCPS",173,0)
 .   ;
"RTN","RCCPCPS",174,0)
 .   ; PRCA*4.5*313 - Remove data for each debtor
"RTN","RCCPCPS",175,0)
 .   K ^XTMP("PRCAGU",$J,DEB)
"RTN","RCCPCPS",176,0)
 .   ;
"RTN","RCCPCPS",177,0)
 .   I RCPSDA'<287 S ^XTMP("RCCPC",0)=DT,(^XTMP("RCCPC",RCDEBTDA),^XTMP("RCCPC1
",PSIEN))="" Q
"RTN","RCCPCPS",178,0)
 .   D NO
"RTN","RCCPCPS",179,0)
 ;
"RTN","RCCPCPS",180,0)
 S PSIEN=0 S PSIEN=$O(^RCPS(349.2,"STDT",SDT,PSIEN)) Q:PSIEN=""  S $P(^RCPS(349
.2,PSIEN,0),"^",18)=1
"RTN","RCCPCPS",181,0)
 ;
"RTN","RCCPCPS",182,0)
 ; PRCA*4.5*313 - Send ICN Error email if necessary
"RTN","RCCPCPS",183,0)
 I $D(^TMP("ICNERROR",$J)) D ICNERR^RCCPCPS1 K ^TMP("ICNERROR",$J)
"RTN","RCCPCPS",184,0)
 ;
"RTN","RCCPCPS",185,0)
 K COMM,TR,TRNIEN
"RTN","RCCPCPS",186,0)
 ;
"RTN","RCCPCPS",187,0)
OSTM ;Process old statements
"RTN","RCCPCPS",188,0)
 S DIK="^RCPS(349.2,",DA=0 F  S DA=$O(^XTMP("RCCPC1",DA)) Q:'DA  D ^DIK
"RTN","RCCPCPS",189,0)
 K DA,^XTMP("RCCPC1")
"RTN","RCCPCPS",190,0)
 ;
"RTN","RCCPCPS",191,0)
STATMNT ;Print patient statements
"RTN","RCCPCPS",192,0)
 N IOP,ZTIO,ZTSAVE,ZTRTN,ZTDESC,ZTASK,%ZIS,ZTDTH,PRCADEV,POP
"RTN","RCCPCPS",193,0)
 S (IOP,PRCADEV)=$P($G(^RC(342,1,0)),"^",8)
"RTN","RCCPCPS",194,0)
 I IOP]"" D
"RTN","RCCPCPS",195,0)
 .S ZTRTN="STM^RCCPCSTM",ZTDTH=$H,ZTDESC="Print old AR Statements"
"RTN","RCCPCPS",196,0)
 .S %ZIS="N0" D ^%ZIS Q:POP
"RTN","RCCPCPS",197,0)
 .S ZTSAVE("PRCADEV")="" D ^%ZTLOAD,^%ZISC
"RTN","RCCPCPS",198,0)
 ; PRCA*4.5*313 - Unlock prior to exiting
"RTN","RCCPCPS",199,0)
 L -^RCPS(349.2):DILOCKTM
"RTN","RCCPCPS",200,0)
 Q
"RTN","RCCPCPS",201,0)
 ;
"RTN","RCCPCPS",202,0)
NO ;If there is no activity
"RTN","RCCPCPS",203,0)
 I $G(^RCPS(349.2,PSIEN,4))["0150" D
"RTN","RCCPCPS",204,0)
 .S ^RCPS(349.2,PSIEN,2,1,0)="^NOTICE: You now have delinquent charges. Please^
^"
"RTN","RCCPCPS",205,0)
 .S ^RCPS(349.2,PSIEN,2,2,0)="^review Enforcement of Involuntary Collections^^"
"RTN","RCCPCPS",206,0)
 .S ^RCPS(349.2,PSIEN,2,3,0)="^on reverse.^^"
"RTN","RCCPCPS",207,0)
 .S ^RCPS(349.2,PSIEN,2,0)="^^3^3"
"RTN","RCCPCPS",208,0)
 I $G(^RCPS(349.2,PSIEN,2,1,0))="" D
"RTN","RCCPCPS",209,0)
 .S ^RCPS(349.2,PSIEN,2,1,0)="^No Activity in the Last 30 Days!^^"
"RTN","RCCPCPS",210,0)
 .S ^RCPS(349.2,PSIEN,2,2,0)="^Please refer to previous statement of rights.^^"
"RTN","RCCPCPS",211,0)
 .S ^RCPS(349.2,PSIEN,2,0)="^^2^2"
"RTN","RCCPCPS",212,0)
 .I $G(^RCPS(349.2,PSIEN,4))="" S ^(4)="90"
"RTN","RCCPCPS",213,0)
 Q
"RTN","RCCPCPS",214,0)
BUILD ;This is the entry point from the BUILD CCPC file option
"RTN","RCCPCPS",215,0)
 N TDT,QDT,ZTDESC,ZTASK,ZTSK,ZDTDTH,ZTIO,ZTRTN,CNCL,%H,%DT,DIR,DTOUT
"RTN","RCCPCPS",216,0)
 ; PRCA*4.5*313 - Check for lock.  If locked quit with warning.
"RTN","RCCPCPS",217,0)
 L +^RCPS(349.2):DILOCKTM I '$T W *7,*7,!,"Another date is being run or transmi
tted.  Try again later." Q
"RTN","RCCPCPS",218,0)
 ; PRCA*4.5*313 - Rewritten to use Patient Statement Date entry
"RTN","RCCPCPS",219,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCPS",220,0)
 S DIR(0)="DAO^^K:"",1,2,4,6,7,8,10,12,14,15,17,19,21,22,24,26,""'[("",""_+$E(Y
,6,7)_"","") X"
"RTN","RCCPCPS",221,0)
 S DIR("A")="Enter a Patient Statement date for this build: "
"RTN","RCCPCPS",222,0)
 S DIR("?")="Enter a Patient Statement date for this build or ^ to exit."
"RTN","RCCPCPS",223,0)
 D ^DIR
"RTN","RCCPCPS",224,0)
 ; PRCA*4.5*313 - Unlock prior to quitting
"RTN","RCCPCPS",225,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) L -^RCPS(349.2):DILOCKTM Q
"RTN","RCCPCPS",226,0)
 S SDT=Y
"RTN","RCCPCPS",227,0)
 S TDT=$O(^RCPS(349.2,"STDT",SDT,0)) I TDT D  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$
D(DIROUT) Q
"RTN","RCCPCPS",228,0)
 .S TDT=$TR($$SLH^RCFN01(SDT),"/","")
"RTN","RCCPCPS",229,0)
 .W *7,!!,"The Patient Statements for ",$E(TDT,1,2)_"/"_$E(TDT,3,4)_"/"_$E(TDT,
5,8)
"RTN","RCCPCPS",230,0)
 .I $D(^RCT(349,"SDT",+$E(SDT,6,7))) D
"RTN","RCCPCPS",231,0)
 ..S TDT=$P(^RCT(349,$O(^RCT(349,"SDT",+$E(SDT,6,7),0)),0),"^",10)
"RTN","RCCPCPS",232,0)
 ..S TDT=$TR($$SLH^RCFN01(TDT),"/","")
"RTN","RCCPCPS",233,0)
 ..W " were transmitted on ",$E(TDT,1,2)_"/"_$E(TDT,3,4)_"/"_$E(TDT,5,8)_"."
"RTN","RCCPCPS",234,0)
 .E  W " do not have a transmission date!"
"RTN","RCCPCPS",235,0)
 .W !!,">> PLEASE CONTACT CUSTOMER SUPPORT BEFORE PROCEEDING <<",!!
"RTN","RCCPCPS",236,0)
 .N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCPS",237,0)
 .S DIR(0)="E",DIR("A")=" Press ENTER to Continue with Build or ^ to Exit" D ^D
IR
"RTN","RCCPCPS",238,0)
 .I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) L -^RCPS(349.2):DILOCKTM Q
"RTN","RCCPCPS",239,0)
 ; PRCA*4.5*313 - Unlock prior to jobbing off
"RTN","RCCPCPS",240,0)
 L -^RCPS(349.2):DILOCKTM
"RTN","RCCPCPS",241,0)
 I $D(DIRUT) K SDT Q
"RTN","RCCPCPS",242,0)
TIME S ZTIO="",ZTRTN="EN1^RCCPCPS",ZTDESC="Build CBSS Statement File"
"RTN","RCCPCPS",243,0)
 S ZTDTH="",ZTSAVE("SDT")=SDT D ^%ZTLOAD Q:$G(ZTSK)=""
"RTN","RCCPCPS",244,0)
 S %H=ZTSK("D") D YMD^%DTC S QDT=X_%
"RTN","RCCPCPS",245,0)
 ; PRCA*5.4*313 - Allow run any time
"RTN","RCCPCPS",246,0)
 ;I (QDT>DT_"."_0800)&(QDT<(DT_"."_1801)) D  G TIME
"RTN","RCCPCPS",247,0)
 ;.W !!,*7,"You Can Not Queue this Job Between 8:00am and 6:00pm.",!
"RTN","RCCPCPS",248,0)
 ;.D KILL^%ZTLOAD
"RTN","RCCPCPS",249,0)
 W !,"Queued for Building."
"RTN","RCCPCPS",250,0)
 ; PRCA*4.5*313 - Unlock prior to quitting
"RTN","RCCPCPS",251,0)
 L -^RCPS(349.2):DILOCKTM
"RTN","RCCPCPS",252,0)
 Q
"RTN","RCCPCPS",253,0)
 ;
"RTN","RCCPCPS",254,0)
RCDESC ;Remove "IN PART" & "IN FULL" from the the bill description
"RTN","RCCPCPS",255,0)
 QUIT:$G(RCDESC(1))=""
"RTN","RCCPCPS",256,0)
 S RCINFULL=" (IN FULL)"
"RTN","RCCPCPS",257,0)
 S RCINPART=" (IN PART)"
"RTN","RCCPCPS",258,0)
 I RCDESC(1)[RCINFULL S RCDESC(1)=$P(RCDESC(1),RCINFULL)_$P(RCDESC(1),RCINFULL,
2)
"RTN","RCCPCPS",259,0)
 I RCDESC(1)[RCINPART S RCDESC(1)=$P(RCDESC(1),RCINPART)_$P(RCDESC(1),RCINPART,
2)
"RTN","RCCPCPS",260,0)
 Q
"RTN","RCCPCPS",261,0)
FLBPD1() ; PRCA*4.5*313 - Return last bill prep date
"RTN","RCCPCPS",262,0)
 N X1,X2 S X1="" I '$D(^PRCA(430,"ATD",RCDFN)) Q X1
"RTN","RCCPCPS",263,0)
 S X2=$O(^PRCA(430,"ATD",RCDFN,X1),-1)
"RTN","RCCPCPS",264,0)
 S X1=$O(^PRCA(430,"ATD",RCDFN,X2,X1),-1)
"RTN","RCCPCPS",265,0)
 Q X1
"RTN","RCCPCPS1")
0^11^B65443378^B37370113
"RTN","RCCPCPS1",1,0)
RCCPCPS1 ;WISC/RFJ-build description for patient statement ;08 Aug 2001
"RTN","RCCPCPS1",2,0)
 ;;4.5;Accounts Receivable;**34,48,104,170,176,192,265,313**;Mar 20, 1995;Build
 118
"RTN","RCCPCPS1",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCPS1",4,0)
 Q
"RTN","RCCPCPS1",5,0)
 ;
"RTN","RCCPCPS1",6,0)
 ;
"RTN","RCCPCPS1",7,0)
TRANDESC(RCTRANDA,RCWIDTH) ;  build the description array for a transaction
"RTN","RCCPCPS1",8,0)
 ;
"RTN","RCCPCPS1",9,0)
 ;  initialize
"RTN","RCCPCPS1",10,0)
 N DESCRIPT,RCBILLDA,RCCATEG,RCCATTXT,RCDATA0,RCDATA1,RCDATA3,RCLINE,TRANTYPE,X
"RTN","RCCPCPS1",11,0)
 I '$G(RCWIDTH) S RCWIDTH=50 ; Default max. width is 50 characters
"RTN","RCCPCPS1",12,0)
 K RCDESC
"RTN","RCCPCPS1",13,0)
 S RCLINE=1,RCDESC(1)=""
"RTN","RCCPCPS1",14,0)
 ;
"RTN","RCCPCPS1",15,0)
 S RCBILLDA=+$P($G(^PRCA(433,RCTRANDA,0)),"^",2) I 'RCBILLDA Q
"RTN","RCCPCPS1",16,0)
 S RCDATA0=^PRCA(430,RCBILLDA,0)
"RTN","RCCPCPS1",17,0)
 S RCCATEG=+$P(RCDATA0,"^",2),RCCATTXT=$P($G(^PRCA(430.2,RCCATEG,0)),"^")
"RTN","RCCPCPS1",18,0)
 S RCDATA1=^PRCA(433,RCTRANDA,1)
"RTN","RCCPCPS1",19,0)
 S TRANTYPE=$P(RCDATA1,"^",2)
"RTN","RCCPCPS1",20,0)
 ;
"RTN","RCCPCPS1",21,0)
 ;  build the first line description
"RTN","RCCPCPS1",22,0)
 ;  if transaction type is an increase or decrease, set description
"RTN","RCCPCPS1",23,0)
 I TRANTYPE=1!(TRANTYPE=35) D
"RTN","RCCPCPS1",24,0)
 .   ;  if c means test, set description to category for c means test
"RTN","RCCPCPS1",25,0)
 .   I RCCATEG=18 S DESCRIPT=$S($P(RCDATA0,"^",16):$P(^PRCA(430.2,$P(RCDATA0,"^
",16),0),"^"),1:RCCATTXT) Q
"RTN","RCCPCPS1",26,0)
 .   ;  otherwise, set to category name
"RTN","RCCPCPS1",27,0)
 .   S DESCRIPT=RCCATTXT
"RTN","RCCPCPS1",28,0)
 ;
"RTN","RCCPCPS1",29,0)
 ;  if the bill category is a rx-copay and it is an increase adjustment
"RTN","RCCPCPS1",30,0)
 ;  then set the description to copay
"RTN","RCCPCPS1",31,0)
 I RCCATEG=22!(RCCATEG=23),TRANTYPE=1 S DESCRIPT="COPAY"
"RTN","RCCPCPS1",32,0)
 ;
"RTN","RCCPCPS1",33,0)
 ;  if the bill category is adult day health care, remove health
"RTN","RCCPCPS1",34,0)
 I RCCATEG=33 S DESCRIPT="ADULT DAY CARE"
"RTN","RCCPCPS1",35,0)
 ;
"RTN","RCCPCPS1",36,0)
 ;  if the bill category is respite or geriatric eval,
"RTN","RCCPCPS1",37,0)
 ;  take the 2nd piece removing institutional
"RTN","RCCPCPS1",38,0)
 I RCCATEG=35!(RCCATEG=36)!(RCCATEG=37)!(RCCATEG=38) S DESCRIPT=$P(RCCATTXT,"-"
)_$S(RCCATEG=35!(RCCATEG=37):" IN",1:" OUT")_"PATIENT"
"RTN","RCCPCPS1",39,0)
 ;
"RTN","RCCPCPS1",40,0)
 ;  if it is a comment transaction
"RTN","RCCPCPS1",41,0)
 I TRANTYPE=45 S DESCRIPT="COMMENT: "_$P($G(^PRCA(433,RCTRANDA,5)),"^",2)
"RTN","RCCPCPS1",42,0)
 ;
"RTN","RCCPCPS1",43,0)
 ;  prepayment bill (1=increase, 35=decrease, otherwise refund)
"RTN","RCCPCPS1",44,0)
 I RCCATEG=26 S DESCRIPT=$S(TRANTYPE=1:"OVERPAYMENT CREDIT",TRANTYPE=35:"OVERPA
YMENT CREDIT DECREASE",1:"OVERPAYMENT REFUND")
"RTN","RCCPCPS1",45,0)
 ;
"RTN","RCCPCPS1",46,0)
 ;  if the first line description not set (like payments), set it
"RTN","RCCPCPS1",47,0)
 ;  to the type of transaction
"RTN","RCCPCPS1",48,0)
 I $G(DESCRIPT)="" S DESCRIPT=$P($G(^PRCA(430.3,+$P(RCDATA1,"^",2),0)),"^")
"RTN","RCCPCPS1",49,0)
 ;
"RTN","RCCPCPS1",50,0)
 ;  if the transaction date is different from the process date,
"RTN","RCCPCPS1",51,0)
 ;  show it with the description
"RTN","RCCPCPS1",52,0)
 I $P(RCDATA1,"^"),$P($P(RCDATA1,"^"),".")'=$P($P(RCDATA1,"^",9),".") S DESCRIP
T=DESCRIPT_"  ("_$$DATE($P($P(RCDATA1,"^"),"."))_")"
"RTN","RCCPCPS1",53,0)
 ;
"RTN","RCCPCPS1",54,0)
 ;  set the first description line
"RTN","RCCPCPS1",55,0)
 D SETDESC(DESCRIPT)
"RTN","RCCPCPS1",56,0)
 ;
"RTN","RCCPCPS1",57,0)
 ;  if it is a payment transaction, show amount paid interest, admin, other
"RTN","RCCPCPS1",58,0)
 I TRANTYPE=2!(TRANTYPE=34) D
"RTN","RCCPCPS1",59,0)
 .   S RCDATA3=$G(^PRCA(433,RCTRANDA,3))
"RTN","RCCPCPS1",60,0)
 .   ;  if not interest, admin, or other, quit
"RTN","RCCPCPS1",61,0)
 .   I '$P(RCDATA3,"^",2),'$P(RCDATA3,"^",3),'$P(RCDATA3,"^",4),'$P(RCDATA3,"^"
,5) Q
"RTN","RCCPCPS1",62,0)
 .   ;
"RTN","RCCPCPS1",63,0)
 .   S DESCRIPT="  (Int:"_$J(+$P(RCDATA3,"^",2),1,2)_"  Adm:"_$J(+$P(RCDATA3,"^
",3),1,2)
"RTN","RCCPCPS1",64,0)
 .   ;  calculate other
"RTN","RCCPCPS1",65,0)
 .   S X=$P(RCDATA1,"^",5)-$P(RCDATA3,"^")-$P(RCDATA3,"^",2)-$P(RCDATA3,"^",3)
"RTN","RCCPCPS1",66,0)
 .   S DESCRIPT=DESCRIPT_$S(X:" Other:"_$J(X,1,2)_")",1:")")
"RTN","RCCPCPS1",67,0)
 .   D SETDESC(DESCRIPT)
"RTN","RCCPCPS1",68,0)
 ;
"RTN","RCCPCPS1",69,0)
 ;  if it is a admin cost or interest charge, total the amounts
"RTN","RCCPCPS1",70,0)
 I TRANTYPE=13!(TRANTYPE=12) D  Q
"RTN","RCCPCPS1",71,0)
 .   S X=$G(^PRCA(433,RCTRANDA,2)) I X="" Q
"RTN","RCCPCPS1",72,0)
 .   S RCTOTAL("INT")=$G(RCTOTAL("INT"))+$P(X,"^",7)
"RTN","RCCPCPS1",73,0)
 .   S RCTOTAL("ADM")=$G(RCTOTAL("ADM"))+$P(X,"^",8)
"RTN","RCCPCPS1",74,0)
 .   S RCTOTAL("OTH")=$G(RCTOTAL("OTH"))+($P(RCDATA1,"^",5)-$P(X,"^",7)-$P(X,"^
",8))
"RTN","RCCPCPS1",75,0)
 ;
"RTN","RCCPCPS1",76,0)
 ;  if not an increase adjustment, quit
"RTN","RCCPCPS1",77,0)
 I TRANTYPE'=1 Q
"RTN","RCCPCPS1",78,0)
 ;
"RTN","RCCPCPS1",79,0)
 ;  increase to c means test, ltc or rx-copay, get data from ib
"RTN","RCCPCPS1",80,0)
 I RCCATEG=18!(RCCATEG=22)!(RCCATEG=23)!((RCCATEG>32)&(RCCATEG<40)) D
"RTN","RCCPCPS1",81,0)
 .   S X="IBRFN1" X ^%ZOSF("TEST") I '$T Q
"RTN","RCCPCPS1",82,0)
 .   K ^TMP("IBRFN1",$J)
"RTN","RCCPCPS1",83,0)
 .   D STMT^IBRFN1(RCTRANDA)
"RTN","RCCPCPS1",84,0)
 .   D IBDATA
"RTN","RCCPCPS1",85,0)
 Q
"RTN","RCCPCPS1",86,0)
 ;
"RTN","RCCPCPS1",87,0)
 ;
"RTN","RCCPCPS1",88,0)
 ;  Returns RCDESC(1..n) array of Bill Description
"RTN","RCCPCPS1",89,0)
BILLDESC(RCBILLDA,RCWIDTH) ;
"RTN","RCCPCPS1",90,0)
 ;  initialize
"RTN","RCCPCPS1",91,0)
 N DESCRIPT,RCCATEG,RCCATTXT,RCDATA0,RCLINE,X
"RTN","RCCPCPS1",92,0)
 I '$G(RCWIDTH) S RCWIDTH=50 ; Default max. width is 50 characters
"RTN","RCCPCPS1",93,0)
 K RCDESC
"RTN","RCCPCPS1",94,0)
 S RCLINE=1,RCDESC(1)=""
"RTN","RCCPCPS1",95,0)
 ;
"RTN","RCCPCPS1",96,0)
 S RCDATA0=^PRCA(430,RCBILLDA,0)
"RTN","RCCPCPS1",97,0)
 S RCCATEG=+$P(RCDATA0,"^",2),RCCATTXT=$P($G(^PRCA(430.2,RCCATEG,0)),"^")
"RTN","RCCPCPS1",98,0)
 ;
"RTN","RCCPCPS1",99,0)
 ;  if category=c means test, set the description and quit
"RTN","RCCPCPS1",100,0)
 I RCCATEG=18 S DESCRIPT=$S($P(RCDATA0,"^",16):$P(^PRCA(430.2,$P(RCDATA0,"^",16
),0),"^"),1:RCCATTXT) D SETDESC(DESCRIPT) Q
"RTN","RCCPCPS1",101,0)
 ;
"RTN","RCCPCPS1",102,0)
 ;  set the category description
"RTN","RCCPCPS1",103,0)
 D SETDESC(RCCATTXT)
"RTN","RCCPCPS1",104,0)
 ;
"RTN","RCCPCPS1",105,0)
 ;  if category not champva subsitence and not tricare patient, quit
"RTN","RCCPCPS1",106,0)
 I RCCATEG'=27,RCCATEG'=31 Q
"RTN","RCCPCPS1",107,0)
 ;
"RTN","RCCPCPS1",108,0)
 ;  build description for champva subsistence and tricare patient bills
"RTN","RCCPCPS1",109,0)
 ;  get data from ib
"RTN","RCCPCPS1",110,0)
 S X="IBRFN1" X ^%ZOSF("TEST") I '$T Q
"RTN","RCCPCPS1",111,0)
 K ^TMP("IBRFN1",$J)
"RTN","RCCPCPS1",112,0)
 D STMTB^IBRFN1($P(RCDATA0,"^"))
"RTN","RCCPCPS1",113,0)
 D IBDATA
"RTN","RCCPCPS1",114,0)
 Q
"RTN","RCCPCPS1",115,0)
 ;
"RTN","RCCPCPS1",116,0)
 ;
"RTN","RCCPCPS1",117,0)
IBDATA ;  get data from IB for description
"RTN","RCCPCPS1",118,0)
 N IBDATA,IBJ
"RTN","RCCPCPS1",119,0)
 ;
"RTN","RCCPCPS1",120,0)
 ;  show IB data
"RTN","RCCPCPS1",121,0)
 S IBJ=0 F  S IBJ=$O(^TMP("IBRFN1",$J,IBJ)) Q:'IBJ  S IBDATA=^TMP("IBRFN1",$J,I
BJ) D
"RTN","RCCPCPS1",122,0)
 .   ;
"RTN","RCCPCPS1",123,0)
 .   ;  if no drug or bill date returned from IB, then it is outpatient
"RTN","RCCPCPS1",124,0)
 .   I $P(IBDATA,"^",3)="" D:$P(IBDATA,"^",2) SETDESC("VISIT DATE: "_$$DATE($P(
IBDATA,"^",2))) Q
"RTN","RCCPCPS1",125,0)
 .   ;
"RTN","RCCPCPS1",126,0)
 .   ;  if no drug quantity returned from ib, then it is inpatient
"RTN","RCCPCPS1",127,0)
 .   I '$P(IBDATA,"^",6) D  Q
"RTN","RCCPCPS1",128,0)
 .   .   I $P(IBDATA,"^",2) D SETDESC("  ADMISSION DATE: "_$$DATE($P(IBDATA,"^"
,2)))
"RTN","RCCPCPS1",129,0)
 .   .   I $P(IBDATA,"^",3) D SETDESC("  BEGINNING DATE OF BILLING CYCLE: "_$$D
ATE($P(IBDATA,"^",3)))
"RTN","RCCPCPS1",130,0)
 .   .   I $P(IBDATA,"^",4) D SETDESC("  ENDING DATE OF BILLING CYCLE: "_$$DATE
($P(IBDATA,"^",4)))
"RTN","RCCPCPS1",131,0)
 .   .   I $P(IBDATA,"^",5) D SETDESC("  DISCHARGE DATE: "_$$DATE($P(IBDATA,"^"
,5)))
"RTN","RCCPCPS1",132,0)
 .   ;
"RTN","RCCPCPS1",133,0)
 .   ;  pharmacy
"RTN","RCCPCPS1",134,0)
 .   D:$P(IBDATA,"^",2) SETDESC("RX:"_$P(IBDATA,"^",2))
"RTN","RCCPCPS1",135,0)
 .   D:$P(IBDATA,"^",7) SETDESC("FD:"_$$DATE($P(IBDATA,"^",7)))
"RTN","RCCPCPS1",136,0)
 .   ;
"RTN","RCCPCPS1",137,0)
 .   ;  if not patient statement detail, quit
"RTN","RCCPCPS1",138,0)
 .   I $$DET^RCFN01($P(RCDATA0,"^",9))'=2 Q
"RTN","RCCPCPS1",139,0)
 .   ;
"RTN","RCCPCPS1",140,0)
 .   ;  return pharmacy detail
"RTN","RCCPCPS1",141,0)
 .   I $P(IBDATA,"^",3)'="" D SETDESC(" DRUG:"_$TR($P(IBDATA,"^",3),"|~"))
"RTN","RCCPCPS1",142,0)
 .   I $P(IBDATA,"^",4) D SETDESC(" DAYS:"_$P(IBDATA,"^",4))
"RTN","RCCPCPS1",143,0)
 .   I $P(IBDATA,"^",6) D SETDESC(" QTY:"_$P(IBDATA,"^",6))
"RTN","RCCPCPS1",144,0)
 .   I $P(IBDATA,"^",5)'="" D SETDESC(" PHY:"_$P(IBDATA,"^",5))
"RTN","RCCPCPS1",145,0)
 .   I $P(IBDATA,"^",8) D SETDESC(" CHG:$"_$J($P(IBDATA,"^",8),0,2))
"RTN","RCCPCPS1",146,0)
 ;
"RTN","RCCPCPS1",147,0)
 K ^TMP("IBRFN1",$J)
"RTN","RCCPCPS1",148,0)
 Q
"RTN","RCCPCPS1",149,0)
 ;
"RTN","RCCPCPS1",150,0)
 ;
"RTN","RCCPCPS1",151,0)
 ; Add line to the description, not longer than RCWIDTH
"RTN","RCCPCPS1",152,0)
 ; Input: RCLINE,RCWIDTH
"RTN","RCCPCPS1",153,0)
 ; Output: RCDESC
"RTN","RCCPCPS1",154,0)
SETDESC(DESCRIPT) N LENGTH
"RTN","RCCPCPS1",155,0)
 ;  calculate the length of the description
"RTN","RCCPCPS1",156,0)
 S LENGTH=$L(RCDESC(RCLINE))+$L(DESCRIPT)
"RTN","RCCPCPS1",157,0)
 I RCDESC(RCLINE)'="" S LENGTH=LENGTH+1
"RTN","RCCPCPS1",158,0)
 ;
"RTN","RCCPCPS1",159,0)
 ;  the description line cannot go over RCWIDTH characters
"RTN","RCCPCPS1",160,0)
 I LENGTH<RCWIDTH S RCDESC(RCLINE)=RCDESC(RCLINE)_$S(RCDESC(RCLINE)="":"",1:" "
)_DESCRIPT Q
"RTN","RCCPCPS1",161,0)
 ;
"RTN","RCCPCPS1",162,0)
 ; Description line to add is over RCWIDTH
"RTN","RCCPCPS1",163,0)
 ; The given string will be splitted _only_ if the limit is more than 44 charac
ters.
"RTN","RCCPCPS1",164,0)
 I $L(DESCRIPT)>RCWIDTH D  Q
"RTN","RCCPCPS1",165,0)
 .   I RCDESC(RCLINE)'="" S RCLINE=RCLINE+1
"RTN","RCCPCPS1",166,0)
 .   S RCDESC(RCLINE)=$E(DESCRIPT,1,RCWIDTH)
"RTN","RCCPCPS1",167,0)
 .   S RCLINE=RCLINE+1
"RTN","RCCPCPS1",168,0)
 .   S RCDESC(RCLINE)=$E(DESCRIPT,RCWIDTH+1,2*RCWIDTH)
"RTN","RCCPCPS1",169,0)
 ;
"RTN","RCCPCPS1",170,0)
 ;  over RCWIDTH characters, start new line
"RTN","RCCPCPS1",171,0)
 I RCDESC(RCLINE)'="" S RCLINE=RCLINE+1
"RTN","RCCPCPS1",172,0)
 S RCDESC(RCLINE)=DESCRIPT
"RTN","RCCPCPS1",173,0)
 Q
"RTN","RCCPCPS1",174,0)
 ;
"RTN","RCCPCPS1",175,0)
DATE(FMDT) ;  format date mm/dd/yyyy
"RTN","RCCPCPS1",176,0)
 I 'FMDT Q ""
"RTN","RCCPCPS1",177,0)
 N X,Y,%DT S %DT="TX",X=FMDT D ^%DT Q:Y<0 ""
"RTN","RCCPCPS1",178,0)
 Q $E(FMDT,4,5)_"/"_$E(FMDT,6,7)_"/"_(1700+$E(FMDT,1,3))
"RTN","RCCPCPS1",179,0)
 ;
"RTN","RCCPCPS1",180,0)
KILL(SDT)  ;  PRCA*4.5*313 - kill data prior to recreating for this day of mont
h
"RTN","RCCPCPS1",181,0)
 ;
"RTN","RCCPCPS1",182,0)
 ; Set date back one month
"RTN","RCCPCPS1",183,0)
 N IEN,X,RCT,DA,DIK,ACK
"RTN","RCCPCPS1",184,0)
 ;
"RTN","RCCPCPS1",185,0)
 S IEN=""
"RTN","RCCPCPS1",186,0)
 F  S IEN=$O(^RCPS(349.2,"STDT",SDT,IEN)) Q:IEN=""  S DA=IEN,DIK="^RCPS(349.2,"
 D ^DIK
"RTN","RCCPCPS1",187,0)
 ;
"RTN","RCCPCPS1",188,0)
 F X="PA","IS" S RCT=$O(^RCT(349.1,"B",X,0)) Q:'RCT  D
"RTN","RCCPCPS1",189,0)
 . S ACK="" F  S ACK=$O(^RCT(349.1,RCT,4,"STDT4",SDT,ACK)) Q:ACK=""  D
"RTN","RCCPCPS1",190,0)
 . . S IEN=0 F  S IEN=$O(^RCT(349.1,RCT,4,"STDT4",SDT,ACK,IEN)) Q:IEN=""  S DA=
IEN,DIK="^RCT(349.1,"_RCT_",4," D ^DIK K ^RCT(349.1,RCT,4,"STDT4",SDT,ACK,IEN)
"RTN","RCCPCPS1",191,0)
 . S IEN=0 F  S IEN=$O(^RCT(349.1,RCT,5,"STDT5",SDT,IEN)) Q:IEN=""  S DA=IEN,DI
K="^RCT(349.1,"_RCT_",5," D ^DIK K ^RCT(349.1,RCT,5,"STDT5",SDT,IEN)
"RTN","RCCPCPS1",192,0)
 ;
"RTN","RCCPCPS1",193,0)
 K ^XTMP("RCCPC")
"RTN","RCCPCPS1",194,0)
 ;
"RTN","RCCPCPS1",195,0)
 Q
"RTN","RCCPCPS1",196,0)
 ;
"RTN","RCCPCPS1",197,0)
MONTHAGO(SDT)  ; PRCA*4.5*313 - Return date one month prior to entered date - S
DT is statement date
"RTN","RCCPCPS1",198,0)
 ; and Statement date cannot exceed 26th day of the month.  
"RTN","RCCPCPS1",199,0)
 ; New OLDDT in calling routine
"RTN","RCCPCPS1",200,0)
 S OLDDT=SDT-100
"RTN","RCCPCPS1",201,0)
 I $E(SDT,4,5)="01" S OLDDT=($E(SDT,1,3)-1)_12_$E(SDT,6,7)
"RTN","RCCPCPS1",202,0)
 Q OLDDT
"RTN","RCCPCPS1",203,0)
 ;
"RTN","RCCPCPS1",204,0)
ICNERR   ; PRCA*4.5*313 - Send email to RCCPC STATEMENTS Mail Group with all mi
ssing ICNs
"RTN","RCCPCPS1",205,0)
 N XMTO,XMSUBJ,XMBODY,XMINSTR,XMDUZ,XMY,DFN,CNT,I
"RTN","RCCPCPS1",206,0)
 ;
"RTN","RCCPCPS1",207,0)
 ; Create Message at MSG level of temporary storage
"RTN","RCCPCPS1",208,0)
 S CNT=1,^TMP("ICNERROR",$J,"MSG",CNT)="The Patient Statements for these patien
ts were not sent to CBSS due to a"
"RTN","RCCPCPS1",209,0)
 S CNT=2,^TMP("ICNERROR",$J,"MSG",CNT)="missing ICN."
"RTN","RCCPCPS1",210,0)
 S CNT=3,^TMP("ICNERROR",$J,"MSG",CNT)="NAME                                SSN
"
"RTN","RCCPCPS1",211,0)
 S CNT=4,^TMP("ICNERROR",$J,"MSG",CNT)="=======================================
======="
"RTN","RCCPCPS1",212,0)
 S DFN="" F  S DFN=$O(^TMP("ICNERROR",$J,DFN)) Q:DFN=""  Q:DFN="MSG"  D
"RTN","RCCPCPS1",213,0)
 . N DPTDATA,NAME
"RTN","RCCPCPS1",214,0)
 . S DPTDATA=$G(^DPT(DFN,0))
"RTN","RCCPCPS1",215,0)
 . I DPTDATA="" Q
"RTN","RCCPCPS1",216,0)
 . S NAME=$P(DPTDATA,U)
"RTN","RCCPCPS1",217,0)
 . I $L(NAME)<35 S $E(NAME,35)=" "
"RTN","RCCPCPS1",218,0)
 . S CNT=CNT+1
"RTN","RCCPCPS1",219,0)
 . S ^TMP("ICNERROR",$J,"MSG",CNT)=NAME_$P(DPTDATA,U,9)
"RTN","RCCPCPS1",220,0)
 ;
"RTN","RCCPCPS1",221,0)
 S XMDUZ=DUZ
"RTN","RCCPCPS1",222,0)
 S XMTO(DUZ)=""
"RTN","RCCPCPS1",223,0)
 S XMTO("G.RCCPC STATEMENTS")=""
"RTN","RCCPCPS1",224,0)
 S XMSUBJ="PATIENTS WITH MISSING ICNS"
"RTN","RCCPCPS1",225,0)
 S XMBODY="^TMP(""ICNERROR"",$J,""MSG"")"
"RTN","RCCPCPS1",226,0)
 S XMINSTR("FLAGS")="X"
"RTN","RCCPCPS1",227,0)
 D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,.XMINSTR)
"RTN","RCCPCPS1",228,0)
 Q
"RTN","RCCPCSE")
0^14^B16507603^B5810439
"RTN","RCCPCSE",1,0)
RCCPCSE ;WASH-ISC@ALTOONA,PA/LDB - CCPC Statements Errors;5/30/96  10:20 AM ;10
/16/96  8:42 AM
"RTN","RCCPCSE",2,0)
V ;;4.5;Accounts Receivable;**34,313**;Mar 20, 1995;Build 118
"RTN","RCCPCSE",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCSE",4,0)
 ;
"RTN","RCCPCSE",5,0)
 K ^TMP($J)
"RTN","RCCPCSE",6,0)
 N ADD,DIR,DIRUT,ERR,ERROR,HDR,LINE,LN,PG,POP,PT,X,X1,Y,%ZIS,Z,ZTRTN,ZTDESC,%,%
Y,ZTSAVE
"RTN","RCCPCSE",7,0)
 I '$O(^RCPS(349.2,"AD","E",0)) W !,"THERE ARE NO CBSS PATIENT STATEMENT ERRORS
" Q
"RTN","RCCPCSE",8,0)
 E  W !,"CBSS PATIENT STATEMENT ERROR REPORT"
"RTN","RCCPCSE",9,0)
 N IEN,%D,DTOUT,SDT,SDAT,TMPQ,ALL,DTPT
"RTN","RCCPCSE",10,0)
 S (TMPQ,ALL)=0
"RTN","RCCPCSE",11,0)
 S IEN="" F  S IEN=$O(^RCPS(349.2,"AD","E",IEN)) Q:IEN=""  I $G(^RCPS(349.2,IEN
,5))'="" D
"RTN","RCCPCSE",12,0)
 . S SDT=$P(^RCPS(349.2,IEN,0),U,19)
"RTN","RCCPCSE",13,0)
 . S DTPT(SDT,IEN)=""
"RTN","RCCPCSE",14,0)
 . S DTPT(SDT)=$G(DTPT(SDT))+1
"RTN","RCCPCSE",15,0)
 ; PRCA*4.5*313 - Ask about all dates or specific
"RTN","RCCPCSE",16,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCSE",17,0)
 S DIR(0)="YAO"
"RTN","RCCPCSE",18,0)
 S DIR("B")="Y"
"RTN","RCCPCSE",19,0)
 S DIR("A")="Do you want to print errors for all dates available? "
"RTN","RCCPCSE",20,0)
 D ^DIR
"RTN","RCCPCSE",21,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCSE",22,0)
 I Y=1 S ALL=1 D PRINT Q
"RTN","RCCPCSE",23,0)
 ; PRCA*4.5*313 - Add date prompts
"RTN","RCCPCSE",24,0)
 W !,"The following dates have errors to print:"
"RTN","RCCPCSE",25,0)
 S SDT="" F  S SDT=$O(DTPT(SDT))  Q:SDT=""  W !,$$DATE^RCCPCPS1(SDT)
"RTN","RCCPCSE",26,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCSE",27,0)
 S DIR(0)="DAO^^K:'$D(DTPT(Y)) X"
"RTN","RCCPCSE",28,0)
 S DIR("A")="Enter a Patient Statement date from list above: "
"RTN","RCCPCSE",29,0)
 S DIR("?")="Enter a Patient Statement date from list above or ^ to exit."
"RTN","RCCPCSE",30,0)
 D ^DIR
"RTN","RCCPCSE",31,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCSE",32,0)
 S SDT=Y
"RTN","RCCPCSE",33,0)
 D PRINT
"RTN","RCCPCSE",34,0)
 Q
"RTN","RCCPCSE",35,0)
PRINT  ; PRCA*4.5*313 Determine print device then enter Sort
"RTN","RCCPCSE",36,0)
 D HOME^%ZIS S %ZIS="QN" D ^%ZIS Q:POP
"RTN","RCCPCSE",37,0)
 I $D(IO("Q")) D  Q
"RTN","RCCPCSE",38,0)
 .S ZTRTN="SORT^RCCPCSE",ZTDESC="CBSS PATIENT STATEMENT ERROR REPORT"
"RTN","RCCPCSE",39,0)
 . S TMPQ=1,(ZTSAVE("DTPT("),ZTSAVE("SDT"),ZTSAVE("ALL"),ZTSAVE("TMPQ"))=""
"RTN","RCCPCSE",40,0)
 .D ^%ZTLOAD
"RTN","RCCPCSE",41,0)
SORT  ; PRCA*4.5*313 - Rewritten to print by date
"RTN","RCCPCSE",42,0)
 S HDR="CBSS PATIENT STATEMENT ERROR REPORT",LINE="",$P(LINE,"=",79)="",PG=1
"RTN","RCCPCSE",43,0)
 I 'ALL D SORT1,PRNT Q
"RTN","RCCPCSE",44,0)
 I ALL S SDT=""
"RTN","RCCPCSE",45,0)
 F  S SDT=$O(DTPT(SDT)) Q:SDT=""  D SORT1
"RTN","RCCPCSE",46,0)
 D PRNT
"RTN","RCCPCSE",47,0)
 ; PRCA*4.5*313 - Remove TMP storage
"RTN","RCCPCSE",48,0)
 K ^TMP($J)
"RTN","RCCPCSE",49,0)
 Q
"RTN","RCCPCSE",50,0)
SORT1  ;PRCA*4.5*313 Print a day of errors
"RTN","RCCPCSE",51,0)
 N IEN
"RTN","RCCPCSE",52,0)
 S IEN="" F  S IEN=$O(DTPT(SDT,IEN)) Q:IEN=""  D
"RTN","RCCPCSE",53,0)
 .S ERR=$G(^RCPS(349.2,IEN,5))
"RTN","RCCPCSE",54,0)
 .S ^TMP($J,"ERR",SDT,IEN)=$P($G(^RCPS(349.2,IEN,0)),"^",3)_"^"_$P(^(0),"^",2)
"RTN","RCCPCSE",55,0)
 .S ADD=$G(^RCPS(349.2,IEN,1))
"RTN","RCCPCSE",56,0)
 .F X=1:1:6 S ADD(X)=$P(ADD,"^",X),^TMP($J,"ERR",SDT,IEN,1+X)=ADD(X)
"RTN","RCCPCSE",57,0)
 .F X=1:5 S X1=X+4,ERROR=$E(ERR,X,X1) Q:ERROR=""  D
"RTN","RCCPCSE",58,0)
 ..S ^TMP($J,"ERR",SDT,IEN,X+10)=ERROR
"RTN","RCCPCSE",59,0)
 ..S ERROR=$O(^RCPSE(349.7,"B",$E(ERROR,1,5),""))
"RTN","RCCPCSE",60,0)
 ..S ERROR=$P($G(^RCPSE(349.7,+ERROR,0)),"^",4)
"RTN","RCCPCSE",61,0)
 ..S ^TMP($J,"ERR",SDT,IEN,X+10)=^TMP($J,"ERR",SDT,IEN,X+10)_"^"_ERROR
"RTN","RCCPCSE",62,0)
 ;
"RTN","RCCPCSE",63,0)
 K ADD
"RTN","RCCPCSE",64,0)
 Q
"RTN","RCCPCSE",65,0)
PRNT  ; PRCA*4.5*313 - Print based upon statement date
"RTN","RCCPCSE",66,0)
 K DIRUT
"RTN","RCCPCSE",67,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCSE",68,0)
 S (SDT,IEN)=""
"RTN","RCCPCSE",69,0)
 F  S SDT=$O(^TMP($J,"ERR",SDT)) Q:SDT=""  D  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$
D(DIROUT) Q
"RTN","RCCPCSE",70,0)
 . W @IOF,?25,HDR,?75,PG,!,LINE S PG=PG+1
"RTN","RCCPCSE",71,0)
 . W !,?20,"Patient Statement Date: "_$$DATE^RCCPCPS1(SDT),!,LINE
"RTN","RCCPCSE",72,0)
 . F  S IEN=$O(^TMP($J,"ERR",SDT,IEN)) Q:IEN=""  D PRNT1 I $D(DTOUT)!$D(DUOUT)!
$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCSE",73,0)
 . I 'TMPQ S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCSE",74,0)
 Q
"RTN","RCCPCSE",75,0)
PRNT1  ; PRCA*4.5*313 - Print based upon statement date
"RTN","RCCPCSE",76,0)
 I ($Y+12)>IOSL D
"RTN","RCCPCSE",77,0)
 .I 'TMPQ S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCSE",78,0)
 .W @IOF,?25,HDR,?75,PG S PG=PG+1
"RTN","RCCPCSE",79,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCSE",80,0)
 W !!,$E($P(^TMP($J,"ERR",SDT,IEN),"^"),1,25),?37,"ERROR CODES",!,$P(^(IEN),"^"
,2),?30,$E(LINE,1,48)
"RTN","RCCPCSE",81,0)
 F X=2:1:4 S:$G(^TMP($J,"ERR",SDT,IEN,X))]"" ADD(X)=^(X)
"RTN","RCCPCSE",82,0)
 S ADD(5)=$G(^TMP($J,"ERR",SDT,IEN,5))_", "_$G(^(6))_" "_$G(^(7))
"RTN","RCCPCSE",83,0)
 S X=7 F  S X=$O(^TMP($J,"ERR",SDT,IEN,X)) Q:'X  S ERR(X-1)=^(X)
"RTN","RCCPCSE",84,0)
 S (Z,Y)=0 F  D  Q:Y=""&(Z="")
"RTN","RCCPCSE",85,0)
 .W !
"RTN","RCCPCSE",86,0)
 .I Z'="" S Z=$O(ADD(Z)) I Z'="",(ADD(Z)]"") W ADD(Z)
"RTN","RCCPCSE",87,0)
 .I Y'="" S Y=$O(ERR(Y)) I Y'="" W ?30,$P(ERR(Y),"^"),?40,$P(ERR(Y),"^",2)
"RTN","RCCPCSE",88,0)
 W !,LINE
"RTN","RCCPCSE",89,0)
 Q
"RTN","RCCPCSV")
0^9^B11825361^B5199490
"RTN","RCCPCSV",1,0)
RCCPCSV  ;WASH-ISC@ALTOONA,PA/LDB-Receive and Process CCPC messages ;1/6/97  11
:36 AM
"RTN","RCCPCSV",2,0)
V ;;4.5;Accounts Receivable;**34,70,87,313**;Mar 20, 1995;Build 118
"RTN","RCCPCSV",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCSV",4,0)
 ;
"RTN","RCCPCSV",5,0)
EN ;INPUT FROM MESSAGE
"RTN","RCCPCSV",6,0)
RREC ;READ INCOMING MESSAGE
"RTN","RCCPCSV",7,0)
 N DAT,DEB,END,ERR,ERROR,EVN,KEY,LABEL,LN,MSG,P,RCMSG,RCTR,RCX,RCX1,RE,SBAL,STO
T,TR,TR0,TR1,TXT
"RTN","RCCPCSV",8,0)
 N SDT,NOERR,X,Y,DA
"RTN","RCCPCSV",9,0)
 K ^TMP($J)
"RTN","RCCPCSV",10,0)
 S (LN,MSG,RCX,RE)=0
"RTN","RCCPCSV",11,0)
 S TXT=0 F  X XMREC Q:XMER<0!(XMRG="")  S TXT=TXT+1,^TMP($J,"MSG",TXT)=XMRG
"RTN","RCCPCSV",12,0)
 S (DA(1),NOERR)=""
"RTN","RCCPCSV",13,0)
 S TXT=1 F  S TXT=$O(^TMP($J,"MSG",TXT)) Q:'TXT  D
"RTN","RCCPCSV",14,0)
 . S:^TMP($J,"MSG",TXT)?1"PA^".E DA(1)=4 S:^TMP($J,"MSG",TXT)?1"IS".E DA(1)=3
"RTN","RCCPCSV",15,0)
 . ; PRCA*4.5*313 - Set Statement date from PA or IS records
"RTN","RCCPCSV",16,0)
 . I "PAIS"[$E(^TMP($J,"MSG",TXT),1,2) S X=$P(^TMP($J,"MSG",TXT),"^",7) D ^%DT 
S SDT=Y
"RTN","RCCPCSV",17,0)
 . ; PRCA*4.5*313 - If the date and sequence number have already been processed
 quit after setting an error
"RTN","RCCPCSV",18,0)
 . I "PAIS"[$P(^TMP($J,"MSG",TXT),U) I ($D(^RCT(349.1,DA(1),4,"STDT4",SDT,$P(^T
MP($J,"MSG",TXT),U,2)))) D  Q
"RTN","RCCPCSV",19,0)
 . . S ERR="Duplicate file was received for Patient Statement Date: "_$P(^TMP($
J,"MSG",TXT),U,7) D ERRMSG
"RTN","RCCPCSV",20,0)
 . . S ERR="Last Message Acknowledgement Number: "_$P(^TMP($J,"MSG",TXT),U,2) D
 ERRMSG
"RTN","RCCPCSV",21,0)
 . . S SDT=$P(^TMP($J,"MSG",TXT),U,7)
"RTN","RCCPCSV",22,0)
 . ; PRCA*4.5*313 - If IT is received it always processes
"RTN","RCCPCSV",23,0)
 . I $P(^TMP($J,"MSG",TXT),U)="IT" S SDT=$P(^TMP($J,"MSG",TXT),"^",6),NOERR=1 Q
"RTN","RCCPCSV",24,0)
 . I $G(XMZ)=""!('DA(1))!($D(ERR)) Q
"RTN","RCCPCSV",25,0)
 . S RCX=RCX+1
"RTN","RCCPCSV",26,0)
 . I "PAISADID"[$E(^TMP($J,"MSG",TXT),1,2) D
"RTN","RCCPCSV",27,0)
 . . ; PRCA*4.5*313 - Add Statement Date to 349.1, five level for PA, IS, AD, a
nd ID records
"RTN","RCCPCSV",28,0)
 . . N DINUM,DIC,X
"RTN","RCCPCSV",29,0)
 . . S DINUM=+$G(XMZ)_RCX
"RTN","RCCPCSV",30,0)
 . . S DIC="^RCT(349.1,DA(1),5,"
"RTN","RCCPCSV",31,0)
 . . S X=$P(^TMP($J,"MSG",TXT),"^",2)
"RTN","RCCPCSV",32,0)
 . . S DIC(0)="L"
"RTN","RCCPCSV",33,0)
 . . S DIC("DR")=".02////"_$P(^TMP($J,"MSG",TXT),"^",3)_";.03////"_$G(XMZ)_";.0
4////"_SDT
"RTN","RCCPCSV",34,0)
 . . D FILE^DICN
"RTN","RCCPCSV",35,0)
 . ; PRCA*4.5*313 - If processing has occurred 
"RTN","RCCPCSV",36,0)
 . S NOERR=1
"RTN","RCCPCSV",37,0)
 ;
"RTN","RCCPCSV",38,0)
 K DA(1)
"RTN","RCCPCSV",39,0)
 I NOERR D SEG,KILL^XM
"RTN","RCCPCSV",40,0)
 I $O(^TMP($J,"ERR",0)) D
"RTN","RCCPCSV",41,0)
 . ; PRCA*4.5*313 - Change CCPC to CBSS and add date
"RTN","RCCPCSV",42,0)
 . S XMSUB="CBSS ERROR MESSAGE TO STATION FOR "_SDT
"RTN","RCCPCSV",43,0)
 . S XMDUZ="AR PACKAGE"
"RTN","RCCPCSV",44,0)
 . S XMTEXT="^TMP($J,"_"""ERR"","
"RTN","RCCPCSV",45,0)
 . I $O(^XMB(3.8,"B","RCCPC STATEMENTS",0)) S XMY("G.RCCPC STATEMENTS")=""
"RTN","RCCPCSV",46,0)
 . D ^XMD
"RTN","RCCPCSV",47,0)
 . K ^TMP($J)
"RTN","RCCPCSV",48,0)
 . ; PRCA*4.5*313 - Change to send SDT for resend
"RTN","RCCPCSV",49,0)
 . D:$G(RE)="R"&($G(SDT)'="") EN^RCCPCML(SDT)
"RTN","RCCPCSV",50,0)
 E  S XMZ=XQMSG,XMSER="S."_XQSOP D REMSBMSG^XMA1C
"RTN","RCCPCSV",51,0)
 Q
"RTN","RCCPCSV",52,0)
 ;
"RTN","RCCPCSV",53,0)
SEG S RCMSG=1 S RCMSG=$O(^TMP($J,"MSG",RCMSG)) D
"RTN","RCCPCSV",54,0)
 .S RCTR=^TMP($J,"MSG",RCMSG)
"RTN","RCCPCSV",55,0)
 .S LABEL=$S(($P(RCTR,"^")]"")&($T(@($P(RCTR,"^")))]""):$P(RCTR,"^"),1:"ERROR")
"RTN","RCCPCSV",56,0)
 .D @(LABEL)
"RTN","RCCPCSV",57,0)
 Q
"RTN","RCCPCSV",58,0)
 ;
"RTN","RCCPCSV",59,0)
ERROR ;SEND ERROR MESSAGE TO MAIL GROUP
"RTN","RCCPCSV",60,0)
 ;
"RTN","RCCPCSV",61,0)
 ; PRCA*4.5*313 - Change CCPC to CBSS
"RTN","RCCPCSV",62,0)
 S ERR="CBSS ERROR - CANNOT READ MESSAGE FROM CBSS" D ERRMSG
"RTN","RCCPCSV",63,0)
 S ERR="An error has occurred in reading a message from the CBSS."
"RTN","RCCPCSV",64,0)
 D ERRMSG
"RTN","RCCPCSV",65,0)
 S ERR="Please contact your IRM for assistance."
"RTN","RCCPCSV",66,0)
 D ERRMSG
"RTN","RCCPCSV",67,0)
 S ERR="The MESSAGE WAS AS FOLLOWS:"
"RTN","RCCPCSV",68,0)
 D ERRMSG
"RTN","RCCPCSV",69,0)
 S ERR=^TMP($J,"MSG",RCMSG)
"RTN","RCCPCSV",70,0)
 D ERRMSG
"RTN","RCCPCSV",71,0)
 Q
"RTN","RCCPCSV",72,0)
 ;
"RTN","RCCPCSV",73,0)
IS ;INVALID STATEMENT
"RTN","RCCPCSV",74,0)
 D IS^RCCPCSV1
"RTN","RCCPCSV",75,0)
 Q
"RTN","RCCPCSV",76,0)
 ;
"RTN","RCCPCSV",77,0)
PA ;STATEMENT ACKNOWLEDGEMENT
"RTN","RCCPCSV",78,0)
 D PA^RCCPCSV1
"RTN","RCCPCSV",79,0)
 Q
"RTN","RCCPCSV",80,0)
 ;
"RTN","RCCPCSV",81,0)
IT ;INVALID TRANSMISSION
"RTN","RCCPCSV",82,0)
 D IT^RCCPCSV1
"RTN","RCCPCSV",83,0)
 Q
"RTN","RCCPCSV",84,0)
 ;
"RTN","RCCPCSV",85,0)
ERRMSG ;ERROR MESSAGE
"RTN","RCCPCSV",86,0)
 S LN=LN+1,^TMP($J,"ERR",LN)=ERR
"RTN","RCCPCSV",87,0)
 Q
"RTN","RCCPCSV1")
0^12^B43313841^B32017096
"RTN","RCCPCSV1",1,0)
RCCPCSV1 ;WASH-ISC@ALTOONA,PA/LDB-Receive and Process CCPC messages ;1/6/97  2:
54 PM
"RTN","RCCPCSV1",2,0)
 ;;4.5;Accounts Receivable;**34,70,76,130,153,313**;Mar 20, 1995;Build 118
"RTN","RCCPCSV1",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCSV1",4,0)
 ;
"RTN","RCCPCSV1",5,0)
IS ;INVALID STATEMENT
"RTN","RCCPCSV1",6,0)
 ; PRCA*4.5*313 - Add SDT for Patient Statement Date
"RTN","RCCPCSV1",7,0)
 N SDAT,SDT,X,Y,ERR
"RTN","RCCPCSV1",8,0)
 S SDAT=$P(RCTR,"^",7) S (X,SDT)=SDAT D ^%DT S SDAT=Y
"RTN","RCCPCSV1",9,0)
 D CHKTRAN(LABEL)
"RTN","RCCPCSV1",10,0)
 S ERR="The following statements did not print due to errors:" D ERRMSG
"RTN","RCCPCSV1",11,0)
 S ERR=" " D ERRMSG
"RTN","RCCPCSV1",12,0)
 S ERR="     KEY            ERROR" D ERRMSG S ERR=" " D ERRMSG
"RTN","RCCPCSV1",13,0)
 D ID
"RTN","RCCPCSV1",14,0)
 S ERR="If these errors are corrected, these statements will not print until" D
 ERRMSG S ERR="the next billing cycle." D ERRMSG
"RTN","RCCPCSV1",15,0)
 Q
"RTN","RCCPCSV1",16,0)
 ;
"RTN","RCCPCSV1",17,0)
ID ;INVALID STATEMENT DETAIL ERROR
"RTN","RCCPCSV1",18,0)
 F  S RCMSG=$O(^TMP($J,"MSG",RCMSG)) Q:'RCMSG  D
"RTN","RCCPCSV1",19,0)
 .; PRCA*4.5*313 - Clean up variables
"RTN","RCCPCSV1",20,0)
 .N KEY,DEB,ERROR,RCX,RCX1,ERR,LN
"RTN","RCCPCSV1",21,0)
 .I $P(^TMP($J,"MSG",RCMSG),"^")'="ID" S ERR="ERROR IN READING CBSS ERROR RECOR
D" D ERRMSG Q
"RTN","RCCPCSV1",22,0)
 .S KEY=$P(^TMP($J,"MSG",RCMSG),"^",2),KEY=$TR(KEY," ",""),KEY=$E(KEY,$F(KEY,$$
SITE^RCMSITE),999)
"RTN","RCCPCSV1",23,0)
 .I KEY']"" D KEYERR Q
"RTN","RCCPCSV1",24,0)
 .S DEB=$O(^RCPS(349.2,"AKEY",KEY,0)) I 'DEB D KEYERR Q
"RTN","RCCPCSV1",25,0)
 .S ERROR=$P(^TMP($J,"MSG",RCMSG),"^",3),^RCPS(349.2,+DEB,5)=ERROR
"RTN","RCCPCSV1",26,0)
 .F RCX=1:5:21 S RCX1=RCX+4 S ERR(0)=$E(ERROR,RCX,RCX1) Q:ERR(0)=""  D
"RTN","RCCPCSV1",27,0)
 ..S ERR(1)=$O(^RCPSE(349.7,"B",ERR(0),""))
"RTN","RCCPCSV1",28,0)
 ..I 'ERR(1) S ERR="NO ERROR DESCRIPTION FOR ERROR CODE: "_ERR(0)
"RTN","RCCPCSV1",29,0)
 ..I ERR(1) S ERR=$P(^RCPSE(349.7,+ERR(1),0),"^",4)
"RTN","RCCPCSV1",30,0)
 ..S ERR=KEY_" "_ERR(0)_" "_ERR
"RTN","RCCPCSV1",31,0)
 ..D ERRMSG
"RTN","RCCPCSV1",32,0)
 ..S ERR=" " D ERRMSG
"RTN","RCCPCSV1",33,0)
 .S ^RCPS(349.2,+DEB,5)=$P(^TMP($J,"MSG",RCMSG),"^",3)
"RTN","RCCPCSV1",34,0)
 .S ^RCPS(349.2,"AD","E",+DEB)=""
"RTN","RCCPCSV1",35,0)
 Q
"RTN","RCCPCSV1",36,0)
 ;
"RTN","RCCPCSV1",37,0)
 ;
"RTN","RCCPCSV1",38,0)
KEYERR ;SEND MESSAGE TO MAIL GROUP INDICATING NO KEY
"RTN","RCCPCSV1",39,0)
 S ERR="CBSS ERROR MESSAGE - NO AR KEY ID FOR CBSS KEY: "_KEY D ERRMSG
"RTN","RCCPCSV1",40,0)
 S ERR="This patient record is corrupted. Please contact IRM." D ERRMSG
"RTN","RCCPCSV1",41,0)
 S ERR=" " D ERRMSG
"RTN","RCCPCSV1",42,0)
 Q
"RTN","RCCPCSV1",43,0)
 ;
"RTN","RCCPCSV1",44,0)
PA ;STATEMENT ACKNOWLEDGEMENT
"RTN","RCCPCSV1",45,0)
 N STDT,SSTDT,SDAT,SDT,IEN,DEB,X,Y,STOT,SEQ,KEY,END,SBAL,EVN,DA,DIK
"RTN","RCCPCSV1",46,0)
 Q:$P(RCTR,"^")'="PA"
"RTN","RCCPCSV1",47,0)
 ; D CHKTRAN(LABEL) 
"RTN","RCCPCSV1",48,0)
 S (X,SDT)=$P(RCTR,"^",7) D ^%DT S SDAT=Y
"RTN","RCCPCSV1",49,0)
 D CHKTRAN(LABEL)
"RTN","RCCPCSV1",50,0)
 S STOT=+$P(RCTR,"^",6)
"RTN","RCCPCSV1",51,0)
 S SEQ=+$P(RCTR,"^",3)
"RTN","RCCPCSV1",52,0)
 F  S RCMSG=$O(^TMP($J,"MSG",RCMSG)) Q:'RCMSG  D
"RTN","RCCPCSV1",53,0)
 .N P
"RTN","RCCPCSV1",54,0)
 .S RCTR=^TMP($J,"MSG",RCMSG)
"RTN","RCCPCSV1",55,0)
 .Q:$P(RCTR,"^")'="AD"
"RTN","RCCPCSV1",56,0)
 .S KEY=$P(RCTR,"^",2),KEY=$TR(KEY," ",""),KEY=$E(KEY,$F(KEY,$$SITE^RCMSITE),99
9)
"RTN","RCCPCSV1",57,0)
 .I KEY']"" D KEYERR Q
"RTN","RCCPCSV1",58,0)
 .;PRCA*4.5*313 - Find Debtor using IEN from 349.2
"RTN","RCCPCSV1",59,0)
 .S IEN=$O(^RCPS(349.2,"AKEY",KEY,0))
"RTN","RCCPCSV1",60,0)
 .I '$G(IEN) D KEYERR Q
"RTN","RCCPCSV1",61,0)
 .S DEB=$P($G(^RCPS(349.2,IEN,0)),U)
"RTN","RCCPCSV1",62,0)
 .;PRCA*4.5*313 - Change DEB to IEN for all date from 349.2
"RTN","RCCPCSV1",63,0)
 .I IEN S END=$P(^RCPS(349.2,+IEN,0),"^",10)
"RTN","RCCPCSV1",64,0)
 .S:'$G(END) END=$O(^RCPS(349.2,"STDT",SDAT,0)),END=$P($G(^(+END,0)),"^",10)
"RTN","RCCPCSV1",65,0)
 .F P=13:1:17 S SBAL(P)=$P(^RCPS(349.2,+IEN,0),"^",P)
"RTN","RCCPCSV1",66,0)
 .;update patient statement date in 341 to end process time
"RTN","RCCPCSV1",67,0)
 .D OPEN^RCEVDRV1(2,$P(^RCD(340,DEB,0),U),END,DUZ,$$SITE^RCMSITE,.ERR,.EVN,SBAL
(13)_U_SBAL(14)_U_SBAL(15)_U_SBAL(16)_U_SBAL(17))
"RTN","RCCPCSV1",68,0)
 .I EVN S DR=".07////"_END_";.11////"_1,DA=+EVN,DIE="^RC(341," D ^DIE K DIE,DR,
DA
"RTN","RCCPCSV1",69,0)
 .; PRCA*4.5*313 - Add cross-reference for File
"RTN","RCCPCSV1",70,0)
 .I EVN S $P(^RC(341,+EVN,6),"^")=$G(SDAT) D
"RTN","RCCPCSV1",71,0)
 . .S DA=+EVN,DIK="^RC(341," D IX1^DIK
"RTN","RCCPCSV1",72,0)
 .;update bill file 430 letter fields
"RTN","RCCPCSV1",73,0)
 .NEW BN,DA,DIC,DIE,DR,II,LET,NOT,X,Y
"RTN","RCCPCSV1",74,0)
 .S DIE="^PRCA(430,",NOT=0,BN=0
"RTN","RCCPCSV1",75,0)
 .F  S BN=$O(^PRCA(430,"AS",DEB,16,BN)) Q:'BN  S DA=BN D
"RTN","RCCPCSV1",76,0)
 ..S LET=$G(^PRCA(430,BN,6))
"RTN","RCCPCSV1",77,0)
 ..I $P(LET,"^",21)>END Q
"RTN","RCCPCSV1",78,0)
 ..S END=$G(SDAT)
"RTN","RCCPCSV1",79,0)
 ..F II=1:1:4 Q:$P(LET,U,II)=END  I $P(LET,U,II)="" S DR=$S(II=1:61,II=2:62,II=
3:63,1:68)_"////^S X="_END_";68.1////^S X="_END D ^DIE Q
"RTN","RCCPCSV1",80,0)
 .;PRCA*4.5*313 - Change DEB to IEN for all date from 349.2
"RTN","RCCPCSV1",81,0)
 .S ^RCPS(349.2,+IEN,6)=1
"RTN","RCCPCSV1",82,0)
PAMAIL   ;
"RTN","RCCPCSV1",83,0)
 N XMSUB,XMY,XMDUZ,XMTEXT,MSG
"RTN","RCCPCSV1",84,0)
 ; PRCA*4.5*313 - Change to CBSS
"RTN","RCCPCSV1",85,0)
 S XMSUB="Patient Acknowledgements received from CBSS."
"RTN","RCCPCSV1",86,0)
 S XMY("G.RCCPC STATEMENTS")="",XMDUZ="AR PACKAGE",XMTEXT="MSG("
"RTN","RCCPCSV1",87,0)
 ; PRCA*4.5*313 - Add Patient Statement Date and renumber other lines
"RTN","RCCPCSV1",88,0)
 S MSG(1)="For Patient Statement Date of "_SDT_"."
"RTN","RCCPCSV1",89,0)
 S MSG(2)="Patient acknowledgement message "_$G(XMZ)_" received."
"RTN","RCCPCSV1",90,0)
 S MSG(3)="This means that CBSS has printed patient statements for this stateme
nt period."
"RTN","RCCPCSV1",91,0)
 D ^XMD
"RTN","RCCPCSV1",92,0)
 Q
"RTN","RCCPCSV1",93,0)
 ;
"RTN","RCCPCSV1",94,0)
CHKTRAN(LABEL) ;Check for incomplete message from CCPC
"RTN","RCCPCSV1",95,0)
 ; PRCA*4.5*313 - Add multiple entries based upon date to four level
"RTN","RCCPCSV1",96,0)
 Q:$G(LABEL)']""
"RTN","RCCPCSV1",97,0)
 N PSIEN,DA,DIK,DO,DIC,X
"RTN","RCCPCSV1",98,0)
 S LABEL(1)=+$O(^RCT(349.1,"B",LABEL,0))
"RTN","RCCPCSV1",99,0)
 ; PRCA*4.5*313 - Add Patient Statement Date to four level
"RTN","RCCPCSV1",100,0)
 I LABEL(1),$P(^TMP($J,"MSG",RCMSG),"^",2)=$P(^TMP($J,"MSG",RCMSG),"^",3) D
"RTN","RCCPCSV1",101,0)
 . S DIC="^RCT(349.1,LABEL(1),4,"
"RTN","RCCPCSV1",102,0)
 . S X=$P(^TMP($J,"MSG",RCMSG),"^",2)
"RTN","RCCPCSV1",103,0)
 . S DA(1)=LABEL(1),DIC(0)="L"
"RTN","RCCPCSV1",104,0)
 . S DIC("DR")=".02////"_$P(^TMP($J,"MSG",RCMSG),"^",3)_";.03////"_$G(XMZ)_";.0
4////"_SDAT
"RTN","RCCPCSV1",105,0)
 . D FILE^DICN
"RTN","RCCPCSV1",106,0)
 Q
"RTN","RCCPCSV1",107,0)
 ;
"RTN","RCCPCSV1",108,0)
TRANCHK ;Check for complete ACK transmission
"RTN","RCCPCSV1",109,0)
 ; PRCA*4.5*313 - Check for statement dates five to seven days in past since bu
ild and transmit. 
"RTN","RCCPCSV1",110,0)
 N X,Y,DATE,SDT,I,X1,X2
"RTN","RCCPCSV1",111,0)
 F I=-3:-1:-5 S X1=DT,X2=I D C^%DTC S (Y,SDT)=X D DD^%DT S DATE=Y D TRANCHK1
"RTN","RCCPCSV1",112,0)
 Q
"RTN","RCCPCSV1",113,0)
 ;
"RTN","RCCPCSV1",114,0)
TRANCHK1 ; PRCA*4.5*313 - Validate transmission completeness for date provided.
"RTN","RCCPCSV1",115,0)
 N MSG,RCT,SEG,SEQ,CNT,IEN,XMDUZ,XMSUB,XMTEXT,XMY
"RTN","RCCPCSV1",116,0)
 F RCT=3,4 S CNT=$O(^RCT(349.1,RCT,4,"STDT4",SDT,0)) I CNT'=""  D
"RTN","RCCPCSV1",117,0)
 .S IEN=$O(^RCT(349.1,RCT,4,"STDT4",SDT,CNT,0))  D
"RTN","RCCPCSV1",118,0)
 ..I IEN'="",$P($G(^RCT(349.1,+RCT,4,IEN,0)),"^")'=$P($G(^RCT(349.1,+RCT,4,IEN,
0)),"^",2) D TRANSEND
"RTN","RCCPCSV1",119,0)
 Q
"RTN","RCCPCSV1",120,0)
 ;
"RTN","RCCPCSV1",121,0)
TRANSEND  ; PRCA*4.5*313 Send Transmission
"RTN","RCCPCSV1",122,0)
 S XMDUZ="AR PACKAGE"
"RTN","RCCPCSV1",123,0)
 ; PRCA*4.5*313 - Change CCPC to CBSS
"RTN","RCCPCSV1",124,0)
 S XMSUB="CBSS ACKNOWLEDGEMENT TRANSMISSION(S) INCOMPLETE"
"RTN","RCCPCSV1",125,0)
 I $O(^XMB(3.8,"B","RCCPC STATEMENTS",0)) S XMY("G.RCCPC STATEMENTS")="" E  S X
MY(.5)=""
"RTN","RCCPCSV1",126,0)
 S XMTEXT="MSG("
"RTN","RCCPCSV1",127,0)
 S SEG=$S(RCT=3:"IS",1:"PA")
"RTN","RCCPCSV1",128,0)
 S SEG(1)=$P(^RCT(349.1,+RCT,4,IEN,0),"^",2)
"RTN","RCCPCSV1",129,0)
 ; PRCA*4.5*313 - Add line identifying Patient Statement Date that errored
"RTN","RCCPCSV1",130,0)
 S MSG(2)="For Patient Statement Date of "_DATE_"."
"RTN","RCCPCSV1",131,0)
 ; PRCA*4.5*313 - Change CCPC to CBSS
"RTN","RCCPCSV1",132,0)
 S MSG(3)="The last "_SEG_" segment message received from CBSS was numbered "_S
EG(1)_"."
"RTN","RCCPCSV1",133,0)
 S MSG(4)="This was not labeled the final message in that segment type transmis
sion."
"RTN","RCCPCSV1",134,0)
 S MSG(5)="This may cause patient statement information to be missing."
"RTN","RCCPCSV1",135,0)
 S MSG(6)="The last message number received was "_$P($G(^RCT(349.1,RCT,4,IEN,0)
),"^",3)_"."
"RTN","RCCPCSV1",136,0)
  ; PRCA*4.5*313 - Change CCPC to CBSS
"RTN","RCCPCSV1",137,0)
 S MSG(7)="Please contact the CBSS in Austin."
"RTN","RCCPCSV1",138,0)
 D ^XMD
"RTN","RCCPCSV1",139,0)
 Q
"RTN","RCCPCSV1",140,0)
 ;
"RTN","RCCPCSV1",141,0)
 ;
"RTN","RCCPCSV1",142,0)
IT ;INVALID TRANSMISSION
"RTN","RCCPCSV1",143,0)
 ; PRCA*4.5*313 - Change message from CCPC to CBSS
"RTN","RCCPCSV1",144,0)
 N SDT,ERR,MSG,RCX,RCX1,ERROR,RE
"RTN","RCCPCSV1",145,0)
 S ERR="The CBSS patient statement messages were not accepted by CBSS" D ERRMSG
"RTN","RCCPCSV1",146,0)
 ; PRCA*4.5*313 - Add statement date to error message
"RTN","RCCPCSV1",147,0)
 S SDT=$P(^TMP($J,"MSG",RCMSG),"^",6)
"RTN","RCCPCSV1",148,0)
 S ERR="for "_SDT_" due to the following error(s):" D ERRMSG
"RTN","RCCPCSV1",149,0)
 S ERR=" " D ERRMSG
"RTN","RCCPCSV1",150,0)
 S RCMSG=1 F  S RCMSG=$O(^TMP($J,"MSG",RCMSG)) Q:'RCMSG  D
"RTN","RCCPCSV1",151,0)
 .S MSG=^TMP($J,"MSG",RCMSG)
"RTN","RCCPCSV1",152,0)
 .S MSG=$P(MSG,"^",8)
"RTN","RCCPCSV1",153,0)
 .F RCX=1:5:21 S RCX1=RCX+4 S ERROR=$E(MSG,RCX,RCX1) Q:ERROR=""  D
"RTN","RCCPCSV1",154,0)
 ..S ERR(1)=$O(^RCPSE(349.7,"B",ERROR,""))
"RTN","RCCPCSV1",155,0)
 ..I 'ERR(1) S ERR="NO ERROR DESCRIPTION FOR ERROR CODE: "_ERROR
"RTN","RCCPCSV1",156,0)
 ..I ERR(1) S ERR=$P(^RCPSE(349.7,+ERR(1),0),"^",4),ERR=ERROR_" "_ERR
"RTN","RCCPCSV1",157,0)
 ..I ERR(1) S:$P(^RCPSE(349.7,+ERR(1),0),"^",3)="R" RE=1
"RTN","RCCPCSV1",158,0)
 ..D ERRMSG
"RTN","RCCPCSV1",159,0)
 S ERR=" " D ERRMSG
"RTN","RCCPCSV1",160,0)
 S ERR="Please contact IRM."
"RTN","RCCPCSV1",161,0)
 D ERRMSG
"RTN","RCCPCSV1",162,0)
 Q
"RTN","RCCPCSV1",163,0)
 ;
"RTN","RCCPCSV1",164,0)
ERRMSG ;ERROR MESSAGE
"RTN","RCCPCSV1",165,0)
 S LN=LN+1,^TMP($J,"ERR",LN)=ERR
"RTN","RCCPCSV1",166,0)
 Q
"RTN","RCCPCT")
0^15^B29330001^B2489697
"RTN","RCCPCT",1,0)
RCCPCT ;WASH-ISC@ALTOONA,PA/LDB - CCPC Patient Statement message totals ;11/7/9
6  10:53 AM
"RTN","RCCPCT",2,0)
 ;;4.5;Accounts Receivable;**34,313**;Mar 20, 1995;Build 118
"RTN","RCCPCT",3,0)
 ;;Per VA Directive 6402, this routine should not be modified.
"RTN","RCCPCT",4,0)
EN ;
"RTN","RCCPCT",5,0)
 D GO
"RTN","RCCPCT",6,0)
 K TDT,TDT1,TDT2,TDT3,DATE,PTOT,TTOT,L,X,Y,Y1,Y2,D,IEN,POP,Q,%,%DT,%ZIS,%Y,FIRS
T,LAST
"RTN","RCCPCT",7,0)
 Q
"RTN","RCCPCT",8,0)
GO ;
"RTN","RCCPCT",9,0)
 W @IOF W !,"This report will print the total Patient Statements sent to CBSS a
nd the"
"RTN","RCCPCT",10,0)
 W !,"total acknowledged as having been printed with three different report"
"RTN","RCCPCT",11,0)
 W !,"formats available."
"RTN","RCCPCT",12,0)
 W !!,"The first format is just a single summary total report of all Statement"
"RTN","RCCPCT",13,0)
 W !,"Dates."
"RTN","RCCPCT",14,0)
 W !!,"The second format is all Statement Dates printed individually with total
s"
"RTN","RCCPCT",15,0)
 W !,"and a summary total at the end."
"RTN","RCCPCT",16,0)
 W !!,"The third format is printing the totals for a single Statement Date sele
cted.",!
"RTN","RCCPCT",17,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCT",18,0)
 S DIR(0)="E" D ^DIR
"RTN","RCCPCT",19,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCT",20,0)
 S IEN="" F  S IEN=$O(^RCT(349,"SDT",IEN)) Q:IEN=""  S TDT(IEN)=""
"RTN","RCCPCT",21,0)
 W @IOF W !!,"The following Patient Statement Dates are available for the Total
s Report:",!
"RTN","RCCPCT",22,0)
 S (TDT1,FIRST,LAST)="" F  S TDT1=$O(TDT(TDT1)) Q:TDT1=""  D
"RTN","RCCPCT",23,0)
 .S TDT3=$P(^RCT(349,$O(^RCT(349,"SDT",TDT1,0)),0),"^",9) W !,$$DATE^RCCPCPS1(T
DT3)
"RTN","RCCPCT",24,0)
 .I TDT3<FIRST S FIRST=TDT3
"RTN","RCCPCT",25,0)
 .I TDT3>LAST S LAST=TDT3
"RTN","RCCPCT",26,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCT",27,0)
 S DIR(0)="YAO"
"RTN","RCCPCT",28,0)
 S DIR("B")="Y"
"RTN","RCCPCT",29,0)
 S DIR("A")="Do you want to print a single total for ALL the available dates? "
"RTN","RCCPCT",30,0)
 D ^DIR
"RTN","RCCPCT",31,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCT",32,0)
 I Y=1 D  Q
"RTN","RCCPCT",33,0)
 .D HOME^%ZIS S %ZIS="AEQ" D ^%ZIS Q:POP
"RTN","RCCPCT",34,0)
 .I $D(IO("Q")) D  Q
"RTN","RCCPCT",35,0)
 ..S Q=1
"RTN","RCCPCT",36,0)
 ..S ZTRTN="STARTS^RCCPCT",ZTDESC="CBSS ALL PATIENT STATEMENTS TOTAL REPORT"
"RTN","RCCPCT",37,0)
 ..S ZTSAVE("Q")="",ZTSAVE("TDT(")=""
"RTN","RCCPCT",38,0)
 ..D ^%ZTLOAD
"RTN","RCCPCT",39,0)
 ..K ZTRTN,ZTDESC,ZTSAVE
"RTN","RCCPCT",40,0)
 .E  D STARTS Q
"RTN","RCCPCT",41,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCT",42,0)
 S DIR(0)="YAO"
"RTN","RCCPCT",43,0)
 S DIR("B")="Y"
"RTN","RCCPCT",44,0)
 S DIR("A")="Do you want to print separate totals for ALL the available dates? 
"
"RTN","RCCPCT",45,0)
 D ^DIR
"RTN","RCCPCT",46,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCT",47,0)
 I Y=1 D  Q
"RTN","RCCPCT",48,0)
 .D HOME^%ZIS S %ZIS="AEQ" D ^%ZIS Q:POP
"RTN","RCCPCT",49,0)
 .I $D(IO("Q")) D  Q
"RTN","RCCPCT",50,0)
 ..S Q=1
"RTN","RCCPCT",51,0)
 ..S ZTRTN="START^RCCPCT",ZTDESC="CBSS ALL PATIENT STATEMENTS TOTAL REPORT"
"RTN","RCCPCT",52,0)
 ..S ZTSAVE("Q")="",ZTSAVE("TDT(")=""
"RTN","RCCPCT",53,0)
 ..D ^%ZTLOAD
"RTN","RCCPCT",54,0)
 ..K ZTRTN,ZTDESC,ZTSAVE
"RTN","RCCPCT",55,0)
 .E  D START Q
"RTN","RCCPCT",56,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCT",57,0)
 S DIR(0)="DAO^"_FIRST_":"_LAST_":EX^K:'$D(TDT(+$E(Y,6,7))) X"
"RTN","RCCPCT",58,0)
 S DIR("A")="Enter a single Patient Statement date from list above: "
"RTN","RCCPCT",59,0)
 S DIR("?")="Enter a single Patient Statement date from list above or ^ to exit
."
"RTN","RCCPCT",60,0)
 D ^DIR
"RTN","RCCPCT",61,0)
 I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCT",62,0)
 S Y1=+$E(Y,6,7),Y2=Y
"RTN","RCCPCT",63,0)
 ;I '$D(TDT(Y1)) W !,"There are no records for that date." Q
"RTN","RCCPCT",64,0)
 D HOME^%ZIS S %ZIS="AEQ" D ^%ZIS Q:POP
"RTN","RCCPCT",65,0)
 I $D(IO("Q")) D  Q
"RTN","RCCPCT",66,0)
 .S Q=1
"RTN","RCCPCT",67,0)
 .S ZTRTN="START1^RCCPCT",ZTDESC="CBSS ALL PATIENT STATEMENTS TOTAL REPORT"
"RTN","RCCPCT",68,0)
 .S ZTSAVE("Q")="",ZTSAVE("Y1")="",ZTSAVE("Y2")=""
"RTN","RCCPCT",69,0)
 .D ^%ZTLOAD
"RTN","RCCPCT",70,0)
 .K ZTRTN,ZTDESC,ZTSAVE
"RTN","RCCPCT",71,0)
START1 ;This will print a summary total for a single date
"RTN","RCCPCT",72,0)
 N PTOT,TTOT,X,D
"RTN","RCCPCT",73,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCT",74,0)
 U IO S (TTOT,X)=0 F  S X=$O(^RCT(349,"SDT",Y1,X)) Q:'X  I $D(^RCT(349,X,0)) S 
TTOT=$P(^RCT(349,X,0),"^",7)+TTOT
"RTN","RCCPCT",75,0)
 S (PTOT,X)=0 F  S X=$O(^RCPS(349.2,"STDT",Y2,X)) Q:'X  I $G(^RCPS(349.2,X,6)) 
S PTOT=PTOT+1
"RTN","RCCPCT",76,0)
 I IOST?1"C".E W @IOF
"RTN","RCCPCT",77,0)
 W !,?10,"CBSS Message Totals for ",$$DATE^RCCPCPS1(Y2),!!
"RTN","RCCPCT",78,0)
 W "Transmission Statement Total  : ",$J(TTOT,9)
"RTN","RCCPCT",79,0)
 W !,"CBSS Statements Printed Total : ",$J(PTOT,9)
"RTN","RCCPCT",80,0)
 W !,"==============================="
"RTN","RCCPCT",81,0)
 W !,"Total Not Printed             : ",$J(TTOT-PTOT,9),!
"RTN","RCCPCT",82,0)
 I '$D(Q) S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCT",83,0)
 Q
"RTN","RCCPCT",84,0)
START ;This will print separate totals for all available statement dates
"RTN","RCCPCT",85,0)
 N PTOT,TTOT,X,X1,DATE
"RTN","RCCPCT",86,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCT",87,0)
 S (TTOT,PTOT,X,X1)=0 S DATE=""
"RTN","RCCPCT",88,0)
 U IO S (TDT1,TDT2)=""
"RTN","RCCPCT",89,0)
 I IOST?1"C".E W @IOF
"RTN","RCCPCT",90,0)
 F  S TDT1=$O(TDT(TDT1)) Q:TDT1=""  D  I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROU
T) Q
"RTN","RCCPCT",91,0)
 .I X="^" Q
"RTN","RCCPCT",92,0)
 .S TTOT=0
"RTN","RCCPCT",93,0)
 .F  S TDT2=$O(^RCT(349,"SDT",TDT1,TDT2)) Q:TDT2=""  D
"RTN","RCCPCT",94,0)
 ..S Y=$P(^RCT(349,TDT2,0),"^",9)
"RTN","RCCPCT",95,0)
 ..S Y1=+$E(Y,3,4),DATE=$$DATE^RCCPCPS1(Y)
"RTN","RCCPCT",96,0)
 ..S X=Y D ^%DT
"RTN","RCCPCT",97,0)
 ..I $D(^RCT(349,TDT2,0)) S TTOT=$P(^RCT(349,TDT2,0),"^",7)+TTOT
"RTN","RCCPCT",98,0)
 ..S PTOT=0,X1="" I $D(^RCPS(349.2,"STDT",Y)) F  S X1=$O(^RCPS(349.2,"STDT",Y,X
1)) Q:'X1  I $G(^RCPS(349.2,X1,6)) S PTOT=PTOT+1
"RTN","RCCPCT",99,0)
 .W !,?10,"CBSS Message Totals for ",DATE,!!
"RTN","RCCPCT",100,0)
 .W "Transmission Statement Total  : ",$J(TTOT,9)
"RTN","RCCPCT",101,0)
 .W !,"CBSS Statements Printed Total : ",$J(PTOT,9)
"RTN","RCCPCT",102,0)
 .W !,"==============================="
"RTN","RCCPCT",103,0)
 .W !,"Total Not Printed             : ",$J(TTOT-PTOT,9),!
"RTN","RCCPCT",104,0)
 .I '$D(Q) I $Y+4>IOSL D
"RTN","RCCPCT",105,0)
 ..S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"RTN","RCCPCT",106,0)
 ..W @IOF
"RTN","RCCPCT",107,0)
 I X="^" Q
"RTN","RCCPCT",108,0)
 W !!!,"*****************************************************"
"RTN","RCCPCT",109,0)
STARTS ; This will print the summary total for ALL available statements
"RTN","RCCPCT",110,0)
 N DATE,PTOT,TTOT,X,D
"RTN","RCCPCT",111,0)
 N DIR,DTOUT,DUOUT,DIRUT,DIROUT
"RTN","RCCPCT",112,0)
 U IO S (TTOT,D)=0 F  S D=$O(TDT(D)) Q:D=""  S X=0 F  S X=$O(^RCT(349,"SDT",D,X
)) Q:X=""  I $D(^RCT(349,X,0)) S TTOT=$P(^RCT(349,X,0),"^",7)+TTOT
"RTN","RCCPCT",113,0)
 S (PTOT,X)=0 F  S X=$O(^RCPS(349.2,X)) Q:'X  I $G(^(X,6)) S PTOT=PTOT+1
"RTN","RCCPCT",114,0)
 W !!,?10,"CBSS Message Totals for ALL available dates ",!!
"RTN","RCCPCT",115,0)
 W "Transmission Statement Total  : ",$J(TTOT,9)
"RTN","RCCPCT",116,0)
 W !,"CBSS Statements Printed Total : ",$J(PTOT,9)
"RTN","RCCPCT",117,0)
 W !,"==============================="
"RTN","RCCPCT",118,0)
 W !,"Total Not Printed             : ",$J(TTOT-PTOT,9),!
"RTN","RCCPCT",119,0)
 I '$D(Q) S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q
"VER")
8.0^22.2
"^DD",340,340,.01,0)
DEBTOR^RV^^0;1^
"^DD",340,340,.01,1,0)
^.1
"^DD",340,340,.01,1,1,0)
340^B
"^DD",340,340,.01,1,1,1)
S ^RCD(340,"B",$E(X,1,30),DA)=""
"^DD",340,340,.01,1,1,2)
K ^RCD(340,"B",$E(X,1,30),DA)
"^DD",340,340,.01,1,1,3)
Needed for look-up of information by Debtor
"^DD",340,340,.01,1,1,"%D",0)
^^2^2^2931014^^^^
"^DD",340,340,.01,1,1,"%D",1,0)
This is the regular FileMan 'B' cross-reference and is used throughout the
"^DD",340,340,.01,1,1,"%D",2,0)
AR package for users to look up information by debtor.
"^DD",340,340,.01,1,2,0)
^^TRIGGER^340^.03
"^DD",340,340,.01,1,2,1)
X ^DD(340,.01,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^RCD(340,D0,0)):^(0),1:"") S X=
$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(340,.01,1,2,1.1) X ^DD(340,.01,1,2,1.4)
"^DD",340,340,.01,1,2,1.1)
S X=DIV S X=+$$ACSET^RCCPCFN1($P(^DPT($P($P(^RCD(340,D0,0),U),";"),0),U)) S:X X
=+X
"^DD",340,340,.01,1,2,1.3)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^RCD(340,D0,0)):^(0),1:"") 
S X=$P(Y(1),U,3)="",Y(2)=X,Y(3)=X S X=Y(0),X=X S X=X[";DPT(",Y=X,X=Y(2),X=X&Y
"^DD",340,340,.01,1,2,1.4)
S DIH=$S($D(^RCD(340,DIV(0),0)):^(0),1:""),DIV=X S $P(^(0),U,3)=DIV,DIH=340,DIG
=.03 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",340,340,.01,1,2,2)
Q
"^DD",340,340,.01,1,2,3)
Needed for assigning statement days for patients
"^DD",340,340,.01,1,2,"%D",0)
^.101^2^2^3160502^^^
"^DD",340,340,.01,1,2,"%D",1,0)
This cross-reference sets the statement day for new patients as determined
"^DD",340,340,.01,1,2,"%D",2,0)
by the first two letters of the patient's last name. 
"^DD",340,340,.01,1,2,"CREATE CONDITION")
STATEMENT DAY=""&(INTERNAL(DEBTOR)[";DPT(")
"^DD",340,340,.01,1,2,"CREATE VALUE")
S X=$$ACSET^RCCPCFN1($P(^DPT($P($P(^RCD(340,D0,0) ,U),";"),0),U) S:X X=+X
"^DD",340,340,.01,1,2,"DELETE VALUE")
NO EFFECT
"^DD",340,340,.01,1,2,"DT")
2961010
"^DD",340,340,.01,1,2,"FIELD")
STATEMENT DAY
"^DD",340,340,.01,1,3,0)
340^AB^MUMPS
"^DD",340,340,.01,1,3,1)
S ^RCD(340,"AB",$P(X,";",2),DA)=""
"^DD",340,340,.01,1,3,2)
K ^RCD(340,"AB",$P(X,";",2),DA)
"^DD",340,340,.01,1,3,3)
Needed to cross-reference debtor file by 'type' of debtor
"^DD",340,340,.01,1,3,"%D",0)
^^5^5^2931014^^^^
"^DD",340,340,.01,1,3,"%D",1,0)
This cross-reference allows rapid look-up of debtors in the debtor file
"^DD",340,340,.01,1,3,"%D",2,0)
by the 'type' of debtor.  There are five types of debtors (Patient,
"^DD",340,340,.01,1,3,"%D",3,0)
Insurance Company, Institution, Vendor, and Person).  This allows
"^DD",340,340,.01,1,3,"%D",4,0)
the AR software to scan the file for only a specific type of debtor
"^DD",340,340,.01,1,3,"%D",5,0)
rather than having to look at each entry.
"^DD",340,340,.01,1,3,"DT")
2930526
"^DD",340,340,.01,1.1)
S X=DIV S X=+$$ACSET^RCCPCFN1($P(^DPT($P($P(^RCD(340,D0,0),U),"";""),0),U) S:X 
X=+X
"^DD",340,340,.01,3)
Enter Debtor Information
"^DD",340,340,.01,7.5)
S:$D(PRCABT) DIC("V")="I +Y(0)="_$P("440!(+Y(0)=4)^440!(+Y(0)=4)^440!(+Y(0)=200
)",U,PRCABT) S:$D(PRCAT) DIC("V")="I +Y(0)="_$S("CP"[PRCAT:2,"FV"[PRCAT:440,"T"
[PRCAT:36,"N"[PRCAT:4,"O"[PRCAT:200,1:"200!(+Y(0)=440)")
"^DD",340,340,.01,21,0)
^^5^5^2970219^^^^
"^DD",340,340,.01,21,1,0)
This field contains the debtor to which this account belongs to.  An
"^DD",340,340,.01,21,2,0)
account can belong to an insurance company, vendor, institution, person,
"^DD",340,340,.01,21,3,0)
or patient.  Accounts can be set up for Medical Care Cost Recovery charges
"^DD",340,340,.01,21,4,0)
and also for non-benefit debts, such as: Employee bills, Ex-employee bills,
"^DD",340,340,.01,21,5,0)
and Vendor bills.
"^DD",340,340,.01,"DT")
3160428
"^DD",340,340,.01,"V",0)
^.12P^5^5
"^DD",340,340,.01,"V",1,0)
2^PATIENT^1^P^n^n
"^DD",340,340,.01,"V",1,1)

"^DD",340,340,.01,"V",1,2)

"^DD",340,340,.01,"V",2,0)
200^OTHER (PERSON)^2^O^n^y
"^DD",340,340,.01,"V",3,0)
36^3RD PARTY^4^I^n^n
"^DD",340,340,.01,"V",4,0)
4^INSTITUTION^5^N^n^n
"^DD",340,340,.01,"V",5,0)
440^VENDOR^3^V^n^n
"^DD",340,340,.03,0)
STATEMENT DAY^NJ2,0^^0;3^K:+X'=X!(X>28)!(X<1)!(X?.E1"."1N.N) X
"^DD",340,340,.03,1,0)
^.1
"^DD",340,340,.03,1,1,0)
340^AC
"^DD",340,340,.03,1,1,1)
S ^RCD(340,"AC",$E(X,1,30),DA)=""
"^DD",340,340,.03,1,1,2)
K ^RCD(340,"AC",$E(X,1,30),DA)
"^DD",340,340,.03,1,1,3)
Needed for printing of patient statements and follow-up letters
"^DD",340,340,.03,1,1,"%D",0)
^^4^4^2931014^^^^
"^DD",340,340,.03,1,1,"%D",1,0)
This cross-reference is used to print patient statements and Vendor, Person,
"^DD",340,340,.03,1,1,"%D",2,0)
and Institution follow-up letters.  Since these type of debtors get notified
"^DD",340,340,.03,1,1,"%D",3,0)
based on their statement day, this cross-reference allows rapid look-up
"^DD",340,340,.03,1,1,"%D",4,0)
of which debtor is due a notification on a particular day.
"^DD",340,340,.03,1,1,"DT")
2930309
"^DD",340,340,.03,3)
Type a Number between 1 and 28, 0 Decimal Digits
"^DD",340,340,.03,5,1,0)
340^.01^2
"^DD",340,340,.03,21,0)
^^19^19^3160428^
"^DD",340,340,.03,21,1,0)
A statement day is assigned to all types of debtors, except insurance
"^DD",340,340,.03,21,2,0)
companies.  A statement day is the day that a statement is generated or a
"^DD",340,340,.03,21,3,0)
follow-up letter is generated for non-benefit debts.  Except for 
"^DD",340,340,.03,21,4,0)
Patient Statements which are generated two days prior to this day.
"^DD",340,340,.03,21,5,0)
The AR package will hold 'notifications' from being sent until the
"^DD",340,340,.03,21,6,0)
debtor's 'statement day' arrives.  This allows all activity since the
"^DD",340,340,.03,21,7,0)
previous statement to print and update the debtor on the account
"^DD",340,340,.03,21,8,0)
activity.
"^DD",340,340,.03,21,9,0)
 
"^DD",340,340,.03,21,10,0)
Patient statement days never change, but Institution, Person, and Vendor
"^DD",340,340,.03,21,11,0)
statement days are changed by the AR software.  When these type debtors
"^DD",340,340,.03,21,12,0)
have a new active bill, the date the new active bill is created becomes
"^DD",340,340,.03,21,13,0)
their 'statement day'.  This statement day remains in effect until no
"^DD",340,340,.03,21,14,0)
active bills exist for the debtor, at which time the statement day
"^DD",340,340,.03,21,15,0)
is 'deleted'.
"^DD",340,340,.03,21,16,0)
 
"^DD",340,340,.03,21,17,0)
Insurance companies are notified based on a bill-specific date.
"^DD",340,340,.03,21,18,0)
Since insurance companies have much more activity, they are notified
"^DD",340,340,.03,21,19,0)
on a constant basis depending on each individual bill 'due-date'.
"^DD",340,340,.03,"DT")
3160428
"^DD",340,340,7.06,0)
CURRENT CBS DEBT AMOUNT^NJ9,2^^7;6^S:X["$" X=$P(X,"$",2) K:X'?."-".N.1".".2N!(X
>999999)!(X<-999999) X
"^DD",340,340,7.06,3)
Type a dollar amount between -999999 and 999999, 2 decimal digits.
"^DD",340,340,7.06,21,0)
^^7^7^3160401^
"^DD",340,340,7.06,21,1,0)
This field stores the debt amount currently
"^DD",340,340,7.06,21,2,0)
updated to the Consolidated Billing Statement System
"^DD",340,340,7.06,21,3,0)
CBSS.  This field is used to compare the current
"^DD",340,340,7.06,21,4,0)
amount at the CBSS with the amount currently
"^DD",340,340,7.06,21,5,0)
available for receiving payment.  For increases
"^DD",340,340,7.06,21,6,0)
or decreases, the debt amount is forwarded to
"^DD",340,340,7.06,21,7,0)
CBSS.
"^DD",340,340,7.06,"DT")
3160401
"^DD",341,341,6.01,0)
CCPC STATEMENT DATE^D^^6;1^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",341,341,6.01,1,0)
^.1
"^DD",341,341,6.01,1,1,0)
341^STDT
"^DD",341,341,6.01,1,1,1)
S ^RC(341,"STDT",$E(X,1,30),DA)=""
"^DD",341,341,6.01,1,1,2)
K ^RC(341,"STDT",$E(X,1,30),DA)
"^DD",341,341,6.01,1,1,"%D",0)
^.101^2^2^3160809^^
"^DD",341,341,6.01,1,1,"%D",1,0)
This cross reference is used to sort and print events by their Patient 
"^DD",341,341,6.01,1,1,"%D",2,0)
Statement date.
"^DD",341,341,6.01,1,1,"DT")
3160803
"^DD",341,341,6.01,3)
Enter date of Patient Statement.
"^DD",341,341,6.01,21,0)
^^1^1^3160921^
"^DD",341,341,6.01,21,1,0)
This is the date of the Patient Statement from CBSS.
"^DD",341,341,6.01,"DT")
3160921
"^DD",349,349,.09,0)
STATEMENT DATE^D^^0;9^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",349,349,.09,3)
Enter the statement date.
"^DD",349,349,.09,21,0)
^^1^1^3161019^
"^DD",349,349,.09,21,1,0)
This is the patient statement date.
"^DD",349,349,.09,"DT")
3161103
"^DD",349.1,349.1,0)
FIELD^^40^14
"^DD",349.1,349.1,0,"DDA")
N
"^DD",349.1,349.1,0,"DT")
3161103
"^DD",349.1,349.1,0,"IX","B",349.1,.01)

"^DD",349.1,349.1,0,"NM","AR TRANSMISSION TYPE")

"^DD",349.1,349.1,0,"PT",349.9,.01)

"^DD",349.1,349.1,0,"VRPK")
PRCA
"^DD",349.1,349.1,.01,0)
CODE^RF^^0;1^K:$L(X)>10!($L(X)<2)!'(X'?1P.E) X
"^DD",349.1,349.1,.01,1,0)
^.1
"^DD",349.1,349.1,.01,1,1,0)
349.1^B
"^DD",349.1,349.1,.01,1,1,1)
S ^RCT(349.1,"B",$E(X,1,30),DA)=""
"^DD",349.1,349.1,.01,1,1,2)
K ^RCT(349.1,"B",$E(X,1,30),DA)
"^DD",349.1,349.1,.01,3)
Answer must be 2-10 characters in length.
"^DD",349.1,349.1,.01,21,0)
^.001^1^1^3040601^^^
"^DD",349.1,349.1,.01,21,1,0)
This field will hold the unique codes for the transmission types.
"^DD",349.1,349.1,.01,23,0)
^^1^1^3040601^
"^DD",349.1,349.1,.01,23,1,0)
 
"^DD",349.1,349.1,.01,"DT")
2960216
"^DD",349.1,349.1,.02,0)
EXPANDED NAME^F^^0;2^K:$L(X)>30!($L(X)<3) X
"^DD",349.1,349.1,.02,3)
Answer must be 3-30 characters in length.
"^DD",349.1,349.1,.02,21,0)
^^1^1^2960216^^
"^DD",349.1,349.1,.02,21,1,0)
This is the expanded name of the transmission type.
"^DD",349.1,349.1,.02,"DT")
2960216
"^DD",349.1,349.1,.03,0)
ACTIVE^S^0:NO;1:YES;^0;3^Q
"^DD",349.1,349.1,.03,21,0)
^^1^1^2960216^
"^DD",349.1,349.1,.03,21,1,0)
This field will indicate if the transmission type is being used.
"^DD",349.1,349.1,.03,"DT")
2960216
"^DD",349.1,349.1,.04,0)
PURGE FREQUENCY^NJ4,0^^0;4^K:+X'=X!(X>3650)!(X<30)!(X?.E1"."1N.N) X
"^DD",349.1,349.1,.04,3)
Type a Number between 30 and 3650, 0 Decimal Digits
"^DD",349.1,349.1,.04,21,0)
^^2^2^2960216^^
"^DD",349.1,349.1,.04,21,1,0)
This field indicates if and when a purge of the entries will take
"^DD",349.1,349.1,.04,21,2,0)
place.
"^DD",349.1,349.1,.04,23,0)
^^2^2^2960216^
"^DD",349.1,349.1,.04,23,1,0)
Number of days that transmission records are on-line before
"^DD",349.1,349.1,.04,23,2,0)
purging occurs.
"^DD",349.1,349.1,.04,"DT")
2960216
"^DD",349.1,349.1,1,0)
LOCAL ADDRESSEE^349.11P^^1;0
"^DD",349.1,349.1,2,0)
LOCAL MAILGROUP^349.12P^^2;0
"^DD",349.1,349.1,31,0)
REMOTE ADDRESSEE^F^^3;1^K:$L(X)>30!($L(X)<1)!'(X?.A) X
"^DD",349.1,349.1,31,3)
Answer must be 1-30 characters in length.
"^DD",349.1,349.1,31,21,0)
^^1^1^2960430^^^
"^DD",349.1,349.1,31,21,1,0)
This is the addressee name at the remote domain.
"^DD",349.1,349.1,31,"DT")
2960430
"^DD",349.1,349.1,32,0)
REMOTE DOMAIN^P4.2'^DIC(4.2,^3;2^Q
"^DD",349.1,349.1,32,1,0)
^.1
"^DD",349.1,349.1,32,1,1,0)
^^TRIGGER^349.1^33
"^DD",349.1,349.1,32,1,1,1)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^RCT(349.1,D0,3)):^(3),1:"") S X=$P(
Y(1),U,3),X=X S DIU=X K Y X ^DD(349.1,32,1,1,1.1) X ^DD(349.1,32,1,1,1.4)
"^DD",349.1,349.1,32,1,1,1.1)
S X=DIV S I(0,0)=$S($D(D0):D0,1:""),D0=DIV S:'$D(^DIC(4.2,+D0,0)) D0=-1 S Y(101
)=$S($D(^DIC(4.2,D0,0)):^(0),1:"") S X=$P(Y(101),U,1) S D0=I(0,0)
"^DD",349.1,349.1,32,1,1,1.4)
S DIH=$S($D(^RCT(349.1,DIV(0),3)):^(3),1:""),DIV=X S $P(^(3),U,3)=DIV,DIH=349.1
,DIG=33 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",349.1,349.1,32,1,1,2)
K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^RCT(349.1,D0,3)):^(3),1:"") S X=$P(
Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(349.1,32,1,1,2.4)
"^DD",349.1,349.1,32,1,1,2.4)
S DIH=$S($D(^RCT(349.1,DIV(0),3)):^(3),1:""),DIV=X S $P(^(3),U,3)=DIV,DIH=349.1
,DIG=33 D ^DICR:$O(^DD(DIH,DIG,1,0))>0
"^DD",349.1,349.1,32,1,1,"CREATE VALUE")
REMOTE DOMAIN:.01
"^DD",349.1,349.1,32,1,1,"DELETE VALUE")
@
"^DD",349.1,349.1,32,1,1,"FIELD")
DOMAIN NAME
"^DD",349.1,349.1,32,21,0)
^.001^2^2^3000524^^^
"^DD",349.1,349.1,32,21,1,0)
This is the remote domain where the transmission record is being
"^DD",349.1,349.1,32,21,2,0)
sent.
"^DD",349.1,349.1,32,"DT")
2960902
"^DD",349.1,349.1,33,0)
DOMAIN NAME^F^^3;3^K:$L(X)>30!($L(X)<3) X
"^DD",349.1,349.1,33,3)
Answer must be 3-30 characters in length.
"^DD",349.1,349.1,33,5,1,0)
349.1^32^1
"^DD",349.1,349.1,33,9)
^
"^DD",349.1,349.1,33,21,0)
^^1^1^2960902^
"^DD",349.1,349.1,33,21,1,0)
This is the name of the DOMAIN from file 4.2 DOMAIN.
"^DD",349.1,349.1,33,"DT")
2960902
"^DD",349.1,349.1,34,0)
RC MAIL ADDRESS^RFX^^3;4^K:$L(X)>30!($L(X)<3) X
"^DD",349.1,349.1,34,3)
Answer must be 3-30 characters in length.
"^DD",349.1,349.1,34,4)
D MAILADD^RCRCXMS
"^DD",349.1,349.1,34,21,0)
^.001^2^2^3040429^^^^
"^DD",349.1,349.1,34,21,1,0)
This field will contain the Regional Counsel mail address for the
"^DD",349.1,349.1,34,21,2,0)
primary site.  It will be the default mail address.
"^DD",349.1,349.1,34,23,0)
^.001^1^1^3040429^^^^
"^DD",349.1,349.1,34,23,1,0)
 
"^DD",349.1,349.1,34,"DT")
3040407
"^DD",349.1,349.1,35,0)
RC DEATH NOTIFICATION ADDRESS^RF^^3;5^K:$L(X)>40!($L(X)<2) X
"^DD",349.1,349.1,35,3)
Answer must be 2-40 characters in length.
"^DD",349.1,349.1,35,4)
D DEATHADD^RCRCXMS
"^DD",349.1,349.1,35,21,0)
^.001^3^3^3040429^^^^
"^DD",349.1,349.1,35,21,1,0)
This field contains the Regional Counsel mail address for death
"^DD",349.1,349.1,35,21,2,0)
notifications for the primary site.  This will be the default for death
"^DD",349.1,349.1,35,21,3,0)
notifications.
"^DD",349.1,349.1,35,23,0)
^.001^1^1^3040429^^^^
"^DD",349.1,349.1,35,23,1,0)
 
"^DD",349.1,349.1,35,"DT")
3040428
"^DD",349.1,349.1,40,0)
MESSAGE ACKNOWLEDGEMENT^349.141A^^4;0
"^DD",349.1,349.1,40,21,0)
^^5^5^3160429^
"^DD",349.1,349.1,40,21,1,0)
Message Acknowledgements contain the top level of data for messages 
"^DD",349.1,349.1,40,21,2,0)
received from Austin.
"^DD",349.1,349.1,40,21,3,0)
 
"^DD",349.1,349.1,40,21,4,0)
The IEN for the multiple Message Acknowledgements is set in the code to
"^DD",349.1,349.1,40,21,5,0)
the day of the month for the Patient Statement.
"^DD",349.1,349.1,51,0)
ACK MESSAGES^349.151A^^5;0
"^DD",349.1,349.1,51,21,0)
^^1^1^3161006^
"^DD",349.1,349.1,51,21,1,0)
Acknowledgement Messages received from external sources.
"^DD",349.1,349.1,61,0)
DIVISION OF CARE^349.161PA^^6;0
"^DD",349.1,349.1,61,21,0)
^.001^4^4^3040517^^^^
"^DD",349.1,349.1,61,21,1,0)
This field is a multiple that allows divisions to be entered if their
"^DD",349.1,349.1,61,21,2,0)
Regional Counsel mail addresses and death notification addresses are 
"^DD",349.1,349.1,61,21,3,0)
different from the primary addresses.
"^DD",349.1,349.1,61,21,4,0)
 
"^DD",349.1,349.1,61,23,0)
^.001^1^1^3040517^^^^
"^DD",349.1,349.1,61,23,1,0)
 
"^DD",349.1,349.1,61,"DT")
3040514
"^DD",349.1,349.11,0)
LOCAL ADDRESSEE SUB-FIELD^^.01^1
"^DD",349.1,349.11,0,"DT")
2960216
"^DD",349.1,349.11,0,"IX","B",349.11,.01)

"^DD",349.1,349.11,0,"NM","LOCAL ADDRESSEE")

"^DD",349.1,349.11,0,"UP")
349.1
"^DD",349.1,349.11,.01,0)
LOCAL ADDRESSEE^MP200'^VA(200,^0;1^Q
"^DD",349.1,349.11,.01,1,0)
^.1
"^DD",349.1,349.11,.01,1,1,0)
349.11^B
"^DD",349.1,349.11,.01,1,1,1)
S ^RCT(349.1,DA(1),1,"B",$E(X,1,30),DA)=""
"^DD",349.1,349.11,.01,1,1,2)
K ^RCT(349.1,DA(1),1,"B",$E(X,1,30),DA)
"^DD",349.1,349.11,.01,21,0)
^^2^2^2960216^
"^DD",349.1,349.11,.01,21,1,0)
The local users who wish to be recepients of the transmission messages
"^DD",349.1,349.11,.01,21,2,0)
will named in this field.
"^DD",349.1,349.11,.01,"DT")
2960216
"^DD",349.1,349.12,0)
LOCAL MAILGROUP SUB-FIELD^^.01^1
"^DD",349.1,349.12,0,"DT")
2960216
"^DD",349.1,349.12,0,"IX","B",349.12,.01)

"^DD",349.1,349.12,0,"NM","LOCAL MAILGROUP")

"^DD",349.1,349.12,0,"UP")
349.1
"^DD",349.1,349.12,.01,0)
LOCAL MAILGROUP^MP3.8'^XMB(3.8,^0;1^Q
"^DD",349.1,349.12,.01,1,0)
^.1
"^DD",349.1,349.12,.01,1,1,0)
349.12^B
"^DD",349.1,349.12,.01,1,1,1)
S ^RCT(349.1,DA(1),2,"B",$E(X,1,30),DA)=""
"^DD",349.1,349.12,.01,1,1,2)
K ^RCT(349.1,DA(1),2,"B",$E(X,1,30),DA)
"^DD",349.1,349.12,.01,21,0)
^^2^2^2960216^
"^DD",349.1,349.12,.01,21,1,0)
This field is used to define any mailgroups which should receive the
"^DD",349.1,349.12,.01,21,2,0)
transmission messages.
"^DD",349.1,349.12,.01,"DT")
2960216
"^DD",349.1,349.141,0)
MESSAGE ACKNOWLEDGEMENT SUB-FIELD^^.04^4
"^DD",349.1,349.141,0,"DT")
3160425
"^DD",349.1,349.141,0,"NM","MESSAGE ACKNOWLEDGEMENT")

"^DD",349.1,349.141,0,"UP")
349.1
"^DD",349.1,349.141,.01,0)
LAST MESSAGE ACK^NJ3,0X^^0;1^K:+X'=X!(X>999)!(X<1)!(X?.E1"."1.N) X
"^DD",349.1,349.141,.01,1,0)
^.1^^0
"^DD",349.1,349.141,.01,3)
Type a number between 1 and 999, 0 decimal digits.
"^DD",349.1,349.141,.01,21,0)
^^1^1^3160425^
"^DD",349.1,349.141,.01,21,1,0)
Number of last message type sent from CBSS.
"^DD",349.1,349.141,.01,"DT")
3161007
"^DD",349.1,349.141,.02,0)
FINAL MESSAGE ACK^NJ3,0^^0;2^K:+X'=X!(X>999)!(X<1)!(X?.E1"."1.N) X
"^DD",349.1,349.141,.02,3)
Type a number between 1 and 999, 0 decimal digits.
"^DD",349.1,349.141,.02,21,0)
^^1^1^3160425^
"^DD",349.1,349.141,.02,21,1,0)
Final message number of this type from CBSS.
"^DD",349.1,349.141,.02,"DT")
3160425
"^DD",349.1,349.141,.03,0)
LAST MESSAGE NUMBER^NJ8,0^^0;3^K:+X'=X!(X>99999999)!(X<1)!(X?.E1"."1.N) X
"^DD",349.1,349.141,.03,3)
Type a number between 1 and 99999999, 0 decimal digits.
"^DD",349.1,349.141,.03,21,0)
^^2^2^3160425^
"^DD",349.1,349.141,.03,21,1,0)
This is the last message number of this type for the last transmission 
"^DD",349.1,349.141,.03,21,2,0)
from CBSS.
"^DD",349.1,349.141,.03,"DT")
3160425
"^DD",349.1,349.141,.04,0)
PATIENT STATEMENT DATE^DX^^0;4^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",349.1,349.141,.04,1,0)
^.1^^0
"^DD",349.1,349.141,.04,3)
Enter date of Patient Statement.
"^DD",349.1,349.141,.04,21,0)
^^1^1^3161025^
"^DD",349.1,349.141,.04,21,1,0)
This is the Patient Statement Date.
"^DD",349.1,349.141,.04,"DT")
3161025
"^DD",349.1,349.151,0)
ACK MESSAGES SUB-FIELD^^.04^4
"^DD",349.1,349.151,0,"DT")
3161103
"^DD",349.1,349.151,0,"NM","ACK MESSAGES")

"^DD",349.1,349.151,0,"UP")
349.1
"^DD",349.1,349.151,.01,0)
ACK MESSAGES^F^^0;1^K:$L(X)>80!($L(X)<3) X
"^DD",349.1,349.151,.01,1,0)
^.1^^0
"^DD",349.1,349.151,.01,3)
Answer must be 3-80 characters in length.
"^DD",349.1,349.151,.01,21,0)
^^1^1^2970106^^
"^DD",349.1,349.151,.01,21,1,0)
This multiple will store the Acknowlegment messages from Austin.
"^DD",349.1,349.151,.01,"DT")
3161005
"^DD",349.1,349.151,.02,0)
ACCOUNT/SEG ID^F^^0;2^K:$L(X)>25!($L(X)<3) X
"^DD",349.1,349.151,.02,3)
Answer must be 3-25 characters in length.
"^DD",349.1,349.151,.02,21,0)
^^1^1^2961114^
"^DD",349.1,349.151,.02,21,1,0)
This field stores the account id for the record.
"^DD",349.1,349.151,.02,"DT")
2961205
"^DD",349.1,349.151,.03,0)
ACCOUNT/SEG INFO^F^^0;3^K:$L(X)>40!($L(X)<3) X
"^DD",349.1,349.151,.03,3)
Answer must be 3-40 characters in length.
"^DD",349.1,349.151,.03,21,0)
^^1^1^2961114^
"^DD",349.1,349.151,.03,21,1,0)
This field will store the detailed information about the record if any.
"^DD",349.1,349.151,.03,"DT")
2961205
"^DD",349.1,349.151,.04,0)
PATIENT STATEMENT DATE^D^^0;4^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",349.1,349.151,.04,3)
Enter date of Patient Statement.
"^DD",349.1,349.151,.04,21,0)
^^1^1^3161006^
"^DD",349.1,349.151,.04,21,1,0)
The Patient Statement date for Acknowledgement Messages.
"^DD",349.1,349.151,.04,"DT")
3161103
"^DD",349.1,349.161,0)
DIVISION OF CARE SUB-FIELD^^.04^4
"^DD",349.1,349.161,0,"DT")
3040429
"^DD",349.1,349.161,0,"IX","B",349.161,.01)

"^DD",349.1,349.161,0,"NM","DIVISION OF CARE")

"^DD",349.1,349.161,0,"UP")
349.1
"^DD",349.1,349.161,.01,0)
DIVISION OF CARE^P40.8'^DG(40.8,^0;1^Q
"^DD",349.1,349.161,.01,1,0)
^.1
"^DD",349.1,349.161,.01,1,1,0)
349.161^B
"^DD",349.1,349.161,.01,1,1,1)
S ^RCT(349.1,DA(1),6,"B",$E(X,1,30),DA)=""
"^DD",349.1,349.161,.01,1,1,2)
K ^RCT(349.1,DA(1),6,"B",$E(X,1,30),DA)
"^DD",349.1,349.161,.01,21,0)
^.001^1^1^3040517^^^^
"^DD",349.1,349.161,.01,21,1,0)
Enter divisions of care where bill charges originate for this site.
"^DD",349.1,349.161,.01,"DT")
3000524
"^DD",349.1,349.161,.02,0)
REMOTE DOMAIN^P4.2'^DIC(4.2,^0;2^Q
"^DD",349.1,349.161,.02,3)

"^DD",349.1,349.161,.02,21,0)
^.001^1^1^3000524^^
"^DD",349.1,349.161,.02,21,1,0)
This is the Remote Domain address where transmissions will be sent for this div
ision.
"^DD",349.1,349.161,.02,"DT")
3000524
"^DD",349.1,349.161,.03,0)
RC MAIL ADDRESS^F^^0;3^K:$L(X)>30!($L(X)<3) X
"^DD",349.1,349.161,.03,3)
Answer must be 3-30 characters in length.
"^DD",349.1,349.161,.03,4)
D MAILADD^RCRCXMS
"^DD",349.1,349.161,.03,21,0)
^.001^4^4^3040429^^
"^DD",349.1,349.161,.03,21,1,0)
This field will contain the name of the Regional Counsel mail address
"^DD",349.1,349.161,.03,21,2,0)
that transactions from the associated Division of Care will be sent.
"^DD",349.1,349.161,.03,21,3,0)
This fields address will be different from the primary division's
"^DD",349.1,349.161,.03,21,4,0)
RC mail address.
"^DD",349.1,349.161,.03,23,0)
^^1^1^3040429^
"^DD",349.1,349.161,.03,23,1,0)
 
"^DD",349.1,349.161,.03,"DT")
3040325
"^DD",349.1,349.161,.04,0)
RC DEATH NOTIFICATION ADDRESS^F^^0;4^K:$L(X)>40!($L(X)<3) X
"^DD",349.1,349.161,.04,3)
Answer must be 3-40 characters in length.
"^DD",349.1,349.161,.04,4)
D DEATHADD^RCRCXMS
"^DD",349.1,349.161,.04,21,0)
^.001^4^4^3040429^^^
"^DD",349.1,349.161,.04,21,1,0)
This field will contain the name of the RC death notifications address
"^DD",349.1,349.161,.04,21,2,0)
that death notices from the associated Division of Care will be sent.
"^DD",349.1,349.161,.04,21,3,0)
This fields address will be different from the primary division's
"^DD",349.1,349.161,.04,21,4,0)
RC death notification address.
"^DD",349.1,349.161,.04,23,0)
^.001^1^1^3040429^^
"^DD",349.1,349.161,.04,23,1,0)
 
"^DD",349.1,349.161,.04,"DT")
3040429
"^DD",349.2,349.2,.01,0)
PATIENT^RP340'X^RCD(340,^0;1^Q
"^DD",349.2,349.2,.01,1,0)
^.1^^0
"^DD",349.2,349.2,.01,3)
Enter the Debtor Number for the Patient Statement.
"^DD",349.2,349.2,.01,21,0)
^^2^2^3161011^^
"^DD",349.2,349.2,.01,21,1,0)
This is the Debtor number to receive the Patient Statement associated 
"^DD",349.2,349.2,.01,21,2,0)
with the specific Patient.
"^DD",349.2,349.2,.01,"DT")
3161011
"^DD",349.2,349.2,.02,0)
SSN^RFXO^^0;2^K:$L(X)>10!($L(X)<9) X S X=$$SSN^RCFN01(+DA)
"^DD",349.2,349.2,.02,1,0)
^.1
"^DD",349.2,349.2,.02,1,1,0)
349.2^AKEY1^MUMPS
"^DD",349.2,349.2,.02,1,1,1)
I $P(^RCPS(349.2,+DA,0),"^",3)]"" S ^RCPS(349.2,"AKEY",$E(X,1,9)_$TR($E($P($P(^
RCPS(349.2,+DA,0),"^",3),","),1,5)," ",""),DA)=""
"^DD",349.2,349.2,.02,1,1,2)
K ^RCPS(349.2,"AKEY",$E(X,1,9)_$TR($E($P($P(^RCPS(349.2,+DA,0),"^",3),","),1,5)
," ",""))
"^DD",349.2,349.2,.02,1,1,"%D",0)
^.101^1^1^3160427^^
"^DD",349.2,349.2,.02,1,1,"%D",1,0)
This cross-reference is used to key the statements for CBSS.
"^DD",349.2,349.2,.02,1,1,"DT")
2960924
"^DD",349.2,349.2,.02,2)
S Y(0)=Y S Y=Y
"^DD",349.2,349.2,.02,2.1)
S Y=Y
"^DD",349.2,349.2,.02,3)
Answer must be 9-10 characters in length.
"^DD",349.2,349.2,.02,21,0)
^^1^1^2960418^^
"^DD",349.2,349.2,.02,21,1,0)
This is the SSN for the patient.
"^DD",349.2,349.2,.02,"DT")
2960924
"^DD",349.2,349.2,.03,0)
PATIENT NAME^RFX^^0;3^K:$L(X)>44!($L(X)<3) X S X=$$NAM^RCFN01(+DA)
"^DD",349.2,349.2,.03,1,0)
^.1
"^DD",349.2,349.2,.03,1,1,0)
349.2^AKEY2^MUMPS
"^DD",349.2,349.2,.03,1,1,1)
I $$KEY^RCCPCFN(+DA)]"" S ^RCPS(349.2,"AKEY",$$KEY^RCCPCFN(+DA),DA)=""
"^DD",349.2,349.2,.03,1,1,2)
I $P(^RCPS(349.2,+DA,0),"^",2)>1 K ^RCPS(349.2,"AKEY",$E($P(^RCPS(349.2,+DA,0),
"^",2),1,9)_$TR($E($P(X,","),1,5)," ",""))
"^DD",349.2,349.2,.03,1,1,"%D",0)
^^1^1^3160427^
"^DD",349.2,349.2,.03,1,1,"%D",1,0)
This cross-reference is used to key the statements for CBSS.
"^DD",349.2,349.2,.03,1,1,"DT")
2960924
"^DD",349.2,349.2,.03,3)
Answer must be 3-44 characters in length.
"^DD",349.2,349.2,.03,21,0)
^^1^1^2960418^^^^
"^DD",349.2,349.2,.03,21,1,0)
This is the patient name as it appears on the statement.
"^DD",349.2,349.2,.03,"DT")
2960924
"^DD",349.2,349.2,.12,0)
INVALID STATEMENT ERROR^P349.7'^RCPSE(349.7,^0;12^Q
"^DD",349.2,349.2,.12,3)
Enter the error code for the record that was not accepted by CBSS.
"^DD",349.2,349.2,.12,21,0)
^^1^1^3160427^
"^DD",349.2,349.2,.12,21,1,0)
This is the error code for the record that was not accepted by CBSS.
"^DD",349.2,349.2,.12,"DT")
3160909
"^DD",349.2,349.2,.18,0)
CBSS FILE BUILT^S^0:NOT BUILT;1:BUILT;^0;18^Q
"^DD",349.2,349.2,.18,3)
Enter a '1' when the CBSS PATIENT STATEMENTS file is complete.
"^DD",349.2,349.2,.18,21,0)
^^2^2^3160909^^
"^DD",349.2,349.2,.18,21,1,0)
This field will store a marker that the CBSS PATIENT STATEMENTS file
"^DD",349.2,349.2,.18,21,2,0)
(349.2) is a complete file for that statement day.
"^DD",349.2,349.2,.18,"DT")
3160921
"^DD",349.2,349.2,.19,0)
PATIENT STATEMENT DATE^D^^0;19^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",349.2,349.2,.19,3)
Enter the date of the Patient Statement. 
"^DD",349.2,349.2,.19,21,0)
^^2^2^3161019^
"^DD",349.2,349.2,.19,21,1,0)
Date Patient Statement will display on printed version.  This date is 
"^DD",349.2,349.2,.19,21,2,0)
standardly two days after the statement is transmitted
"^DD",349.2,349.2,.19,"DT")
3161103
"^DD",349.2,349.2,51,0)
ERROR CODE(S)^F^^5;1^K:$L(X)>30!($L(X)<5) X
"^DD",349.2,349.2,51,1,0)
^.1^^0
"^DD",349.2,349.2,51,3)
Answer must be 5-30 characters in length.
"^DD",349.2,349.2,51,21,0)
^^2^2^3161007^
"^DD",349.2,349.2,51,21,1,0)
These are the error codes sent back by CBSS when a statement cannot be
"^DD",349.2,349.2,51,21,2,0)
printed.
"^DD",349.2,349.2,51,"DT")
3161007
"^DD",349.2,349.2,61,0)
CBSS PRINTED^S^1:Y;0:N;^6;1^Q
"^DD",349.2,349.2,61,3)
Enter whether the patient statement for this patient printed at the CBSS.
"^DD",349.2,349.2,61,21,0)
^^2^2^3160909^^
"^DD",349.2,349.2,61,21,1,0)
This field indicates whether the patient statement for this patient printed
"^DD",349.2,349.2,61,21,2,0)
at the CCPC or not.
"^DD",349.2,349.2,61,"DT")
3160921
"^DD",349.2,349.2,81,0)
INTEGRATION CONTROL NUMBER^NJ12,0^^8;1^K:+X'=X!(X>999999999999)!(X<0)!(X?.E1"."
1.N) X
"^DD",349.2,349.2,81,3)
Enter the ICN, a number between 0 and 999999999999 with no decimal digits.
"^DD",349.2,349.2,81,21,0)
^^2^2^3160909^
"^DD",349.2,349.2,81,21,1,0)
Machine to machine identifier for a patient. This field can only be 
"^DD",349.2,349.2,81,21,2,0)
edited by CIRN.
"^DD",349.2,349.2,81,"DT")
3160921
"^DD",349.2,349.2,82,0)
ICN CHECKSUM^F^^8;2^K:$L(X)>6!($L(X)<6) X
"^DD",349.2,349.2,82,3)
Answer must be 6 characters in length.
"^DD",349.2,349.2,82,21,0)
^^2^2^3160428^
"^DD",349.2,349.2,82,21,1,0)
This checksum is the calculated checksum for the Integration Control 
"^DD",349.2,349.2,82,21,2,0)
Number.  It verifies the integrity of the ICN.
"^DD",349.2,349.2,82,"DT")
3160428
"^DD",349.2,349.2,83,0)
AR FLAG^S^T:TRUE;F:FALSE;^8;3^Q
"^DD",349.2,349.2,83,3)
Enter T for 'TRUE' or F for 'False', for whether the patient address was obtain
ed from AR storage.
"^DD",349.2,349.2,83,21,0)
^^2^2^3160428^
"^DD",349.2,349.2,83,21,1,0)
This is a set of code, indicating whether or not the address was taken 
"^DD",349.2,349.2,83,21,2,0)
from the AR DEBTOR (#340).
"^DD",349.2,349.2,83,"DT")
3160921
"^DD",349.2,349.2,84,0)
DATE OF LATEST BILL^DX^^8;4^S %DT="EX" D ^%DT S X=Y K:X<1 X
"^DD",349.2,349.2,84,3)
Enter the date on which the latest bill was established.
"^DD",349.2,349.2,84,21,0)
^^1^1^3160428^^
"^DD",349.2,349.2,84,21,1,0)
The date the latest bill was prepared.  Time is not allowed.
"^DD",349.2,349.2,84,"DT")
3160921
"^DD",349.5,349.5,0)
FIELD^^1^7
"^DD",349.5,349.5,0,"DT")
3170224
"^DD",349.5,349.5,0,"IX","B",349.5,.01)

"^DD",349.5,349.5,0,"NM","AR ANNUAL PAYMENT STATEMENT")

"^DD",349.5,349.5,.01,0)
PS SEGMENT NUMBER^RNJ4,0^^0;1^K:+X'=X!(X>9999)!(X<1)!(X?.E1"."1.N) X
"^DD",349.5,349.5,.01,1,0)
^.1
"^DD",349.5,349.5,.01,1,1,0)
349.5^B
"^DD",349.5,349.5,.01,1,1,1)
S ^RCAP(349.5,"B",$E(X,1,30),DA)=""
"^DD",349.5,349.5,.01,1,1,2)
K ^RCAP(349.5,"B",$E(X,1,30),DA)
"^DD",349.5,349.5,.01,3)
Enter the PS Segment Number (a number between 1 and 9999).
"^DD",349.5,349.5,.01,21,0)
^^1^1^3170223^
"^DD",349.5,349.5,.01,21,1,0)
This is the Segment Number for the "PS" Record Identifier.
"^DD",349.5,349.5,.01,"DT")
3170224
"^DD",349.5,349.5,.02,0)
YEAR^NJ3,0^^0;2^K:+X'=X!(X>400)!(X<300)!(X?.E1"."1.N) X
"^DD",349.5,349.5,.02,3)
Enter the Year for this segment in Internal FileMan Format (a number between 30
0 and 400).
"^DD",349.5,349.5,.02,21,0)
^^1^1^3170223^
"^DD",349.5,349.5,.02,21,1,0)
This is the Annual Payment File Year to be processed.
"^DD",349.5,349.5,.02,"DT")
3170224
"^DD",349.5,349.5,.03,0)
DATE/TIME BUILD STARTED^D^^0;3^S %DT="ESTXR" D ^%DT S X=Y K:3170101>X X
"^DD",349.5,349.5,.03,3)
Enter the Date and Time Build Started.
"^DD",349.5,349.5,.03,21,0)
^^1^1^3170223^
"^DD",349.5,349.5,.03,21,1,0)
This is the Date and Time that the Build for this file started.
"^DD",349.5,349.5,.03,"DT")
3170224
"^DD",349.5,349.5,.04,0)
DATE/TIME BUILD ENDED^D^^0;4^S %DT="ESTXR" D ^%DT S X=Y K:3170101>X X
"^DD",349.5,349.5,.04,3)
Enter the Date and Time Build Ended.
"^DD",349.5,349.5,.04,21,0)
^^1^1^3170223^
"^DD",349.5,349.5,.04,21,1,0)
This is the Date and Time that the Build for this file ended.
"^DD",349.5,349.5,.04,"DT")
3170224
"^DD",349.5,349.5,.05,0)
DATE/TIME TRANSMIT STARTED^D^^0;5^S %DT="ESTXR" D ^%DT S X=Y K:3170101>X X
"^DD",349.5,349.5,.05,3)
Enter the Date and Time Transmit Started.
"^DD",349.5,349.5,.05,21,0)
^^1^1^3170223^
"^DD",349.5,349.5,.05,21,1,0)
This is the Date and Time that the Transmit for this file started.
"^DD",349.5,349.5,.05,"DT")
3170224
"^DD",349.5,349.5,.06,0)
DATE/TIME TRANSMIT ENDED^D^^0;6^S %DT="ESTXR" D ^%DT S X=Y K:3170101>X X
"^DD",349.5,349.5,.06,3)
Enter Date/Time Transmit Ended.
"^DD",349.5,349.5,.06,21,0)
^^1^1^3170223^
"^DD",349.5,349.5,.06,21,1,0)
This is the Date and Time that the Transmit for this file ended.
"^DD",349.5,349.5,.06,"DT")
3170224
"^DD",349.5,349.5,1,0)
STATEMENT FILE LINES^349.51^^1;0
"^DD",349.5,349.5,1,21,0)
^^1^1^3170224^^
"^DD",349.5,349.5,1,21,1,0)
This is the multiple for the Annual Payment Statement file lines.
"^DD",349.5,349.51,0)
STATEMENT FILE LINES SUB-FIELD^^.01^1
"^DD",349.5,349.51,0,"DT")
3170224
"^DD",349.5,349.51,0,"NM","STATEMENT FILE LINES")

"^DD",349.5,349.51,0,"UP")
349.5
"^DD",349.5,349.51,.01,0)
STATEMENT FILE LINES^MFJ342^^0;1^K:$L(X)>342!($L(X)<1) X
"^DD",349.5,349.51,.01,1,0)
^.1^^0
"^DD",349.5,349.51,.01,3)
Enter File Lines for Annual Payment Statement (1 to 342 characters).
"^DD",349.5,349.51,.01,21,0)
^^1^1^3170224^
"^DD",349.5,349.51,.01,21,1,0)
These are the File Lines for Annual Payment Statement.
"^DD",349.5,349.51,.01,"DT")
3170224
"^DIC",349.1,349.1,0)
AR TRANSMISSION TYPE^349.1
"^DIC",349.1,349.1,0,"GL")
^RCT(349.1,
"^DIC",349.1,349.1,"%D",0)
^1.001^2^2^3160422^^^^
"^DIC",349.1,349.1,"%D",1,0)
This file stores the transmission types used in file 349
"^DIC",349.1,349.1,"%D",2,0)
AR TRANSMISSION RECORDS.
"^DIC",349.1,"B","AR TRANSMISSION TYPE",349.1)

"^DIC",349.5,349.5,0)
AR ANNUAL PAYMENT STATEMENT^349.5
"^DIC",349.5,349.5,0,"GL")
^RCAP(349.5,
"^DIC",349.5,349.5,"%",0)
^1.005^^
"^DIC",349.5,349.5,"%D",0)
^^3^3^3170223^
"^DIC",349.5,349.5,"%D",1,0)
This file will hold all of the previous year's patient payment data for
"^DIC",349.5,349.5,"%D",2,0)
that calendar year and persist for only one year to then be deleted and
"^DIC",349.5,349.5,"%D",3,0)
replaced at the beginning of the next calendar year.
"^DIC",349.5,"B","AR ANNUAL PAYMENT STATEMENT",349.5)

"BLD",10111,6)
4^
$END KID PRCA*4.5*313
