1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 2/2/2017 2:10:09 PM Eastern Standard Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

1.1 Files compared

# Location File Last Modified
1 PSE Patch PRCA_45_307 CIF submission.zip Patch PRCA_45_307v18.docx Tue Jan 3 21:25:42 2017 UTC
2 PSE Patch PRCA_45_307 CIF submission.zip Patch PRCA_45_307v18.docx Thu Feb 2 18:27:25 2017 UTC

1.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 5 8838
Changed 4 12
Inserted 0 0
Removed 0 0

1.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

1.4 Active regular expressions

No regular expressions were active.

1.5 Comparison detail

  1   ========== ========== ========== ========== ========== ========== ========== =======
  2   Run Date:  DEC 19, 20 16                       Designa tion: PRCA *4.5*307 v 18
  3   Package :  PRCA - ACC OUNTS RECE IVABLE           Prio rity: Mand atory
  4   Version :  4.5                                      St atus: Unde r Developm ent
  5   ========== ========== ========== ========== ========== ========== ========== =======
  6  
  7   Associated  patches:  (v)PRCA*4. 5*233<<= m ust be ins talled BEF ORE `PRCA* 4.5*307'
  8                         (v)PRCA*4. 5*237<<= m ust be ins talled BEF ORE `PRCA* 4.5*307'
  9                         (v)PRCA*4. 5*276<<= m ust be ins talled BEF ORE `PRCA* 4.5*307'
  10                         (v)PRCA*4. 5*309<<= m ust be ins talled BEF ORE `PRCA* 4.5*307'
  11  
  12   Subject: P atient Sta tement Enh ancement P hase One
  13  
  14   Category: 
  15     - Routin e
  16     - Enhanc ement (Man datory)
  17     - Data D ictionary
  18  
  19   Descriptio n:
  20   ========== ==
  21  
  22    ********* ********** ********** ********** ********** ********** ********** ********
  23        This  patch supp orts chang es to the  Veterans H ealth Info rmation
  24        Syste m and Tech nology Arc hitecture  (VistA) fo r the Pati ent Statem ent
  25        Enhan cements Pr oject (PSE ).
  26     
  27        It is  imperativ e that the se patches  be instal led no lat er than th e
  28        compl iance date . Your und erstanding  and suppo rt is appr eciated.
  29    ********* ********** ********** ********** ********** ********** ********** ********
  30      
  31    The Chief  Business  Office (CB O) request ed modific ations to  the VistA
  32    Accounts  Receivable  (AR) pack age to rem edy defici encies ide ntified wi th
  33    patient s tatements.  The main  goals of t his projec t includes  the
  34    remediati on and enh ancement o f the AR a pplication  software  to correct
  35    these dis crepancies . Addition ally this  project wi ll perform  the initi al
  36    developme nt of the  VistA AR e nhancement s to creat e a single , consolid ated
  37    patient s tatement,  self-servi ce options  for payme nt, and ot her modifi cations.
  38     
  39    This patc h modifies  the Accou nt Receiva ble (AR) v 4.5 applic ation as
  40    described  below:
  41     
  42    1. Patien t Statemen t Auto-Cor rection Pr ogram
  43        The A R applicat ion execut es an Auto -Correctio n program  that detec ts
  44        and r emediates  the follow ing 3 type s of state ment discr epancies:
  45     
  46        1. Tr ansaction  amounts mi ssing in t he AR TRAN SACTION fi le (#433).
  47        2. Du plicate tr ansactions  in the AR  TRANSACTI ON file (# 433).
  48        3. In complete s tatus erro rs in the  AR TRANSAC TION file  (#433).
  49     
  50        The P atient Sta tement Aut o-Correcti on Program  is schedu led as par t of
  51        the A R nightly  background  job.
  52     
  53        The P atient Sta tement Aut o-Correcti on Program  can be ru n on deman d
  54        and w ill be an  option in  the Accoun t Manageme nt menu.
  55     
  56        The P atient Sta tement Aut o-Correcti on Program  runs as a
  57        post- initializa tion progr am at the  time of in stallation .
  58     
  59        OI&T  should als o schedule  the PRCA  AUTOCRCT P GM QUEUED  option to  run
  60        every  Wednesday  at 1:00 A M local ti me, before  the CCPC  job.
  61      
  62    2. Auto-C orrect Pat ient Discr epancy Rep ort
  63        The A uto-Correc t Patient  Discrepanc y Report l ists the d iscrepancy
  64        detai ls that we re remedia ted by the  Patient S tatement 
  65        Auto- Correction  Program.
  66     
  67        The A uto-Correc t Patient  Discrepanc y Report d isplays th e bill num ber,
  68        the d ebtor, the  last four  digits of  the SSN,  the transa ction numb er,
  69        the c orrection  date, and  the reason  for the a uto-correc tion.
  70     
  71        The A uto-Correc t Patient  Discrepanc y Report p rovides fo ur sort
  72        optio ns.
  73          1 B ill Number
  74          2 D ebtor Name
  75          3 A uto-Correc t Date
  76          4 T ransaction  Number
  77     
  78        Each  entry in t he Auto-Co rrect Pati ent Discre pancy Repo rt will ha ve 
  79        one o f the four  Auto-Corr ect Reason s.
  80          1 I NCOMPLETE  FLAG ERROR
  81          2 D UPLICATE T RANSACTION
  82          3 N ULL TRANSA CTION AMOU NT
  83          4 N OT FIXABLE
  84     
  85        Trans actions li sted as NO T FIXABLE  will need  to be manu ally revie wed 
  86        to de termine th e appropri ate course  of action  and then  they shoul d be
  87        corre cted manua lly.
  88     
  89    3. Root C ause of St atement Di screpancie s
  90        Chang es prevent  Null Tran sactions w hen Commen t field is  left blan k by
  91        user  and a time out occurs .
  92        
  93        Chang es process ing of Tie r Rate tra nsactions  in VistA t o stop
  94        dupli cates bein g filed.
  95     
  96      
  97    Patch Com ponents:
  98    --------- --------
  99     
  100    Files & F ields Asso ciated:
  101     
  102    The follo wing is a  list of fi les includ ed in this  patch:
  103      
  104    File Name  (Number)     Field N ame (Numbe r)              New/M odified/De leted
  105    --------- ---------     ------- ---------- --              ----- ---------- -----
  106    AR TRANSA CTION         AUTO-CO RRECTION                            NEW
  107    FILE (#43 3)            DATE (# 94)
  108                            
  109                            AUTO-CO RRECTION T RANS.                    NEW
  110                            AMOUNT  (#95)                      
  111                            
  112                            AUTO-CO RRECTION T YPE                      NEW
  113                            OF ERRO R (#96)
  114      
  115                            AUTO-CO RRECTION T ICKET                    NEW
  116                            FLAG (# 97)
  117     
  118    Forms Ass ociated:
  119      
  120    Form Name               File #                             New/M odified/De leted
  121    ---------               ------                             ----- ---------- -----
  122    N/A
  123      
  124      
  125    Mail Grou ps Associa ted:
  126      
  127    Mail Grou p Name                                           New/M odified/De leted
  128    --------- ------                                           ----- ---------- -----
  129    PRCACPS                                                             NEW
  130      
  131      
  132    Options A ssociated:
  133         
  134    Option Na me                      Type                     New/M odified/De leted
  135    --------- --                      -------- ---             ----- ---------- -----
  136    PRCA ACCO UNT MANAGE MENT         MENU                            MODIFIED
  137    PRCA AUTO CRCT PGM                RUN ROUT INE                      NEW
  138    PRCA AUTO CRCT RPT                RUN ROUT INE                      NEW
  139      
  140      
  141    Protocols  Associate d:
  142     
  143    Protocol  Name   New /Modified/ Deleted
  144    --------- ----   --- ---------- -------
  145    N/A  
  146     
  147     
  148    Security  Keys Assoc iated:
  149     
  150      
  151    Security  Key Name                                         New/M odified/De leted
  152    --------- --------                                         ----- ---------- -----
  153    PRCA AUTO CRCT PGM                                                  NEW
  154      
  155     
  156    Templates  Associate d:
  157      
  158    Template  Name          Type       File Na me (Number )    New/M odified/De leted
  159    --------- ----          -----      ------- ---------- --   ----- ---------- -----
  160    PRCA RE-E STABLISH      INPUT      AR TRAN SACTION FI LE          MODIFIED
  161     WRITE-OF F
  162     
  163    Remote Pr ocedure:                                         New/M odified/De leted
  164    --------- --------                                         ----- ---------- -----
  165    N/A
  166      
  167    Additiona l Informat ion:
  168    N/A
  169      
  170    New Servi ce Request  (NSRs):
  171    --------- ---------- --------
  172    N/A
  173      
  174    Patient S afety Issu es (PSIs):
  175    --------- ---------- ----------
  176    N/A
  177      
  178    Defect Tr acking Sys tem Ticket (s) & Over view:
  179    --------- ---------- ---------- ---------- -----
  180    N/A
  181     
  182    Test Site s:
  183    --------- --
  184    TBD
  185      
  186      
  187    Software  and Docume ntation Re trieval In structions :
  188    --------- ---------- ---------- ---------- ---------- -
  189    Software  being rele ased as a  host file  and/or doc umentation  describin
  190    the new f unctionali ty introdu ced by thi s patch ar e availabl e.
  191      
  192    The prefe rred metho d is to re trieve fil es from do wnload. DNS .
  193    This tran smits the  files from  the first  available  server. S ites may a lso
  194    elect to  retrieve f iles direc tly from a  specific  server. 
  195      
  196    Sites may  retrieve  the softwa re and/or  documentat ion direct ly using S ecure
  197    File Tran sfer Proto col (SFTP)  from the  ANONYMOUS. SOFTWARE d irectory a t the
  198    following  OI Field  Offices:
  199     
  200    Albany:                 DNS
  201    Hines:                  DNS   
  202    Salt Lake  City:        DNS
  203     
  204    Documenta tion can a lso be fou nd on the  VA Softwar e Document ation Libr ary at:
  205    http:// URL /
  206      
  207     
  208    Title                                           File  Name             SFTP  Mode
  209    --------- ---------- ---------- ---------- ---------- ---------- ---------- -----
  210    Patient S tatement E nhancement s User Man ual  prca_ 4_5_p307_u m.pdf (bin ary)
  211    Patient S tatement E nhancement s Release       prca_ 4_5_p307_r n.pdf (bin ary)
  212     Notes /  Installati on Guide                   
  213    Accounts  Receivable  Technical  Manual /       prca_ 4_5_p307_t m.pdf (bin ary)
  214     Security  Guide 
  215     
  216      
  217    Patch Ins tallation:
  218     
  219      
  220    Pre/Post  Installati on Overvie w:
  221    --------- ---------- ---------- --
  222     
  223    The post- install ro utine for  patch PRCA *4.5*307 w ill, for 1 7 specific
  224    Station I D's listed  at the bo ttom of th is documen t, update  the 
  225    SITE STAT EMENT DAY  field (#.1 1) in AR S ITE PARAME TER file ( #342).
  226     
  227    The post- install ro utine for  patch PRCA *4.5*307 w ill queue  the 
  228    Patient S tatement A uto-Correc tion Progr am to reme diate stat ement
  229    discrepan cies.
  230     
  231    The post  install ro utine PRCA 307P may b e deleted  from the s ystem if t he
  232    post-inst all proces s has comp leted.
  233     
  234    Pre-Insta llation In structions :
  235    --------- ---------- ---------- -
  236    This patc h may be i nstalled w ith users  on the sys tem althou gh it is 
  237    recommend ed that it  be instal led during  non-peak  hours to m inimize
  238    potential  disruptio n to users . This pat ch should  take less  than 20
  239    minutes t o install.
  240     
  241    The follo wing optio ns may be  marked as  'out of or der':
  242      
  243         Stat ement Disc repancy Li sting    [ PRCA DISC  LIST]
  244         Chec k Patient  Account Ba lance    [ PRCA ACCOU NT CHECK]
  245      
  246    Installat ion Instru ctions:
  247    --------- ---------- -------
  248    This patc h modifies  the Accou nt Receiva ble (AR) v 4.5 applic ation
  249    to prepar e for a si ngle, cons olidated p atient sta tement.
  250      
  251       1. Cho ose the Pa ckMan mess age contai ning this  patch.  
  252      
  253       2. Cho ose the IN STALL/CHEC K MESSAGE  PackMan op tion.  
  254      
  255       3. Fro m the Kern el Install ation and  Distributi on System  Menu, sele ct
  256          the  Installat ion Menu.  From this  menu, you  may elect  to use the
  257          fol lowing opt ions. When  prompted  for the IN STALL NAME  enter the
  258          pat ch PRCA*4. 5*307.
  259      
  260          a.  Backup a T ransport G lobal - Th is option  will creat e a backup
  261              message of  any routi nes export ed with th is patch.  It will no t
  262              backup any  other cha nges such  as DDs or  templates.
  263     
  264          b.  Compare Tr ansport Gl obal to Cu rrent Syst em - This  option wil l
  265              allow you  to view al l changes  that will  be made wh en this
  266              patch is i nstalled.  It compare s all comp onents of  this patch
  267              routines,  DDs, templ ates, etc.
  268     
  269          c.  Verify Che cksums in  Transport  Global - T his option  will allo w
  270              you to ens ure the in tegrity of  the routi nes that a re in the
  271              transport  global.
  272      
  273       4. Fro m the Inst allation M enu, selec t the Inst all Packag e(s)
  274          opt ion and ch oose the p atch to in stall.
  275     
  276       5. Whe n prompted  'Want KID S to Rebui ld Menu Tr ees Upon C ompletion
  277          of  Install? Y ES//' repl y 'YES' un less your  system reb uilds menu  
  278          tre es nightly  using Tas kMan. Answ ering Yes  during nor mal busine ss
  279          hou rs could a ffect user s on the s ystem and  installati on times w ill
  280          inc rease.
  281      
  282       6. Whe n Prompted  "Enter th e Coordina tor for Ma il Group ' PRCACPS':" ,
  283           re spond with  the name:  Kendrick,  Tammy S.
  284      
  285       7. Whe n Prompted  "Want KID S to INHIB IT LOGONs  during the  install? 
  286           NO //", respo nd NO.  
  287      
  288       8. Whe n Prompted  "Want to  DISABLE Sc heduled Op tions, Men u Options,  and 
  289           Pr otocols? N O//", resp ond YES.
  290      
  291            a . When Pro mpted "Ent er options  you wish  to mark as  'Out Of 
  292                Order':" , enter th e followin g options:
  293      
  294                   State ment Discr epancy Lis ting    [P RCA DISC L IST]
  295                   Check  Patient A ccount Bal ance    [P RCA ACCOUN T CHECK]
  296      
  297            b . When Pro mpted "Ent er protoco ls you wis h to mark  as 'Out 
  298                Of Order ':", Press  <ENTER>.
  299     
  300       9. Whe n prompted  "Delay In stall (Min utes):  (0 -60): 0//"   enter an
  301          app ropriate n umber of m inutes to  delay the  installati on in 
  302          ord er to give  users eno ugh time t o exit the  disabled  options
  303          bef ore the in stallation  starts.
  304     
  305      10. Whe n prompted  "Device:  Home//" re spond with  the corre ct device.
  306      
  307    Post-Inst allation I nstruction s
  308    --------- ---------- ---------- -
  309    The Auto- Correction  program m ay take up  to 20 min utes to ru n.
  310      
  311    Updated i n this pat ch during  the post i nstall pro cess, for  only 17
  312    specific  Station ID 's listed  below, wil l be an up date to th e SITE
  313    STATEMENT  DAY field  (#.11) in  AR SITE P ARAMETER f ile (#342) . Only Pat ient
  314    Debtors f or the fol lowing Sta tion ID's  will have  their STAT EMENT DAY
  315    changed t o a new da te in the  month. Thi s change f or these 1 7 Station  ID's
  316    will allo w a window  of time a t the end  of the mon th to inst all the
  317    follow-on  PSE patch  PRCA*4.5* 313 nation ally.
  318      
  319    STATION #    STATION  NAME       DATE
  320    --------- ---------- ---------- -----
  321       438       SIOUX F ALLS,SD      21
  322       501       ALBUQUE RQUE,NM      21
  323       504       AMARILL O,TX         21
  324       542       COATESV ILLE,PA      21
  325       562       ERIE,PA              21
  326       568       FORT ME ADE,SD       21
  327       649       PRESCOT T,AZ         21
  328       656       ST. CLO UD,MN        21
  329       688       WASHING TON,DC       21
  330       756       EL PASO ,TX          21
  331       565       FAYETTE VILLE,NC     22
  332       621       MOUNTAI N HOME,TN    22
  333       658       SALEM,V A            22
  334       664       SAN DIE GO,CA        22
  335       671       SAN ANT ONIO,TX      22
  336       689       WEST HA VEN,CT       22
  337       740       TX VALL EY CSTL,TX   22
  338     
  339    During th e post-ins tall proce ss you may  see liste d in the l og one of  the 
  340    following  messages:
  341     
  342    >>> STATI ON ID XXX  MATCH FOUN D! 
  343    >>> THE P ATIENT STA TEMENT TRA NSMISSION  DATE WILL  BE UPDATED
  344    *Note: XX X will equ al your ST ATION NUMB ER* 
  345     
  346    >>> WARNI NG! STATIO N ID NOT F OUND!
  347    >>> THE P ATIENT STA TEMENT TRA NSMISSION  DATE WILL  NOT BE UPD ATED
  348     
  349     
  350    The post- install ro utine for  patch PRCA *4.5*307 w ill queue  the
  351    Patient S tatement A uto-Correc tion Progr am to reme diate stat ement
  352    discrepan cies.
  353     
  354    The insta llation lo g will dis play:
  355    >>>POST-I NSTALL CON SOLIDATED  PATIENT ST ATEMENT AU TO-CORRECT ION
  356    >>>PROGRA M HAS BEEN  QUEUED
  357     
  358    If there  is an erro r, the ins tallation  log will d isplay:
  359    >>>ERROR:  POST-INST ALL CONSOL IDATED PAT IENT STATE MENT AUTO- CORRECTION
  360    >>>PROGRA M COULD NO T BE QUEUE D
  361     
  362      
  363    The post  install ro utine PRCA 307P may b e deleted  from the s ystem if t he
  364    post-inst all proces s has comp leted.
  365    ========= ========== ========== ========== ========== ========== ========== ===
  366  
  367   Routine In formation:
  368   ========== ==========
  369   The second  line of e ach of the se routine s now look s like:
  370    ;;4.5;Acc ounts Rece ivable;**[ Patch List ]**;Mar 20 , 1995;Bui ld 72
  371  
  372   The checks ums below  are new ch ecksums, a nd
  373    can be ch ecked with  CHECK1^XT SUMBLD.
  374  
  375   Routine Na me: PRCA30 7P
  376       Before :       n/ a   After:   B6358634   **307**
  377   Routine Na me: PRCAAC R
  378       Before :       n/ a   After:  B97009305   **307**
  379   Routine Na me: PRCAAC R1
  380       Before :       n/ a   After: B104478523   **307**
  381   Routine Na me: PRCACP S
  382       Before :       n/ a   After: B251510911   **307**
  383   Routine Na me: PRCACP SA
  384       Before :       n/ a   After:  B13044758   **307**
  385   Routine Na me: PRCASE R1
  386       Before : B1595752 6   After:  B18484730   **48,104 ,165,233,3 07**
  387   Routine Na me: RCCPCB J
  388       Before :  B628849 1   After:   B7509278   **34,76, 130,153,16 6,195,217, 237,307**
  389   Routine Na me: RCDPBT LM
  390       Before : B4947614 0   After:  B55886735   **114,14 8,153,168, 169,198,24 7,
  391                                                  271,276 ,307**
  392   Routine Na me: RCWROF F
  393       Before : B3490145 9   After:  B36621298   **168,20 4,309,307* *
  394    
  395   Routine li st of prec eding patc hes: 233,  237, 276,  309
  396  
  397   ========== ========== ========== ========== ========== ========== ========== =======
  398   User Infor mation:
  399   Entered By     PI I
                               Date Enter ed    : DEC 15,  2014
  400   Completed  By:                                  Date C ompleted: 
  401   Released B y :                                  Date R eleased : 
  402   ========== ========== ========== ========== ========== ========== ========== =======
  403  
  404  
  405   Packman Ma il Message :
  406   ========== ========== =
  407  
  408   $END TXT
  409   $KID PRCA* 4.5*307
  410   **INSTALL  NAME**
  411   PRCA*4.5*3 07
  412   "BLD",1015 3,0)
  413   PRCA*4.5*3 07^ACCOUNT S RECEIVAB LE^0^31612 19^y
  414   "BLD",1015 3,1,0)
  415   ^^1^1^3151 102^^
  416   "BLD",1015 3,1,1,0)
  417   Consolidat ed Patient  Statement
  418   "BLD",1015 3,4,0)
  419   ^9.64PA^43 3^1
  420   "BLD",1015 3,4,433,0)
  421   433
  422   "BLD",1015 3,4,433,2, 0)
  423   ^9.641^433 ^1
  424   "BLD",1015 3,4,433,2, 433,0)
  425   AR TRANSAC TION  (Fil e-top leve l)
  426   "BLD",1015 3,4,433,2, 433,1,0)
  427   ^9.6411^97 ^4
  428   "BLD",1015 3,4,433,2, 433,1,94,0 )
  429   AUTO-CORRE CTION DATE
  430   "BLD",1015 3,4,433,2, 433,1,95,0 )
  431   AUTO-CORRE CTION TRAN S. AMOUNT
  432   "BLD",1015 3,4,433,2, 433,1,96,0 )
  433   AUTO-CORRE CTION TYPE  OF ERROR
  434   "BLD",1015 3,4,433,2, 433,1,97,0 )
  435   AUTO-CORRE CTION TICK ET FLAG
  436   "BLD",1015 3,4,433,22 2)
  437   y^n^p^^^^n ^^n
  438   "BLD",1015 3,4,433,22 4)
  439  
  440   "BLD",1015 3,4,"APDD" ,433,433)
  441  
  442   "BLD",1015 3,4,"APDD" ,433,433,9 4)
  443  
  444   "BLD",1015 3,4,"APDD" ,433,433,9 5)
  445  
  446   "BLD",1015 3,4,"APDD" ,433,433,9 6)
  447  
  448   "BLD",1015 3,4,"APDD" ,433,433,9 7)
  449  
  450   "BLD",1015 3,4,"B",43 3,433)
  451  
  452   "BLD",1015 3,6)
  453   17^
  454   "BLD",1015 3,6.3)
  455   72
  456   "BLD",1015 3,"ABPKG")
  457   n
  458   "BLD",1015 3,"INID")
  459   ^n
  460   "BLD",1015 3,"INIT")
  461   EN^PRCA307 P
  462   "BLD",1015 3,"KRN",0)
  463   ^9.67PA^77 9.2^20
  464   "BLD",1015 3,"KRN",.4 ,0)
  465   .4
  466   "BLD",1015 3,"KRN",.4 ,"NM",0)
  467   ^9.68A^^0
  468   "BLD",1015 3,"KRN",.4 01,0)
  469   .401
  470   "BLD",1015 3,"KRN",.4 01,"NM",0)
  471   ^9.68A^^
  472   "BLD",1015 3,"KRN",.4 02,0)
  473   .402
  474   "BLD",1015 3,"KRN",.4 02,"NM",0)
  475   ^9.68A^1^1
  476   "BLD",1015 3,"KRN",.4 02,"NM",1, 0)
  477   PRCA RE-ES TABLISH WR ITE-OFF     FILE #433 ^433^0
  478   "BLD",1015 3,"KRN",.4 02,"NM","B ","PRCA RE -ESTABLISH  WRITE-OFF     FILE # 433",1)
  479  
  480   "BLD",1015 3,"KRN",.4 03,0)
  481   .403
  482   "BLD",1015 3,"KRN",.4 03,"NM",0)
  483   ^9.68A^^
  484   "BLD",1015 3,"KRN",.5 ,0)
  485   .5
  486   "BLD",1015 3,"KRN",.8 4,0)
  487   .84
  488   "BLD",1015 3,"KRN",3. 6,0)
  489   3.6
  490   "BLD",1015 3,"KRN",3. 8,0)
  491   3.8
  492   "BLD",1015 3,"KRN",3. 8,"NM",0)
  493   ^9.68A^1^1
  494   "BLD",1015 3,"KRN",3. 8,"NM",1,0 )
  495   PRCACPS^^0
  496   "BLD",1015 3,"KRN",3. 8,"NM","B" ,"PRCACPS" ,1)
  497  
  498   "BLD",1015 3,"KRN",9. 2,0)
  499   9.2
  500   "BLD",1015 3,"KRN",9. 8,0)
  501   9.8
  502   "BLD",1015 3,"KRN",9. 8,"NM",0)
  503   ^9.68A^10^ 9
  504   "BLD",1015 3,"KRN",9. 8,"NM",1,0 )
  505   PRCACPS^^0 ^B25151091 1
  506   "BLD",1015 3,"KRN",9. 8,"NM",2,0 )
  507   PRCA307P^^ 0^B6358634
  508   "BLD",1015 3,"KRN",9. 8,"NM",3,0 )
  509   PRCASER1^^ 0^B1848473 0
  510   "BLD",1015 3,"KRN",9. 8,"NM",4,0 )
  511   RCWROFF^^0 ^B36621298
  512   "BLD",1015 3,"KRN",9. 8,"NM",5,0 )
  513   RCCPCBJ^^0 ^B7509278
  514   "BLD",1015 3,"KRN",9. 8,"NM",7,0 )
  515   PRCAACR^^0 ^B97009305
  516   "BLD",1015 3,"KRN",9. 8,"NM",8,0 )
  517   PRCAACR1^^ 0^B1044785 23
  518   "BLD",1015 3,"KRN",9. 8,"NM",9,0 )
  519   RCDPBTLM^^ 0^B5588673 5
  520   "BLD",1015 3,"KRN",9. 8,"NM",10, 0)
  521   PRCACPSA^^ 0^B1304475 8
  522   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"PRCA307P ",2)
  523  
  524   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"PRCAACR" ,7)
  525  
  526   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"PRCAACR1 ",8)
  527  
  528   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"PRCACPS" ,1)
  529  
  530   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"PRCACPSA ",10)
  531  
  532   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"PRCASER1 ",3)
  533  
  534   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"RCCPCBJ" ,5)
  535  
  536   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"RCDPBTLM ",9)
  537  
  538   "BLD",1015 3,"KRN",9. 8,"NM","B" ,"RCWROFF" ,4)
  539  
  540   "BLD",1015 3,"KRN",19 ,0)
  541   19
  542   "BLD",1015 3,"KRN",19 ,"NM",0)
  543   ^9.68A^4^4
  544   "BLD",1015 3,"KRN",19 ,"NM",1,0)
  545   PRCA AUTOC RCT PGM^^0
  546   "BLD",1015 3,"KRN",19 ,"NM",2,0)
  547   PRCA AUTOC RCT RPT^^0
  548   "BLD",1015 3,"KRN",19 ,"NM",3,0)
  549   PRCA ACCOU NT MANAGEM ENT^^2
  550   "BLD",1015 3,"KRN",19 ,"NM",4,0)
  551   PRCA AUTOC RCT PGM QU EUED^^0
  552   "BLD",1015 3,"KRN",19 ,"NM","B", "PRCA ACCO UNT MANAGE MENT",3)
  553  
  554   "BLD",1015 3,"KRN",19 ,"NM","B", "PRCA AUTO CRCT PGM", 1)
  555  
  556   "BLD",1015 3,"KRN",19 ,"NM","B", "PRCA AUTO CRCT PGM Q UEUED",4)
  557  
  558   "BLD",1015 3,"KRN",19 ,"NM","B", "PRCA AUTO CRCT RPT", 2)
  559  
  560   "BLD",1015 3,"KRN",19 .1,0)
  561   19.1
  562   "BLD",1015 3,"KRN",19 .1,"NM",0)
  563   ^9.68A^1^1
  564   "BLD",1015 3,"KRN",19 .1,"NM",1, 0)
  565   PRCA AUTOC RCT PGM^^0
  566   "BLD",1015 3,"KRN",19 .1,"NM","B ","PRCA AU TOCRCT PGM ",1)
  567  
  568   "BLD",1015 3,"KRN",10 1,0)
  569   101
  570   "BLD",1015 3,"KRN",40 9.61,0)
  571   409.61
  572   "BLD",1015 3,"KRN",77 1,0)
  573   771
  574   "BLD",1015 3,"KRN",77 9.2,0)
  575   779.2
  576   "BLD",1015 3,"KRN",87 0,0)
  577   870
  578   "BLD",1015 3,"KRN",89 89.51,0)
  579   8989.51
  580   "BLD",1015 3,"KRN",89 89.52,0)
  581   8989.52
  582   "BLD",1015 3,"KRN",89 94,0)
  583   8994
  584   "BLD",1015 3,"KRN","B ",.4,.4)
  585  
  586   "BLD",1015 3,"KRN","B ",.401,.40 1)
  587  
  588   "BLD",1015 3,"KRN","B ",.402,.40 2)
  589  
  590   "BLD",1015 3,"KRN","B ",.403,.40 3)
  591  
  592   "BLD",1015 3,"KRN","B ",.5,.5)
  593  
  594   "BLD",1015 3,"KRN","B ",.84,.84)
  595  
  596   "BLD",1015 3,"KRN","B ",3.6,3.6)
  597  
  598   "BLD",1015 3,"KRN","B ",3.8,3.8)
  599  
  600   "BLD",1015 3,"KRN","B ",9.2,9.2)
  601  
  602   "BLD",1015 3,"KRN","B ",9.8,9.8)
  603  
  604   "BLD",1015 3,"KRN","B ",19,19)
  605  
  606   "BLD",1015 3,"KRN","B ",19.1,19. 1)
  607  
  608   "BLD",1015 3,"KRN","B ",101,101)
  609  
  610   "BLD",1015 3,"KRN","B ",409.61,4 09.61)
  611  
  612   "BLD",1015 3,"KRN","B ",771,771)
  613  
  614   "BLD",1015 3,"KRN","B ",779.2,77 9.2)
  615  
  616   "BLD",1015 3,"KRN","B ",870,870)
  617  
  618   "BLD",1015 3,"KRN","B ",8989.51, 8989.51)
  619  
  620   "BLD",1015 3,"KRN","B ",8989.52, 8989.52)
  621  
  622   "BLD",1015 3,"KRN","B ",8994,899 4)
  623  
  624   "BLD",1015 3,"QDEF")
  625   ^^^^^^^^YE S
  626   "BLD",1015 3,"QUES",0 )
  627   ^9.62^^
  628   "BLD",1015 3,"REQB",0 )
  629   ^9.611^7^4
  630   "BLD",1015 3,"REQB",3 ,0)
  631   PRCA*4.5*2 37^1
  632   "BLD",1015 3,"REQB",4 ,0)
  633   PRCA*4.5*2 33^1
  634   "BLD",1015 3,"REQB",6 ,0)
  635   PRCA*4.5*3 09^1
  636   "BLD",1015 3,"REQB",7 ,0)
  637   PRCA*4.5*2 76^1
  638   "BLD",1015 3,"REQB"," B","PRCA*4 .5*233",4)
  639  
  640   "BLD",1015 3,"REQB"," B","PRCA*4 .5*237",3)
  641  
  642   "BLD",1015 3,"REQB"," B","PRCA*4 .5*276",7)
  643  
  644   "BLD",1015 3,"REQB"," B","PRCA*4 .5*309",6)
  645  
  646   "FIA",433)
  647   AR TRANSAC TION
  648   "FIA",433, 0)
  649   ^PRCA(433,
  650   "FIA",433, 0,0)
  651   433NI
  652   "FIA",433, 0,1)
  653   y^n^p^^^^n ^^n
  654   "FIA",433, 0,10)
  655  
  656   "FIA",433, 0,11)
  657  
  658   "FIA",433, 0,"RLRO")
  659  
  660   "FIA",433, 0,"VR")
  661   4.5^PRCA
  662   "FIA",433, 433)
  663   1
  664   "FIA",433, 433,94)
  665  
  666   "FIA",433, 433,95)
  667  
  668   "FIA",433, 433,96)
  669  
  670   "FIA",433, 433,97)
  671  
  672   "INIT")
  673   EN^PRCA307 P
  674   "IX",433,4 33,"TACD", 0)
  675   433^TACD^T he date th at this tr ansaction  was correc ted by the  Auto-Corr ection Pr
  676   ogram.^R^^ F^IR^I^433 ^^^^^LS
  677   "IX",433,4 33,"TACD", .1,0)
  678   ^^2^2^3160 920^
  679   "IX",433,4 33,"TACD", .1,1,0)
  680   The is the  date that  the Patie nt Stateme nt Auto-Co rrection P rogram
  681   "IX",433,4 33,"TACD", .1,2,0)
  682   corrected  the statem ent discre pancy for  this trans action.
  683   "IX",433,4 33,"TACD", 1)
  684   S ^PRCA(43 3,"TACD",$ E(X,1,7),D A)=""
  685   "IX",433,4 33,"TACD", 2)
  686   K ^PRCA(43 3,"TACD",$ E(X,1,7),D A)
  687   "IX",433,4 33,"TACD", 2.5)
  688   K ^PRCA(43 3,"TACD")
  689   "IX",433,4 33,"TACD", 11.1,0)
  690   ^.114IA^1^ 1
  691   "IX",433,4 33,"TACD", 11.1,1,0)
  692   1^F^433^94 ^7^1^F
  693   "IX",433,4 33,"TACD", "NOREINDEX ")
  694   1
  695   "KRN",.402 ,830,-1)
  696   0^1
  697   "KRN",.402 ,830,0)
  698   PRCA RE-ES TABLISH WR ITE-OFF^31 60222.1339 ^^433^^^31 61118
  699   "KRN",.402 ,830,"DR", 1,433)
  700   .03////^S  X=PRCABN;6 ////^S X=$ S($D(PRCA( "SEG")):PR CA("SEG"), 1:"");12// //^S X=PR
  701   CATYPE;11/ ///^S X=DT ;15////^S  X=$S($D(PR CATAMT):PR CATAMT,1:0 );81////^S  X=$S($D(
  702   PRCAPB):+P RCAPB,1:0) ;82////^S  X=$S($D(PR CAPB):$P(P RCAPB,"^", 2),1:0);
  703   "KRN",.402 ,830,"DR", 1,433,1)
  704   83////^S X =$S($D(PRC APB):$P(PR CAPB,"^",3 ),1:0);84/ ///^S X=$S ($D(PRCAPB ):$P(PRCA
  705   PB,"^",4), 1:0);85/// /^S X=$S($ D(PRCAPB): $P(PRCAPB, "^",5),1:0 );42////^S  X=DUZ;41
  706   ;
  707   "KRN",3.8, 327,-1)
  708   0^1
  709   "KRN",3.8, 327,0)
  710   PRCACPS^PU ^^^^^
  711   "KRN",3.8, 327,2,0)
  712   ^3.801^2^2 ^3160406^^ ^
  713   "KRN",3.8, 327,2,1,0)
  714   This mail  group will  receive a  notificat ion when t he Consoli dated
  715   "KRN",3.8, 327,2,2,0)
  716   Patient St atement Au to-Correct ion progra m has comp leted.
  717   "KRN",3.8, 327,3)
  718  
  719   "KRN",19,3 126,-1)
  720   2^3
  721   "KRN",19,3 126,0)
  722   PRCA ACCOU NT MANAGEM ENT^Accoun t Manageme nt^^M^1^^^ ^^^^53
  723   "KRN",19,3 126,10,0)
  724   ^19.01PI^1 7^17
  725   "KRN",19,3 126,10,16, 0)
  726   11664^^4
  727   "KRN",19,3 126,10,16, "^")
  728   PRCA AUTOC RCT PGM
  729   "KRN",19,3 126,10,17, 0)
  730   11665^^3
  731   "KRN",19,3 126,10,17, "^")
  732   PRCA AUTOC RCT RPT
  733   "KRN",19,3 126,"U")
  734   ACCOUNT MA NAGEMENT
  735   "KRN",19,1 1664,-1)
  736   0^1
  737   "KRN",19,1 1664,0)
  738   PRCA AUTOC RCT PGM^Pa tient Stat ement Auto -Correctio n Program^ ^R^^PRCA A UTOCRCT P
  739   GM^^^^^^
  740   "KRN",19,1 1664,1,0)
  741   ^19.06^2^2 ^3160304^^
  742   "KRN",19,1 1664,1,1,0 )
  743   This optio n runs the  Auto-Corr ection pro gram for P atient Sta tement
  744   "KRN",19,1 1664,1,2,0 )
  745   discrepanc ies.
  746   "KRN",19,1 1664,25)
  747   BEGIN^PRCA CPS
  748   "KRN",19,1 1664,"U")
  749   PATIENT ST ATEMENT AU TO-CORRECT
  750   "KRN",19,1 1665,-1)
  751   0^2
  752   "KRN",19,1 1665,0)
  753   PRCA AUTOC RCT RPT^Au to-Correct  Patient D iscrepancy  Report^^R ^^^^^^^^
  754   "KRN",19,1 1665,1,0)
  755   ^19.06^3^3 ^3161012^^ ^^
  756   "KRN",19,1 1665,1,1,0 )
  757   This optio n runs the  Auto-Corr ection Pat ient Discr epancy Rep ort
  758   "KRN",19,1 1665,1,2,0 )
  759   for correc tions made  by the Pa tient Stat ement Auto -Correctio n
  760   "KRN",19,1 1665,1,3,0 )
  761   Program.
  762   "KRN",19,1 1665,25)
  763   PSACRT^PRC AACR
  764   "KRN",19,1 1665,"U")
  765   AUTO-CORRE CT PATIENT  DISCREPAN
  766   "KRN",19,1 1666,-1)
  767   0^4
  768   "KRN",19,1 1666,0)
  769   PRCA AUTOC RCT PGM QU EUED^Patie nt Stateme nt Auto-Co rrection P rogram Que ued^^R^^P
  770   RCA AUTOCR CT PGM^^^^ ^^
  771   "KRN",19,1 1666,1,0)
  772   ^^2^2^3161 017^
  773   "KRN",19,1 1666,1,1,0 )
  774   This optio n supports  the entry  point for  the Queue ing of the
  775   "KRN",19,1 1666,1,2,0 )
  776   Auto-Corre ction prog ram for Pa tient Stat ement disc repancies.
  777   "KRN",19,1 1666,25)
  778   START^PRCA CPS
  779   "KRN",19,1 1666,"U")
  780   PATIENT ST ATEMENT AU TO-CORRECT
  781   "KRN",19.1 ,602,-1)
  782   0^1
  783   "KRN",19.1 ,602,0)
  784   PRCA AUTOC RCT PGM
  785   "KRN",19.1 ,602,1,0)
  786   ^19.11^3^3 ^3160418^^ ^
  787   "KRN",19.1 ,602,1,1,0 )
  788   This is a  key for th e AR optio n 'PRCA AU TOCRCT PGM '.
  789   "KRN",19.1 ,602,1,2,0 )
  790   The 'PRCA  AUTOCRCT P GM' option  runs the  Consolidat ed
  791   "KRN",19.1 ,602,1,3,0 )
  792   Patient St atement Au to-Correct ion progra m.
  793   "MBREQ")
  794   0
  795   "ORD",3,19 .1)
  796   19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
  797   "ORD",3,19 .1,0)
  798   SECURITY K EY
  799   "ORD",7,.4 02)
  800   .402;7;;;E DEOUT^DIFR OMSO(.402, DA,"",XPDA );FPRE^DIF ROMSI(.402 ,"",XPDA); EPRE^DIFR
  801   OMSI(.402, DA,$E("N", $G(XPDNEW) ),XPDA,"", OLDA);;EPO ST^DIFROMS I(.402,DA, "",XPDA);
  802   DEL^DIFROM SK(.402,"" ,%)
  803   "ORD",7,.4 02,0)
  804   INPUT TEMP LATE
  805   "ORD",11,3 .8)
  806   3.8;11;;;M AILG^XPDTA 1;MAILGF1^ XPDIA1;MAI LGE1^XPDIA 1;MAILGF2^ XPDIA1;;MA ILGDEL^XP
  807   DIA1(%)
  808   "ORD",11,3 .8,0)
  809   MAIL GROUP
  810   "ORD",18,1 9)
  811   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  812   "ORD",18,1 9,0)
  813   OPTION
  814   "PKG",53,- 1)
  815   1^1
  816   "PKG",53,0 )
  817   ACCOUNTS R ECEIVABLE^ PRCA^FMS
  818   "PKG",53,2 0,0)
  819   ^9.402P^1^ 1
  820   "PKG",53,2 0,1,0)
  821   2^^PRCAMRG
  822   "PKG",53,2 0,1,1)
  823  
  824   "PKG",53,2 0,"B",2,1)
  825  
  826   "PKG",53,2 2,0)
  827   ^9.49I^1^1
  828   "PKG",53,2 2,1,0)
  829   4.5^305111 9^2960627
  830   "PKG",53,2 2,1,"PAH", 1,0)
  831   307^316121 9^87
  832   "PKG",53,2 2,1,"PAH", 1,1,0)
  833   ^^1^1^3161 219
  834   "PKG",53,2 2,1,"PAH", 1,1,1,0)
  835   Consolidat ed Patient  Statement
  836   "QUES","XP F1",0)
  837   Y
  838   "QUES","XP F1","??")
  839   ^D REP^XPD H
  840   "QUES","XP F1","A")
  841   Shall I wr ite over y our |FLAG|  File
  842   "QUES","XP F1","B")
  843   YES
  844   "QUES","XP F1","M")
  845   D XPF1^XPD IQ
  846   "QUES","XP F2",0)
  847   Y
  848   "QUES","XP F2","??")
  849   ^D DTA^XPD H
  850   "QUES","XP F2","A")
  851   Want my da ta |FLAG|  yours
  852   "QUES","XP F2","B")
  853   YES
  854   "QUES","XP F2","M")
  855   D XPF2^XPD IQ
  856   "QUES","XP I1",0)
  857   YO
  858   "QUES","XP I1","??")
  859   ^D INHIBIT ^XPDH
  860   "QUES","XP I1","A")
  861   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  862   "QUES","XP I1","B")
  863   NO
  864   "QUES","XP I1","M")
  865   D XPI1^XPD IQ
  866   "QUES","XP M1",0)
  867   PO^VA(200, :EM
  868   "QUES","XP M1","??")
  869   ^D MG^XPDH
  870   "QUES","XP M1","A")
  871   Enter the  Coordinato r for Mail  Group '|F LAG|'
  872   "QUES","XP M1","B")
  873  
  874   "QUES","XP M1","M")
  875   D XPM1^XPD IQ
  876   "QUES","XP O1",0)
  877   Y
  878   "QUES","XP O1","??")
  879   ^D MENU^XP DH
  880   "QUES","XP O1","A")
  881   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  882   "QUES","XP O1","B")
  883   YES
  884   "QUES","XP O1","M")
  885   D XPO1^XPD IQ
  886   "QUES","XP Z1",0)
  887   Y
  888   "QUES","XP Z1","??")
  889   ^D OPT^XPD H
  890   "QUES","XP Z1","A")
  891   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  892   "QUES","XP Z1","B")
  893   NO
  894   "QUES","XP Z1","M")
  895   D XPZ1^XPD IQ
  896   "QUES","XP Z2",0)
  897   Y
  898   "QUES","XP Z2","??")
  899   ^D RTN^XPD H
  900   "QUES","XP Z2","A")
  901   Want to MO VE routine s to other  CPUs
  902   "QUES","XP Z2","B")
  903   NO
  904   "QUES","XP Z2","M")
  905   D XPZ2^XPD IQ
  906   "RTN")
  907   9
  908   "RTN","PRC A307P")
  909   0^2^B63586 34^n/a
  910   "RTN","PRC A307P",1,0 )
  911   PRCA307P ; ALB/BDB -  PATCH PRCA *4.5*307 P OST-INSTAL L ROUTINE  ; 11/2/15  4:15pm
  912   "RTN","PRC A307P",2,0 )
  913    ;;4.5;Acc ounts Rece ivable;**3 07**;Mar 2 0, 1995;Bu ild 72
  914   "RTN","PRC A307P",3,0 )
  915    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  916   "RTN","PRC A307P",4,0 )
  917    ; This ro utine will  update a  specific l ist of Sta tion ID's
  918   "RTN","PRC A307P",5,0 )
  919    ; and que ues the Pa tient Stat ement Auto -Correctio n Program
  920   "RTN","PRC A307P",6,0 )
  921    ;
  922   "RTN","PRC A307P",7,0 )
  923    Q
  924   "RTN","PRC A307P",8,0 )
  925   EN ;Entry  point for  PRCA*4.5*3 07 post-in stall
  926   "RTN","PRC A307P",9,0 )
  927    N SDAY,SI TE,T
  928   "RTN","PRC A307P",10, 0)
  929    S SITE=$$ SITE^RCMSI TE
  930   "RTN","PRC A307P",11, 0)
  931    I SITE=0  D
  932   "RTN","PRC A307P",12, 0)
  933    .D MES^XP DUTL(" ")
  934   "RTN","PRC A307P",13, 0)
  935    .D BMES^X PDUTL(">>>  WARNING!  STATION ID  NOT FOUND !")
  936   "RTN","PRC A307P",14, 0)
  937    .D MES^XP DUTL(">>>  THE PATIEN T STATEMEN T TRANSMIS SION DATE  WILL NOT B E UPDATED
  938   ")
  939   "RTN","PRC A307P",15, 0)
  940    .D MES^XP DUTL(" ")
  941   "RTN","PRC A307P",16, 0)
  942    I SITE'=0 ,$T(@SITE)  D
  943   "RTN","PRC A307P",17, 0)
  944    .D MES^XP DUTL(" ")
  945   "RTN","PRC A307P",18, 0)
  946    .D BMES^X PDUTL(">>>  STATION I D "_SITE_"  MATCH FOU ND!")
  947   "RTN","PRC A307P",19, 0)
  948    .D MES^XP DUTL(">>>  THE PATIEN T STATEMEN T TRANSMIS SION DATE  WILL BE UP DATED")
  949   "RTN","PRC A307P",20, 0)
  950    .D MES^XP DUTL(" ")
  951   "RTN","PRC A307P",21, 0)
  952    .;set pat ient state ment day t o site sta tement day
  953   "RTN","PRC A307P",22, 0)
  954    .S T=$T(@ SITE),SDAY =+$P(T,";; ",2)
  955   "RTN","PRC A307P",23, 0)
  956    .S $P(^RC (342,1,0), "^",11)=SD AY
  957   "RTN","PRC A307P",24, 0)
  958    .S DEB=0  F  S DEB=$ O(^RCD(340 ,"AB","DPT (",DEB)) Q :'DEB  I $ D(^RCD(340 ,+DEB,0))
  959    D
  960   "RTN","PRC A307P",25, 0)
  961    ..S STDT= $P($G(^RCD (340,+DEB, 0)),"^",3)  Q:'STDT
  962   "RTN","PRC A307P",26, 0)
  963    ..S SSTDT =$P($G(^RC (342,1,0)) ,"^",11)
  964   "RTN","PRC A307P",27, 0)
  965    ..Q:(SSTD T=STDT)
  966   "RTN","PRC A307P",28, 0)
  967    ..K ^RCD( 340,"AC",S TDT,+DEB)
  968   "RTN","PRC A307P",29, 0)
  969    ..S $P(^R CD(340,+DE B,0),"^",3 )=SSTDT
  970   "RTN","PRC A307P",30, 0)
  971    ..S ^RCD( 340,"AC",S STDT,DEB)= ""
  972   "RTN","PRC A307P",31, 0)
  973    K SDAY,SI TE,DEB,STD T,SSTDT,T
  974   "RTN","PRC A307P",32, 0)
  975    ;
  976   "RTN","PRC A307P",33, 0)
  977    N ZTDTH,Z TIO,ZTDESC ,ZTRTN,ZTS K
  978   "RTN","PRC A307P",34, 0)
  979    S ZTDESC= "Auto-Corr ect Patien t Statemen t Discrepa ncies"
  980   "RTN","PRC A307P",35, 0)
  981    S ZTRTN=" START^PRCA CPS",ZTDTH =$H,ZTIO=" "
  982   "RTN","PRC A307P",36, 0)
  983    D ^%ZTLOA D
  984   "RTN","PRC A307P",37, 0)
  985    I $G(ZTSK ) D  Q
  986   "RTN","PRC A307P",38, 0)
  987    .D BMES^X PDUTL(">>> POST-INSTA LL CONSOLI DATED PATI ENT STATEM ENT AUTO-C ORRECTION
  988   ")
  989   "RTN","PRC A307P",39, 0)
  990    .D MES^XP DUTL(">>>P ROGRAM HAS  BEEN QUEU ED IN TASK  "_ZTSK)
  991   "RTN","PRC A307P",40, 0)
  992    I '$G(ZTS K) D  Q
  993   "RTN","PRC A307P",41, 0)
  994    .D BMES^X PDUTL(">>> ERROR: POS T-INSTALL  CONSOLIDAT ED PATIENT  STATEMENT  AUTO-COR
  995   RECTION")
  996   "RTN","PRC A307P",42, 0)
  997    .D MES^XP DUTL(">>>P ROGRAM COU LD NOT BE  QUEUED")
  998   "RTN","PRC A307P",43, 0)
  999    ;
  1000   "RTN","PRC A307P",44, 0)
  1001    ;Stations  that will  have mont hly statem ent build  date chang ed
  1002   "RTN","PRC A307P",45, 0)
  1003   438 ;;21^S IOUX FALLS ,SD
  1004   "RTN","PRC A307P",46, 0)
  1005   501 ;;21^A LBUQUERQUE ,NM
  1006   "RTN","PRC A307P",47, 0)
  1007   504 ;;21^A MARILLO,TX
  1008   "RTN","PRC A307P",48, 0)
  1009   542 ;;21^C OATESVILLE ,PA
  1010   "RTN","PRC A307P",49, 0)
  1011   562 ;;21^E RIE,PA
  1012   "RTN","PRC A307P",50, 0)
  1013   568 ;;21^F ORT MEADE, SD
  1014   "RTN","PRC A307P",51, 0)
  1015   649 ;;21^P RESCOTT,AZ
  1016   "RTN","PRC A307P",52, 0)
  1017   656 ;;21^S T. CLOUD,M N
  1018   "RTN","PRC A307P",53, 0)
  1019   688 ;;21^W ASHINGTON, DC
  1020   "RTN","PRC A307P",54, 0)
  1021   756 ;;21^E L PASO,TX
  1022   "RTN","PRC A307P",55, 0)
  1023   565 ;;22^F AYETTEVILL E,NC
  1024   "RTN","PRC A307P",56, 0)
  1025   621 ;;22^M OUNTAIN HO ME,TN
  1026   "RTN","PRC A307P",57, 0)
  1027   658 ;;22^S ALEM,VA
  1028   "RTN","PRC A307P",58, 0)
  1029   664 ;;22^S AN DIEGO,C A
  1030   "RTN","PRC A307P",59, 0)
  1031   671 ;;22^S AN ANTONIO ,TX
  1032   "RTN","PRC A307P",60, 0)
  1033   689 ;;22^W EST HAVEN, CT
  1034   "RTN","PRC A307P",61, 0)
  1035   740 ;;22^T EXAS VALLE Y COASTAL, TX
  1036   "RTN","PRC AACR")
  1037   0^7^B97009 305^n/a
  1038   "RTN","PRC AACR",1,0)
  1039   PRCAACR ;A LBANY/BDB- PATIENT ST ATEMENTS A UTO-CORREC TION REPOR T ;09/21/1 5 3:34 PM
  1040   "RTN","PRC AACR",2,0)
  1041    ;;4.5;Acc ounts Rece ivable;**3 07**;Mar 2 0, 1995;Bu ild 72
  1042   "RTN","PRC AACR",3,0)
  1043    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  1044   "RTN","PRC AACR",4,0)
  1045    ;
  1046   "RTN","PRC AACR",5,0)
  1047    Q
  1048   "RTN","PRC AACR",6,0)
  1049    ;
  1050   "RTN","PRC AACR",7,0)
  1051   PSACRT ; r eport, pri nts sorted  individua l transact ions that  have been  auto-corr
  1052   ected
  1053   "RTN","PRC AACR",8,0)
  1054    N DIC,PAG E,BY,DHD,F ILENUM,FLD S,FR,L,TO, PRCABDT,PR CAEDT,PRCA SORT
  1055   "RTN","PRC AACR",9,0)
  1056    W !
  1057   "RTN","PRC AACR",10,0 )
  1058   PSDATE ;
  1059   "RTN","PRC AACR",11,0 )
  1060    ; Determi ne if Auto  Correct p rocess is  currently  running
  1061   "RTN","PRC AACR",12,0 )
  1062    N PRCASTR T,QUIT,X,X 1,X2,Y
  1063   "RTN","PRC AACR",13,0 )
  1064    S PRCASTR T=$G(^XTMP ("PRCACPS" ,0)),QUIT= ""
  1065   "RTN","PRC AACR",14,0 )
  1066    ; QUIT if  Auto Corr ect proces s is curre ntly runni ng
  1067   "RTN","PRC AACR",15,0 )
  1068    I PRCASTR T'="" D  Q :QUIT
  1069   "RTN","PRC AACR",16,0 )
  1070    .S Y=$P(P RCASTRT,U, 2)
  1071   "RTN","PRC AACR",17,0 )
  1072    .D DD^%DT
  1073   "RTN","PRC AACR",18,0 )
  1074    .S PRCAST RT=Y
  1075   "RTN","PRC AACR",19,0 )
  1076    .W !!,"Th e Patient  Statement  Auto-Corre ction Prog ram is cur rently run ning."
  1077   "RTN","PRC AACR",20,0 )
  1078    .W !,"It  was starte d at ",PRC ASTRT," an d can take  up to 1 h our to com plete."
  1079   "RTN","PRC AACR",21,0 )
  1080    .W !!,"If  you choos e to conti nue with t his report , it may n ot reflect  all of t
  1081   he"
  1082   "RTN","PRC AACR",22,0 )
  1083    .W !,"cha nges from  this lates t run of t he Patient  Statement  Auto-Corr ection Pr
  1084   ogram."
  1085   "RTN","PRC AACR",23,0 )
  1086    .W !
  1087   "RTN","PRC AACR",24,0 )
  1088    .S DIR(0) ="Y",DIR(" A")="Do yo u want to  continue", DIR("B")=" NO"
  1089   "RTN","PRC AACR",25,0 )
  1090    .D ^DIR
  1091   "RTN","PRC AACR",26,0 )
  1092    .W !
  1093   "RTN","PRC AACR",27,0 )
  1094    .; Quit i f ^, ^^, T imeout or  No
  1095   "RTN","PRC AACR",28,0 )
  1096    .I $D(DTO UT)!($D(DU OUT))!($D( DIROUT))!( Y=0) S QUI T=1
  1097   "RTN","PRC AACR",29,0 )
  1098    .; Send M ailMan mes sage to PR CACPS mail  group if  Yes
  1099   "RTN","PRC AACR",30,0 )
  1100    .I Y=1 D  PRCAMAIL^P RCACPS(PRC ASTRT)
  1101   "RTN","PRC AACR",31,0 )
  1102    .K DTOUT, DUOUT,DIRO UT
  1103   "RTN","PRC AACR",32,0 )
  1104    ;
  1105   "RTN","PRC AACR",33,0 )
  1106    N DIROUT, DIS,DTOUT, DUOUT
  1107   "RTN","PRC AACR",34,0 )
  1108    S DIR("A" )="Date Ra nge: FROM:  ",DIR("B" )="T-7"
  1109   "RTN","PRC AACR",35,0 )
  1110    S DIR("?" )="The def ault date  is T-7.  F uture date s may not  be entered ."
  1111   "RTN","PRC AACR",36,0 )
  1112    S DIR(0)= "DO" D ^DI R
  1113   "RTN","PRC AACR",37,0 )
  1114    S:Y'="" P RCABDT=Y
  1115   "RTN","PRC AACR",38,0 )
  1116    I $D(DIRU T)&'Y K DI RUT Q
  1117   "RTN","PRC AACR",39,0 )
  1118    I PRCABDT >DT G PSDA TE
  1119   "RTN","PRC AACR",40,0 )
  1120    W "(",Y(0 ),")"
  1121   "RTN","PRC AACR",41,0 )
  1122    K DIR,X,Y
  1123   "RTN","PRC AACR",42,0 )
  1124    S DIR(0)= "DO"
  1125   "RTN","PRC AACR",43,0 )
  1126    S DIR("A" )="Date Ra nge:   TO:  ",DIR("B" )="T"
  1127   "RTN","PRC AACR",44,0 )
  1128    S DIR("?" )="The def ault date  is T, but  any date m ay be ente red."
  1129   "RTN","PRC AACR",45,0 )
  1130    D ^DIR S: Y="" Y=DT
  1131   "RTN","PRC AACR",46,0 )
  1132    I $D(DIRU T)&'Y K DI RUT Q
  1133   "RTN","PRC AACR",47,0 )
  1134    W "(",Y(0 ),")"
  1135   "RTN","PRC AACR",48,0 )
  1136    S PRCAEDT =Y
  1137   "RTN","PRC AACR",49,0 )
  1138    I PRCABDT >PRCAEDT G  PSDATE
  1139   "RTN","PRC AACR",50,0 )
  1140    K DIR
  1141   "RTN","PRC AACR",51,0 )
  1142    S DIR(0)= "S^1:Bill  Number;2:D ebtor Name ;3:Auto-Co rrect Date ;4:Transac tion Numb
  1143   er",DIR("A ")="Sort b y"
  1144   "RTN","PRC AACR",52,0 )
  1145    D ^DIR K  DIR
  1146   "RTN","PRC AACR",53,0 )
  1147    S PRCASOR T=Y
  1148   "RTN","PRC AACR",54,0 )
  1149    Q:$D(DTOU T)!($D(DUO UT))!($D(D IROUT))
  1150   "RTN","PRC AACR",55,0 )
  1151    ;
  1152   "RTN","PRC AACR",56,0 )
  1153    ; Prompt  for device
  1154   "RTN","PRC AACR",57,0 )
  1155    W !
  1156   "RTN","PRC AACR",58,0 )
  1157    N ZTRTN,Z TDESC,ZTSA VE
  1158   "RTN","PRC AACR",59,0 )
  1159    S %ZIS="Q "
  1160   "RTN","PRC AACR",60,0 )
  1161    D ^%ZIS Q :POP
  1162   "RTN","PRC AACR",61,0 )
  1163    I $D(IO(" Q")) D  Q
  1164   "RTN","PRC AACR",62,0 )
  1165    .I $G(IOS T)["P-MES"  S ZTRTN=" PRT^PRCAAC R1"
  1166   "RTN","PRC AACR",63,0 )
  1167    .I $G(IOS T)'["P-MES " S ZTRTN= "PRT^PRCAA CR"
  1168   "RTN","PRC AACR",64,0 )
  1169    .S ZTSAVE ("PRCABDT" )="",ZTSAV E("PRCAEDT ")="",ZTSA VE("PRCASO RT")=""
  1170   "RTN","PRC AACR",65,0 )
  1171    .D ^%ZTLO AD
  1172   "RTN","PRC AACR",66,0 )
  1173    .D ^%ZISC
  1174   "RTN","PRC AACR",67,0 )
  1175    .K IO("Q" ),POP
  1176   "RTN","PRC AACR",68,0 )
  1177    ;
  1178   "RTN","PRC AACR",69,0 )
  1179    ;Print Re port if no t QUEUED
  1180   "RTN","PRC AACR",70,0 )
  1181   PRT ;
  1182   "RTN","PRC AACR",71,0 )
  1183    ; If not  queued and  output se nt to P-ME S
  1184   "RTN","PRC AACR",72,0 )
  1185    I $G(IOST )["P-MES"  D PRT^PRCA ACR1 Q
  1186   "RTN","PRC AACR",73,0 )
  1187    ;If not q ueued and  output not  sent to P -MES
  1188   "RTN","PRC AACR",74,0 )
  1189    U IO
  1190   "RTN","PRC AACR",75,0 )
  1191    K ^TMP("P RCAACR",$J )
  1192   "RTN","PRC AACR",76,0 )
  1193    S PAGE=0
  1194   "RTN","PRC AACR",77,0 )
  1195    S DASH="" ,$P(DASH," -",79)=""
  1196   "RTN","PRC AACR",78,0 )
  1197    S DIS(0)= "I $D(^PRC A(433,""TA CD"",PRCAT SRT,D0))", L=0
  1198   "RTN","PRC AACR",79,0 )
  1199    N PRCATSR T,PRCATN,P RCAACD,PRC AACR,PRCAB N,PRCADATA ,PRCADTR,P RCASSN,PRC AACTF,PRC
  1200   ATNTF
  1201   "RTN","PRC AACR",80,0 )
  1202    S PRCATSR T=PRCABDT- .00001
  1203   "RTN","PRC AACR",81,0 )
  1204    ; Loop th rough the  specified  date range
  1205   "RTN","PRC AACR",82,0 )
  1206    F  S PRCA TSRT=$O(^P RCA(433,"T ACD",PRCAT SRT)) Q:PR CATSRT=""! (PRCATSRT> PRCAEDT) 
  1207    D
  1208   "RTN","PRC AACR",83,0 )
  1209    .S PRCATN =""
  1210   "RTN","PRC AACR",84,0 )
  1211    .; Loop t hrough the  transacti ons for th e current  date
  1212   "RTN","PRC AACR",85,0 )
  1213    .F  S PRC ATN=$O(^PR CA(433,"TA CD",PRCATS RT,PRCATN) ) Q:'PRCAT N  D
  1214   "RTN","PRC AACR",86,0 )
  1215    ..; Load  associated  data fiel ds for rep ort
  1216   "RTN","PRC AACR",87,0 )
  1217    ..S PRCAT NTF=PRCATN  ; Transac tion Numbe r Ticket F lag
  1218   "RTN","PRC AACR",88,0 )
  1219    ..S PRCAB N=$P(^PRCA (433,PRCAT N,0),U,2)
  1220   "RTN","PRC AACR",89,0 )
  1221    ..S PRCAD TR=$$GET1^ DIQ(430,PR CABN_",",9 ) ; (#9) D EBTOR
  1222   "RTN","PRC AACR",90,0 )
  1223    ..S PRCAS SN=$G(^PRC A(430,PRCA BN,0)) ; L oad 0 Node
  1224   "RTN","PRC AACR",91,0 )
  1225    ..S PRCAS SN=$P(PRCA SSN,U,9) ;  get IEN o f Debtor
  1226   "RTN","PRC AACR",92,0 )
  1227    ..S PRCAB N=$$GET1^D IQ(433,PRC ATN_",",.0 3) ; (#.03 ) BILL NUM BER
  1228   "RTN","PRC AACR",93,0 )
  1229    ..S PRCAS SN=$$GET1^ DIQ(340,PR CASSN_",", 110) ; SSN
  1230   "RTN","PRC AACR",94,0 )
  1231    ..S PRCAA CD=$$GET1^ DIQ(433,PR CATN_",",9 4,"I") ;(# 94) AUTO-C ORRECTION  DATE
  1232   "RTN","PRC AACR",95,0 )
  1233    ..S PRCAA CR=$$GET1^ DIQ(433,PR CATN_",",9 6) ;(#96)  AUTO-CORRE CTION TYPE  OF ERROR
  1234   "RTN","PRC AACR",96,0 )
  1235    ..S PRCAA CR=$E(PRCA ACR,1,14)
  1236   "RTN","PRC AACR",97,0 )
  1237    ..S PRCAA CTF=$$GET1 ^DIQ(433,P RCATN_",", 97) ;(#97) AUTO-CORRE CTION TICK ET FLAG
  1238   "RTN","PRC AACR",98,0 )
  1239    ..; If Ti cket Flag  is set, re set Transa ction Numb er to null
  1240   "RTN","PRC AACR",99,0 )
  1241    ..I PRCAA CTF="YES"  S PRCATNTF =""
  1242   "RTN","PRC AACR",100, 0)
  1243    ..;
  1244   "RTN","PRC AACR",101, 0)
  1245    ..; Store  in ^TMP s orted by B ill Number , Debtor a nd Transac tion #
  1246   "RTN","PRC AACR",102, 0)
  1247    ..I PRCAS ORT=1 D  Q
  1248   "RTN","PRC AACR",103, 0)
  1249    ...S ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRCA SSN_U_PRC
  1250   ATNTF_U_PR CAACD_U_PR CAACR
  1251   "RTN","PRC AACR",104, 0)
  1252    ..;
  1253   "RTN","PRC AACR",105, 0)
  1254    ..; Store  in ^TMP s orted by D ebtor, Bil l Number a nd Transac tion #
  1255   "RTN","PRC AACR",106, 0)
  1256    ..I PRCAS ORT=2 D  Q
  1257   "RTN","PRC AACR",107, 0)
  1258    ...S ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRCA SSN_U_PRC
  1259   ATNTF_U_PR CAACD_U_PR CAACR
  1260   "RTN","PRC AACR",108, 0)
  1261    ..;
  1262   "RTN","PRC AACR",109, 0)
  1263    ..; Store  in ^TMP s orted by A uto-Correc t Date, De btor, Bill  Number an d Transac
  1264   tion #
  1265   "RTN","PRC AACR",110, 0)
  1266    ..I PRCAS ORT=3 D  Q
  1267   "RTN","PRC AACR",111, 0)
  1268    ...S ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCAD TR_U_PRCA
  1269   BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
  1270   "RTN","PRC AACR",112, 0)
  1271    ..; Store  in ^TMP s orted by B ill Number , Debtor a nd Transac tion #
  1272   "RTN","PRC AACR",113, 0)
  1273    ..;
  1274   "RTN","PRC AACR",114, 0)
  1275    ..; Store  in ^TMP s orted by T ransaction , Debtor a nd #Bill N umber
  1276   "RTN","PRC AACR",115, 0)
  1277    ..I PRCAS ORT=4 D  Q
  1278   "RTN","PRC AACR",116, 0)
  1279    ...S ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_PR CABN_U_PR
  1280   CASSN_U_PR CAACD_U_PR CAACR
  1281   "RTN","PRC AACR",117, 0)
  1282    ..; Store  in ^TMP s orted by B ill Number , Debtor a nd Transac tion #
  1283   "RTN","PRC AACR",118, 0)
  1284    ;
  1285   "RTN","PRC AACR",119, 0)
  1286    ; Display  Auto-Corr ect data s orted by B ill Number
  1287   "RTN","PRC AACR",120, 0)
  1288    N QUIT ;  QUIT befor e end of r eport
  1289   "RTN","PRC AACR",121, 0)
  1290    S QUIT=""
  1291   "RTN","PRC AACR",122, 0)
  1292    I PRCASOR T=1 D
  1293   "RTN","PRC AACR",123, 0)
  1294    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRC
  1295   ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
  1296   "RTN","PRC AACR",124, 0)
  1297    .; Displa y Bill Num ber header
  1298   "RTN","PRC AACR",125, 0)
  1299    .D PSACRT P1
  1300   "RTN","PRC AACR",126, 0)
  1301    .S PRCABN =""
  1302   "RTN","PRC AACR",127, 0)
  1303    .F  S PRC ABN=$O(^TM P("PRCAACR ",$J,PRCAB N)) Q:'PRC ABN  D  Q: QUIT
  1304   "RTN","PRC AACR",128, 0)
  1305    ..S PRCAD TR=""
  1306   "RTN","PRC AACR",129, 0)
  1307    ..F  S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R)) Q:PRCA DTR=""  D   Q:QUIT
  1308   "RTN","PRC AACR",130, 0)
  1309    ...S PRCA TN=""
  1310   "RTN","PRC AACR",131, 0)
  1311    ...F  S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R,PRCATN))  Q:'PRCATN   D  Q:QU
  1312   IT
  1313   "RTN","PRC AACR",132, 0)
  1314    ....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)
  1315   "RTN","PRC AACR",133, 0)
  1316    ....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
  1317   "RTN","PRC AACR",134, 0)
  1318    ....W !,$ J($P(PRCAD ATA,U,1),1 1),?13,$E( $P(PRCADAT A,U,2),1,1 8),?33,$E( $P(PRCADA
  1319   TA,U,3),6, 9),?39,$J( $P(PRCADAT A,U,4),9), ?50,$P(PRC ADATA,U,5) ,?64,$P(PR CADATA,U,
  1320   6)
  1321   "RTN","PRC AACR",135, 0)
  1322    ....I $Y> (IOSL-3) D
  1323   "RTN","PRC AACR",136, 0)
  1324    .....I $E (IOST,1,2) ="C-" D  Q :QUIT
  1325   "RTN","PRC AACR",137, 0)
  1326    ......D P RTC
  1327   "RTN","PRC AACR",138, 0)
  1328    ......I $ D(DIRUT)!( $D(DTOUT))  S QUIT=1
  1329   "RTN","PRC AACR",139, 0)
  1330    .....D PS ACRTP1
  1331   "RTN","PRC AACR",140, 0)
  1332    ;
  1333   "RTN","PRC AACR",141, 0)
  1334    ; Display  Auto-Corr ect data s orted Debt or
  1335   "RTN","PRC AACR",142, 0)
  1336    I PRCASOR T=2 D
  1337   "RTN","PRC AACR",143, 0)
  1338    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRC
  1339   ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
  1340   "RTN","PRC AACR",144, 0)
  1341    .; Displa y Debtor h eader
  1342   "RTN","PRC AACR",145, 0)
  1343    .D PSACRT P2
  1344   "RTN","PRC AACR",146, 0)
  1345    .S PRCADT R=""
  1346   "RTN","PRC AACR",147, 0)
  1347    .F  S PRC ADTR=$O(^T MP("PRCAAC R",$J,PRCA DTR)) Q:PR CADTR=""   D  Q:QUIT
  1348   "RTN","PRC AACR",148, 0)
  1349    ..S PRCAB N=""
  1350   "RTN","PRC AACR",149, 0)
  1351    ..F  S PR CABN=$O(^T MP("PRCAAC R",$J,PRCA DTR,PRCABN )) Q:'PRCA BN  D  Q:Q UIT
  1352   "RTN","PRC AACR",150, 0)
  1353    ...S PRCA TN=""
  1354   "RTN","PRC AACR",151, 0)
  1355    ...F  S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ADTR,PRCAB N,PRCATN))  Q:'PRCATN   D  Q:QU
  1356   IT
  1357   "RTN","PRC AACR",152, 0)
  1358    ....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)
  1359   "RTN","PRC AACR",153, 0)
  1360    ....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
  1361   "RTN","PRC AACR",154, 0)
  1362    ....W !,$ E($P(PRCAD ATA,U,1),1 ,18),?20,$ J($P(PRCAD ATA,U,2),1 1),?33,$E( $P(PRCADA
  1363   TA,U,3),6, 9),?39,$J( $P(PRCADAT A,U,4),9), ?50,$P(PRC ADATA,U,5) ,?64,$P(PR CADATA,U,
  1364   6)
  1365   "RTN","PRC AACR",155, 0)
  1366    ....I $Y> (IOSL-3) D
  1367   "RTN","PRC AACR",156, 0)
  1368    .....I $E (IOST,1,2) ="C-" D  Q :QUIT
  1369   "RTN","PRC AACR",157, 0)
  1370    ......D P RTC
  1371   "RTN","PRC AACR",158, 0)
  1372    ......I $ D(DIRUT)!( $D(DTOUT))  S QUIT=1
  1373   "RTN","PRC AACR",159, 0)
  1374    .....D PS ACRTP2
  1375   "RTN","PRC AACR",160, 0)
  1376    ;
  1377   "RTN","PRC AACR",161, 0)
  1378    ; Display  Auto-Corr ect data s orted AUTO -C DATE
  1379   "RTN","PRC AACR",162, 0)
  1380    I PRCASOR T=3 D
  1381   "RTN","PRC AACR",163, 0)
  1382    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCA
  1383   DTR_U_PRCA BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
  1384   "RTN","PRC AACR",164, 0)
  1385    .; Displa y AUTO-C D ATE header
  1386   "RTN","PRC AACR",165, 0)
  1387    .D PSACRT P3
  1388   "RTN","PRC AACR",166, 0)
  1389    .S PRCAAC D=""
  1390   "RTN","PRC AACR",167, 0)
  1391    .F  S PRC AACD=$O(^T MP("PRCAAC R",$J,PRCA ACD)) Q:PR CAACD=""   D  Q:QUIT
  1392   "RTN","PRC AACR",168, 0)
  1393    ..S PRCAD TR=""
  1394   "RTN","PRC AACR",169, 0)
  1395    ..F  S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR)) Q:PRC ADTR=""  D   Q:QUIT
  1396   "RTN","PRC AACR",170, 0)
  1397    ...S PRCA BN=""
  1398   "RTN","PRC AACR",171, 0)
  1399    ...F  S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR,PRCABN) ) Q:'PRCAB N  D  Q:Q
  1400   UIT
  1401   "RTN","PRC AACR",172, 0)
  1402    ....S PRC ATN=""
  1403   "RTN","PRC AACR",173, 0)
  1404    ....F  S  PRCATN=$O( ^TMP("PRCA ACR",$J,PR CAACD,PRCA DTR,PRCABN ,PRCATN))  Q:'PRCATN
  1405     D  Q:QUI T
  1406   "RTN","PRC AACR",174, 0)
  1407    .....S PR CADATA=^TM P("PRCAACR ",$J,PRCAA CD,PRCADTR ,PRCABN,PR CATN)
  1408   "RTN","PRC AACR",175, 0)
  1409    .....S $P (PRCADATA, U,1)=$$GET 1^DIQ(433, PRCATN_"," ,94)
  1410   "RTN","PRC AACR",176, 0)
  1411    .....W !, $P(PRCADAT A,U,1),?14 ,$E($P(PRC ADATA,U,2) ,1,18),?34 ,$J($P(PRC ADATA,U,3
  1412   ),11),?47, $E($P(PRCA DATA,U,4), 6,9),?53,$ J($P(PRCAD ATA,U,5),9 ),?64,$P(P RCADATA,U
  1413   ,6)
  1414   "RTN","PRC AACR",177, 0)
  1415    .....I $Y >(IOSL-3)  D
  1416   "RTN","PRC AACR",178, 0)
  1417    ......I $ E(IOST,1,2 )="C-" D   Q:QUIT
  1418   "RTN","PRC AACR",179, 0)
  1419    .......D  PRTC
  1420   "RTN","PRC AACR",180, 0)
  1421    .......I  $D(DIRUT)! ($D(DTOUT) ) S QUIT=1
  1422   "RTN","PRC AACR",181, 0)
  1423    ......D P SACRTP3
  1424   "RTN","PRC AACR",182, 0)
  1425    ;
  1426   "RTN","PRC AACR",183, 0)
  1427    ; Display  Auto-Corr ect data s orted Tran saction Nu mber
  1428   "RTN","PRC AACR",184, 0)
  1429    I PRCASOR T=4 D
  1430   "RTN","PRC AACR",185, 0)
  1431    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_P
  1432   RCABN_U_PR CASSN_U_PR CAACD_U_PR CAACR
  1433   "RTN","PRC AACR",186, 0)
  1434    .; Displa y AUTO-C D ATE header
  1435   "RTN","PRC AACR",187, 0)
  1436    .D PSACRT P4
  1437   "RTN","PRC AACR",188, 0)
  1438    .S PRCATN =""
  1439   "RTN","PRC AACR",189, 0)
  1440    .F  S PRC ATN=$O(^TM P("PRCAACR ",$J,PRCAT N)) Q:'PRC ATN  D  Q: QUIT
  1441   "RTN","PRC AACR",190, 0)
  1442    ..S PRCAD TR=""
  1443   "RTN","PRC AACR",191, 0)
  1444    ..F  S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R)) Q:PRCA DTR=""  D   Q:QUIT
  1445   "RTN","PRC AACR",192, 0)
  1446    ...S PRCA BN=""
  1447   "RTN","PRC AACR",193, 0)
  1448    ...F  S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R,PRCABN))  Q:'PRCABN   D  Q:QU
  1449   IT
  1450   "RTN","PRC AACR",194, 0)
  1451    ....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)
  1452   "RTN","PRC AACR",195, 0)
  1453    ....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
  1454   "RTN","PRC AACR",196, 0)
  1455    ....W !,$ J($P(PRCAD ATA,U,1),9 ),?11,$E($ P(PRCADATA ,U,2),1,18 ),?31,$J($ P(PRCADAT
  1456   A,U,3),11) ,?44,$E($P (PRCADATA, U,4),6,9), ?50,$P(PRC ADATA,U,5) ,?64,$P(PR CADATA,U,
  1457   6)
  1458   "RTN","PRC AACR",197, 0)
  1459    ....I $Y> (IOSL-3) D
  1460   "RTN","PRC AACR",198, 0)
  1461    .....I $E (IOST,1,2) ="C-" D  Q :QUIT
  1462   "RTN","PRC AACR",199, 0)
  1463    ......D P RTC
  1464   "RTN","PRC AACR",200, 0)
  1465    ......I $ D(DIRUT)!( $D(DTOUT))  S QUIT=1
  1466   "RTN","PRC AACR",201, 0)
  1467    .....D PS ACRTP4
  1468   "RTN","PRC AACR",202, 0)
  1469    D ^%ZISC
  1470   "RTN","PRC AACR",203, 0)
  1471    I $E(IOST ,1,2)="C-" ,'$D(DUOUT ),('$D(DTO UT)) W ! S  DIR(0)="E " D ^DIR
  1472   "RTN","PRC AACR",204, 0)
  1473    K X,Y,DAS H,D0
  1474   "RTN","PRC AACR",205, 0)
  1475    Q
  1476   "RTN","PRC AACR",206, 0)
  1477    ;
  1478   "RTN","PRC AACR",207, 0)
  1479   PRTC ; Pre ss Return  To Continu e
  1480   "RTN","PRC AACR",208, 0)
  1481    S DIR(0)= "E" D ^DIR
  1482   "RTN","PRC AACR",209, 0)
  1483    Q
  1484   "RTN","PRC AACR",210, 0)
  1485    ;
  1486   "RTN","PRC AACR",211, 0)
  1487   PSACRTP1 ;  header fo r patient  statement  auto-corre ction repo rt 1
  1488   "RTN","PRC AACR",212, 0)
  1489    W @IOF
  1490   "RTN","PRC AACR",213, 0)
  1491    S PAGE=PA GE+1
  1492   "RTN","PRC AACR",214, 0)
  1493    W "PAGE " _PAGE,?8," BILLS THAT  HAVE BEEN  AUTO-CORR ECTED (SOR TED BY BIL L #)",?66
  1494   ,$$UPPER^V ALM1($$FMT E^XLFDT(DT ))
  1495   "RTN","PRC AACR",215, 0)
  1496    W !,DASH, !
  1497   "RTN","PRC AACR",216, 0)
  1498    W !,"BILL  NO.",?13, "DEBTOR",? 33,"SSN",? 39,"TRANS  NUM",?50," AUTO-C DAT E",?64,"A
  1499   UTO-C REAS ON"
  1500   "RTN","PRC AACR",217, 0)
  1501    W !,"---- -------",? 13,"------ ---------- --",?33,"- ---",?39," ---------" ,?50,"---
  1502   ---------" ,?64,"---- ---------- "
  1503   "RTN","PRC AACR",218, 0)
  1504    Q
  1505   "RTN","PRC AACR",219, 0)
  1506    ;
  1507   "RTN","PRC AACR",220, 0)
  1508   PSACRTP2 ;  header fo r patient  statement  auto-corre ction repo rt 2
  1509   "RTN","PRC AACR",221, 0)
  1510    W @IOF
  1511   "RTN","PRC AACR",222, 0)
  1512    S PAGE=PA GE+1
  1513   "RTN","PRC AACR",223, 0)
  1514    W "PAGE " _PAGE,?8," BILLS THAT  HAVE BEEN  AUTO-CORR ECTED (SOR TED BY DEB TOR)",?66
  1515   ,$$UPPER^V ALM1($$FMT E^XLFDT(DT ))
  1516   "RTN","PRC AACR",224, 0)
  1517    W !,DASH, !
  1518   "RTN","PRC AACR",225, 0)
  1519    W !,"DEBT OR",?20,"B ILL NO.",? 33,"SSN",? 39,"TRANS  NUM",?50," AUTO-C DAT E",?64,"A
  1520   UTO-C REAS ON"
  1521   "RTN","PRC AACR",226, 0)
  1522    W !,"---- ---------- ----",?20, "--------- --",?33,"- ---",?39," ---------" ,?50,"---
  1523   ---------" ,?64,"---- ---------- "
  1524   "RTN","PRC AACR",227, 0)
  1525    Q
  1526   "RTN","PRC AACR",228, 0)
  1527    ;
  1528   "RTN","PRC AACR",229, 0)
  1529   PSACRTP3 ;  header fo r patient  statement  auto-corre ction repo rt 3
  1530   "RTN","PRC AACR",230, 0)
  1531    W @IOF
  1532   "RTN","PRC AACR",231, 0)
  1533    S PAGE=PA GE+1
  1534   "RTN","PRC AACR",232, 0)
  1535    W "PAGE " _PAGE,?8," BILLS THAT  HAVE BEEN  AUTO-CORR ECTED (SOR TED BY AUT O-C DT)",
  1536   ?66,$$UPPE R^VALM1($$ FMTE^XLFDT (DT))
  1537   "RTN","PRC AACR",233, 0)
  1538    W !,DASH, !
  1539   "RTN","PRC AACR",234, 0)
  1540    W !,"AUTO -C DATE",? 14,"DEBTOR ",?34,"BIL L NO.",?47 ,"SSN",?53 ,"TRANS NU M",?64,"A
  1541   UTO-C REAS ON"
  1542   "RTN","PRC AACR",235, 0)
  1543    W !,"---- --------", ?14,"----- ---------- ---",?34," ---------- -",?47,"-- --",?53,"
  1544   ---------" ,?64,"---- ---------- "
  1545   "RTN","PRC AACR",236, 0)
  1546    Q
  1547   "RTN","PRC AACR",237, 0)
  1548    ;
  1549   "RTN","PRC AACR",238, 0)
  1550   PSACRTP4 ;  header fo r patient  statement  auto-corre ction repo rt 4
  1551   "RTN","PRC AACR",239, 0)
  1552    W @IOF
  1553   "RTN","PRC AACR",240, 0)
  1554    S PAGE=PA GE+1
  1555   "RTN","PRC AACR",241, 0)
  1556    W "PAGE " _PAGE,?8," BILLS THAT  HAVE BEEN  AUTO-CORR ECTED (SOR TED BY TRA NS NUM)",
  1557   ?66,$$UPPE R^VALM1($$ FMTE^XLFDT (DT))
  1558   "RTN","PRC AACR",242, 0)
  1559    W !,DASH, !
  1560   "RTN","PRC AACR",243, 0)
  1561    W !,"TRAN S NUM",?11 ,"DEBTOR", ?31,"BILL  NO.",?44," SSN",?50," AUTO-C DAT E",?64,"A
  1562   UTO-C REAS ON"
  1563   "RTN","PRC AACR",244, 0)
  1564    W !,"---- -----",?11 ,"-------- ---------- ",?31,"--- --------", ?44,"----" ,?50,"---
  1565   ---------" ,?64,"---- ---------- "
  1566   "RTN","PRC AACR",245, 0)
  1567    Q
  1568   "RTN","PRC AACR",246, 0)
  1569    ;
  1570   "RTN","PRC AACR",247, 0)
  1571   EXIT ;
  1572   "RTN","PRC AACR",248, 0)
  1573    Q
  1574   "RTN","PRC AACR1")
  1575   0^8^B10447 8523^n/a
  1576   "RTN","PRC AACR1",1,0 )
  1577   PRCAACR1 ; ALBANY/BDB -PATIENT S TATEMENTS  AUTO-CORRE CTION REPO RT ;09/21/ 15 3:34 P
  1578   M
  1579   "RTN","PRC AACR1",2,0 )
  1580    ;;4.5;Acc ounts Rece ivable;**3 07**;Mar 2 0, 1995;Bu ild 72
  1581   "RTN","PRC AACR1",3,0 )
  1582    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  1583   "RTN","PRC AACR1",4,0 )
  1584    ;
  1585   "RTN","PRC AACR1",5,0 )
  1586    Q
  1587   "RTN","PRC AACR1",6,0 )
  1588    ;Print Re port when  Queued to  P-MES
  1589   "RTN","PRC AACR1",7,0 )
  1590   PRT ;
  1591   "RTN","PRC AACR1",8,0 )
  1592    U IO
  1593   "RTN","PRC AACR1",9,0 )
  1594    ; build a rray of tr ansaction  auto-corre cted
  1595   "RTN","PRC AACR1",10, 0)
  1596    K ^TMP("P RCAACR1",$ J)
  1597   "RTN","PRC AACR1",11, 0)
  1598    N DASH,PA GE
  1599   "RTN","PRC AACR1",12, 0)
  1600    S PAGE=0
  1601   "RTN","PRC AACR1",13, 0)
  1602    S DASH="" ,$P(DASH," -",79)=""
  1603   "RTN","PRC AACR1",14, 0)
  1604    N PRCATSR T,PRCATN,P RCAACD,PRC AACR,PRCAB N,PRCADATA ,PRCADTR,P RCASSN,PRC AIEN,PRCA
  1605   ACTF,PRCAT NTF,PRCATE MP
  1606   "RTN","PRC AACR1",15, 0)
  1607    S PRCATSR T=PRCABDT- .00001,PRC AIEN=0
  1608   "RTN","PRC AACR1",16, 0)
  1609    ; Loop th rough the  specified  date range
  1610   "RTN","PRC AACR1",17, 0)
  1611    F  S PRCA TSRT=$O(^P RCA(433,"T ACD",PRCAT SRT)) Q:PR CATSRT=""! (PRCATSRT> PRCAEDT) 
  1612    D
  1613   "RTN","PRC AACR1",18, 0)
  1614    .S PRCATN =""
  1615   "RTN","PRC AACR1",19, 0)
  1616    .; Loop t hrough the  transacti ons for th e current  date
  1617   "RTN","PRC AACR1",20, 0)
  1618    .F  S PRC ATN=$O(^PR CA(433,"TA CD",PRCATS RT,PRCATN) ) Q:'PRCAT N  D
  1619   "RTN","PRC AACR1",21, 0)
  1620    ..; Load  associated  data fiel ds for rep ort
  1621   "RTN","PRC AACR1",22, 0)
  1622    ..S PRCAT NTF=PRCATN  ; Transac tion Numbe r Ticket F lag
  1623   "RTN","PRC AACR1",23, 0)
  1624    ..S PRCAB N=$P(^PRCA (433,PRCAT N,0),U,2)
  1625   "RTN","PRC AACR1",24, 0)
  1626    ..S PRCAD TR=$$GET1^ DIQ(430,PR CABN_",",9 ) ; (#9) D EBTOR
  1627   "RTN","PRC AACR1",25, 0)
  1628    ..S PRCAS SN=$G(^PRC A(430,PRCA BN,0)) ; L oad 0 Node
  1629   "RTN","PRC AACR1",26, 0)
  1630    ..S PRCAS SN=$P(PRCA SSN,U,9) ;  get IEN o f Debtor
  1631   "RTN","PRC AACR1",27, 0)
  1632    ..S PRCAB N=$$GET1^D IQ(433,PRC ATN_",",.0 3) ; (#.03 ) BILL NUM BER
  1633   "RTN","PRC AACR1",28, 0)
  1634    ..S PRCAS SN=$$GET1^ DIQ(340,PR CASSN_",", 110) ; SSN
  1635   "RTN","PRC AACR1",29, 0)
  1636    ..S PRCAS SN=$E(PRCA SSN,6,9)
  1637   "RTN","PRC AACR1",30, 0)
  1638    ..S PRCAA CD=$$GET1^ DIQ(433,PR CATN_",",9 4,"I") ;(# 94) AUTO-C ORRECTION  DATE
  1639   "RTN","PRC AACR1",31, 0)
  1640    ..S PRCAA CR=$$GET1^ DIQ(433,PR CATN_",",9 6) ;(#96)  AUTO-CORRE CTION TYPE  OF ERROR
  1641   "RTN","PRC AACR1",32, 0)
  1642    ..S PRCAA CR=$E(PRCA ACR,1,14)
  1643   "RTN","PRC AACR1",33, 0)
  1644    ..S PRCAA CTF=$$GET1 ^DIQ(433,P RCATN_",", 97) ;(#97) AUTO-CORRE CTION TICK ET FLAG
  1645   "RTN","PRC AACR1",34, 0)
  1646    ..; If Ti cket Flag  is set, re set Transa ction Numb er to null
  1647   "RTN","PRC AACR1",35, 0)
  1648    ..I PRCAA CTF="YES"  S PRCATNTF =""
  1649   "RTN","PRC AACR1",36, 0)
  1650    ..;
  1651   "RTN","PRC AACR1",37, 0)
  1652     ..; Stor e in ^TMP  sorted by  Bill Numbe r, Debtor  and Transa ction #
  1653   "RTN","PRC AACR1",38, 0)
  1654    ..I PRCAS ORT=1 D  Q
  1655   "RTN","PRC AACR1",39, 0)
  1656    ...S ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRCA SSN_U_PRC
  1657   ATNTF_U_PR CAACD_U_PR CAACR
  1658   "RTN","PRC AACR1",40, 0)
  1659    ..;
  1660   "RTN","PRC AACR1",41, 0)
  1661    ..; Store  in ^TMP s orted by D ebtor, Bil l Number a nd Transac tion #
  1662   "RTN","PRC AACR1",42, 0)
  1663    ..I PRCAS ORT=2 D  Q
  1664   "RTN","PRC AACR1",43, 0)
  1665    ...S ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRCA SSN_U_PRC
  1666   ATNTF_U_PR CAACD_U_PR CAACR
  1667   "RTN","PRC AACR1",44, 0)
  1668    ..;
  1669   "RTN","PRC AACR1",45, 0)
  1670    ..; Store  in ^TMP s orted by A uto-Correc t Date, De btor, Bill  Number an d Transac
  1671   tion #
  1672   "RTN","PRC AACR1",46, 0)
  1673    ..I PRCAS ORT=3 D  Q
  1674   "RTN","PRC AACR1",47, 0)
  1675    ...S ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCAD TR_U_PRCA
  1676   BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
  1677   "RTN","PRC AACR1",48, 0)
  1678    ..; Store  in ^TMP s orted by B ill Number , Debtor a nd Transac tion #
  1679   "RTN","PRC AACR1",49, 0)
  1680    ..;
  1681   "RTN","PRC AACR1",50, 0)
  1682    ..; Store  in ^TMP s orted by T ransaction , Debtor a nd #Bill N umber
  1683   "RTN","PRC AACR1",51, 0)
  1684    ..I PRCAS ORT=4 D  Q
  1685   "RTN","PRC AACR1",52, 0)
  1686    ...S ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_PR CABN_U_PR
  1687   CASSN_U_PR CAACD_U_PR CAACR
  1688   "RTN","PRC AACR1",53, 0)
  1689    ..; Store  in ^TMP s orted by B ill Number , Debtor a nd Transac tion #
  1690   "RTN","PRC AACR1",54, 0)
  1691    ..Q
  1692   "RTN","PRC AACR1",55, 0)
  1693    ; Display  Auto-Corr ect data s orted by B ill Number
  1694   "RTN","PRC AACR1",56, 0)
  1695    I PRCASOR T=1 D
  1696   "RTN","PRC AACR1",57, 0)
  1697    .; Print  Header
  1698   "RTN","PRC AACR1",58, 0)
  1699    .D PSACRT P1
  1700   "RTN","PRC AACR1",59, 0)
  1701    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)=PRC ABN_U_PRCA DTR_U_PRC
  1702   ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
  1703   "RTN","PRC AACR1",60, 0)
  1704    .S PRCABN =""
  1705   "RTN","PRC AACR1",61, 0)
  1706    .F  S PRC ABN=$O(^TM P("PRCAACR ",$J,PRCAB N)) Q:'PRC ABN  D
  1707   "RTN","PRC AACR1",62, 0)
  1708    ..S PRCAD TR=""
  1709   "RTN","PRC AACR1",63, 0)
  1710    ..F  S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R)) Q:PRCA DTR=""  D
  1711   "RTN","PRC AACR1",64, 0)
  1712    ...S PRCA TN=""
  1713   "RTN","PRC AACR1",65, 0)
  1714    ...F  S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ABN,PRCADT R,PRCATN))  Q:'PRCATN   D
  1715   "RTN","PRC AACR1",66, 0)
  1716    ....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCABN ,PRCADTR,P RCATN)
  1717   "RTN","PRC AACR1",67, 0)
  1718    ....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
  1719   "RTN","PRC AACR1",68, 0)
  1720    ....S PRC AIEN=PRCAI EN+1
  1721   "RTN","PRC AACR1",69, 0)
  1722    ....; Add  Bill Numb er
  1723   "RTN","PRC AACR1",70, 0)
  1724    ....S PRC ATEMP=$J($ P(PRCADATA ,U,1),11), $E(PRCATEM P,13)=" "
  1725   "RTN","PRC AACR1",71, 0)
  1726    ....; Add  18 chars  of Debtor' s name
  1727   "RTN","PRC AACR1",72, 0)
  1728    ....S PRC ATEMP=PRCA TEMP_$E($P (PRCADATA, U,2),1,18) ,$E(PRCATE MP,33)=" "
  1729   "RTN","PRC AACR1",73, 0)
  1730    ....; Add  SSN
  1731   "RTN","PRC AACR1",74, 0)
  1732    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,3 ),$E(PRCAT EMP,39)="  "
  1733   "RTN","PRC AACR1",75, 0)
  1734    ....; Add  Transacti on Number
  1735   "RTN","PRC AACR1",76, 0)
  1736    ....S PRC ATEMP=PRCA TEMP_$J($P (PRCADATA, U,4),9),$E (PRCATEMP, 50)=" "
  1737   "RTN","PRC AACR1",77, 0)
  1738    ....; Add  Auto-Corr ect Date
  1739   "RTN","PRC AACR1",78, 0)
  1740    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,5 ),$E(PRCAT EMP,64)="  "
  1741   "RTN","PRC AACR1",79, 0)
  1742    ....; Add  Auto-Corr ect Reason
  1743   "RTN","PRC AACR1",80, 0)
  1744    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,6 )
  1745   "RTN","PRC AACR1",81, 0)
  1746    ....S ^TM P("PRCAACR 1",$J,PRCA IEN)=PRCAT EMP
  1747   "RTN","PRC AACR1",82, 0)
  1748    ....Q
  1749   "RTN","PRC AACR1",83, 0)
  1750    ;
  1751   "RTN","PRC AACR1",84, 0)
  1752    ; Store i n ^TMP sor ted by Deb tor, Bill  Number and  Transacti on #
  1753   "RTN","PRC AACR1",85, 0)
  1754    I PRCASOR T=2 D
  1755   "RTN","PRC AACR1",86, 0)
  1756    .; Print  Header
  1757   "RTN","PRC AACR1",87, 0)
  1758    .D PSACRT P2
  1759   "RTN","PRC AACR1",88, 0)
  1760    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)=PRC ADTR_U_PRC ABN_U_PRC
  1761   ASSN_U_PRC ATNTF_U_PR CAACD_U_PR CAACR
  1762   "RTN","PRC AACR1",89, 0)
  1763    .S PRCADT R=""
  1764   "RTN","PRC AACR1",90, 0)
  1765    .F  S PRC ADTR=$O(^T MP("PRCAAC R",$J,PRCA DTR)) Q:PR CADTR=""   D
  1766   "RTN","PRC AACR1",91, 0)
  1767    ..S PRCAB N=""
  1768   "RTN","PRC AACR1",92, 0)
  1769    ..F  S PR CABN=$O(^T MP("PRCAAC R",$J,PRCA DTR,PRCABN )) Q:'PRCA BN  D
  1770   "RTN","PRC AACR1",93, 0)
  1771    ...S PRCA TN=""
  1772   "RTN","PRC AACR1",94, 0)
  1773    ...F  S P RCATN=$O(^ TMP("PRCAA CR",$J,PRC ADTR,PRCAB N,PRCATN))  Q:'PRCATN   D
  1774   "RTN","PRC AACR1",95, 0)
  1775    ....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCADT R,PRCABN,P RCATN)
  1776   "RTN","PRC AACR1",96, 0)
  1777    ....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
  1778   "RTN","PRC AACR1",97, 0)
  1779    ....S PRC AIEN=PRCAI EN+1
  1780   "RTN","PRC AACR1",98, 0)
  1781    ....; Add  18 chars  of Debtor' s name
  1782   "RTN","PRC AACR1",99, 0)
  1783    ....S PRC ATEMP=$E($ P(PRCADATA ,U,1),1,18 ),$E(PRCAT EMP,20)="  "
  1784   "RTN","PRC AACR1",100 ,0)
  1785    ....; Add  Bill Numb er
  1786   "RTN","PRC AACR1",101 ,0)
  1787    ....S PRC ATEMP=PRCA TEMP_$J($P (PRCADATA, U,2),11),$ E(PRCATEMP ,33)=" "
  1788   "RTN","PRC AACR1",102 ,0)
  1789    ....; Add  SSN
  1790   "RTN","PRC AACR1",103 ,0)
  1791    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,3 ),$E(PRCAT EMP,39)="  "
  1792   "RTN","PRC AACR1",104 ,0)
  1793    ....; Add  Transacti on Number
  1794   "RTN","PRC AACR1",105 ,0)
  1795    ....S PRC ATEMP=PRCA TEMP_$J($P (PRCADATA, U,4),9),$E (PRCATEMP, 50)=" "
  1796   "RTN","PRC AACR1",106 ,0)
  1797    ....; Add  Auto-Corr ect Date
  1798   "RTN","PRC AACR1",107 ,0)
  1799    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,5 ),$E(PRCAT EMP,64)="  "
  1800   "RTN","PRC AACR1",108 ,0)
  1801    ....; Add  Auto-Corr ect Reason
  1802   "RTN","PRC AACR1",109 ,0)
  1803    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,6 )
  1804   "RTN","PRC AACR1",110 ,0)
  1805    ....S ^TM P("PRCAACR 1",$J,PRCA IEN)=PRCAT EMP
  1806   "RTN","PRC AACR1",111 ,0)
  1807    ....Q
  1808   "RTN","PRC AACR1",112 ,0)
  1809    ;
  1810   "RTN","PRC AACR1",113 ,0)
  1811    ; Store i n ^TMP sor ted by Aut o-Correct  Date, Debt or, Bill N umber and  Transacti
  1812   on #
  1813   "RTN","PRC AACR1",114 ,0)
  1814    I PRCASOR T=3 D
  1815   "RTN","PRC AACR1",115 ,0)
  1816    .; Print  Header
  1817   "RTN","PRC AACR1",116 ,0)
  1818    .D PSACRT P3
  1819   "RTN","PRC AACR1",117 ,0)
  1820    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCAAC D,PRCADTR, PRCABN,PRC ATN)=PRCAA CD_U_PRCA
  1821   DTR_U_PRCA BN_U_PRCAS SN_U_PRCAT NTF_U_PRCA ACR
  1822   "RTN","PRC AACR1",118 ,0)
  1823    .S PRCAAC D=""
  1824   "RTN","PRC AACR1",119 ,0)
  1825    .F  S PRC AACD=$O(^T MP("PRCAAC R",$J,PRCA ACD)) Q:PR CAACD=""   D
  1826   "RTN","PRC AACR1",120 ,0)
  1827    ..S PRCAD TR=""
  1828   "RTN","PRC AACR1",121 ,0)
  1829    ..F  S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR)) Q:PRC ADTR=""  D
  1830   "RTN","PRC AACR1",122 ,0)
  1831    ...S PRCA BN=""
  1832   "RTN","PRC AACR1",123 ,0)
  1833    ...F  S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC AACD,PRCAD TR,PRCABN) ) Q:'PRCAB N  D
  1834   "RTN","PRC AACR1",124 ,0)
  1835    ....S PRC ATN=""
  1836   "RTN","PRC AACR1",125 ,0)
  1837    ....F  S  PRCATN=$O( ^TMP("PRCA ACR",$J,PR CAACD,PRCA DTR,PRCABN ,PRCATN))  Q:'PRCATN
  1838     D
  1839   "RTN","PRC AACR1",126 ,0)
  1840    .....S PR CADATA=^TM P("PRCAACR ",$J,PRCAA CD,PRCADTR ,PRCABN,PR CATN)
  1841   "RTN","PRC AACR1",127 ,0)
  1842    .....S $P (PRCADATA, U,1)=$$GET 1^DIQ(433, PRCATN_"," ,94)
  1843   "RTN","PRC AACR1",128 ,0)
  1844    .....S PR CAIEN=PRCA IEN+1
  1845   "RTN","PRC AACR1",129 ,0)
  1846    .....; Ad d Auto-Cor rect Date
  1847   "RTN","PRC AACR1",130 ,0)
  1848    .....S PR CATEMP=$P( PRCADATA,U ,1),$E(PRC ATEMP,14)= " "
  1849   "RTN","PRC AACR1",131 ,0)
  1850    .....; Ad d 18 chars  of Debtor 's name
  1851   "RTN","PRC AACR1",132 ,0)
  1852    .....S PR CATEMP=PRC ATEMP_$E($ P(PRCADATA ,U,2),1,18 ),$E(PRCAT EMP,34)="  "
  1853   "RTN","PRC AACR1",133 ,0)
  1854    .....; Ad d Bill Num ber
  1855   "RTN","PRC AACR1",134 ,0)
  1856    .....S PR CATEMP=PRC ATEMP_$J($ P(PRCADATA ,U,3),11), $E(PRCATEM P,47)=" "
  1857   "RTN","PRC AACR1",135 ,0)
  1858    .....; Ad d SSN
  1859   "RTN","PRC AACR1",136 ,0)
  1860    .....S PR CATEMP=PRC ATEMP_$P(P RCADATA,U, 4),$E(PRCA TEMP,53)="  "
  1861   "RTN","PRC AACR1",137 ,0)
  1862    .....; Ad d Transact ion Number
  1863   "RTN","PRC AACR1",138 ,0)
  1864    .....S PR CATEMP=PRC ATEMP_$J($ P(PRCADATA ,U,5),9),$ E(PRCATEMP ,64)=" "
  1865   "RTN","PRC AACR1",139 ,0)
  1866    .....; Ad d Auto-Cor rect Reaso n
  1867   "RTN","PRC AACR1",140 ,0)
  1868    .....S PR CATEMP=PRC ATEMP_$P(P RCADATA,U, 6)
  1869   "RTN","PRC AACR1",141 ,0)
  1870    .....S ^T MP("PRCAAC R1",$J,PRC AIEN)=PRCA TEMP
  1871   "RTN","PRC AACR1",142 ,0)
  1872    .....Q 
  1873   "RTN","PRC AACR1",143 ,0)
  1874    ;
  1875   "RTN","PRC AACR1",144 ,0)
  1876    ; Store i n ^TMP sor ted by Tra nsaction,  Debtor and  #Bill Num ber
  1877   "RTN","PRC AACR1",145 ,0)
  1878    I PRCASOR T=4 D
  1879   "RTN","PRC AACR1",146 ,0)
  1880    .; Print  Header
  1881   "RTN","PRC AACR1",147 ,0)
  1882    .D PSACRT P4
  1883   "RTN","PRC AACR1",148 ,0)
  1884    .; Data L ayout ^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)=PRC ATNTF_U_PR CADTR_U_P
  1885   RCABN_U_PR CASSN_U_PR CAACD_U_PR CAACR
  1886   "RTN","PRC AACR1",149 ,0)
  1887    .S PRCATN =""
  1888   "RTN","PRC AACR1",150 ,0)
  1889    .F  S PRC ATN=$O(^TM P("PRCAACR ",$J,PRCAT N)) Q:'PRC ATN  D
  1890   "RTN","PRC AACR1",151 ,0)
  1891    ..S PRCAD TR=""
  1892   "RTN","PRC AACR1",152 ,0)
  1893    ..F  S PR CADTR=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R)) Q:PRCA DTR=""  D
  1894   "RTN","PRC AACR1",153 ,0)
  1895    ...S PRCA BN=""
  1896   "RTN","PRC AACR1",154 ,0)
  1897    ...F  S P RCABN=$O(^ TMP("PRCAA CR",$J,PRC ATN,PRCADT R,PRCABN))  Q:'PRCABN   D
  1898   "RTN","PRC AACR1",155 ,0)
  1899    ....S PRC ADATA=^TMP ("PRCAACR" ,$J,PRCATN ,PRCADTR,P RCABN)
  1900   "RTN","PRC AACR1",156 ,0)
  1901    ....S $P( PRCADATA,U ,5)=$$GET1 ^DIQ(433,P RCATN_",", 94)
  1902   "RTN","PRC AACR1",157 ,0)
  1903    ....S PRC AIEN=PRCAI EN+1
  1904   "RTN","PRC AACR1",158 ,0)
  1905    ....; Add  Transacti on Number
  1906   "RTN","PRC AACR1",159 ,0)
  1907    ....S PRC ATEMP=$J($ P(PRCADATA ,U,1),9),$ E(PRCATEMP ,11)=" "
  1908   "RTN","PRC AACR1",160 ,0)
  1909    ....; Add  18 chars  of Debtor' s name
  1910   "RTN","PRC AACR1",161 ,0)
  1911    ....S PRC ATEMP=PRCA TEMP_$E($P (PRCADATA, U,2),1,18) ,$E(PRCATE MP,31)=" "
  1912   "RTN","PRC AACR1",162 ,0)
  1913    ....; Add  Bill Numb er
  1914   "RTN","PRC AACR1",163 ,0)
  1915    ....S PRC ATEMP=PRCA TEMP_$J($P (PRCADATA, U,3),11),$ E(PRCATEMP ,44)=" "
  1916   "RTN","PRC AACR1",164 ,0)
  1917    ....; Add  SSN
  1918   "RTN","PRC AACR1",165 ,0)
  1919    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,4 ),$E(PRCAT EMP,50)="  "
  1920   "RTN","PRC AACR1",166 ,0)
  1921    ....; Add  Auto-Corr ect Date
  1922   "RTN","PRC AACR1",167 ,0)
  1923    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,5 ),$E(PRCAT EMP,64)="  "
  1924   "RTN","PRC AACR1",168 ,0)
  1925    ....; Add  Auto-Corr ect Reason
  1926   "RTN","PRC AACR1",169 ,0)
  1927    ....S PRC ATEMP=PRCA TEMP_$P(PR CADATA,U,6 )
  1928   "RTN","PRC AACR1",170 ,0)
  1929    ....S ^TM P("PRCAACR 1",$J,PRCA IEN)=PRCAT EMP
  1930   "RTN","PRC AACR1",171 ,0)
  1931    ....Q
  1932   "RTN","PRC AACR1",172 ,0)
  1933    ;
  1934   "RTN","PRC AACR1",173 ,0)
  1935    ; Send Ma ilMan mess age with N o Forward
  1936   "RTN","PRC AACR1",174 ,0)
  1937    N XMTO,XM SUBJ,XMBOD Y,XMINSTR, XMDUZ
  1938   "RTN","PRC AACR1",175 ,0)
  1939    S XMTO(DU Z)=""
  1940   "RTN","PRC AACR1",176 ,0)
  1941    S XMSUBJ= "BILLS THA T HAVE BEE N AUTO-COR RECTED"
  1942   "RTN","PRC AACR1",177 ,0)
  1943    S XMBODY= "^TMP(""PR CAACR1"",$ J)"
  1944   "RTN","PRC AACR1",178 ,0)
  1945    S XMINSTR ("FLAGS")= "X"
  1946   "RTN","PRC AACR1",179 ,0)
  1947    S XMDUZ=D UZ
  1948   "RTN","PRC AACR1",180 ,0)
  1949    D SENDMSG ^XMXAPI(XM DUZ,XMSUBJ ,XMBODY,.X MTO,.XMINS TR)
  1950   "RTN","PRC AACR1",181 ,0)
  1951    D HOME^%Z IS
  1952   "RTN","PRC AACR1",182 ,0)
  1953    K IO("Q") ,POP
  1954   "RTN","PRC AACR1",183 ,0)
  1955    K ^TMP("P RCAACR",$J )
  1956   "RTN","PRC AACR1",184 ,0)
  1957    K ^TMP("P RCAACR1",$ J)
  1958   "RTN","PRC AACR1",185 ,0)
  1959    K PRCABDT ,PRCAEDT,P RCASORT
  1960   "RTN","PRC AACR1",186 ,0)
  1961    Q
  1962   "RTN","PRC AACR1",187 ,0)
  1963    ;
  1964   "RTN","PRC AACR1",188 ,0)
  1965   PSACRTP1 ;  header fo r patient  statement  auto-corre ction repo rt 1
  1966   "RTN","PRC AACR1",189 ,0)
  1967    S PAGE=PA GE+1
  1968   "RTN","PRC AACR1",190 ,0)
  1969    S PRCAIEN =PRCAIEN+1
  1970   "RTN","PRC AACR1",191 ,0)
  1971    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  1972   "RTN","PRC AACR1",192 ,0)
  1973    S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,8)= ""
  1974   "RTN","PRC AACR1",193 ,0)
  1975    S PRCADAT A=PRCADATA _"BILLS TH AT HAVE BE EN AUTO-CO RRECTED (S ORTED BY B ILL #)"
  1976   "RTN","PRC AACR1",194 ,0)
  1977    S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
  1978   "RTN","PRC AACR1",195 ,0)
  1979    S PRCAIEN =PRCAIEN+1
  1980   "RTN","PRC AACR1",196 ,0)
  1981    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  1982   "RTN","PRC AACR1",197 ,0)
  1983    S PRCAIEN =PRCAIEN+1
  1984   "RTN","PRC AACR1",198 ,0)
  1985    S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
  1986   "RTN","PRC AACR1",199 ,0)
  1987    S PRCAIEN =PRCAIEN+1
  1988   "RTN","PRC AACR1",200 ,0)
  1989    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  1990   "RTN","PRC AACR1",201 ,0)
  1991    S PRCADAT A="BILL NO .     DEBT OR               SSN    TRANS NU M  AUTO-C  DATE   AU
  1992   TO-C REASO N"
  1993   "RTN","PRC AACR1",202 ,0)
  1994    S PRCAIEN =PRCAIEN+1
  1995   "RTN","PRC AACR1",203 ,0)
  1996    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  1997   "RTN","PRC AACR1",204 ,0)
  1998    S PRCADAT A="------- ----  ---- ---------- ----  ----   -------- -  ------- -----  --
  1999   ---------- --"
  2000   "RTN","PRC AACR1",205 ,0)
  2001    S PRCAIEN =PRCAIEN+1
  2002   "RTN","PRC AACR1",206 ,0)
  2003    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2004   "RTN","PRC AACR1",207 ,0)
  2005    Q
  2006   "RTN","PRC AACR1",208 ,0)
  2007    ;
  2008   "RTN","PRC AACR1",209 ,0)
  2009   PSACRTP2 ;  header fo r patient  statement  auto-corre ction repo rt 2
  2010   "RTN","PRC AACR1",210 ,0)
  2011    S PAGE=PA GE+1
  2012   "RTN","PRC AACR1",211 ,0)
  2013    S PRCAIEN =PRCAIEN+1
  2014   "RTN","PRC AACR1",212 ,0)
  2015    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  2016   "RTN","PRC AACR1",213 ,0)
  2017    S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,8)= ""
  2018   "RTN","PRC AACR1",214 ,0)
  2019    S PRCADAT A=PRCADATA _"BILLS TH AT HAVE BE EN AUTO-CO RRECTED (S ORTED BY D EBTOR)"
  2020   "RTN","PRC AACR1",215 ,0)
  2021    S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
  2022   "RTN","PRC AACR1",216 ,0)
  2023    S PRCAIEN =PRCAIEN+1
  2024   "RTN","PRC AACR1",217 ,0)
  2025    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2026   "RTN","PRC AACR1",218 ,0)
  2027    S PRCAIEN =PRCAIEN+1
  2028   "RTN","PRC AACR1",219 ,0)
  2029    S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
  2030   "RTN","PRC AACR1",220 ,0)
  2031    S PRCAIEN =PRCAIEN+1
  2032   "RTN","PRC AACR1",221 ,0)
  2033    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  2034   "RTN","PRC AACR1",222 ,0)
  2035    S PRCADAT A="DEBTOR                BILL NO .     SSN    TRANS NU M  AUTO-C  DATE   AU
  2036   TO-C REASO N"
  2037   "RTN","PRC AACR1",223 ,0)
  2038    S PRCAIEN =PRCAIEN+1
  2039   "RTN","PRC AACR1",224 ,0)
  2040    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2041   "RTN","PRC AACR1",225 ,0)
  2042    S PRCADAT A="------- ---------- -  ------- ----  ----   -------- -  ------- -----  --
  2043   ---------- --"
  2044   "RTN","PRC AACR1",226 ,0)
  2045    S PRCAIEN =PRCAIEN+1
  2046   "RTN","PRC AACR1",227 ,0)
  2047    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2048   "RTN","PRC AACR1",228 ,0)
  2049    Q
  2050   "RTN","PRC AACR1",229 ,0)
  2051    ;
  2052   "RTN","PRC AACR1",230 ,0)
  2053   PSACRTP3 ;  header fo r patient  statement  auto-corre ction repo rt 3
  2054   "RTN","PRC AACR1",231 ,0)
  2055    S PAGE=PA GE+1
  2056   "RTN","PRC AACR1",232 ,0)
  2057    S PRCAIEN =PRCAIEN+1
  2058   "RTN","PRC AACR1",233 ,0)
  2059    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  2060   "RTN","PRC AACR1",234 ,0)
  2061    S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,8)= ""
  2062   "RTN","PRC AACR1",235 ,0)
  2063    S PRCADAT A=PRCADATA _"BILLS TH AT HAVE BE EN AUTO-CO RRECTED (S ORTED BY A UTO-C DT)
  2064   "
  2065   "RTN","PRC AACR1",236 ,0)
  2066    S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
  2067   "RTN","PRC AACR1",237 ,0)
  2068    S PRCAIEN =PRCAIEN+1
  2069   "RTN","PRC AACR1",238 ,0)
  2070    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2071   "RTN","PRC AACR1",239 ,0)
  2072    S PRCAIEN =PRCAIEN+1
  2073   "RTN","PRC AACR1",240 ,0)
  2074    S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
  2075   "RTN","PRC AACR1",241 ,0)
  2076    S PRCAIEN =PRCAIEN+1
  2077   "RTN","PRC AACR1",242 ,0)
  2078    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  2079   "RTN","PRC AACR1",243 ,0)
  2080    S PRCADAT A="AUTO-C  DATE   DEB TOR               BIL L NO.      SSN   TRAN S NUM  AU
  2081   TO-C REASO N"
  2082   "RTN","PRC AACR1",244 ,0)
  2083    S PRCAIEN =PRCAIEN+1
  2084   "RTN","PRC AACR1",245 ,0)
  2085    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2086   "RTN","PRC AACR1",246 ,0)
  2087    S PRCADAT A="------- -----  --- ---------- -----  --- --------   ----  ---- -----  --
  2088   ---------- --"
  2089   "RTN","PRC AACR1",247 ,0)
  2090    S PRCAIEN =PRCAIEN+1
  2091   "RTN","PRC AACR1",248 ,0)
  2092    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2093   "RTN","PRC AACR1",249 ,0)
  2094    Q
  2095   "RTN","PRC AACR1",250 ,0)
  2096    ;
  2097   "RTN","PRC AACR1",251 ,0)
  2098   PSACRTP4 ;  header fo r patient  statement  auto-corre ction repo rt 4
  2099   "RTN","PRC AACR1",252 ,0)
  2100    S PAGE=PA GE+1
  2101   "RTN","PRC AACR1",253 ,0)
  2102    S PRCAIEN =PRCAIEN+1
  2103   "RTN","PRC AACR1",254 ,0)
  2104    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  2105   "RTN","PRC AACR1",255 ,0)
  2106    S PRCADAT A="PAGE "_ PAGE,$E(PR CADATA,8)= ""
  2107   "RTN","PRC AACR1",256 ,0)
  2108    S PRCADAT A=PRCADATA _"BILLS TH AT HAVE BE EN AUTO-CO RRECTED (S ORTED BY T RANS NUM)
  2109   "
  2110   "RTN","PRC AACR1",257 ,0)
  2111    S $E(PRCA DATA,66)=" ",PRCADATA =PRCADATA_ $$UPPER^VA LM1($$FMTE ^XLFDT(DT) )
  2112   "RTN","PRC AACR1",258 ,0)
  2113    S PRCAIEN =PRCAIEN+1
  2114   "RTN","PRC AACR1",259 ,0)
  2115    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2116   "RTN","PRC AACR1",260 ,0)
  2117    S PRCAIEN =PRCAIEN+1
  2118   "RTN","PRC AACR1",261 ,0)
  2119    S ^TMP("P RCAACR1",$ J,PRCAIEN) =DASH
  2120   "RTN","PRC AACR1",262 ,0)
  2121    S PRCAIEN =PRCAIEN+1
  2122   "RTN","PRC AACR1",263 ,0)
  2123    S ^TMP("P RCAACR1",$ J,PRCAIEN) =""
  2124   "RTN","PRC AACR1",264 ,0)
  2125    S PRCADAT A="TRANS N UM  DEBTOR                BILL N O.     SSN    AUTO-C  DATE   AU
  2126   TO-C REASO N"
  2127   "RTN","PRC AACR1",265 ,0)
  2128    S PRCAIEN =PRCAIEN+1
  2129   "RTN","PRC AACR1",266 ,0)
  2130    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2131   "RTN","PRC AACR1",267 ,0)
  2132    S PRCADAT A="------- --  ------ ---------- --  ------ -----  --- -  ------- -----  --
  2133   ---------- --"
  2134   "RTN","PRC AACR1",268 ,0)
  2135    S PRCAIEN =PRCAIEN+1
  2136   "RTN","PRC AACR1",269 ,0)
  2137    S ^TMP("P RCAACR1",$ J,PRCAIEN) =PRCADATA
  2138   "RTN","PRC AACR1",270 ,0)
  2139    Q
  2140   "RTN","PRC AACR1",271 ,0)
  2141    ;
  2142   "RTN","PRC AACR1",272 ,0)
  2143   EXIT ;
  2144   "RTN","PRC AACR1",273 ,0)
  2145    Q
  2146   "RTN","PRC ACPS")
  2147   0^1^B25151 0911^n/a
  2148   "RTN","PRC ACPS",1,0)
  2149   PRCACPS ;A LBANY/BDB- PATIENT ST ATEMENTS A UTO-CORREC TION ;09/2 1/15 3:34  PM
  2150   "RTN","PRC ACPS",2,0)
  2151    ;;4.5;Acc ounts Rece ivable;**3 07**;Mar 2 0, 1995;Bu ild 72
  2152   "RTN","PRC ACPS",3,0)
  2153    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  2154   "RTN","PRC ACPS",4,0)
  2155    ;
  2156   "RTN","PRC ACPS",5,0)
  2157    Q
  2158   "RTN","PRC ACPS",6,0)
  2159    ;
  2160   "RTN","PRC ACPS",7,0)
  2161   BEGIN ; En try point  for manual  run
  2162   "RTN","PRC ACPS",8,0)
  2163    ; Determi ne if Auto  Correct p rocess is  currently  running
  2164   "RTN","PRC ACPS",9,0)
  2165    N DIR,PRC ASTRT,QUIT ,X,X1,X2,Y
  2166   "RTN","PRC ACPS",10,0 )
  2167    S PRCASTR T=$G(^XTMP ("PRCACPS" ,0)),QUIT= 0
  2168   "RTN","PRC ACPS",11,0 )
  2169    ; Notify  user if Au to Correct  process i s currentl y running
  2170   "RTN","PRC ACPS",12,0 )
  2171    I PRCASTR T'="" D  Q :QUIT
  2172   "RTN","PRC ACPS",13,0 )
  2173    .S Y=$P(P RCASTRT,U, 2)
  2174   "RTN","PRC ACPS",14,0 )
  2175    .D DD^%DT
  2176   "RTN","PRC ACPS",15,0 )
  2177    .S PRCAST RT=Y
  2178   "RTN","PRC ACPS",16,0 )
  2179    .W !!,"Th e Patient  Statement  Auto-Corre ction Prog ram was pr eviously s tarted on
  2180   "
  2181   "RTN","PRC ACPS",17,0 )
  2182    .W !,PRCA STRT," and  has not y et success fully comp leted."
  2183   "RTN","PRC ACPS",18,0 )
  2184    .W !!,"Th e job can  take up to  1 hour to  complete  when sched uled to ru n outside
  2185   "
  2186   "RTN","PRC ACPS",19,0 )
  2187    .W !,"of  normal bus iness hour s and long er if run  during nor mal busine ss hours"
  2188   "RTN","PRC ACPS",20,0 )
  2189    .W !,"whe n the load  on the sy stem is gr eater."
  2190   "RTN","PRC ACPS",21,0 )
  2191    .W !!
  2192   "RTN","PRC ACPS",22,0 )
  2193    .W !,"If  it has bee n more tha n an hour  since the  Patient St atement Au to-Correc
  2194   tion"
  2195   "RTN","PRC ACPS",23,0 )
  2196    .W !,"Pro gram was s tarted and  the confi rmation e- mail with  subject: C PS"
  2197   "RTN","PRC ACPS",24,0 )
  2198    .W !,"AUT O-CORRECTI ON COMPLET E has not  been sent  to the PRC ACPS mail  group, yo
  2199   u can"
  2200   "RTN","PRC ACPS",25,0 )
  2201    .W !,"run  the Patie nt Stateme nt Auto-Co rrection P rogram aga in."
  2202   "RTN","PRC ACPS",26,0 )
  2203    .W !
  2204   "RTN","PRC ACPS",27,0 )
  2205    .S DIR("A ")="Do you  want to r un the Pat ient State ment Auto- Correction  Program 
  2206   again"
  2207   "RTN","PRC ACPS",28,0 )
  2208    .S DIR(0) ="Y",DIR(" B")="NO"
  2209   "RTN","PRC ACPS",29,0 )
  2210    .D ^DIR
  2211   "RTN","PRC ACPS",30,0 )
  2212    .W !
  2213   "RTN","PRC ACPS",31,0 )
  2214    .; Quit i f ^, ^^, T imeout or  No
  2215   "RTN","PRC ACPS",32,0 )
  2216    .I $D(DTO UT)!($D(DU OUT))!($D( DIROUT))!( Y=0) S QUI T=1
  2217   "RTN","PRC ACPS",33,0 )
  2218    .K DTOUT, DUOUT,DIRO UT
  2219   "RTN","PRC ACPS",34,0 )
  2220    .Q
  2221   "RTN","PRC ACPS",35,0 )
  2222    ;
  2223   "RTN","PRC ACPS",36,0 )
  2224    N ZTDTH,Z TIO,ZTDESC ,ZTRTN,ZTS K
  2225   "RTN","PRC ACPS",37,0 )
  2226    W !,"Queu e the pati ent statem ent discre pancies au to-correct ion progra m to run:
  2227   "
  2228   "RTN","PRC ACPS",38,0 )
  2229    S ZTDESC= "Auto-Corr ect Patien t Statemen t Discrepa ncies"
  2230   "RTN","PRC ACPS",39,0 )
  2231    S ZTRTN=" START^PRCA CPS",ZTIO= ""
  2232   "RTN","PRC ACPS",40,0 )
  2233    D ^%ZTLOA D
  2234   "RTN","PRC ACPS",41,0 )
  2235    Q
  2236   "RTN","PRC ACPS",42,0 )
  2237    ;
  2238   "RTN","PRC ACPS",43,0 )
  2239   START ; En try point  for Schedu led backgr ound job
  2240   "RTN","PRC ACPS",44,0 )
  2241    N DEBTOR, DEBTOR0,DE BTOR1,PRCA STRT,REFRE V,X,Y
  2242   "RTN","PRC ACPS",45,0 )
  2243    S PRCASTR T=$G(^XTMP ("PRCACPS" ,0))
  2244   "RTN","PRC ACPS",46,0 )
  2245    ; If a pr evious job  still run ning send  e-mail war ning to PR CACPS mail  group
  2246   "RTN","PRC ACPS",47,0 )
  2247    I PRCASTR T'="" D
  2248   "RTN","PRC ACPS",48,0 )
  2249    .S Y=$P(P RCASTRT,U, 2)
  2250   "RTN","PRC ACPS",49,0 )
  2251    .; Conver t date to  external f ormat
  2252   "RTN","PRC ACPS",50,0 )
  2253    .D DD^%DT
  2254   "RTN","PRC ACPS",51,0 )
  2255    .S PRCAST RT=Y
  2256   "RTN","PRC ACPS",52,0 )
  2257    .; Send m ail to PRC ACPS mail  group noti ng previou s run didn 't complet e
  2258   "RTN","PRC ACPS",53,0 )
  2259    .D PRCAMA IL(PRCASTR T)
  2260   "RTN","PRC ACPS",54,0 )
  2261    .Q
  2262   "RTN","PRC ACPS",55,0 )
  2263    ; Get cur rent date/ time
  2264   "RTN","PRC ACPS",56,0 )
  2265    D NOW^%DT C
  2266   "RTN","PRC ACPS",57,0 )
  2267    S (PRCAST RT,X1)=%,X 2=8
  2268   "RTN","PRC ACPS",58,0 )
  2269    D C^%DTC
  2270   "RTN","PRC ACPS",59,0 )
  2271    S ^XTMP(" PRCACPS",0 )=X_U_PRCA STRT_U_"Pa tient Stat ement Auto -Correctio n Program
  2272   "
  2273   "RTN","PRC ACPS",60,0 )
  2274    ; Loop th rough C x- ref in 430 . This fie ld points  to the Deb tor File,  which in 
  2275   turn is a
  2276   "RTN","PRC ACPS",61,0 )
  2277    ; variabl e pointer  to other f iles.
  2278   "RTN","PRC ACPS",62,0 )
  2279    S DEBTOR= 0
  2280   "RTN","PRC ACPS",63,0 )
  2281    F  S DEBT OR=$O(^PRC A(430,"C", DEBTOR)) Q :DEBTOR'?1 N.N  D
  2282   "RTN","PRC ACPS",64,0 )
  2283    .; Perfor m the same  in/out of  balance c heck at th e CHECK PA TIENT ACCO UNT BALAN
  2284   CE option
  2285   "RTN","PRC ACPS",65,0 )
  2286    .; Quit t o next deb tor if acc ount is in  balance
  2287   "RTN","PRC ACPS",66,0 )
  2288    .I '$$EN^ PRCAMRKC(D EBTOR) Q
  2289   "RTN","PRC ACPS",67,0 )
  2290    .S BALDIF F=0
  2291   "RTN","PRC ACPS",68,0 )
  2292    .S DEBTOR 0=$G(^RCD( 340,DEBTOR ,0)),DEBTO R1=$G(^(1) )
  2293   "RTN","PRC ACPS",69,0 )
  2294    .; QUIT i f it doesn 't point t o the PATI ENT (^DPT)  file
  2295   "RTN","PRC ACPS",70,0 )
  2296    .Q:$P(DEB TOR0,"^")' ["DPT("
  2297   "RTN","PRC ACPS",71,0 )
  2298    .Q:$P(DEB TOR1,"^",9 )=1  ; qui t if debto r address  marked unk nown
  2299   "RTN","PRC ACPS",72,0 )
  2300    .; Skip t his Debtor  is they a t least 1  Bill in #4 30 with a  status of  REFUND RE
  2301   VIEW (#44)
  2302   "RTN","PRC ACPS",73,0 )
  2303    .Q:$$REFR EV(DEBTOR)  
  2304   "RTN","PRC ACPS",74,0 )
  2305    .; Get pr evious bal ance and d ate of las t transact ion from t he AR EVEN T file (#
  2306   341)
  2307   "RTN","PRC ACPS",75,0 )
  2308    .D ENTER( DEBTOR)
  2309   "RTN","PRC ACPS",76,0 )
  2310    .; Perfor m checks/u pdates bas ed on File  #430
  2311   "RTN","PRC ACPS",77,0 )
  2312    .D START1
  2313   "RTN","PRC ACPS",78,0 )
  2314    .; QUIT i f in balan ce
  2315   "RTN","PRC ACPS",79,0 )
  2316    .;Q:BALDI FF=0
  2317   "RTN","PRC ACPS",80,0 )
  2318    .I BALDIF F=0 K BALD IFF,^TMP(" PRCAGTPS", $J),^TMP(" PRCABILL", $J) Q
  2319   "RTN","PRC ACPS",81,0 )
  2320    .; Review  Data in ^ TMP and up date #433  as needed
  2321   "RTN","PRC ACPS",82,0 )
  2322    .D START2
  2323   "RTN","PRC ACPS",83,0 )
  2324    .K BALDIF F,^TMP("PR CAGTPS",$J ),^TMP("PR CABILL",$J )
  2325   "RTN","PRC ACPS",84,0 )
  2326    ; Send ma ilman mess age to the  PRCACPS m ail group  at end of  processing
  2327   "RTN","PRC ACPS",85,0 )
  2328    D USRMSG
  2329   "RTN","PRC ACPS",86,0 )
  2330    Q
  2331   "RTN","PRC ACPS",87,0 )
  2332    ;
  2333   "RTN","PRC ACPS",88,0 )
  2334   REFREV(DEB TOR) ;
  2335   "RTN","PRC ACPS",89,0 )
  2336    ; Check i f any Bill  for this  Debtor has  a status  of REFUND  REVIEW (#4 4)
  2337   "RTN","PRC ACPS",90,0 )
  2338    N BN,QUIT
  2339   "RTN","PRC ACPS",91,0 )
  2340    S BN="",Q UIT=0
  2341   "RTN","PRC ACPS",92,0 )
  2342    F  S BN=$ O(^PRCA(43 0,"C",DEBT OR,BN)) Q: 'BN  D  Q: QUIT
  2343   "RTN","PRC ACPS",93,0 )
  2344    .; Check  CURRENT ST ATUS (#8)  for status  of REFUND  REVIEW (# 44)
  2345   "RTN","PRC ACPS",94,0 )
  2346    .I $P($G( ^PRCA(430, BN,0)),U,8 )=44 S QUI T=1 Q
  2347   "RTN","PRC ACPS",95,0 )
  2348    Q QUIT
  2349   "RTN","PRC ACPS",96,0 )
  2350    ;
  2351   "RTN","PRC ACPS",97,0 )
  2352   ENTER(DEBT OR) ;
  2353   "RTN","PRC ACPS",98,0 )
  2354    S (PBAL,B BAL,TBAL)= 0 K ^TMP(" PRCAGTPS", $J)
  2355   "RTN","PRC ACPS",99,0 )
  2356    ; Get las t type of  event for  debtor by  calling $$ LST^RCFN01 . Referenc es files 
  2357   #340 and # 341.1
  2358   "RTN","PRC ACPS",100, 0)
  2359    S DAT=$$L ST^RCFN01( DEBTOR,2)  I DAT<1 S  DAT=0
  2360   "RTN","PRC ACPS",101, 0)
  2361    ; PBAL^PR CAGU gets  previous b alance and  date of l ast transa ction from  the AR E
  2362   VENT file  (#341)
  2363   "RTN","PRC ACPS",102, 0)
  2364    I DAT S D AT=9999999 .999999-DA T D PBAL^P RCAGU(DEBT OR,.DAT,.P BAL)
  2365   "RTN","PRC ACPS",103, 0)
  2366    D EN(DEBT OR,DAT)
  2367   "RTN","PRC ACPS",104, 0)
  2368    K BBAL,TB AL,DAT
  2369   "RTN","PRC ACPS",105, 0)
  2370    Q
  2371   "RTN","PRC ACPS",106, 0)
  2372    ;
  2373   "RTN","PRC ACPS",107, 0)
  2374   EN(DEBTOR, BEG,END,TT Y) ;
  2375   "RTN","PRC ACPS",108, 0)
  2376    NEW Y
  2377   "RTN","PRC ACPS",109, 0)
  2378    ; If Begi nning date  is not de fined, set  it to 0 t o start at  beginning
  2379   "RTN","PRC ACPS",110, 0)
  2380    ; If End  date is no t defined,  set it to  today's d ate
  2381   "RTN","PRC ACPS",111, 0)
  2382    S:$G(BEG) ="" BEG=0  I $G(END)= "" D NOW^% DTC S END= % K %
  2383   "RTN","PRC ACPS",112, 0)
  2384    S TTY=$G( TTY) I TTY ="" D F430
  2385   "RTN","PRC ACPS",113, 0)
  2386    D F433
  2387   "RTN","PRC ACPS",114, 0)
  2388   Q Q
  2389   "RTN","PRC ACPS",115, 0)
  2390   F430 ; Che cks for AC COUNTS REC EIVABLE fi le (#430)  for bills  with (#3)  ORIGINAL 
  2391   AMOUNT has  a value,
  2392   "RTN","PRC ACPS",116, 0)
  2393    ; set thi s into the  ^TMP glob al with _" ^0"
  2394   "RTN","PRC ACPS",117, 0)
  2395    NEW DAT,B N
  2396   "RTN","PRC ACPS",118, 0)
  2397    S DAT=BEG  F  S DAT= $O(^PRCA(4 30,"ATD",D EBTOR,DAT) ) Q:('DAT) !(DAT>END)   S BN=0 
  2398   F  S BN=$O (^PRCA(430 ,"ATD",DEB TOR,DAT,BN )) Q:'BN   D
  2399   "RTN","PRC ACPS",119, 0)
  2400    .; Add th e original  amount if  it is wit hin date r ange based  on the da te of the
  2401    last stat ement
  2402   "RTN","PRC ACPS",120, 0)
  2403    .I $P(^PR CA(430,BN, 0),U,3) S  ^TMP("PRCA GTPS",$J,D EBTOR,BN,0 )=$P(^PRCA (430,BN,0
  2404   ),"^",3)_" ^0"
  2405   "RTN","PRC ACPS",121, 0)
  2406    Q
  2407   "RTN","PRC ACPS",122, 0)
  2408   F433 ;
  2409   "RTN","PRC ACPS",123, 0)
  2410    NEW DAT,T N
  2411   "RTN","PRC ACPS",124, 0)
  2412    ; Loop th rough the  Dates and  Bills
  2413   "RTN","PRC ACPS",125, 0)
  2414    F DAT=BEG :0 S DAT=$ O(^PRCA(43 3,"ATD",DE BTOR,DAT))  Q:('DAT)! (DAT>END)   F TN=0:0
  2415    S TN=$O(^ PRCA(433," ATD",DEBTO R,DAT,TN))  Q:'TN  D
  2416   "RTN","PRC ACPS",126, 0)
  2417    .S TCMPLT ="",TMBSNC ="",TRDMRD ="",COMM=0
  2418   "RTN","PRC ACPS",127, 0)
  2419    .S TN0=$G (^PRCA(433 ,TN,0)) Q: TN0=""
  2420   "RTN","PRC ACPS",128, 0)
  2421    .S TN1=$G (^PRCA(433 ,TN,1))
  2422   "RTN","PRC ACPS",129, 0)
  2423    .S TN3=$G (^PRCA(433 ,TN,3))
  2424   "RTN","PRC ACPS",130, 0)
  2425    .I $P(TN1 ,U,2)="" Q   ;MISSING  TRANS TYP E
  2426   "RTN","PRC ACPS",131, 0)
  2427    .I $P(TN0 ,U,10)=1 S  TCMPLT=1
  2428   "RTN","PRC ACPS",132, 0)
  2429    .I $P(TN1 ,U,2)=45 S  COMM=1 G  F433A
  2430   "RTN","PRC ACPS",133, 0)
  2431    .I $G(TTY )'="" Q:TT Y'=$P(TN1, U,2)
  2432   "RTN","PRC ACPS",134, 0)
  2433    .; Quit i f Transact ion Type i s blank or  one of th e followin g:
  2434   "RTN","PRC ACPS",135, 0)
  2435    .; 3:REFE R TO RC, 4 :REFER TO  DOJ, 5:REE STABLISH T O RC/DOJ,  6:RETURNED  BY RC/DO
  2436   J
  2437   "RTN","PRC ACPS",136, 0)
  2438    .; 7:CASH  COLLECTIO N BY RC/DO J, 24:MARS HAL/COURT  COST, 25:R EPAYMENT P LAN, 30:D
  2439   EBIT VOUCH ER (SF 551 5)
  2440   "RTN","PRC ACPS",137, 0)
  2441    .I TTY="" ,",3,4,5,6 ,7,24,25,3 0,"[(","_$ P(TN1,U,2) _",") Q
  2442   "RTN","PRC ACPS",138, 0)
  2443    .; QUIT i f BILL NUM BER (#.03) = blank OR  TRANSACTI ON STATUS  (#4) '= CO MPLETE
  2444   "RTN","PRC ACPS",139, 0)
  2445    .I ($P(TN 0,U,2)="") !($P(TN0,U ,4)'=2) Q
  2446   "RTN","PRC ACPS",140, 0)
  2447    .; IF PRC AHIST="THI ST" AND TR ANSACTION  TYPE (#12)  = COMMENT  (#45) cal l F433A t
  2448   o Set the  data into  ^TMP("PRCA GTPS",$J,D EBTOR
  2449   "RTN","PRC ACPS",141, 0)
  2450    .I $G(PRC AHIST)="TH IST",$P(TN 1,U,2)=45  G F433A
  2451   "RTN","PRC ACPS",142, 0)
  2452    .; IF TRA NSACTION T YPE (#12)  '= to 46   UNSUSPENDE D AND TRAN SACTION TY PE (#12)'
  2453   = to 47  C HARGE SUSP ENDED
  2454   "RTN","PRC ACPS",143, 0)
  2455    .I $P(TN1 ,"^",2)'=4 6,$P(TN1," ^",2)'=47  D  I TN1=" " Q
  2456   "RTN","PRC ACPS",144, 0)
  2457    ..N RCTRA NDA,RCSTOP ,TRANTYPE
  2458   "RTN","PRC ACPS",145, 0)
  2459    ..S RCSTO P=0
  2460   "RTN","PRC ACPS",146, 0)
  2461    ..; Loop  BACKWARDS  through th e BILL NUM BER "C" x- ref
  2462   "RTN","PRC ACPS",147, 0)
  2463    ..S RCTRA NDA=TN
  2464   "RTN","PRC ACPS",148, 0)
  2465    ..F  S RC TRANDA=$O( ^PRCA(433, "C",+$P(TN 0,"^",2),R CTRANDA),- 1) Q:'RCTR ANDA  D  
  2466   I RCSTOP Q
  2467   "RTN","PRC ACPS",149, 0)
  2468    ...; QUIT  if TRANSA CTION STAT US (#4) '=  COMPLETE
  2469   "RTN","PRC ACPS",150, 0)
  2470    ...I $P($ G(^PRCA(43 3,RCTRANDA ,0)),"^",4 )'=2 Q
  2471   "RTN","PRC ACPS",151, 0)
  2472    ...; Load  Transacti on Type
  2473   "RTN","PRC ACPS",152, 0)
  2474    ...S TRAN TYPE=$P($G (^PRCA(433 ,RCTRANDA, 1)),"^",2)
  2475   "RTN","PRC ACPS",153, 0)
  2476    ...; IF T RANSACTION  TYPE (#12 ) = 46 UNS USPENDED s et stop &  Quit
  2477   "RTN","PRC ACPS",154, 0)
  2478    ...I TRAN TYPE=46 S  RCSTOP=1 Q
  2479   "RTN","PRC ACPS",155, 0)
  2480    ...; IF T RANSACTION  TYPE (#12 ) = 47 CHA RGE SUSPEN DED set st op & Quit
  2481   "RTN","PRC ACPS",156, 0)
  2482    ...I TRAN TYPE=47 S  RCSTOP=1,T N1="" Q
  2483   "RTN","PRC ACPS",157, 0)
  2484   F433A .
  2485   "RTN","PRC ACPS",158, 0)
  2486    .; The da ta in the  ^TMP is as  follows:
  2487   "RTN","PRC ACPS",159, 0)
  2488    .; Data =
  2489   "RTN","PRC ACPS",160, 0)
  2490    .; 1. TRA NS. AMOUNT  (#15)              $ P(TN1,U,5)
  2491   "RTN","PRC ACPS",161, 0)
  2492    .; 2. TRA NSACTION T YPE (#12)           $ P(TN1,U,2)
  2493   "RTN","PRC ACPS",162, 0)
  2494    .; 3. PRI N.COLLECTE D (#31)             $ P(TN3,U,1)
  2495   "RTN","PRC ACPS",163, 0)
  2496    .; 4. INT EREST COLL ECTED (#32 )        $ P(TN3,U,2)
  2497   "RTN","PRC ACPS",164, 0)
  2498    .; 5. ADM IN.COLLECT ED (#33)            $ P(TN3,U,3)
  2499   "RTN","PRC ACPS",165, 0)
  2500    .; 6. MAR SHAL FEE C OLLECTED ( #34)     $ P(TN3,U,4)
  2501   "RTN","PRC ACPS",166, 0)
  2502    .; 7. COU RT COST CO LLECTED (# 35)      $ P(TN3,U,5)
  2503   "RTN","PRC ACPS",167, 0)
  2504    .; 8. TOT AL OF #3 -  #7                 $ P(TN3,U,1) +$P(TN3,U, 2)+$P(TN3, U,3)+$P(T
  2505   N3,U,4)+$P (TN3,U,5)
  2506   "RTN","PRC ACPS",168, 0)
  2507    .; 9. TCM PLT                            ( #10) INCOM PLETE TRAN SACTION FL AG
  2508   "RTN","PRC ACPS",169, 0)
  2509    .;10. TRD MRD - Does n't appear  to be use d
  2510   "RTN","PRC ACPS",170, 0)
  2511    .;11. TMB SNC - Does n't appear  to be use d
  2512   "RTN","PRC ACPS",171, 0)
  2513    .;12. Dup licate fla g for use  in START2  1=duplicat e, 0=not a  duplicate . Set in 
  2514   BILLQUIT^P RCACPSA
  2515   "RTN","PRC ACPS",172, 0)
  2516    .;
  2517   "RTN","PRC ACPS",173, 0)
  2518    .N PRCATE MP
  2519   "RTN","PRC ACPS",174, 0)
  2520    .S PRCATE MP=$P(TN1, U,5)_U_$P( TN1,U,2)_U _$P(TN3,U, 1)_U_$P(TN 3,U,2)_U_$ P(TN3,U,3
  2521   )_U_$P(TN3 ,U,4)_U_$P (TN3,U,5)
  2522   "RTN","PRC ACPS",175, 0)
  2523    .S PRCATE MP=PRCATEM P_U_($P(TN 3,U,1)+$P( TN3,U,2)+$ P(TN3,U,3) +$P(TN3,U, 4)+$P(TN3
  2524   ,U,5))
  2525   "RTN","PRC ACPS",176, 0)
  2526    .S PRCATE MP=PRCATEM P_U_TCMPLT
  2527   "RTN","PRC ACPS",177, 0)
  2528    .S PRCATE MP=PRCATEM P_U_TRDMRD
  2529   "RTN","PRC ACPS",178, 0)
  2530    .S PRCATE MP=PRCATEM P_U_TMBSNC
  2531   "RTN","PRC ACPS",179, 0)
  2532    .S ^TMP(" PRCAGTPS", $J,DEBTOR, $P(TN0,U,2 ),TN)=PRCA TEMP
  2533   "RTN","PRC ACPS",180, 0)
  2534    .K TN0,TN 1,TN3,TCMP LT,TRDMRD, TMBSNC,COM M
  2535   "RTN","PRC ACPS",181, 0)
  2536    K PRCAHIS T
  2537   "RTN","PRC ACPS",182, 0)
  2538    Q
  2539   "RTN","PRC ACPS",183, 0)
  2540    ;
  2541   "RTN","PRC ACPS",184, 0)
  2542   START1 ;
  2543   "RTN","PRC ACPS",185, 0)
  2544    ;
  2545   "RTN","PRC ACPS",186, 0)
  2546    S BILL=""
  2547   "RTN","PRC ACPS",187, 0)
  2548    S CBALTOT =0 ; Will  be the tot al of all  CURRENT BA LANCE fiel d (#11) fo r the bil
  2549   l
  2550   "RTN","PRC ACPS",188, 0)
  2551    ; ACCOUNT S RECEIVAB LE (#430)  The C cros s-referenc e allows u ser look-u p of bill
  2552   s belongin g to a spe cific debt or.
  2553   "RTN","PRC ACPS",189, 0)
  2554    ; Loop th rough bill s
  2555   "RTN","PRC ACPS",190, 0)
  2556    ; ^TMP("P RCABILL",$ J,DEBTOR,B ILL)= Sum  of CURRENT  BALANCE f ield (#11)  for the 
  2557   Bill
  2558   "RTN","PRC ACPS",191, 0)
  2559    ;                                    ^Sum  of TRANS.  AMOUNT (#1 5) for all  transact
  2560   ions for t he Bill
  2561   "RTN","PRC ACPS",192, 0)
  2562    ;                                    ^Stop  Flag if t he Bill ha s more tha n one err
  2563   or 
  2564   "RTN","PRC ACPS",193, 0)
  2565    K ^TMP("P RCABILL",$ J)
  2566   "RTN","PRC ACPS",194, 0)
  2567    F  S BILL =$O(^PRCA( 430,"C",DE BTOR,BILL) ) Q:BILL'? 1N.N  D
  2568   "RTN","PRC ACPS",195, 0)
  2569    .; BILLTO T is the C URRENT BAL ANCE field  (#11) for  each Bill  for the D ebtor
  2570   "RTN","PRC ACPS",196, 0)
  2571    .N BILLTO T
  2572   "RTN","PRC ACPS",197, 0)
  2573    .S BN0=$G (^PRCA(430 ,BILL,0))
  2574   "RTN","PRC ACPS",198, 0)
  2575    .; QUIT:  CURRENT ST ATUS (#8)  '= ACTIVE
  2576   "RTN","PRC ACPS",199, 0)
  2577    .; I $P(B N0,U,8)'=1 6 Q  based  on call o n 11/28/16  process a ll bill wi th a stat
  2578   us other t han Refund  Review
  2579   "RTN","PRC ACPS",200, 0)
  2580    .; Skip a ll Debtors  with 1 or  more Bill s with a s tatus of R EFEUND REV IEW (#44)
  2581   .  This ch eck is don e in
  2582   "RTN","PRC ACPS",201, 0)
  2583    .; REFREV  above.
  2584   "RTN","PRC ACPS",202, 0)
  2585    .; Sum up  CURRENT B ALANCE (#1 1) for eac h ACTIVE B ill
  2586   "RTN","PRC ACPS",203, 0)
  2587    .; Set in  CBALTOT f or BALDIFF  and in PR CABILL for  BILLDIFF  in Start2
  2588   "RTN","PRC ACPS",204, 0)
  2589    .; S CBAL TOT=CBALTO T+$$GET1^D IQ(430,BIL L,11)
  2590   "RTN","PRC ACPS",205, 0)
  2591    .S BILLTO T=$$GET1^D IQ(430,BIL L,11) ; Ge t CURRENT  BALANCE (# 11) which  is comput
  2592   ed: #71+#7 2+#73+#74+ #75
  2593   "RTN","PRC ACPS",206, 0)
  2594    .S ^TMP(" PRCABILL", $J,DEBTOR, BILL)=+BIL LTOT
  2595   "RTN","PRC ACPS",207, 0)
  2596    .S CBALTO T=CBALTOT+ BILLTOT
  2597   "RTN","PRC ACPS",208, 0)
  2598    N BILL,I, TN,TRANSTO T,TNVAL,TT YPE,TNTOT
  2599   "RTN","PRC ACPS",209, 0)
  2600    S TN="",( BILL,TRANS TOT,TTYPE, TNVAL)=0
  2601   "RTN","PRC ACPS",210, 0)
  2602    ; Loop th rough Bill s
  2603   "RTN","PRC ACPS",211, 0)
  2604    F  S BILL =$O(^TMP(" PRCAGTPS", $J,DEBTOR, BILL)) Q:B ILL=""  D
  2605   "RTN","PRC ACPS",212, 0)
  2606    .; Call B ILLQUIT to  determine  if this b ill has mu ltiple iss ues
  2607   "RTN","PRC ACPS",213, 0)
  2608    .I $$BILL QUIT^PRCAC PSA(DEBTOR ,BILL) Q
  2609   "RTN","PRC ACPS",214, 0)
  2610    .; Initia lize TNTOT  for Trans action Tot al for thi s bill
  2611   "RTN","PRC ACPS",215, 0)
  2612    .I $G(TNT OT(BILL))= "" S TNTOT (BILL)=0
  2613   "RTN","PRC ACPS",216, 0)
  2614    .; Loop t hrough Tra nsactions
  2615   "RTN","PRC ACPS",217, 0)
  2616    .S TN=""  F  S TN=$O (^TMP("PRC AGTPS",$J, DEBTOR,BIL L,TN)) Q:T N=""  D
  2617   "RTN","PRC ACPS",218, 0)
  2618    ..; IF Tr ansaction  # = 0 Add  TRANS. AMO UNT (#15)  to the Tra nsaction T otal
  2619   "RTN","PRC ACPS",219, 0)
  2620    ..I TN=0  S TRANSTOT =TRANSTOT+ ^TMP("PRCA GTPS",$J,D EBTOR,BILL ,TN) Q
  2621   "RTN","PRC ACPS",220, 0)
  2622    ..; S TNV AL = (#15)  TRANS. AM OUNT from  #433
  2623   "RTN","PRC ACPS",221, 0)
  2624    ..S TNVAL =+^TMP("PR CAGTPS",$J ,DEBTOR,BI LL,TN)
  2625   "RTN","PRC ACPS",222, 0)
  2626    ..; S TTY PE = (#12)  TRANSACTI ON TYPE fr om #433
  2627   "RTN","PRC ACPS",223, 0)
  2628    ..S TTYPE =+$P(^TMP( "PRCAGTPS" ,$J,DEBTOR ,BILL,TN), U,2)
  2629   "RTN","PRC ACPS",224, 0)
  2630    ..; IF IN COMPLETE T RANSACTION  FLAG is s et, set Tr ansaction  amount = 0
  2631   "RTN","PRC ACPS",225, 0)
  2632    ..S TCMPL T=+$P(^TMP ("PRCAGTPS ",$J,DEBTO R,BILL,TN) ,U,9)
  2633   "RTN","PRC ACPS",226, 0)
  2634    ..I TCMPL T S TNVAL= 0
  2635   "RTN","PRC ACPS",227, 0)
  2636    ..S TMBSN C=$P(^TMP( "PRCAGTPS" ,$J,DEBTOR ,BILL,TN), U,11)
  2637   "RTN","PRC ACPS",228, 0)
  2638    ..I TMBSN C S TNVAL= 0
  2639   "RTN","PRC ACPS",229, 0)
  2640    ..; Set T NVAL =0 if  one of th e followin g Transact ion Types:
  2641   "RTN","PRC ACPS",230, 0)
  2642    ..; 3:REF ER TO RC,  4:REFER TO  DOJ, 5:RE ESTABLISH  TO RC/DOJ,  6:RETURNE D BY RC/D
  2643   OJ
  2644   "RTN","PRC ACPS",231, 0)
  2645    ..; 25:RE PAYMENT PL AN, 32:RET URNED FOR  AMENDMENT,  33:AMENDE D BILL
  2646   "RTN","PRC ACPS",232, 0)
  2647    ..I (TTYP E=3)!(TTYP E=4)!(TTYP E=5)!(TTYP E=6)!(TTYP E=32)!(TTY PE=25)!(TT YPE=33) S
  2648    TNVAL=0
  2649   "RTN","PRC ACPS",233, 0)
  2650    ..; Set T NVAL to ne gative val ue if one  of the Tra nsaction T ypes:
  2651   "RTN","PRC ACPS",234, 0)
  2652    ..; 2:PAY MENT (IN P ART), 8:TE RM.BY FIS. OFFICER, 9 :TERM.BY C OMPROMISE,  10:WAIVE
  2653   D IN FULL
  2654   "RTN","PRC ACPS",235, 0)
  2655    ..; 11:WA IVED IN PA RT, 14:EXE MPT INT/AD M. COST, 2 9:TERM.BY  RC/DOJ, 34 :PAYMENT 
  2656   (IN FULL)
  2657   "RTN","PRC ACPS",236, 0)
  2658    ..; 35:DE CREASE ADJ USTMENT, 4 1:REFUNDED , 47:CHARG E SUSPENDE D
  2659   "RTN","PRC ACPS",237, 0)
  2660    ..I TTYPE =2!(TTYPE= 8)!(TTYPE= 9)!(TTYPE= 10)!(TTYPE =11)!(TTYP E=14)!(TTY PE=29)!(T
  2661   TYPE=34)!( TTYPE=35)! (TTYPE=41) !(TTYPE=47 ) S TNVAL= -TNVAL
  2662   "RTN","PRC ACPS",238, 0)
  2663    ..; Updat e Transact ion Total
  2664   "RTN","PRC ACPS",239, 0)
  2665    ..S TRANS TOT=TRANST OT+TNVAL
  2666   "RTN","PRC ACPS",240, 0)
  2667    ..; Updat e Transact ion Total  for this B ill
  2668   "RTN","PRC ACPS",241, 0)
  2669    ..S TNTOT (BILL)=TNT OT(BILL)+T NVAL
  2670   "RTN","PRC ACPS",242, 0)
  2671    .; Update  PRCABILL  with Trans action Tot al for thi s Bill
  2672   "RTN","PRC ACPS",243, 0)
  2673    .S $P(^TM P("PRCABIL L",$J,DEBT OR,BILL),U ,2)=TNTOT( BILL)
  2674   "RTN","PRC ACPS",244, 0)
  2675    ; Set Bal ance Diffe rence = Su m up CURRE NT BALANCE  (#8) for  each ACTIV E Bill - 
  2676   Transactio n Total -  PBAL from  AR EVENT f ile (#341)
  2677   "RTN","PRC ACPS",245, 0)
  2678    S BALDIFF =CBALTOT-T RANSTOT-PB AL
  2679   "RTN","PRC ACPS",246, 0)
  2680    K CBALTOT ,TRANSTOT, PBAL,TCMPL T,BILL,BN0
  2681   "RTN","PRC ACPS",247, 0)
  2682    Q
  2683   "RTN","PRC ACPS",248, 0)
  2684    ;
  2685   "RTN","PRC ACPS",249, 0)
  2686   START2 ;
  2687   "RTN","PRC ACPS",250, 0)
  2688    N I,ATNLA ST,BILL,BI LLCNT,BILL CNTR,BILLN UM,FIXED,T N,TN9,TRAN STOT,TNVAL ,TTYPE,TC
  2689   PLT,STOP,T RANCRNT,TR ANPREV,TNL AST
  2690   "RTN","PRC ACPS",251, 0)
  2691    S (BILL,B ILLCNTR,FI XED)=0,ATN LAST=""
  2692   "RTN","PRC ACPS",252, 0)
  2693    ; ATNLAST  = The las t number f or the acc ount
  2694   "RTN","PRC ACPS",253, 0)
  2695    ; FIXED =  Account l evel flag  noting if  anything w as fixed f or this ac count
  2696   "RTN","PRC ACPS",254, 0)
  2697    ; PRCAFIX (X) = Hold s the tota l of the n umber of t ransaction s for a bi ll that m
  2698   atch to ch eck criter ia X
  2699   "RTN","PRC ACPS",255, 0)
  2700    ; Determi ne the num ber of bil l for this  account
  2701   "RTN","PRC ACPS",256, 0)
  2702    S (BILLCN T,BILLCNTR )=0,BILLNU M=""
  2703   "RTN","PRC ACPS",257, 0)
  2704    ; Determi ne the num ber of bil ls for thi s account
  2705   "RTN","PRC ACPS",258, 0)
  2706    F  S BILL NUM=$O(^TM P("PRCAGTP S",$J,DEBT OR,BILLNUM )) S BILLC NT=BILLCNT +1 Q:'BIL
  2707   LNUM
  2708   "RTN","PRC ACPS",259, 0)
  2709    ; Loop th rough Bill s
  2710   "RTN","PRC ACPS",260, 0)
  2711    F  S BILL =$O(^TMP(" PRCAGTPS", $J,DEBTOR, BILL)) Q:B ILL=""  D
  2712   "RTN","PRC ACPS",261, 0)
  2713    .S BILLCN TR=BILLCNT R+1
  2714   "RTN","PRC ACPS",262, 0)
  2715    .; QUIT i f STOP fla g is set f or this Bi ll
  2716   "RTN","PRC ACPS",263, 0)
  2717    .I $P($G( ^TMP("PRCA BILL",$J,D EBTOR,BILL )),U,3)=1  Q
  2718   "RTN","PRC ACPS",264, 0)
  2719    .; New an d set Bill  Balance D ifference
  2720   "RTN","PRC ACPS",265, 0)
  2721    .N BILLDI FF
  2722   "RTN","PRC ACPS",266, 0)
  2723    .; If the  Original  Bill Amoun t is not n ull use th is formula
  2724   "RTN","PRC ACPS",267, 0)
  2725    .I +$G(^T MP("PRCAGT PS",$J,DEB TOR,BILL,0 )) D
  2726   "RTN","PRC ACPS",268, 0)
  2727    ..S BILLD IFF=$P($G( ^TMP("PRCA GTPS",$J,D EBTOR,BILL ,0)),U,1)- ($P($G(^TM P("PRCABI
  2728   LL",$J,DEB TOR,BILL)) ,U,1)+$P($ G(^TMP("PR CABILL",$J ,DEBTOR,BI LL)),U,2))
  2729   "RTN","PRC ACPS",269, 0)
  2730    .; If the  Original  Amount is  null use t his formul
  2731   "RTN","PRC ACPS",270, 0)
  2732    .I '+$G(^ TMP("PRCAG TPS",$J,DE BTOR,BILL, 0)) D
  2733   "RTN","PRC ACPS",271, 0)
  2734    ..S BILLD IFF=$P($G( ^TMP("PRCA BILL",$J,D EBTOR,BILL )),U,1)-$P ($G(^TMP(" PRCABILL"
  2735   ,$J,DEBTOR ,BILL)),U, 2)
  2736   "RTN","PRC ACPS",272, 0)
  2737    .; Quit i f Bill Bal ance Diffe rence is z ero
  2738   "RTN","PRC ACPS",273, 0)
  2739    .I 'BILLD IFF Q
  2740   "RTN","PRC ACPS",274, 0)
  2741    .; PRCAFI X(X) = Hol ds the tot al of the  number of  transactio ns for a b ill that 
  2742   match to c heck crite ria X
  2743   "RTN","PRC ACPS",275, 0)
  2744    .; PRCATT TF = Total  Transacti on Types t o Fix
  2745   "RTN","PRC ACPS",276, 0)
  2746    .N PRCATT TF,PRCAFIX
  2747   "RTN","PRC ACPS",277, 0)
  2748    .S (PRCAT TTF,TRANST OT,TTYPE,T NVAL)=0
  2749   "RTN","PRC ACPS",278, 0)
  2750    .S (TN,TN LAST)=""
  2751   "RTN","PRC ACPS",279, 0)
  2752    .; Initia lize type  of fix cou nts
  2753   "RTN","PRC ACPS",280, 0)
  2754    .F I=1:1: 4 S PRCAFI X(I)=""
  2755   "RTN","PRC ACPS",281, 0)
  2756    .;
  2757   "RTN","PRC ACPS",282, 0)
  2758    .F  S TN= $O(^TMP("P RCAGTPS",$ J,DEBTOR,B ILL,TN)) Q :TN=""  D
  2759   "RTN","PRC ACPS",283, 0)
  2760    ..; Save  first tran saction nu mber
  2761   "RTN","PRC ACPS",284, 0)
  2762    ..S (ATNL AST,TNLAST )=TN
  2763   "RTN","PRC ACPS",285, 0)
  2764    ..; IF Tr ansaction  number = 0  update Tr ansaction  Total with  (#15) TRA NS. AMOUN
  2765   T from #43 3
  2766   "RTN","PRC ACPS",286, 0)
  2767    ..I TN=0  S TRANSTOT =TRANSTOT+ ^TMP("PRCA GTPS",$J,D EBTOR,BILL ,TN) Q
  2768   "RTN","PRC ACPS",287, 0)
  2769    ..; Set T NVAL = (#1 5) TRANS.  AMOUNT fro m #433
  2770   "RTN","PRC ACPS",288, 0)
  2771    ..S TNVAL =$P(^TMP(" PRCAGTPS", $J,DEBTOR, BILL,TN),U ,1)
  2772   "RTN","PRC ACPS",289, 0)
  2773    ..; Set T TYPE = (#1 2) TRANSAC TION TYPE  from #433
  2774   "RTN","PRC ACPS",290, 0)
  2775    ..S TTYPE =+$P(^TMP( "PRCAGTPS" ,$J,DEBTOR ,BILL,TN), U,2)
  2776   "RTN","PRC ACPS",291, 0)
  2777    ..; Set T CPLT = (#1 0) INCOMPL ETE TRANSA CTION FLAG
  2778   "RTN","PRC ACPS",292, 0)
  2779    ..S TCPLT =+$P($G(^P RCA(433,TN ,0)),U,10)
  2780   "RTN","PRC ACPS",293, 0)
  2781    ..; I thi nk this wi ll always  be blank
  2782   "RTN","PRC ACPS",294, 0)
  2783    ..S TRDMR D=$P(^TMP( "PRCAGTPS" ,$J,DEBTOR ,BILL,TN), U,10)
  2784   "RTN","PRC ACPS",295, 0)
  2785    ..; I thi nk this wi ll always  be blank
  2786   "RTN","PRC ACPS",296, 0)
  2787    ..S TMBSN C=$P(^TMP( "PRCAGTPS" ,$J,DEBTOR ,BILL,TN), U,11)
  2788   "RTN","PRC ACPS",297, 0)
  2789    ..; Quit  it this tr ansaction  was previo usly used  to correct  an out of  balance 
  2790   scenario
  2791   "RTN","PRC ACPS",298, 0)
  2792    ..S TN9=$ G(^PRCA(43 3,TN,9))
  2793   "RTN","PRC ACPS",299, 0)
  2794    ..Q:$P(TN 9,U,4)'=""
  2795   "RTN","PRC ACPS",300, 0)
  2796    ..;
  2797   "RTN","PRC ACPS",301, 0)
  2798    ..; *** T he Null tr ansaction  check will  be implem ented in P RCA*4.5*31 3 ***
  2799   "RTN","PRC ACPS",302, 0)
  2800    ..; Check  #1 - Tran saction wi th missing  $ amount  & Transact ion Type ' = Comment
  2801    (#45)
  2802   "RTN","PRC ACPS",303, 0)
  2803    ..;I TNVA L="",(TTYP E'=45) D   Q
  2804   "RTN","PRC ACPS",304, 0)
  2805    ..;.S PRC AFIX(1)=$G (PRCAFIX(1 ))+1,IENCR RT=TN
  2806   "RTN","PRC ACPS",305, 0)
  2807    ..;.S PRC AFIX(1,TN) =""
  2808   "RTN","PRC ACPS",306, 0)
  2809    ..;
  2810   "RTN","PRC ACPS",307, 0)
  2811    ..; Check  #2 - Tran saction ma rked as In complete w ith +$ amo unt matchi ng off by
  2812    amount
  2813   "RTN","PRC ACPS",308, 0)
  2814    ..I TNVAL =BILLDIFF  I TCPLT D   Q
  2815   "RTN","PRC ACPS",309, 0)
  2816    ...Q:(TTY PE=45)
  2817   "RTN","PRC ACPS",310, 0)
  2818    ...I TRDM RD Q
  2819   "RTN","PRC ACPS",311, 0)
  2820    ...S PRCA FIX(2)=$G( PRCAFIX(2) )+1,IENCRR T=TN
  2821   "RTN","PRC ACPS",312, 0)
  2822    ...S PRCA FIX(2,TN)= ""
  2823   "RTN","PRC ACPS",313, 0)
  2824    ..;
  2825   "RTN","PRC ACPS",314, 0)
  2826    ..; Check  #3 - Tran saction ma rked as In complete w ith -$ amo unt matchi ng off by
  2827    amount`
  2828   "RTN","PRC ACPS",315, 0)
  2829    ..I -TNVA L=BILLDIFF  I TCPLT D   Q
  2830   "RTN","PRC ACPS",316, 0)
  2831    ...Q:(TTY PE=45)
  2832   "RTN","PRC ACPS",317, 0)
  2833    ...S PRCA FIX(3)=$G( PRCAFIX(3) )+1,IENCRR T=TN
  2834   "RTN","PRC ACPS",318, 0)
  2835    ...S PRCA FIX(3,TN)= ""
  2836   "RTN","PRC ACPS",319, 0)
  2837    ..;
  2838   "RTN","PRC ACPS",320, 0)
  2839    ..; Check  #4 - Dupl icate Tran saction
  2840   "RTN","PRC ACPS",321, 0)
  2841    ..I TTYPE '=45,($P(^ TMP("PRCAG TPS",$J,DE BTOR,BILL, TN),U,12)= 1) D
  2842   "RTN","PRC ACPS",322, 0)
  2843    ...S PRCA FIX(4)=$G( PRCAFIX(4) )+1,IENCRR T=TN
  2844   "RTN","PRC ACPS",323, 0)
  2845    ...S PRCA FIX(4,TN)= ""
  2846   "RTN","PRC ACPS",324, 0)
  2847    .;
  2848   "RTN","PRC ACPS",325, 0)
  2849    .; Quit i f there we re no tran sactions f or this bi ll
  2850   "RTN","PRC ACPS",326, 0)
  2851    .I $G(IEN CRRT)=""!( $G(TNLAST) ="") Q
  2852   "RTN","PRC ACPS",327, 0)
  2853    .; If we  are on the  last Bill  and there  were no t ransaction s for the  entire ac
  2854   count Quit
  2855   "RTN","PRC ACPS",328, 0)
  2856    .I BILLCN TR=BILLCNT ,ATNLAST=" " Q
  2857   "RTN","PRC ACPS",329, 0)
  2858    .;
  2859   "RTN","PRC ACPS",330, 0)
  2860    .F I=1:1: 4 D
  2861   "RTN","PRC ACPS",331, 0)
  2862    ..S PRCAT TTF=PRCATT TF+PRCAFIX (I)
  2863   "RTN","PRC ACPS",332, 0)
  2864    .; if you  get to he re the bil l was out  of balance  and if it  shows not hing to f
  2865   ix, set la st transac tion
  2866   "RTN","PRC ACPS",333, 0)
  2867    .; for th is Bill to  NOT FIXAB LE
  2868   "RTN","PRC ACPS",334, 0)
  2869    . I PRCAT TTF=0 D UP DTLTR^PRCA CPSA(TNLAS T) S FIXED =1 Q
  2870   "RTN","PRC ACPS",335, 0)
  2871    .; Update  this bill
  2872   "RTN","PRC ACPS",336, 0)
  2873    .D FIXBIL L(.FIXED)
  2874   "RTN","PRC ACPS",337, 0)
  2875    Q:FIXED
  2876   "RTN","PRC ACPS",338, 0)
  2877    ; The acc ount was o ut of bala nce but no thing was  found on a ny bill th at could 
  2878   be fixed.
  2879   "RTN","PRC ACPS",339, 0)
  2880    ; Mark th e last tra nsaction f or the las t bill for  this acco unt as not  fixable.
  2881   "RTN","PRC ACPS",340, 0)
  2882    I 'FIXED, ($G(ATNLAS T))>0 D UP DTLTR^PRCA CPSA(ATNLA ST)
  2883   "RTN","PRC ACPS",341, 0)
  2884    Q
  2885   "RTN","PRC ACPS",342, 0)
  2886    ;
  2887   "RTN","PRC ACPS",343, 0)
  2888   FIXBILL(FI XED) ;Upda te a singl e bill usi ng PRCAFIX  array
  2889   "RTN","PRC ACPS",344, 0)
  2890    ; Make up date deter mination b ased on ch ecks 1 - 4 .
  2891   "RTN","PRC ACPS",345, 0)
  2892    ; Sum up  check tota ls
  2893   "RTN","PRC ACPS",346, 0)
  2894    ;F I=1:1: 4 D
  2895   "RTN","PRC ACPS",347, 0)
  2896    ;.S PRCAT TTF=PRCATT TF+PRCAFIX (I)
  2897   "RTN","PRC ACPS",348, 0)
  2898    ; Get cur rent date/ time
  2899   "RTN","PRC ACPS",349, 0)
  2900    N PRCADAT E
  2901   "RTN","PRC ACPS",350, 0)
  2902    D NOW^%DT C
  2903   "RTN","PRC ACPS",351, 0)
  2904    S PRCADAT E=X
  2905   "RTN","PRC ACPS",352, 0)
  2906    ; Otherwi se there i s only 1 b ad transac tion so up date as ne eded
  2907   "RTN","PRC ACPS",353, 0)
  2908    ; Lock Re cord
  2909   "RTN","PRC ACPS",354, 0)
  2910    L +^PRCA( 433,IENCRR T,9):DILOC KTM
  2911   "RTN","PRC ACPS",355, 0)
  2912    ; If lock  not obtai ned, updat e number o f transact ions that  couldn't b e fixed
  2913   "RTN","PRC ACPS",356, 0)
  2914    Q:'$T
  2915   "RTN","PRC ACPS",357, 0)
  2916    ; Set FDA  array for  the neces sary field s based on  the type  of fix ide ntified
  2917   "RTN","PRC ACPS",358, 0)
  2918    N PRCAFDA
  2919   "RTN","PRC ACPS",359, 0)
  2920    ; *** The  Null tran saction ch eck will b e implemen ted in PRC A*4.5*313  ***
  2921   "RTN","PRC ACPS",360, 0)
  2922    ; Check # 1 - Transa ction with  missing $  amount
  2923   "RTN","PRC ACPS",361, 0)
  2924    ;I PRCAFI X(1) D
  2925   "RTN","PRC ACPS",362, 0)
  2926    ;.S PRCAF DA(433,IEN CRRT_",",1 5)=$S(BILL DIFF>0:BIL LDIFF,1:-B ILLDIFF)
  2927   "RTN","PRC ACPS",363, 0)
  2928    ;.S PRCAF DA(433,IEN CRRT_",",9 4)=PRCADAT E
  2929   "RTN","PRC ACPS",364, 0)
  2930    ;.S PRCAF DA(433,IEN CRRT_",",9 5)=$S(BILL DIFF>0:BIL LDIFF,1:-B ILLDIFF)
  2931   "RTN","PRC ACPS",365, 0)
  2932    ;.S PRCAF DA(433,IEN CRRT_",",9 6)="N" ; N ULL TRANSA CTION AMOU NT
  2933   "RTN","PRC ACPS",366, 0)
  2934    ; Check # 2 - Transa ction mark ed as Inco mplete wit h +$ amoun t matching  off by a
  2935   mount
  2936   "RTN","PRC ACPS",367, 0)
  2937    ; Check # 3 - Transa ction mark ed as Inco mplete wit h -$ amoun t matching  off by a
  2938   mount
  2939   "RTN","PRC ACPS",368, 0)
  2940    I PRCAFIX (2)!(PRCAF IX(3)) D
  2941   "RTN","PRC ACPS",369, 0)
  2942    .S PRCAFD A(433,IENC RRT_",",10 )=""
  2943   "RTN","PRC ACPS",370, 0)
  2944    .S PRCAFD A(433,IENC RRT_",",94 )=PRCADATE
  2945   "RTN","PRC ACPS",371, 0)
  2946    .S PRCAFD A(433,IENC RRT_",",96 )="I" ; IN COMPLETE F LAG ERROR
  2947   "RTN","PRC ACPS",372, 0)
  2948    ; Check # 4 - Duplic ate Transa ction
  2949   "RTN","PRC ACPS",373, 0)
  2950    I PRCAFIX (4) D
  2951   "RTN","PRC ACPS",374, 0)
  2952    .; Null o ut audit f ields on o riginal tr ansaction
  2953   "RTN","PRC ACPS",375, 0)
  2954    .S PRCAFD A(433,IENC RRT-1_",", 94)=""
  2955   "RTN","PRC ACPS",376, 0)
  2956    .S PRCAFD A(433,IENC RRT-1_",", 95)=""
  2957   "RTN","PRC ACPS",377, 0)
  2958    .S PRCAFD A(433,IENC RRT-1_",", 96)=""
  2959   "RTN","PRC ACPS",378, 0)
  2960    .L +^PRCA (433,IENCR RT-1,9):DI LOCKTM
  2961   "RTN","PRC ACPS",379, 0)
  2962    .Q:'$T
  2963   "RTN","PRC ACPS",380, 0)
  2964    .D FILE^D IE(,"PRCAF DA")
  2965   "RTN","PRC ACPS",381, 0)
  2966    .L -^PRCA (433,IENCR RT-1,9)
  2967   "RTN","PRC ACPS",382, 0)
  2968    .; Set th e fields f or the dup licate tra nsaction
  2969   "RTN","PRC ACPS",383, 0)
  2970    .S PRCAFD A(433,IENC RRT_",",10 )=1 ; INCO MPLETE TRA NSACTION
  2971   "RTN","PRC ACPS",384, 0)
  2972    .S PRCAFD A(433,IENC RRT_",",94 )=PRCADATE
  2973   "RTN","PRC ACPS",385, 0)
  2974    .S PRCAFD A(433,IENC RRT_",",95 )=$S(BILLD IFF>0:BILL DIFF,1:-BI LLDIFF)
  2975   "RTN","PRC ACPS",386, 0)
  2976    .S PRCAFD A(433,IENC RRT_",",96 )="D" ; DU PLICATE TR ANSACTION
  2977   "RTN","PRC ACPS",387, 0)
  2978    ; Update  Transactio n
  2979   "RTN","PRC ACPS",388, 0)
  2980    D FILE^DI E(,"PRCAFD A")
  2981   "RTN","PRC ACPS",389, 0)
  2982    S FIXED=1
  2983   "RTN","PRC ACPS",390, 0)
  2984    ; Unlock  file
  2985   "RTN","PRC ACPS",391, 0)
  2986    L -^PRCA( 433,IENCRR T,9)
  2987   "RTN","PRC ACPS",392, 0)
  2988    K TMBSNC, IENCRRT
  2989   "RTN","PRC ACPS",393, 0)
  2990    Q
  2991   "RTN","PRC ACPS",394, 0)
  2992    ;
  2993   "RTN","PRC ACPS",395, 0)
  2994   DIQOUTCS(D IQOUT) ;Re turn check sum for a  processed  DIQOUT arr ay.
  2995   "RTN","PRC ACPS",396, 0)
  2996    N CS,DATA ,FIELD,FNU M,IENS,IND ,SFN,STRIN G,TARGET,T EXT,WP
  2997   "RTN","PRC ACPS",397, 0)
  2998    S FNUM=$O (DIQOUT("" ))
  2999   "RTN","PRC ACPS",398, 0)
  3000    S (CS,FNU M)=0
  3001   "RTN","PRC ACPS",399, 0)
  3002    F  S FNUM =$O(DIQOUT (FNUM)) Q: FNUM=""  D
  3003   "RTN","PRC ACPS",400, 0)
  3004    .S IENS=" "
  3005   "RTN","PRC ACPS",401, 0)
  3006    .F  S IEN S=$O(DIQOU T(FNUM,IEN S)) Q:IENS =""  D
  3007   "RTN","PRC ACPS",402, 0)
  3008    ..S FIELD =0
  3009   "RTN","PRC ACPS",403, 0)
  3010    ..F  S FI ELD=$O(DIQ OUT(FNUM,I ENS,FIELD) ) Q:FIELD= ""  D
  3011   "RTN","PRC ACPS",404, 0)
  3012    ...S DATA =DIQOUT(FN UM,IENS,FI ELD)
  3013   "RTN","PRC ACPS",405, 0)
  3014    ...S TEXT =FNUM_$L(I ENS,",")_F IELD_DATA
  3015   "RTN","PRC ACPS",406, 0)
  3016    ...S CS=$ $CRC32^XLF CRC(TEXT,C S)
  3017   "RTN","PRC ACPS",407, 0)
  3018    Q CS
  3019   "RTN","PRC ACPS",408, 0)
  3020    ;
  3021   "RTN","PRC ACPS",409, 0)
  3022   USRMSG ;se nds mailma n message  to the PRC ACPS mail  group
  3023   "RTN","PRC ACPS",410, 0)
  3024    N XMY,XMD UZ,XMSUB,X MTEXT,X
  3025   "RTN","PRC ACPS",411, 0)
  3026    S XMDUZ=" AR PACKAGE "
  3027   "RTN","PRC ACPS",412, 0)
  3028    S XMY("G. PRCACPS")= ""
  3029   "RTN","PRC ACPS",413, 0)
  3030    S XMSUB=" CPS AUTO-C ORRECTION  COMPLETE " _$E(DT,4,5 )_"/"_$E(D T,6,7)_"/" _$E(DT,2,
  3031   3)
  3032   "RTN","PRC ACPS",414, 0)
  3033    S X(1)="C onsolidate d Patient  Statement  Auto-Corre ction"
  3034   "RTN","PRC ACPS",415, 0)
  3035    S X(2)="P rogram com pleted on  "_$$FMTE^X LFDT($$NOW ^XLFDT()," 5P")
  3036   "RTN","PRC ACPS",416, 0)
  3037    S XMTEXT= "X("
  3038   "RTN","PRC ACPS",417, 0)
  3039    D ^XMD
  3040   "RTN","PRC ACPS",418, 0)
  3041    ; Remove  ^XTMP node
  3042   "RTN","PRC ACPS",419, 0)
  3043    K ^XTMP(" PRCACPS",0 )
  3044   "RTN","PRC ACPS",420, 0)
  3045    Q
  3046   "RTN","PRC ACPS",421, 0)
  3047    ;
  3048   "RTN","PRC ACPS",422, 0)
  3049   PRCAMAIL(P RCASTRT) ;
  3050   "RTN","PRC ACPS",423, 0)
  3051    ; Send e- mail notif ication to  the PRCAC PS mail gr oup if the  Auto-Corr ect was m
  3052   anually ru n
  3053   "RTN","PRC ACPS",424, 0)
  3054    ; when it  showed to  be curren tly runnin g or possi ble errore d out on a  previous
  3055    attempt.
  3056   "RTN","PRC ACPS",425, 0)
  3057    ;
  3058   "RTN","PRC ACPS",426, 0)
  3059    ; PRCASTA RT = Exter nal format  of date/t ime (i.e.  OCT 12, 20 16@09:39:5 8) that t
  3060   he
  3061   "RTN","PRC ACPS",427, 0)
  3062    ; Auto-Co rrect prog ram was la st started .
  3063   "RTN","PRC ACPS",428, 0)
  3064    N XMY,XMD UZ,XMSUB,X MTEXT,X
  3065   "RTN","PRC ACPS",429, 0)
  3066    S XMDUZ=" AR PACKAGE "
  3067   "RTN","PRC ACPS",430, 0)
  3068    S XMY("G. PRCACPS")= ""
  3069   "RTN","PRC ACPS",431, 0)
  3070    S XMSUB=" CPS AUTO-C ORRECTION  FAILURE "_ $E(DT,4,5) _"/"_$E(DT ,6,7)_"/"_ $E(DT,2,3
  3071   )
  3072   "RTN","PRC ACPS",432, 0)
  3073    S X(1)="T he Patient  Statement  Auto-Corr ection Pro gram was s tarted on: "
  3074   "RTN","PRC ACPS",433, 0)
  3075    S X(2)=PR CASTRT_" a nd may not  have comp leted norm ally."
  3076   "RTN","PRC ACPS",434, 0)
  3077    S X(3)=""
  3078   "RTN","PRC ACPS",435, 0)
  3079    S X(4)="P lease have  OI&T chec k the erro r trap for  any error s related  to routin
  3080   e"
  3081   "RTN","PRC ACPS",436, 0)
  3082    S X(5)="P RCACPS on  this date. "
  3083   "RTN","PRC ACPS",437, 0)
  3084    S XMTEXT= "X("
  3085   "RTN","PRC ACPS",438, 0)
  3086    D ^XMD
  3087   "RTN","PRC ACPS",439, 0)
  3088    Q
  3089   "RTN","PRC ACPSA")
  3090   0^10^B1304 4758^n/a
  3091   "RTN","PRC ACPSA",1,0 )
  3092   PRCACPSA ; ALBANY/MGD -PATIENT S TATEMENTS  AUTO-CORRE CTION ;09/ 21/15 3:34  PM
  3093   "RTN","PRC ACPSA",2,0 )
  3094    ;;4.5;Acc ounts Rece ivable;**3 07**;Mar 2 0, 1995;Bu ild 72
  3095   "RTN","PRC ACPSA",3,0 )
  3096    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3097   "RTN","PRC ACPSA",4,0 )
  3098    ;
  3099   "RTN","PRC ACPSA",5,0 )
  3100    Q
  3101   "RTN","PRC ACPSA",6,0 )
  3102    ;
  3103   "RTN","PRC ACPSA",7,0 )
  3104   BILLQUIT(D EBTOR,BILL ) ;
  3105   "RTN","PRC ACPSA",8,0 )
  3106    ; check n ews and in itializati ons
  3107   "RTN","PRC ACPSA",9,0 )
  3108    N FILENUM ,IENCRRT,I ENPREV,PRC ABFIX,PRCA BST,PRCAFD A,PRCACUR, PRCACUR1,P RCAPRV,PR
  3109   CAPRV1,TN, TNLAST,TRN SCRRT,TRNS PREV,X
  3110   "RTN","PRC ACPSA",10, 0)
  3111    S TNLAST= ""
  3112   "RTN","PRC ACPSA",11, 0)
  3113    S PRCABFI X=0
  3114   "RTN","PRC ACPSA",12, 0)
  3115    S TN=0
  3116   "RTN","PRC ACPSA",13, 0)
  3117    F  S TN=$ O(^TMP("PR CAGTPS",$J ,DEBTOR,BI LL,TN)) Q: 'TN  D
  3118   "RTN","PRC ACPSA",14, 0)
  3119    .; Load 0  and 1 nod es
  3120   "RTN","PRC ACPSA",15, 0)
  3121    .S PRCACU R=$G(^PRCA (433,TN,0) )
  3122   "RTN","PRC ACPSA",16, 0)
  3123    .S PRCACU R1=$G(^PRC A(433,TN,1 ))
  3124   "RTN","PRC ACPSA",17, 0)
  3125    .; Quit i f this Tra nsaction i s a COMMEN T
  3126   "RTN","PRC ACPSA",18, 0)
  3127    .I $P(PRC ACUR1,U,2) =45 Q
  3128   "RTN","PRC ACPSA",19, 0)
  3129    .; Quit i f this tra nsaction w as updated  earlier a s part of  an previou s fix
  3130   "RTN","PRC ACPSA",20, 0)
  3131    .I $P($G( ^PRCA(433, TN,9)),U,4 ) Q
  3132   "RTN","PRC ACPSA",21, 0)
  3133    .S TNLAST =TN
  3134   "RTN","PRC ACPSA",22, 0)
  3135    .; Check  if Transac tion is ma rked as IN COMPLETE
  3136   "RTN","PRC ACPSA",23, 0)
  3137    .I $P(PRC ACUR,U,10) =1 S PRCAB FIX=PRCABF IX+1,PRCAB FIX("I")=$ G(PRCABFIX ("I"))+1
  3138   "RTN","PRC ACPSA",24, 0)
  3139    .; *** Th e Null tra nsaction c heck will  be impleme nted in PR CA*4.5*313  ***
  3140   "RTN","PRC ACPSA",25, 0)
  3141    .; Check  if zero do llar amoun t
  3142   "RTN","PRC ACPSA",26, 0)
  3143    .;I $P(PR CACUR1,U,5 )="" S PRC ABFIX=PRCA BFIX+1,PRC ABFIX("N") =$G(PRCABF IX("N"))+
  3144   1
  3145   "RTN","PRC ACPSA",27, 0)
  3146    .S PRCAPR V=$G(^PRCA (433,TN-1, 0))
  3147   "RTN","PRC ACPSA",28, 0)
  3148    .S PRCAPR V1=$G(^PRC A(433,TN-1 ,1))
  3149   "RTN","PRC ACPSA",29, 0)
  3150    .; Perfor m quick hi gh level d uplicate c heck
  3151   "RTN","PRC ACPSA",30, 0)
  3152    .I $P(PRC ACUR,U,2)' =$P(PRCAPR V,U,2) Q   ; QUIT if  (#.03) BIL L NUMBER d on't matc
  3153   h
  3154   "RTN","PRC ACPSA",31, 0)
  3155    .I $P(PRC ACUR,U,9)' =$P(PRCAPR V,U,9) Q   ; QUIT if  (#42) PROC ESSED BY d on't matc
  3156   h
  3157   "RTN","PRC ACPSA",32, 0)
  3158    .I $P(PRC ACUR1,U,1) '=$P(PRCAP RV1,U,1) Q   ; QUIT i f (#11) TR ANSACTION  DATE don'
  3159   t match
  3160   "RTN","PRC ACPSA",33, 0)
  3161    .I $P(PRC ACUR1,U,5) '=$P(PRCAP RV1,U,5) Q   ; QUIT i f (#15) TR ANS. AMOUN T don't m
  3162   atch
  3163   "RTN","PRC ACPSA",34, 0)
  3164    .; Perfor m detailed  duplicate  check
  3165   "RTN","PRC ACPSA",35, 0)
  3166    .S IENPRE V=TN-1,IEN CRRT=TN,FI LENUM=433
  3167   "RTN","PRC ACPSA",36, 0)
  3168    .K TRNSPR EV S FILEN UM=433 D G ETS^DIQ(FI LENUM,IENP REV,"**"," N","TRNSPR EV","MSG"
  3169   )
  3170   "RTN","PRC ACPSA",37, 0)
  3171    .K TRNSCR RT S FILEN UM=433 D G ETS^DIQ(FI LENUM,IENC RRT,"**"," N","TRNSCR RT","MSG"
  3172   )
  3173   "RTN","PRC ACPSA",38, 0)
  3174    .S TRNSCR RT(433,TN_ ",",.01)=T RNSPREV(43 3,(TN-1)_" ,",.01)
  3175   "RTN","PRC ACPSA",39, 0)
  3176    .I $D(TRN SPREV(433, (TN-1)_"," ,41)) S TR NSCRRT(433 ,TN_",",41 )=$G(TRNSP REV(433,(
  3177   TN-1)_",", 41))
  3178   "RTN","PRC ACPSA",40, 0)
  3179    .I $$DIQO UTCS^PRCAC PS(.TRNSPR EV)'=$$DIQ OUTCS^PRCA CPS(.TRNSC RRT) Q
  3180   "RTN","PRC ACPSA",41, 0)
  3181    .; Set du plicate fl ag which w ill be use d in START 2
  3182   "RTN","PRC ACPSA",42, 0)
  3183    .S $P(^TM P("PRCAGTP S",$J,DEBT OR,BILL,TN ),U,12)=1
  3184   "RTN","PRC ACPSA",43, 0)
  3185    .; we hav e a duplic ate so upd ate counte r
  3186   "RTN","PRC ACPSA",44, 0)
  3187    .S PRCABF IX=PRCABFI X+1,PRCABF IX("D")=$G (PRCABFIX( "D"))+1
  3188   "RTN","PRC ACPSA",45, 0)
  3189    ; Get Bil l Status f or checks
  3190   "RTN","PRC ACPSA",46, 0)
  3191    S PRCABST =$P($G(^PR CA(430,BIL L,0)),U,8)
  3192   "RTN","PRC ACPSA",47, 0)
  3193    ;
  3194   "RTN","PRC ACPSA",48, 0)
  3195    ; 3rd pie ce of ^TMP ("PRCABILL ",$J,DEBTO R,BILL) is  stop/go f lag for th is bill.
  3196   "RTN","PRC ACPSA",49, 0)
  3197    ; Set bel ow and uti lized in S TART2^PRCA CPS
  3198   "RTN","PRC ACPSA",50, 0)
  3199    ;
  3200   "RTN","PRC ACPSA",51, 0)
  3201    ; Check f or Duplica te needs t o include  Bill Statu s of ACTIV E (#16), O PEN (#42)
  3202    or CANCEL LATION (#3 9)
  3203   "RTN","PRC ACPSA",52, 0)
  3204    ; If ther e was only  1 problem  and that  problem wa s a Duplic ate and th e Bill St
  3205   atus is AC TIVE or OP EN
  3206   "RTN","PRC ACPSA",53, 0)
  3207    ; or CANC ELLATION Q uit and le t it get s et in CHEC K2
  3208   "RTN","PRC ACPSA",54, 0)
  3209    I PRCABFI X=1,$G(PRC ABFIX("D") )=1,(PRCAB ST=16!(PRC ABST=42)!( PRCABST=39 )) S $P(^
  3210   TMP("PRCAB ILL",$J,DE BTOR,BILL) ,U,3)=0 Q  0
  3211   "RTN","PRC ACPSA",55, 0)
  3212    ; If a si ngle probl em on a Bi ll in a st atus other  than Acti ve or Open  mark las
  3213   t transact ion as NOT  FIXABLE
  3214   "RTN","PRC ACPSA",56, 0)
  3215    I PRCABFI X=1,PRCABS T'=16&(PRC ABST'=42)  D UPDTLTR( TNLAST)
  3216   "RTN","PRC ACPSA",57, 0)
  3217    ; If a si ngle probl em on a Bi ll in a st atus of Ac tive or Op en will be  further 
  3218   checked in  START2
  3219   "RTN","PRC ACPSA",58, 0)
  3220    I PRCABFI X=1,(PRCAB ST=16!(PRC ABST=42))  S PRCABFIX =0
  3221   "RTN","PRC ACPSA",59, 0)
  3222    ; If mult iple probl ems set au dit fields  for last  transactio n for the  Bill
  3223   "RTN","PRC ACPSA",60, 0)
  3224    I PRCABFI X>1 D UPDT LTR(TNLAST ) S PRCABF IX=1
  3225   "RTN","PRC ACPSA",61, 0)
  3226    ; Update  Bill level  stop flag
  3227   "RTN","PRC ACPSA",62, 0)
  3228    S $P(^TMP ("PRCABILL ",$J,DEBTO R,BILL),U, 3)=PRCABFI X
  3229   "RTN","PRC ACPSA",63, 0)
  3230    Q PRCABFI X
  3231   "RTN","PRC ACPSA",64, 0)
  3232    ;
  3233   "RTN","PRC ACPSA",65, 0)
  3234   UPDTLTR(TN LAST) ;
  3235   "RTN","PRC ACPSA",66, 0)
  3236    ; Set aud it fields  for last t ransaction  (TNLAST)  for a bill
  3237   "RTN","PRC ACPSA",67, 0)
  3238    N PRCABIL L,PRCADATE ,PRCADTR
  3239   "RTN","PRC ACPSA",68, 0)
  3240    D NOW^%DT C
  3241   "RTN","PRC ACPSA",69, 0)
  3242    S PRCADAT E=X
  3243   "RTN","PRC ACPSA",70, 0)
  3244    I TNLAST= "" Q
  3245   "RTN","PRC ACPSA",71, 0)
  3246    ; Quit is  this Tran saction wa s previous ly used to  fix anoth er issue
  3247   "RTN","PRC ACPSA",72, 0)
  3248    I $P($G(^ PRCA(433,T NLAST,9)), U,4) Q
  3249   "RTN","PRC ACPSA",73, 0)
  3250    ; Identif y Bill for  this Tran saction
  3251   "RTN","PRC ACPSA",74, 0)
  3252    S PRCABIL L=$P(^PRCA (433,TNLAS T,0),U,2)
  3253   "RTN","PRC ACPSA",75, 0)
  3254    ; Use Bil l to ident ify Debtor
  3255   "RTN","PRC ACPSA",76, 0)
  3256    S PRCADTR =$P(^PRCA( 430,PRCABI LL,0),U,9)
  3257   "RTN","PRC ACPSA",77, 0)
  3258    ; Quit if  the stop  flag for t his bill w as previou sly set in  $$BILLQUI T^PRCACPS
  3259   A
  3260   "RTN","PRC ACPSA",78, 0)
  3261    I $P(^TMP ("PRCABILL ",$J,PRCAD TR,PRCABIL L),U,3) Q
  3262   "RTN","PRC ACPSA",79, 0)
  3263    ; Set up  Audit Fiel d Array
  3264   "RTN","PRC ACPSA",80, 0)
  3265    S PRCAFDA (433,TNLAS T_",",94)= PRCADATE
  3266   "RTN","PRC ACPSA",81, 0)
  3267    S PRCAFDA (433,TNLAS T_",",96)= "X" ; NOT  FIXABLE
  3268   "RTN","PRC ACPSA",82, 0)
  3269    S PRCAFDA (433,TNLAS T_",",97)= 1
  3270   "RTN","PRC ACPSA",83, 0)
  3271    L +^PRCA( 433,TNLAST ,9):DILOCK TM
  3272   "RTN","PRC ACPSA",84, 0)
  3273    ; QUIT if  lock not  obtainable
  3274   "RTN","PRC ACPSA",85, 0)
  3275    Q:'$T
  3276   "RTN","PRC ACPSA",86, 0)
  3277    ; Update  record
  3278   "RTN","PRC ACPSA",87, 0)
  3279    D FILE^DI E(,"PRCAFD A")
  3280   "RTN","PRC ACPSA",88, 0)
  3281    ; Unlock  file
  3282   "RTN","PRC ACPSA",89, 0)
  3283    L -^PRCA( 433,TNLAST ,9)
  3284   "RTN","PRC ACPSA",90, 0)
  3285    Q
  3286   "RTN","PRC ASER1")
  3287   0^3^B18484 730^B15957 526
  3288   "RTN","PRC ASER1",1,0 )
  3289   PRCASER1 ; WASH-ISC@A LTOONA,PA/ RGY-Accept  transacti on from bi lling engi ne ;9/8/9
  3290   3  2:21 PM
  3291   "RTN","PRC ASER1",2,0 )
  3292   V ;;4.5;Ac counts Rec eivable;** 48,104,165 ,233,307** ;Mar 20, 1 995;Build  72
  3293   "RTN","PRC ASER1",3,0 )
  3294    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3295   "RTN","PRC ASER1",4,0 )
  3296    NEW AMT,A MT1,PRCAER R,PRCABN,P RCADJ,X1,X MDUZ,XMSUB ,XMTEXT,XM Y,DEBT
  3297   "RTN","PRC ASER1",5,0 )
  3298    I '$D(X)  S PRCAERR= "-1^PRCA02 0" G Q
  3299   "RTN","PRC ASER1",6,0 )
  3300    I $O(^PRC A(430.3,"A C",+X,0))' ?1N.N,$P($ G(^PRCA(43 0.3,+X,0)) ,"^",3)'=2 1 S PRCAE
  3301   RR="-1^PRC A021" G Q
  3302   "RTN","PRC ASER1",7,0 )
  3303    I +X'=21, $P($G(^PRC A(430.3,+X ,0)),"^",3 )'=21 S PR CAERR="-1^ PRCA022" G  Q
  3304   "RTN","PRC ASER1",8,0 )
  3305    I $P(X,"^ ",2)'?.N.1 ".".2N S P RCAERR="-1 ^PRCA023"  G Q
  3306   "RTN","PRC ASER1",9,0 )
  3307    I $P(X,"^ ",2)'>0 S  PRCAERR="- 1^PRCA017"  G Q
  3308   "RTN","PRC ASER1",10, 0)
  3309    I $P(X,"^ ",3)="" S  PRCAERR="- 1^PRCA006"  G Q
  3310   "RTN","PRC ASER1",11, 0)
  3311    S PRCABN= $O(^PRCA(4 30,"B",$P( X,"^",3),0 )) I $G(^P RCA(430,+P RCABN,0))= "" S PRCA
  3312   ERR="-1^PR CA007" G Q
  3313   "RTN","PRC ASER1",12, 0)
  3314    I '$D(^VA (200,+$P(X ,"^",4),0) ) S PRCAER R="-1^PRCA 013" G Q
  3315   "RTN","PRC ASER1",13, 0)
  3316    I $P(X,"^ ",5)'?7N S  PRCAERR=" -1^PRCA024 " G Q
  3317   "RTN","PRC ASER1",14, 0)
  3318    S (AMT1,A MT)=$P(X," ^",2)
  3319   "RTN","PRC ASER1",15, 0)
  3320    D DEC(PRC ABN,.AMT,$ P(X,"^",4) ,$P(X,U,6) ,$P(X,U,5) )
  3321   "RTN","PRC ASER1",16, 0)
  3322    S XMDUZ=" AR Package ",XMTEXT=" X1(",DEBT= $P($G(^PRC A(430,PRCA BN,0)),"^" ,9),DEBT=
  3323   $E($$NAM^R CFN01(DEBT ),1)_" ("_ $E($$SSN^R CFN01(DEBT ),6,9)_")"
  3324   "RTN","PRC ASER1",17, 0)
  3325    I AMT'=AM T1 S X1(1) ="A decrea se adjustm ent for bi ll/Pt name  (SSN) #"_ $P(X,"^",
  3326   3)_"/"_DEB T_" has be en",XMSUB= "Automatic  Adj: "_$P (X,"^",3)
  3327   "RTN","PRC ASER1",18, 0)
  3328    I AMT=AMT 1 S X1(1)= "**** NOTI CE: A decr ease adjus tment for  bill/Pt na me (SSN) 
  3329   #"_$P(X,U, 3)_"/"_DEB T,XMSUB="M anual Adj:  "_$P(X,U, 3),X1(3)="  "
  3330   "RTN","PRC ASER1",19, 0)
  3331    S Y=DT X  ^DD("DD")  S X1(2)=$S (AMT'=AMT1 :"automati cally",1:" needs to b e manuall
  3332   y")_" appl ied in the  amount of  $"_$J($S( AMT1=AMT:A MT1,1:AMT1 -AMT),0,2) _" on "_Y
  3333   _"."
  3334   "RTN","PRC ASER1",20, 0)
  3335    I AMT,AMT '=AMT1 S X 1(3)="Plea se review  bill for p roper appl ication of  the unap
  3336   plied amou nt of $"_$ J(AMT,0,2) _"."
  3337   "RTN","PRC ASER1",21, 0)
  3338    S X1(4)="  ",X1(5)=" Data sent  from Servi ce"
  3339   "RTN","PRC ASER1",22, 0)
  3340    S X1(6)="         Am ount: $"_$ J(AMT1,0,2 )
  3341   "RTN","PRC ASER1",23, 0)
  3342    S Y=$P(X, U,5) X ^DD ("DD") S X 1(7)="           Date : "_Y
  3343   "RTN","PRC ASER1",24, 0)
  3344    S X1(8)="         Re ason: "_$S ($P(X,"^", 6)]"":$P(X ,"^",6),1: "N/A")
  3345   "RTN","PRC ASER1",25, 0)
  3346    S X1(9)="  Adjustmen t by: "_$P ($G(^VA(20 0,+$P(X,"^ ",4),0))," ^")
  3347   "RTN","PRC ASER1",26, 0)
  3348    S AMT=0 F  X=1:1:5 S  AMT=AMT+$ P($G(^PRCA (430,PRCAB N,7)),U,X)
  3349   "RTN","PRC ASER1",27, 0)
  3350    S AMT1=AM T-+$G(^PRC A(430,PRCA BN,7))
  3351   "RTN","PRC ASER1",28, 0)
  3352    S X=$P(^P RCA(430.3, +$P($G(^PR CA(430,PRC ABN,0)),U, 8),0),U,1)
  3353   "RTN","PRC ASER1",29, 0)
  3354    S X1(10)= " ",X1(12) =" ",X1(13 )="Bill st atus is "_ $S(XMSUB[" Auto":"now  ",1:"")_
  3355   X_" with a  balance o f $"_$J(AM T,0,2)_"." ,X1(14)="  "
  3356   "RTN","PRC ASER1",30, 0)
  3357    I AMT1>0  S X1(15)="  *WARNING*   There is  outstandi ng adminis trative ch arges of 
  3358   $"_$J(AMT1 ,0,2)_".", X1(16)="              An adjustm ent of adm inistrativ e charges
  3359    MAY need  to be done ."
  3360   "RTN","PRC ASER1",31, 0)
  3361    S XMY("G. PRCA ADJUS TMENT TRAN S")=""
  3362   "RTN","PRC ASER1",32, 0)
  3363    D ^XMD
  3364   "RTN","PRC ASER1",33, 0)
  3365   Q S Y=$S($ D(PRCAERR) :PRCAERR,1 :0) Q
  3366   "RTN","PRC ASER1",34, 0)
  3367   TEST  ;
  3368   "RTN","PRC ASER1",35, 0)
  3369    S X="21^2 2^503-AA00 07^5^29212 06^RX RETU RNED IN MA IL" D ^PRC ASER1 W !, Y,!
  3370   "RTN","PRC ASER1",36, 0)
  3371    Q
  3372   "RTN","PRC ASER1",37, 0)
  3373   DEC(PRCABN ,AMT,APR,R EA,BDT,PRC AEN) ;Auto  decrease  from servi ce Bill#,T ran amt,p
  3374   erson,reas on,Tran da te
  3375   "RTN","PRC ASER1",38, 0)
  3376    NEW BAL,D A,DIC,DIE, DR,ERR,PRC A,PRCAA2,P RCAMT,PRCA SV,X,Y,PRC ADUP ; PRC A*4.5*307
  3377    - New PRC ADUP then  initialize  next line
  3378   "RTN","PRC ASER1",39, 0)
  3379    S PRCADUP =0
  3380   "RTN","PRC ASER1",40, 0)
  3381    ; PRCA*4. 5*307 - If  reason is  TIER RATE  check for  duplicate
  3382   "RTN","PRC ASER1",41, 0)
  3383    I REA["TI ER RATE" D  DUPCHK
  3384   "RTN","PRC ASER1",42, 0)
  3385    S PRCAEN= "",BAL=+$G (^PRCA(430 ,PRCABN,7) ) I 'BAL Q
  3386   "RTN","PRC ASER1",43, 0)
  3387    I $P(^PRC A(430,PRCA BN,0),U,8) '=$O(^PRCA (430.3,"AC ",102,"")) ,$P(^PRCA( 430,PRCAB
  3388   N,0),U,8)' =$O(^PRCA( 430.3,"AC" ,112,""))  Q
  3389   "RTN","PRC ASER1",44, 0)
  3390    I $P(^PRC A(430,PRCA BN,0),U,2) =$O(^PRCA( 430.2,"AC" ,33,0)) Q
  3391   "RTN","PRC ASER1",45, 0)
  3392    S BAL=$S( AMT>BAL:BA L,1:AMT)
  3393   "RTN","PRC ASER1",46, 0)
  3394    S PRCA("A DJ")=$O(^P RCA(430.3, "AC",21,0) ),PRCASV(" FY")=$$FY^ RCFN01(DT) _U_BAL,PR
  3395   CASV("APR" )=APR,PRCA SV("BDT")= $S($G(BDT) >0:BDT,1:D T)
  3396   "RTN","PRC ASER1",47, 0)
  3397    D SETTR^P RCAUTL,PAT TR^PRCAUTL  S DIE="^P RCA(433,", DR="[PRCA  FY ADJ2 BA TCH]",DA=
  3398   PRCAEN D ^ DIE S PRCA A2=$P(^PRC A(433,PRCA EN,4,0),U, 3) D UPFY^ PRCADJ,TRA NUP^PRCAU
  3399   TL
  3400   "RTN","PRC ASER1",48, 0)
  3401    I ("^30^3 1^")[("^"_ $P($G(^PRC A(430,PRCA BN,0)),"^" ,2)_"^") D  EN^PRCAFB DM(PRCABN
  3402   ,BAL,PRCA( "ADJ"),$G( PRCADJ("BD T")),PRCAE N,.ERR)
  3403   "RTN","PRC ASER1",49, 0)
  3404    D UPPRIN^ PRCADJ
  3405   "RTN","PRC ASER1",50, 0)
  3406    I "AutoAU TO"'[$E(RE A,1,4) S R EA="Auto D ec.: "_REA
  3407   "RTN","PRC ASER1",51, 0)
  3408    S DA=PRCA EN,DIE="^P RCA(433,", DR="41///" _REA D ^DI E
  3409   "RTN","PRC ASER1",52, 0)
  3410    ; PRCA*4. 5*307 - Ma rk Incompl ete Transa ction if d uplicate,  blocking f rom Patie
  3411   nt Stateme nt 
  3412   "RTN","PRC ASER1",53, 0)
  3413    I PRCADUP  S DR="10/ ///1" D ^D IE
  3414   "RTN","PRC ASER1",54, 0)
  3415    S AMT=AMT -+$P($G(^P RCA(433,PR CAEN,1)),U ,5)
  3416   "RTN","PRC ASER1",55, 0)
  3417    Q
  3418   "RTN","PRC ASER1",56, 0)
  3419    ;
  3420   "RTN","PRC ASER1",57, 0)
  3421   DUPCHK ;PR CA*4.5*307  - Check f or duplica te (lower/ higher) se t PRCADUP  if true
  3422   "RTN","PRC ASER1",58, 0)
  3423    N PRCATX, PRCAII,PRC ATRN
  3424   "RTN","PRC ASER1",59, 0)
  3425    S PRCATX= $P(^PRCA(4 33,0),U,3)
  3426   "RTN","PRC ASER1",60, 0)
  3427    F PRCAII= PRCATX-20: 1:PRCATX D   Q:PRCADU P
  3428   "RTN","PRC ASER1",61, 0)
  3429    . S PRCAT RN=$G(^PRC A(433,PRCA II,1)) I $ P(PRCATRN, U,5)'=AMT  Q
  3430   "RTN","PRC ASER1",62, 0)
  3431    . I $P($G (^PRCA(433 ,PRCAII,0) ),U,2)'=PR CABN Q
  3432   "RTN","PRC ASER1",63, 0)
  3433    . I $P($G (^PRCA(433 ,PRCAII,0) ),U,9)'=AP R Q
  3434   "RTN","PRC ASER1",64, 0)
  3435    . I $P(PR CATRN,U)'= BDT Q
  3436   "RTN","PRC ASER1",65, 0)
  3437    . S PRCAD UP=PRCAII
  3438   "RTN","PRC ASER1",66, 0)
  3439    Q
  3440   "RTN","RCC PCBJ")
  3441   0^5^B75092 78^B628849 1
  3442   "RTN","RCC PCBJ",1,0)
  3443   RCCPCBJ ;W ASH-ISC@AL TOONA,PA/N YB-Backgro und Driver  for CCPC  ;1/7/97  9 :42 AM
  3444   "RTN","RCC PCBJ",2,0)
  3445    ;;4.5;Acc ounts Rece ivable;**3 4,76,130,1 53,166,195 ,217,237,3 07**;Mar 2 0, 1995;B
  3446   uild 72
  3447   "RTN","RCC PCBJ",3,0)
  3448    ;;Per VHA  Directive  10-93-142 , this rou tine shoul d not be m odified.
  3449   "RTN","RCC PCBJ",4,0)
  3450   EN ;Starts  the backg round job  for CCPC 5  days befo re stateme nt day
  3451   "RTN","RCC PCBJ",5,0)
  3452    N X,X1,X2 ,X3,ZTRTN, ZTIO,ZTDTH ,ZTSK,ZTDE SC
  3453   "RTN","RCC PCBJ",6,0)
  3454    D ACK
  3455   "RTN","RCC PCBJ",7,0)
  3456    I $$DOW^X LFDT(DT,1) =3 D  ;run  the cbs a uto-correc tion progr am on wedn esdays
  3457   "RTN","RCC PCBJ",8,0)
  3458    .N ZTDESC ,ZTASK,ZTD TH,ZTIO,ZT RTN
  3459   "RTN","RCC PCBJ",9,0)
  3460    .S ZTIO=" ",ZTRTN="S TART^PRCAC PS"
  3461   "RTN","RCC PCBJ",10,0 )
  3462    .S ZTDESC ="PATIENT  STATEMENTS  AUTO-CORR ECTION PRO GRAM",ZTDT H=$H
  3463   "RTN","RCC PCBJ",11,0 )
  3464    .D ^%ZTLO AD
  3465   "RTN","RCC PCBJ",12,0 )
  3466    ;
  3467   "RTN","RCC PCBJ",13,0 )
  3468    S X1=$$ST D^RCCPCFN, X2=-2 D C^ %DTC
  3469   "RTN","RCC PCBJ",14,0 )
  3470    ;10-proce ss end tim e/18-ccpc  file built
  3471   "RTN","RCC PCBJ",15,0 )
  3472    I X=DT D   Q
  3473   "RTN","RCC PCBJ",16,0 )
  3474    . S X3=$O (^RCPS(349 .2,0)) Q:' X3
  3475   "RTN","RCC PCBJ",17,0 )
  3476    . Q:'$P($ P($G(^RCPS (349.2,X3, 0)),"^",10 ),".")
  3477   "RTN","RCC PCBJ",18,0 )
  3478    . Q:'$P($ G(^RCPS(34 9.2,X3,0)) ,"^",18)
  3479   "RTN","RCC PCBJ",19,0 )
  3480    . D EN^RC CPCML
  3481   "RTN","RCC PCBJ",20,0 )
  3482    ;quit if  date creat ed is yest erday's da te
  3483   "RTN","RCC PCBJ",21,0 )
  3484    S X1=$$ST D^RCCPCFN, X2=-1 D C^ %DTC
  3485   "RTN","RCC PCBJ",22,0 )
  3486    I X=DT D   Q
  3487   "RTN","RCC PCBJ",23,0 )
  3488    . S X3=+$ O(^RCT(349 ,0))
  3489   "RTN","RCC PCBJ",24,0 )
  3490    . S X3=$P ($P($G(^RC T(349,X3,0 )),"^",11) ,".")
  3491   "RTN","RCC PCBJ",25,0 )
  3492    . S X1=DT ,X2=-1 D C ^%DTC
  3493   "RTN","RCC PCBJ",26,0 )
  3494    . I X=X3  Q
  3495   "RTN","RCC PCBJ",27,0 )
  3496    . D EN^RC CPCML
  3497   "RTN","RCC PCBJ",28,0 )
  3498    ;
  3499   "RTN","RCC PCBJ",29,0 )
  3500    S X1=$$ST D^RCCPCFN, X2=-3 D C^ %DTC
  3501   "RTN","RCC PCBJ",30,0 )
  3502    I X'=DT Q
  3503   "RTN","RCC PCBJ",31,0 )
  3504    I DT'<$P( $G(^RC(342 ,1,30)),"^ ",1)&(DT'> $P($G(^RC( 342,1,30)) ,"^",2)) D  ^RCEXINA
  3505   D
  3506   "RTN","RCC PCBJ",32,0 )
  3507    S ZTIO="" ,ZTRTN="OP EN^RCCPCBJ ",ZTDESC=" CCPC PATIE NT STATEME NT"
  3508   "RTN","RCC PCBJ",33,0 )
  3509    S ZTDTH=$ H D ^%ZTLO AD
  3510   "RTN","RCC PCBJ",34,0 )
  3511    Q
  3512   "RTN","RCC PCBJ",35,0 )
  3513   OPEN ;Upda te Open st atus bills  to Active  or Cancel lation sta tus
  3514   "RTN","RCC PCBJ",36,0 )
  3515    N DATE,DA Y,BN,DEBTO R,DA,DIE,D R,P,AMT
  3516   "RTN","RCC PCBJ",37,0 )
  3517    N ZTSAVE, ZTRTN,ZTDE SC,ZTASK,% ZIS,ZTDTH
  3518   "RTN","RCC PCBJ",38,0 )
  3519    S DATE=$$ STD^RCCPCF N,DAY=+$$S TDY^RCCPCF N,DEBTOR=0  F  S DEBT OR=$O(^RCD (340,"AC"
  3520   ,DAY,DEBTO R)) Q:'DEB TOR  D
  3521   "RTN","RCC PCBJ",39,0 )
  3522       .S BN= 0 F  S BN= $O(^PRCA(4 30,"AS",DE BTOR,$O(^P RCA(430.3, "AC",112,0 )),BN)) Q
  3523   :'BN  D
  3524   "RTN","RCC PCBJ",40,0 )
  3525          ..S  AMT=0 F P =1:1:5 S A MT=$P($G(^ PRCA(430,+ BN,7)),"^" ,P)+AMT
  3526   "RTN","RCC PCBJ",41,0 )
  3527          ..I  $P($G(^PR CA(430,+BN ,0)),"^",2 )=$O(^PRCA (430.2,"AC ",33,0)),A MT Q
  3528   "RTN","RCC PCBJ",42,0 )
  3529          ..S  DIE="^PRC A(430,",DA =+BN,DR="8 ////^S X=" _$S(AMT:$O (^PRCA(430 .3,"AC",1
  3530   02,0)),1:$ O(^PRCA(43 0.3,"AC",1 11,0))) D  ^DIE K DA, DIE,DR
  3531   "RTN","RCC PCBJ",43,0 )
  3532          ..Q
  3533   "RTN","RCC PCBJ",44,0 )
  3534       .Q
  3535   "RTN","RCC PCBJ",45,0 )
  3536    ;
  3537   "RTN","RCC PCBJ",46,0 )
  3538    ;  update  patient a ccounts wi th interes t and admi n
  3539   "RTN","RCC PCBJ",47,0 )
  3540    N RCLASDA T
  3541   "RTN","RCC PCBJ",48,0 )
  3542    S RCLASDA T=DATE
  3543   "RTN","RCC PCBJ",49,0 )
  3544    I DT>3010 101 D FIRS TPTY^RCBEC HGS
  3545   "RTN","RCC PCBJ",50,0 )
  3546    D ^RCCPCP S
  3547   "RTN","RCC PCBJ",51,0 )
  3548    D REFUND
  3549   "RTN","RCC PCBJ",52,0 )
  3550    Q
  3551   "RTN","RCC PCBJ",53,0 )
  3552    ;
  3553   "RTN","RCC PCBJ",54,0 )
  3554    ;
  3555   "RTN","RCC PCBJ",55,0 )
  3556   REFUND ;Up date Open  status PRE PAYMENT bi lls to REF UND REVIEW
  3557   "RTN","RCC PCBJ",56,0 )
  3558    S DEBTOR= 0,DAY=+$$S TDY^RCCPCF N
  3559   "RTN","RCC PCBJ",57,0 )
  3560    F  S DEBT OR=$O(^RCD (340,"AC", DAY,DEBTOR )) Q:'DEBT OR  D
  3561   "RTN","RCC PCBJ",58,0 )
  3562       .S BN= 0 F  S BN= $O(^PRCA(4 30,"AS",DE BTOR,$O(^P RCA(430.3, "AC",112,0 )),BN)) Q
  3563   :'BN  D
  3564   "RTN","RCC PCBJ",59,0 )
  3565          ..I  $P($G(^PR CA(430,+BN ,0)),"^",2 )=$O(^PRCA (430.2,"AC ",33,0)) S  X=$$EN^P
  3566   RCARFU(+BN )
  3567   "RTN","RCC PCBJ",60,0 )
  3568          ..Q
  3569   "RTN","RCC PCBJ",61,0 )
  3570       .Q
  3571   "RTN","RCC PCBJ",62,0 )
  3572    Q
  3573   "RTN","RCC PCBJ",63,0 )
  3574    ;
  3575   "RTN","RCC PCBJ",64,0 )
  3576   ACK ;CHECK  FOR ACKNO WLEDGEMENT S
  3577   "RTN","RCC PCBJ",65,0 )
  3578    N DEB,MSG ,NO,RCX,X, X1,X2
  3579   "RTN","RCC PCBJ",66,0 )
  3580    S X1=$$ST D^RCCPCFN, X2=DT D ^% DTC I X>3  D
  3581   "RTN","RCC PCBJ",67,0 )
  3582    .D TRANCH K^RCCPCSV1
  3583   "RTN","RCC PCBJ",68,0 )
  3584    Q
  3585   "RTN","RCD PBTLM")
  3586   0^9^B55886 735^B49476 140
  3587   "RTN","RCD PBTLM",1,0 )
  3588   RCDPBTLM ; WISC/RFJ -  bill tran sactions L ist Manage r top rout ine ;1 Jun  99
  3589   "RTN","RCD PBTLM",2,0 )
  3590    ;;4.5;Acc ounts Rece ivable;**1 14,148,153 ,168,169,1 98,247,271 ,276,307** ;Mar 20, 
  3591   1995;Build  72
  3592   "RTN","RCD PBTLM",3,0 )
  3593    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  3594   "RTN","RCD PBTLM",4,0 )
  3595    ;
  3596   "RTN","RCD PBTLM",5,0 )
  3597    ; Referen ce to $$RE C^IBRFN su pported by  DBIA 2031
  3598   "RTN","RCD PBTLM",6,0 )
  3599    ;
  3600   "RTN","RCD PBTLM",7,0 )
  3601    ;  called  from menu  option (1 9)
  3602   "RTN","RCD PBTLM",8,0 )
  3603    ;
  3604   "RTN","RCD PBTLM",9,0 )
  3605    N RCBILLD A,RCDPFXIT
  3606   "RTN","RCD PBTLM",10, 0)
  3607    ;
  3608   "RTN","RCD PBTLM",11, 0)
  3609    F  D  Q:' RCBILLDA
  3610   "RTN","RCD PBTLM",12, 0)
  3611    .   W !!  S RCBILLDA =$$SELBILL
  3612   "RTN","RCD PBTLM",13, 0)
  3613    .   I RCB ILLDA<1 S  RCBILLDA=0  Q
  3614   "RTN","RCD PBTLM",14, 0)
  3615    .   D EN^ VALM("RCDP  TRANSACTI ONS LIST")
  3616   "RTN","RCD PBTLM",15, 0)
  3617    .   ;  fa st exit
  3618   "RTN","RCD PBTLM",16, 0)
  3619    .   I $G( RCDPFXIT)  S RCBILLDA =0
  3620   "RTN","RCD PBTLM",17, 0)
  3621    Q
  3622   "RTN","RCD PBTLM",18, 0)
  3623    ;
  3624   "RTN","RCD PBTLM",19, 0)
  3625    ;
  3626   "RTN","RCD PBTLM",20, 0)
  3627   INIT ;  in itializati on for lis t manager  list
  3628   "RTN","RCD PBTLM",21, 0)
  3629    ;  requir es rcbilld a
  3630   "RTN","RCD PBTLM",22, 0)
  3631    N ADMIN,D ATE,RCLINE ,RCLIST,RC TOTAL,RCTR AN,RCTRAND A
  3632   "RTN","RCD PBTLM",23, 0)
  3633    K ^TMP("R CDPBTLM",$ J),^TMP("V ALM VIDEO" ,$J)
  3634   "RTN","RCD PBTLM",24, 0)
  3635    ;
  3636   "RTN","RCD PBTLM",25, 0)
  3637    ;  fast e xit
  3638   "RTN","RCD PBTLM",26, 0)
  3639    I $G(RCDP FXIT) S VA LMQUIT=1 Q
  3640   "RTN","RCD PBTLM",27, 0)
  3641    ;
  3642   "RTN","RCD PBTLM",28, 0)
  3643    ;  set th e List Man ager line  number
  3644   "RTN","RCD PBTLM",29, 0)
  3645    S RCLINE= 0
  3646   "RTN","RCD PBTLM",30, 0)
  3647    ;  set th e List Man ager trans action num ber
  3648   "RTN","RCD PBTLM",31, 0)
  3649    S RCTRAN= 0
  3650   "RTN","RCD PBTLM",32, 0)
  3651    ;
  3652   "RTN","RCD PBTLM",33, 0)
  3653    ;  get tr ansactions  and balan ce for bil l
  3654   "RTN","RCD PBTLM",34, 0)
  3655    S RCTOTAL =$$GETTRAN S(RCBILLDA )
  3656   "RTN","RCD PBTLM",35, 0)
  3657    ;
  3658   "RTN","RCD PBTLM",36, 0)
  3659    S DATE=""  F  S DATE =$O(RCLIST (DATE)) Q: 'DATE  D
  3660   "RTN","RCD PBTLM",37, 0)
  3661    .   S RCT RANDA="" F   S RCTRAN DA=$O(RCLI ST(DATE,RC TRANDA)) Q :RCTRANDA= ""  D
  3662   "RTN","RCD PBTLM",38, 0)
  3663    .   .   S  RCLINE=RC LINE+1
  3664   "RTN","RCD PBTLM",39, 0)
  3665    .   .   ;
  3666   "RTN","RCD PBTLM",40, 0)
  3667    .   .   ;   create a n index ar ray for tr ansaction  lookup in  list
  3668   "RTN","RCD PBTLM",41, 0)
  3669    .   .   I  RCTRANDA  D
  3670   "RTN","RCD PBTLM",42, 0)
  3671    .   .   .    S RCTRA N=RCTRAN+1
  3672   "RTN","RCD PBTLM",43, 0)
  3673    .   .   .    S ^TMP( "RCDPBTLM" ,$J,"IDX", RCTRAN,RCT RAN)=RCTRA NDA
  3674   "RTN","RCD PBTLM",44, 0)
  3675    .   .   .    D SET^R CDPAPLI(RC TRAN,RCLIN E,1,80,0,I ORVON,IORV OFF)
  3676   "RTN","RCD PBTLM",45, 0)
  3677    .   .   ;
  3678   "RTN","RCD PBTLM",46, 0)
  3679    .   .   D  SET^RCDPA PLI($S(RCT RANDA:RCTR ANDA,1:" " ),RCLINE,4 ,80)
  3680   "RTN","RCD PBTLM",47, 0)
  3681    .   .   D  SET^RCDPA PLI($E(DAT E,4,5)_"/" _$E(DATE,6 ,7)_"/"_$E (DATE,2,3) ,RCLINE,1
  3682   3,21)
  3683   "RTN","RCD PBTLM",48, 0)
  3684    .   .   D  SET^RCDPA PLI($TR($P (RCLIST(DA TE,RCTRAND A),"^"),"A BCDEFGHIJK LMNOPQRST
  3685   UVWXYZ","a bcdefghijk lmnopqrstu vwxyz"),RC LINE,25,50 )
  3686   "RTN","RCD PBTLM",49, 0)
  3687    .   .   D  SET^RCDPA PLI($J($P( RCLIST(DAT E,RCTRANDA ),"^",2),9 ,2),RCLINE ,53,62)
  3688   "RTN","RCD PBTLM",50, 0)
  3689    .   .   D  SET^RCDPA PLI($J($P( RCLIST(DAT E,RCTRANDA ),"^",3),9 ,2),RCLINE ,62,71)
  3690   "RTN","RCD PBTLM",51, 0)
  3691    .   .   ;   add mars hal fee an d court co st to crea te admin d ollars
  3692   "RTN","RCD PBTLM",52, 0)
  3693    .   .   S  ADMIN=$P( RCLIST(DAT E,RCTRANDA ),"^",4)+$ P(RCLIST(D ATE,RCTRAN DA),"^",5
  3694   )+$P(RCLIS T(DATE,RCT RANDA),"^" ,6)
  3695   "RTN","RCD PBTLM",53, 0)
  3696    .   .   D  SET^RCDPA PLI($J(ADM IN,9,2),RC LINE,71,80 )
  3697   "RTN","RCD PBTLM",54, 0)
  3698    ;
  3699   "RTN","RCD PBTLM",55, 0)
  3700    ;  show t otals
  3701   "RTN","RCD PBTLM",56, 0)
  3702    S RCLINE= RCLINE+1
  3703   "RTN","RCD PBTLM",57, 0)
  3704    D SET^RCD PAPLI("                                                         - -------- 
  3705   -------- - -------",R CLINE,1,80 )
  3706   "RTN","RCD PBTLM",58, 0)
  3707    S RCLINE= RCLINE+1
  3708   "RTN","RCD PBTLM",59, 0)
  3709    D SET^RCD PAPLI("    TOTAL BALA NCE FOR BI LL",RCLINE ,1,80)
  3710   "RTN","RCD PBTLM",60, 0)
  3711    D SET^RCD PAPLI($J($ P(RCTOTAL, "^",1),9,2 ),RCLINE,5 3,62)
  3712   "RTN","RCD PBTLM",61, 0)
  3713    D SET^RCD PAPLI($J($ P(RCTOTAL, "^",2),9,2 ),RCLINE,6 2,71)
  3714   "RTN","RCD PBTLM",62, 0)
  3715    D SET^RCD PAPLI($J($ P(RCTOTAL, "^",3)+$P( RCTOTAL,"^ ",4)+$P(RC TOTAL,"^", 5),9,2),R
  3716   CLINE,71,8 0)
  3717   "RTN","RCD PBTLM",63, 0)
  3718    ;
  3719   "RTN","RCD PBTLM",64, 0)
  3720    ;  compar e totals t o what is  stored in  the file
  3721   "RTN","RCD PBTLM",65, 0)
  3722    N RCDATA7 ,RCFOUT
  3723   "RTN","RCD PBTLM",66, 0)
  3724    S RCDATA7 =$G(^PRCA( 430,RCBILL DA,7))
  3725   "RTN","RCD PBTLM",67, 0)
  3726    ;  for a  write-off  bill, the  balance sh ould equal  all zeros , for
  3727   "RTN","RCD PBTLM",68, 0)
  3728    ;  these  bills, nod e 7 is the  write-off  amount, s o for the  out of
  3729   "RTN","RCD PBTLM",69, 0)
  3730    ;  balanc e check to  work, nod e 7 needs  to be adju sted to al l zeros
  3731   "RTN","RCD PBTLM",70, 0)
  3732    I $P(^PRC A(430,RCBI LLDA,0),"^ ",8)=23 S  RCDATA7="0 ^0^0^0^0"
  3733   "RTN","RCD PBTLM",71, 0)
  3734    I +$P(RCD ATA7,"^",1 )'=+$P(RCT OTAL,"^",1 ) S RCFOUT =1
  3735   "RTN","RCD PBTLM",72, 0)
  3736    I +$P(RCD ATA7,"^",2 )'=+$P(RCT OTAL,"^",2 ) S RCFOUT =1
  3737   "RTN","RCD PBTLM",73, 0)
  3738    I ($P(RCD ATA7,"^",3 )+$P(RCDAT A7,"^",4)+ $P(RCDATA7 ,"^",5))'= +$P(RCTOTA L,"^",3) 
  3739   S RCFOUT=1
  3740   "RTN","RCD PBTLM",74, 0)
  3741    I $G(RCFO UT) D
  3742   "RTN","RCD PBTLM",75, 0)
  3743    .   S RCL INE=RCLINE +1
  3744   "RTN","RCD PBTLM",76, 0)
  3745    .   D SET ^RCDPAPLI( " ",RCLINE ,1,80)
  3746   "RTN","RCD PBTLM",77, 0)
  3747    .   S RCL INE=RCLINE +1
  3748   "RTN","RCD PBTLM",78, 0)
  3749    .   D SET ^RCDPAPLI( "  STORED  BALANCE FO R BILL (**  INCORRECT  **)",RCLI NE,1,80)
  3750   "RTN","RCD PBTLM",79, 0)
  3751    .   D SET ^RCDPAPLI( $J($P(RCDA TA7,"^",1) ,9,2),RCLI NE,53,62)
  3752   "RTN","RCD PBTLM",80, 0)
  3753    .   D SET ^RCDPAPLI( $J($P(RCDA TA7,"^",2) ,9,2),RCLI NE,62,71)
  3754   "RTN","RCD PBTLM",81, 0)
  3755    .   D SET ^RCDPAPLI( $J($P(RCDA TA7,"^",3) +$P(RCDATA 7,"^",4)+$ P(RCDATA7, "^",5),9,
  3756   2),RCLINE, 71,80)
  3757   "RTN","RCD PBTLM",82, 0)
  3758    ;
  3759   "RTN","RCD PBTLM",83, 0)
  3760    ;  set va lmcnt to n umber of l ines in th e list
  3761   "RTN","RCD PBTLM",84, 0)
  3762    S VALMCNT =RCLINE
  3763   "RTN","RCD PBTLM",85, 0)
  3764    D HDR
  3765   "RTN","RCD PBTLM",86, 0)
  3766    Q
  3767   "RTN","RCD PBTLM",87, 0)
  3768    ;
  3769   "RTN","RCD PBTLM",88, 0)
  3770    ;
  3771   "RTN","RCD PBTLM",89, 0)
  3772   HDR ;  hea der code f or list ma nager disp lay
  3773   "RTN","RCD PBTLM",90, 0)
  3774    ;  requir es rcbilld a
  3775   "RTN","RCD PBTLM",91, 0)
  3776    N %,DATA, RCDEBTDA,R CDPDATA
  3777   "RTN","RCD PBTLM",92, 0)
  3778    ;
  3779   "RTN","RCD PBTLM",93, 0)
  3780    D DIQ430^ RCDPBPLM(R CBILLDA,". 01;8;")
  3781   "RTN","RCD PBTLM",94, 0)
  3782    ;
  3783   "RTN","RCD PBTLM",95, 0)
  3784    S RCDEBTD A=$P(^PRCA (430,RCBIL LDA,0),"^" ,9)
  3785   "RTN","RCD PBTLM",96, 0)
  3786    S DATA=$$ ACCNTHDR^R CDPAPLM(RC DEBTDA)
  3787   "RTN","RCD PBTLM",97, 0)
  3788    ;
  3789   "RTN","RCD PBTLM",98, 0)
  3790    S %="",$P (%," ",80) =""
  3791   "RTN","RCD PBTLM",99, 0)
  3792    ; PRCA*4. 5*276 - ge t EEOB ind icator for  1st/3rd p arty payme nt and att ach to bi
  3793   ll when ap plicable
  3794   "RTN","RCD PBTLM",100 ,0)
  3795    S PRCOUT= $$COMP3^PR CAAPR(RCBI LLDA)
  3796   "RTN","RCD PBTLM",101 ,0)
  3797    I PRCOUT' ="%" S PRC OUT=$$IBEE OBCK^PRCAA PR1(RCBILL DA)
  3798   "RTN","RCD PBTLM",102 ,0)
  3799    S VALMHDR (1)=$E("Bi ll #: "_$G (PRCOUT)_$ G(RCDPDATA (430,RCBIL LDA,.01,"E "))_%,1,2
  3800   5)_"Accoun t: "_$P(DA TA,"^")_$P (DATA,"^", 2)
  3801   "RTN","RCD PBTLM",103 ,0)
  3802    S VALMHDR (2)=$E("St atus: "_$G (RCDPDATA( 430,RCBILL DA,8,"E")) _%,1,25)_$ E("   Add
  3803   r: "_$P(DA TA,"^",4)_ ", "_$P(DA TA,"^",7)_ ", "_$P(DA TA,"^",8)_ "  "_$P(DA TA,"^",9)
  3804   _%,1,55)
  3805   "RTN","RCD PBTLM",104 ,0)
  3806    ; PRCA*4. 5*276 - sh ow caption  for user
  3807   "RTN","RCD PBTLM",105 ,0)
  3808    S VALMSG= "|% EEOB |  Enter ??  for more a ctions |"  ; PRCA*4.5 *276
  3809   "RTN","RCD PBTLM",106 ,0)
  3810    Q
  3811   "RTN","RCD PBTLM",107 ,0)
  3812    S VALMHDR (3)="  "_I ORVON_$E(" Bill Balan ce: "_$J($ P(RCTOTAL, "^")+$P(RC TOTAL,"^"
  3813   ,2)+$P(RCT OTAL,"^",3 )+$P(RCTOT AL,"^",4)+ $P(RCTOTAL ,"^",5),0, 2)_%,1,23) _IORVOFF_
  3814   "  Phone:  "_$P(DATA, "^",10)
  3815   "RTN","RCD PBTLM",108 ,0)
  3816    Q
  3817   "RTN","RCD PBTLM",109 ,0)
  3818    ;
  3819   "RTN","RCD PBTLM",110 ,0)
  3820    ;
  3821   "RTN","RCD PBTLM",111 ,0)
  3822   EXIT ;  ex it list ma nager opti on and cle an up
  3823   "RTN","RCD PBTLM",112 ,0)
  3824    K ^TMP("R CDPBTLM",$ J),^TMP("R CDPBTLMX", $J)
  3825   "RTN","RCD PBTLM",113 ,0)
  3826    Q
  3827   "RTN","RCD PBTLM",114 ,0)
  3828    ;
  3829   "RTN","RCD PBTLM",115 ,0)
  3830    ;
  3831   "RTN","RCD PBTLM",116 ,0)
  3832   SELBILL()  ;  select  a bill
  3833   "RTN","RCD PBTLM",117 ,0)
  3834    ;  return s -1 for t imeout or  ^, 0 for n o selectio n, or ien  of bill
  3835   "RTN","RCD PBTLM",118 ,0)
  3836    N %,%Y,C, DIC,DTOUT, DUOUT,RCBE FLUP,X,Y
  3837   "RTN","RCD PBTLM",119 ,0)
  3838    N DPTNOFZ Y,DPTNOFZK  S (DPTNOF ZY,DPTNOFZ K)=1
  3839   "RTN","RCD PBTLM",120 ,0)
  3840    N RCY,DIR ,DIRUT
  3841   "RTN","RCD PBTLM",121 ,0)
  3842    ; allow u ser to get  the recor d using bi ll# or ECM E#
  3843   "RTN","RCD PBTLM",122 ,0)
  3844    S DIR("A" )="Select  (B)ILL or  (E)CME#: "
  3845   "RTN","RCD PBTLM",123 ,0)
  3846    S DIR(0)= "SA^B:BILL  NUMBER;E: ECME#"
  3847   "RTN","RCD PBTLM",124 ,0)
  3848    S DIR("B" )="B"
  3849   "RTN","RCD PBTLM",125 ,0)
  3850    D ^DIR K  DIR I $D(D IRUT) Q 0
  3851   "RTN","RCD PBTLM",126 ,0)
  3852    S RCY=Y
  3853   "RTN","RCD PBTLM",127 ,0)
  3854    I RCY="E"  Q $$SELEC ME
  3855   "RTN","RCD PBTLM",128 ,0)
  3856    S DIC="^P RCA(430,", DIC(0)="QE AM",DIC("A ")="Select  BILL: "
  3857   "RTN","RCD PBTLM",129 ,0)
  3858    S DIC("W" )="D DICW^ RCBEUBI1"
  3859   "RTN","RCD PBTLM",130 ,0)
  3860    ;  specia l lookup o n input
  3861   "RTN","RCD PBTLM",131 ,0)
  3862    S RCBEFLU P=1
  3863   "RTN","RCD PBTLM",132 ,0)
  3864    D ^DIC
  3865   "RTN","RCD PBTLM",133 ,0)
  3866    I Y<0,'$G (DUOUT),'$ G(DTOUT) S  Y=0
  3867   "RTN","RCD PBTLM",134 ,0)
  3868    Q +Y
  3869   "RTN","RCD PBTLM",135 ,0)
  3870    ;
  3871   "RTN","RCD PBTLM",136 ,0)
  3872    ;
  3873   "RTN","RCD PBTLM",137 ,0)
  3874   GETTRANS(B ILLDA) ;   original a mount goes  first for  bill
  3875   "RTN","RCD PBTLM",138 ,0)
  3876    ;  return s list of  transactio ns in
  3877   "RTN","RCD PBTLM",139 ,0)
  3878    ;  rclist (date,tran da)=tranty pe ^ princ iple ^ int erest ^ ad min
  3879   "RTN","RCD PBTLM",140 ,0)
  3880    ;  return s principl e balance  ^ interest  balance ^  admin bal ance
  3881   "RTN","RCD PBTLM",141 ,0)
  3882    ;         ^ marshall  fee balan ce ^ court  cost bala nce
  3883   "RTN","RCD PBTLM",142 ,0)
  3884    N %,ADMBA L,AMTDISP, CCBAL,DATA 0,DATA1,DA TA9,DATE,I NTBAL,MFBA L,PRINBAL, RCDPDATA,
  3885   TRANDA,VAL UE
  3886   "RTN","RCD PBTLM",143 ,0)
  3887    ;
  3888   "RTN","RCD PBTLM",144 ,0)
  3889    D DIQ430^ RCDPBPLM(B ILLDA,"3;6 0;")
  3890   "RTN","RCD PBTLM",145 ,0)
  3891    ;
  3892   "RTN","RCD PBTLM",146 ,0)
  3893    K RCLIST
  3894   "RTN","RCD PBTLM",147 ,0)
  3895    S (ADMBAL ,CCBAL,INT BAL,MFBAL, PRINBAL)=0
  3896   "RTN","RCD PBTLM",148 ,0)
  3897    S PRINBAL =RCDPDATA( 430,BILLDA ,3,"I")
  3898   "RTN","RCD PBTLM",149 ,0)
  3899    ;  loop t ransaction  and add t o list
  3900   "RTN","RCD PBTLM",150 ,0)
  3901    S TRANDA= 0 F  S TRA NDA=$O(^PR CA(433,"C" ,BILLDA,TR ANDA)) Q:' TRANDA  D
  3902   "RTN","RCD PBTLM",151 ,0)
  3903    . S DATA1 =$G(^PRCA( 433,TRANDA ,1))
  3904   "RTN","RCD PBTLM",152 ,0)
  3905    . S DATE= $P(DATA1," ^",9) I 'D ATE Q
  3906   "RTN","RCD PBTLM",153 ,0)
  3907    . ; Don't  include t ransaction s that hav e the INCO MPLETE TRA NSACTION F LAG (#10)
  3908    set to YE S and
  3909   "RTN","RCD PBTLM",154 ,0)
  3910    . ; this  transactio n was prev iously use d by the a uto-correc t program  to correc
  3911   t an earli er issue.  PRCA*4.5*3 07
  3912   "RTN","RCD PBTLM",155 ,0)
  3913    . S DATA0 =$G(^PRCA( 433,TRANDA ,0))
  3914   "RTN","RCD PBTLM",156 ,0)
  3915    . S DATA9 =$G(^PRCA( 433,TRANDA ,9))
  3916   "RTN","RCD PBTLM",157 ,0)
  3917    . ; Check  for Incom plete and  previously  fixed by  auto-corre ct
  3918   "RTN","RCD PBTLM",158 ,0)
  3919    . I $P(DA TA0,U,10), ($P(DATA9, U,4)) S VA LUE="" Q
  3920   "RTN","RCD PBTLM",159 ,0)
  3921    . S VALUE =$$TRANVAL U(TRANDA)  I VALUE=""  Q
  3922   "RTN","RCD PBTLM",160 ,0)
  3923    . S RCLIS T($P(DATE, "."),TRAND A)=$P($G(^ PRCA(430.3 ,+$P(DATA1 ,"^",2),0) ),"^")_VA
  3924   LUE
  3925   "RTN","RCD PBTLM",161 ,0)
  3926    . ;
  3927   "RTN","RCD PBTLM",162 ,0)
  3928    . ;  calc ulate bill 's balance
  3929   "RTN","RCD PBTLM",163 ,0)
  3930    . S PRINB AL=PRINBAL +$P(VALUE, "^",2)
  3931   "RTN","RCD PBTLM",164 ,0)
  3932    . S INTBA L=INTBAL+$ P(VALUE,"^ ",3)
  3933   "RTN","RCD PBTLM",165 ,0)
  3934    . S ADMBA L=ADMBAL+$ P(VALUE,"^ ",4)
  3935   "RTN","RCD PBTLM",166 ,0)
  3936    . S MFBAL =MFBAL+$P( VALUE,"^", 5)
  3937   "RTN","RCD PBTLM",167 ,0)
  3938    . S CCBAL =CCBAL+$P( VALUE,"^", 6)
  3939   "RTN","RCD PBTLM",168 ,0)
  3940    ;
  3941   "RTN","RCD PBTLM",169 ,0)
  3942    S DATE=$G (RCDPDATA( 430,BILLDA ,60,"I"))
  3943   "RTN","RCD PBTLM",170 ,0)
  3944    ;  check  to make su re activat ion date i s not grea ter than f irst trans action
  3945   "RTN","RCD PBTLM",171 ,0)
  3946    S %=$O(RC LIST(0)) I  DATE>% S  DATE=%
  3947   "RTN","RCD PBTLM",172 ,0)
  3948    S RCLIST( +$P(DATE," ."),0)="or iginal amo unt^"_RCDP DATA(430,B ILLDA,3,"I ")
  3949   "RTN","RCD PBTLM",173 ,0)
  3950    ;
  3951   "RTN","RCD PBTLM",174 ,0)
  3952    Q PRINBAL _"^"_INTBA L_"^"_ADMB AL_"^"_MFB AL_"^"_CCB AL
  3953   "RTN","RCD PBTLM",175 ,0)
  3954    ;
  3955   "RTN","RCD PBTLM",176 ,0)
  3956    ;
  3957   "RTN","RCD PBTLM",177 ,0)
  3958   TRANVALU(T RANDA) ;   return the  transacti on value a s displaye d (with +  or - sign
  3959   )
  3960   "RTN","RCD PBTLM",178 ,0)
  3961    N TYPE,VA LUE
  3962   "RTN","RCD PBTLM",179 ,0)
  3963    S VALUE=$ $TRANBAL^R CRJRCOT(TR ANDA)
  3964   "RTN","RCD PBTLM",180 ,0)
  3965    ;  no dol lars on tr ansaction
  3966   "RTN","RCD PBTLM",181 ,0)
  3967    I '$P(VAL UE,"^"),'$ P(VALUE,"^ ",2),'$P(V ALUE,"^",3 ),'$P(VALU E,"^",4),' $P(VALUE,
  3968   "^",5) Q " "
  3969   "RTN","RCD PBTLM",182 ,0)
  3970    ;  check  type for p ayments, e tc, make v alues (-)  to subtrac t
  3971   "RTN","RCD PBTLM",183 ,0)
  3972    S TYPE=$P ($G(^PRCA( 433,TRANDA ,1)),"^",2 )
  3973   "RTN","RCD PBTLM",184 ,0)
  3974    I TYPE=2! (TYPE=8)!( TYPE=9)!(T YPE=10)!(T YPE=11)!(T YPE=14)!(T YPE=29)!(T YPE=34)!(
  3975   TYPE=35)!( TYPE=41) D
  3976   "RTN","RCD PBTLM",185 ,0)
  3977    .   S $P( VALUE,"^", 1)=-$P(VAL UE,"^",1)
  3978   "RTN","RCD PBTLM",186 ,0)
  3979    .   S $P( VALUE,"^", 2)=-$P(VAL UE,"^",2)
  3980   "RTN","RCD PBTLM",187 ,0)
  3981    .   S $P( VALUE,"^", 3)=-$P(VAL UE,"^",3)
  3982   "RTN","RCD PBTLM",188 ,0)
  3983    .   S $P( VALUE,"^", 4)=-$P(VAL UE,"^",4)
  3984   "RTN","RCD PBTLM",189 ,0)
  3985    .   S $P( VALUE,"^", 5)=-$P(VAL UE,"^",5)
  3986   "RTN","RCD PBTLM",190 ,0)
  3987    ;
  3988   "RTN","RCD PBTLM",191 ,0)
  3989    ;  the fo llowing tr ansaction  types shou ld not cha nge the bi lls balanc e
  3990   "RTN","RCD PBTLM",192 ,0)
  3991    ;  return  the amoun t displaye d in the d escription  and 0 for  value
  3992   "RTN","RCD PBTLM",193 ,0)
  3993    ;    refe r to RC 3,  refer to  DOJ 4, ree stablish 5 , returned  6 and 32
  3994   "RTN","RCD PBTLM",194 ,0)
  3995    ;    repa yment plan  25, amend ed 33, sus pended 47,  unsuspend ed 46
  3996   "RTN","RCD PBTLM",195 ,0)
  3997    K AMTDISP
  3998   "RTN","RCD PBTLM",196 ,0)
  3999    I TYPE=3! (TYPE=4)!( TYPE=5)!(T YPE=6)!(TY PE=25)!(TY PE=32)!(TY PE=33)!(TY PE=46)!(T
  4000   YPE=47) D
  4001   "RTN","RCD PBTLM",197 ,0)
  4002    .   S AMT DISP=" ($" _$J($P(VAL UE,"^")+$P (VALUE,"^" ,2)+$P(VAL UE,"^",3)+ $P(VALUE,
  4003   "^",4)+$P( VALUE,"^", 5),0,2)_") "
  4004   "RTN","RCD PBTLM",198 ,0)
  4005    .   S VAL UE=""
  4006   "RTN","RCD PBTLM",199 ,0)
  4007    Q $G(AMTD ISP)_"^"_V ALUE
  4008   "RTN","RCD PBTLM",200 ,0)
  4009    ;
  4010   "RTN","RCD PBTLM",201 ,0)
  4011   SELECME()  ;
  4012   "RTN","RCD PBTLM",202 ,0)
  4013    ; functio n takes th e user inp ut of the  ECME # to  return a v alid ien o f file 43
  4014   0
  4015   "RTN","RCD PBTLM",203 ,0)
  4016    ; if an i nvalid ECM E is evalu ated then  the proces s keeps as king the u ser for E
  4017   CME #
  4018   "RTN","RCD PBTLM",204 ,0)
  4019    ; until a  valid ECM E# is ente red or unt il the use r enters a  "^" or nu ll value
  4020   "RTN","RCD PBTLM",205 ,0)
  4021    ; output  - returns  the IEN of  the recor d entry in  the ACCOU NT RECEIVA BLE file 
  4022   (#430) or  "??"
  4023   "RTN","RCD PBTLM",206 ,0)
  4024    N RCECME, RCBILL,DIR ,DIRUT,Y
  4025   "RTN","RCD PBTLM",207 ,0)
  4026    S DIR(0)= "FO^1:12^I  X'?1.12N  W !!,""Can not contai n alpha ch aracters""  K X"
  4027   "RTN","RCD PBTLM",208 ,0)
  4028    S DIR("A" )="Select  ECME#"
  4029   "RTN","RCD PBTLM",209 ,0)
  4030   RET D ^DIR  I $D(DIRU T) Q 0
  4031   "RTN","RCD PBTLM",210 ,0)
  4032    S RCECME= $S(+Y>0:Y, 1:0)
  4033   "RTN","RCD PBTLM",211 ,0)
  4034    S RCBILL= $$REC^IBRF N(RCECME)     ; IA 20 31
  4035   "RTN","RCD PBTLM",212 ,0)
  4036    I RCBILL< 0 W !!,"?? " G RET
  4037   "RTN","RCD PBTLM",213 ,0)
  4038    E  W !!,$ P($G(^PRCA (430,+RCBI LL,0)),"^" )," "
  4039   "RTN","RCD PBTLM",214 ,0)
  4040    Q RCBILL
  4041   "RTN","RCD PBTLM",215 ,0)
  4042    ;RCDPBTLM
  4043   "RTN","RCW ROFF")
  4044   0^4^B36621 298^B34901 459
  4045   "RTN","RCW ROFF",1,0)
  4046   RCWROFF ;W ISC/RFJ-wr ite off, t erminated  ;1 Feb 200 0
  4047   "RTN","RCW ROFF",2,0)
  4048    ;;4.5;Acc ounts Rece ivable;**1 68,204,309 ,307**;Mar  20, 1995; Build 72
  4049   "RTN","RCW ROFF",3,0)
  4050    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4051   "RTN","RCW ROFF",4,0)
  4052    Q
  4053   "RTN","RCW ROFF",5,0)
  4054    ;
  4055   "RTN","RCW ROFF",6,0)
  4056    ;
  4057   "RTN","RCW ROFF",7,0)
  4058   8 ;  termi nated by f iscal offi cer (trant ype=8) (me nu option)
  4059   "RTN","RCW ROFF",8,0)
  4060    N RCDRSTR G
  4061   "RTN","RCW ROFF",9,0)
  4062    S RCDRSTR G="11TERMI NATION DAT E;"
  4063   "RTN","RCW ROFF",10,0 )
  4064    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  4065   "RTN","RCW ROFF",11,0 )
  4066    D MAIN("8 ^Fiscal Of ficer Term ination",R CDRSTRG)
  4067   "RTN","RCW ROFF",12,0 )
  4068    Q
  4069   "RTN","RCW ROFF",13,0 )
  4070    ;
  4071   "RTN","RCW ROFF",14,0 )
  4072    ;
  4073   "RTN","RCW ROFF",15,0 )
  4074   9 ;  termi nated by c ompromise  (trantype= 9) (menu o ption)
  4075   "RTN","RCW ROFF",16,0 )
  4076    N RCDRSTR G
  4077   "RTN","RCW ROFF",17,0 )
  4078    S RCDRSTR G="11TERMI NATION DAT E;"
  4079   "RTN","RCW ROFF",18,0 )
  4080    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  4081   "RTN","RCW ROFF",19,0 )
  4082    D MAIN("9 ^Compromis e Terminat ion",RCDRS TRG)
  4083   "RTN","RCW ROFF",20,0 )
  4084    Q
  4085   "RTN","RCW ROFF",21,0 )
  4086    ;
  4087   "RTN","RCW ROFF",22,0 )
  4088    ;
  4089   "RTN","RCW ROFF",23,0 )
  4090   A9 ;  comp romised by  rc/doj (u se trantyp e=9) (menu  option)
  4091   "RTN","RCW ROFF",24,0 )
  4092    N RCDRSTR G
  4093   "RTN","RCW ROFF",25,0 )
  4094    S RCDRSTR G="11TERMI NATION DAT E;"
  4095   "RTN","RCW ROFF",26,0 )
  4096    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  4097   "RTN","RCW ROFF",27,0 )
  4098    D MAIN("9 ^Compromis e Terminat ion by RC/ DOJ",RCDRS TRG)
  4099   "RTN","RCW ROFF",28,0 )
  4100    Q
  4101   "RTN","RCW ROFF",29,0 )
  4102    ;
  4103   "RTN","RCW ROFF",30,0 )
  4104    ;
  4105   "RTN","RCW ROFF",31,0 )
  4106   10 ;  waiv ed in full  transacti on (tranty pe=10) (me nu option)
  4107   "RTN","RCW ROFF",32,0 )
  4108    D MAIN("1 0^Waiver", "11WAIVED  DATE;")
  4109   "RTN","RCW ROFF",33,0 )
  4110    Q
  4111   "RTN","RCW ROFF",34,0 )
  4112    ;
  4113   "RTN","RCW ROFF",35,0 )
  4114    ;
  4115   "RTN","RCW ROFF",36,0 )
  4116   A10 ;  wai ved by rc/ doj (use t rantype=10 ) (menu op tion)
  4117   "RTN","RCW ROFF",37,0 )
  4118    D MAIN("1 0^RC/DOJ W aiver","11 WAIVED DAT E;")
  4119   "RTN","RCW ROFF",38,0 )
  4120    Q
  4121   "RTN","RCW ROFF",39,0 )
  4122    ;
  4123   "RTN","RCW ROFF",40,0 )
  4124    ;
  4125   "RTN","RCW ROFF",41,0 )
  4126   29 ;  term inated by  rc/doj (tr antype=29)  (menu opt ion)
  4127   "RTN","RCW ROFF",42,0 )
  4128    N RCDRSTR G
  4129   "RTN","RCW ROFF",43,0 )
  4130    S RCDRSTR G="11TERMI NATION DAT E;"
  4131   "RTN","RCW ROFF",44,0 )
  4132    S RCDRSTR G=RCDRSTRG _"17;"  ;t ermination  reason
  4133   "RTN","RCW ROFF",45,0 )
  4134    D MAIN("2 9^RC/DOJ T ermination ",RCDRSTRG )
  4135   "RTN","RCW ROFF",46,0 )
  4136    Q
  4137   "RTN","RCW ROFF",47,0 )
  4138    ;
  4139   "RTN","RCW ROFF",48,0 )
  4140    ;
  4141   "RTN","RCW ROFF",49,0 )
  4142   47 ;  susp ended (tra ntype=47)  (menu opti on)
  4143   "RTN","RCW ROFF",50,0 )
  4144    N RCDRSTR G
  4145   "RTN","RCW ROFF",51,0 )
  4146    S RCDRSTR G="11SUSPE NDED DATE; "
  4147   "RTN","RCW ROFF",52,0 )
  4148    S RCDRSTR G=RCDRSTRG _"90R;"  ; suspension  type
  4149   "RTN","RCW ROFF",53,0 )
  4150    S RCDRSTR G=RCDRSTRG _"S RCX=$$ SUSTP^RCWR OFF(X);"
  4151   "RTN","RCW ROFF",54,0 )
  4152    S RCDRSTR G=RCDRSTRG _"5.02//// ^S X=RCX;"   ;brief c omment
  4153   "RTN","RCW ROFF",55,0 )
  4154    S RCDRSTR G=RCDRSTRG _"K RCX;"
  4155   "RTN","RCW ROFF",56,0 )
  4156    D MAIN("4 7^Suspensi on",RCDRST RG)
  4157   "RTN","RCW ROFF",57,0 )
  4158    Q
  4159   "RTN","RCW ROFF",58,0 )
  4160    ;
  4161   "RTN","RCW ROFF",59,0 )
  4162   SUSTP(X) ;  suspensio n types fo r brief co mment in * 309
  4163   "RTN","RCW ROFF",60,0 )
  4164    ; input-c ode betwee n 0 to 11
  4165   "RTN","RCW ROFF",61,0 )
  4166    ; output- text
  4167   "RTN","RCW ROFF",62,0 )
  4168    N IBX
  4169   "RTN","RCW ROFF",63,0 )
  4170    S IBX=$P( $T(SUSTX+X ),";;",2)
  4171   "RTN","RCW ROFF",64,0 )
  4172    Q IBX
  4173   "RTN","RCW ROFF",65,0 )
  4174    ;
  4175   "RTN","RCW ROFF",66,0 )
  4176   SUSTX ;;NO T CO-PAY S USPENSION
  4177   "RTN","RCW ROFF",67,0 )
  4178    ;;INITIAL  CO-PAY WA IVER
  4179   "RTN","RCW ROFF",68,0 )
  4180    ;;APPEAL  CO-PAY WAI VER
  4181   "RTN","RCW ROFF",69,0 )
  4182    ;;ADMINIS TRATIVE SU SPENSION
  4183   "RTN","RCW ROFF",70,0 )
  4184    ;;COMPROM ISE
  4185   "RTN","RCW ROFF",71,0 )
  4186    ;;TERMINA TION
  4187   "RTN","RCW ROFF",72,0 )
  4188    ;;BANKRUP TCY CHAP 7
  4189   "RTN","RCW ROFF",73,0 )
  4190    ;;BANKRUP TCY CHAP 1 3
  4191   "RTN","RCW ROFF",74,0 )
  4192    ;;BANKRUP TCY OTHER
  4193   "RTN","RCW ROFF",75,0 )
  4194    ;;PROBATE
  4195   "RTN","RCW ROFF",76,0 )
  4196    ;;CHOICE
  4197   "RTN","RCW ROFF",77,0 )
  4198    ;;DISPUTE
  4199   "RTN","RCW ROFF",78,0 )
  4200    ;
  4201   "RTN","RCW ROFF",79,0 )
  4202    ;
  4203   "RTN","RCW ROFF",80,0 )
  4204   MAIN(RCTRT YPE,RCDRST RG) ;  mai n subrouti ne to proc ess a waiv er, termin ation, su
  4205   spended tr ansaction
  4206   "RTN","RCW ROFF",81,0 )
  4207    ;  rctrty pe = trans action typ e^descript ion, examp le 10^waiv er
  4208   "RTN","RCW ROFF",82,0 )
  4209    ;  rcdrst rg = dr st ring used  when calli ng die
  4210   "RTN","RCW ROFF",83,0 )
  4211    N BALANCE ,DR,RCBILL DA,RCTRAND A,Y
  4212   "RTN","RCW ROFF",84,0 )
  4213    F  D  Q:R CBILLDA<1
  4214   "RTN","RCW ROFF",85,0 )
  4215    .   K RCT RANDA  ;do  not leave  around in  for loop
  4216   "RTN","RCW ROFF",86,0 )
  4217    .   ;  se lect a bil l
  4218   "RTN","RCW ROFF",87,0 )
  4219    .   S RCB ILLDA=$$GE TABILL^RCB EUBIL I RC BILLDA<1 Q
  4220   "RTN","RCW ROFF",88,0 )
  4221    .   ;  ch eck to see  if bill h as been re ferred to  rc/doj (6; 4 = referr al date)
  4222   "RTN","RCW ROFF",89,0 )
  4223    .   I $P( RCTRTYPE," ^",2)["RC/ DOJ",$P($G (^PRCA(430 ,RCBILLDA, 6)),"^",4) ="" W !,"
  4224   THIS ACCOU NT IS NOT  REFERRED T O RC/DOJ."  Q
  4225   "RTN","RCW ROFF",90,0 )
  4226    .   ;  lo ck the bil l
  4227   "RTN","RCW ROFF",91,0 )
  4228    .   L +^P RCA(430,RC BILLDA):5  I '$T W !, "ANOTHER U SER IS CUR RENTLY WOR KING WITH
  4229    THIS BILL ." Q
  4230   "RTN","RCW ROFF",92,0 )
  4231    .   D SHO WBILL^RCWR OFF1(RCBIL LDA)
  4232   "RTN","RCW ROFF",93,0 )
  4233    .   I '$G (^PRCA(430 ,RCBILLDA, 7)) W !,"T HIS BILL H AS NO PRIN CIPAL BALA NCE." D U
  4234   NLOCK Q
  4235   "RTN","RCW ROFF",94,0 )
  4236    .   ;  as k to enter  transacti on
  4237   "RTN","RCW ROFF",95,0 )
  4238    .   S Y=$ $ASKOK($P( RCTRTYPE," ^",2)) I Y '=1 D UNLO CK S:Y<0 R CBILLDA=0  Q
  4239   "RTN","RCW ROFF",96,0 )
  4240    .   ;  ad d a new tr ansaction  to file 43 3
  4241   "RTN","RCW ROFF",97,0 )
  4242    .   S RCT RANDA=$$AD D433^RCBEU TRA(RCBILL DA,$P(RCTR TYPE,"^"))  I 'RCTRAN DA W !,$P
  4243   (RCTRANDA, "^",2) D U NLOCK Q
  4244   "RTN","RCW ROFF",98,0 )
  4245    .   W !,"   Transact ion number  ",RCTRAND A," added  ..."
  4246   "RTN","RCW ROFF",99,0 )
  4247    .   ;
  4248   "RTN","RCW ROFF",100, 0)
  4249    .   ;  se t up dr st ring for d ie call  P RCA*4.5*30 7 - Move c omment bel ow balanc
  4250   e sets
  4251   "RTN","RCW ROFF",101, 0)
  4252    .   S DR= RCDRSTRG    ;_"41;"   ;comment
  4253   "RTN","RCW ROFF",102, 0)
  4254    .   ;  bi ll amount  moved to t ransaction  amount
  4255   "RTN","RCW ROFF",103, 0)
  4256    .   S BAL ANCE=$P($G (^PRCA(430 ,RCBILLDA, 7)),"^",1, 5)
  4257   "RTN","RCW ROFF",104, 0)
  4258    .   S DR= DR_"15//// "_($P(BALA NCE,"^")+$ P(BALANCE, "^",2)+$P( BALANCE,"^ ",3)+$P(B
  4259   ALANCE,"^" ,4)+$P(BAL ANCE,"^",5 ))_";"
  4260   "RTN","RCW ROFF",105, 0)
  4261    .   I $P( BALANCE,"^ ",1) S DR= DR_"81//// "_+$P(BALA NCE,"^",1) _";"   ;pr incipal
  4262   "RTN","RCW ROFF",106, 0)
  4263    .   I $P( BALANCE,"^ ",2) S DR= DR_"82//// "_+$P(BALA NCE,"^",2) _";"   ;in terest
  4264   "RTN","RCW ROFF",107, 0)
  4265    .   I $P( BALANCE,"^ ",3) S DR= DR_"83//// "_+$P(BALA NCE,"^",3) _";"   ;ad min
  4266   "RTN","RCW ROFF",108, 0)
  4267    .   I $P( BALANCE,"^ ",4) S DR= DR_"84//// "_+$P(BALA NCE,"^",4) _";"   ;ma rshal fee
  4268   "RTN","RCW ROFF",109, 0)
  4269    .   I $P( BALANCE,"^ ",5) S DR= DR_"85//// "_+$P(BALA NCE,"^",5) _";"   ;co urt cost
  4270   "RTN","RCW ROFF",110, 0)
  4271    .   ;
  4272   "RTN","RCW ROFF",111, 0)
  4273    .   ; PRC A*4.5*307  - Comment  save is mo ved below  balance se ts
  4274   "RTN","RCW ROFF",112, 0)
  4275    .   S DR= DR_"41;"
  4276   "RTN","RCW ROFF",113, 0)
  4277    .   ;  ed it the fie lds
  4278   "RTN","RCW ROFF",114, 0)
  4279    .   S Y=$ $EDIT433^R CBEUTRA(RC TRANDA,DR)
  4280   "RTN","RCW ROFF",115, 0)
  4281    .   I 'Y  W !,$P(Y," ^",2) D DE L433^RCBEU TRA(RCTRAN DA,"",0),U NLOCK Q
  4282   "RTN","RCW ROFF",116, 0)
  4283    .   ;  se t the bill  and trans action as  RC/DOJ
  4284   "RTN","RCW ROFF",117, 0)
  4285    .   I $P( RCTRTYPE," ^",2)["RC/ DOJ" D SET RCDOJ^RCBE UBIL(RCBIL LDA,RCTRAN DA,"RC")
  4286   "RTN","RCW ROFF",118, 0)
  4287    .   ;  ch ange the s tatus of t he bill
  4288   "RTN","RCW ROFF",119, 0)
  4289    .   I $P( RCTRTYPE," ^")'=47 D  CHGSTAT^RC BEUBIL(RCB ILLDA,23)   ;write of f
  4290   "RTN","RCW ROFF",120, 0)
  4291    .   I $P( RCTRTYPE," ^")=47 D C HGSTAT^RCB EUBIL(RCBI LLDA,40)    ;suspende d
  4292   "RTN","RCW ROFF",121, 0)
  4293    .   ;  ma rk transac tion as pr ocessed
  4294   "RTN","RCW ROFF",122, 0)
  4295    .   D PRO CESS^RCBEU TRA(RCTRAN DA)
  4296   "RTN","RCW ROFF",123, 0)
  4297    .   ;
  4298   "RTN","RCW ROFF",124, 0)
  4299    .   ;  cr eate fms w rite off d ocument, i f not accr ued and no t suspende d (47) tr
  4300   ansaction
  4301   "RTN","RCW ROFF",125, 0)
  4302    .   I '$$ ACCK^PRCAA CC(RCBILLD A),$P($G(^ PRCA(433,R CTRANDA,1) ),"^",2)'= 47 D FMSD
  4303   OC(RCTRAND A)
  4304   "RTN","RCW ROFF",126, 0)
  4305    .   ;
  4306   "RTN","RCW ROFF",127, 0)
  4307    .   W !,"   * * * *  * ",$P(RCT RTYPE,"^", 2)," has b een PROCES SED! * * *  * *"
  4308   "RTN","RCW ROFF",128, 0)
  4309    .   I '$G (REFMS)&(D T>$$LDATE^ RCRJR(DT))  S Y=$E($$ FPS^RCAMFN 01(DT,1),1 ,5)_"01" 
  4310   D DD^%DT W  !!,"   *  * * * Tran smission w ill be hel d until "_ Y_" * * *  *"
  4311   "RTN","RCW ROFF",129, 0)
  4312    .   D UNL OCK
  4313   "RTN","RCW ROFF",130, 0)
  4314    Q
  4315   "RTN","RCW ROFF",131, 0)
  4316    ;
  4317   "RTN","RCW ROFF",132, 0)
  4318    ;
  4319   "RTN","RCW ROFF",133, 0)
  4320   FMSDOC(RCT RANDA) ;   create fms  write off  document
  4321   "RTN","RCW ROFF",134, 0)
  4322    N Y
  4323   "RTN","RCW ROFF",135, 0)
  4324    W !!,"Cre ating FMS  Write-off  document . .. "
  4325   "RTN","RCW ROFF",136, 0)
  4326    S Y=$$BUI LDWR^RCXFM SW1(RCTRAN DA)
  4327   "RTN","RCW ROFF",137, 0)
  4328    I Y W $P( Y,"^",2),"  created."
  4329   "RTN","RCW ROFF",138, 0)
  4330    E  W "ERR OR: ",$P(Y ,"^",2)
  4331   "RTN","RCW ROFF",139, 0)
  4332    Q
  4333   "RTN","RCW ROFF",140, 0)
  4334    ;
  4335   "RTN","RCW ROFF",141, 0)
  4336    ;
  4337   "RTN","RCW ROFF",142, 0)
  4338   UNLOCK ;   unlock bil l and tran saction
  4339   "RTN","RCW ROFF",143, 0)
  4340    L -^PRCA( 430,RCBILL DA)
  4341   "RTN","RCW ROFF",144, 0)
  4342    I $G(RCTR ANDA) L -^ PRCA(433,R CTRANDA)
  4343   "RTN","RCW ROFF",145, 0)
  4344    Q
  4345   "RTN","RCW ROFF",146, 0)
  4346    ;
  4347   "RTN","RCW ROFF",147, 0)
  4348    ;
  4349   "RTN","RCW ROFF",148, 0)
  4350   ASKOK(TRAN TYPE) ;  a sk record  transactio n
  4351   "RTN","RCW ROFF",149, 0)
  4352    N DIR,DIQ 2,DIRUT,DT OUT,DUOUT, X,Y
  4353   "RTN","RCW ROFF",150, 0)
  4354    S DIR(0)= "YO",DIR(" B")="NO"
  4355   "RTN","RCW ROFF",151, 0)
  4356    S DIR("A" )="  Are y ou sure yo u want to  record thi s bill as  a "
  4357   "RTN","RCW ROFF",152, 0)
  4358    I $L(TRAN TYPE)<20 S  DIR("A")= DIR("A")_T RANTYPE
  4359   "RTN","RCW ROFF",153, 0)
  4360    E  S DIR( "A",1)=DIR ("A"),DIR( "A")="  "_ TRANTYPE
  4361   "RTN","RCW ROFF",154, 0)
  4362    W ! D ^DI R
  4363   "RTN","RCW ROFF",155, 0)
  4364    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  4365   "RTN","RCW ROFF",156, 0)
  4366    Q Y
  4367   "VER")
  4368   8.0^22.0
  4369   "^DD",433, 433,94,0)
  4370   AUTO-CORRE CTION DATE ^D^^9;4^S  %DT="EX" D  ^%DT S X= Y K:Y<1 X
  4371   "^DD",433, 433,94,3)
  4372   Type the d ate that t he stateme nt discrep ancy was c orrected.
  4373   "^DD",433, 433,94,21, 0)
  4374   ^^2^2^3160 428^
  4375   "^DD",433, 433,94,21, 1,0)
  4376   The is the  date that  the auto- correction  program c orrected t he
  4377   "^DD",433, 433,94,21, 2,0)
  4378   statement  discrepanc y for this  transacti on.
  4379   "^DD",433, 433,94,"DT ")
  4380   3160920
  4381   "^DD",433, 433,95,0)
  4382   AUTO-CORRE CTION TRAN S. AMOUNT^ NJ9,2^^9;5 ^S:X["$" X =$P(X,"$", 2) K:X'?." -".N.1"."
  4383   .2N!(X>999 999)!(X<-9 99999) X
  4384   "^DD",433, 433,95,3)
  4385   Type a dol lar amount  between - 999999 and  999999, 2  decimal d igits.
  4386   "^DD",433, 433,95,21, 0)
  4387   ^.001^1^1^ 3160428^^
  4388   "^DD",433, 433,95,21, 1,0)
  4389   This is th e transact ion amount  associate d with the  statement  discrepan cy.
  4390   "^DD",433, 433,95,"DT ")
  4391   3160428
  4392   "^DD",433, 433,96,0)
  4393   AUTO-CORRE CTION TYPE  OF ERROR^ S^I:INCOMP LETE FLAG  ERROR;D:DU PLICATE TR ANSACTION
  4394   ;N:NULL TR ANSACTION  AMOUNT;X:N OT FIXABLE ;^9;6^Q
  4395   "^DD",433, 433,96,3)
  4396   Type the k ind of sta tement dis crepancy e rror that  was correc ted.
  4397   "^DD",433, 433,96,21, 0)
  4398   ^^5^5^3161 004^
  4399   "^DD",433, 433,96,21, 1,0)
  4400   This field  stores th e type of  error that  was corre cted
  4401   "^DD",433, 433,96,21, 2,0)
  4402   for the st atement di screpancy.   The erro rs are thr ee
  4403   "^DD",433, 433,96,21, 3,0)
  4404   types: inc omplete fl ag error,  a duplicat e transact ion,
  4405   "^DD",433, 433,96,21, 4,0)
  4406   a null tra nsaction a mount, or  not fixabl e for all  other
  4407   "^DD",433, 433,96,21, 5,0)
  4408   errors.
  4409   "^DD",433, 433,96,"DT ")
  4410   3161004
  4411   "^DD",433, 433,97,0)
  4412   AUTO-CORRE CTION TICK ET FLAG^S^ 1:YES;0:NO ;^9;7^Q
  4413   "^DD",433, 433,97,3)
  4414   Enter Yes  if this tr ansaction  will need  to be manu ally revie wed and co rrected.
  4415   "^DD",433, 433,97,21, 0)
  4416   ^^2^2^3161 027^
  4417   "^DD",433, 433,97,21, 1,0)
  4418   Flag notin g that thi s transact ion will n eed to be  manually r eviewed an
  4419   "^DD",433, 433,97,21, 2,0)
  4420   corrected.
  4421   "^DD",433, 433,97,"DT ")
  4422   3161027
  4423   "BLD",1015 3,6)
  4424   18^
  4425   $END KID P RCA*4.5*30 7