5. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 3/2/2018 12:46:59 PM Central 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.

5.1 Files compared

# Location File Last Modified
1 PRCA_IB_EPAYMENTS_BUNDLE_2_0_V25.zip PRCA_IB_EPAYMENTS_BUNDLE_2_0_V25.KID Wed Dec 20 18:22:08 2017 UTC
2 PRCA_IB_EPAYMENTS_BUNDLE_2_0_V25.zip PRCA_IB_EPAYMENTS_BUNDLE_2_0_V25.KID Fri Mar 2 18:18:58 2018 UTC

5.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 2 77974
Changed 1 2
Inserted 0 0
Removed 0 0

5.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

5.4 Active regular expressions

No regular expressions were active.

5.5 Comparison detail

  1   KIDS Distr ibution sa ved on Dec  01, 2017@ 14:26:21
  2   PRCA IB EP AYMENTS BU NDLE 2.0 T EST V25
  3   **KIDS**:P RCA IB EPA YMENTS BUN DLE 2.0^IB *2.0*596^P RCA*4.5*32 1^
  4  
  5   **INSTALL  NAME**
  6   PRCA IB EP AYMENTS BU NDLE 2.0
  7   "BLD",1058 3,0)
  8   PRCA IB EP AYMENTS BU NDLE 2.0^^ 1^3171201^ y
  9   "BLD",1058 3,1,0)
  10   ^^5^5^3170 626^
  11   "BLD",1058 3,1,1,0)
  12   The purpos e of this  patch is t o meet the  requireme nts of the  Medical C are
  13   "BLD",1058 3,1,2,0)
  14   Collection  Fund (MCC F) Electro nic Data I nterchange  (EDI) Tra nsaction 
  15   "BLD",1058 3,1,3,0)
  16   Applicatio n Suite (T AS) Phase  1 project  as related  to Accoun ts Receiva ble
  17   "BLD",1058 3,1,4,0)
  18   (PRCA). Tw o patches  will be re leased in  this KIDS  multi-buil d distribu tion
  19   "BLD",1058 3,1,5,0)
  20   containing : PRCA*4.5 *321 and I B*2*596.
  21   "BLD",1058 3,6.3)
  22   21
  23   "BLD",1058 3,10,0)
  24   ^9.63^2^2
  25   "BLD",1058 3,10,1,0)
  26   IB*2.0*596 ^1
  27   "BLD",1058 3,10,2,0)
  28   PRCA*4.5*3 21^1
  29   "BLD",1058 3,10,"B"," IB*2.0*596 ",1)
  30  
  31   "BLD",1058 3,10,"B"," PRCA*4.5*3 21",2)
  32  
  33   "BLD",1058 3,"KRN",0)
  34   ^9.67PA^77 9.2^20
  35   "BLD",1058 3,"KRN",.4 ,0)
  36   .4
  37   "BLD",1058 3,"KRN",.4 01,0)
  38   .401
  39   "BLD",1058 3,"KRN",.4 02,0)
  40   .402
  41   "BLD",1058 3,"KRN",.4 03,0)
  42   .403
  43   "BLD",1058 3,"KRN",.5 ,0)
  44   .5
  45   "BLD",1058 3,"KRN",.8 4,0)
  46   .84
  47   "BLD",1058 3,"KRN",3. 6,0)
  48   3.6
  49   "BLD",1058 3,"KRN",3. 8,0)
  50   3.8
  51   "BLD",1058 3,"KRN",9. 2,0)
  52   9.2
  53   "BLD",1058 3,"KRN",9. 8,0)
  54   9.8
  55   "BLD",1058 3,"KRN",19 ,0)
  56   19
  57   "BLD",1058 3,"KRN",19 .1,0)
  58   19.1
  59   "BLD",1058 3,"KRN",10 1,0)
  60   101
  61   "BLD",1058 3,"KRN",40 9.61,0)
  62   409.61
  63   "BLD",1058 3,"KRN",77 1,0)
  64   771
  65   "BLD",1058 3,"KRN",77 9.2,0)
  66   779.2
  67   "BLD",1058 3,"KRN",87 0,0)
  68   870
  69   "BLD",1058 3,"KRN",89 89.51,0)
  70   8989.51
  71   "BLD",1058 3,"KRN",89 89.52,0)
  72   8989.52
  73   "BLD",1058 3,"KRN",89 94,0)
  74   8994
  75   "BLD",1058 3,"KRN","B ",.4,.4)
  76  
  77   "BLD",1058 3,"KRN","B ",.401,.40 1)
  78  
  79   "BLD",1058 3,"KRN","B ",.402,.40 2)
  80  
  81   "BLD",1058 3,"KRN","B ",.403,.40 3)
  82  
  83   "BLD",1058 3,"KRN","B ",.5,.5)
  84  
  85   "BLD",1058 3,"KRN","B ",.84,.84)
  86  
  87   "BLD",1058 3,"KRN","B ",3.6,3.6)
  88  
  89   "BLD",1058 3,"KRN","B ",3.8,3.8)
  90  
  91   "BLD",1058 3,"KRN","B ",9.2,9.2)
  92  
  93   "BLD",1058 3,"KRN","B ",9.8,9.8)
  94  
  95   "BLD",1058 3,"KRN","B ",19,19)
  96  
  97   "BLD",1058 3,"KRN","B ",19.1,19. 1)
  98  
  99   "BLD",1058 3,"KRN","B ",101,101)
  100  
  101   "BLD",1058 3,"KRN","B ",409.61,4 09.61)
  102  
  103   "BLD",1058 3,"KRN","B ",771,771)
  104  
  105   "BLD",1058 3,"KRN","B ",779.2,77 9.2)
  106  
  107   "BLD",1058 3,"KRN","B ",870,870)
  108  
  109   "BLD",1058 3,"KRN","B ",8989.51, 8989.51)
  110  
  111   "BLD",1058 3,"KRN","B ",8989.52, 8989.52)
  112  
  113   "BLD",1058 3,"KRN","B ",8994,899 4)
  114  
  115   "MBREQ")
  116   0
  117   "QUES","XP F1",0)
  118   Y
  119   "QUES","XP F1","??")
  120   ^D REP^XPD H
  121   "QUES","XP F1","A")
  122   Shall I wr ite over y our |FLAG|  File
  123   "QUES","XP F1","B")
  124   YES
  125   "QUES","XP F1","M")
  126   D XPF1^XPD IQ
  127   "QUES","XP F2",0)
  128   Y
  129   "QUES","XP F2","??")
  130   ^D DTA^XPD H
  131   "QUES","XP F2","A")
  132   Want my da ta |FLAG|  yours
  133   "QUES","XP F2","B")
  134   YES
  135   "QUES","XP F2","M")
  136   D XPF2^XPD IQ
  137   "QUES","XP I1",0)
  138   YO
  139   "QUES","XP I1","??")
  140   ^D INHIBIT ^XPDH
  141   "QUES","XP I1","A")
  142   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  143   "QUES","XP I1","B")
  144   NO
  145   "QUES","XP I1","M")
  146   D XPI1^XPD IQ
  147   "QUES","XP M1",0)
  148   PO^VA(200, :EM
  149   "QUES","XP M1","??")
  150   ^D MG^XPDH
  151   "QUES","XP M1","A")
  152   Enter the  Coordinato r for Mail  Group '|F LAG|'
  153   "QUES","XP M1","B")
  154  
  155   "QUES","XP M1","M")
  156   D XPM1^XPD IQ
  157   "QUES","XP O1",0)
  158   Y
  159   "QUES","XP O1","??")
  160   ^D MENU^XP DH
  161   "QUES","XP O1","A")
  162   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  163   "QUES","XP O1","B")
  164   NO
  165   "QUES","XP O1","M")
  166   D XPO1^XPD IQ
  167   "QUES","XP Z1",0)
  168   Y
  169   "QUES","XP Z1","??")
  170   ^D OPT^XPD H
  171   "QUES","XP Z1","A")
  172   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  173   "QUES","XP Z1","B")
  174   NO
  175   "QUES","XP Z1","M")
  176   D XPZ1^XPD IQ
  177   "QUES","XP Z2",0)
  178   Y
  179   "QUES","XP Z2","??")
  180   ^D RTN^XPD H
  181   "QUES","XP Z2","A")
  182   Want to MO VE routine s to other  CPUs
  183   "QUES","XP Z2","B")
  184   NO
  185   "QUES","XP Z2","M")
  186   D XPZ2^XPD IQ
  187   "VER")
  188   8.0^22.2
  189   **INSTALL  NAME**
  190   IB*2.0*596
  191   "BLD",1058 2,0)
  192   IB*2.0*596 ^INTEGRATE D BILLING^ 0^3171201^ y
  193   "BLD",1058 2,4,0)
  194   ^9.64PA^^
  195   "BLD",1058 2,6.3)
  196   29
  197   "BLD",1058 2,"ABPKG")
  198   n
  199   "BLD",1058 2,"KRN",0)
  200   ^9.67PA^77 9.2^20
  201   "BLD",1058 2,"KRN",.4 ,0)
  202   .4
  203   "BLD",1058 2,"KRN",.4 01,0)
  204   .401
  205   "BLD",1058 2,"KRN",.4 02,0)
  206   .402
  207   "BLD",1058 2,"KRN",.4 03,0)
  208   .403
  209   "BLD",1058 2,"KRN",.5 ,0)
  210   .5
  211   "BLD",1058 2,"KRN",.8 4,0)
  212   .84
  213   "BLD",1058 2,"KRN",3. 6,0)
  214   3.6
  215   "BLD",1058 2,"KRN",3. 8,0)
  216   3.8
  217   "BLD",1058 2,"KRN",9. 2,0)
  218   9.2
  219   "BLD",1058 2,"KRN",9. 8,0)
  220   9.8
  221   "BLD",1058 2,"KRN",9. 8,"NM",0)
  222   ^9.68A^1^1
  223   "BLD",1058 2,"KRN",9. 8,"NM",1,0 )
  224   IBCEOB4^^0 ^B25651384
  225   "BLD",1058 2,"KRN",9. 8,"NM","B" ,"IBCEOB4" ,1)
  226  
  227   "BLD",1058 2,"KRN",19 ,0)
  228   19
  229   "BLD",1058 2,"KRN",19 .1,0)
  230   19.1
  231   "BLD",1058 2,"KRN",10 1,0)
  232   101
  233   "BLD",1058 2,"KRN",40 9.61,0)
  234   409.61
  235   "BLD",1058 2,"KRN",77 1,0)
  236   771
  237   "BLD",1058 2,"KRN",77 9.2,0)
  238   779.2
  239   "BLD",1058 2,"KRN",87 0,0)
  240   870
  241   "BLD",1058 2,"KRN",89 89.51,0)
  242   8989.51
  243   "BLD",1058 2,"KRN",89 89.52,0)
  244   8989.52
  245   "BLD",1058 2,"KRN",89 94,0)
  246   8994
  247   "BLD",1058 2,"KRN","B ",.4,.4)
  248  
  249   "BLD",1058 2,"KRN","B ",.401,.40 1)
  250  
  251   "BLD",1058 2,"KRN","B ",.402,.40 2)
  252  
  253   "BLD",1058 2,"KRN","B ",.403,.40 3)
  254  
  255   "BLD",1058 2,"KRN","B ",.5,.5)
  256  
  257   "BLD",1058 2,"KRN","B ",.84,.84)
  258  
  259   "BLD",1058 2,"KRN","B ",3.6,3.6)
  260  
  261   "BLD",1058 2,"KRN","B ",3.8,3.8)
  262  
  263   "BLD",1058 2,"KRN","B ",9.2,9.2)
  264  
  265   "BLD",1058 2,"KRN","B ",9.8,9.8)
  266  
  267   "BLD",1058 2,"KRN","B ",19,19)
  268  
  269   "BLD",1058 2,"KRN","B ",19.1,19. 1)
  270  
  271   "BLD",1058 2,"KRN","B ",101,101)
  272  
  273   "BLD",1058 2,"KRN","B ",409.61,4 09.61)
  274  
  275   "BLD",1058 2,"KRN","B ",771,771)
  276  
  277   "BLD",1058 2,"KRN","B ",779.2,77 9.2)
  278  
  279   "BLD",1058 2,"KRN","B ",870,870)
  280  
  281   "BLD",1058 2,"KRN","B ",8989.51, 8989.51)
  282  
  283   "BLD",1058 2,"KRN","B ",8989.52, 8989.52)
  284  
  285   "BLD",1058 2,"KRN","B ",8994,899 4)
  286  
  287   "BLD",1058 2,"QUES",0 )
  288   ^9.62^^
  289   "BLD",1058 2,"REQB",0 )
  290   ^9.611^1^1
  291   "BLD",1058 2,"REQB",1 ,0)
  292   IB*2.0*511 ^1
  293   "BLD",1058 2,"REQB"," B","IB*2.0 *511",1)
  294  
  295   "MBREQ")
  296   1
  297   "PKG",230, -1)
  298   1^1
  299   "PKG",230, 0)
  300   INTEGRATED  BILLING^I B^INTEGRAT ED BILLING
  301   "PKG",230, 20,0)
  302   ^9.402P^1^ 1
  303   "PKG",230, 20,1,0)
  304   2^^IBAXDR
  305   "PKG",230, 20,1,1)
  306  
  307   "PKG",230, 20,"B",2,1 )
  308  
  309   "PKG",230, 22,0)
  310   ^9.49I^1^1
  311   "PKG",230, 22,1,0)
  312   2.0^294032 1^2940525
  313   "PKG",230, 22,1,"PAH" ,1,0)
  314   596^317120 1^52082464 4
  315   "QUES","XP F1",0)
  316   Y
  317   "QUES","XP F1","??")
  318   ^D REP^XPD H
  319   "QUES","XP F1","A")
  320   Shall I wr ite over y our |FLAG|  File
  321   "QUES","XP F1","B")
  322   YES
  323   "QUES","XP F1","M")
  324   D XPF1^XPD IQ
  325   "QUES","XP F2",0)
  326   Y
  327   "QUES","XP F2","??")
  328   ^D DTA^XPD H
  329   "QUES","XP F2","A")
  330   Want my da ta |FLAG|  yours
  331   "QUES","XP F2","B")
  332   YES
  333   "QUES","XP F2","M")
  334   D XPF2^XPD IQ
  335   "QUES","XP I1",0)
  336   YO
  337   "QUES","XP I1","??")
  338   ^D INHIBIT ^XPDH
  339   "QUES","XP I1","A")
  340   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  341   "QUES","XP I1","B")
  342   NO
  343   "QUES","XP I1","M")
  344   D XPI1^XPD IQ
  345   "QUES","XP M1",0)
  346   PO^VA(200, :EM
  347   "QUES","XP M1","??")
  348   ^D MG^XPDH
  349   "QUES","XP M1","A")
  350   Enter the  Coordinato r for Mail  Group '|F LAG|'
  351   "QUES","XP M1","B")
  352  
  353   "QUES","XP M1","M")
  354   D XPM1^XPD IQ
  355   "QUES","XP O1",0)
  356   Y
  357   "QUES","XP O1","??")
  358   ^D MENU^XP DH
  359   "QUES","XP O1","A")
  360   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  361   "QUES","XP O1","B")
  362   NO
  363   "QUES","XP O1","M")
  364   D XPO1^XPD IQ
  365   "QUES","XP Z1",0)
  366   Y
  367   "QUES","XP Z1","??")
  368   ^D OPT^XPD H
  369   "QUES","XP Z1","A")
  370   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  371   "QUES","XP Z1","B")
  372   NO
  373   "QUES","XP Z1","M")
  374   D XPZ1^XPD IQ
  375   "QUES","XP Z2",0)
  376   Y
  377   "QUES","XP Z2","??")
  378   ^D RTN^XPD H
  379   "QUES","XP Z2","A")
  380   Want to MO VE routine s to other  CPUs
  381   "QUES","XP Z2","B")
  382   NO
  383   "QUES","XP Z2","M")
  384   D XPZ2^XPD IQ
  385   "RTN")
  386   1
  387   "RTN","IBC EOB4")
  388   0^1^B25651 384
  389   "RTN","IBC EOB4",1,0)
  390   IBCEOB4 ;A LB/PJH - E PAYMENTS M OVE/COPY E EOB TO NEW  CLAIM ;Ju n 11, 2014 @17:45:06
  391   "RTN","IBC EOB4",2,0)
  392    ;;2.0;INT EGRATED BI LLING;**45 1,511,596* *;21-MAR-1 994;Build  29
  393   "RTN","IBC EOB4",3,0)
  394    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  395   "RTN","IBC EOB4",4,0)
  396    ;
  397   "RTN","IBC EOB4",5,0)
  398    ;Entry po int for EE OB Move
  399   "RTN","IBC EOB4",6,0)
  400   MOVE(EOBIE N,IBIFN,DU Z,MDATE,JC OM,EVENT)  ;
  401   "RTN","IBC EOB4",7,0)
  402    ;
  403   "RTN","IBC EOB4",8,0)
  404    N DA,DIC, DIE,DIK,DR ,IEN101,OB ILL,X,Y
  405   "RTN","IBC EOB4",9,0)
  406    S OBILL=$ $EXTERNAL^ DILFD(361. 1,.01,,$P( $G(^IBM(36 1.1,EOBIEN ,0)),U))
  407   "RTN","IBC EOB4",10,0 )
  408    ;
  409   "RTN","IBC EOB4",11,0 )
  410    ;Create n ew MOVE/CO PY HISTORY  stub
  411   "RTN","IBC EOB4",12,0 )
  412    S DA(1)=E OBIEN
  413   "RTN","IBC EOB4",13,0 )
  414    S DIC="^I BM(361.1," _DA(1)_",1 01,",DIC(0 )="L",X=MD ATE
  415   "RTN","IBC EOB4",14,0 )
  416    D FILE^DI CN
  417   "RTN","IBC EOB4",15,0 )
  418    S IEN101= +Y Q:'IEN1 01
  419   "RTN","IBC EOB4",16,0 )
  420    ;
  421   "RTN","IBC EOB4",17,0 )
  422    ;Update d etail on M OVE/COPY H ISTORY
  423   "RTN","IBC EOB4",18,0 )
  424    K DA,DIE, DR,X,Y
  425   "RTN","IBC EOB4",19,0 )
  426    S DIE="^I BM(361.1," _EOBIEN_", 101,",DA=I EN101
  427   "RTN","IBC EOB4",20,0 )
  428    ;Update U ser, Date/ Time, Comm ents,Move/ Copy event
  429   "RTN","IBC EOB4",21,0 )
  430    S DR=".02 ///"_DUZ_" ;.03///"_J COM_";.05/ //"_EVENT
  431   "RTN","IBC EOB4",22,0 )
  432    ;Update o riginal bi ll number
  433   "RTN","IBC EOB4",23,0 )
  434    S DR=DR_" ;.04///"_O BILL
  435   "RTN","IBC EOB4",24,0 )
  436    D ^DIE
  437   "RTN","IBC EOB4",25,0 )
  438    ;
  439   "RTN","IBC EOB4",26,0 )
  440    ;Update b ill number  on EOB
  441   "RTN","IBC EOB4",27,0 )
  442    K DA,DIE, DR,X,Y
  443   "RTN","IBC EOB4",28,0 )
  444    S DIE="^I BM(361.1," ,DA=EOBIEN ,DR=".01// /"_IBIFN
  445   "RTN","IBC EOB4",29,0 )
  446    D ^DIE
  447   "RTN","IBC EOB4",30,0 )
  448    ;
  449   "RTN","IBC EOB4",31,0 )
  450    ;Re-index  updated E OB to corr ect PAYER  NAME - IB* 2*511
  451   "RTN","IBC EOB4",32,0 )
  452    K DA S DI K="^IBM(36 1.1,",DA=E OBIEN D IX ^DIK
  453   "RTN","IBC EOB4",33,0 )
  454    ;
  455   "RTN","IBC EOB4",34,0 )
  456    ;Update a ny AR AMOU NTS DISTRI BUTION (sp lit/edit d etail)
  457   "RTN","IBC EOB4",35,0 )
  458    D FUNCTIO N(EOBIEN,O BILL,IBIFN )
  459   "RTN","IBC EOB4",36,0 )
  460    ;
  461   "RTN","IBC EOB4",37,0 )
  462    Q
  463   "RTN","IBC EOB4",38,0 )
  464    ;
  465   "RTN","IBC EOB4",39,0 )
  466    ;Entry po int for EE OB Copy
  467   "RTN","IBC EOB4",40,0 )
  468   COPY(EOBIE N,IBIFN,DU Z,MDATE,JC OM,EVENT)  ;'
  469   "RTN","IBC EOB4",41,0 )
  470    ;
  471   "RTN","IBC EOB4",42,0 )
  472    N IEN,IEN 1,OBILL,NE WEOB
  473   "RTN","IBC EOB4",43,0 )
  474    ;
  475   "RTN","IBC EOB4",44,0 )
  476    ;Original  Claim num ber
  477   "RTN","IBC EOB4",45,0 )
  478    S OBILL=$ $EXTERNAL^ DILFD(361. 1,.01,,$P( $G(^IBM(36 1.1,EOBIEN ,0)),U))
  479   "RTN","IBC EOB4",46,0 )
  480    ;
  481   "RTN","IBC EOB4",47,0 )
  482    ;Lock zer o node bef ore making  inserts
  483   "RTN","IBC EOB4",48,0 )
  484    Q:'$$LOCK (0)
  485   "RTN","IBC EOB4",49,0 )
  486    ;
  487   "RTN","IBC EOB4",50,0 )
  488    ;Scan thr ough list  of new cla ims
  489   "RTN","IBC EOB4",51,0 )
  490    S IEN=0
  491   "RTN","IBC EOB4",52,0 )
  492    F  S IEN= $O(IBIFN(I EN)) Q:'IE N  D
  493   "RTN","IBC EOB4",53,0 )
  494    .;Create  stub
  495   "RTN","IBC EOB4",54,0 )
  496    .N DA,DIC ,DIE,DIK,D LAYGO,DR,I EN1,IEN101 ,X,Y
  497   "RTN","IBC EOB4",55,0 )
  498    .S DIC(0) ="L",DIC=" ^IBM(361.1 ,",DLAYGO= 361.1
  499   "RTN","IBC EOB4",56,0 )
  500    .;Use 399  ien as .0 1 field
  501   "RTN","IBC EOB4",57,0 )
  502    .S X=IEN
  503   "RTN","IBC EOB4",58,0 )
  504    .D FILE^D ICN
  505   "RTN","IBC EOB4",59,0 )
  506    .S NEWEOB =+Y Q:'NEW EOB
  507   "RTN","IBC EOB4",60,0 )
  508    .;Lock th e new entr y
  509   "RTN","IBC EOB4",61,0 )
  510    .Q:'$$LOC K(NEWEOB)
  511   "RTN","IBC EOB4",62,0 )
  512    .;Copy de tails to n ew EOB (ex cept for a udit infor mation)
  513   "RTN","IBC EOB4",63,0 )
  514    .N ARRAY
  515   "RTN","IBC EOB4",64,0 )
  516    .M ARRAY= ^IBM(361.1 ,EOBIEN) K  ARRAY(101 )
  517   "RTN","IBC EOB4",65,0 )
  518    .M ^IBM(3 61.1,NEWEO B)=ARRAY
  519   "RTN","IBC EOB4",66,0 )
  520    .;Re-inde x new EOB
  521   "RTN","IBC EOB4",67,0 )
  522    .K DA,DIE ,DIK,DR,IE N1,IEN101, X,Y
  523   "RTN","IBC EOB4",68,0 )
  524    .S DIK="^ IBM(361.1, ",DA=NEWEO B D IX^DIK
  525   "RTN","IBC EOB4",69,0 )
  526    .;Update  .01 field  in new EOB
  527   "RTN","IBC EOB4",70,0 )
  528    .K DA,X,Y
  529   "RTN","IBC EOB4",71,0 )
  530    .S DIE="^ IBM(361.1, ",DA=NEWEO B
  531   "RTN","IBC EOB4",72,0 )
  532    .S DR=".0 1////"_IBI FN(IEN)
  533   "RTN","IBC EOB4",73,0 )
  534    .D ^DIE
  535   "RTN","IBC EOB4",74,0 )
  536    .;Re-inde x updated  EOB to cor rect PAYER  NAME - IB *2*511
  537   "RTN","IBC EOB4",75,0 )
  538    .K DA,DIK ,X,Y S DIK ="^IBM(361 .1,",DA=NE WEOB D IX^ DIK
  539   "RTN","IBC EOB4",76,0 )
  540    .;
  541   "RTN","IBC EOB4",77,0 )
  542    .;Update  any AR AMO UNTS DISTR IBUTION (s plit/edit  detail)
  543   "RTN","IBC EOB4",78,0 )
  544    .D FUNCTI ON(NEWEOB, OBILL,IBIF N(IEN))
  545   "RTN","IBC EOB4",79,0 )
  546    .;
  547   "RTN","IBC EOB4",80,0 )
  548    .;Create  stub for a udit infor mation
  549   "RTN","IBC EOB4",81,0 )
  550    .K DA,DIC ,X,Y
  551   "RTN","IBC EOB4",82,0 )
  552    .S DA(1)= NEWEOB
  553   "RTN","IBC EOB4",83,0 )
  554    .S DIC="^ IBM(361.1, "_DA(1)_", 101,",DIC( 0)="L",X=M DATE
  555   "RTN","IBC EOB4",84,0 )
  556    .D FILE^D ICN
  557   "RTN","IBC EOB4",85,0 )
  558    .S IEN101 =+Y Q:'IEN 101
  559   "RTN","IBC EOB4",86,0 )
  560    .;
  561   "RTN","IBC EOB4",87,0 )
  562    .;Update  detail on  MOVE/COPY  HISTORY
  563   "RTN","IBC EOB4",88,0 )
  564    .K DA,DIE ,DR,X,Y
  565   "RTN","IBC EOB4",89,0 )
  566    .S DIE="^ IBM(361.1, "_NEWEOB_" ,101,",DA= IEN101
  567   "RTN","IBC EOB4",90,0 )
  568    .;Update  User, Date /Time, Com ments,Even t
  569   "RTN","IBC EOB4",91,0 )
  570    .S DR=".0 2///"_DUZ_ ";.03///"_ JCOM_";.05 ///"_EVENT
  571   "RTN","IBC EOB4",92,0 )
  572    .S DR=DR_ ";.04///"_ OBILL
  573   "RTN","IBC EOB4",93,0 )
  574    .D ^DIE
  575   "RTN","IBC EOB4",94,0 )
  576    .;
  577   "RTN","IBC EOB4",95,0 )
  578    .;Insert  Other clai m numbers
  579   "RTN","IBC EOB4",96,0 )
  580    .K DIC,DL AYGO,IEN1, X,Y
  581   "RTN","IBC EOB4",97,0 )
  582    .S IEN1=" "
  583   "RTN","IBC EOB4",98,0 )
  584    .F  S IEN 1=$O(IBIFN (IEN1)) Q: 'IEN1  D
  585   "RTN","IBC EOB4",99,0 )
  586    ..;curren t claim ex cluded
  587   "RTN","IBC EOB4",100, 0)
  588    ..Q:IEN1= IEN
  589   "RTN","IBC EOB4",101, 0)
  590    ..N DA,DI C,DLAYGO,D R,X
  591   "RTN","IBC EOB4",102, 0)
  592    ..S DA(1) =IEN101,DA (2)=NEWEOB
  593   "RTN","IBC EOB4",103, 0)
  594    ..S DIC=" ^IBM(361.1 ,"_DA(2)_" ,101,"_DA( 1)_",1,"
  595   "RTN","IBC EOB4",104, 0)
  596    ..S DIC(0 )="L",X=IB IFN(IEN1)
  597   "RTN","IBC EOB4",105, 0)
  598    ..D FILE^ DICN
  599   "RTN","IBC EOB4",106, 0)
  600    .;Unlock  new entry
  601   "RTN","IBC EOB4",107, 0)
  602    .D UNLOCK (NEWEOB)
  603   "RTN","IBC EOB4",108, 0)
  604    ;
  605   "RTN","IBC EOB4",109, 0)
  606    ;Update o riginal EO B audit in formation
  607   "RTN","IBC EOB4",110, 0)
  608    N DA,DIC, DIE,DLAYGO ,DR,IEN1,I EN101,X,Y
  609   "RTN","IBC EOB4",111, 0)
  610    S DA(1)=E OBIEN
  611   "RTN","IBC EOB4",112, 0)
  612    S DIC="^I BM(361.1," _DA(1)_",1 01,",DIC(0 )="L",X=MD ATE
  613   "RTN","IBC EOB4",113, 0)
  614    D FILE^DI CN
  615   "RTN","IBC EOB4",114, 0)
  616    S IEN101= +Y Q:'IEN1 01
  617   "RTN","IBC EOB4",115, 0)
  618    ;
  619   "RTN","IBC EOB4",116, 0)
  620    ;Update U ser, Date/ Time, Comm ents,Event
  621   "RTN","IBC EOB4",117, 0)
  622    K DA,DIC, X,Y
  623   "RTN","IBC EOB4",118, 0)
  624    S DIE="^I BM(361.1," _EOBIEN_", 101,",DA=I EN101
  625   "RTN","IBC EOB4",119, 0)
  626    S DR=".02 ///"_DUZ_" ;.03///"_J COM_";.05/ //"_EVENT
  627   "RTN","IBC EOB4",120, 0)
  628    D ^DIE
  629   "RTN","IBC EOB4",121, 0)
  630    ;
  631   "RTN","IBC EOB4",122, 0)
  632    ;Insert O ther claim  numbers
  633   "RTN","IBC EOB4",123, 0)
  634    K DA,DIC, X,Y
  635   "RTN","IBC EOB4",124, 0)
  636    S IEN1=""
  637   "RTN","IBC EOB4",125, 0)
  638    F  S IEN1 =$O(IBIFN( IEN1)) Q:' IEN1  D
  639   "RTN","IBC EOB4",126, 0)
  640    .K DA,DIC ,DR,X
  641   "RTN","IBC EOB4",127, 0)
  642    .S DA(1)= IEN101,DA( 2)=EOBIEN
  643   "RTN","IBC EOB4",128, 0)
  644    .S DIC="^ IBM(361.1, "_DA(2)_", 101,"_DA(1 )_",1,"
  645   "RTN","IBC EOB4",129, 0)
  646    .S DIC(0) ="L",X=IBI FN(IEN1)
  647   "RTN","IBC EOB4",130, 0)
  648    .D FILE^D ICN
  649   "RTN","IBC EOB4",131, 0)
  650    ;
  651   "RTN","IBC EOB4",132, 0)
  652    ;Release  zero node  after inse rts
  653   "RTN","IBC EOB4",133, 0)
  654    D UNLOCK( 0)
  655   "RTN","IBC EOB4",134, 0)
  656    Q
  657   "RTN","IBC EOB4",135, 0)
  658    ;
  659   "RTN","IBC EOB4",136, 0)
  660   REMOVE(EOB IEN,DUZ,JC OM) ;Mark  EEOB as Re moved - IB *2*511
  661   "RTN","IBC EOB4",137, 0)
  662    ; Timesta mp
  663   "RTN","IBC EOB4",138, 0)
  664    N DA,DIC, DIE,DR,IEN 101,OBILL, X,Y
  665   "RTN","IBC EOB4",139, 0)
  666    S OBILL=$ $EXTERNAL^ DILFD(361. 1,.01,,$P( $G(^IBM(36 1.1,EOBIEN ,0)),U))
  667   "RTN","IBC EOB4",140, 0)
  668    ;
  669   "RTN","IBC EOB4",141, 0)
  670    ;Create n ew MOVE/CO PY HISTORY  stub for  remove act ion
  671   "RTN","IBC EOB4",142, 0)
  672    S DA(1)=E OBIEN
  673   "RTN","IBC EOB4",143, 0)
  674    S DIC="^I BM(361.1," _DA(1)_",1 01,",DIC(0 )="L",X=$$ NOW^XLFDT
  675   "RTN","IBC EOB4",144, 0)
  676    D FILE^DI CN
  677   "RTN","IBC EOB4",145, 0)
  678    S IEN101= +Y Q:'IEN1 01
  679   "RTN","IBC EOB4",146, 0)
  680    ;
  681   "RTN","IBC EOB4",147, 0)
  682    ;Update d etail on M OVE/COPY H ISTORY
  683   "RTN","IBC EOB4",148, 0)
  684    N DIE,DA, DR,X,Y
  685   "RTN","IBC EOB4",149, 0)
  686    S DIE="^I BM(361.1," _EOBIEN_", 101,",DA=I EN101
  687   "RTN","IBC EOB4",150, 0)
  688    ;Update U ser, Date/ Time, Comm ents, Orig inal Bill  and Remove  event
  689   "RTN","IBC EOB4",151, 0)
  690    S DR=".02 ///"_DUZ_" ;.03///"_J COM_";.04/ //"_OBILL_ ";.05///R"
  691   "RTN","IBC EOB4",152, 0)
  692    D ^DIE
  693   "RTN","IBC EOB4",153, 0)
  694    ;
  695   "RTN","IBC EOB4",154, 0)
  696    ;Mark EEO B as remov ed to prev ent furthe r use
  697   "RTN","IBC EOB4",155, 0)
  698    N DIE,DA, DR,X,Y
  699   "RTN","IBC EOB4",156, 0)
  700    S DIE="^I BM(361.1," ,DA=EOBIEN
  701   "RTN","IBC EOB4",157, 0)
  702    ;Update E EOB REMOVE D
  703   "RTN","IBC EOB4",158, 0)
  704    S DR="102 ///1"
  705   "RTN","IBC EOB4",159, 0)
  706    D ^DIE
  707   "RTN","IBC EOB4",160, 0)
  708    Q
  709   "RTN","IBC EOB4",161, 0)
  710    ; 
  711   "RTN","IBC EOB4",162, 0)
  712    ;Update S plit/Edit  history fo r EOB
  713   "RTN","IBC EOB4",163, 0)
  714   FUNCTION(E OBIEN,ONAM E,NEWIEN)  ;
  715   "RTN","IBC EOB4",164, 0)
  716    N DA,DIE, DR,NEWNAME ,SUB,X,Y
  717   "RTN","IBC EOB4",165, 0)
  718    ;Check fo r split/ed it history  for origi nal claim
  719   "RTN","IBC EOB4",166, 0)
  720    S SUB=$O( ^IBM(361.1 ,EOBIEN,8, "B",ONAME, "")) Q:'SU B
  721   "RTN","IBC EOB4",167, 0)
  722    ;New bill  name
  723   "RTN","IBC EOB4",168, 0)
  724    S NEWNAME =$P($G(^DG CR(399,NEW IEN,0)),U)
  725   "RTN","IBC EOB4",169, 0)
  726    ;Update b ill number  in Split/ Edit histo ry
  727   "RTN","IBC EOB4",170, 0)
  728    S DA(1)=E OBIEN,DIE= "^IBM(361. 1,"_DA(1)_ ",8,",DA=S UB
  729   "RTN","IBC EOB4",171, 0)
  730    S DR=".01 ///"_NEWNA ME_";.03// /"_NEWNAME
  731   "RTN","IBC EOB4",172, 0)
  732    D ^DIE
  733   "RTN","IBC EOB4",173, 0)
  734    Q
  735   "RTN","IBC EOB4",174, 0)
  736    ;
  737   "RTN","IBC EOB4",175, 0)
  738    ;
  739   "RTN","IBC EOB4",176, 0)
  740   LOCK(EOBIE N) ;Lock O riginal EO B
  741   "RTN","IBC EOB4",177, 0)
  742    L +^IBM(3 61.1,EOBIE N):5 I  Q  1
  743   "RTN","IBC EOB4",178, 0)
  744    W !,"EOB  in use by  another us er, try la ter"
  745   "RTN","IBC EOB4",179, 0)
  746    Q 0
  747   "RTN","IBC EOB4",180, 0)
  748    ;
  749   "RTN","IBC EOB4",181, 0)
  750   UNLOCK(EOB IEN) ;Rele ase EOB
  751   "RTN","IBC EOB4",182, 0)
  752    L -^IBM(3 61.1,EOBIE N)
  753   "RTN","IBC EOB4",183, 0)
  754    Q
  755   "RTN","IBC EOB4",184, 0)
  756    ;
  757   "RTN","IBC EOB4",185, 0)
  758    ; BEGIN I B*2.0*596
  759   "RTN","IBC EOB4",186, 0)
  760   RESTORE(EO BIEN) ;EP  - RCDPEM5
  761   "RTN","IBC EOB4",187, 0)
  762    ; Clear E EOB REMOVE D flag fro m previous ly suspens ed EEOB
  763   "RTN","IBC EOB4",188, 0)
  764    ; INPUT -  EEOBIEN -  #361.1 IE
  765   "RTN","IBC EOB4",189, 0)
  766    ;
  767   "RTN","IBC EOB4",190, 0)
  768    Q:'EOBIEN
  769   "RTN","IBC EOB4",191, 0)
  770    ;
  771   "RTN","IBC EOB4",192, 0)
  772    N DIE,DA, DR,X,Y
  773   "RTN","IBC EOB4",193, 0)
  774    S DIE="^I BM(361.1," ,DA=EOBIEN
  775   "RTN","IBC EOB4",194, 0)
  776    ;Update E EOB REMOVE D
  777   "RTN","IBC EOB4",195, 0)
  778    S DR="102 ///@"
  779   "RTN","IBC EOB4",196, 0)
  780    D ^DIE
  781   "RTN","IBC EOB4",197, 0)
  782    Q
  783   "RTN","IBC EOB4",198, 0)
  784    ; END IB* 2.0*596
  785   "VER")
  786   8.0^22.2
  787   **INSTALL  NAME**
  788   PRCA*4.5*3 21
  789   "BLD",1055 2,0)
  790   PRCA*4.5*3 21^ACCOUNT S RECEIVAB LE^0^31712 01^y
  791   "BLD",1055 2,4,0)
  792   ^9.64PA^34 4.61^7
  793   "BLD",1055 2,4,342,0)
  794   342
  795   "BLD",1055 2,4,342,2, 0)
  796   ^9.641^342 ^1
  797   "BLD",1055 2,4,342,2, 342,0)
  798   AR SITE PA RAMETER  ( File-top l evel)
  799   "BLD",1055 2,4,342,2, 342,1,0)
  800   ^9.6411^7. 08^2
  801   "BLD",1055 2,4,342,2, 342,1,7.07 ,0)
  802   AUTO-AUDIT  MEDICAL E DI BILLS
  803   "BLD",1055 2,4,342,2, 342,1,7.08 ,0)
  804   AUTO-AUDIT  RX EDI BI LLS
  805   "BLD",1055 2,4,342,22 2)
  806   y^y^p^^^^n ^^n
  807   "BLD",1055 2,4,342,22 4)
  808  
  809   "BLD",1055 2,4,344,0)
  810   344
  811   "BLD",1055 2,4,344,2, 0)
  812   ^9.641^344 ^2
  813   "BLD",1055 2,4,344,2, 344,0)
  814   AR BATCH P AYMENT  (F ile-top le vel)
  815   "BLD",1055 2,4,344,2, 344,1,0)
  816   ^9.6411^.0 3^1
  817   "BLD",1055 2,4,344,2, 344,1,.03, 0)
  818   DATE OPENE D
  819   "BLD",1055 2,4,344,2, 344.01,0)
  820   TRANSACTIO N  (sub-fi le)
  821   "BLD",1055 2,4,344,2, 344.01,1,0 )
  822   ^9.6411^.0 9^1
  823   "BLD",1055 2,4,344,2, 344.01,1,. 09,0)
  824   PATIENT NA ME OR BILL  NUMBER
  825   "BLD",1055 2,4,344,22 2)
  826   y^y^p^^^^n ^^n
  827   "BLD",1055 2,4,344,22 4)
  828  
  829   "BLD",1055 2,4,344.31 ,0)
  830   344.31
  831   "BLD",1055 2,4,344.31 ,2,0)
  832   ^9.641^344 .31^1
  833   "BLD",1055 2,4,344.31 ,2,344.31, 0)
  834   EDI THIRD  PARTY EFT  DETAIL  (F ile-top le vel)
  835   "BLD",1055 2,4,344.31 ,2,344.31, 1,0)
  836   ^9.6411^3^ 1
  837   "BLD",1055 2,4,344.31 ,2,344.31, 1,3,0)
  838   DEBIT/CRED IT FLAG
  839   "BLD",1055 2,4,344.31 ,222)
  840   y^y^p^^^^n ^^n
  841   "BLD",1055 2,4,344.31 ,224)
  842  
  843   "BLD",1055 2,4,344.49 ,0)
  844   344.49
  845   "BLD",1055 2,4,344.49 ,2,0)
  846   ^9.641^344 .491^1
  847   "BLD",1055 2,4,344.49 ,2,344.491 ,0)
  848   SEQUENCE #   (sub-fil e)
  849   "BLD",1055 2,4,344.49 ,2,344.491 ,1,0)
  850   ^9.6411^.1 ^1
  851   "BLD",1055 2,4,344.49 ,2,344.491 ,1,.1,0)
  852   RECEIPT LI NE COMMENT
  853   "BLD",1055 2,4,344.49 ,222)
  854   y^y^p^^^^n ^^n
  855   "BLD",1055 2,4,344.49 ,224)
  856  
  857   "BLD",1055 2,4,344.6, 0)
  858   344.6
  859   "BLD",1055 2,4,344.6, 2,0)
  860   ^9.641^344 .6^1
  861   "BLD",1055 2,4,344.6, 2,344.6,0)
  862   RCDPE AUTO -PAY EXCLU SION  (Fil e-top leve l)
  863   "BLD",1055 2,4,344.6, 2,344.6,1, 0)
  864   ^9.6411^.1 ^3
  865   "BLD",1055 2,4,344.6, 2,344.6,1, .01,0)
  866   PAYER NAME
  867   "BLD",1055 2,4,344.6, 2,344.6,1, .09,0)
  868   PHARMACY P AYER
  869   "BLD",1055 2,4,344.6, 2,344.6,1, .1,0)
  870   TRICARE PA YER
  871   "BLD",1055 2,4,344.6, 222)
  872   y^y^p^^^^n ^^n
  873   "BLD",1055 2,4,344.6, 224)
  874  
  875   "BLD",1055 2,4,344.61 ,0)
  876   344.61
  877   "BLD",1055 2,4,344.61 ,2,0)
  878   ^9.641^344 .61^1
  879   "BLD",1055 2,4,344.61 ,2,344.61, 0)
  880   RCDPE PARA METER  (Fi le-top lev el)
  881   "BLD",1055 2,4,344.61 ,2,344.61, 1,0)
  882   ^9.6411^.0 7^3
  883   "BLD",1055 2,4,344.61 ,2,344.61, 1,.06,0)
  884   MEDICAL EF T POST PRE VENT DAYS
  885   "BLD",1055 2,4,344.61 ,2,344.61, 1,.07,0)
  886   PHARMACY E FT POST PR EVENT DAYS
  887   "BLD",1055 2,4,344.61 ,2,344.61, 1,.1,0)
  888   DAY FOR WO RKLOAD NOT IFICATIONS
  889   "BLD",1055 2,4,344.61 ,222)
  890   y^y^p^^^^n ^^n
  891   "BLD",1055 2,4,344.61 ,224)
  892  
  893   "BLD",1055 2,4,344.73 ,0)
  894   344.73
  895   "BLD",1055 2,4,344.73 ,222)
  896   y^y^f^^^^n
  897   "BLD",1055 2,4,"APDD" ,342,342)
  898  
  899   "BLD",1055 2,4,"APDD" ,342,342,7 .07)
  900  
  901   "BLD",1055 2,4,"APDD" ,342,342,7 .08)
  902  
  903   "BLD",1055 2,4,"APDD" ,344,344)
  904  
  905   "BLD",1055 2,4,"APDD" ,344,344,. 03)
  906  
  907   "BLD",1055 2,4,"APDD" ,344,344.0 1)
  908  
  909   "BLD",1055 2,4,"APDD" ,344,344.0 1,.09)
  910  
  911   "BLD",1055 2,4,"APDD" ,344.31,34 4.31)
  912  
  913   "BLD",1055 2,4,"APDD" ,344.31,34 4.31,3)
  914  
  915   "BLD",1055 2,4,"APDD" ,344.49,34 4.491)
  916  
  917   "BLD",1055 2,4,"APDD" ,344.49,34 4.491,.1)
  918  
  919   "BLD",1055 2,4,"APDD" ,344.6,344 .6)
  920  
  921   "BLD",1055 2,4,"APDD" ,344.6,344 .6,.01)
  922  
  923   "BLD",1055 2,4,"APDD" ,344.6,344 .6,.09)
  924  
  925   "BLD",1055 2,4,"APDD" ,344.6,344 .6,.1)
  926  
  927   "BLD",1055 2,4,"APDD" ,344.61,34 4.61)
  928  
  929   "BLD",1055 2,4,"APDD" ,344.61,34 4.61,.06)
  930  
  931   "BLD",1055 2,4,"APDD" ,344.61,34 4.61,.07)
  932  
  933   "BLD",1055 2,4,"APDD" ,344.61,34 4.61,.1)
  934  
  935   "BLD",1055 2,4,"B",34 2,342)
  936  
  937   "BLD",1055 2,4,"B",34 4,344)
  938  
  939   "BLD",1055 2,4,"B",34 4.31,344.3 1)
  940  
  941   "BLD",1055 2,4,"B",34 4.49,344.4 9)
  942  
  943   "BLD",1055 2,4,"B",34 4.6,344.6)
  944  
  945   "BLD",1055 2,4,"B",34 4.61,344.6 1)
  946  
  947   "BLD",1055 2,4,"B",34 4.73,344.7 3)
  948  
  949   "BLD",1055 2,6.3)
  950   46
  951   "BLD",1055 2,"INIT")
  952   POST^RCP32 1
  953   "BLD",1055 2,"KRN",0)
  954   ^9.67PA^77 9.2^20
  955   "BLD",1055 2,"KRN",.4 ,0)
  956   .4
  957   "BLD",1055 2,"KRN",.4 01,0)
  958   .401
  959   "BLD",1055 2,"KRN",.4 02,0)
  960   .402
  961   "BLD",1055 2,"KRN",.4 03,0)
  962   .403
  963   "BLD",1055 2,"KRN",.5 ,0)
  964   .5
  965   "BLD",1055 2,"KRN",.8 4,0)
  966   .84
  967   "BLD",1055 2,"KRN",3. 6,0)
  968   3.6
  969   "BLD",1055 2,"KRN",3. 8,0)
  970   3.8
  971   "BLD",1055 2,"KRN",3. 8,"NM",0)
  972   ^9.68A^1^1
  973   "BLD",1055 2,"KRN",3. 8,"NM",1,0 )
  974   RCDPE AUDI T^^0
  975   "BLD",1055 2,"KRN",3. 8,"NM","B" ,"RCDPE AU DIT",1)
  976  
  977   "BLD",1055 2,"KRN",9. 2,0)
  978   9.2
  979   "BLD",1055 2,"KRN",9. 2,"NM",0)
  980   ^9.68A^1^1
  981   "BLD",1055 2,"KRN",9. 2,"NM",1,0 )
  982   RCDPE PAYE R FLAGS GE NERAL^^0
  983   "BLD",1055 2,"KRN",9. 2,"NM","B" ,"RCDPE PA YER FLAGS  GENERAL",1 )
  984  
  985   "BLD",1055 2,"KRN",9. 8,0)
  986   9.8
  987   "BLD",1055 2,"KRN",9. 8,"NM",0)
  988   ^9.68A^69^ 64
  989   "BLD",1055 2,"KRN",9. 8,"NM",1,0 )
  990   RCDPECH^^0 ^B9924260
  991   "BLD",1055 2,"KRN",9. 8,"NM",3,0 )
  992   RCDPEDAR^^ 0^B8198747 7
  993   "BLD",1055 2,"KRN",9. 8,"NM",4,0 )
  994   RCDPEDA2^^ 0^B1424989 17
  995   "BLD",1055 2,"KRN",9. 8,"NM",5,0 )
  996   RCDPEDA3^^ 0^B1133928 51
  997   "BLD",1055 2,"KRN",9. 8,"NM",7,0 )
  998   RCDPEWL3^^ 0^B8845199 7
  999   "BLD",1055 2,"KRN",9. 8,"NM",8,0 )
  1000   RCDPEWL1^^ 0^B7844249 4
  1001   "BLD",1055 2,"KRN",9. 8,"NM",9,0 )
  1002   RCDPEAA2^^ 0^B1223125 25
  1003   "BLD",1055 2,"KRN",9. 8,"NM",10, 0)
  1004   RCDPE215^^ 0^B8976423 5
  1005   "BLD",1055 2,"KRN",9. 8,"NM",11, 0)
  1006   RCDPR215^^ 0^B4478762 5
  1007   "BLD",1055 2,"KRN",9. 8,"NM",12, 0)
  1008   RCDPLPL1^^ 0^B3661740 9
  1009   "BLD",1055 2,"KRN",9. 8,"NM",13, 0)
  1010   RCDPLPL4^^ 0^B2399902 72
  1011   "BLD",1055 2,"KRN",9. 8,"NM",14, 0)
  1012   RCDPUT^^0^ B27245872
  1013   "BLD",1055 2,"KRN",9. 8,"NM",15, 0)
  1014   RCDPEDA4^^ 0^B3684111 0
  1015   "BLD",1055 2,"KRN",9. 8,"NM",16, 0)
  1016   RCDPESR3^^ 0^B5532052 8
  1017   "BLD",1055 2,"KRN",9. 8,"NM",17, 0)
  1018   RCDPEM^^0^ B74838117
  1019   "BLD",1055 2,"KRN",9. 8,"NM",18, 0)
  1020   RCDPEM1^^0 ^B45189971
  1021   "BLD",1055 2,"KRN",9. 8,"NM",19, 0)
  1022   RCDPTAR^^0 ^B19475825 8
  1023   "BLD",1055 2,"KRN",9. 8,"NM",20, 0)
  1024   RCDPEMA^^0 ^B29986515
  1025   "BLD",1055 2,"KRN",9. 8,"NM",21, 0)
  1026   RCDPEM5^^0 ^B15447332 4
  1027   "BLD",1055 2,"KRN",9. 8,"NM",22, 0)
  1028   RCDPUREC^^ 0^B1463544 31
  1029   "BLD",1055 2,"KRN",9. 8,"NM",23, 0)
  1030   RCDPEM4^^0 ^B22800655 8
  1031   "BLD",1055 2,"KRN",9. 8,"NM",24, 0)
  1032   RCDPEARL^^ 0^B3793055 7
  1033   "BLD",1055 2,"KRN",9. 8,"NM",25, 0)
  1034   RCP321^^0^ B27251682
  1035   "BLD",1055 2,"KRN",9. 8,"NM",26, 0)
  1036   RCDPEAR1^^ 0^B2073949 84
  1037   "BLD",1055 2,"KRN",9. 8,"NM",27, 0)
  1038   RCDPEAR2^^ 0^B1115295 01
  1039   "BLD",1055 2,"KRN",9. 8,"NM",28, 0)
  1040   RCDPEAR3^^ 0^B4337332
  1041   "BLD",1055 2,"KRN",9. 8,"NM",29, 0)
  1042   RCDPENR2^^ 0^B2577195 05
  1043   "BLD",1055 2,"KRN",9. 8,"NM",30, 0)
  1044   RCDPPLB^^0 ^B19718206 0
  1045   "BLD",1055 2,"KRN",9. 8,"NM",31, 0)
  1046   RCDPRU^^0^ B191218781
  1047   "BLD",1055 2,"KRN",9. 8,"NM",32, 0)
  1048   RCDPRU2^^0 ^B21266563
  1049   "BLD",1055 2,"KRN",9. 8,"NM",33, 0)
  1050   RCDPURE1^^ 0^B7313325 9
  1051   "BLD",1055 2,"KRN",9. 8,"NM",34, 0)
  1052   RCDPENR3^^ 0^B1984554 58
  1053   "BLD",1055 2,"KRN",9. 8,"NM",35, 0)
  1054   RCDPENR4^^ 0^B6959856 6
  1055   "BLD",1055 2,"KRN",9. 8,"NM",36, 0)
  1056   RCDPLPL3^^ 0^B5976151 7
  1057   "BLD",1055 2,"KRN",9. 8,"NM",37, 0)
  1058   RCDPRPL1^^ 0^B3385760 5
  1059   "BLD",1055 2,"KRN",9. 8,"NM",38, 0)
  1060   RCDPURED^^ 0^B7439178 2
  1061   "BLD",1055 2,"KRN",9. 8,"NM",39, 0)
  1062   RCDPELAR^^ 0^B1266152 93
  1063   "BLD",1055 2,"KRN",9. 8,"NM",40, 0)
  1064   RCDPRPLM^^ 0^B9136788 4
  1065   "BLD",1055 2,"KRN",9. 8,"NM",41, 0)
  1066   RCDPESR6^^ 0^B4702623 8
  1067   "BLD",1055 2,"KRN",9. 8,"NM",42, 0)
  1068   RCDPEX3^^0 ^B76582678
  1069   "BLD",1055 2,"KRN",9. 8,"NM",43, 0)
  1070   RCDPEX31^^ 0^B4206033 7
  1071   "BLD",1055 2,"KRN",9. 8,"NM",44, 0)
  1072   RCDPEAA1^^ 0^B1623484 83
  1073   "BLD",1055 2,"KRN",9. 8,"NM",45, 0)
  1074   RCDPEAA4^^ 0^B5175417 6
  1075   "BLD",1055 2,"KRN",9. 8,"NM",46, 0)
  1076   RCDPESR2^^ 0^B9123370 3
  1077   "BLD",1055 2,"KRN",9. 8,"NM",47, 0)
  1078   RCDPESR4^^ 0^B8570940 7
  1079   "BLD",1055 2,"KRN",9. 8,"NM",48, 0)
  1080   RCDPEAP^^0 ^B22832139 4
  1081   "BLD",1055 2,"KRN",9. 8,"NM",49, 0)
  1082   RCDPEAP1^^ 0^B1056844 43
  1083   "BLD",1055 2,"KRN",9. 8,"NM",50, 0)
  1084   RCDPEM2^^0 ^B24727684 3
  1085   "BLD",1055 2,"KRN",9. 8,"NM",51, 0)
  1086   RCDPEWL8^^ 0^B1027691 03
  1087   "BLD",1055 2,"KRN",9. 8,"NM",52, 0)
  1088   RCDPEX32^^ 0^B5517477 0
  1089   "BLD",1055 2,"KRN",9. 8,"NM",54, 0)
  1090   PRCABJ2^^0 ^B14780114
  1091   "BLD",1055 2,"KRN",9. 8,"NM",55, 0)
  1092   RCDPESP^^0 ^B16633548 0
  1093   "BLD",1055 2,"KRN",9. 8,"NM",56, 0)
  1094   RCDPESP5^^ 0^B1478325 56
  1095   "BLD",1055 2,"KRN",9. 8,"NM",57, 0)
  1096   RCDPEP^^0^ B147639796
  1097   "BLD",1055 2,"KRN",9. 8,"NM",58, 0)
  1098   RCDPESP2^^ 0^B1767145 45
  1099   "BLD",1055 2,"KRN",9. 8,"NM",59, 0)
  1100   RCDPRLIS^^ 0^B1284059 94
  1101   "BLD",1055 2,"KRN",9. 8,"NM",60, 0)
  1102   RCDPRL^^0^ B2015972
  1103   "BLD",1055 2,"KRN",9. 8,"NM",61, 0)
  1104   PRCAUDT^^0 ^B53225243
  1105   "BLD",1055 2,"KRN",9. 8,"NM",64, 0)
  1106   RCDPEM7^^0 ^B14728980 0
  1107   "BLD",1055 2,"KRN",9. 8,"NM",65, 0)
  1108   RCDPEWL0^^ 0^B2424112 11
  1109   "BLD",1055 2,"KRN",9. 8,"NM",66, 0)
  1110   RCDPEWL7^^ 0^B1239919 07
  1111   "BLD",1055 2,"KRN",9. 8,"NM",67, 0)
  1112   RCDPEWLD^^ 0^B1013213 13
  1113   "BLD",1055 2,"KRN",9. 8,"NM",68, 0)
  1114   RCDPESP1^^ 0^B1060874 51
  1115   "BLD",1055 2,"KRN",9. 8,"NM",69, 0)
  1116   RCDPARC^^0 ^B23830471 9
  1117   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"PRCABJ2" ,54)
  1118  
  1119   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"PRCAUDT" ,61)
  1120  
  1121   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPARC" ,69)
  1122  
  1123   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPE215 ",10)
  1124  
  1125   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAA1 ",44)
  1126  
  1127   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAA2 ",9)
  1128  
  1129   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAA4 ",45)
  1130  
  1131   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAP" ,48)
  1132  
  1133   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAP1 ",49)
  1134  
  1135   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAR1 ",26)
  1136  
  1137   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAR2 ",27)
  1138  
  1139   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEAR3 ",28)
  1140  
  1141   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEARL ",24)
  1142  
  1143   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPECH" ,1)
  1144  
  1145   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEDA2 ",4)
  1146  
  1147   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEDA3 ",5)
  1148  
  1149   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEDA4 ",15)
  1150  
  1151   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEDAR ",3)
  1152  
  1153   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPELAR ",39)
  1154  
  1155   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEM", 17)
  1156  
  1157   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEM1" ,18)
  1158  
  1159   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEM2" ,50)
  1160  
  1161   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEM4" ,23)
  1162  
  1163   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEM5" ,21)
  1164  
  1165   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEM7" ,64)
  1166  
  1167   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEMA" ,20)
  1168  
  1169   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPENR2 ",29)
  1170  
  1171   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPENR3 ",34)
  1172  
  1173   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPENR4 ",35)
  1174  
  1175   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEP", 57)
  1176  
  1177   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESP" ,55)
  1178  
  1179   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESP1 ",68)
  1180  
  1181   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESP2 ",58)
  1182  
  1183   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESP5 ",56)
  1184  
  1185   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESR2 ",46)
  1186  
  1187   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESR3 ",16)
  1188  
  1189   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESR4 ",47)
  1190  
  1191   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPESR6 ",41)
  1192  
  1193   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEWL0 ",65)
  1194  
  1195   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEWL1 ",8)
  1196  
  1197   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEWL3 ",7)
  1198  
  1199   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEWL7 ",66)
  1200  
  1201   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEWL8 ",51)
  1202  
  1203   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEWLD ",67)
  1204  
  1205   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEX3" ,42)
  1206  
  1207   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEX31 ",43)
  1208  
  1209   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPEX32 ",52)
  1210  
  1211   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPLPL1 ",12)
  1212  
  1213   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPLPL3 ",36)
  1214  
  1215   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPLPL4 ",13)
  1216  
  1217   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPPLB" ,30)
  1218  
  1219   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPR215 ",11)
  1220  
  1221   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPRL", 60)
  1222  
  1223   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPRLIS ",59)
  1224  
  1225   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPRPL1 ",37)
  1226  
  1227   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPRPLM ",40)
  1228  
  1229   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPRU", 31)
  1230  
  1231   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPRU2" ,32)
  1232  
  1233   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPTAR" ,19)
  1234  
  1235   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPURE1 ",33)
  1236  
  1237   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPUREC ",22)
  1238  
  1239   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPURED ",38)
  1240  
  1241   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCDPUT", 14)
  1242  
  1243   "BLD",1055 2,"KRN",9. 8,"NM","B" ,"RCP321", 25)
  1244  
  1245   "BLD",1055 2,"KRN",19 ,0)
  1246   19
  1247   "BLD",1055 2,"KRN",19 ,"NM",0)
  1248   ^9.68A^37^ 37
  1249   "BLD",1055 2,"KRN",19 ,"NM",1,0)
  1250   RCDPE EEOB  MOVE/COPY /RMOVE RPT ^^0
  1251   "BLD",1055 2,"KRN",19 ,"NM",2,0)
  1252   RCDPE EDI  LOCKBOX ME NU^^0
  1253   "BLD",1055 2,"KRN",19 ,"NM",3,0)
  1254   RCDPE EDI  LOCKBOX WO RKLIST^^4^
  1255   "BLD",1055 2,"KRN",19 ,"NM",4,0)
  1256   RCDPE EXCE PTION PROC ESSING^^4^
  1257   "BLD",1055 2,"KRN",19 ,"NM",5,0)
  1258   RCDPE MATC H EFT TO E RA^^4^
  1259   "BLD",1055 2,"KRN",19 ,"NM",6,0)
  1260   RCDPE MANU AL MATCH E FT-ERA^^4^
  1261   "BLD",1055 2,"KRN",19 ,"NM",7,0)
  1262   RCDPE MARK  0-BAL EFT  MATCHED^^ 4^
  1263   "BLD",1055 2,"KRN",19 ,"NM",8,0)
  1264   RCDPE ERA  POSTED BY  PAPER EOB^ ^4^
  1265   "BLD",1055 2,"KRN",19 ,"NM",9,0)
  1266   RCDPE UNMA TCH ERA^^4 ^
  1267   "BLD",1055 2,"KRN",19 ,"NM",10,0 )
  1268   RCDPE REMO VE ERA FRO M WORKLIST ^^4^
  1269   "BLD",1055 2,"KRN",19 ,"NM",11,0 )
  1270   RCDPE EEOB  MOVE/COPY /REMOVE^^4 ^
  1271   "BLD",1055 2,"KRN",19 ,"NM",12,0 )
  1272   RCDPE REMO VE DUP DEP OSITS^^4^
  1273   "BLD",1055 2,"KRN",19 ,"NM",13,0 )
  1274   RCDPE UNPO STED EFT O VERRIDE^^4 ^
  1275   "BLD",1055 2,"KRN",19 ,"NM",14,0 )
  1276   RCDPE APAR ^^4^
  1277   "BLD",1055 2,"KRN",19 ,"NM",15,0 )
  1278   RCDPE EDI  LOCKBOX RE PORTS MENU ^^0^
  1279   "BLD",1055 2,"KRN",19 ,"NM",16,0 )
  1280   RCDPE PAYE R IDENTIFY ^^0
  1281   "BLD",1055 2,"KRN",19 ,"NM",17,0 )
  1282   RCDPE EDI  LOCKBOX AC T REPORT^^ 4^
  1283   "BLD",1055 2,"KRN",19 ,"NM",18,0 )
  1284   RCDPE EFT  AGING REPO RT^^4^
  1285   "BLD",1055 2,"KRN",19 ,"NM",19,0 )
  1286   RCDPE ERA  AGING REPO RT^^4^
  1287   "BLD",1055 2,"KRN",19 ,"NM",20,0 )
  1288   RCDPE VIEW /PRINT ERA ^^4^
  1289   "BLD",1055 2,"KRN",19 ,"NM",21,0 )
  1290   RCDPE ACTI VE WITH EE OB REPORT^ ^4^
  1291   "BLD",1055 2,"KRN",19 ,"NM",22,0 )
  1292   RCDPE REMO VED ERA AU DIT^^4^
  1293   "BLD",1055 2,"KRN",19 ,"NM",23,0 )
  1294   RCDPE ERA  W/PAPER EO B REPORT^^ 4^
  1295   "BLD",1055 2,"KRN",19 ,"NM",24,0 )
  1296   RCDPE EFT  AUDIT REPO RT^^4^
  1297   "BLD",1055 2,"KRN",19 ,"NM",25,0 )
  1298   RCDPE AUTO -POST REPO RT^^4^
  1299   "BLD",1055 2,"KRN",19 ,"NM",26,0 )
  1300   RCDPE AUTO -DECREASE  REPORT^^4^
  1301   "BLD",1055 2,"KRN",19 ,"NM",27,0 )
  1302   RCDPE PAYE R EXCLUSIO N NAME TIN ^^4^
  1303   "BLD",1055 2,"KRN",19 ,"NM",28,0 )
  1304   RCDPE CARC /RARC TABL E REPORT^^ 4^
  1305   "BLD",1055 2,"KRN",19 ,"NM",29,0 )
  1306   RCDPE PROV IDER LVL A DJ REPORT^ ^4^
  1307   "BLD",1055 2,"KRN",19 ,"NM",30,0 )
  1308   RCDPE EFT  TRANSACTIO N AUD REP^ ^4^
  1309   "BLD",1055 2,"KRN",19 ,"NM",31,0 )
  1310   RCDPE CARC  CODE PAYE R REPORT^^ 4^
  1311   "BLD",1055 2,"KRN",19 ,"NM",32,0 )
  1312   RCDPE ERA  STATUS CHN G AUD REP^ ^4^
  1313   "BLD",1055 2,"KRN",19 ,"NM",33,0 )
  1314   RCDPE UNAP PLIED EFT  DEP REPORT ^^4^
  1315   "BLD",1055 2,"KRN",19 ,"NM",34,0 )
  1316   RCDPE AUTO -POST RECE IPT REPORT ^^4^
  1317   "BLD",1055 2,"KRN",19 ,"NM",35,0 )
  1318   RCDPE EFT- ERA TRENDI NG REPORT^ ^4^
  1319   "BLD",1055 2,"KRN",19 ,"NM",36,0 )
  1320   RCDPE CARC /RARC QUIC K SEARCH^^ 4^
  1321   "BLD",1055 2,"KRN",19 ,"NM",37,0 )
  1322   RCDPE MOVE  ERA TO SU SPENSE^^0
  1323   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE ACT IVE WITH E EOB REPORT ",21)
  1324  
  1325   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE APA R",14)
  1326  
  1327   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE AUT O-DECREASE  REPORT",2 6)
  1328  
  1329   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE AUT O-POST REC EIPT REPOR T",34)
  1330  
  1331   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE AUT O-POST REP ORT",25)
  1332  
  1333   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE CAR C CODE PAY ER REPORT" ,31)
  1334  
  1335   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE CAR C/RARC QUI CK SEARCH" ,36)
  1336  
  1337   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE CAR C/RARC TAB LE REPORT" ,28)
  1338  
  1339   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EDI  LOCKBOX A CT REPORT" ,17)
  1340  
  1341   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EDI  LOCKBOX M ENU",2)
  1342  
  1343   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EDI  LOCKBOX R EPORTS MEN U",15)
  1344  
  1345   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EDI  LOCKBOX W ORKLIST",3 )
  1346  
  1347   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EEO B MOVE/COP Y/REMOVE", 11)
  1348  
  1349   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EEO B MOVE/COP Y/RMOVE RP T",1)
  1350  
  1351   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EFT  AGING REP ORT",18)
  1352  
  1353   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EFT  AUDIT REP ORT",24)
  1354  
  1355   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EFT  TRANSACTI ON AUD REP ",30)
  1356  
  1357   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EFT -ERA TREND ING REPORT ",35)
  1358  
  1359   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE ERA  AGING REP ORT",19)
  1360  
  1361   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE ERA  POSTED BY  PAPER EOB ",8)
  1362  
  1363   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE ERA  STATUS CH NG AUD REP ",32)
  1364  
  1365   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE ERA  W/PAPER E OB REPORT" ,23)
  1366  
  1367   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE EXC EPTION PRO CESSING",4 )
  1368  
  1369   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE MAN UAL MATCH  EFT-ERA",6 )
  1370  
  1371   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE MAR K 0-BAL EF T MATCHED" ,7)
  1372  
  1373   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE MAT CH EFT TO  ERA",5)
  1374  
  1375   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE MOV E ERA TO S USPENSE",3 7)
  1376  
  1377   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE PAY ER EXCLUSI ON NAME TI N",27)
  1378  
  1379   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE PAY ER IDENTIF Y",16)
  1380  
  1381   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE PRO VIDER LVL  ADJ REPORT ",29)
  1382  
  1383   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE REM OVE DUP DE POSITS",12 )
  1384  
  1385   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE REM OVE ERA FR OM WORKLIS T",10)
  1386  
  1387   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE REM OVED ERA A UDIT",22)
  1388  
  1389   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE UNA PPLIED EFT  DEP REPOR T",33)
  1390  
  1391   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE UNM ATCH ERA", 9)
  1392  
  1393   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE UNP OSTED EFT  OVERRIDE", 13)
  1394  
  1395   "BLD",1055 2,"KRN",19 ,"NM","B", "RCDPE VIE W/PRINT ER A",20)
  1396  
  1397   "BLD",1055 2,"KRN",19 .1,0)
  1398   19.1
  1399   "BLD",1055 2,"KRN",19 .1,"NM",0)
  1400   ^9.68A^^0
  1401   "BLD",1055 2,"KRN",10 1,0)
  1402   101
  1403   "BLD",1055 2,"KRN",10 1,"NM",0)
  1404   ^9.68A^19^ 18
  1405   "BLD",1055 2,"KRN",10 1,"NM",1,0 )
  1406   RCDPE APAR  SELECTED  EEOB MENU^ ^0
  1407   "BLD",1055 2,"KRN",10 1,"NM",2,0 )
  1408   VALM QUIT^ ^4^
  1409   "BLD",1055 2,"KRN",10 1,"NM",3,0 )
  1410   RCDPE APAR  VIEW/PRIN T ERA^^4^
  1411   "BLD",1055 2,"KRN",10 1,"NM",4,0 )
  1412   RCDPE APAR  SPLIT LIN E^^4^
  1413   "BLD",1055 2,"KRN",10 1,"NM",5,0 )
  1414   RCDPE APAR  RESEARCH^ ^4^
  1415   "BLD",1055 2,"KRN",10 1,"NM",6,0 )
  1416   RCDPE APAR  EEOB REVI EW^^4^
  1417   "BLD",1055 2,"KRN",10 1,"NM",7,0 )
  1418   RCDPE APAR  VIEW/PRIN T EOB^^4^
  1419   "BLD",1055 2,"KRN",10 1,"NM",8,0 )
  1420   RCDPE APAR  VERIFY^^4 ^
  1421   "BLD",1055 2,"KRN",10 1,"NM",9,0 )
  1422   VALM BLANK  1^^4^
  1423   "BLD",1055 2,"KRN",10 1,"NM",10, 0)
  1424   RCDPE APAR  CLAIM COM MENT^^4^
  1425   "BLD",1055 2,"KRN",10 1,"NM",11, 0)
  1426   RCDPE MARK  FOR AUTOP OST^^4^
  1427   "BLD",1055 2,"KRN",10 1,"NM",12, 0)
  1428   RCDPE PAYE R FLAGS ME NU^^0
  1429   "BLD",1055 2,"KRN",10 1,"NM",13, 0)
  1430   RCDPE PAYE R FLAGS ED IT^^0
  1431   "BLD",1055 2,"KRN",10 1,"NM",14, 0)
  1432   RCDPE PAYE R FLAGS FI LTER^^0
  1433   "BLD",1055 2,"KRN",10 1,"NM",15, 0)
  1434   RCDPE PAYE R FLAG PHA RM^^0
  1435   "BLD",1055 2,"KRN",10 1,"NM",16, 0)
  1436   RCDPE PAYE R FLAG TRI C^^0
  1437   "BLD",1055 2,"KRN",10 1,"NM",18, 0)
  1438   RCDP LIST  OF RECEIPT S MENU^^0
  1439   "BLD",1055 2,"KRN",10 1,"NM",19, 0)
  1440   RCDP LIST  OF RECEIPT S PROCESS^ ^0
  1441   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDP LIS T OF RECEI PTS MENU", 18)
  1442  
  1443   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDP LIS T OF RECEI PTS PROCES S",19)
  1444  
  1445   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR CLAIM C OMMENT",10 )
  1446  
  1447   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR EEOB RE VIEW",6)
  1448  
  1449   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR RESEARC H",5)
  1450  
  1451   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR SELECTE D EEOB MEN U",1)
  1452  
  1453   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR SPLIT L INE",4)
  1454  
  1455   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR VERIFY" ,8)
  1456  
  1457   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR VIEW/PR INT EOB",7 )
  1458  
  1459   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE AP AR VIEW/PR INT ERA",3 )
  1460  
  1461   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE MA RK FOR AUT OPOST",11)
  1462  
  1463   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE PA YER FLAG P HARM",15)
  1464  
  1465   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE PA YER FLAG T RIC",16)
  1466  
  1467   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE PA YER FLAGS  EDIT",13)
  1468  
  1469   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE PA YER FLAGS  FILTER",14 )
  1470  
  1471   "BLD",1055 2,"KRN",10 1,"NM","B" ,"RCDPE PA YER FLAGS  MENU",12)
  1472  
  1473   "BLD",1055 2,"KRN",10 1,"NM","B" ,"VALM BLA NK 1",9)
  1474  
  1475   "BLD",1055 2,"KRN",10 1,"NM","B" ,"VALM QUI T",2)
  1476  
  1477   "BLD",1055 2,"KRN",40 9.61,0)
  1478   409.61
  1479   "BLD",1055 2,"KRN",40 9.61,"NM", 0)
  1480   ^9.68A^4^4
  1481   "BLD",1055 2,"KRN",40 9.61,"NM", 1,0)
  1482   RCDP RECEI PT PROFILE ^^0
  1483   "BLD",1055 2,"KRN",40 9.61,"NM", 2,0)
  1484   RCDPE PAYE R FLAGS^^0
  1485   "BLD",1055 2,"KRN",40 9.61,"NM", 3,0)
  1486   RCDPE APAR  EEOB LIST ^^0
  1487   "BLD",1055 2,"KRN",40 9.61,"NM", 4,0)
  1488   RCDP LIST  OF RECEIPT S REPORT^^ 0
  1489   "BLD",1055 2,"KRN",40 9.61,"NM", "B","RCDP  LIST OF RE CEIPTS REP ORT",4)
  1490  
  1491   "BLD",1055 2,"KRN",40 9.61,"NM", "B","RCDP  RECEIPT PR OFILE",1)
  1492  
  1493   "BLD",1055 2,"KRN",40 9.61,"NM", "B","RCDPE  APAR EEOB  LIST",3)
  1494  
  1495   "BLD",1055 2,"KRN",40 9.61,"NM", "B","RCDPE  PAYER FLA GS",2)
  1496  
  1497   "BLD",1055 2,"KRN",77 1,0)
  1498   771
  1499   "BLD",1055 2,"KRN",77 1,"NM",0)
  1500   ^9.68A^^
  1501   "BLD",1055 2,"KRN",77 9.2,0)
  1502   779.2
  1503   "BLD",1055 2,"KRN",87 0,0)
  1504   870
  1505   "BLD",1055 2,"KRN",89 89.51,0)
  1506   8989.51
  1507   "BLD",1055 2,"KRN",89 89.51,"NM" ,0)
  1508   ^9.68A^2^2
  1509   "BLD",1055 2,"KRN",89 89.51,"NM" ,1,0)
  1510   RCDPE APAR ^^0
  1511   "BLD",1055 2,"KRN",89 89.51,"NM" ,2,0)
  1512   RCDPE EDI  LOCKBOX WO RKLIST^^0
  1513   "BLD",1055 2,"KRN",89 89.51,"NM" ,"B","RCDP E APAR",1)
  1514  
  1515   "BLD",1055 2,"KRN",89 89.51,"NM" ,"B","RCDP E EDI LOCK BOX WORKLI ST",2)
  1516  
  1517   "BLD",1055 2,"KRN",89 89.52,0)
  1518   8989.52
  1519   "BLD",1055 2,"KRN",89 94,0)
  1520   8994
  1521   "BLD",1055 2,"KRN","B ",.4,.4)
  1522  
  1523   "BLD",1055 2,"KRN","B ",.401,.40 1)
  1524  
  1525   "BLD",1055 2,"KRN","B ",.402,.40 2)
  1526  
  1527   "BLD",1055 2,"KRN","B ",.403,.40 3)
  1528  
  1529   "BLD",1055 2,"KRN","B ",.5,.5)
  1530  
  1531   "BLD",1055 2,"KRN","B ",.84,.84)
  1532  
  1533   "BLD",1055 2,"KRN","B ",3.6,3.6)
  1534  
  1535   "BLD",1055 2,"KRN","B ",3.8,3.8)
  1536  
  1537   "BLD",1055 2,"KRN","B ",9.2,9.2)
  1538  
  1539   "BLD",1055 2,"KRN","B ",9.8,9.8)
  1540  
  1541   "BLD",1055 2,"KRN","B ",19,19)
  1542  
  1543   "BLD",1055 2,"KRN","B ",19.1,19. 1)
  1544  
  1545   "BLD",1055 2,"KRN","B ",101,101)
  1546  
  1547   "BLD",1055 2,"KRN","B ",409.61,4 09.61)
  1548  
  1549   "BLD",1055 2,"KRN","B ",771,771)
  1550  
  1551   "BLD",1055 2,"KRN","B ",779.2,77 9.2)
  1552  
  1553   "BLD",1055 2,"KRN","B ",870,870)
  1554  
  1555   "BLD",1055 2,"KRN","B ",8989.51, 8989.51)
  1556  
  1557   "BLD",1055 2,"KRN","B ",8989.52, 8989.52)
  1558  
  1559   "BLD",1055 2,"KRN","B ",8994,899 4)
  1560  
  1561   "BLD",1055 2,"QDEF")
  1562   ^^^^^^^^YE S
  1563   "BLD",1055 2,"QUES",0 )
  1564   ^9.62^^
  1565   "BLD",1055 2,"REQB",0 )
  1566   ^9.611^5^4
  1567   "BLD",1055 2,"REQB",1 ,0)
  1568   PRCA*4.5*3 18^1
  1569   "BLD",1055 2,"REQB",3 ,0)
  1570   PRCA*4.5*3 12^1
  1571   "BLD",1055 2,"REQB",4 ,0)
  1572   PRCA*4.5*3 17^1
  1573   "BLD",1055 2,"REQB",5 ,0)
  1574   PRCA*4.5*3 19^1
  1575   "BLD",1055 2,"REQB"," B","PRCA*4 .5*312",3)
  1576  
  1577   "BLD",1055 2,"REQB"," B","PRCA*4 .5*317",4)
  1578  
  1579   "BLD",1055 2,"REQB"," B","PRCA*4 .5*318",1)
  1580  
  1581   "BLD",1055 2,"REQB"," B","PRCA*4 .5*319",5)
  1582  
  1583   "FIA",342)
  1584   AR SITE PA RAMETER
  1585   "FIA",342, 0)
  1586   ^RC(342,
  1587   "FIA",342, 0,0)
  1588   342P
  1589   "FIA",342, 0,1)
  1590   y^y^p^^^^n ^^n
  1591   "FIA",342, 0,10)
  1592  
  1593   "FIA",342, 0,11)
  1594  
  1595   "FIA",342, 0,"RLRO")
  1596  
  1597   "FIA",342, 0,"VR")
  1598   4.5^PRCA
  1599   "FIA",342, 342)
  1600   1
  1601   "FIA",342, 342,7.07)
  1602  
  1603   "FIA",342, 342,7.08)
  1604  
  1605   "FIA",344)
  1606   AR BATCH P AYMENT
  1607   "FIA",344, 0)
  1608   ^RCY(344,
  1609   "FIA",344, 0,0)
  1610   344I
  1611   "FIA",344, 0,1)
  1612   y^y^p^^^^n ^^n
  1613   "FIA",344, 0,10)
  1614  
  1615   "FIA",344, 0,11)
  1616  
  1617   "FIA",344, 0,"RLRO")
  1618  
  1619   "FIA",344, 0,"VR")
  1620   4.5^PRCA
  1621   "FIA",344, 344)
  1622   1
  1623   "FIA",344, 344,.03)
  1624  
  1625   "FIA",344, 344.01)
  1626   1
  1627   "FIA",344, 344.01,.09 )
  1628  
  1629   "FIA",344. 31)
  1630   EDI THIRD  PARTY EFT  DETAIL
  1631   "FIA",344. 31,0)
  1632   ^RCY(344.3 1,
  1633   "FIA",344. 31,0,0)
  1634   344.31PI
  1635   "FIA",344. 31,0,1)
  1636   y^y^p^^^^n ^^n
  1637   "FIA",344. 31,0,10)
  1638  
  1639   "FIA",344. 31,0,11)
  1640  
  1641   "FIA",344. 31,0,"RLRO ")
  1642  
  1643   "FIA",344. 31,0,"VR")
  1644   4.5^PRCA
  1645   "FIA",344. 31,344.31)
  1646   1
  1647   "FIA",344. 31,344.31, 3)
  1648  
  1649   "FIA",344. 49)
  1650   EDI LOCKBO X EOB WORK LIST
  1651   "FIA",344. 49,0)
  1652   ^RCY(344.4 9,
  1653   "FIA",344. 49,0,0)
  1654   344.49P
  1655   "FIA",344. 49,0,1)
  1656   y^y^p^^^^n ^^n
  1657   "FIA",344. 49,0,10)
  1658  
  1659   "FIA",344. 49,0,11)
  1660  
  1661   "FIA",344. 49,0,"RLRO ")
  1662  
  1663   "FIA",344. 49,0,"VR")
  1664   4.5^PRCA
  1665   "FIA",344. 49,344.49)
  1666   1
  1667   "FIA",344. 49,344.491 )
  1668   1
  1669   "FIA",344. 49,344.491 ,.1)
  1670  
  1671   "FIA",344. 6)
  1672   RCDPE AUTO -PAY EXCLU SION
  1673   "FIA",344. 6,0)
  1674   ^RCY(344.6 ,
  1675   "FIA",344. 6,0,0)
  1676   344.6I
  1677   "FIA",344. 6,0,1)
  1678   y^y^p^^^^n ^^n
  1679   "FIA",344. 6,0,10)
  1680  
  1681   "FIA",344. 6,0,11)
  1682  
  1683   "FIA",344. 6,0,"RLRO" )
  1684  
  1685   "FIA",344. 6,0,"VR")
  1686   4.5^PRCA
  1687   "FIA",344. 6,344.6)
  1688   1
  1689   "FIA",344. 6,344.6,.0 1)
  1690  
  1691   "FIA",344. 6,344.6,.0 9)
  1692  
  1693   "FIA",344. 6,344.6,.1 )
  1694  
  1695   "FIA",344. 61)
  1696   RCDPE PARA METER
  1697   "FIA",344. 61,0)
  1698   ^RCY(344.6 1,
  1699   "FIA",344. 61,0,0)
  1700   344.61P
  1701   "FIA",344. 61,0,1)
  1702   y^y^p^^^^n ^^n
  1703   "FIA",344. 61,0,10)
  1704  
  1705   "FIA",344. 61,0,11)
  1706  
  1707   "FIA",344. 61,0,"RLRO ")
  1708  
  1709   "FIA",344. 61,0,"VR")
  1710   4.5^PRCA
  1711   "FIA",344. 61,344.61)
  1712   1
  1713   "FIA",344. 61,344.61, .06)
  1714  
  1715   "FIA",344. 61,344.61, .07)
  1716  
  1717   "FIA",344. 61,344.61, .1)
  1718  
  1719   "FIA",344. 73)
  1720   RCDPE COMM ENT HISTOR Y
  1721   "FIA",344. 73,0)
  1722   ^RCY(344.7 3,
  1723   "FIA",344. 73,0,0)
  1724   344.73P
  1725   "FIA",344. 73,0,1)
  1726   y^y^f^^^^n
  1727   "FIA",344. 73,0,10)
  1728  
  1729   "FIA",344. 73,0,11)
  1730  
  1731   "FIA",344. 73,0,"RLRO ")
  1732  
  1733   "FIA",344. 73,0,"VR")
  1734   4.5^PRCA
  1735   "FIA",344. 73,344.73)
  1736   0
  1737   "INIT")
  1738   POST^RCP32 1
  1739   "IX",344.6 ,344.6,"B" ,0)
  1740   344.6^B^In dex by Nam e (full 60 )^R^^F^IR^ I^344.6^^^ ^^LS
  1741   "IX",344.6 ,344.6,"B" ,.1,0)
  1742   ^^2^2^3170 620^
  1743   "IX",344.6 ,344.6,"B" ,.1,1,0)
  1744   This index  allows lo okup using  the full  60 charact er long PA YER NAME 
  1745   "IX",344.6 ,344.6,"B" ,.1,2,0)
  1746   field.
  1747   "IX",344.6 ,344.6,"B" ,1)
  1748   S ^RCY(344 .6,"B",$E( X,1,60),DA )=""
  1749   "IX",344.6 ,344.6,"B" ,2)
  1750   K ^RCY(344 .6,"B",$E( X,1,60),DA )
  1751   "IX",344.6 ,344.6,"B" ,2.5)
  1752   K ^RCY(344 .6,"B")
  1753   "IX",344.6 ,344.6,"B" ,11.1,0)
  1754   ^.114IA^1^ 1
  1755   "IX",344.6 ,344.6,"B" ,11.1,1,0)
  1756   1^F^344.6^ .01^60^1^F
  1757   "IX",344.6 ,344.6,"CP ID",0)
  1758   344.6^CPID ^Combinati on of the  PAYER NAME  and PAYER  ID^R^^R^I R^I^344.6^ ^^^^LS
  1759   "IX",344.6 ,344.6,"CP ID",.1,0)
  1760   ^^2^2^3140 506^
  1761   "IX",344.6 ,344.6,"CP ID",.1,1,0 )
  1762   This index  is used t o ensure t hat the PA YER NAME / PAYER ID c ombination  is 
  1763   "IX",344.6 ,344.6,"CP ID",.1,2,0 )
  1764   unique.
  1765   "IX",344.6 ,344.6,"CP ID",1)
  1766   S ^RCY(344 .6,"CPID", $E(X(1),1, 60),$E(X(2 ),1,30),DA )=""
  1767   "IX",344.6 ,344.6,"CP ID",2)
  1768   K ^RCY(344 .6,"CPID", $E(X(1),1, 60),$E(X(2 ),1,30),DA )
  1769   "IX",344.6 ,344.6,"CP ID",2.5)
  1770   K ^RCY(344 .6,"CPID")
  1771   "IX",344.6 ,344.6,"CP ID",11.1,0 )
  1772   ^.114IA^2^ 2
  1773   "IX",344.6 ,344.6,"CP ID",11.1,1 ,0)
  1774   1^F^344.6^ .01^60^1^F
  1775   "IX",344.6 ,344.6,"CP ID",11.1,2 ,0)
  1776   2^F^344.6^ .02^30^2^F
  1777   "IX",344.7 3,344.73," AC",0)
  1778   344.73^AC^ Lookup ind ex^MU^^R^I R^I^344.73 ^^^^^S
  1779   "IX",344.7 3,344.73," AC",.1,0)
  1780   ^^2^2^3170 620^
  1781   "IX",344.7 3,344.73," AC",.1,1,0 )
  1782   This index  allows lo okup of co mment hist ory by rec eipt, rece ipt line 
  1783   "IX",344.7 3,344.73," AC",.1,2,0 )
  1784   number and  date/time  entered.
  1785   "IX",344.7 3,344.73," AC",1)
  1786   S ^RCY(344 .73,"AC",X (1),X(2),X (3))=DA
  1787   "IX",344.7 3,344.73," AC",2)
  1788   K ^RCY(344 .73,"AC",X (1),X(2),X (3))
  1789   "IX",344.7 3,344.73," AC",2.5)
  1790   K ^RCY(344 .73,"AC")
  1791   "IX",344.7 3,344.73," AC",11.1,0 )
  1792   ^.114IA^3^ 3
  1793   "IX",344.7 3,344.73," AC",11.1,1 ,0)
  1794   1^F^344.73 ^.01^^1^F
  1795   "IX",344.7 3,344.73," AC",11.1,2 ,0)
  1796   2^F^344.73 ^1^^2^F
  1797   "IX",344.7 3,344.73," AC",11.1,3 ,0)
  1798   3^F^344.73 ^3^^3^F
  1799   "IX",344.7 3,344.73," C",0)
  1800   344.73^C^U niqueness  Index for  Key 'A' of  File #344 .73^R^^R^I R^I^344.73 ^^^^^LS
  1801   "IX",344.7 3,344.73," C",.1,0)
  1802   ^^2^2^3170 620^
  1803   "IX",344.7 3,344.73," C",.1,1,0)
  1804   This is an  index by  receipt, r eceipt lin e number,  user and d ate/time 
  1805   "IX",344.7 3,344.73," C",.1,2,0)
  1806   entered us ed to trac k changes  comment hi story.
  1807   "IX",344.7 3,344.73," C",1)
  1808   S ^RCY(344 .73,"C",X( 1),X(2),X( 3),X(4),DA )=""
  1809   "IX",344.7 3,344.73," C",2)
  1810   K ^RCY(344 .73,"C",X( 1),X(2),X( 3),X(4),DA )
  1811   "IX",344.7 3,344.73," C",2.5)
  1812   K ^RCY(344 .73,"C")
  1813   "IX",344.7 3,344.73," C",11.1,0)
  1814   ^.114IA^4^ 4
  1815   "IX",344.7 3,344.73," C",11.1,1, 0)
  1816   1^F^344.73 ^.01^^1
  1817   "IX",344.7 3,344.73," C",11.1,2, 0)
  1818   2^F^344.73 ^1^^2
  1819   "IX",344.7 3,344.73," C",11.1,3, 0)
  1820   3^F^344.73 ^2^^3
  1821   "IX",344.7 3,344.73," C",11.1,4, 0)
  1822   4^F^344.73 ^3^^4
  1823   "KEY",344. 73,344.73, "A",0)
  1824   344.73^A^P ^1473
  1825   "KEY",344. 73,344.73, "A",2,0)
  1826   ^.312IA^4^ 4
  1827   "KEY",344. 73,344.73, "A",2,1,0)
  1828   .01^344.73 ^1
  1829   "KEY",344. 73,344.73, "A",2,2,0)
  1830   1^344.73^2
  1831   "KEY",344. 73,344.73, "A",2,3,0)
  1832   2^344.73^3
  1833   "KEY",344. 73,344.73, "A",2,4,0)
  1834   3^344.73^4
  1835   "KEYPTR",3 44.73,344. 73,"A")
  1836   344.73^C
  1837   "KRN",3.8, 1427,-1)
  1838   0^1
  1839   "KRN",3.8, 1427,0)
  1840   RCDPE AUDI T^PU^y^^^0 ^
  1841   "KRN",3.8, 1427,2,0)
  1842   ^3.801^3^3 ^3150617^^ ^^
  1843   "KRN",3.8, 1427,2,1,0 )
  1844   This is th e mail gro up that wi ll receive  warning b ulletins p roduced by  the
  1845   "KRN",3.8, 1427,2,2,0 )
  1846   ePayments  Workload N otificatio n process.  Warnings  for overdu e EFT and  ERA
  1847   "KRN",3.8, 1427,2,3,0 )
  1848   are sent t o this gro up.
  1849   "KRN",3.8, 1427,3)
  1850  
  1851   "KRN",9.2, 1554,-1)
  1852   0^1
  1853   "KRN",9.2, 1554,0)
  1854   RCDPE PAYE R FLAGS GE NERAL^Flag  Payers as  Pharmacy/ Tricare^31 70512.083^ ^
  1855   "KRN",9.2, 1554,1,0)
  1856   ^^43^43^31 70822^
  1857   "KRN",9.2, 1554,1,1,0 )
  1858   PH - Use t his option  to flag/u n-flag a p ayer as a  Pharmacy p ayer.  The
  1859   "KRN",9.2, 1554,1,2,0 )
  1860        selec ted entrie s will be  toggled, s o that un- flagged en tries are
  1861   "KRN",9.2, 1554,1,3,0 )
  1862        flagg ed, and fl agged entr ies are un -flagged.
  1863   "KRN",9.2, 1554,1,4,0 )
  1864    
  1865   "KRN",9.2, 1554,1,5,0 )
  1866   TR - Use t his option  to flag/u n-flag a p ayer as a  Tricare pa yer.  The
  1867   "KRN",9.2, 1554,1,6,0 )
  1868        selec ted entrie s will be  toggled, a s for the  PH option.
  1869   "KRN",9.2, 1554,1,7,0 )
  1870    
  1871   "KRN",9.2, 1554,1,8,0 )
  1872   ED - Use t his option  to edit t he Pharmac y and Tric are flags  on a singl e
  1873   "KRN",9.2, 1554,1,9,0 )
  1874        payer .
  1875   "KRN",9.2, 1554,1,10, 0)
  1876    
  1877   "KRN",9.2, 1554,1,11, 0)
  1878   FI - Use t his option  to change  the filte rs on the  list, to d isplay onl y
  1879   "KRN",9.2, 1554,1,12, 0)
  1880        entri es that ma tch the fi lter crite ria. You m ay filter  the list b y
  1881   "KRN",9.2, 1554,1,13, 0)
  1882        Date  Added and  by the sta tus of the  Pharmacy  and Tricar e flags.
  1883   "KRN",9.2, 1554,1,14, 0)
  1884    
  1885   "KRN",9.2, 1554,1,15, 0)
  1886   PRE-SELECT ION
  1887   "KRN",9.2, 1554,1,16, 0)
  1888         - If  you selec t any of t he above o ptions you  will be p rompted fo r
  1889   "KRN",9.2, 1554,1,17, 0)
  1890           th e appropri ate inform ation to c omplete th e action.   However y ou
  1891   "KRN",9.2, 1554,1,18, 0)
  1892           ma y save tim e and keys trokes by  preselecti on of the  answers.   Type
  1893   "KRN",9.2, 1554,1,19, 0)
  1894           th e equals s ign (=) af ter the op tion and s pecify the  answers a s
  1895   "KRN",9.2, 1554,1,20, 0)
  1896           fo llows:
  1897   "KRN",9.2, 1554,1,21, 0)
  1898    
  1899   "KRN",9.2, 1554,1,22, 0)
  1900           ED =Line to E dit
  1901   "KRN",9.2, 1554,1,23, 0)
  1902           e. g. ED=10       - Edit  Pharmacy  and Tricar e flags fo r line 10
  1903   "KRN",9.2, 1554,1,24, 0)
  1904    
  1905   "KRN",9.2, 1554,1,25, 0)
  1906           PH =List of L ines
  1907   "KRN",9.2, 1554,1,26, 0)
  1908           TR =List of L ines
  1909   "KRN",9.2, 1554,1,27, 0)
  1910    
  1911   "KRN",9.2, 1554,1,28, 0)
  1912           Li st of line s may be s pecified u sing the s tandard fo rmat. Use  ';'
  1913   "KRN",9.2, 1554,1,29, 0)
  1914           to  separate  individual  lines in  the list.   Use '-' t o specify
  1915   "KRN",9.2, 1554,1,30, 0)
  1916           a  range of l ines.
  1917   "KRN",9.2, 1554,1,31, 0)
  1918           e. g. PH=10        - tog gle pharma cy for lin e 10
  1919   "KRN",9.2, 1554,1,32, 0)
  1920                 PH=1;4; 8    - tog gle pharma cy for lin es 1, 4 an d 8
  1921   "KRN",9.2, 1554,1,33, 0)
  1922                 TR=3-9       - tog gle Tricar e for line s 3 throug h 9
  1923   "KRN",9.2, 1554,1,34, 0)
  1924                 PH=1;3- 9;12 - tog gle pharma cy for lin es 1, 3 th rough 9 an d 12
  1925   "KRN",9.2, 1554,1,35, 0)
  1926    
  1927   "KRN",9.2, 1554,1,36, 0)
  1928    
  1929   "KRN",9.2, 1554,1,37, 0)
  1930           FI =Type;[Sta rt];[End]
  1931   "KRN",9.2, 1554,1,38, 0)
  1932    
  1933   "KRN",9.2, 1554,1,39, 0)
  1934           Sp ecify the  type of fi lter and o ptionally  the start  and end da te
  1935   "KRN",9.2, 1554,1,40, 0)
  1936           fo r filter b y Date Add ed.
  1937   "KRN",9.2, 1554,1,41, 0)
  1938           e. g. FI=P        - Chan ge filter  to show li nes flagge d pharmacy
  1939   "KRN",9.2, 1554,1,42, 0)
  1940                 FI=A;T- 7;T - Chan ge filter  to show al l records  added in t he
  1941   "KRN",9.2, 1554,1,43, 0)
  1942                               last  7 days.
  1943   "KRN",19,2 919461,-1)
  1944   4^4
  1945   "KRN",19,2 919461,0)
  1946   RCDPE EXCE PTION PROC ESSING
  1947   "KRN",19,2 919462,-1)
  1948   4^18
  1949   "KRN",19,2 919462,0)
  1950   RCDPE EFT  AGING REPO RT
  1951   "KRN",19,2 919463,-1)
  1952   4^19
  1953   "KRN",19,2 919463,0)
  1954   RCDPE ERA  AGING REPO RT
  1955   "KRN",19,2 919464,-1)
  1956   4^5
  1957   "KRN",19,2 919464,0)
  1958   RCDPE MATC H EFT TO E RA
  1959   "KRN",19,2 919465,-1)
  1960   4^3
  1961   "KRN",19,2 919465,0)
  1962   RCDPE EDI  LOCKBOX WO RKLIST
  1963   "KRN",19,2 919467,-1)
  1964   0^2
  1965   "KRN",19,2 919467,0)
  1966   RCDPE EDI  LOCKBOX ME NU^EDI Loc kbox (ePay ments)^^M^ ^^^^^^^ACC OUNTS RECE IVABLE
  1967   "KRN",19,2 919467,1,0 )
  1968   ^19.06^1^1 ^3170619^^ ^^
  1969   "KRN",19,2 919467,1,1 ,0)
  1970   This is th e menu tha t contains  the EDI L ockbox fun ctionality .
  1971   "KRN",19,2 919467,10, 0)
  1972   ^19.01IP^1 8^18
  1973   "KRN",19,2 919467,10, 2,0)
  1974   2919465^WL ^10
  1975   "KRN",19,2 919467,10, 2,"^")
  1976   RCDPE EDI  LOCKBOX WO RKLIST
  1977   "KRN",19,2 919467,10, 5,0)
  1978   2919461^EX C^5
  1979   "KRN",19,2 919467,10, 5,"^")
  1980   RCDPE EXCE PTION PROC ESSING
  1981   "KRN",19,2 919467,10, 6,0)
  1982   2919464^MA ^20
  1983   "KRN",19,2 919467,10, 6,"^")
  1984   RCDPE MATC H EFT TO E RA
  1985   "KRN",19,2 919467,10, 7,0)
  1986   2919470^RE P^55
  1987   "KRN",19,2 919467,10, 7,"^")
  1988   RCDPE EDI  LOCKBOX RE PORTS MENU
  1989   "KRN",19,2 919467,10, 8,0)
  1990   2919471^MM ^30
  1991   "KRN",19,2 919467,10, 8,"^")
  1992   RCDPE MANU AL MATCH E FT-ERA
  1993   "KRN",19,2 919467,10, 9,0)
  1994   2919472^ZB ^70
  1995   "KRN",19,2 919467,10, 9,"^")
  1996   RCDPE MARK  0-BAL EFT  MATCHED
  1997   "KRN",19,2 919467,10, 11,0)
  1998   2919476^UP ^65
  1999   "KRN",19,2 919467,10, 11,"^")
  2000   RCDPE ERA  POSTED BY  PAPER EOB
  2001   "KRN",19,2 919467,10, 12,0)
  2002   2919478^UN ^60
  2003   "KRN",19,2 919467,10, 12,"^")
  2004   RCDPE UNMA TCH ERA
  2005   "KRN",19,2 919467,10, 13,0)
  2006   2921657^RE M^50
  2007   "KRN",19,2 919467,10, 13,"^")
  2008   RCDPE REMO VE ERA FRO M WORKLIST
  2009   "KRN",19,2 919467,10, 14,0)
  2010   2922178^MC R^25
  2011   "KRN",19,2 919467,10, 14,"^")
  2012   RCDPE EEOB  MOVE/COPY /REMOVE
  2013   "KRN",19,2 919467,10, 15,0)
  2014   2921609^RE FT^45
  2015   "KRN",19,2 919467,10, 15,"^")
  2016   RCDPE REMO VE DUP DEP OSITS
  2017   "KRN",19,2 919467,10, 16,0)
  2018   2922187^OE FT^40
  2019   "KRN",19,2 919467,10, 16,"^")
  2020   RCDPE UNPO STED EFT O VERRIDE
  2021   "KRN",19,2 919467,10, 17,0)
  2022   2922188^AP AR^15
  2023   "KRN",19,2 919467,10, 17,"^")
  2024   RCDPE APAR
  2025   "KRN",19,2 919467,10, 18,0)
  2026   2922476^ID P^80
  2027   "KRN",19,2 919467,10, 18,"^")
  2028   RCDPE PAYE R IDENTIFY
  2029   "KRN",19,2 919467,10. 1)
  2030  
  2031   "KRN",19,2 919467,99)
  2032   64572,4511 7
  2033   "KRN",19,2 919467,99. 1)
  2034   64572,4512 2
  2035   "KRN",19,2 919467,"U" )
  2036   EDI LOCKBO X (EPAYMEN TS)
  2037   "KRN",19,2 919468,-1)
  2038   4^17
  2039   "KRN",19,2 919468,0)
  2040   RCDPE EDI  LOCKBOX AC T REPORT
  2041   "KRN",19,2 919470,-1)
  2042   0^15
  2043   "KRN",19,2 919470,0)
  2044   RCDPE EDI  LOCKBOX RE PORTS MENU ^EDI Lockb ox (ePayme nts) Repor ts Menu^^M ^^^^^^^^AC COUNTS REC EIVABLE
  2045   "KRN",19,2 919470,1,0 )
  2046   2^19.06^2^ 2^3171023^ ^^^
  2047   "KRN",19,2 919470,1,1 ,0)
  2048   This menu  allows acc ess to all  the repor ts that ca n be produ ced for ED I
  2049   "KRN",19,2 919470,1,2 ,0)
  2050   Lockbox.
  2051   "KRN",19,2 919470,10, 0)
  2052   ^19.01IP^2 5^25
  2053   "KRN",19,2 919470,10, 1,0)
  2054   2919468^DA ^10
  2055   "KRN",19,2 919470,10, 1,"^")
  2056   RCDPE EDI  LOCKBOX AC T REPORT
  2057   "KRN",19,2 919470,10, 3,0)
  2058   2919462^EF T^30
  2059   "KRN",19,2 919470,10, 3,"^")
  2060   RCDPE EFT  AGING REPO RT
  2061   "KRN",19,2 919470,10, 4,0)
  2062   2919463^ER A^40
  2063   "KRN",19,2 919470,10, 4,"^")
  2064   RCDPE ERA  AGING REPO RT
  2065   "KRN",19,2 919470,10, 6,0)
  2066   2919477^VP
  2067   "KRN",19,2 919470,10, 6,"^")
  2068   RCDPE VIEW /PRINT ERA
  2069   "KRN",19,2 919470,10, 7,0)
  2070   2919712^AB ^60
  2071   "KRN",19,2 919470,10, 7,"^")
  2072   RCDPE ACTI VE WITH EE OB REPORT
  2073   "KRN",19,2 919470,10, 9,0)
  2074   2921658^RE MR^
  2075   "KRN",19,2 919470,10, 9,"^")
  2076   RCDPE REMO VED ERA AU DIT
  2077   "KRN",19,2 919470,10, 10,0)
  2078   2921610^PO SR^
  2079   "KRN",19,2 919470,10, 10,"^")
  2080   RCDPE ERA  W/PAPER EO B REPORT
  2081   "KRN",19,2 919470,10, 11,0)
  2082   2921611^DU PR
  2083   "KRN",19,2 919470,10, 11,"^")
  2084   RCDPE EFT  AUDIT REPO RT
  2085   "KRN",19,2 919470,10, 12,0)
  2086   2922179^MC R
  2087   "KRN",19,2 919470,10, 12,"^")
  2088   RCDPE EEOB  MOVE/COPY /RMOVE RPT
  2089   "KRN",19,2 919470,10, 13,0)
  2090   2922181^AP ^80
  2091   "KRN",19,2 919470,10, 13,"^")
  2092   RCDPE AUTO -POST REPO RT
  2093   "KRN",19,2 919470,10, 14,0)
  2094   2922182^AD ^70
  2095   "KRN",19,2 919470,10, 14,"^")
  2096   RCDPE AUTO -DECREASE  REPORT
  2097   "KRN",19,2 919470,10, 15,0)
  2098   2922186^PX
  2099   "KRN",19,2 919470,10, 15,"^")
  2100   RCDPE PAYE R EXCLUSIO N NAME TIN
  2101   "KRN",19,2 919470,10, 16,0)
  2102   2922296^TB
  2103   "KRN",19,2 919470,10, 16,"^")
  2104   RCDPE CARC /RARC TABL E REPORT
  2105   "KRN",19,2 919470,10, 18,0)
  2106   2922297^PL B
  2107   "KRN",19,2 919470,10, 18,"^")
  2108   RCDPE PROV IDER LVL A DJ REPORT
  2109   "KRN",19,2 919470,10, 19,0)
  2110   2922298^ET A
  2111   "KRN",19,2 919470,10, 19,"^")
  2112   RCDPE EFT  TRANSACTIO N AUD REP
  2113   "KRN",19,2 919470,10, 20,0)
  2114   2922295^CR
  2115   "KRN",19,2 919470,10, 20,"^")
  2116   RCDPE CARC  CODE PAYE R REPORT
  2117   "KRN",19,2 919470,10, 21,0)
  2118   2922310^ES C
  2119   "KRN",19,2 919470,10, 21,"^")
  2120   RCDPE ERA  STATUS CHN G AUD REP
  2121   "KRN",19,2 919470,10, 22,0)
  2122   2922424^UN ^50
  2123   "KRN",19,2 919470,10, 22,"^")
  2124   RCDPE UNAP PLIED EFT  DEP REPORT
  2125   "KRN",19,2 919470,10, 23,0)
  2126   2922451^AP R^90
  2127   "KRN",19,2 919470,10, 23,"^")
  2128   RCDPE AUTO -POST RECE IPT REPORT
  2129   "KRN",19,2 919470,10, 24,0)
  2130   2922302^ET R^45
  2131   "KRN",19,2 919470,10, 24,"^")
  2132   RCDPE EFT- ERA TRENDI NG REPORT
  2133   "KRN",19,2 919470,10, 25,0)
  2134   2922299^QS
  2135   "KRN",19,2 919470,10, 25,"^")
  2136   RCDPE CARC /RARC QUIC K SEARCH
  2137   "KRN",19,2 919470,99)
  2138   64579,2182 7
  2139   "KRN",19,2 919470,99. 1)
  2140   59232,4962 9
  2141   "KRN",19,2 919470,"U" )
  2142   EDI LOCKBO X (EPAYMEN TS) REPORT
  2143   "KRN",19,2 919471,-1)
  2144   4^6
  2145   "KRN",19,2 919471,0)
  2146   RCDPE MANU AL MATCH E FT-ERA
  2147   "KRN",19,2 919472,-1)
  2148   4^7
  2149   "KRN",19,2 919472,0)
  2150   RCDPE MARK  0-BAL EFT  MATCHED
  2151   "KRN",19,2 919473,-1)
  2152   0^37
  2153   "KRN",19,2 919473,0)
  2154   RCDPE MOVE  ERA TO SU SPENSE^Mov e ERA Tota l To Suspe nse^THIS O PTION IS N O LONGER I N USE^R^^^ ^^^^^ACCOU NTS RECEIV ABLE
  2155   "KRN",19,2 919473,1,0 )
  2156   ^19.06^10^ 10^3030520 ^^^^
  2157   "KRN",19,2 919473,1,1 ,0)
  2158   This optio n will all ow the use r to choos e an ERA r ecord that  is matche d
  2159   "KRN",19,2 919473,1,2 ,0)
  2160   to an EFT  deposit an d will cre ate a rece ipt to pos t the tota l amount
  2161   "KRN",19,2 919473,1,3 ,0)
  2162   reported a s being pa id on the  EFT to SUS PENSE.  Th e ERA reco rd must
  2163   "KRN",19,2 919473,1,4 ,0)
  2164   not alread y have a r eceipt att ached to i t.  This o ption is u sed to for ce a
  2165   "KRN",19,2 919473,1,5 ,0)
  2166   'TR' docum ent to be  generated  from the E DI Lockbox  deposit a ccount to  the
  2167   "KRN",19,2 919473,1,6 ,0)
  2168   suspense a ccount whe n creating /posting a  receipt c an not be  done due t o
  2169   "KRN",19,2 919473,1,7 ,0)
  2170   take backs  or other  situations  where the  EFT and E RA amounts  do not ma tch.
  2171   "KRN",19,2 919473,1,8 ,0)
  2172   NO posting  to indivi dual claim s in AR is  accomplis hed by thi s option.
  2173   "KRN",19,2 919473,1,9 ,0)
  2174   These must  be done m anually.   FMS is upd ated if th ere is any  payment
  2175   "KRN",19,2 919473,1,1 0,0)
  2176   indicated  on the EFT .
  2177   "KRN",19,2 919473,25)
  2178   SUSPERA^RC DPEWL5
  2179   "KRN",19,2 919473,"U" )
  2180   MOVE ERA T OTAL TO SU SPENSE
  2181   "KRN",19,2 919476,-1)
  2182   4^8
  2183   "KRN",19,2 919476,0)
  2184   RCDPE ERA  POSTED BY  PAPER EOB
  2185   "KRN",19,2 919477,-1)
  2186   4^20
  2187   "KRN",19,2 919477,0)
  2188   RCDPE VIEW /PRINT ERA
  2189   "KRN",19,2 919478,-1)
  2190   4^9
  2191   "KRN",19,2 919478,0)
  2192   RCDPE UNMA TCH ERA
  2193   "KRN",19,2 919712,-1)
  2194   4^21
  2195   "KRN",19,2 919712,0)
  2196   RCDPE ACTI VE WITH EE OB REPORT
  2197   "KRN",19,2 921609,-1)
  2198   4^12
  2199   "KRN",19,2 921609,0)
  2200   RCDPE REMO VE DUP DEP OSITS
  2201   "KRN",19,2 921610,-1)
  2202   4^23
  2203   "KRN",19,2 921610,0)
  2204   RCDPE ERA  W/PAPER EO B REPORT
  2205   "KRN",19,2 921611,-1)
  2206   4^24
  2207   "KRN",19,2 921611,0)
  2208   RCDPE EFT  AUDIT REPO RT
  2209   "KRN",19,2 921657,-1)
  2210   4^10
  2211   "KRN",19,2 921657,0)
  2212   RCDPE REMO VE ERA FRO M WORKLIST
  2213   "KRN",19,2 921658,-1)
  2214   4^22
  2215   "KRN",19,2 921658,0)
  2216   RCDPE REMO VED ERA AU DIT
  2217   "KRN",19,2 922178,-1)
  2218   4^11
  2219   "KRN",19,2 922178,0)
  2220   RCDPE EEOB  MOVE/COPY /REMOVE
  2221   "KRN",19,2 922179,-1)
  2222   0^1
  2223   "KRN",19,2 922179,0)
  2224   RCDPE EEOB  MOVE/COPY /RMOVE RPT ^EEOB Move /Copy/Remo ve Audit R eport^^R^^ ^^^^^y^ACC OUNTS RECE IVABLE
  2225   "KRN",19,2 922179,1,0 )
  2226   ^19.06^3^3 ^3140529^^ ^^
  2227   "KRN",19,2 922179,1,1 ,0)
  2228   This repor t lists EE OBs that h ave either  been move d or copie d to new c laim
  2229   "KRN",19,2 922179,1,2 ,0)
  2230   numbers or  have been  removed f rom a clai m. The rep ort can be  filtered  by
  2231   "KRN",19,2 922179,1,3 ,0)
  2232   Station/Di vision and  by date r ange.  
  2233   "KRN",19,2 922179,25)
  2234   EOB^RCDPEM 4
  2235   "KRN",19,2 922179,"U" )
  2236   EEOB MOVE/ COPY/REMOV E AUDIT RE
  2237   "KRN",19,2 922181,-1)
  2238   4^25
  2239   "KRN",19,2 922181,0)
  2240   RCDPE AUTO -POST REPO RT
  2241   "KRN",19,2 922182,-1)
  2242   4^26
  2243   "KRN",19,2 922182,0)
  2244   RCDPE AUTO -DECREASE  REPORT
  2245   "KRN",19,2 922186,-1)
  2246   4^27
  2247   "KRN",19,2 922186,0)
  2248   RCDPE PAYE R EXCLUSIO N NAME TIN
  2249   "KRN",19,2 922187,-1)
  2250   4^13
  2251   "KRN",19,2 922187,0)
  2252   RCDPE UNPO STED EFT O VERRIDE
  2253   "KRN",19,2 922188,-1)
  2254   4^14
  2255   "KRN",19,2 922188,0)
  2256   RCDPE APAR
  2257   "KRN",19,2 922295,-1)
  2258   4^31
  2259   "KRN",19,2 922295,0)
  2260   RCDPE CARC  CODE PAYE R REPORT
  2261   "KRN",19,2 922296,-1)
  2262   4^28
  2263   "KRN",19,2 922296,0)
  2264   RCDPE CARC /RARC TABL E REPORT
  2265   "KRN",19,2 922297,-1)
  2266   4^29
  2267   "KRN",19,2 922297,0)
  2268   RCDPE PROV IDER LVL A DJ REPORT
  2269   "KRN",19,2 922298,-1)
  2270   4^30
  2271   "KRN",19,2 922298,0)
  2272   RCDPE EFT  TRANSACTIO N AUD REP
  2273   "KRN",19,2 922299,-1)
  2274   4^36
  2275   "KRN",19,2 922299,0)
  2276   RCDPE CARC /RARC QUIC K SEARCH
  2277   "KRN",19,2 922302,-1)
  2278   4^35
  2279   "KRN",19,2 922302,0)
  2280   RCDPE EFT- ERA TRENDI NG REPORT
  2281   "KRN",19,2 922310,-1)
  2282   4^32
  2283   "KRN",19,2 922310,0)
  2284   RCDPE ERA  STATUS CHN G AUD REP
  2285   "KRN",19,2 922424,-1)
  2286   4^33
  2287   "KRN",19,2 922424,0)
  2288   RCDPE UNAP PLIED EFT  DEP REPORT
  2289   "KRN",19,2 922451,-1)
  2290   4^34
  2291   "KRN",19,2 922451,0)
  2292   RCDPE AUTO -POST RECE IPT REPORT
  2293   "KRN",19,2 922476,-1)
  2294   0^16
  2295   "KRN",19,2 922476,0)
  2296   RCDPE PAYE R IDENTIFY ^Identify  Payers^^R^ ^^^^^^^ACC OUNTS RECE IVABLE
  2297   "KRN",19,2 922476,1,0 )
  2298   ^19.06^7^7 ^3170822^^
  2299   "KRN",19,2 922476,1,1 ,0)
  2300   The option  displays  a list of  payers fro m the PAYE R EXCLUSIO N file 
  2301   "KRN",19,2 922476,1,2 ,0)
  2302   (#344.6) a nd allows  an end use r with the  appropria te securit y access t
  2303   "KRN",19,2 922476,1,3 ,0)
  2304   flag entri es as Phar macy and/o r Tricare.  Entries c an be eith er, neithe
  2305   "KRN",19,2 922476,1,4 ,0)
  2306   or both.   The option  allows th e user to  filter the  list by d ate added.   
  2307   "KRN",19,2 922476,1,5 ,0)
  2308   This is im portant as  entries a re added t o the file  automatic ally by th
  2309   "KRN",19,2 922476,1,6 ,0)
  2310   nightly pr ocess.  A  user needs  to be abl e to see w hat entrie s were 
  2311   "KRN",19,2 922476,1,7 ,0)
  2312   added rece ntly and i f they nee d to be fl agged.
  2313   "KRN",19,2 922476,25)
  2314   EN^RCDPEP
  2315   "KRN",19,2 922476,"U" )
  2316   IDENTIFY P AYERS
  2317   "KRN",101, 1697,-1)
  2318   4^2
  2319   "KRN",101, 1697,0)
  2320   VALM QUIT
  2321   "KRN",101, 1702,-1)
  2322   4^9
  2323   "KRN",101, 1702,0)
  2324   VALM BLANK  1
  2325   "KRN",101, 7963,-1)
  2326   4^3
  2327   "KRN",101, 7963,0)
  2328   RCDPE APAR  VIEW/PRIN T ERA
  2329   "KRN",101, 7965,-1)
  2330   0^1
  2331   "KRN",101, 7965,0)
  2332   RCDPE APAR  SELECTED  EEOB MENU^ APAR Selec ted EEOB^^ M^^^^^^^^A CCOUNTS RE CEIVABLE
  2333   "KRN",101, 7965,1,0)
  2334   ^101.06^3^ 3^3140515^ ^^^
  2335   "KRN",101, 7965,1,1,0 )
  2336   The APAR s elected EE OB menu co ntains the  actions t hat can be  performed  
  2337   "KRN",101, 7965,1,2,0 )
  2338   manually o n the EEOB  item that  did not g et a recei pt when th e associat ed 
  2339   "KRN",101, 7965,1,3,0 )
  2340   ERA record  was proce ssed durin g the auto -post nigh tly proces s.
  2341   "KRN",101, 7965,4)
  2342   25^4
  2343   "KRN",101, 7965,10,0)
  2344   ^101.01PA^ 21^21
  2345   "KRN",101, 7965,10,1, 0)
  2346   1697^^999^ ^^EXIT
  2347   "KRN",101, 7965,10,1, "^")
  2348   VALM QUIT
  2349   "KRN",101, 7965,10,3, 0)
  2350   7966^^100^
  2351   "KRN",101, 7965,10,3, "^")
  2352   RCDPE MARK  FOR AUTOP OST
  2353   "KRN",101, 7965,10,10 ,0)
  2354   7963^ERA^2 20^
  2355   "KRN",101, 7965,10,10 ,"^")
  2356   RCDPE APAR  VIEW/PRIN T ERA
  2357   "KRN",101, 7965,10,11 ,0)
  2358   7967^^50^
  2359   "KRN",101, 7965,10,11 ,"^")
  2360   RCDPE APAR  SPLIT LIN E
  2361   "KRN",101, 7965,10,13 ,0)
  2362   7969^^240^ ^^Research  Menu
  2363   "KRN",101, 7965,10,13 ,"^")
  2364   RCDPE APAR  RESEARCH
  2365   "KRN",101, 7965,10,14 ,0)
  2366   7970^^310^
  2367   "KRN",101, 7965,10,14 ,"^")
  2368   RCDPE APAR  EEOB REVI EW
  2369   "KRN",101, 7965,10,15 ,0)
  2370   7971^EOB^2 10^
  2371   "KRN",101, 7965,10,15 ,"^")
  2372   RCDPE APAR  VIEW/PRIN T EOB
  2373   "KRN",101, 7965,10,16 ,0)
  2374   7973^^320^ ^^
  2375   "KRN",101, 7965,10,16 ,"^")
  2376   RCDPE APAR  VERIFY
  2377   "KRN",101, 7965,10,19 ,0)
  2378   1702^^250^
  2379   "KRN",101, 7965,10,19 ,"^")
  2380   VALM BLANK  1
  2381   "KRN",101, 7965,10,20 ,0)
  2382   8017^^150^
  2383   "KRN",101, 7965,10,20 ,"^")
  2384   RCDPE APAR  CLAIM COM MENT
  2385   "KRN",101, 7965,10,21 ,0)
  2386   1702^^170^
  2387   "KRN",101, 7965,10,21 ,"^")
  2388   VALM BLANK  1
  2389   "KRN",101, 7965,15)
  2390   I $G(RCFAS TXT) S VAL MBCK="Q"
  2391   "KRN",101, 7965,26)
  2392   D SHOW^VAL M
  2393   "KRN",101, 7965,28)
  2394   Select Act ion: 
  2395   "KRN",101, 7965,99)
  2396   64572,4511 7
  2397   "KRN",101, 7966,-1)
  2398   4^11
  2399   "KRN",101, 7966,0)
  2400   RCDPE MARK  FOR AUTOP OST
  2401   "KRN",101, 7967,-1)
  2402   4^4
  2403   "KRN",101, 7967,0)
  2404   RCDPE APAR  SPLIT LIN E
  2405   "KRN",101, 7969,-1)
  2406   4^5
  2407   "KRN",101, 7969,0)
  2408   RCDPE APAR  RESEARCH
  2409   "KRN",101, 7970,-1)
  2410   4^6
  2411   "KRN",101, 7970,0)
  2412   RCDPE APAR  EEOB REVI EW
  2413   "KRN",101, 7971,-1)
  2414   4^7
  2415   "KRN",101, 7971,0)
  2416   RCDPE APAR  VIEW/PRIN T EOB
  2417   "KRN",101, 7973,-1)
  2418   4^8
  2419   "KRN",101, 7973,0)
  2420   RCDPE APAR  VERIFY
  2421   "KRN",101, 8017,-1)
  2422   4^10
  2423   "KRN",101, 8017,0)
  2424   RCDPE APAR  CLAIM COM MENT
  2425   "KRN",101, 8358,-1)
  2426   0^13
  2427   "KRN",101, 8358,0)
  2428   RCDPE PAYE R FLAGS ED IT^Edit Fl ags^^A^^^^ ^^^^
  2429   "KRN",101, 8358,20)
  2430   D EDIT^RCD PEP
  2431   "KRN",101, 8358,99)
  2432   64572,4511 7
  2433   "KRN",101, 8359,-1)
  2434   0^14
  2435   "KRN",101, 8359,0)
  2436   RCDPE PAYE R FLAGS FI LTER^Filte r^^A^^^^^^ ^^
  2437   "KRN",101, 8359,20)
  2438   D FILTER^R CDPEP
  2439   "KRN",101, 8359,99)
  2440   64572,4511 7
  2441   "KRN",101, 8360,-1)
  2442   0^15
  2443   "KRN",101, 8360,0)
  2444   RCDPE PAYE R FLAG PHA RM^Flag Ph armacy^^A^ ^^^^^^^
  2445   "KRN",101, 8360,20)
  2446   D FLAGP^RC DPEP
  2447   "KRN",101, 8360,99)
  2448   64572,4511 7
  2449   "KRN",101, 8361,-1)
  2450   0^16
  2451   "KRN",101, 8361,0)
  2452   RCDPE PAYE R FLAG TRI C^Flag Tri care^^A^^^ ^^^^^
  2453   "KRN",101, 8361,20)
  2454   D FLAGT^RC DPEP
  2455   "KRN",101, 8361,99)
  2456   64572,4511 7
  2457   "KRN",101, 8362,-1)
  2458   0^12
  2459   "KRN",101, 8362,0)
  2460   RCDPE PAYE R FLAGS ME NU^Payer F lags^^M^^^ ^^^^^
  2461   "KRN",101, 8362,4)
  2462   26^4
  2463   "KRN",101, 8362,10,0)
  2464   ^101.01PA^ 5^5
  2465   "KRN",101, 8362,10,1, 0)
  2466   8358^ED^10 0^
  2467   "KRN",101, 8362,10,1, "^")
  2468   RCDPE PAYE R FLAGS ED IT
  2469   "KRN",101, 8362,10,2, 0)
  2470   8359^FI^11 0^
  2471   "KRN",101, 8362,10,2, "^")
  2472   RCDPE PAYE R FLAGS FI LTER
  2473   "KRN",101, 8362,10,3, 0)
  2474   8360^PH^20 0^
  2475   "KRN",101, 8362,10,3, "^")
  2476   RCDPE PAYE R FLAG PHA RM
  2477   "KRN",101, 8362,10,4, 0)
  2478   8361^TR^21 0^
  2479   "KRN",101, 8362,10,4, "^")
  2480   RCDPE PAYE R FLAG TRI C
  2481   "KRN",101, 8362,10,5, 0)
  2482   1697^Q^900 ^
  2483   "KRN",101, 8362,10,5, "^")
  2484   VALM QUIT
  2485   "KRN",101, 8362,26)
  2486   D SHOW^VAL M
  2487   "KRN",101, 8362,28)
  2488   Select Act ion:
  2489   "KRN",101, 8362,99)
  2490   64572,4511 7
  2491   "KRN",101, 8363,-1)
  2492   0^19
  2493   "KRN",101, 8363,0)
  2494   RCDP LIST  OF RECEIPT S PROCESS^ Receipt Pr ocessing^^ A^^^^^^^^A CCOUNTS RE CEIVABLE
  2495   "KRN",101, 8363,20)
  2496   D RP^RCDPR L
  2497   "KRN",101, 8363,99)
  2498   64572,4511 7
  2499   "KRN",101, 8364,-1)
  2500   0^18
  2501   "KRN",101, 8364,0)
  2502   RCDP LIST  OF RECEIPT S MENU^Lis t of Recei pts Menu^^ M^^^^^^^^
  2503   "KRN",101, 8364,4)
  2504   26^4
  2505   "KRN",101, 8364,10,0)
  2506   ^101.01PA^ 2^2
  2507   "KRN",101, 8364,10,1, 0)
  2508   8363^RP^10 0^
  2509   "KRN",101, 8364,10,1, "^")
  2510   RCDP LIST  OF RECEIPT S PROCESS
  2511   "KRN",101, 8364,10,2, 0)
  2512   1697^Q^900 ^
  2513   "KRN",101, 8364,10,2, "^")
  2514   VALM QUIT
  2515   "KRN",101, 8364,26)
  2516   D SHOW^VAL M
  2517   "KRN",101, 8364,99)
  2518   64572,4511 7
  2519   "KRN",409. 61,423,-1)
  2520   0^1
  2521   "KRN",409. 61,423,0)
  2522   RCDP RECEI PT PROFILE ^1^^80^7^1 6^1^1^Tran saction^RC DP RECEIPT  PROFILE M ENU^Receip t Profile^ 1^^1
  2523   "KRN",409. 61,423,1)
  2524   ^VALM HIDD EN ACTIONS
  2525   "KRN",409. 61,423,"AR RAY")
  2526    ^TMP("RCD PRPLM",$J)
  2527   "KRN",409. 61,423,"CO L",0)
  2528   ^409.621^8 ^7
  2529   "KRN",409. 61,423,"CO L",2,0)
  2530   ACCOUNT^7^ 26^Account
  2531   "KRN",409. 61,423,"CO L",3,0)
  2532   PAY DATE^3 5^8^Pay Da te
  2533   "KRN",409. 61,423,"CO L",4,0)
  2534   PAY AMOUNT ^63^7^Pay  Amt
  2535   "KRN",409. 61,423,"CO L",5,0)
  2536   PROC AMOUN T^72^8^Pro c Amt
  2537   "KRN",409. 61,423,"CO L",6,0)
  2538   OPEN BY^45 ^7^Open By
  2539   "KRN",409. 61,423,"CO L",7,0)
  2540   TRANS NUMB ER^2^1^#
  2541   "KRN",409. 61,423,"CO L",8,0)
  2542   EDIT BY^54 ^7^Edit By
  2543   "KRN",409. 61,423,"CO L","B","AC COUNT",2)
  2544  
  2545   "KRN",409. 61,423,"CO L","B","BY ",6)
  2546  
  2547   "KRN",409. 61,423,"CO L","B","ED IT BY",8)
  2548  
  2549   "KRN",409. 61,423,"CO L","B","OP EN BY",6)
  2550  
  2551   "KRN",409. 61,423,"CO L","B","PA Y AMOUNT", 4)
  2552  
  2553   "KRN",409. 61,423,"CO L","B","PA Y DATE",3)
  2554  
  2555   "KRN",409. 61,423,"CO L","B","PR OC AMOUNT" ,5)
  2556  
  2557   "KRN",409. 61,423,"CO L","B","TR ANS NUMBER ",7)
  2558  
  2559   "KRN",409. 61,423,"FN L")
  2560   D EXIT^RCD PRPLM
  2561   "KRN",409. 61,423,"HD R")
  2562   D HDR^RCDP RPLM
  2563   "KRN",409. 61,423,"IN IT")
  2564   D INIT^RCD PRPLM
  2565   "KRN",409. 61,726,-1)
  2566   0^3
  2567   "KRN",409. 61,726,0)
  2568   RCDPE APAR  EEOB LIST ^1^^93^6^1 9^1^1^EEOB  Line^RCDP E APAR EEO B LIST MEN U^AUTOPOST  - AWAIT R ESOLUTION^ 1^^1
  2569   "KRN",409. 61,726,1)
  2570   ^VALM HIDD EN ACTIONS
  2571   "KRN",409. 61,726,"AR RAY")
  2572    ^TMP("RCD PE-APAR_EE OB_WL",$J)
  2573   "KRN",409. 61,726,"CO L",0)
  2574   ^409.621^3 ^2
  2575   "KRN",409. 61,726,"CO L",2,0)
  2576   PAYER_LN^9 ^50^Payer  Name/ID
  2577   "KRN",409. 61,726,"CO L",3,0)
  2578   DATE POSTE D^81^12^Da te Posted
  2579   "KRN",409. 61,726,"CO L","B","DA TE POSTED" ,3)
  2580  
  2581   "KRN",409. 61,726,"CO L","B","PA YER_LN",2)
  2582  
  2583   "KRN",409. 61,726,"FN L")
  2584   D EXIT^RCD PEAA1
  2585   "KRN",409. 61,726,"HD R")
  2586   D HDR^RCDP EAA1
  2587   "KRN",409. 61,726,"IN IT")
  2588   D INIT^RCD PEAA1
  2589   "KRN",409. 61,795,-1)
  2590   0^2
  2591   "KRN",409. 61,795,0)
  2592   RCDPE PAYE R FLAGS^1^ ^95^4^19^1 ^1^^RCDPE  PAYER FLAG S MENU^Pay er Pharmac y/Tricare^ 1^^1
  2593   "KRN",409. 61,795,1)
  2594   ^VALM HIDD EN ACTIONS
  2595   "KRN",409. 61,795,"AR RAY")
  2596    ^TMP("RCD PEP",$J)
  2597   "KRN",409. 61,795,"CO L",0)
  2598   ^409.621^6 ^6
  2599   "KRN",409. 61,795,"CO L",1,0)
  2600   LINE^1^4^  #
  2601   "KRN",409. 61,795,"CO L",2,0)
  2602   PAYER^6^55 ^PAYER^^1
  2603   "KRN",409. 61,795,"CO L",3,0)
  2604   PHARMACY F LAG^75^2^R x
  2605   "KRN",409. 61,795,"CO L",4,0)
  2606   TRICARE FL AG^79^2^TR
  2607   "KRN",409. 61,795,"CO L",5,0)
  2608   ID^63^10^T IN
  2609   "KRN",409. 61,795,"CO L",6,0)
  2610   DATE ADDED ^82^12^DAT E ADDED
  2611   "KRN",409. 61,795,"CO L","AIDENT ",1,2)
  2612  
  2613   "KRN",409. 61,795,"CO L","B","DA TE ADDED", 6)
  2614  
  2615   "KRN",409. 61,795,"CO L","B","ID ",5)
  2616  
  2617   "KRN",409. 61,795,"CO L","B","LI NE",1)
  2618  
  2619   "KRN",409. 61,795,"CO L","B","PA YER",2)
  2620  
  2621   "KRN",409. 61,795,"CO L","B","PH ARMACY FLA G",3)
  2622  
  2623   "KRN",409. 61,795,"CO L","B","TR ICARE FLAG ",4)
  2624  
  2625   "KRN",409. 61,795,"FN L")
  2626   D EXIT^RCD PEP
  2627   "KRN",409. 61,795,"HD R")
  2628   D HDR^RCDP EP
  2629   "KRN",409. 61,795,"HL P")
  2630   D HELP^RCD PEP
  2631   "KRN",409. 61,795,"IN IT")
  2632   D INIT^RCD PEP
  2633   "KRN",409. 61,796,-1)
  2634   0^4
  2635   "KRN",409. 61,796,0)
  2636   RCDP LIST  OF RECEIPT S REPORT^1 ^^80^6^20^ 1^1^^RCDP  LIST OF RE CEIPTS MEN U^LIST OF  RECEIPTS^1 ^^1
  2637   "KRN",409. 61,796,1)
  2638   ^VALM HIDD EN ACTIONS
  2639   "KRN",409. 61,796,"AR RAY")
  2640  
  2641   "KRN",409. 61,796,"CO L",0)
  2642   ^409.621^9 ^9
  2643   "KRN",409. 61,796,"CO L",1,0)
  2644   DATE OPENE D^7^8^DATE
  2645   "KRN",409. 61,796,"CO L",2,0)
  2646   RECEIPT^16 ^12^RECEIP T
  2647   "KRN",409. 61,796,"CO L",3,0)
  2648   TYPE^29^5^ TYPE
  2649   "KRN",409. 61,796,"CO L",4,0)
  2650   USER INITI ALS^35^2^U S
  2651   "KRN",409. 61,796,"CO L",5,0)
  2652   COUNT^38^5 ^COUNT
  2653   "KRN",409. 61,796,"CO L",6,0)
  2654   AMOUNT^48^ 6^AMOUNT
  2655   "KRN",409. 61,796,"CO L",7,0)
  2656   FMS DOC^56 ^13^FMS CR  DOC
  2657   "KRN",409. 61,796,"CO L",8,0)
  2658   STATUS^73^ 6^STATUS
  2659   "KRN",409. 61,796,"CO L",9,0)
  2660   LINE^1^4^  #
  2661   "KRN",409. 61,796,"CO L","B","AM OUNT",6)
  2662  
  2663   "KRN",409. 61,796,"CO L","B","CO UNT",5)
  2664  
  2665   "KRN",409. 61,796,"CO L","B","DA TE OPENED" ,1)
  2666  
  2667   "KRN",409. 61,796,"CO L","B","FM S DOC",7)
  2668  
  2669   "KRN",409. 61,796,"CO L","B","LI NE",9)
  2670  
  2671   "KRN",409. 61,796,"CO L","B","RE CEIPT",2)
  2672  
  2673   "KRN",409. 61,796,"CO L","B","ST ATUS",8)
  2674  
  2675   "KRN",409. 61,796,"CO L","B","TY PE",3)
  2676  
  2677   "KRN",409. 61,796,"CO L","B","US ER INITIAL S",4)
  2678  
  2679   "KRN",409. 61,796,"FN L")
  2680   D EXIT^RCD PRL
  2681   "KRN",409. 61,796,"HD R")
  2682   D HDR^RCDP RL
  2683   "KRN",409. 61,796,"HL P")
  2684   D HELP^RCD PRL
  2685   "KRN",409. 61,796,"IN IT")
  2686   D INIT^RCD PRL
  2687   "KRN",8989 .51,941,-1 )
  2688   0^1
  2689   "KRN",8989 .51,941,0)
  2690   RCDPE APAR ^Display u nposted EE OBs by use r pref^1
  2691   "KRN",8989 .51,941,1)
  2692   F
  2693   "KRN",8989 .51,941,6)
  2694   F
  2695   "KRN",8989 .51,941,20 ,0)
  2696   ^^21^21^31 70821^
  2697   "KRN",8989 .51,941,20 ,1,0)
  2698   The AUTO-P OST - AWAI TING RESOL UTION scre en that is  generated  when
  2699   "KRN",8989 .51,941,20 ,2,0)
  2700   executing  the RCDPE  AUTO-POST  AWAITING R ESOLUTION  option pro vides the
  2701   "KRN",8989 .51,941,20 ,3,0)
  2702   capability  to filter  the data  displayed  via the Ch ange View  action. Th e
  2703   "KRN",8989 .51,941,20 ,4,0)
  2704   Change Vie w action s aves the f ilter pref erences by  user.
  2705   "KRN",8989 .51,941,20 ,5,0)
  2706    
  2707   "KRN",8989 .51,941,20 ,6,0)
  2708   Parameter  Instance                Possible  Value
  2709   "KRN",8989 .51,941,20 ,7,0)
  2710     
  2711   "KRN",8989 .51,941,20 ,8,0)
  2712   ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----
  2713   "KRN",8989 .51,941,20 ,9,0)
  2714   ALL_PAYERS /RANGE_OF_ PAYERS       3 fields :A/R;Start With;GoTo 
  2715   "KRN",8989 .51,941,20 ,10,0)
  2716                                           (e. g.,'R;AE;A EZ') 
  2717   "KRN",8989 .51,941,20 ,11,0)
  2718   Note: The  second and  third fie lds of ALL _PAYERS/RA NGE_OF_PAY ERS are on ly
  2719   "KRN",8989 .51,941,20 ,12,0)
  2720          pre sent When  the first  field is s et to 'R'  (Range of  Payers)
  2721   "KRN",8989 .51,941,20 ,13,0)
  2722    
  2723   "KRN",8989 .51,941,20 ,14,0)
  2724   MEDICAL/PH ARMACY                  1 field:  M/P/B
  2725   "KRN",8989 .51,941,20 ,15,0)
  2726   Note: M/P/ B (M)edica l (P)harma cy or (B)
  2727   "KRN",8989 .51,941,20 ,16,0)
  2728    
  2729   "KRN",8989 .51,941,20 ,17,0)
  2730   SORT                               2 fields :N/P/R/U;1 /0
  2731   "KRN",8989 .51,941,20 ,18,0)
  2732   Note: 1st  field D=Da te/Time ER A Filed, N =Payer Nam e, P=Amoun t Posted
  2733   "KRN",8989 .51,941,20 ,19,0)
  2734                    R=Au to Post Re ject Reaso n, R=Unpos ted Amount
  2735   "KRN",8989 .51,941,20 ,20,0)
  2736         2nd  field H=Hi ghest to L owest, L=L owest to H ighest
  2737   "KRN",8989 .51,941,20 ,21,0)
  2738                    Null  if first  field is N  or P
  2739   "KRN",8989 .51,941,30 ,0)
  2740   ^8989.513I ^1^1
  2741   "KRN",8989 .51,941,30 ,1,0)
  2742   1^200
  2743   "KRN",8989 .51,942,-1 )
  2744   0^2
  2745   "KRN",8989 .51,942,0)
  2746   RCDPE EDI  LOCKBOX WO RKLIST^ERA  Worklist  Change Vie w Paramete rs^1
  2747   "KRN",8989 .51,942,1)
  2748   F
  2749   "KRN",8989 .51,942,6)
  2750   F
  2751   "KRN",8989 .51,942,20 ,0)
  2752   ^^19^19^31 70913^
  2753   "KRN",8989 .51,942,20 ,1,0)
  2754   The ERA Li st - Workl ist screen  within th e ERA Work list optio n [RCDPE E DI LOCKBOX
  2755   "KRN",8989 .51,942,20 ,2,0)
  2756   WORKLIST]   provides  the capabi lity to fi lter the d ata displa yed via th e Change
  2757   "KRN",8989 .51,942,20 ,3,0)
  2758   View actio n. The Cha nge View a ction allo ws users t o change a nd save th eir
  2759   "KRN",8989 .51,942,20 ,4,0)
  2760   individual  filter pr eferences.
  2761   "KRN",8989 .51,942,20 ,5,0)
  2762     
  2763   "KRN",8989 .51,942,20 ,6,0)
  2764   Below is a  list of t he paramet er/value p airs (inst ances) for  the Chang e View 
  2765   "KRN",8989 .51,942,20 ,7,0)
  2766   action, wh ich are st ored using  this Para meter Defi nition.
  2767   "KRN",8989 .51,942,20 ,8,0)
  2768    
  2769   "KRN",8989 .51,942,20 ,9,0)
  2770    Parameter  Instance                Possibl e Value
  2771   "KRN",8989 .51,942,20 ,10,0)
  2772    --------- ---------- ---------- ---------- ---------- ---------- ---------- ---------
  2773   "KRN",8989 .51,942,20 ,11,0)
  2774    ERA_POSTI NG_STATUS                'U':Unp osted;'P': Posted;'B' :Both
  2775   "KRN",8989 .51,942,20 ,12,0)
  2776    ERA-EFT_M ATCH_STATU S             'N':Not  Matched;' M':Matched ;'B':Both
  2777   "KRN",8989 .51,942,20 ,13,0)
  2778    ALL_PAYER S/RANGE_OF _PAYERS       3 field s:A/R;Star tWith;GoTo  (e.g.,'R; AE;AEZ')
  2779   "KRN",8989 .51,942,20 ,14,0)
  2780    ERA_AUTO_ POSTING                  'A':Aut o-Posting; 'N':Non Au to-Posting ;'B':Both
  2781   "KRN",8989 .51,942,20 ,15,0)
  2782    ERA_CLAIM _TYPE                    'M':Med ical;'P':P harmacy;T: Tricare'A' :All
  2783   "KRN",8989 .51,942,20 ,16,0)
  2784    ERA_PAYME NT_TYPE                  'Z':Zer o;'P':Paym ent;'B':Bo th
  2785   "KRN",8989 .51,942,20 ,17,0)
  2786    
  2787   "KRN",8989 .51,942,20 ,18,0)
  2788   Note: The  second and  third fie lds of ALL _PAYERS/RA NGE_OF_PAY ERS are on ly
  2789   "KRN",8989 .51,942,20 ,19,0)
  2790         pres ent When t he first f ield is se t to 'R' ( Range of P ayers)
  2791   "KRN",8989 .51,942,30 ,0)
  2792   ^8989.513I ^1^1
  2793   "KRN",8989 .51,942,30 ,1,0)
  2794   1^200
  2795   "MBREQ")
  2796   1
  2797   "ORD",1,9. 2)
  2798   9.2;1;;;HE LP^XPDTA1; HLPF1^XPDI A1;HLPE1^X PDIA1;HLPF 2^XPDIA1;; HLPDEL^XPD IA1
  2799   "ORD",1,9. 2,0)
  2800   HELP FRAME
  2801   "ORD",11,3 .8)
  2802   3.8;11;;;M AILG^XPDTA 1;MAILGF1^ XPDIA1;MAI LGE1^XPDIA 1;MAILGF2^ XPDIA1;;MA ILGDEL^XPD IA1(%)
  2803   "ORD",11,3 .8,0)
  2804   MAIL GROUP
  2805   "ORD",15,1 01)
  2806   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  2807   "ORD",15,1 01,0)
  2808   PROTOCOL
  2809   "ORD",17,4 09.61)
  2810   409.61;17; 1;;;;LME1^ XPDIA1;;;L MDEL^XPDIA 1
  2811   "ORD",17,4 09.61,0)
  2812   LIST TEMPL ATE
  2813   "ORD",18,1 9)
  2814   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  2815   "ORD",18,1 9,0)
  2816   OPTION
  2817   "ORD",20,8 989.51)
  2818   8989.51;20 ;;;PAR1E1^ XPDTA2;PAR 1F1^XPDIA3 ;PAR1E1^XP DIA3;PAR1F 2^XPDIA3;; PAR1DEL^XP DIA3(%)
  2819   "ORD",20,8 989.51,0)
  2820   PARAMETER  DEFINITION
  2821   "PKG",561, -1)
  2822   1^1
  2823   "PKG",561, 0)
  2824   ACCOUNTS R ECEIVABLE^ PRCA^FMS
  2825   "PKG",561, 20,0)
  2826   ^9.402P^1^ 1
  2827   "PKG",561, 20,1,0)
  2828   2^^PRCAMRG
  2829   "PKG",561, 20,1,1)
  2830  
  2831   "PKG",561, 20,"B",2,1 )
  2832  
  2833   "PKG",561, 22,0)
  2834   ^9.49I^1^1
  2835   "PKG",561, 22,1,0)
  2836   4.5^295032 0^2950331
  2837   "PKG",561, 22,1,"PAH" ,1,0)
  2838   321^317120 1^52082464 4
  2839   "QUES","XP F1",0)
  2840   Y
  2841   "QUES","XP F1","??")
  2842   ^D REP^XPD H
  2843   "QUES","XP F1","A")
  2844   Shall I wr ite over y our |FLAG|  File
  2845   "QUES","XP F1","B")
  2846   YES
  2847   "QUES","XP F1","M")
  2848   D XPF1^XPD IQ
  2849   "QUES","XP F2",0)
  2850   Y
  2851   "QUES","XP F2","??")
  2852   ^D DTA^XPD H
  2853   "QUES","XP F2","A")
  2854   Want my da ta |FLAG|  yours
  2855   "QUES","XP F2","B")
  2856   YES
  2857   "QUES","XP F2","M")
  2858   D XPF2^XPD IQ
  2859   "QUES","XP I1",0)
  2860   YO
  2861   "QUES","XP I1","??")
  2862   ^D INHIBIT ^XPDH
  2863   "QUES","XP I1","A")
  2864   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  2865   "QUES","XP I1","B")
  2866   NO
  2867   "QUES","XP I1","M")
  2868   D XPI1^XPD IQ
  2869   "QUES","XP M1",0)
  2870   PO^VA(200, :EM
  2871   "QUES","XP M1","??")
  2872   ^D MG^XPDH
  2873   "QUES","XP M1","A")
  2874   Enter the  Coordinato r for Mail  Group '|F LAG|'
  2875   "QUES","XP M1","B")
  2876  
  2877   "QUES","XP M1","M")
  2878   D XPM1^XPD IQ
  2879   "QUES","XP O1",0)
  2880   Y
  2881   "QUES","XP O1","??")
  2882   ^D MENU^XP DH
  2883   "QUES","XP O1","A")
  2884   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  2885   "QUES","XP O1","B")
  2886   YES
  2887   "QUES","XP O1","M")
  2888   D XPO1^XPD IQ
  2889   "QUES","XP Z1",0)
  2890   Y
  2891   "QUES","XP Z1","??")
  2892   ^D OPT^XPD H
  2893   "QUES","XP Z1","A")
  2894   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  2895   "QUES","XP Z1","B")
  2896   NO
  2897   "QUES","XP Z1","M")
  2898   D XPZ1^XPD IQ
  2899   "QUES","XP Z2",0)
  2900   Y
  2901   "QUES","XP Z2","??")
  2902   ^D RTN^XPD H
  2903   "QUES","XP Z2","A")
  2904   Want to MO VE routine s to other  CPUs
  2905   "QUES","XP Z2","B")
  2906   NO
  2907   "QUES","XP Z2","M")
  2908   D XPZ2^XPD IQ
  2909   "RTN")
  2910   64
  2911   "RTN","PRC ABJ2")
  2912   0^54^B1478 0114
  2913   "RTN","PRC ABJ2",1,0)
  2914   PRCABJ2 ;A LB/SAB - N IGHTLY PRO CESS FOR A CCOUNTS RE CEIVABLE ; 07-JUL-15
  2915   "RTN","PRC ABJ2",2,0)
  2916    ;;4.5;Acc ounts Rece ivable;**3 04,321**;M ar 20, 199 5;Build 46
  2917   "RTN","PRC ABJ2",3,0)
  2918    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  2919   "RTN","PRC ABJ2",4,0)
  2920    ;
  2921   "RTN","PRC ABJ2",5,0)
  2922    ; read of  DGCR(399. 2 allowed  by DBIA 38 22
  2923   "RTN","PRC ABJ2",6,0)
  2924    ;
  2925   "RTN","PRC ABJ2",7,0)
  2926    Q
  2927   "RTN","PRC ABJ2",8,0)
  2928    ; Auto-au dit Paper  and Electr onic (EDI)  bills if  ready
  2929   "RTN","PRC ABJ2",9,0)
  2930   ABAUDIT ;
  2931   "RTN","PRC ABJ2",10,0 )
  2932    ; Local V ariables
  2933   "RTN","PRC ABJ2",11,0 )
  2934    ;    APIE N - Accoun ts Payable  (file #43 0) ien
  2935   "RTN","PRC ABJ2",12,0 )
  2936    ;
  2937   "RTN","PRC ABJ2",13,0 )
  2938    N APIEN,B ILLTYP,DIE ,DA,DR,DIR ,DIRUT,DTO UT,DUOUT,X ,Y,APD0,AP D202,FLG1, FLG2,FLG1E ,FLG2E,NBL IEN ; PRCA *4.5*321
  2939   "RTN","PRC ABJ2",14,0 )
  2940    N PRCABLN O,PRCAECME ,RATEIEN,R CPAPER,XX  ; PRCA*4.5 *321
  2941   "RTN","PRC ABJ2",15,0 )
  2942    ;
  2943   "RTN","PRC ABJ2",16,0 )
  2944    S APIEN=" "
  2945   "RTN","PRC ABJ2",17,0 )
  2946    ;
  2947   "RTN","PRC ABJ2",18,0 )
  2948    ;Check pa rameters t o see if i t needs to  run.
  2949   "RTN","PRC ABJ2",19,0 )
  2950    S FLG1=$$ GET1^DIQ(3 42,"1,",7. 05,"I")    ; Get the  value of t he auto-au dit medica l paper bi ll flag
  2951   "RTN","PRC ABJ2",20,0 )
  2952    S FLG2=$$ GET1^DIQ(3 42,"1,",7. 06,"I")    ; Get the  value of t he auto-au dit pharma cy paper b ill flag
  2953   "RTN","PRC ABJ2",21,0 )
  2954    S FLG1E=$ $GET1^DIQ( 342,"1,",7 .07,"I") ;  Get the v alue of th e auto-aud it medical  EDI bill  flag - PRC A*4.5*321
  2955   "RTN","PRC ABJ2",22,0 )
  2956    S FLG2E=$ $GET1^DIQ( 342,"1,",7 .08,"I") ;  Get the v alue of th e auto-aud it pharmac y EDI bill  flag - PR CA*4.5*321
  2957   "RTN","PRC ABJ2",23,0 )
  2958    ;
  2959   "RTN","PRC ABJ2",24,0 )
  2960    ; Quit if  all auto- audit para meters are  set to 'N o'
  2961   "RTN","PRC ABJ2",25,0 )
  2962    Q:('FLG1) &('FLG2)&( 'FLG1E)&(' FLG2E)  ;  PRCA*4.5*3 21
  2963   "RTN","PRC ABJ2",26,0 )
  2964    ;
  2965   "RTN","PRC ABJ2",27,0 )
  2966    ;retrieve  DB values
  2967   "RTN","PRC ABJ2",28,0 )
  2968    S NBLIEN= $O(^PRCA(4 30.3,"B"," NEW BILL", ""))  ; Ne w Bill Sta tus IEN
  2969   "RTN","PRC ABJ2",29,0 )
  2970    ;S CATIEN =$O(^PRCA( 430.2,"C", "RI",""))         ; R eimbursabl e Insuranc e IEN  ; r emoved PRC A*4.5*321
  2971   "RTN","PRC ABJ2",30,0 )
  2972    ;S HICD=$ O(^PRCA(43 0.6,"B","H I",""))           ; H ealth insu rance IEN   ; removed  PRCA*4.5* 321
  2973   "RTN","PRC ABJ2",31,0 )
  2974    ;S ACTIVE =$O(^PRCA( 430.3,"B", "ACTIVE"," "))    ; N ew Bill St atus IEN   ; removed  PRCA*4.5*3 21
  2975   "RTN","PRC ABJ2",32,0 )
  2976    S BILLTYP =$O(^DGCR( 399.3,"B", "REIMBURSA BLE INS.", ""))  ; Bi ll Type IE N
  2977   "RTN","PRC ABJ2",33,0 )
  2978    ;S RCPAPE R=1 ; Fiel d 27 in ^D GCR(399 ;  0 - is ele ctronic, 1  - FORCE L OCAL PRINT   ; remove d PRCA*4.5 *321
  2979   "RTN","PRC ABJ2",34,0 )
  2980    ;
  2981   "RTN","PRC ABJ2",35,0 )
  2982    Q:NBLIEN= ""
  2983   "RTN","PRC ABJ2",36,0 )
  2984    ;
  2985   "RTN","PRC ABJ2",37,0 )
  2986    F  S APIE N=$O(^PRCA (430,"AC", NBLIEN,API EN)) Q:'AP IEN  D
  2987   "RTN","PRC ABJ2",38,0 )
  2988    . S APD0= $G(^PRCA(4 30,APIEN,0 ))   ; Pat ient info
  2989   "RTN","PRC ABJ2",39,0 )
  2990    . S APD20 2=$G(^PRCA (430,APIEN ,202))   ; Insured in fo
  2991   "RTN","PRC ABJ2",40,0 )
  2992    . Q:$$GET 1^DIQ(399, APIEN_",", .07,"I")'= BILLTYP  ;  Bill type  is not Re imbursable  Insurance . Skip
  2993   "RTN","PRC ABJ2",41,0 )
  2994    . ; BEGIN  - PRCA*4. 5*321
  2995   "RTN","PRC ABJ2",42,0 )
  2996    . Q:$$GET 1^DIQ(430, APIEN_",", 7,"I")=""        ; Qu it if no P ATIENT IEN
  2997   "RTN","PRC ABJ2",43,0 )
  2998    . Q:$$GET 1^DIQ(430, APIEN_",", 9,"I")=""        ; Qu it if no D EBTOR info rmation
  2999   "RTN","PRC ABJ2",44,0 )
  3000    . Q:$$GET 1^DIQ(430, APIEN_",", 239,"I")=" "     ; qu it if no s ubscriber  name store d
  3001   "RTN","PRC ABJ2",45,0 )
  3002    . Q:$$GET 1^DIQ(430, APIEN_",", 243,"I")=" "     ; qu it if no g roup name  stored
  3003   "RTN","PRC ABJ2",46,0 )
  3004    . Q:$$GET 1^DIQ(430, APIEN_",", 244,"I")=" "     ; qu it if no g roup numbe r stored
  3005   "RTN","PRC ABJ2",47,0 )
  3006    . Q:$$BIL LREJ^PRCAU DT(APIEN)   ; PRCA*4. 5*321 - cl aim has re ject messa ges, do no t audit
  3007   "RTN","PRC ABJ2",48,0 )
  3008    . ;
  3009   "RTN","PRC ABJ2",49,0 )
  3010    . S RATEI EN=$$GET1^ DIQ(399,AP IEN_",",.0 7,"I") ; G et bill's  rate type  ; IA 4118
  3011   "RTN","PRC ABJ2",50,0 )
  3012    . Q:'RATE IEN
  3013   "RTN","PRC ABJ2",51,0 )
  3014    . ; A rat e type is  auto-audit ed if BILL  RESULTING  FROM fiel d is non-n ull
  3015   "RTN","PRC ABJ2",52,0 )
  3016    . Q:'$$GE T1^DIQ(399 .3,RATEIEN _",",.11," I")  ; Qui t if not a n auto-aud it rate ty pe
  3017   "RTN","PRC ABJ2",53,0 )
  3018    . ;Read o n IB file  #399 field  #27 cover ed by ICR  #3820
  3019   "RTN","PRC ABJ2",54,0 )
  3020    . S RCPAP ER=$$GET1^ DIQ(399,AP IEN_",",27 ,"I") ; 0  - is elect ronic, 1 -  is paper
  3021   "RTN","PRC ABJ2",55,0 )
  3022    . ;Get th e Bill num ber to che ck if it i s a Pharma cy bill
  3023   "RTN","PRC ABJ2",56,0 )
  3024    . S PRCAB LNO=$$GET1 ^DIQ(430,A PIEN_",",. 01,"I")
  3025   "RTN","PRC ABJ2",57,0 )
  3026    . S PRCAE CME=$$GETE CME^RCDPEN R1(PRCABLN O)
  3027   "RTN","PRC ABJ2",58,0 )
  3028    . I PRCAE CME="",'FL G1,RCPAPER  Q     ;Sk ip this pa per bill i f No Medic al process ing
  3029   "RTN","PRC ABJ2",59,0 )
  3030    . I PRCAE CME'="",'F LG2,RCPAPE R Q    ;Sk ip this pa per bill i f No Pharm acy proces sing
  3031   "RTN","PRC ABJ2",60,0 )
  3032    . I PRCAE CME="",'FL G1E,'RCPAP ER Q     ; Skip this  EDI bill i f No Medic al process ing
  3033   "RTN","PRC ABJ2",61,0 )
  3034    . I PRCAE CME'="",'F LG2E,'RCPA PER Q    ; Skip this  EDI bill i f No Pharm acy proces sing
  3035   "RTN","PRC ABJ2",62,0 )
  3036    . ;
  3037   "RTN","PRC ABJ2",63,0 )
  3038    . ; Bill  Passed all  checks no w call aut o-audit fo r this Bil l number
  3039   "RTN","PRC ABJ2",64,0 )
  3040    . D AUDIT X^PRCAUDT( APIEN)
  3041   "RTN","PRC ABJ2",65,0 )
  3042    Q
  3043   "RTN","PRC AUDT")
  3044   0^61^B5322 5243
  3045   "RTN","PRC AUDT",1,0)
  3046   PRCAUDT ;S F-ISC/YJK- AUDIT A NE W BILL/EDI T INCOMPLE TE AR ;10/ 17/96  5:3 3 PM
  3047   "RTN","PRC AUDT",2,0)
  3048   V ;;4.5;Ac counts Rec eivable;** 1,21,57,97 ,143,107,1 73,321**;M ar 20, 199 5;Build 46
  3049   "RTN","PRC AUDT",3,0)
  3050    ;;Per VHA  Directive  10-93-142 , this rou tine shoul d not be m odified.
  3051   "RTN","PRC AUDT",4,0)
  3052    NEW X,Y,L OOP,DIR
  3053   "RTN","PRC AUDT",5,0)
  3054    W ! S DIR ("B")="YES ",DIR("A") ="Do you w ant to loo p thru 'NE W BILLS'", DIR(0)="Y"  D ^DIR K  DIR G:$D(D IRUT) END  S LOOP=+Y
  3055   "RTN","PRC AUDT",6,0)
  3056    D AUDITB( 0,0,LOOP)
  3057   "RTN","PRC AUDT",7,0)
  3058    Q
  3059   "RTN","PRC AUDT",8,0)
  3060    ;
  3061   "RTN","PRC AUDT",9,0)
  3062   AUDITB(PRC ABN,PRAUTO A,LOOP) ;
  3063   "RTN","PRC AUDT",10,0 )
  3064    ; PRCABN  = the ien  of the ent ry to audi t or 0 for  batch ent ry above
  3065   "RTN","PRC AUDT",11,0 )
  3066    ; PRAUTOA  = 1 for a uto-audit
  3067   "RTN","PRC AUDT",12,0 )
  3068    ; LOOP =  1 if loopi ng through  bills, 0  if not
  3069   "RTN","PRC AUDT",13,0 )
  3070    N PRCA,PR CASEG,PREN D,PRQUIT,X ,XX,Y ; PR CA*4.5*321
  3071   "RTN","PRC AUDT",14,0 )
  3072    S PREND=0 ,PRCA("AUT O_AUDIT")= PRAUTOA
  3073   "RTN","PRC AUDT",15,0 )
  3074    F  D  Q:$ S(PREND:1, PRAUTOA:1, 1:0)
  3075   "RTN","PRC AUDT",16,0 )
  3076    . K PRCAB T
  3077   "RTN","PRC AUDT",17,0 )
  3078    . S PRQUI T=0 ; PRCA *4.5*321
  3079   "RTN","PRC AUDT",18,0 )
  3080    . S PRCA( "MESG")="* ** AUDITED  AND RELEA SED ***"
  3081   "RTN","PRC AUDT",19,0 )
  3082    . I LOOP, '$O(^PRCA( 430,"AC",1 8,PRCABN))  W !!,"***  Loop Done  ***",!! S  PREND=1 Q
  3083   "RTN","PRC AUDT",20,0 )
  3084    . I PRAUT OA S PRCA( "CKSITE")= "",PRCA("S ITE")=$P($ $BILL(PRCA BN),"-") K  PRCAT
  3085   "RTN","PRC AUDT",21,0 )
  3086    . I '$D(P RCA("CKSIT E")) D CKS ITE K:$D(P RCA("CKSIT E")) PRCAT  I '$D(PRC A("CKSITE" )) S PREND =1 Q
  3087   "RTN","PRC AUDT",22,0 )
  3088    . I LOOP  S PRCABN=$ O(^PRCA(43 0,"AC",18, PRCABN)) I  'PRCABN S  PREND=1 Q
  3089   "RTN","PRC AUDT",23,0 )
  3090    . I LOOP! PRAUTOA D   Q:PRQUIT
  3091   "RTN","PRC AUDT",24,0 )
  3092    .. I $$BI LLREJ(PRCA BN) S PRQU IT=1 Q   ;  PRCA*4.5* 321 - clai m has reje ct message s, do not  audit
  3093   "RTN","PRC AUDT",25,0 )
  3094    .. S PRCA TY=$P(^PRC A(430,PRCA BN,0),U,2) ,PRCA("SEG ")=$S(+$P( ^(0),U,21) >240:$P(^( 0),U,21),1 :"")
  3095   "RTN","PRC AUDT",26,0 )
  3096    .. S PRCA ("STATUS") =$P(^PRCA( 430,PRCABN ,0),U,8),P RCA("APPR" )=$P(^(0), U,18)
  3097   "RTN","PRC AUDT",27,0 )
  3098    . E  D  Q :PREND!PRQ UIT
  3099   "RTN","PRC AUDT",28,0 )
  3100    .. S DIC( "S")="S Z0 =$S($D(^PR CA(430.3,+ $P(^(0),U, 8),0)):$P( ^(0),U,3), 1:0) I Z0= 104"
  3101   "RTN","PRC AUDT",29,0 )
  3102    .. D DIC  I '$G(PRCA BN) S PREN D=1 Q
  3103   "RTN","PRC AUDT",30,0 )
  3104    .. I $$BI LLREJ(PRCA BN) D  S P RQUIT=1 Q    ; PRCA*4 .5*321
  3105   "RTN","PRC AUDT",31,0 )
  3106    ... D PAU SE("Claim  has reject  messages,  can not b e audited" )
  3107   "RTN","PRC AUDT",32,0 )
  3108    . ;
  3109   "RTN","PRC AUDT",33,0 )
  3110    . S PRCAK T=$S($P(^P RCA(430,PR CABN,0),U, 2)]"":$P(^ (0),U,2),1 :"")
  3111   "RTN","PRC AUDT",34,0 )
  3112    . I +PRCA KT'>0 D:$G (PRAUTOA)  SETERR("NO  CATEGORY  DEFINED FO R BILL "_$ $BILL(PRCA BN)) D END  Q
  3113   "RTN","PRC AUDT",35,0 )
  3114    . S PRCAR I=$O(^PRCA (430.2,"AC ",21,0))
  3115   "RTN","PRC AUDT",36,0 )
  3116    . I $P(^P RCA(430,PR CABN,0),U, 21)="" S X =PRCABN D: PRCARI=PRC AKT SEGMT  S:'$D(Y) Y =-1 S PRCA SEG=$S(PRC ARI=PRCAKT &(Y<1):"", PRCARI=PRC AKT:Y,$D(^ PRCA(430.2 ,PRCAKT,0) ):$P(^(0), U,3),1:"") ,$P(^PRCA( 430,PRCABN ,0),U,21)= PRCASEG
  3117   "RTN","PRC AUDT",37,0 )
  3118    . S PRCAT =$S($D(^PR CA(430.2,P RCAKT,0)): $P(^(0),U, 6),1:"") I  PRCAT=""  D:$G(PRAUT OA) SETERR ("NO CATEG ORY TYPE D EFINED FOR  BILL "_$$ BILL(PRCAB N)) D END  Q
  3119   "RTN","PRC AUDT",38,0 )
  3120    . I $P(^P RCA(430.2, PRCAKT,0), U,7)=24 S  PRCAT("C") =1,Z0=$P(^ PRCA(430,P RCABN,0),U ,16) S:+Z0 '>0 Z0=PRC AKT S $P(^ PRCA(430,P RCABN,0),U ,21)=$S($D (^PRCA(430 .2,+Z0,0)) :$P(^(0),U ,3),1:0) K  Z0,PRCAKT
  3121   "RTN","PRC AUDT",39,0 )
  3122    . ;
  3123   "RTN","PRC AUDT",40,0 )
  3124    . I '$G(P RAUTOA) D  DISPL,DISP LACC^PRCAF UT D  Q:PR END
  3125   "RTN","PRC AUDT",41,0 )
  3126    .. I $D(P RCA("EXIT" )) S PREND =1 Q 
  3127   "RTN","PRC AUDT",42,0 )
  3128    .. D MESS G
  3129   "RTN","PRC AUDT",43,0 )
  3130    . S PRCAR ETN=0,PRCA OK=$G(PRAU TOA)
  3131   "RTN","PRC AUDT",44,0 )
  3132    . I '$G(P RAUTOA) D  ASK I $D(P RCA("EXIT" )) D END S  PREND=1 Q
  3133   "RTN","PRC AUDT",45,0 )
  3134    . I PRCAO K=1 D  D:$ D(PRCA("EX IT")) END  Q
  3135   "RTN","PRC AUDT",46,0 )
  3136    .. K PRCA ("EXIT") D  MTCHK I $ D(PRCA("EX IT")) Q
  3137   "RTN","PRC AUDT",47,0 )
  3138    .. D:PRCA T="T" THIR D^PRCAUDT1
  3139   "RTN","PRC AUDT",48,0 )
  3140    .. I +$P( ^PRCA(430, PRCABN,0), U,5)'>0 D  CAUSED^PRC AUDT1 Q:PR CAOK=0
  3141   "RTN","PRC AUDT",49,0 )
  3142    .. D COMM ENTS^PRCAU T3 Q:$D(PR CA("EXIT") )
  3143   "RTN","PRC AUDT",50,0 )
  3144    .. S PRCA SIG=0 D SI G K PRCA(" EXIT") Q:P RCASIG=0
  3145   "RTN","PRC AUDT",51,0 )
  3146    .. D UPBA LN^PRCAUDT 1,UPSEG
  3147   "RTN","PRC AUDT",52,0 )
  3148    .. I '$$A CCK^PRCAAC C(PRCABN), ("^28^29^" '[("^"_$G( PRCAKT)_"^ ")) D EN^P RCAFBD(PRC ABN,.ERR)
  3149   "RTN","PRC AUDT",53,0 )
  3150    .. I $G(P RCAKT)=28  D EN^PRCAC PV(PRCABN, .ERR) S:ER R<0 PRCA(" MESG")="FM S document  created .  . . "
  3151   "RTN","PRC AUDT",54,0 )
  3152    .. K PRCA ("EXIT")
  3153   "RTN","PRC AUDT",55,0 )
  3154    .. I +$G( ERR)>0 D   D END Q
  3155   "RTN","PRC AUDT",56,0 )
  3156    ... N Z,Z 0,Z1
  3157   "RTN","PRC AUDT",57,0 )
  3158    ... S Z=" Unable to  create FMS  Billing D ocument: " ,Z0=$P(ERR ,U,2),Z1=" Status rem ains NEW B ILL."
  3159   "RTN","PRC AUDT",58,0 )
  3160    ... I '$G (PRAUTOA)  D
  3161   "RTN","PRC AUDT",59,0 )
  3162    .... W *7 ,!!,Z,!,?1 0,Z0,!!,Z1 ,!! H 3
  3163   "RTN","PRC AUDT",60,0 )
  3164    ... E  D
  3165   "RTN","PRC AUDT",61,0 )
  3166    .... D SE TERR(Z),SE TERR(Z0),S ETERR(Z1)
  3167   "RTN","PRC AUDT",62,0 )
  3168    ... S PRC A("STATUS" )=18 D UPS TATS^PRCAU T2
  3169   "RTN","PRC AUDT",63,0 )
  3170    ... ;
  3171   "RTN","PRC AUDT",64,0 )
  3172    .. I '$G( PRAUTOA) D  SIG1 W !, PRCA("MESG ")
  3173   "RTN","PRC AUDT",65,0 )
  3174    .. D END
  3175   "RTN","PRC AUDT",66,0 )
  3176    . I PRCAR ETN=1,'$G( PRAUTOA) D  RETN^PRCA UDT1 Q
  3177   "RTN","PRC AUDT",67,0 )
  3178    . D END
  3179   "RTN","PRC AUDT",68,0 )
  3180    D END
  3181   "RTN","PRC AUDT",69,0 )
  3182    Q
  3183   "RTN","PRC AUDT",70,0 )
  3184    ;
  3185   "RTN","PRC AUDT",71,0 )
  3186   END L -^PR CA(430,+$G (PRCABN))  K %,DA,PRC AKT,PRCATY ,PRCANM,PR CARETN,PRC AOK,PRCAT, DIC,DIE,DR ,ERR,PRCAS IG,J,Z0,D0 ,DI,PRC,PR CARI,DIR,D IRUT,DIROU T,DUOUT
  3187   "RTN","PRC AUDT",72,0 )
  3188    D CLEAN^D ILF
  3189   "RTN","PRC AUDT",73,0 )
  3190    Q
  3191   "RTN","PRC AUDT",74,0 )
  3192    ;
  3193   "RTN","PRC AUDT",75,0 )
  3194    ;======== ========== ====== SUB ROUTINES = ========== ========== =====
  3195   "RTN","PRC AUDT",76,0 )
  3196   BULL(PRCAB N) ; Send  a bulletin  for auto  audit erro rs
  3197   "RTN","PRC AUDT",77,0 )
  3198    ; PRCABN  = ien of b ill in fil e 430
  3199   "RTN","PRC AUDT",78,0 )
  3200    N XMBODY, XMB,XMINST R,XMTYPE,X MFULL,XMTO ,XMZ,XMERR ,PRCAE,CT, Z
  3201   "RTN","PRC AUDT",79,0 )
  3202    S XMTO("I :G.RCDPE P AYMENTS")= "",CT=0
  3203   "RTN","PRC AUDT",80,0 )
  3204    S CT=CT+1 ,PRCAE(CT) ="The foll owing prob lem(s) wer e encounte red when a ttempting  to auto-au dit a bill ",CT=CT+1, PRCAE(CT)= "from IB's  electroni c return m essages"
  3205   "RTN","PRC AUDT",81,0 )
  3206    S CT=CT+1 ,PRCAE(CT) =" ",Z=0
  3207   "RTN","PRC AUDT",82,0 )
  3208    F  S Z=$O (^TMP($J," PRCA_AUTO_ AUDIT_ERRO R",Z)) Q:' Z  S CT=CT +1,PRCAE(C T)=$G(^(Z) )
  3209   "RTN","PRC AUDT",83,0 )
  3210    S XMBODY= "PRCAE"
  3211   "RTN","PRC AUDT",84,0 )
  3212    D SENDMSG ^XMXAPI("" ,"AUTO AUD IT FAILED  FOR BILL " _$$BILL(PR CABN),XMBO DY,.XMTO)
  3213   "RTN","PRC AUDT",85,0 )
  3214    Q
  3215   "RTN","PRC AUDT",86,0 )
  3216    ;
  3217   "RTN","PRC AUDT",87,0 )
  3218   DIC S DIC= "^PRCA(430 ,",DIC(0)= "AEQM" D B ILLN^PRCAU TL Q
  3219   "RTN","PRC AUDT",88,0 )
  3220   DIE W ! S  DA=PRCABN, DIC="^PRCA (430,",PRC A("LOCK")= 0 D LOCKF^ PRCAWO1 Q: PRCA("LOCK ")=1  S DI E=DIC
  3221   "RTN","PRC AUDT",89,0 )
  3222    I '$$ACCK ^PRCAACC(P RCABN),("^ 27^28^"'[( "^"_PRCAKT _"^")) D C PLK^PRCAFU T(PRCABN)
  3223   "RTN","PRC AUDT",90,0 )
  3224    Q:$D(PRCA ("EXIT"))   S DR="[PR CAE AUDIT] " D ^DIE K  DIE,DR Q
  3225   "RTN","PRC AUDT",91,0 )
  3226   DISPL ;dis play the a ccounts re ceivable d ata user h as entered .
  3227   "RTN","PRC AUDT",92,0 )
  3228    Q:'$D(PRC ABN)  NEW  DIC,L,FR,T O,FLDS,IOP ,BY
  3229   "RTN","PRC AUDT",93,0 )
  3230    S IOP=IO( 0),DIC="^P RCA(430,", FLDS="[PRC A DISP AUD IT]",(FR,T O)=PRCABN, L=0,BY="@N UMBER" D E N1^DIP,WOB IL^PRCAUDT 1 Q
  3231   "RTN","PRC AUDT",94,0 )
  3232   ASK S %=2  W !,"IS TH IS DATA CO RRECT" D Y N^DICN I % <0 S PRCA( "EXIT")=""  Q
  3233   "RTN","PRC AUDT",95,0 )
  3234    I %=0 D M 1^PRCAMESG  G ASK
  3235   "RTN","PRC AUDT",96,0 )
  3236    I %=1 S P RCAOK=1 Q
  3237   "RTN","PRC AUDT",97,0 )
  3238   ASK1 S %=2  W !!,"Do  you want t o edit thi s informat ion " D YN ^DICN I %< 0 S PRCA(" EXIT")=""  Q
  3239   "RTN","PRC AUDT",98,0 )
  3240    I %=0 D M 2^PRCAMESG  G ASK1
  3241   "RTN","PRC AUDT",99,0 )
  3242    I %=1 D D IE,DISPL,D ISPLACC^PR CAFUT G AS K
  3243   "RTN","PRC AUDT",100, 0)
  3244   ASK2 S %=2  W !!,"The n do you w ant to ret urn this b ill to the  service"  D YN^DICN  I %<0 S PR CA("EXIT") ="" Q
  3245   "RTN","PRC AUDT",101, 0)
  3246    Q:%=2  I  %=0 W !,"A nswer 'Y'  (YES) or ' N' (NO)" G  ASK2
  3247   "RTN","PRC AUDT",102, 0)
  3248   ASK3 S %=2  W !,"Are  you sure y ou want to  return" D  YN^DICN I  %<0 S PRC A("EXIT")= "" Q
  3249   "RTN","PRC AUDT",103, 0)
  3250    I %=0 W " Answer 'Y'  (YES) if  you want t o return t his bill t o the serv ice that o riginated  it.  If no t, answer  'N' (NO)."  G ASK3
  3251   "RTN","PRC AUDT",104, 0)
  3252    I %=1 S P RCARETN=1  Q
  3253   "RTN","PRC AUDT",105, 0)
  3254    Q  ;end o f ASK
  3255   "RTN","PRC AUDT",106, 0)
  3256   SIG N PRCA DUZ
  3257   "RTN","PRC AUDT",107, 0)
  3258    I $G(PRAU TOA) S PRC ADUZ=+$O(^ VA(200,"B" ,"PRCA,AUT OAUDIT",0) ),PRCANM=" AUTO-AUDIT "
  3259   "RTN","PRC AUDT",108, 0)
  3260    I '$G(PRA UTOA) S DA =PRCABN D  SIG^PRCASI G
  3261   "RTN","PRC AUDT",109, 0)
  3262    D NOW^%DT C I $D(PRC ANM) S $P( ^PRCA(430, PRCABN,9), U,1,3)=$S( '$G(PRAUTO A):+DUZ,1: PRCADUZ)_U _PRCANM_U_ %,PRCASIG= 1
  3263   "RTN","PRC AUDT",110, 0)
  3264    Q
  3265   "RTN","PRC AUDT",111, 0)
  3266   SIG1 S PRC ANM=$P($G( ^VA(200,DU Z,20)),U,2 ) I PRCANM ]"" D EN^P RCASIG(.PR CANM,DUZ,P RCABN_+$P( ^PRCA(430, PRCABN,0), U,3)) S $P (^PRCA(430 ,PRCABN,9) ,U,2)=PRCA NM
  3267   "RTN","PRC AUDT",112, 0)
  3268    Q
  3269   "RTN","PRC AUDT",113, 0)
  3270   MESSG Q
  3271   "RTN","PRC AUDT",114, 0)
  3272   SEGMT D:$D (^DGCR(399 ,PRCABN))  ^IBCAMS S: '$D(^DGCR( 399,PRCABN )) Y=297 Q
  3273   "RTN","PRC AUDT",115, 0)
  3274   UPSEG ;
  3275   "RTN","PRC AUDT",116, 0)
  3276    S PRCAT=$ P(^PRCA(43 0,PRCABN,0 ),U,2),$P( ^(0),U,21) =""
  3277   "RTN","PRC AUDT",117, 0)
  3278    D SEGMT^P RCAEOL
  3279   "RTN","PRC AUDT",118, 0)
  3280    Q
  3281   "RTN","PRC AUDT",119, 0)
  3282   CKSITE ;ch eck site p arameter a nd user nu mber.
  3283   "RTN","PRC AUDT",120, 0)
  3284    NEW DIC
  3285   "RTN","PRC AUDT",121, 0)
  3286    S DIC="^D IC(4,",DIC (0)="QEAM" ,DIC("B")= $P($G(^RC( 342,1,0)), "^"),DIC(" A")="SITE:  " D ^DIC  Q:Y<0  S P RCA("SITE" )=+$$GET1^ DIQ(4,+Y,9 9) Q:'PRCA ("SITE")
  3287   "RTN","PRC AUDT",122, 0)
  3288    S PRCA("C KSITE")=""  Q
  3289   "RTN","PRC AUDT",123, 0)
  3290   MTCHK N PR CAI,PRCAMT ,PRCAMT1,Z ,Z0
  3291   "RTN","PRC AUDT",124, 0)
  3292    S PRCAMT1 =0 F PRCAI =0:0 S PRC AI=$O(^PRC A(430,PRCA BN,2,PRCAI )) Q:'PRCA I  S PRCAM T=+$P($G(^ (PRCAI,0)) ,"^",8) I  PRCAMT S P RCAMT1=PRC AMT1+1
  3293   "RTN","PRC AUDT",125, 0)
  3294    I PRCAMT1 =1 Q
  3295   "RTN","PRC AUDT",126, 0)
  3296    S Z="Curr ently, jus t one Fisc al Year am ount is se nt to FMS. ",Z0="This  bill has  "_PRCAMT1_ " entered  and should  be return ed to the  service."
  3297   "RTN","PRC AUDT",127, 0)
  3298    I '$G(PRA UTOA) D
  3299   "RTN","PRC AUDT",128, 0)
  3300    . W !!,?3 ,Z,?3,Z0,!
  3301   "RTN","PRC AUDT",129, 0)
  3302    E  D
  3303   "RTN","PRC AUDT",130, 0)
  3304    . D SETER R("BILL: " _$$BILL(PR CABN)),SET ERR(Z),SET ERR(Z0)
  3305   "RTN","PRC AUDT",131, 0)
  3306    S PRCA("E XIT")=""
  3307   "RTN","PRC AUDT",132, 0)
  3308    Q
  3309   "RTN","PRC AUDT",133, 0)
  3310    ;ZZPJH WI P 8/21/17
  3311   "RTN","PRC AUDT",134, 0)
  3312   AUDITX(PRC ABN) ; Aut o audit a  bill
  3313   "RTN","PRC AUDT",135, 0)
  3314    N PRAUTOA
  3315   "RTN","PRC AUDT",136, 0)
  3316    K ^TMP($J ,"PRCA_AUT O_AUDIT_ER ROR")
  3317   "RTN","PRC AUDT",137, 0)
  3318    L +^PRCA( 430,+$G(PR CABN)):5 I  '$T D SET ERR(PRCABN ,"ANOTHER  USER HAS L OCKED BILL  "_$$BILL( PRCABN))
  3319   "RTN","PRC AUDT",138, 0)
  3320    I '$D(^TM P($J,"PRCA _AUTO_AUDI T_ERROR"))  D AUDITB( PRCABN,1,0 )
  3321   "RTN","PRC AUDT",139, 0)
  3322    ;
  3323   "RTN","PRC AUDT",140, 0)
  3324    I $D(^TMP ($J,"PRCA_ AUTO_AUDIT _ERROR"))  D BULL(PRC ABN)
  3325   "RTN","PRC AUDT",141, 0)
  3326    K ^TMP($J ,"PRCA_AUT O_AUDIT_ER ROR")
  3327   "RTN","PRC AUDT",142, 0)
  3328    Q
  3329   "RTN","PRC AUDT",143, 0)
  3330    ;
  3331   "RTN","PRC AUDT",144, 0)
  3332   SETERR(TEX T) ;
  3333   "RTN","PRC AUDT",145, 0)
  3334    S ^TMP($J ,"PRCA_AUT O_AUDIT_ER ROR",+$O(^ TMP($J,"PR CA_AUTO_AU DIT_ERROR" ,""),-1)+1 )=TEXT
  3335   "RTN","PRC AUDT",146, 0)
  3336    Q
  3337   "RTN","PRC AUDT",147, 0)
  3338    ;
  3339   "RTN","PRC AUDT",148, 0)
  3340   BILL(PRCAB N) ; Retur ns AR bill  number in  external  format
  3341   "RTN","PRC AUDT",149, 0)
  3342    Q $P($G(^ PRCA(430,+ $G(PRCABN) ,0)),U)
  3343   "RTN","PRC AUDT",150, 0)
  3344    ;
  3345   "RTN","PRC AUDT",151, 0)
  3346   BILLREJ(PR CABN) ; EP  Check if  bill has r eject mess ages. Adde d for PRCA *4.5*321
  3347   "RTN","PRC AUDT",152, 0)
  3348    ; Input -  PRCABN -  Internal E ntry numbe r from ACC OUNTS RECE IVABLE fil e [#430]
  3349   "RTN","PRC AUDT",153, 0)
  3350    ; (Note -  file #399  has same  IEN as fil e #430)
  3351   "RTN","PRC AUDT",154, 0)
  3352    ; Output  - 1 - Reje ct message s 0 - No R eject mess ages
  3353   "RTN","PRC AUDT",155, 0)
  3354    N BILLNO, RETURN
  3355   "RTN","PRC AUDT",156, 0)
  3356    S BILLNO= $$GET1^DIQ (399,PRCAB N_",",.01, "I")
  3357   "RTN","PRC AUDT",157, 0)
  3358    S RETURN= $$BILLREJ^ IBJTU6(BIL LNO) ; API  call cove red by IA  6060
  3359   "RTN","PRC AUDT",158, 0)
  3360    Q RETURN
  3361   "RTN","PRC AUDT",159, 0)
  3362    ;
  3363   "RTN","PRC AUDT",160, 0)
  3364   PAUSE(MSG)  ; Display  message a nd pause t ill user r esponds
  3365   "RTN","PRC AUDT",161, 0)
  3366    ; INPUT -  MSG - Mes sage to di splay to u ser
  3367   "RTN","PRC AUDT",162, 0)
  3368    ; Output  - None
  3369   "RTN","PRC AUDT",163, 0)
  3370    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  3371   "RTN","PRC AUDT",164, 0)
  3372    W !!,MSG, !
  3373   "RTN","PRC AUDT",165, 0)
  3374    S DIR(0)= "EA"
  3375   "RTN","PRC AUDT",166, 0)
  3376    S DIR("A" )="Type <E nter> to c ontinue: "
  3377   "RTN","PRC AUDT",167, 0)
  3378    D ^DIR
  3379   "RTN","PRC AUDT",168, 0)
  3380    Q
  3381   "RTN","RCD PARC")
  3382   0^69^B2383 04719
  3383   "RTN","RCD PARC",1,0)
  3384   RCDPARC ;A LB/TJB - C ARC REPORT  ON PAYER  OR CARC CO DE ;9/15/1 4 3:00pm
  3385   "RTN","RCD PARC",2,0)
  3386    ;;4.5;Acc ounts Rece ivable;**3 03,321**;M ar 20, 199 5;Build 46
  3387   "RTN","RCD PARC",3,0)
  3388    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3389   "RTN","RCD PARC",4,0)
  3390    Q
  3391   "RTN","RCD PARC",5,0)
  3392    ; PRCA*4. 5*303 - CA RC and Pay er report
  3393   "RTN","RCD PARC",6,0)
  3394    ; DESCRIP TION :
  3395   "RTN","RCD PARC",7,0)
  3396    ;   The f ollowing g enerates a  report th at display s selected  or all
  3397   "RTN","RCD PARC",8,0)
  3398    ;   CARC  Codes and  Payers and  totals th e amounts  for each C ARC code.
  3399   "RTN","RCD PARC",9,0)
  3400    ;   sever al filters  may be us ed to limi t the CARC  codes or  Payer info rmation
  3401   "RTN","RCD PARC",10,0 )
  3402    ;   to be  displayed :
  3403   "RTN","RCD PARC",11,0 )
  3404   EN ; Entry  point for  Report
  3405   "RTN","RCD PARC",12,0 )
  3406    N DUOUT,D TOUT,DIR,X ,Y,RCDT1,R CDT2,RCDET ,ZTRTN,ZTS K,ZTDESC,Z TSAVE,ZTST OP,%ZIS,PO P,DTOK,DIV HDR,CRHDR
  3407   "RTN","RCD PARC",13,0 )
  3408    N RCDIV,R CINC,VAUTD ,RCRANGE,R CNP,RCJOB, RCNP1,RCPG ,RCNOW,RCH R,RCODE,RC RARC,RCSTO P,EX
  3409   "RTN","RCD PARC",14,0 )
  3410    S RCRARC= 0,RCSTOP=0
  3411   "RTN","RCD PARC",15,0 )
  3412    ; ICR 107 7 - Get di vision/sta tion
  3413   "RTN","RCD PARC",16,0 )
  3414    D DIVISIO N^VAUTOMA
  3415   "RTN","RCD PARC",17,0 )
  3416    I 'VAUTD& ($D(VAUTD) '=11) G AR CQ
  3417   "RTN","RCD PARC",18,0 )
  3418    ;
  3419   "RTN","RCD PARC",19,0 )
  3420    S DIR("A" )="(S)umma ry or(D)et ail Report  format?:  ",DIR(0)=" SA^S:Summa ry Informa tion only; D:Detail a nd Totals"
  3421   "RTN","RCD PARC",20,0 )
  3422    S DIR("B" )="SUMMARY " D ^DIR K  DIR
  3423   "RTN","RCD PARC",21,0 )
  3424    I $D(DTOU T)!$D(DUOU T)!(Y="")  G ARCQ
  3425   "RTN","RCD PARC",22,0 )
  3426    S RCDET=( $E(Y,1)="D ")
  3427   "RTN","RCD PARC",23,0 )
  3428    ; Get CAR C Codes fo r report
  3429   "RTN","RCD PARC",24,0 )
  3430    D GCARC^R CDPCRR(.RC ODE) G:RCS TOP ARCQ
  3431   "RTN","RCD PARC",25,0 )
  3432    ;
  3433   "RTN","RCD PARC",26,0 )
  3434    ;I RCDET  D  G:$D(DT OUT)!$D(DU OUT)!(Y="" ) ARCQ ; S ee if User  wants RAR Cs display ed on Deta iled repor
  3435   "RTN","RCD PARC",27,0 )
  3436    ;. S DIR( 0)="YA",DI R("A")="Di splay avai lable RARC s on Detai led Report ? (Y/N): " ,DIR("B")= "No"
  3437   "RTN","RCD PARC",28,0 )
  3438    ;. D ^DIR  K DIR
  3439   "RTN","RCD PARC",29,0 )
  3440    ;. I $D(D TOUT)!$D(D UOUT)!(Y=" ") Q 
  3441   "RTN","RCD PARC",30,0 )
  3442    ;. S RCRA RC=(Y=1)
  3443   "RTN","RCD PARC",31,0 )
  3444    S RCRARC= 0 ; Set RA RCs not to  display o n report,  but keep a round just  in case S usan chang es her min d.
  3445   "RTN","RCD PARC",32,0 )
  3446    ;
  3447   "RTN","RCD PARC",33,0 )
  3448    ; Get Pay er informa tion
  3449   "RTN","RCD PARC",34,0 )
  3450    S EX=$$GE TPAY^RCDPR U(.RCPAY)
  3451   "RTN","RCD PARC",35,0 )
  3452    G:EX=0 AR CQ
  3453   "RTN","RCD PARC",36,0 )
  3454    ;
  3455   "RTN","RCD PARC",37,0 )
  3456    ; Get Pay er TIN inf ormation
  3457   "RTN","RCD PARC",38,0 )
  3458    S EX=$$GE TTIN^RCDPR U(.RCTIN)
  3459   "RTN","RCD PARC",39,0 )
  3460    G:EX=0 AR CQ
  3461   "RTN","RCD PARC",40,0 )
  3462    ;
  3463   "RTN","RCD PARC",41,0 )
  3464    S DIR("A" )="Sort Re port by (C )ARC or (P )ayer?: ", DIR(0)="SA ^P:Payer N ame;CARC:  CARC Codes ;C:CARC Co des"
  3465   "RTN","RCD PARC",42,0 )
  3466    S DIR("B" )="CARC" D  ^DIR K DI R
  3467   "RTN","RCD PARC",43,0 )
  3468    I $D(DTOU T)!$D(DUOU T)!(Y="")  G ARCQ
  3469   "RTN","RCD PARC",44,0 )
  3470    S RCSORT= $E(Y,1)
  3471   "RTN","RCD PARC",45,0 )
  3472    ;
  3473   "RTN","RCD PARC",46,0 )
  3474    S DIR("?" )="Enter t he Beginni ng date fo r the repo rt"
  3475   "RTN","RCD PARC",47,0 )
  3476    S DIR(0)= "DAO^:"_DT _":APE",DI R("A")="St art Date:  ",DIR("B") ="T" D ^DI R K DIR
  3477   "RTN","RCD PARC",48,0 )
  3478    I $D(DTOU T)!$D(DUOU T)!(Y="")  G ARCQ
  3479   "RTN","RCD PARC",49,0 )
  3480    S RCDT1=Y
  3481   "RTN","RCD PARC",50,0 )
  3482    S DIR("?" )="Enter t he end dat e for the  report"
  3483   "RTN","RCD PARC",51,0 )
  3484    S DIR("B" )=$$DATE^R CDPRU($P($ $NOW^XLFDT ,"."),"2Z" )
  3485   "RTN","RCD PARC",52,0 )
  3486    S DIR(0)= "DAO^"_RCD T1_":"_DT_ ":APE",DIR ("A")="End  Date: ",D IR("B")="T " D ^DIR K  DIR
  3487   "RTN","RCD PARC",53,0 )
  3488    I $D(DTOU T)!$D(DUOU T)!(Y="")  G ARCQ
  3489   "RTN","RCD PARC",54,0 )
  3490    S RCDT2=Y
  3491   "RTN","RCD PARC",55,0 )
  3492    S DTOK=$$ CHECKDT^RC DPRU(RCDT1 ,RCDT2,361 .1)
  3493   "RTN","RCD PARC",56,0 )
  3494    I 'DTOK W  !!,"*** N ote: Date  Range "_$$ DATE^RCDPR U(RCDT1)_"  - "_$$DAT E^RCDPRU(R CDT2)," ** *",! W "** * No Recor ds found * **",! D AS K^RCDPRU(. RCSTOP) G  ARCQ
  3495   "RTN","RCD PARC",57,0 )
  3496    ; Get inp ut to expo rt to exce l. Removed  per Susan  (03/24/20 15)
  3497   "RTN","RCD PARC",58,0 )
  3498    S RCEXCEL =0
  3499   "RTN","RCD PARC",59,0 )
  3500    ;S RCEXCE L=$$DISPTY ^RCDPRU()
  3501   "RTN","RCD PARC",60,0 )
  3502    ;D:RCEXCE L INFO^RCD PRU
  3503   "RTN","RCD PARC",61,0 )
  3504    ;
  3505   "RTN","RCD PARC",62,0 )
  3506    S %ZIS="Q M" D ^%ZIS  Q:POP
  3507   "RTN","RCD PARC",63,0 )
  3508    I $D(IO(" Q")) D  Q
  3509   "RTN","RCD PARC",64,0 )
  3510    . S ZTRTN ="ENQ^RCDP ARC",ZTDES C="AR - 83 5 CARC & P AYER DATA  REPORT",ZT SAVE("*")= ""
  3511   "RTN","RCD PARC",65,0 )
  3512    . D ^%ZTL OAD
  3513   "RTN","RCD PARC",66,0 )
  3514    . W !!,$S ($D(ZTSK): "Your task  number"_Z TSK_" has  been queue d.",1:"Una ble to que ue this jo b.")
  3515   "RTN","RCD PARC",67,0 )
  3516    . K ZTSK, IO("Q") D  HOME^%ZIS
  3517   "RTN","RCD PARC",68,0 )
  3518    U IO
  3519   "RTN","RCD PARC",69,0 )
  3520    ;
  3521   "RTN","RCD PARC",70,0 )
  3522   ENQ ; Queu e point fo r report.
  3523   "RTN","RCD PARC",71,0 )
  3524    S RCNOW=$ $NOW^RCDPR U(),RCPG=0 ,$P(RCHR," =",IOM)=""
  3525   "RTN","RCD PARC",72,0 )
  3526    ;
  3527   "RTN","RCD PARC",73,0 )
  3528    K ^TMP("R CDPARC_REP ORT",$J)
  3529   "RTN","RCD PARC",74,0 )
  3530    ; Collect  the data  and put it  into the  ^TMP globa l
  3531   "RTN","RCD PARC",75,0 )
  3532    D GETDATA ($G(RCODE( "CARC")),. RCPAY,.RCT IN,$G(RCSO RT),$G(RCR ARC),RCDT1 ,RCDT2,$NA (^TMP("RCD PARC_REPOR T",$J)),.V AUTD)
  3533   "RTN","RCD PARC",76,0 )
  3534    ;
  3535   "RTN","RCD PARC",77,0 )
  3536   REPORT ; P rint out t he report
  3537   "RTN","RCD PARC",78,0 )
  3538    ; Set up  Division H eader Text  and CARC  Header Tex t
  3539   "RTN","RCD PARC",79,0 )
  3540    S:VAUTD=1  DIVHDR="A LL" D:VAUT D=0
  3541   "RTN","RCD PARC",80,0 )
  3542    . N I S D IVHDR="",I ="" F  S I =$O(VAUTD( I)) Q:I=""   S:DIVHDR '="" DIVHD R=DIVHDR_" , "_VAUTD( I) S:DIVHD R="" DIVHD R=VAUTD(I)
  3543   "RTN","RCD PARC",81,0 )
  3544    I RCODE(" CARC")="AL L" S CRHDR ="ALL"
  3545   "RTN","RCD PARC",82,0 )
  3546    E  S CRHD R=RCODE("C ARC")
  3547   "RTN","RCD PARC",83,0 )
  3548    ; Trim in formation  so it will  fit on an  80 or IOM  character  line
  3549   "RTN","RCD PARC",84,0 )
  3550    D:($L(DIV HDR)+$L(CR HDR))>(IOM -25)
  3551   "RTN","RCD PARC",85,0 )
  3552    . N VAL,D H,CH,R1,R2  S DH=0,CH =0,R1=0,R2 =0,VAL=(IO M-25)\2 ;  get half o f the scre en length
  3553   "RTN","RCD PARC",86,0 )
  3554    . S:$L(DI VHDR)>VAL  DH=1 S:$L( CRHDR)>VAL  CH=1 S:DH =0 R1=VAL- $L(DIVHDR)  S:CH=0 R2 =VAL-$L(CR HDR)
  3555   "RTN","RCD PARC",87,0 )
  3556    . I $L(DI VHDR)>(VAL +R2) S DIV HDR=$E(DIV HDR,1,(VAL +R2))_"... "
  3557   "RTN","RCD PARC",88,0 )
  3558    . I $L(CR HDR)>(VAL+ R1) S CRHD R=$E(CRHDR ,1,(VAL+R2 ))_"..."
  3559   "RTN","RCD PARC",89,0 )
  3560    ;
  3561   "RTN","RCD PARC",90,0 )
  3562    I 'RCEXCE L D
  3563   "RTN","RCD PARC",91,0 )
  3564    . S RCPG= RCPG+1 W @ IOF
  3565   "RTN","RCD PARC",92,0 )
  3566    . D HDRP( $$HDR(RCDE T,RCRARC), 1,"Page: " _RCPG_" ")
  3567   "RTN","RCD PARC",93,0 )
  3568    . D HDRP( "SORT BY:  "_$S($E(RC SORT,1)="C ":"CARC",1 :"Payer")_ "  RUN DAT E: "_RCNOW ,1)
  3569   "RTN","RCD PARC",94,0 )
  3570    . D HDRP( "DIVISIONS : "_DIVHDR _" CARCs:  "_CRHDR,1)
  3571   "RTN","RCD PARC",95,0 )
  3572    . D HDRP( "835 PAYER S: "_$S($E (RCPAY)="A ":"ALL",1: "Selected" )_" 835 PA YER TINs:  "_$S($E(RC TIN)="A":" ALL",1:"Se lected"),1 )
  3573   "RTN","RCD PARC",96,0 )
  3574    . D HDRP( "EOB PAID  DATE RANGE : "_$$DATE ^RCDPRU(RC DT1)_" - " _$$DATE^RC DPRU(RCDT2 ),1)
  3575   "RTN","RCD PARC",97,0 )
  3576    . W !,RCH R,!
  3577   "RTN","RCD PARC",98,0 )
  3578    E  D
  3579   "RTN","RCD PARC",99,0 )
  3580    . ; Excel  Report
  3581   "RTN","RCD PARC",100, 0)
  3582    . W "CARC ^PAYER^TIN ^REP_DATE^ AMOUNT",!
  3583   "RTN","RCD PARC",101, 0)
  3584    ;
  3585   "RTN","RCD PARC",102, 0)
  3586    D PRTREP( $NA(^TMP(" RCDPARC_RE PORT",$J," REPORT")), $NA(^TMP(" RCDPARC_RE PORT",$J," ~~SUM")),R CSORT,RCDE T,$G(RCRAR C),.RCSTOP ) G:RCSTOP  ARCQ
  3587   "RTN","RCD PARC",103, 0)
  3588    D ASK^RCD PRU(.RCSTO P)
  3589   "RTN","RCD PARC",104, 0)
  3590    ;
  3591   "RTN","RCD PARC",105, 0)
  3592   ARCQ ; Cle an-up and  quit
  3593   "RTN","RCD PARC",106, 0)
  3594    K DHDR,RC EXCEL,RCLI ST,RCLPAY, RCODE,RCPA Y,RCSORT,R CRARC,RCTI N,RCTLIST
  3595   "RTN","RCD PARC",107, 0)
  3596    ;K ^TMP(" RCDPARC_RE PORT",$J)
  3597   "RTN","RCD PARC",108, 0)
  3598    Q
  3599   "RTN","RCD PARC",109, 0)
  3600    ;
  3601   "RTN","RCD PARC",110, 0)
  3602   PRTREP(DAT A,SUMM,SOR T,CD,RA,RC STOP) ; Pr int report  data out  of the "RE PORT" suba rray
  3603   "RTN","RCD PARC",111, 0)
  3604    ; Input:    DATA         - Comp iled repor t data in  ^TMP("RCDP ARC_REPORT ",$J)
  3605   "RTN","RCD PARC",112, 0)
  3606    ;           SUM          - Comp iled grand  totals in  ^TMP("RCD PARC_REPOR T",$J,"~~S UM")
  3607   "RTN","RCD PARC",113, 0)
  3608    ;           SORT         - Sele cted Sort  Option
  3609   "RTN","RCD PARC",114, 0)
  3610    ;           CD           - 'D'  - Detail r eport, 'S'  - Summary  report
  3611   "RTN","RCD PARC",115, 0)
  3612    ;           RA           - Alwa ys 0 for n ow to not  display CA RCS on rep ort
  3613   "RTN","RCD PARC",116, 0)
  3614    ; Output:   RCSTOP       - 1 if  user quit  out of th e display,  0 otherwi se
  3615   "RTN","RCD PARC",117, 0)
  3616    N AMTA,AM TB,AMTP,CL ,CZ,DESC,D IWL,DIWR,D LN,DX0,DZ, IX,IY,LN,L N2,PAY,PCT ,PYRTINS,P YZ,RCSL
  3617   "RTN","RCD PARC",118, 0)
  3618    N TIN,TIX ,TIY,X,XX, YY,ZZ
  3619   "RTN","RCD PARC",119, 0)
  3620    S $P(LN," -",80)="", $P(DLN,"=" ,80)="",$P (LN2,"-",7 8)="",LN2= "  "_LN2,R CSL=8
  3621   "RTN","RCD PARC",120, 0)
  3622    ; Do Gran d totals -  moved to  top of rep ort per Su san on 7/1 6/2015
  3623   "RTN","RCD PARC",121, 0)
  3624    S DX0=$G( @SUMM@("CL AIMS")),PC T=0
  3625   "RTN","RCD PARC",122, 0)
  3626    S:+$P(DX0 ,U,2)'=0 P CT=$J(($P( DX0,U,4)/$ P(DX0,U,2) )*100,3,0)
  3627   "RTN","RCD PARC",123, 0)
  3628    S:+$P(DX0 ,U,2)=0 PC T="ERR"
  3629   "RTN","RCD PARC",124, 0)
  3630    I RCSL'<( IOSL-4) S  RCSTOP=$$N EWPG(.RCPG ,1,.RCSL,C D,RA) Q:RC STOP
  3631   "RTN","RCD PARC",125, 0)
  3632    W !
  3633   "RTN","RCD PARC",126, 0)
  3634    W "GRAND  TOTAL ALL  CARCS / AL L PAYERS O N REPORT", !
  3635   "RTN","RCD PARC",127, 0)
  3636    W "   TOT AL #CLAIMS :  ",$J($P (DX0,U,1), 6,0),"  AD J: ",PCT," % [TOT AMT  ADJUSTED  / TOT AMT  BILLED]",!
  3637   "RTN","RCD PARC",128, 0)
  3638    W "   AMT  ADJUST: $ ",$J($P(DX 0,U,4),11, 2),"  AMT  BILLED: $" ,$J($P(DX0 ,U,2),11,2 ),"  AMT P AID: $",$J ($P(DX0,U, 3),11,2),!
  3639   "RTN","RCD PARC",129, 0)
  3640    W !,DLN,! ! S RCSL=R CSL+5
  3641   "RTN","RCD PARC",130, 0)
  3642    ;
  3643   "RTN","RCD PARC",131, 0)
  3644    S IX="",I EN="",CL=0 ,AMTB=0,AM TP=0,DESC= "Empty Des cription"
  3645   "RTN","RCD PARC",132, 0)
  3646    F  S IX=$ O(@DATA@(I X)) Q:IX=" "!RCSTOP   S TIX=$G(@ DATA@(IX)) ,IY="" D   Q:RCSTOP 
  3647   "RTN","RCD PARC",133, 0)
  3648    . D:SORT= "C"  Q:RCS TOP  ; CAR C Sorted o utput IX = > CARC; IY  => Payer  Name
  3649   "RTN","RCD PARC",134, 0)
  3650    .. S DX0= $G(@DATA@( IX,"~~SUM" )),CL=$P(D X0,U,1),AM TB=$P(DX0, U,2),AMTP= $P(DX0,U,3 ),AMTA=$P( DX0,U,4),D ESC=$P(DX0 ,U,5),PCT= (AMTA/AMTB )*100
  3651   "RTN","RCD PARC",135, 0)
  3652    .. W "CAR C: ",$J(IX ,4)," TOTA L #CLAIMS:  ",$J(CL,5 ,0)," ADJ: ",$J(PCT,3 ,0),"% [TO T AMT ADJU STED / TOT  AMT BILLE D]",! S RC SL=RCSL+1
  3653   "RTN","RCD PARC",136, 0)
  3654    .. I RCSL '<(IOSL-2)  S RCSTOP= $$NEWPG(.R CPG,0,.RCS L,CD,RA) Q :RCSTOP
  3655   "RTN","RCD PARC",137, 0)
  3656    .. W "  A MT ADJUST:  ",$J(AMTA ,11,2),"   AMT BILLED : ",$J(AMT B,12,2),"   AMT PAID:  ",$J(AMTP ,12,2),! S  RCSL=RCSL +1
  3657   "RTN","RCD PARC",138, 0)
  3658    .. I RCSL '<(IOSL-2)  S RCSTOP= $$NEWPG(.R CPG,0,.RCS L,CD,RA) Q :RCSTOP
  3659   "RTN","RCD PARC",139, 0)
  3660    .. S X="D esc: "_$E( DESC,1,73) ,DIWL=1,DI WR=80 K ^U TILITY($J, "W") D ^DI WP,^DIWW S  RCSL=RCSL +1
  3661   "RTN","RCD PARC",140, 0)
  3662    .. I RCSL '<(IOSL-2)  S RCSTOP= $$NEWPG(.R CPG,0,.RCS L,CD,RA) Q :RCSTOP
  3663   "RTN","RCD PARC",141, 0)
  3664    .. W LN,!  S RCSL=RC SL+1
  3665   "RTN","RCD PARC",142, 0)
  3666    .. I RCSL '<(IOSL-2)  S RCSTOP= $$NEWPG(.R CPG,0,.RCS L,CD,RA) Q :RCSTOP
  3667   "RTN","RCD PARC",143, 0)
  3668    .. S CZ=0 ,PAY="" F   S PAY=$O( @DATA@(IX, "~~SUM",PA Y)) Q:PAY= ""!RCSTOP   S CZ=CZ+1  D  Q:RCST OP
  3669   "RTN","RCD PARC",144, 0)
  3670    ... S DZ= @DATA@(IX, "~~SUM",PA Y),PCT=$S( (+$P(DZ,U, 2)'=0):($P (DZ,U,4)/$ P(DZ,U,2)* 100),1:"ER ROR")
  3671   "RTN","RCD PARC",145, 0)
  3672    ... I CZ> 1 W LN2,!  S RCSL=RCS L+1
  3673   "RTN","RCD PARC",146, 0)
  3674    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3675   "RTN","RCD PARC",147, 0)
  3676    ... ; PRC A*4.5*321  Start modi fied code  block
  3677   "RTN","RCD PARC",148, 0)
  3678    ... D PAY TINS^RCDPR U2(PAY,.PY RTINS)
  3679   "RTN","RCD PARC",149, 0)
  3680    ... W " P AYER NAME/ TIN",!
  3681   "RTN","RCD PARC",150, 0)
  3682    ... S RCS L=RCSL+1
  3683   "RTN","RCD PARC",151, 0)
  3684    ... S PYZ ="" F  S P YZ=$O(PYRT INS(PYZ))  Q:PYZ=""   D  Q:RCSTO P
  3685   "RTN","RCD PARC",152, 0)
  3686    .... W "  ",$$PAYTIN ^RCDPRU2(P YRTINS(PYZ ),76),!
  3687   "RTN","RCD PARC",153, 0)
  3688    .... S RC SL=RCSL+1
  3689   "RTN","RCD PARC",154, 0)
  3690    .... I RC SL'<(IOSL- 2) S RCSTO P=$$NEWPG( .RCPG,0,.R CSL,CD,RA)
  3691   "RTN","RCD PARC",155, 0)
  3692    ... ; PRC A*4.5*321  End modifi ed code bl ock
  3693   "RTN","RCD PARC",156, 0)
  3694    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3695   "RTN","RCD PARC",157, 0)
  3696    ... W "   #CLAIMS: " ,$J($P(DZ, U,1),4,0), " ADJ:",$J (PCT,3,0), "% [ADJ: " ,$J($P(DZ, U,4),10,2) ,"/BILLED:  ",$J($P(D Z,U,2),10, 2),"] PAID : ",$J($P( DZ,U,3),10 ,2),! S RC SL=RCSL+1
  3697   "RTN","RCD PARC",158, 0)
  3698    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3699   "RTN","RCD PARC",159, 0)
  3700    ... D:RCD ET DETAIL( DATA,IX,PA Y,.RCSL,.R CSTOP) Q:R CSTOP  ; D ata array,  CARC, Pay er/TIN
  3701   "RTN","RCD PARC",160, 0)
  3702    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3703   "RTN","RCD PARC",161, 0)
  3704    .. Q:RCST OP  W LN,!  S RCSL=RC SL+1 ; Rem oved "!,"  in front o f "LN"
  3705   "RTN","RCD PARC",162, 0)
  3706    .. I RCSL '<(IOSL-2)  S RCSTOP= $$NEWPG(.R CPG,0,.RCS L,CD,RA) Q :RCSTOP
  3707   "RTN","RCD PARC",163, 0)
  3708    . Q:RCSTO P
  3709   "RTN","RCD PARC",164, 0)
  3710    . D:SORT= "P"  Q:RCS TOP  ; Pay er Sorted  output IX  => Payer N ame; IY =>  CARC
  3711   "RTN","RCD PARC",165, 0)
  3712    .. ; PRCA *4.5*321 S tart modif ied code b lock
  3713   "RTN","RCD PARC",166, 0)
  3714    .. D PAYT INS^RCDPRU 2(IX,.PYRT INS)
  3715   "RTN","RCD PARC",167, 0)
  3716    .. W " PA YER NAME/T IN",!
  3717   "RTN","RCD PARC",168, 0)
  3718    .. S RCSL =RCSL+1
  3719   "RTN","RCD PARC",169, 0)
  3720    .. S PYZ= "" F  S PY Z=$O(PYRTI NS(PYZ)) Q :PYZ=""  D   Q:RCSTOP
  3721   "RTN","RCD PARC",170, 0)
  3722    ... W " " ,$$PAYTIN^ RCDPRU2(PY RTINS(PYZ) ,76),!
  3723   "RTN","RCD PARC",171, 0)
  3724    ... S RCS L=RCSL+1
  3725   "RTN","RCD PARC",172, 0)
  3726    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)
  3727   "RTN","RCD PARC",173, 0)
  3728    .. ; PRCA *4.5*321 E nd modifie d code blo ck
  3729   "RTN","RCD PARC",174, 0)
  3730    .. S DX0= $G(@DATA@( IX,"~~SUM" )),CL=$P(D X0,U,1),AM TB=$P(DX0, U,2),AMTP= $P(DX0,U,3 ),AMTA=$P( DX0,U,4),P CT=(AMTA/A MTB)*100
  3731   "RTN","RCD PARC",175, 0)
  3732    .. W "#CL AIMS: ",$J (CL,4,0),"  ADJ: ",$J (PCT,3,0), "% [ADJ:", $J(AMTA,10 ,2),"/BILL ED:",$J(AM TB,11,2)," ] PAID:",$ J(AMTP,11, 2),! S RCS L=RCSL+1
  3733   "RTN","RCD PARC",176, 0)
  3734    .. W LN,! ! S RCSL=R CSL+2
  3735   "RTN","RCD PARC",177, 0)
  3736    .. S CZ=0 ,IY="" F   S IY=$O(@D ATA@(IX,"~ ~SUM",IY))  Q:IY=""   S CZ=CZ+1  D  Q:RCSTO P
  3737   "RTN","RCD PARC",178, 0)
  3738    ... S DZ= @DATA@(IX, "~~SUM",IY )
  3739   "RTN","RCD PARC",179, 0)
  3740    ... I CZ> 1 W LN2,!  S RCSL=RCS L+1
  3741   "RTN","RCD PARC",180, 0)
  3742    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3743   "RTN","RCD PARC",181, 0)
  3744    ... S PCT =$S((+$P(D Z,U,2)'=0) :($P(DZ,U, 4)/$P(DZ,U ,2)*100),1 :"ERROR")
  3745   "RTN","RCD PARC",182, 0)
  3746    ... W ?2, "CARC: ",$ J(IY,4),?1 4,"#CLAIMS : ",$J($P( DZ,U,1),5, 0),?30,"AD J: ",$J(PC T,3,0),"%  [AMT ADJUS TED / AMT  BILLED]",!  S RCSL=RC SL+1
  3747   "RTN","RCD PARC",183, 0)
  3748    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3749   "RTN","RCD PARC",184, 0)
  3750    ... W ?2, "AMT ADJUS T: ",$J($P (DZ,U,4),1 1,2),?26,"   BILLED:  ",$J($P(DZ ,U,2),12,2 ),?56," PA ID: ",$J($ P(DZ,U,3), 12,2),! S  RCSL=RCSL+ 1
  3751   "RTN","RCD PARC",185, 0)
  3752    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3753   "RTN","RCD PARC",186, 0)
  3754    ... S X=" Desc: "_$E ($P(DZ,U,5 ),1,68),DI WL=3,DIWR= 80 K ^UTIL ITY($J,"W" ) D ^DIWP, ^DIWW S RC SL=RCSL+1
  3755   "RTN","RCD PARC",187, 0)
  3756    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3757   "RTN","RCD PARC",188, 0)
  3758    ... D:RCD ET DETAIL( DATA,IX,IY ,.RCSL,.RC STOP) Q:RC STOP  ; Da ta array,  Payer/TIN,  CARC
  3759   "RTN","RCD PARC",189, 0)
  3760    ... I RCS L'<(IOSL-2 ) S RCSTOP =$$NEWPG(. RCPG,0,.RC SL,CD,RA)  Q:RCSTOP
  3761   "RTN","RCD PARC",190, 0)
  3762    .. Q:RCST OP  W LN,!  S RCSL=RC SL+1 ; Rem oved "!,"  in front o f LN
  3763   "RTN","RCD PARC",191, 0)
  3764    .. I RCSL '<(IOSL-2)  S RCSTOP= $$NEWPG(.R CPG,0,.RCS L,CD,RA) Q :RCSTOP
  3765   "RTN","RCD PARC",192, 0)
  3766    Q
  3767   "RTN","RCD PARC",193, 0)
  3768    ;
  3769   "RTN","RCD PARC",194, 0)
  3770   DETAIL(DAT A,L1,L2,RC SL,DSTOP)  ; Print de tail infor mation for  this entr y
  3771   "RTN","RCD PARC",195, 0)
  3772    N IEN,DOS ,DX,DY,HDR ,PCT,PAT,S SN
  3773   "RTN","RCD PARC",196, 0)
  3774    S HDR=0
  3775   "RTN","RCD PARC",197, 0)
  3776    S IEN=""  F  S IEN=$ O(@DATA@(L 1,L2,IEN))  Q:IEN=""! DSTOP  S H DR=HDR+1 D   Q:DSTOP 
  3777   "RTN","RCD PARC",198, 0)
  3778    . ; Print  out Detai l
  3779   "RTN","RCD PARC",199, 0)
  3780    . D:HDR=1   Q:DSTOP
  3781   "RTN","RCD PARC",200, 0)
  3782    .. W "  - ---------- ---------- ---------- ---------- ---------- ---------- ---------- -------",!  S RCSL=RC SL+1
  3783   "RTN","RCD PARC",201, 0)
  3784    .. W "  C LAIM#    D OS    %ADJ   [AMT ADJ /AMT BILLE D]  PAID    PATIENT N AME           SSN",!  S RCSL=RCS L+1
  3785   "RTN","RCD PARC",202, 0)
  3786    .. W "  = ========== ========== ========== ========== ========== ========== ========== =======",!  S RCSL=RC SL+1
  3787   "RTN","RCD PARC",203, 0)
  3788    .. I RCSL '<(IOSL-2)  S DSTOP=$ $NEWPG(.RC PG,0,.RCSL ,CD,RA) Q: DSTOP
  3789   "RTN","RCD PARC",204, 0)
  3790    . S DX=@D ATA@(L1,L2 ,IEN,0),DY =@DATA@(L1 ,L2,IEN,1) ,DOS=$$DAT E^RCDPRU($ $GET1^DIQ( 399,$P(DX, U,1)_",",. 03,"I")),P CT=($P(DY, U,2)/$P(DX ,U,6))*100
  3791   "RTN","RCD PARC",205, 0)
  3792    . ;S $P(D X,U,6)=654 321.99,$P( DX,U,7)=12 3456.99
  3793   "RTN","RCD PARC",206, 0)
  3794    . S PAT=$ $GET1^DIQ( 2,$P(DX,U, 3)_",",.01 ,"E"),SSN= "("_$E($$G ET1^DIQ(2, $P(DX,U,3) _",",.09," E"),*-3,*) _")"
  3795   "RTN","RCD PARC",207, 0)
  3796    . W ?2,$P (DX,U,2),? 10,DOS,?19 ,$J(PCT,3, 0),?24,$J( $P(DY,U,2) ,9,2),?34, $J($P(DX,U ,6),9,2),? 44,$J($P(D X,U,7),9,2 ),?54,$E(P AT,1,19),? 74,SSN,! S  RCSL=RCSL +1
  3797   "RTN","RCD PARC",208, 0)
  3798    . I RCSL' <(IOSL-2)  S DSTOP=$$ NEWPG(.RCP G,0,.RCSL, CD,RA) Q:D STOP
  3799   "RTN","RCD PARC",209, 0)
  3800    . ;W "RCR ARC = ",RC RARC,"   D Y=",DY,!
  3801   "RTN","RCD PARC",210, 0)
  3802    . ; Write  out RARC  if we have  one
  3803   "RTN","RCD PARC",211, 0)
  3804    . I RCRAR C=1&($P(DY ,U,5)'="")  S X="RARC : "_$P(DY, U,5)_"  "_ $P(DY,U,6) ,DIWL=5,DI WR=80 K ^U TILITY($J, "W") D ^DI WP,^DIWW S  RCSL=RCSL +1
  3805   "RTN","RCD PARC",212, 0)
  3806    . I RCSL' <(IOSL-2)  S DSTOP=$$ NEWPG(.RCP G,0,.RCSL, CD,RA) Q:D STOP
  3807   "RTN","RCD PARC",213, 0)
  3808    W ! S RCS L=RCSL+1
  3809   "RTN","RCD PARC",214, 0)
  3810    Q
  3811   "RTN","RCD PARC",215, 0)
  3812   HDR(CD,RA)  ; Report  header
  3813   "RTN","RCD PARC",216, 0)
  3814    N ZZ S ZZ =$S($G(RA) =1:" & RAR C",1:"")
  3815   "RTN","RCD PARC",217, 0)
  3816    Q:CD "EDI  LOCKBOX 8 35 CARC"_Z Z_" DATA R EPORT - DE TAIL FORMA T"
  3817   "RTN","RCD PARC",218, 0)
  3818    Q "EDI LO CKBOX 835  CARC DATA  REPORT - S UMMARY FOR MAT"
  3819   "RTN","RCD PARC",219, 0)
  3820    ;
  3821   "RTN","RCD PARC",220, 0)
  3822   HDRP(Z,X,Z 1) ; Print  Header (Z =String, X =1 (line f eed) X=0 ( no LF), Z1  (page num ber right  justified)
  3823   "RTN","RCD PARC",221, 0)
  3824    I $G(X)=1  W !
  3825   "RTN","RCD PARC",222, 0)
  3826    W ?(IOM-$ L(Z)\2),Z  W:$G(Z1)]" " ?(IOM-$L (Z1)),Z1
  3827   "RTN","RCD PARC",223, 0)
  3828    Q
  3829   "RTN","RCD PARC",224, 0)
  3830   NEWPG(RCPG ,RCNEW,RCS L,CD,RA) ;  Check for  new page  needed, ou tput heade r
  3831   "RTN","RCD PARC",225, 0)
  3832    ; RCPG =  Page numbe r passwd b y referece
  3833   "RTN","RCD PARC",226, 0)
  3834    ; RCNEW =  1 to forc e new page
  3835   "RTN","RCD PARC",227, 0)
  3836    ; RCSL =  page lengt h passed b y referenc e
  3837   "RTN","RCD PARC",228, 0)
  3838    ; Functio n returns  1 if user  chooses to  stop outp ut
  3839   "RTN","RCD PARC",229, 0)
  3840    N ZSTOP S  ZSTOP=0
  3841   "RTN","RCD PARC",230, 0)
  3842    I RCNEW!' RCPG!(($Y+ 5)>IOSL) D
  3843   "RTN","RCD PARC",231, 0)
  3844    . D:RCPG  ASK^RCDPRU (.ZSTOP) Q :ZSTOP
  3845   "RTN","RCD PARC",232, 0)
  3846    . S RCPG= RCPG+1 W @ IOF
  3847   "RTN","RCD PARC",233, 0)
  3848    . D HDRP( $$HDR(CD,R A),1,"Page : "_RCPG)
  3849   "RTN","RCD PARC",234, 0)
  3850    . D HDRP( "SORT BY:  "_$S($E(RC SORT,1)="C ":"CARC",1 :"Payer")_ "  RUN DAT E: "_RCNOW ,1)
  3851   "RTN","RCD PARC",235, 0)
  3852    . D HDRP( "Divisions : "_DIVHDR _" CARCs:  "_CRHDR,1)
  3853   "RTN","RCD PARC",236, 0)
  3854    . D HDRP( "835 PAYER S: "_$S($E (RCPAY)="A ":"ALL",1: "Selected" )_" 835 PA YER TINs:  "_$S($E(RC TIN)="A":" ALL",1:"Se lected"),1 )
  3855   "RTN","RCD PARC",237, 0)
  3856    . D HDRP( "EOB PAID  DATE RANGE : "_$$DATE ^RCDPRU(RC DT1)_" - " _$$DATE^RC DPRU(RCDT2 ),1)
  3857   "RTN","RCD PARC",238, 0)
  3858    . W !,RCH R,! S RCSL =7
  3859   "RTN","RCD PARC",239, 0)
  3860    Q ZSTOP
  3861   "RTN","RCD PARC",240, 0)
  3862    ;
  3863   "RTN","RCD PARC",241, 0)
  3864    ;
  3865   "RTN","RCD PARC",242, 0)
  3866    ; Select  Range or l ist of CAR C Codes
  3867   "RTN","RCD PARC",243, 0)
  3868   CARC ;
  3869   "RTN","RCD PARC",244, 0)
  3870    N DIR,OKA Y
  3871   "RTN","RCD PARC",245, 0)
  3872    S DIR("A" )="Enter a  List or R ange of CA RC codes:  ",DIR(0)=" F^1:200"
  3873   "RTN","RCD PARC",246, 0)
  3874    S DIR("?" )="Codes c an be ente red as: 1, 2,4:15,A1: B6"
  3875   "RTN","RCD PARC",247, 0)
  3876    S DIR("?" ,1)="Pleas e enter a  list or ra nge of CAR C Codes, u se a comma  "
  3877   "RTN","RCD PARC",248, 0)
  3878    S DIR("?" ,2)="and a  colon ':'  to delimi t ranges o f codes."
  3879   "RTN","RCD PARC",249, 0)
  3880    D ^DIR K  DIR
  3881   "RTN","RCD PARC",250, 0)
  3882    I $D(DTOU T)!$D(DUOU T)!(Y="")  S RCSTOP=1  Q
  3883   "RTN","RCD PARC",251, 0)
  3884    S RCODE=X ,OKAY=$$VA L^RCDPRU(3 45,.RCODE)
  3885   "RTN","RCD PARC",252, 0)
  3886    I 'OKAY S  DIR("A",1 )="Invalid  Range/Lis t of CARC  Codes, Ple ase reente r.." G CAR C
  3887   "RTN","RCD PARC",253, 0)
  3888    K DIR("A" ,1) ; Clea n up DIR
  3889   "RTN","RCD PARC",254, 0)
  3890    Q RCODE
  3891   "RTN","RCD PARC",255, 0)
  3892    ; Get dat a for repo rt and app ly filters  if necess ary
  3893   "RTN","RCD PARC",256, 0)
  3894   GETDATA(GC ARC,GPAYER ,GTIN,GSOR T,GRARC,GS TART,GSTOP ,GARRAY,GD IV) ;
  3895   "RTN","RCD PARC",257, 0)
  3896    ; Input:  GCCARC - R ange of CA RC codes t o include
  3897   "RTN","RCD PARC",258, 0)
  3898    ;         GPAYER - R ange of pa yers to in clude 
  3899   "RTN","RCD PARC",259, 0)
  3900    ;         GTIN   - R ange of TI Ns to incl ude
  3901   "RTN","RCD PARC",260, 0)
  3902    ;         GSORT  - S ort order 
  3903   "RTN","RCD PARC",261, 0)
  3904    ;         GRARC  - F lag to dis play RARC  codes on t he report  (0 = No)
  3905   "RTN","RCD PARC",262, 0)
  3906    ;         GSTART - S tart date
  3907   "RTN","RCD PARC",263, 0)
  3908    ;         GSTOP  - E nd date
  3909   "RTN","RCD PARC",264, 0)
  3910    ;         GARRAY - R oot of the  array in  which to s tore the o utput data
  3911   "RTN","RCD PARC",265, 0)
  3912    ;         GDIV   - R ange of Di visions to  include
  3913   "RTN","RCD PARC",266, 0)
  3914    ; Output:  @GARRAY(" BILLS",IEN ,0)=A1^A2^ A3^A4^A5^A 6^A7
  3915   "RTN","RCD PARC",267, 0)
  3916    ;            A1=Poin ter to BIL L/CLAIM fi le (#399)
  3917   "RTN","RCD PARC",268, 0)
  3918    ;            A2=Bill  Number
  3919   "RTN","RCD PARC",269, 0)
  3920    ;            A3=Poin ter to pat ient file  (#2)
  3921   "RTN","RCD PARC",270, 0)
  3922    ;            A4=Paye r Name fro m EOB, poi nter to In surance fi le (#36)
  3923   "RTN","RCD PARC",271, 0)
  3924    ;            A5=TIN  from EOB
  3925   "RTN","RCD PARC",272, 0)
  3926    ;            A6=Tota l Charges
  3927   "RTN","RCD PARC",273, 0)
  3928    ;            A7=Paid  amount
  3929   "RTN","RCD PARC",274, 0)
  3930    ;
  3931   "RTN","RCD PARC",275, 0)
  3932    N SDT,IEN ,CNT,ZX,RM ,ZND,CARR, PNARR,PTAR R,RCSET,GL INE,DZN,PT R,ZPAY,RCE RR,RCDEN
  3933   "RTN","RCD PARC",276, 0)
  3934    S SDT=$O( ^IBM(361.1 ,"E",GSTAR T),-1)
  3935   "RTN","RCD PARC",277, 0)
  3936    ; Set up  the arrays  for filte ring on CA RC, PAYER  name and P ayer TINs
  3937   "RTN","RCD PARC",278, 0)
  3938    D RNG^RCD PRU("CARC" ,GCARC,.CA RR)
  3939   "RTN","RCD PARC",279, 0)
  3940    D RNG^RCD PRU("PAYER ",GPAYER(" DATA"),.PN ARR)
  3941   "RTN","RCD PARC",280, 0)
  3942    I $G(PNAR R("PAYER") )'="ALL" D   ;
  3943   "RTN","RCD PARC",281, 0)
  3944    . N XARR, ZARR
  3945   "RTN","RCD PARC",282, 0)
  3946    . MERGE X ARR=PNARR( "PAYER")
  3947   "RTN","RCD PARC",283, 0)
  3948    . D PAYLI ST^RCDPRU2 (.XARR,"E" ,.ZARR) ;  PRCA*4.5*3 21 - Expan d payer li st to incl ude all wi th same TI N
  3949   "RTN","RCD PARC",284, 0)
  3950    . MERGE P NARR("PAYE R")=ZARR
  3951   "RTN","RCD PARC",285, 0)
  3952    D RNG^RCD PRU("TIN", GTIN("DATA "),.PTARR)
  3953   "RTN","RCD PARC",286, 0)
  3954    ;Get poss ible bills  to work o n from ^IB M(361.1,"E ") index
  3955   "RTN","RCD PARC",287, 0)
  3956    F  S SDT= $O(^IBM(36 1.1,"E",SD T)) Q:SDT= ""!(SDT>GS TOP)  D
  3957   "RTN","RCD PARC",288, 0)
  3958    . S IEN=" " F  S IEN =$O(^IBM(3 61.1,"E",S DT,IEN)) Q :IEN=""  D
  3959   "RTN","RCD PARC",289, 0)
  3960    .. S RM=$ $GET1^DIQ( 361.1,IEN_ ",",102,"I ") Q:$G(RM )=1  ; Qui t looking  if this EO B is remov ed
  3961   "RTN","RCD PARC",290, 0)
  3962    .. ; If n ot all div isions the n check to  see if th is EOB sho uld be inc luded
  3963   "RTN","RCD PARC",291, 0)
  3964    .. I GDIV =0 S RCDIV ="",RCDEN= $$GET1^DIQ (361.1,IEN _",",.01," I") S:RCDE N'="" RCDI V=$$GET1^D IQ(399,RCD EN_",",.22 ,"I") Q:RC DIV=""  Q: $G(GDIV(RC DIV))=""
  3965   "RTN","RCD PARC",292, 0)
  3966    .. ; Get  the data f or this cl aim and 83 5 Payer
  3967   "RTN","RCD PARC",293, 0)
  3968    .. S ZND= ^IBM(361.1 ,IEN,0),PT R=$P(ZND,U ,1),ZPAY=$ $GPAYR^RCD PRU2($P(ZN D,U,3))
  3969   "RTN","RCD PARC",294, 0)
  3970    .. S RCSE T=1
  3971   "RTN","RCD PARC",295, 0)
  3972    .. ; Are  there CARC  codes for  this reco rd
  3973   "RTN","RCD PARC",296, 0)
  3974    .. S:($G( ^IBM(361.1 ,IEN,10,0) )']"")&($G (^IBM(361. 1,IEN,15,0 ))']"") RC SET=0
  3975   "RTN","RCD PARC",297, 0)
  3976    .. ; Is t he PAYER i ncluded in  the list
  3977   "RTN","RCD PARC",298, 0)
  3978    .. S:'$$C HK^RCDPRU2 ("PAYER",Z PAY,.PNARR ) RCSET=0
  3979   "RTN","RCD PARC",299, 0)
  3980    .. ; Is t he payer T IN include d in the l ist
  3981   "RTN","RCD PARC",300, 0)
  3982    .. S:'$$C HK^RCDPRU2 ("TIN",$P( ZND,U,3)_"  ",.PTARR)  RCSET=0
  3983   "RTN","RCD PARC",301, 0)
  3984    .. Q:RCSE T=0  ; No  need to ch eck furthe r get next  IEN
  3985   "RTN","RCD PARC",302, 0)
  3986    .. ; Poin ter to the  bill (^DG CR(399,))^ KBill #^Pa tient poin ter^Payer  Pointer [^ DIC(36)]^P ayer ID/TI N^Total Ch arges^Paid  Amount
  3987   "RTN","RCD PARC",303, 0)
  3988    .. S DZN= $G(^DGCR(3 99,PTR,0))
  3989   "RTN","RCD PARC",304, 0)
  3990    .. S:($G( ^IBM(361.1 ,IEN,10,0) )]"")!($G( ^IBM(361.1 ,IEN,15,0) )]"") @GAR RAY@("BILL S",IEN,0)= PTR_U_$P(D ZN,U,1)_U_ $P(DZN,U,2 )_U_$P(ZND ,U,2)_U_$P (ZND,U,3)_ U_$G(^DGCR (399,PTR," U1"))_U_$P ($G(^IBM(3 61.1,IEN,1 )),U,1)
  3991   "RTN","RCD PARC",305, 0)
  3992    .. S CNT= 0
  3993   "RTN","RCD PARC",306, 0)
  3994    .. ; Get  Claim Leve l CARC Dat a
  3995   "RTN","RCD PARC",307, 0)
  3996    .. D:$G(^ IBM(361.1, IEN,10,0)) ]""
  3997   "RTN","RCD PARC",308, 0)
  3998    ... ; Get  CARC info rmation, C ARC is in  361.11
  3999   "RTN","RCD PARC",309, 0)
  4000    ... N IX, RCGX S IX= "" D GETS^ DIQ(361.1, IEN_",","1 0*;","E"," RCGX")
  4001   "RTN","RCD PARC",310, 0)
  4002    ... ; CAR C^AMOUNT^Q UANTITY^DE SCRIPTION
  4003   "RTN","RCD PARC",311, 0)
  4004    ... S IX= "" F  S IX =$O(RCGX(" 361.111",I X)) Q:IX=" "  D
  4005   "RTN","RCD PARC",312, 0)
  4006    .... ; Qu it if this  CARC is n ot in the  list
  4007   "RTN","RCD PARC",313, 0)
  4008    .... Q:'$ $CHK^RCDPR U2("CARC", RCGX("361. 111",IX,.0 1,"E"),.CA RR)
  4009   "RTN","RCD PARC",314, 0)
  4010    .... S CN T=CNT+1
  4011   "RTN","RCD PARC",315, 0)
  4012    .... S @G ARRAY@("BI LLS",IEN," C",CNT)=RC GX("361.11 1",IX,.01, "E")_U_RCG X("361.111 ",IX,.02," E")_U_RCGX ("361.111" ,IX,.03,"E ")_U_RCGX( "361.111", IX,.04,"E" )
  4013   "RTN","RCD PARC",316, 0)
  4014    .. ; Get  Line level  CARC Data
  4015   "RTN","RCD PARC",317, 0)
  4016    .. D:$G(^ IBM(361.1, IEN,15,0)) ]""
  4017   "RTN","RCD PARC",318, 0)
  4018    ... ; Get  CARC and  RARC infor mation. CA RC is in 3 61.11511 a nd RARC is  in 361.11 54
  4019   "RTN","RCD PARC",319, 0)
  4020    ... N IX, RCGX S IX= "" D GETS^ DIQ(361.1, IEN_",","1 5*;","IE", "RCGX")
  4021   "RTN","RCD PARC",320, 0)
  4022    ... ; CAR C^AMOUNT^Q UANTITY^DE SCRIPTION
  4023   "RTN","RCD PARC",321, 0)
  4024    ... S IX= "" F  S IX =$O(RCGX(" 361.11511" ,IX)) Q:IX =""  D
  4025   "RTN","RCD PARC",322, 0)
  4026    .... ; Qu it if this  CARC is n ot on the  list
  4027   "RTN","RCD PARC",323, 0)
  4028    .... Q:'$ $CHK^RCDPR U2("CARC", RCGX("361. 11511",IX, .01,"E"),. CARR)
  4029   "RTN","RCD PARC",324, 0)
  4030    .... S CN T=CNT+1
  4031   "RTN","RCD PARC",325, 0)
  4032    .... S @G ARRAY@("BI LLS",IEN," C",CNT)=RC GX("361.11 511",IX,.0 1,"E")_U_R CGX("361.1 1511",IX,. 02,"E")_U_ RCGX("361. 11511",IX, .03,"E")_U _RCGX("361 .11511",IX ,.04,"E")
  4033   "RTN","RCD PARC",326, 0)
  4034    ... ; RAR C^DESCRIPT ION
  4035   "RTN","RCD PARC",327, 0)
  4036    ... S IX= "" F ZX=1: 1 S IX=$O( RCGX("361. 1154",IX))  Q:IX=""   S @GARRAY@ ("BILLS",I EN,"R",ZX) =RCGX("361 .1154",IX, .02,"E")_U _RCGX("361 .1154",IX, .03,"E")
  4037   "RTN","RCD PARC",328, 0)
  4038    ; Possibl e bills ha ve been ac cumulated  in "BILLS"  sub-array , Apply fi lters and  accumulate  data in " REPORT" su b-array
  4039   "RTN","RCD PARC",329, 0)
  4040    D SORT(GA RRAY,GSORT )
  4041   "RTN","RCD PARC",330, 0)
  4042    Q
  4043   "RTN","RCD PARC",331, 0)
  4044    ;
  4045   "RTN","RCD PARC",332, 0)
  4046   SORT(ARRAY ,SORT) ; S ort and su mmarize da ta based o n SORT var iable
  4047   "RTN","RCD PARC",333, 0)
  4048    N CARC,IE N,D1,D2,PI EN,PAYER,Z ,TIN,DESC, R1,BILL S  IEN=""
  4049   "RTN","RCD PARC",334, 0)
  4050    ; IEN= IE N from fil e 361.1; P IEN= 835 P ayer IEN f rom file 3 44.6
  4051   "RTN","RCD PARC",335, 0)
  4052    F  S IEN= $O(@ARRAY@ ("BILLS",I EN)) Q:IEN =""  D
  4053   "RTN","RCD PARC",336, 0)
  4054    . S D1=@A RRAY@("BIL LS",IEN,0) ,TIN=$P(D1 ,U,5),BILL =$P(D1,U,2 )
  4055   "RTN","RCD PARC",337, 0)
  4056    . S PAYER =$$GPAYR^R CDPRU2(TIN ) Q:$G(PAY ER)=""  ;  couldn't f ind a paye r to match  TIN, quit
  4057   "RTN","RCD PARC",338, 0)
  4058    . S CARC= "",Z="",R1 =""
  4059   "RTN","RCD PARC",339, 0)
  4060    . F  S Z= $O(@ARRAY@ ("BILLS",I EN,"C",Z))  Q:Z=""  S  D2=@ARRAY @("BILLS", IEN,"C",Z) ,CARC=$P(D 2,U,1),DES C=$P(D2,U, 4) D
  4061   "RTN","RCD PARC",340, 0)
  4062    .. ; If R ARC exists  append to  CARC Info rmation
  4063   "RTN","RCD PARC",341, 0)
  4064    .. S:$G(@ ARRAY@("BI LLS",IEN," R",Z))'=""  R1=@ARRAY @("BILLS", IEN,"R",Z)
  4065   "RTN","RCD PARC",342, 0)
  4066    .. ;W "RA RC: |",$G( @ARRAY@("B ILLS",IEN, "R",Z)),"| ",!
  4067   "RTN","RCD PARC",343, 0)
  4068    .. D:SORT ="C"  ; So rt by CARC , group by  Payer
  4069   "RTN","RCD PARC",344, 0)
  4070    ... S @AR RAY@("REPO RT",CARC,P AYER_"/"_T IN,IEN,0)= D1
  4071   "RTN","RCD PARC",345, 0)
  4072    ... ; Fir st time th rough set  the "BILLS " D2 into  report, ot herwise ad d adjustme nt amt to  the existi ng for thi s CARC
  4073   "RTN","RCD PARC",346, 0)
  4074    ... I $G( @ARRAY@("R EPORT",CAR C,PAYER_"/ "_TIN,IEN, 1))="" S @ ARRAY@("RE PORT",CARC ,PAYER_"/" _TIN,IEN,1 )=D2_U_R1
  4075   "RTN","RCD PARC",347, 0)
  4076    ... E  S  $P(@ARRAY@ ("REPORT", CARC,PAYER _"/"_TIN,I EN,1),U,2) =$P(@ARRAY @("REPORT" ,CARC,PAYE R_"/"_TIN, IEN,1),U,2 )+$P(D2,U, 2) ;W "CAR C: ",CARC, " Bill: ", BILL," D2:  ",D2,!
  4077   "RTN","RCD PARC",348, 0)
  4078    .. D:SORT ="P"  ; So rt by Paye r, group b y CARC
  4079   "RTN","RCD PARC",349, 0)
  4080    ... S @AR RAY@("REPO RT",PAYER_ "/"_TIN,CA RC,IEN,0)= D1
  4081   "RTN","RCD PARC",350, 0)
  4082    ... ; Fir st time th rough set  the "BILLS " D2 into  report, ot herwise ad d adjustme nt amt to  the existi ng for thi s CARC
  4083   "RTN","RCD PARC",351, 0)
  4084    ... I $G( @ARRAY@("R EPORT",PAY ER_"/"_TIN ,CARC,IEN, 1))="" S @ ARRAY@("RE PORT",PAYE R_"/"_TIN, CARC,IEN,1 )=D2_U_R1
  4085   "RTN","RCD PARC",352, 0)
  4086    ... E  S  $P(@ARRAY@ ("REPORT", PAYER_"/"_ TIN,CARC,I EN,1),U,2) =$P(@ARRAY @("REPORT" ,PAYER_"/" _TIN,CARC, IEN,1),U,2 )+$P(D2,U, 2)
  4087   "RTN","RCD PARC",353, 0)
  4088    .. ;I CAR C=1 W ARRA Y," BILL:" ,BILL," CA RC:",CARC, "  ",PAYER _"/"_TIN,"   ",$P(D1, U,6),"  ", $P(D1,U,7) ,"  ",DESC ,"  ",$P(D 2,U,2),"   ",SORT,!
  4089   "RTN","RCD PARC",354, 0)
  4090    .. D SUM^ RCDPRU2(AR RAY,IEN,BI LL,CARC,PA YER_"/"_TI N,$P(D1,U, 6),$P(D1,U ,7),DESC,$ P(D2,U,2), SORT)
  4091   "RTN","RCD PARC",355, 0)
  4092    Q
  4093   "RTN","RCD PE215")
  4094   0^10^B8976 4235
  4095   "RTN","RCD PE215",1,0 )
  4096   RCDPE215 ; ALB/TMK- S F215 EDI L ockbox Sum mary Repor t ;1 Jun 9 9
  4097   "RTN","RCD PE215",2,0 )
  4098    ;;4.5;Acc ounts Rece ivable;**1 14,173,220 ,321**;Mar  20, 1995; Build 46
  4099   "RTN","RCD PE215",3,0 )
  4100    ;;Per VHA  Directive  10-93-142 , this rou tine shoul d not be m odified.
  4101   "RTN","RCD PE215",4,0 )
  4102    Q
  4103   "RTN","RCD PE215",5,0 )
  4104    ;
  4105   "RTN","RCD PE215",6,0 )
  4106   SUMM215 ;   summary 2 15
  4107   "RTN","RCD PE215",7,0 )
  4108    D FULL^VA LM1
  4109   "RTN","RCD PE215",8,0 )
  4110    S VALMBCK ="R"
  4111   "RTN","RCD PE215",9,0 )
  4112    ;
  4113   "RTN","RCD PE215",10, 0)
  4114    N %,%ZIS, POP,RCDEPT DA,RCTYPE, DIC,X,Y,ZT SAVE,ZTDES C,ZTSK,ZTR TN
  4115   "RTN","RCD PE215",11, 0)
  4116    ;
  4117   "RTN","RCD PE215",12, 0)
  4118    S DIC(0)= "AEMQ",DIC ="^RCY(344 .1,",DIC(" A")="Selec t DEPOSIT:  "
  4119   "RTN","RCD PE215",13, 0)
  4120    D ^DIC K  DIC
  4121   "RTN","RCD PE215",14, 0)
  4122    I Y'>0 Q
  4123   "RTN","RCD PE215",15, 0)
  4124    S RCDEPTD A=+Y
  4125   "RTN","RCD PE215",16, 0)
  4126    S RCTYPE= $$GETTYPE^ RCDPR215
  4127   "RTN","RCD PE215",17, 0)
  4128    I RCTYPE= "" Q
  4129   "RTN","RCD PE215",18, 0)
  4130    ;
  4131   "RTN","RCD PE215",19, 0)
  4132    ; device
  4133   "RTN","RCD PE215",20, 0)
  4134    W ! S %ZI S="Q" D ^% ZIS Q:POP
  4135   "RTN","RCD PE215",21, 0)
  4136    I $D(IO(" Q")) D  D  ^%ZTLOAD K  IO("Q"),Z TSK D ^%ZI SC Q
  4137   "RTN","RCD PE215",22, 0)
  4138    .   S ZTD ESC="Print  Summary 2 15 Report" ,ZTRTN="DQ ^RCDPE215"
  4139   "RTN","RCD PE215",23, 0)
  4140    .   S ZTS AVE("RCDEP TDA")="",Z TSAVE("RCT YPE")="",Z TSAVE("ZTR EQ")="@"
  4141   "RTN","RCD PE215",24, 0)
  4142    W !!,"<*>  please wa it <*>"
  4143   "RTN","RCD PE215",25, 0)
  4144    D DQ
  4145   "RTN","RCD PE215",26, 0)
  4146    Q
  4147   "RTN","RCD PE215",27, 0)
  4148    ;
  4149   "RTN","RCD PE215",28, 0)
  4150   DQ ;  queu ed report  entrypoint
  4151   "RTN","RCD PE215",29, 0)
  4152    ;  RCDEPT DA = ien o f the depo sit to sum marize
  4153   "RTN","RCD PE215",30, 0)
  4154    ;  RCTYPE ="D"etail  or "A"ccru al
  4155   "RTN","RCD PE215",31, 0)
  4156    N %I,AMOU NT,BILL,BI LLDA,COMME NTS,COUNT, DA,DATA,DE POSIT,FMSD OCNO,FUND, NOW,PAGE,P IECE,PRINT OTL,RCSTFL AG,RCYLINE ,RECEIPT,S CREEN,TOTA L,TOTLAMT, UNAPPLY,X, Y,RCDETAIL ,PCT,RECEI PDA,TOT,ED ITOT,DETAI L,Z,EFTFUN D
  4157   "RTN","RCD PE215",32, 0)
  4158    ;
  4159   "RTN","RCD PE215",33, 0)
  4160    ;  calcul ate report
  4161   "RTN","RCD PE215",34, 0)
  4162    K ^TMP($J ,"RCFMSCR" ),^TMP($J, "RCFMSCR_S UM"),^TMP( $J,"RCDPR2 15"),^TMP( $J,"RCDET" )
  4163   "RTN","RCD PE215",35, 0)
  4164    S EFTFUND =$S(DT<$$A DDPTEDT^PR CAACC():"5 287.4/8NZZ ",1:"52870 4/8NZZ")
  4165   "RTN","RCD PE215",36, 0)
  4166    S DEPOSIT =$P($G(^RC Y(344.1,RC DEPTDA,0)) ,U)
  4167   "RTN","RCD PE215",37, 0)
  4168    S RECEIPD A=0 F  S R ECEIPDA=$O (^RCY(344, "AD",RCDEP TDA,RECEIP DA)) Q:'RE CEIPDA  D
  4169   "RTN","RCD PE215",38, 0)
  4170    . D FMSLI NES^RCXFMS C1(RECEIPD A)
  4171   "RTN","RCD PE215",39, 0)
  4172    . ; sort  by Receipt  #
  4173   "RTN","RCD PE215",40, 0)
  4174    . S ^TMP( $J,"RCFMSC R_SUM",REC EIPDA)=""
  4175   "RTN","RCD PE215",41, 0)
  4176    . M ^TMP( $J,"RCFMSC R_SUM",REC EIPDA)=^TM P($J,"RCFM SCR")
  4177   "RTN","RCD PE215",42, 0)
  4178    . K ^TMP( $J,"RCFMSC R")
  4179   "RTN","RCD PE215",43, 0)
  4180    . I $$EDI LB^RCDPEU( RECEIPDA)= 1 D  ; EFT  dep recei pt
  4181   "RTN","RCD PE215",44, 0)
  4182    .. S TOT= 0
  4183   "RTN","RCD PE215",45, 0)
  4184    .. S Z=0  F  S Z=$O( ^RCY(344,R ECEIPDA,1, Z)) Q:'Z   S TOT=TOT+ $P($G(^(Z, 0)),U,4)
  4185   "RTN","RCD PE215",46, 0)
  4186    .. S (^TM P($J,"RCFM SCR_SUM",R ECEIPDA,EF TFUND),^TM P($J,"RCTO T","EDILBO X"))=TOT
  4187   "RTN","RCD PE215",47, 0)
  4188    ;
  4189   "RTN","RCD PE215",48, 0)
  4190    ;  summar y rep for  a deposit
  4191   "RTN","RCD PE215",49, 0)
  4192    S PAGE=0, RCYLINE="" ,$P(RCYLIN E,"-",81)= ""
  4193   "RTN","RCD PE215",50, 0)
  4194    D NOW^%DT C S Y=% D  DD^%DT S N OW=Y
  4195   "RTN","RCD PE215",51, 0)
  4196    S SCREEN= 0 I '$D(ZT QUEUED),IO =IO(0),$E( IOST)="C"  S SCREEN=1
  4197   "RTN","RCD PE215",52, 0)
  4198    U IO
  4199   "RTN","RCD PE215",53, 0)
  4200    K ^TMP($J ,"RCTOT")
  4201   "RTN","RCD PE215",54, 0)
  4202    S RCDETAI L=1,PCT=0, EDITOT=0
  4203   "RTN","RCD PE215",55, 0)
  4204    S RECEIPD A=0 F  S R ECEIPDA=$O (^TMP($J," RCFMSCR_SU M",RECEIPD A)) Q:'REC EIPDA  D
  4205   "RTN","RCD PE215",56, 0)
  4206    . S DATA= $G(^RCY(34 4,RECEIPDA ,0))
  4207   "RTN","RCD PE215",57, 0)
  4208    . S RECEI PT=$P(DATA ,"^")
  4209   "RTN","RCD PE215",58, 0)
  4210    . S FMSDO CNO=$P($G( ^RCY(344.1 ,+$P(DATA, "^",6),2)) ,"^")
  4211   "RTN","RCD PE215",59, 0)
  4212    . D SET(" <NP>",RECE IPT_"@"_FM SDOCNO_"@" _RECEIPDA, .PCT)
  4213   "RTN","RCD PE215",60, 0)
  4214    . ;
  4215   "RTN","RCD PE215",61, 0)
  4216    . S TOTAL =""  ;  st ores print otal^intto tal^admint otal^marsh total^ccto tal
  4217   "RTN","RCD PE215",62, 0)
  4218    . ;
  4219   "RTN","RCD PE215",63, 0)
  4220    . S FUND= "" F  S FU ND=$O(^TMP ($J,"RCFMS CR_SUM",RE CEIPDA,FUN D)) Q:'FUN D  D
  4221   "RTN","RCD PE215",64, 0)
  4222    ..   D SE T("!!?5"," Appropriat ion: "_FUN D,.PCT)
  4223   "RTN","RCD PE215",65, 0)
  4224    ..   I RC TYPE="D" D  SET("!"," ",.PCT)
  4225   "RTN","RCD PE215",66, 0)
  4226    ..   ;
  4227   "RTN","RCD PE215",67, 0)
  4228    ..   S PR INTOTL=0
  4229   "RTN","RCD PE215",68, 0)
  4230    ..   S CO UNT=0
  4231   "RTN","RCD PE215",69, 0)
  4232    ..   I FU ND=EFTFUND  S PRINTOT L=PRINTOTL +$G(^TMP($ J,"RCFMSCR _SUM",RECE IPDA,FUND) ),EDITOT=E DITOT+$G(^ TMP($J,"RC FMSCR_SUM" ,RECEIPDA, FUND))
  4233   "RTN","RCD PE215",70, 0)
  4234    ..   S BI LLDA=0 F   S BILLDA=$ O(^TMP($J, "RCFMSCR_S UM",RECEIP DA,FUND,BI LLDA)) Q:' BILLDA  D
  4235   "RTN","RCD PE215",71, 0)
  4236    ...   S C OUNT=COUNT +1
  4237   "RTN","RCD PE215",72, 0)
  4238    ...   S B ILL=$P($G( ^PRCA(430, BILLDA,0)) ,"^")
  4239   "RTN","RCD PE215",73, 0)
  4240    ...   S D ATA=^TMP($ J,"RCFMSCR _SUM",RECE IPDA,FUND, BILLDA)
  4241   "RTN","RCD PE215",74, 0)
  4242    ...   S P RINTOTL=PR INTOTL+$P( DATA,"^")
  4243   "RTN","RCD PE215",75, 0)
  4244    ...   F P IECE=1:1:5  S $P(TOTA L,"^",PIEC E)=$P(TOTA L,"^",PIEC E)+$P(DATA ,"^",PIECE ),$P(^TMP( $J,"RCTOT" ,"TOTAL"), "^",PIECE) =$P($G(^TM P($J,"RCTO T","TOTAL" )),"^",PIE CE)+$P(DAT A,"^",PIEC E)
  4245   "RTN","RCD PE215",76, 0)
  4246    ...   ;   if accrued  report,no  detail
  4247   "RTN","RCD PE215",77, 0)
  4248    ...   I R CTYPE="A"  Q
  4249   "RTN","RCD PE215",78, 0)
  4250    ...   ;
  4251   "RTN","RCD PE215",79, 0)
  4252    ...   D S ET("!?5",C OUNT_")",. PCT),SET(" ?10",BILL, .PCT),SET( "?30",$J($ P(DATA,"^" ),10,2),.P CT),SET("? 45","DEBTO R: "_$E($$ DEBTOR^RCD PR215(BILL DA),1,25), .PCT)
  4253   "RTN","RCD PE215",80, 0)
  4254    ...   D S ET("!?15", "INT:"_$J( $P(DATA,"^ ",2),10,2) _" ADMIN:" _$J($P(DAT A,"^",3),1 0,2)_" MAR S: "_$J($P (DATA,"^", 4),10,2)_"  CC: "_$J( $P(DATA,"^ ",5),10,2) ,.PCT,1)
  4255   "RTN","RCD PE215",81, 0)
  4256    ..   ;
  4257   "RTN","RCD PE215",82, 0)
  4258    ..   I RC TYPE="D" D  SET("!?30 ","------- ---",.PCT) ,SET("!?5" ,"TOTAL fo r "_FUND,. PCT)
  4259   "RTN","RCD PE215",83, 0)
  4260    ..   D SE T("?30",$J (PRINTOTL, 10,2),.PCT )
  4261   "RTN","RCD PE215",84, 0)
  4262    ..   I FU ND="0160a1 " D SET("? 45","0160a 1 sub-tota ls Champva  receipts" ,.PCT),SET ("!?45","n ot sent to  FMS on th e CR docum ent.",.PCT )
  4263   "RTN","RCD PE215",85, 0)
  4264    ..   S ^T MP($J,"RCT OT","PRINT OTL",FUND) =$G(^TMP($ J,"RCTOT", "PRINTOTL" ,FUND))+PR INTOTL
  4265   "RTN","RCD PE215",86, 0)
  4266    ..   I FU ND=EFTFUND  S $P(^TMP ($J,"RCTOT ","TOTAL") ,U)=$P($G( ^TMP($J,"R CTOT","TOT AL")),U)+P RINTOTL
  4267   "RTN","RCD PE215",87, 0)
  4268    . ;
  4269   "RTN","RCD PE215",88, 0)
  4270    . ;  show  int, admi n, etc rec eipt total s
  4271   "RTN","RCD PE215",89, 0)
  4272    . D SET(" !","",.PCT )
  4273   "RTN","RCD PE215",90, 0)
  4274    . D SET(" !?5","INTE REST : (AP P: 1435)", .PCT),SET( "?30",$J($ P(TOTAL,"^ ",2),10,2) ,.PCT)
  4275   "RTN","RCD PE215",91, 0)
  4276    . D SET(" !?5","ADMI N    : (AP P: 3220)", .PCT),SET( "?30",$J($ P(TOTAL,"^ ",3),10,2) ,.PCT)
  4277   "RTN","RCD PE215",92, 0)
  4278    . D SET(" !?5","MARS HALL : (AP P: 0869)", .PCT),SET( "?30",$J($ P(TOTAL,"^ ",4),10,2) ,.PCT)
  4279   "RTN","RCD PE215",93, 0)
  4280    . D SET(" !?5","COUR TCOST: (AP P: 0869)", .PCT),SET( "?30",$J($ P(TOTAL,"^ ",5),10,2) ,.PCT)
  4281   "RTN","RCD PE215",94, 0)
  4282    . D SET(" !?30","--- -------",. PCT)
  4283   "RTN","RCD PE215",95, 0)
  4284    . D SET(" !?30",$J($ P(TOTAL,"^ ",2)+$P(TO TAL,"^",3) +$P(TOTAL, "^",4)+$P( TOTAL,"^", 5),10,2),. PCT)
  4285   "RTN","RCD PE215",96, 0)
  4286    . ;
  4287   "RTN","RCD PE215",97, 0)
  4288    . I $G(^T MP($J,"RCF MSCR_SUM", RECEIPDA,E FTFUND)) S  $P(TOTAL, U)=$P(TOTA L,U)+^TMP( $J,"RCFMSC R_SUM",REC EIPDA,EFTF UND)
  4289   "RTN","RCD PE215",98, 0)
  4290    . D SUSP( RECEIPDA,R CTYPE,.TOT AL,.PCT)
  4291   "RTN","RCD PE215",99, 0)
  4292    . ;
  4293   "RTN","RCD PE215",100 ,0)
  4294    . S TOTLA MT=0 F PIE CE=1:1:5 S  TOTLAMT=T OTLAMT+$P( TOTAL,"^", PIECE)
  4295   "RTN","RCD PE215",101 ,0)
  4296    . D SET(" !!","TOTAL S: ",.PCT)
  4297   "RTN","RCD PE215",102 ,0)
  4298    . D SET(" !?5","TOTA L AMT POST ED FOR REC EIPT:",.PC T),SET("?3 0",$J(TOTL AMT,10,2), .PCT,1)
  4299   "RTN","RCD PE215",103 ,0)
  4300    ;
  4301   "RTN","RCD PE215",104 ,0)
  4302    D H
  4303   "RTN","RCD PE215",105 ,0)
  4304    W !!,"*** * GRAND TO TALS FOR D EPOSIT: "_ $P($G(^RCY (344.1,+RC DEPTDA,0)) ,U)
  4305   "RTN","RCD PE215",106 ,0)
  4306    S TOT=0
  4307   "RTN","RCD PE215",107 ,0)
  4308    S FUND=""  F  S FUND =$O(^TMP($ J,"RCTOT", "PRINTOTL" ,FUND)) Q: FUND=""  D
  4309   "RTN","RCD PE215",108 ,0)
  4310    . W !!?5, "Appropria tion: ",FU ND,": ",?3 5,$J($G(^T MP($J,"RCT OT","PRINT OTL",FUND) ),10,2)
  4311   "RTN","RCD PE215",109 ,0)
  4312    . S TOT=T OT+$G(^TMP ($J,"RCTOT ","PRINTOT L",FUND))
  4313   "RTN","RCD PE215",110 ,0)
  4314    W !,?35," ========== ===",!,"To tal Approp riation: " ,?35,$J(+T OT,10,2)
  4315   "RTN","RCD PE215",111 ,0)
  4316    I FUND="0 160a1" W ? 47,"0160a1  sub-total s Champva  receipts", !?47,"not  sent to FM S on the C R doc."
  4317   "RTN","RCD PE215",112 ,0)
  4318    ;
  4319   "RTN","RCD PE215",113 ,0)
  4320    S TOTAL=$ G(^TMP($J, "RCTOT","T OTAL"))
  4321   "RTN","RCD PE215",114 ,0)
  4322    W !
  4323   "RTN","RCD PE215",115 ,0)
  4324    W !?5,"IN TEREST : ( APP: 1435) ",?35,$J($ P(TOTAL,"^ ",2),10,2)
  4325   "RTN","RCD PE215",116 ,0)
  4326    W !?5,"AD MIN    : ( APP: 3220) ",?35,$J($ P(TOTAL,"^ ",3),10,2)
  4327   "RTN","RCD PE215",117 ,0)
  4328    W !?5,"MA RSHALL : ( APP: 0869) ",?35,$J($ P(TOTAL,"^ ",4),10,2)
  4329   "RTN","RCD PE215",118 ,0)
  4330    W !?5,"CO URTCOST: ( APP: 0869) ",?35,$J($ P(TOTAL,"^ ",5),10,2)
  4331   "RTN","RCD PE215",119 ,0)
  4332    W !?35,"- ---------"
  4333   "RTN","RCD PE215",120 ,0)
  4334    W !?35,$J ($P(TOTAL, "^",2)+$P( TOTAL,"^", 3)+$P(TOTA L,"^",4)+$ P(TOTAL,"^ ",5),10,2)
  4335   "RTN","RCD PE215",121 ,0)
  4336    I $G(^TMP ($J,"RCTOT ","SUSPENS E")) W !!? 5,"Total A ppropriati on: 3875", ?35,$J(^TM P($J,"RCTO T","SUSPEN SE"),10,2)
  4337   "RTN","RCD PE215",122 ,0)
  4338    ;
  4339   "RTN","RCD PE215",123 ,0)
  4340    S TOTLAMT =0 F PIECE =1:1:5 S T OTLAMT=TOT LAMT+$P(TO TAL,"^",PI ECE)
  4341   "RTN","RCD PE215",124 ,0)
  4342    I $G(^TMP ($J,"RCTOT ","EDILBOX ")) S TOTL AMT=TOTLAM T+^TMP($J, "RCTOT","E DILBOX")
  4343   "RTN","RCD PE215",125 ,0)
  4344    W !!,"TOT ALS: "
  4345   "RTN","RCD PE215",126 ,0)
  4346    W !?5,"TO T AMT POST ED FOR DEP OSIT: ",?3 5,$J(+TOTL AMT,10,2)
  4347   "RTN","RCD PE215",127 ,0)
  4348    I SCREEN  D PAUSE G: $G(RCSTFLA G) Q
  4349   "RTN","RCD PE215",128 ,0)
  4350    N Q,W,T,N S
  4351   "RTN","RCD PE215",129 ,0)
  4352    S W=""
  4353   "RTN","RCD PE215",130 ,0)
  4354    S PCT=0 F   S PCT=$O (^TMP($J," RCDET",PCT )) Q:'PCT   D  G:$G(R CSTFLAG) Q
  4355   "RTN","RCD PE215",131 ,0)
  4356    . S Q=$P( $G(^TMP($J ,"RCDET",P CT)),U),T= $P($G(^(PC T)),U,2),N S=$P($G(^( PCT)),U,3)
  4357   "RTN","RCD PE215",132 ,0)
  4358    . I Q="<N P>" D  Q
  4359   "RTN","RCD PE215",133 ,0)
  4360    .. I W'=" " W @W S W ="" D:SCRE EN PAUSE Q :$G(RCSTFL AG)
  4361   "RTN","RCD PE215",134 ,0)
  4362    .. S RECE IPT=$P(T," @"),FMSDOC NO=$P(T,"@ ",2),RECEI PDA=$P(T," @",3)
  4363   "RTN","RCD PE215",135 ,0)
  4364    .. D H,H1 (0)
  4365   "RTN","RCD PE215",136 ,0)
  4366    . I $E(Q) ="!" W:W'= "" @W S W= ""
  4367   "RTN","RCD PE215",137 ,0)
  4368    . S W=W_$ S(W="":"", 1:",")_Q_$ S(Q'="":", ",1:"")_"" ""_T_""""
  4369   "RTN","RCD PE215",138 ,0)
  4370    . I 'NS,$ Y>(IOSL-6)  D:SCREEN  PAUSE I '$ G(RCSTFLAG ) D H,H1(1 )
  4371   "RTN","RCD PE215",139 ,0)
  4372    I W'="" W  @W S W=""
  4373   "RTN","RCD PE215",140 ,0)
  4374    I SCREEN  W !,"Press  RETURN to  continue:  " R X:DTI ME
  4375   "RTN","RCD PE215",141 ,0)
  4376    ;
  4377   "RTN","RCD PE215",142 ,0)
  4378   Q D ^%ZISC
  4379   "RTN","RCD PE215",143 ,0)
  4380    K ^TMP($J ,"RCFMSCR" ),^TMP($J, "RCDPR215" ),^TMP($J, "RCTOT"),^ TMP($J,"RC FMSCR_SUM" ),^TMP($J, "RCDET")
  4381   "RTN","RCD PE215",144 ,0)
  4382    Q
  4383   "RTN","RCD PE215",145 ,0)
  4384    ;
  4385   "RTN","RCD PE215",146 ,0)
  4386    ;
  4387   "RTN","RCD PE215",147 ,0)
  4388   SUSP(RECEI PDA,RCTYPE ,TOTAL,PCT ) ;  unapp lied amts  for suspen se
  4389   "RTN","RCD PE215",148 ,0)
  4390    ; RCTYPE  = see expl anation at  DQ above
  4391   "RTN","RCD PE215",149 ,0)
  4392    ; Returns  PCT,TOTAL  if passed  by refere nce
  4393   "RTN","RCD PE215",150 ,0)
  4394    ;
  4395   "RTN","RCD PE215",151 ,0)
  4396    N DA,AMOU NT,UNAPPLY ,COUNT,PRI NTOTL,COMM ENTS
  4397   "RTN","RCD PE215",152 ,0)
  4398    K ^TMP($J ,"RCDPR215 ")
  4399   "RTN","RCD PE215",153 ,0)
  4400    S DA=0 F   S DA=$O(^ RCY(344,RE CEIPDA,1,D A)) Q:'DA   D
  4401   "RTN","RCD PE215",154 ,0)
  4402    .   S AMO UNT=$P($G( ^RCY(344,R ECEIPDA,1, DA,0)),"^" ,4) I 'AMO UNT Q
  4403   "RTN","RCD PE215",155 ,0)
  4404    .   S UNA PPLY=$P($G (^RCY(344, RECEIPDA,1 ,DA,2)),"^ ",5) I UNA PPLY="" Q
  4405   "RTN","RCD PE215",156 ,0)
  4406    .   ;  if  amount ha s not been  processed , show it  in suspens e
  4407   "RTN","RCD PE215",157 ,0)
  4408    .   I '$P (^RCY(344, RECEIPDA,1 ,DA,0),"^" ,5) S ^TMP ($J,"RCDPR 215",DA)=U NAPPLY_"^" _AMOUNT_"^ "_$P($G(^R CY(344,REC EIPDA,1,DA ,1)),"^",2 )
  4409   "RTN","RCD PE215",158 ,0)
  4410    ;
  4411   "RTN","RCD PE215",159 ,0)
  4412    I $O(^TMP ($J,"RCDPR 215",0)) D
  4413   "RTN","RCD PE215",160 ,0)
  4414    .   D SET ("!!?5","A ppropriati on: 3875", .PCT)
  4415   "RTN","RCD PE215",161 ,0)
  4416    .   I RCT YPE="D" D  SET("!","" ,.PCT)
  4417   "RTN","RCD PE215",162 ,0)
  4418    .   ;
  4419   "RTN","RCD PE215",163 ,0)
  4420    .   S COU NT=0,PRINT OTL=0
  4421   "RTN","RCD PE215",164 ,0)
  4422    .   S DA= 0 F  S DA= $O(^TMP($J ,"RCDPR215 ",DA)) Q:' DA!($G(RCS TFLAG))  D
  4423   "RTN","RCD PE215",165 ,0)
  4424    .   .   ;
  4425   "RTN","RCD PE215",166 ,0)
  4426    .   .   S  UNAPPLY=$ P(^TMP($J, "RCDPR215" ,DA),"^"), AMOUNT=$P( ^(DA),"^", 2),COMMENT S=$P(^(DA) ,"^",3)
  4427   "RTN","RCD PE215",167 ,0)
  4428    .   .   S  PRINTOTL= PRINTOTL+A MOUNT
  4429   "RTN","RCD PE215",168 ,0)
  4430    .   .   S  $P(TOTAL, "^")=$P(TO TAL,"^")+A MOUNT
  4431   "RTN","RCD PE215",169 ,0)
  4432    .   .   ;   no detai l if accru ed report
  4433   "RTN","RCD PE215",170 ,0)
  4434    .   .   I  RCTYPE="A " Q
  4435   "RTN","RCD PE215",171 ,0)
  4436    .   .   ;
  4437   "RTN","RCD PE215",172 ,0)
  4438    .   .   S  COUNT=COU NT+1
  4439   "RTN","RCD PE215",173 ,0)
  4440    .   .   D  SET("!?5" ,COUNT_")" ,.PCT),SET ("?10",UNA PPLY,.PCT) ,SET("?30" ,$J(AMOUNT ,10,2),.PC T),SET("?4 5","COMMEN TS: "_$E(C OMMENTS,1, 25),.PCT)
  4441   "RTN","RCD PE215",174 ,0)
  4442    .   .   I  $TR($E(CO MMENTS,26, 80)," ")'= "" D SET(" !?25",$E(C OMMENTS,26 ,80),.PCT)
  4443   "RTN","RCD PE215",175 ,0)
  4444    .   .   ; PRCA*4.5*3 21 - BEGIN
  4445   "RTN","RCD PE215",176 ,0)
  4446    .   .   ;  Get comme nt history  from RCDP E COMMENT  HISTORY fi le #344.73
  4447   "RTN","RCD PE215",177 ,0)
  4448    .   .   N  RCCHIS,RC COM,RCSUB
  4449   "RTN","RCD PE215",178 ,0)
  4450    .   .   D  GET^RCDPE CH(.RCCHIS ,RECEIPDA, DA)
  4451   "RTN","RCD PE215",179 ,0)
  4452    .   .   S  RCSUB=0
  4453   "RTN","RCD PE215",180 ,0)
  4454    .   .   F   S RCSUB= $O(RCCHIS( RCSUB)) Q: 'RCSUB  D
  4455   "RTN","RCD PE215",181 ,0)
  4456    .   .   .   I RCSUB> 1 D
  4457   "RTN","RCD PE215",182 ,0)
  4458    .   .   .    .  S RC COM=$P(RCC HIS(RCSUB) ,U,3)
  4459   "RTN","RCD PE215",183 ,0)
  4460    .   .   .    .  D SE T("!?45"," COMMENTS:  "_$E(RCCOM ,1,25),.PC T)
  4461   "RTN","RCD PE215",184 ,0)
  4462    .   .   .    .  I $T R($E(RCCOM ,26,80),"  ")'="" D S ET("!?25", $E(RCCOM,2 6,80),.PCT )
  4463   "RTN","RCD PE215",185 ,0)
  4464    .   .   .   D SET("! ?45","ADDE D BY USER:  "_$P(RCCH IS(RCSUB), U,2),.PCT)
  4465   "RTN","RCD PE215",186 ,0)
  4466    .   .   .   D SET("! ?45","ADDE D: "_$P(RC CHIS(RCSUB ),U,1),.PC T)
  4467   "RTN","RCD PE215",187 ,0)
  4468    .   .   ; PRCA*4.5*3 21 - END
  4469   "RTN","RCD PE215",188 ,0)
  4470    .   ;
  4471   "RTN","RCD PE215",189 ,0)
  4472    .   S $P( ^TMP($J,"R CTOT","TOT AL"),U)=($ P($G(^TMP( $J,"RCTOT" ,"TOTAL")) ,U)+PRINTO TL)
  4473   "RTN","RCD PE215",190 ,0)
  4474    .   I RCT YPE="D" D  SET("!?30" ,"-------- --",.PCT), SET("!?5", "TOTAL for  3875",.PC T)
  4475   "RTN","RCD PE215",191 ,0)
  4476    .   D SET ("?30",$J( PRINTOTL,1 0,2),.PCT)
  4477   "RTN","RCD PE215",192 ,0)
  4478    .   S ^TM P($J,"RCTO T","SUSPEN SE")=$G(^T MP($J,"RCT OT","SUSPE NSE"))+PRI NTOTL
  4479   "RTN","RCD PE215",193 ,0)
  4480    Q
  4481   "RTN","RCD PE215",194 ,0)
  4482    ;
  4483   "RTN","RCD PE215",195 ,0)
  4484    ;
  4485   "RTN","RCD PE215",196 ,0)
  4486   GETTYPE()  ;  ask typ e of repor t to print
  4487   "RTN","RCD PE215",197 ,0)
  4488    N DIR,X,Y
  4489   "RTN","RCD PE215",198 ,0)
  4490    S DIR(0)= "S^A:ACCRU ED;D:DETAI LED",DIR(" A")="ACCRU ED OR DETA ILED REPOR T",DIR("B" )="ACCRUED ",DIR("?") ="A DETAIL ED Report  will list  out accrue d bills se parately"
  4491   "RTN","RCD PE215",199 ,0)
  4492    S DIR("?" ,1)="An AC CRUED Repo rt will li st just th e accrued  total unde r each app ropriation "
  4493   "RTN","RCD PE215",200 ,0)
  4494    D ^DIR
  4495   "RTN","RCD PE215",201 ,0)
  4496    I Y'="A", Y'="D" Q " "
  4497   "RTN","RCD PE215",202 ,0)
  4498    Q Y
  4499   "RTN","RCD PE215",203 ,0)
  4500    ;
  4501   "RTN","RCD PE215",204 ,0)
  4502    ;
  4503   "RTN","RCD PE215",205 ,0)
  4504   H ;  Depos it hdr
  4505   "RTN","RCD PE215",206 ,0)
  4506    N Z
  4507   "RTN","RCD PE215",207 ,0)
  4508    S PAGE=PA GE+1 I PAG E'=1!(SCRE EN) W @IOF
  4509   "RTN","RCD PE215",208 ,0)
  4510    W $C(13), "Page ",PA GE,?(80-$L (NOW)),NOW
  4511   "RTN","RCD PE215",209 ,0)
  4512    W !,$E($T R(RCYLINE, "-","*"),1 ,26)," 215  DEPOSIT S UMMARY REP ORT ",$E($ TR(RCYLINE ,"-","*"), 1,26)
  4513   "RTN","RCD PE215",210 ,0)
  4514    W !!,"DEP OSIT #: ", DEPOSIT
  4515   "RTN","RCD PE215",211 ,0)
  4516    W !,RCYLI NE
  4517   "RTN","RCD PE215",212 ,0)
  4518    Q
  4519   "RTN","RCD PE215",213 ,0)
  4520    ;
  4521   "RTN","RCD PE215",214 ,0)
  4522   H1(CONT) ;  Receipt H dr
  4523   "RTN","RCD PE215",215 ,0)
  4524    ; CONT =  1 if conti nuation fr om previou s page
  4525   "RTN","RCD PE215",216 ,0)
  4526    ;
  4527   "RTN","RCD PE215",217 ,0)
  4528    N Z
  4529   "RTN","RCD PE215",218 ,0)
  4530    W !!,"REC EIPT #: "_ RECEIPT_$S ($G(CONT): " (continu ed)",1:"")
  4531   "RTN","RCD PE215",219 ,0)
  4532    I FMSDOCN O'="" W ?5 1,"FMS Doc ument #: " ,FMSDOCNO
  4533   "RTN","RCD PE215",220 ,0)
  4534    S Z="",$P (Z,"-",$L( RECEIPT)+1 )=""
  4535   "RTN","RCD PE215",221 ,0)
  4536    W !,?11,Z
  4537   "RTN","RCD PE215",222 ,0)
  4538    S Z=""
  4539   "RTN","RCD PE215",223 ,0)
  4540    I $P($G(^ RCY(344,RE CEIPDA,0)) ,U,18) S Z =$E(" REFE RENCE ERA  #: "_$P($G (^RCY(344. 4,+$P($G(^ RCY(344,RE CEIPDA,0)) ,U,18),0)) ,U)_" ("_$ P($G(^RCY( 344.4,+$P( $G(^RCY(34 4,RECEIPDA ,0)),U,18) ,0)),U,2)_ ")"_$J("", 51),1,51)
  4541   "RTN","RCD PE215",224 ,0)
  4542    I Z'="" W  !,Z
  4543   "RTN","RCD PE215",225 ,0)
  4544    W !
  4545   "RTN","RCD PE215",226 ,0)
  4546    Q
  4547   "RTN","RCD PE215",227 ,0)
  4548    ;
  4549   "RTN","RCD PE215",228 ,0)
  4550    ;
  4551   "RTN","RCD PE215",229 ,0)
  4552   PAUSE ;
  4553   "RTN","RCD PE215",230 ,0)
  4554    D PAUSE^R CDPR215
  4555   "RTN","RCD PE215",231 ,0)
  4556    Q
  4557   "RTN","RCD PE215",232 ,0)
  4558    ;
  4559   "RTN","RCD PE215",233 ,0)
  4560   SET(CTRL,T XT,PCT,NOS P) ; Sets  print arra y for deta il
  4561   "RTN","RCD PE215",234 ,0)
  4562    ;PCT = co unt of lin es
  4563   "RTN","RCD PE215",235 ,0)
  4564    ;CTRL = C ontrol cha racters
  4565   "RTN","RCD PE215",236 ,0)
  4566    ;TXT = te xt to prin t
  4567   "RTN","RCD PE215",237 ,0)
  4568    ;NOSP = 1  if line s hould alwa ys print w ith the pr evious lin e
  4569   "RTN","RCD PE215",238 ,0)
  4570    S PCT=PCT +1,^TMP($J ,"RCDET",P CT)=CTRL_U _TXT_U_+$G (NOSP)
  4571   "RTN","RCD PE215",239 ,0)
  4572    Q
  4573   "RTN","RCD PE215",240 ,0)
  4574    ;
  4575   "RTN","RCD PEAA1")
  4576   0^44^B1623 48483
  4577   "RTN","RCD PEAA1",1,0 )
  4578   RCDPEAA1 ; ALB/KML -  AUTO POST  AWAITING R ESOLUTION  (APAR) - L IST OF UNP OSTED EEOB S ;Jun 06,  2014@19:1 1:19
  4579   "RTN","RCD PEAA1",2,0 )
  4580    ;;4.5;Acc ounts Rece ivable;**2 98,304,317 ,321**;Mar  20, 1995; Build 46
  4581   "RTN","RCD PEAA1",3,0 )
  4582    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  4583   "RTN","RCD PEAA1",4,0 )
  4584    Q
  4585   "RTN","RCD PEAA1",5,0 )
  4586    ;
  4587   "RTN","RCD PEAA1",6,0 )
  4588   EN ; Main  entry poin t
  4589   "RTN","RCD PEAA1",7,0 )
  4590    N RCQUIT, RCPROG
  4591   "RTN","RCD PEAA1",8,0 )
  4592    S RCQUIT= 0
  4593   "RTN","RCD PEAA1",9,0 )
  4594    S RCPROG= "RCDPEAA1"
  4595   "RTN","RCD PEAA1",10, 0)
  4596    ; Calling  Change Vi ew API in  Menu Optio n Mode
  4597   "RTN","RCD PEAA1",11, 0)
  4598    S RCQUIT= $$PARAMS(" MO") ; PRC A*4.5*321
  4599   "RTN","RCD PEAA1",12, 0)
  4600    Q:RCQUIT
  4601   "RTN","RCD PEAA1",13, 0)
  4602    D EN^VALM ("RCDPE AP AR EEOB LI ST")
  4603   "RTN","RCD PEAA1",14, 0)
  4604    ;
  4605   "RTN","RCD PEAA1",15, 0)
  4606   ENQ Q
  4607   "RTN","RCD PEAA1",16, 0)
  4608    ;
  4609   "RTN","RCD PEAA1",17, 0)
  4610   INIT ; EP  Listman Te mplate - R CDPE APAR  EEOB LIST
  4611   "RTN","RCD PEAA1",18, 0)
  4612    ;
  4613   "RTN","RCD PEAA1",19, 0)
  4614    ; Paramet ers for se lecting EE OBs to be  included i n the list  are
  4615   "RTN","RCD PEAA1",20, 0)
  4616    ; contain ed in the  global ^TM P("RCDPE_A PAR_EEOB_P ARAMS",$J, parameter  name)
  4617   "RTN","RCD PEAA1",21, 0)
  4618    ;
  4619   "RTN","RCD PEAA1",22, 0)
  4620    ; PRCA*4. 5*321 - St art modifi ed code bl ock
  4621   "RTN","RCD PEAA1",23, 0)
  4622    N FDTTM,P 1,P2,RCAPA R,RCDA,RCP ROG
  4623   "RTN","RCD PEAA1",24, 0)
  4624    S RCAPAR= 1,P1="RCDP E_APAR_EEO B_PASS1",P 2="RCDPE_A PAR_EEOB_P ASS2"
  4625   "RTN","RCD PEAA1",25, 0)
  4626    S RCPROG= "RCDPE-APA R_EEOB_WL"
  4627   "RTN","RCD PEAA1",26, 0)
  4628    D FULL^VA LM1,CLEAN^ VALM10
  4629   "RTN","RCD PEAA1",27, 0)
  4630    K ^TMP($J ,RCPROG),^ TMP($J,P1) ,^TMP($J,P 2)
  4631   "RTN","RCD PEAA1",28, 0)
  4632    K ^TMP(RC PROG,$J),^ TMP("RCDPE -APAR_EEOB _WLDX",$J)
  4633   "RTN","RCD PEAA1",29, 0)
  4634    ; First P ass - Get  ERAs that  are in a ' partial' a uto-post s tatus
  4635   "RTN","RCD PEAA1",30, 0)
  4636    S RCDA=0
  4637   "RTN","RCD PEAA1",31, 0)
  4638    F  D  Q:' RCDA
  4639   "RTN","RCD PEAA1",32, 0)
  4640    . S RCDA= $O(^RCY(34 4.4,"E",1, RCDA))
  4641   "RTN","RCD PEAA1",33, 0)
  4642    . Q:'RCDA
  4643   "RTN","RCD PEAA1",34, 0)
  4644    . Q:'$$FI LTER(RCDA)   ; Record  didn't pa ss filter  criteria
  4645   "RTN","RCD PEAA1",35, 0)
  4646    . S ^TMP( $J,P1,RCDA )=""
  4647   "RTN","RCD PEAA1",36, 0)
  4648    ;
  4649   "RTN","RCD PEAA1",37, 0)
  4650    D:$D(^TMP ($J,P1)) B LD^RCDPEAA 4(P1,P2,RC PROG) ; Bu ild, Sort  and Output  the list
  4651   "RTN","RCD PEAA1",38, 0)
  4652    ;
  4653   "RTN","RCD PEAA1",39, 0)
  4654    ; If no E EOBs found  display t he message  below in  the list a rea
  4655   "RTN","RCD PEAA1",40, 0)
  4656    I '$O(^TM P(RCPROG,$ J,0)) D
  4657   "RTN","RCD PEAA1",41, 0)
  4658    . S ^TMP( RCPROG,$J, 1,0)="THER E ARE NO E EOBs MATCH ING YOUR S ELECTION C RITERIA"
  4659   "RTN","RCD PEAA1",42, 0)
  4660    . S VALMC NT=1
  4661   "RTN","RCD PEAA1",43, 0)
  4662    ; PRCA*4. 5*321 - En d modified  code bloc k
  4663   "RTN","RCD PEAA1",44, 0)
  4664    Q
  4665   "RTN","RCD PEAA1",45, 0)
  4666    ;
  4667   "RTN","RCD PEAA1",46, 0)
  4668   HDR ;
  4669   "RTN","RCD PEAA1",47, 0)
  4670    N LINE,RC MDRX,RCPAY R,SORT,X,Y
  4671   "RTN","RCD PEAA1",48, 0)
  4672    S RCPAYR= $G(^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"RCP AYR"))
  4673   "RTN","RCD PEAA1",49, 0)
  4674    S RCMDRX= $G(^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"RCM EDRX"))
  4675   "RTN","RCD PEAA1",50, 0)
  4676    S Y=$S(RC MDRX="M":" MEDICAL",R CMDRX="P": "PHARMACY" ,1:"MEDICA L + PHARMA CY")_" CLA IMS"
  4677   "RTN","RCD PEAA1",51, 0)
  4678    S X=$S(($ P(RCPAYR,U )="A")!(RC PAYR=""):" ALL PAYERS ",1:"PAYER S: "_$P(RC PAYR,U,2)_ "-"_$P(RCP AYR,U,3))
  4679   "RTN","RCD PEAA1",52, 0)
  4680    S VALMHDR (1)="Curre nt View:"_ $J("",4)_Y _" for "_X
  4681   "RTN","RCD PEAA1",53, 0)
  4682    ; PRCA*4. 5*321 - St art modifi ed code bl ock
  4683   "RTN","RCD PEAA1",54, 0)
  4684    S SORT=$P ($G(^TMP(" RCDPE_APAR _EEOB_PARA MS",$J,"SO RT")),"^", 1)
  4685   "RTN","RCD PEAA1",55, 0)
  4686    S X=$S(SO RT="N":"Pa yer Name", SORT="R":" Reason",SO RT="D":"Da te",SORT=" U":"Unpost ed",1:"Pos ted")
  4687   "RTN","RCD PEAA1",56, 0)
  4688    S Y=$P($G (^TMP("RCD PE_APAR_EE OB_PARAMS" ,$J,"SORT" )),"^",2)
  4689   "RTN","RCD PEAA1",57, 0)
  4690    I SORT="D " S X=X_$S (Y="H":" -  Descendin g",1:" - A scending")
  4691   "RTN","RCD PEAA1",58, 0)
  4692    E  S X=X_ $S(Y="H":"  - Highest  to Lowest ",Y="L":"  - Lowest t o Highest" ,1:"")
  4693   "RTN","RCD PEAA1",59, 0)
  4694    S VALMHDR (2)="   So rted By:"_ $J("",4)_X
  4695   "RTN","RCD PEAA1",60, 0)
  4696    S LINE=$J ("",10)_$$ LJ^XLFSTR( "ERA #.Seq uence",17)
  4697   "RTN","RCD PEAA1",61, 0)
  4698    S LINE=LI NE_$$LJ^XL FSTR("Clai m #",14)
  4699   "RTN","RCD PEAA1",62, 0)
  4700    S LINE=LI NE_$$RJ^XL FSTR("Post ed",13)_"  "
  4701   "RTN","RCD PEAA1",63, 0)
  4702    ; S LINE= LINE_$$LJ^ XLFSTR("Po st Dt",11)
  4703   "RTN","RCD PEAA1",64, 0)
  4704    S LINE=LI NE_$$LJ^XL FSTR("Crea ted Dt",11 ) ; PRCA*4 .5*321
  4705   "RTN","RCD PEAA1",65, 0)
  4706    S LINE=LI NE_$$RJ^XL FSTR("Unpo sted",13)
  4707   "RTN","RCD PEAA1",66, 0)
  4708    ; PRCA*4. 5*321 - En d modified  code bloc k
  4709   "RTN","RCD PEAA1",67, 0)
  4710    S VALMHDR (3)=LINE
  4711   "RTN","RCD PEAA1",68, 0)
  4712    Q
  4713   "RTN","RCD PEAA1",69, 0)
  4714    ;
  4715   "RTN","RCD PEAA1",70, 0)
  4716   EXIT ; --  Clean up l ist
  4717   "RTN","RCD PEAA1",71, 0)
  4718    ; PRCA*4. 5*321 - St art modifi ed code bl ock
  4719   "RTN","RCD PEAA1",72, 0)
  4720    K ^TMP("R CDPE_APAR_ PVW",$J)
  4721   "RTN","RCD PEAA1",73, 0)
  4722    K ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J)
  4723   "RTN","RCD PEAA1",74, 0)
  4724    K ^TMP("R CDPE-APAR_ EEOB_WL",$ J),^TMP("R CDPE-APAR_ EEOB_WLDX" ,$J)
  4725   "RTN","RCD PEAA1",75, 0)
  4726    K ^TMP($J ,"RCDPE_AP AR_EEOB_PA SS1"),^TMP ($J,"RCDPE _APAR_EEOB _PASS2")
  4727   "RTN","RCD PEAA1",76, 0)
  4728    ; PRCA*4. 5*321 - En d modified  code bloc k
  4729   "RTN","RCD PEAA1",77, 0)
  4730    K RCAPAR
  4731   "RTN","RCD PEAA1",78, 0)
  4732    Q
  4733   "RTN","RCD PEAA1",79, 0)
  4734    ;
  4735   "RTN","RCD PEAA1",80, 0)
  4736   PARAMS(SOU RCE) ; Ret rieve/Edit /Save View  Parameter s for APAR  EEOB Work list
  4737   "RTN","RCD PEAA1",81, 0)
  4738    ; Input:    SOURCE       - "MO"  - Called  from Menu  Option 
  4739   "RTN","RCD PEAA1",82, 0)
  4740    ;                          "CV"  - Called  from Chang e View act ion
  4741   "RTN","RCD PEAA1",83, 0)
  4742    ; Output:  ^TMP("RCD PE_APAR_EE OB_PARAMS" ,$J,"RCPAY R") - P1^P 2^P3 Where :
  4743   "RTN","RCD PEAA1",84, 0)
  4744    ;                                                           P1-  All Payers /Range of  Payers
  4745   "RTN","RCD PEAA1",85, 0)
  4746    ;                                                                ("A": All/ "R":Range  of Payers)
  4747   "RTN","RCD PEAA1",86, 0)
  4748    ;                                                           P2-  START WITH  PAYER (e. g.,'AET')
  4749   "RTN","RCD PEAA1",87, 0)
  4750    ;                                                                (Range Lim ited Only)
  4751   "RTN","RCD PEAA1",88, 0)
  4752    ;                                                           P3-  GO TO PAYE R (e.g.,'A ETZ')
  4753   "RTN","RCD PEAA1",89, 0)
  4754    ;                                                              ( Range Limi ted Only)
  4755   "RTN","RCD PEAA1",90, 0)
  4756    ;          ^TMP("RCD PE_APAR_EE OB_PARAMS" ,$J,"RCMED RX")-  (M) edical, (P )harmacy,  or (B)
  4757   "RTN","RCD PEAA1",91, 0)
  4758    ;        
  4759   "RTN","RCD PEAA1",92, 0)
  4760    ;          ^TMP("RCD PE_APAR_EE OB_PARAMS" ,$J,"SORT" ) - P1^P2  Where
  4761   "RTN","RCD PEAA1",93, 0)
  4762    ;                                                         P1 - S ort Type
  4763   "RTN","RCD PEAA1",94, 0)
  4764    ;                                                              " N" - Payer  Name
  4765   "RTN","RCD PEAA1",95, 0)
  4766    ;                                                              " P" - Poste d Amount
  4767   "RTN","RCD PEAA1",96, 0)
  4768    ;                                                              " R" - Auto- Post Rejec t Reason
  4769   "RTN","RCD PEAA1",97, 0)
  4770    ;                                                              " U" - Unpos ted Amount
  4771   "RTN","RCD PEAA1",98, 0)
  4772    ;                                                         P2 - H  - Highest  to Lowest  Amount
  4773   "RTN","RCD PEAA1",99, 0)
  4774    ;                                                              L  - Lowest  to Highest  Amount
  4775   "RTN","RCD PEAA1",100 ,0)
  4776    ;                                                              " "- If P1=" N" or "P"
  4777   "RTN","RCD PEAA1",101 ,0)
  4778    ; Returns : 1 if use r ^ arrowe d or timed  out, 0 ot herwise
  4779   "RTN","RCD PEAA1",102 ,0)
  4780    N RCQUIT, RCXPAR,USE PVW,XX     ;PRCA*4.5* 321 added  RCQUIT
  4781   "RTN","RCD PEAA1",103 ,0)
  4782    S (RCQUIT ,USEPVW)=0            ;PRCA*4.5* 321 initia lise USEPW
  4783   "RTN","RCD PEAA1",104 ,0)
  4784    ; Retriev e user's s aved prefe rred view  (if any)
  4785   "RTN","RCD PEAA1",105 ,0)
  4786    D:SOURCE= "MO" GETWL PVW(.RCXPA R)
  4787   "RTN","RCD PEAA1",106 ,0)
  4788    ;
  4789   "RTN","RCD PEAA1",107 ,0)
  4790    ;Only ask  user if t hey want t o use thei r preferre d view in  the follow ing scenar ios:
  4791   "RTN","RCD PEAA1",108 ,0)
  4792    ; a) Sour ce is "MO"  and user  has a pref erred view  on file
  4793   "RTN","RCD PEAA1",109 ,0)
  4794    ; b) Sour ce is "CV"  (change v iew action ), user ha s a prefer red view b ut is
  4795   "RTN","RCD PEAA1",110 ,0)
  4796    ;    not  using the  preferred  view crite ria at thi s time.
  4797   "RTN","RCD PEAA1",111 ,0)
  4798    S XX=$$PR EFVW(SOURC E)
  4799   "RTN","RCD PEAA1",112 ,0)
  4800    I ((XX=1) &(SOURCE=" MO"))!((XX =0)&(SOURC E="CV")) D   ; PRCA*4 .5*321 - m ove Q:USEP VW
  4801   "RTN","RCD PEAA1",113 ,0)
  4802    . ;
  4803   "RTN","RCD PEAA1",114 ,0)
  4804    . ; Ask t he user if  they want  to use th e preferre d view
  4805   "RTN","RCD PEAA1",115 ,0)
  4806    . S USEPV W=$$ASKUVW ^RCDPEWL0( )
  4807   "RTN","RCD PEAA1",116 ,0)
  4808    . I USEPV W=-1 S RCQ UIT=1 Q
  4809   "RTN","RCD PEAA1",117 ,0)
  4810    . Q:'USEP VW
  4811   "RTN","RCD PEAA1",118 ,0)
  4812    . ;
  4813   "RTN","RCD PEAA1",119 ,0)
  4814    . ; Set t he Sort/Fi ltering Cr iteria fro m the pref erred view  
  4815   "RTN","RCD PEAA1",120 ,0)
  4816    . M ^TMP( "RCDPE_APA R_EEOB_PAR AMS",$J)=^ TMP("RCDPE _APAR_PVW" ,$J)
  4817   "RTN","RCD PEAA1",121 ,0)
  4818    ;
  4819   "RTN","RCD PEAA1",122 ,0)
  4820    ; PRCA*4. 5*321 - St art modifi ed code bl ock
  4821   "RTN","RCD PEAA1",123 ,0)
  4822    Q:USEPVW  0
  4823   "RTN","RCD PEAA1",124 ,0)
  4824    Q:RCQUIT  1
  4825   "RTN","RCD PEAA1",125 ,0)
  4826    S RCQUIT= $$PAYR() ;  Select Pa yer(s)
  4827   "RTN","RCD PEAA1",126 ,0)
  4828    Q:RCQUIT  1
  4829   "RTN","RCD PEAA1",127 ,0)
  4830    S RCQUIT= $$MORP() ;  Select Me dical or P harmacy
  4831   "RTN","RCD PEAA1",128 ,0)
  4832    Q:RCQUIT  1
  4833   "RTN","RCD PEAA1",129 ,0)
  4834    S RCQUIT= $$SORT() ;  Select So rt
  4835   "RTN","RCD PEAA1",130 ,0)
  4836    Q:RCQUIT  1
  4837   "RTN","RCD PEAA1",131 ,0)
  4838    S RCQUIT= $$SAVEPVW( ) ; Save P referred V iew
  4839   "RTN","RCD PEAA1",132 ,0)
  4840    Q:RCQUIT  1
  4841   "RTN","RCD PEAA1",133 ,0)
  4842    Q 0
  4843   "RTN","RCD PEAA1",134 ,0)
  4844    ; PRCA*4. 5*321 - En d modified  code bloc k
  4845   "RTN","RCD PEAA1",135 ,0)
  4846    ;
  4847   "RTN","RCD PEAA1",136 ,0)
  4848   GETWLPVW(R CXPAR)  ;  Retrieves  the prefer red view s ettings fo r the APAR  worklist
  4849   "RTN","RCD PEAA1",137 ,0)
  4850    ; for the  user
  4851   "RTN","RCD PEAA1",138 ,0)
  4852    ; PRCA*4. 5*317 - Ad ded subrou tine
  4853   "RTN","RCD PEAA1",139 ,0)
  4854    ; Input:    None
  4855   "RTN","RCD PEAA1",140 ,0)
  4856    ; Output:   RCXPAR()                           - Arra y of prefe rred view  sort/filte r criteria
  4857   "RTN","RCD PEAA1",141 ,0)
  4858    ;           ^TMP("RC DPE_APAR_E EOB_PARAMS ",$)- Glob al array o f preferre d view set tings
  4859   "RTN","RCD PEAA1",142 ,0)
  4860    N XX
  4861   "RTN","RCD PEAA1",143 ,0)
  4862    K ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J)
  4863   "RTN","RCD PEAA1",144 ,0)
  4864    D GETLST^ XPAR(.RCXP AR,"USR"," RCDPE APAR ","I")
  4865   "RTN","RCD PEAA1",145 ,0)
  4866    D:$D(RCXP AR("ALL_PA YERS/RANGE _OF_PAYERS ")) PVWSAV E(.RCXPAR)
  4867   "RTN","RCD PEAA1",146 ,0)
  4868    ;
  4869   "RTN","RCD PEAA1",147 ,0)
  4870    S XX=$G(R CXPAR("ALL _PAYERS/RA NGE_OF_PAY ERS"))
  4871   "RTN","RCD PEAA1",148 ,0)
  4872    S ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"RCP AYR")=$S(X X'="":$TR( XX,";","^" ),1:"A")
  4873   "RTN","RCD PEAA1",149 ,0)
  4874    S XX=$G(R CXPAR("MED ICAL/PHARM ACY"))
  4875   "RTN","RCD PEAA1",150 ,0)
  4876    S ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"RCM EDRX")=$S( XX'="":$TR (XX,";","^ "),1:"B")
  4877   "RTN","RCD PEAA1",151 ,0)
  4878    ; PRCA&4. 5*321 - ad d sort to  preferened  view
  4879   "RTN","RCD PEAA1",152 ,0)
  4880    S XX=$G(R CXPAR("SOR T"))
  4881   "RTN","RCD PEAA1",153 ,0)
  4882    S ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"SOR T")=$S(XX' ="":$TR(XX ,";","^"), 1:"N")
  4883   "RTN","RCD PEAA1",154 ,0)
  4884    Q
  4885   "RTN","RCD PEAA1",155 ,0)
  4886    ;
  4887   "RTN","RCD PEAA1",156 ,0)
  4888   PVWSAVE(RC XPAR) ; Sa ve a copy  of the pre ferred vie w on file
  4889   "RTN","RCD PEAA1",157 ,0)
  4890    ; PRCA*4. 5*317 adde d subrouti ne
  4891   "RTN","RCD PEAA1",158 ,0)
  4892    ; Input:  RCXPAR - a rray of pr eferred vi ew setting  for the u ser
  4893   "RTN","RCD PEAA1",159 ,0)
  4894    ; Output:  ^TMP("RCE RA_PVW") -  a copy of  the prefe rred setti ngs
  4895   "RTN","RCD PEAA1",160 ,0)
  4896    ;
  4897   "RTN","RCD PEAA1",161 ,0)
  4898    K ^TMP("R CDPE_APAR_ PVW",$J)
  4899   "RTN","RCD PEAA1",162 ,0)
  4900    ; only co ntinue if  we have an swers to a ll APAR re lated pref erred view  prompts
  4901   "RTN","RCD PEAA1",163 ,0)
  4902    Q:'$D(RCX PAR("ALL_P AYERS/RANG E_OF_PAYER S"))
  4903   "RTN","RCD PEAA1",164 ,0)
  4904    Q:'$D(RCX PAR("MEDIC AL/PHARMAC Y"))
  4905   "RTN","RCD PEAA1",165 ,0)
  4906    Q:'$D(RCX PAR("SORT" ))  ; PRCA *4.5*321
  4907   "RTN","RCD PEAA1",166 ,0)
  4908    ;
  4909   "RTN","RCD PEAA1",167 ,0)
  4910    S ^TMP("R CDPE_APAR_ PVW",$J,"R CPAYR")=$T R(RCXPAR(" ALL_PAYERS /RANGE_OF_ PAYERS")," ;","^")
  4911   "RTN","RCD PEAA1",168 ,0)
  4912    S ^TMP("R CDPE_APAR_ PVW",$J,"R CMEDRX")=$ TR(RCXPAR( "MEDICAL/P HARMACY"), ";","^")
  4913   "RTN","RCD PEAA1",169 ,0)
  4914    S ^TMP("R CDPE_APAR_ PVW",$J,"S ORT")=$TR( RCXPAR("SO RT"),";"," ^") ; PRCA *4.5*321
  4915   "RTN","RCD PEAA1",170 ,0)
  4916    Q
  4917   "RTN","RCD PEAA1",171 ,0)
  4918    ;
  4919   "RTN","RCD PEAA1",172 ,0)
  4920   PREFVW(SOU RCE,RCXPAR ) ; Checks  to see if  the user  has a pref erred view
  4921   "RTN","RCD PEAA1",173 ,0)
  4922    ; PRCA*4. 5*317 adde d subrouti ne
  4923   "RTN","RCD PEAA1",174 ,0)
  4924    ; When so urce is 'C V', checks  to see if  the prefe rred view  is being u sed
  4925   "RTN","RCD PEAA1",175 ,0)
  4926    ; Input:    SOURCE                            - 'MO'  - When cal led from t he Lockbox  menu
  4927   "RTN","RCD PEAA1",176 ,0)
  4928    ;                                                       option
  4929   "RTN","RCD PEAA1",177 ,0)
  4930    ;                                               'CV'  - When cal led from t he Change  View
  4931   "RTN","RCD PEAA1",178 ,0)
  4932    ;                                                       action
  4933   "RTN","RCD PEAA1",179 ,0)
  4934    ;           RCXPAR                           - Array  of preferr ed view va lues
  4935   "RTN","RCD PEAA1",180 ,0)
  4936    ;           ^TMP("RC DPE_APAR_E EOB_PARAMS ")- Global  array of  currently  in use def aults
  4937   "RTN","RCD PEAA1",181 ,0)
  4938    ;           ^TMP("RC DPE_APAR_P VW",$J)      - Global  array of  preferred  view setti ngs
  4939   "RTN","RCD PEAA1",182 ,0)
  4940    ;
  4941   "RTN","RCD PEAA1",183 ,0)
  4942    ; Returns : 1 - User  has prefe rred view  if SOURCE  is 'MO' or  is using
  4943   "RTN","RCD PEAA1",184 ,0)
  4944    ;               thei r preferre d view if  SOURCE is  'CV'
  4945   "RTN","RCD PEAA1",185 ,0)
  4946    ;           0 - User  is not us ing their  preferred  view
  4947   "RTN","RCD PEAA1",186 ,0)
  4948    ;          -1 - User  does not  have a pre ferred vie w
  4949   "RTN","RCD PEAA1",187 ,0)
  4950    ;
  4951   "RTN","RCD PEAA1",188 ,0)
  4952    I SOURCE= "MO" Q $S( $D(^TMP("R CDPE_APAR_ PVW",$J)): 1,1:-1)
  4953   "RTN","RCD PEAA1",189 ,0)
  4954    Q:'$D(^TM P("RCDPE_A PAR_PVW",$ J)) -1       ; No sto red prefer red view
  4955   "RTN","RCD PEAA1",190 ,0)
  4956    Q:$G(^TMP ("RCDPE_AP AR_EEOB_PA RAMS",$J," RCPAYR"))' =$G(^TMP(" RCDPE_APAR _PVW",$J," RCPAYR"))  0
  4957   "RTN","RCD PEAA1",191 ,0)
  4958    Q:$G(^TMP ("RCDPE_AP AR_EEOB_PA RAMS",$J," RCMEDRX")) '=$G(^TMP( "RCDPE_APA R_PVW",$J, "RCMEDRX") ) 0
  4959   "RTN","RCD PEAA1",192 ,0)
  4960    Q:$G(^TMP ("RCDPE_AP AR_EEOB_PA RAMS",$J," SORT"))'=$ G(^TMP("RC DPE_APAR_P VW",$J,"SO RT")) 0 ;  PRCA*4.5*3 21
  4961   "RTN","RCD PEAA1",193 ,0)
  4962    Q 1
  4963   "RTN","RCD PEAA1",194 ,0)
  4964    ;
  4965   "RTN","RCD PEAA1",195 ,0)
  4966   PAYR() ; P ayer Selec tion
  4967   "RTN","RCD PEAA1",196 ,0)
  4968    ; Input:    ^TMP("RC DPE_APAR_E EOB_PARAMS ",$J,"RCPA YR") - Cur rent payer  selection  setting
  4969   "RTN","RCD PEAA1",197 ,0)
  4970    ; Output:   ^TMP("RC DPE_APAR_E EOB_PARAMS ",$J,"RCPA YR") - Upd ated  paye r selectio n setting
  4971   "RTN","RCD PEAA1",198 ,0)
  4972    ;           RCQUIT=1  if user ^  or timed  out
  4973   "RTN","RCD PEAA1",199 ,0)
  4974    ; Returns : 1 if use r ^ arrowe d or time  out
  4975   "RTN","RCD PEAA1",200 ,0)
  4976    N DIR,DIR UT,DIROUT, DUOUT,DTOU T,RCPAYR,R CPAYRDF,RC XPAR,RCDRL IM,RCERROR ,RCAUTOPDF
  4977   "RTN","RCD PEAA1",201 ,0)
  4978    N RCTYPED F,RCQ,X,XX ,Y
  4979   "RTN","RCD PEAA1",202 ,0)
  4980    S RCPAYRD F=$G(^TMP( "RCDPE_APA R_EEOB_PAR AMS",$J,"R CPAYR"))
  4981   "RTN","RCD PEAA1",203 ,0)
  4982    S RCQUIT= 0
  4983   "RTN","RCD PEAA1",204 ,0)
  4984    K DIR
  4985   "RTN","RCD PEAA1",205 ,0)
  4986    S DIR(0)= "SA^A:ALL; R:RANGE"
  4987   "RTN","RCD PEAA1",206 ,0)
  4988    S DIR("A" )="(A)LL p ayers, (R) ANGE of pa yer names:  "
  4989   "RTN","RCD PEAA1",207 ,0)
  4990    S DIR("B" )="ALL"
  4991   "RTN","RCD PEAA1",208 ,0)
  4992    S DIR("?" ,1)="Enter ing ALL wi ll select  all payers ."
  4993   "RTN","RCD PEAA1",209 ,0)
  4994    S DIR("?" )="If RANG E is enter ed, you wi ll be prom pted for a  payer ran ge."
  4995   "RTN","RCD PEAA1",210 ,0)
  4996    S:$P(RCPA YRDF,"^")' ="" DIR("B ")=$P(RCPA YRDF,"^")   ;Stored p referred v iew, use a s default
  4997   "RTN","RCD PEAA1",211 ,0)
  4998    W !
  4999   "RTN","RCD PEAA1",212 ,0)
  5000    D ^DIR
  5001   "RTN","RCD PEAA1",213 ,0)
  5002    I $D(DTOU T)!$D(DUOU T) S RCQUI T=1 Q 1
  5003   "RTN","RCD PEAA1",214 ,0)
  5004    S RCPAYR= Y
  5005   "RTN","RCD PEAA1",215 ,0)
  5006    I RCPAYR= "A" S ^TMP ("RCDPE_AP AR_EEOB_PA RAMS",$J," RCPAYR")=Y  Q 0
  5007   "RTN","RCD PEAA1",216 ,0)
  5008    I RCPAYR= "R" D  Q:R CQUIT RCQU IT
  5009   "RTN","RCD PEAA1",217 ,0)
  5010    . W !,"Na mes you se lect here  will be th e payer na mes from t he ERA, NO T the INS  File"
  5011   "RTN","RCD PEAA1",218 ,0)
  5012    . K DIR
  5013   "RTN","RCD PEAA1",219 ,0)
  5014    . S DIR(" ?")="Enter  a name be tween 1 an d 30 chara cters in U PPERCASE"
  5015   "RTN","RCD PEAA1",220 ,0)
  5016    . S DIR(0 )="FA^1:30 ^K:X'?.U X ",DIR("A") ="Start wi th payer n ame: "
  5017   "RTN","RCD PEAA1",221 ,0)
  5018    . S:$P(RC PAYRDF,"^" ,2)'="" DI R("B")=$P( RCPAYRDF," ^",2)  ;St ored prefe rred view,  use as de fault
  5019   "RTN","RCD PEAA1",222 ,0)
  5020    . W !
  5021   "RTN","RCD PEAA1",223 ,0)
  5022    . D ^DIR
  5023   "RTN","RCD PEAA1",224 ,0)
  5024    . I $D(DT OUT)!$D(DU OUT) D  Q
  5025   "RTN","RCD PEAA1",225 ,0)
  5026    . . S RCQ UIT=1 Q
  5027   "RTN","RCD PEAA1",226 ,0)
  5028    . . K ^TM P("RCDPE_A PAR_EEOB_P ARAMS",$J, "RCPAYR")
  5029   "RTN","RCD PEAA1",227 ,0)
  5030    . S RCPAY R("FROM")= Y
  5031   "RTN","RCD PEAA1",228 ,0)
  5032    . K DIR
  5033   "RTN","RCD PEAA1",229 ,0)
  5034    . S DIR(" ?")="Enter  a name be tween 1 an d 30 chara cters in U PPERCASE"
  5035   "RTN","RCD PEAA1",230 ,0)
  5036    . S DIR(0 )="FA^1:30 ^K:X'?.U X ",DIR("A") ="Go to pa yer name:  "
  5037   "RTN","RCD PEAA1",231 ,0)
  5038    . S DIR(" B")=$E(RCP AYR("FROM" ),1,27)_"Z ZZ"
  5039   "RTN","RCD PEAA1",232 ,0)
  5040    . W ! D ^ DIR K DIR
  5041   "RTN","RCD PEAA1",233 ,0)
  5042    . I $D(DT OUT)!$D(DU OUT) S RCQ UIT=1 Q
  5043   "RTN","RCD PEAA1",234 ,0)
  5044    . S ^TMP( "RCDPE_APA R_EEOB_PAR AMS",$J,"R CPAYR")=RC PAYR_"^"_R CPAYR("FRO M")_"^"_Y
  5045   "RTN","RCD PEAA1",235 ,0)
  5046    Q 0
  5047   "RTN","RCD PEAA1",236 ,0)
  5048    ;
  5049   "RTN","RCD PEAA1",237 ,0)
  5050   MORP() ; A sk for Med ical or Ph armacy (Or  Both)
  5051   "RTN","RCD PEAA1",238 ,0)
  5052    ; Input:  None
  5053   "RTN","RCD PEAA1",239 ,0)
  5054    ; Returns : 1 if use r ^ arrowe d or timed  out, 0 ot herwise
  5055   "RTN","RCD PEAA1",240 ,0)
  5056    N DEF
  5057   "RTN","RCD PEAA1",241 ,0)
  5058    S DEF=$G( ^TMP("RCDP E_APAR_EEO B_PARAMS", $J,"RCMEDR X"))
  5059   "RTN","RCD PEAA1",242 ,0)
  5060    S DEF=$S( DEF="P":"P HARMACY",D EF="M":"ME DICAL",1:" BOTH")
  5061   "RTN","RCD PEAA1",243 ,0)
  5062    S RCQ=$$R TYPE^RCDPE SP2(DEF)
  5063   "RTN","RCD PEAA1",244 ,0)
  5064    I RCQ=-1  Q 1
  5065   "RTN","RCD PEAA1",245 ,0)
  5066    S ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"RCM EDRX")=RCQ
  5067   "RTN","RCD PEAA1",246 ,0)
  5068    Q 0
  5069   "RTN","RCD PEAA1",247 ,0)
  5070    ;
  5071   "RTN","RCD PEAA1",248 ,0)
  5072   SORT() ; A sk for Sor t - Payer,  Dollar, D ate, Trace  Number
  5073   "RTN","RCD PEAA1",249 ,0)
  5074    ; Input:  None
  5075   "RTN","RCD PEAA1",250 ,0)
  5076    ; Returns : 1 if use r ^ arrowe d or timed  out, 0 ot herwise
  5077   "RTN","RCD PEAA1",251 ,0)
  5078    N DEF,DIR ,DIRUT,DTO UT,DUOUT,P 1,X,XX,Y
  5079   "RTN","RCD PEAA1",252 ,0)
  5080    S DEF=$P( $G(^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"SOR T")),"^",1 )
  5081   "RTN","RCD PEAA1",253 ,0)
  5082    S DEF=$S( DEF="D":"D ATE",DEF=" N":"PAYER  NAME",DEF= "P":"POSTE D",DEF="R" :"REASON", DEF="U":"U NPOSTED",1 :"")
  5083   "RTN","RCD PEAA1",254 ,0)
  5084    S DIR(0)= "SA^D:DATE ;N:PAYER N AME;P:POST ED;R:REASO N;U:UNPOST ED"
  5085   "RTN","RCD PEAA1",255 ,0)
  5086    S DIR("A" )="Sort By  (D)ATE, P AYER (N)AM E, (R)EASO N, (P)OSTE D, (U)NPOS TED: "
  5087   "RTN","RCD PEAA1",256 ,0)
  5088    S DIR("B" )=$S(DEF'= "":DEF,1:" DATE")
  5089   "RTN","RCD PEAA1",257 ,0)
  5090    S DIR("?" ,1)="Enter  'DATE' to  sort by d ate create d."
  5091   "RTN","RCD PEAA1",258 ,0)
  5092    S DIR("?" ,2)="Enter  'PAYER NA ME' to sor t by payer  name."
  5093   "RTN","RCD PEAA1",259 ,0)
  5094    S DIR("?" ,3)="Enter  'REASON'  to sort by  auto-post  reject re ason."
  5095   "RTN","RCD PEAA1",260 ,0)
  5096    S DIR("?" ,4)="Enter  'POSTED'  to sort by  the poste d amount."
  5097   "RTN","RCD PEAA1",261 ,0)
  5098    S DIR("?" )="Enter ' UNPOSTED'  to sort by  the unpos ted amount ."
  5099   "RTN","RCD PEAA1",262 ,0)
  5100    W !
  5101   "RTN","RCD PEAA1",263 ,0)
  5102    D ^DIR
  5103   "RTN","RCD PEAA1",264 ,0)
  5104    I $D(DTOU T)!$D(DUOU T) Q 1
  5105   "RTN","RCD PEAA1",265 ,0)
  5106    I Y="N"!( Y="R") D   Q 0
  5107   "RTN","RCD PEAA1",266 ,0)
  5108    . S ^TMP( "RCDPE_APA R_EEOB_PAR AMS",$J,"S ORT")=Y
  5109   "RTN","RCD PEAA1",267 ,0)
  5110    ;
  5111   "RTN","RCD PEAA1",268 ,0)
  5112    S P1=Y,XX =""
  5113   "RTN","RCD PEAA1",269 ,0)
  5114    I P1="P"! (P1="U") S  XX=$$HTOL () I XX=-1  Q 1
  5115   "RTN","RCD PEAA1",270 ,0)
  5116    I P1="D"  S XX=$$DAT EORD() I X X=-1 Q 1
  5117   "RTN","RCD PEAA1",271 ,0)
  5118    S ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"SOR T")=P1_"^" _XX
  5119   "RTN","RCD PEAA1",272 ,0)
  5120    Q 0
  5121   "RTN","RCD PEAA1",273 ,0)
  5122    ;
  5123   "RTN","RCD PEAA1",274 ,0)
  5124   HTOL() ; A sk for how  dollar am ounts shou ld be sort ed - eithe r highest  to
  5125   "RTN","RCD PEAA1",275 ,0)
  5126    ; lowest  amount or  lowest to  highest am ount
  5127   "RTN","RCD PEAA1",276 ,0)
  5128    ; Input:  None
  5129   "RTN","RCD PEAA1",277 ,0)
  5130    ; Returns : -1 - if  user ^ arr owed or ti med out
  5131   "RTN","RCD PEAA1",278 ,0)
  5132    ; H - Hig hest to Lo west
  5133   "RTN","RCD PEAA1",279 ,0)
  5134    ; L - Low est to Hig hest
  5135   "RTN","RCD PEAA1",280 ,0)
  5136    N DEF,DIR ,DIRUT,DTO UT,DUOUT,P 1,X,Y
  5137   "RTN","RCD PEAA1",281 ,0)
  5138    S DEF=$P( $G(^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"SOR T")),"^",2 )
  5139   "RTN","RCD PEAA1",282 ,0)
  5140    S DEF=$S( DEF="H":"H IGHEST TO  LOWEST",DE F="L":"LOW EST TO HIG HEST",1:"" )
  5141   "RTN","RCD PEAA1",283 ,0)
  5142    S DIR(0)= "SA^H:HIGH EST TO LOW EST;L:LOWE ST TO HIGH EST"
  5143   "RTN","RCD PEAA1",284 ,0)
  5144    S DIR("A" )="Sort By  (H)IGHEST  TO LOWEST  or (L)OWE ST TO HIGH EST: "
  5145   "RTN","RCD PEAA1",285 ,0)
  5146    S DIR("B" )=$S(DEF'= "":DEF,1:" HIGHEST TO  LOWEST")
  5147   "RTN","RCD PEAA1",286 ,0)
  5148    S DIR("?" ,1)="Enter  'HIGHEST  TO LOWEST'  to sort a mounts in  decreasing  order."
  5149   "RTN","RCD PEAA1",287 ,0)
  5150    S DIR("?" )="Enter ' LOWEST TO  HIGHEST' t o sort amo unts in in creasing o rder."
  5151   "RTN","RCD PEAA1",288 ,0)
  5152    W !
  5153   "RTN","RCD PEAA1",289 ,0)
  5154    D ^DIR
  5155   "RTN","RCD PEAA1",290 ,0)
  5156    I $D(DTOU T)!$D(DUOU T) Q -1
  5157   "RTN","RCD PEAA1",291 ,0)
  5158    Q Y
  5159   "RTN","RCD PEAA1",292 ,0)
  5160   DATEORD()  ; Ask how  creation d ate should  be sorted  - ascendi ng or desc ending
  5161   "RTN","RCD PEAA1",293 ,0)
  5162    ; Input:  None
  5163   "RTN","RCD PEAA1",294 ,0)
  5164    ; Returns : -1 - if  user ^ arr owed or ti med out
  5165   "RTN","RCD PEAA1",295 ,0)
  5166    ; H - Des cending (H ighest to  lowest)
  5167   "RTN","RCD PEAA1",296 ,0)
  5168    ; L - Asc ending (Lo west to Hi ghest)
  5169   "RTN","RCD PEAA1",297 ,0)
  5170    N DEF,DIR ,DIRUT,DTO UT,DUOUT,P 1,X,Y
  5171   "RTN","RCD PEAA1",298 ,0)
  5172    S DEF=$P( $G(^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"SOR T")),"^",2 )
  5173   "RTN","RCD PEAA1",299 ,0)
  5174    S DEF=$S( DEF="H":"D ESCENDING" ,DEF="L":" ASCENDING" ,1:"")
  5175   "RTN","RCD PEAA1",300 ,0)
  5176    S DIR(0)= "SA^A:ASCE NDING;D:DE SCENDING"
  5177   "RTN","RCD PEAA1",301 ,0)
  5178    S DIR("A" )="Sort in  (A)SCENDI NG or (D)E SCENDING o rder: "
  5179   "RTN","RCD PEAA1",302 ,0)
  5180    S DIR("B" )=$S(DEF'= "":DEF,1:" ASCENDING" )
  5181   "RTN","RCD PEAA1",303 ,0)
  5182    S DIR("?" ,1)="Enter  'ASCENDIN G' to see  oldest EEO Bs first."
  5183   "RTN","RCD PEAA1",304 ,0)
  5184    S DIR("?" )="Enter ' DESCENDING ' to see n ewest EEOB s first."
  5185   "RTN","RCD PEAA1",305 ,0)
  5186    W !
  5187   "RTN","RCD PEAA1",306 ,0)
  5188    D ^DIR
  5189   "RTN","RCD PEAA1",307 ,0)
  5190    I $D(DTOU T)!$D(DUOU T) Q -1
  5191   "RTN","RCD PEAA1",308 ,0)
  5192    S Y=$S(Y= "D":"H",1: "L")
  5193   "RTN","RCD PEAA1",309 ,0)
  5194    Q Y
  5195   "RTN","RCD PEAA1",310 ,0)
  5196   SAVEPVW()  ; Option t o save as  User Prefe rred View
  5197   "RTN","RCD PEAA1",311 ,0)
  5198    ; PRCA*4. 5*317 adde d subrouti ne
  5199   "RTN","RCD PEAA1",312 ,0)
  5200    ; Input:  ^TMP("RCDP E_APAR_EEO B_PARAMS", $J) - Glob al array o f current  worklist s ettings
  5201   "RTN","RCD PEAA1",313 ,0)
  5202    ; Output  Current wo rklist set tings set  as preferr ed view (p otentially )
  5203   "RTN","RCD PEAA1",314 ,0)
  5204    ;         ^TMP("RCDP E_APAR_PVW ",$J)          - Glob al array o f preferre d view set tings
  5205   "RTN","RCD PEAA1",315 ,0)
  5206    ; Returns : 1 - User  ^ arrowed  or timed  out, 0 oth erwise
  5207   "RTN","RCD PEAA1",316 ,0)
  5208    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,X,XX,Y
  5209   "RTN","RCD PEAA1",317 ,0)
  5210    K DIR
  5211   "RTN","RCD PEAA1",318 ,0)
  5212    W !
  5213   "RTN","RCD PEAA1",319 ,0)
  5214    S DIR(0)= "YA",DIR(" B")="NO"
  5215   "RTN","RCD PEAA1",320 ,0)
  5216    S DIR("A" )="Do you  want to sa ve this as  your pref erred view  (Y/N)? "
  5217   "RTN","RCD PEAA1",321 ,0)
  5218    D ^DIR
  5219   "RTN","RCD PEAA1",322 ,0)
  5220    ; PRCA*4. 5*321 ; St art modifi ed code bl ock
  5221   "RTN","RCD PEAA1",323 ,0)
  5222    I $D(DTOU T)!$D(DUOU T) Q 1
  5223   "RTN","RCD PEAA1",324 ,0)
  5224    I Y=1 D
  5225   "RTN","RCD PEAA1",325 ,0)
  5226    . S XX=^T MP("RCDPE_ APAR_EEOB_ PARAMS",$J ,"RCPAYR")
  5227   "RTN","RCD PEAA1",326 ,0)
  5228    . D EN^XP AR(DUZ_";V A(200,","R CDPE APAR" ,"ALL_PAYE RS/RANGE_O F_PAYERS", $TR(XX,"^" ,";"),.RCE RROR)
  5229   "RTN","RCD PEAA1",327 ,0)
  5230    . S XX=^T MP("RCDPE_ APAR_EEOB_ PARAMS",$J ,"RCMEDRX" )
  5231   "RTN","RCD PEAA1",328 ,0)
  5232    . D EN^XP AR(DUZ_";V A(200,","R CDPE APAR" ,"MEDICAL/ PHARMACY", XX,.RCERRO R)
  5233   "RTN","RCD PEAA1",329 ,0)
  5234    . S XX=^T MP("RCDPE_ APAR_EEOB_ PARAMS",$J ,"SORT")
  5235   "RTN","RCD PEAA1",330 ,0)
  5236    . D EN^XP AR(DUZ_";V A(200,","R CDPE APAR" ,"SORT",$T R(XX,"^"," ;"),.RCERR OR)
  5237   "RTN","RCD PEAA1",331 ,0)
  5238    . ;
  5239   "RTN","RCD PEAA1",332 ,0)
  5240    . ;Captur e new pref erred sett ings for c omparison
  5241   "RTN","RCD PEAA1",333 ,0)
  5242    . K ^TMP( "RCDPE_APA R_PVW",$J)
  5243   "RTN","RCD PEAA1",334 ,0)
  5244    . M ^TMP( "RCDPE_APA R_PVW",$J) =^TMP("RCD PE_APAR_EE OB_PARAMS" ,$J)
  5245   "RTN","RCD PEAA1",335 ,0)
  5246    Q 0
  5247   "RTN","RCD PEAA1",336 ,0)
  5248    ; PRCA*4. 5*321 ; En d modified  code bloc k
  5249   "RTN","RCD PEAA1",337 ,0)
  5250    ;
  5251   "RTN","RCD PEAA1",338 ,0)
  5252   FILTER(RCD A) ; Retur ns 1 if re cord in en try 344.4  passes
  5253   "RTN","RCD PEAA1",339 ,0)
  5254    ; the edi ts for the  APAR work list selec tion of EE OBs
  5255   "RTN","RCD PEAA1",340 ,0)
  5256    ; Paramet ers found  in ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J)
  5257   "RTN","RCD PEAA1",341 ,0)
  5258    ; 
  5259   "RTN","RCD PEAA1",342 ,0)
  5260    ; Input:  RCDA - Int ernal IEN  OF 344.4
  5261   "RTN","RCD PEAA1",343 ,0)
  5262    ; Returns : 1 if the  ERA Recor d passes f ilters, 0  otherwise
  5263   "RTN","RCD PEAA1",344 ,0)
  5264    ; PRCA*4. 5*321 - St art modifi ed code bl ock
  5265   "RTN","RCD PEAA1",345 ,0)
  5266    N OK,RCEC ME,RCERATY P,RCIEN,RC PAYR,RCPAY FR,RCPAYTO ,XX
  5267   "RTN","RCD PEAA1",346 ,0)
  5268    S OK=1
  5269   "RTN","RCD PEAA1",347 ,0)
  5270    ;
  5271   "RTN","RCD PEAA1",348 ,0)
  5272    S RCPAYR= $P($G(^TMP ("RCDPE_AP AR_EEOB_PA RAMS",$J," RCPAYR")), U,1)
  5273   "RTN","RCD PEAA1",349 ,0)
  5274    S RCPAYFR =$P($G(^TM P("RCDPE_A PAR_EEOB_P ARAMS",$J, "RCPAYR")) ,U,2)
  5275   "RTN","RCD PEAA1",350 ,0)
  5276    S RCPAYTO =$P($G(^TM P("RCDPE_A PAR_EEOB_P ARAMS",$J, "RCPAYR")) ,U,3)
  5277   "RTN","RCD PEAA1",351 ,0)
  5278    S RCERATY P=$G(^TMP( "RCDPE_APA R_EEOB_PAR AMS",$J,"R CMEDRX"))
  5279   "RTN","RCD PEAA1",352 ,0)
  5280    ; Payer n ame filter
  5281   "RTN","RCD PEAA1",353 ,0)
  5282    I RCPAYR' ="A" D  Q: 'OK OK
  5283   "RTN","RCD PEAA1",354 ,0)
  5284    . S XX=$$ GET1^DIQ(3 44.4,RCDA, .06,"I") ;  Payer Nam e
  5285   "RTN","RCD PEAA1",355 ,0)
  5286    . S XX=$$ UP^XLFSTR( XX)
  5287   "RTN","RCD PEAA1",356 ,0)
  5288    . ;
  5289   "RTN","RCD PEAA1",357 ,0)
  5290    . ; Make  sure the P ayer is in  the selec ted Payer  range
  5291   "RTN","RCD PEAA1",358 ,0)
  5292    . I $S(XX =RCPAYFR:1 ,XX=RCPAYT O:1,XX]RCP AYFR:RCPAY TO]XX,1:0)  Q
  5293   "RTN","RCD PEAA1",359 ,0)
  5294    . S OK=0
  5295   "RTN","RCD PEAA1",360 ,0)
  5296    ;
  5297   "RTN","RCD PEAA1",361 ,0)
  5298    ; ERA Typ e (Medical /Pharmacy)  filter
  5299   "RTN","RCD PEAA1",362 ,0)
  5300    I RCERATY P'="B" D
  5301   "RTN","RCD PEAA1",363 ,0)
  5302    . ;
  5303   "RTN","RCD PEAA1",364 ,0)
  5304    . ; Check  the first  EOB in th e ERA to s ee if it i s a Pharma cy or Medi cal ERA
  5305   "RTN","RCD PEAA1",365 ,0)
  5306    . S RCIEN =$O(^RCY(3 44.4,RCDA, 1,0))
  5307   "RTN","RCD PEAA1",366 ,0)
  5308    . I RCIEN ="" S OK=0  Q
  5309   "RTN","RCD PEAA1",367 ,0)
  5310    . S RCECM E=$$GET1^D IQ(344.41, RCIEN_","_ RCDA_",",. 24,"I") ;  ECME #
  5311   "RTN","RCD PEAA1",368 ,0)
  5312    . ;
  5313   "RTN","RCD PEAA1",369 ,0)
  5314    . ; If re quested fi lter is Ph armacy and  there is  an ECME #,  display
  5315   "RTN","RCD PEAA1",370 ,0)
  5316    . I RCECM E="",RCERA TYP="M" Q
  5317   "RTN","RCD PEAA1",371 ,0)
  5318    . ;
  5319   "RTN","RCD PEAA1",372 ,0)
  5320    . ; If re quested fi lter is Me dical and  there is n o ECME #,  display
  5321   "RTN","RCD PEAA1",373 ,0)
  5322    . I RCECM E'="",RCER ATYP="P" Q
  5323   "RTN","RCD PEAA1",374 ,0)
  5324    . ;
  5325   "RTN","RCD PEAA1",375 ,0)
  5326    . ; Other wise, not  valid on t he filter,  don't dis play
  5327   "RTN","RCD PEAA1",376 ,0)
  5328    . S OK=0
  5329   "RTN","RCD PEAA1",377 ,0)
  5330    Q OK
  5331   "RTN","RCD PEAA1",378 ,0)
  5332    ; PRCA*4. 5*321 - En d modified  code bloc k
  5333   "RTN","RCD PEAA1",379 ,0)
  5334    ;
  5335   "RTN","RCD PEAA1",380 ,0)
  5336   ENTEREOB ;  EP Protoc ol action  - RCDPE AP AR SELECT  EEOB
  5337   "RTN","RCD PEAA1",381 ,0)
  5338    ; Enter t he APAR EE OB SCRATCH PAD
  5339   "RTN","RCD PEAA1",382 ,0)
  5340    N RCDA,RC DA1,RCIENS ,X,XQORM
  5341   "RTN","RCD PEAA1",383 ,0)
  5342    S VALMBCK ="R"
  5343   "RTN","RCD PEAA1",384 ,0)
  5344    S RCIENS= $$SEL()
  5345   "RTN","RCD PEAA1",385 ,0)
  5346    I 'RCIENS  D INIT Q
  5347   "RTN","RCD PEAA1",386 ,0)
  5348    D EN^VALM ("RCDPE AP AR SELECTE D EEOB")
  5349   "RTN","RCD PEAA1",387 ,0)
  5350    D INIT
  5351   "RTN","RCD PEAA1",388 ,0)
  5352    Q
  5353   "RTN","RCD PEAA1",389 ,0)
  5354    ;
  5355   "RTN","RCD PEAA1",390 ,0)
  5356   SEL() ; Se lect an it em from th e APAR lis t of EEOBs
  5357   "RTN","RCD PEAA1",391 ,0)
  5358    ; Input:  None
  5359   "RTN","RCD PEAA1",392 ,0)
  5360    ; Returns : RCIENS -  Internal  IENs A1^A2 ^A3 Where:
  5361   "RTN","RCD PEAA1",393 ,0)
  5362    ; A1 - IE N for in f ile 344.49
  5363   "RTN","RCD PEAA1",394 ,0)
  5364    ; A2 - IE N for subf ile 344.49 1
  5365   "RTN","RCD PEAA1",395 ,0)
  5366    ; A3 - Se lectable l ine item f rom listma n screen
  5367   "RTN","RCD PEAA1",396 ,0)
  5368    N RCDA,RC ITEMS,RCSE Q,VALMY
  5369   "RTN","RCD PEAA1",397 ,0)
  5370    D FULL^VA LM1
  5371   "RTN","RCD PEAA1",398 ,0)
  5372    D EN^VALM 2($G(XQORN OD(0)),"S" )
  5373   "RTN","RCD PEAA1",399 ,0)
  5374    S (RCSEQ, RCDA,RCITE MS)=0
  5375   "RTN","RCD PEAA1",400 ,0)
  5376    F  D  Q:' RCSEQ
  5377   "RTN","RCD PEAA1",401 ,0)
  5378    . S RCSEQ =$O(VALMY( RCSEQ))
  5379   "RTN","RCD PEAA1",402 ,0)
  5380    . Q:'RCSE Q
  5381   "RTN","RCD PEAA1",403 ,0)
  5382    . S RCITE MS=$P($G(^ TMP("RCDPE -APAR_EEOB _WLDX",$J, RCSEQ)),U, 2,3)_U_RCS EQ
  5383   "RTN","RCD PEAA1",404 ,0)
  5384    Q RCITEMS
  5385   "RTN","RCD PEAA1",405 ,0)
  5386    ;
  5387   "RTN","RCD PEAA1",406 ,0)
  5388   CV ;
  5389   "RTN","RCD PEAA1",407 ,0)
  5390    ; Change  View actio n for APAR  pick list
  5391   "RTN","RCD PEAA1",408 ,0)
  5392    D FULL^VA LM1 D PARA MS("CV")
  5393   "RTN","RCD PEAA1",409 ,0)
  5394    D HDR,INI T S VALMBC K="R",VALM BG=1
  5395   "RTN","RCD PEAA1",410 ,0)
  5396    Q
  5397   "RTN","RCD PEAA2")
  5398   0^9^B12231 2525
  5399   "RTN","RCD PEAA2",1,0 )
  5400   RCDPEAA2 ; ALB/KML -  APAR Scree n - SELECT ED EOB ;Ju n 06, 2014 @19:11:19
  5401   "RTN","RCD PEAA2",2,0 )
  5402    ;;4.5;Acc ounts Rece ivable;**2 98,304,318 ,321**;Mar  20, 1995; Build 46
  5403   "RTN","RCD PEAA2",3,0 )
  5404    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  5405   "RTN","RCD PEAA2",4,0 )
  5406    Q
  5407   "RTN","RCD PEAA2",5,0 )
  5408    ;
  5409   "RTN","RCD PEAA2",6,0 )
  5410   INIT(RCIEN S) ; Entry  point for  List temp late to bu ild the di splay of t he EEOB on  APAR
  5411   "RTN","RCD PEAA2",7,0 )
  5412    ;  
  5413   "RTN","RCD PEAA2",8,0 )
  5414    ;    Inpu t - RCIENS  = ien of  entry in f ile 344.49 ^ien of 34 4.491^sele ctable lin e item fro m listman  screen
  5415   "RTN","RCD PEAA2",9,0 )
  5416    ;
  5417   "RTN","RCD PEAA2",10, 0)
  5418    N FDTTM
  5419   "RTN","RCD PEAA2",11, 0)
  5420    D CLEAN^V ALM10
  5421   "RTN","RCD PEAA2",12, 0)
  5422    K ^TMP("R CDPE-EOB_W L",$J),^TM P("RCDPE-E OB_WLDX",$ J),^TMP("R CS",$J)
  5423   "RTN","RCD PEAA2",13, 0)
  5424    S VALMCNT =0,VALMBG= 1
  5425   "RTN","RCD PEAA2",14, 0)
  5426    D BLD(RCI ENS)
  5427   "RTN","RCD PEAA2",15, 0)
  5428    Q
  5429   "RTN","RCD PEAA2",16, 0)
  5430    ;
  5431   "RTN","RCD PEAA2",17, 0)
  5432    ;
  5433   "RTN","RCD PEAA2",18, 0)
  5434   BLD(RCIENS ) ; Displa y selected  EEOB  on  APAR scree n
  5435   "RTN","RCD PEAA2",19, 0)
  5436    N RCZ0,RC ECME,REASO N,V1,RCLI1 ,TLINE,RCS CR,Z,ZZ,Z0 ,ZZ1,RC0,R CTL,RCTS,R CCL,RCCL1
  5437   "RTN","RCD PEAA2",20, 0)
  5438    S RCSCR=$ P(RCIENS,U ),Z=$P(^RC Y(344.49,R CSCR,1,$P( RCIENS,U,2 ),0),U),RC PROG="RCDP EAA2"
  5439   "RTN","RCD PEAA2",21, 0)
  5440    I Z#1=0 S  ZZ=+$O(^R CY(344.49, RCSCR,1,"B ",Z,0)) I  ZZ D
  5441   "RTN","RCD PEAA2",22, 0)
  5442    . S Z0=Z  F  S Z0=$O (^RCY(344. 49,RCSCR,1 ,"B",Z0))  Q:((Z0\1)' =(Z\1))  S  Z=Z0,ZZ1= +$O(^RCY(3 44.49,RCSC R,1,"B",Z0 ,0)) I ZZ1  D
  5443   "RTN","RCD PEAA2",23, 0)
  5444    .. S ^TMP ("RCS",$J, ZZ,ZZ1)=""
  5445   "RTN","RCD PEAA2",24, 0)
  5446    . S ^TMP( "RCS",$J,Z Z)=""
  5447   "RTN","RCD PEAA2",25, 0)
  5448    S (RCTS,Z Z)=0
  5449   "RTN","RCD PEAA2",26, 0)
  5450    F  S ZZ=$ O(^TMP("RC S",$J,ZZ))  Q:'ZZ  D
  5451   "RTN","RCD PEAA2",27, 0)
  5452    . S RCZ0= $G(^RCY(34 4.49,RCSCR ,1,ZZ,0))
  5453   "RTN","RCD PEAA2",28, 0)
  5454    . S RCECM E=$P($G(^R CY(344.4,R CSCR,1,+$P (RCZ0,U,9) ,4)),U,2)   ; ECME #  (344.41,.2 4)
  5455   "RTN","RCD PEAA2",29, 0)
  5456    . S REASO N=$$GET1^D IQ(344.41, $P(RCZ0,U, 9)_","_RCS CR_",",5)   ; AUTOPOS T REJECTIO N REASON ( 344.41,5)
  5457   "RTN","RCD PEAA2",30, 0)
  5458    . S TLINE =$$TOPLINE (RCZ0)
  5459   "RTN","RCD PEAA2",31, 0)
  5460    . D SET(T LINE,$P(RC Z0,U),$P(R CZ0,U),ZZ)
  5461   "RTN","RCD PEAA2",32, 0)
  5462    . ; PRCA* 4.5*304 -  Add claim  comment to  screen if  it exists  for this  ERA EEOB d etail line
  5463   "RTN","RCD PEAA2",33, 0)
  5464    . S:$P(RC Z0,U,9)'=" " RCCL=$$G ET1^DIQ(34 4.41,$P(RC Z0,U,9)_", "_RCSCR_", ",4)
  5465   "RTN","RCD PEAA2",34, 0)
  5466    . D:$G(RC CL)'=""  ;  If we hav e a ERA De tail line  comment, d isplay it
  5467   "RTN","RCD PEAA2",35, 0)
  5468    . . D SLI NE(RCCL,"R CCL1",58,7 6)
  5469   "RTN","RCD PEAA2",36, 0)
  5470    . . S TLI NE=$J("",4 )_"Claim C omment: "_ RCCL1(1)
  5471   "RTN","RCD PEAA2",37, 0)
  5472    . . D SET (TLINE,$P( RCZ0,U),$P (RCZ0,U),Z Z)
  5473   "RTN","RCD PEAA2",38, 0)
  5474    . . ; If  we have a  second lin e for the  comment th en put it  on the scr een
  5475   "RTN","RCD PEAA2",39, 0)
  5476    . . I RCC L1>1 D SET ($J("",4)_ RCCL1(2),$ P(RCZ0,U), $P(RCZ0,U) ,ZZ) I RCC L1=3 D SET ($J("",4)_ RCCL1(3),$ P(RCZ0,U), $P(RCZ0,U) ,ZZ)
  5477   "RTN","RCD PEAA2",40, 0)
  5478    . ; **End  of *304 m odificatio ns**
  5479   "RTN","RCD PEAA2",41, 0)
  5480    . ; sub-l ine info ( e.g., "n.0 01")
  5481   "RTN","RCD PEAA2",42, 0)
  5482    . S ZZ1=0  F  S ZZ1= $O(^TMP("R CS",$J,ZZ, ZZ1)) Q:'Z Z1  D
  5483   "RTN","RCD PEAA2",43, 0)
  5484    . . S RCZ Z0=$G(^RCY (344.49,RC SCR,1,ZZ1, 0))
  5485   "RTN","RCD PEAA2",44, 0)
  5486    . . S RCT =$P(RCZZ0, U),RCTL=$L (RCT)
  5487   "RTN","RCD PEAA2",45, 0)
  5488    . . S V1= $S($P(RCZZ 0,U,2)'["* *ADJ":"",$ P($P(RCZZ0 ,U,2),"ADJ ",2):"***A DJUSTMENT  AT ERA LEV EL",1:"***  ADJUSTMEN T LINE FOR  TOTALS MI SMATCH")
  5489   "RTN","RCD PEAA2",46, 0)
  5490    . . S RCL I1=$S(V1=" ":" Claim  #: "_$P(RC ZZ0,U,2)_"  Patient/L ast 4: "_$ S($P(RCZZ0 ,U,7):$$PN M4("","",$ P(RCZZ0,U, 7)),'$P($G (^RCY(344. 49,RCSCR,1 ,ZZ1,2)),U ,3):$$PNM4 (+$G(^RCY( 344.49,RCS CR,0)),ZZ1 ),1:"??"), 1:V1)
  5491   "RTN","RCD PEAA2",47, 0)
  5492    . . D SET ($J("",4)_ $P("   ^(V )",U,$P(RC ZZ0,U,13)+ 1)_RCT_RCL I1,RCT,RCT ,ZZ1)
  5493   "RTN","RCD PEAA2",48, 0)
  5494    . . I $P( RCZZ0,U,7)  D CLINES( RCZZ0,RCT, ZZ1)
  5495   "RTN","RCD PEAA2",49, 0)
  5496    . . ;
  5497   "RTN","RCD PEAA2",50, 0)
  5498    . . D SET ($J("",4+R CTL)_"Paym ent Amt: " _$J(+$P(RC ZZ0,U,5)," ",2)_"   T otal Adjus tments: "_ $J(+$P(RCZ Z0,U,8),"" ,2)_"  Net : "_$J($P( RCZZ0,U,5) +$P(RCZZ0, U,8),"",2) ,RCT,RCT,Z Z1)
  5499   "RTN","RCD PEAA2",51, 0)
  5500    . . ; dis play pharm acy EEOB d ata  
  5501   "RTN","RCD PEAA2",52, 0)
  5502    . . I RCE CME]"" D R XLINES(RCZ Z0,RCECME, RCT,ZZ1)
  5503   "RTN","RCD PEAA2",53, 0)
  5504    . . ; PRC A*4.5*321  BEGIN
  5505   "RTN","RCD PEAA2",54, 0)
  5506    . . I $P( RCZZ0,U,10 )'="" D
  5507   "RTN","RCD PEAA2",55, 0)
  5508    . . . D S ET($J("",9 )_"Receipt  Comment:  "_$P(RCZZ0 ,U,10),$P( RCZZ0,U),R CT,ZZ1)
  5509   "RTN","RCD PEAA2",56, 0)
  5510    . . . D S ET($J("",9 )_"Added B y User: "_ $$GET1^DIQ (344.491,Z Z1_","_RCS CR_",",2.0 3),RCTS,RC T,ZZ1)
  5511   "RTN","RCD PEAA2",57, 0)
  5512    . . . D S ET($J("",9 )_"Date/Ti me Added:  "_$$GET1^D IQ(344.491 ,ZZ1_","_R CSCR_",",2 .04),RCTS, RCT,ZZ1)
  5513   "RTN","RCD PEAA2",58, 0)
  5514    . . ; PRC A*4.5*321  END
  5515   "RTN","RCD PEAA2",59, 0)
  5516    . . I $O( ^RCY(344.4 9,RCSCR,1, ZZ1,1,0))  D ADJLINES (RCZZ0,RCT ,ZZ1)
  5517   "RTN","RCD PEAA2",60, 0)
  5518    . . I $G( ^TMP($J,"R C_REVIEW") ) D REVLIN ES(RCSCR,R CZZ0,RCT,Z Z1)
  5519   "RTN","RCD PEAA2",61, 0)
  5520    . . D SET ($J("",7)_ "APAR Reas on: "_REAS ON,RCT,RCT ,ZZ1)
  5521   "RTN","RCD PEAA2",62, 0)
  5522    . . S A=" ",$P(A,"." ,79)="" D  SET(A,RCT, RCT,ZZ1)
  5523   "RTN","RCD PEAA2",63, 0)
  5524    I VALMCNT =0 D SET(" THERE ARE  NO EEOBs M ATCHING YO UR SELECTI ON CRITERI A")
  5525   "RTN","RCD PEAA2",64, 0)
  5526    K ^TMP($J ,"RCS")
  5527   "RTN","RCD PEAA2",65, 0)
  5528    Q
  5529   "RTN","RCD PEAA2",66, 0)
  5530    ;
  5531   "RTN","RCD PEAA2",67, 0)
  5532   SET(X,RCSE Q,RCSEQ1,R CZ9) ; --  set ListMa nager arra ys
  5533   "RTN","RCD PEAA2",68, 0)
  5534    ; X = the  data to s et into th e global
  5535   "RTN","RCD PEAA2",69, 0)
  5536    ; RCSEQ =  the selec table line  #
  5537   "RTN","RCD PEAA2",70, 0)
  5538    ; RCSEQ1  = = the su b line #
  5539   "RTN","RCD PEAA2",71, 0)
  5540    ; RCZ9 =  reference  to the lin e(s) in fi le 344.41  or to the  subline in
  5541   "RTN","RCD PEAA2",72, 0)
  5542    ;         file 344.4 9 for RCSE Q having a  decimal
  5543   "RTN","RCD PEAA2",73, 0)
  5544    S VALMCNT =VALMCNT+1 ,^TMP("RCD PE-EOB_WL" ,$J,VALMCN T,0)=X
  5545   "RTN","RCD PEAA2",74, 0)
  5546    I $G(RCSE Q) S ^TMP( "RCDPE-EOB _WL",$J,"I DX",VALMCN T,RCSEQ)=" "
  5547   "RTN","RCD PEAA2",75, 0)
  5548    I $G(RCSE Q1),'$D(^T MP("RCDPE- EOB_WLDX", $J,RCSEQ1) ) S ^TMP(" RCDPE-EOB_ WLDX",$J,R CSEQ1)=VAL MCNT_U_$G( RCZ9)
  5549   "RTN","RCD PEAA2",76, 0)
  5550    Q
  5551   "RTN","RCD PEAA2",77, 0)
  5552    ;
  5553   "RTN","RCD PEAA2",78, 0)
  5554   TOPLINE(RC Z0) ; Func tion retur ns the top  line of t he EEOB di splay
  5555   "RTN","RCD PEAA2",79, 0)
  5556    ; RCZ0 =  the 0-node  of the wh ole number  entry lin e for the  EEOB
  5557   "RTN","RCD PEAA2",80, 0)
  5558    N A
  5559   "RTN","RCD PEAA2",81, 0)
  5560    S A=" "_$ S($P(RCZ0, U,13):"(V) ",1:"   ") _"EEOB: ER A Seq #"_$ S($P(RCZ0, U,9)[",":" 's",1:"")_ " "_$S($P( RCZ0,U,9)' ="":$P(RCZ 0,U,9),1:" None")_"    Net Payme nt Amt: "_ $J(+$P(RCZ 0,U,6),"", 2)
  5561   "RTN","RCD PEAA2",82, 0)
  5562    I $G(^TMP ($J,"RC_RE VIEW")) S  A=A_"  Rev iewed?: "_ $S($P(RCZ0 ,U,11)="": "NO",1:$$E XTERNAL^DI LFD(344.49 1,.11,,$P( RCZ0,U,11) ))
  5563   "RTN","RCD PEAA2",83, 0)
  5564    Q A
  5565   "RTN","RCD PEAA2",84, 0)
  5566    ;
  5567   "RTN","RCD PEAA2",85, 0)
  5568    ;PRCA*4.5 *304 - Spl it long li ne into pr intable le ngths
  5569   "RTN","RCD PEAA2",86, 0)
  5570   SLINE(ZIN, ZARR,FLN,S LN) ;
  5571   "RTN","RCD PEAA2",87, 0)
  5572    ; ZIN - I nput strin g; ZARR -  Array outp ut of line s ; FLN -  First line  length ;  SLN - Subs equent lin e lengths
  5573   "RTN","RCD PEAA2",88, 0)
  5574    ; Assumes  ZIN max l ength is 1 32 charact ers and FL N and SLN  variables  will make  ZIN fit in  3 lines.
  5575   "RTN","RCD PEAA2",89, 0)
  5576    N ZL,ZI,Z M
  5577   "RTN","RCD PEAA2",90, 0)
  5578    I $L(ZIN) <(FLN+1) S  @ZARR@(1) =ZIN,@ZARR =1 Q
  5579   "RTN","RCD PEAA2",91, 0)
  5580    ; Otherwi se we are  spanning m ore than 1  line
  5581   "RTN","RCD PEAA2",92, 0)
  5582    S ZL="" F  ZI=1:1 Q: ($L(ZL)+$L ($P(ZIN,"  ",ZI)))>FL N  S ZL=ZL _$S($L(ZL) >0:" ",1:" ")_$P(ZIN, " ",ZI)
  5583   "RTN","RCD PEAA2",93, 0)
  5584    S @ZARR@( 1)=ZL,ZL=$ P(ZIN," ", ZI,9999)
  5585   "RTN","RCD PEAA2",94, 0)
  5586    I $L(ZL)< (SLN+1) S  @ZARR@(2)= ZL,@ZARR=2  Q
  5587   "RTN","RCD PEAA2",95, 0)
  5588    ; Spillin g onto a t hird line.
  5589   "RTN","RCD PEAA2",96, 0)
  5590    S ZM="" F  ZI=1:1 Q: ($L(ZM)+$L ($P(ZL," " ,ZI)))>SLN   S ZM=ZM_ $S($L(ZM)> 0:" ",1:"" )_$P(ZL,"  ",ZI)
  5591   "RTN","RCD PEAA2",97, 0)
  5592    S @ZARR@( 2)=ZM,ZM=$ P(ZL," ",Z I,9999)
  5593   "RTN","RCD PEAA2",98, 0)
  5594    S @ZARR@( 3)=ZM,@ZAR R=3
  5595   "RTN","RCD PEAA2",99, 0)
  5596    Q
  5597   "RTN","RCD PEAA2",100 ,0)
  5598    ; **END o f *304 cha nges**
  5599   "RTN","RCD PEAA2",101 ,0)
  5600    ;
  5601   "RTN","RCD PEAA2",102 ,0)
  5602   CLINES(RCZ Z0,RCT,ZZ1 ) ;  calle d from BLD  ; set up  the claim  informatio n lines
  5603   "RTN","RCD PEAA2",103 ,0)
  5604    ; 
  5605   "RTN","RCD PEAA2",104 ,0)
  5606    ;  Input  -   RCZZ0  = zero nod e data at  344.491
  5607   "RTN","RCD PEAA2",105 ,0)
  5608    ;             RCT    = sub line  #
  5609   "RTN","RCD PEAA2",106 ,0)
  5610    ;             ZZ1    = referenc e to the t o the subl ine in
  5611   "RTN","RCD PEAA2",107 ,0)
  5612    ;                      file 344 .49 for RC SEQ having  a decimal
  5613   "RTN","RCD PEAA2",108 ,0)
  5614    N A,RCX,Q ,QQ
  5615   "RTN","RCD PEAA2",109 ,0)
  5616    S A("OA") =$$ORI^PRC AFN(+$P(RC ZZ0,U,7)), A("SDT")=$ P($G(^DGCR (399,+$P(R CZZ0,U,7), "U")),U),A ("DFN")=+$ P($G(^(0)) ,U,2),A("E NRPR")=""
  5617   "RTN","RCD PEAA2",110 ,0)
  5618    ; Find Rx  copay sta tus
  5619   "RTN","RCD PEAA2",111 ,0)
  5620    S A("RXCP ")=$S('A(" SDT"):"",1 :$$RXST^IB ARXEU(A("D FN"),A("SD T"))),A("R XCP")=$S($ P(A("RXCP" ),U)'="":$ P(A("RXCP" ),U,2),1:" UNKNOWN")  ;IA #10147
  5621   "RTN","RCD PEAA2",112 ,0)
  5622    ; Find M/ T status
  5623   "RTN","RCD PEAA2",113 ,0)
  5624    S RCX=$$L ST^DGMTU(A ("DFN"),A( "SDT")),A( "M/T")=$P( RCX,U,4)
  5625   "RTN","RCD PEAA2",114 ,0)
  5626    S A("M/T" )=$S('RCX: "??",A("M/ T")="P":"P EN",A("M/T ")="C":"YE S",A("M/T" )="G":"GMT ",A("M/T") ="R":"REQ" ,1:"NO")
  5627   "RTN","RCD PEAA2",115 ,0)
  5628    S QQ="    Billed Amt : "_$J(A(" OA"),"",2) _"   Amt T o Post: "_ $J(+$P(RCZ Z0,U,3),"" ,2)
  5629   "RTN","RCD PEAA2",116 ,0)
  5630    D SET($J( "",4+RCTL) _"Claim Ba l: "_$J(+$ P($$BILL^R CJIBFN2(+$ P(RCZZ0,U, 7)),U,3)," ",2)_QQ,$P (RCZZ0,U), RCT,ZZ1)
  5631   "RTN","RCD PEAA2",117 ,0)
  5632    S ^TMP("R C_BILL",$J ,$P(RCZZ0, U,7),RCT)= QQ
  5633   "RTN","RCD PEAA2",118 ,0)
  5634    S Z3=$J(" ",4+RCTL)_ "Svc Dt: " _$S(A("SDT ")'="":$$F MTE^XLFDT( A("SDT"),2 ),1:"UNKNO WN")
  5635   "RTN","RCD PEAA2",119 ,0)
  5636    S Z3=Z3_"   COB: "_$ S($D(^DGCR (399,+$P(R CZZ0,U,7), "I"_($$COB N(+$P(RCZZ 0,U,7))+1) )):"YES",1 :"NO ")
  5637   "RTN","RCD PEAA2",120 ,0)
  5638    D SET(Z3_ "  Rx Copa y: "_$E(A( "RXCP"),1, 17)_"  Mea ns Tst: "_ A("M/T"),$ P(RCZZ0,U) ,RCT,ZZ1)
  5639   "RTN","RCD PEAA2",121 ,0)
  5640    Q
  5641   "RTN","RCD PEAA2",122 ,0)
  5642    ;
  5643   "RTN","RCD PEAA2",123 ,0)
  5644   REVLINES(R CSCR,RCZZ0 ,RCT,ZZ1)  ;called fr om BLD; se t up the r eviewed li nes
  5645   "RTN","RCD PEAA2",124 ,0)
  5646    ; 
  5647   "RTN","RCD PEAA2",125 ,0)
  5648    ;    Inpu t - RCSCR  = ien of 3 44.49 (and  344.4)
  5649   "RTN","RCD PEAA2",126 ,0)
  5650    ;             RCZZ0  = zero nod e data at  344.491
  5651   "RTN","RCD PEAA2",127 ,0)
  5652    ;             RCT    = sub line  #
  5653   "RTN","RCD PEAA2",128 ,0)
  5654    ;             ZZ1    = referenc e to the t o the subl ine in
  5655   "RTN","RCD PEAA2",129 ,0)
  5656    ;                      file 344 .49 for RC SEQ having  a decimal
  5657   "RTN","RCD PEAA2",130 ,0)
  5658    N A,A0,B, B0
  5659   "RTN","RCD PEAA2",131 ,0)
  5660    S A=$J("" ,10)_"REVI EW STATUS:  ("_$S($P( RCZZ0,U,11 )="I":"REV IEW IN PRO CESS",$P(R CZZ0,U,11) =1:"REVIEW ED",1:"NOT  REVIEWED" )
  5661   "RTN","RCD PEAA2",132 ,0)
  5662    I $P(RCZZ 0,U,12) S  A=A_"   SE T BY: "_$E ($P($G(^VA (200,$P(RC ZZ0,U,12), 0)),U),1,2 0)
  5663   "RTN","RCD PEAA2",133 ,0)
  5664    D SET(A_" )",+$P(RCZ Z0,U),RCT, ZZ1)
  5665   "RTN","RCD PEAA2",134 ,0)
  5666    S A=0 F   S A=$O(^RC Y(344.49,R CSCR,1,ZZ1 ,4,A)) Q:' A  S A0=$G (^(A,0)) D
  5667   "RTN","RCD PEAA2",135 ,0)
  5668    . D SET($ J("",12)_$ $FMTE^XLFD T($P(A0,U) ,2)_"  "_$ P($G(^VA(2 00,+$P(A0, U,2),0)),U )_$S($P(A0 ,U,4):"  L AST EDIT:  "_$$FMTE^X LFDT($P(A0 ,U,4),2),1 :""),$P(RC ZZ0,U),RCT ,ZZ1)
  5669   "RTN","RCD PEAA2",136 ,0)
  5670    . S B=0 F   S B=$O(^ RCY(344.49 ,RCSCR,1,Z Z1,4,A,1,B )) Q:'B  S  B0=$G(^(B ,0)) D
  5671   "RTN","RCD PEAA2",137 ,0)
  5672    . . I $L( B0)>64 D S ET($J("",1 5)_$E(B0,1 ,64),$P(RC ZZ0,U),RCT ,ZZ1) S B0 ="  "_$E(B 0,65,$L(B0 )) ; Split  line if >  64 charac ters in co mment line
  5673   "RTN","RCD PEAA2",138 ,0)
  5674    . . D SET ($J("",15) _B0,$P(RCZ Z0,U),RCT, ZZ1)
  5675   "RTN","RCD PEAA2",139 ,0)
  5676    Q
  5677   "RTN","RCD PEAA2",140 ,0)
  5678    ;
  5679   "RTN","RCD PEAA2",141 ,0)
  5680   ADJLINES(R CZZ0,RCT,Z Z1) ; call ed from BL D;  set up  the adjus tment line s
  5681   "RTN","RCD PEAA2",142 ,0)
  5682    ; 
  5683   "RTN","RCD PEAA2",143 ,0)
  5684    ;  Input  -   RCZZ0  = zero nod e data at  344.491
  5685   "RTN","RCD PEAA2",144 ,0)
  5686    ;             RCT    = sub line  #
  5687   "RTN","RCD PEAA2",145 ,0)
  5688    ;             ZZ1    = referenc e to the t o the subl ine in
  5689   "RTN","RCD PEAA2",146 ,0)
  5690    ;                      file 344 .49 for RC SEQ having  a decimal
  5691   "RTN","RCD PEAA2",147 ,0)
  5692    N RCAZ,RC AZ0,Z3
  5693   "RTN","RCD PEAA2",148 ,0)
  5694    S Z3=""
  5695   "RTN","RCD PEAA2",149 ,0)
  5696    D SET($J( "",4+RCTL) _"ADJUSTME NTS:",$P(R CZZ0,U),RC T,ZZ1)
  5697   "RTN","RCD PEAA2",150 ,0)
  5698    S RCAZ=0  F  S RCAZ= $O(^RCY(34 4.49,RCSCR ,1,ZZ1,1,R CAZ)) Q:'R CAZ  S RCA Z0=$G(^(RC AZ,0)) D
  5699   "RTN","RCD PEAA2",151 ,0)
  5700    . S Z3=$J ("",6+RCTL )_+RCAZ0_" .  ",Q=$L( Z3)
  5701   "RTN","RCD PEAA2",152 ,0)
  5702    . I $P(RC AZ0,U,2)=0  S Z3=Z3_" Distribute d adj dec  for retrac tion "_$P( RCAZ0,U,4) _": "_$P(R CAZ0,U,3)
  5703   "RTN","RCD PEAA2",153 ,0)
  5704    . I $P(RC AZ0,U,2)=1  S Z3=Z3_" Adjustment  distribut ion to bal ance recei pt: "_$P(R CAZ0,U,3)
  5705   "RTN","RCD PEAA2",154 ,0)
  5706    . I $P(RC AZ0,U,2)=2 !($P(RCAZ0 ,U,2)=4) D
  5707   "RTN","RCD PEAA2",155 ,0)
  5708    . . S Z3= Z3_"ERA pa yment adju sted from  "_$J($P(RC ZZ0,U,5)-$ P(RCZZ0,U, 6),"",2)_"  to "_$J(+ $P(RCZZ0,U ,5),"",2)_ "  NET: "_ $J($P(RCZZ 0,U,5)+$P( RCAZ0,U,3) ,"",2)
  5709   "RTN","RCD PEAA2",156 ,0)
  5710    . I $P(RC AZ0,U,2)=5  S Z3=Z3_" Non-specif ic payment  (ref# "_$ P(RCAZ0,U, 4)_"): "_$ P(RCAZ0,U, 3)
  5711   "RTN","RCD PEAA2",157 ,0)
  5712    . I $P(RC AZ0,U,2)=3  S Z3=Z3_" Non-specif ic retract ion (ref#  "_$P(RCAZ0 ,U,4)_"):  "_$P(RCAZ0 ,U,3)
  5713   "RTN","RCD PEAA2",158 ,0)
  5714    . D SET(Z 3,$P(RCZZ0 ,U),RCT,ZZ 1)
  5715   "RTN","RCD PEAA2",159 ,0)
  5716    . I $P(RC AZ0,U,9)'= "" D SET($ J("",Q)_$P (RCAZ0,U,9 ),$P(RCZZ0 ,U),RCT,ZZ 1)
  5717   "RTN","RCD PEAA2",160 ,0)
  5718    Q
  5719   "RTN","RCD PEAA2",161 ,0)
  5720    ;
  5721   "RTN","RCD PEAA2",162 ,0)
  5722    ;
  5723   "RTN","RCD PEAA2",163 ,0)
  5724   RXLINES(RC ZZ0,RCECME ,RCT,ZZ1)  ; called f rom BLD ;  set up the  Pharmacy  lines
  5725   "RTN","RCD PEAA2",164 ,0)
  5726    ;
  5727   "RTN","RCD PEAA2",165 ,0)
  5728    ;  Input  -   RCZZ0    = zero n ode data a t 344.491
  5729   "RTN","RCD PEAA2",166 ,0)
  5730    ;             RCECME   = ECME #  for Pharm acy claims
  5731   "RTN","RCD PEAA2",167 ,0)
  5732    ;             RCT      = sub li ne #
  5733   "RTN","RCD PEAA2",168 ,0)
  5734    ;             ZZ1      = refere nce to the  to the su bline in
  5735   "RTN","RCD PEAA2",169 ,0)
  5736    ;                        file 3 44.49 for  RCSEQ havi ng a decim al
  5737   "RTN","RCD PEAA2",170 ,0)
  5738    N RXARRAY
  5739   "RTN","RCD PEAA2",171 ,0)
  5740    D GETPHAR M^RCDPEWLP ($P(RCZZ0, U,7),.RXAR RAY)
  5741   "RTN","RCD PEAA2",172 ,0)
  5742    D SET($J( "",9)_"ECM E #: "_RCE CME,$P(RCZ Z0,U),RCT, ZZ1)
  5743   "RTN","RCD PEAA2",173 ,0)
  5744    I '$D(RXA RRAY) D SE T($J("",9) _" Pharmac y data doe s not exis t for this  claim",$P (RCZZ0,U), RCT,ZZ1) Q
  5745   "RTN","RCD PEAA2",174 ,0)
  5746    D SET($J( "",9)_"Rx/ Fill/Relea se Status:  "_RXARRAY ("RX")_"/" _RXARRAY(" FILL")_"/" _RXARRAY(" RELEASED S TATUS"),$P (RCZZ0,U), RCT,ZZ1)
  5747   "RTN","RCD PEAA2",175 ,0)
  5748    D SET($J( "",9)_"DOS : "_RXARRA Y("DOS"),$ P(RCZZ0,U) ,RCT,ZZ1)
  5749   "RTN","RCD PEAA2",176 ,0)
  5750    Q
  5751   "RTN","RCD PEAA2",177 ,0)
  5752    ;
  5753   "RTN","RCD PEAA2",178 ,0)
  5754   HDR ; Crea tes header  lines for  the selec ted EEOB d isplay
  5755   "RTN","RCD PEAA2",179 ,0)
  5756    N RC0,RC4 ,RC5,Z,RCD A,RCSEQ
  5757   "RTN","RCD PEAA2",180 ,0)
  5758    I '$G(RCI ENS) S VAL MQUIT=1 Q
  5759   "RTN","RCD PEAA2",181 ,0)
  5760    S RCDA=$P (RCIENS,U) ,RCSEQ=$P( RCIENS,U,3 )
  5761   "RTN","RCD PEAA2",182 ,0)
  5762    S RC0=$G( ^RCY(344.4 ,RCDA,0)), RC4=$G(^RC Y(344.4,RC DA,4)),RC5 =$G(^RCY(3 44.4,RCDA, 5))
  5763   "RTN","RCD PEAA2",183 ,0)
  5764    S VALMHDR (1)=$E("ER A Entry #:  "_$P(RC0, U)_$J("",3 1),1,31)_" Total Amt  Pd: "_$J(+ $P(RC0,U,5 ),"",2)
  5765   "RTN","RCD PEAA2",184 ,0)
  5766    I +RCSEQ  S VALMHDR( 2)=$E("Pos ted Amt: " _$J($P(^TM P("RCDPE-A PAR_EEOB_W LDX",$J,RC SEQ),U,5), "",2)_$J(" ",31),1,31 )
  5767   "RTN","RCD PEAA2",185 ,0)
  5768    S VALMHDR (2)=$G(VAL MHDR(2))_" Un-posted  balance: " _$J($P(^TM P("RCDPE-A PAR_EEOB_W LDX",$J,RC SEQ),U,4), "",2)
  5769   "RTN","RCD PEAA2",186 ,0)
  5770    S VALMHDR (3)="Payer  Name/ID:  "_$P(RC0,U ,6)_"/"_$P (RC0,U,3)
  5771   "RTN","RCD PEAA2",187 ,0)
  5772    S Z=+$O(^ RCY(344.31 ,"AERA",RC DA,0))
  5773   "RTN","RCD PEAA2",188 ,0)
  5774    I Z S VAL MHDR(4)="E FT #/TRACE  #: "_$P($ G(^RCY(344 .3,+$G(^RC Y(344.31,Z ,0)),0)),U )_"/"_$P(R C0,U,2)
  5775   "RTN","RCD PEAA2",189 ,0)
  5776    I 'Z,$P(R C5,U,2)'=" " S VALMHD R(4)="PAPE R CHECK #:  "_$P(RC5, U,2)
  5777   "RTN","RCD PEAA2",190 ,0)
  5778    S VALMHDR (5)="Poste d Receipt  #(s): "_$$ RCPTS(RCDA ,RC0)
  5779   "RTN","RCD PEAA2",191 ,0)
  5780    Q
  5781   "RTN","RCD PEAA2",192 ,0)
  5782    ;
  5783   "RTN","RCD PEAA2",193 ,0)
  5784   RCPTS(RCDA ,RC0) ; pu ll list of  'other re ceipt #s
  5785   "RTN","RCD PEAA2",194 ,0)
  5786    ;  input   - RCDA  =  ien of en try in 344 .4
  5787   "RTN","RCD PEAA2",195 ,0)
  5788    ;            RC0   =  data stri ng at zero  node of e ntry in 34 4.4
  5789   "RTN","RCD PEAA2",196 ,0)
  5790    ;  output  - RCPTS =  returns l ist of rec eipts stor ed at 344. 4,.08 and  344.48 mul tiple
  5791   "RTN","RCD PEAA2",197 ,0)
  5792    N X,RIEN, RCPTS
  5793   "RTN","RCD PEAA2",198 ,0)
  5794    S X=0
  5795   "RTN","RCD PEAA2",199 ,0)
  5796    S RCPTS=$ P($G(^RCY( 344,+$P(RC 0,U,8),0)) ,U)
  5797   "RTN","RCD PEAA2",200 ,0)
  5798    I RCPTS=" " G RCPTSQ   ; receip t not post ed to any  of EEOB it ems
  5799   "RTN","RCD PEAA2",201 ,0)
  5800    S RCPTS=R CPTS_","
  5801   "RTN","RCD PEAA2",202 ,0)
  5802    F  S X=$O (^RCY(344. 4,RCDA,8,X )) Q:'X  S  RIEN=+^(X ,0) S RCPT S=RCPTS_$P ($G(^RCY(3 44,RIEN,0) ),U)_","
  5803   "RTN","RCD PEAA2",203 ,0)
  5804    S RCPTS=$ $TRIM^XLFS TR(RCPTS," R",",")  ;  remove or phan comma  from last  receipt n umber
  5805   "RTN","RCD PEAA2",204 ,0)
  5806   RCPTSQ ;
  5807   "RTN","RCD PEAA2",205 ,0)
  5808    Q RCPTS
  5809   "RTN","RCD PEAA2",206 ,0)
  5810    ;
  5811   "RTN","RCD PEAA2",207 ,0)
  5812   EXIT ; --  Clean up l ist
  5813   "RTN","RCD PEAA2",208 ,0)
  5814    K RCFASTX T
  5815   "RTN","RCD PEAA2",209 ,0)
  5816    Q
  5817   "RTN","RCD PEAA2",210 ,0)
  5818    ;
  5819   "RTN","RCD PEAA2",211 ,0)
  5820   PNM4(RCIFN ,RCDA,RC)  ; Returns  either the  patient n ame or pat ient name/ last 4
  5821   "RTN","RCD PEAA2",212 ,0)
  5822    ; RCIFN =  ien of fi le 344.4
  5823   "RTN","RCD PEAA2",213 ,0)
  5824    ; RCDA =  ien of fil e 344.41
  5825   "RTN","RCD PEAA2",214 ,0)
  5826    ; RC = th e ien of f ile 430
  5827   "RTN","RCD PEAA2",215 ,0)
  5828    N Z,Z0,Q
  5829   "RTN","RCD PEAA2",216 ,0)
  5830    S Z=""
  5831   "RTN","RCD PEAA2",217 ,0)
  5832    I $G(RCIF N)'="" D
  5833   "RTN","RCD PEAA2",218 ,0)
  5834    . S Z0=$G (^RCY(344. 4,RCIFN,1, RCDA,0)),Z =""
  5835   "RTN","RCD PEAA2",219 ,0)
  5836    . I $P(Z0 ,U,2) S Q= +$P($G(^DG CR(399,+$G (^IBM(361. 1,+$P(Z0,U ,2),0)),0) ),U,2),Z=$ P($G(^DPT( Q,0)),U)_" /"_$E($P($ G(^(0)),U, 9),6,9) ;  IA 4051
  5837   "RTN","RCD PEAA2",220 ,0)
  5838    . I $TR(Z ,"/")="" S  Z=$P(Z0,U ,15)
  5839   "RTN","RCD PEAA2",221 ,0)
  5840    I $G(RC)' ="" D
  5841   "RTN","RCD PEAA2",222 ,0)
  5842    . S Q=+$P ($G(^PRCA( 430,RC,0)) ,U,7)
  5843   "RTN","RCD PEAA2",223 ,0)
  5844    . I Q S Z =$P($G(^DP T(Q,0)),U) _"/"_$E($P ($G(^(0)), U,9),6,9)
  5845   "RTN","RCD PEAA2",224 ,0)
  5846    Q Z
  5847   "RTN","RCD PEAA2",225 ,0)
  5848    ;
  5849   "RTN","RCD PEAA2",226 ,0)
  5850   COBN(RC,A)  ; Return  seq # of s elected pa yer
  5851   "RTN","RCD PEAA2",227 ,0)
  5852    ; A = 'PS T' or null  to get cu rrent bill  payer seq  #
  5853   "RTN","RCD PEAA2",228 ,0)
  5854    I $G(A)=" " S A=$P($ G(^DGCR(39 9,RC,0)),U ,21) S:A=" " A="P" S: "PST"'[A A ="P"
  5855   "RTN","RCD PEAA2",229 ,0)
  5856    I 'A S A= $F("PST",A )-1 S:A<1  A=1
  5857   "RTN","RCD PEAA2",230 ,0)
  5858    Q A
  5859   "RTN","RCD PEAA2",231 ,0)
  5860    ;
  5861   "RTN","RCD PEAA2",232 ,0)
  5862   COPAY(RCIF N)       ;  Returns 1  if any no t cancelle d 1st part y bills ex ist for
  5863   "RTN","RCD PEAA2",233 ,0)
  5864    ; a 3rd p arty bill  or any bil ls related  to this 3 rd party b ill
  5865   "RTN","RCD PEAA2",234 ,0)
  5866    ; RCIFN =  the 3rd p arty bill  #
  5867   "RTN","RCD PEAA2",235 ,0)
  5868    N FIRST,R CTP0,RCTP1 ,RCTP2
  5869   "RTN","RCD PEAA2",236 ,0)
  5870    K ^TMP("I BRBF",$J), ^TMP($J,"I BRBF")
  5871   "RTN","RCD PEAA2",237 ,0)
  5872    D RELBILL ^IBRFN(RCI FN) ; DBIA  3124
  5873   "RTN","RCD PEAA2",238 ,0)
  5874    S RCTP0=0  F  S RCTP 0=$O(^TMP( "IBRBF",$J ,RCIFN,RCT P0)) Q:RCT P0=""  S R CTP1=$G(^( RCTP0)) D
  5875   "RTN","RCD PEAA2",239 ,0)
  5876    . I $P(RC TP1,U,3) K  ^TMP("IBR BF",$J,RCI FN,RCTP0)  Q  ; IB ca ncelled
  5877   "RTN","RCD PEAA2",240 ,0)
  5878    . S RCTP2 =$O(^PRCA( 430,"B",+$ P(RCTP1,U, 4),0)) I $ P($G(^PRCA (430,+RCTP 2,0)),U,8) =39 K ^TMP ("IBRBF",$ J,RCIFN,RC TP0) ; AR  cancelled
  5879   "RTN","RCD PEAA2",241 ,0)
  5880    S FIRST=$ S($O(^TMP( "IBRBF",$J ,RCIFN,0)) :1,1:0)
  5881   "RTN","RCD PEAA2",242 ,0)
  5882    K ^TMP("I BRBF",$J), ^TMP($J,"I BRBF")
  5883   "RTN","RCD PEAA2",243 ,0)
  5884    Q FIRST
  5885   "RTN","RCD PEAA2",244 ,0)
  5886    ;
  5887   "RTN","RCD PEAA2",245 ,0)
  5888   MARK(RCIEN S) ;EP - P rotocol ac tion - RCD PE MARK FO R AUTO POS T
  5889   "RTN","RCD PEAA2",246 ,0)
  5890    ; Mark fo r Auto-Pos t - EEOB o n APAR get s marked f or auto-po st if it p asses
  5891   "RTN","RCD PEAA2",247 ,0)
  5892    ; autopos ting valid ation
  5893   "RTN","RCD PEAA2",248 ,0)
  5894    ; Input:    RCIENS   - Internal  IEN of en try in fil e 344.49^i en of 
  5895   "RTN","RCD PEAA2",249 ,0)
  5896    ;                      344.491^ selectable  line item  from list man screen
  5897   "RTN","RCD PEAA2",250 ,0)
  5898    ;
  5899   "RTN","RCD PEAA2",251 ,0)
  5900    I '$D(^XU SEC("RCDPE PP",DUZ))  D  Q  ; PR CA*4.5*318  Added sec urity key  check
  5901   "RTN","RCD PEAA2",252 ,0)
  5902    . D FULL^ VALM1
  5903   "RTN","RCD PEAA2",253 ,0)
  5904    . S VALMB CK="R"
  5905   "RTN","RCD PEAA2",254 ,0)
  5906    . W !!,"T his action  can only  be taken b y users th at have th e RCDPEPP  security k ey.",!
  5907   "RTN","RCD PEAA2",255 ,0)
  5908    . D PAUSE ^VALM1
  5909   "RTN","RCD PEAA2",256 ,0)
  5910    ;
  5911   "RTN","RCD PEAA2",257 ,0)
  5912    N RESULT, REASON,LIN E,DIR,X,Y, RCERROR,XX ,ERADA1,RC DFDA
  5913   "RTN","RCD PEAA2",258 ,0)
  5914    S:$G(RCIE NS)="" RCI ENS=+$$SEL ^RCDPEAA1( )
  5915   "RTN","RCD PEAA2",259 ,0)
  5916    Q:'RCIENS
  5917   "RTN","RCD PEAA2",260 ,0)
  5918    I '$$VALI D^RCDPEAP( $P(RCIENS, U),$P(RCIE NS,U,2),.R ESULT) D   G MARKQ
  5919   "RTN","RCD PEAA2",261 ,0)
  5920    . S LINE= $O(RESULT( ""))
  5921   "RTN","RCD PEAA2",262 ,0)
  5922    . S REASO N=$TR(RESU LT(LINE),U ,"-")
  5923   "RTN","RCD PEAA2",263 ,0)
  5924    . S DIR(0 )="EA",DIR ("A",1)="E EOB cannot  be marked  for Auto- Post for t he followi ng reason: "
  5925   "RTN","RCD PEAA2",264 ,0)
  5926    . S DIR(" A",2)=REAS ON
  5927   "RTN","RCD PEAA2",265 ,0)
  5928    . S DIR(" A")="PRESS  RETURN TO  CONTINUE  "
  5929   "RTN","RCD PEAA2",266 ,0)
  5930    . W ! D ^ DIR K DIR  W !
  5931   "RTN","RCD PEAA2",267 ,0)
  5932    ; EEOB pa ssed valid ation; rea dy for Aut opost
  5933   "RTN","RCD PEAA2",268 ,0)
  5934    L +^RCY(3 44.4,$P(RC IENS,U),0) :5 I '$T D  NOLOCK G  MARKQ
  5935   "RTN","RCD PEAA2",269 ,0)
  5936    S ERADA1= $P($G(^RCY (344.49,$P (RCIENS,U) ,1,$P(RCIE NS,U,2),0) ),U,9)  ;  get 344.41  ien (344. 491,.09)
  5937   "RTN","RCD PEAA2",270 ,0)
  5938    S RCDFDA( 344.41,ERA DA1_","_$P (RCIENS,U) _",",6)=1
  5939   "RTN","RCD PEAA2",271 ,0)
  5940    D FILE^DI E("","RCDF DA")
  5941   "RTN","RCD PEAA2",272 ,0)
  5942    S DIR(0)= "EA",DIR(" A",1)=$P(R CIENS,U)_" ."_ERADA1_ " has been  marked fo r auto-pos t and has  been remov ed from th e APAR Lis t."
  5943   "RTN","RCD PEAA2",273 ,0)
  5944    S DIR("A" )="PRESS R ETURN TO C ONTINUE "
  5945   "RTN","RCD PEAA2",274 ,0)
  5946    W ! D ^DI R K DIR W  !
  5947   "RTN","RCD PEAA2",275 ,0)
  5948    L -^RCY(3 44.4,$P(RC IENS,U),0)
  5949   "RTN","RCD PEAA2",276 ,0)
  5950   MARKQ ;
  5951   "RTN","RCD PEAA2",277 ,0)
  5952    Q
  5953   "RTN","RCD PEAA2",278 ,0)
  5954    ;
  5955   "RTN","RCD PEAA2",279 ,0)
  5956   NOLOCK ; e ntry canno t be locke d
  5957   "RTN","RCD PEAA2",280 ,0)
  5958    N DIR
  5959   "RTN","RCD PEAA2",281 ,0)
  5960    S DIR(0)= "EA"
  5961   "RTN","RCD PEAA2",282 ,0)
  5962    S DIR("A" ,1)="Sorry , another  user is ed iting this  ERA entry ."
  5963   "RTN","RCD PEAA2",283 ,0)
  5964    S DIR("A" ,2)="Try a gain later ."
  5965   "RTN","RCD PEAA2",284 ,0)
  5966    S DIR("A" ,3)=""
  5967   "RTN","RCD PEAA2",285 ,0)
  5968    S DIR("A" )="PRESS E NTER TO CO NTINUE "
  5969   "RTN","RCD PEAA2",286 ,0)
  5970    D ^DIR
  5971   "RTN","RCD PEAA2",287 ,0)
  5972    Q
  5973   "RTN","RCD PEAA2",288 ,0)
  5974    ;
  5975   "RTN","RCD PEAA2",289 ,0)
  5976   VIEWERA(RC IENS) ; Vi ew/Print E RA - proto col entry  from APAR  EEOB List  screen and  APAR - EE OB ITEM -  SCRATCHPAD  screen
  5977   "RTN","RCD PEAA2",290 ,0)
  5978    N RCSCR
  5979   "RTN","RCD PEAA2",291 ,0)
  5980    I RCPROG= "RCDPEAA2"  S RCSCR=$ P(RCIENS,U )
  5981   "RTN","RCD PEAA2",292 ,0)
  5982    I RCPROG= "RCDPEAA1"  S RCSCR=+ $$SEL^RCDP EAA1()
  5983   "RTN","RCD PEAA2",293 ,0)
  5984    I RCSCR>0  D PRERA^R CDPEWL0
  5985   "RTN","RCD PEAA2",294 ,0)
  5986    Q
  5987   "RTN","RCD PEAA4")
  5988   0^45^B5175 4176
  5989   "RTN","RCD PEAA4",1,0 )
  5990   RCDPEAA4 ; AITC/CJE -  AUTO POST  AWAITING  RESOLUTION  (APAR) -  LIST OF UN POSTED EEO BS ;Jun 06 , 2014@19: 11:19
  5991   "RTN","RCD PEAA4",2,0 )
  5992    ;;4.5;Acc ounts Rece ivable;**3 21**;;Buil d 46;Build  99
  5993   "RTN","RCD PEAA4",3,0 )
  5994    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  5995   "RTN","RCD PEAA4",4,0 )
  5996    Q
  5997   "RTN","RCD PEAA4",5,0 )
  5998    ;
  5999   "RTN","RCD PEAA4",6,0 )
  6000   BLD(P1,P2, RCPROG) ;E P from RCD PEAA1
  6001   "RTN","RCD PEAA4",7,0 )
  6002    ; Build,S ORT and ou tput the E EOB list t o be displ ayed on AP AR
  6003   "RTN","RCD PEAA4",8,0 )
  6004    ; screen
  6005   "RTN","RCD PEAA4",9,0 )
  6006    ; Input:  P1 - "RCDP E_APAR_EEO B_PASS1"
  6007   "RTN","RCD PEAA4",10, 0)
  6008    ; P2 - "R CDPE_APAR_ EEOB_PASS2 "
  6009   "RTN","RCD PEAA4",11, 0)
  6010    ; RCPROG  - "RCDPE-A PAR_EEOB_W L"
  6011   "RTN","RCD PEAA4",12, 0)
  6012    ; ^TMP($J ,P1,ERAIEN ) - Global  array of  all the ER A records  that
  6013   "RTN","RCD PEAA4",13, 0)
  6014    ; passed  the filter  criteria
  6015   "RTN","RCD PEAA4",14, 0)
  6016    ; Output:  ^TMP($J,P 2,A1,A2) -  B1^B2^B3^ B4^B5^B6^B 7^B8^B9
  6017   "RTN","RCD PEAA4",15, 0)
  6018    ; See ERA LINES for  detail
  6019   "RTN","RCD PEAA4",16, 0)
  6020    ; VALMCNT  - Total n umber of l ines in th e listman  body
  6021   "RTN","RCD PEAA4",17, 0)
  6022    N AMTPST, AUTOPDT,BA LANCE,ERAI EN,I34441, I344491,IE NS,OSEQ,RC DA1,RCDT,R CPT,RCSEQ, RCT,REASON
  6023   "RTN","RCD PEAA4",18, 0)
  6024    N TOTPOST D,XX,YY
  6025   "RTN","RCD PEAA4",19, 0)
  6026    S (RCT,TO TPOSTD,BAL ANCE,VALMC NT)=0
  6027   "RTN","RCD PEAA4",20, 0)
  6028    S ERAIEN= 0
  6029   "RTN","RCD PEAA4",21, 0)
  6030    ;
  6031   "RTN","RCD PEAA4",22, 0)
  6032    ; 2nd Pas s get the  data and s ort the li nes EEOB d ata lines  to be disp layed
  6033   "RTN","RCD PEAA4",23, 0)
  6034    F  D  Q:' ERAIEN
  6035   "RTN","RCD PEAA4",24, 0)
  6036    . S ERAIE N=$O(^TMP( $J,P1,ERAI EN))
  6037   "RTN","RCD PEAA4",25, 0)
  6038    . Q:'ERAI EN
  6039   "RTN","RCD PEAA4",26, 0)
  6040    . S RCSEQ =0
  6041   "RTN","RCD PEAA4",27, 0)
  6042    . F  D  Q :'RCSEQ
  6043   "RTN","RCD PEAA4",28, 0)
  6044    . . S RCS EQ=$O(^RCY (344.49,ER AIEN,1,"B" ,RCSEQ))
  6045   "RTN","RCD PEAA4",29, 0)
  6046    . . Q:'RC SEQ
  6047   "RTN","RCD PEAA4",30, 0)
  6048    . . Q:RCS EQ#1'=0
  6049   "RTN","RCD PEAA4",31, 0)
  6050    . . S RCD A1=+$O(^RC Y(344.49,E RAIEN,1,"B ",RCSEQ,0) )
  6051   "RTN","RCD PEAA4",32, 0)
  6052    . . Q:'RC DA1
  6053   "RTN","RCD PEAA4",33, 0)
  6054    . . S I34 4491=RCDA1 _","_ERAIE N_","                   ; IENS f or subfile  344.491
  6055   "RTN","RCD PEAA4",34, 0)
  6056    . . S AMT PST=$$GET1 ^DIQ(344.4 91,I344491 ,.03,"I")  ; Amount t o post on  Receipt
  6057   "RTN","RCD PEAA4",35, 0)
  6058    . . Q:+AM TPST=0  ;  Ignore zer o value li nes
  6059   "RTN","RCD PEAA4",36, 0)
  6060    . . S OSE Q=$$GET1^D IQ(344.491 ,I344491,. 09,"E") ;  Original E RA sequenc e #s
  6061   "RTN","RCD PEAA4",37, 0)
  6062    . . S I34 441=+OSEQ_ ","_ERAIEN _","                    ; IENS f or subfile  344.41
  6063   "RTN","RCD PEAA4",38, 0)
  6064    . . S RCP T=$$GET1^D IQ(344.41, I34441,.25 ,"I") ; In ternal Rec eipt IEN ( file 344)
  6065   "RTN","RCD PEAA4",39, 0)
  6066    . . S REA SON=$$GET1 ^DIQ(344.4 1,I34441,5 ) ; Extern al Auto-Po st Reject  Reason
  6067   "RTN","RCD PEAA4",40, 0)
  6068    . . ;
  6069   "RTN","RCD PEAA4",41, 0)
  6070    . . ; If  we have a  receipt, a dd the Amo unt to Pos t to the t otal poste d amount
  6071   "RTN","RCD PEAA4",42, 0)
  6072    . . S:RCP T'="" TOTP OSTD=TOTPO STD+AMTPST
  6073   "RTN","RCD PEAA4",43, 0)
  6074    . . ;
  6075   "RTN","RCD PEAA4",44, 0)
  6076    . . ; If  we have do n't have a  receipt,  calculate  the unpost ed balance
  6077   "RTN","RCD PEAA4",45, 0)
  6078    . . I RCP T="" D
  6079   "RTN","RCD PEAA4",46, 0)
  6080    . . . S X X=$$GET1^D IQ(344.49, ERAIEN_"," ,.03,"I")  ; Total Pa yment Rece ived
  6081   "RTN","RCD PEAA4",47, 0)
  6082    . . . S B ALANCE=XX- TOTPOSTD
  6083   "RTN","RCD PEAA4",48, 0)
  6084    . . ;
  6085   "RTN","RCD PEAA4",49, 0)
  6086    . . ; Onl y display  EEOBs that  do not ha ve a recei pt and are n't marked  for auto- post
  6087   "RTN","RCD PEAA4",50, 0)
  6088    . . S YY= $$GET1^DIQ (344.41,I3 4441,6,"I" ) ; Mark f or Auto-Po st flag of  the ERA d etail ln
  6089   "RTN","RCD PEAA4",51, 0)
  6090    . . I RCP T="",'YY D
  6091   "RTN","RCD PEAA4",52, 0)
  6092    . . . S R CT=RCT+1
  6093   "RTN","RCD PEAA4",53, 0)
  6094    . . . S X X=$$GET1^D IQ(344.4,E RAIEN_",", .01,"I") ;  ERA Numbe r
  6095   "RTN","RCD PEAA4",54, 0)
  6096    . . . S $ P(RCARRY(R CT),"^",1) =XX
  6097   "RTN","RCD PEAA4",55, 0)
  6098    . . . S $ P(RCARRY(R CT),"^",2) =+OSEQ                  ; Origin al ERA Det ail Sequen ce Numbers
  6099   "RTN","RCD PEAA4",56, 0)
  6100    . . . S X X=$$GET1^D IQ(344.491 ,I344491,. 02,"E")      ; Claim  Number
  6101   "RTN","RCD PEAA4",57, 0)
  6102    . . . S $ P(RCARRY(R CT),"^",3) =XX
  6103   "RTN","RCD PEAA4",58, 0)
  6104    . . . S $ P(RCARRY(R CT),"^",4) =RCDA1                  ; Intern al IEN for  subfile 3 44.491
  6105   "RTN","RCD PEAA4",59, 0)
  6106    . . . S $ P(RCARRY(R CT),"^",5) =REASON                 ; Reason  on APAR
  6107   "RTN","RCD PEAA4",60, 0)
  6108    . I $D(RC ARRY) D
  6109   "RTN","RCD PEAA4",61, 0)
  6110    . . S RCD T=$$GET1^D IQ(344.4,E RAIEN_",", .07,"I") ;  ERA File  Date/Time  for sort
  6111   "RTN","RCD PEAA4",62, 0)
  6112    . . S AUT OPDT=$$GET 1^DIQ(344. 4,ERAIEN_" ,",4.01,"I ") ; Inter nal Auto-P ost Date
  6113   "RTN","RCD PEAA4",63, 0)
  6114    . . S XX= $$GET1^DIQ (344.4,ERA IEN_",",.0 3,"I") ; P ayer ID
  6115   "RTN","RCD PEAA4",64, 0)
  6116    . . S YY= $$GET1^DIQ (344.4,ERA IEN_",",.0 6,"I") ; P ayer Name
  6117   "RTN","RCD PEAA4",65, 0)
  6118    . . D ERA LINES(ERAI EN,.RCARRY ,BALANCE,T OTPOSTD,AU TOPDT,RCDT ,XX,YY,P2)
  6119   "RTN","RCD PEAA4",66, 0)
  6120    . . K RCA RRY
  6121   "RTN","RCD PEAA4",67, 0)
  6122    . S (BALA NCE,TOTPOS TD)=0 ; Re set posted  and unpos ted balanc es
  6123   "RTN","RCD PEAA4",68, 0)
  6124    ;
  6125   "RTN","RCD PEAA4",69, 0)
  6126    ; Final P ass - buil d the disp lay lines  and load t he listman  template
  6127   "RTN","RCD PEAA4",70, 0)
  6128    D BOUT(P2 ,.VALMCNT)
  6129   "RTN","RCD PEAA4",71, 0)
  6130    Q
  6131   "RTN","RCD PEAA4",72, 0)
  6132    ;
  6133   "RTN","RCD PEAA4",73, 0)
  6134   ERALINES(R CDA,RCARRY ,BALANCE,T OTPOSTD,PO STDT,FILED T,PAYID,PA YNM,P2) ;  Build sort ed list
  6135   "RTN","RCD PEAA4",74, 0)
  6136    ; Input:  RCDA - Top  file ien  for files  344.4 and  344.49
  6137   "RTN","RCD PEAA4",75, 0)
  6138    ; RCARRY( CTR) - A1^ A2^A3^A4 W here:
  6139   "RTN","RCD PEAA4",76, 0)
  6140    ; A1 - ER A Number
  6141   "RTN","RCD PEAA4",77, 0)
  6142    ; A2 - Or iginal Seq uence Numb ers
  6143   "RTN","RCD PEAA4",78, 0)
  6144    ; A3 - Cl aim Number
  6145   "RTN","RCD PEAA4",79, 0)
  6146    ; A4 - In ternal IEN  for subfi le 344.491
  6147   "RTN","RCD PEAA4",80, 0)
  6148    ; A5 - Re ason on AP AR
  6149   "RTN","RCD PEAA4",81, 0)
  6150    ; BALANCE  - Amount  that is le ft to be p osted 
  6151   "RTN","RCD PEAA4",82, 0)
  6152    ; TOTPOST D - Total  amount pos ted thus f ar against  the ERA
  6153   "RTN","RCD PEAA4",83, 0)
  6154    ; POSTDT  - Latest a uto-posted  date
  6155   "RTN","RCD PEAA4",84, 0)
  6156    ; FILEDT  - Date/Tim e the ERA  was filed
  6157   "RTN","RCD PEAA4",85, 0)
  6158    ; PAYID -  Payer id
  6159   "RTN","RCD PEAA4",86, 0)
  6160    ; PAYNM -  Payer nam e
  6161   "RTN","RCD PEAA4",87, 0)
  6162    ; P2 - "R CDPE_APAR_ EEOB_PASS2 "
  6163   "RTN","RCD PEAA4",88, 0)
  6164    ; REASON  - External  Auto-Post  Reject Re ason
  6165   "RTN","RCD PEAA4",89, 0)
  6166    ; Output:  ^TMP($J,P 2,A1,A2) =  B1^B2^B3^ B4^B5^B6^B 7^B8^B9 Wh ere:
  6167   "RTN","RCD PEAA4",90, 0)
  6168    ; A1 - Up percased v alue of th e selected  sort fiel d
  6169   "RTN","RCD PEAA4",91, 0)
  6170    ; A2 - In ternal IEN  of the ER A record
  6171   "RTN","RCD PEAA4",92, 0)
  6172    ; B1 - Li ne Number
  6173   "RTN","RCD PEAA4",93, 0)
  6174    ; B2 - ER A #.Sequen ce # (max  19 10+"."+ 8 characte rs)
  6175   "RTN","RCD PEAA4",94, 0)
  6176    ; B3 - Cl aim # (max  15 charac ters)
  6177   "RTN","RCD PEAA4",95, 0)
  6178    ; B4 - Po sted Amoun t (max 15  characters )
  6179   "RTN","RCD PEAA4",96, 0)
  6180    ; B5 - Ex ternal Pos t Date (8  characters )
  6181   "RTN","RCD PEAA4",97, 0)
  6182    ; B6 - Un posted Bal ance (max  15 charact ers)
  6183   "RTN","RCD PEAA4",98, 0)
  6184    ; B7 - Pa yer Name/P ayer ID (m ax 76 char acters)
  6185   "RTN","RCD PEAA4",99, 0)
  6186    ; B8 - In ternal IEN  for subfi le 344.491
  6187   "RTN","RCD PEAA4",100 ,0)
  6188    ; B9 - Au to-Post Re ject Reaso n
  6189   "RTN","RCD PEAA4",101 ,0)
  6190    ; B10 - D ate ERA Fi led
  6191   "RTN","RCD PEAA4",102 ,0)
  6192    N A1,DLIN E,RCT,REAS ON,X,XX
  6193   "RTN","RCD PEAA4",103 ,0)
  6194    S RCT=""
  6195   "RTN","RCD PEAA4",104 ,0)
  6196    F  D  Q:R CT=""
  6197   "RTN","RCD PEAA4",105 ,0)
  6198    . S RCT=$ O(RCARRY(R CT))
  6199   "RTN","RCD PEAA4",106 ,0)
  6200    . Q:RCT=" "
  6201   "RTN","RCD PEAA4",107 ,0)
  6202    . S REASO N=$P(RCARR Y(RCT),"^" ,5)
  6203   "RTN","RCD PEAA4",108 ,0)
  6204    . S A1=$$ SORTP(BALA NCE,TOTPOS TD,PAYNM,R EASON,FILE DT) ; Get  Sort Value
  6205   "RTN","RCD PEAA4",109 ,0)
  6206    . I A1=""  S A1=" "  ; Set null  sort valu e to space  to avoid  subscript  error 
  6207   "RTN","RCD PEAA4",110 ,0)
  6208    . S DLINE =RCT                                          ; Line N umber
  6209   "RTN","RCD PEAA4",111 ,0)
  6210    . S XX=$P (RCARRY(RC T),U,1)_". "_$P(RCARR Y(RCT),U,2 ) ; ERA #. Sequence #
  6211   "RTN","RCD PEAA4",112 ,0)
  6212    . S $P(DL INE,"^",2) =XX
  6213   "RTN","RCD PEAA4",113 ,0)
  6214    . S $P(DL INE,"^",3) =$P(RCARRY (RCT),U,3)              ; Claim  #
  6215   "RTN","RCD PEAA4",114 ,0)
  6216    . S $P(DL INE,"^",4) =TOTPOSTD                          ; Posted  Amount
  6217   "RTN","RCD PEAA4",115 ,0)
  6218    . S $P(DL INE,"^",5) =$$FMTE^XL FDT(POSTDT ,"2ZD")      ; Extern al Post Da te
  6219   "RTN","RCD PEAA4",116 ,0)
  6220    . S $P(DL INE,"^",6) =BALANCE                           ; Unpost ed Balance
  6221   "RTN","RCD PEAA4",117 ,0)
  6222    . S $P(DL INE,"^",7) =PAYNM_"/" _PAYID                  ; Payer  Name/ID
  6223   "RTN","RCD PEAA4",118 ,0)
  6224    . S $P(DL INE,"^",8) =$P(RCARRY (RCT),"^", 4)           ; Intern al IEN for  subfile 3 44.491
  6225   "RTN","RCD PEAA4",119 ,0)
  6226    . S $P(DL INE,"^",9) =REASON                            ; Auto-P ost Reject  Reason
  6227   "RTN","RCD PEAA4",120 ,0)
  6228    . S $P(DL INE,"^",10 )=$$FMTE^X LFDT($P(FI LEDT,".",1 ),"2ZD") ;  External  Date ERA F iled
  6229   "RTN","RCD PEAA4",121 ,0)
  6230    . S ^TMP( $J,P2,A1,R CDA,RCT)=D LINE
  6231   "RTN","RCD PEAA4",122 ,0)
  6232    Q
  6233   "RTN","RCD PEAA4",123 ,0)
  6234    ;
  6235   "RTN","RCD PEAA4",124 ,0)
  6236   BOUT(P2,VA LMCNT) ; B uild the d isplay lin es and loa d into the  listman t emplate
  6237   "RTN","RCD PEAA4",125 ,0)
  6238    ; Input:  P2 - "RCDP E_APAR_EEO B_PASS2"
  6239   "RTN","RCD PEAA4",126 ,0)
  6240    ; ^TMP($J ,P2,A1,A2)  - B1^B2^B 3^B4^B5^B6 ^B7^B8
  6241   "RTN","RCD PEAA4",127 ,0)
  6242    ; See ERA LINES for  detail
  6243   "RTN","RCD PEAA4",128 ,0)
  6244    ; Output:  VALMCNT -  Total # o f body lin es
  6245   "RTN","RCD PEAA4",129 ,0)
  6246    ; ^TMP("R CDPE-APAR_ EEOB_WL",$ J,VALMCNT, 0) - Listm an Body li ne
  6247   "RTN","RCD PEAA4",130 ,0)
  6248    ; ^TMP("R CDPE-APAR_ EEOB_WL",$ J,"IDX",VA LMCNT,RCSE Q) - Line  selection  index
  6249   "RTN","RCD PEAA4",131 ,0)
  6250    ; ^TMP("R CDPE-APAR_ EEOB_WLDX" ,$J,RCSEQ)  - A1^A2^A 3^...An Wh ere
  6251   "RTN","RCD PEAA4",132 ,0)
  6252    ; A1 - Li ne selecti on #
  6253   "RTN","RCD PEAA4",133 ,0)
  6254    ; A2 - In ternal IEN  for 344.4
  6255   "RTN","RCD PEAA4",134 ,0)
  6256    ; A3 - In ternal IEN  for 344.4 91
  6257   "RTN","RCD PEAA4",135 ,0)
  6258    ; A4 - Un posted Bal ance
  6259   "RTN","RCD PEAA4",136 ,0)
  6260    ; A5 - Po sted Amoun t
  6261   "RTN","RCD PEAA4",137 ,0)
  6262    N A1,BALA NCE,COUNT, DLINE,ERAI EN,RCT,TOT POSTDX,XX
  6263   "RTN","RCD PEAA4",138 ,0)
  6264    S A1="",C OUNT=0
  6265   "RTN","RCD PEAA4",139 ,0)
  6266    F  D  Q:A 1=""
  6267   "RTN","RCD PEAA4",140 ,0)
  6268    . S A1=$O (^TMP($J,P 2,A1))
  6269   "RTN","RCD PEAA4",141 ,0)
  6270    . Q:A1=""
  6271   "RTN","RCD PEAA4",142 ,0)
  6272    . S ERAIE N=""
  6273   "RTN","RCD PEAA4",143 ,0)
  6274    . F  D  Q :ERAIEN=""
  6275   "RTN","RCD PEAA4",144 ,0)
  6276    . . S ERA IEN=$O(^TM P($J,P2,A1 ,ERAIEN))
  6277   "RTN","RCD PEAA4",145 ,0)
  6278    . . Q:ERA IEN=""
  6279   "RTN","RCD PEAA4",146 ,0)
  6280    . . S RCT =""
  6281   "RTN","RCD PEAA4",147 ,0)
  6282    . . F  D   Q:RCT=""
  6283   "RTN","RCD PEAA4",148 ,0)
  6284    . . . S R CT=$O(^TMP ($J,P2,A1, ERAIEN,RCT ))
  6285   "RTN","RCD PEAA4",149 ,0)
  6286    . . . Q:R CT=""
  6287   "RTN","RCD PEAA4",150 ,0)
  6288    . . . S X X=^TMP($J, P2,A1,ERAI EN,RCT)
  6289   "RTN","RCD PEAA4",151 ,0)
  6290    . . . S C OUNT=COUNT +1 ; Selec tion #
  6291   "RTN","RCD PEAA4",152 ,0)
  6292    . . . S D LINE=$J(CO UNT,3)
  6293   "RTN","RCD PEAA4",153 ,0)
  6294    . . . S D LINE=DLINE _$J("",7)_ $$LJ^XLFST R($P(XX,"^ ",2),17) ;  ERA #.Seq uence #
  6295   "RTN","RCD PEAA4",154 ,0)
  6296    . . . S D LINE=DLINE _$$LJ^XLFS TR($P(XX," ^",3),14)           ;  Claim #
  6297   "RTN","RCD PEAA4",155 ,0)
  6298    . . . S T OTPOSTD=$P (XX,"^",4)
  6299   "RTN","RCD PEAA4",156 ,0)
  6300    . . . S D LINE=DLINE _$J(TOTPOS TD,13,2)_"  "                  ;  Posted Am ount
  6301   "RTN","RCD PEAA4",157 ,0)
  6302    . . . ; S  DLINE=DLI NE_$P(XX," ^",5)_"    "                      ; Posted  Date
  6303   "RTN","RCD PEAA4",158 ,0)
  6304    . . . S D LINE=DLINE _$P(XX,"^" ,10)_"   "                     ;  Date ERA  filed
  6305   "RTN","RCD PEAA4",159 ,0)
  6306    . . . S B ALANCE=$P( XX,"^",6)
  6307   "RTN","RCD PEAA4",160 ,0)
  6308    . . . S D LINE=DLINE _$J(BALANC E,13,2)_"  "                   ;  Unpaid Ba lance
  6309   "RTN","RCD PEAA4",161 ,0)
  6310    . . . ; S  DLINE=DLI NE_$P(XX," ^",10)                            ; Date ER A filed
  6311   "RTN","RCD PEAA4",162 ,0)
  6312    . . . S D LINE=DLINE _$P(XX,"^" ,5)                            ;  Posted Da te
  6313   "RTN","RCD PEAA4",163 ,0)
  6314    . . . ;
  6315   "RTN","RCD PEAA4",164 ,0)
  6316    . . . ; L ine 1 of d isplayed E EOB item
  6317   "RTN","RCD PEAA4",165 ,0)
  6318    . . . D S ET(DLINE,C OUNT,ERAIE N,$P(XX,"^ ",8),BALAN CE,TOTPOST D,.VALMCNT )
  6319   "RTN","RCD PEAA4",166 ,0)
  6320    . . . ;
  6321   "RTN","RCD PEAA4",167 ,0)
  6322    . . . ; L ine 2 of d isplayed E EOB item:  payer name /payer id
  6323   "RTN","RCD PEAA4",168 ,0)
  6324    . . . S D LINE=$J("" ,5)_$$PAYT IN^RCDPRU2 ($P(XX,"^" ,7),75)
  6325   "RTN","RCD PEAA4",169 ,0)
  6326    . . . D S ET(DLINE,C OUNT,ERAIE N,$P(XX,"^ ",8),BALAN CE,TOTPOST D,.VALMCNT )
  6327   "RTN","RCD PEAA4",170 ,0)
  6328    . . . ;
  6329   "RTN","RCD PEAA4",171 ,0)
  6330    . . . ; L ine 3 of d isplayed E EOB item:  Auto-Post  Reject Rea son
  6331   "RTN","RCD PEAA4",172 ,0)
  6332    . . . S D LINE=$J("" ,5)_$P(XX, "^",9)
  6333   "RTN","RCD PEAA4",173 ,0)
  6334    . . . D S ET(DLINE,C OUNT,ERAIE N,$P(XX,"^ ",8),BALAN CE,TOTPOST D,.VALMCNT )
  6335   "RTN","RCD PEAA4",174 ,0)
  6336    Q
  6337   "RTN","RCD PEAA4",175 ,0)
  6338    ;
  6339   "RTN","RCD PEAA4",176 ,0)
  6340   SORTP(BALA NCE,TOTPOS TD,PAYNM,R EASON,FILE DT) ; Get  the value  for the se lected sor t
  6341   "RTN","RCD PEAA4",177 ,0)
  6342    ; Input:  BALANCE -  Unpaid Bal ance
  6343   "RTN","RCD PEAA4",178 ,0)
  6344    ; TOTPOST D - Posted  Amount
  6345   "RTN","RCD PEAA4",179 ,0)
  6346    ; POSTDT  - Internal  Posted Da tge
  6347   "RTN","RCD PEAA4",180 ,0)
  6348    ; PAYNM -  Payer Nam e
  6349   "RTN","RCD PEAA4",181 ,0)
  6350    ; REASON  - External  Auto-Post  Reject Re ason
  6351   "RTN","RCD PEAA4",182 ,0)
  6352    ; FILEDT  - Internal  Date/Time  the ERA w as filed
  6353   "RTN","RCD PEAA4",183 ,0)
  6354    ; ^TMP("R CDPE_APAR_ EEOB_PARAM S",$J,"SOR T")- Selec ted sort ( P/D/A/T)
  6355   "RTN","RCD PEAA4",184 ,0)
  6356    ; Returns : External  value for  the selec ted sort t ype
  6357   "RTN","RCD PEAA4",185 ,0)
  6358    N VALUE,X X,YY
  6359   "RTN","RCD PEAA4",186 ,0)
  6360    S XX=^TMP ("RCDPE_AP AR_EEOB_PA RAMS",$J," SORT")
  6361   "RTN","RCD PEAA4",187 ,0)
  6362    S YY=$P(X X,"^",2),X X=$P(XX,"^ ",1)
  6363   "RTN","RCD PEAA4",188 ,0)
  6364    S YY=$S(Y Y="H":-1,1 :1)
  6365   "RTN","RCD PEAA4",189 ,0)
  6366    I XX="N"  Q $$UP^XLF STR(PAYNM)   ; Sort b y Payer Na me
  6367   "RTN","RCD PEAA4",190 ,0)
  6368    I XX="R"  Q $$UP^XLF STR(REASON ) ; Sort b y Auto-pos t Reject R eason
  6369   "RTN","RCD PEAA4",191 ,0)
  6370    I XX="D"  Q FILEDT*Y Y            ; Sort b y Date/Tim e ERA file d
  6371   "RTN","RCD PEAA4",192 ,0)
  6372    I XX="U"  Q BALANCE* YY           ; Sort b y Unposted  Balance
  6373   "RTN","RCD PEAA4",193 ,0)
  6374    Q TOTPOST D*YY                    ; Sort b y Posted A mount
  6375   "RTN","RCD PEAA4",194 ,0)
  6376    ;
  6377   "RTN","RCD PEAA4",195 ,0)
  6378   SET(DLINE, RCSEQ,ERAI EN,RCDA1,B ALANCE,TOT POSTD,VALM CNT) ; Set  ListManag er arrays
  6379   "RTN","RCD PEAA4",196 ,0)
  6380    ; Input:  DLINE - Li ne to be d isplayed i n the list man body
  6381   "RTN","RCD PEAA4",197 ,0)
  6382    ; RCSEQ -  Line Sele ction numb er
  6383   "RTN","RCD PEAA4",198 ,0)
  6384    ; ERAIEN  - Internal  IEN for 3 44.4 or 34 4.49
  6385   "RTN","RCD PEAA4",199 ,0)
  6386    ; RCDA1 -  Inernal I EN for sub file 344.4 91
  6387   "RTN","RCD PEAA4",200 ,0)
  6388    ; BALANCE  - Unposte d Balance
  6389   "RTN","RCD PEAA4",201 ,0)
  6390    ; TOTPOST D - Posted  Amount
  6391   "RTN","RCD PEAA4",202 ,0)
  6392    ; VALMCNT  - Current  listman b ody line c ount
  6393   "RTN","RCD PEAA4",203 ,0)
  6394    ; Output:  VALMCNT -  Updated l istman bod y line cou nt
  6395   "RTN","RCD PEAA4",204 ,0)
  6396    ; ^TMP("R CDPE-APAR_ EEOB_WL",$ J,VALMCNT, 0) - Listm an Body li ne
  6397   "RTN","RCD PEAA4",205 ,0)
  6398    ; ^TMP("R CDPE-APAR_ EEOB_WL",$ J,"IDX",VA LMCNT,RCSE Q) - Line  selection  index
  6399   "RTN","RCD PEAA4",206 ,0)
  6400    ; ^TMP("R CDPE-APAR_ EEOB_WLDX" ,$J,RCSEQ)  - A1^A2^A 3^...An Wh ere
  6401   "RTN","RCD PEAA4",207 ,0)
  6402    ; A1 - Li ne selecti on #
  6403   "RTN","RCD PEAA4",208 ,0)
  6404    ; A2 - In ternal IEN  for 344.4
  6405   "RTN","RCD PEAA4",209 ,0)
  6406    ; A3 - In ternal IEN  for 344.4 91
  6407   "RTN","RCD PEAA4",210 ,0)
  6408    ; A4 - Un posted Bal ance
  6409   "RTN","RCD PEAA4",211 ,0)
  6410    ; A5 - Po sted Amoun t
  6411   "RTN","RCD PEAA4",212 ,0)
  6412    S VALMCNT =VALMCNT+1
  6413   "RTN","RCD PEAA4",213 ,0)
  6414    S ^TMP("R CDPE-APAR_ EEOB_WL",$ J,VALMCNT, 0)=DLINE
  6415   "RTN","RCD PEAA4",214 ,0)
  6416    S ^TMP("R CDPE-APAR_ EEOB_WL",$ J,"IDX",VA LMCNT,RCSE Q)=ERAIEN
  6417   "RTN","RCD PEAA4",215 ,0)
  6418    S ^TMP("R CDPE-APAR_ EEOB_WLDX" ,$J,RCSEQ) =VALMCNT_U _ERAIEN_U_ RCDA1_U_$G (BALANCE)_ U_$G(TOTPO STD)
  6419   "RTN","RCD PEAA4",216 ,0)
  6420    Q
  6421   "RTN","RCD PEAA4",217 ,0)
  6422    ;
  6423   "RTN","RCD PEAP")
  6424   0^48^B2283 21394
  6425   "RTN","RCD PEAP",1,0)
  6426   RCDPEAP ;A LB/PJH - A UTO POST M ATCHING EF T ERA PAIR  ;Oct 15,  2014@12:36 :51
  6427   "RTN","RCD PEAP",2,0)
  6428    ;;4.5;Acc ounts Rece ivable;**2 98,304,318 ,321**;Mar  20, 1995; Build 46
  6429   "RTN","RCD PEAP",3,0)
  6430    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  6431   "RTN","RCD PEAP",4,0)
  6432    ;Read ^IB M(361.1) v ia Private  IA 4051
  6433   "RTN","RCD PEAP",5,0)
  6434    ;
  6435   "RTN","RCD PEAP",6,0)
  6436   EN ;Auto-p ost ERA Re ceipts
  6437   "RTN","RCD PEAP",7,0)
  6438    ;Process  newly matc hed and ma tched but  unprocesse d ERAs
  6439   "RTN","RCD PEAP",8,0)
  6440    D EN1
  6441   "RTN","RCD PEAP",9,0)
  6442    ;Process  previously  processed  ERA's
  6443   "RTN","RCD PEAP",10,0 )
  6444    D EN2
  6445   "RTN","RCD PEAP",11,0 )
  6446    Q
  6447   "RTN","RCD PEAP",12,0 )
  6448    ;
  6449   "RTN","RCD PEAP",13,0 )
  6450   EN1 ;Auto- post newly  matched a nd matched  but unpro cessed ERA
  6451   "RTN","RCD PEAP",14,0 )
  6452    N RCRZ,RC EFTDA
  6453   "RTN","RCD PEAP",15,0 )
  6454    S RCRZ=0
  6455   "RTN","RCD PEAP",16,0 )
  6456    ;Scan ERA  file for  auto-post  candidates  with AUTO -POST STAT US = UNPOS TED
  6457   "RTN","RCD PEAP",17,0 )
  6458    F  S RCRZ =$O(^RCY(3 44.4,"E",0 ,RCRZ)) Q: 'RCRZ  D
  6459   "RTN","RCD PEAP",18,0 )
  6460    .;Get EFT  reference
  6461   "RTN","RCD PEAP",19,0 )
  6462    .S RCEFTD A=$O(^RCY( 344.31,"AE RA",RCRZ," ")) Q:'RCE FTDA
  6463   "RTN","RCD PEAP",20,0 )
  6464    .;Check t hat EFT fu nds were p osted to F MS and Acc epted by F MS.  If no t, quit an d go to ne xt unposte d ERA
  6465   "RTN","RCD PEAP",21,0 )
  6466    .N RCOK,R CDEPTDA,RC RECTDA
  6467   "RTN","RCD PEAP",22,0 )
  6468    .S RCOK=1
  6469   "RTN","RCD PEAP",23,0 )
  6470    .I $P($G( ^RCY(344.3 ,+$G(^RCY( 344.31,+RC EFTDA,0)), 0)),U,8),$ P($G(^RCY( 344.31,+RC EFTDA,0)), U,7) D  Q: 'RCOK
  6471   "RTN","RCD PEAP",24,0 )
  6472    ..S RCDEP TDA=+$P($G (^RCY(344. 3,+$G(^RCY (344.31,+R CEFTDA,0)) ,0)),U,3), RCRECTDA=+ $O(^RCY(34 4,"AD",+RC DEPTDA,0))  ; Get dep osit ticke t and EFT  receipt (C R - 8NZZ)
  6473   "RTN","RCD PEAP",25,0 )
  6474    ..I RCREC TDA N Z S  Z=$P($$FMS STAT^RCDPU REC(RCRECT DA),U,2) I  $E(Z)="A"  Q  ; EFT  Accepted b y FMS
  6475   "RTN","RCD PEAP",26,0 )
  6476    ..S RCOK= 0
  6477   "RTN","RCD PEAP",27,0 )
  6478    .;
  6479   "RTN","RCD PEAP",28,0 )
  6480    .;Auto-Po st
  6481   "RTN","RCD PEAP",29,0 )
  6482    .D AUTOPO ST(RCEFTDA ,RCRZ)
  6483   "RTN","RCD PEAP",30,0 )
  6484    Q
  6485   "RTN","RCD PEAP",31,0 )
  6486    ;
  6487   "RTN","RCD PEAP",32,0 )
  6488    ; Process  ERA
  6489   "RTN","RCD PEAP",33,0 )
  6490   AUTOPOST(R CEFTDA,RCE RA) ; 
  6491   "RTN","RCD PEAP",34,0 )
  6492    ; RCEFTDA  = ien of  file #344. 31
  6493   "RTN","RCD PEAP",35,0 )
  6494    ; RCERA =  ien of fi le #344.4
  6495   "RTN","RCD PEAP",36,0 )
  6496    ;
  6497   "RTN","RCD PEAP",37,0 )
  6498    ;Lock ERA
  6499   "RTN","RCD PEAP",38,0 )
  6500    L +^RCY(3 44.4,RCERA ):5 Q:'$T
  6501   "RTN","RCD PEAP",39,0 )
  6502    ;
  6503   "RTN","RCD PEAP",40,0 )
  6504    ;Build Sc ratchpad a nd Verify  Lines
  6505   "RTN","RCD PEAP",41,0 )
  6506    N ALLOK,R CERR,RCLIN ES,RCRCPTD A,RCSCR,RC TRDA,ZEROB AL ; PRCA* 4.5*318 Va riables pl aced in al pha order
  6507   "RTN","RCD PEAP",42,0 )
  6508    K ^TMP($J ,"RCDPEWLA ")
  6509   "RTN","RCD PEAP",43,0 )
  6510    S RCSCR=$ $SCRPAD(RC ERA)
  6511   "RTN","RCD PEAP",44,0 )
  6512    ; Re-set  AUTO-POST  STATUS  if  unable to  create sc ratchpad
  6513   "RTN","RCD PEAP",45,0 )
  6514    I 'RCSCR  D SETSTA(R CERA,"@"," Auto Posti ng: Remove d from Aut o Posting- Unable to  create scr atchpad")  G AUTOQ
  6515   "RTN","RCD PEAP",46,0 )
  6516    ;
  6517   "RTN","RCD PEAP",47,0 )
  6518    ; ERA can not be aut oposted; r emove any  pre-existi ng value t o the AUTO -POST STAT US so ERA  can be pro cessed man ually in t he Worklis t
  6519   "RTN","RCD PEAP",48,0 )
  6520    I $D(^TMP ($J,"RCDPE WLA","ERA  LEVEL ADJU STMENT EXI STS")) D S ETSTA(RCER A,"@","Aut o Posting:  Removed f rom Auto P osting-ERA  level Adj ustment(s) ") G AUTOQ
  6521   "RTN","RCD PEAP",49,0 )
  6522    ;
  6523   "RTN","RCD PEAP",50,0 )
  6524    ; If ERA  is unbalan ced, do no t auto-pos t
  6525   "RTN","RCD PEAP",51,0 )
  6526    I $$UNBAL ^RCDPEAP1( RCERA) D   Q  ; PRCA* 4.5*318 Ad ded line
  6527   "RTN","RCD PEAP",52,0 )
  6528    .D SETSTA (RCERA,"@" ,"Auto Pos ting: Remo ved from A uto Postin g-Unbalanc ed ERA") ;  PRCA*4.5* 321
  6529   "RTN","RCD PEAP",53,0 )
  6530    ;
  6531   "RTN","RCD PEAP",54,0 )
  6532    ;Check if  all lines  can be po sted
  6533   "RTN","RCD PEAP",55,0 )
  6534    S ALLOK=$ $ALLOK(RCE RA,RCSCR,. ZEROBAL,.R CLINES)
  6535   "RTN","RCD PEAP",56,0 )
  6536    ;
  6537   "RTN","RCD PEAP",57,0 )
  6538    ;If $$ALL OK post en tire ERA a nd reset A UTO-POST S TATUS = CO MPLETE
  6539   "RTN","RCD PEAP",58,0 )
  6540    I ALLOK D  POSTALL(R CERA)
  6541   "RTN","RCD PEAP",59,0 )
  6542    ;
  6543   "RTN","RCD PEAP",60,0 )
  6544    ; If 'ALL OK and 'ZE ROBAL(matc hing posit ive/negati ve pairs t o not bala nce out to  zero), th en ERA nee ds to go t o the stan dard workl ist for ma nual recei pt process ing
  6545   "RTN","RCD PEAP",61,0 )
  6546    I 'ALLOK, 'ZEROBAL D  SETSTA(RC ERA,"@","A uto Postin g: Removed  from Auto  Posting-+ /- pairs d o not bala nce") G AU TOQ
  6547   "RTN","RCD PEAP",62,0 )
  6548    ;
  6549   "RTN","RCD PEAP",63,0 )
  6550    ;If 'ALLO K and some  of the li nes passed  validatio n then pos t receipt  to summary  ERA and s et AUTO-PO ST STATUS  = PARTIAL
  6551   "RTN","RCD PEAP",64,0 )
  6552    ;Un-poste d lines fa ll to APAR  list for  processing .
  6553   "RTN","RCD PEAP",65,0 )
  6554    I 'ALLOK  D POSTERA( RCERA,.RCL INES)
  6555   "RTN","RCD PEAP",66,0 )
  6556    ;Unlock E RA
  6557   "RTN","RCD PEAP",67,0 )
  6558   AUTOQ D UN LOCKE
  6559   "RTN","RCD PEAP",68,0 )
  6560    Q
  6561   "RTN","RCD PEAP",69,0 )
  6562    ;
  6563   "RTN","RCD PEAP",70,0 )
  6564   EN2 ;Auto- Post Previ ously Proc essed ERA
  6565   "RTN","RCD PEAP",71,0 )
  6566    N AUTORCP T,CLAIM,CO MPLETE,EOB IEN,RCERA, RCIFN,RCRC PTDA,RCLIN ES
  6567   "RTN","RCD PEAP",72,0 )
  6568    S RCERA=0 ,AUTORCPT= 1 ;Variabl e AUTORCPT  suppresse s #344 tri gger updat e to ERA r eceipt fie ld
  6569   "RTN","RCD PEAP",73,0 )
  6570    ;Scan ERA  file for  auto-post  candidates  with AUTO -POST STAT US = PARTI AL
  6571   "RTN","RCD PEAP",74,0 )
  6572    F  S RCER A=$O(^RCY( 344.4,"E", 1,RCERA))  Q:'RCERA   D
  6573   "RTN","RCD PEAP",75,0 )
  6574    . ;Ignore  if it was  just part ially post ed in POST LNS so we  do not pro cess again
  6575   "RTN","RCD PEAP",76,0 )
  6576    . Q:$D(^T MP("RCDPEA P",$J,RCER A))
  6577   "RTN","RCD PEAP",77,0 )
  6578    . ;Set re ceipt vari able to nu ll for eac h ERA so t hat the re ceipt numb er from th e previous  ERA is no t hanging  around
  6579   "RTN","RCD PEAP",78,0 )
  6580    . S RCRCP TDA=""
  6581   "RTN","RCD PEAP",79,0 )
  6582    . ;Check  if there a re lines t hat are se t for auto -posting a nd if they  can be po sted or ha ve errors.
  6583   "RTN","RCD PEAP",80,0 )
  6584    . K RCLIN ES
  6585   "RTN","RCD PEAP",81,0 )
  6586    . S RCLIN ES=0
  6587   "RTN","RCD PEAP",82,0 )
  6588    . D VALID ^RCDPEAP1( RCERA,.RCL INES)
  6589   "RTN","RCD PEAP",83,0 )
  6590    . ;If val id lines f ound creat e receipt  for those  lines (Var iable RCLI NES is onl y incremen ted for va lid lines)
  6591   "RTN","RCD PEAP",84,0 )
  6592    . I RCLIN ES D
  6593   "RTN","RCD PEAP",85,0 )
  6594    . . N RCE FTDA,RCDEP TDA,RCRECT DA
  6595   "RTN","RCD PEAP",86,0 )
  6596    . . ;Get  EFT refere nce
  6597   "RTN","RCD PEAP",87,0 )
  6598    . . S RCE FTDA=$O(^R CY(344.31, "AERA",RCE RA,"")) Q: 'RCEFTDA
  6599   "RTN","RCD PEAP",88,0 )
  6600    . . ;Get  deposit ti cket and E FT receipt
  6601   "RTN","RCD PEAP",89,0 )
  6602    . . S RCD EPTDA=+$P( $G(^RCY(34 4.3,+$G(^R CY(344.31, +RCEFTDA,0 )),0)),U,3 ),RCRECTDA =+$O(^RCY( 344,"AD",+ RCDEPTDA,0 ))
  6603   "RTN","RCD PEAP",90,0 )
  6604    . . ;ERA  Receipt is  created f rom scratc hpad entry  - type 14  is EDI Lo ckbox paym ent
  6605   "RTN","RCD PEAP",91,0 )
  6606    . . S RCR CPTDA=$$BL DRCPT^RCDP EMA(RCERA)  ; Creates  basic rec eipt for E RA of paym ent type E DI LOCKBOX ; 2nd para meter mean s an alpha  suffix on  receipt n umber
  6607   "RTN","RCD PEAP",92,0 )
  6608    . . I 'RC RCPTDA Q   ;PRCA*4.5* 318 - Prob lem buildi ng receipt  header
  6609   "RTN","RCD PEAP",93,0 )
  6610    . . K RCE RR
  6611   "RTN","RCD PEAP",94,0 )
  6612    . . D RCP TDET^RCDPE MA(RCERA,R CRCPTDA,.R CLINES,.RC ERR) ; Add s detail t o a receip t based on  file 344. 49 and RCL INES array
  6613   "RTN","RCD PEAP",95,0 )
  6614    . . ;;Una ble to cre ate receip t - clear  scratchpad , reset AU TO-POST ST ATUS = NUL L - PRCA*4 .5*318 - r eplaced fo llowing li ne
  6615   "RTN","RCD PEAP",96,0 )
  6616    . . ;;I $ O(RCERR("" )) D CLEAR (RCSCR),SE TSTA(RCERA ,"@","Auto  Posting:  Removed fr om Auto Po sting-Unab le to crea te receipt ") Q
  6617   "RTN","RCD PEAP",97,0 )
  6618    . . I $O( RCERR(""))  Q  ; PRCA *4.5*318 -  Do not at tempt to p rocess par tially fil ed receipt
  6619   "RTN","RCD PEAP",98,0 )
  6620    . . ;Lock  ERA recei pt and dep osit ticke t
  6621   "RTN","RCD PEAP",99,0 )
  6622    . . I '$$ LOCKREC^RC DPRPLU(RCR CPTDA) Q
  6623   "RTN","RCD PEAP",100, 0)
  6624    . . I '$$ LOCKDEP^RC DPDPLU(RCD EPTDA) D U NLOCKR Q
  6625   "RTN","RCD PEAP",101, 0)
  6626    . . ;Proc ess Receip t to FMS
  6627   "RTN","RCD PEAP",102, 0)
  6628    . . D PRO CESS^RCDPU RE1(RCRCPT DA,2) I $D (^TMP("RCD PE-RECEIPT -ERROR",$J )) D UNLOC KR Q
  6629   "RTN","RCD PEAP",103, 0)
  6630    . . ; upd ate 344, . 18 ERA REF ERENCE fie ld
  6631   "RTN","RCD PEAP",104, 0)
  6632    . . D ERA REF(RCERA, RCRCPTDA)
  6633   "RTN","RCD PEAP",105, 0)
  6634    . . ;Unlo ck deposit  ticket an d receipt
  6635   "RTN","RCD PEAP",106, 0)
  6636    . . D UNL OCKR
  6637   "RTN","RCD PEAP",107, 0)
  6638    . ;Update  ERA and E RA detail  lines with  receipt #  or auto-p ost reject ion reason
  6639   "RTN","RCD PEAP",108, 0)
  6640    . D ERADE T^RCDPEAP1 (RCERA,RCR CPTDA,.RCL INES)
  6641   "RTN","RCD PEAP",109, 0)
  6642    . ;Determ ine if pos ting compl ete for th is ERA
  6643   "RTN","RCD PEAP",110, 0)
  6644    . S COMPL ETE=$$COMP LETE(RCERA )
  6645   "RTN","RCD PEAP",111, 0)
  6646    . ;If com plete upda te ERA det ail post s tatus to P OSTED
  6647   "RTN","RCD PEAP",112, 0)
  6648    . I COMPL ETE S DIE= "^RCY(344. 4,",DR=".1 4////1",DA =RCERA D ^ DIE
  6649   "RTN","RCD PEAP",113, 0)
  6650    . ;Update  the audit  log
  6651   "RTN","RCD PEAP",114, 0)
  6652    . D AUDIT LOG(RCERA, $S(COMPLET E:2,1:1)," Auto Posti ng: Previo usly proce ssed ERA p osting att empt")
  6653   "RTN","RCD PEAP",115, 0)
  6654    . ;Set ER A auto-pos t status a nd update  latest aut o-post dat e
  6655   "RTN","RCD PEAP",116, 0)
  6656    . S DIE=" ^RCY(344.4 ,",DR="4.0 1////"_DT_ ";4.02//// "_$S(COMPL ETE:2,1:1) ,DA=RCERA  D ^DIE
  6657   "RTN","RCD PEAP",117, 0)
  6658    ;Unlock E RA
  6659   "RTN","RCD PEAP",118, 0)
  6660    D UNLOCKE
  6661   "RTN","RCD PEAP",119, 0)
  6662    Q
  6663   "RTN","RCD PEAP",120, 0)
  6664    ;
  6665   "RTN","RCD PEAP",121, 0)
  6666    ;Function s/Sub-rout ines in al pha order
  6667   "RTN","RCD PEAP",122, 0)
  6668    ;
  6669   "RTN","RCD PEAP",123, 0)
  6670   ACTIVE(EOB IEN) ;Veri fy claim i s active
  6671   "RTN","RCD PEAP",124, 0)
  6672    ; EOBIEN  - IEN of f ile 361.1
  6673   "RTN","RCD PEAP",125, 0)
  6674    N RCIFN,R CBILL,RCST ATUS
  6675   "RTN","RCD PEAP",126, 0)
  6676    ;Get EOB  number (im plies this  is 3rd Pa rty claim)
  6677   "RTN","RCD PEAP",127, 0)
  6678    I 'EOBIEN  Q 0
  6679   "RTN","RCD PEAP",128, 0)
  6680    ;Get #399  claim num ber from E OB
  6681   "RTN","RCD PEAP",129, 0)
  6682    S RCIFN=$ P($G(^IBM( 361.1,EOBI EN,0)),U)  Q:'RCIFN 0
  6683   "RTN","RCD PEAP",130, 0)
  6684    S RCBILL= $P($G(^DGC R(399,RCIF N,0)),U) Q :RCBILL=""  0  ; IA 4 051
  6685   "RTN","RCD PEAP",131, 0)
  6686    ;Check if  bill is c ancelled o r closed
  6687   "RTN","RCD PEAP",132, 0)
  6688    S RCSTATU S=$P($G(^D GCR(399,RC IFN,0)),U, 13)
  6689   "RTN","RCD PEAP",133, 0)
  6690    Q $S(RCST ATUS=0:0,R CSTATUS=7: 0,1:1)
  6691   "RTN","RCD PEAP",134, 0)
  6692    ; 
  6693   "RTN","RCD PEAP",135, 0)
  6694   ALLOK(RCER A,RCSCR,ZE ROBAL,RCLI NES) ;Veri fy which s cratchpad  lines are  able to au to-post
  6695   "RTN","RCD PEAP",136, 0)
  6696    ; RCERA -  344.4 ien
  6697   "RTN","RCD PEAP",137, 0)
  6698    ; RCSCR -  344.49 ie n
  6699   "RTN","RCD PEAP",138, 0)
  6700    ; ZEROBAL  - flag th at represe nts if ERA  has zero  payment ba lance afte r processi ng matched  positive/ negative p airs, pass ed by refe rence
  6701   "RTN","RCD PEAP",139, 0)
  6702    ; RCLINES  - array o f ERA line  reference s (passed  in by refe rence)
  6703   "RTN","RCD PEAP",140, 0)
  6704    ;            NOTE:   ORIGINAL E RA SEQUENC ES (344.49 1, .09) ca n have mul tiple ERA  line refer ences sepa rated by c ommas (e.g ., 3,4)
  6705   "RTN","RCD PEAP",141, 0)
  6706    ; returns  0 or 1 (A LLOK)
  6707   "RTN","RCD PEAP",142, 0)
  6708    N ALLOK,A MT,ERALINE ,STATUS,SU B,SUB1,CLA IM,WLINE,V ERIFY
  6709   "RTN","RCD PEAP",143, 0)
  6710    K CLARRAY
  6711   "RTN","RCD PEAP",144, 0)
  6712    S (ZEROBA L,ALLOK)=1
  6713   "RTN","RCD PEAP",145, 0)
  6714    S (SUB,RC LINES)=0
  6715   "RTN","RCD PEAP",146, 0)
  6716    F  S SUB= $O(^RCY(34 4.49,RCSCR ,1,"B",SUB )) Q:SUB=" "  D
  6717   "RTN","RCD PEAP",147, 0)
  6718    . ;Get sc ratchpad l ine and da ta
  6719   "RTN","RCD PEAP",148, 0)
  6720    . S SUB1= $O(^RCY(34 4.49,RCSCR ,1,"B",SUB ,"")) Q:'S UB1  S WLI NE=$G(^RCY (344.49,RC SCR,1,SUB1 ,0)),AMT=$ P(WLINE,U, 3)
  6721   "RTN","RCD PEAP",149, 0)
  6722    . ;If int eger seque nce, get E RA line re ference an d verify f lag and th en quit fo r this seq uence and  go on to t he non-int eger seque nce to fin ish valida tion
  6723   "RTN","RCD PEAP",150, 0)
  6724    . I $P(WL INE,U)?1N. N S VERIFY =1 S ERALI NE=$P(WLIN E,U,9) S:' $P(WLINE,U ,13) ALLOK =0,RCLINES (ERALINE)= "0^^1",VER IFY=0 Q
  6725   "RTN","RCD PEAP",151, 0)
  6726    . ; ignor e zero val ued lines
  6727   "RTN","RCD PEAP",152, 0)
  6728    . Q:AMT=0   Q:AMT="0 .00"
  6729   "RTN","RCD PEAP",153, 0)
  6730    . ;Get cl aim number  from N.00 1 line - i f not foun d treat as  inactive
  6731   "RTN","RCD PEAP",154, 0)
  6732    . S CLAIM =$P(WLINE, U,7) I 'CL AIM S ALLO K=0,$P(RCL INES(ERALI NE),U,3)=2  Q
  6733   "RTN","RCD PEAP",155, 0)
  6734    . ;Save c laim numbe r
  6735   "RTN","RCD PEAP",156, 0)
  6736    . S $P(RC LINES(ERAL INE),U,2)= $P($G(^PRC A(430,CLAI M,0)),U) Q :'VERIFY
  6737   "RTN","RCD PEAP",157, 0)
  6738    . ;Claim  must be OP EN or ACTI VE
  6739   "RTN","RCD PEAP",158, 0)
  6740    . S STATU S=$P($G(^P RCA(430,CL AIM,0)),"^ ",8) I STA TUS'=42,ST ATUS'=16 S  ALLOK=0,$ P(RCLINES( ERALINE),U ,3)=2 Q
  6741   "RTN","RCD PEAP",159, 0)
  6742    . ;Check  that payme nt does no t exceed b alance and  no pendin g payments  (at the t ime of aut o posting)
  6743   "RTN","RCD PEAP",160, 0)
  6744    . S CLARR AY(CLAIM)= +$G(CLARRA Y(CLAIM))+ $P(WLINE,U ,3) I '$$C HECKPAY(.C LARRAY,CLA IM) S ALLO K=0,$P(RCL INES(ERALI NE),U,3)=3  Q
  6745   "RTN","RCD PEAP",161, 0)
  6746    . ;Check  if referre d to gener al council
  6747   "RTN","RCD PEAP",162, 0)
  6748    . I $P($G (^PRCA(430 ,CLAIM,6)) ,U,4)]"" S  ALLOK=0,$ P(RCLINES( ERALINE),U ,3)=4 Q
  6749   "RTN","RCD PEAP",163, 0)
  6750    . ;Line i s potentia lly postab le
  6751   "RTN","RCD PEAP",164, 0)
  6752    . S $P(RC LINES(ERAL INE),U)=1, $P(RCLINES (ERALINE), U,3)=$P(WL INE,U,6),R CLINES=$G( RCLINES)+1
  6753   "RTN","RCD PEAP",165, 0)
  6754    Q ALLOK
  6755   "RTN","RCD PEAP",166, 0)
  6756    ;
  6757   "RTN","RCD PEAP",167, 0)
  6758   AUDITLOG(D A,RCNEWST, RCREASON)  ;
  6759   "RTN","RCD PEAP",168, 0)
  6760    ; Update  the Auto-p ost Audit  Log
  6761   "RTN","RCD PEAP",169, 0)
  6762    ;
  6763   "RTN","RCD PEAP",170, 0)
  6764    I '$G(DA)  Q
  6765   "RTN","RCD PEAP",171, 0)
  6766    I $G(RCRE ASON)="" Q
  6767   "RTN","RCD PEAP",172, 0)
  6768    ;
  6769   "RTN","RCD PEAP",173, 0)
  6770    N RCAUDIT ,RCOLDST,D IE,DR,X,Y, DTOUT,DUOU T,DROUT,DI RUT
  6771   "RTN","RCD PEAP",174, 0)
  6772    ; Get the  current s tatus
  6773   "RTN","RCD PEAP",175, 0)
  6774    S RCOLDST =$$GET1^DI Q(344.4,DA _",",4.02, "I")
  6775   "RTN","RCD PEAP",176, 0)
  6776    ; If the  new status  is null,  set to old  status (n o change)
  6777   "RTN","RCD PEAP",177, 0)
  6778    I $G(RCNE WST)="" S  RCNEWST=RC OLDST
  6779   "RTN","RCD PEAP",178, 0)
  6780    ; File
  6781   "RTN","RCD PEAP",179, 0)
  6782    S RCAUDIT (344.72,"+ 1,",.01)=$ $NOW^XLFDT  ;Date/Tim e Stamp
  6783   "RTN","RCD PEAP",180, 0)
  6784    S RCAUDIT (344.72,"+ 1,",.02)=D UZ          ;User
  6785   "RTN","RCD PEAP",181, 0)
  6786    S RCAUDIT (344.72,"+ 1,",.03)=D A           ;ERA #
  6787   "RTN","RCD PEAP",182, 0)
  6788    S RCAUDIT (344.72,"+ 1,",.04)=R COLDST      ;Old Stat us
  6789   "RTN","RCD PEAP",183, 0)
  6790    I RCNEWST '="@" S RC AUDIT(344. 72,"+1,",. 05)=RCNEWS T ;New sta tus
  6791   "RTN","RCD PEAP",184, 0)
  6792    S RCAUDIT (344.72,"+ 1,",.06)=$ E(RCREASON ,1,80) ;Re ason text
  6793   "RTN","RCD PEAP",185, 0)
  6794    D UPDATE^ DIE(,"RCAU DIT")
  6795   "RTN","RCD PEAP",186, 0)
  6796    Q
  6797   "RTN","RCD PEAP",187, 0)
  6798    ;
  6799   "RTN","RCD PEAP",188, 0)
  6800   BUILD(RCSC R,ARRAY) ; Build list  of ERA li nes
  6801   "RTN","RCD PEAP",189, 0)
  6802    ;
  6803   "RTN","RCD PEAP",190, 0)
  6804    ; RCSCR =  ien of fi le 344.49
  6805   "RTN","RCD PEAP",191, 0)
  6806    ; ARRAY =  the array  that will  hold the  list of ER A lines, p assed by r eference
  6807   "RTN","RCD PEAP",192, 0)
  6808    ;
  6809   "RTN","RCD PEAP",193, 0)
  6810    N FOUND,S CRLINE,SUB ,SUB1
  6811   "RTN","RCD PEAP",194, 0)
  6812    K ARRAY
  6813   "RTN","RCD PEAP",195, 0)
  6814    S SUB=0,A RRAY=0
  6815   "RTN","RCD PEAP",196, 0)
  6816    F  S SUB= $O(^RCY(34 4.49,RCSCR ,1,"B",SUB )) Q:SUB=" "  D:SUB'[ "."
  6817   "RTN","RCD PEAP",197, 0)
  6818    . ;Get ac tual scrat chpad ^RCY (344.49,RC SCR,1) nod e
  6819   "RTN","RCD PEAP",198, 0)
  6820    . S SUB1= $O(^RCY(34 4.49,RCSCR ,1,"B",SUB ,"")) Q:'S UB1
  6821   "RTN","RCD PEAP",199, 0)
  6822    . ;Ignore  zero line s
  6823   "RTN","RCD PEAP",200, 0)
  6824    . Q:'$P($ G(^RCY(344 .49,RCSCR, 1,SUB1,0)) ,U,3)
  6825   "RTN","RCD PEAP",201, 0)
  6826    . ;Index  scratchpad  line by E RA sequenc e
  6827   "RTN","RCD PEAP",202, 0)
  6828    . S ARRAY ($P($G(^RC Y(344.49,R CSCR,1,SUB 1,0)),U,9) )=SUB1,ARR AY=$G(ARRA Y)+1
  6829   "RTN","RCD PEAP",203, 0)
  6830    Q
  6831   "RTN","RCD PEAP",204, 0)
  6832    ;
  6833   "RTN","RCD PEAP",205, 0)
  6834   CHECKPAY(A RRAY,CLAIM ) ;Check b alance ver sus paymen ts
  6835   "RTN","RCD PEAP",206, 0)
  6836    ; ARRAY =  array of  claim numb ers and re spective p ayment amo unts
  6837   "RTN","RCD PEAP",207, 0)
  6838    ;          e.g. ARRA Y(430 ien)  = 123.04
  6839   "RTN","RCD PEAP",208, 0)
  6840    ; CLAIM =  AR BILL ( 344.491, . 07) - IEN  of file 43 0
  6841   "RTN","RCD PEAP",209, 0)
  6842    Q:'CLAIM  0
  6843   "RTN","RCD PEAP",210, 0)
  6844    ; get the  payment a mount to b e posted t o the clai m
  6845   "RTN","RCD PEAP",211, 0)
  6846    S AMT=ARR AY(CLAIM)
  6847   "RTN","RCD PEAP",212, 0)
  6848    ;Payment  exceeds pr inciple ba lance
  6849   "RTN","RCD PEAP",213, 0)
  6850    Q:AMT>$P( $G(^PRCA(4 30,CLAIM,7 )),U) 0
  6851   "RTN","RCD PEAP",214, 0)
  6852    ;Check pe nding paym ents for c laim
  6853   "RTN","RCD PEAP",215, 0)
  6854    N PENDING  S PENDING =$$PENDPAY ^RCDPURET( CLAIM) K ^ TMP($J,"RC DPUREC","P P")
  6855   "RTN","RCD PEAP",216, 0)
  6856    ;Pending  payments i s > billed
  6857   "RTN","RCD PEAP",217, 0)
  6858    I PENDING >AMT Q 0
  6859   "RTN","RCD PEAP",218, 0)
  6860    ;otherwis e OK to po st payment
  6861   "RTN","RCD PEAP",219, 0)
  6862    Q 1
  6863   "RTN","RCD PEAP",220, 0)
  6864    ; 
  6865   "RTN","RCD PEAP",221, 0)
  6866   CLEAR(DA)  ;Clear scr atchpad
  6867   "RTN","RCD PEAP",222, 0)
  6868    N DIK S D IK="^RCY(3 44.49," D  ^DIK
  6869   "RTN","RCD PEAP",223, 0)
  6870    Q
  6871   "RTN","RCD PEAP",224, 0)
  6872    ;
  6873   "RTN","RCD PEAP",225, 0)
  6874   COMPLETE(R CSCR) ;Che ck for non -zero line s without  a receipt
  6875   "RTN","RCD PEAP",226, 0)
  6876    ;
  6877   "RTN","RCD PEAP",227, 0)
  6878    ; RCSCR =  ien of fi le 344.49
  6879   "RTN","RCD PEAP",228, 0)
  6880    ; Returns  status of  check (1  or 0)
  6881   "RTN","RCD PEAP",229, 0)
  6882    N RCSUB,S CRSUB,COMP LETE,SCRLI NE,RCERA
  6883   "RTN","RCD PEAP",230, 0)
  6884    ;Default  to complet e
  6885   "RTN","RCD PEAP",231, 0)
  6886    S SCRSUB= 0,COMPLETE =1,RCERA=R CSCR
  6887   "RTN","RCD PEAP",232, 0)
  6888    ;Scan scr atchpad
  6889   "RTN","RCD PEAP",233, 0)
  6890    F  S SCRS UB=$O(^RCY (344.49,RC SCR,1,SCRS UB)) Q:'SC RSUB  D  Q :'COMPLETE
  6891   "RTN","RCD PEAP",234, 0)
  6892    . ;Ignore  zero and  split line s (splitti ng line sh ould not c hange bala nce)
  6893   "RTN","RCD PEAP",235, 0)
  6894    . S SCRLI NE=$G(^RCY (344.49,RC SCR,1,SCRS UB,0)) Q:$ P(SCRLINE, U)'?1N.N   Q:$P(SCRLI NE,U,3)=0   Q:$P(SCRL INE,U,3)=" 0.00"
  6895   "RTN","RCD PEAP",236, 0)
  6896    . ;Check  if non-zer o line has  receipt o n ERA, DET AIL line
  6897   "RTN","RCD PEAP",237, 0)
  6898    . S RCSUB =$P(SCRLIN E,U,9) I R CSUB,$P($G (^RCY(344. 4,RCERA,1, RCSUB,4)), U,3)]"" Q
  6899   "RTN","RCD PEAP",238, 0)
  6900    . ;Otherw ise more A UTO-postin g to do
  6901   "RTN","RCD PEAP",239, 0)
  6902    . S COMPL ETE=0
  6903   "RTN","RCD PEAP",240, 0)
  6904    Q COMPLET E
  6905   "RTN","RCD PEAP",241, 0)
  6906    ;
  6907   "RTN","RCD PEAP",242, 0)
  6908   ERAREF(RCS CR,RCRCPTD A) ; updat e ERA refe rence and  EFT record  IEN in fi le 344
  6909   "RTN","RCD PEAP",243, 0)
  6910    ; RCSCR -  IEN of re cord in fi le 344.49
  6911   "RTN","RCD PEAP",244, 0)
  6912    ; RCRCPTD A - ien of  record in  file 344  (receipt i en)
  6913   "RTN","RCD PEAP",245, 0)
  6914    N Z,DR,DI E,DA
  6915   "RTN","RCD PEAP",246, 0)
  6916    S Z=+$O(^ RCY(344.31 ,"AERA",RC SCR,0))
  6917   "RTN","RCD PEAP",247, 0)
  6918    S DIE="^R CY(344,",D A=RCRCPTDA ,DR=".18// //"_RCSCR_ $S(Z:";.17 ////"_Z,1: "") D ^DIE
  6919   "RTN","RCD PEAP",248, 0)
  6920    Q
  6921   "RTN","RCD PEAP",249, 0)
  6922    ;
  6923   "RTN","RCD PEAP",250, 0)
  6924   NOTOK(RCSC R) ;Verify  all scrat chpad line s passed a uto verify  (V)
  6925   "RTN","RCD PEAP",251, 0)
  6926    ;
  6927   "RTN","RCD PEAP",252, 0)
  6928    ; RCSCR =  ien of fi le 344.49
  6929   "RTN","RCD PEAP",253, 0)
  6930    ; Returns  status of  check (1  or 0)
  6931   "RTN","RCD PEAP",254, 0)
  6932    N NOTOK,S UB
  6933   "RTN","RCD PEAP",255, 0)
  6934    S SUB=0,N OTOK=0
  6935   "RTN","RCD PEAP",256, 0)
  6936    F  S SUB= $O(^RCY(34 4.49,RCSCR ,1,SUB)) Q :'SUB  D   Q:NOTOK
  6937   "RTN","RCD PEAP",257, 0)
  6938    . ;Set NO TOK if any  single li ne is unve rified
  6939   "RTN","RCD PEAP",258, 0)
  6940    . S:$P($G (^RCY(344. 49,RCSCR,1 ,SUB,0)),U ,13)'=1 NO TOK=1
  6941   "RTN","RCD PEAP",259, 0)
  6942    Q NOTOK
  6943   "RTN","RCD PEAP",260, 0)
  6944    ;
  6945   "RTN","RCD PEAP",261, 0)
  6946   POSTALL(RC ERA) ; all  lines in  ERA get po sted on fi rst attemp t of auto- post
  6947   "RTN","RCD PEAP",262, 0)
  6948    ;
  6949   "RTN","RCD PEAP",263, 0)
  6950    ; RCERA =  ien of 34 4.4
  6951   "RTN","RCD PEAP",264, 0)
  6952    ;
  6953   "RTN","RCD PEAP",265, 0)
  6954    ;ERA Rece ipt is cre ated from  scratchpad  entry - t ype 14 is  EDI Lockbo x payment
  6955   "RTN","RCD PEAP",266, 0)
  6956    S RCRCPTD A=$$BLDRCP T^RCDPUREC (DT,"",+$O (^RC(341.1 ,"AC",14,0 )))  ; Cre ates basic  receipt f or ERA of  payment ty pe EDI LOC KBOX; 2nd  parameter  means no a lpha suffi x on recei pt number
  6957   "RTN","RCD PEAP",267, 0)
  6958    D RCPTDET ^RCDPEM(RC SCR,RCRCPT DA,.RCERR)  ; Adds de tail to a  receipt ba sed on fil e 344.49
  6959   "RTN","RCD PEAP",268, 0)
  6960    ;
  6961   "RTN","RCD PEAP",269, 0)
  6962    ;Unable t o create r eceipt - c lear scrat chpad, res et AUTO-PO ST STATUS  = NULL
  6963   "RTN","RCD PEAP",270, 0)
  6964    I $O(RCER R("")) D C LEAR(RCSCR ),SETSTA(R CERA,"@"," Auto Posti ng: Remove d from Aut o Posting- Unable to  create rec eipt") Q
  6965   "RTN","RCD PEAP",271, 0)
  6966    ;
  6967   "RTN","RCD PEAP",272, 0)
  6968    ;Lock ERA  receipt a nd deposit  ticket
  6969   "RTN","RCD PEAP",273, 0)
  6970    I '$$LOCK REC^RCDPRP LU(RCRCPTD A) Q
  6971   "RTN","RCD PEAP",274, 0)
  6972    I '$$LOCK DEP^RCDPDP LU(RCDEPTD A) D UNLOC KR Q
  6973   "RTN","RCD PEAP",275, 0)
  6974    ;
  6975   "RTN","RCD PEAP",276, 0)
  6976    ;Process  Receipt to  FMS
  6977   "RTN","RCD PEAP",277, 0)
  6978    D PROCESS ^RCDPURE1( RCRCPTDA,2 )
  6979   "RTN","RCD PEAP",278, 0)
  6980    I $D(^TMP ("RCDPE-RE CEIPT-ERRO R",$J)) D  CLEAR(RCSC R),SETSTA( RCERA,"@", "Auto Post ing: Remov ed from Au to Posting -Error in  receipt pr ocessing") ,UNLOCKR Q
  6981   "RTN","RCD PEAP",279, 0)
  6982    ;
  6983   "RTN","RCD PEAP",280, 0)
  6984    ; update  344, .18 E RA REFEREN CE field
  6985   "RTN","RCD PEAP",281, 0)
  6986    D ERAREF( RCSCR,RCRC PTDA)
  6987   "RTN","RCD PEAP",282, 0)
  6988    ;
  6989   "RTN","RCD PEAP",283, 0)
  6990    ;Unlock d eposit tic ket and re ceipt
  6991   "RTN","RCD PEAP",284, 0)
  6992    D UNLOCKR
  6993   "RTN","RCD PEAP",285, 0)
  6994    ;
  6995   "RTN","RCD PEAP",286, 0)
  6996    ;Update t he audit l og
  6997   "RTN","RCD PEAP",287, 0)
  6998    D AUDITLO G(RCERA,2, "Auto Post ing: ERA p osted succ essfully")
  6999   "RTN","RCD PEAP",288, 0)
  7000    ;Update E RA receipt  and detai l post sta tus
  7001   "RTN","RCD PEAP",289, 0)
  7002    S DIE="^R CY(344.4," ,DR=".14// //1;.08/// /"_RCRCPTD A,DA=RCERA  D ^DIE
  7003   "RTN","RCD PEAP",290, 0)
  7004    ;Set ERA  auto-post  status to  'complete'  and updat e latest a uto-post d ate
  7005   "RTN","RCD PEAP",291, 0)
  7006    S DIE="^R CY(344.4," ,DR="4.01/ ///"_DT_"; 4.02////2" ,DA=RCERA  D ^DIE
  7007   "RTN","RCD PEAP",292, 0)
  7008    ;Update a uto-post d ate for ea ch claim l ine
  7009   "RTN","RCD PEAP",293, 0)
  7010    N RCLINE, RCSCSUB,RC SCD0
  7011   "RTN","RCD PEAP",294, 0)
  7012    S RCSCSUB =0
  7013   "RTN","RCD PEAP",295, 0)
  7014    F  S RCSC SUB=$O(^RC Y(344.49,R CERA,1,RCS CSUB)) Q:' RCSCSUB  D
  7015   "RTN","RCD PEAP",296, 0)
  7016    . S RCSCD 0=$G(^RCY( 344.49,RCE RA,1,RCSCS UB,0))
  7017   "RTN","RCD PEAP",297, 0)
  7018    . ;Ignore  if zero v alue (line  not on re ceipt) oth erwise get  original  ERA line s equence
  7019   "RTN","RCD PEAP",298, 0)
  7020    . Q:'+$P( RCSCD0,U,3 )  S RCLIN E=$P(RCSCD 0,U,9) Q:' RCLINE
  7021   "RTN","RCD PEAP",299, 0)
  7022    . ;Update  ERA line  with recei pt number  and auto-p ost date
  7023   "RTN","RCD PEAP",300, 0)
  7024    . N DA,DI E,DR S DA( 1)=RCERA,D A=RCLINE,D IE="^RCY(3 44.4,"_DA( 1)_",1,",D R=".25//// "_RCRCPTDA _";9////"_ DT D ^DIE
  7025   "RTN","RCD PEAP",301, 0)
  7026    Q
  7027   "RTN","RCD PEAP",302, 0)
  7028    ;
  7029   "RTN","RCD PEAP",303, 0)
  7030   POSTERA(RC ERA,RCLINE S) ; only  some of th e EEOB lin es passed  validation  on first  attempt (D AY 1) of a uto-post
  7031   "RTN","RCD PEAP",304, 0)
  7032    ; therefo re assign  the receip t number a nd 'partia l' post st atus to ER A summary
  7033   "RTN","RCD PEAP",305, 0)
  7034    ;
  7035   "RTN","RCD PEAP",306, 0)
  7036    ; RCERA =  ien of 34 4.4
  7037   "RTN","RCD PEAP",307, 0)
  7038    ; RCLINES  = array o f ERA line  reference s
  7039   "RTN","RCD PEAP",308, 0)
  7040    ;
  7041   "RTN","RCD PEAP",309, 0)
  7042    ; no line s passed v alidation;   at lease  1 EEOB li ne needs t o pass val idation be fore assig ning a rec eipt to th e ERA
  7043   "RTN","RCD PEAP",310, 0)
  7044    I RCLINES =0 S RCRCP TDA="" G P OSTERAQ
  7045   "RTN","RCD PEAP",311, 0)
  7046    ;ERA Rece ipt is cre ated from  scratchpad  entry - t ype 14 is  EDI Lockbo x payment
  7047   "RTN","RCD PEAP",312, 0)
  7048    S RCRCPTD A=$$BLDRCP T^RCDPEMA( RCERA) ; C reates bas ic receipt  for ERA o f payment  type EDI L OCKBOXA
  7049   "RTN","RCD PEAP",313, 0)
  7050    D RCPTDET ^RCDPEMA(R CSCR,RCRCP TDA,.RCLIN ES,.RCERR)  ; Adds de tail to a  receipt ba sed on fil e 344.49 a nd RCLINES  array
  7051   "RTN","RCD PEAP",314, 0)
  7052    ;
  7053   "RTN","RCD PEAP",315, 0)
  7054    ;Unable t o create r eceipt - c lear scrat chpad, res et AUTO-PO ST STATUS  = NULL
  7055   "RTN","RCD PEAP",316, 0)
  7056    I $O(RCER R("")) D C LEAR(RCSCR ),SETSTA(R CERA,"@"," Auto Posti ng: Remove d from Aut o Posting- Unable to  create rec eipt") Q
  7057   "RTN","RCD PEAP",317, 0)
  7058    ;
  7059   "RTN","RCD PEAP",318, 0)
  7060    ;Lock ERA  receipt a nd deposit  ticket
  7061   "RTN","RCD PEAP",319, 0)
  7062    I '$$LOCK REC^RCDPRP LU(RCRCPTD A) Q
  7063   "RTN","RCD PEAP",320, 0)
  7064    I '$$LOCK DEP^RCDPDP LU(RCDEPTD A) D UNLOC KR Q
  7065   "RTN","RCD PEAP",321, 0)
  7066    ;
  7067   "RTN","RCD PEAP",322, 0)
  7068    ;Process  Receipt to  FMS
  7069   "RTN","RCD PEAP",323, 0)
  7070    D PROCESS ^RCDPURE1( RCRCPTDA,2 )
  7071   "RTN","RCD PEAP",324, 0)
  7072    I $D(^TMP ("RCDPE-RE CEIPT-ERRO R",$J)) D  CLEAR(RCSC R),SETSTA( RCERA,"@", "Auto Post ing: Remov ed from Au to Posting -Error in  receipt pr ocessing") ,UNLOCKR Q
  7073   "RTN","RCD PEAP",325, 0)
  7074    ;
  7075   "RTN","RCD PEAP",326, 0)
  7076    ; update  344, .18 E RA REFEREN CE field
  7077   "RTN","RCD PEAP",327, 0)
  7078    D ERAREF( RCSCR,RCRC PTDA)
  7079   "RTN","RCD PEAP",328, 0)
  7080    ;
  7081   "RTN","RCD PEAP",329, 0)
  7082    ;Unlock d eposit tic ket and re ceipt
  7083   "RTN","RCD PEAP",330, 0)
  7084    D UNLOCKR
  7085   "RTN","RCD PEAP",331, 0)
  7086    ;Update E RA receipt  and detai l post sta tus
  7087   "RTN","RCD PEAP",332, 0)
  7088    S DIE="^R CY(344.4," ,DR=".14// //5;.08/// /"_RCRCPTD A,DA=RCERA  D ^DIE
  7089   "RTN","RCD PEAP",333, 0)
  7090   POSTERAQ ;
  7091   "RTN","RCD PEAP",334, 0)
  7092    D POSTLNS (RCERA,RCR CPTDA,.RCL INES)
  7093   "RTN","RCD PEAP",335, 0)
  7094    Q
  7095   "RTN","RCD PEAP",336, 0)
  7096    ;
  7097   "RTN","RCD PEAP",337, 0)
  7098   POSTLNS(RC ERA,RCRCPT DA,RCLINES ) ; this s ubroutine  should onl y be calle d when som e of the E EOB lines
  7099   "RTN","RCD PEAP",338, 0)
  7100    ;                                   passed  validatio n on FIRST  attempt ( DAY 1) of  auto-post
  7101   "RTN","RCD PEAP",339, 0)
  7102    ;
  7103   "RTN","RCD PEAP",340, 0)
  7104    ; RCERA =  ien of ER A entry in  344.4
  7105   "RTN","RCD PEAP",341, 0)
  7106    ; RCRCPTD A = ien of  receipt e ntry in 34 4 or undef ined if re ceipt not  created si nce none o f the line s passed v alidation
  7107   "RTN","RCD PEAP",342, 0)
  7108    ; RCLINES  = array o f ERA line  reference s
  7109   "RTN","RCD PEAP",343, 0)
  7110    ;
  7111   "RTN","RCD PEAP",344, 0)
  7112    ;Mark ERA  as proces sed to pre vent repro cessing in  EN2^RCDPE AP which r uns next
  7113   "RTN","RCD PEAP",345, 0)
  7114    S ^TMP("R CDPEAP",$J ,RCERA)=""
  7115   "RTN","RCD PEAP",346, 0)
  7116    S RCRCPTD A=$G(RCRCP TDA)
  7117   "RTN","RCD PEAP",347, 0)
  7118    ;Update i ndividual  claim line s on ERA
  7119   "RTN","RCD PEAP",348, 0)
  7120    N RCLIN,D A,DIE,DR,L NUM,RCI,RE JECT
  7121   "RTN","RCD PEAP",349, 0)
  7122    S RCLIN=0  F  S RCLI N=$O(RCLIN ES(RCLIN))  Q:'RCLIN   D
  7123   "RTN","RCD PEAP",350, 0)
  7124    . ; flag  the line i f it was r ejected du ring valid ation
  7125   "RTN","RCD PEAP",351, 0)
  7126    . S REJEC T=0 I '$P( RCLINES(RC LIN),U) S  REJECT=1
  7127   "RTN","RCD PEAP",352, 0)
  7128    . ;get al l ERA line  reference s (e.g. RC LINES(RCLI N) could h ave multip le line #  references )
  7129   "RTN","RCD PEAP",353, 0)
  7130    . ;Need t o parse ou t each lin e referenc e so that  the necess ary fields  can be up dated for  the specif ic line
  7131   "RTN","RCD PEAP",354, 0)
  7132    . F RCI=1 :1 S LNUM= $P(RCLIN," ,",RCI) Q: LNUM=""  D
  7133   "RTN","RCD PEAP",355, 0)
  7134    . . S DA( 1)=RCERA,D A=LNUM,DIE ="^RCY(344 .4,"_DA(1) _",1,"
  7135   "RTN","RCD PEAP",356, 0)
  7136    . . ;If n ot posted  then the A UTO-POST R EJECTION R EASON (344 .41,5) nee ds to be u pdated ;ot herwise up date line  with recei pt number  and auto-p ost date
  7137   "RTN","RCD PEAP",357, 0)
  7138    . . I REJ ECT S DR=" 5////"_$P( RCLINES(RC LIN),U,3)
  7139   "RTN","RCD PEAP",358, 0)
  7140    . . E  S  DR=".25/// /"_RCRCPTD A_";9////" _DT
  7141   "RTN","RCD PEAP",359, 0)
  7142    . . D ^DI E
  7143   "RTN","RCD PEAP",360, 0)
  7144    ;Update t he Audit L og
  7145   "RTN","RCD PEAP",361, 0)
  7146    D AUDITLO G(RCERA,1, "Auto Post ing: Some  of the ERA  lines wen t to APAR" )
  7147   "RTN","RCD PEAP",362, 0)
  7148    ;Set ERA  AUTO-POST  STATUS = P ARTIAL and  update au to-post da te
  7149   "RTN","RCD PEAP",363, 0)
  7150    S DIE="^R CY(344.4," ,DR="4.01/ ///"_DT_"; 4.02////1" ,DA=RCERA  D ^DIE
  7151   "RTN","RCD PEAP",364, 0)
  7152    Q
  7153   "RTN","RCD PEAP",365, 0)
  7154    ;
  7155   "RTN","RCD PEAP",366, 0)
  7156   SCRPAD(RCE RA) ;Build  Scratchpa d entry in  #344.49 f or the ERA
  7157   "RTN","RCD PEAP",367, 0)
  7158    ;
  7159   "RTN","RCD PEAP",368, 0)
  7160    ; Input -  RCERA - I EN for #34 4.4
  7161   "RTN","RCD PEAP",369, 0)
  7162    ;
  7163   "RTN","RCD PEAP",370, 0)
  7164    ; Output  - RCSCR =  Scratchpad  IEN (Succ ess) or 0  (Fail)
  7165   "RTN","RCD PEAP",371, 0)
  7166    ;
  7167   "RTN","RCD PEAP",372, 0)
  7168    N RC0,RC5 ,RCSCR,RCD AT,X
  7169   "RTN","RCD PEAP",373, 0)
  7170    S RC0=$G( ^RCY(344.4 ,RCERA,0)) ,RC5=$G(^R CY(344.4,R CERA,5))
  7171   "RTN","RCD PEAP",374, 0)
  7172    ;Ignore i s this ERA  already h as a recei pt
  7173   "RTN","RCD PEAP",375, 0)
  7174    I +$P(RC0 ,U,8) Q 0
  7175   "RTN","RCD PEAP",376, 0)
  7176    ;Ignore i f this is  zero ERA
  7177   "RTN","RCD PEAP",377, 0)
  7178    I +$P(RC0 ,U,5)=0 Q  0
  7179   "RTN","RCD PEAP",378, 0)
  7180    ;Ignore i f this is  not a vali d auto-pos t ERA type  
  7181   "RTN","RCD PEAP",379, 0)
  7182    I "^ACH^C HK^"'[(U_$ P(RC0,U,15 )_U) Q 0 ;  added CHK  - PRCA*4. 5*321
  7183   "RTN","RCD PEAP",380, 0)
  7184    ; Scratch pad alread y exists
  7185   "RTN","RCD PEAP",381, 0)
  7186    S RCSCR=+ $O(^RCY(34 4.49,"B",R CERA,0)) I  RCSCR G S CRPADX
  7187   "RTN","RCD PEAP",382, 0)
  7188    ;Create n ew Scratch pad
  7189   "RTN","RCD PEAP",383, 0)
  7190    S RCSCR=+ $$ADDREC^R CDPEWL(RCE RA,.RCDAT)  I 'RCSCR  Q 0
  7191   "RTN","RCD PEAP",384, 0)
  7192    ;Add all  the ERA li nes to the  Scratchpa d entry
  7193   "RTN","RCD PEAP",385, 0)
  7194    D ADDLINE S^RCDPEWLA (RCSCR)
  7195   "RTN","RCD PEAP",386, 0)
  7196   SCRPADX ;R eturn Scra tchpad IEN
  7197   "RTN","RCD PEAP",387, 0)
  7198    Q RCSCR
  7199   "RTN","RCD PEAP",388, 0)
  7200    ;
  7201   "RTN","RCD PEAP",389, 0)
  7202   SETSTA(DA, STATUS,RCR EASON) ;Se t ERA auto -post stat us
  7203   "RTN","RCD PEAP",390, 0)
  7204    ; Log sta tus change
  7205   "RTN","RCD PEAP",391, 0)
  7206    I '$G(DA)  Q
  7207   "RTN","RCD PEAP",392, 0)
  7208    I $G(STAT US)="" Q
  7209   "RTN","RCD PEAP",393, 0)
  7210    ;
  7211   "RTN","RCD PEAP",394, 0)
  7212    D AUDITLO G(DA,STATU S,$G(RCREA SON))
  7213   "RTN","RCD PEAP",395, 0)
  7214    ; Update  status
  7215   "RTN","RCD PEAP",396, 0)
  7216    N DIE,DR
  7217   "RTN","RCD PEAP",397, 0)
  7218    S DIE="^R CY(344.4," ,DR="4.02/ ///"_STATU S D ^DIE
  7219   "RTN","RCD PEAP",398, 0)
  7220    Q
  7221   "RTN","RCD PEAP",399, 0)
  7222    ;
  7223   "RTN","RCD PEAP",400, 0)
  7224    ;
  7225   "RTN","RCD PEAP",401, 0)
  7226   UNLOCKR ;U nlock ERA  receipt an d deposit  ticket
  7227   "RTN","RCD PEAP",402, 0)
  7228    L -^RCY(3 44,RCRCPTD A)
  7229   "RTN","RCD PEAP",403, 0)
  7230    L -^RCY(3 44.1,RCDEP TDA)
  7231   "RTN","RCD PEAP",404, 0)
  7232    Q
  7233   "RTN","RCD PEAP",405, 0)
  7234    ;
  7235   "RTN","RCD PEAP",406, 0)
  7236   UNLOCKE ;U nlock ERA
  7237   "RTN","RCD PEAP",407, 0)
  7238    L -^RCY(3 44.4,RCERA )
  7239   "RTN","RCD PEAP",408, 0)
  7240    Q
  7241   "RTN","RCD PEAP",409, 0)
  7242    ;
  7243   "RTN","RCD PEAP",410, 0)
  7244   VALID(RCSC R,SCRLINE, RCARRAY) ; Validates  Scratchpad  line - Us ed by APAR /Mark for  Auto-post
  7245   "RTN","RCD PEAP",411, 0)
  7246    ;Input
  7247   "RTN","RCD PEAP",412, 0)
  7248    ;  RCSCR    - #344.4 /#344.49 f ile IEN
  7249   "RTN","RCD PEAP",413, 0)
  7250    ;  SCRLIN E - Subscr ipt of fir st scratch pad entry  for the ER A line
  7251   "RTN","RCD PEAP",414, 0)
  7252    ;  RCARRA Y - Passed  reference  to result  array
  7253   "RTN","RCD PEAP",415, 0)
  7254    ;Output
  7255   "RTN","RCD PEAP",416, 0)
  7256    ;  OK       - Boolea n 1 or 0
  7257   "RTN","RCD PEAP",417, 0)
  7258    ;  RCARRA Y - Array  of claim(s ) which fa il validat ion
  7259   "RTN","RCD PEAP",418, 0)
  7260    ;
  7261   "RTN","RCD PEAP",419, 0)
  7262    ;             e.g  l ine number  2
  7263   "RTN","RCD PEAP",420, 0)
  7264    ;                  R CARRAY(2.0 01)="K8000 01^NOT AN  ACTIVE CLA IM"
  7265   "RTN","RCD PEAP",421, 0)
  7266    ;
  7267   "RTN","RCD PEAP",422, 0)
  7268    ;             e.g. s plit line  number 2
  7269   "RTN","RCD PEAP",423, 0)
  7270    ;                  R CARRAY(2.0 01)="K8000 02^CLAIM R EFERRED TO  GENERAL C OUNCIL"
  7271   "RTN","RCD PEAP",424, 0)
  7272    ;                  R CARRAY(2.0 06)="K8000 03^PAYMENT  EXCEEDS C LAIM BALAN CE"
  7273   "RTN","RCD PEAP",425, 0)
  7274    ;
  7275   "RTN","RCD PEAP",426, 0)
  7276    N CLAIM,D ONE,SEQ,SE Q1,SUB,STA TUS,WLINE
  7277   "RTN","RCD PEAP",427, 0)
  7278    K RCARRAY ,CLARRAY
  7279   "RTN","RCD PEAP",428, 0)
  7280    S SUB=SCR LINE,SEQ=$ P($G(^RCY( 344.49,RCS CR,1,SUB,0 )),U),DONE =0
  7281   "RTN","RCD PEAP",429, 0)
  7282    F  S SUB= $O(^RCY(34 4.49,RCSCR ,1,SUB)) Q :SUB=""  D   Q:DONE
  7283   "RTN","RCD PEAP",430, 0)
  7284    . ;Get sc ratchpad N .001 line  and data
  7285   "RTN","RCD PEAP",431, 0)
  7286    . S WLINE =$G(^RCY(3 44.49,RCSC R,1,SUB,0) ),SEQ1=$P( WLINE,".")  I SEQ1'=S EQ S DONE= 1 Q
  7287   "RTN","RCD PEAP",432, 0)
  7288    . ;Get cl aim number  from N.00 N line - i gnore susp ense lines
  7289   "RTN","RCD PEAP",433, 0)
  7290    . S CLAIM =$P(WLINE, U,7) I 'CL AIM Q
  7291   "RTN","RCD PEAP",434, 0)
  7292    . ;Claim  must be OP EN or ACTI VE
  7293   "RTN","RCD PEAP",435, 0)
  7294    . S STATU S=$P($G(^P RCA(430,CL AIM,0)),"^ ",8) I STA TUS'=42,ST ATUS'=16 S  RCARRAY(S EQ1)=$P(WL INE,U,2)_" ^NOT AN AC TIVE CLAIM " Q
  7295   "RTN","RCD PEAP",436, 0)
  7296    . ;Check  that payme nt does no t exceed b alance and  no pendin g payments  (at the t ime of aut o posting)
  7297   "RTN","RCD PEAP",437, 0)
  7298    . S CLARR AY(CLAIM)= +$G(CLARRA Y(CLAIM))+ $P(WLINE,U ,3) I '$$C HECKPAY(.C LARRAY,CLA IM) S RCAR RAY(SEQ1)= $P(WLINE,U ,2)_"^PAYM ENT EXCEED S CLAIM BA LANCE" Q
  7299   "RTN","RCD PEAP",438, 0)
  7300    . ;Check  if referre d to gener al council
  7301   "RTN","RCD PEAP",439, 0)
  7302    . I $P($G (^PRCA(430 ,CLAIM,6)) ,U,4)]"" S  RCARRAY(S EQ1)=$P(WL INE,U,2)_" ^CLAIM REF ERRED TO G ENERAL COU NCIL" Q
  7303   "RTN","RCD PEAP",440, 0)
  7304    . ;Check  that payme nt is not  negative
  7305   "RTN","RCD PEAP",441, 0)
  7306    . I $P(WL INE,U,6)<0  S RCARRAY (SEQ1)=$P( WLINE,U,2) _"^PAYMENT  AMOUNT IS  NEGATIVE"  Q
  7307   "RTN","RCD PEAP",442, 0)
  7308    ;Returns  1 if line  is OK
  7309   "RTN","RCD PEAP",443, 0)
  7310    Q $S($O(R CARRAY("") )]"":0,1:1 )
  7311   "RTN","RCD PEAP1")
  7312   0^49^B1056 84443
  7313   "RTN","RCD PEAP1",1,0 )
  7314   RCDPEAP1 ; ALB/KML -  AUTO POST  MATCHING E FT ERA PAI R - CONT.  ;Jun 06, 2 014@19:11: 19
  7315   "RTN","RCD PEAP1",2,0 )
  7316    ;;4.5;Acc ounts Rece ivable;**2 98,304,318 ,321**;Mar  20, 1995; Build 46
  7317   "RTN","RCD PEAP1",3,0 )
  7318    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  7319   "RTN","RCD PEAP1",4,0 )
  7320    ;Read ^IB M(361.1) v ia Private  IA 4051
  7321   "RTN","RCD PEAP1",5,0 )
  7322    ;
  7323   "RTN","RCD PEAP1",6,0 )
  7324    ;-------- ---------- ---------- ---
  7325   "RTN","RCD PEAP1",7,0 )
  7326    ;RCDPEM0  and RCDPEA P SUBROUTI NES
  7327   "RTN","RCD PEAP1",8,0 )
  7328    ;-------- ---------- ---------- ---
  7329   "RTN","RCD PEAP1",9,0 )
  7330   AUTOCHK(RC ERA) ;Veri fy if ERA  can be aut o-posted -  PRE-CHECK  USED IN R CDPEM0
  7331   "RTN","RCD PEAP1",10, 0)
  7332    ; Many ch ecks done  by this ar e also don e AUTOCHK2  below so  if these a re changed , may also  need to b e changed
  7333   "RTN","RCD PEAP1",11, 0)
  7334    N NOTOK,R CDSUB,RCD0 ,RCSCR
  7335   "RTN","RCD PEAP1",12, 0)
  7336    K ^TMP($J ,"RCDPEWLA ")
  7337   "RTN","RCD PEAP1",13, 0)
  7338    ;Check fo r exceptio ns
  7339   "RTN","RCD PEAP1",14, 0)
  7340    S RCDSUB= 0,NOTOK=0
  7341   "RTN","RCD PEAP1",15, 0)
  7342    F  S RCDS UB=$O(^RCY (344.4,RCE RA,1,RCDSU B)) Q:'RCD SUB  D  Q: NOTOK
  7343   "RTN","RCD PEAP1",16, 0)
  7344    . ;Except ion exists  if INVALI D BILL NUM BER field  is populat ed in #344 .41
  7345   "RTN","RCD PEAP1",17, 0)
  7346    . S RCD0= $G(^RCY(34 4.4,RCERA, 1,RCDSUB,0 )) S:($P(R CD0,U,5)]" ") NOTOK=1
  7347   "RTN","RCD PEAP1",18, 0)
  7348    ;Cannot a uto-post i f exceptio ns exist
  7349   "RTN","RCD PEAP1",19, 0)
  7350    Q:NOTOK 0
  7351   "RTN","RCD PEAP1",20, 0)
  7352    ; Ignore  ERA if ERA  level Adj ustments e xist
  7353   "RTN","RCD PEAP1",21, 0)
  7354    I $O(^RCY (344.4,RCE RA,2,0)) Q  0
  7355   "RTN","RCD PEAP1",22, 0)
  7356    ; Ignore  non-ACH ty pe ERA to  prevent CH K type ERA  from auto matically  auto-posti ng in nigh tly job -  PRCA*4.5*3 21
  7357   "RTN","RCD PEAP1",23, 0)
  7358    I $$GET1^ DIQ(344.4, RCERA_",", .15)'="ACH " Q 0
  7359   "RTN","RCD PEAP1",24, 0)
  7360    ;Create s cratchpad
  7361   "RTN","RCD PEAP1",25, 0)
  7362    S RCSCR=$ $SCRPAD^RC DPEAP(RCER A) Q:'RCSC R 0
  7363   "RTN","RCD PEAP1",26, 0)
  7364    ;Ignore E RA if clai m level ad justments  without pa yment exis t
  7365   "RTN","RCD PEAP1",27, 0)
  7366    ;This wil l only get  set if th e scratchp ad is crea ted, not i f it alrea dy exists.   Looking  at the cod e, it
  7367   "RTN","RCD PEAP1",28, 0)
  7368    ;will mai nly set if  there are  ERA level  adjustmen ts and may  get set f or unbalan ced pairs,  which is  found
  7369   "RTN","RCD PEAP1",29, 0)
  7370    ;by the Z EROBAL fun ction.  So , I think  this does  not have a  real purp ose but wa s not 100%  sure.
  7371   "RTN","RCD PEAP1",30, 0)
  7372    I $D(^TMP ($J,"RCDPE WLA","ERA  LEVEL ADJU STMENT EXI STS")) D C LEAR^RCDPE AP(RCSCR)  Q 0
  7373   "RTN","RCD PEAP1",31, 0)
  7374    ; ERA nee ds to drop  to standa rd worklis t if adjus tment betw een matchi ng 
  7375   "RTN","RCD PEAP1",32, 0)
  7376    ;positive /negative  does not c reate a ze ro balance
  7377   "RTN","RCD PEAP1",33, 0)
  7378    I '$$ZERO BAL(RCSCR)  D CLEAR^R CDPEAP(RCS CR) Q 0
  7379   "RTN","RCD PEAP1",34, 0)
  7380    ;Clear sc ratchpad
  7381   "RTN","RCD PEAP1",35, 0)
  7382    D CLEAR^R CDPEAP(RCS CR)
  7383   "RTN","RCD PEAP1",36, 0)
  7384    ;This is  valid auto -post - re turn to MA TCH^RCPDEM 0
  7385   "RTN","RCD PEAP1",37, 0)
  7386    Q 1
  7387   "RTN","RCD PEAP1",38, 0)
  7388    ;
  7389   "RTN","RCD PEAP1",39, 0)
  7390   AUTOCHK2(R CERA,RCTYP ) ; RCTYP  added PRCA *4.5*321
  7391   "RTN","RCD PEAP1",40, 0)
  7392    ;Check if  this entr y is an au to-post ca ndidate
  7393   "RTN","RCD PEAP1",41, 0)
  7394    ;This has  the same/ similar ch ecks as MA TCH^RCDPEM 0 and AUTO CHK above.   If those  procedure s are
  7395   "RTN","RCD PEAP1",42, 0)
  7396    ;  change d, this ma y need to  updated as  well.
  7397   "RTN","RCD PEAP1",43, 0)
  7398    ;
  7399   "RTN","RCD PEAP1",44, 0)
  7400    ;Input
  7401   "RTN","RCD PEAP1",45, 0)
  7402    ;  RCERA:  IEN from  Electronic  Remittanc e Advice f ile (#344. 4)
  7403   "RTN","RCD PEAP1",46, 0)
  7404    ;  RCTYP:  Call type  0 = Workl ist/Mark f or autopos t  1 = Man ual match  ; PRCA*4.5 *321
  7405   "RTN","RCD PEAP1",47, 0)
  7406    ;Output
  7407   "RTN","RCD PEAP1",48, 0)
  7408    ;  1: Aut o-Post can didate
  7409   "RTN","RCD PEAP1",49, 0)
  7410    ;  0^Reas on: Not a  auto-post  candidate  and reason
  7411   "RTN","RCD PEAP1",50, 0)
  7412    ;
  7413   "RTN","RCD PEAP1",51, 0)
  7414    ; Validat e Paramete r
  7415   "RTN","RCD PEAP1",52, 0)
  7416    I '$G(RCE RA) Q "0^I nvalid Par ameter"
  7417   "RTN","RCD PEAP1",53, 0)
  7418    I $G(RCTY P)="" Q "0 ^Invalid P arameter"  ; PRCA*4.5 *321
  7419   "RTN","RCD PEAP1",54, 0)
  7420    I (RCTYP> 1)!(RCTYP< 0) Q "0^In valid Para meter" ; P RCA*4.5*32 1
  7421   "RTN","RCD PEAP1",55, 0)
  7422    ;
  7423   "RTN","RCD PEAP1",56, 0)
  7424    N STATUS, RC0,RCERAT YP,RCXCLDE ,RCDSUB,NO TOK,RCCREA TE,RCSCR
  7425   "RTN","RCD PEAP1",57, 0)
  7426    K ^TMP($J ,"RCDPEWLA ")
  7427   "RTN","RCD PEAP1",58, 0)
  7428    ;
  7429   "RTN","RCD PEAP1",59, 0)
  7430    ; Check i f record e xists
  7431   "RTN","RCD PEAP1",60, 0)
  7432    I '$D(^RC Y(344.4,RC ERA,0)) Q  "0^Invalid  ERA recor d"
  7433   "RTN","RCD PEAP1",61, 0)
  7434    ;
  7435   "RTN","RCD PEAP1",62, 0)
  7436    ; Check c urrent sta tus
  7437   "RTN","RCD PEAP1",63, 0)
  7438    S STATUS= $$GET1^DIQ (344.4,RCE RA_",",4.0 2,"I")
  7439   "RTN","RCD PEAP1",64, 0)
  7440    I STATUS= 0 Q "0^Alr eady marke d for Auto -Posting"
  7441   "RTN","RCD PEAP1",65, 0)
  7442    I STATUS= 1 Q "0^Alr eady parti ally Auto- Posted"
  7443   "RTN","RCD PEAP1",66, 0)
  7444    I STATUS= 2 Q "0^Alr eady compl etely Auto -Posted"
  7445   "RTN","RCD PEAP1",67, 0)
  7446    ;
  7447   "RTN","RCD PEAP1",68, 0)
  7448    ; Check f or matchin g
  7449   "RTN","RCD PEAP1",69, 0)
  7450    I '$$GET1 ^DIQ(344.4 ,RCERA_"," ,.09,"I")  Q "0^ERA n ot matched "
  7451   "RTN","RCD PEAP1",70, 0)
  7452    ;
  7453   "RTN","RCD PEAP1",71, 0)
  7454    ; Check f or zero va lue ERA
  7455   "RTN","RCD PEAP1",72, 0)
  7456    S RC0=$G( ^RCY(344.4 ,RCERA,0))
  7457   "RTN","RCD PEAP1",73, 0)
  7458    I +$P(RC0 ,U,5)=0 Q  "0^Zero va lue ERA"
  7459   "RTN","RCD PEAP1",74, 0)
  7460    ;
  7461   "RTN","RCD PEAP1",75, 0)
  7462    ; Determi ne if ERA  should be  excluded u sing the s ite parame ters
  7463   "RTN","RCD PEAP1",76, 0)
  7464    S RCERATY P=$$PHARM( RCERA)
  7465   "RTN","RCD PEAP1",77, 0)
  7466    ;
  7467   "RTN","RCD PEAP1",78, 0)
  7468    ; Check i f medical  claim and  auto-posti ng is turn ed off
  7469   "RTN","RCD PEAP1",79, 0)
  7470    I 'RCERAT YP,'$P($G( ^RCY(344.6 1,1,0)),U, 2) Q "0^Me dical auto -posting o ff"
  7471   "RTN","RCD PEAP1",80, 0)
  7472    ;
  7473   "RTN","RCD PEAP1",81, 0)
  7474    ; Check i f pharmacy  claim and  auto-post ing is tur ned off
  7475   "RTN","RCD PEAP1",82, 0)
  7476    I RCERATY P,'$P($G(^ RCY(344.61 ,1,1)),U,1 ) Q "0^Pha rmacy auto -posting o ff"
  7477   "RTN","RCD PEAP1",83, 0)
  7478    ;
  7479   "RTN","RCD PEAP1",84, 0)
  7480    ; Check i f ERA paye r is exclu ded from a utopost
  7481   "RTN","RCD PEAP1",85, 0)
  7482    S RCXCLDE =0
  7483   "RTN","RCD PEAP1",86, 0)
  7484    S:'RCERAT YP RCXCLDE =$$EXCLUDE (RCERA)
  7485   "RTN","RCD PEAP1",87, 0)
  7486    S:RCERATY P RCXCLDE= $$EXCLDRX( RCERA)
  7487   "RTN","RCD PEAP1",88, 0)
  7488    I RCXCLDE  Q "0^"_$S (RCERATYP: "Pharmacy" ,1:"Medica l")_" paye r excluded "
  7489   "RTN","RCD PEAP1",89, 0)
  7490    ;
  7491   "RTN","RCD PEAP1",90, 0)
  7492    ; Check f or invalid  bill numb er excepti on
  7493   "RTN","RCD PEAP1",91, 0)
  7494    S RCDSUB= 0,NOTOK=0
  7495   "RTN","RCD PEAP1",92, 0)
  7496    F  S RCDS UB=$O(^RCY (344.4,RCE RA,1,RCDSU B)) Q:'RCD SUB  D  Q: NOTOK
  7497   "RTN","RCD PEAP1",93, 0)
  7498    . S RCD0= $G(^RCY(34 4.4,RCERA, 1,RCDSUB,0 ))
  7499   "RTN","RCD PEAP1",94, 0)
  7500    . I $P(RC D0,U,5)]""  S NOTOK=1
  7501   "RTN","RCD PEAP1",95, 0)
  7502    I NOTOK Q  "0^Invali d Bill Num ber Except ion(s)"
  7503   "RTN","RCD PEAP1",96, 0)
  7504    ;
  7505   "RTN","RCD PEAP1",97, 0)
  7506    ; Check f or ERA lev el Adjustm ents
  7507   "RTN","RCD PEAP1",98, 0)
  7508    I $O(^RCY (344.4,RCE RA,2,0)) Q  "0^ERA le vel Adjust ment(s)"
  7509   "RTN","RCD PEAP1",99, 0)
  7510    ;
  7511   "RTN","RCD PEAP1",100 ,0)
  7512    ; Check i f receipt  already cr eated
  7513   "RTN","RCD PEAP1",101 ,0)
  7514    I +$P(RC0 ,U,8) Q "0 ^ERA has a  receipt"
  7515   "RTN","RCD PEAP1",102 ,0)
  7516    ;
  7517   "RTN","RCD PEAP1",103 ,0)
  7518    ; Check p ayment typ e of ERA -  CHK type  is allowed  for a man ual match
  7519   "RTN","RCD PEAP1",104 ,0)
  7520    I "^ACH^C HK^"'[(U_$ P(RC0,U,15 )_U) Q "0^ Payment Ty pe is not  ACH or CHK " ; PRCA*4 .5*321
  7521   "RTN","RCD PEAP1",105 ,0)
  7522    ;
  7523   "RTN","RCD PEAP1",106 ,0)
  7524    ; CHK typ e ERA must  be matche d to an EF T to be el igible for  mark for  autopost
  7525   "RTN","RCD PEAP1",107 ,0)
  7526    I $P(RC0, U,15)="CHK ",'$O(^RCY (344.31,"A ERA",RCERA ,"")) Q "0 ^ERA is no t matched  to an EFT"  ; PRCA*4. 5*321
  7527   "RTN","RCD PEAP1",108 ,0)
  7528    ;
  7529   "RTN","RCD PEAP1",109 ,0)
  7530    ; Create  scratchpad  if needed
  7531   "RTN","RCD PEAP1",110 ,0)
  7532    S RCCREAT E=0
  7533   "RTN","RCD PEAP1",111 ,0)
  7534    S RCSCR=+ $O(^RCY(34 4.49,"B",R CERA,0))
  7535   "RTN","RCD PEAP1",112 ,0)
  7536    I 'RCSCR  S RCSCR=$$ SCRPAD^RCD PEAP(RCERA ) S RCCREA TE=1
  7537   "RTN","RCD PEAP1",113 ,0)
  7538    I 'RCSCR  Q "0^Unabl e to creat e scratchp ad"
  7539   "RTN","RCD PEAP1",114 ,0)
  7540    ;
  7541   "RTN","RCD PEAP1",115 ,0)
  7542    ; Check i f claim le vel adjust ments with out paymen t exist
  7543   "RTN","RCD PEAP1",116 ,0)
  7544    ; Note th at PRCA*29 8 sets thi s temp glo bal only i f the scra tchpad is  created by  the call  above ($$S CRPAD^RCDP EAP). If t he
  7545   "RTN","RCD PEAP1",117 ,0)
  7546    ;   scrat chpad alre ady exists , the TMP  global wil l never ge t set.   L ooking at  the code,  it will ma inly set i f there
  7547   "RTN","RCD PEAP1",118 ,0)
  7548    ;   are E RA level a djustments  and may g et set for  unbalance d pairs, w hich is fo und by the  ZEROBAL f unction.   So, I thin k
  7549   "RTN","RCD PEAP1",119 ,0)
  7550    ;   this  does not h ave a real  purpose b ut was not  100% sure  and wante d to mimic  what AUTO CHK does.
  7551   "RTN","RCD PEAP1",120 ,0)
  7552    I $D(^TMP ($J,"RCDPE WLA","ERA  LEVEL ADJU STMENT EXI STS")) D:R CCREATE CL EAR^RCDPEA P(RCSCR) Q  "0^Claim  Level Adju stments w/ o payment"
  7553   "RTN","RCD PEAP1",121 ,0)
  7554    ;
  7555   "RTN","RCD PEAP1",122 ,0)
  7556    ; Check i f adjustme nt between  matching  positive/n egative do es not cre ate a zero  balance
  7557   "RTN","RCD PEAP1",123 ,0)
  7558    I '$$ZERO BAL(RCSCR)  D:RCCREAT E CLEAR^RC DPEAP(RCSC R) Q "0^+/ - pairs do  not balan ce"
  7559   "RTN","RCD PEAP1",124 ,0)
  7560    ;
  7561   "RTN","RCD PEAP1",125 ,0)
  7562    ; Clear s cratchpad  if it was  created by  this func tion
  7563   "RTN","RCD PEAP1",126 ,0)
  7564    D:RCCREAT E CLEAR^RC DPEAP(RCSC R)
  7565   "RTN","RCD PEAP1",127 ,0)
  7566    ;
  7567   "RTN","RCD PEAP1",128 ,0)
  7568    ;If we go t this far , this is  an autopos t candidat e so quit  with 1
  7569   "RTN","RCD PEAP1",129 ,0)
  7570    Q 1
  7571   "RTN","RCD PEAP1",130 ,0)
  7572    ;
  7573   "RTN","RCD PEAP1",131 ,0)
  7574   EXCLUDE(RC ERA) ;Veri fy if auto -posting i s allowed  for this P ayer - PRE CHECK USED  IN RCDPEM 0
  7575   "RTN","RCD PEAP1",132 ,0)
  7576    ;Not allo wed if med ical auto- posting is  switched  off
  7577   "RTN","RCD PEAP1",133 ,0)
  7578    Q:'$P($G( ^RCY(344.6 1,1,0)),U, 2) 1
  7579   "RTN","RCD PEAP1",134 ,0)
  7580    ;Check if  Payer Nam e and Paye r ID from  ERA are in  auto-post ing payer  table
  7581   "RTN","RCD PEAP1",135 ,0)
  7582    N RCPNM,R CPID,RCPXD A
  7583   "RTN","RCD PEAP1",136 ,0)
  7584    S RCPNM=$ P($G(^RCY( 344.4,RCER A,0)),U,6)  Q:RCPNM=" " 1
  7585   "RTN","RCD PEAP1",137 ,0)
  7586    S RCPID=$ P($G(^RCY( 344.4,RCER A,0)),U,3)  Q:RCPID=" " 1
  7587   "RTN","RCD PEAP1",138 ,0)
  7588    ;Auto-pos t is allow ed if this  is a new  payer (not  in table)
  7589   "RTN","RCD PEAP1",139 ,0)
  7590    S RCPXDA= $O(^RCY(34 4.6,"CPID" ,RCPNM,RCP ID,"")) Q: RCPXDA=""  0
  7591   "RTN","RCD PEAP1",140 ,0)
  7592    ;If payer  table ent ry found c heck if pa yer is exc luded from  medical a uto-post
  7593   "RTN","RCD PEAP1",141 ,0)
  7594    Q:$P($G(^ RCY(344.6, RCPXDA,0)) ,U,6)=1 1
  7595   "RTN","RCD PEAP1",142 ,0)
  7596    ;Otherwis e it is OK  to auto-p ost
  7597   "RTN","RCD PEAP1",143 ,0)
  7598    Q 0
  7599   "RTN","RCD PEAP1",144 ,0)
  7600    ;
  7601   "RTN","RCD PEAP1",145 ,0)
  7602   PHARM(RCER A) ;Check  if ERA is  for Pharma cy only (E CME number  on first  line) - CA LLED FROM  RCDPEM0
  7603   "RTN","RCD PEAP1",146 ,0)
  7604    N SUB S S UB=$O(^RCY (344.4,RCE RA,1,0)) Q :'SUB 0
  7605   "RTN","RCD PEAP1",147 ,0)
  7606    Q:$P($G(^ RCY(344.4, RCERA,1,SU B,4)),U,2) ]"" 1
  7607   "RTN","RCD PEAP1",148 ,0)
  7608    Q 0
  7609   "RTN","RCD PEAP1",149 ,0)
  7610    ;
  7611   "RTN","RCD PEAP1",150 ,0)
  7612   ERADET(RCE RA,RCRCPTD A,RCLINES)  ; called  on subsequ ent attemp ts of auto -post for  a given ER A (DAY 2,  DAY 3, ex. )
  7613   "RTN","RCD PEAP1",151 ,0)
  7614    ;  update  ERA with  receipt or  if not po sted then  update the  AUTO-POST  REJECTION  REASON (# 5)
  7615   "RTN","RCD PEAP1",152 ,0)
  7616    ;
  7617   "RTN","RCD PEAP1",153 ,0)
  7618    ; RCERA =  ien of en try in fil e 344.4
  7619   "RTN","RCD PEAP1",154 ,0)
  7620    ; RCRCPTD A = ien of  receipt n umber (344 , .01) - o ptional
  7621   "RTN","RCD PEAP1",155 ,0)
  7622    ; RCLINES  = array o f ERA line  reference s
  7623   "RTN","RCD PEAP1",156 ,0)
  7624    ;
  7625   "RTN","RCD PEAP1",157 ,0)
  7626    I '$G(RCE RA) Q
  7627   "RTN","RCD PEAP1",158 ,0)
  7628    S RCRCPTD A=$G(RCRCP TDA)
  7629   "RTN","RCD PEAP1",159 ,0)
  7630    ;
  7631   "RTN","RCD PEAP1",160 ,0)
  7632    N DA,DIC, DIE,DLAYGO ,DO,DR,X
  7633   "RTN","RCD PEAP1",161 ,0)
  7634    ; Update  receipt.   If this is  the first  receipt,  put it in  the RECEIP T (#08) fi eld.  If n ot, put in  OTHER REC EIPTS mult iple (#344 .48)
  7635   "RTN","RCD PEAP1",162 ,0)
  7636    I RCRCPTD A D
  7637   "RTN","RCD PEAP1",163 ,0)
  7638    . I $P($G (^RCY(344. 4,RCERA,0) ),U,8)]""  S DA(1)=RC ERA,DIC="^ RCY(344.4, "_DA(1)_", 8,",DIC(0) ="L",X=RCR CPTDA D FI LE^DICN I  1
  7639   "RTN","RCD PEAP1",164 ,0)
  7640    . E  S DI E="^RCY(34 4.4,",DR=" .14////1;. 08////"_RC RCPTDA,DA= RCERA D ^D IE
  7641   "RTN","RCD PEAP1",165 ,0)
  7642    ;
  7643   "RTN","RCD PEAP1",166 ,0)
  7644    ; Update  ERA detail  line with  Receipt o r reject r eason as a ppropriate
  7645   "RTN","RCD PEAP1",167 ,0)
  7646    ; PRCA*4. 5*318 begi ns
  7647   "RTN","RCD PEAP1",168 ,0)
  7648    N RCLIN,R EJECT
  7649   "RTN","RCD PEAP1",169 ,0)
  7650    S RCLIN=0
  7651   "RTN","RCD PEAP1",170 ,0)
  7652    F  S RCLI N=$O(RCLIN ES(RCLIN))  Q:'RCLIN   D
  7653   "RTN","RCD PEAP1",171 ,0)
  7654    . ; Set R EJECT to t rue if the  line was  rejected d uring vali dation
  7655   "RTN","RCD PEAP1",172 ,0)
  7656    . S REJEC T=0 I '$P( RCLINES(RC LIN),U) S  REJECT=1
  7657   "RTN","RCD PEAP1",173 ,0)
  7658    . ;If not  posted th en update  the AUTO-P OST REJECT ION REASON  (#5)
  7659   "RTN","RCD PEAP1",174 ,0)
  7660    . ;Otherw ise update  line with  receipt n umber and  autopost d ate
  7661   "RTN","RCD PEAP1",175 ,0)
  7662    . S DA(1) =RCERA,DA= RCLIN,DIE= "^RCY(344. 4,"_DA(1)_ ",1,"
  7663   "RTN","RCD PEAP1",176 ,0)
  7664    . I 'REJE CT,'RCRCPT DA Q
  7665   "RTN","RCD PEAP1",177 ,0)
  7666    . I REJEC T S DR="5/ //"_$P(RCL INES(RCLIN ),U,3)
  7667   "RTN","RCD PEAP1",178 ,0)
  7668    . E  S DR =".25///"_ RCRCPTDA_" ;9///"_DT
  7669   "RTN","RCD PEAP1",179 ,0)
  7670    . D ^DIE
  7671   "RTN","RCD PEAP1",180 ,0)
  7672    ; PRCA*4. 5*318 ends
  7673   "RTN","RCD PEAP1",181 ,0)
  7674    Q
  7675   "RTN","RCD PEAP1",182 ,0)
  7676    ;
  7677   "RTN","RCD PEAP1",183 ,0)
  7678   ZEROBAL(RC SCR) ;
  7679   "RTN","RCD PEAP1",184 ,0)
  7680    ; per req uirements,  only posi tive/negat ive paymen t pairs wh ere paymen
  7681   "RTN","RCD PEAP1",185 ,0)
  7682    ; calcula tes to zer o are allo wed for au to-post
  7683   "RTN","RCD PEAP1",186 ,0)
  7684    ; if paym ent ends u p less tha n zero or  greater th an zero th en ERA can not
  7685   "RTN","RCD PEAP1",187 ,0)
  7686    ;be autop osted.  
  7687   "RTN","RCD PEAP1",188 ,0)
  7688    ; ERA get s sent to  the standa rd worklis t for manu al receipt  processin g
  7689   "RTN","RCD PEAP1",189 ,0)
  7690    ; note:   a payment  pair repre sents 2 EE OB sequenc es with th e same cla im
  7691   "RTN","RCD PEAP1",190 ,0)
  7692    ;          RCSCR - 3 44.49 ien
  7693   "RTN","RCD PEAP1",191 ,0)
  7694    ;          X - retur ns 1 or 0
  7695   "RTN","RCD PEAP1",192 ,0)
  7696    ; 
  7697   "RTN","RCD PEAP1",193 ,0)
  7698    N SUB,SUB 1,WLINE,X, ERALINE
  7699   "RTN","RCD PEAP1",194 ,0)
  7700    S SUB=0,X =1,ERALINE =""
  7701   "RTN","RCD PEAP1",195 ,0)
  7702    F  S SUB= $O(^RCY(34 4.49,RCSCR ,1,"B",SUB )) Q:SUB=" "  D
  7703   "RTN","RCD PEAP1",196 ,0)
  7704    . ;Get sc ratchpad l ine and da ta 
  7705   "RTN","RCD PEAP1",197 ,0)
  7706    . S SUB1= $O(^RCY(34 4.49,RCSCR ,1,"B",SUB ,"")) Q:'S UB1  S WLI NE=$G(^RCY (344.49,RC SCR,1,SUB1 ,0))
  7707   "RTN","RCD PEAP1",198 ,0)
  7708    . ;If int eger seque nce, get E RA line re ference th en quit fo r this seq uence and  go on to t he non-int eger seque nce to fin ish valida tion
  7709   "RTN","RCD PEAP1",199 ,0)
  7710    . I $P(WL INE,U)?1N. N S ERALIN E=$P(WLINE ,U,9) Q 
  7711   "RTN","RCD PEAP1",200 ,0)
  7712    . ; there  are multi ple EEOB s equences f or the spe cific bill  number so  an adjust ment took  place; 
  7713   "RTN","RCD PEAP1",201 ,0)
  7714    . ; if pa yment adju stment doe sn't gener ate a zero  payment b alance at  344.491,.0 6 then thi s ERA need s to drop  to standar d worklist
  7715   "RTN","RCD PEAP1",202 ,0)
  7716    . I ERALI NE[",",+$P (WLINE,U,6 )'=0 S X=0  Q
  7717   "RTN","RCD PEAP1",203 ,0)
  7718    . ;do not  autopost  ERA if one  of paymen ts is nega tive amoun t
  7719   "RTN","RCD PEAP1",204 ,0)
  7720    . I $P(WL INE,U,6)<0  S X=0
  7721   "RTN","RCD PEAP1",205 ,0)
  7722    Q X
  7723   "RTN","RCD PEAP1",206 ,0)
  7724    ;
  7725   "RTN","RCD PEAP1",207 ,0)
  7726    ; Verify  if auto-po sting is a llowed for  Pharmacy  claims and  for the P ayer - PRE CHECK USED  IN RCDPEM 0
  7727   "RTN","RCD PEAP1",208 ,0)
  7728   EXCLDRX(RC ERA) ;
  7729   "RTN","RCD PEAP1",209 ,0)
  7730    ;Not allo wed if pha rmacy auto -posting i s switched  off
  7731   "RTN","RCD PEAP1",210 ,0)
  7732    Q:'$P($G( ^RCY(344.6 1,1,1)),U, 1) 1
  7733   "RTN","RCD PEAP1",211 ,0)
  7734    ;Check if  Payer Nam e and Paye r ID from  ERA are in  auto-post ing payer  table
  7735   "RTN","RCD PEAP1",212 ,0)
  7736    N RCPNM,R CPID,RCPXD A
  7737   "RTN","RCD PEAP1",213 ,0)
  7738    S RCPNM=$ P($G(^RCY( 344.4,RCER A,0)),U,6)  Q:RCPNM=" " 1
  7739   "RTN","RCD PEAP1",214 ,0)
  7740    S RCPID=$ P($G(^RCY( 344.4,RCER A,0)),U,3)  Q:RCPID=" " 1
  7741   "RTN","RCD PEAP1",215 ,0)
  7742    ;Auto-pos t is allow ed if this  is a new  payer (not  in table)
  7743   "RTN","RCD PEAP1",216 ,0)
  7744    S RCPXDA= $O(^RCY(34 4.6,"CPID" ,RCPNM,RCP ID,"")) Q: RCPXDA=""  0
  7745   "RTN","RCD PEAP1",217 ,0)
  7746    ;If payer  table ent ry found c heck if pa yer is exc luded from  pharmacy  auto-post
  7747   "RTN","RCD PEAP1",218 ,0)
  7748    Q:$P($G(^ RCY(344.6, RCPXDA,0)) ,U,8)=1 1
  7749   "RTN","RCD PEAP1",219 ,0)
  7750    ;Otherwis e it is OK  to auto-p ost
  7751   "RTN","RCD PEAP1",220 ,0)
  7752    Q 0
  7753   "RTN","RCD PEAP1",221 ,0)
  7754    ;
  7755   "RTN","RCD PEAP1",222 ,0)
  7756   VALID(RCER A,RCLINES)  ;
  7757   "RTN","RCD PEAP1",223 ,0)
  7758    ;Verify w hich scrat chpad line s are able  to auto-p ost - call ed by EN2^ RCDPEAP
  7759   "RTN","RCD PEAP1",224 ,0)
  7760    ;
  7761   "RTN","RCD PEAP1",225 ,0)
  7762    ; RCERA -  Electroni c Remittan ce Advice  (#344.4) I EN
  7763   "RTN","RCD PEAP1",226 ,0)
  7764    ; RCLINES  - Array o f ERA line  reference s (passed  in by refe rence)
  7765   "RTN","RCD PEAP1",227 ,0)
  7766    ;            RCLINES (ERALINE)= 1  - ERA l ine(s) are  postable.   Also RCL INES count er is incr emented.
  7767   "RTN","RCD PEAP1",228 ,0)
  7768    ;            RCLINES (ERALINE)= 0^^Reject  Reason Cod e - ERA li ne(s) are  not postab le
  7769   "RTN","RCD PEAP1",229 ,0)
  7770    ;            NOTE: O RIGINAL ER A SEQUENCE S (#.09) c an have mu ltiple ERA  line refe rences sep arated by  commas (e. g.,"3,4")
  7771   "RTN","RCD PEAP1",230 ,0)
  7772    ;
  7773   "RTN","RCD PEAP1",231 ,0)
  7774    ;Check fo r ScratchP ad entry.   If missin g (should  not happen ), quit
  7775   "RTN","RCD PEAP1",232 ,0)
  7776    N RCSCR
  7777   "RTN","RCD PEAP1",233 ,0)
  7778    S RCSCR=$ O(^RCY(344 .49,"B",+$ G(RCERA)," "))
  7779   "RTN","RCD PEAP1",234 ,0)
  7780    I RCSCR=" " S RCLINE S=0 Q
  7781   "RTN","RCD PEAP1",235 ,0)
  7782    ;Loop thr ough scrat chpad for  this ERA
  7783   "RTN","RCD PEAP1",236 ,0)
  7784    N SUB,SUB 1,WLINE,ER ALINE,PIEC E,SEQ,CLAI M,STATUS,C LARRAY,AUT OPOST
  7785   "RTN","RCD PEAP1",237 ,0)
  7786    S SUB=0 F   S SUB=$O (^RCY(344. 49,RCSCR,1 ,"B",SUB))  Q:SUB=""   D
  7787   "RTN","RCD PEAP1",238 ,0)
  7788    . ;Get sc ratchpad l ine and da ta
  7789   "RTN","RCD PEAP1",239 ,0)
  7790    . S SUB1= $O(^RCY(34 4.49,RCSCR ,1,"B",SUB ,""))
  7791   "RTN","RCD PEAP1",240 ,0)
  7792    . I 'SUB1  Q
  7793   "RTN","RCD PEAP1",241 ,0)
  7794    . S WLINE =$G(^RCY(3 44.49,RCSC R,1,SUB1,0 ))
  7795   "RTN","RCD PEAP1",242 ,0)
  7796    . ;If int eger seque nce, get E RA line re ference an d check fo r auto-pos t flag
  7797   "RTN","RCD PEAP1",243 ,0)
  7798    . I $P(WL INE,U)?1N. N D  Q
  7799   "RTN","RCD PEAP1",244 ,0)
  7800    .. S ERAL INE=$P(WLI NE,U,9)
  7801   "RTN","RCD PEAP1",245 ,0)
  7802    .. ; If E RA referen ce is miss ing (shoul d not happ en), skip  ahead to n ext intege r sequence
  7803   "RTN","RCD PEAP1",246 ,0)
  7804    .. I ERAL INE="" S S UB=SUB\1_" .999" Q
  7805   "RTN","RCD PEAP1",247 ,0)
  7806    .. ; Chec k for rece ipt - PRCA *4.5*318 
  7807   "RTN","RCD PEAP1",248 ,0)
  7808    .. I $$GE T1^DIQ(344 .41,ERALIN E_","_RCER A_",",.25) ]"" S SUB= SUB\1_".99 9" Q  ; PR CA*4.5*318
  7809   "RTN","RCD PEAP1",249 ,0)
  7810    .. S AUTO POST=1
  7811   "RTN","RCD PEAP1",250 ,0)
  7812    .. F PIEC E=1:1 S SE Q=$P(ERALI NE,",",PIE CE) Q:'SEQ   I '$P($G (^RCY(344. 4,RCERA,1, SEQ,5)),U, 2) S AUTOP OST=0 Q
  7813   "RTN","RCD PEAP1",251 ,0)
  7814    .. ; Unle ss all of  the associ ated ERA d etail line s are set  for auto-p ost, skip  ahead to n ext intege r sequence
  7815   "RTN","RCD PEAP1",252 ,0)
  7816    .. I 'AUT OPOST S SU B=SUB\1_". 999" Q
  7817   "RTN","RCD PEAP1",253 ,0)
  7818    . ;If no  claim numb er (suspen se), set t o autopost  but check  the rest  of the lin es for the  ERA refer ence
  7819   "RTN","RCD PEAP1",254 ,0)
  7820    . S CLAIM =$P(WLINE, U,7)
  7821   "RTN","RCD PEAP1",255 ,0)
  7822    . I 'CLAI M S RCLINE S(ERALINE) =1 Q
  7823   "RTN","RCD PEAP1",256 ,0)
  7824    . ;Quit w ith error  if claim i s not OPEN  or ACTIVE
  7825   "RTN","RCD PEAP1",257 ,0)
  7826    . S STATU S=$P($G(^P RCA(430,CL AIM,0)),"^ ",8)
  7827   "RTN","RCD PEAP1",258 ,0)
  7828    . I STATU S'=42,STAT US'=16 S R CLINES(ERA LINE)="0^^ 5",SUB=SUB \1_".999"  Q
  7829   "RTN","RCD PEAP1",259 ,0)
  7830    . ;Quit w ith error  if referre d to gener al council
  7831   "RTN","RCD PEAP1",260 ,0)
  7832    . I $P($G (^PRCA(430 ,CLAIM,6)) ,U,4)]"" S  RCLINES(E RALINE)="0 ^^7",SUB=S UB\1_".999 " Q
  7833   "RTN","RCD PEAP1",261 ,0)
  7834    . ;Check  for negati ve payment  amount
  7835   "RTN","RCD PEAP1",262 ,0)
  7836    . I $P(WL INE,U,6)<0  S RCLINES (ERALINE)= "0^^6",SUB =SUB\1_".9 99" Q
  7837   "RTN","RCD PEAP1",263 ,0)
  7838    . ;Increm ent claim  balance.   If payment  exceeds c laim balan ce and no  pending pa yments (at  the time  of auto po sting), qu it
  7839   "RTN","RCD PEAP1",264 ,0)
  7840    . ;  with  error.  A lso deduct  the amoun t from the  balance s o subseque nt, smalle r amounts  may get po sted
  7841   "RTN","RCD PEAP1",265 ,0)
  7842    . S CLARR AY(CLAIM)= +$G(CLARRA Y(CLAIM))+ $P(WLINE,U ,3)
  7843   "RTN","RCD PEAP1",266 ,0)
  7844    . I '$$CH ECKPAY^RCD PEAP(.CLAR RAY,CLAIM)  S RCLINES (ERALINE)= "0^^3",SUB =SUB\1_".9 99",CLARRA Y(CLAIM)=+ $G(CLARRAY (CLAIM))-$ P(WLINE,U, 3) Q
  7845   "RTN","RCD PEAP1",267 ,0)
  7846    . ;Line i s potentia lly postab le - updat e flag
  7847   "RTN","RCD PEAP1",268 ,0)
  7848    . S RCLIN ES(ERALINE )=1
  7849   "RTN","RCD PEAP1",269 ,0)
  7850    ;
  7851   "RTN","RCD PEAP1",270 ,0)
  7852    ;Reset th e MARK FOR  AUTOPOST  flag on ER A lines an d return c ount of au to-postabl e lines -  PRCA*4.5*3 18
  7853   "RTN","RCD PEAP1",271 ,0)
  7854    N DA,DIE, DR,RCLIN,R CI
  7855   "RTN","RCD PEAP1",272 ,0)
  7856    S RCLIN=0 ,RCLINES=0  F  S RCLI N=$O(RCLIN ES(RCLIN))  Q:'RCLIN   D
  7857   "RTN","RCD PEAP1",273 ,0)
  7858    . I +RCLI NES(RCLIN)  S RCLINES =RCLINES+1
  7859   "RTN","RCD PEAP1",274 ,0)
  7860    . ;Set MA RK FOR AUT O-POST (#6 ) to NO fo r every li ne
  7861   "RTN","RCD PEAP1",275 ,0)
  7862    . S DA(1) =RCERA,DA= RCLIN,DIE= "^RCY(344. 4,"_DA(1)_ ",1,"
  7863   "RTN","RCD PEAP1",276 ,0)
  7864    . S DR="6 ///0"
  7865   "RTN","RCD PEAP1",277 ,0)
  7866    . D ^DIE
  7867   "RTN","RCD PEAP1",278 ,0)
  7868    Q
  7869   "RTN","RCD PEAP1",279 ,0)
  7870    ;
  7871   "RTN","RCD PEAP1",280 ,0)
  7872   UNBAL(RCER A) ; PRCA* 4.5*318 ad ded method
  7873   "RTN","RCD PEAP1",281 ,0)
  7874    ; Determi ne if the  ERA total  matches th e EFT tota l for the  selected E RA
  7875   "RTN","RCD PEAP1",282 ,0)
  7876    ; Input:    RCERA     - Interna l IEN of t he selecte d ERA
  7877   "RTN","RCD PEAP1",283 ,0)
  7878    ; Returns : 1 - ERA  is unbalan ced, 0 oth erwise
  7879   "RTN","RCD PEAP1",284 ,0)
  7880    N RCLTOT, RCSUB,RCTO T
  7881   "RTN","RCD PEAP1",285 ,0)
  7882    ;ERA tota l balance  - on match ed ERAs th e ERA tota l balance  is the sam e as the E FT total
  7883   "RTN","RCD PEAP1",286 ,0)
  7884    S RCTOT=+ $$GET1^DIQ (344.4,RCE RA_",",.05 )
  7885   "RTN","RCD PEAP1",287 ,0)
  7886    ;Sum of E RA claim l ine paymen ts
  7887   "RTN","RCD PEAP1",288 ,0)
  7888    S RCSUB=0 ,RCLTOT=0
  7889   "RTN","RCD PEAP1",289 ,0)
  7890    F  S RCSU B=$O(^RCY( 344.4,RCER A,1,RCSUB) ) Q:'RCSUB   D
  7891   "RTN","RCD PEAP1",290 ,0)
  7892    . S RCLTO T=RCLTOT+$ $GET1^DIQ( 344.41,RCS UB_","_RCE RA_",",.03 )
  7893   "RTN","RCD PEAP1",291 ,0)
  7894    ;Plus sum  of ERA ad justment l ines
  7895   "RTN","RCD PEAP1",292 ,0)
  7896    S RCSUB=0
  7897   "RTN","RCD PEAP1",293 ,0)
  7898    F  S RCSU B=$O(^RCY( 344.4,RCER A,2,RCSUB) ) Q:'RCSUB   D
  7899   "RTN","RCD PEAP1",294 ,0)
  7900    . S RCLTO T=RCLTOT+$ $GET1^DIQ( 344.42,RCS UB_","_RCE RA_",",.03 )
  7901   "RTN","RCD PEAP1",295 ,0)
  7902    ;Return 1  if total  of ERA lin es does no t match EF T
  7903   "RTN","RCD PEAP1",296 ,0)
  7904    Q $S(RCTO T=RCLTOT:0 ,1:1)
  7905   "RTN","RCD PEAR1")
  7906   0^26^B2073 94984
  7907   "RTN","RCD PEAR1",1,0 )
  7908   RCDPEAR1 ; ALB/TMK/PJ H - ERA Un matched Ag ing Report  (file #34 4.4) ;Dec  20, 2014@1 8:41:35
  7909   "RTN","RCD PEAR1",2,0 )
  7910    ;;4.5;Acc ounts Rece ivable;**1 73,269,276 ,284,293,2 98,321**;M ar 20, 199 5;Build 46
  7911   "RTN","RCD PEAR1",3,0 )
  7912    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  7913   "RTN","RCD PEAR1",4,0 )
  7914    Q
  7915   "RTN","RCD PEAR1",5,0 )
  7916    ;
  7917   "RTN","RCD PEAR1",6,0 )
  7918    ; PRCA*4. 5*298 rout ine comple tely refac tored
  7919   "RTN","RCD PEAR1",7,0 )
  7920   EN1 ; entr y point -  ERA Unmatc hed Aging  Report [RC DPE ERA AG ING REPORT ]
  7921   "RTN","RCD PEAR1",8,0 )
  7922    ; data fr om ELECTRO NIC REMITT ANCE ADVIC E file (#3 44.4)
  7923   "RTN","RCD PEAR1",9,0 )
  7924    N RCDISPT Y,RCDT,RCD TRNG,RCHDR ,RCJOB,RCL NCNT,RCLST MGR,RCOUT, RCPGNUM,RC PYRLST,RCR ESPYR
  7925   "RTN","RCD PEAR1",10, 0)
  7926    N RCSTOP, RCTMPND,RC XCLUDE,RCZ ROBAL,VAUT D,Y
  7927   "RTN","RCD PEAR1",11, 0)
  7928    ; RCDISPT Y - displa y type (Ex cel)
  7929   "RTN","RCD PEAR1",12, 0)
  7930    ; RCDTRNG  - selecte d date ran ge
  7931   "RTN","RCD PEAR1",13, 0)
  7932    ; RCDT("B EG") - sta rt date, R CDT("END")  - end dat e
  7933   "RTN","RCD PEAR1",14, 0)
  7934    ; RCHDR -  header ar ray
  7935   "RTN","RCD PEAR1",15, 0)
  7936    ; RCLSTMG R - list m anager fla g
  7937   "RTN","RCD PEAR1",16, 0)
  7938    ; RCRESPY R - payer  info respo nse: "1^fi rst payer^ last payer " or "2^^"  (for all)  or "3^^"  (for speci fic)
  7939   "RTN","RCD PEAR1",17, 0)
  7940    ; RCDTRNG  - "1^star t date^end  date"
  7941   "RTN","RCD PEAR1",18, 0)
  7942    ; RCPYRLS T - payer  list for s elected pa yers
  7943   "RTN","RCD PEAR1",19, 0)
  7944    ; RCXCLUD E("CHAMPVA ") - boole an, exclud e CHAMPVA
  7945   "RTN","RCD PEAR1",20, 0)
  7946    ; RCXCLUD E("TRICARE ") - boole an, exclud e TriCare
  7947   "RTN","RCD PEAR1",21, 0)
  7948    ; RCZROBA L - zero b alance fla g
  7949   "RTN","RCD PEAR1",22, 0)
  7950    ; VAUTD -  division  informatio n
  7951   "RTN","RCD PEAR1",23, 0)
  7952    ;
  7953   "RTN","RCD PEAR1",24, 0)
  7954    K ^TMP($J ,"RC TOTAL ")  ; clea r old tota ls
  7955   "RTN","RCD PEAR1",25, 0)
  7956    W !,$$HDR NM D DIVIS ION^VAUTOM A  ; retur ns VAUTD
  7957   "RTN","RCD PEAR1",26, 0)
  7958    I 'VAUTD& ($D(VAUTD) '=11) G EN 1Q
  7959   "RTN","RCD PEAR1",27, 0)
  7960    S RCLSTMG R=""  ; in itial valu e, won't b e asked if  non-null
  7961   "RTN","RCD PEAR1",28, 0)
  7962    S (RCXCLU DE("CHAMPV A"),RCXCLU DE("TRICAR E"))=0  ;  default to  false
  7963   "RTN","RCD PEAR1",29, 0)
  7964    S RCDTRNG =$$DTRNG^R CDPEM4() I  'RCDTRNG  G EN1Q
  7965   "RTN","RCD PEAR1",30, 0)
  7966    S RCDT("B EG")=$P(RC DTRNG,U,2) ,RCDT("END ")=$P(RCDT RNG,U,3)
  7967   "RTN","RCD PEAR1",31, 0)
  7968    ;Get insu rance comp any to be  used as fi lter
  7969   "RTN","RCD PEAR1",32, 0)
  7970    ; PRCA*4. 5*284 - RC RESPYR (Ty pe of Resp onse(1=Ran ge,2=All,3 =Specific) ^From name ^To name)
  7971   "RTN","RCD PEAR1",33, 0)
  7972    S RCRESPY R=$$GETPAY ^RCDPEM9(3 44.4) G:RC RESPYR<0 E N1Q
  7973   "RTN","RCD PEAR1",34, 0)
  7974    ; Get Zer o Balance  Filter
  7975   "RTN","RCD PEAR1",35, 0)
  7976    S RCZROBA L=$$ZROBAL () G:RCZRO BAL<0 EN1Q
  7977   "RTN","RCD PEAR1",36, 0)
  7978    ; CHAMPVA  exclusion  filter
  7979   "RTN","RCD PEAR1",37, 0)
  7980    S RCXCLUD E("CHAMPVA ")=$$INCHM PVA^RCDPEA RL  ; user  is asked  whether to  include
  7981   "RTN","RCD PEAR1",38, 0)
  7982    G:RCXCLUD E("CHAMPVA ")<0 EN1Q
  7983   "RTN","RCD PEAR1",39, 0)
  7984    ; TRICARE  exclusion  filter
  7985   "RTN","RCD PEAR1",40, 0)
  7986    S RCXCLUD E("TRICARE ")=$$INTRI CAR^RCDPEA RL  ; user  is asked  whether to  include
  7987   "RTN","RCD PEAR1",41, 0)
  7988    G:RCXCLUD E("TRICARE ")<0 EN1Q
  7989   "RTN","RCD PEAR1",42, 0)
  7990    ; display  type, ask  for Excel  format
  7991   "RTN","RCD PEAR1",43, 0)
  7992    S RCDISPT Y=$$DISPTY ^RCDPEM3()  I RCDISPT Y=-1 G EN1 Q
  7993   "RTN","RCD PEAR1",44, 0)
  7994    ; display  device in fo about E xcel forma t, set Lis tMan flag  to prevent  question
  7995   "RTN","RCD PEAR1",45, 0)
  7996    I RCDISPT Y S RCLSTM GR="^" D I NFO^RCDPEM 6
  7997   "RTN","RCD PEAR1",46, 0)
  7998    I $D(DUOU T)!$D(DTOU T) G EN1Q
  7999   "RTN","RCD PEAR1",47, 0)
  8000    S RCJOB=$ J  ; neede d in RPTOU T
  8001   "RTN","RCD PEAR1",48, 0)
  8002    ;
  8003   "RTN","RCD PEAR1",49, 0)
  8004    I '(+RCRE SPYR=2) D   ; get pay er list if  not all p ayers
  8005   "RTN","RCD PEAR1",50, 0)
  8006    .N J,P S  J=0
  8007   "RTN","RCD PEAR1",51, 0)
  8008    .F  S J=$ O(^TMP("RC SELPAY",$J ,J)) Q:'J   S P=$G(^( J)) S:P]""  RCPYRLST( P)=""
  8009   "RTN","RCD PEAR1",52, 0)
  8010    ; if not  output to  Excel ask  for ListMa n display,  exit if t imeout or  '^' - PRCA *4.5*298
  8011   "RTN","RCD PEAR1",53, 0)
  8012    I RCLSTMG R="" S RCL STMGR=$$AS KLM^RCDPEA RL G:RCLST MGR<0 EN1Q
  8013   "RTN","RCD PEAR1",54, 0)
  8014    ; display  in ListMa n format a nd exit on  return
  8015   "RTN","RCD PEAR1",55, 0)
  8016    I RCLSTMG R D  G EN1 Q
  8017   "RTN","RCD PEAR1",56, 0)
  8018    .S RCTMPN D=$T(+0)_" ^ERA UNMAT CHED AGING "  K ^TMP( $J,RCTMPND )  ; clean  any resid ue
  8019   "RTN","RCD PEAR1",57, 0)
  8020    .D RPTOUT
  8021   "RTN","RCD PEAR1",58, 0)
  8022    .N H,L,HD R S L=0
  8023   "RTN","RCD PEAR1",59, 0)
  8024    .S HDR("T ITLE")=$$H DRNM
  8025   "RTN","RCD PEAR1",60, 0)
  8026    .F H=1:1: 7 I $D(RCH DR(H)) S L =H,HDR(H)= RCHDR(H)   ; take fir st 7 lines  of report  header
  8027   "RTN","RCD PEAR1",61, 0)
  8028    .I $O(RCH DR(L)) D   ; any rema ining head er lines a t top of r eport
  8029   "RTN","RCD PEAR1",62, 0)
  8030    ..N N S N =0,H=L F   S H=$O(RCH DR(H)) Q:' H  S N=N+. 001,^TMP($ J,RCTMPND, N)=RCHDR(H )
  8031   "RTN","RCD PEAR1",63, 0)
  8032    .; invoke  ListMan
  8033   "RTN","RCD PEAR1",64, 0)
  8034    .D LMRPT^ RCDPEARL(. HDR,$NA(^T MP($J,RCTM PND))) ; g enerate Li stMan disp lay
  8035   "RTN","RCD PEAR1",65, 0)
  8036    ;
  8037   "RTN","RCD PEAR1",66, 0)
  8038    ; Ask dev ice
  8039   "RTN","RCD PEAR1",67, 0)
  8040    N %ZIS S  %ZIS="QM"  D ^%ZIS G: POP EN1Q
  8041   "RTN","RCD PEAR1",68, 0)
  8042    I $D(IO(" Q")) D  G  EN1Q
  8043   "RTN","RCD PEAR1",69, 0)
  8044    .N ZTDESC ,ZTQUEUED, ZTRTN,ZTSA VE,ZTSK,ZT STOP
  8045   "RTN","RCD PEAR1",70, 0)
  8046    .S ZTRTN= "RPTOUT^RC DPEAR1",ZT DESC="AR -  EDI LOCKB OX ERA AGI NG REPORT"
  8047   "RTN","RCD PEAR1",71, 0)
  8048    .S ZTSAVE ("RC*")="" ,ZTSAVE("V AUTD")=""
  8049   "RTN","RCD PEAR1",72, 0)
  8050    .; PRCA*4 .5*284 - ^ TMP may be  on anothe r server,  save off s pecific pa yers in lo cal
  8051   "RTN","RCD PEAR1",73, 0)
  8052    .;I +RCRE SPYR=3 M R CPYRLST=^T MP("RCSELP AY",$J)
  8053   "RTN","RCD PEAR1",74, 0)
  8054    .D ^%ZTLO AD
  8055   "RTN","RCD PEAR1",75, 0)
  8056    .W !!,$S( $G(ZTSK):" Task numbe r "_ZTSK_"  has been  queued.",1 :"Unable t o queue th is task.")
  8057   "RTN","RCD PEAR1",76, 0)
  8058    .K ZTSK,I O("Q") D H OME^%ZIS
  8059   "RTN","RCD PEAR1",77, 0)
  8060    ;
  8061   "RTN","RCD PEAR1",78, 0)
  8062    U IO S RC TMPND="" D  RPTOUT
  8063   "RTN","RCD PEAR1",79, 0)
  8064    ;
  8065   "RTN","RCD PEAR1",80, 0)
  8066   EN1Q ; exi t and clea n up
  8067   "RTN","RCD PEAR1",81, 0)
  8068    K ^TMP("R CSELPAY",$ J),^TMP("R CPAYER",$J )
  8069   "RTN","RCD PEAR1",82, 0)
  8070    I '$G(RCL STMGR) D ^ %ZISC
  8071   "RTN","RCD PEAR1",83, 0)
  8072    Q
  8073   "RTN","RCD PEAR1",84, 0)
  8074    ;
  8075   "RTN","RCD PEAR1",85, 0)
  8076   RPTOUT ; E ntry point  for listi ng report
  8077   "RTN","RCD PEAR1",86, 0)
  8078    ; RCTMPND  = name of  the subsc ript for ^ TMP to use  to return  all lines
  8079   "RTN","RCD PEAR1",87, 0)
  8080    ;         (for bulle tin).  If  undefined  or null, o utput is p rinted
  8081   "RTN","RCD PEAR1",88, 0)
  8082    ; Return  global if  RCTMPND no t null: ^T MP($J,RCTM PND,line#) =line text
  8083   "RTN","RCD PEAR1",89, 0)
  8084    N ERADT,P YMNTFRM,RC 0,RCEDT,RC EXCEP,RCFL IEN,RCITM, RCNT,RCPAY ,RCSF0,RCZ ,STA,STNAM ,STNUM,X,Y ,Z,Z0
  8085   "RTN","RCD PEAR1",90, 0)
  8086    ; ERADT -  date of e ntry
  8087   "RTN","RCD PEAR1",91, 0)
  8088    ; RCFLIEN  - entry n umber in f ile #344.4
  8089   "RTN","RCD PEAR1",92, 0)
  8090    ; RCITM -  entry in  ^RCY(344.4 ,0) = ELEC TRONIC REM ITTANCE AD VICE^344.4 I
  8091   "RTN","RCD PEAR1",93, 0)
  8092    ; RCSF0 -  zero node  of sub-fi le entry
  8093   "RTN","RCD PEAR1",94, 0)
  8094    ;
  8095   "RTN","RCD PEAR1",95, 0)
  8096    S RCTMPND =$G(RCTMPN D)  I RCTM PND'="" K  ^TMP($J,RC TMPND)  ;  clear resi dual data
  8097   "RTN","RCD PEAR1",96, 0)
  8098    ; RCNT -  count of i tems
  8099   "RTN","RCD PEAR1",97, 0)
  8100    K ^TMP($J ,"RCERA_AG ED"),^TMP( $J,"RCERA_ ADJ")
  8101   "RTN","RCD PEAR1",98, 0)
  8102    S RCRESPY R=+RCRESPY R
  8103   "RTN","RCD PEAR1",99, 0)
  8104    S RCFLIEN =0,RCNT=0
  8105   "RTN","RCD PEAR1",100 ,0)
  8106    F  S RCFL IEN=$O(^RC Y(344.4,"A MATCH",0,R CFLIEN)) Q :'RCFLIEN   D
  8107   "RTN","RCD PEAR1",101 ,0)
  8108    .K RCITM  M RCITM=^R CY(344.4,R CFLIEN)  ;  grab enti re entry
  8109   "RTN","RCD PEAR1",102 ,0)
  8110    .Q:$P($G( RCITM(6)), U)  ; who  removed th e ERA - PR CA*4.5*293
  8111   "RTN","RCD PEAR1",103 ,0)
  8112    .S ERADT= +$P($G(RCI TM(0)),U,7 )  ; (#.07 ) FILE DAT E/TIME [7D ]
  8113   "RTN","RCD PEAR1",104 ,0)
  8114    .Q:'ERADT   ; no dat e, don't i nclude
  8115   "RTN","RCD PEAR1",105 ,0)
  8116    .; Check  date range
  8117   "RTN","RCD PEAR1",106 ,0)
  8118    .Q:(RCDT( "BEG")>ERA DT\1)!(ERA DT\1>RCDT( "END"))
  8119   "RTN","RCD PEAR1",107 ,0)
  8120    .; Check  Station/Di vision
  8121   "RTN","RCD PEAR1",108 ,0)
  8122    .;I '$$CH KDIV^RCDPE DAR(RCFLIE N,1,.VAUTD ) Q
  8123   "RTN","RCD PEAR1",109 ,0)
  8124    .I 'VAUTD  D ERASTA^ RCDPEM4(RC FLIEN,.STA ,.STNUM,.S TNAM) I '$ D(VAUTD(ST A)) Q
  8125   "RTN","RCD PEAR1",110 ,0)
  8126    .; Check  for payer  match
  8127   "RTN","RCD PEAR1",111 ,0)
  8128    .S PYMNTF RM=$P($G(R CITM(0)),U ,6)  ; PAY MENT FROM  field
  8129   "RTN","RCD PEAR1",112 ,0)
  8130    .I '(RCRE SPYR=2),PY MNTFRM]""  Q:'$D(RCPY RLST($$UP^ XLFSTR(PYM NTFRM)))   ; will inc lude null  payers whe n ALL paye rs selecte d
  8131   "RTN","RCD PEAR1",113 ,0)
  8132    .Q:(PYMNT FRM="")&'( RCRESPYR=2 )  ; null  payers exc luded when  not ALL s elected
  8133   "RTN","RCD PEAR1",114 ,0)
  8134    .; Check  for Zero B al
  8135   "RTN","RCD PEAR1",115 ,0)
  8136    .I 'RCZRO BAL,'$P($G (RCITM(0)) ,U,5) Q  ;  (#.05) TO TAL AMOUNT  PAID [5N]
  8137   "RTN","RCD PEAR1",116 ,0)
  8138    .; CHAMPV A check
  8139   "RTN","RCD PEAR1",117 ,0)
  8140    .I $G(RCX CLUDE("CHA MPVA")),$$ CLMCHMPV^R CDPEARL("3 44.4;"_RCF LIEN) D  Q   ; count  and quit i f true
  8141   "RTN","RCD PEAR1",118 ,0)
  8142    ..N N S N =$G(^TMP($ J,"RC TOTA L","CHAMPV A"))+1,^(" CHAMPVA")= N  ; total  can be li sted
  8143   "RTN","RCD PEAR1",119 ,0)
  8144    .;
  8145   "RTN","RCD PEAR1",120 ,0)
  8146    .; TRICAR E check
  8147   "RTN","RCD PEAR1",121 ,0)
  8148    .I $G(RCX CLUDE("TRI CARE")),$$ CLMTRICR^R CDPEARL("3 44.4;"_RCF LIEN) D  Q   ; count  and quit i f true
  8149   "RTN","RCD PEAR1",122 ,0)
  8150    ..N N S N =$G(^TMP($ J,"RC TOTA L","TRICAR E"))+1,^(" TRICARE")= N  ; total  can be li sted
  8151   "RTN","RCD PEAR1",123 ,0)
  8152    .;
  8153   "RTN","RCD PEAR1",124 ,0)
  8154    .; includ e on repor t
  8155   "RTN","RCD PEAR1",125 ,0)
  8156    .S ^TMP($ J,"RCERA_A GED",$$FMD IFF^XLFDT( ERADT,DT), RCFLIEN)=0 ,RCNT=RCNT +1
  8157   "RTN","RCD PEAR1",126 ,0)
  8158    ;
  8159   "RTN","RCD PEAR1",127 ,0)
  8160    S ^TMP($J ,"RC TOTAL ","COUNT") =RCNT  ; s ave counte r
  8161   "RTN","RCD PEAR1",128 ,0)
  8162    ; build l ocal payer  array
  8163   "RTN","RCD PEAR1",129 ,0)
  8164    D SELPAY^ RCDPEAR3(R CRESPYR,RC JOB,.RCPAY )
  8165   "RTN","RCD PEAR1",130 ,0)
  8166    ; build h eader, ini tialize st op flag
  8167   "RTN","RCD PEAR1",131 ,0)
  8168    D:'RCLSTM GR HDRBLD  S RCSTOP=0
  8169   "RTN","RCD PEAR1",132 ,0)
  8170    D:RCLSTMG R HDRLM
  8171   "RTN","RCD PEAR1",133 ,0)
  8172    ;
  8173   "RTN","RCD PEAR1",134 ,0)
  8174    ; Excel f ormat, pri nt and exi t
  8175   "RTN","RCD PEAR1",135 ,0)
  8176    I RCDISPT Y D EXCEL, ^%ZISC G E XIT
  8177   "RTN","RCD PEAR1",136 ,0)
  8178    ;
  8179   "RTN","RCD PEAR1",137 ,0)
  8180    D  ;  Cal culate tot al amount  for ERA
  8181   "RTN","RCD PEAR1",138 ,0)
  8182    .N T S T= 0  ; total
  8183   "RTN","RCD PEAR1",139 ,0)
  8184    .S RCZ=""  F  S RCZ= $O(^TMP($J ,"RCERA_AG ED",RCZ))  Q:RCZ=""   S RCFLIEN= 0 F  S RCF LIEN=$O(^T MP($J,"RCE RA_AGED",R CZ,RCFLIEN )) Q:'RCFL IEN  D
  8185   "RTN","RCD PEAR1",140 ,0)
  8186    ..S RC0=$ G(^RCY(344 .4,RCFLIEN ,0)),T=T+$ P(RC0,U,5)
  8187   "RTN","RCD PEAR1",141 ,0)
  8188    .;
  8189   "RTN","RCD PEAR1",142 ,0)
  8190    .S ^TMP($ J,"RC TOTA L","AMOUNT ")=T
  8191   "RTN","RCD PEAR1",143 ,0)
  8192    ;
  8193   "RTN","RCD PEAR1",144 ,0)
  8194    S RCLNCNT =0  ; line  counter
  8195   "RTN","RCD PEAR1",145 ,0)
  8196    D:'RCLSTM GR HDRLST^ RCDPEARL(. RCSTOP,.RC HDR)  ; fi rst header  in report
  8197   "RTN","RCD PEAR1",146 ,0)
  8198    ; list to tals
  8199   "RTN","RCD PEAR1",147 ,0)
  8200    S Y=" Tot al NUMBER  Aged Elect ronic ERA  messages f ound: "_$F N(^TMP($J, "RC TOTAL" ,"COUNT"), ",")
  8201   "RTN","RCD PEAR1",148 ,0)
  8202    D SL^RCDP EARL(Y,.RC LNCNT,RCTM PND)
  8203   "RTN","RCD PEAR1",149 ,0)
  8204    S Y=" Tot al AMOUNT  Aged Elect ronic ERA  messages f ound: $"_$ FN(^TMP($J ,"RC TOTAL ","AMOUNT" ),",",2)
  8205   "RTN","RCD PEAR1",150 ,0)
  8206    D SL^RCDP EARL(Y,.RC LNCNT,RCTM PND)
  8207   "RTN","RCD PEAR1",151 ,0)
  8208    ; if filt ers select ed show to tal exclud ed
  8209   "RTN","RCD PEAR1",152 ,0)
  8210    F J="CHAM PVA","TRIC ARE" I $G( RCXCLUDE(J )) S Y=" " _J_" exclu sion count : "_(+$G(^ TMP($J,"RC  TOTAL",J) )) D SL^RC DPEARL(Y,. RCLNCNT,RC TMPND)
  8211   "RTN","RCD PEAR1",153 ,0)
  8212    D SL^RCDP EARL(" "_$ TR($J("",7 8)," ","=" ),.RCLNCNT ,RCTMPND)   ; row of  equal sign s
  8213   "RTN","RCD PEAR1",154 ,0)
  8214    ;
  8215   "RTN","RCD PEAR1",155 ,0)
  8216    S RCZ=""  F  S RCZ=$ O(^TMP($J, "RCERA_AGE D",RCZ)) Q :RCZ=""  S  RCFLIEN=0  F  S RCFL IEN=$O(^TM P($J,"RCER A_AGED",RC Z,RCFLIEN) ) Q:'RCFLI EN  D  G:R CSTOP EXIT
  8217   "RTN","RCD PEAR1",156 ,0)
  8218    .I $D(ZTQ UEUED),$$S ^%ZTLOAD S  (RCSTOP,Z TSTOP)=1 K  ZTREQ I + $G(RCPGNUM ) W:RCTMPN D="" !!,"* **TASK STO PPED BY US ER***" Q
  8219   "RTN","RCD PEAR1",157 ,0)
  8220    .I RCPGNU M D SL^RCD PEARL(" ", .RCLNCNT,. RCTMPND) ;  On detail  list, ski p line
  8221   "RTN","RCD PEAR1",158 ,0)
  8222    .I 'RCLST MGR,'RCPGN UM!(($Y+5) >IOSL) D H DRLST^RCDP EARL(.RCST OP,.RCHDR)  Q:RCSTOP
  8223   "RTN","RCD PEAR1",159 ,0)
  8224    .S RC0=$G (^RCY(344. 4,RCFLIEN, 0))
  8225   "RTN","RCD PEAR1",160 ,0)
  8226    .S RCEXCE P=$$XCEPT^ RCDPEWLP(R CFLIEN)  ;  PRCA*4.5* 298  assig nment of E RA excepti on flag (w ill either  be "" or  "x")
  8227   "RTN","RCD PEAR1",161 ,0)
  8228    .S Z=$$SE TSTR^VALM1 ($J(RCEXCE P_-RCZ,4), "",1,5)  ;  PRCA*4.5* 298 displa y ERA exce ption flag
  8229   "RTN","RCD PEAR1",162 ,0)
  8230    .S Z=$$SE TSTR^VALM1 ("  "_$P(R C0,U,2),Z, 5,50)
  8231   "RTN","RCD PEAR1",163 ,0)
  8232    .D SL^RCD PEARL(Z,.R CLNCNT,RCT MPND)
  8233   "RTN","RCD PEAR1",164 ,0)
  8234    .S Z=$$SE TSTR^VALM1 ($$PAYTIN^ RCDPRU2($P (RC0,U,6)_ "/"_$P(RC0 ,U,3),78), "",3,78) ;  PRCA*4.5* 321
  8235   "RTN","RCD PEAR1",165 ,0)
  8236    .D SL^RCD PEARL(Z,.R CLNCNT,RCT MPND)
  8237   "RTN","RCD PEAR1",166 ,0)
  8238    .S Z=$$SE TSTR^VALM1 ($J("",16) _$S($P(RC0 ,U,7):$$FM TE^XLFDT($ P(RC0,U,7) \1,2),1:"" ),"",1,25)
  8239   "RTN","RCD PEAR1",167 ,0)
  8240    .S Z=$$SE TSTR^VALM1 ("  "_$J($ P(RC0,U,5) ,15,2),Z,2 6,17)
  8241   "RTN","RCD PEAR1",168 ,0)
  8242    .S Z=$$SE TSTR^VALM1 ("  "_+$P( RC0,U,11), Z,43,11)
  8243   "RTN","RCD PEAR1",169 ,0)
  8244    .S Z=$$SE TSTR^VALM1 ("  "_$P(R C0,U),Z_$S ('$$HACERA ^RCDPEU(RC FLIEN):"", 1:" (HAC E RA)"),54,1 6) ; PRCA* 4.5*321
  8245   "RTN","RCD PEAR1",170 ,0)
  8246    .S Z=$$SE TSTR^VALM1 ("  "_$$FM TE^XLFDT($ P(RC0,U,4) ,2),Z,70,1 0)                  ;  PRCA*4.5* 321
  8247   "RTN","RCD PEAR1",171 ,0)
  8248    .D SL^RCD PEARL(Z,.R CLNCNT,RCT MPND)
  8249   "RTN","RCD PEAR1",172 ,0)
  8250    .I "23"[$ $ADJ^RCDPE U(RCFLIEN)  D SL^RCDP EARL($J("" ,9)_"** CL AIM LEVEL  ADJUSTMENT S EXIST FO R THIS ERA  ***",.RCL NCNT,RCTMP ND)
  8251   "RTN","RCD PEAR1",173 ,0)
  8252    .I $O(^RC Y(344.4,RC FLIEN,2,0) ) D  ; ERA  level adj ustments e xist
  8253   "RTN","RCD PEAR1",174 ,0)
  8254    ..N Q
  8255   "RTN","RCD PEAR1",175 ,0)
  8256    ..D DISPA DJ^RCDPESR 8(RCFLIEN, "^TMP("_$J _",""RCERA _ADJ"")")
  8257   "RTN","RCD PEAR1",176 ,0)
  8258    ..I $O(^T MP($J,"RCE RA_ADJ",0) ) D SL^RCD PEARL($J(" ",9)_"** G ENERAL ADJ USTMENT DA TA EXIST F OR THIS ER A **",.RCL NCNT,RCTMP ND)
  8259   "RTN","RCD PEAR1",177 ,0)
  8260    ..S Q=0 F   S Q=$O(^ TMP($J,"RC ERA_ADJ",Q )) Q:'Q  D  SL^RCDPEA RL($J("",9 )_$G(^TMP( $J,"RCERA_ ADJ",Q)),. RCLNCNT,RC TMPND)
  8261   "RTN","RCD PEAR1",178 ,0)
  8262    .;
  8263   "RTN","RCD PEAR1",179 ,0)
  8264    .N D,RCSF IEN S RCSF IEN=0  ; R CSFIEN - s ub-file ie n, RCSF0 -  zero node  of sub-fi le entry
  8265   "RTN","RCD PEAR1",180 ,0)
  8266    .F  S RCS FIEN=$O(^R CY(344.4,R CFLIEN,1,R CSFIEN)) Q :'RCSFIEN   S RCSF0=$ G(^(RCSFIE N,0)) D  Q :RCSTOP
  8267   "RTN","RCD PEAR1",181 ,0)
  8268    ..N RCDAT A,RCOUT  ;  set by RC DPESR0, RC DATA - mes sage data,  RCOUT - f ormatted m essage dis play
  8269   "RTN","RCD PEAR1",182 ,0)
  8270    ..I 'RCLS TMGR,$Y>(I OSL-RCHDR( 0)) D HDRL ST^RCDPEAR L(.RCSTOP, .RCHDR) Q: RCSTOP
  8271   "RTN","RCD PEAR1",183 ,0)
  8272    ..S D=$J( "",7)_" EE OB Seq #:  "_$P(RCSF0 ,U)_$S($D( ^RCY(344.4 ,RCFLIEN,1 ,"ATB",1,R CSFIEN)):"  (REVERSAL )",1:"")_"   EEOB "
  8273   "RTN","RCD PEAR1",184 ,0)
  8274    ..S D=D_$ S('$P(RCSF 0,U,2):"no t on file" ,1:"on fil e for "_$P ($G(^DGCR( 399,+$G(^I BM(361.1,+ $P(RCSF0,U ,2),0)),0) ),U))_"  " _$J(+$P(RC SF0,U,3)," ",2)
  8275   "RTN","RCD PEAR1",185 ,0)
  8276    ..D SL^RC DPEARL(D,. RCLNCNT,RC TMPND)
  8277   "RTN","RCD PEAR1",186 ,0)
  8278    ..Q:$P(RC SF0,U,2)
  8279   "RTN","RCD PEAR1",187 ,0)
  8280    ..D DISP^ RCDPESR0(" ^RCY(344.4 ,"_RCFLIEN _",1,"_RCS FIEN_",1)" ,"RCDATA", 1,"RCOUT", 68,1)
  8281   "RTN","RCD PEAR1",188 ,0)
  8282    ..I '$O(R COUT(0)) D  SL^RCDPEA RL($J("",9 )_" NO DET AIL FOUND" ,.RCLNCNT, RCTMPND) Q
  8283   "RTN","RCD PEAR1",189 ,0)
  8284    ..S Z=0 F   S Z=$O(R COUT(Z)) Q :'Z  D  Q: RCSTOP
  8285   "RTN","RCD PEAR1",190 ,0)
  8286    ...I 'RCD ISPTY,'RCL STMGR,$Y>( IOSL-RCHDR (0)) D HDR LST^RCDPEA RL(.RCSTOP ,.RCHDR) Q :RCSTOP
  8287   "RTN","RCD PEAR1",191 ,0)
  8288    ...D SL^R CDPEARL($J ("",9)_"*" _RCOUT(Z), .RCLNCNT,R CTMPND)
  8289   "RTN","RCD PEAR1",192 ,0)
  8290    ;
  8291   "RTN","RCD PEAR1",193 ,0)
  8292    ; PRCA*4. 5*298, put  end-of-re port into  SL^RCDPEAR L
  8293   "RTN","RCD PEAR1",194 ,0)
  8294    I 'RCSTOP  D SL^RCDP EARL(" ",. RCLNCNT,RC TMPND),SL^ RCDPEARL($ $ENDORPRT^ RCDPEARL,. RCLNCNT,RC TMPND)
  8295   "RTN","RCD PEAR1",195 ,0)
  8296    ;
  8297   "RTN","RCD PEAR1",196 ,0)
  8298   EXIT ;
  8299   "RTN","RCD PEAR1",197 ,0)
  8300    ; PRCA*4. 5*298, add ed ListMan  check
  8301   "RTN","RCD PEAR1",198 ,0)
  8302    I '$D(ZTQ UEUED),'RC LSTMGR D
  8303   "RTN","RCD PEAR1",199 ,0)
  8304    .I 'RCSTO P,RCPGNUM, RCTMPND=""  D ASK^RCD PEARL(.RCS TOP)
  8305   "RTN","RCD PEAR1",200 ,0)
  8306    .D ^%ZISC
  8307   "RTN","RCD PEAR1",201 ,0)
  8308    ;
  8309   "RTN","RCD PEAR1",202 ,0)
  8310    S:$D(ZTQU EUED) ZTRE Q="@"
  8311   "RTN","RCD PEAR1",203 ,0)
  8312    K ^TMP($J ,"RCERA_AG ED"),^TMP( "RCSELPAY" ,$J),^TMP( $J,"RC TOT AL")
  8313   "RTN","RCD PEAR1",204 ,0)
  8314    Q
  8315   "RTN","RCD PEAR1",205 ,0)
  8316    ;
  8317   "RTN","RCD PEAR1",206 ,0)
  8318   HDRBLD ; C reate the  report hea der
  8319   "RTN","RCD PEAR1",207 ,0)
  8320    ; Input:    RCDISPTY         -  1 - Output  to excel,  0 otherwi se
  8321   "RTN","RCD PEAR1",208 ,0)
  8322    ;           RCDTRNG          -  Date range  selected
  8323   "RTN","RCD PEAR1",209 ,0)
  8324    ;           RCXCLUDE         -  TRICARE /C HAMPVA fla gs
  8325   "RTN","RCD PEAR1",210 ,0)
  8326    ;           VAUTD            -  Divisions  to include  in report  (if liste d in VAUTD  array)
  8327   "RTN","RCD PEAR1",211 ,0)
  8328    ; Output:   RCHDR(0)         -  Header tex t line cou nt
  8329   "RTN","RCD PEAR1",212 ,0)
  8330    ;           RCHDR(1)         -  Excel colu mn data (o nly set If  DISPTY=1)
  8331   "RTN","RCD PEAR1",213 ,0)
  8332    ;           RCHDR("X ECUTE") -  M code for  page numb er
  8333   "RTN","RCD PEAR1",214 ,0)
  8334    ;           RCHDR("R UNDATE")-  Date/time  report gen erated, ex ternal for mat
  8335   "RTN","RCD PEAR1",215 ,0)
  8336    ;           RCPGNUM          -  Page count er
  8337   "RTN","RCD PEAR1",216 ,0)
  8338    ;           RCSTOP           -  Flag to ex it
  8339   "RTN","RCD PEAR1",217 ,0)
  8340    ;
  8341   "RTN","RCD PEAR1",218 ,0)
  8342    N CHATRI, DIV,HCNT,X X,Y
  8343   "RTN","RCD PEAR1",219 ,0)
  8344    K RCHDR
  8345   "RTN","RCD PEAR1",220 ,0)
  8346    S RCHDR(" RUNDATE")= $$NOW^RCDP EARL,RCPGN UM=0,RCSTO P=0
  8347   "RTN","RCD PEAR1",221 ,0)
  8348    I RCDISPT Y D  Q  ;  Excel form at, xecute  code is Q UIT, null  page numbe r
  8349   "RTN","RCD PEAR1",222 ,0)
  8350    . S RCHDR (0)=1,RCHD R("XECUTE" )="Q",RCPG NUM=""
  8351   "RTN","RCD PEAR1",223 ,0)
  8352    . S XX="A ged Days^T race #^Pay ment From/ ID^ERA Dat e^File Dat e^Amount P aid"
  8353   "RTN","RCD PEAR1",224 ,0)
  8354    . S XX=XX _"^EEOB Cn t^ERA #^EE OB Detail"
  8355   "RTN","RCD PEAR1",225 ,0)
  8356    . S RCHDR (1)=XX
  8357   "RTN","RCD PEAR1",226 ,0)
  8358    ;
  8359   "RTN","RCD PEAR1",227 ,0)
  8360    S XX="N Y  S RCPGNUM =RCPGNUM+1 ,Y=$$HDRNM ^"
  8361   "RTN","RCD PEAR1",228 ,0)
  8362    S XX=XX_$ T(+0)_",RC HDR(1)=$J( "" "",80-$ L(Y)\2)_Y" _"_""           Page:  ""_RCPGNU M"
  8363   "RTN","RCD PEAR1",229 ,0)
  8364    S RCHDR(" XECUTE")=X X
  8365   "RTN","RCD PEAR1",230 ,0)
  8366    S HCNT=1
  8367   "RTN","RCD PEAR1",231 ,0)
  8368    S Y="RUN  DATE: "_RC HDR("RUNDA TE"),HCNT= HCNT+1
  8369   "RTN","RCD PEAR1",232 ,0)
  8370    S RCHDR(H CNT)=$J("" ,80-$L(Y)\ 2)_Y
  8371   "RTN","RCD PEAR1",233 ,0)
  8372    ;
  8373   "RTN","RCD PEAR1",234 ,0)
  8374    ; divisio ns
  8375   "RTN","RCD PEAR1",235 ,0)
  8376    S Y="DIVI SIONS: "
  8377   "RTN","RCD PEAR1",236 ,0)
  8378    I $D(VAUT D)=1 S Y=Y _"ALL",Y=$ J("",80-$L (Y)\2)_Y,H CNT=HCNT+1 ,RCHDR(HCN T)=Y
  8379   "RTN","RCD PEAR1",237 ,0)
  8380    I $D(VAUT D)>1 D
  8381   "RTN","RCD PEAR1",238 ,0)
  8382    . N S,X S  S=0
  8383   "RTN","RCD PEAR1",239 ,0)
  8384    . F  S S= $O(VAUTD(S )) Q:'S  D
  8385   "RTN","RCD PEAR1",240 ,0)
  8386    . . S X=V AUTD(S)_$S ($O(VAUTD( S)):", ",1 :"")
  8387   "RTN","RCD PEAR1",241 ,0)
  8388    . . I $L( X)+$L(Y)>8 0 D
  8389   "RTN","RCD PEAR1",242 ,0)
  8390    . . . S H CNT=HCNT+1 ,RCHDR(HCN T)=$J("",8 0-$L(Y)\2) _Y,Y=$J("  ",12)
  8391   "RTN","RCD PEAR1",243 ,0)
  8392    . . S Y=Y _X
  8393   "RTN","RCD PEAR1",244 ,0)
  8394    . ;
  8395   "RTN","RCD PEAR1",245 ,0)
  8396    . S:$TR(Y ," ")]"" H CNT=HCNT+1 ,RCHDR(HCN T)=Y  ; an y residual  data
  8397   "RTN","RCD PEAR1",246 ,0)
  8398    ;
  8399   "RTN","RCD PEAR1",247 ,0)
  8400    ; Payers
  8401   "RTN","RCD PEAR1",248 ,0)
  8402    S Y="PAYE RS: "
  8403   "RTN","RCD PEAR1",249 ,0)
  8404    I $D(RCPA Y)=1 D
  8405   "RTN","RCD PEAR1",250 ,0)
  8406    . S Y=Y_R CPAY,Y=Y,H CNT=HCNT+1 ,RCHDR(HCN T)=$J("",8 0-$L(Y)\2) _Y
  8407   "RTN","RCD PEAR1",251 ,0)
  8408    I $D(RCPA Y)=10 D
  8409   "RTN","RCD PEAR1",252 ,0)
  8410    . N S,X
  8411   "RTN","RCD PEAR1",253 ,0)
  8412    . S S=0
  8413   "RTN","RCD PEAR1",254 ,0)
  8414    . F  S S= $O(RCPAY(S )) Q:'S  D
  8415   "RTN","RCD PEAR1",255 ,0)
  8416    . . S X=R CPAY(S)_$S ($O(RCPAY( S)):", ",1 :"")
  8417   "RTN","RCD PEAR1",256 ,0)
  8418    . . I $L( X)+$L(Y)>8 0 D
  8419   "RTN","RCD PEAR1",257 ,0)
  8420    . . . S H CNT=HCNT+1 ,RCHDR(HCN T)=$J("",8 0-$L(Y)\2) _Y,Y=$J("  ",8)
  8421   "RTN","RCD PEAR1",258 ,0)
  8422    . . S Y=Y _X
  8423   "RTN","RCD PEAR1",259 ,0)
  8424    . ;
  8425   "RTN","RCD PEAR1",260 ,0)
  8426    . S:$TR(Y ," ")]"" H CNT=HCNT+1 ,RCHDR(HCN T)=Y  ; an y residual  data
  8427   "RTN","RCD PEAR1",261 ,0)
  8428    ;
  8429   "RTN","RCD PEAR1",262 ,0)
  8430    S Y("1ST" )=$P(RCDTR NG,U,2),Y( "LST")=$P( RCDTRNG,U, 3)
  8431   "RTN","RCD PEAR1",263 ,0)
  8432    F Y="1ST" ,"LST" S Y (Y)=$$FMTE ^XLFDT(Y(Y ),"2Z")
  8433   "RTN","RCD PEAR1",264 ,0)
  8434    S Y="DATE  RANGE: "_ Y("1ST")_"  - "_Y("LS T")_" (ERA  FILE DATE )"
  8435   "RTN","RCD PEAR1",265 ,0)
  8436    S CHATRI= "" F J="CH AMPVA","TR ICARE" S Y =Y_"    "_ J_": "_$S( $G(RCXCLUD E(J)):"NO" ,1:"YES")
  8437   "RTN","RCD PEAR1",266 ,0)
  8438    S HCNT=HC NT+1,RCHDR (HCNT)=$J( "",80-$L(Y )\2)_Y
  8439   "RTN","RCD PEAR1",267 ,0)
  8440    ;
  8441   "RTN","RCD PEAR1",268 ,0)
  8442    S HCNT=HC NT+1,RCHDR (HCNT)=""
  8443   "RTN","RCD PEAR1",269 ,0)
  8444    S Y="AGED "
  8445   "RTN","RCD PEAR1",270 ,0)
  8446    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8447   "RTN","RCD PEAR1",271 ,0)
  8448    S Y="DAYS   TRACE #"
  8449   "RTN","RCD PEAR1",272 ,0)
  8450    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8451   "RTN","RCD PEAR1",273 ,0)
  8452    S Y="  PA YMENT FROM /ID" ; PRC A*4.5*321  - Allow ex tra room f or 60 char acter Paye r Name
  8453   "RTN","RCD PEAR1",274 ,0)
  8454    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8455   "RTN","RCD PEAR1",275 ,0)
  8456    S Y="                  FILE DAT E      AMO UNT PAID   EEOB CNT    ERA #            ERA  DATE"
  8457   "RTN","RCD PEAR1",276 ,0)
  8458    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8459   "RTN","RCD PEAR1",277 ,0)
  8460    S Y="",$P (Y,"=",80) ="",HCNT=H CNT+1,RCHD R(HCNT)=Y
  8461   "RTN","RCD PEAR1",278 ,0)
  8462    S RCHDR(0 )=HCNT  ;  total line s in heade r
  8463   "RTN","RCD PEAR1",279 ,0)
  8464    Q
  8465   "RTN","RCD PEAR1",280 ,0)
  8466    ;
  8467   "RTN","RCD PEAR1",281 ,0)
  8468   HDRLM ; Cr eate the l ist manage r version  of the rep ort header
  8469   "RTN","RCD PEAR1",282 ,0)
  8470    ; Input:    RCDTRNG      - Date  range fil ter value  to be prin ted as par t of the
  8471   "RTN","RCD PEAR1",283 ,0)
  8472    ;                          head er
  8473   "RTN","RCD PEAR1",284 ,0)
  8474    ;           RCPAY        - 1 -  All Payers
  8475   "RTN","RCD PEAR1",285 ,0)
  8476    ;                          2 -  Selected P ayers
  8477   "RTN","RCD PEAR1",286 ,0)
  8478    ;           RCPAY()      - Arra y of selec ted Payers  if RCPAY= 2
  8479   "RTN","RCD PEAR1",287 ,0)
  8480    ;           RCLSTMGR     -
  8481   "RTN","RCD PEAR1",288 ,0)
  8482    ;           VAUTD        - 1 -  All divisi ons
  8483   "RTN","RCD PEAR1",289 ,0)
  8484    ;                          2 -  Selected d ivisions
  8485   "RTN","RCD PEAR1",290 ,0)
  8486    ;           VAUTD()      - Arra y of selec ted divisi ons (if VA UTD=2)
  8487   "RTN","RCD PEAR1",291 ,0)
  8488    ; Output:   RCHDR(0)     - Head er text li ne count
  8489   "RTN","RCD PEAR1",292 ,0)
  8490    ;
  8491   "RTN","RCD PEAR1",293 ,0)
  8492    N DATE,DI V,HCNT,MSG ,Y,Z0
  8493   "RTN","RCD PEAR1",294 ,0)
  8494    K RCHDR
  8495   "RTN","RCD PEAR1",295 ,0)
  8496    S Z0="",R CPGNUM=0,R CSTOP=0
  8497   "RTN","RCD PEAR1",296 ,0)
  8498    S RCHDR(1 )="DATE RA NGE: "_$$F MTE^XLFDT( $P(RCDTRNG ,U,2),"2Z" )
  8499   "RTN","RCD PEAR1",297 ,0)
  8500    S RCHDR(1 )=RCHDR(1) _" - "_$$F MTE^XLFDT( $P(RCDTRNG ,U,3),"2Z" )_" (ERA F ILE DATE)"
  8501   "RTN","RCD PEAR1",298 ,0)
  8502    S RCHDR(1 )=RCHDR(1) _"    TRIC ARE: "_$S( $G(RCXCLUD E("TRICARE ")):"NO",1 :"YES")
  8503   "RTN","RCD PEAR1",299 ,0)
  8504    S RCHDR(1 )=RCHDR(1) _"    CHAM PVA: "_$S( $G(RCXCLUD E("CHAMPVA ")):"NO",1 :"YES")
  8505   "RTN","RCD PEAR1",300 ,0)
  8506    S HCNT=1
  8507   "RTN","RCD PEAR1",301 ,0)
  8508    ;
  8509   "RTN","RCD PEAR1",302 ,0)
  8510    S Y="DIVI SIONS: "
  8511   "RTN","RCD PEAR1",303 ,0)
  8512    I $D(VAUT D)=1 S Y=Y _"ALL",HCN T=HCNT+1,R CHDR(HCNT) =Y
  8513   "RTN","RCD PEAR1",304 ,0)
  8514    I $D(VAUT D)>1 D
  8515   "RTN","RCD PEAR1",305 ,0)
  8516    . N S,X
  8517   "RTN","RCD PEAR1",306 ,0)
  8518    . S S=0
  8519   "RTN","RCD PEAR1",307 ,0)
  8520    . F  S S= $O(VAUTD(S )) Q:'S  D
  8521   "RTN","RCD PEAR1",308 ,0)
  8522    . . S X=V AUTD(S)_$S ($O(VAUTD( S)):", ",1 :"")
  8523   "RTN","RCD PEAR1",309 ,0)
  8524    . . I $L( X)+$L(Y)>8 0 S HCNT=H CNT+1,RCHD R(HCNT)=Y, Y=$J(" ",1 2)
  8525   "RTN","RCD PEAR1",310 ,0)
  8526    . . S Y=Y _X
  8527   "RTN","RCD PEAR1",311 ,0)
  8528    .;
  8529   "RTN","RCD PEAR1",312 ,0)
  8530    .S:$TR(Y, " ")]"" HC NT=HCNT+1, RCHDR(HCNT )=Y  ; any  residual  data
  8531   "RTN","RCD PEAR1",313 ,0)
  8532    ;
  8533   "RTN","RCD PEAR1",314 ,0)
  8534    ; Payers
  8535   "RTN","RCD PEAR1",315 ,0)
  8536    S Y="PAYE RS: "
  8537   "RTN","RCD PEAR1",316 ,0)
  8538    I $D(RCPA Y)=1 D 
  8539   "RTN","RCD PEAR1",317 ,0)
  8540    . S Y=Y_R CPAY,HCNT= HCNT+1,RCH DR(HCNT)=Y
  8541   "RTN","RCD PEAR1",318 ,0)
  8542    I $D(RCPA Y)=10 D
  8543   "RTN","RCD PEAR1",319 ,0)
  8544    . N S,X S  S=0 F  S  S=$O(RCPAY (S)) Q:'S   D
  8545   "RTN","RCD PEAR1",320 ,0)
  8546    . . S X=R CPAY(S)_$S ($O(RCPAY( S)):", ",1 :"")
  8547   "RTN","RCD PEAR1",321 ,0)
  8548    . . I $L( X)+$L(Y)>8 0 S HCNT=H CNT+1,RCHD R(HCNT)=Y, Y=$J(" ",8 )
  8549   "RTN","RCD PEAR1",322 ,0)
  8550    . . S Y=Y _X
  8551   "RTN","RCD PEAR1",323 ,0)
  8552    . ;
  8553   "RTN","RCD PEAR1",324 ,0)
  8554    . S:$TR(Y ," ")]"" H CNT=HCNT+1 ,RCHDR(HCN T)=Y  ; an y residual  data
  8555   "RTN","RCD PEAR1",325 ,0)
  8556    ;
  8557   "RTN","RCD PEAR1",326 ,0)
  8558    S Y="AGED "
  8559   "RTN","RCD PEAR1",327 ,0)
  8560    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8561   "RTN","RCD PEAR1",328 ,0)
  8562    S Y="DAYS   TRACE #"
  8563   "RTN","RCD PEAR1",329 ,0)
  8564    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8565   "RTN","RCD PEAR1",330 ,0)
  8566    S Y="  PA YMENT FROM /ID" ; PRC A*4.5*321  - Allow ex tra room f or 60 char acter Paye r Name
  8567   "RTN","RCD PEAR1",331 ,0)
  8568    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8569   "RTN","RCD PEAR1",332 ,0)
  8570    S Y="                  FILE DAT E      AMO UNT PAID   EEOB CNT    ERA #            ERA  DATE"
  8571   "RTN","RCD PEAR1",333 ,0)
  8572    S HCNT=HC NT+1,RCHDR (HCNT)=Y
  8573   "RTN","RCD PEAR1",334 ,0)
  8574    S RCHDR(0 )=HCNT  ;  total line s in heade r
  8575   "RTN","RCD PEAR1",335 ,0)
  8576    Q
  8577   "RTN","RCD PEAR1",336 ,0)
  8578    ; extrins ic variabl e, name fo r header P RCA*4.5*29 8
  8579   "RTN","RCD PEAR1",337 ,0)
  8580   HDRNM() Q  "ERA UNMAT CHED AGING  REPORT"
  8581   "RTN","RCD PEAR1",338 ,0)
  8582    ;
  8583   "RTN","RCD PEAR1",339 ,0)
  8584   EXCEL ; Pr int report  to screen , one reco rd per lin e for expo rt to MS E xcel.
  8585   "RTN","RCD PEAR1",340 ,0)
  8586    N D,RCSF0 ,RC1ST,RCE XCEP,RCFLI EN,RCLN,RC SFIEN,RCZ, Z
  8587   "RTN","RCD PEAR1",341 ,0)
  8588    ; RCSFIEN  - sub-fil e ien
  8589   "RTN","RCD PEAR1",342 ,0)
  8590    D HDRLST^ RCDPEARL(. RCSTOP,.RC HDR)
  8591   "RTN","RCD PEAR1",343 ,0)
  8592    S RCZ=""  F  S RCZ=$ O(^TMP($J, "RCERA_AGE D",RCZ)) Q :RCZ=""  S  RCFLIEN=0  F  S RCFL IEN=$O(^TM P($J,"RCER A_AGED",RC Z,RCFLIEN) ) Q:'RCFLI EN  D  G:R CSTOP PRTQ 2
  8593   "RTN","RCD PEAR1",344 ,0)
  8594    .I $D(ZTQ UEUED),$$S ^%ZTLOAD S  (RCSTOP,Z TSTOP)=1 K  ZTREQ I + $G(RCPGNUM ) W:RCTMPN D="" !!,"* **TASK STO PPED BY US ER***" Q
  8595   "RTN","RCD PEAR1",345 ,0)
  8596    .S RC0=$G (^RCY(344. 4,RCFLIEN, 0))
  8597   "RTN","RCD PEAR1",346 ,0)
  8598    .S RCEXCE P=$$XCEPT^ RCDPEWLP(R CFLIEN)  ;  PRCA*4.5* 298  assig nment of E RA excepti on flag (w ill either  be "" or  "x")
  8599   "RTN","RCD PEAR1",347 ,0)
  8600    .S Z=$J(R CEXCEP_-RC Z,4)_U_$P( RC0,U,2)_U _$P(RC0,U, 6)_"/"_$P( RC0,U,3)_U _$$FMTE^XL FDT($P(RC0 ,U,4),2)_U _$$FMTE^XL FDT($P(RC0 ,U,7),2)_U    ;PRCA*4 .5*298 dis play ERA e xception f lag
  8601   "RTN","RCD PEAR1",348 ,0)
  8602    .S Z=Z_$P (RC0,U,5)_ U_$P(RC0,U ,11)_U_$P( RC0,U)
  8603   "RTN","RCD PEAR1",349 ,0)
  8604    .W !,Z
  8605   "RTN","RCD PEAR1",350 ,0)
  8606    .S RCLN=Z ,RC1ST=0
  8607   "RTN","RCD PEAR1",351 ,0)
  8608    .K Z
  8609   "RTN","RCD PEAR1",352 ,0)
  8610    .I "23"[$ $ADJ^RCDPE U(RCFLIEN)  D LSTXCEL  W "^** CL AIM LEVEL  ADJUSTMENT S EXIST FO R THIS ERA  ***"
  8611   "RTN","RCD PEAR1",353 ,0)
  8612    .I $O(^RC Y(344.4,RC FLIEN,2,0) ) D  ; ERA  level adj ustments e xist
  8613   "RTN","RCD PEAR1",354 ,0)
  8614    ..N Q
  8615   "RTN","RCD PEAR1",355 ,0)
  8616    ..D DISPA DJ^RCDPESR 8(RCFLIEN, "^TMP("_$J _",""RCERA _ADJ"")")
  8617   "RTN","RCD PEAR1",356 ,0)
  8618    ..I $O(^T MP($J,"RCE RA_ADJ",0) ) D LSTXCE L W "^** G ENERAL ADJ USTMENT DA TA EXISTS  FOR ERA ** "
  8619   "RTN","RCD PEAR1",357 ,0)
  8620    ..S Q=0 F   S Q=$O(^ TMP($J,"RC ERA_ADJ",Q )) Q:'Q  D  LSTXCEL W  "^"_$G(^T MP($J,"RCE RA_ADJ",Q) )
  8621   "RTN","RCD PEAR1",358 ,0)
  8622    .;
  8623   "RTN","RCD PEAR1",359 ,0)
  8624    .S RCSFIE N=0 F  S R CSFIEN=$O( ^RCY(344.4 ,RCFLIEN,1 ,RCSFIEN))  Q:'RCSFIE N  S RCSF0 =$G(^(RCSF IEN,0)) D   Q:RCSTOP
  8625   "RTN","RCD PEAR1",360 ,0)
  8626    ..N D
  8627   "RTN","RCD PEAR1",361 ,0)
  8628    ..K RCOUT
  8629   "RTN","RCD PEAR1",362 ,0)
  8630    ..S D=" E EOB Seq #:  "_$P(RCSF 0,U)_$S($D (^RCY(344. 4,RCFLIEN, 1,"ATB",1, RCSFIEN)): " (REVERSA L)",1:"")_ "  EEOB "
  8631   "RTN","RCD PEAR1",363 ,0)
  8632    ..S D=D_$ S('$P(RCSF 0,U,2):"no t on file" ,1:"on fil e for "_$P ($G(^DGCR( 399,+$G(^I BM(361.1,+ $P(RCSF0,U ,2),0)),0) ),U))_"  " _$J(+$P(RC SF0,U,3)," ",2)
  8633   "RTN","RCD PEAR1",364 ,0)
  8634    ..D LSTXC EL W "^",D
  8635   "RTN","RCD PEAR1",365 ,0)
  8636    ..Q:$P(RC SF0,U,2)
  8637   "RTN","RCD PEAR1",366 ,0)
  8638    ..D DISP^ RCDPESR0(" ^RCY(344.4 ,"_RCFLIEN _",1,"_RCS FIEN_",1)" ,"RCDATA", 1,"RCOUT", 68,1)
  8639   "RTN","RCD PEAR1",367 ,0)
  8640    ..I '$O(R COUT(0)) D  LSTXCEL W  "^NO DETA IL FOUND"  Q
  8641   "RTN","RCD PEAR1",368 ,0)
  8642    ..S Z=0 F   S Z=$O(R COUT(Z)) Q :'Z  D  Q: RCSTOP
  8643   "RTN","RCD PEAR1",369 ,0)
  8644    ...D LSTX CEL W "^*" _RCOUT(Z)
  8645   "RTN","RCD PEAR1",370 ,0)
  8646    ;
  8647   "RTN","RCD PEAR1",371 ,0)
  8648    W !!,$$EN DORPRT^RCD PEARL
  8649   "RTN","RCD PEAR1",372 ,0)
  8650    Q
  8651   "RTN","RCD PEAR1",373 ,0)
  8652    ;
  8653   "RTN","RCD PEAR1",374 ,0)
  8654   LSTXCEL ;  Display re peat info  line befor e each EEO B detail s ection.
  8655   "RTN","RCD PEAR1",375 ,0)
  8656    ; First d etail line  does not  need it
  8657   "RTN","RCD PEAR1",376 ,0)
  8658    I RC1ST W  !,RCLN Q
  8659   "RTN","RCD PEAR1",377 ,0)
  8660    S RC1ST=1  Q
  8661   "RTN","RCD PEAR1",378 ,0)
  8662    ;
  8663   "RTN","RCD PEAR1",379 ,0)
  8664   PRTQ2 I '$ D(ZTQUEUED ),'RCSTOP, RCPGNUM,RC TMPND="" D  ASK^RCDPE ARL(.RCSTO P)
  8665   "RTN","RCD PEAR1",380 ,0)
  8666    I $D(ZTQU EUED) S ZT REQ="@"
  8667   "RTN","RCD PEAR1",381 ,0)
  8668    I '$D(ZTQ UEUED) D ^ %ZISC
  8669   "RTN","RCD PEAR1",382 ,0)
  8670    K ^TMP($J ,"RCEFT_AG ED")
  8671   "RTN","RCD PEAR1",383 ,0)
  8672    Q
  8673   "RTN","RCD PEAR1",384 ,0)
  8674    ;
  8675   "RTN","RCD PEAR1",385 ,0)
  8676   ZROBAL() ;  function,  Get Zero  Payment Fi lter
  8677   "RTN","RCD PEAR1",386 ,0)
  8678    ; returns  1 for yes , zero for  no, -1 on  '^' or ti meout
  8679   "RTN","RCD PEAR1",387 ,0)
  8680    N DIR,DIR UT,DTOUT,D UOUT,X,Y
  8681   "RTN","RCD PEAR1",388 ,0)
  8682    S DIR(0)= "YA",DIR(" A")="Inclu de Zero pa yment amou nts? (Y/N) : ",DIR("B ")="YES"
  8683   "RTN","RCD PEAR1",389 ,0)
  8684    D ^DIR
  8685   "RTN","RCD PEAR1",390 ,0)
  8686    I $D(DUOU T)!$D(DIRU T)!$D(DTOU T) S Y=-1
  8687   "RTN","RCD PEAR1",391 ,0)
  8688    Q Y
  8689   "RTN","RCD PEAR2")
  8690   0^27^B1115 29501
  8691   "RTN","RCD PEAR2",1,0 )
  8692   RCDPEAR2 ; ALB/TMK/PJ H - EFT Un matched Ag ing Report  - FILE 34 4.3 ;Nov 2 4, 2014@18 :31:57
  8693   "RTN","RCD PEAR2",2,0 )
  8694    ;;4.5;Acc ounts Rece ivable;**1 73,269,276 ,284,283,2 93,298,318 ,321**;Mar  20, 1995; Build 46
  8695   "RTN","RCD PEAR2",3,0 )
  8696    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  8697   "RTN","RCD PEAR2",4,0 )
  8698    Q
  8699   "RTN","RCD PEAR2",5,0 )
  8700    ;
  8701   "RTN","RCD PEAR2",6,0 )
  8702    ; PRCA*4. 5*298 note s at botto m
  8703   "RTN","RCD PEAR2",7,0 )
  8704   EN1 ; opti on: EFT Un matched Ag ing Report  [RCDPE EF T AGING RE PORT]
  8705   "RTN","RCD PEAR2",8,0 )
  8706    N %ZIS,DI C,DIR,DTOU T,DUOUT,PO P,RCDISPTY ,RCDTRNG,R CEND,RCHDR ,RCJOB
  8707   "RTN","RCD PEAR2",9,0 )
  8708    N RCJOB1, RCLSTMGR,R CNP,RCPYRL ST,RCPGNUM ,RCSTART,R CTMPND,X,Y
  8709   "RTN","RCD PEAR2",10, 0)
  8710    ; RCDISPT Y = displa y type
  8711   "RTN","RCD PEAR2",11, 0)
  8712    ; RCEND =  end date
  8713   "RTN","RCD PEAR2",12, 0)
  8714    ; RCLSTMG R = list m anager fla g
  8715   "RTN","RCD PEAR2",13, 0)
  8716    ; RCNP =  payer info : "1^first  payer^las t payer" o r "2^^" (f or all)
  8717   "RTN","RCD PEAR2",14, 0)
  8718    ; RCPYRLS T - payer  list for s elected pa yers
  8719   "RTN","RCD PEAR2",15, 0)
  8720    ; RCDTRNG = "1^start  date^end  date"
  8721   "RTN","RCD PEAR2",16, 0)
  8722    ; RCSTART  = start d ate
  8723   "RTN","RCD PEAR2",17, 0)
  8724    ; RCTMPND  = name of  the subsc ript for ^ TMP to use
  8725   "RTN","RCD PEAR2",18, 0)
  8726    ;
  8727   "RTN","RCD PEAR2",19, 0)
  8728    S RCLSTMG R=""  ; in itial valu e
  8729   "RTN","RCD PEAR2",20, 0)
  8730    S RCDTRNG =$$DTRNG^R CDPEM4() G :'(RCDTRNG >0) EN1Q
  8731   "RTN","RCD PEAR2",21, 0)
  8732    S RCSTART =$P(RCDTRN G,U,2)-1,R CEND=$P(RC DTRNG,U,3)
  8733   "RTN","RCD PEAR2",22, 0)
  8734    ;Get insu rance comp any to be  used as fi lter
  8735   "RTN","RCD PEAR2",23, 0)
  8736    ; PRCA*4. 5*284 - RC NP (Type o f Response (1=Range,2 =All,3=Spe cific)^Fro m name^To  name)
  8737   "RTN","RCD PEAR2",24, 0)
  8738    S RCNP=$$ GETPAY^RCD PEM9(344.3 1) G:RCNP< 0 EN1Q
  8739   "RTN","RCD PEAR2",25, 0)
  8740    ;Get disp lay type
  8741   "RTN","RCD PEAR2",26, 0)
  8742    S RCDISPT Y=$$DISPTY ^RCDPEM3()  G:RCDISPT Y<0 EN1Q
  8743   "RTN","RCD PEAR2",27, 0)
  8744    ; display  device in fo about E xcel forma t, set Lis tMan flag  to prevent  question
  8745   "RTN","RCD PEAR2",28, 0)
  8746    I RCDISPT Y S RCLSTM GR="^" D I NFO^RCDPEM 6
  8747   "RTN","RCD PEAR2",29, 0)
  8748    I $D(DUOU T)!$D(DTOU T) G EN1Q
  8749   "RTN","RCD PEAR2",30, 0)
  8750    S RCJOB=$ J  ; neede d in RPTOU T
  8751   "RTN","RCD PEAR2",31, 0)
  8752    ;
  8753   "RTN","RCD PEAR2",32, 0)
  8754    ; if not  output to  Excel ask  for ListMa n display,  exit if t imeout or  '^' - PRCA *4.5*298
  8755   "RTN","RCD PEAR2",33, 0)
  8756    I RCLSTMG R="" S RCL STMGR=$$AS KLM^RCDPEA RL I RCLST MGR<0 G EN 1Q
  8757   "RTN","RCD PEAR2",34, 0)
  8758    ; display  in ListMa n format a nd exit on  return
  8759   "RTN","RCD PEAR2",35, 0)
  8760    I RCLSTMG R D  G EN1 Q
  8761   "RTN","RCD PEAR2",36, 0)
  8762    .S RCTMPN D=$T(+0)_" ^EFT UNMAT CHED AGING "  K ^TMP( $J,RCTMPND )  ; clean  any resid ue
  8763   "RTN","RCD PEAR2",37, 0)
  8764    .D RPTOUT
  8765   "RTN","RCD PEAR2",38, 0)
  8766    .N H,L,HD R S L=0
  8767   "RTN","RCD PEAR2",39, 0)
  8768    .S HDR("T ITLE")=$$H DRNM
  8769   "RTN","RCD PEAR2",40, 0)
  8770    .F H=1:1: 7 I $D(RCH DR(H)) S L =H,HDR(H)= RCHDR(H)   ; take fir st 3 lines  of report  header
  8771   "RTN","RCD PEAR2",41, 0)
  8772    .I $O(RCH DR(L)) D   ; any rema ining head er lines a t top of r eport
  8773   "RTN","RCD PEAR2",42, 0)
  8774    ..N N S N =0,H=L F   S H=$O(RCH DR(H)) Q:' H  S N=N+. 001,^TMP($ J,RCTMPND, N)=RCHDR(H )
  8775   "RTN","RCD PEAR2",43, 0)
  8776    .D LMRPT^ RCDPEARL(. HDR,$NA(^T MP($J,RCTM PND))) ; g enerate Li stMan disp lay
  8777   "RTN","RCD PEAR2",44, 0)
  8778    ;
  8779   "RTN","RCD PEAR2",45, 0)
  8780    S RCJOB=$ J,RCTMPND= ""
  8781   "RTN","RCD PEAR2",46, 0)
  8782    ; Ask dev ice
  8783   "RTN","RCD PEAR2",47, 0)
  8784    S %ZIS="Q M" D ^%ZIS  G:POP EN1 Q
  8785   "RTN","RCD PEAR2",48, 0)
  8786    I $D(IO(" Q")) D  G  EN1Q
  8787   "RTN","RCD PEAR2",49, 0)
  8788    .N ZTDESC ,ZTRTN,ZTS AVE,ZTSTOP
  8789   "RTN","RCD PEAR2",50, 0)
  8790    .S ZTRTN= "RPTOUT^RC DPEAR2",ZT DESC="EFT  AGING REPO RT"
  8791   "RTN","RCD PEAR2",51, 0)
  8792    .S ZTSAVE ("RC*")="" ,ZTSAVE("V AUTD")=""
  8793   "RTN","RCD PEAR2",52, 0)
  8794    .; PRCA*4 .5*284 - B ecause TMP  global ma y be on an other serv er, save o ff specifi c payers i n local
  8795   "RTN","RCD PEAR2",53, 0)
  8796    .I +RCNP= 3 M RCPYRL ST=^TMP("R CSELPAY",$ J)
  8797   "RTN","RCD PEAR2",54, 0)
  8798    .D ^%ZTLO AD
  8799   "RTN","RCD PEAR2",55, 0)
  8800    .W !!,$S( $G(ZTSK):" Task numbe r "_ZTSK_"  has been  queued.",1 :"Unable t o queue th is task.")
  8801   "RTN","RCD PEAR2",56, 0)
  8802    .K ZTSK,I O("Q") D H OME^%ZIS
  8803   "RTN","RCD PEAR2",57, 0)
  8804    ;
  8805   "RTN","RCD PEAR2",58, 0)
  8806    U IO D RP TOUT
  8807   "RTN","RCD PEAR2",59, 0)
  8808    ;
  8809   "RTN","RCD PEAR2",60, 0)
  8810   EN1Q ; exi t and clea n up
  8811   "RTN","RCD PEAR2",61, 0)
  8812    I 'RCLSTM GR D ^%ZIS C
  8813   "RTN","RCD PEAR2",62, 0)
  8814    K ^TMP("R CSELPAY",$ J),^TMP("R CPAYER",$J )
  8815   "RTN","RCD PEAR2",63, 0)
  8816    Q
  8817   "RTN","RCD PEAR2",64, 0)
  8818    ;
  8819   "RTN","RCD PEAR2",65, 0)
  8820   RPTOUT ; E ntry point  for queue d job, nig htly job
  8821   "RTN","RCD PEAR2",66, 0)
  8822    ; RCTMPND  = name of  the subsc ript for ^ TMP to use  to return  all lines
  8823   "RTN","RCD PEAR2",67, 0)
  8824    ;          If undefi ned or nul l, output  is printed
  8825   "RTN","RCD PEAR2",68, 0)
  8826    ; Return  global if  RCTMPND no t null: ^T MP($J,RCTM PND,line#) =line text
  8827   "RTN","RCD PEAR2",69, 0)
  8828    N DIC,DUO UT,RC0,RC1 3,RC3443,R CCT,RCIEN, RCNT,RCOUT ,RCPAY,RCP AYER,RCPAY ID
  8829   "RTN","RCD PEAR2",70, 0)
  8830    N RCSTOP, RCTOT,RCZ, X,XX,YY,Z, Z0,ZZ
  8831   "RTN","RCD PEAR2",71, 0)
  8832    S RCTMPND =$G(RCTMPN D)
  8833   "RTN","RCD PEAR2",72, 0)
  8834    S (RCCT,R CSTOP,RCNT ,RCTOT)=0
  8835   "RTN","RCD PEAR2",73, 0)
  8836    K ^TMP($J ,"RCERA_AG ED"),^TMP( $J,"RCERA_ ADJ")
  8837   "RTN","RCD PEAR2",74, 0)
  8838    ; PRCA*4. 5*284 - Qu eued job n eeds to re load payer  selection  list
  8839   "RTN","RCD PEAR2",75, 0)
  8840    I $G(RCJO B)'="",RCJ OB'=$J D
  8841   "RTN","RCD PEAR2",76, 0)
  8842    .K ^TMP(" RCSELPAY", $J)
  8843   "RTN","RCD PEAR2",77, 0)
  8844    .D RLOAD^ RCDPEAR3(3 44.31)
  8845   "RTN","RCD PEAR2",78, 0)
  8846    .S RCJOB= $J
  8847   "RTN","RCD PEAR2",79, 0)
  8848    ; build l ocal payer  array her e
  8849   "RTN","RCD PEAR2",80, 0)
  8850    S RCNP=+R CNP
  8851   "RTN","RCD PEAR2",81, 0)
  8852    D SELPAY^ RCDPEAR3(R CNP,RCJOB, .RCPAY)
  8853   "RTN","RCD PEAR2",82, 0)
  8854    I RCTMPND '="" K ^TM P($J,RCTMP ND)
  8855   "RTN","RCD PEAR2",83, 0)
  8856    ; cross-r ef on file  #344.31 f ield #.08  - MATCH ST ATUS
  8857   "RTN","RCD PEAR2",84, 0)
  8858    S RCIEN=0  F  S RCIE N=$O(^RCY( 344.31,"AM ATCH",0,RC IEN)) Q:'R CIEN  D    ;unmatched  entries o nly
  8859   "RTN","RCD PEAR2",85, 0)
  8860    .Q:$P($G( ^RCY(344.3 1,RCIEN,3) ),U)  ; EF T has been  removed
  8861   "RTN","RCD PEAR2",86, 0)
  8862    .Q:$P($G( ^RCY(344.3 1,RCIEN,0) ),U,7)=0   ; payment  of zero
  8863   "RTN","RCD PEAR2",87, 0)
  8864    .;
  8865   "RTN","RCD PEAR2",88, 0)
  8866    .S RC13=$ P($G(^RCY( 344.31,RCI EN,0)),U,1 3)  ; date  received
  8867   "RTN","RCD PEAR2",89, 0)
  8868    .; Check  for payer  match
  8869   "RTN","RCD PEAR2",90, 0)
  8870    .I '$$CHK PYR^RCDPED AR(RCIEN,0 ,RCJOB,RCN P) Q   ;PR CA*4.5*318  passed ex isting var iable RCNP
  8871   "RTN","RCD PEAR2",91, 0)
  8872    .; Check  date range
  8873   "RTN","RCD PEAR2",92, 0)
  8874    .Q:(RCSTA RT>RC13)!( RC13>RCEND )
  8875   "RTN","RCD PEAR2",93, 0)
  8876    .; Passed  all the f ilters - i nclude on  report
  8877   "RTN","RCD PEAR2",94, 0)
  8878    .S ^TMP($ J,"RCEFT_A GED",$$FMD IFF^XLFDT( RC13,DT),R CIEN)=0,RC NT=RCNT+1
  8879   "RTN","RCD PEAR2",95, 0)
  8880    ;
  8881   "RTN","RCD PEAR2",96, 0)
  8882    D:'RCLSTM GR HDRBLD   ; create  header
  8883   "RTN","RCD PEAR2",97, 0)
  8884    D:RCLSTMG R HDRLM  ;  create Li stman head er
  8885   "RTN","RCD PEAR2",98, 0)
  8886    ;
  8887   "RTN","RCD PEAR2",99, 0)
  8888    I RCDISPT Y D EXCEL  Q
  8889   "RTN","RCD PEAR2",100 ,0)
  8890    ;
  8891   "RTN","RCD PEAR2",101 ,0)
  8892    ; Find to tal amount  of EFTs
  8893   "RTN","RCD PEAR2",102 ,0)
  8894    S RCZ=""  F  S RCZ=$ O(^TMP($J, "RCEFT_AGE D",RCZ)) Q :RCZ=""  S  RCIEN=0 F   S RCIEN= $O(^TMP($J ,"RCEFT_AG ED",RCZ,RC IEN)) Q:'R CIEN  D  G :RCSTOP PR TQ
  8895   "RTN","RCD PEAR2",103 ,0)
  8896    .I $D(ZTQ UEUED),$$S ^%ZTLOAD S  (RCSTOP,Z TSTOP)=1 K  ZTREQ I + $G(RCPGNUM ) W:RCTMPN D="" !!,"* **TASK STO PPED BY US ER***" Q
  8897   "RTN","RCD PEAR2",104 ,0)
  8898    .S RC0=$G (^RCY(344. 31,RCIEN,0 )),RC3443= $G(^RCY(34 4.3,+RC0,0 ))
  8899   "RTN","RCD PEAR2",105 ,0)
  8900    .S RCTOT= RCTOT+$P(R C0,U,7)
  8901   "RTN","RCD PEAR2",106 ,0)
  8902    ;
  8903   "RTN","RCD PEAR2",107 ,0)
  8904    D:'RCLSTM GR HDRLST^ RCDPEARL(. RCSTOP,.RC HDR)  ; in itial repo rt header
  8905   "RTN","RCD PEAR2",108 ,0)
  8906    ;
  8907   "RTN","RCD PEAR2",109 ,0)
  8908    S Z=$$SET STR^VALM1( "Totals:", "",1,79)
  8909   "RTN","RCD PEAR2",110 ,0)
  8910    D SL^RCDP EARL(Z,.RC CT,RCTMPND )
  8911   "RTN","RCD PEAR2",111 ,0)
  8912    S Z=$$SET STR^VALM1( " Number A ged Electr onic EFT M essages Fo und: "_RCN T,"",1,79)
  8913   "RTN","RCD PEAR2",112 ,0)
  8914    D SL^RCDP EARL(Z,.RC CT,RCTMPND )
  8915   "RTN","RCD PEAR2",113 ,0)
  8916    S Z=$$SET STR^VALM1( " Amount A ged Electr onic EFT M essages Fo und: $"_$F N(+RCTOT," ,",2),"",1 ,79)
  8917   "RTN","RCD PEAR2",114 ,0)
  8918    D SL^RCDP EARL(Z,.RC CT,RCTMPND )
  8919   "RTN","RCD PEAR2",115 ,0)
  8920    D SL^RCDP EARL($TR($ J("",IOM), " ","="),. RCCT,RCTMP ND)
  8921   "RTN","RCD PEAR2",116 ,0)
  8922    ;
  8923   "RTN","RCD PEAR2",117 ,0)
  8924    S RCZ=""  F  S RCZ=$ O(^TMP($J, "RCEFT_AGE D",RCZ)) Q :RCZ=""  S  RCIEN=0 F   S RCIEN= $O(^TMP($J ,"RCEFT_AG ED",RCZ,RC IEN)) Q:'R CIEN  D  G :RCSTOP PR TQ
  8925   "RTN","RCD PEAR2",118 ,0)
  8926    .I $D(ZTQ UEUED),$$S ^%ZTLOAD S  (RCSTOP,Z TSTOP)=1 K  ZTREQ I + $G(RCPGNUM ) W:RCTMPN D="" !!,"* **TASK STO PPED BY US ER***" Q
  8927   "RTN","RCD PEAR2",119 ,0)
  8928    .I RCPGNU M D SL^RCD PEARL(" ", .RCCT,.RCT MPND) ; On  detail li st, skip l ine
  8929   "RTN","RCD PEAR2",120 ,0)
  8930    .I 'RCLST MGR,$Y>(IO SL-RCHDR(0 )) D HDRLS T^RCDPEARL (.RCSTOP,. RCHDR) Q:R CSTOP
  8931   "RTN","RCD PEAR2",121 ,0)
  8932    .S RC0=$G (^RCY(344. 31,RCIEN,0 )),RC3443= $G(^RCY(34 4.3,+RC0,0 ))
  8933   "RTN","RCD PEAR2",122 ,0)
  8934    .S RCTOT= RCTOT+$P(R C0,U,7)
  8935   "RTN","RCD PEAR2",123 ,0)
  8936    .S Z=$$SE TSTR^VALM1 ($J(-RCZ,4 ),"",1,4)
  8937   "RTN","RCD PEAR2",124 ,0)
  8938    .; PRCA*4 .5*318 mov ed deposit  date up a  row to gi ve more ro om for pay er/payer I D
  8939   "RTN","RCD PEAR2",125 ,0)
  8940    .S Z=$$SE TSTR^VALM1 ("  "_$P(R C0,U,4),Z, 5,52)  ;tr ace#
  8941   "RTN","RCD PEAR2",126 ,0)
  8942    .S Z=$$SE TSTR^VALM1 ($$FMTE^XL FDT($P(RC0 ,U,12),2), Z,73,8)  ;  deposit d ate
  8943   "RTN","RCD PEAR2",127 ,0)
  8944    .D SL^RCD PEARL(Z,.R CCT,RCTMPN D)
  8945   "RTN","RCD PEAR2",128 ,0)
  8946    .N RCPAY  S RCPAY=$P (RC0,U,2)  S:RCPAY=""  RCPAY="NO  PAYER NAM E RECEIVED " ; PRCA*4 .5*298
  8947   "RTN","RCD PEAR2",129 ,0)
  8948    .S RCPAYI D=$P(RC0,U ,3)                            ;  Payer ID     ;PRCA*4 .5*298
  8949   "RTN","RCD PEAR2",130 ,0)
  8950    .;PRCA*4. 5*318 dyna mically di splay paye r name/ID  based on l ength
  8951   "RTN","RCD PEAR2",131 ,0)
  8952    .S RCPAYE R=RCPAY_"/ "_RCPAYID
  8953   "RTN","RCD PEAR2",132 ,0)
  8954    .I $L(RCP AYER)>76 D
  8955   "RTN","RCD PEAR2",133 ,0)
  8956    . . S ZZ= $L(RCPAYER ,"/"),XX=$ P(RCPAYER, "/",1,ZZ-1 ),YY=$P(RC PAYER,"/", ZZ)
  8957   "RTN","RCD PEAR2",134 ,0)
  8958    . . S XX= $E(RCPAYER ,1,$L(XX)- ($L(RCPAYE R)-76)),RC PAYER=XX_" /"_YY
  8959   "RTN","RCD PEAR2",135 ,0)
  8960    .S Z=$$SE TSTR^VALM1 (RCPAYER," ",5,76) ;  PRCA*4.5*2 98             (payer /payer ID)
  8961   "RTN","RCD PEAR2",136 ,0)
  8962    .;S Z=$$S ETSTR^VALM 1("  "_$$F MTE^XLFDT( $P(RC0,U,1 2),2),Z,70 ,10)  ; de posit date
  8963   "RTN","RCD PEAR2",137 ,0)
  8964    .;end of  PRCA*4.5*3 18 display  change
  8965   "RTN","RCD PEAR2",138 ,0)
  8966    .D SL^RCD PEARL(Z,.R CCT,RCTMPN D)
  8967   "RTN","RCD PEAR2",139 ,0)
  8968    .S Z=$$SE TSTR^VALM1 ($J("",6)_ $S($P(RC0, U,13):$$FM TE^XLFDT($ P(RC0,U,13 ),2),1:"") ,"",1,17)
  8969   "RTN","RCD PEAR2",140 ,0)
  8970    .S Z=$$SE TSTR^VALM1 ("  "_$J($ P(RC0,U,7) ,15,2),Z,1 8,17)
  8971   "RTN","RCD PEAR2",141 ,0)
  8972    .; PRCA*4 .5*283 - c hange leng th from 8  to 11 to a llow for 9  digit DEP  #'s
  8973   "RTN","RCD PEAR2",142 ,0)
  8974    .S Z=$$SE TSTR^VALM1 ("  "_$P(R C3443,U,6) ,Z,35,11)
  8975   "RTN","RCD PEAR2",143 ,0)
  8976    .S Z=$$SE TSTR^VALM1 ("  "_$S($ P(RC3443,U ,12):"",1: "NOT ")_"P osted to 8 NZZ"_$S($P (RC3443,U, 12):" "_$$ FMTE^XLFDT ($P(RC3443 ,U,11),2), 1:""),Z,47 ,36)
  8977   "RTN","RCD PEAR2",144 ,0)
  8978    .D SL^RCD PEARL(Z,.R CCT,RCTMPN D)
  8979   "RTN","RCD PEAR2",145 ,0)
  8980    .K RCOUT
  8981   "RTN","RCD PEAR2",146 ,0)
  8982    .D GETS^D IQ(344.31, RCIEN_",", 2,"E","RCO UT")
  8983   "RTN","RCD PEAR2",147 ,0)
  8984    .Q:'$O(RC OUT(344.31 ,RCIEN_"," ,2,0))
  8985   "RTN","RCD PEAR2",148 ,0)
  8986    .D SL^RCD PEARL($J(" ",8)_"--EX CEPTION NO TES--",.RC CT,RCTMPND )
  8987   "RTN","RCD PEAR2",149 ,0)
  8988    .S Z=0 F   S Z=$O(RC OUT(344.31 ,RCIEN_"," ,2,Z)) Q:' Z  D  Q:RC STOP
  8989   "RTN","RCD PEAR2",150 ,0)
  8990    ..I 'RCLS TMGR,$Y>(I OSL-RCHDR( 0)) D HDRL ST^RCDPEAR L(.RCSTOP, .RCHDR) Q: RCSTOP
  8991   "RTN","RCD PEAR2",151 ,0)
  8992    ..D SL^RC DPEARL($J( "",8)_" "_ RCOUT(344. 31,RCIEN_" ,",2,Z),.R CCT,RCTMPN D)
  8993   "RTN","RCD PEAR2",152 ,0)
  8994    ;
  8995   "RTN","RCD PEAR2",153 ,0)
  8996    ;
  8997   "RTN","RCD PEAR2",154 ,0)
  8998    ; PRCA*4. 5*298, put  end-of-re port into  SL^RCDPEAR L
  8999   "RTN","RCD PEAR2",155 ,0)
  9000    D SL^RCDP EARL(" ",. RCCT,RCTMP ND)  ; ski p a line
  9001   "RTN","RCD PEAR2",156 ,0)
  9002    D SL^RCDP EARL($$END ORPRT^RCDP EARL,.RCCT ,RCTMPND)
  9003   "RTN","RCD PEAR2",157 ,0)
  9004    ;
  9005   "RTN","RCD PEAR2",158 ,0)
  9006   PRTQ ;
  9007   "RTN","RCD PEAR2",159 ,0)
  9008    ; PRCA*4. 5*298, add ed ListMan  check
  9009   "RTN","RCD PEAR2",160 ,0)
  9010    I '$D(ZTQ UEUED),'RC LSTMGR,'RC STOP D ASK ^RCDPEARL( .RCSTOP)
  9011   "RTN","RCD PEAR2",161 ,0)
  9012    I $D(ZTQU EUED) S ZT REQ="@"
  9013   "RTN","RCD PEAR2",162 ,0)
  9014    I '$D(ZTQ UEUED) D ^ %ZISC
  9015   "RTN","RCD PEAR2",163 ,0)
  9016    K ^TMP($J ,"RCEFT_AG ED"),ZTQUE UED
  9017   "RTN","RCD PEAR2",164 ,0)
  9018    Q
  9019   "RTN","RCD PEAR2",165 ,0)
  9020    ;
  9021   "RTN","RCD PEAR2",166 ,0)
  9022    ; extrins ic variabl e, text fo r header P RCA*4.5*29 8
  9023   "RTN","RCD PEAR2",167 ,0)
  9024   HDRNM() Q  "EFT UNMAT CHED AGING  REPORT"
  9025   "RTN","RCD PEAR2",168 ,0)
  9026    ;
  9027   "RTN","RCD PEAR2",169 ,0)
  9028   HDRBLD ; c reate the  report hea der
  9029   "RTN","RCD PEAR2",170 ,0)
  9030    ; returns  RCHDR, RC PGNUM, RCS TOP
  9031   "RTN","RCD PEAR2",171 ,0)
  9032    ;   RCHDR (0) = head er text li ne count
  9033   "RTN","RCD PEAR2",172 ,0)
  9034    ;   RCHDR ("XECUTE")  = M code  for page n umber
  9035   "RTN","RCD PEAR2",173 ,0)
  9036    ;   RCHDR ("RUNDATE" ) = date/t ime report  generated , external  format
  9037   "RTN","RCD PEAR2",174 ,0)
  9038    ;   RCPGN UM - page  counter
  9039   "RTN","RCD PEAR2",175 ,0)
  9040    ;   RCSTO P - flag t o exit
  9041   "RTN","RCD PEAR2",176 ,0)
  9042    ;INPUT:
  9043   "RTN","RCD PEAR2",177 ,0)
  9044    ; RCDTRNG  - date ra nge filter  value to  be printed  as part o f the head er
  9045   "RTN","RCD PEAR2",178 ,0)
  9046    ; RCPAY -  Payer fil ter value( s)
  9047   "RTN","RCD PEAR2",179 ,0)
  9048    ; RCLSTMG R
  9049   "RTN","RCD PEAR2",180 ,0)
  9050    ;
  9051   "RTN","RCD PEAR2",181 ,0)
  9052    K RCHDR S  RCHDR("RU NDATE")=$$ NOW^RCDPEA RL,RCPGNUM =0,RCSTOP= 0
  9053   "RTN","RCD PEAR2",182 ,0)
  9054    ;
  9055   "RTN","RCD PEAR2",183 ,0)
  9056    I RCDISPT Y D  Q  ;  Excel form at, xecute  code is Q UIT, null  page numbe r
  9057   "RTN","RCD PEAR2",184 ,0)
  9058    .S RCHDR( 0)=1,RCHDR ("XECUTE") ="Q",RCPGN UM=""
  9059   "RTN","RCD PEAR2",185 ,0)
  9060    .S RCHDR( 1)="Aged D ays^Trace  #^Deposit  From/ID^Fi le Date^De posit Amou nt^Deposit  #^Deposit  Post Stat us^Deposit  Date"
  9061   "RTN","RCD PEAR2",186 ,0)
  9062    ;
  9063   "RTN","RCD PEAR2",187 ,0)
  9064    N START,E ND,MSG,DAT E,Y,DIV,HC NT
  9065   "RTN","RCD PEAR2",188 ,0)
  9066    S START=$ $FMTE^XLFD T($P(RCDTR NG,U,2),2) ,END=$$FMT E^XLFDT($P (RCDTRNG,U ,3),2)
  9067   "RTN","RCD PEAR2",189 ,0)
  9068    ;
  9069   "RTN","RCD PEAR2",190 ,0)
  9070    S Y=$$HDR NM,HCNT=1, RCHDR(HCNT )=$J("",80 -$L(Y)\2)_ Y  ; line  1 will be  replaced b y XECUTE c ode below
  9071   "RTN","RCD PEAR2",191 ,0)
  9072    S RCHDR(" XECUTE")=" N Y S RCPG NUM=RCPGNU M+1,Y=$$HD RNM^"_$T(+ 0)_"_$S(RC LSTMGR:""" ",1:$J(""P age: ""_RC PGNUM,12)) ,RCHDR(1)= $J("" "",8 0-$L(Y)\2) _Y"
  9073   "RTN","RCD PEAR2",192 ,0)
  9074    S Y="RUN  DATE: "_RC HDR("RUNDA TE"),HCNT= HCNT+1,RCH DR(HCNT)=$ J("",80-$L (Y)\2)_Y   ; line 1 w ill be rep laced by X ECUTE code  below
  9075   "RTN","RCD PEAR2",193 ,0)
  9076    ;
  9077   "RTN","RCD PEAR2",194 ,0)
  9078    ; Payer(s )
  9079   "RTN","RCD PEAR2",195 ,0)
  9080    S Y="PAYE RS: " D
  9081   "RTN","RCD PEAR2",196 ,0)
  9082    .I $D(RCP AY)=1 S Y= Y_RCPAY,HC NT=HCNT+1, RCHDR(HCNT )=$J("",80 -$L(Y)\2)_ Y Q
  9083   "RTN","RCD PEAR2",197 ,0)
  9084    .N S,X S  S=0 F  S S =$O(RCPAY( S)) Q:'S   D
  9085   "RTN","RCD PEAR2",198 ,0)
  9086    ..S X=RCP AY(S)_$S($ O(RCPAY(S) ):", ",1:" ")
  9087   "RTN","RCD PEAR2",199 ,0)
  9088    ..I $L(X) +$L(Y)>80  S HCNT=HCN T+1,RCHDR( HCNT)=Y,Y= $J(" ",8)
  9089   "RTN","RCD PEAR2",200 ,0)
  9090    ..S Y=Y_X
  9091   "RTN","RCD PEAR2",201 ,0)
  9092    .;
  9093   "RTN","RCD PEAR2",202 ,0)
  9094    .S:$TR(Y, " ")]"" HC NT=HCNT+1, RCHDR(HCNT )=Y  ; any  residual  data
  9095   "RTN","RCD PEAR2",203 ,0)
  9096    S Y="DATE  RANGE: "_ $P($$FMTE^ XLFDT(STAR T,2),"@")_ " - "_$P($ $FMTE^XLFD T(END,2)," @")_" (DAT E EFT FILE D)"
  9097   "RTN","RCD PEAR2",204 ,0)
  9098    S Y=$J("" ,80-$L(Y)\ 2)_Y,HCNT= HCNT+1,RCH DR(HCNT)=Y
  9099   "RTN","RCD PEAR2",205 ,0)
  9100    ;
  9101   "RTN","RCD PEAR2",206 ,0)
  9102    S Y="AGED ",HCNT=HCN T+1,RCHDR( HCNT)=Y
  9103   "RTN","RCD PEAR2",207 ,0)
  9104    ; PRCA*4. 5*318 move d deposit  date up a  row
  9105   "RTN","RCD PEAR2",208 ,0)
  9106    S Y="DAYS   TRACE #                                                                 DE P DATE",HC NT=HCNT+1, RCHDR(HCNT )=Y
  9107   "RTN","RCD PEAR2",209 ,0)
  9108    S Y="     DEPOSIT FR OM/ID",HCN T=HCNT+1,R CHDR(HCNT) =Y
  9109   "RTN","RCD PEAR2",210 ,0)
  9110    S Y="       FILE DAT E     DEPO SIT AMOUNT   DEP #        DEPOSI T POST STA TUS",HCNT= HCNT+1,RCH DR(HCNT)=Y
  9111   "RTN","RCD PEAR2",211 ,0)
  9112    S Y="",$P (Y,"=",81) ="",HCNT=H CNT+1,RCHD R(HCNT)=Y   ; row of  equal sign s at botto m
  9113   "RTN","RCD PEAR2",212 ,0)
  9114    ;
  9115   "RTN","RCD PEAR2",213 ,0)
  9116    S RCHDR(0 )=HCNT
  9117   "RTN","RCD PEAR2",214 ,0)
  9118    ;
  9119   "RTN","RCD PEAR2",215 ,0)
  9120    Q
  9121   "RTN","RCD PEAR2",216 ,0)
  9122    ;
  9123   "RTN","RCD PEAR2",217 ,0)
  9124   HDRLM ; cr eate the L istman hea der sectio n
  9125   "RTN","RCD PEAR2",218 ,0)
  9126    ; returns  RCHDR
  9127   "RTN","RCD PEAR2",219 ,0)
  9128    ;   RCHDR (0) = head er text li ne count
  9129   "RTN","RCD PEAR2",220 ,0)
  9130    ;INPUT:
  9131   "RTN","RCD PEAR2",221 ,0)
  9132    ; RCDTRNG  - date ra nge filter  value to  be printed  as part o f the head er
  9133   "RTN","RCD PEAR2",222 ,0)
  9134    ; RCPAY -  Payer fil ter value( s)
  9135   "RTN","RCD PEAR2",223 ,0)
  9136    ;
  9137   "RTN","RCD PEAR2",224 ,0)
  9138    K RCHDR S  RCPGNUM=0 ,RCSTOP=0
  9139   "RTN","RCD PEAR2",225 ,0)
  9140    ;
  9141   "RTN","RCD PEAR2",226 ,0)
  9142    N START,E ND,MSG,DAT E,Y,DIV,HC NT
  9143   "RTN","RCD PEAR2",227 ,0)
  9144    S START=$ $FMTE^XLFD T($P(RCDTR NG,U,2),2) ,END=$$FMT E^XLFDT($P (RCDTRNG,U ,3),2)
  9145   "RTN","RCD PEAR2",228 ,0)
  9146    S Y="DATE  RANGE: "_ $P($$FMTE^ XLFDT(STAR T,2),"@")_ " - "_$P($ $FMTE^XLFD T(END,2)," @")_" (DAT E EFT FILE D)"
  9147   "RTN","RCD PEAR2",229 ,0)
  9148    S HCNT=1, RCHDR(HCNT )=Y
  9149   "RTN","RCD PEAR2",230 ,0)
  9150    ; Payer(s )
  9151   "RTN","RCD PEAR2",231 ,0)
  9152    S Y="PAYE RS: " D
  9153   "RTN","RCD PEAR2",232 ,0)
  9154    .I $D(RCP AY)=1 S Y= Y_RCPAY,HC NT=HCNT+1, RCHDR(HCNT )=Y Q
  9155   "RTN","RCD PEAR2",233 ,0)
  9156    .N S,X S  S=0 F  S S =$O(RCPAY( S)) Q:'S   D
  9157   "RTN","RCD PEAR2",234 ,0)
  9158    ..S X=RCP AY(S)_$S($ O(RCPAY(S) ):", ",1:" ")
  9159   "RTN","RCD PEAR2",235 ,0)
  9160    ..I $L(X) +$L(Y)>80  S HCNT=HCN T+1,RCHDR( HCNT)=Y,Y= $J(" ",8)
  9161   "RTN","RCD PEAR2",236 ,0)
  9162    ..S Y=Y_X
  9163   "RTN","RCD PEAR2",237 ,0)
  9164    .;
  9165   "RTN","RCD PEAR2",238 ,0)
  9166    .S:$TR(Y, " ")]"" HC NT=HCNT+1, RCHDR(HCNT )=Y  ; any  residual  data
  9167   "RTN","RCD PEAR2",239 ,0)
  9168    ;
  9169   "RTN","RCD PEAR2",240 ,0)
  9170    S HCNT=HC NT+1,RCHDR (HCNT)=""
  9171   "RTN","RCD PEAR2",241 ,0)
  9172    S Y="AGED ",HCNT=HCN T+1,RCHDR( HCNT)=Y
  9173   "RTN","RCD PEAR2",242 ,0)
  9174    ; PRCA*4. 5*318 move d deposit  date up a  row
  9175   "RTN","RCD PEAR2",243 ,0)
  9176    S Y="DAYS  TRACE #                                                                 DEP  DATE",HCN T=HCNT+1,R CHDR(HCNT) =Y
  9177   "RTN","RCD PEAR2",244 ,0)
  9178    S Y="     DEPOSIT FR OM/ID",HCN T=HCNT+1,R CHDR(HCNT) =Y
  9179   "RTN","RCD PEAR2",245 ,0)
  9180    S Y="      FILE DATE      DEPOS IT AMOUNT   DEP #        DEPOSIT  POST STAT US",HCNT=H CNT+1,RCHD R(HCNT)=Y
  9181   "RTN","RCD PEAR2",246 ,0)
  9182    ;
  9183   "RTN","RCD PEAR2",247 ,0)
  9184    S RCHDR(0 )=HCNT
  9185   "RTN","RCD PEAR2",248 ,0)
  9186    ;
  9187   "RTN","RCD PEAR2",249 ,0)
  9188    Q
  9189   "RTN","RCD PEAR2",250 ,0)
  9190    ;
  9191   "RTN","RCD PEAR2",251 ,0)
  9192   EXCEL ; Pr int report  to screen , one reco rd per lin e for expo rt to MS E xcel.
  9193   "RTN","RCD PEAR2",252 ,0)
  9194    ; RCTMPND  = name of  the subsc ript for ^ TMP to use
  9195   "RTN","RCD PEAR2",253 ,0)
  9196    W !!,"Age d Days^Tra ce #^Depos it From/ID ^File Date ^Deposit A mount^Depo sit #^Depo sit Post S tatus^Depo sit Date"
  9197   "RTN","RCD PEAR2",254 ,0)
  9198    S RCZ=""  F  S RCZ=$ O(^TMP($J, "RCEFT_AGE D",RCZ)) Q :RCZ=""  S  RCIEN=0 F   S RCIEN= $O(^TMP($J ,"RCEFT_AG ED",RCZ,RC IEN)) Q:'R CIEN  D  G :RCSTOP PR TQ2
  9199   "RTN","RCD PEAR2",255 ,0)
  9200    .I $D(ZTQ UEUED),$$S ^%ZTLOAD S  (RCSTOP,Z TSTOP)=1 K  ZTREQ I + $G(RCPG) W :RCTMPND=" " !!,"***T ASK STOPPE D BY USER* **" Q
  9201   "RTN","RCD PEAR2",256 ,0)
  9202    .S RC0=$G (^RCY(344. 31,RCIEN,0 )),RC3443= $G(^RCY(34 4.3,+RC0,0 ))
  9203   "RTN","RCD PEAR2",257 ,0)
  9204    .N RCPAY  S RCPAY=$P (RC0,U,2)  S:RCPAY=""  RCPAY="NO  PAYER NAM E RECEIVED " ; PRCA*4 .5*298
  9205   "RTN","RCD PEAR2",258 ,0)
  9206    .S Z=$J(- RCZ,4)_"^" _$P(RC0,U, 4)_"^"_RCP AY_"/"_$P( RC0,U,3)_" ^"_$S($P(R C0,U,13):$ $FMTE^XLFD T($P(RC0,U ,13),2),1: "")_"^" ;  PRCA*4.5*2 98
  9207   "RTN","RCD PEAR2",259 ,0)
  9208    .S Z=Z_$P (RC0,U,7)_ "^"_$P(RC3 443,U,6)_" ^"_$S($P(R C3443,U,12 ):"",1:"NO T ")_"Post ed to 8NZZ "_$S($P(RC 3443,U,12) :"^"_$$FMT E^XLFDT($P (RC0,U,12) ,2),1:"")
  9209   "RTN","RCD PEAR2",260 ,0)
  9210    .W !,Z
  9211   "RTN","RCD PEAR2",261 ,0)
  9212    W !!,"***  END OF RE PORT ***", !
  9213   "RTN","RCD PEAR2",262 ,0)
  9214    ;
  9215   "RTN","RCD PEAR2",263 ,0)
  9216   PRTQ2 ;
  9217   "RTN","RCD PEAR2",264 ,0)
  9218    I $D(ZTQU EUED) S ZT REQ="@"
  9219   "RTN","RCD PEAR2",265 ,0)
  9220    I '$D(ZTQ UEUED) D ^ %ZISC
  9221   "RTN","RCD PEAR2",266 ,0)
  9222    K ^TMP($J ,"RCEFT_AG ED"),^TMP( "RCSELPAY" ,$J),^TMP( "RCPAYER", $J),^TMP($ J,"RCERA_A DJ")
  9223   "RTN","RCD PEAR2",267 ,0)
  9224    Q
  9225   "RTN","RCD PEAR2",268 ,0)
  9226    ;
  9227   "RTN","RCD PEAR2",269 ,0)
  9228    ;PRCA*4.5 *298
  9229   "RTN","RCD PEAR2",270 ,0)
  9230    ; removed  RCIND loc al variabl e
  9231   "RTN","RCD PEAR2",271 ,0)
  9232    ; changed  RC00 to R C3443
  9233   "RTN","RCD PEAR2",272 ,0)
  9234    ; replace d SETLINE  with SL^RC DPEARL
  9235   "RTN","RCD PEAR2",273 ,0)
  9236    ; added $ $HDRNM
  9237   "RTN","RCD PEAR2",274 ,0)
  9238    ; added R CLSTMGR in  checks fo r header
  9239   "RTN","RCD PEAR2",275 ,0)
  9240    ; changed  upper cas e text to  mixed case  throughou t
  9241   "RTN","RCD PEAR2",276 ,0)
  9242    ;
  9243   "RTN","RCD PEAR3")
  9244   0^28^B4337 332
  9245   "RTN","RCD PEAR3",1,0 )
  9246   RCDPEAR3 ; AITC/CJE -  ERA Unmat ched Aging  Report ;
  9247   "RTN","RCD PEAR3",2,0 )
  9248    ;;4.5;Acc ounts Rece ivable;**3 21**;;Buil d 46
  9249   "RTN","RCD PEAR3",3,0 )
  9250    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  9251   "RTN","RCD PEAR3",4,0 )
  9252    Q
  9253   "RTN","RCD PEAR3",5,0 )
  9254    ;
  9255   "RTN","RCD PEAR3",6,0 )
  9256    ; PRCA*4. 5*321 over flow routi ne for and  RCDPEAR2
  9257   "RTN","RCD PEAR3",7,0 )
  9258    ; SELPAY  and RLOAD  moved from  RCDPEAR1  to meet SA C size lim it
  9259   "RTN","RCD PEAR3",8,0 )
  9260   SELPAY(RCR ESPYR,RCJO B,RCPAY) ; localize t he payer f ilters for  header di splay
  9261   "RTN","RCD PEAR3",9,0 )
  9262    ; Input:
  9263   "RTN","RCD PEAR3",10, 0)
  9264    ;   RCRES PYR (pass- by-val/req uired) - p ayer filte r response  indicator  (2=ALL, 3 =SPECIFIC)
  9265   "RTN","RCD PEAR3",11, 0)
  9266    ;   RCJOB  - job num ber to acc ess the po pulated te mporary gl obal array  in case r eport was  tasked to  run
  9267   "RTN","RCD PEAR3",12, 0)
  9268    ; Output:
  9269   "RTN","RCD PEAR3",13, 0)
  9270    ;   RCPAY  (pass-by- ref/requir ed) - loca l array of  payers e. g. RCPAY=" ALL", RCPA Y(1)="Aetn a",
  9271   "RTN","RCD PEAR3",14, 0)
  9272    ;                                     or R CPAY="star t payer =  end payer"
  9273   "RTN","RCD PEAR3",15, 0)
  9274    N CNT,I
  9275   "RTN","RCD PEAR3",16, 0)
  9276    I RCRESPY R=2 S RCPA Y="ALL" Q
  9277   "RTN","RCD PEAR3",17, 0)
  9278    S:RCJOB=" " RCJOB=$J    ; RCJOB  should no t be null
  9279   "RTN","RCD PEAR3",18, 0)
  9280    I RCRESPY R=3 D  Q
  9281   "RTN","RCD PEAR3",19, 0)
  9282    .S CNT=0
  9283   "RTN","RCD PEAR3",20, 0)
  9284    .F  S CNT =$O(^TMP(" RCSELPAY", RCJOB,CNT) ) Q:'CNT   D
  9285   "RTN","RCD PEAR3",21, 0)
  9286    ..S RCPAY (CNT)=^TMP ("RCSELPAY ",RCJOB,CN T)
  9287   "RTN","RCD PEAR3",22, 0)
  9288    ; RCRESPY R indicate s a range  of payers
  9289   "RTN","RCD PEAR3",23, 0)
  9290    S I=$O(^T MP("RCSELP AY",RCJOB, "")),RCPAY =^(I)_" -  "
  9291   "RTN","RCD PEAR3",24, 0)
  9292    S I=$O(^T MP("RCSELP AY",RCJOB, ""),-1),RC PAY=RCPAY_ ^(I)
  9293   "RTN","RCD PEAR3",25, 0)
  9294    Q
  9295   "RTN","RCD PEAR3",26, 0)
  9296    ;
  9297   "RTN","RCD PEAR3",27, 0)
  9298   RLOAD(FILE ) ; PRCA*4 .5*284 - L oad Payer  temp globa l AFTER qu eued job s tarts
  9299   "RTN","RCD PEAR3",28, 0)
  9300    ; Load Se lected pay ers from l ocal array  end exit
  9301   "RTN","RCD PEAR3",29, 0)
  9302    ; Input:  FILE to lo ad payers  from (344. 31 passed  from RCDPE AR2)
  9303   "RTN","RCD PEAR3",30, 0)
  9304    ; Output:  ^TMP("RCP AYER") and  ^TMP("RCS ELPAY") ar rays
  9305   "RTN","RCD PEAR3",31, 0)
  9306    ;
  9307   "RTN","RCD PEAR3",32, 0)
  9308    I +RCRESP YR=3 M ^TM P("RCSELPA Y",$J)=RCP YRLST Q
  9309   "RTN","RCD PEAR3",33, 0)
  9310    N CNT,IND X,NUM,RCIN SF,RCINST, RCPAY
  9311   "RTN","RCD PEAR3",34, 0)
  9312    ;
  9313   "RTN","RCD PEAR3",35, 0)
  9314    ; Load AL L payers a nd exit
  9315   "RTN","RCD PEAR3",36, 0)
  9316    I +RCRESP YR=2 D  Q
  9317   "RTN","RCD PEAR3",37, 0)
  9318    .S CNT=0, RCPAY="" F   S RCPAY= $O(^RCY(FI LE,"C",RCP AY)) Q:RCP AY=""  S C NT=CNT+1,^ TMP("RCSEL PAY",$J,CN T)=RCPAY
  9319   "RTN","RCD PEAR3",38, 0)
  9320    ;
  9321   "RTN","RCD PEAR3",39, 0)
  9322    ; Range o f Payers
  9323   "RTN","RCD PEAR3",40, 0)
  9324    ; Build l ist of ava ilable sta tions
  9325   "RTN","RCD PEAR3",41, 0)
  9326    K ^TMP("R CPAYER",$J )  ; Clear  residual  list data
  9327   "RTN","RCD PEAR3",42, 0)
  9328    S CNT=0,R CPAY=""
  9329   "RTN","RCD PEAR3",43, 0)
  9330    F  S RCPA Y=$O(^RCY( FILE,"C",R CPAY)) Q:R CPAY=""  S  CNT=CNT+1 ,^TMP("RCP AYER",$J,C NT)=RCPAY, ^TMP("RCPA YER",$J,"B ",RCPAY,CN T)=""
  9331   "RTN","RCD PEAR3",44, 0)
  9332    ;
  9333   "RTN","RCD PEAR3",45, 0)
  9334    S RCINSF= $P(RCRESPY R,"^",2),R CINST=$P(R CRESPYR,"^ ",3),INDX= 1
  9335   "RTN","RCD PEAR3",46, 0)
  9336    F  S RCIN SF=$O(^TMP ("RCPAYER" ,$J,"B",RC INSF)) Q:R CINSF=""   Q:RCINSF]R CINST  D
  9337   "RTN","RCD PEAR3",47, 0)
  9338    .S NUM=$O (^TMP("RCP AYER",$J," B",RCINSF, ""))
  9339   "RTN","RCD PEAR3",48, 0)
  9340    .S ^TMP(" RCSELPAY", $J,INDX)=$ G(^TMP("RC PAYER",$J, NUM)),INDX =INDX+1
  9341   "RTN","RCD PEAR3",49, 0)
  9342    Q
  9343   "RTN","RCD PEAR3",50, 0)
  9344    ;
  9345   "RTN","RCD PEARL")
  9346   0^24^B3793 0557
  9347   "RTN","RCD PEARL",1,0 )
  9348   RCDPEARL ; ALB/hrubov cak - Misc . Report u tilities f or ListMan , etc. ;Ju n 06, 2014 @19:11:19
  9349   "RTN","RCD PEARL",2,0 )
  9350    ;;4.5;Acc ounts Rece ivable;**2 98,321**;1 5 April 20 14;Build 4 6
  9351   "RTN","RCD PEARL",3,0 )
  9352    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  9353   "RTN","RCD PEARL",4,0 )
  9354    ;
  9355   "RTN","RCD PEARL",5,0 )
  9356    ; IA 594  - ACCOUNTS  RECEIVABL E CATEGORY  file (#43 0.2)
  9357   "RTN","RCD PEARL",6,0 )
  9358    ; IA 1992  - BILL/CL AIMS file  (#399)
  9359   "RTN","RCD PEARL",7,0 )
  9360    ; IA 3822  - RATE TY PE file (# 399.3)
  9361   "RTN","RCD PEARL",8,0 )
  9362    ; IA 4051  - EXPLANA TION OF BE NEFITS fil e (#361.1)
  9363   "RTN","RCD PEARL",9,0 )
  9364    ;
  9365   "RTN","RCD PEARL",10, 0)
  9366    Q
  9367   "RTN","RCD PEARL",11, 0)
  9368    ;
  9369   "RTN","RCD PEARL",12, 0)
  9370   ASK(STOP)  ; Ask to c ontinue
  9371   "RTN","RCD PEARL",13, 0)
  9372    ; STOP pa ssed by re f., return ed as 1 if  timeout o r user ent ers '^'
  9373   "RTN","RCD PEARL",14, 0)
  9374    Q:'($E(IO ST,1,2)="C -")  ; mus t have use r
  9375   "RTN","RCD PEARL",15, 0)
  9376    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  9377   "RTN","RCD PEARL",16, 0)
  9378    S DIR("A" )="Press e nter to co ntinue, '^ ' to exit:  "
  9379   "RTN","RCD PEARL",17, 0)
  9380    S DIR(0)= "EA" D ^DI R
  9381   "RTN","RCD PEARL",18, 0)
  9382    I ($D(DTO UT))!($D(D UOUT))!(Y= "^") S STO P=1
  9383   "RTN","RCD PEARL",19, 0)
  9384    Q
  9385   "RTN","RCD PEARL",20, 0)
  9386    ;
  9387   "RTN","RCD PEARL",21, 0)
  9388   ASKLM() ;  extrinsic  function,  ask for Li stMan disp lay using  ^DIR
  9389   "RTN","RCD PEARL",22, 0)
  9390    ; returns  zero = No , 1 = yes,  -1 on tim eout or '^ '
  9391   "RTN","RCD PEARL",23, 0)
  9392    N DIR,RSL T,X,Y S RS LT=0
  9393   "RTN","RCD PEARL",24, 0)
  9394    S DIR(0)= "YA",DIR(" A")="Displ ay in List  Manager f ormat? (Y/ N): ",DIR( "B")="NO"
  9395   "RTN","RCD PEARL",25, 0)
  9396    D ^DIR S  RSLT=$S($D (DUOUT)!$D (DTOUT):-1 ,1:Y)
  9397   "RTN","RCD PEARL",26, 0)
  9398    Q RSLT
  9399   "RTN","RCD PEARL",27, 0)
  9400    ;
  9401   "RTN","RCD PEARL",28, 0)
  9402   CLMCHMPV(R CLMIEN) ;  boolean fu nction, re turns true  if CHAMPV A claim, e lse false
  9403   "RTN","RCD PEARL",29, 0)
  9404    ; RCLMIEN  - file en try, forma t: 'file # ;ien' (see  PTR4302 c omments)
  9405   "RTN","RCD PEARL",30, 0)
  9406    Q $$EVALC LM(RCLMIEN ,"CHAMPVA" )
  9407   "RTN","RCD PEARL",31, 0)
  9408    ;
  9409   "RTN","RCD PEARL",32, 0)
  9410   CLMTRICR(R CLMIEN) ;  boolean fu nction, re turns true  if TRICAR E claim, e lse false
  9411   "RTN","RCD PEARL",33, 0)
  9412    ; RCLMIEN  - file en try, forma t: 'file # ;ien' (see  PTR4302 c omments)
  9413   "RTN","RCD PEARL",34, 0)
  9414    Q $$EVALC LM(RCLMIEN ,"TRICARE" )
  9415   "RTN","RCD PEARL",35, 0)
  9416    ;
  9417   "RTN","RCD PEARL",36, 0)
  9418   ENDORPRT()  ; extrins ic variabl e, formatt ed for 80  column dis play
  9419   "RTN","RCD PEARL",37, 0)
  9420    N A S A=" ***** END  OF REPORT  *****" Q $ J(" ",80-$ L(A)\2)_A
  9421   "RTN","RCD PEARL",38, 0)
  9422    ;
  9423   "RTN","RCD PEARL",39, 0)
  9424   EVALCLM(RC LMIEN,TRGT XT) ; bool ean functi on, case i nsensitive
  9425   "RTN","RCD PEARL",40, 0)
  9426    ; returns  1 if clai m has targ et text, e lse false  (error mes sages eval uate as fa lse)
  9427   "RTN","RCD PEARL",41, 0)
  9428    ; RCLMIEN  (required ) - file e ntry, form at: 'file  #;ien' (se e PTR4302  comments)
  9429   "RTN","RCD PEARL",42, 0)
  9430    ; TRGTXT  (required)  - target  text
  9431   "RTN","RCD PEARL",43, 0)
  9432    Q:($G(RCL MIEN)="")! ($G(TRGTXT )="") "^in valid"  ;  both requi red
  9433   "RTN","RCD PEARL",44, 0)
  9434    N RSLT,F, R,T
  9435   "RTN","RCD PEARL",45, 0)
  9436    S T=$$UP( TRGTXT),RS LT=0  ; te xt to uppe rcase, def ault to fa lse
  9437   "RTN","RCD PEARL",46, 0)
  9438    S F=$G(RC LMIEN) Q:' ($P(F,";") >1)!'($P(F ,";",2)>0)  RSLT  ; f ile must b e > 1 and  entry > ze ro
  9439   "RTN","RCD PEARL",47, 0)
  9440    S R=$$PTR 4302(RCLMI EN) Q:'R R SLT  ; no  text to ch eck
  9441   "RTN","RCD PEARL",48, 0)
  9442    ;
  9443   "RTN","RCD PEARL",49, 0)
  9444    S F=$$UP( $P(R,";",2 ,99))  ; t ext of ent ry from AC COUNTS REC EIVABLE CA TEGORY (#4 30.2)
  9445   "RTN","RCD PEARL",50, 0)
  9446    S RSLT=F[ T  ; boole an result
  9447   "RTN","RCD PEARL",51, 0)
  9448    Q RSLT
  9449   "RTN","RCD PEARL",52, 0)
  9450    ;
  9451   "RTN","RCD PEARL",53, 0)
  9452   INCHMPVA()  ; functio n, include  CHAMPVA q uestion
  9453   "RTN","RCD PEARL",54, 0)
  9454    ; returns  zero = No , 1 = yes,  -1 on tim eout or '^ '
  9455   "RTN","RCD PEARL",55, 0)
  9456    N DIR,DTO UT,DUOUT,R SLT,X,Y S  RSLT=0
  9457   "RTN","RCD PEARL",56, 0)
  9458    S DIR(0)= "YA",DIR(" A")="Inclu de CHAMPVA ? (Y/N): " ,DIR("B")= "YES"
  9459   "RTN","RCD PEARL",57, 0)
  9460    S DIR("?" )="Enter ' NO' to exc lude entri es related  to CHAMPV A from the  report."
  9461   "RTN","RCD PEARL",58, 0)
  9462    D ^DIR S  RSLT=$S($D (DUOUT)!$D (DTOUT):-1 ,1:Y)
  9463   "RTN","RCD PEARL",59, 0)
  9464    Q RSLT
  9465   "RTN","RCD PEARL",60, 0)
  9466    ;
  9467   "RTN","RCD PEARL",61, 0)
  9468   INTRICAR()  ; functio n, include  TRICARE q uestion
  9469   "RTN","RCD PEARL",62, 0)
  9470    ; returns  zero = No , 1 = yes,  -1 on tim eout or '^ '
  9471   "RTN","RCD PEARL",63, 0)
  9472    N DIR,DTO UT,DUOUT,R SLT,X,Y S  RSLT=0
  9473   "RTN","RCD PEARL",64, 0)
  9474    S DIR(0)= "YA",DIR(" A")="Inclu de TRICARE ? (Y/N): " ,DIR("B")= "YES"
  9475   "RTN","RCD PEARL",65, 0)
  9476    S DIR("?" )="Enter ' NO' to exc lude entri es related  to TRICAR E from the  report."
  9477   "RTN","RCD PEARL",66, 0)
  9478    D ^DIR S  RSLT=$S($D (DUOUT)!$D (DTOUT):-1 ,1:Y)
  9479   "RTN","RCD PEARL",67, 0)
  9480    Q RSLT
  9481   "RTN","RCD PEARL",68, 0)
  9482    ; Begin P RCA*4.5*32 1
  9483   "RTN","RCD PEARL",69, 0)
  9484    ;
  9485   "RTN","RCD PEARL",70, 0)
  9486   EXCHMPVA()  ; functio n, exclude  CHAMPVA q uestion -  EP RCDPEM4
  9487   "RTN","RCD PEARL",71, 0)
  9488    ; returns  zero = No , 1 = yes,  -1 on tim eout or '^ '
  9489   "RTN","RCD PEARL",72, 0)
  9490    N DIR,DTO UT,DUOUT,R SLT,X,Y S  RSLT=0
  9491   "RTN","RCD PEARL",73, 0)
  9492    S DIR(0)= "YA",DIR(" A")="Exclu de CHAMPVA ? (Y/N): " ,DIR("B")= "NO"
  9493   "RTN","RCD PEARL",74, 0)
  9494    S DIR("?" )="Enter ' Y' to excl ude entrie s related  to CHAMPVA  from the  report."
  9495   "RTN","RCD PEARL",75, 0)
  9496    D ^DIR S  RSLT=$S($D (DUOUT)!$D (DTOUT):-1 ,1:Y)
  9497   "RTN","RCD PEARL",76, 0)
  9498    Q RSLT
  9499   "RTN","RCD PEARL",77, 0)
  9500    ;
  9501   "RTN","RCD PEARL",78, 0)
  9502   EXTRICAR()  ; functio n, exclude  TRICARE q uestion -  EP RCDPEM4
  9503   "RTN","RCD PEARL",79, 0)
  9504    ; returns  zero = No , 1 = yes,  -1 on tim eout or '^ '
  9505   "RTN","RCD PEARL",80, 0)
  9506    N DIR,DTO UT,DUOUT,R SLT,X,Y S  RSLT=0
  9507   "RTN","RCD PEARL",81, 0)
  9508    S DIR(0)= "YA",DIR(" A")="Exclu de TRICARE ? (Y/N): " ,DIR("B")= "NO"
  9509   "RTN","RCD PEARL",82, 0)
  9510    S DIR("?" )="Enter ' Y' to excl ude entrie s related  to TRICARE  from the  report."
  9511   "RTN","RCD PEARL",83, 0)
  9512    D ^DIR S  RSLT=$S($D (DUOUT)!$D (DTOUT):-1 ,1:Y)
  9513   "RTN","RCD PEARL",84, 0)
  9514    Q RSLT
  9515   "RTN","RCD PEARL",85, 0)
  9516    ; End PRC A*4.5*321
  9517   "RTN","RCD PEARL",86, 0)
  9518    ;
  9519   "RTN","RCD PEARL",87, 0)
  9520   HDRLST(RCS TOP,RCHDR)  ; write t he header  in RCHDR
  9521   "RTN","RCD PEARL",88, 0)
  9522    ; RCSTOP,  RCHDR pas sed by ref .
  9523   "RTN","RCD PEARL",89, 0)
  9524    Q:RCSTOP   ; nothing  to do
  9525   "RTN","RCD PEARL",90, 0)
  9526    ;
  9527   "RTN","RCD PEARL",91, 0)
  9528    I $E(IOST ,1,2)="C-" ,'RCDISPTY ,RCPGNUM D  ASK(.RCST OP)
  9529   "RTN","RCD PEARL",92, 0)
  9530    Q:RCSTOP   ; no head er needed
  9531   "RTN","RCD PEARL",93, 0)
  9532    I 'RCDISP TY W @IOF
  9533   "RTN","RCD PEARL",94, 0)
  9534    X RCHDR(" XECUTE")   ; incremen t page cou nt, insert  into head er
  9535   "RTN","RCD PEARL",95, 0)
  9536    N J F J=1 :1:RCHDR(0 ) W !,RCHD R(J)
  9537   "RTN","RCD PEARL",96, 0)
  9538    Q
  9539   "RTN","RCD PEARL",97, 0)
  9540    ;
  9541   "RTN","RCD PEARL",98, 0)
  9542   LMEN ; inv oke ListMa n for RCDP E MISC REP ORTS list  template
  9543   "RTN","RCD PEARL",99, 0)
  9544    ; externa l routines  should ca ll LMRPT
  9545   "RTN","RCD PEARL",100 ,0)
  9546    D EN^VALM ("RCDPE MI SC REPORTS ")
  9547   "RTN","RCD PEARL",101 ,0)
  9548    Q
  9549   "RTN","RCD PEARL",102 ,0)
  9550    ;
  9551   "RTN","RCD PEARL",103 ,0)
  9552   LMHDR ; Li stMan head er
  9553   "RTN","RCD PEARL",104 ,0)
  9554    N J S J=0
  9555   "RTN","RCD PEARL",105 ,0)
  9556    F J=1:1 Q :'$D(RCLMH DR(J))  S  VALMHDR(J) =RCLMHDR(J )
  9557   "RTN","RCD PEARL",106 ,0)
  9558    S:$G(RCLM HDR("TITLE "))'="" VA LM("TITLE" )=RCLMHDR( "TITLE")
  9559   "RTN","RCD PEARL",107 ,0)
  9560    Q
  9561   "RTN","RCD PEARL",108 ,0)
  9562    ;
  9563   "RTN","RCD PEARL",109 ,0)
  9564   LMINIT ; s et up List Man array,  invoked f rom inside  List Temp late
  9565   "RTN","RCD PEARL",110 ,0)
  9566    ;
  9567   "RTN","RCD PEARL",111 ,0)
  9568    N C,J,Y S  (J,C)=0
  9569   "RTN","RCD PEARL",112 ,0)
  9570    F  S J=$O (@RCLMND@( J)) Q:'J   S Y=$G(@RC LMND@(J)), C=C+1 D SE T^VALM10(C ,Y)
  9571   "RTN","RCD PEARL",113 ,0)
  9572    S VALMCNT =C
  9573   "RTN","RCD PEARL",114 ,0)
  9574    Q
  9575   "RTN","RCD PEARL",115 ,0)
  9576    ;
  9577   "RTN","RCD PEARL",116 ,0)
  9578   LMHLP ; Li stMan help
  9579   "RTN","RCD PEARL",117 ,0)
  9580    S X="?" D  DISP^XQOR M1 W !!
  9581   "RTN","RCD PEARL",118 ,0)
  9582    Q
  9583   "RTN","RCD PEARL",119 ,0)
  9584    ;
  9585   "RTN","RCD PEARL",120 ,0)
  9586   LMEXIT ; p erformed o n exiting  ListMan sc reen
  9587   "RTN","RCD PEARL",121 ,0)
  9588    K @RCLMND   ; delete  ListMan d ata
  9589   "RTN","RCD PEARL",122 ,0)
  9590    D FULL^VA LM1  ; res et termina l display
  9591   "RTN","RCD PEARL",123 ,0)
  9592    Q
  9593   "RTN","RCD PEARL",124 ,0)
  9594    ;
  9595   "RTN","RCD PEARL",125 ,0)
  9596   LMEXPND ;  expand cod e for List Man
  9597   "RTN","RCD PEARL",126 ,0)
  9598    Q
  9599   "RTN","RCD PEARL",127 ,0)
  9600    ;
  9601   "RTN","RCD PEARL",128 ,0)
  9602   LMRPT(RCLM HDR,RCLMND ) ; genera te ListMan  display
  9603   "RTN","RCD PEARL",129 ,0)
  9604    ; RCLMHDR  = header  text, pass ed by ref.  (required )
  9605   "RTN","RCD PEARL",130 ,0)
  9606    ; RCLMND  = storage  node for L istMan dat a (require d)
  9607   "RTN","RCD PEARL",131 ,0)
  9608    Q:'$D(RCL MHDR)  Q:( $G(RCLMND) ="")  ; bo th require d
  9609   "RTN","RCD PEARL",132 ,0)
  9610    D LMEN
  9611   "RTN","RCD PEARL",133 ,0)
  9612    Q
  9613   "RTN","RCD PEARL",134 ,0)
  9614    ;
  9615   "RTN","RCD PEARL",135 ,0)
  9616   NOW() Q $$ FMTE^XLFDT ($$NOW^XLF DT,2)  ; e xtrinsic v ariable, n ow as MM/D D/YY@HH:MM :SS
  9617   "RTN","RCD PEARL",136 ,0)
  9618    ;
  9619   "RTN","RCD PEARL",137 ,0)
  9620   PAD(TXT,LN GTH) ; fun ction, pad  TXT with  spaces to  LNGTH
  9621   "RTN","RCD PEARL",138 ,0)
  9622    Q $$LJ^XL FSTR(TXT,L NGTH)
  9623   "RTN","RCD PEARL",139 ,0)
  9624    ;
  9625   "RTN","RCD PEARL",140 ,0)
  9626   PTR4302(FL NTRY) ; fu nction, re turns entr y from 430 .2 or erro r message
  9627   "RTN","RCD PEARL",141 ,0)
  9628    ; FLNTRY  - file ent ry (requir ed), forma t: 'file # ;ien'
  9629   "RTN","RCD PEARL",142 ,0)
  9630    ; on succ ess return s 'ien^nam e' else '^ error mess age'
  9631   "RTN","RCD PEARL",143 ,0)
  9632    ; file nu mber and i en can be  from:
  9633   "RTN","RCD PEARL",144 ,0)
  9634    ;  ^PRCA( 430.2,0) =  ACCOUNTS  RECEIVABLE  CATEGORY^ 430.2I
  9635   "RTN","RCD PEARL",145 ,0)
  9636    ;  ^DGCR( 399.3,0) =  RATE TYPE ^399.3I^
  9637   "RTN","RCD PEARL",146 ,0)
  9638    ;  ^DGCR( 399,0) = B ILL/CLAIMS ^399I
  9639   "RTN","RCD PEARL",147 ,0)
  9640    ;  ^IBM(3 61.1,0) =  EXPLANATIO N OF BENEF ITS^361.1P I^
  9641   "RTN","RCD PEARL",148 ,0)
  9642    ;  ^RCY(3 44.4,0) =  ELECTRONIC  REMITTANC E ADVICE^3 44.4I
  9643   "RTN","RCD PEARL",149 ,0)
  9644    ;  ^RCY(3 44,0) = AR  BATCH PAY MENT^344I
  9645   "RTN","RCD PEARL",150 ,0)
  9646    ;
  9647   "RTN","RCD PEARL",151 ,0)
  9648    N F,PF,RC FLNUM,RCIE N,RSLT,X,Y
  9649   "RTN","RCD PEARL",152 ,0)
  9650    ; PF - pa rent file
  9651   "RTN","RCD PEARL",153 ,0)
  9652    ; RCFLNUM  - file nu mber
  9653   "RTN","RCD PEARL",154 ,0)
  9654    ; RCIEN -  internal  entry numb er
  9655   "RTN","RCD PEARL",155 ,0)
  9656    ; RSLT -  result
  9657   "RTN","RCD PEARL",156 ,0)
  9658    ;
  9659   "RTN","RCD PEARL",157 ,0)
  9660    S RSLT=U, F=$G(FLNTR Y),RCFLNUM =+$P(F,";" ),RCIEN=+$ P(F,";",2)
  9661   "RTN","RCD PEARL",158 ,0)
  9662    Q:'(RCFLN UM>1) U_"i nvalid fil e #"
  9663   "RTN","RCD PEARL",159 ,0)
  9664    Q:'(RCIEN >0) U_"inv alid IEN"
  9665   "RTN","RCD PEARL",160 ,0)
  9666    ;
  9667   "RTN","RCD PEARL",161 ,0)
  9668    ; default  result
  9669   "RTN","RCD PEARL",162 ,0)
  9670    S RSLT="^ file "_RCF LNUM_" no  entry #"_R CIEN
  9671   "RTN","RCD PEARL",163 ,0)
  9672    ;
  9673   "RTN","RCD PEARL",164 ,0)
  9674    ; ACCOUNT S RECEIVAB LE CATEGOR Y file #43 0.2
  9675   "RTN","RCD PEARL",165 ,0)
  9676    I RCFLNUM =430.2 D   Q RSLT
  9677   "RTN","RCD PEARL",166 ,0)
  9678    .S X=$G(^ PRCA(430.2 ,RCIEN,0)) ,Y=$P(X,U)  S:Y]"" RS LT=RCIEN_" ;"_Y
  9679   "RTN","RCD PEARL",167 ,0)
  9680    ;
  9681   "RTN","RCD PEARL",168 ,0)
  9682    ; RATE TY PE file #3 99.3, (#.0 6) ACCOUNT S RECEIVAB LE CATEGOR Y [6P:430. 2]
  9683   "RTN","RCD PEARL",169 ,0)
  9684    I RCFLNUM =399.3 D   Q RSLT
  9685   "RTN","RCD PEARL",170 ,0)
  9686    .S X=$G(^ DGCR(399.3 ,RCIEN,0)) ,Y=+$P(X,U ,6) Q:'(Y> 0)
  9687   "RTN","RCD PEARL",171 ,0)
  9688    .S RSLT=$ $PTR4302(" 430.2;"_Y)
  9689   "RTN","RCD PEARL",172 ,0)
  9690    ;
  9691   "RTN","RCD PEARL",173 ,0)
  9692    ; BILL/CL AIMS file  #399, (#.0 7) RATE TY PE [7P:399 .3]
  9693   "RTN","RCD PEARL",174 ,0)
  9694    I RCFLNUM =399 D  Q  RSLT
  9695   "RTN","RCD PEARL",175 ,0)
  9696    .S X=$G(^ DGCR(399,R CIEN,0)) Q :X=""
  9697   "RTN","RCD PEARL",176 ,0)
  9698    .S PF=399 .3,RSLT="^ no pointer  to "_PF,Y =+$P(X,U,7 ) Q:'(Y>0)
  9699   "RTN","RCD PEARL",177 ,0)
  9700    .S RSLT=$ $PTR4302(P F_";"_Y)
  9701   "RTN","RCD PEARL",178 ,0)
  9702    ;
  9703   "RTN","RCD PEARL",179 ,0)
  9704    ; EXPLANA TION OF BE NEFITS fil e #361.1,  (#.01) BIL L [1P:399]
  9705   "RTN","RCD PEARL",180 ,0)
  9706    I RCFLNUM =361.1 D   Q RSLT
  9707   "RTN","RCD PEARL",181 ,0)
  9708    .S X=$G(^ IBM(361.1, RCIEN,0))  Q:X=""
  9709   "RTN","RCD PEARL",182 ,0)
  9710    .S PF=399 ,RSLT="^no  pointer t o "_PF,Y=+ $P(X,U) Q: '(Y>0)
  9711   "RTN","RCD PEARL",183 ,0)
  9712    .S RSLT=$ $PTR4302(P F_";"_Y)
  9713   "RTN","RCD PEARL",184 ,0)
  9714    ;
  9715   "RTN","RCD PEARL",185 ,0)
  9716    ; ELECTRO NIC REMITT ANCE ADVIC E file #34 4.4
  9717   "RTN","RCD PEARL",186 ,0)
  9718    ;  ERA DE TAIL sub-f ile #344.4 1, (#.02)  EOB DETAIL  [2P:361.1 ]
  9719   "RTN","RCD PEARL",187 ,0)
  9720    I RCFLNUM =344.4 D   Q RSLT
  9721   "RTN","RCD PEARL",188 ,0)
  9722    .S X=$G(^ RCY(344.4, RCIEN,0))  Q:X=""  ;  top level  entry not  found
  9723   "RTN","RCD PEARL",189 ,0)
  9724    .S RSLT=" ^sub-file  344.41 no  entries"
  9725   "RTN","RCD PEARL",190 ,0)
  9726    .; take f irst entry  that give s result f rom file # 430.2
  9727   "RTN","RCD PEARL",191 ,0)
  9728    .N J,C S  (J,C)=0 F   S J=$O(^R CY(344.4,R CIEN,1,J))  Q:'J!RSLT   S X=$G(^ (J,0)) D
  9729   "RTN","RCD PEARL",192 ,0)
  9730    ..S PF=36 1.1,RSLT=" ^no pointe r to "_PF
  9731   "RTN","RCD PEARL",193 ,0)
  9732    ..S Y=+$P (X,U,2) Q: '(Y>0)  S  C=C+1
  9733   "RTN","RCD PEARL",194 ,0)
  9734    ..S RSLT= "^sub-file  344.41 to tal checke d "_C,F=$$ PTR4302(PF _";"_Y) S: F RSLT=F
  9735   "RTN","RCD PEARL",195 ,0)
  9736    ;
  9737   "RTN","RCD PEARL",196 ,0)
  9738    ; AR BATC H PAYMENT  file #344,  (#.18) ER A REFERENC E [18P:344 .4]
  9739   "RTN","RCD PEARL",197 ,0)
  9740    I RCFLNUM =344 D  Q  RSLT
  9741   "RTN","RCD PEARL",198 ,0)
  9742    .S X=$G(^ RCY(344,RC IEN,0)) Q: X=""
  9743   "RTN","RCD PEARL",199 ,0)
  9744    .S PF=344 .4,Y=+$P(X ,U,18),RSL T="^no poi nter to "_ PF Q:'(Y>0 )
  9745   "RTN","RCD PEARL",200 ,0)
  9746    .S RSLT=$ $PTR4302(P F_";"_Y)
  9747   "RTN","RCD PEARL",201 ,0)
  9748    ;
  9749   "RTN","RCD PEARL",202 ,0)
  9750    ; finishe d all chec ks, valid  file numbe r not foun d
  9751   "RTN","RCD PEARL",203 ,0)
  9752    S RSLT=U_ "invalid f ile #"_RCF LNUM
  9753   "RTN","RCD PEARL",204 ,0)
  9754    ;
  9755   "RTN","RCD PEARL",205 ,0)
  9756    Q RSLT
  9757   "RTN","RCD PEARL",206 ,0)
  9758    ;
  9759   "RTN","RCD PEARL",207 ,0)
  9760   SL(T,RCLNC NT,RC2GLBL ) ; Set te xt into gl obal or wr ite line
  9761   "RTN","RCD PEARL",208 ,0)
  9762    ; T = tex t to outpu t
  9763   "RTN","RCD PEARL",209 ,0)
  9764    ; RCLNCNT  = line co unter, pas sed by ref . (optiona l)
  9765   "RTN","RCD PEARL",210 ,0)
  9766    ; RC2GLBL  = if non- null indic ates outpu t to globa l, no writ es
  9767   "RTN","RCD PEARL",211 ,0)
  9768    I $G(RC2G LBL)="" W  !,T Q
  9769   "RTN","RCD PEARL",212 ,0)
  9770    S RCLNCNT =RCLNCNT+1 ,^TMP($J,R C2GLBL,RCL NCNT)=T
  9771   "RTN","RCD PEARL",213 ,0)
  9772    Q
  9773   "RTN","RCD PEARL",214 ,0)
  9774    ;
  9775   "RTN","RCD PEARL",215 ,0)
  9776   UP(A) ; Re turns UPPE RCASE
  9777   "RTN","RCD PEARL",216 ,0)
  9778    Q $$UP^XL FSTR(A)
  9779   "RTN","RCD PECH")
  9780   0^1^B99242 60
  9781   "RTN","RCD PECH",1,0)
  9782   RCDPECH ;A LB/PJH - R ECEIPT COM MENT HISTO RY ;24-FEB -03
  9783   "RTN","RCD PECH",2,0)
  9784    ;;4.5;Acc ounts Rece ivable;**1 73,276,321 **;Mar 20,  1995;Buil d 46
  9785   "RTN","RCD PECH",3,0)
  9786    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  9787   "RTN","RCD PECH",4,0)
  9788    Q
  9789   "RTN","RCD PECH",5,0)
  9790    ;
  9791   "RTN","RCD PECH",6,0)
  9792   AUDIT(RCRC PT,RCLINE, RCZ,RCR) ; EP store e ntry in RC DPE COMMEN T HISTORY
  9793   "RTN","RCD PECH",7,0)
  9794    ;Input
  9795   "RTN","RCD PECH",8,0)
  9796    ; RCRCPT  - Receipt  IEN #344
  9797   "RTN","RCD PECH",9,0)
  9798    ; RCLINE  - Receipt  line numbe r
  9799   "RTN","RCD PECH",10,0 )
  9800    ; RCZ     - Scratchp ad IEN (op tional)
  9801   "RTN","RCD PECH",11,0 )
  9802    ; RCR     - Scratchp ad line nu mber (opti onal)
  9803   "RTN","RCD PECH",12,0 )
  9804    ;Output
  9805   "RTN","RCD PECH",13,0 )
  9806    ; Write r ecord to # 344.73 - R CDPE COMME NT HISTORY
  9807   "RTN","RCD PECH",14,0 )
  9808    ;
  9809   "RTN","RCD PECH",15,0 )
  9810    Q:'$G(RCR CPT)
  9811   "RTN","RCD PECH",16,0 )
  9812    Q:'$G(RCL INE)
  9813   "RTN","RCD PECH",17,0 )
  9814    ;
  9815   "RTN","RCD PECH",18,0 )
  9816    N RCCOM,R CDATE,RCUS ER
  9817   "RTN","RCD PECH",19,0 )
  9818    ; Use scr atchpad as  data sour ce if pass ed
  9819   "RTN","RCD PECH",20,0 )
  9820    I $G(RCZ) ,$G(RCR) D   Q:RCCOM= ""
  9821   "RTN","RCD PECH",21,0 )
  9822    . S RCCOM =$$GET1^DI Q(344.491, RCR_","_RC Z_",",.1)
  9823   "RTN","RCD PECH",22,0 )
  9824    . S RCUSE R=$$GET1^D IQ(344.491 ,RCR_","_R CZ_",",2.0 3,"I")
  9825   "RTN","RCD PECH",23,0 )
  9826    . S RCDAT E=$$GET1^D IQ(344.491 ,RCR_","_R CZ_",",2.0 4,"I")
  9827   "RTN","RCD PECH",24,0 )
  9828    ; Otherwi se use rec eipt field s and curr ent user/t ime
  9829   "RTN","RCD PECH",25,0 )
  9830    E  D  Q:R CCOM=""
  9831   "RTN","RCD PECH",26,0 )
  9832    . S RCDAT E=$$NOW^XL FDT
  9833   "RTN","RCD PECH",27,0 )
  9834    . S RCCOM =$$GET1^DI Q(344.01,R CLINE_","_ RCRCPT_"," ,1.02)
  9835   "RTN","RCD PECH",28,0 )
  9836    . S RCUSE R=DUZ
  9837   "RTN","RCD PECH",29,0 )
  9838    ; Use cur rent date  if origina l date is  not found
  9839   "RTN","RCD PECH",30,0 )
  9840    I 'RCDATE  S RCDATE= $$NOW^XLFD T
  9841   "RTN","RCD PECH",31,0 )
  9842    ; Use cur rent user  if origina l user not  found
  9843   "RTN","RCD PECH",32,0 )
  9844    I 'RCUSER  S RCUSER= DUZ
  9845   "RTN","RCD PECH",33,0 )
  9846    ;
  9847   "RTN","RCD PECH",34,0 )
  9848    N RCAUDIT
  9849   "RTN","RCD PECH",35,0 )
  9850    ;
  9851   "RTN","RCD PECH",36,0 )
  9852    ; Set up  array for  UPDATE^DIE
  9853   "RTN","RCD PECH",37,0 )
  9854    S RCAUDIT (344.73,"+ 1,",.01)=R CRCPT ;Rec eipt
  9855   "RTN","RCD PECH",38,0 )
  9856    S RCAUDIT (344.73,"+ 1,",1)=RCL INE   ;Rec eipt line  number
  9857   "RTN","RCD PECH",39,0 )
  9858    S RCAUDIT (344.73,"+ 1,",2)=RCU SER   ;Use r
  9859   "RTN","RCD PECH",40,0 )
  9860    S RCAUDIT (344.73,"+ 1,",3)=RCD ATE   ;Dat e
  9861   "RTN","RCD PECH",41,0 )
  9862    S RCAUDIT (344.73,"+ 1,",4)=RCC OM    ;Com ment
  9863   "RTN","RCD PECH",42,0 )
  9864    ;
  9865   "RTN","RCD PECH",43,0 )
  9866    ; Update  file
  9867   "RTN","RCD PECH",44,0 )
  9868    D UPDATE^ DIE(,"RCAU DIT")
  9869   "RTN","RCD PECH",45,0 )
  9870    Q
  9871   "RTN","RCD PECH",46,0 )
  9872    ;
  9873   "RTN","RCD PECH",47,0 )
  9874   GET(RETURN ,RCRCPT,RC LINE) ;EP  Get commen t history  for a rece ipt
  9875   "RTN","RCD PECH",48,0 )
  9876    ;Input
  9877   "RTN","RCD PECH",49,0 )
  9878    ; RCRCPT  - Receipt  IEN
  9879   "RTN","RCD PECH",50,0 )
  9880    ; RCLINE  - Receipt  line numbe r
  9881   "RTN","RCD PECH",51,0 )
  9882    ;Output
  9883   "RTN","RCD PECH",52,0 )
  9884    ; RETURN( N) = Date  ^ User Nam e ^ Commen t text
  9885   "RTN","RCD PECH",53,0 )
  9886    ;
  9887   "RTN","RCD PECH",54,0 )
  9888    Q:'$G(RCR CPT)  Q:'$ G(RCLINE)
  9889   "RTN","RCD PECH",55,0 )
  9890    ;
  9891   "RTN","RCD PECH",56,0 )
  9892    N RCCOMM, RCDA,RCDAT E,RCCDT,RC USER
  9893   "RTN","RCD PECH",57,0 )
  9894    ; Return  comments -  most rece nt first i n return a rray
  9895   "RTN","RCD PECH",58,0 )
  9896    S RETURN= 0,RCCDT=99 99999
  9897   "RTN","RCD PECH",59,0 )
  9898    F  S RCCD T=$O(^RCY( 344.73,"AC ",RCRCPT,R CLINE,RCCD T),-1) Q:' RCCDT  D
  9899   "RTN","RCD PECH",60,0 )
  9900    . S RCDA= $G(^RCY(34 4.73,"AC", RCRCPT,RCL INE,RCCDT) ) Q:'RCDA
  9901   "RTN","RCD PECH",61,0 )
  9902    . ; Get c omments an d user det ails
  9903   "RTN","RCD PECH",62,0 )
  9904    . S RCCOM =$$GET1^DI Q(344.73,R CDA_",",4)
  9905   "RTN","RCD PECH",63,0 )
  9906    . S RCUSE R=$$GET1^D IQ(344.73, RCDA_",",2 ,"E")
  9907   "RTN","RCD PECH",64,0 )
  9908    . S RCDAT E=$$GET1^D IQ(344.73, RCDA_",",3 ,"E")
  9909   "RTN","RCD PECH",65,0 )
  9910    . S RETUR N=RETURN+1 ,RETURN(RE TURN)=RCDA TE_U_RCUSE R_U_RCCOM
  9911   "RTN","RCD PECH",66,0 )
  9912    Q
  9913   "RTN","RCD PECH",67,0 )
  9914    ;
  9915   "RTN","RCD PECH",68,0 )
  9916   COM() ;EP  Receipt li ne comment  entry
  9917   "RTN","RCD PECH",69,0 )
  9918    ;
  9919   "RTN","RCD PECH",70,0 )
  9920    ;Output
  9921   "RTN","RCD PECH",71,0 )
  9922    ; Y - Com ment text  (3 - 60 ch aracters)
  9923   "RTN","RCD PECH",72,0 )
  9924    ;     or  -1 = abort /timeout
  9925   "RTN","RCD PECH",73,0 )
  9926    ;
  9927   "RTN","RCD PECH",74,0 )
  9928    N DIR,DIR UT,DTOUT,D UOUT,X,Y
  9929   "RTN","RCD PECH",75,0 )
  9930    S DIR("A" )="COMMENT : "
  9931   "RTN","RCD PECH",76,0 )
  9932    S DIR(0)= "SA^1:Coll ected/Clos ed;2:Cance lled;3:Ret urned refu nd;4:Overp ayment;5:I nactive bi ll;"
  9933   "RTN","RCD PECH",77,0 )
  9934    S DIR(0)= DIR(0)_"6: Duplicate  payment;7: Policy ter med;8:Serv ice connec ted;9:Othe r"
  9935   "RTN","RCD PECH",78,0 )
  9936    D ^DIR Q: $D(DTOUT)! $D(DUOUT)  -1
  9937   "RTN","RCD PECH",79,0 )
  9938    ; If sele ction is n ot 'Other'  use selec tion as co mment text
  9939   "RTN","RCD PECH",80,0 )
  9940    I Y'=9 S  Y=Y(0) Q Y
  9941   "RTN","RCD PECH",81,0 )
  9942    ; Otherwi se force e ntry of fr ee text co mment of 3  to 60 cha racters 
  9943   "RTN","RCD PECH",82,0 )
  9944    F  D  Q:Y '=""
  9945   "RTN","RCD PECH",83,0 )
  9946    . S DIR(0 )="344.491 ,.1A",DIR( "A")=" COM MENT TEXT:  "
  9947   "RTN","RCD PECH",84,0 )
  9948    . D ^DIR
  9949   "RTN","RCD PECH",85,0 )
  9950    . I $D(DT OUT)!$D(DU OUT) S Y=- 1 Q
  9951   "RTN","RCD PECH",86,0 )
  9952    . ; Remov e leading  or trailin g spaces
  9953   "RTN","RCD PECH",87,0 )
  9954    . S Y=$$T RIM^XLFSTR (X)
  9955   "RTN","RCD PECH",88,0 )
  9956    . I (Y="" )!(Y="@")  D
  9957   "RTN","RCD PECH",89,0 )
  9958    . . W !," A comment  is require d when cha nging the  status of  an item in  suspense,  Please"
  9959   "RTN","RCD PECH",90,0 )
  9960    . . W !," try again"
  9961   "RTN","RCD PECH",91,0 )
  9962    . . S:Y=" @" Y=""
  9963   "RTN","RCD PECH",92,0 )
  9964    Q Y
  9965   "RTN","RCD PEDA2")
  9966   0^4^B14249 8917
  9967   "RTN","RCD PEDA2",1,0 )
  9968   RCDPEDA2 ; AITC/DW -  ACTIVITY R EPORT ;Feb  17, 2017@ 10:37:00
  9969   "RTN","RCD PEDA2",2,0 )
  9970    ;;4.5;Acc ounts Rece ivable;**3 18,321**;M ar 20, 199 5;Build 46
  9971   "RTN","RCD PEDA2",3,0 )
  9972    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  9973   "RTN","RCD PEDA2",4,0 )
  9974    Q
  9975   "RTN","RCD PEDA2",5,0 )
  9976    ;
  9977   "RTN","RCD PEDA2",6,0 )
  9978   RPT2(INPUT ) ;EP from  RCDPEDAR
  9979   "RTN","RCD PEDA2",7,0 )
  9980    ; Loop th rough EDI  LOCKBOX DE POSIT entr ies
  9981   "RTN","RCD PEDA2",8,0 )
  9982    ; Input:    INPUT                              - A1^A 2^A3^...^A n Where:
  9983   "RTN","RCD PEDA2",9,0 )
  9984    ;                                                 A1  - 1 - Call ed by nigh tly job, 0  otherwise
  9985   "RTN","RCD PEDA2",10, 0)
  9986    ;                                                 A2  - 1 - Disp lay to lis t manager,  0 otherwi se
  9987   "RTN","RCD PEDA2",11, 0)
  9988    ;                                                 A3  - 1 - Deta il report,  0 - Summa ry report
  9989   "RTN","RCD PEDA2",12, 0)
  9990    ;                                                 A4  - Current  Page Numbe r
  9991   "RTN","RCD PEDA2",13, 0)
  9992    ;                                                 A5  - Stop Fla g
  9993   "RTN","RCD PEDA2",14, 0)
  9994    ;                                                 A6  - Start of  Date Rang e
  9995   "RTN","RCD PEDA2",15, 0)
  9996    ;                                                 A7  - End of D ate Range
  9997   "RTN","RCD PEDA2",16, 0)
  9998    ;                                                 A8  - Current  Line Numbe r
  9999   "RTN","RCD PEDA2",17, 0)
  10000    ;                                                 A9  - Internal  Date bein g processe d
  10001   "RTN","RCD PEDA2",18, 0)
  10002    ;                                                 A10 - 1 - Only  Display E FTs with a  debit fla g of 'D'
  10003   "RTN","RCD PEDA2",19, 0)
  10004    ;                                                       0 - Disp lay all EF Ts
  10005   "RTN","RCD PEDA2",20, 0)
  10006    ;           ^TMP(B1, $J,B2,B3)                 = ""
  10007   "RTN","RCD PEDA2",21, 0)
  10008    ;           ^TMP(B1, $J,B2,B3," EFT",B4)       = "" W here:
  10009   "RTN","RCD PEDA2",22, 0)
  10010    ;                                                B1 -  "RCDAILYA CT"
  10011   "RTN","RCD PEDA2",23, 0)
  10012    ;                                                B2 -  Internal  Date from  DATE/TIME  ADDED
  10013   "RTN","RCD PEDA2",24, 0)
  10014    ;                                                      (344.3, . 13)
  10015   "RTN","RCD PEDA2",25, 0)
  10016    ;                                                B3 -  Internal  IEN for 34 4.3
  10017   "RTN","RCD PEDA2",26, 0)
  10018    ;                                                B4 -  Internal  IEN for fi le 344.31
  10019   "RTN","RCD PEDA2",27, 0)
  10020    ; Output:   INPUT                              - A1^A 2^A3^...^A n - The fo llowing pi eces 
  10021   "RTN","RCD PEDA2",28, 0)
  10022    ;                                                                    may be  updated
  10023   "RTN","RCD PEDA2",29, 0)
  10024    ;                                                 A4  - Updated  Page Numbe r
  10025   "RTN","RCD PEDA2",30, 0)
  10026    ;                                                 A5  - Stop Fla g
  10027   "RTN","RCD PEDA2",31, 0)
  10028    ;                                                 A6  - Updated  Line numbe r
  10029   "RTN","RCD PEDA2",32, 0)
  10030    ;           ^TMP($J, "TOTALS"," DEBIT")        - Curr ent Total  # of debit s for date  range
  10031   "RTN","RCD PEDA2",33, 0)
  10032    ;           ^TMP($J, "TOTALS"," DEBIT","D" )   - Tota l # of deb its for In ternal dat e (C1)
  10033   "RTN","RCD PEDA2",34, 0)
  10034    ;           ^TMP($J, "TOTALS"," DEBITA")       - Curr ent Total  Debit Amou nt for dat e range
  10035   "RTN","RCD PEDA2",35, 0)
  10036    ;           ^TMP($J, "TOTALS"," DEBITA","D ")  - Tota l Debit Am ount for I nternal da te (C1)
  10037   "RTN","RCD PEDA2",36, 0)
  10038    ;           ^TMP($J, "TOTALS"," DEP",C1)       - Tota l # of dep osits by I nternal da te (C1)
  10039   "RTN","RCD PEDA2",37, 0)
  10040    ;           ^TMP($J, "TOTALS"," DEPA",C1)      - Tota l Deposit  Amount by  Internal d ate (C1)
  10041   "RTN","RCD PEDA2",38, 0)
  10042    ;           ^TMP($J, "TOTALS"," EFT","D")      - Tota l Deposit  Amount by  EFTs for d ate
  10043   "RTN","RCD PEDA2",39, 0)
  10044    ;           ^TMP($J, "TOTALS"," FMS")          - FMS  Document S tatus or " NO FMS DOC "
  10045   "RTN","RCD PEDA2",40, 0)
  10046    ;           ^TMP($J, "TOTALS"," FMS","D",- 1)  - Tota l Deposit  Amount by  FMS Docume nt
  10047   "RTN","RCD PEDA2",41, 0)
  10048    ;           ^TMP($J, "TOTALS"," FMS","D",0 )   - Tota l Amount f or Error/R ejected do cuments
  10049   "RTN","RCD PEDA2",42, 0)
  10050    ;           ^TMP($J, "TOTALS"," FMS","D",1 ")  - Tota l Amount f or 'A','M' ,"F' or 'T ' docs
  10051   "RTN","RCD PEDA2",43, 0)
  10052    ;           ^TMP($J, "TOTALS"," FMS","D",2 ")  - Tota l Amount f or queued  docs
  10053   "RTN","RCD PEDA2",44, 0)
  10054    ;           ^TMP($J, "TOTALS"," FMSTOT")       - Upda ted Total  Deposit Am ount for d ate range
  10055   "RTN","RCD PEDA2",45, 0)
  10056    ;           ^TMP($J, "TOTALS"," MATCH","D" )   - Curr ent Total  matched EF Ts for dat e
  10057   "RTN","RCD PEDA2",46, 0)
  10058    N CRDOC,D ETL,DLNCT, DTADD,IEN3 44,IEN3443 ,IEN34431, TOTDEP,Q,X ,XX,YY
  10059   "RTN","RCD PEDA2",47, 0)
  10060    S DETL=$P (INPUT,"^" ,3),DTADD= $P(INPUT," ^",9)
  10061   "RTN","RCD PEDA2",48, 0)
  10062    ;
  10063   "RTN","RCD PEDA2",49, 0)
  10064    ; Clear t he followi ng daily t otals
  10065   "RTN","RCD PEDA2",50, 0)
  10066    K ^TMP($J ,"TOTALS", "EFT","D")
  10067   "RTN","RCD PEDA2",51, 0)
  10068    K ^TMP($J ,"TOTALS", "FMS","D")
  10069   "RTN","RCD PEDA2",52, 0)
  10070    K ^TMP($J ,"TOTALS", "MATCH","D ")
  10071   "RTN","RCD PEDA2",53, 0)
  10072    K ^TMP($J ,"TOTALS", "DEBIT","D ")             ;PRCA* 4.5*321 Ad d Debit fl ag logic
  10073   "RTN","RCD PEDA2",54, 0)
  10074    K ^TMP($J ,"TOTALS", "DEBITA"," D")
  10075   "RTN","RCD PEDA2",55, 0)
  10076    K ^TMP($J ,"ONEDEP") ,^TMP($J," DEPERRS")      ;PRCA* 4.5*321
  10077   "RTN","RCD PEDA2",56, 0)
  10078    S IEN3443 ="",DLNCT= 0                         ;PRCA* 4.5*321 Ad d DLNCT
  10079   "RTN","RCD PEDA2",57, 0)
  10080    F  D  Q:I EN3443=""   Q:$P(INPU T,"^",5)=1
  10081   "RTN","RCD PEDA2",58, 0)
  10082    . S IEN34 43=$O(^TMP ("RCDAILYA CT",$J,DTA DD,IEN3443 ))
  10083   "RTN","RCD PEDA2",59, 0)
  10084    . Q:IEN34 43=""
  10085   "RTN","RCD PEDA2",60, 0)
  10086    . S XX=$$ GET1^DIQ(3 44.3,IEN34 43,.03,"I" )       ;  IEN for 34 4.1
  10087   "RTN","RCD PEDA2",61, 0)
  10088    . S IEN34 4=+$O(^RCY (344,"AD", +XX,0))            ;  IEN for 34 4
  10089   "RTN","RCD PEDA2",62, 0)
  10090    . S XX=$G (^TMP($J," TOTALS","D EP",DTADD) )
  10091   "RTN","RCD PEDA2",63, 0)
  10092    . S ^TMP( $J,"TOTALS ","DEP",DT ADD)=XX+1          ;  # of depos its for da y
  10093   "RTN","RCD PEDA2",64, 0)
  10094    . S TOTDE P=$$GET1^D IQ(344.3,I EN3443,.08 ,"I")   ;  Total Depo sit Amount
  10095   "RTN","RCD PEDA2",65, 0)
  10096    . S XX=$G (^TMP($J," TOTALS","D EPA",DTADD ))
  10097   "RTN","RCD PEDA2",66, 0)
  10098    . S ^TMP( $J,"TOTALS ","DEPA",D TADD)=XX+T OTDEP   ;  Total Depo sit Amount  for day
  10099   "RTN","RCD PEDA2",67, 0)
  10100    . S CRDOC =$$GET1^DI Q(344,IEN3 44,200,"I" )       ;  FMS Docume nt Number
  10101   "RTN","RCD PEDA2",68, 0)
  10102    . S ^TMP( $J,"TOTALS ","CRDOC", IEN3443)=C RDOC
  10103   "RTN","RCD PEDA2",69, 0)
  10104    . I CRDOC ="" D                                    ;  No FMS Doc ument Numb er
  10105   "RTN","RCD PEDA2",70, 0)
  10106    . . S YY= $G(^TMP($J ,"TOTALS", "FMS","D", -1))
  10107   "RTN","RCD PEDA2",71, 0)
  10108    . . S ^TM P($J,"TOTA LS","FMS", "D",-1)=YY +TOTDEP
  10109   "RTN","RCD PEDA2",72, 0)
  10110    . . S ^TM P($J,"TOTA LS","FMS") ="NO FMS D OC"
  10111   "RTN","RCD PEDA2",73, 0)
  10112    . I CRDOC '="" D                                   ;  FMS Docume nt Number  found
  10113   "RTN","RCD PEDA2",74, 0)
  10114    . . S YY= $$STATUS^G ECSSGET(CR DOC)               ;  Get the st atus of th e doc
  10115   "RTN","RCD PEDA2",75, 0)
  10116    . . I YY= -1 D  Q                                  ;  Document w asn't foun d
  10117   "RTN","RCD PEDA2",76, 0)
  10118    . . . S X X=$G(^TMP( $J,"TOTALS ","FMS","D ",-1))
  10119   "RTN","RCD PEDA2",77, 0)
  10120    . . . S ^ TMP($J,"TO TALS","FMS ","D",-1)= XX+TOTDEP
  10121   "RTN","RCD PEDA2",78, 0)
  10122    . . . S ^ TMP($J,"TO TALS","FMS ")="STATUS  MISSING"
  10123   "RTN","RCD PEDA2",79, 0)
  10124    . . S XX= $E($P(YY,"  "),1,10)                     ;  First Word  of the st atus
  10125   "RTN","RCD PEDA2",80, 0)
  10126    . . S ^TM P($J,"TOTA LS","FMS") =XX                ;  First Word  of the st atus
  10127   "RTN","RCD PEDA2",81, 0)
  10128    . . S Q=$ E(YY,1)                                  ;  First Char acter of t he status
  10129   "RTN","RCD PEDA2",82, 0)
  10130    . . S Q=$ S(Q="E"!(Q ="R"):0,Q= "Q":2,1:1)         ;  Q=0 - Reje ct or Erro r, 2 - Que ued, 1 - g ood
  10131   "RTN","RCD PEDA2",83, 0)
  10132    . . S XX= $G(^TMP($J ,"TOTALS", "FMS","D", Q))
  10133   "RTN","RCD PEDA2",84, 0)
  10134    . . S ^TM P($J,"TOTA LS","FMS", "D",Q)=XX+ TOTDEP  ;  Rej/Err, Q ueued OR g ood Amount  for day
  10135   "RTN","RCD PEDA2",85, 0)
  10136    . ;
  10137   "RTN","RCD PEDA2",86, 0)
  10138    . D ONEDE P(.INPUT,I EN3443,TOT DEP,.DLNCT )       ;P RCA*4.5*32 1 Gather a nd display  one depos it
  10139   "RTN","RCD PEDA2",87, 0)
  10140    Q
  10141   "RTN","RCD PEDA2",88, 0)
  10142    ;
  10143   "RTN","RCD PEDA2",89, 0)
  10144   ONEDEP(INP UT,IEN3443 ,TOTDEP,DL NCT) ; Gat her and di splay line s for one  Deposit
  10145   "RTN","RCD PEDA2",90, 0)
  10146    ; PRCA*4. 5*321 new  method to  first gath er all the  lines bef ore displa ying them
  10147   "RTN","RCD PEDA2",91, 0)
  10148    ; Input:    INPUT                          - See RPT2  for detai ls
  10149   "RTN","RCD PEDA2",92, 0)
  10150    ;           ^TMP(B1, $J,B2,B3)             - See RPT2  for detai ls
  10151   "RTN","RCD PEDA2",93, 0)
  10152    ;           IEN3443                        - Internal  IEN for f ile 344.3
  10153   "RTN","RCD PEDA2",94, 0)
  10154    ;           TOTDEP                         - Total De posit Amou nt (344.3,  .08)
  10155   "RTN","RCD PEDA2",95, 0)
  10156    ;           DLNCT                          - Current  # of depos it lines d isplayed
  10157   "RTN","RCD PEDA2",96, 0)
  10158    ;           ^TMP($J, "DEPERRS")            - Current  Line Count
  10159   "RTN","RCD PEDA2",97, 0)
  10160    ;                                            Note: On ly passed  if not in  detail mod e
  10161   "RTN","RCD PEDA2",98, 0)
  10162    ;           ^TMP($J, "DEPERRS,X ) - Error  line(s)
  10163   "RTN","RCD PEDA2",99, 0)
  10164    ; Output:   INPUT                          - See RPT2  for detai ls
  10165   "RTN","RCD PEDA2",100 ,0)
  10166    ;           DLNCT                          - Updated  # of depos it lines d isplayed
  10167   "RTN","RCD PEDA2",101 ,0)
  10168    ;           ^TMP(B1, $J,B2,B3," EFT",B4)   - See RPT2  for detai ls
  10169   "RTN","RCD PEDA2",102 ,0)
  10170    ;           ^TMP($J, "TOTALS"," DEP",C1)   - See RPT2  for detai ls
  10171   "RTN","RCD PEDA2",103 ,0)
  10172    ;           ^TMP($J, "DEPERRS")            - Updated  Line Count
  10173   "RTN","RCD PEDA2",104 ,0)
  10174    ;                                            Note: On ly passed  if not in  detail mod e
  10175   "RTN","RCD PEDA2",105 ,0)
  10176    N CURLNS, DEPLNS,DET L,DTADD,EF TCTR,EFTLN ,EFTLNS,LS TMAN,XX,YY ,ZZ
  10177   "RTN","RCD PEDA2",106 ,0)
  10178    S DETL=$P (INPUT,"^" ,3)
  10179   "RTN","RCD PEDA2",107 ,0)
  10180    S DTADD=$ P(INPUT,"^ ",9)
  10181   "RTN","RCD PEDA2",108 ,0)
  10182    K:DETL ^T MP($J,"ONE DEP"),^TMP ($J,"DEPER RS")
  10183   "RTN","RCD PEDA2",109 ,0)
  10184    S LSTMAN= $P(INPUT," ^",2)
  10185   "RTN","RCD PEDA2",110 ,0)
  10186    I DETL D                                       ; Gath er Detail  Line
  10187   "RTN","RCD PEDA2",111 ,0)
  10188    . D DETLN (.INPUT,IE N3443,TOTD EP)
  10189   "RTN","RCD PEDA2",112 ,0)
  10190    S ^TMP($J ,"TOTALS", "FMSTOT")= 0              ; Init ialize FMS  total for  range
  10191   "RTN","RCD PEDA2",113 ,0)
  10192    D ERRMSGS ^RCDPEDA4( .INPUT,IEN 3443)          ; Gath er any err or message  lines
  10193   "RTN","RCD PEDA2",114 ,0)
  10194    D PROCEFT (.INPUT,IE N3443)                    ; Gath er lines f or EFT rec ords
  10195   "RTN","RCD PEDA2",115 ,0)
  10196    Q:'DETL
  10197   "RTN","RCD PEDA2",116 ,0)
  10198    ;
  10199   "RTN","RCD PEDA2",117 ,0)
  10200    ; Determi ne overall  line coun t for depo sit
  10201   "RTN","RCD PEDA2",118 ,0)
  10202    S ZZ=1                             ; depos it line (1 st line pe r record)                   
  10203   "RTN","RCD PEDA2",119 ,0)
  10204    S ZZ=ZZ+$ G(^TMP($J, "DEPERRS") )  ; depos it errors  line cnt
  10205   "RTN","RCD PEDA2",120 ,0)
  10206    S XX=0 F  XX=$O(^TMP ($J,"ONEDE P",XX)) D   Q:XX=""
  10207   "RTN","RCD PEDA2",121 ,0)
  10208    . S ZZ=ZZ +$G(^TMP($ J,"ONEDEP" ,XX))
  10209   "RTN","RCD PEDA2",122 ,0)
  10210    S DEPLNS= ZZ
  10211   "RTN","RCD PEDA2",123 ,0)
  10212    ;
  10213   "RTN","RCD PEDA2",124 ,0)
  10214    ; If not  outputting  to listma n and at l east 1 dep osit is al ready disp layed
  10215   "RTN","RCD PEDA2",125 ,0)
  10216    ; on the  page, chec k to see i f we have  don't have  room to d isplay the  
  10217   "RTN","RCD PEDA2",126 ,0)
  10218    ; deposit  detail li ne
  10219   "RTN","RCD PEDA2",127 ,0)
  10220    I 'LSTMAN ,DLNCT,(DL NCT+DEPLNS +2)>IOSL D   Q:$P(INP UT,"^",5)= 1
  10221   "RTN","RCD PEDA2",128 ,0)
  10222    . S DLNCT =0
  10223   "RTN","RCD PEDA2",129 ,0)
  10224    . D NEWDH DR(.INPUT, DTADD)
  10225   "RTN","RCD PEDA2",130 ,0)
  10226    . Q:$P(IN PUT,"^",5) =1
  10227   "RTN","RCD PEDA2",131 ,0)
  10228    ; Display  first dep osit line
  10229   "RTN","RCD PEDA2",132 ,0)
  10230    S DLNCT=D LNCT+1
  10231   "RTN","RCD PEDA2",133 ,0)
  10232    S XX=^TMP ($J,"ONEDE P",0,1)
  10233   "RTN","RCD PEDA2",134 ,0)
  10234    D SL^RCDP EDA3(.INPU T,XX)
  10235   "RTN","RCD PEDA2",135 ,0)
  10236    ;
  10237   "RTN","RCD PEDA2",136 ,0)
  10238    ; If not  outputting  to listma n, check t o see if w e have don 't have ro om to
  10239   "RTN","RCD PEDA2",137 ,0)
  10240    ; display  any depos it error i nfo
  10241   "RTN","RCD PEDA2",138 ,0)
  10242    S XX=$G(^ TMP($J,"DE PERRS"))
  10243   "RTN","RCD PEDA2",139 ,0)
  10244    I 'LSTMAN ,XX,XX<IOS L,(DLNCT+X X)>IOSL D   Q:$P(INPU T,"^",5)=1
  10245   "RTN","RCD PEDA2",140 ,0)
  10246    . S DLNCT =0
  10247   "RTN","RCD PEDA2",141 ,0)
  10248    . D NEWDH DR(.INPUT, DTADD)
  10249   "RTN","RCD PEDA2",142 ,0)
  10250    . Q:$P(IN PUT,"^",5) =1 
  10251   "RTN","RCD PEDA2",143 ,0)
  10252    S DLNCT=D LNCT+XX
  10253   "RTN","RCD PEDA2",144 ,0)
  10254    ;
  10255   "RTN","RCD PEDA2",145 ,0)
  10256    ; Display  Deposit E rror (if a ny)
  10257   "RTN","RCD PEDA2",146 ,0)
  10258    S XX=""
  10259   "RTN","RCD PEDA2",147 ,0)
  10260    F  D  Q:X X=""
  10261   "RTN","RCD PEDA2",148 ,0)
  10262    . S XX=$O (^TMP($J," DEPERRS",X X))
  10263   "RTN","RCD PEDA2",149 ,0)
  10264    . Q:XX=""
  10265   "RTN","RCD PEDA2",150 ,0)
  10266    . S YY=^T MP($J,"DEP ERRS",XX)
  10267   "RTN","RCD PEDA2",151 ,0)
  10268    . D SL^RC DPEDA3(.IN PUT,YY)
  10269   "RTN","RCD PEDA2",152 ,0)
  10270    ;
  10271   "RTN","RCD PEDA2",153 ,0)
  10272    ; Display  Remaining  Deposit l ines one E FT at a ti me
  10273   "RTN","RCD PEDA2",154 ,0)
  10274    S EFTCTR= 0
  10275   "RTN","RCD PEDA2",155 ,0)
  10276    F  D  Q:E FTCTR=""   Q:$P(INPUT ,"^",5)=1
  10277   "RTN","RCD PEDA2",156 ,0)
  10278    . S EFTCT R=$O(^TMP( $J,"ONEDEP ",EFTCTR))
  10279   "RTN","RCD PEDA2",157 ,0)
  10280    . Q:EFTCT R=""
  10281   "RTN","RCD PEDA2",158 ,0)
  10282    . ;
  10283   "RTN","RCD PEDA2",159 ,0)
  10284    . ; If no t outputti ng to list man, check  to see if  we have d on't have  room to
  10285   "RTN","RCD PEDA2",160 ,0)
  10286    . ; displ ay any EFT
  10287   "RTN","RCD PEDA2",161 ,0)
  10288    . S EFTLN S=$G(^TMP( $J,"ONEDEP ",EFTCTR))
  10289   "RTN","RCD PEDA2",162 ,0)
  10290    . I 'LSTM AN,EFTLNS< IOSL,(DLNC T+EFTLNS)> IOSL D  Q: $P(INPUT," ^",5)=1
  10291   "RTN","RCD PEDA2",163 ,0)
  10292    . . D NEW DHDR(.INPU T,DTADD)
  10293   "RTN","RCD PEDA2",164 ,0)
  10294    . . Q:$P( INPUT,"^", 5)=1
  10295   "RTN","RCD PEDA2",165 ,0)
  10296    . . S XX= ^TMP($J,"O NEDEP",0,1 )
  10297   "RTN","RCD PEDA2",166 ,0)
  10298    . . D SL^ RCDPEDA3(. INPUT,XX)
  10299   "RTN","RCD PEDA2",167 ,0)
  10300    . . S DLN CT=1
  10301   "RTN","RCD PEDA2",168 ,0)
  10302    . S EFTLN =""
  10303   "RTN","RCD PEDA2",169 ,0)
  10304    . F  D  Q :EFTLN=""
  10305   "RTN","RCD PEDA2",170 ,0)
  10306    . . S EFT LN=$O(^TMP ($J,"ONEDE P",EFTCTR, EFTLN))
  10307   "RTN","RCD PEDA2",171 ,0)
  10308    . . Q:EFT LN=""
  10309   "RTN","RCD PEDA2",172 ,0)
  10310    . . S ZZ= ^TMP($J,"O NEDEP",EFT CTR,EFTLN)
  10311   "RTN","RCD PEDA2",173 ,0)
  10312    . . D SL^ RCDPEDA3(. INPUT,ZZ)
  10313   "RTN","RCD PEDA2",174 ,0)
  10314    . . S DLN CT=DLNCT+1
  10315   "RTN","RCD PEDA2",175 ,0)
  10316    Q
  10317   "RTN","RCD PEDA2",176 ,0)
  10318    ;
  10319   "RTN","RCD PEDA2",177 ,0)
  10320   NEWDHDR(IN PUT,DTADD)  ; display  a new dep osit heade r for the  specified  date
  10321   "RTN","RCD PEDA2",178 ,0)
  10322    ; Input:    INPUT    - See RPT2  for detai ls
  10323   "RTN","RCD PEDA2",179 ,0)
  10324    ;           DTADD    - Internal  Date depo sit are be ing displa yed for
  10325   "RTN","RCD PEDA2",180 ,0)
  10326    N XX
  10327   "RTN","RCD PEDA2",181 ,0)
  10328    D HDR^RCD PEDA3(.INP UT)
  10329   "RTN","RCD PEDA2",182 ,0)
  10330    Q:$P(INPU T,"^",5)=1    ; user  quit or ti med out
  10331   "RTN","RCD PEDA2",183 ,0)
  10332    S XX="DAT E EFT DEPO SIT RECEIV ED: "_$$FM TE^XLFDT(D TADD,"2Z")
  10333   "RTN","RCD PEDA2",184 ,0)
  10334    S XX=$J(" ",80-$L(XX )\2)_XX                ; Center  it
  10335   "RTN","RCD PEDA2",185 ,0)
  10336    D SL^RCDP EDA3(.INPU T,XX)
  10337   "RTN","RCD PEDA2",186 ,0)
  10338    D SL^RCDP EDA3(.INPU T," ")
  10339   "RTN","RCD PEDA2",187 ,0)
  10340    Q
  10341   "RTN","RCD PEDA2",188 ,0)
  10342    ;
  10343   "RTN","RCD PEDA2",189 ,0)
  10344   DETLN(INPU T,IEN3443, TOTDEP) ;  Display de tail line
  10345   "RTN","RCD PEDA2",190 ,0)
  10346    ; Input:    INPUT                     - Se e RPT2 for  details
  10347   "RTN","RCD PEDA2",191 ,0)
  10348    ;           IEN3443                   - In ternal IEN  for file  344.3
  10349   "RTN","RCD PEDA2",192 ,0)
  10350    ;           TOTDEP                    - To tal Deposi t Amount ( 344.3, .08 )
  10351   "RTN","RCD PEDA2",193 ,0)
  10352    ;           ^TMP($J, "TOTALS"," FMS") - FM S Document  # or "NO  FMS DOC"
  10353   "RTN","RCD PEDA2",194 ,0)
  10354    ; Output:   INPUT                     - A1 ^A2^A3^... ^An - The  following  pieces may  be update d
  10355   "RTN","RCD PEDA2",195 ,0)
  10356    ;                                          A5 - Updat ed Page Nu mber
  10357   "RTN","RCD PEDA2",196 ,0)
  10358    ;                                          A6 - Stop  Flag
  10359   "RTN","RCD PEDA2",197 ,0)
  10360    ;                                          A8 - Updat ed Line Co unter
  10361   "RTN","RCD PEDA2",198 ,0)
  10362    ;
  10363   "RTN","RCD PEDA2",199 ,0)
  10364    N DTADD,D ETL,LSTMAN ,NJ,X,XX,Y Y
  10365   "RTN","RCD PEDA2",200 ,0)
  10366    S LSTMAN= $P(INPUT," ^",2),NJ=$ P(INPUT,"^ ",1)
  10367   "RTN","RCD PEDA2",201 ,0)
  10368    S DETL=$P (INPUT,"^" ,3)
  10369   "RTN","RCD PEDA2",202 ,0)
  10370    S XX=$$GE T1^DIQ(344 .3,IEN3443 ,.06,"I")          ;  Deposit Nu mber
  10371   "RTN","RCD PEDA2",203 ,0)
  10372    ;
  10373   "RTN","RCD PEDA2",204 ,0)
  10374    ; PRCA*4. 5*283 - ch ange lengt h of DEP #  from 6 to  9 to allo w for 9 di git DEP #' s
  10375   "RTN","RCD PEDA2",205 ,0)
  10376    S X=$$SET STR^VALM1( XX,"",1,9)
  10377   "RTN","RCD PEDA2",206 ,0)
  10378    ;
  10379   "RTN","RCD PEDA2",207 ,0)
  10380    ; Change  DEPOSIT DT 's startin g position  from 9 to  12
  10381   "RTN","RCD PEDA2",208 ,0)
  10382    S YY=$$GE T1^DIQ(344 .3,IEN3443 ,.07,"I")          ;  Deposit Da te
  10383   "RTN","RCD PEDA2",209 ,0)
  10384    S X=$$SET STR^VALM1( $$FMTE^XLF DT(YY\1,"2 Z"),X,12,1 0)
  10385   "RTN","RCD PEDA2",210 ,0)
  10386    ;
  10387   "RTN","RCD PEDA2",211 ,0)
  10388    ; Change  starting p osition fr om 21 to 2 3 & reduce  length of  spaces fr om 10 to 8 .
  10389   "RTN","RCD PEDA2",212 ,0)
  10390    S X=$$SET STR^VALM1( "",X,23,8)
  10391   "RTN","RCD PEDA2",213 ,0)
  10392    S X=$$SET STR^VALM1( "",X,32,10 )
  10393   "RTN","RCD PEDA2",214 ,0)
  10394    S XX=^TMP ($J,"TOTAL S","FMS")
  10395   "RTN","RCD PEDA2",215 ,0)
  10396    S X=$$SET STR^VALM1( $E($J(TOTD EP,"",2)_$ J("",20),1 ,20)_XX,X, 43,37)
  10397   "RTN","RCD PEDA2",216 ,0)
  10398    S ^TMP($J ,"ONEDEP", 0,1)=X     ; PRCA*4.5 *321
  10399   "RTN","RCD PEDA2",217 ,0)
  10400    Q
  10401   "RTN","RCD PEDA2",218 ,0)
  10402    ;
  10403   "RTN","RCD PEDA2",219 ,0)
  10404   PROCEFT(IN PUT,IEN344 3)  ; Proc ess EFT re cords
  10405   "RTN","RCD PEDA2",220 ,0)
  10406    ; Input:    INPUT                              - See  RPT2 for d etails
  10407   "RTN","RCD PEDA2",221 ,0)
  10408    ;           IEN3443                            - Inte rnal IEN f or file 34 4.3
  10409   "RTN","RCD PEDA2",222 ,0)
  10410    ;           ^TMP($J, "ONEDEP",0 ,1)            - Depo sit Detail  line
  10411   "RTN","RCD PEDA2",223 ,0)
  10412    ;           ^TMP($J, "TOTALS"," DEBIT","D" )   - Curr ent Total  # of Debit  EFTs for  date
  10413   "RTN","RCD PEDA2",224 ,0)
  10414    ;           ^TMP($J, "TOTALS"," DEBITA","D ")  - Curr ent Total  Amount of  Debit EFTs  for date
  10415   "RTN","RCD PEDA2",225 ,0)
  10416    ;           ^TMP($J, "TOTALS"," EFT","D")      - Curr ent Total  Deposit Am ount by EF Ts for dat e
  10417   "RTN","RCD PEDA2",226 ,0)
  10418    ;           ^TMP($J, "TOTALS"," MATCH","D" )   - Curr ent Total  matched EF Ts for dat e
  10419   "RTN","RCD PEDA2",227 ,0)
  10420    ;           ^TMP($J, "TOTALS"," FMSTOT")       - Curr ent Total  Deposit Am ount for d ate range
  10421   "RTN","RCD PEDA2",228 ,0)
  10422    ; Output:   INPUT                              - A1^A 2^A3^...^A n - The fo llowing pi eces
  10423   "RTN","RCD PEDA2",229 ,0)
  10424    ;                                                                    may be  updated
  10425   "RTN","RCD PEDA2",230 ,0)
  10426    ;                                                  A5  - Updated  Page Numb er
  10427   "RTN","RCD PEDA2",231 ,0)
  10428    ;                                                  A6  - Stop Fl ag
  10429   "RTN","RCD PEDA2",232 ,0)
  10430    ;                                                  A8  - Updated  Line Coun ter
  10431   "RTN","RCD PEDA2",233 ,0)
  10432    ;       ^ TMP($J,"ON EDEP",0,1)                 - Dep osit Detai l line
  10433   "RTN","RCD PEDA2",234 ,0)
  10434    ;       ^ TMP($J,"ON EDEP","EFT CTR")           - # o f lines fo r This EFT
  10435   "RTN","RCD PEDA2",235 ,0)
  10436    ;       ^ TMP($J,"ON EDEP","EFT CTR",xx)=L INE  - EFT  Lines
  10437   "RTN","RCD PEDA2",236 ,0)
  10438    ;       ^ TMP($J,"TO TALS","DEB IT","D")    - Updated  Total # o f Debit EF Ts for dat e
  10439   "RTN","RCD PEDA2",237 ,0)
  10440    ;       ^ TMP($J,"TO TALS","DEB ITA","D")   - Updated  Total Amo unt of Deb it EFTs fo r date
  10441   "RTN","RCD PEDA2",238 ,0)
  10442    ;       ^ TMP($J,"TO TALS","DEB IT")        - Updated  Total # o f Debit EF Ts for dat e range
  10443   "RTN","RCD PEDA2",239 ,0)
  10444    ;       ^ TMP($J,"TO TALS","DEB ITA")       - Updated  Total Amo unt of Deb it EFTs fo r date ran ge
  10445   "RTN","RCD PEDA2",240 ,0)
  10446    ;       ^ TMP($J,"TO TALS","FMS TOT")       - Updated  Total Dep osit Amoun t for date  range
  10447   "RTN","RCD PEDA2",241 ,0)
  10448    ;       ^ TMP($J,"TO TALS","EFT ","D")      - Updated  Total Dep osit Amoun t by EFTs  for date
  10449   "RTN","RCD PEDA2",242 ,0)
  10450    ;       ^ TMP($J,"TO TALS","MAT CH","D")    - Updated  Total mat ched EFTs  for date
  10451   "RTN","RCD PEDA2",243 ,0)
  10452    N DETL,DF LG,DTADD,E FTCTR,IEN3 4431,PAMT, RCFMS1,TRD OC,X,XX,YY     ; PRCA *4.5*321 A dded DFLG
  10453   "RTN","RCD PEDA2",244 ,0)
  10454    ; PRCA*4. 5*321 capt ure displa y and line  cnt to ^T MP($J,"ONE DEP")
  10455   "RTN","RCD PEDA2",245 ,0)
  10456    S ^TMP($J ,"TOTALS", "FMSTOT")= 0,EFTCTR=0
  10457   "RTN","RCD PEDA2",246 ,0)
  10458    S DTADD=$ P(INPUT,"^ ",9)
  10459   "RTN","RCD PEDA2",247 ,0)
  10460    S RCFMS1= "NO FMS DO C"
  10461   "RTN","RCD PEDA2",248 ,0)
  10462    S DETL=$P (INPUT,"^" ,3)
  10463   "RTN","RCD PEDA2",249 ,0)
  10464    S IEN3443 1=""
  10465   "RTN","RCD PEDA2",250 ,0)
  10466    F  D  Q:I EN34431=""   Q:$P(INP UT,"^",5)= 1
  10467   "RTN","RCD PEDA2",251 ,0)
  10468    . S IEN34 431=$O(^TM P("RCDAILY ACT",$J,DT ADD,IEN344 3,"EFT",IE N34431))
  10469   "RTN","RCD PEDA2",252 ,0)
  10470    . Q:IEN34 431=""
  10471   "RTN","RCD PEDA2",253 ,0)
  10472    . S XX=$G (^TMP($J," TOTALS","E FT","D"))+ 1
  10473   "RTN","RCD PEDA2",254 ,0)
  10474    . S ^TMP( $J,"TOTALS ","EFT","D ")=XX                  ; Total #  EFTs for  date
  10475   "RTN","RCD PEDA2",255 ,0)
  10476    . ;
  10477   "RTN","RCD PEDA2",256 ,0)
  10478    . S YY=$$ GET1^DIQ(3 44.31,IEN3 4431,3,"E" )           ; Debit/C redit flag  ; PRCA*4. 5*321 adde d line
  10479   "RTN","RCD PEDA2",257 ,0)
  10480    . S DFLG= $S(YY="D": 1,1:0)                            ; PRCA*4. 5*321 adde d line
  10481   "RTN","RCD PEDA2",258 ,0)
  10482    . S PAMT= $$GET1^DIQ (344.31,IE N34431,.07 ,"I")       ; Amount  of Payment
  10483   "RTN","RCD PEDA2",259 ,0)
  10484    . I DFLG  D                                            ; PRCA*4. 5*321 adde d if State ment
  10485   "RTN","RCD PEDA2",260 ,0)
  10486    . . S XX= $G(^TMP($J ,"TOTALS", "DEBIT","D "))+1
  10487   "RTN","RCD PEDA2",261 ,0)
  10488    . . S ^TM P($J,"TOTA LS","DEBIT ","D")=XX              ; Total #  Debit EFT s for date
  10489   "RTN","RCD PEDA2",262 ,0)
  10490    . . S XX= $G(^TMP($J ,"TOTALS", "DEBITA"," D"))        ; Total D ebit Amoun ts for dat e
  10491   "RTN","RCD PEDA2",263 ,0)
  10492    . . S ^TM P($J,"TOTA LS","DEBIT A","D")=XX +PAMT
  10493   "RTN","RCD PEDA2",264 ,0)
  10494    . ;
  10495   "RTN","RCD PEDA2",265 ,0)
  10496    . S XX=+$ $GET1^DIQ( 344.31,IEN 34431,.09, "I")        ; Receipt  # from 34 4.31
  10497   "RTN","RCD PEDA2",266 ,0)
  10498    . S TRDOC =$$GET1^DI Q(344,XX,2 00,"I")                ; FMS Doc ument #
  10499   "RTN","RCD PEDA2",267 ,0)
  10500    . S X=$S( TRDOC'="": $$STATUS^G ECSSGET(TR DOC),1:"")
  10501   "RTN","RCD PEDA2",268 ,0)
  10502    . I X'="" ,X'=-1,$E( X,1)'="R", $E(X,1)'=" E" D
  10503   "RTN","RCD PEDA2",269 ,0)
  10504    . . S XX= $G(^TMP($J ,"TOTALS", "FMSTOT"))
  10505   "RTN","RCD PEDA2",270 ,0)
  10506    . . S ^TM P($J,"TOTA LS","FMSTO T")=XX+PAM T           ; Total A mount of P ayment
  10507   "RTN","RCD PEDA2",271 ,0)
  10508    . . S RCF MS1=$S($E( X,1)="Q":" QUEUED TO  POST",1:"P OSTED")
  10509   "RTN","RCD PEDA2",272 ,0)
  10510    . S XX=$S (X="":"",X =-1:"NO FM S DOC",1:$ E($P(X," " ,1),1,10))
  10511   "RTN","RCD PEDA2",273 ,0)
  10512    . S RCFMS 1(IEN34431 )=XX                              ; FMS Doc ument Stat us for EFT
  10513   "RTN","RCD PEDA2",274 ,0)
  10514    . S XX=$$ GET1^DIQ(3 44.31,IEN3 4431,.08," I")         ; Match S tatus
  10515   "RTN","RCD PEDA2",275 ,0)
  10516    . I XX D
  10517   "RTN","RCD PEDA2",276 ,0)
  10518    . . S XX= $G(^TMP($J ,"TOTALS", "MATCH","D "))
  10519   "RTN","RCD PEDA2",277 ,0)
  10520    . . S ^TM P($J,"TOTA LS","MATCH ","D")=XX+ 1           ; Total M atched EFT S by date
  10521   "RTN","RCD PEDA2",278 ,0)
  10522    . I DETL  D                              ; PRCA*4.5*3 21
  10523   "RTN","RCD PEDA2",279 ,0)
  10524    . . S EFT CTR=EFTCTR +1
  10525   "RTN","RCD PEDA2",280 ,0)
  10526    . . D EFT DTL(.INPUT ,IEN3443,I EN34431,.R CFMS1,EFTC TR)
  10527   "RTN","RCD PEDA2",281 ,0)
  10528    . . S YY= $G(^TMP($J ,"ONEDEP", EFTCTR))+1
  10529   "RTN","RCD PEDA2",282 ,0)
  10530    . . S ^TM P($J,"ONED EP",EFTCTR )=YY
  10531   "RTN","RCD PEDA2",283 ,0)
  10532    . . S ^TM P($J,"ONED EP",EFTCTR ,YY)=" "
  10533   "RTN","RCD PEDA2",284 ,0)
  10534    Q
  10535   "RTN","RCD PEDA2",285 ,0)
  10536    ;
  10537   "RTN","RCD PEDA2",286 ,0)
  10538   EFTDTL(INP UT,IEN3443 ,IEN34431, RCFMS1,EFT CTR)   ; D isplay EFT  Detail
  10539   "RTN","RCD PEDA2",287 ,0)
  10540    ; Input:    INPUT                     - Se e RPT2 for  details
  10541   "RTN","RCD PEDA2",288 ,0)
  10542    ;           IEN3443                   - In ternal IEN  for file  344.3
  10543   "RTN","RCD PEDA2",289 ,0)
  10544    ;           IEN34431                  - In ternal IEN  for file  344.31
  10545   "RTN","RCD PEDA2",290 ,0)
  10546    ;           RCFMS1(I EN34431)         - FM S Document  Status fo r EFT IEN
  10547   "RTN","RCD PEDA2",291 ,0)
  10548    ;           EFTCTR                    - Us ed to stor e lines fo r an EFT
  10549   "RTN","RCD PEDA2",292 ,0)
  10550    ;           ^TMP($J, ONEDEP,0,1 )     - De posit Deta il line
  10551   "RTN","RCD PEDA2",293 ,0)
  10552    ; Output:   INPUT                     - Se e RPT2 for  details
  10553   "RTN","RCD PEDA2",294 ,0)
  10554    ;           ^TMP($J, ONEDEP,0,1 )     - De posit Deta il line
  10555   "RTN","RCD PEDA2",295 ,0)
  10556    ;           ^TMP($J, ONEDEP,EFT CTR)  - #  of lines f or EFT
  10557   "RTN","RCD PEDA2",296 ,0)
  10558    ;           ^TMP($J, ONEDEP,EFT CTR,xx)- E FT Deposit  Lines ;PR CA*4.5*321  capture d isplay to  ^TMP($J,"O NEDEP",EFT RCR) inclu ding line  cnt
  10559   "RTN","RCD PEDA2",297 ,0)
  10560    N EFTLN,P AY,PAYER,P AYID,X,XX, YY,ZZ
  10561   "RTN","RCD PEDA2",298 ,0)
  10562    S XX=$$GE T1^DIQ(344 .31,IEN344 31,.01,"I" )       ;  EFT Transa ction IEN
  10563   "RTN","RCD PEDA2",299 ,0)
  10564    S X=$$SET STR^VALM1( XX,"",3,6)
  10565   "RTN","RCD PEDA2",300 ,0)
  10566    S XX=$$GE T1^DIQ(344 .31,IEN344 31,.12,"I" )       ;  Date Claim s Paid
  10567   "RTN","RCD PEDA2",301 ,0)
  10568    S X=$$SET STR^VALM1( $$FMTE^XLF DT(XX\1,"2 Z"),X,31,8 )
  10569   "RTN","RCD PEDA2",302 ,0)
  10570    S XX=$$GE T1^DIQ(344 .31,IEN344 31,.07,"I" )       ;  Amount of  Payment
  10571   "RTN","RCD PEDA2",303 ,0)
  10572    S X=$$SET STR^VALM1( $J(XX,"",2 ),X,41,18)
  10573   "RTN","RCD PEDA2",304 ,0)
  10574    ;
  10575   "RTN","RCD PEDA2",305 ,0)
  10576    ; PRCA*4. 5*284, Mov e to left  3 space (6 1 to 58) t o allow fo r 10 digit  ERA #'s
  10577   "RTN","RCD PEDA2",306 ,0)
  10578    S XX=$$GE T1^DIQ(344 .31,IEN344 31,.08,"I" )       ;  Match Stat us
  10579   "RTN","RCD PEDA2",307 ,0)
  10580    S YY=$$GE T1^DIQ(344 .31,IEN344 31,.1,"I")         ;  ERA IEN
  10581   "RTN","RCD PEDA2",308 ,0)
  10582    S X=$$SET STR^VALM1( $$EXTERNAL ^DILFD(344 .31,.08,"" ,+XX)_$S(X X=1:"/ERA  #"_YY,1:"" ),X,57,20)
  10583   "RTN","RCD PEDA2",309 ,0)
  10584    S ^TMP($J ,"ONEDEP", EFTCTR,1)= X
  10585   "RTN","RCD PEDA2",310 ,0)
  10586    ;
  10587   "RTN","RCD PEDA2",311 ,0)
  10588    S XX=$$GE T1^DIQ(344 .31,IEN344 31,.04,"I" )       ;  Trace Numb er
  10589   "RTN","RCD PEDA2",312 ,0)
  10590    S X=$$SET STR^VALM1( XX,"",5,$L (XX))
  10591   "RTN","RCD PEDA2",313 ,0)
  10592    S XX=$G(^ TMP($J,"TO TALS","CRD OC",IEN344 3))
  10593   "RTN","RCD PEDA2",314 ,0)
  10594    S X=$$SET STR^VALM1( XX,X,59,$L (XX))              ;  CR Documen t Number   ; PRCA*4.5 *318 add
  10595   "RTN","RCD PEDA2",315 ,0)
  10596    S ^TMP($J ,"ONEDEP", EFTCTR,2)= X
  10597   "RTN","RCD PEDA2",316 ,0)
  10598    ;
  10599   "RTN","RCD PEDA2",317 ,0)
  10600    S PAYER=$ $GET1^DIQ( 344.31,IEN 34431,.02, "I")    ;  Payer Name
  10601   "RTN","RCD PEDA2",318 ,0)
  10602    S:PAYER=" " PAYER="N O PAYER NA ME RECEIVE D"      ;  PRCA*4.5*2 98
  10603   "RTN","RCD PEDA2",319 ,0)
  10604    S PAYID=$ $GET1^DIQ( 344.31,IEN 34431,.03, "I")    ;  Payer ID
  10605   "RTN","RCD PEDA2",320 ,0)
  10606    S PAY=PAY ER_"/"_PAY ID
  10607   "RTN","RCD PEDA2",321 ,0)
  10608    I $L(PAY) >74 D                                    ;  PRCA*4.5*3 18 added i f statemen t
  10609   "RTN","RCD PEDA2",322 ,0)
  10610    . S ZZ=$L (PAY,"/"), XX=$P(PAY, "/",1,ZZ-1 ),YY=$P(PA Y,"/",ZZ)
  10611   "RTN","RCD PEDA2",323 ,0)
  10612    . S XX=$E (XX,1,$L(X X)-($L(PAY )-74)),PAY =XX_"/"_YY
  10613   "RTN","RCD PEDA2",324 ,0)
  10614    S X=$$SET STR^VALM1( PAY,"",7,7 4)
  10615   "RTN","RCD PEDA2",325 ,0)
  10616    S ^TMP($J ,"ONEDEP", EFTCTR,3)= X
  10617   "RTN","RCD PEDA2",326 ,0)
  10618    S ^TMP($J ,"ONEDEP", EFTCTR)=3
  10619   "RTN","RCD PEDA2",327 ,0)
  10620    ;
  10621   "RTN","RCD PEDA2",328 ,0)
  10622    ; PRCA*4. 5*318 add  TR #s to d etail rpt
  10623   "RTN","RCD PEDA2",329 ,0)
  10624    ; Gather  & display  all TR Doc  #s for EF T detail r ecord            
  10625   "RTN","RCD PEDA2",330 ,0)
  10626    D GETTR^R CDPEDA4(IE N34431,.IN PUT)               ;  PRCA*4.5*3 21 moved f or routine  size
  10627   "RTN","RCD PEDA2",331 ,0)
  10628    S X=""
  10629   "RTN","RCD PEDA2",332 ,0)
  10630    S XX=$$GE T1^DIQ(344 .31,IEN344 31,3,"E")          ;  Debit Flag  ; PRCA 4. 5*321 Adde d line
  10631   "RTN","RCD PEDA2",333 ,0)
  10632    S XX=$S(X X="D":"DEB IT",1:"      ")               ;  PRCA*4.5*3 21 Added l ine
  10633   "RTN","RCD PEDA2",334 ,0)
  10634    S X=$$SET STR^VALM1( XX,X,37,5)
  10635   "RTN","RCD PEDA2",335 ,0)
  10636    ;
  10637   "RTN","RCD PEDA2",336 ,0)
  10638    ; PRCA*4. 5*304 - le ngthen rec eipt numbe r display  to 12
  10639   "RTN","RCD PEDA2",337 ,0)
  10640    S XX=$$GE T1^DIQ(344 .31,IEN344 31,.09,"I" )       ;  Receipt IE N
  10641   "RTN","RCD PEDA2",338 ,0)
  10642    I XX'=""  D
  10643   "RTN","RCD PEDA2",339 ,0)
  10644    . S YY=$$ GET1^DIQ(3 44,XX,.01, "I")               ;  Receipt Nu mber
  10645   "RTN","RCD PEDA2",340 ,0)
  10646    . S X=$$S ETSTR^VALM 1(YY,X,45, 12)                ;  PRCA*4.5*3 21 changed  46 to 45
  10647   "RTN","RCD PEDA2",341 ,0)
  10648    S X=$$SET STR^VALM1( $G(RCFMS1( IEN34431)) ,X,61,19)
  10649   "RTN","RCD PEDA2",342 ,0)
  10650    S EFTLN=$ G(^TMP($J, "ONEDEP",E FTCTR))+1
  10651   "RTN","RCD PEDA2",343 ,0)
  10652    S ^TMP($J ,"ONEDEP", EFTCTR)=EF TLN
  10653   "RTN","RCD PEDA2",344 ,0)
  10654    S ^TMP($J ,"ONEDEP", EFTCTR,EFT LN)=X
  10655   "RTN","RCD PEDA2",345 ,0)
  10656    D EFTERRS ^RCDPEDA4( .INPUT,IEN 34431,EFTC TR)     ;  Display an y EFT Erro rs
  10657   "RTN","RCD PEDA2",346 ,0)
  10658    D DUP(.IN PUT,IEN344 31,EFTCTR)                    ;  Display an y Duplicat e Errors
  10659   "RTN","RCD PEDA2",347 ,0)
  10660    Q
  10661   "RTN","RCD PEDA2",348 ,0)
  10662    ;
  10663   "RTN","RCD PEDA2",349 ,0)
  10664   DUP(INPUT, IEN34431,E FTCTR) ; C heck to se e if the E FT was a d uplicate
  10665   "RTN","RCD PEDA2",350 ,0)
  10666    ; Input:    IEN34431                  - In ternal IEN  for file  344.31
  10667   "RTN","RCD PEDA2",351 ,0)
  10668    ;           INPUT                     - Se e RPT2 for  details
  10669   "RTN","RCD PEDA2",352 ,0)
  10670    ;           EFTCTR                    - Us ed to stor e lines fo r EFT
  10671   "RTN","RCD PEDA2",353 ,0)
  10672    ;           ^TMP($J, ONEDEP,EFT CTE)  - Cu rrent # of  lines for  EFT
  10673   "RTN","RCD PEDA2",354 ,0)
  10674    ;           ^TMP($J, ONEDEP,EFT CTR,xx)- C urrent Dep osit Lines
  10675   "RTN","RCD PEDA2",355 ,0)
  10676    ; Output:   ^TMP($J, ONEDEP,EFT CTR)  - Up dated # of  lines for  EFT
  10677   "RTN","RCD PEDA2",356 ,0)
  10678    ;           ^TMP($J, ONEDEP,EFT CTR,xx)- U pdated EFT  Lines
  10679   "RTN","RCD PEDA2",357 ,0)
  10680    ;
  10681   "RTN","RCD PEDA2",358 ,0)
  10682    ;PRCA*4.5 *321 captu re display  to ^TMP($ J,"ONEDEP" ,EFTRCR) i ncluding l ine cnt
  10683   "RTN","RCD PEDA2",359 ,0)
  10684    N EFTLN,X X,YY
  10685   "RTN","RCD PEDA2",360 ,0)
  10686    Q:'$D(^RC Y(344.31,I EN34431,3) )                  ;  Not a dupl icate
  10687   "RTN","RCD PEDA2",361 ,0)
  10688    S XX=$$GE T1^DIQ(344 .31,IEN344 31,.18,"I" )       ;  Date/Time  Removed
  10689   "RTN","RCD PEDA2",362 ,0)
  10690    S YY=$$GE T1^DIQ(344 .31,IEN344 31,.17,"I" )       ;  User who r emoved it
  10691   "RTN","RCD PEDA2",363 ,0)
  10692    S X="   M ARKED AS D UPLICATE:  "_$$FMTE^X LFDT(XX)_"  "_$$EXTER NAL^DILFD( 344.31,.17 ,,YY)
  10693   "RTN","RCD PEDA2",364 ,0)
  10694    S EFTLN=$ G(^TMP($J, "ONEDEP",E FTCTR))+1
  10695   "RTN","RCD PEDA2",365 ,0)
  10696    S ^TMP($J ,"ONEDEP", EFTCTR)=EF TLN
  10697   "RTN","RCD PEDA2",366 ,0)
  10698    S ^TMP($J ,"ONEDEP", EFTCTR,EFT LN)=X
  10699   "RTN","RCD PEDA2",367 ,0)
  10700    S EFTLN=E FTLN+1
  10701   "RTN","RCD PEDA2",368 ,0)
  10702    S ^TMP($J ,"ONEDEP", EFTCTR)=EF TLN
  10703   "RTN","RCD PEDA2",369 ,0)
  10704    S ^TMP($J ,"ONEDEP", EFTCTR,EFT LN)=" "
  10705   "RTN","RCD PEDA2",370 ,0)
  10706    Q
  10707   "RTN","RCD PEDA2",371 ,0)
  10708    ;
  10709   "RTN","RCD PEDA3")
  10710   0^5^B11339 2851
  10711   "RTN","RCD PEDA3",1,0 )
  10712   RCDPEDA3 ; AITC/DW -  ACTIVITY R EPORT ;Feb  17, 2017@ 10:37:00
  10713   "RTN","RCD PEDA3",2,0 )
  10714    ;;4.5;Acc ounts Rece ivable;**3 18,321**;M ar 20, 199 5;Build 46
  10715   "RTN","RCD PEDA3",3,0 )
  10716    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  10717   "RTN","RCD PEDA3",4,0 )
  10718    Q
  10719   "RTN","RCD PEDA3",5,0 )
  10720    ;
  10721   "RTN","RCD PEDA3",6,0 )
  10722   HDR(INPUT)  ;EP from  RCDPEDAR
  10723   "RTN","RCD PEDA3",7,0 )
  10724    ; Display s report h eader
  10725   "RTN","RCD PEDA3",8,0 )
  10726    ; Input:    INPUT        - A1^A 2^A3^...^A n Where:
  10727   "RTN","RCD PEDA3",9,0 )
  10728    ;                           A1  - 1 if cal led from N ightly Pro cess, 0 ot herwise
  10729   "RTN","RCD PEDA3",10, 0)
  10730    ;                           A2  - 1 if dis playing to  Listman,  0 otherwis e
  10731   "RTN","RCD PEDA3",11, 0)
  10732    ;                           A3  - 1 if Det ail report , 0 if sum mary repor t
  10733   "RTN","RCD PEDA3",12, 0)
  10734    ;                           A4  - Current  Page Numbe r
  10735   "RTN","RCD PEDA3",13, 0)
  10736    ;                           A5  - Stop Fla g
  10737   "RTN","RCD PEDA3",14, 0)
  10738    ;                           A6  - Start of  Date Rang e
  10739   "RTN","RCD PEDA3",15, 0)
  10740    ;                           A7  - End of D ate Range
  10741   "RTN","RCD PEDA3",16, 0)
  10742    ;                           A9  - Current  line count
  10743   "RTN","RCD PEDA3",17, 0)
  10744    ;                           A10 - 1 - Only  Display E FTs with a  debit fla g of 'D'
  10745   "RTN","RCD PEDA3",18, 0)
  10746    ;                                 0 - Disp lay all EF Ts
  10747   "RTN","RCD PEDA3",19, 0)
  10748    ; Output:   INPUT        - A1^A 2^A3^...^A n - The fo llowing pi eces may b e updated
  10749   "RTN","RCD PEDA3",20, 0)
  10750    ;                           A4  - Current  Page Numbe r
  10751   "RTN","RCD PEDA3",21, 0)
  10752    ;                           A5  - Stop Fla g
  10753   "RTN","RCD PEDA3",22, 0)
  10754    ;                           A8  - Updated  line count
  10755   "RTN","RCD PEDA3",23, 0)
  10756    N CTR,CUR PG,DETL,DO NLY,DTST,D TEND,NJ,NO JUST,PLN,S TOP,X,XX,Y ,Z,Z0,Z1
  10757   "RTN","RCD PEDA3",24, 0)
  10758    S DETL=$P (INPUT,"^" ,3)
  10759   "RTN","RCD PEDA3",25, 0)
  10760    S CURPG=$ P(INPUT,"^ ",4)
  10761   "RTN","RCD PEDA3",26, 0)
  10762    S STOP=$P (INPUT,"^" ,5)
  10763   "RTN","RCD PEDA3",27, 0)
  10764    S DTST=$P (INPUT,"^" ,6)                       ; Date  Range Sta rt
  10765   "RTN","RCD PEDA3",28, 0)
  10766    S DTEND=$ P(INPUT,"^ ",7)                      ; Date  Range End s
  10767   "RTN","RCD PEDA3",29, 0)
  10768    S DONLY=$ P(INPUT,"^ ",10)                     ; EFTs  with Debi ts Only  ; PRCA*4.5*3 21 add deb it logic
  10769   "RTN","RCD PEDA3",30, 0)
  10770    S NJ=$P(I NPUT,"^",1 )
  10771   "RTN","RCD PEDA3",31, 0)
  10772    Q:NJ&(CUR PG)
  10773   "RTN","RCD PEDA3",32, 0)
  10774    I CURPG!( $E(IOST,1, 2)="C-") D
  10775   "RTN","RCD PEDA3",33, 0)
  10776    . Q:NJ
  10777   "RTN","RCD PEDA3",34, 0)
  10778    . I CURPG ,($E(IOST, 1,2)="C-")  D  Q:STOP
  10779   "RTN","RCD PEDA3",35, 0)
  10780    . . S STO P=$$ASK()
  10781   "RTN","RCD PEDA3",36, 0)
  10782    . W @IOF  ; Write fo rm feed
  10783   "RTN","RCD PEDA3",37, 0)
  10784    I STOP S  $P(INPUT," ^",5)=1 Q
  10785   "RTN","RCD PEDA3",38, 0)
  10786    S CURPG=C URPG+1,$P( INPUT,"^", 4)=CURPG
  10787   "RTN","RCD PEDA3",39, 0)
  10788    ;
  10789   "RTN","RCD PEDA3",40, 0)
  10790    ; PRCA276  if coming  from nigh tly job ne ed to defi ne payer s election v ariable
  10791   "RTN","RCD PEDA3",41, 0)
  10792    I NJ N RC NP S RCNP= 2
  10793   "RTN","RCD PEDA3",42, 0)
  10794    ;
  10795   "RTN","RCD PEDA3",43, 0)
  10796    ; PRCA276  if coming  from nigh tly job ne ed to defi ne divisio n selectio n variable
  10797   "RTN","RCD PEDA3",44, 0)
  10798    I NJ N VA UTD S VAUT D=1
  10799   "RTN","RCD PEDA3",45, 0)
  10800    S Z0="EDI  LOCKBOX E FT DAILY A CTIVITY "_ $S(DETL:"D ETAIL",1:" SUMMARY")_ " REPORT"
  10801   "RTN","RCD PEDA3",46, 0)
  10802    S Z=$$SET STR^VALM1( $J("",80-$ L(Z0)\2)_Z 0,"",1,79)
  10803   "RTN","RCD PEDA3",47, 0)
  10804    S Z=$$SET STR^VALM1( "Page: "_C URPG,Z,70, 10)
  10805   "RTN","RCD PEDA3",48, 0)
  10806    D SL(.INP UT,Z)
  10807   "RTN","RCD PEDA3",49, 0)
  10808    S Z="RUN  DATE: "_$$ FMTE^XLFDT ($$NOW^XLF DT(),"2Z") ,Z=$J("",8 0-$L(Z)\2) _Z
  10809   "RTN","RCD PEDA3",50, 0)
  10810    D SL(.INP UT,Z)
  10811   "RTN","RCD PEDA3",51, 0)
  10812    ;
  10813   "RTN","RCD PEDA3",52, 0)
  10814    ; PRCA276  add divis ions to he ader
  10815   "RTN","RCD PEDA3",53, 0)
  10816    S Z1=""
  10817   "RTN","RCD PEDA3",54, 0)
  10818    I 'VAUTD  D
  10819   "RTN","RCD PEDA3",55, 0)
  10820    . S Z0=0
  10821   "RTN","RCD PEDA3",56, 0)
  10822    . F  D  Q :'Z0
  10823   "RTN","RCD PEDA3",57, 0)
  10824    .. S Z0=$ O(VAUTD(Z0 ))
  10825   "RTN","RCD PEDA3",58, 0)
  10826    .. Q:'Z0
  10827   "RTN","RCD PEDA3",59, 0)
  10828    .. S XX=$ $GET1^DIQ( 40.8,Z0,1, "I") ;Faci lity Numbe r   ;PRCA* 4.5*321
  10829   "RTN","RCD PEDA3",60, 0)
  10830    .. ;S Z1= Z1_VAUTD(Z 0)_", "
  10831   "RTN","RCD PEDA3",61, 0)
  10832    .. S Z1=Z 1_XX_", "
  10833   "RTN","RCD PEDA3",62, 0)
  10834    S Z="DIVI SIONS: "_$ S(VAUTD:"A LL",1:$E(Z 1,1,$L(Z1) -2)),Z=$J( "",80-$L(Z )\2)_Z
  10835   "RTN","RCD PEDA3",63, 0)
  10836    D SL(.INP UT,Z)
  10837   "RTN","RCD PEDA3",64, 0)
  10838    ;
  10839   "RTN","RCD PEDA3",65, 0)
  10840    ; PRCA276  add payer  selection  list to h eader
  10841   "RTN","RCD PEDA3",66, 0)
  10842    S NOJUST= 0
  10843   "RTN","RCD PEDA3",67, 0)
  10844    I RCNP'=2  D
  10845   "RTN","RCD PEDA3",68, 0)
  10846    . S CTR=1 ,Z0=0,PLN( CTR)=""
  10847   "RTN","RCD PEDA3",69, 0)
  10848    . F  D  Q :'Z0
  10849   "RTN","RCD PEDA3",70, 0)
  10850    . . S Z0= $O(^TMP("R CSELPAY",$ J,Z0))
  10851   "RTN","RCD PEDA3",71, 0)
  10852    . . Q:'Z0
  10853   "RTN","RCD PEDA3",72, 0)
  10854    . . S XX= ^TMP("RCSE LPAY",$J,Z 0)
  10855   "RTN","RCD PEDA3",73, 0)
  10856    . . I ($L (XX)+$L(PL N(CTR))+10 )>80 D
  10857   "RTN","RCD PEDA3",74, 0)
  10858    . . . S C TR=CTR+1,P LN(CTR)="  "_XX,NOJUS T=1
  10859   "RTN","RCD PEDA3",75, 0)
  10860    . . E  S  PLN(CTR)=P LN(CTR)_$S (PLN(CTR)= "":XX,1:",  "_XX)
  10861   "RTN","RCD PEDA3",76, 0)
  10862    S Z="PAYE RS: "_$S(R CNP=2:"ALL ",1:PLN(1) )
  10863   "RTN","RCD PEDA3",77, 0)
  10864    S:'NOJUST  Z=$J("",8 0-$L(Z)\2) _Z
  10865   "RTN","RCD PEDA3",78, 0)
  10866    D SL(.INP UT,Z)
  10867   "RTN","RCD PEDA3",79, 0)
  10868    S CTR=1
  10869   "RTN","RCD PEDA3",80, 0)
  10870    F  D  Q:C TR=""
  10871   "RTN","RCD PEDA3",81, 0)
  10872    . S CTR=$ O(PLN(CTR) )
  10873   "RTN","RCD PEDA3",82, 0)
  10874    . Q:CTR=" "
  10875   "RTN","RCD PEDA3",83, 0)
  10876    . D SL(.I NPUT,PLN(C TR))
  10877   "RTN","RCD PEDA3",84, 0)
  10878    ;
  10879   "RTN","RCD PEDA3",85, 0)
  10880    ; PRCA276   add date  filter to  header
  10881   "RTN","RCD PEDA3",86, 0)
  10882    S Z="DATE  RANGE: "_ $$FMTE^XLF DT(DTST,"2 Z")_" - "_ $$FMTE^XLF DT(DTEND," 2Z")
  10883   "RTN","RCD PEDA3",87, 0)
  10884    S Z=Z_" ( DATE DEPOS IT ADDED)         DEB IT ONLY EF Ts: "   ;  PRCA*4.5*3 21 debit i nfo
  10885   "RTN","RCD PEDA3",88, 0)
  10886    S Z=Z_$S( DONLY:"YES ",1:"NO")
  10887   "RTN","RCD PEDA3",89, 0)
  10888    S Z=$J("" ,80-$L(Z)\ 2)_Z
  10889   "RTN","RCD PEDA3",90, 0)
  10890    D SL(.INP UT,Z)
  10891   "RTN","RCD PEDA3",91, 0)
  10892    I DETL D
  10893   "RTN","RCD PEDA3",92, 0)
  10894    . ;
  10895   "RTN","RCD PEDA3",93, 0)
  10896    . ; PRCA* 4.5*283 -  Add 3 more  spaces be tween DEP  # and DEPO SIT DT 
  10897   "RTN","RCD PEDA3",94, 0)
  10898    . ; and r emove 3 sp aces betwe en DEPOSIT  DT and DE P AMOUNT t o allow fo r 9 digit  DEP #'s
  10899   "RTN","RCD PEDA3",95, 0)
  10900    . D SL(.I NPUT,"")
  10901   "RTN","RCD PEDA3",96, 0)
  10902    . S XX="D EP #       DEPOSIT DT   "_$J("", 19)_"DEP A MOUNT           FMS D EPOSIT STA T"
  10903   "RTN","RCD PEDA3",97, 0)
  10904    . S Z=$$S ETSTR^VALM 1(XX,"",1, $L(XX))
  10905   "RTN","RCD PEDA3",98, 0)
  10906    . D SL(.I NPUT,Z)
  10907   "RTN","RCD PEDA3",99, 0)
  10908    . ;
  10909   "RTN","RCD PEDA3",100 ,0)
  10910    . ; PRCA* 4.5*318, M ove entire  EFT # row  to left 1  space to  adjust for  other row s needing  space
  10911   "RTN","RCD PEDA3",101 ,0)
  10912    . ; PRCA* 4.5*284, M ove Match  Status to  left 3 spa ce to allo w for 10 d igit ERA # 's
  10913   "RTN","RCD PEDA3",102 ,0)
  10914    . S XX=$J ("",2)_"EF T #"_$J("" ,22)_"DATE  PD   PAYM ENT AMOUNT   ERA MATC H STATUS"
  10915   "RTN","RCD PEDA3",103 ,0)
  10916    . S Z=$$S ETSTR^VALM 1(XX,"",1, $L(XX))
  10917   "RTN","RCD PEDA3",104 ,0)
  10918    . D SL(.I NPUT,Z)
  10919   "RTN","RCD PEDA3",105 ,0)
  10920    . ; PRCA* 4.5*318, M ove entire  EFT Payer  Trace # r ow to left  6 spaces  to adjust  for other  rows needi ng space
  10921   "RTN","RCD PEDA3",106 ,0)
  10922    . S Z=$$S ETSTR^VALM 1($J("",4) _"EFT PAYE R TRACE #" ,"",1,52)
  10923   "RTN","RCD PEDA3",107 ,0)
  10924    . S Z=$$S ETSTR^VALM 1("CR #",Z ,59,4)      ;PRCA*4.5 *318 add C R #
  10925   "RTN","RCD PEDA3",108 ,0)
  10926    . D SL(.I NPUT,Z)
  10927   "RTN","RCD PEDA3",109 ,0)
  10928    . ; PRCA* 4.5*318, M ove entire  Payment F rom row to  left 8 sp aces to ad just 
  10929   "RTN","RCD PEDA3",110 ,0)
  10930    . ; a pos sible 60 c haracter P ayer Name  and 20 cha racter Pay er ID
  10931   "RTN","RCD PEDA3",111 ,0)
  10932    . S XX=$J ("",6)_"PA YMENT FROM "
  10933   "RTN","RCD PEDA3",112 ,0)
  10934    . S Z=$$S ETSTR^VALM 1(XX,"",1, $L(XX))
  10935   "RTN","RCD PEDA3",113 ,0)
  10936    . D SL(.I NPUT,Z)
  10937   "RTN","RCD PEDA3",114 ,0)
  10938    . S XX=$J ("",3)_"TR  #"                      ;PRCA*4 .5*318 add  TR #
  10939   "RTN","RCD PEDA3",115 ,0)
  10940    . S Z=$$S ETSTR^VALM 1(XX,"",1, $L(XX))
  10941   "RTN","RCD PEDA3",116 ,0)
  10942    . D SL(.I NPUT,Z)                             ; TR DO C header
  10943   "RTN","RCD PEDA3",117 ,0)
  10944    . S XX=$J ("",36)_"D EBIT   DEP  RECEIPT # "  ;PRCA*4 .5*321
  10945   "RTN","RCD PEDA3",118 ,0)
  10946    . S Z=$$S ETSTR^VALM 1(XX,"",1, $L(XX))
  10947   "RTN","RCD PEDA3",119 ,0)
  10948    . S Z=$$S ETSTR^VALM 1("DEP REC EIPT STATU S",Z,61,19 )
  10949   "RTN","RCD PEDA3",120 ,0)
  10950    . D SL(.I NPUT,Z)
  10951   "RTN","RCD PEDA3",121 ,0)
  10952    D SL(.INP UT,$TR($J( "",IOM-1), " ","="))
  10953   "RTN","RCD PEDA3",122 ,0)
  10954    Q
  10955   "RTN","RCD PEDA3",123 ,0)
  10956    ;
  10957   "RTN","RCD PEDA3",124 ,0)
  10958   TOTSDAY(IN PUT) ;EP f rom RCDPED AR
  10959   "RTN","RCD PEDA3",125 ,0)
  10960    ;                Dis play the t otals for  the specif ied date
  10961   "RTN","RCD PEDA3",126 ,0)
  10962    ;
  10963   "RTN","RCD PEDA3",127 ,0)
  10964    ; Input:    INPUT        - A1^A 2^A3^...^A n Where:
  10965   "RTN","RCD PEDA3",128 ,0)
  10966    ;                           A1  - 1 if cal led from N ightly Pro cess, 0 ot herwise
  10967   "RTN","RCD PEDA3",129 ,0)
  10968    ;                           A2  - 1 if dis playing to  Listman,  0 otherwis e
  10969   "RTN","RCD PEDA3",130 ,0)
  10970    ;                           A3  - 1 if Det ail report , 0 if sum mary repor t
  10971   "RTN","RCD PEDA3",131 ,0)
  10972    ;                           A4  - Current  Page Numbe r
  10973   "RTN","RCD PEDA3",132 ,0)
  10974    ;                           A5  - Stop Fla g
  10975   "RTN","RCD PEDA3",133 ,0)
  10976    ;                           A6  - Start of  Date Rang e
  10977   "RTN","RCD PEDA3",134 ,0)
  10978    ;                           A7  - End of D ate Range
  10979   "RTN","RCD PEDA3",135 ,0)
  10980    ;                           A8  - Current  Line Count er
  10981   "RTN","RCD PEDA3",136 ,0)
  10982    ;                           A9  - Internal  Date bein g processe d
  10983   "RTN","RCD PEDA3",137 ,0)
  10984    ;           ^TMP($J, "TOTALS"," DEBIT")        - Curr ent Total  # of debit s for date  range
  10985   "RTN","RCD PEDA3",138 ,0)
  10986    ;           ^TMP($J, "TOTALS"," DEBIT","D" )   - Tota l # of deb its for In ternal dat e (C1)
  10987   "RTN","RCD PEDA3",139 ,0)
  10988    ;           ^TMP($J, "TOTALS"," DEBITA")       - Curr ent Total  Debit Amou nt for dat e range
  10989   "RTN","RCD PEDA3",140 ,0)
  10990    ;           ^TMP($J, "TOTALS"," DEBITA","D ")  - Tota l Debit Am ount for I nternal da te (C1)
  10991   "RTN","RCD PEDA3",141 ,0)
  10992    ;           ^TMP($J, "TOTALS"," DEP")          - Curr ent Total  # of depos its for da te range
  10993   "RTN","RCD PEDA3",142 ,0)
  10994    ;           ^TMP($J, "TOTALS"," DEP",C1)       - Tota l # of dep osits for  Internal d ate (C1)
  10995   "RTN","RCD PEDA3",143 ,0)
  10996    ;           ^TMP($J, "TOTALS"," DEPA")         - Curr ent Total  Deposit Am ount for d ate range
  10997   "RTN","RCD PEDA3",144 ,0)
  10998    ;           ^TMP($J, "TOTALS"," DEPA",C1)      - Tota l Deposit  Amount for  Internal  date (C1)
  10999   "RTN","RCD PEDA3",145 ,0)
  11000    ;           ^TMP($J, "TOTALS"," EFT","D")      - Tota l Deposit  Amount by  EFTs for d ate
  11001   "RTN","RCD PEDA3",146 ,0)
  11002    ;           ^TMP($J, "TOTALS"," EFT","T")      - Curr ent Total  Deposit Am ount by EF Ts for ran ge
  11003   "RTN","RCD PEDA3",147 ,0)
  11004    ;           ^TMP($J, "TOTALS"," FMS")          - FMS  Document S tatus or " NO FMS DOC "
  11005   "RTN","RCD PEDA3",148 ,0)
  11006    ;           ^TMP($J, "TOTALS"," FMS","D",- 1)  - Tota l Deposit  Amount by  FMS Docume nt
  11007   "RTN","RCD PEDA3",149 ,0)
  11008    ;           ^TMP($J, "TOTALS"," FMS","D",0 )   - Tota l Amount f or Error/R ejected do cuments
  11009   "RTN","RCD PEDA3",150 ,0)
  11010    ;           ^TMP($J, "TOTALS"," FMS","D",1 ")  - Tota l Amount f or 'A','M' ,"F' or 'T ' docs
  11011   "RTN","RCD PEDA3",151 ,0)
  11012    ;           ^TMP($J, "TOTALS"," FMS","D",2 ")  - Tota l Amount f or queued  docs
  11013   "RTN","RCD PEDA3",152 ,0)
  11014    ;           ^TMP($J, "TOTALS"," FMS","T",- 1)  - Tota l Deposit  Amount by  FMS Docume nt for ran ge
  11015   "RTN","RCD PEDA3",153 ,0)
  11016    ;           ^TMP($J, "TOTALS"," FMS","T",0 )   - Tota l Amount f or Error/R ejected do cs for ran ge
  11017   "RTN","RCD PEDA3",154 ,0)
  11018    ;           ^TMP($J, "TOTALS"," FMS","T",1 ")  - Tota l Amount f or 'A','M' ,"F' or 'T ' docs ran ge
  11019   "RTN","RCD PEDA3",155 ,0)
  11020    ;           ^TMP($J, "TOTALS"," FMS","T",2 ")  - Tota l Amount f or queued  docs for r ange
  11021   "RTN","RCD PEDA3",156 ,0)
  11022    ;           ^TMP($J, "TOTALS"," FMSTOT")       - Upda ted Total  Deposit Am ount for d ate range
  11023   "RTN","RCD PEDA3",157 ,0)
  11024    ;           ^TMP($J, "TOTALS"," MATCH","D" )   - Curr ent Total  matched EF Ts for dat e
  11025   "RTN","RCD PEDA3",158 ,0)
  11026    ;           ^TMP($J, "TOTALS"," MATCH","T" )   - Curr ent Total  matched EF Ts for dat e range
  11027   "RTN","RCD PEDA3",159 ,0)
  11028    ; Output:   INPUT        - A1^A 2^A3^...^A n - The fo llowing pi eces may b e updated
  11029   "RTN","RCD PEDA3",160 ,0)
  11030    ;                           A4  - Updated  Page Numbe r
  11031   "RTN","RCD PEDA3",161 ,0)
  11032    ;                           A5  - Stop Fla g
  11033   "RTN","RCD PEDA3",162 ,0)
  11034    ;                           A8  - Updated  Line Count er
  11035   "RTN","RCD PEDA3",163 ,0)
  11036    ;           ^TMP($J, "TOTALS"," DEBIT")        - Upda ted Total  # of debit s for date  range
  11037   "RTN","RCD PEDA3",164 ,0)
  11038    ;           ^TMP($J, "TOTALS"," DEBIT","D" )   - Upda ted Total  # of debit s for Inte rnal date  (C1)
  11039   "RTN","RCD PEDA3",165 ,0)
  11040    ;           ^TMP($J, "TOTALS"," DEBITA")       - Upda ted Total  Debit Amou nt for dat e range
  11041   "RTN","RCD PEDA3",166 ,0)
  11042    ;           ^TMP($J, "TOTALS"," DEBITA","D ")  - Upda ted Total  Debit Amou nt for Int ernal date  (C1)
  11043   "RTN","RCD PEDA3",167 ,0)
  11044    ;           ^TMP($J, "TOTALS"," DEP")          - Upda ted Total  # of depos its for da te range
  11045   "RTN","RCD PEDA3",168 ,0)
  11046    ;           ^TMP($J, "TOTALS"," DEPA")         - Upda ted Total  Deposit Am ount for d ate range
  11047   "RTN","RCD PEDA3",169 ,0)
  11048    ;           ^TMP($J, "TOTALS"," EFT","T")      - Upda ted Total  Deposit Am ount by EF Ts for ran ge
  11049   "RTN","RCD PEDA3",170 ,0)
  11050    ;           ^TMP($J, "TOTALS"," FMS","T",- 1)  - Upda ted Deposi t Amount b y FMS Docu ment for r ange
  11051   "RTN","RCD PEDA3",171 ,0)
  11052    ;           ^TMP($J, "TOTALS"," FMS","T",0 )   - Upda ted Amount  for Error /Rejected  docs for r ange
  11053   "RTN","RCD PEDA3",172 ,0)
  11054    ;           ^TMP($J, "TOTALS"," FMS","T",1 ")  - Upda ted Amount  for 'A',' M',"F' or  'T' docs r ange
  11055   "RTN","RCD PEDA3",173 ,0)
  11056    ;           ^TMP($J, "TOTALS"," FMS","T",2 ")  - Upda ted Amount  for queue d docs for  range
  11057   "RTN","RCD PEDA3",174 ,0)
  11058    ;           ^TMP($J, "TOTALS"," MATCH","T" )   - Upda ted Total  Matched EF Ts for dat e range
  11059   "RTN","RCD PEDA3",175 ,0)
  11060    N CURPG,D ETL,DTADD, LSTMAN,NL, Q,XX,YY
  11061   "RTN","RCD PEDA3",176 ,0)
  11062    S LSTMAN= $P(INPUT," ^",2)                     ; Disp lay to Lis tman flag
  11063   "RTN","RCD PEDA3",177 ,0)
  11064    S NJ=$P(I NPUT,"^",1 )                         ; Call ed from Ni ghtly Proc ess flag
  11065   "RTN","RCD PEDA3",178 ,0)
  11066    S DETL=$P (INPUT,"^" ,3)                       ; Deta il Report  flag
  11067   "RTN","RCD PEDA3",179 ,0)
  11068    S CURPG=$ P(INPUT,"^ ",4)                      ; Curr ent Page C ounter
  11069   "RTN","RCD PEDA3",180 ,0)
  11070    S DTADD=$ P(INPUT,"^ ",9)                      ; Date  to displa y totals f or
  11071   "RTN","RCD PEDA3",181 ,0)
  11072    S XX=$G(^ TMP($J,"TO TALS","DEP A"))           ; Curr ent Total  Deposit Am ount for d ate range
  11073   "RTN","RCD PEDA3",182 ,0)
  11074    S YY=$G(^ TMP($J,"TO TALS","DEP A",DTADD))     ; Tota l Deposit  Amount for  date
  11075   "RTN","RCD PEDA3",183 ,0)
  11076    S ^TMP($J ,"TOTALS", "DEPA")=XX +YY            ; Upda ted Total  for range
  11077   "RTN","RCD PEDA3",184 ,0)
  11078    S XX=$G(^ TMP($J,"TO TALS","DEP "))            ; Curr ent Total  # of Depos its for da te range
  11079   "RTN","RCD PEDA3",185 ,0)
  11080    S YY=$G(^ TMP($J,"TO TALS","DEP ",DTADD))      ; Tota l # of Dep osits for  date
  11081   "RTN","RCD PEDA3",186 ,0)
  11082    S ^TMP($J ,"TOTALS", "DEP")=XX+ YY             ; Upda ted Total  # for rang e
  11083   "RTN","RCD PEDA3",187 ,0)
  11084    ;
  11085   "RTN","RCD PEDA3",188 ,0)
  11086    S XX=$G(^ TMP($J,"TO TALS","EFT ","T"))        ; Curr ent Total  Amount by  EFTs for d ate range
  11087   "RTN","RCD PEDA3",189 ,0)
  11088    S YY=$G(^ TMP($J,"TO TALS","EFT ","D"))        ; Tota l Amount b y EFTs for  date
  11089   "RTN","RCD PEDA3",190 ,0)
  11090    S ^TMP($J ,"TOTALS", "EFT","T") =XX+YY         ; Upda ted Total  Amount for  range
  11091   "RTN","RCD PEDA3",191 ,0)
  11092    ;
  11093   "RTN","RCD PEDA3",192 ,0)
  11094    S XX=$G(^ TMP($J,"TO TALS","MAT CH","T"))      ; Curr ent Total  # Matched  EFTs for d ate range
  11095   "RTN","RCD PEDA3",193 ,0)
  11096    S YY=$G(^ TMP($J,"TO TALS","MAT CH","D"))      ; # Ma tched EFTs  for date
  11097   "RTN","RCD PEDA3",194 ,0)
  11098    S ^TMP($J ,"TOTALS", "MATCH","T ")=XX+YY       ; Upda ted Total  # Matched  EFTs for d ate range
  11099   "RTN","RCD PEDA3",195 ,0)
  11100    ;
  11101   "RTN","RCD PEDA3",196 ,0)
  11102    ; Update  document s tatus tota ls for ran ge
  11103   "RTN","RCD PEDA3",197 ,0)
  11104    F Q=-1,0, 1,2 D
  11105   "RTN","RCD PEDA3",198 ,0)
  11106    . S XX=$G (^TMP($J," TOTALS","F MS","T",Q) )   ; Curr ent Total  # of Q sta tus for da te range
  11107   "RTN","RCD PEDA3",199 ,0)
  11108    . S YY=$G (^TMP($J," TOTALS","F MS","D",Q) )   ; # of  Q status  for date
  11109   "RTN","RCD PEDA3",200 ,0)
  11110    . S ^TMP( $J,"TOTALS ","FMS","T ",Q)=XX+YY     ; Upda ted Total  # of Q sta tus for da te range
  11111   "RTN","RCD PEDA3",201 ,0)
  11112    ;
  11113   "RTN","RCD PEDA3",202 ,0)
  11114    ; daily t otals
  11115   "RTN","RCD PEDA3",203 ,0)
  11116    ;I $S('NJ :($Y+5)>IO SL,1:0)!'C URPG D  Q: $P(INPUT," ^",5)=1  ;  PRCA*4.5* 321 change d
  11117   "RTN","RCD PEDA3",204 ,0)
  11118    I $S('NJ: 1,1:0)!'CU RPG D  Q:$ P(INPUT,"^ ",5)=1
  11119   "RTN","RCD PEDA3",205 ,0)
  11120    . D:'LSTM AN HDR(.IN PUT)
  11121   "RTN","RCD PEDA3",206 ,0)
  11122    S XX=$E(" **TOTALS F OR DATE: " _$$FMTE^XL FDT(DTADD\ 1,"2Z")_$J ("",30),1, 30)
  11123   "RTN","RCD PEDA3",207 ,0)
  11124    S YY=$G(^ TMP($J,"TO TALS","DEP ",DTADD))
  11125   "RTN","RCD PEDA3",208 ,0)
  11126    S XX=XX_"    # OF DE POSIT TICK ETS RECEIV ED: "_+YY_ $J("",5)
  11127   "RTN","RCD PEDA3",209 ,0)
  11128    D SL(.INP UT,XX)
  11129   "RTN","RCD PEDA3",210 ,0)
  11130    S YY=$G(^ TMP($J,"TO TALS","DEP A",DTADD))
  11131   "RTN","RCD PEDA3",211 ,0)
  11132    S XX=$J(" ",29)_"TOT AL AMOUNT  OF DEPOSIT S RECEIVED : $"_$J(YY ,"",2)
  11133   "RTN","RCD PEDA3",212 ,0)
  11134    D SL(.INP UT,XX)
  11135   "RTN","RCD PEDA3",213 ,0)
  11136    Q:$P(INPU T,"^",5)=1
  11137   "RTN","RCD PEDA3",214 ,0)
  11138    D SL(.INP UT," ")
  11139   "RTN","RCD PEDA3",215 ,0)
  11140    D SL(.INP UT,$J("",2 0)_"DEPOSI T AMOUNTS  SENT TO FM S:")
  11141   "RTN","RCD PEDA3",216 ,0)
  11142    Q:$P(INPU T,"^",5)=1
  11143   "RTN","RCD PEDA3",217 ,0)
  11144    S YY=+$G( ^TMP($J,"T OTALS","FM S","D",1))
  11145   "RTN","RCD PEDA3",218 ,0)
  11146    S XX=$J(" ",39)_"ACC EPTED: $"_ $J(YY,"",2 )
  11147   "RTN","RCD PEDA3",219 ,0)
  11148    D SL(.INP UT,XX)
  11149   "RTN","RCD PEDA3",220 ,0)
  11150    Q:$P(INPU T,"^",5)=1
  11151   "RTN","RCD PEDA3",221 ,0)
  11152    S YY=+$G( ^TMP($J,"T OTALS","FM S","D",2))
  11153   "RTN","RCD PEDA3",222 ,0)
  11154    S XX=$J(" ",41)_"QUE UED: $"_$J (YY,"",2)
  11155   "RTN","RCD PEDA3",223 ,0)
  11156    D SL(.INP UT,XX)
  11157   "RTN","RCD PEDA3",224 ,0)
  11158    Q:$P(INPU T,"^",5)=1
  11159   "RTN","RCD PEDA3",225 ,0)
  11160    S YY=+$G( ^TMP($J,"T OTALS","FM S","D",0))
  11161   "RTN","RCD PEDA3",226 ,0)
  11162    S XX=$J(" ",35)_"ERR OR/REJECT:  $"_$J(YY, "",2)
  11163   "RTN","RCD PEDA3",227 ,0)
  11164    D SL(.INP UT,XX)
  11165   "RTN","RCD PEDA3",228 ,0)
  11166    Q:$P(INPU T,"^",5)=1
  11167   "RTN","RCD PEDA3",229 ,0)
  11168    S YY=+$G( ^TMP($J,"T OTALS","FM S","D",-1) )
  11169   "RTN","RCD PEDA3",230 ,0)
  11170    S XX=$J(" ",37)_"NOT  IN FMS: $ "_$J(YY,"" ,2)
  11171   "RTN","RCD PEDA3",231 ,0)
  11172    D SL(.INP UT,XX)
  11173   "RTN","RCD PEDA3",232 ,0)
  11174    D SL(.INP UT," ")
  11175   "RTN","RCD PEDA3",233 ,0)
  11176    Q:$P(INPU T,"^",5)=1
  11177   "RTN","RCD PEDA3",234 ,0)
  11178    ;
  11179   "RTN","RCD PEDA3",235 ,0)
  11180    ; PRCA*4. 5*321 add  all debit  logic
  11181   "RTN","RCD PEDA3",236 ,0)
  11182    S XX=$G(^ TMP($J,"TO TALS","DEB IT"))          ; Curr ent Total  # of debit  EFTs for  date range
  11183   "RTN","RCD PEDA3",237 ,0)
  11184    S YY=$G(^ TMP($J,"TO TALS","DEB IT","D"))      ; Tota l # of deb it EFTs fo r date
  11185   "RTN","RCD PEDA3",238 ,0)
  11186    S ^TMP($J ,"TOTALS", "DEBIT")=X X+YY           ; Upda ted Total  # of debit  EFTs for  range
  11187   "RTN","RCD PEDA3",239 ,0)
  11188    S XX=$G(^ TMP($J,"TO TALS","DEB ITA"))         ; Curr ent Total  amount of  debit EFTs  for date  range
  11189   "RTN","RCD PEDA3",240 ,0)
  11190    S YY=$G(^ TMP($J,"TO TALS","DEB ITA","D"))     ; Tota l amount o f debit EF Ts for dat e
  11191   "RTN","RCD PEDA3",241 ,0)
  11192    S ^TMP($J ,"TOTALS", "DEBITA")= XX+YY          ; Upda ted Total  amount of  debit EFTs  for range
  11193   "RTN","RCD PEDA3",242 ,0)
  11194    S YY=+$G( ^TMP($J,"T OTALS","DE BIT","D"))
  11195   "RTN","RCD PEDA3",243 ,0)
  11196    S XX=$J(" ",27)_"# E FT DEBIT V OUCHERS: " _YY
  11197   "RTN","RCD PEDA3",244 ,0)
  11198    D SL(.INP UT,XX)
  11199   "RTN","RCD PEDA3",245 ,0)
  11200    S YY=+$G( ^TMP($J,"T OTALS","DE BITA","D") )
  11201   "RTN","RCD PEDA3",246 ,0)
  11202    S XX=$J(" ",33)_"DEB IT VOUCHER S: $"_$J(Y Y,"",2)
  11203   "RTN","RCD PEDA3",247 ,0)
  11204    D SL(.INP UT,XX)
  11205   "RTN","RCD PEDA3",248 ,0)
  11206    D SL(.INP UT," ")
  11207   "RTN","RCD PEDA3",249 ,0)
  11208    ;
  11209   "RTN","RCD PEDA3",250 ,0)
  11210    S YY=+$G( ^TMP($J,"T OTALS","EF T","D"))
  11211   "RTN","RCD PEDA3",251 ,0)
  11212    S XX=$J(" ",26)_"# E FT PAYMENT  RECORDS:  "_YY
  11213   "RTN","RCD PEDA3",252 ,0)
  11214    D SL(.INP UT,XX)
  11215   "RTN","RCD PEDA3",253 ,0)
  11216    Q:$P(INPU T,"^",5)=1
  11217   "RTN","RCD PEDA3",254 ,0)
  11218    S YY=+$G( ^TMP($J,"T OTALS","MA TCH","D"))
  11219   "RTN","RCD PEDA3",255 ,0)
  11220    S XX=$J(" ",25)_"# E FT PAYMENT S MATCHED:  "_YY
  11221   "RTN","RCD PEDA3",256 ,0)
  11222    D SL(.INP UT,XX)
  11223   "RTN","RCD PEDA3",257 ,0)
  11224    Q:$P(INPU T,"^",5)=1
  11225   "RTN","RCD PEDA3",258 ,0)
  11226    ; PRCA*4. 5*321 remo ve Matched  payment a mt posted
  11227   "RTN","RCD PEDA3",259 ,0)
  11228    ;S YY=+$G (^TMP($J," TOTALS","D EPAP",DTAD D))
  11229   "RTN","RCD PEDA3",260 ,0)
  11230    ;S XX=$J( "",18)_"MA TCHED PAYM ENT AMOUNT  POSTED: $ "_$J(YY,"" ,2)
  11231   "RTN","RCD PEDA3",261 ,0)
  11232    ;D SL(.IN PUT,XX)
  11233   "RTN","RCD PEDA3",262 ,0)
  11234    D SL(.INP UT," ")
  11235   "RTN","RCD PEDA3",263 ,0)
  11236    Q
  11237   "RTN","RCD PEDA3",264 ,0)
  11238    ;
  11239   "RTN","RCD PEDA3",265 ,0)
  11240   TOTSF(INPU T) ; EP fr om RCDPEDA R
  11241   "RTN","RCD PEDA3",266 ,0)
  11242    ;              Displ ay Final T otals
  11243   "RTN","RCD PEDA3",267 ,0)
  11244    ;
  11245   "RTN","RCD PEDA3",268 ,0)
  11246    ; Input:    INPUT        - A1^A 2^A3^...^A n Where:
  11247   "RTN","RCD PEDA3",269 ,0)
  11248    ;                           A1  - 1 if cal led from N ightly Pro cess, 0 ot herwise
  11249   "RTN","RCD PEDA3",270 ,0)
  11250    ;                           A2  - 1 if dis playing to  Listman,  0 otherwis e
  11251   "RTN","RCD PEDA3",271 ,0)
  11252    ;                           A3  - 1 if Det ail report , 0 if sum mary repor t
  11253   "RTN","RCD PEDA3",272 ,0)
  11254    ;                           A4  - Current  Page Numbe r
  11255   "RTN","RCD PEDA3",273 ,0)
  11256    ;                           A5  - Stop Fla g
  11257   "RTN","RCD PEDA3",274 ,0)
  11258    ;                           A6  - Start of  Date Rang e
  11259   "RTN","RCD PEDA3",275 ,0)
  11260    ;                           A7  - End of D ate Range
  11261   "RTN","RCD PEDA3",276 ,0)
  11262    ;                           A8  - Current  Line Count er
  11263   "RTN","RCD PEDA3",277 ,0)
  11264    ;                           A9  - Internal  Date bein g processe d
  11265   "RTN","RCD PEDA3",278 ,0)
  11266    ;           ^TMP($J, "TOTALS"," DEP")          - Tota l # of dep osits for  date range
  11267   "RTN","RCD PEDA3",279 ,0)
  11268    ;           ^TMP($J, "TOTALS"," DEPA")         - Tota l Deposit  Amount for  date rang e
  11269   "RTN","RCD PEDA3",280 ,0)
  11270    ;           ^TMP($J, "TOTALS"," EFT","T")      - Tota l Deposit  Amount by  EFTs for r ange
  11271   "RTN","RCD PEDA3",281 ,0)
  11272    ;           ^TMP($J, "TOTALS"," FMS","T",- 1)  - Tota l Deposit  Amount by  FMS Docume nt for ran ge
  11273   "RTN","RCD PEDA3",282 ,0)
  11274    ;           ^TMP($J, "TOTALS"," FMS","T",0 )   - Tota l Amount f or Error/R ejected do cs for ran ge
  11275   "RTN","RCD PEDA3",283 ,0)
  11276    ;           ^TMP($J, "TOTALS"," FMS","T",1 ")  - Tota l Amount f or 'A','M' ,"F' or 'T ' docs ran ge
  11277   "RTN","RCD PEDA3",284 ,0)
  11278    ;           ^TMP($J, "TOTALS"," FMS","T",2 ")  - Tota l Amount f or queued  docs for r ange
  11279   "RTN","RCD PEDA3",285 ,0)
  11280    ;           ^TMP($J, "TOTALS"," MATCH","T" )   - Tota l Matched  EFTs for d ate range
  11281   "RTN","RCD PEDA3",286 ,0)
  11282    ; Output:   INPUT        - A1^A 2^A3^...^A n - The fo llowing pi eces may b e updated
  11283   "RTN","RCD PEDA3",287 ,0)
  11284    ;                           A5  - Updated  Page Numbe r
  11285   "RTN","RCD PEDA3",288 ,0)
  11286    ;                           A6  - Stop Fla g
  11287   "RTN","RCD PEDA3",289 ,0)
  11288    ;                           A8  - Updated  Line Count er
  11289   "RTN","RCD PEDA3",290 ,0)
  11290    N LSTMAN, NJ,XX,YY
  11291   "RTN","RCD PEDA3",291 ,0)
  11292    S LSTMAN= $P(INPUT," ^",2),NJ=$ P(INPUT,"^ ",1)
  11293   "RTN","RCD PEDA3",292 ,0)
  11294    ;
  11295   "RTN","RCD PEDA3",293 ,0)
  11296    ; header  if no outp ut was dis played and  not being  displayed  in listma n
  11297   "RTN","RCD PEDA3",294 ,0)
  11298    ;I '$O(^T MP("RCDAIL YACT",$J,0 )),'LSTMAN  D HDR(.IN PUT)  ; PR CA*4.5*321  hdr regar dless if n o output
  11299   "RTN","RCD PEDA3",295 ,0)
  11300    I 'LSTMAN  D HDR(.IN PUT)
  11301   "RTN","RCD PEDA3",296 ,0)
  11302    ;
  11303   "RTN","RCD PEDA3",297 ,0)
  11304    ; If user  quit or ( Nightly pr ocess flag  AND not d isplay to  listman) -  end here
  11305   "RTN","RCD PEDA3",298 ,0)
  11306    I $P(INPU T,"^",5)=1 !(NJ&'LSTM AN) Q
  11307   "RTN","RCD PEDA3",299 ,0)
  11308    ;D SL(.IN PUT," ")                                            ;  PRCA*4.5*3 21 removed
  11309   "RTN","RCD PEDA3",300 ,0)
  11310    S XX=$E(" **** TOTAL S FOR DATE  RANGE:"_$ J("",30),1 ,30)
  11311   "RTN","RCD PEDA3",301 ,0)
  11312    S YY=+$G( ^TMP($J,"T OTALS","DE P"))
  11313   "RTN","RCD PEDA3",302 ,0)
  11314    S XX=XX_"    # OF DE POSIT TICK ETS RECEIV ED: "_YY_$ J("",5)
  11315   "RTN","RCD PEDA3",303 ,0)
  11316    D SL(.INP UT,XX)
  11317   "RTN","RCD PEDA3",304 ,0)
  11318    S YY=+$G( ^TMP($J,"T OTALS","DE PA"))
  11319   "RTN","RCD PEDA3",305 ,0)
  11320    S XX=$J(" ",29)_"TOT AL AMOUNT  OF DEPOSIT S RECEIVED : $"_$J(YY ,"",2)
  11321   "RTN","RCD PEDA3",306 ,0)
  11322    D SL(.INP UT,XX)
  11323   "RTN","RCD PEDA3",307 ,0)
  11324    D SL(.INP UT," ")
  11325   "RTN","RCD PEDA3",308 ,0)
  11326    D SL(.INP UT,$J("",2 0)_"DEPOSI T AMOUNTS  SENT TO FM S:")
  11327   "RTN","RCD PEDA3",309 ,0)
  11328    S YY=+$G( ^TMP($J,"T OTALS","FM S","T",1))
  11329   "RTN","RCD PEDA3",310 ,0)
  11330    S XX=$J(" ",39)_"ACC EPTED: $"_ $J(YY,"",2 )
  11331   "RTN","RCD PEDA3",311 ,0)
  11332    D SL(.INP UT,XX)
  11333   "RTN","RCD PEDA3",312 ,0)
  11334    S YY=+$G( ^TMP($J,"T OTALS","FM S","T",2))
  11335   "RTN","RCD PEDA3",313 ,0)
  11336    S XX=$J(" ",41)_"QUE UED: $"_$J (YY,"",2)
  11337   "RTN","RCD PEDA3",314 ,0)
  11338    D SL(.INP UT,XX)
  11339   "RTN","RCD PEDA3",315 ,0)
  11340    S YY=+$G( ^TMP($J,"T OTALS","FM S","T",0))
  11341   "RTN","RCD PEDA3",316 ,0)
  11342    S XX=$J(" ",35)_"ERR OR/REJECT:  $"_$J(YY, "",2)
  11343   "RTN","RCD PEDA3",317 ,0)
  11344    D SL(.INP UT,XX)
  11345   "RTN","RCD PEDA3",318 ,0)
  11346    S YY=+$G( ^TMP($J,"T OTALS","FM S","T",-1) )
  11347   "RTN","RCD PEDA3",319 ,0)
  11348    S XX=$J(" ",37)_"NOT  IN FMS: $ "_$J(YY,"" ,2)
  11349   "RTN","RCD PEDA3",320 ,0)
  11350    D SL(.INP UT,XX)
  11351   "RTN","RCD PEDA3",321 ,0)
  11352    D SL(.INP UT," ")
  11353   "RTN","RCD PEDA3",322 ,0)
  11354    ;
  11355   "RTN","RCD PEDA3",323 ,0)
  11356    S YY=+$G( ^TMP($J,"T OTALS","DE BIT"))
  11357   "RTN","RCD PEDA3",324 ,0)
  11358    S XX=$J(" ",21)_"TOT AL # EFT D EBIT VOUCH ERS: "_YY
  11359   "RTN","RCD PEDA3",325 ,0)
  11360    D SL(.INP UT,XX)
  11361   "RTN","RCD PEDA3",326 ,0)
  11362    S YY=+$G( ^TMP($J,"T OTALS","DE BITA"))
  11363   "RTN","RCD PEDA3",327 ,0)
  11364    S XX=$J(" ",27)_"TOT AL DEBIT V OUCHERS: $ "_$J(YY,"" ,2)
  11365   "RTN","RCD PEDA3",328 ,0)
  11366    D SL(.INP UT,XX)
  11367   "RTN","RCD PEDA3",329 ,0)
  11368    D SL(.INP UT," ")
  11369   "RTN","RCD PEDA3",330 ,0)
  11370    ;
  11371   "RTN","RCD PEDA3",331 ,0)
  11372    S YY=+$G( ^TMP($J,"T OTALS","EF T","T"))
  11373   "RTN","RCD PEDA3",332 ,0)
  11374    S XX=$J(" ",26)_"# E FT PAYMENT  RECORDS:  "_YY
  11375   "RTN","RCD PEDA3",333 ,0)
  11376    D SL(.INP UT,XX)
  11377   "RTN","RCD PEDA3",334 ,0)
  11378    S YY=+$G( ^TMP($J,"T OTALS","MA TCH","T"))
  11379   "RTN","RCD PEDA3",335 ,0)
  11380    S XX=$J(" ",25)_"# E FT PAYMENT S MATCHED:  "_YY
  11381   "RTN","RCD PEDA3",336 ,0)
  11382    D SL(.INP UT,XX)
  11383   "RTN","RCD PEDA3",337 ,0)
  11384    ; PRCA*4. 5*321 remo ve Matched  payment a mt posted
  11385   "RTN","RCD PEDA3",338 ,0)
  11386    ;S YY=+$G (^TMP($J," TOTALS","D EPAP"))
  11387   "RTN","RCD PEDA3",339 ,0)
  11388    ;S XX=$J( "",18)_"MA TCHED PAYM ENT AMOUNT  POSTED: $ "_$J(YY,"" ,2)
  11389   "RTN","RCD PEDA3",340 ,0)
  11390    ;D SL(.IN PUT,XX)
  11391   "RTN","RCD PEDA3",341 ,0)
  11392    D SL(.INP UT," ")
  11393   "RTN","RCD PEDA3",342 ,0)
  11394    D SL(.INP UT," ")
  11395   "RTN","RCD PEDA3",343 ,0)
  11396    Q
  11397   "RTN","RCD PEDA3",344 ,0)
  11398    ;
  11399   "RTN","RCD PEDA3",345 ,0)
  11400   ASK() ; As k to conti nue
  11401   "RTN","RCD PEDA3",346 ,0)
  11402    ; PRCA*4. 5*321 chan ged to ext rinsic fun ction
  11403   "RTN","RCD PEDA3",347 ,0)
  11404    ; Input:  None
  11405   "RTN","RCD PEDA3",348 ,0)
  11406    ; Returns : 1 if use r wants to  stop, 0 o therwise
  11407   "RTN","RCD PEDA3",349 ,0)
  11408    I $E(IOST ,1,2)'["C- " Q 0
  11409   "RTN","RCD PEDA3",350 ,0)
  11410    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T
  11411   "RTN","RCD PEDA3",351 ,0)
  11412    S DIR(0)= "E" W ! D  ^DIR
  11413   "RTN","RCD PEDA3",352 ,0)
  11414    I ($D(DIR UT))!($D(D UOUT)) Q 1
  11415   "RTN","RCD PEDA3",353 ,0)
  11416    Q 0
  11417   "RTN","RCD PEDA3",354 ,0)
  11418    ;
  11419   "RTN","RCD PEDA3",355 ,0)
  11420   SL(INPUT,Z ) ;EP from  RCDPEDAR  & RCDEPA2
  11421   "RTN","RCD PEDA3",356 ,0)
  11422    ;             Writes  or stores  line
  11423   "RTN","RCD PEDA3",357 ,0)
  11424    ;
  11425   "RTN","RCD PEDA3",358 ,0)
  11426    ; Input:    INPUT                     - A1 ^A2^A3^... ^An Where:
  11427   "RTN","RCD PEDA3",359 ,0)
  11428    ;                                          A1 - 1 if  called fro m Nightly  Process, 0  otherwise
  11429   "RTN","RCD PEDA3",360 ,0)
  11430    ;                                          A2 - 1 if  displaying  to Listma n, 0 other wise
  11431   "RTN","RCD PEDA3",361 ,0)
  11432    ;                                          A3 - 1 if  Detail rep ort, 0 if  summary re port
  11433   "RTN","RCD PEDA3",362 ,0)
  11434    ;                                          A4 - Curre nt Page Nu mber
  11435   "RTN","RCD PEDA3",363 ,0)
  11436    ;                                          A5 - Stop  Flag
  11437   "RTN","RCD PEDA3",364 ,0)
  11438    ;                                          A6 - Start  of Date R ange
  11439   "RTN","RCD PEDA3",365 ,0)
  11440    ;                                          A7 - End o f Date Ran ge
  11441   "RTN","RCD PEDA3",366 ,0)
  11442    ;                                          A8 - Curre nt Line Nu mber
  11443   "RTN","RCD PEDA3",367 ,0)
  11444    ;           Z                         - Da ta line to  write or  store
  11445   "RTN","RCD PEDA3",368 ,0)
  11446    ;           RCCT                      - Cu rrent line  counter
  11447   "RTN","RCD PEDA3",369 ,0)
  11448    ;           RCNJ                      - 1  to set arr ay, 0 to w rite line
  11449   "RTN","RCD PEDA3",370 ,0)
  11450    ;           ^TMP($J, "RCDPE_DAR ")    - Cu rrent arra y of store d lines (i f RCNJ=1)
  11451   "RTN","RCD PEDA3",371 ,0)
  11452    ; Output:   INPUT                     - A1 ^A2^A3^... ^An - The  following  pieces may  be update d
  11453   "RTN","RCD PEDA3",372 ,0)
  11454    ;                                          A11 - Upda ted Line N umber
  11455   "RTN","RCD PEDA3",373 ,0)
  11456    ; Output:   
  11457   "RTN","RCD PEDA3",374 ,0)
  11458    ;           ^TMP($J, "RCDPE_DAR ")    - Up dated arra y of store d lines (i f RCNJ=1)
  11459   "RTN","RCD PEDA3",375 ,0)
  11460    N XX
  11461   "RTN","RCD PEDA3",376 ,0)
  11462    S XX=$P(I NPUT,"^",8 )+1
  11463   "RTN","RCD PEDA3",377 ,0)
  11464    S $P(INPU T,"^",8)=X X
  11465   "RTN","RCD PEDA3",378 ,0)
  11466    ;
  11467   "RTN","RCD PEDA3",379 ,0)
  11468    ; Called  from night ly process
  11469   "RTN","RCD PEDA3",380 ,0)
  11470    I $P(INPU T,"^",1) S  ^TMP($J," RCDPE_DAR" ,XX)=Z Q
  11471   "RTN","RCD PEDA3",381 ,0)
  11472    W !,Z
  11473   "RTN","RCD PEDA3",382 ,0)
  11474    Q
  11475   "RTN","RCD PEDA4")
  11476   0^15^B3684 1110
  11477   "RTN","RCD PEDA4",1,0 )
  11478   RCDPEDA4 ; AITC/DW -  ACTIVITY R EPORT ;Feb  17, 2017@ 10:37:00
  11479   "RTN","RCD PEDA4",2,0 )
  11480    ;;4.5;Acc ounts Rece ivable;**3 18,321**;M ar 20, 199 5;Build 46
  11481   "RTN","RCD PEDA4",3,0 )
  11482    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  11483   "RTN","RCD PEDA4",4,0 )
  11484    ; Continu ation of R CDPEDAR -  Daily acti vity Repor t
  11485   "RTN","RCD PEDA4",5,0 )
  11486    Q
  11487   "RTN","RCD PEDA4",6,0 )
  11488    ;
  11489   "RTN","RCD PEDA4",7,0 )
  11490   ERRMSGS(IN PUT,IEN344 3) ;EP fro m RCDPEDA2
  11491   "RTN","RCD PEDA4",8,0 )
  11492    ; Display  any EFT e rror messa ges
  11493   "RTN","RCD PEDA4",9,0 )
  11494    ; Input:    INPUT                 - See EF TERRS for  details
  11495   "RTN","RCD PEDA4",10, 0)
  11496    ;           IEN3443               - Intern al IEN for  file 344. 3
  11497   "RTN","RCD PEDA4",11, 0)
  11498    ;           ^TMP($J, "DEPERRS")   - Curren t Line Cou nt
  11499   "RTN","RCD PEDA4",12, 0)
  11500    ;                                   Note:  Only passe d if not i n detail m ode
  11501   "RTN","RCD PEDA4",13, 0)
  11502    ;           ^TMP($J, "DEPERRS,X ) - Error  line(s)
  11503   "RTN","RCD PEDA4",14, 0)
  11504    ; Output:   ^TMP($J, "DEPERRS")   - Curren t Line Cou nt
  11505   "RTN","RCD PEDA4",15, 0)
  11506    ;                                   Note:  Only passe d if not i n detail m ode
  11507   "RTN","RCD PEDA4",16, 0)
  11508    ;
  11509   "RTN","RCD PEDA4",17, 0)
  11510    ; PRCA*4. 5*321 capt ure displa y and line  cnt to ^T MP($J,"DEP ERRS")
  11511   "RTN","RCD PEDA4",18, 0)
  11512    N DETL,ER RS,LNCT,XX ,ZZ
  11513   "RTN","RCD PEDA4",19, 0)
  11514    S DETL=$P (INPUT,"^" ,3)
  11515   "RTN","RCD PEDA4",20, 0)
  11516    S XX=$$GE T1^DIQ(344 .3,IEN3443 ,2,"I","ER RS")    ;  Error Mess age WP fie ld
  11517   "RTN","RCD PEDA4",21, 0)
  11518    Q:'$D(ERR S)                                       ;  No errors
  11519   "RTN","RCD PEDA4",22, 0)
  11520    S XX=$J(" ",3)_"ERRO R MESSAGES  FOR EFT:"
  11521   "RTN","RCD PEDA4",23, 0)
  11522    S LNCT=$G (^TMP($J," DEPERRS")) +1
  11523   "RTN","RCD PEDA4",24, 0)
  11524    S ^TMP($J ,"DEPERRS" )=LNCT
  11525   "RTN","RCD PEDA4",25, 0)
  11526    S ^TMP($J ,"DEPERRS" ,LNCT)=XX
  11527   "RTN","RCD PEDA4",26, 0)
  11528    S XX=""
  11529   "RTN","RCD PEDA4",27, 0)
  11530    F  D  Q:X X=""
  11531   "RTN","RCD PEDA4",28, 0)
  11532    . S XX=$O (ERRS(XX))
  11533   "RTN","RCD PEDA4",29, 0)
  11534    . Q:XX=""
  11535   "RTN","RCD PEDA4",30, 0)
  11536    . S ZZ=$J ("",5)_ERR S(XX)
  11537   "RTN","RCD PEDA4",31, 0)
  11538    . S LNCT= $G(^TMP($J ,"DEPERRS" ))+1
  11539   "RTN","RCD PEDA4",32, 0)
  11540    . S ^TMP( $J,"DEPERR S")=LNCT
  11541   "RTN","RCD PEDA4",33, 0)
  11542    . S ^TMP( $J,"DEPERR S",LNCT)=Z Z
  11543   "RTN","RCD PEDA4",34, 0)
  11544    Q
  11545   "RTN","RCD PEDA4",35, 0)
  11546    ; 
  11547   "RTN","RCD PEDA4",36, 0)
  11548   EFTERRS(IN PUT,IEN344 31,EFTCTR)  ;EP from  RCDPEDA2
  11549   "RTN","RCD PEDA4",37, 0)
  11550    ; Output  any EFT De tail error s
  11551   "RTN","RCD PEDA4",38, 0)
  11552    ; Input:    INPUT        - A1^A 2^A3^...^A n Where:
  11553   "RTN","RCD PEDA4",39, 0)
  11554    ;                            A1  - 1 if ca lled from  Nightly Pr ocess, 0 o therwise
  11555   "RTN","RCD PEDA4",40, 0)
  11556    ;                            A2  - 1 if di splaying t o Listman,  0 otherwi se
  11557   "RTN","RCD PEDA4",41, 0)
  11558    ;                            A3  - 1 if De tail repor t, 0 if su mmary repo rt
  11559   "RTN","RCD PEDA4",42, 0)
  11560    ;                            A4  - Current  Page Numb er
  11561   "RTN","RCD PEDA4",43, 0)
  11562    ;                            A5  - Stop Fl ag
  11563   "RTN","RCD PEDA4",44, 0)
  11564    ;                            A6  - Start o f Date Ran ge
  11565   "RTN","RCD PEDA4",45, 0)
  11566    ;                            A7  - End of  Date Range
  11567   "RTN","RCD PEDA4",46, 0)
  11568    ;                            A8  - Current  Line Coun ter
  11569   "RTN","RCD PEDA4",47, 0)
  11570    ;                            A9  - Interna l Date bei ng process ed
  11571   "RTN","RCD PEDA4",48, 0)
  11572    ;                            A1 0- 1 - Onl y Display  EFTs with  a debit fl ag of 'D'
  11573   "RTN","RCD PEDA4",49, 0)
  11574    ;                                  0 - Dis play all E FTs
  11575   "RTN","RCD PEDA4",50, 0)
  11576    ;           IEN34431     - Inte rnal IEN f or file 34 4.31
  11577   "RTN","RCD PEDA4",51, 0)
  11578    ;           EFTCTR                    - Us ed to stor e lines fo r EFT
  11579   "RTN","RCD PEDA4",52, 0)
  11580    ;           ^TMP($J, ONEDEP,0,1 )     - De posit Deta il line
  11581   "RTN","RCD PEDA4",53, 0)
  11582    ;           ^TMP($J, ONEDEP,EFT CTR)  - Cu rrent # of  lines for  EFT
  11583   "RTN","RCD PEDA4",54, 0)
  11584    ;           ^TMP($J, ONEDEP,EFT CTR,xx)- E FT Deposit  Lines
  11585   "RTN","RCD PEDA4",55, 0)
  11586    ; Output    ^TMP($J, ONEDEP,EFT CTR)  - Up dated # of  lines for  EFT
  11587   "RTN","RCD PEDA4",56, 0)
  11588    ;           ^TMP($J, ONEDEP,EFT CTR,xx)- U pdated EFT  Deposit L ines
  11589   "RTN","RCD PEDA4",57, 0)
  11590    Q:'$O(^RC Y(344.31,I EN34431,2, 0))            ; No e rror messa ge
  11591   "RTN","RCD PEDA4",58, 0)
  11592    N EFTLN,E RRS,V,XX,Y Y
  11593   "RTN","RCD PEDA4",59, 0)
  11594    S XX=$J(" ",3)_"ERRO R MESSAGES  FOR EFT D ETAIL:"
  11595   "RTN","RCD PEDA4",60, 0)
  11596    S EFTLN=$ G(^TMP($J, "ONEDEP",E FTCTR))+1
  11597   "RTN","RCD PEDA4",61, 0)
  11598    S ^TMP($J ,"ONEDEP", EFTCTR)=EF TLN
  11599   "RTN","RCD PEDA4",62, 0)
  11600    S ^TMP($J ,"ONEDEP", EFTCTR,EFT LN)=XX
  11601   "RTN","RCD PEDA4",63, 0)
  11602    S XX=$$GE T1^DIQ(344 .31,IEN344 31,2,"I"," ERRS")
  11603   "RTN","RCD PEDA4",64, 0)
  11604    S V=""
  11605   "RTN","RCD PEDA4",65, 0)
  11606    F  D  Q:V =""
  11607   "RTN","RCD PEDA4",66, 0)
  11608    . S V=$O( ERRS(V))
  11609   "RTN","RCD PEDA4",67, 0)
  11610    . Q:V=""
  11611   "RTN","RCD PEDA4",68, 0)
  11612    . S XX=$J ("",5)_ERR S(V)
  11613   "RTN","RCD PEDA4",69, 0)
  11614    . S EFTLN =EFTLN+1
  11615   "RTN","RCD PEDA4",70, 0)
  11616    . S ^TMP( $J,"ONEDEP ",EFTCTR)= EFTLN
  11617   "RTN","RCD PEDA4",71, 0)
  11618    . S ^TMP( $J,"ONEDEP ",EFTCTR,E FTLN)=XX
  11619   "RTN","RCD PEDA4",72, 0)
  11620    Q
  11621   "RTN","RCD PEDA4",73, 0)
  11622    ;
  11623   "RTN","RCD PEDA4",74, 0)
  11624   LMHDR(RCST OP,RCDET,R CNJ,RCDT1, RCDT2,RCHD R,DONLY) ; EP from RC DPEDAR       
  11625   "RTN","RCD PEDA4",75, 0)
  11626    ; ListMan  report he ading
  11627   "RTN","RCD PEDA4",76, 0)
  11628    ; Input:    RCDET        - 1 to  display d etail, 0 o therwise
  11629   "RTN","RCD PEDA4",77, 0)
  11630    ;           RCNJ         - Set  1, indicat es report  was called  from the  nightly
  11631   "RTN","RCD PEDA4",78, 0)
  11632    ;                          proc ess OR dis playing to  listman.   Used to s et lines
  11633   "RTN","RCD PEDA4",79, 0)
  11634    ;                          into  a ^TMP ar ray instea d of displ aying them .
  11635   "RTN","RCD PEDA4",80, 0)
  11636    ;           RCDT1        - Inte rnal Start  Date of d ate range
  11637   "RTN","RCD PEDA4",81, 0)
  11638    ;           RCDT2        - Inte rnal End D ate of dat e range
  11639   "RTN","RCD PEDA4",82, 0)
  11640    ;           DONLY        - 1 -  Only EFTs  with debit s, 0 - dis play all E FTs
  11641   "RTN","RCD PEDA4",83, 0)
  11642    ;           RCNP         - Paye r Selectio n flag A1^ A2^A3 Wher e:
  11643   "RTN","RCD PEDA4",84, 0)
  11644    ;                           A1  - 1 - Rang e,2 - All, 3 -Specifi c
  11645   "RTN","RCD PEDA4",85, 0)
  11646    ;                           A2  - From Pay er text (o nly set if  A1=1)
  11647   "RTN","RCD PEDA4",86, 0)
  11648    ;                           A3  - Through  text (only  set if A1 =1)
  11649   "RTN","RCD PEDA4",87, 0)
  11650    ;           ^TMP("RC SELPAY",$J ,B1) - Sel ected paye rs to be d isplayed
  11651   "RTN","RCD PEDA4",88, 0)
  11652    ; Output:   RCHDR        - Arra y of listm an header  lines
  11653   "RTN","RCD PEDA4",89, 0)
  11654    ;           RCSTOP       - 1 if  user stop ped 
  11655   "RTN","RCD PEDA4",90, 0)
  11656    ;
  11657   "RTN","RCD PEDA4",91, 0)
  11658    N RCCT,X, XX,Y,Z,Z0, Z1
  11659   "RTN","RCD PEDA4",92, 0)
  11660    S RCCT=0
  11661   "RTN","RCD PEDA4",93, 0)
  11662    S XX=$S(R CDET:"DETA IL",1:"SUM MARY")_" R EPORT"
  11663   "RTN","RCD PEDA4",94, 0)
  11664    S RCHDR(" TITLE")="E DI LOCKBOX  EFT DAILY  ACTIVITY  "_XX
  11665   "RTN","RCD PEDA4",95, 0)
  11666    S Z1=""
  11667   "RTN","RCD PEDA4",96, 0)
  11668    I 'VAUTD  D
  11669   "RTN","RCD PEDA4",97, 0)
  11670    . S Z0=0
  11671   "RTN","RCD PEDA4",98, 0)
  11672    . F  D  Q :'Z0
  11673   "RTN","RCD PEDA4",99, 0)
  11674    . . S Z0= $O(VAUTD(Z 0))
  11675   "RTN","RCD PEDA4",100 ,0)
  11676    . . Q:'Z0
  11677   "RTN","RCD PEDA4",101 ,0)
  11678    . . S XX= $$GET1^DIQ (40.8,Z0,1 ,"I")  ; F acility Nu mber  ;PRC A*4.5*321
  11679   "RTN","RCD PEDA4",102 ,0)
  11680    . . ;S Z1 =Z1_VAUTD( Z0)_", "
  11681   "RTN","RCD PEDA4",103 ,0)
  11682    . . S Z1= Z1_XX_", "
  11683   "RTN","RCD PEDA4",104 ,0)
  11684    S Z="DIVI SIONS: "_$ S(VAUTD:"A LL",1:$E(Z 1,1,$L(Z1) -2))
  11685   "RTN","RCD PEDA4",105 ,0)
  11686    I 'RCDET  D
  11687   "RTN","RCD PEDA4",106 ,0)
  11688    . S RCCT= RCCT+1,RCH DR(RCCT)=" "
  11689   "RTN","RCD PEDA4",107 ,0)
  11690    S RCCT=RC CT+1,RCHDR (RCCT)=Z
  11691   "RTN","RCD PEDA4",108 ,0)
  11692    ;
  11693   "RTN","RCD PEDA4",109 ,0)
  11694    I 'RCDET  D
  11695   "RTN","RCD PEDA4",110 ,0)
  11696    . S RCCT= RCCT+1,RCH DR(RCCT)=" "
  11697   "RTN","RCD PEDA4",111 ,0)
  11698    S Z="DATE  RANGE: "_ $$FMTE^XLF DT(RCDT1," 2Z")_" - "
  11699   "RTN","RCD PEDA4",112 ,0)
  11700    S Z=Z_$$F MTE^XLFDT( RCDT2,"2Z" )_" (DATE  DEPOSIT AD DED)"
  11701   "RTN","RCD PEDA4",113 ,0)
  11702    S Z=Z_"         DEBI T ONLY EFT s: "_$S(DO NLY=1:"YES ",1:"NO")  ; PRCA*4.5 *321 Added  line
  11703   "RTN","RCD PEDA4",114 ,0)
  11704    I 'RCDET  D
  11705   "RTN","RCD PEDA4",115 ,0)
  11706    . S RCCT= RCCT+1,RCH DR(RCCT)=" "
  11707   "RTN","RCD PEDA4",116 ,0)
  11708    S RCCT=RC CT+1,RCHDR (RCCT)=Z
  11709   "RTN","RCD PEDA4",117 ,0)
  11710    I RCDET D
  11711   "RTN","RCD PEDA4",118 ,0)
  11712    . S XX="D EP #       DEPOSIT DT   "_$J("", 19)
  11713   "RTN","RCD PEDA4",119 ,0)
  11714    . S XX=XX _"DEP AMOU NT           FMS DEPO SIT STAT"
  11715   "RTN","RCD PEDA4",120 ,0)
  11716    . S Z=$$S ETSTR^VALM 1(XX,"",1, 80)
  11717   "RTN","RCD PEDA4",121 ,0)
  11718    . S RCCT= RCCT+1,RCH DR(RCCT)=Z
  11719   "RTN","RCD PEDA4",122 ,0)
  11720    . ; PRCA* 4.5*318, M ove entire  EFT # row  to left 1  space to  adjust for  other row s needing  space
  11721   "RTN","RCD PEDA4",123 ,0)
  11722    . S XX=$J ("",2)_"EF T #"_$J("" ,22)_"DATE  PD   PAYM ENT AMOUNT   ERA MATC H STATUS"
  11723   "RTN","RCD PEDA4",124 ,0)
  11724    . S Z=$$S ETSTR^VALM 1(XX,"",1, 80)
  11725   "RTN","RCD PEDA4",125 ,0)
  11726    . S RCCT= RCCT+1,RCH DR(RCCT)=Z
  11727   "RTN","RCD PEDA4",126 ,0)
  11728    . ; PRCA* 4.5*318, M ove entire  EFT Payer  Trace # r ow to left  6 spaces  to adjust  for other  rows needi ng space
  11729   "RTN","RCD PEDA4",127 ,0)
  11730    . S Z=$$S ETSTR^VALM 1($J("",4) _"EFT PAYE R TRACE #" ,"",1,30)
  11731   "RTN","RCD PEDA4",128 ,0)
  11732    . ;PRCA*4 .5*318 add  CR #
  11733   "RTN","RCD PEDA4",129 ,0)
  11734    . S Z=$$S ETSTR^VALM 1("CR #",Z ,59,80)
  11735   "RTN","RCD PEDA4",130 ,0)
  11736    . S RCCT= RCCT+1,RCH DR(RCCT)=Z
  11737   "RTN","RCD PEDA4",131 ,0)
  11738    . ; PRCA* 4.5*318, M ove entire  Payment F rom row to  left 8 sp aces to ad just 
  11739   "RTN","RCD PEDA4",132 ,0)
  11740    . ; a pos sible 60 c haracter P ayer Name  and 20 cha racter Pay er ID
  11741   "RTN","RCD PEDA4",133 ,0)
  11742    . S Z=$$S ETSTR^VALM 1($J("",6) _"PAYMENT  FROM","",1 ,30)
  11743   "RTN","RCD PEDA4",134 ,0)
  11744    . S Z=$$S ETSTR^VALM 1("DEBIT", Z,37,5)             ;  PRCA*4.5* 321 Added  line
  11745   "RTN","RCD PEDA4",135 ,0)
  11746    . S Z=$$S ETSTR^VALM 1("DEP REC EIPT #",Z, 45,30)   ;  PRCA*4.5* 321 used t o be 31,30
  11747   "RTN","RCD PEDA4",136 ,0)
  11748    . S Z=$$S ETSTR^VALM 1("DEP REC EIPT STATU S",Z,61,19 )
  11749   "RTN","RCD PEDA4",137 ,0)
  11750    . S RCCT= RCCT+1,RCH DR(RCCT)=Z
  11751   "RTN","RCD PEDA4",138 ,0)
  11752    . ;PRCA*4 .5*318 add  TR #s
  11753   "RTN","RCD PEDA4",139 ,0)
  11754    . S Z=$$S ETSTR^VALM 1("TR #"," ",4,30)
  11755   "RTN","RCD PEDA4",140 ,0)
  11756    . S RCCT= RCCT+1,RCH DR(RCCT)=Z
  11757   "RTN","RCD PEDA4",141 ,0)
  11758    Q
  11759   "RTN","RCD PEDA4",142 ,0)
  11760    ;
  11761   "RTN","RCD PEDA4",143 ,0)
  11762   GETTR(IEN3 4431,INPUT )   ;EP fr om RCDPEDA 2
  11763   "RTN","RCD PEDA4",144 ,0)
  11764    ; Gathers  and Displ ays all TR  Doc #s fo r a specif ied EFT de tail recor d
  11765   "RTN","RCD PEDA4",145 ,0)
  11766    ; PRCA*4. 5*318 add  TR #s to d etail rpt
  11767   "RTN","RCD PEDA4",146 ,0)
  11768    ; Input:    IEN34431                  - In ternal IEN  for file  #344.31
  11769   "RTN","RCD PEDA4",147 ,0)
  11770    ;           INPUT                     - Se e EFTERRS  for detail s
  11771   "RTN","RCD PEDA4",148 ,0)
  11772    ;           EFTCTR                    - Us ed to stor e lines fo r EFT
  11773   "RTN","RCD PEDA4",149 ,0)
  11774    ;           ^TMP($J, ONEDEP,0,1 )     - De posit Deta il line
  11775   "RTN","RCD PEDA4",150 ,0)
  11776    ;           ^TMP($J, ONEDEP,EFT CTR)  - Cu rrent # of  lines for  EFT
  11777   "RTN","RCD PEDA4",151 ,0)
  11778    ;           ^TMP($J, ONEDEP,EFT CTR,xx)- E FT Deposit  Lines
  11779   "RTN","RCD PEDA4",152 ,0)
  11780    ; Output    ^TMP($J, ONEDEP,0,1 )     - Up dated Deta il line
  11781   "RTN","RCD PEDA4",153 ,0)
  11782    ;           ^TMP($J, ONEDEP,EFT CTR)  - Up dated # of  lines for  EFT
  11783   "RTN","RCD PEDA4",154 ,0)
  11784    ;           ^TMP($J, ONEDEP,EFT CTR,xx)- E FT Deposit  Lines
  11785   "RTN","RCD PEDA4",155 ,0)
  11786    ;
  11787   "RTN","RCD PEDA4",156 ,0)
  11788    ; PRCA*4. 5*321 capt ure displa y to ^TMP( $J,"ONEDEP ",EFTRCR)  including  line cnt
  11789   "RTN","RCD PEDA4",157 ,0)
  11790    N CTR,EFT LN,IEN3444 ,IENS,LNCT ,RECEIPT,T RDOC,TRDOC S,XX,ZZ
  11791   "RTN","RCD PEDA4",158 ,0)
  11792    ;
  11793   "RTN","RCD PEDA4",159 ,0)
  11794    ; First g ather up a ll the TR  Document n umbers int o as many  lines as n eeded
  11795   "RTN","RCD PEDA4",160 ,0)
  11796    S CTR=1,L NCT=$G(^TM P($J,"ONED EP"))
  11797   "RTN","RCD PEDA4",161 ,0)
  11798    S EFTLN=$ G(^TMP($J, "ONEDEP",E FTCTR))
  11799   "RTN","RCD PEDA4",162 ,0)
  11800    S IEN3444 =$$GET1^DI Q(344.31,I EN34431,.1 ,"I") ; In ternal IEN  for for 3 44.4
  11801   "RTN","RCD PEDA4",163 ,0)
  11802    S RECEIPT =$$GET1^DI Q(344.4,IE N3444,.08, "I")  ; Re ceipt # fr om 344.4
  11803   "RTN","RCD PEDA4",164 ,0)
  11804    I RECEIPT '="" D
  11805   "RTN","RCD PEDA4",165 ,0)
  11806    . S TRDOC =$TR($$GET 1^DIQ(344, RECEIPT,20 0,"I")," " )    ; FMS  Document  #
  11807   "RTN","RCD PEDA4",166 ,0)
  11808    . I TRDOC ="" Q
  11809   "RTN","RCD PEDA4",167 ,0)
  11810    . S TRDOC S(CTR)=TRD OC
  11811   "RTN","RCD PEDA4",168 ,0)
  11812    . S XX=""
  11813   "RTN","RCD PEDA4",169 ,0)
  11814    . F  D  Q :XX=""
  11815   "RTN","RCD PEDA4",170 ,0)
  11816    . . S XX= $O(^RCY(34 4.4,IEN344 4,8,XX))
  11817   "RTN","RCD PEDA4",171 ,0)
  11818    . . Q:XX= ""
  11819   "RTN","RCD PEDA4",172 ,0)
  11820    . . S IEN S=XX_","_I EN3444_","
  11821   "RTN","RCD PEDA4",173 ,0)
  11822    . . S REC EIPT=$$GET 1^DIQ(344. 48,IENS,.0 1,"I")  ;  Other rece ipt number s
  11823   "RTN","RCD PEDA4",174 ,0)
  11824    . . I REC EIPT="" Q
  11825   "RTN","RCD PEDA4",175 ,0)
  11826    . . S TRD OC=$TR($$G ET1^DIQ(34 4,RECEIPT, 200,"I"),"  ")   ; FM S Document  #
  11827   "RTN","RCD PEDA4",176 ,0)
  11828    . . Q:TRD OC=""
  11829   "RTN","RCD PEDA4",177 ,0)
  11830    . . I $L( TRDOC)+$L( $G(TRDOCS( CTR)))+1>7 3 D  Q
  11831   "RTN","RCD PEDA4",178 ,0)
  11832    . . . S C TR=CTR+1,T RDOCS(CTR) =TRDOC
  11833   "RTN","RCD PEDA4",179 ,0)
  11834    . . S TRD OCS(CTR)=T RDOCS(CTR) _", "_TRDO C
  11835   "RTN","RCD PEDA4",180 ,0)
  11836    ;
  11837   "RTN","RCD PEDA4",181 ,0)
  11838    ; Now dis play the T R Document  numbers
  11839   "RTN","RCD PEDA4",182 ,0)
  11840    I '$D(TRD OCS) D  Q     ; blank  line for  TR#s
  11841   "RTN","RCD PEDA4",183 ,0)
  11842    . S EFTLN =EFTLN+1
  11843   "RTN","RCD PEDA4",184 ,0)
  11844    . S ^TMP( $J,"ONEDEP ",EFTCTR)= EFTLN
  11845   "RTN","RCD PEDA4",185 ,0)
  11846    . S ^TMP( $J,"ONEDEP ",EFTCTR,E FTLN)=" "
  11847   "RTN","RCD PEDA4",186 ,0)
  11848    S XX=""
  11849   "RTN","RCD PEDA4",187 ,0)
  11850    F  D  Q:X X=""
  11851   "RTN","RCD PEDA4",188 ,0)
  11852    . S XX=$O (TRDOCS(XX ))
  11853   "RTN","RCD PEDA4",189 ,0)
  11854    . Q:XX=""
  11855   "RTN","RCD PEDA4",190 ,0)
  11856    . S EFTLN =EFTLN+1
  11857   "RTN","RCD PEDA4",191 ,0)
  11858    . S ^TMP( $J,"ONEDEP ",EFTCTR)= EFTLN
  11859   "RTN","RCD PEDA4",192 ,0)
  11860    . S ^TMP( $J,"ONEDEP ",EFTCTR,E FTLN)=$J(" ",3)_TRDOC S(XX)
  11861   "RTN","RCD PEDA4",193 ,0)
  11862    Q
  11863   "RTN","RCD PEDA4",194 ,0)
  11864    ;
  11865   "RTN","RCD PEDAR")
  11866   0^3^B81987 477
  11867   "RTN","RCD PEDAR",1,0 )
  11868   RCDPEDAR ; ALB/TMK -  ACTIVITY R EPORT ;Jun  06, 2014@ 19:11:19
  11869   "RTN","RCD PEDAR",2,0 )
  11870    ;;4.5;Acc ounts Rece ivable;**1 73,276,284 ,283,298,3 04,318,321 **;Mar 20,  1995;Buil d 46
  11871   "RTN","RCD PEDAR",3,0 )
  11872    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  11873   "RTN","RCD PEDAR",4,0 )
  11874    Q
  11875   "RTN","RCD PEDAR",5,0 )
  11876    ;
  11877   "RTN","RCD PEDAR",6,0 )
  11878   RPT ; Dail y Activity  Rpt On De mand
  11879   "RTN","RCD PEDAR",7,0 )
  11880    N POP,RCD ET,RCDIV,R CDONLY,RCD T1,RCDT2,R CHDR,RCINC ,RCLSTMGR, RCNP,RCNJ
  11881   "RTN","RCD PEDAR",8,0 )
  11882    N RCPYRSE L,RCRANGE, RCSTOP,RCT MPND,VAUTD ,X,XX,Y,%Z IS
  11883   "RTN","RCD PEDAR",9,0 )
  11884    S RCNJ=0                                       ; Not  the nightl y job, use r interact ions
  11885   "RTN","RCD PEDAR",10, 0)
  11886    D DIVISIO N^VAUTOMA                            ; IA 6 64 Select  Division/S tation - s ets VAUTD
  11887   "RTN","RCD PEDAR",11, 0)
  11888    I 'VAUTD, ($D(VAUTD) '=11) Q
  11889   "RTN","RCD PEDAR",12, 0)
  11890    S RCDET=$ $RTYPE()                             ; Sele ct Report  Type (Summ ary/Detail )
  11891   "RTN","RCD PEDAR",13, 0)
  11892    Q:RCDET=- 1
  11893   "RTN","RCD PEDAR",14, 0)
  11894    S XX=$$DT RANGE(.RCD T1,.RCDT2)                ; Sele ct Date Ra nge to be  used
  11895   "RTN","RCD PEDAR",15, 0)
  11896    Q:'XX
  11897   "RTN","RCD PEDAR",16, 0)
  11898    ;
  11899   "RTN","RCD PEDAR",17, 0)
  11900    ; Get ins urance com pany to be  used as f ilter
  11901   "RTN","RCD PEDAR",18, 0)
  11902    ; PRCA*4. 5*284 - RC NP is Type  of Respon se (1=Rang e,2=All,3= Specific)  ^ From Ran ge^ Thru R ange
  11903   "RTN","RCD PEDAR",19, 0)
  11904    S RCNP=$$ GETPAY^RCD PEM9(344.3 1)
  11905   "RTN","RCD PEDAR",20, 0)
  11906    Q:+RCNP=- 1                                    ; No I nsurance C ompany sel ected
  11907   "RTN","RCD PEDAR",21, 0)
  11908    ;
  11909   "RTN","RCD PEDAR",22, 0)
  11910    S RCDONLY =$$DBTONLY ()                        ; Debi t only fil ter   ;PRC A*4.5*321
  11911   "RTN","RCD PEDAR",23, 0)
  11912    Q:RCDONLY =-1                                  ; '^'  or timeout
  11913   "RTN","RCD PEDAR",24, 0)
  11914    S RCLSTMG R=$$ASKLM^ RCDPEARL                  ; Ask  to Display  in Listma n Template
  11915   "RTN","RCD PEDAR",25, 0)
  11916    Q:RCLSTMG R<0                                  ; '^'  or timeout
  11917   "RTN","RCD PEDAR",26, 0)
  11918    ;
  11919   "RTN","RCD PEDAR",27, 0)
  11920    I RCLSTMG R=1 D  Q                             ; List Man Templa te format,  put in ar ray
  11921   "RTN","RCD PEDAR",28, 0)
  11922    . S RCTMP ND="RCDPE_ DAR"
  11923   "RTN","RCD PEDAR",29, 0)
  11924    . K ^TMP( $J,RCTMPND )
  11925   "RTN","RCD PEDAR",30, 0)
  11926    . D EN(RC DET,RCDT1, RCDT2,RCLS TMGR,RCDON LY)
  11927   "RTN","RCD PEDAR",31, 0)
  11928    . D LMHDR ^RCDPEDA4( .RCSTOP,RC DET,1,RCDT 1,RCDT2,.R CHDR,RCDON LY)
  11929   "RTN","RCD PEDAR",32, 0)
  11930    . D LMRPT ^RCDPEARL( .RCHDR,$NA (^TMP($J,R CTMPND)))  ; Generate  ListMan d isplay
  11931   "RTN","RCD PEDAR",33, 0)
  11932    . K ^TMP( $J,RCTMPND )
  11933   "RTN","RCD PEDAR",34, 0)
  11934    ;
  11935   "RTN","RCD PEDAR",35, 0)
  11936    ; Ask dev ice
  11937   "RTN","RCD PEDAR",36, 0)
  11938    S %ZIS="Q M"
  11939   "RTN","RCD PEDAR",37, 0)
  11940    D ^%ZIS
  11941   "RTN","RCD PEDAR",38, 0)
  11942    Q:POP
  11943   "RTN","RCD PEDAR",39, 0)
  11944    ;
  11945   "RTN","RCD PEDAR",40, 0)
  11946    I $D(IO(" Q")) D  Q                            ; Queu ed Report
  11947   "RTN","RCD PEDAR",41, 0)
  11948    . N ZTDES C,ZTRTN,ZT SAVE,ZTSK
  11949   "RTN","RCD PEDAR",42, 0)
  11950    . S ZTRTN ="EN^RCDPE DAR("_RCDE T_","_RCDT 1_","_RCDT 2_",0,"_RC DONLY_")"  ;PRCA*4.5* 321 added  RCDONLY
  11951   "RTN","RCD PEDAR",43, 0)
  11952    . S ZTDES C="AR - ED I LOCKBOX  EFT DAILY  ACTIVITY R EPORT"
  11953   "RTN","RCD PEDAR",44, 0)
  11954    . S ZTSAV E("RC*")=" ",ZTSAVE(" VAUTD")=""
  11955   "RTN","RCD PEDAR",45, 0)
  11956    . ;
  11957   "RTN","RCD PEDAR",46, 0)
  11958    . ; PRCA* 4.5*284 -  Because TM P global m ay be on a nother ser ver, save  off specif ic payers  in local
  11959   "RTN","RCD PEDAR",47, 0)
  11960    . M RCPYR SEL=^TMP(" RCSELPAY", $J)
  11961   "RTN","RCD PEDAR",48, 0)
  11962    . D ^%ZTL OAD
  11963   "RTN","RCD PEDAR",49, 0)
  11964    . W !!,$S ($D(ZTSK): "Task numb er "_ZTSK_ " was queu ed.",1:"Un able to qu eue this t ask.")
  11965   "RTN","RCD PEDAR",50, 0)
  11966    . K ZTSK, IO("Q")
  11967   "RTN","RCD PEDAR",51, 0)
  11968    . D HOME^ %ZIS
  11969   "RTN","RCD PEDAR",52, 0)
  11970    ;
  11971   "RTN","RCD PEDAR",53, 0)
  11972    U IO
  11973   "RTN","RCD PEDAR",54, 0)
  11974    D EN(RCDE T,RCDT1,RC DT2,RCLSTM GR,RCDONLY )
  11975   "RTN","RCD PEDAR",55, 0)
  11976    Q
  11977   "RTN","RCD PEDAR",56, 0)
  11978    ;
  11979   "RTN","RCD PEDAR",57, 0)
  11980   DBTONLY()  ; Allows t he user to  select fi lter to on ly show EF Ts with de bits
  11981   "RTN","RCD PEDAR",58, 0)
  11982    ; PRCA*4. 5*321 Adde d subrouti ne
  11983   "RTN","RCD PEDAR",59, 0)
  11984    ; Input:    None
  11985   "RTN","RCD PEDAR",60, 0)
  11986    ; Returns : 0        - All EFTs  to displa y
  11987   "RTN","RCD PEDAR",61, 0)
  11988    ;           1        - Only EFT s with deb its to be  displayed
  11989   "RTN","RCD PEDAR",62, 0)
  11990    ;          -1        - User up- arrowed or  timed out
  11991   "RTN","RCD PEDAR",63, 0)
  11992    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T
  11993   "RTN","RCD PEDAR",64, 0)
  11994    S DIR("A" )="Show EF Ts with de bits only?  "
  11995   "RTN","RCD PEDAR",65, 0)
  11996    S DIR(0)= "SA^Y:YES; N:NO"
  11997   "RTN","RCD PEDAR",66, 0)
  11998    S DIR("B" )="NO"
  11999   "RTN","RCD PEDAR",67, 0)
  12000    S DIR("?" ,1)="Enter  'YES' to  only show  EFTs with  a debit fl ag of 'D'. "
  12001   "RTN","RCD PEDAR",68, 0)
  12002    S DIR("?" )="Enter ' NO' to sho w all EFTs ."
  12003   "RTN","RCD PEDAR",69, 0)
  12004    D ^DIR
  12005   "RTN","RCD PEDAR",70, 0)
  12006    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q -1
  12007   "RTN","RCD PEDAR",71, 0)
  12008    Q $E(Y,1) ="Y"
  12009   "RTN","RCD PEDAR",72, 0)
  12010    ;
  12011   "RTN","RCD PEDAR",73, 0)
  12012   RTYPE() ;  Allows the  user to s elect the  report typ e (Summary /Detail)
  12013   "RTN","RCD PEDAR",74, 0)
  12014    ; Input:    None
  12015   "RTN","RCD PEDAR",75, 0)
  12016    ; Returns : 0        - Summary  Display
  12017   "RTN","RCD PEDAR",76, 0)
  12018    ;           1        - Detail D isplay
  12019   "RTN","RCD PEDAR",77, 0)
  12020    ;          -1        - User up- arrowed or  timed out
  12021   "RTN","RCD PEDAR",78, 0)
  12022    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T
  12023   "RTN","RCD PEDAR",79, 0)
  12024    S DIR("A" )="(S)UMMA RY OR (D)E TAIL?: "
  12025   "RTN","RCD PEDAR",80, 0)
  12026    S DIR(0)= "SA^S:SUMM ARY TOTALS  ONLY;D:DE TAIL AND T OTALS"
  12027   "RTN","RCD PEDAR",81, 0)
  12028    S DIR("B" )="D"
  12029   "RTN","RCD PEDAR",82, 0)
  12030    D ^DIR
  12031   "RTN","RCD PEDAR",83, 0)
  12032    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q -1
  12033   "RTN","RCD PEDAR",84, 0)
  12034    Q Y="D"
  12035   "RTN","RCD PEDAR",85, 0)
  12036    ;
  12037   "RTN","RCD PEDAR",86, 0)
  12038   DTRANGE(ST DATE,ENDDA TE) ; Allo ws the use r to selec t the date  range to  by used
  12039   "RTN","RCD PEDAR",87, 0)
  12040    ; Input:    None
  12041   "RTN","RCD PEDAR",88, 0)
  12042    ; Output:   STDATE   = Internal  Fileman D ate to sta rt at
  12043   "RTN","RCD PEDAR",89, 0)
  12044    ;           ENDDATE  - Internal  Fileman D ate to end  at
  12045   "RTN","RCD PEDAR",90, 0)
  12046    ; Returns : 0 - User  up-arrowe d or timed  out, 1 ot herwise
  12047   "RTN","RCD PEDAR",91, 0)
  12048    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T
  12049   "RTN","RCD PEDAR",92, 0)
  12050    S DIR("?" )="Enter t he earlies t date of  receipt of  deposit t o include  on the rep ort."
  12051   "RTN","RCD PEDAR",93, 0)
  12052    S DIR(0)= "DAO^:"_DT _":APE"
  12053   "RTN","RCD PEDAR",94, 0)
  12054    S DIR("A" )="START D ATE: "
  12055   "RTN","RCD PEDAR",95, 0)
  12056    D ^DIR
  12057   "RTN","RCD PEDAR",96, 0)
  12058    Q:$D(DTOU T)!$D(DUOU T)!(Y="")  0
  12059   "RTN","RCD PEDAR",97, 0)
  12060    S STDATE= Y
  12061   "RTN","RCD PEDAR",98, 0)
  12062    K DIR
  12063   "RTN","RCD PEDAR",99, 0)
  12064    S DIR("?" )="Enter t he latest  date of re ceipt of d eposit to  include on  the repor t."
  12065   "RTN","RCD PEDAR",100 ,0)
  12066    S DIR("B" )=Y(0)
  12067   "RTN","RCD PEDAR",101 ,0)
  12068    S DIR(0)= "DAO^"_RCD T1_":"_DT_ ":APE",DIR ("A")="END  DATE: "
  12069   "RTN","RCD PEDAR",102 ,0)
  12070    D ^DIR
  12071   "RTN","RCD PEDAR",103 ,0)
  12072    Q:$D(DTOU T)!$D(DUOU T)!(Y="")  0
  12073   "RTN","RCD PEDAR",104 ,0)
  12074    S ENDDATE =Y
  12075   "RTN","RCD PEDAR",105 ,0)
  12076    Q 1
  12077   "RTN","RCD PEDAR",106 ,0)
  12078    ;
  12079   "RTN","RCD PEDAR",107 ,0)
  12080   EN(RCDET,R CDT1,RCDT2 ,RCLSTMGR, DONLY) ; E ntry point  for repor t, might b e queued
  12081   "RTN","RCD PEDAR",108 ,0)
  12082    ; Input:    RCDET        - 1 -  Detail Rep ort, 0 - S ummary
  12083   "RTN","RCD PEDAR",109 ,0)
  12084    ;           RCDT1        - Inte rnal Filem an Start d ate
  12085   "RTN","RCD PEDAR",110 ,0)
  12086    ;           RCDT2        - Inte rnal Filem an End dat e
  12087   "RTN","RCD PEDAR",111 ,0)
  12088    ;           RCLSTMGR     - 1 di splay in l ist manage r, 0 other wise
  12089   "RTN","RCD PEDAR",112 ,0)
  12090    ;                          Opti onal, defa ults to 0
  12091   "RTN","RCD PEDAR",113 ,0)
  12092    ;           DONLY        - 1 on ly display  EFTs with  a debit f lag of 'D'
  12093   "RTN","RCD PEDAR",114 ,0)
  12094    ;                          0 di splay all  EFTs
  12095   "RTN","RCD PEDAR",115 ,0)
  12096    ;           RCNP         - A1^A 2^A3 Where :
  12097   "RTN","RCD PEDAR",116 ,0)
  12098    ;                             A 1 - 1 - Ra nge of Pay ers
  12099   "RTN","RCD PEDAR",117 ,0)
  12100    ;                                   2 - Al l Payers s elected
  12101   "RTN","RCD PEDAR",118 ,0)
  12102    ;                                   3 - Sp ecific pay ers
  12103   "RTN","RCD PEDAR",119 ,0)
  12104    ;                             A 2 - From R ange (When  a from/th ru range i s selected  by user)
  12105   "RTN","RCD PEDAR",120 ,0)
  12106    ;                             A 3 - Thru R ange (When  a from/th ru range i s selected  by user)
  12107   "RTN","RCD PEDAR",121 ,0)
  12108    ;           RCPYRSEL     - Arra y of selec ted payers  (Only pre sent if A1 =3 above
  12109   "RTN","RCD PEDAR",122 ,0)
  12110    ;           VAUTD        - 1 -  All select ed divisio ns OR an a rray of se lected div isions
  12111   "RTN","RCD PEDAR",123 ,0)
  12112    N DFLG,DT ADD,IEN344 3,IEN34431 ,INPUT,RCF LG,RCJOB,R CT,XX,Z    ; PRCA*4.5 *321 Added  DFLG
  12113   "RTN","RCD PEDAR",124 ,0)
  12114    N:$G(ZTSK ) ZTSTOP                             ; Job  was tasked , ZTSTOP =  flag to s top
  12115   "RTN","RCD PEDAR",125 ,0)
  12116    S:'$D(RCL STMGR) RCL STMGR=0
  12117   "RTN","RCD PEDAR",126 ,0)
  12118    ;
  12119   "RTN","RCD PEDAR",127 ,0)
  12120    ; PRCA*4. 5*284 - Qu eued job n eeds to re load payer  selection  list
  12121   "RTN","RCD PEDAR",128 ,0)
  12122    I $D(RCPY RSEL) D
  12123   "RTN","RCD PEDAR",129 ,0)
  12124    . K ^TMP( "RCSELPAY" ,$J)
  12125   "RTN","RCD PEDAR",130 ,0)
  12126    . M ^TMP( "RCSELPAY" ,$J)=RCPYR SEL
  12127   "RTN","RCD PEDAR",131 ,0)
  12128    ;
  12129   "RTN","RCD PEDAR",132 ,0)
  12130    S XX=$S(R CLSTMGR:1, 1:0)
  12131   "RTN","RCD PEDAR",133 ,0)
  12132    S INPUT=X X_"^"_RCLS TMGR_"^"_+ RCDET
  12133   "RTN","RCD PEDAR",134 ,0)
  12134    S RCNP=+R CNP,RCJOB= $J
  12135   "RTN","RCD PEDAR",135 ,0)
  12136    K ^TMP("R CDAILYACT" ,$J)
  12137   "RTN","RCD PEDAR",136 ,0)
  12138    K ^TMP($J ,"TOTALS")                           ; Init ialize Tot als temp w orkspace
  12139   "RTN","RCD PEDAR",137 ,0)
  12140    ;
  12141   "RTN","RCD PEDAR",138 ,0)
  12142    ; Loop th rough all  of the EDI  LOCKBOX D EPOSIT rec ords in th e selected  date
  12143   "RTN","RCD PEDAR",139 ,0)
  12144    ; range a nd add any  that pass  the payer  and divis ion filter s into ^TM P
  12145   "RTN","RCD PEDAR",140 ,0)
  12146    ; by the  internal d ate added
  12147   "RTN","RCD PEDAR",141 ,0)
  12148    S DTADD=R CDT1-.0001 ,RCT=0
  12149   "RTN","RCD PEDAR",142 ,0)
  12150    S $P(INPU T,"^",4)=0                           ; Curr ent Page N umber
  12151   "RTN","RCD PEDAR",143 ,0)
  12152    S $P(INPU T,"^",5)=0                           ; Stop  Flag
  12153   "RTN","RCD PEDAR",144 ,0)
  12154    S $P(INPU T,"^",10)= DONLY
  12155   "RTN","RCD PEDAR",145 ,0)
  12156    F  D  Q:' DTADD  Q:D TADD>(RCDT 2_".9999")   Q:$P(INP UT,"^",5)= 1
  12157   "RTN","RCD PEDAR",146 ,0)
  12158    . S DTADD =$O(^RCY(3 44.3,"AREC DT",DTADD) )
  12159   "RTN","RCD PEDAR",147 ,0)
  12160    . Q:'DTAD D
  12161   "RTN","RCD PEDAR",148 ,0)
  12162    . Q:DTADD >(RCDT2_". 9999")
  12163   "RTN","RCD PEDAR",149 ,0)
  12164    . S IEN34 43=0
  12165   "RTN","RCD PEDAR",150 ,0)
  12166    . F  D  Q :'IEN3443   Q:$P(INPU T,"^",5)=1
  12167   "RTN","RCD PEDAR",151 ,0)
  12168    . . S IEN 3443=$O(^R CY(344.3," ARECDT",DT ADD,IEN344 3))
  12169   "RTN","RCD PEDAR",152 ,0)
  12170    . . Q:'IE N3443
  12171   "RTN","RCD PEDAR",153 ,0)
  12172    . . S IEN 34431="",R CFLG=0
  12173   "RTN","RCD PEDAR",154 ,0)
  12174    . . F  D   Q:IEN3443 1=""
  12175   "RTN","RCD PEDAR",155 ,0)
  12176    . . . S I EN34431=$O (^RCY(344. 31,"B",IEN 3443,IEN34 431))
  12177   "RTN","RCD PEDAR",156 ,0)
  12178    . . . Q:I EN34431=""
  12179   "RTN","RCD PEDAR",157 ,0)
  12180    . . . Q:' $$CHKPYR(I EN34431,0, RCJOB,RCNP )   ; Not  a selected  payer     PRCA*4.5*3 18 added , RCNP
  12181   "RTN","RCD PEDAR",158 ,0)
  12182    . . . Q:' $$CHKDIV(I EN34431,0, .VAUTD)        ; Not  a selected  station/d ivision
  12183   "RTN","RCD PEDAR",159 ,0)
  12184    . . . ;
  12185   "RTN","RCD PEDAR",160 ,0)
  12186    . . . ; P RCA*4.5*32 1 Added fi lter for D ebit EFTs  Only below
  12187   "RTN","RCD PEDAR",161 ,0)
  12188    . . . I D ONLY D  Q: DFLG'="D"                 ; Not  an EFT wit h a debit  flag of 'D '
  12189   "RTN","RCD PEDAR",162 ,0)
  12190    . . . . S  DFLG=$$GE T1^DIQ(344 .31,IEN344 31,3,"E")
  12191   "RTN","RCD PEDAR",163 ,0)
  12192    . . . S R CFLG=1
  12193   "RTN","RCD PEDAR",164 ,0)
  12194    . . . S ^ TMP("RCDAI LYACT",$J, DTADD\1,IE N3443,"EFT ",IEN34431 )=""
  12195   "RTN","RCD PEDAR",165 ,0)
  12196    . . ;
  12197   "RTN","RCD PEDAR",166 ,0)
  12198    . . S:RCF LG ^TMP("R CDAILYACT" ,$J,DTADD\ 1,IEN3443) =""
  12199   "RTN","RCD PEDAR",167 ,0)
  12200    . . S RCT =RCT+1                               ; Curr ent Record  Count
  12201   "RTN","RCD PEDAR",168 ,0)
  12202    . . ;
  12203   "RTN","RCD PEDAR",169 ,0)
  12204    . . ; Che ck for use r stopped  every 100  records
  12205   "RTN","RCD PEDAR",170 ,0)
  12206    . . I '(R CT#100),$D (ZTQUEUED) ,$$S^%ZTLO AD D  Q
  12207   "RTN","RCD PEDAR",171 ,0)
  12208    . . . S Z TSTOP=1
  12209   "RTN","RCD PEDAR",172 ,0)
  12210    . . . S $ P(INPUT,"^ ",5)=1                    ; Stop  now
  12211   "RTN","RCD PEDAR",173 ,0)
  12212    . . . K Z TREQ
  12213   "RTN","RCD PEDAR",174 ,0)
  12214    ;
  12215   "RTN","RCD PEDAR",175 ,0)
  12216    I '$P(INP UT,"^",5)  D
  12217   "RTN","RCD PEDAR",176 ,0)
  12218    . S $P(IN PUT,"^",6) =RCDT1                    ; Star t of Date  Range
  12219   "RTN","RCD PEDAR",177 ,0)
  12220    . S $P(IN PUT,"^",7) =RCDT2                    ; End  of Date Ra nge
  12221   "RTN","RCD PEDAR",178 ,0)
  12222    . D RPT1( .INPUT)
  12223   "RTN","RCD PEDAR",179 ,0)
  12224    D ENQ(INP UT)
  12225   "RTN","RCD PEDAR",180 ,0)
  12226    Q
  12227   "RTN","RCD PEDAR",181 ,0)
  12228    ;
  12229   "RTN","RCD PEDAR",182 ,0)
  12230   ENQ(INPUT)  ; Clean u p
  12231   "RTN","RCD PEDAR",183 ,0)
  12232    ; Input:    INPUT        - A1^A 2^A3^...^A 8 Where:
  12233   "RTN","RCD PEDAR",184 ,0)
  12234    ;                           A1  - 1 if Det ail report , 0 if sum mary repor t
  12235   "RTN","RCD PEDAR",185 ,0)
  12236    ;                           A2  - 1 if dis playing to  Listman,  0 otherwis e
  12237   "RTN","RCD PEDAR",186 ,0)
  12238    ;                           A3  - 0 if NOT  called fr om Nightly  Process,  1 otherwis e
  12239   "RTN","RCD PEDAR",187 ,0)
  12240    ;                           A4  - Current  Page Numbe r
  12241   "RTN","RCD PEDAR",188 ,0)
  12242    ;                           A5  - Stop Fla g
  12243   "RTN","RCD PEDAR",189 ,0)
  12244    ;                           A6  - Start of  Date Rang e
  12245   "RTN","RCD PEDAR",190 ,0)
  12246    ;                           A7  - End of D ate Range
  12247   "RTN","RCD PEDAR",191 ,0)
  12248    ;           ZTQUEUED     - Defi ned if Joh  was queue d
  12249   "RTN","RCD PEDAR",192 ,0)
  12250    ; Output:   ZTREQ        - "@"  Only retur ned if ZTQ UEUED is d efined
  12251   "RTN","RCD PEDAR",193 ,0)
  12252    N XX,YY,Z Z
  12253   "RTN","RCD PEDAR",194 ,0)
  12254    K ^TMP($J ,"DEPERRS" ),^TMP($J, "ONEDEP")   ; PRCA*4. 5*321
  12255   "RTN","RCD PEDAR",195 ,0)
  12256    K ^TMP("R CDAILYACT" ,$J),^TMP( "RCSELPAY" ,$J)
  12257   "RTN","RCD PEDAR",196 ,0)
  12258    K ^TMP($J ,"TOTALS")
  12259   "RTN","RCD PEDAR",197 ,0)
  12260    I '$D(ZTQ UEUED) D
  12261   "RTN","RCD PEDAR",198 ,0)
  12262    . D ^%ZIS C
  12263   "RTN","RCD PEDAR",199 ,0)
  12264    . S XX=$P (INPUT,"^" ,1)                       ; Nigh tly Proces s Flag
  12265   "RTN","RCD PEDAR",200 ,0)
  12266    . S YY=$P (INPUT,"^" ,5)                       ; Stop  Flag
  12267   "RTN","RCD PEDAR",201 ,0)
  12268    . S ZZ=$P (INPUT,"^" ,4)                       ; Curr ent Page N umber
  12269   "RTN","RCD PEDAR",202 ,0)
  12270    . I 'XX,' YY,ZZ D
  12271   "RTN","RCD PEDAR",203 ,0)
  12272    . . S XX= ""
  12273   "RTN","RCD PEDAR",204 ,0)
  12274    . . D ASK ^RCDPEARL( .XX)
  12275   "RTN","RCD PEDAR",205 ,0)
  12276    I $D(ZTQU EUED) S ZT REQ="@"
  12277   "RTN","RCD PEDAR",206 ,0)
  12278    Q
  12279   "RTN","RCD PEDAR",207 ,0)
  12280    ;
  12281   "RTN","RCD PEDAR",208 ,0)
  12282   RPT1(INPUT ) ;EP from  RCDPEM1 ( Nightly Pr ocess)
  12283   "RTN","RCD PEDAR",209 ,0)
  12284    ; Output  the report
  12285   "RTN","RCD PEDAR",210 ,0)
  12286    ; Input:    INPUT        - A1^A 2^A3^...^A n Where:
  12287   "RTN","RCD PEDAR",211 ,0)
  12288    ;                           A1  - 1 if cal led from N ightly Pro cess, 0 ot herwise
  12289   "RTN","RCD PEDAR",212 ,0)
  12290    ;                           A2  - 1 if dis playing to  Listman,  0 otherwis e
  12291   "RTN","RCD PEDAR",213 ,0)
  12292    ;                           A4  - Current  Page Numbe r
  12293   "RTN","RCD PEDAR",214 ,0)
  12294    ;                           A5  - Stop Fla g
  12295   "RTN","RCD PEDAR",215 ,0)
  12296    ;                           A6  - Start of  Date Rang e
  12297   "RTN","RCD PEDAR",216 ,0)
  12298    ;                           A7  - End of D ate Range
  12299   "RTN","RCD PEDAR",217 ,0)
  12300    ;           ^TMP(B1, $J,B2,B3)           =  "" - Arra y of recor d IENs in  344.3 in d ate range
  12301   "RTN","RCD PEDAR",218 ,0)
  12302    ;                                                and  for select ed payer(s ) and divi sion(s)
  12303   "RTN","RCD PEDAR",219 ,0)
  12304    ;           ^TMP(B1, $J,B2,B3," EFT",B4) =  "" - Arra y of recor d IENS in  344.31 for  above Whe re:
  12305   "RTN","RCD PEDAR",220 ,0)
  12306    ;                          B1 -  "RCDAILYA CT"
  12307   "RTN","RCD PEDAR",221 ,0)
  12308    ;                          B2 -  Internal  Date from  DATE/TIME  ADDED (344 .3, .13)
  12309   "RTN","RCD PEDAR",222 ,0)
  12310    ;                          B3 -  Internal  IEN for 34 4.3
  12311   "RTN","RCD PEDAR",223 ,0)
  12312    ;                          B4 -  Internal  IEN for fi le 344.31
  12313   "RTN","RCD PEDAR",224 ,0)
  12314    ; Output:   INPUT        - A1^A 2^A3^...^A n - The fo llowing pi eces may b e updated
  12315   "RTN","RCD PEDAR",225 ,0)
  12316    ;                           A4  - Current  Page Numbe r
  12317   "RTN","RCD PEDAR",226 ,0)
  12318    ;                           A5  - Stop Fla g
  12319   "RTN","RCD PEDAR",227 ,0)
  12320    ;
  12321   "RTN","RCD PEDAR",228 ,0)
  12322    N CURPG,D ETL,DTADD, DTEND,DTST ,HDR1,LSTM AN,NJ
  12323   "RTN","RCD PEDAR",229 ,0)
  12324    S DETL=$P (INPUT,"^" ,3)                       ; Deta il Report  flag
  12325   "RTN","RCD PEDAR",230 ,0)
  12326    S LSTMAN= $P(INPUT," ^",2)                     ; List man flag
  12327   "RTN","RCD PEDAR",231 ,0)
  12328    S NJ=$P(I NPUT,"^",1 )                         ; Nigh tly Proces s flag
  12329   "RTN","RCD PEDAR",232 ,0)
  12330    S CURPG=$ P(INPUT,"^ ",4)                      ; Curr ent Page N umber
  12331   "RTN","RCD PEDAR",233 ,0)
  12332    S DTST=$P (INPUT,"^" ,6)                       ; Date  Range Sta rt
  12333   "RTN","RCD PEDAR",234 ,0)
  12334    S DTEND=$ P(INPUT,"^ ",7)                      ; Date  Range End
  12335   "RTN","RCD PEDAR",235 ,0)
  12336    S $P(INPU T,"^",8)=0                           ; Curr ent line c ounter
  12337   "RTN","RCD PEDAR",236 ,0)
  12338    S DTADD=" "
  12339   "RTN","RCD PEDAR",237 ,0)
  12340    F  D  Q:D TADD=""  Q :$P(INPUT, "^",5)=1
  12341   "RTN","RCD PEDAR",238 ,0)
  12342    . S DTADD =$O(^TMP(" RCDAILYACT ",$J,DTADD ))
  12343   "RTN","RCD PEDAR",239 ,0)
  12344    . Q:DTADD =""
  12345   "RTN","RCD PEDAR",240 ,0)
  12346    . ;
  12347   "RTN","RCD PEDAR",241 ,0)
  12348    . I 'LSTM AN,DETL D   Q:$P(INPU T,"^",5)=1                 ; PRC A*4.5*321
  12349   "RTN","RCD PEDAR",242 ,0)
  12350    . . D HDR ^RCDPEDA3( .INPUT)
  12351   "RTN","RCD PEDAR",243 ,0)
  12352    . ;
  12353   "RTN","RCD PEDAR",244 ,0)
  12354    . I DETL  D                                      ; De tail Repor t
  12355   "RTN","RCD PEDAR",245 ,0)
  12356    . . S HDR 1="DATE EF T DEPOSIT  RECEIVED:  "_$$FMTE^X LFDT(DTADD ,"2Z")  ;  PRCA*4.5*3 21 moved l ocation
  12357   "RTN","RCD PEDAR",246 ,0)
  12358    . . S HDR 1=$J("",80 -$L(HDR1)\ 2)_HDR1          ; Ce nter it
  12359   "RTN","RCD PEDAR",247 ,0)
  12360    . . D SL^ RCDPEDA3(. INPUT,HDR1 )
  12361   "RTN","RCD PEDAR",248 ,0)
  12362    . . D SL^ RCDPEDA3(. INPUT," ")
  12363   "RTN","RCD PEDAR",249 ,0)
  12364    . S $P(IN PUT,"^",9) =DTADD
  12365   "RTN","RCD PEDAR",250 ,0)
  12366    . D RPT2^ RCDPEDA2(. INPUT)                    ; Proc ess all 34 4.3 record s found
  12367   "RTN","RCD PEDAR",251 ,0)
  12368    . Q:$P(IN PUT,"^",5) =1                        ; User  quit
  12369   "RTN","RCD PEDAR",252 ,0)
  12370    . D TOTSD AY^RCDPEDA 3(.INPUT)                 ; Disp lay Totals  for Date
  12371   "RTN","RCD PEDAR",253 ,0)
  12372    ;
  12373   "RTN","RCD PEDAR",254 ,0)
  12374    Q:$P(INPU T,"^",5)=1                           ; User  quit
  12375   "RTN","RCD PEDAR",255 ,0)
  12376    D TOTSF^R CDPEDA3(.I NPUT)                     ; Disp lay Final  Totals
  12377   "RTN","RCD PEDAR",256 ,0)
  12378    D SL^RCDP EDA3(.INPU T,$$ENDORP RT^RCDPEAR L)  ; Disp lay End of  Report
  12379   "RTN","RCD PEDAR",257 ,0)
  12380    Q
  12381   "RTN","RCD PEDAR",258 ,0)
  12382    ;
  12383   "RTN","RCD PEDAR",259 ,0)
  12384   CHKPYR(IEN ,FLG,RCJOB ,RCNP) ;EP  from RCDP EAR2 PRCA* 4.5*318 ad ded RCNP p arameter
  12385   "RTN","RCD PEDAR",260 ,0)
  12386    ; Checks  to be sure  the speci fied payer  has been  selected
  12387   "RTN","RCD PEDAR",261 ,0)
  12388    ; Input:    IEN      - Internal  IEN into  file 344.3 1 (EDI THI RD PARTY E FT DETAI)  OR
  12389   "RTN","RCD PEDAR",262 ,0)
  12390    ;                                          file 344.4   (ELECTRO NIC REMITT ANCE ADVIC E)
  12391   "RTN","RCD PEDAR",263 ,0)
  12392    ;                      Used to  retrieve t he payer
  12393   "RTN","RCD PEDAR",264 ,0)
  12394    ;           FLG      - 0 if IEN  contains  ien in fil e 344.31
  12395   "RTN","RCD PEDAR",265 ,0)
  12396    ;                      1 if IEN  contains  ien in fil e 344.4
  12397   "RTN","RCD PEDAR",266 ,0)
  12398    ;           RCJOB    - $J
  12399   "RTN","RCD PEDAR",267 ,0)
  12400    ;           RCNP     - 0 - Not  passed
  12401   "RTN","RCD PEDAR",268 ,0)
  12402    ;                      1 - Rang e of Payer s
  12403   "RTN","RCD PEDAR",269 ,0)
  12404    ;                      2 - All  Payers sel ected
  12405   "RTN","RCD PEDAR",270 ,0)
  12406    ;                      3 - Spec ific payer s
  12407   "RTN","RCD PEDAR",271 ,0)
  12408    ;                      Optional , defaults  to 0
  12409   "RTN","RCD PEDAR",272 ,0)
  12410    ;           ^TMP("RC SELPAY",$J ,CNT)=A1 W here:
  12411   "RTN","RCD PEDAR",273 ,0)
  12412    ;                                      CNT  - Counter  of the nu mber of pa yers 1-n
  12413   "RTN","RCD PEDAR",274 ,0)
  12414    ;                                      A1   - Payer N ame
  12415   "RTN","RCD PEDAR",275 ,0)
  12416    ; Returns : 1 if pay er in 344. 31/.02 or  344.4/.06  is in the  list of se lected pay ers
  12417   "RTN","RCD PEDAR",276 ,0)
  12418    ;             ^TMP(" RCSELPAY", $J)
  12419   "RTN","RCD PEDAR",277 ,0)
  12420    ;           0 otherw ise
  12421   "RTN","RCD PEDAR",278 ,0)
  12422    N RCPAY,R ES,Z
  12423   "RTN","RCD PEDAR",279 ,0)
  12424    S:'$D(RCN P) RCNP=0                                     ; PRCA*4 .5*318 add ed line
  12425   "RTN","RCD PEDAR",280 ,0)
  12426    S RCPAY=" "
  12427   "RTN","RCD PEDAR",281 ,0)
  12428    I IEN D
  12429   "RTN","RCD PEDAR",282 ,0)
  12430    . I FLG S  RCPAY=$$G ET1^DIQ(34 4.4,IEN,.0 6,"I") Q     ; PAYMEN T FROM fie ld
  12431   "RTN","RCD PEDAR",283 ,0)
  12432    . S RCPAY =$$GET1^DI Q(344.31,I EN,.02,"I" )            ; PAYER  NAME field
  12433   "RTN","RCD PEDAR",284 ,0)
  12434    ;
  12435   "RTN","RCD PEDAR",285 ,0)
  12436    ; Include  EFT with  null Payer  Names in  reports fo r ALL paye rs - PRCA* 4.5*298 
  12437   "RTN","RCD PEDAR",286 ,0)
  12438    I FLG=0,R CNP=2,RCPA Y="" Q 1
  12439   "RTN","RCD PEDAR",287 ,0)
  12440    Q:RCPAY=" " 0                                           ; No Pay er to comp are, inval id
  12441   "RTN","RCD PEDAR",288 ,0)
  12442    S Z=0,RES =0
  12443   "RTN","RCD PEDAR",289 ,0)
  12444    F  D  Q:Z =""  Q:RES
  12445   "RTN","RCD PEDAR",290 ,0)
  12446    . S Z=$O( ^TMP("RCSE LPAY",RCJO B,Z))
  12447   "RTN","RCD PEDAR",291 ,0)
  12448    . Q:Z=""
  12449   "RTN","RCD PEDAR",292 ,0)
  12450    . S:RCPAY =$G(^TMP(" RCSELPAY", RCJOB,Z))  RES=1
  12451   "RTN","RCD PEDAR",293 ,0)
  12452    Q RES
  12453   "RTN","RCD PEDAR",294 ,0)
  12454    ;
  12455   "RTN","RCD PEDAR",295 ,0)
  12456   CHKDIV(IEN ,FLG,VAUTD ) ;
  12457   "RTN","RCD PEDAR",296 ,0)
  12458    ; IEN - i en in file  344.31 or  344.4
  12459   "RTN","RCD PEDAR",297 ,0)
  12460    ; FLG - 0  if IEN co ntains ien  in file 3 44.31, 1 i f IEN cont ains ien i n file 344 .4
  12461   "RTN","RCD PEDAR",298 ,0)
  12462    ; VAUTD -  array of  selected d ivisions f rom DIVISI ON^VAUTOMA  API call
  12463   "RTN","RCD PEDAR",299 ,0)
  12464    ; returns  1 if divi sion assoc iated with  an entry  in 344.31  is on the  list in VA UTD
  12465   "RTN","RCD PEDAR",300 ,0)
  12466    ; returns  0 otherwi se
  12467   "RTN","RCD PEDAR",301 ,0)
  12468    N ERA,I,N AME,RCSTA, RES
  12469   "RTN","RCD PEDAR",302 ,0)
  12470    S RES=0
  12471   "RTN","RCD PEDAR",303 ,0)
  12472    I VAUTD=1  S RES=1 G  CHKDIVX
  12473   "RTN","RCD PEDAR",304 ,0)
  12474    I 'IEN G  CHKDIVX
  12475   "RTN","RCD PEDAR",305 ,0)
  12476    S ERA=$S( FLG:IEN,1: $P($G(^RCY (344.31,IE N,0)),U,10 ))
  12477   "RTN","RCD PEDAR",306 ,0)
  12478    S RCSTA=$ $ERASTA^RC DPEM3(ERA) ,NAME=$P(R CSTA,U)
  12479   "RTN","RCD PEDAR",307 ,0)
  12480    I NAME="U NKNOWN" G  CHKDIVX
  12481   "RTN","RCD PEDAR",308 ,0)
  12482    S I=0 I ' VAUTD F  S  I=$O(VAUT D(I)) Q:'I !RES  I NA ME=VAUTD(I ) S RES=1
  12483   "RTN","RCD PEDAR",309 ,0)
  12484   CHKDIVX ;
  12485   "RTN","RCD PEDAR",310 ,0)
  12486    Q RES
  12487   "RTN","RCD PELAR")
  12488   0^39^B1266 15293
  12489   "RTN","RCD PELAR",1,0 )
  12490   RCDPELAR ; EDE/FA - L IST ALL AU TO-POSTED  RECEIPTS R EPORT ;Nov  17, 2016
  12491   "RTN","RCD PELAR",2,0 )
  12492    ;;4.5;Acc ounts Rece ivable;**3 18,321**;M ar 20, 199 5;Build 46
  12493   "RTN","RCD PELAR",3,0 )
  12494    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  12495   "RTN","RCD PELAR",4,0 )
  12496    ;
  12497   "RTN","RCD PELAR",5,0 )
  12498   EN ; Main  entry poin t
  12499   "RTN","RCD PELAR",6,0 )
  12500    N INPUT,R CVAUTD,XX, YY
  12501   "RTN","RCD PELAR",7,0 )
  12502    K ^TMP($J ,"RCDPE_LA R"),^TMP(" RCDPE_LAR" ,$J)
  12503   "RTN","RCD PELAR",8,0 )
  12504    K ^TMP("R CSELPAY",$ J),^TMP($J ,"SELPAYER ")
  12505   "RTN","RCD PELAR",9,0 )
  12506    ;
  12507   "RTN","RCD PELAR",10, 0)
  12508    S INPUT=$ $STADIV(.R CVAUTD)                       ;  Division f ilter
  12509   "RTN","RCD PELAR",11, 0)
  12510    Q:'INPUT                                           ;  '^' or tim eout
  12511   "RTN","RCD PELAR",12, 0)
  12512    S $P(INPU T,"^",2)=$ $APORERA()                    ;  Filter by  Auto-Post  Date or ER A Date Rec eived
  12513   "RTN","RCD PELAR",13, 0)
  12514    Q:'$P(INP UT,"^",2)                                ;  '^' or tim eout
  12515   "RTN","RCD PELAR",14, 0)
  12516    S $P(INPU T,"^",3)=$ $DTRNG(0)                     ;  Start Date |End date
  12517   "RTN","RCD PELAR",15, 0)
  12518    Q:'$P(INP UT,"^",3)                                ;  '^' or tim eout
  12519   "RTN","RCD PELAR",16, 0)
  12520    S $P(INPU T,"^",4)=$ $SELERA()                     ;  Select typ e of ERAS  to be disp layed
  12521   "RTN","RCD PELAR",17, 0)
  12522    Q:'$P(INP UT,"^",4)                                ;  '^' or tim eout
  12523   "RTN","RCD PELAR",18, 0)
  12524    S XX=+$$G ETPAY^RCDP EM9(344.4, 1,0)               ;  Insurance  Company fi lter
  12525   "RTN","RCD PELAR",19, 0)
  12526    S XX=$S(X X=-1:-1,XX =2:1,1:2)
  12527   "RTN","RCD PELAR",20, 0)
  12528    S $P(INPU T,"^",5)=X X                             ;  Insurance  Company fi lter
  12529   "RTN","RCD PELAR",21, 0)
  12530    Q:$P(INPU T,"^",5)<0                               ;  '^' or tim eout
  12531   "RTN","RCD PELAR",22, 0)
  12532    S XX=$P(I NPUT,"^",2 ),YY=$P(IN PUT,"^",4)
  12533   "RTN","RCD PELAR",23, 0)
  12534    S $P(INPU T,"^",6)=$ $RPTSORT(X X,YY)              ;  Select Sec ondary sor t
  12535   "RTN","RCD PELAR",24, 0)
  12536    Q:'$P(INP UT,"^",6)                                ;  '^' or tim eout
  12537   "RTN","RCD PELAR",25, 0)
  12538    S $P(INPU T,"^",7)=$ $ASKLM^RCD PEARL              ;  Ask to Dis play in Li stman Temp late
  12539   "RTN","RCD PELAR",26, 0)
  12540    Q:$P(INPU T,"^",7)<0                               ;  '^' or tim eout
  12541   "RTN","RCD PELAR",27, 0)
  12542    I $P(INPU T,"^",7)=1  D  Q                         ;  Compile da ta and cal l listman  to display
  12543   "RTN","RCD PELAR",28, 0)
  12544    . D LMOUT (INPUT,.RC VAUTD,.IO)
  12545   "RTN","RCD PELAR",29, 0)
  12546    S $P(INPU T,"^",8)=$ $EXCEL()                      ;  Ask to out put to Exc el
  12547   "RTN","RCD PELAR",30, 0)
  12548    Q:$P(INPU T,"^",8)=- 1                             ;  '^' or tim eout
  12549   "RTN","RCD PELAR",31, 0)
  12550    D:$P(INPU T,"^",8)=1  INFO^RCDP EM6                ;  Display ca pture info rmation fo r Excel
  12551   "RTN","RCD PELAR",32, 0)
  12552    S $P(INPU T,"^",9)=$ $DEVICE($P (INPUT,"^" ,8),.IO)     ; Ask ou tput devic e
  12553   "RTN","RCD PELAR",33, 0)
  12554    Q:'$P(INP UT,"^",9)
  12555   "RTN","RCD PELAR",34, 0)
  12556    ;
  12557   "RTN","RCD PELAR",35, 0)
  12558    ; Option  to queue
  12559   "RTN","RCD PELAR",36, 0)
  12560    I $D(IO(" Q")) D  Q
  12561   "RTN","RCD PELAR",37, 0)
  12562    . N JOB S  JOB=$J
  12563   "RTN","RCD PELAR",38, 0)
  12564    . N ZTDES C,ZTRTN,ZT SAVE,ZTSK
  12565   "RTN","RCD PELAR",39, 0)
  12566    . S ZTRTN ="REPORT^R CDPELAR(IN PUT,.RCVAU TD,.IO,JOB )"
  12567   "RTN","RCD PELAR",40, 0)
  12568    . S ZTDES C="LIST AL L AUTO-POS TED RECEIP TS REPORT"
  12569   "RTN","RCD PELAR",41, 0)
  12570    . M RCPYR SEL=^TMP(" RCSELPAY", $J)
  12571   "RTN","RCD PELAR",42, 0)
  12572    . S ZTSAV E("RC*")=" ",ZTSAVE(" VAUTD")="" ,ZTSAVE("I O*")=""
  12573   "RTN","RCD PELAR",43, 0)
  12574    . S ZTSAV E("INPUT") ="",ZTSAVE ("JOB")=""
  12575   "RTN","RCD PELAR",44, 0)
  12576    . D ^%ZTL OAD
  12577   "RTN","RCD PELAR",45, 0)
  12578    . W !!,$S ($D(ZTSK): "Task numb er "_ZTSK_ " was queu ed.",1:"Un able to qu eue this t ask.")
  12579   "RTN","RCD PELAR",46, 0)
  12580    . K ZTSK, IO("Q")
  12581   "RTN","RCD PELAR",47, 0)
  12582    . D HOME^ %ZIS
  12583   "RTN","RCD PELAR",48, 0)
  12584    ;
  12585   "RTN","RCD PELAR",49, 0)
  12586    D REPORT( INPUT,.RCV AUTD,.IO)             ; Compile  and Displa y Report d ata
  12587   "RTN","RCD PELAR",50, 0)
  12588    Q
  12589   "RTN","RCD PELAR",51, 0)
  12590    ;
  12591   "RTN","RCD PELAR",52, 0)
  12592   LMOUT(INPU T,RCVAUTD, IO) ; Outp ut report  to Listman
  12593   "RTN","RCD PELAR",53, 0)
  12594    ; Input:    INPUT        - See  REPORT for  a complet e descript ion
  12595   "RTN","RCD PELAR",54, 0)
  12596    ;           RCVAUTD      -  Arr ay of sele cted Divis ions
  12597   "RTN","RCD PELAR",55, 0)
  12598    ;                           Onl y passed i f A1=2
  12599   "RTN","RCD PELAR",56, 0)
  12600    ; Output:   ^TMP("RC DPE_LAR",$ J,CTR)=Lin e - Array  of display  lines (no  headers)
  12601   "RTN","RCD PELAR",57, 0)
  12602    ;                                               for o utput to L istman
  12603   "RTN","RCD PELAR",58, 0)
  12604    ;                                               Only  set when A 7-1
  12605   "RTN","RCD PELAR",59, 0)
  12606    N HDR
  12607   "RTN","RCD PELAR",60, 0)
  12608    S $P(INPU T,"^",9)=0                                ;  Initial l istman lin e counter
  12609   "RTN","RCD PELAR",61, 0)
  12610    D REPORT( INPUT,.RCV AUTD,.IO)                      ;  Get the l ines to be  displayed
  12611   "RTN","RCD PELAR",62, 0)
  12612    S HDR("TI TLE")="AUT O-POSTED R ECEIPT REP ORT"
  12613   "RTN","RCD PELAR",63, 0)
  12614    S HDR(1)= $$HDRLN2^R CDPELA1(IN PUT)
  12615   "RTN","RCD PELAR",64, 0)
  12616    S HDR(2)= $$HDRLN3^R CDPELA1(IN PUT)
  12617   "RTN","RCD PELAR",65, 0)
  12618    S HDR(3)= ""
  12619   "RTN","RCD PELAR",66, 0)
  12620    S HDR(4)= ""
  12621   "RTN","RCD PELAR",67, 0)
  12622    S HDR(5)= "PAYER"
  12623   "RTN","RCD PELAR",68, 0)
  12624    S HDR(6)= "        D ATE      D ATE"
  12625   "RTN","RCD PELAR",69, 0)
  12626    S HDR(7)= $$ERAHDR2^ RCDPELA1()
  12627   "RTN","RCD PELAR",70, 0)
  12628    D LMRPT^R CDPEARL(.H DR,$NA(^TM P("RCDPE_L AR",$J)))  ; Generate  ListMan d isplay
  12629   "RTN","RCD PELAR",71, 0)
  12630    ;
  12631   "RTN","RCD PELAR",72, 0)
  12632    D ^%ZISC                                           ;  Close the  device
  12633   "RTN","RCD PELAR",73, 0)
  12634    K ^TMP("R CDPE_LAR", $J),^TMP($ J,"RCDPE_L AR")
  12635   "RTN","RCD PELAR",74, 0)
  12636    K ^TMP("R CSELPAY",$ J),^TMP($J ,"SELPAYER ")
  12637   "RTN","RCD PELAR",75, 0)
  12638    Q
  12639   "RTN","RCD PELAR",76, 0)
  12640    ;
  12641   "RTN","RCD PELAR",77, 0)
  12642   STADIV(RCV AUTD) ; Di vision/Sta tion Filte r
  12643   "RTN","RCD PELAR",78, 0)
  12644    ; Input:    None
  12645   "RTN","RCD PELAR",79, 0)
  12646    ; Output:   RCVAUTD      - Arra y of selec ted divisi ons, if 1  is returne d
  12647   "RTN","RCD PELAR",80, 0)
  12648    ; Returns : 0            - User  up-arrowe d or timed  out
  12649   "RTN","RCD PELAR",81, 0)
  12650    ;           1            - All  divisions  selected
  12651   "RTN","RCD PELAR",82, 0)
  12652    ;           2            - Sele cted Divis ions
  12653   "RTN","RCD PELAR",83, 0)
  12654    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,VAUTD,X, Y
  12655   "RTN","RCD PELAR",84, 0)
  12656    D DIVISIO N^VAUTOMA                            ; IA # 664 allows  this
  12657   "RTN","RCD PELAR",85, 0)
  12658    Q:Y<0 0                                        ; User  up-arrowe d or timed  out
  12659   "RTN","RCD PELAR",86, 0)
  12660    Q:VAUTD=1  1                                   ; All  divisions  selected
  12661   "RTN","RCD PELAR",87, 0)
  12662    M RCVAUTD =VAUTD                               ; Save  selected  divisions  (if any)
  12663   "RTN","RCD PELAR",88, 0)
  12664    Q 2
  12665   "RTN","RCD PELAR",89, 0)
  12666    ;
  12667   "RTN","RCD PELAR",90, 0)
  12668   APORERA()  ; Ask the  user if th ey want to  filter by  Auto-Post  Date or E RA Date
  12669   "RTN","RCD PELAR",91, 0)
  12670    ; receive d
  12671   "RTN","RCD PELAR",92, 0)
  12672    ; Input:    None
  12673   "RTN","RCD PELAR",93, 0)
  12674    ; Returns : 0        - User up- arrowed or  timed out
  12675   "RTN","RCD PELAR",94, 0)
  12676    ;           1        - Filter b y Auto-Pos t date ran ge
  12677   "RTN","RCD PELAR",95, 0)
  12678    ;           2        - Filter b y ERA Date  Received
  12679   "RTN","RCD PELAR",96, 0)
  12680    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  12681   "RTN","RCD PELAR",97, 0)
  12682    S DIR("A" )="(A)uto- Post Date  or (E)RA D ate Receiv ed? (A/E):  "
  12683   "RTN","RCD PELAR",98, 0)
  12684    S DIR(0)= "SA^A:Auto -Post Date ;E:ERA Dat e Received "
  12685   "RTN","RCD PELAR",99, 0)
  12686    S DIR("?" ,1)="Enter  'A' to fi lter by an  Auto-Post  Date Rang e."
  12687   "RTN","RCD PELAR",100 ,0)
  12688    S DIR("?" )="Enter ' E' to filt er by an E RA Date Re ceived Dat e Range."
  12689   "RTN","RCD PELAR",101 ,0)
  12690    S DIR("B" )="A"
  12691   "RTN","RCD PELAR",102 ,0)
  12692    D ^DIR
  12693   "RTN","RCD PELAR",103 ,0)
  12694    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q 0
  12695   "RTN","RCD PELAR",104 ,0)
  12696    Q:Y="A" 1
  12697   "RTN","RCD PELAR",105 ,0)
  12698    Q 2
  12699   "RTN","RCD PELAR",106 ,0)
  12700    ;
  12701   "RTN","RCD PELAR",107 ,0)
  12702   DTRNG(WHIC H) ; Allow s the user  to select  the Auto- Post OR ER A Received
  12703   "RTN","RCD PELAR",108 ,0)
  12704    ; date ra nge to be  used
  12705   "RTN","RCD PELAR",109 ,0)
  12706    ; Input:    WHICH    - 0 - Auto -Post Date  Range
  12707   "RTN","RCD PELAR",110 ,0)
  12708    ;                      1 - ERA  Date Recei ved Date R ange
  12709   "RTN","RCD PELAR",111 ,0)
  12710    ; Returns : 0        - User up- arrowed or  timed out , 1 otherw ise
  12711   "RTN","RCD PELAR",112 ,0)
  12712    ;           A1^A2    - Where:
  12713   "RTN","RCD PELAR",113 ,0)
  12714    ;                      A1 - Aut -Post Star t Date
  12715   "RTN","RCD PELAR",114 ,0)
  12716    ;                      A2 - Aut o-Post End  Date
  12717   "RTN","RCD PELAR",115 ,0)
  12718    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,RANGE,ST ART,X,XX,Y
  12719   "RTN","RCD PELAR",116 ,0)
  12720    S DIR(0)= "DAO^:"_DT _":APE"
  12721   "RTN","RCD PELAR",117 ,0)
  12722    S DIR("A" )="Start D ate: "
  12723   "RTN","RCD PELAR",118 ,0)
  12724    S XX="Ent er the ear liest "_$S (WHICH=0:" Auto-Post  date",1:"E RA Date Re ceived")
  12725   "RTN","RCD PELAR",119 ,0)
  12726    S XX=XX_"  for recei pts to inc lude on th e report"
  12727   "RTN","RCD PELAR",120 ,0)
  12728    S DIR("?" )=XX
  12729   "RTN","RCD PELAR",121 ,0)
  12730    D ^DIR
  12731   "RTN","RCD PELAR",122 ,0)
  12732    Q:$D(DTOU T)!$D(DUOU T)!(Y="")  0
  12733   "RTN","RCD PELAR",123 ,0)
  12734    S START=Y
  12735   "RTN","RCD PELAR",124 ,0)
  12736   ENDDT ; Pr ompt for e nd date
  12737   "RTN","RCD PELAR",125 ,0)
  12738    K DIR
  12739   "RTN","RCD PELAR",126 ,0)
  12740    S DIR("B" )=Y(0)
  12741   "RTN","RCD PELAR",127 ,0)
  12742    S DIR(0)= "DAO^"_STA RT_":"_DT_ ":APE"
  12743   "RTN","RCD PELAR",128 ,0)
  12744    S DIR("A" )="End Dat e: "
  12745   "RTN","RCD PELAR",129 ,0)
  12746    S XX="Ent er the lat est "_$S(W HICH=0:"Au to-Post da te",1:"ERA  Date Rece ived")
  12747   "RTN","RCD PELAR",130 ,0)
  12748    S XX=XX_"  for recei pts to inc lude on th e report"
  12749   "RTN","RCD PELAR",131 ,0)
  12750    S DIR("?" )=XX
  12751   "RTN","RCD PELAR",132 ,0)
  12752    D ^DIR
  12753   "RTN","RCD PELAR",133 ,0)
  12754    Q:$D(DTOU T)!$D(DUOU T)!(Y="")  0
  12755   "RTN","RCD PELAR",134 ,0)
  12756    I Y<START  D  G ENDD T
  12757   "RTN","RCD PELAR",135 ,0)
  12758    . S XX=$$ FMTE^XLFDT (START,"2Z D") ;****
  12759   "RTN","RCD PELAR",136 ,0)
  12760    . W !,*7, "Enter an  End date t hat is not  less than  "_XX
  12761   "RTN","RCD PELAR",137 ,0)
  12762    S RANGE=S TART_"|"_Y
  12763   "RTN","RCD PELAR",138 ,0)
  12764    Q RANGE
  12765   "RTN","RCD PELAR",139 ,0)
  12766    ;
  12767   "RTN","RCD PELAR",140 ,0)
  12768   SELERA() ;  Ask the u ser which  types of E RA the wan t to see o n the repo rt
  12769   "RTN","RCD PELAR",141 ,0)
  12770    ; Input:    None
  12771   "RTN","RCD PELAR",142 ,0)
  12772    ; Returns : 0        - User up- arrowed or  timed out
  12773   "RTN","RCD PELAR",143 ,0)
  12774    ;           1        - Posted/C ompleted R eceipts
  12775   "RTN","RCD PELAR",144 ,0)
  12776    ;           2        - Only ERA s with Mis sing Recei pts
  12777   "RTN","RCD PELAR",145 ,0)
  12778    ;           3        - Both Pos ted/Comple ted and Mi ssing Rece ipts
  12779   "RTN","RCD PELAR",146 ,0)
  12780    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  12781   "RTN","RCD PELAR",147 ,0)
  12782    S DIR("A" )="Select  ERAs to be  Displayed : "
  12783   "RTN","RCD PELAR",148 ,0)
  12784    S DIR(0)= "SA^1:Post ed/Complet ed Receipt s;2:Missin g Receipts ;3:Both"
  12785   "RTN","RCD PELAR",149 ,0)
  12786    S DIR("B" )="Both"
  12787   "RTN","RCD PELAR",150 ,0)
  12788    S DIR("?" ,1)="Enter  1 to only  display P osted Rece ipts."
  12789   "RTN","RCD PELAR",151 ,0)
  12790    S DIR("?" ,2)="Enter  2 to only  display E RAs with m issing rec eipts."
  12791   "RTN","RCD PELAR",152 ,0)
  12792    S DIR("?" )="Enter 3  to displa y all rece ipts."
  12793   "RTN","RCD PELAR",153 ,0)
  12794    D ^DIR
  12795   "RTN","RCD PELAR",154 ,0)
  12796    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q 0
  12797   "RTN","RCD PELAR",155 ,0)
  12798    Q Y
  12799   "RTN","RCD PELAR",156 ,0)
  12800    ;
  12801   "RTN","RCD PELAR",157 ,0)
  12802   RPTSORT(WH ICH,ERASEL ) ; Ask th e user how  they want  to sort t he data
  12803   "RTN","RCD PELAR",158 ,0)
  12804    ; Input:    WHICH    - 1- Filte ring by Au to-Post Da te
  12805   "RTN","RCD PELAR",159 ,0)
  12806    ;                      2 - Filt ering by E RA Date Re ceived 
  12807   "RTN","RCD PELAR",160 ,0)
  12808    ;           ERASEL   - ERA Filt er           
  12809   "RTN","RCD PELAR",161 ,0)
  12810    ;                      1 - Post ed/Complet ed Receipt s
  12811   "RTN","RCD PELAR",162 ,0)
  12812    ;                      2 - Only  ERAs with  Missing R eceipts
  12813   "RTN","RCD PELAR",163 ,0)
  12814    ;                      3 - Both  Posted/Co mpleted an d Missing  Receipts
  12815   "RTN","RCD PELAR",164 ,0)
  12816    ; Returns : 0        - User up- arrowed or  timed out
  12817   "RTN","RCD PELAR",165 ,0)
  12818    ;           1        - Auto-Pos t Date sor t
  12819   "RTN","RCD PELAR",166 ,0)
  12820    ;           2        - Missing  Receipts
  12821   "RTN","RCD PELAR",167 ,0)
  12822    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,XX,Y
  12823   "RTN","RCD PELAR",168 ,0)
  12824    ;
  12825   "RTN","RCD PELAR",169 ,0)
  12826    ; If the  user is on ly showing  Posted/Co mpleted Re ceipts OR 
  12827   "RTN","RCD PELAR",170 ,0)
  12828    ; Missing  Receipts  then the o nly possib le sort va lue is by  date
  12829   "RTN","RCD PELAR",171 ,0)
  12830    I ERASEL' =3 Q 1
  12831   "RTN","RCD PELAR",172 ,0)
  12832    S DIR("A" )="Sort by  (D)ate or  (M)issing  Receipts:  "
  12833   "RTN","RCD PELAR",173 ,0)
  12834    S DIR(0)= "SA^D:Date ;M:Missing  Receipts"
  12835   "RTN","RCD PELAR",174 ,0)
  12836    S DIR("B" )="D"
  12837   "RTN","RCD PELAR",175 ,0)
  12838    S XX=$S(W HICH=1:"Au to-Post da te.",1:"ER A Date Rec eived.")
  12839   "RTN","RCD PELAR",176 ,0)
  12840    S DIR("?" ,1)="Enter  'D' to so rt by "_XX
  12841   "RTN","RCD PELAR",177 ,0)
  12842    S DIR("?" )="Enter ' M' to disp lay Missin g Receipts  first."
  12843   "RTN","RCD PELAR",178 ,0)
  12844    D ^DIR
  12845   "RTN","RCD PELAR",179 ,0)
  12846    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q 0
  12847   "RTN","RCD PELAR",180 ,0)
  12848    S XX=$S(Y ="D":1,Y=" P":2,1:3)
  12849   "RTN","RCD PELAR",181 ,0)
  12850    Q XX
  12851   "RTN","RCD PELAR",182 ,0)
  12852    ;
  12853   "RTN","RCD PELAR",183 ,0)
  12854   EXCEL() ;  Ask the us er if they  want to e xport to E xcel
  12855   "RTN","RCD PELAR",184 ,0)
  12856    ; Input:    None
  12857   "RTN","RCD PELAR",185 ,0)
  12858    ; Returns : -1       - User up- arrowed or  timed out
  12859   "RTN","RCD PELAR",186 ,0)
  12860    ;            0       - Output t o paper
  12861   "RTN","RCD PELAR",187 ,0)
  12862    ;            1       - Output t o Excel
  12863   "RTN","RCD PELAR",188 ,0)
  12864    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  12865   "RTN","RCD PELAR",189 ,0)
  12866    S DIR(0)= "Y"
  12867   "RTN","RCD PELAR",190 ,0)
  12868    S DIR("A" )="Export  the report  to Micros oft Excel"
  12869   "RTN","RCD PELAR",191 ,0)
  12870    S DIR("B" )="NO"
  12871   "RTN","RCD PELAR",192 ,0)
  12872    S DIR("?" )="Enter ' YES' to ou tput to Ex cel. Other wise enter  'NO'"
  12873   "RTN","RCD PELAR",193 ,0)
  12874    D ^DIR
  12875   "RTN","RCD PELAR",194 ,0)
  12876    I $G(DUOU T) Q -1
  12877   "RTN","RCD PELAR",195 ,0)
  12878    Q Y
  12879   "RTN","RCD PELAR",196 ,0)
  12880    ;
  12881   "RTN","RCD PELAR",197 ,0)
  12882   DEVICE(EXC EL,IO) ; S elect the  output dev ice
  12883   "RTN","RCD PELAR",198 ,0)
  12884    ; Input:    EXCEL    - 1 - Oupu t to Excel , 0 otherw ise
  12885   "RTN","RCD PELAR",199 ,0)
  12886    ; Output:   %ZIS     - Selected  device
  12887   "RTN","RCD PELAR",200 ,0)
  12888    ;           IO       - Array of  selected  output inf o
  12889   "RTN","RCD PELAR",201 ,0)
  12890    ; Returns : 0        - No devic e selected , 1 otherw ise
  12891   "RTN","RCD PELAR",202 ,0)
  12892    N POP,RCP YRSEL,%ZIS
  12893   "RTN","RCD PELAR",203 ,0)
  12894    S %ZIS="Q M"
  12895   "RTN","RCD PELAR",204 ,0)
  12896    D ^%ZIS
  12897   "RTN","RCD PELAR",205 ,0)
  12898    Q:POP 0
  12899   "RTN","RCD PELAR",206 ,0)
  12900    Q:EXCEL 1                    ;  Output to  Excel, no  queueing
  12901   "RTN","RCD PELAR",207 ,0)
  12902    ;
  12903   "RTN","RCD PELAR",208 ,0)
  12904    Q 1
  12905   "RTN","RCD PELAR",209 ,0)
  12906    ;
  12907   "RTN","RCD PELAR",210 ,0)
  12908   REPORT(INP UT,RCVAUTD ,IO,JOB) ;  Compile a nd run the  report
  12909   "RTN","RCD PELAR",211 ,0)
  12910    ; Expects  ZTQUEUED  to be defi ned alread y if queue d
  12911   "RTN","RCD PELAR",212 ,0)
  12912    ; Input:    INPUT    - A1^A2^A3 ^...^An Wh ere:
  12913   "RTN","RCD PELAR",213 ,0)
  12914    ;                         A1 -  1 - All di visions se lected
  12915   "RTN","RCD PELAR",214 ,0)
  12916    ;                               2 - Select ed divisio ns
  12917   "RTN","RCD PELAR",215 ,0)
  12918    ;                         A2 -  1 - Filter  by Auto-P ost date r ange
  12919   "RTN","RCD PELAR",216 ,0)
  12920    ;                               2 - Filter  by ERA Da te Receive d date ran ge
  12921   "RTN","RCD PELAR",217 ,0)
  12922    ;                         A3 -  B1|B2   -  Where:
  12923   "RTN","RCD PELAR",218 ,0)
  12924    ;                                B1 - ERA  Date Recei ved Start  Date if A2 =2
  12925   "RTN","RCD PELAR",219 ,0)
  12926    ;                                     Auto -Post Star t Date of  A2=1
  12927   "RTN","RCD PELAR",220 ,0)
  12928    ;                                B2 - ERA  Date Recei ved End Da te if A2=2
  12929   "RTN","RCD PELAR",221 ,0)
  12930    ;                                     Auto -Post End  Date of A2 =1
  12931   "RTN","RCD PELAR",222 ,0)
  12932    ;                         A4 -  1 - Posted /Completed  Receipts
  12933   "RTN","RCD PELAR",223 ,0)
  12934    ;                               2 - Only E RAs with M issing Rec eipts
  12935   "RTN","RCD PELAR",224 ,0)
  12936    ;                               3 - Both P osted/Comp leted and  Missing Re ceipts
  12937   "RTN","RCD PELAR",225 ,0)
  12938    ;                         A5 -  1 - All in surance co mpanies se lected
  12939   "RTN","RCD PELAR",226 ,0)
  12940    ;                               2 - Select ed insuran ce compani es chosen
  12941   "RTN","RCD PELAR",227 ,0)
  12942    ;                         A6 -  1 - Auto-P ost Date/E RA Date Re ceived Sor t
  12943   "RTN","RCD PELAR",228 ,0)
  12944    ;                               2 - Payer  sort
  12945   "RTN","RCD PELAR",229 ,0)
  12946    ;                               3 - Missin g Receipts
  12947   "RTN","RCD PELAR",230 ,0)
  12948    ;                         A7 -  0 - Do not  display i n a listma n template
  12949   "RTN","RCD PELAR",231 ,0)
  12950    ;                               1 - Displa y in a lis tman templ ate
  12951   "RTN","RCD PELAR",232 ,0)
  12952    ;                         A8 -  0 - Output  to paper
  12953   "RTN","RCD PELAR",233 ,0)
  12954    ;                               1 - Output  to Excel
  12955   "RTN","RCD PELAR",234 ,0)
  12956    ;                         A9 -  Line count er for Lis tman outpu t  
  12957   "RTN","RCD PELAR",235 ,0)
  12958    ;            RCVAUTD  -  Array  of selecte d Division s
  12959   "RTN","RCD PELAR",236 ,0)
  12960    ;                        Only p assed if A 1=2
  12961   "RTN","RCD PELAR",237 ,0)
  12962    ;            IO       - Interfa ce device
  12963   "RTN","RCD PELAR",238 ,0)
  12964    ;            JOB      - $J (opt ional, onl y passed i n when rep ort is que ued)
  12965   "RTN","RCD PELAR",239 ,0)
  12966    ;            ^TMP("R CSELPAY",$ J)- Global  Array of  selected i nsurance c ompanies
  12967   "RTN","RCD PELAR",240 ,0)
  12968    ; Output:    ^TMP("R CDPE_LAR", $J,CTR)=Li ne - Array  of displa y lines (n o headers)
  12969   "RTN","RCD PELAR",241 ,0)
  12970    ;                                               for o utput to L istman
  12971   "RTN","RCD PELAR",242 ,0)
  12972    ;                                               Only  set when A 7-1
  12973   "RTN","RCD PELAR",243 ,0)
  12974    N CURDT,D IVFLT,DTEN D,DTSTART, ERAFILT,WH ICH,XX,SOR T,STOP
  12975   "RTN","RCD PELAR",244 ,0)
  12976    K ^TMP("R CDPE_LAR", $J),^TMP($ J,"RCDPE_L AR")
  12977   "RTN","RCD PELAR",245 ,0)
  12978    I '$G(JOB ) S JOB=""
  12979   "RTN","RCD PELAR",246 ,0)
  12980    U IO
  12981   "RTN","RCD PELAR",247 ,0)
  12982    D PAYERS( JOB)                                 ; Rear range paye r global f or easier  use
  12983   "RTN","RCD PELAR",248 ,0)
  12984    S DIVFLT= $P(INPUT," ^",1)                     ; Divi sion filte r
  12985   "RTN","RCD PELAR",249 ,0)
  12986    S WHICH=$ P(INPUT,"^ ",2)                      ; 1 -  Auto-Post  date, 2 -  ERA Date R eceived
  12987   "RTN","RCD PELAR",250 ,0)
  12988    S SORT=$P (INPUT,"^" ,6)                       ; Type  of second ary sort
  12989   "RTN","RCD PELAR",251 ,0)
  12990    S DTEND=$ P($P(INPUT ,"^",3),"| ",2)_".999 9"  ; End  of Date Ra nge
  12991   "RTN","RCD PELAR",252 ,0)
  12992    S DTSTART =$P($P(INP UT,"^",3), "|",1)         ; End  of Date Ra nge
  12993   "RTN","RCD PELAR",253 ,0)
  12994    S ERAFILT =$P(INPUT, "^",4)                    ; ERA  Filter
  12995   "RTN","RCD PELAR",254 ,0)
  12996    ;
  12997   "RTN","RCD PELAR",255 ,0)
  12998    ; First f ilter and  sort the r eport
  12999   "RTN","RCD PELAR",256 ,0)
  13000    S CURDT=( DTSTART-1) _.9999                    ;PRCA* 4.5*321 Ad ded '_.999 9'
  13001   "RTN","RCD PELAR",257 ,0)
  13002    F  D  Q:' CURDT  Q:C URDT>(DTEN D)
  13003   "RTN","RCD PELAR",258 ,0)
  13004    . S:WHICH =1 CURDT=$ O(^RCY(344 .4,"F",CUR DT))
  13005   "RTN","RCD PELAR",259 ,0)
  13006    . S:WHICH =2 CURDT=$ O(^RCY(344 .4,"AFD",C URDT))
  13007   "RTN","RCD PELAR",260 ,0)
  13008    . Q:'CURD T
  13009   "RTN","RCD PELAR",261 ,0)
  13010    . Q:CURDT >(DTEND)
  13011   "RTN","RCD PELAR",262 ,0)
  13012    . I WHICH =2 D RPTE( DIVFLT,CUR DT,SORT,ER AFILT,.RCV AUTD) Q
  13013   "RTN","RCD PELAR",263 ,0)
  13014    . D RPTA( DIVFLT,CUR DT,SORT,ER AFILT,.RCV AUTD)
  13015   "RTN","RCD PELAR",264 ,0)
  13016    ;
  13017   "RTN","RCD PELAR",265 ,0)
  13018    D RPTOUT^ RCDPELA1(I NPUT)                  ; Output  the report
  13019   "RTN","RCD PELAR",266 ,0)
  13020    ;
  13021   "RTN","RCD PELAR",267 ,0)
  13022    ; Quit if  Listman -  clean up  of ^TMP &  device is  handled in  LMOUT^RCD PELAR
  13023   "RTN","RCD PELAR",268 ,0)
  13024    I $P(INPU T,"^",7)=1  Q
  13025   "RTN","RCD PELAR",269 ,0)
  13026    ;
  13027   "RTN","RCD PELAR",270 ,0)
  13028    ; Close d evice
  13029   "RTN","RCD PELAR",271 ,0)
  13030    I '$D(ZTQ UEUED) D ^ %ZISC
  13031   "RTN","RCD PELAR",272 ,0)
  13032    I $D(ZTQU EUED) S ZT REQ="@"
  13033   "RTN","RCD PELAR",273 ,0)
  13034    K ^TMP("R CDPE_LAR", $J),^TMP($ J,"RCDPE_L AR")
  13035   "RTN","RCD PELAR",274 ,0)
  13036    K ^TMP("R CSELPAY",$ J),^TMP($J ,"SELPAYER ")
  13037   "RTN","RCD PELAR",275 ,0)
  13038    K ZTQUEUE D
  13039   "RTN","RCD PELAR",276 ,0)
  13040    Q
  13041   "RTN","RCD PELAR",277 ,0)
  13042    ;
  13043   "RTN","RCD PELAR",278 ,0)
  13044   PAYERS(JOB ) ; Rearra nge payer  global for  easier us e
  13045   "RTN","RCD PELAR",279 ,0)
  13046    ; Input:    ^TMP("RC SELPAY",$J ,nn)=Payer  Name - Gl obal Array  of select ed
  13047   "RTN","RCD PELAR",280 ,0)
  13048    ;                                                  in surance co mpanies
  13049   "RTN","RCD PELAR",281 ,0)
  13050    ; Output    ^TMP($J, "SELPAYER" ,Payer Nam e)="" - Gl obal Array  of select ed
  13051   "RTN","RCD PELAR",282 ,0)
  13052    ;                                       in surance re arranged f or easier  checks
  13053   "RTN","RCD PELAR",283 ,0)
  13054    I JOB=""  S JOB=$J
  13055   "RTN","RCD PELAR",284 ,0)
  13056    N PAYER,X X
  13057   "RTN","RCD PELAR",285 ,0)
  13058    K ^TMP($J ,"SELPAYER ")
  13059   "RTN","RCD PELAR",286 ,0)
  13060    S XX=""
  13061   "RTN","RCD PELAR",287 ,0)
  13062    F  D  Q:X X=""
  13063   "RTN","RCD PELAR",288 ,0)
  13064    . S XX=$O (^TMP("RCS ELPAY",JOB ,XX))
  13065   "RTN","RCD PELAR",289 ,0)
  13066    . Q:XX=""
  13067   "RTN","RCD PELAR",290 ,0)
  13068    . S PAYER =$$UP^XLFS TR(^TMP("R CSELPAY",J OB,XX))
  13069   "RTN","RCD PELAR",291 ,0)
  13070    . S ^TMP( $J,"SELPAY ER",PAYER) =""
  13071   "RTN","RCD PELAR",292 ,0)
  13072    K ^TMP("R CSELPAY",J OB)
  13073   "RTN","RCD PELAR",293 ,0)
  13074    Q
  13075   "RTN","RCD PELAR",294 ,0)
  13076    ;
  13077   "RTN","RCD PELAR",295 ,0)
  13078   RPTE(DIVFL T,CURDT,SO RT,ERAFILT ,VAUTD) ;  Use the ER A Date Rec eived inde x and filt er out
  13079   "RTN","RCD PELAR",296 ,0)
  13080    ; divisio ns, payers  that were n't select ed
  13081   "RTN","RCD PELAR",297 ,0)
  13082    ; Input:    DIVFLT                - 1 - Al l Division s selected , 2 otherw ise
  13083   "RTN","RCD PELAR",298 ,0)
  13084    ;           CURDT                 - Date b eing proce ssed
  13085   "RTN","RCD PELAR",299 ,0)
  13086    ;           SORT                  - 1 - Au to-Post Da te Sort
  13087   "RTN","RCD PELAR",300 ,0)
  13088    ;                                   2 - Mi ssing Rece ipts
  13089   "RTN","RCD PELAR",301 ,0)
  13090    ;           ERAFILT               - 1 - Po sted/Compl eted Recei pts
  13091   "RTN","RCD PELAR",302 ,0)
  13092    ;                                   2 - On ly ERAs wi th Missing  Receipts
  13093   "RTN","RCD PELAR",303 ,0)
  13094    ;                                   3 - Bo th Posted/ Completed  and Missin g Receipts
  13095   "RTN","RCD PELAR",304 ,0)
  13096    ;           VAUTD                 - Array  of selecte d division s
  13097   "RTN","RCD PELAR",305 ,0)
  13098    ;          ^TMP("RCS ELPAY",$J)   - Global  Array of  selected i nsurance c ompanies
  13099   "RTN","RCD PELAR",306 ,0)
  13100    ; Output:  ^TMP($J,A 1,"SEL",A2 ,A3,A4,A5) ="" - if r ecord pass ed filters  Where:
  13101   "RTN","RCD PELAR",307 ,0)
  13102    ;                                    A1 -  "RCDPE_LAR "
  13103   "RTN","RCD PELAR",308 ,0)
  13104    ;                                    A2 -  Uppercased  Payer Nam e (primary  sort)
  13105   "RTN","RCD PELAR",309 ,0)
  13106    ;                                    A3 -  Secondary  Sort Value
  13107   "RTN","RCD PELAR",310 ,0)
  13108    ;                                    A4 -  Internal I EN for fil e 344.4
  13109   "RTN","RCD PELAR",311 ,0)
  13110    ;                                    A5 -  Internal I EN for sub  file 344. 41
  13111   "RTN","RCD PELAR",312 ,0)
  13112    N COMPLET E,IEN3444, IEN34441,I ENS,PAYER, RECEIPT,SV AL,XX
  13113   "RTN","RCD PELAR",313 ,0)
  13114    S IEN3444 =0
  13115   "RTN","RCD PELAR",314 ,0)
  13116    F  D  Q:' IEN3444
  13117   "RTN","RCD PELAR",315 ,0)
  13118    . S IEN34 44=$O(^RCY (344.4,"AF D",CURDT,I EN3444))
  13119   "RTN","RCD PELAR",316 ,0)
  13120    . Q:'IEN3 444
  13121   "RTN","RCD PELAR",317 ,0)
  13122    . S PAYER =$$GET1^DI Q(344.4,IE N3444,.06, "I")             ; Pa yment From  field
  13123   "RTN","RCD PELAR",318 ,0)
  13124    . S PAYER =$$UP^XLFS TR(PAYER)
  13125   "RTN","RCD PELAR",319 ,0)
  13126    . Q:'$D(^ TMP($J,"SE LPAYER",PA YER))                       ; No t a select ed payer
  13127   "RTN","RCD PELAR",320 ,0)
  13128    . I DIVFL T'=1 Q:'$$ CHKDIV^RCD PEDAR(IEN3 444,1,.VAU TD)   ; No t a select ed Divisio n
  13129   "RTN","RCD PELAR",321 ,0)
  13130    . S XX=$$ GET1^DIQ(3 44.4,IEN34 44,4.01,"I ")               ; Au to-Post da te on ERA
  13131   "RTN","RCD PELAR",322 ,0)
  13132    . Q:'XX                                                     ; sk ip if not  auto-poste d ERA
  13133   "RTN","RCD PELAR",323 ,0)
  13134    . S COMPL ETE=$$COMP LETE(IEN34 44)                         ; Ch eck for mi ssing rece ipts
  13135   "RTN","RCD PELAR",324 ,0)
  13136    . I ERAFI LT=1,'COMP LETE Q                                 ; Mi ssing Rece ipt
  13137   "RTN","RCD PELAR",325 ,0)
  13138    . I ERAFI LT=2,COMPL ETE Q                                  ; No t a Missin g Receipt
  13139   "RTN","RCD PELAR",326 ,0)
  13140    . ;
  13141   "RTN","RCD PELAR",327 ,0)
  13142    . ; Just  showing mi ssing rece ipts and t his ERA do esn't have  any
  13143   "RTN","RCD PELAR",328 ,0)
  13144    . I ERAFI LT=2,COMPL ETE Q
  13145   "RTN","RCD PELAR",329 ,0)
  13146    . S IEN34 441=0
  13147   "RTN","RCD PELAR",330 ,0)
  13148    . F  D  Q :'IEN34441
  13149   "RTN","RCD PELAR",331 ,0)
  13150    . . S IEN 34441=$O(^ RCY(344.4, IEN3444,1, IEN34441))
  13151   "RTN","RCD PELAR",332 ,0)
  13152    . . Q:'IE N34441
  13153   "RTN","RCD PELAR",333 ,0)
  13154    . . S IEN S=IEN34441 _","_IEN34 44_","
  13155   "RTN","RCD PELAR",334 ,0)
  13156    . . S SVA L=$S(SORT= 1:CURDT,1: COMPLETE)                   ; Ge t the sort  value
  13157   "RTN","RCD PELAR",335 ,0)
  13158    . . S ^TM P($J,"RCDP E_LAR","SE L",PAYER,S VAL,IEN344 4,IEN34441 )=""
  13159   "RTN","RCD PELAR",336 ,0)
  13160    Q
  13161   "RTN","RCD PELAR",337 ,0)
  13162    ;
  13163   "RTN","RCD PELAR",338 ,0)
  13164   RPTA(DIVFL T,CURDT,SO RT,ERAFILT ,VAUTD) ;  Use the Au to-Post Da te index a nd filter  out
  13165   "RTN","RCD PELAR",339 ,0)
  13166    ; divisio ns, payers  that were n't select ed
  13167   "RTN","RCD PELAR",340 ,0)
  13168    ; Input:    DIVFLT                - 1 - Al l Division s selected , 2 otherw ise
  13169   "RTN","RCD PELAR",341 ,0)
  13170    ;           CURDT                 - Date b eing proce ssed
  13171   "RTN","RCD PELAR",342 ,0)
  13172    ;           SORT                  - 1 - Au to-Post Da te Sort
  13173   "RTN","RCD PELAR",343 ,0)
  13174    ;                                   2 - Mi ssing Rece ipts
  13175   "RTN","RCD PELAR",344 ,0)
  13176    ;           ERAFILT               - 1 - Po sted/Compl eted Recei pts
  13177   "RTN","RCD PELAR",345 ,0)
  13178    ;                                   2 - On ly ERAs wi th Missing  Receipts
  13179   "RTN","RCD PELAR",346 ,0)
  13180    ;                                   3 - Bo th Posted/ Completed  and Missin g Receipts
  13181   "RTN","RCD PELAR",347 ,0)
  13182    ;           VAUTD                 - Array  of selecte d division s
  13183   "RTN","RCD PELAR",348 ,0)
  13184    ;          ^TMP("RCS ELPAY",$J)   - Global  Array of  selected i nsurance c ompanies
  13185   "RTN","RCD PELAR",349 ,0)
  13186    ;          ^TMP($J," RCDPE_LAR" ,"ERA") -  see output  for defin ition
  13187   "RTN","RCD PELAR",350 ,0)
  13188    ; Output:  ^TMP($J,A 1,"SEL",A2 ,A3,A4,A5) ="" - if r ecord pass ed filters  Where:
  13189   "RTN","RCD PELAR",351 ,0)
  13190    ;                                    A1 -  "RCDPE_LAR "
  13191   "RTN","RCD PELAR",352 ,0)
  13192    ;                                    A2 -  Uppercased  Payer Nam e (primary  sort)
  13193   "RTN","RCD PELAR",353 ,0)
  13194    ;                                    A3 -  Secondary  Sort Value
  13195   "RTN","RCD PELAR",354 ,0)
  13196    ;                                    A4 -  Internal I EN for fil e 344.4
  13197   "RTN","RCD PELAR",355 ,0)
  13198    ;                                    A5 -  Internal I EN for sub  file 344. 41
  13199   "RTN","RCD PELAR",356 ,0)
  13200    ;         ^TMP($J,A1 ,"ERA",A2) ="" - List  of ERAs t hat were a lready pul led Where:
  13201   "RTN","RCD PELAR",357 ,0)
  13202    ;                                    A1 -  "RCDPE_LAR "
  13203   "RTN","RCD PELAR",358 ,0)
  13204    ;                                    A2 -  IEN of #34 4.4 (ERA # )
  13205   "RTN","RCD PELAR",359 ,0)
  13206    ;
  13207   "RTN","RCD PELAR",360 ,0)
  13208    N COMPLET E,IEN3444, IEN3441,PA YER,SVAL
  13209   "RTN","RCD PELAR",361 ,0)
  13210    S IEN3444 =0
  13211   "RTN","RCD PELAR",362 ,0)
  13212    F  D  Q:' IEN3444
  13213   "RTN","RCD PELAR",363 ,0)
  13214    . S IEN34 44=$O(^RCY (344.4,"F" ,CURDT,IEN 3444))
  13215   "RTN","RCD PELAR",364 ,0)
  13216    . Q:'IEN3 444
  13217   "RTN","RCD PELAR",365 ,0)
  13218    . I DIVFL T'=1 Q:'$$ CHKDIV^RCD PEDAR(IEN3 444,1,.VAU TD)  ; Not  a selecte d Division
  13219   "RTN","RCD PELAR",366 ,0)
  13220    . S COMPL ETE=$$COMP LETE(IEN34 44)
  13221   "RTN","RCD PELAR",367 ,0)
  13222    . I ERAFI LT=1,'COMP LETE Q                                ; Mis sing Recei pt
  13223   "RTN","RCD PELAR",368 ,0)
  13224    . I ERAFI LT=2,COMPL ETE Q                                 ; Not  a Missing  Receipt
  13225   "RTN","RCD PELAR",369 ,0)
  13226    . S PAYER =$$GET1^DI Q(344.4,IE N3444,.06, "I")            ; Pay ment From  field
  13227   "RTN","RCD PELAR",370 ,0)
  13228    . S PAYER =$$UP^XLFS TR(PAYER)
  13229   "RTN","RCD PELAR",371 ,0)
  13230    . Q:'$D(^ TMP($J,"SE LPAYER",PA YER))                      ; Not  a selecte d payer
  13231   "RTN","RCD PELAR",372 ,0)
  13232    . Q:$D(^T MP($J,"RCD PE_LAR","E RA",IEN344 4))             ; Alr eady pulle d this ERA
  13233   "RTN","RCD PELAR",373 ,0)
  13234    . ;
  13235   "RTN","RCD PELAR",374 ,0)
  13236    . S ^TMP( $J,"RCDPE_ LAR","ERA" ,IEN3444)= ""
  13237   "RTN","RCD PELAR",375 ,0)
  13238    . S IEN34 441=0
  13239   "RTN","RCD PELAR",376 ,0)
  13240    . F  D  Q :'IEN34441
  13241   "RTN","RCD PELAR",377 ,0)
  13242    . . S IEN 34441=$O(^ RCY(344.4, IEN3444,1, IEN34441))
  13243   "RTN","RCD PELAR",378 ,0)
  13244    . . Q:'IE N34441
  13245   "RTN","RCD PELAR",379 ,0)
  13246    . . S SVA L=$S(SORT= 1:CURDT,1: COMPLETE)                  ; Get  the sort  value
  13247   "RTN","RCD PELAR",380 ,0)
  13248    . . S ^TM P($J,"RCDP E_LAR","SE L",PAYER,S VAL,IEN344 4,IEN34441 )=""
  13249   "RTN","RCD PELAR",381 ,0)
  13250    Q
  13251   "RTN","RCD PELAR",382 ,0)
  13252    ;
  13253   "RTN","RCD PELAR",383 ,0)
  13254   COMPLETE(I EN3444) ;  Checks an  ERA for mi ssing rece ipts
  13255   "RTN","RCD PELAR",384 ,0)
  13256    ; Input:    IEN3444    - ERA to  be checke d
  13257   "RTN","RCD PELAR",385 ,0)
  13258    ; Returns : 0 if at  least one  detail lin e of the E RA has a m issing rec eipt
  13259   "RTN","RCD PELAR",386 ,0)
  13260    ;           1 otherw ise
  13261   "RTN","RCD PELAR",387 ,0)
  13262    N XX
  13263   "RTN","RCD PELAR",388 ,0)
  13264    S XX=$$GE T1^DIQ(344 .4,IEN3444 ,4.02,"I")     ; Auto -Post Stat us field
  13265   "RTN","RCD PELAR",389 ,0)
  13266    I XX=2 Q  1                                    ; Comp lete ERA
  13267   "RTN","RCD PELAR",390 ,0)
  13268    Q 0
  13269   "RTN","RCD PELAR",391 ,0)
  13270    ;
  13271   "RTN","RCD PELAR",392 ,0)
  13272   ASKSTOP()  ; Ask to c ontinue
  13273   "RTN","RCD PELAR",393 ,0)
  13274    ; Input:    IOST     - Device T ype 
  13275   "RTN","RCD PELAR",394 ,0)
  13276    ; Returns : 1 - User  wants to  quit, 0 ot herwise
  13277   "RTN","RCD PELAR",395 ,0)
  13278    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T
  13279   "RTN","RCD PELAR",396 ,0)
  13280    Q:$E(IOST ,1,2)'["C- " 0                       ; Not  a terminal
  13281   "RTN","RCD PELAR",397 ,0)
  13282    S DIR(0)= "E"
  13283   "RTN","RCD PELAR",398 ,0)
  13284    W ! D ^DI R
  13285   "RTN","RCD PELAR",399 ,0)
  13286    I ($D(DIR UT))!($D(D UOUT)) Q 1
  13287   "RTN","RCD PELAR",400 ,0)
  13288    Q 0
  13289   "RTN","RCD PELAR",401 ,0)
  13290    ;
  13291   "RTN","RCD PEM")
  13292   0^17^B7483 8117
  13293   "RTN","RCD PEM",1,0)
  13294   RCDPEM ;AL B/TMK/PJH  - POST EFT , ERA MATC HING TO EF T ;Jun 06,  2014@19:1 1:19
  13295   "RTN","RCD PEM",2,0)
  13296    ;;4.5;Acc ounts Rece ivable;**1 73,255,269 ,276,283,2 98,304,318 ,321**;Mar  20, 1995; Build 46
  13297   "RTN","RCD PEM",3,0)
  13298    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  13299   "RTN","RCD PEM",4,0)
  13300    ; IA 4050  covers ca ll to SPL1 ^IBCEOBAR
  13301   "RTN","RCD PEM",5,0)
  13302    ; Note -  keep proce ssing in l ine with R CDPXPAP
  13303   "RTN","RCD PEM",6,0)
  13304    ;
  13305   "RTN","RCD PEM",7,0)
  13306   EN ; Post  EFT deposi ts, auto-m atch EFT's  and ERA's  
  13307   "RTN","RCD PEM",8,0)
  13308    ;
  13309   "RTN","RCD PEM",9,0)
  13310    K ^TMP($J ,"RCDPETOT "),^TMP("R CDPEAP",$J )
  13311   "RTN","RCD PEM",10,0)
  13312    ; ^TMP($J ,"RCDPETOT ",344.3 or  344.31,fi le ien)=
  13313   "RTN","RCD PEM",11,0)
  13314    ;  (1) ma tch (0/1/- 1)   (2) t otal $   ( 3) posted  (0/1)  (4)  error ref
  13315   "RTN","RCD PEM",12,0)
  13316    ;  (5) EF T deposit  ien 344.1  if added f or EFT
  13317   "RTN","RCD PEM",13,0)
  13318    ;
  13319   "RTN","RCD PEM",14,0)
  13320    N RCZ,RCS UM,RCDEP,R ECTDA,RC0, RCER,RCDUZ ,Z,Z0,Z1,D A,X,Y,DIE, DR
  13321   "RTN","RCD PEM",15,0)
  13322    M RCDUZ=D UZ
  13323   "RTN","RCD PEM",16,0)
  13324    N DUZ S D UZ=+$O(^VA (200,"B"," EDILOCKBOX ,AUTOMATIC ",0)),DUZ( 0)="" S:'D UZ DUZ=.5
  13325   "RTN","RCD PEM",17,0)
  13326    K ^TMP($J ,"RCXM"),^ TMP($J,"RC TOT")
  13327   "RTN","RCD PEM",18,0)
  13328    S ZTREQ=" @"
  13329   "RTN","RCD PEM",19,0)
  13330    L +^RCY(3 44.3,"ALOC K"):5 I '$ T D  G ENQ  ; Lock re cord
  13331   "RTN","RCD PEM",20,0)
  13332    . ; Send  bulletin t hat job co uld not be  run
  13333   "RTN","RCD PEM",21,0)
  13334    . S ^TMP( $J,"RCXM", 1)="The ni ghtly job  to post EF T deposits  and match  EFTs to E RAs could  not be run ",^TMP($J, "RCXM",2)= "Another m atch proce ss was alr eady runni ng (lock o n ^RCY(344 .3,""ALOCK "") )"
  13335   "RTN","RCD PEM",22,0)
  13336    . D SENDB ULL^RCDPEM 1
  13337   "RTN","RCD PEM",23,0)
  13338    ;
  13339   "RTN","RCD PEM",24,0)
  13340    ; Post de posits for  any unpos ted EFTs i n file 344 .3
  13341   "RTN","RCD PEM",25,0)
  13342    ; 'Unpost ed' EFTs h ave a 0 in  AMOUNT PO STED field
  13343   "RTN","RCD PEM",26,0)
  13344    S ^TMP($J ,"RCTOT"," EFT_DEP")= 0
  13345   "RTN","RCD PEM",27,0)
  13346    S RCZ=0 F   S RCZ=$O (^RCY(344. 3,"APOST", 0,RCZ)) Q: 'RCZ  S RC 0=$G(^RCY( 344.3,RCZ, 0))  I RC0 '="",$P(RC 0,U,8) D
  13347   "RTN","RCD PEM",28,0)
  13348    . S ^TMP( $J,"RCTOT" ,"EFT_DEP" )=^TMP($J, "RCTOT","E FT_DEP")+1
  13349   "RTN","RCD PEM",29,0)
  13350    . ; Verif y check su ms
  13351   "RTN","RCD PEM",30,0)
  13352    . S RCSUM =$$CHKSUM^ RCDPESR3(R CZ)
  13353   "RTN","RCD PEM",31,0)
  13354    . I RCSUM '=$P(RC0,U ,9) D  Q
  13355   "RTN","RCD PEM",32,0)
  13356    .. ; Bull etin that  check sums  do not ma tch
  13357   "RTN","RCD PEM",33,0)
  13358    .. ; Upda te record  error list  and check sum error  field
  13359   "RTN","RCD PEM",34,0)
  13360    .. S RCER (1)=$$SETE RR^RCDPEM0 (2)
  13361   "RTN","RCD PEM",35,0)
  13362    .. S RCER (2)="  Che cksum is i nvalid and  the EFT d eposit rec ord is cor rupted.",R CER(3)="   Stored Che cksum = "_ $P(RC0,U,9 )_" Calcul ated Check sum: "_RCS UM,RCER(4) ="  This E FT deposit  cannot be  sent to F MS.  You m ust ask fo r it to be "
  13363   "RTN","RCD PEM",36,0)
  13364    .. S RCER (5)="   re transmitte d to your  site."
  13365   "RTN","RCD PEM",37,0)
  13366    .. D BULL ^RCDPEM1(3 44.3,RC0,. RCER)
  13367   "RTN","RCD PEM",38,0)
  13368    .. S $P(^ TMP($J,"RC DPETOT",34 4.3,RCZ),U ,4)=+$G(^T MP($J,"RCX M",0))
  13369   "RTN","RCD PEM",39,0)
  13370    .. D STOR ERR^RCDPEM 0(RCZ,.RCE R)
  13371   "RTN","RCD PEM",40,0)
  13372    .. S DIE= "^RCY(344. 3,",DA=RCZ ,DR=".1/// /1" D ^DIE
  13373   "RTN","RCD PEM",41,0)
  13374    .. S ^TMP ($J,"RCTOT ","CSUM")= $G(^TMP($J ,"RCTOT"," CSUM"))+1
  13375   "RTN","RCD PEM",42,0)
  13376    . ;
  13377   "RTN","RCD PEM",43,0)
  13378    . S RCDEP =+$P(RC0,U ,3),RECTDA =+$O(^RCY( 344,"AD",R CDEP,0))
  13379   "RTN","RCD PEM",44,0)
  13380    . I RCDEP  D LOCKDEP (RCDEP,1)
  13381   "RTN","RCD PEM",45,0)
  13382    . I 'RCDE P!'RECTDA  D  ;  Add  deposit an d/or recei pt to file s 344.1, 3 44
  13383   "RTN","RCD PEM",46,0)
  13384    .. I 'RCD EP D  ; Ad d dep reco rd RCDEP,  update fie ld .03 wit h the poin ter
  13385   "RTN","RCD PEM",47,0)
  13386    ... S RCD EP=+$$ADDD EP^RCDPEM0 ($P(RC0,U, 6),$P(RC0, U,7),RCZ)
  13387   "RTN","RCD PEM",48,0)
  13388    ... S ^TM P($J,"RCTO T","DEPOSI T")=$G(^TM P($J,"RCTO T","DEPOSI T"))+1
  13389   "RTN","RCD PEM",49,0)
  13390    .. ;
  13391   "RTN","RCD PEM",50,0)
  13392    .. I 'REC TDA,RCDEP  D  ; Add r eceipt rec ord, post  to rev sou rce cd 8NZ Z
  13393   "RTN","RCD PEM",51,0)
  13394    ... S REC TDA=+$$ADD REC^RCDPEM 0(RCDEP,RC Z)
  13395   "RTN","RCD PEM",52,0)
  13396    .. ;
  13397   "RTN","RCD PEM",53,0)
  13398    . I RCDEP  D LOCKDEP (RCDEP,0)
  13399   "RTN","RCD PEM",54,0)
  13400    . ;
  13401   "RTN","RCD PEM",55,0)
  13402    . I 'RCDE P!'RECTDA  D  Q  ; Co uld not ad d entry to  file 344. 1 or 344 
  13403   "RTN","RCD PEM",56,0)
  13404    .. ; Send  a bulleti n, update  error text
  13405   "RTN","RCD PEM",57,0)
  13406    .. S RCER (1)=$$SETE RR^RCDPEM0 (2),RCER(2 )="  "_$S( 'RCDEP:"Ne ither a de posit nor  a receipt  were able" ,1:"A rece ipt was no t able")_"  to be add ed - no ma tch attemp ted"
  13407   "RTN","RCD PEM",58,0)
  13408    .. I RCDE P,'RECTDA  S RCER(3)= "  Deposit  Ticket #  created: " _$P($G(^RC Y(344.1,+$ P(RC0,U,3) ,0)),U)
  13409   "RTN","RCD PEM",59,0)
  13410    .. S RCER ($O(RCER(" "),-1)+1)= "This EFT  deposit ca n't be sen t to FMS.   You must  ask Austin  to retran smit"
  13411   "RTN","RCD PEM",60,0)
  13412    .. D BULL ^RCDPEM1(3 44.3,RC0,. RCER)
  13413   "RTN","RCD PEM",61,0)
  13414    .. S $P(^ TMP($J,"RC DPETOT",34 4.3,RCZ),U ,4)=+$G(^T MP($J,"RCX M",0))
  13415   "RTN","RCD PEM",62,0)
  13416    .. D STOR ERR^RCDPEM 0(RCZ,.RCE R)
  13417   "RTN","RCD PEM",63,0)
  13418    .. S ^TMP ($J,"RCTOT ","ERR")=$ G(^TMP($J, "RCTOT","E RR"))+1
  13419   "RTN","RCD PEM",64,0)
  13420    . ;
  13421   "RTN","RCD PEM",65,0)
  13422    . S DIE=" ^RCY(344.3 1," S Z=0  F  S Z=$O( ^RCY(344.3 1,"B",RCZ, Z)) Q:'Z   S DA=Z,DR= ".11////1"  D ^DIE
  13423   "RTN","RCD PEM",66,0)
  13424    ;
  13425   "RTN","RCD PEM",67,0)
  13426    ;Update p ayer table  for new p ayers - PR CA*4.5*298
  13427   "RTN","RCD PEM",68,0)
  13428    D NEWPYR^ RCDPESP
  13429   "RTN","RCD PEM",69,0)
  13430    ;Scan Non -Released  Rx Excepti ons for re leased Rx  - PRCA*4.5 *298
  13431   "RTN","RCD PEM",70,0)
  13432    D EN^RCDP EX4
  13433   "RTN","RCD PEM",71,0)
  13434    ;
  13435   "RTN","RCD PEM",72,0)
  13436    D MATCH(0 ,1)
  13437   "RTN","RCD PEM",73,0)
  13438    ;
  13439   "RTN","RCD PEM",74,0)
  13440    ;Auto Pos t - PRCA*4 .5*298
  13441   "RTN","RCD PEM",75,0)
  13442    D EN^RCDP EAP
  13443   "RTN","RCD PEM",76,0)
  13444    ;Auto Dec rease - PR CA*4.5*298
  13445   "RTN","RCD PEM",77,0)
  13446    D EN^RCDP EAD
  13447   "RTN","RCD PEM",78,0)
  13448    ;
  13449   "RTN","RCD PEM",79,0)
  13450    ;Workload  Notificat ions - PRC A*4.5*321
  13451   "RTN","RCD PEM",80,0)
  13452    D EN^RCDP EM7
  13453   "RTN","RCD PEM",81,0)
  13454    ;
  13455   "RTN","RCD PEM",82,0)
  13456    L -^RCY(3 44.3,"ALOC K")
  13457   "RTN","RCD PEM",83,0)
  13458   ENQ K ^TMP ($J,"RCDPE TOT"),^TMP ("RCDPEAP" ,$J)
  13459   "RTN","RCD PEM",84,0)
  13460    ;
  13461   "RTN","RCD PEM",85,0)
  13462    ;ePayment s 5010 par t II enhan cements
  13463   "RTN","RCD PEM",86,0)
  13464    ;Create B ulletins o f EEOB Mov ed or Copi ed today
  13465   "RTN","RCD PEM",87,0)
  13466    D EN^RCDP EM8
  13467   "RTN","RCD PEM",88,0)
  13468    Q
  13469   "RTN","RCD PEM",89,0)
  13470    ;
  13471   "RTN","RCD PEM",90,0)
  13472   MATCH(RCMA N,RCPROC)  ; match un matched EF Ts with ER As
  13473   "RTN","RCD PEM",91,0)
  13474    ; RCMAN =  1 if job  run manual ly, outsid e of night ly process ing
  13475   "RTN","RCD PEM",92,0)
  13476    ; RCPROC  = 1 if cal led from E FT-EOB aut omatch, 0  if from ma nual match
  13477   "RTN","RCD PEM",93,0)
  13478    ;
  13479   "RTN","RCD PEM",94,0)
  13480    N RC0,RCE R,RCZ,RCHA C
  13481   "RTN","RCD PEM",95,0)
  13482    I '$O(^RC Y(344.31," AMATCH",0, 0)) D  G M ATCHQ
  13483   "RTN","RCD PEM",96,0)
  13484    . ; Send  bulletin -  no unmatc hed EFTs f ound
  13485   "RTN","RCD PEM",97,0)
  13486    . N RCT
  13487   "RTN","RCD PEM",98,0)
  13488    . S RCT=+ $O(^TMP($J ,"RCXM","  "),-1)+1
  13489   "RTN","RCD PEM",99,0)
  13490    . S ^TMP( $J,"RCXM", RCT)=$S('$ G(RCMAN):" The nightl y job",1:" The manual  option")_ " to match  EFTs has  found no E FTs are cu rrently un matched on  your syst em"
  13491   "RTN","RCD PEM",100,0 )
  13492    . I $G(RC MAN) S ^TM P($J,"RCXM ",RCT+1)=" The action  was initi ated by "_ $P($G(^VA( 200,DUZ,0) ),U)
  13493   "RTN","RCD PEM",101,0 )
  13494    . D SENDB ULL^RCDPEM 1
  13495   "RTN","RCD PEM",102,0 )
  13496    ;
  13497   "RTN","RCD PEM",103,0 )
  13498    S RCZ=0 F   S RCZ=$O (^RCY(344. 31,"AMATCH ",0,RCZ))  Q:'RCZ  D
  13499   "RTN","RCD PEM",104,0 )
  13500    . K RCER
  13501   "RTN","RCD PEM",105,0 )
  13502    . S RC0=$ G(^RCY(344 .31,RCZ,0) ),RCHAC=($ E($P($G(^R CY(344.3,+ RC0,0)),U, 6),1,3)="H AC")
  13503   "RTN","RCD PEM",106,0 )
  13504    . Q:RC0=" "  ; Bad x ref
  13505   "RTN","RCD PEM",107,0 )
  13506    . Q:$S('R CHAC:'$P(R C0,U,11),1 :0)  ; EFT  deposit m ust have b een record ed
  13507   "RTN","RCD PEM",108,0 )
  13508    . S ^TMP( $J,"RCTOT" ,"EFT")=$G (^TMP($J," RCTOT","EF T"))+1
  13509   "RTN","RCD PEM",109,0 )
  13510    . I RCHAC  S ^TMP($J ,"RCTOT"," EFT_HAC")= $G(^TMP($J ,"RCTOT"," EFT_HAC")) +1
  13511   "RTN","RCD PEM",110,0 )
  13512    . S ^TMP( $J,"RCDPET OT",344.31 ,RCZ)=""
  13513   "RTN","RCD PEM",111,0 )
  13514    . ;
  13515   "RTN","RCD PEM",112,0 )
  13516    . D MATCH ^RCDPEM0(R CZ,RCPROC)
  13517   "RTN","RCD PEM",113,0 )
  13518    ;
  13519   "RTN","RCD PEM",114,0 )
  13520    I '$O(^TM P($J,"RCXM ",0)) K RC ER S RCER( 1)="",RCER (2)="NO EX CEPTIONS W HILE MATCH ING EFTs-E RAs OR IN  RECORDING  THE DEPOSI TS TO FMS"  D BULL^RC DPEM1(""," ",.RCER) K  RCER
  13521   "RTN","RCD PEM",115,0 )
  13522    D EN2^RCD PEM1,BULL^ RCDPEM1("" ,"",.RCER)
  13523   "RTN","RCD PEM",116,0 )
  13524    D SENDBUL L^RCDPEM1
  13525   "RTN","RCD PEM",117,0 )
  13526    ;
  13527   "RTN","RCD PEM",118,0 )
  13528   MATCHQ K ^ TMP($J,"RC DPETOT"),^ TMP($J,"RC TOT")
  13529   "RTN","RCD PEM",119,0 )
  13530    Q
  13531   "RTN","RCD PEM",120,0 )
  13532    ;
  13533   "RTN","RCD PEM",121,0 )
  13534   LOCKDEP(RC DEP,LOCK)  ; Lock/con firm depos it ien RCD EP file 34 1.1
  13535   "RTN","RCD PEM",122,0 )
  13536    ; If LOCK  = 1 lock  deposit
  13537   "RTN","RCD PEM",123,0 )
  13538    ; If LOCK  = 0 unloc k deposit
  13539   "RTN","RCD PEM",124,0 )
  13540    I $G(LOCK ) D
  13541   "RTN","RCD PEM",125,0 )
  13542    . L +^RCY (344.1,RCD EP,0):DILO CKTM
  13543   "RTN","RCD PEM",126,0 )
  13544    . D CONFI RM^RCDPUDE P(RCDEP) ;  confirm t o prevent  changes
  13545   "RTN","RCD PEM",127,0 )
  13546    I '$G(LOC K) L -^RCY (344.1,RCD EP,0)
  13547   "RTN","RCD PEM",128,0 )
  13548    Q
  13549   "RTN","RCD PEM",129,0 )
  13550    ;
  13551   "RTN","RCD PEM",130,0 )
  13552   RCPTDET(RC RZ,RECTDA1 ,RCER) ; A dds detail  to a rece ipt based  on file 34 4.49
  13553   "RTN","RCD PEM",131,0 )
  13554    ; RCRZ =  ien of ERA  entry in  file 344.4 9
  13555   "RTN","RCD PEM",132,0 )
  13556    ; RECTDA1  = ien of  receipt en try in fil e 344
  13557   "RTN","RCD PEM",133,0 )
  13558    ; RCER =  error arra y returned  if passed  by refere nce
  13559   "RTN","RCD PEM",134,0 )
  13560    ;
  13561   "RTN","RCD PEM",135,0 )
  13562    N DA,DIE, DR,Q,RCR,R CSPL,RCZ0, RCTRANDA,R CQ,X,Y,Z0, Z1,Z ; PRC A*4.5*318
  13563   "RTN","RCD PEM",136,0 )
  13564    ;
  13565   "RTN","RCD PEM",137,0 )
  13566    S RCR=0 F   S RCR=$O (^RCY(344. 49,RCRZ,1, RCR)) Q:'R CR  D
  13567   "RTN","RCD PEM",138,0 )
  13568    . S RCZ0= $G(^RCY(34 4.49,RCRZ, 1,RCR,0))
  13569   "RTN","RCD PEM",139,0 )
  13570    . I $P(RC Z0,U)'["."  S RCSPL(+ RCZ0)=$P(R CZ0,U,9) Q
  13571   "RTN","RCD PEM",140,0 )
  13572    . I $S(+$ P(RCZ0,U,3 )=0:$P($G( ^RCY(344.4 9,RCRZ,0)) ,U,3),1:$P (RCZ0,U,3) <0) S RCSP L(RCZ0\1,+ RCZ0)=RCZ0  Q
  13573   "RTN","RCD PEM",141,0 )
  13574    . S RCTRA NDA=$$ADDT RAN^RCDPUR ET(RECTDA1 )
  13575   "RTN","RCD PEM",142,0 )
  13576    . ;
  13577   "RTN","RCD PEM",143,0 )
  13578    . I RCTRA NDA'>0 D   Q  ; Error  adding re ceipt deta il - PRCA* 4.5*318
  13579   "RTN","RCD PEM",144,0 )
  13580    .. S RCER (1)=$$SETE RR^RCDPEM0 (1) ; PRCA *4.5*318 -  pass RCPR OC value t o $$SETERR
  13581   "RTN","RCD PEM",145,0 )
  13582    .. S RCER ($O(RCER(" "),-1)+1)= "  NO DETA IL LINE AD DED TO REC EIPT "_$P( $G(^RCY(34 4,RECTDA1, 0)),U)_" F OR LINE #" _$P(RCZ0,U )_" IN EEO B WORKLIST  SCRATCH P AD"
  13583   "RTN","RCD PEM",146,0 )
  13584    . ;
  13585   "RTN","RCD PEM",147,0 )
  13586    . ;Store  receipt li ne detail
  13587   "RTN","RCD PEM",148,0 )
  13588    . D DET(R CRZ,RCR,RE CTDA1,RCTR ANDA)
  13589   "RTN","RCD PEM",149,0 )
  13590    . S RCSPL (RCZ0\1,+R CZ0)=RCZ0
  13591   "RTN","RCD PEM",150,0 )
  13592    ;
  13593   "RTN","RCD PEM",151,0 )
  13594    ; Update  A/R CORREC TED PAYMEN T multiple  with appo rtionment  for split  lines
  13595   "RTN","RCD PEM",152,0 )
  13596    S Z=0 F   S Z=$O(RCS PL(Z)) Q:' Z  S RCQ=+ $G(RCSPL(Z )) I RCQ D
  13597   "RTN","RCD PEM",153,0 )
  13598    . S Z1=$O (RCSPL(Z," ")) Q:Z1=" "
  13599   "RTN","RCD PEM",154,0 )
  13600    . I $O(RC SPL(Z,""), -1)=Z1,'$$ SPLIT(Z,Z1 ,RCERA) Q   ; No spli t occurred
  13601   "RTN","RCD PEM",155,0 )
  13602    . S Z1=0  F  S Z1=$O (RCSPL(Z,Z 1)) Q:'Z1   S Z0=$G(R CSPL(Z,Z1) ) D
  13603   "RTN","RCD PEM",156,0 )
  13604    .. S Q=+$ P($G(^RCY( 344.4,RCRZ ,1,RCQ,0)) ,U,2) ; EO B detail r ec
  13605   "RTN","RCD PEM",157,0 )
  13606    .. Q:'Q
  13607   "RTN","RCD PEM",158,0 )
  13608    .. I '$P( Z0,U,7)!($ P(Z0,U,2)= "") D  ; S uspensed
  13609   "RTN","RCD PEM",159,0 )
  13610    ... D SPL 1^IBCEOBAR (Q,$S($P(Z 0,U,2)="": "NO BILL", 1:$P(Z0,U, 2)),"",$P( Z0,U,6)) ;  IA 4050
  13611   "RTN","RCD PEM",160,0 )
  13612    .. E  D
  13613   "RTN","RCD PEM",161,0 )
  13614    ... D SPL 1^IBCEOBAR (Q,$P(Z0,U ,2),$P(Z0, U,7),$P(Z0 ,U,6)) ; A dd the spl it bill #  ; IA 4050
  13615   "RTN","RCD PEM",162,0 )
  13616    . ; BEGIN  - PRCA*4. 5*321
  13617   "RTN","RCD PEM",163,0 )
  13618    . ;Move/C opy/Remove  EEOB deta il for spl it line
  13619   "RTN","RCD PEM",164,0 )
  13620    . N CLAIM ,IEN3611,R CSPLIT,RCS UB,RCZSAV
  13621   "RTN","RCD PEM",165,0 )
  13622    . ; Sub-a rray of sp lit claim  detail for  individua l line
  13623   "RTN","RCD PEM",166,0 )
  13624    . M RCSPL IT=RCSPL(Z )
  13625   "RTN","RCD PEM",167,0 )
  13626    . ; Prote ct Z subsc ript varia ble from o verwrite b y triggers
  13627   "RTN","RCD PEM",168,0 )
  13628    . S RCZSA V=Z
  13629   "RTN","RCD PEM",169,0 )
  13630    . ; Get s cratchpad  line numbe r for this  ERA line
  13631   "RTN","RCD PEM",170,0 )
  13632    . S RCSUB =$O(^RCY(3 44.49,RCRZ ,1,"ASEQ", Z,""))
  13633   "RTN","RCD PEM",171,0 )
  13634    . ; Origi nal claim  number fro m Scratchp ad line
  13635   "RTN","RCD PEM",172,0 )
  13636    . S CLAIM =$$GET1^DI Q(344.491, RCSUB_","_ RCRZ_",",. 02)
  13637   "RTN","RCD PEM",173,0 )
  13638    . ; EOB f or origina l claim fr om ERA lin e
  13639   "RTN","RCD PEM",174,0 )
  13640    . S IEN36 11=$$GET1^ DIQ(344.41 ,RCQ_","_R CRZ_",",.0 2,"I")
  13641   "RTN","RCD PEM",175,0 )
  13642    . ; Autom atic Move/ Copy/Remov e EOB
  13643   "RTN","RCD PEM",176,0 )
  13644    . I $$AUT O^RCDPEM5( CLAIM,.RCS PLIT,RCERA ,"W",IEN36 11)
  13645   "RTN","RCD PEM",177,0 )
  13646    . ; Resto re Z
  13647   "RTN","RCD PEM",178,0 )
  13648    . S Z=RCZ SAV
  13649   "RTN","RCD PEM",179,0 )
  13650    . ; END   - PRCA*4.5 *321
  13651   "RTN","RCD PEM",180,0 )
  13652    ;
  13653   "RTN","RCD PEM",181,0 )
  13654    Q
  13655   "RTN","RCD PEM",182,0 )
  13656   SPLIT(Z,Z1 ,RCERA) ;C heck if wo rklist was  split but  to to sin gle claim
  13657   "RTN","RCD PEM",183,0 )
  13658    N SUB,NBI LL,OBILL
  13659   "RTN","RCD PEM",184,0 )
  13660    ;Find spl it line in  scratchpa d
  13661   "RTN","RCD PEM",185,0 )
  13662    S SUB=$O( ^RCY(344.4 9,RCERA,1, "B",Z1,"") ) Q:'SUB 0
  13663   "RTN","RCD PEM",186,0 )
  13664    ;Get orig inal claim  number fr om scratch pad
  13665   "RTN","RCD PEM",187,0 )
  13666    S OBILL=$ P($G(^RCY( 344.49,RCE RA,1,SUB-1 ,0)),U,2)
  13667   "RTN","RCD PEM",188,0 )
  13668    ;New clai m number
  13669   "RTN","RCD PEM",189,0 )
  13670    S NBILL=$ P(RCSPL(Z, Z1),U,2)
  13671   "RTN","RCD PEM",190,0 )
  13672    ;If new a nd old cla im are not  the same  this is a  move via s plit
  13673   "RTN","RCD PEM",191,0 )
  13674    I OBILL'= "",OBILL'= NBILL Q 1
  13675   "RTN","RCD PEM",192,0 )
  13676    ;Otherwis e this is  not a spli t
  13677   "RTN","RCD PEM",193,0 )
  13678    Q 0
  13679   "RTN","RCD PEM",194,0 )
  13680    ;
  13681   "RTN","RCD PEM",195,0 )
  13682   DET(RCZ,RC R,RECTDA1, RCTRANDA)  ; Store re ceipt deta il
  13683   "RTN","RCD PEM",196,0 )
  13684    ; RCZ = i en of entr y file 344 .49
  13685   "RTN","RCD PEM",197,0 )
  13686    ; RCR = i en of entr y in file  344.491
  13687   "RTN","RCD PEM",198,0 )
  13688    ; RCPROC  = Function  calling t his subrou tine
  13689   "RTN","RCD PEM",199,0 )
  13690    ;         = 1 EFT ma tch to ERA    = 0 man ual add re ceipt
  13691   "RTN","RCD PEM",200,0 )
  13692    ; RECTDA1  = ien of  entry in f ile 344
  13693   "RTN","RCD PEM",201,0 )
  13694    ; RCTRAND A = ien of  entry in  subfile 34 4.01
  13695   "RTN","RCD PEM",202,0 )
  13696    ;
  13697   "RTN","RCD PEM",203,0 )
  13698    N DIE,DA, DR,X,Y,Z,R CUP,RCCOM, RCZ0,RC0
  13699   "RTN","RCD PEM",204,0 )
  13700    S RC0=$G( ^RCY(344.4 9,RCZ,0))
  13701   "RTN","RCD PEM",205,0 )
  13702    S RCZ0=$G (^RCY(344. 49,RCZ,1,R CR,0))
  13703   "RTN","RCD PEM",206,0 )
  13704    S DR="",R CUP=+$O(^R CY(344.49, RCZ,1,"B", +RCZ0/1,0) ),RCUP=$G( ^RCY(344.4 9,RCZ,1,RC UP,0))
  13705   "RTN","RCD PEM",207,0 )
  13706    I $P(RCZ0 ,U,7) S DR =".09////^ S X="_+$P( RCZ0,U,7)_ "_$C(59)_" "PRCA(430, "";"
  13707   "RTN","RCD PEM",208,0 )
  13708    S DR=DR_" .04////"_( +$P(RCZ0,U ,3))_";.27 ////"_RCR_ ";"
  13709   "RTN","RCD PEM",209,0 )
  13710    I $P(RC0, U,5)'="" S  DR=DR_".1 ////"_$P(R C0,U,5)_"; "
  13711   "RTN","RCD PEM",210,0 )
  13712    I $P(RC0, U,6)'="" S  DR=DR_".0 8////"_$P( RC0,U,6)_" ;"
  13713   "RTN","RCD PEM",211,0 )
  13714    S Z=0 F   S Z=$O(^RC Y(344.49,R CZ,1,RCR,1 ,Z)) Q:'Z   I $P($G(^ (Z,0)),U,5 )=1 S DR=D R_".28//// 1;" Q  ; U pdate rece ipt line w ith dec ad j flag
  13715   "RTN","RCD PEM",212,0 )
  13716    S RCCOM=$ P(RCZ0,U,1 0)
  13717   "RTN","RCD PEM",213,0 )
  13718    I $P(RCUP ,U,2)["**A DJ" S RCCO M=RCCOM_$S (RCCOM'="" :"/",1:"") _$S($P($P( RCUP,U,2), "ADJ",2):" ERA adjust ment - no  bill refer enced",1:" Total of E FT mismatc hed to ERA ")
  13719   "RTN","RCD PEM",214,0 )
  13720    I RCCOM]" " S DR=DR_ "1.02////" _$E(RCCOM, 1,60)_";"
  13721   "RTN","RCD PEM",215,0 )
  13722    I $P($G(^ RCY(344.49 ,RCZ,0)),U ,4)'="" S  DR=DR_".07 ////"_$P($ G(^RCY(344 .49,RCZ,0) ),U,4)_";"
  13723   "RTN","RCD PEM",216,0 )
  13724    S DA(1)=R ECTDA1,DA= RCTRANDA,D IE="^RCY(3 44,"_DA(1) _",1,"
  13725   "RTN","RCD PEM",217,0 )
  13726    D ^DIE
  13727   "RTN","RCD PEM",218,0 )
  13728    ;Update c omment his tory - PRC A*4.5*321
  13729   "RTN","RCD PEM",219,0 )
  13730    D:RCCOM]" " AUDIT^RC DPECH(RECT DA1,RCTRAN DA,RCZ,RCR )
  13731   "RTN","RCD PEM",220,0 )
  13732    Q
  13733   "RTN","RCD PEM",221,0 )
  13734    ;
  13735   "RTN","RCD PEM1")
  13736   0^18^B4518 9971
  13737   "RTN","RCD PEM1",1,0)
  13738   RCDPEM1 ;A LB/TMK,DWA ,PJH - ERA  MATCH TO  EFT (cont)  ; 5/5/11  1:25pm
  13739   "RTN","RCD PEM1",2,0)
  13740    ;;4.5;Acc ounts Rece ivable;**1 73,269,318 ,321**;Mar  20, 1995; Build 46
  13741   "RTN","RCD PEM1",3,0)
  13742    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  13743   "RTN","RCD PEM1",4,0)
  13744    Q
  13745   "RTN","RCD PEM1",5,0)
  13746    ;
  13747   "RTN","RCD PEM1",6,0)
  13748   BULL(RCFIL E,RC0,RCER ) ; Add th e error to  the bulle tin text a rray
  13749   "RTN","RCD PEM1",7,0)
  13750    ; RCFILE  = null, 34 4.3 or 344 .31, depen ding on th e file bei ng worked
  13751   "RTN","RCD PEM1",8,0)
  13752    ; RC0 = t he 0-node  of the RCF ILE entry
  13753   "RTN","RCD PEM1",9,0)
  13754    ; RCER =  the error  text to be  placed in  the bulle tin (passe d by ref)
  13755   "RTN","RCD PEM1",10,0 )
  13756    ;
  13757   "RTN","RCD PEM1",11,0 )
  13758    N RCHCT,C T,Z
  13759   "RTN","RCD PEM1",12,0 )
  13760    I '$O(^TM P($J,"RCXM ",0)) S ^T MP($J,"RCX M",1)="The  following  exception s were enc ountered a ttempting" ,^TMP($J," RCXM",2)=" to post EF T deposits  OR to mat ch EFT's w ith ERA's: ",^TMP($J, "RCXM",3)= " "
  13761   "RTN","RCD PEM1",13,0 )
  13762    S (RCHCT, CT)=+$O(^T MP($J,"RCX M",""),-1)
  13763   "RTN","RCD PEM1",14,0 )
  13764    S ^TMP($J ,"RCXM",0) =$G(^TMP($ J,"RCXM",0 ))+1
  13765   "RTN","RCD PEM1",15,0 )
  13766    I RC0'=""  D
  13767   "RTN","RCD PEM1",16,0 )
  13768    . D BLD(" ^TMP($J,"" RCXM"")",. CT,RCFILE, RC0)
  13769   "RTN","RCD PEM1",17,0 )
  13770    . S RCER= $G(RCER)+1 ,RCHCT=RCH CT+1
  13771   "RTN","RCD PEM1",18,0 )
  13772    . S ^TMP( $J,"RCXM", RCHCT)=$E( ^TMP($J,"R CXM",0)_$J ("",4),1,4 )_$G(^TMP( $J,"RCXM", RCHCT))
  13773   "RTN","RCD PEM1",19,0 )
  13774    S Z=1 F   S Z=$O(RCE R(Z)) Q:'Z   S CT=CT+ 1,^TMP($J, "RCXM",CT) ="  "_RCER (Z)
  13775   "RTN","RCD PEM1",20,0 )
  13776    S CT=CT+1 ,^TMP($J," RCXM",CT)= "  "
  13777   "RTN","RCD PEM1",21,0 )
  13778    Q
  13779   "RTN","RCD PEM1",22,0 )
  13780    ;
  13781   "RTN","RCD PEM1",23,0 )
  13782   SENDBULL ;  Sends the  bulletin  when all p rocessing  is complet e
  13783   "RTN","RCD PEM1",24,0 )
  13784    N XMBODY, XMB,XMINST R,XMTYPE,X MFULL,XMTO ,XMZ,XMERR ,XMSUBJ
  13785   "RTN","RCD PEM1",25,0 )
  13786    S XMTO("I :G.RCDPE P AYMENTS")= ""
  13787   "RTN","RCD PEM1",26,0 )
  13788    S XMBODY= "^TMP($J," "RCXM"")"
  13789   "RTN","RCD PEM1",27,0 )
  13790    S XMSUBJ= "EDI LBOX  "_$$FMTE^X LFDT(DT,2) _" EXCEPTI ONS EFT DE P/MATCH EF Ts TO ERAs "
  13791   "RTN","RCD PEM1",28,0 )
  13792    D  ;
  13793   "RTN","RCD PEM1",29,0 )
  13794    . N DUZ
  13795   "RTN","RCD PEM1",30,0 )
  13796    . S DUZ=. 5,DUZ(0)=" @"
  13797   "RTN","RCD PEM1",31,0 )
  13798    . D SENDM SG^XMXAPI( .5,XMSUBJ, XMBODY,.XM TO,,.XMZ)
  13799   "RTN","RCD PEM1",32,0 )
  13800    K ^TMP($J ,"RCXM")
  13801   "RTN","RCD PEM1",33,0 )
  13802    Q
  13803   "RTN","RCD PEM1",34,0 )
  13804    ;
  13805   "RTN","RCD PEM1",35,0 )
  13806   BLD(RCARRA Y,RCT,RCFI LE,RC0) ;  Build the  array for  entry 344. 31 detail
  13807   "RTN","RCD PEM1",36,0 )
  13808    ; RCARRAY  = the nam e of the a rray to be  set
  13809   "RTN","RCD PEM1",37,0 )
  13810    ; RCT = t he # of li nes alread y output i nto this a rray
  13811   "RTN","RCD PEM1",38,0 )
  13812    ; RCFILE  = 344.3 or  344.31
  13813   "RTN","RCD PEM1",39,0 )
  13814    ; RC0 = t he 0-node  of the ent ry in RCFI LE
  13815   "RTN","RCD PEM1",40,0 )
  13816    ;
  13817   "RTN","RCD PEM1",41,0 )
  13818    N Z,RC00
  13819   "RTN","RCD PEM1",42,0 )
  13820    I RCFILE= 344.31 D
  13821   "RTN","RCD PEM1",43,0 )
  13822    . S RC00= $G(^RCY(34 4.3,+RC0,0 ))
  13823   "RTN","RCD PEM1",44,0 )
  13824    . S Z=$$S ETSTR^VALM 1("  TRACE  #: "_$P(R C0,U,4),"" ,1,61) ; E xpand Trac e # to 50  characters
  13825   "RTN","RCD PEM1",45,0 )
  13826    . S RCT=R CT+1,@RCAR RAY@(RCT)= Z ; for In s. Co. bel ow
  13827   "RTN","RCD PEM1",46,0 )
  13828    . S Z=$$S ETSTR^VALM 1("  INS C O: "_$E($P (RC0,U,2), 1,22)_"/"_ $P(RC0,U,3 ),"",1,76)
  13829   "RTN","RCD PEM1",47,0 )
  13830    . S RCT=R CT+1,@RCAR RAY@(RCT)= Z
  13831   "RTN","RCD PEM1",48,0 )
  13832    . S Z=$$S ETSTR^VALM 1("  DEPOS IT DATE: " _$$FMTE^XL FDT($P(RC0 0,U,7),2), "",1,24)
  13833   "RTN","RCD PEM1",49,0 )
  13834    . S Z=$$S ETSTR^VALM 1("  DATE  REC'D: "_$ S($P(RC00, U,13):$$FM TE^XLFDT($ P(RC00,U,1 3)\1,2),1: ""),Z,25,2 2)
  13835   "RTN","RCD PEM1",50,0 )
  13836    . S Z=$$S ETSTR^VALM 1("  PAYME NT AMT: "_ $TR($J($P( RC0,U,7),1 5,2)," "), Z,47,30)
  13837   "RTN","RCD PEM1",51,0 )
  13838    . S RCT=R CT+1,@RCAR RAY@(RCT)= Z
  13839   "RTN","RCD PEM1",52,0 )
  13840    ;
  13841   "RTN","RCD PEM1",53,0 )
  13842    I RCFILE= 344.3 D
  13843   "RTN","RCD PEM1",54,0 )
  13844    . S Z=$$S ETSTR^VALM 1("  DEPOS IT #: "_$P (RC0,U,6), "",1,13)
  13845   "RTN","RCD PEM1",55,0 )
  13846    . S Z=$$S ETSTR^VALM 1("  DEPOS IT DATE: " _$$FMTE^XL FDT($P(RC0 ,U,7),2),Z ,16,24)
  13847   "RTN","RCD PEM1",56,0 )
  13848    . S RCT=R CT+1,@RCAR RAY@(RCT)= Z
  13849   "RTN","RCD PEM1",57,0 )
  13850    . S Z=$$S ETSTR^VALM 1("  DATE  REC'D: "_$ S($P(RC0,U ,13):$$FMT E^XLFDT($P (RC0,U,13) \1,2),1:"" ),"",25,22 )
  13851   "RTN","RCD PEM1",58,0 )
  13852    . S Z=$$S ETSTR^VALM 1("  DEPOS IT AMT: "_ $TR($J($P( RC0,U,8),1 5,2)," "), Z,47,30)
  13853   "RTN","RCD PEM1",59,0 )
  13854    . S RCT=R CT+1,@RCAR RAY@(RCT)= Z
  13855   "RTN","RCD PEM1",60,0 )
  13856    ;
  13857   "RTN","RCD PEM1",61,0 )
  13858    Q
  13859   "RTN","RCD PEM1",62,0 )
  13860    ;
  13861   "RTN","RCD PEM1",63,0 )
  13862   EN1 ; Queu e match jo b for run  on demand
  13863   "RTN","RCD PEM1",64,0 )
  13864    N DIR,X,Y ,ZTIO,ZTRT N,ZTSK,ZTD ESC,ZTDTH
  13865   "RTN","RCD PEM1",65,0 )
  13866    S DIR(0)= "YA",DIR(" A",1)="THI S OPTION Q UEUES THE  JOB TO MAT CH EFTs TO  ELECTRONI C ERAs"
  13867   "RTN","RCD PEM1",66,0 )
  13868    S DIR("A" )="ARE YOU  SURE YOU  WANT TO RU N THIS JOB ?: ",DIR(" B")="NO"
  13869   "RTN","RCD PEM1",67,0 )
  13870    W ! D ^DI R K DIR
  13871   "RTN","RCD PEM1",68,0 )
  13872    I Y'=1 G  EN1Q
  13873   "RTN","RCD PEM1",69,0 )
  13874    L +^RCY(3 44.3,"ALOC K"):5 I '$ T D  G EN1 Q
  13875   "RTN","RCD PEM1",70,0 )
  13876    . S DIR(0 )="EA",DIR ("A",1)="T his job is  currently  running . .. try aga in later", DIR("A")=" Press ENTE R to conti nue: " D ^ DIR K DIR
  13877   "RTN","RCD PEM1",71,0 )
  13878    S ZTIO="" ,ZTDTH=$$N OW^XLFDT()
  13879   "RTN","RCD PEM1",72,0 )
  13880    S ZTRTN=" MATCH^RCDP EM(1,1)",Z TDESC="AR  - MANUAL E FT-ERA MAT CH EDI LOC KBOX"
  13881   "RTN","RCD PEM1",73,0 )
  13882    D ^%ZTLOA D
  13883   "RTN","RCD PEM1",74,0 )
  13884    W !!,$S($ D(ZTSK):"Y our job ha s been que ued - task  number "_ ZTSK,1:"Un able to qu eue this j ob.")
  13885   "RTN","RCD PEM1",75,0 )
  13886    U IO
  13887   "RTN","RCD PEM1",76,0 )
  13888   EN1Q L -^R CY(344.3," ALOCK")
  13889   "RTN","RCD PEM1",77,0 )
  13890    Q
  13891   "RTN","RCD PEM1",78,0 )
  13892    ;
  13893   "RTN","RCD PEM1",79,0 )
  13894   EN2 ; Entr ypoint fro m nightly  job to put  Nightly d ata into t he nightly  job's sta tus bullet in
  13895   "RTN","RCD PEM1",80,0 )
  13896    ; PRCA*4. 5*321 drop ped call t o the Dail y Activity  Report
  13897   "RTN","RCD PEM1",81,0 )
  13898    ; data in to the nig htly job's  status bu lletin
  13899   "RTN","RCD PEM1",82,0 )
  13900    N CT,DATA ,Z,Z0,RCHD ,T,T0
  13901   "RTN","RCD PEM1",83,0 )
  13902    S CT=+$O( ^TMP($J,"R CXM",""),- 1)
  13903   "RTN","RCD PEM1",84,0 )
  13904    S CT=CT+1 ,^TMP($J," RCXM",CT)= ""
  13905   "RTN","RCD PEM1",85,0 )
  13906    I $D(^TMP ($J,"RCTOT ","EFT_DEP ")) D
  13907   "RTN","RCD PEM1",86,0 )
  13908    . S CT=CT +1,^TMP($J ,"RCXM",CT )=$J("",12 )_"******* *** TOTALS  ********* *"
  13909   "RTN","RCD PEM1",87,0 )
  13910    . S CT=CT +1,^TMP($J ,"RCXM",CT )="DEPOSIT S"
  13911   "RTN","RCD PEM1",88,0 )
  13912    . S CT=CT +1,^TMP($J ,"RCXM",CT )="  TOTAL  # UNPOSTE D EFT DEPO SITS FOUND : "_+$G(^T MP($J,"RCT OT","EFT_D EP"))
  13913   "RTN","RCD PEM1",89,0 )
  13914    . S CT=CT +1,^TMP($J ,"RCXM",CT )="  TOTAL  # NEW EFT  DEPOSITS  CREATED: " _+$G(^TMP( $J,"RCTOT" ,"DEPOSIT" ))
  13915   "RTN","RCD PEM1",90,0 )
  13916    . S CT=CT +1,^TMP($J ,"RCXM",CT )="  TOTAL  # NEW EFT  DEPOSIT R ECEIPTS CR EATED: "_+ $G(^TMP($J ,"RCTOT"," EFT_RECPT" ))
  13917   "RTN","RCD PEM1",91,0 )
  13918    . S CT=CT +1,^TMP($J ,"RCXM",CT )="  TOTAL  # EFT DEP OSITS WITH  CHECK SUM  ERRORS: " _+$G(^TMP( $J,"RCTOT" ,"CSUM"))
  13919   "RTN","RCD PEM1",92,0 )
  13920    . S CT=CT +1,^TMP($J ,"RCXM",CT )="  TOTAL  # EFT DEP OSITS WITH  OTHER ERR ORS: "_+$G (^TMP($J," RCTOT","ER R"))
  13921   "RTN","RCD PEM1",93,0 )
  13922    . S CT=CT +1,^TMP($J ,"RCXM",CT )="  TOTAL  EFT DEPOS IT AMOUNT  POSTED TO  REV SRC CD  8NZZ: "_$ J(+$G(^TMP ($J,"RCTOT ","SUSPAMT ")),"",2)
  13923   "RTN","RCD PEM1",94,0 )
  13924    . S CT=CT +1,^TMP($J ,"RCXM",CT )=""
  13925   "RTN","RCD PEM1",95,0 )
  13926    S CT=CT+1 ,^TMP($J," RCXM",CT)= "EFT-ERA M ATCHES"
  13927   "RTN","RCD PEM1",96,0 )
  13928    S CT=CT+1 ,^TMP($J," RCXM",CT)= "  TOTAL #  UNMATCHED  ERAs CHEC KED: "_+$G (^TMP($J," RCTOT","EF T"))
  13929   "RTN","RCD PEM1",97,0 )
  13930    S CT=CT+1 ,^TMP($J," RCXM",CT)= "  TOTAL #  ERAs MATC HED TO EFT s: "_+$G(^ TMP($J,"RC TOT","MATC H"))_$S($G (^TMP($J," RCTOT","MA TCH"))&$G( ^TMP($J,"R CTOT","TOT MIS")):" I NCLUDING " _+$G(^TMP( $J,"RCTOT" ,"TOTMIS") )_" WITH M ISMATCHED  TOTALS",1: "")
  13931   "RTN","RCD PEM1",98,0 )
  13932    S CT=CT+1 ,^TMP($J," RCXM",CT)= "  TOTAL #  ERAs STIL L UNMATCHE D: "_+$G(^ TMP($J,"RC TOT","NO_M ATCH"))
  13933   "RTN","RCD PEM1",99,0 )
  13934    S CT=CT+1 ,^TMP($J," RCXM",CT)= ""
  13935   "RTN","RCD PEM1",100, 0)
  13936    ;K ^TMP(" RCDAILYACT ",$J)  ; P RCA*4.5*32 1 don't ne ed - relat ed to Dail y Activity  Report
  13937   "RTN","RCD PEM1",101, 0)
  13938    K ^TMP($J ,"RC1")
  13939   "RTN","RCD PEM1",102, 0)
  13940    ;
  13941   "RTN","RCD PEM1",103, 0)
  13942    S Z=0 F   S Z=$O(^TM P($J,"RCDP ETOT",344. 31,Z)) Q:' Z  S Z0=$G (^RCY(344. 31,Z,0)) I  Z0 S ^TMP ($J,"RC1", +Z0,Z)=Z0
  13943   "RTN","RCD PEM1",104, 0)
  13944    ;
  13945   "RTN","RCD PEM1",105, 0)
  13946    S (RCHD,Z )=0 F  S Z =$O(^TMP($ J,"RCDPETO T",344.3,Z )) Q:'Z  S  DATA=$G(^ (Z)) D
  13947   "RTN","RCD PEM1",106, 0)
  13948    . I 'RCHD  D HDR(.CT ,.RCHD) ;  Add header s
  13949   "RTN","RCD PEM1",107, 0)
  13950    . S Z0=$G (^RCY(344. 3,Z,0))
  13951   "RTN","RCD PEM1",108, 0)
  13952    . S CT=CT +1
  13953   "RTN","RCD PEM1",109, 0)
  13954    . S ^TMP( $J,"RCXM", CT)=""
  13955   "RTN","RCD PEM1",110, 0)
  13956    . I '$G(D ATA) D
  13957   "RTN","RCD PEM1",111, 0)
  13958    .. S CT=C T+1
  13959   "RTN","RCD PEM1",112, 0)
  13960    .. S ^TMP ($J,"RCXM" ,CT)=^TMP( $J,"RCXM", CT)_"  "_$ E($P($G(^R CY(344.1,+ $P(Z0,U,3) ,0)),U)_$J ("",15),1, 15)_"  "_$ E($P($G(^R CY(344,+$O (^RCY(344, "AD",+$P(Z 0,U,3),0)) ,0)),U)_$J ("",15),1, 15)_"  "
  13961   "RTN","RCD PEM1",113, 0)
  13962    .. S ^TMP ($J,"RCXM" ,CT)=^TMP( $J,"RCXM", CT)_$J(+$P (Z0,U,12), "",2)
  13963   "RTN","RCD PEM1",114, 0)
  13964    . I $G(DA TA) D
  13965   "RTN","RCD PEM1",115, 0)
  13966    .. S ^TMP ($J,"RCXM" ,CT)=^TMP( $J,"RCXM", CT)_"  "_$ E($P($G(^R CY(344.1,+ $P(DATA,U, 5),0)),U)_ $J("",15), 1,15)_"  " _$E($S($P( DATA,U,5): $P($G(^RCY (344,+DATA ,0)),U),1: "")_$J("", 15),1,15)_ "  "
  13967   "RTN","RCD PEM1",116, 0)
  13968    .. S ^TMP ($J,"RCXM" ,CT)=^TMP( $J,"RCXM", CT)_$J($S( $P(DATA,U, 3):+$P(DAT A,U,2),1:0 ),"",2)
  13969   "RTN","RCD PEM1",117, 0)
  13970    . I $P(DA TA,U,4) S  CT=CT+1,^T MP($J,"RCX M",CT)="     ERROR #  REFERENCED  ABOVE : " _$P(DATA,U ,4)
  13971   "RTN","RCD PEM1",118, 0)
  13972    . S T=0 F   S T=$O(^ TMP($J,"RC 1",Z,T)) Q :'T  S T0= $G(^(T)) D
  13973   "RTN","RCD PEM1",119, 0)
  13974    .. S CT=C T+1
  13975   "RTN","RCD PEM1",120, 0)
  13976    .. S ^TMP ($J,"RCXM" ,CT)=$J("" ,5)_$P(T0, U,4)
  13977   "RTN","RCD PEM1",121, 0)
  13978    .. S CT=C T+1 ; sepa rate TRACE  # above f rom PAYER  NAME/ID be low
  13979   "RTN","RCD PEM1",122, 0)
  13980    .. S ^TMP ($J,"RCXM" ,CT)=$J("" ,5)_$P(T0, U,2)_"/"_$ P(T0,U,3)
  13981   "RTN","RCD PEM1",123, 0)
  13982    .. S CT=C T+1,^TMP($ J,"RCXM",C T)=$J("",1 0)_"PAYMEN T AMOUNT:  "_$J(+$P(T 0,U,7),"", 2)_"  MATC H STATUS:  "_$$EXTERN AL^DILFD(3 44.31,.08, ,$P(T0,U,8 ))
  13983   "RTN","RCD PEM1",124, 0)
  13984    .. S:$O(^ TMP($J,"RC DPETOT",34 4.3,Z)) CT =CT+1,^TMP ($J,"RCXM" ,CT)=" "
  13985   "RTN","RCD PEM1",125, 0)
  13986    ;. I $P(D ATA,U,3) S  ^TMP("RCD AILYACT",$ J,DT,Z)=Z0   ;PRCA*4. 5*321 remo ve
  13987   "RTN","RCD PEM1",126, 0)
  13988    ;
  13989   "RTN","RCD PEM1",127, 0)
  13990    K ^TMP($J ,"RC1")
  13991   "RTN","RCD PEM1",128, 0)
  13992    ;I $O(^TM P("RCDAILY ACT",$J,0) ) D  ; Dai ly activit y rep auto matic bull etin ;PRCA *4.5*321 r emove
  13993   "RTN","RCD PEM1",129, 0)
  13994    ;. N XMBO DY,XMB,XMI NSTR,XMTYP E,XMFULL,X MTO,XMZ,XM ERR,XMSUBJ
  13995   "RTN","RCD PEM1",130, 0)
  13996    ;. K ^TMP ($J,"RCDPE _DAR")
  13997   "RTN","RCD PEM1",131, 0)
  13998    ;. D RPT1 ^RCDPEDAR( "1^0^0^0^0 ^"_DT_"^"_ DT)  ;PRCA *4.5*318,  changed th e paramete rs
  13999   "RTN","RCD PEM1",132, 0)
  14000    ;. K ^TMP ("RCDAILYA CT",$J)
  14001   "RTN","RCD PEM1",133, 0)
  14002    ;. Q:'$O( ^TMP($J,"R CDPE_DAR", 0))
  14003   "RTN","RCD PEM1",134, 0)
  14004    ;. S XMTO ("I:G.RCDP E PAYMENTS ")=""
  14005   "RTN","RCD PEM1",135, 0)
  14006    ;. S XMBO DY="^TMP($ J,""RCDPE_ DAR"")"
  14007   "RTN","RCD PEM1",136, 0)
  14008    ;. S XMSU BJ="EDI LB OX - AUTO  DAILY ACTI VITY SUMMA RY - "_$$F MTE^XLFDT( DT,2)
  14009   "RTN","RCD PEM1",137, 0)
  14010    ;. D  ;
  14011   "RTN","RCD PEM1",138, 0)
  14012    ;.. N DUZ
  14013   "RTN","RCD PEM1",139, 0)
  14014    ;.. S DUZ =.5,DUZ(0) ="@"
  14015   "RTN","RCD PEM1",140, 0)
  14016    ;.. D SEN DMSG^XMXAP I(.5,XMSUB J,XMBODY,. XMTO,,.XMZ )
  14017   "RTN","RCD PEM1",141, 0)
  14018    ;. K ^TMP ($J,"RCDPE _DAR")
  14019   "RTN","RCD PEM1",142, 0)
  14020    Q
  14021   "RTN","RCD PEM1",143, 0)
  14022    ;
  14023   "RTN","RCD PEM1",144, 0)
  14024   HDR(CT,HD)  ; Header  array set
  14025   "RTN","RCD PEM1",145, 0)
  14026    ; CT = li ne count,  passed by  reference
  14027   "RTN","RCD PEM1",146, 0)
  14028    ; HD = fl ag returne d as 1 so  the header  is only o utput once
  14029   "RTN","RCD PEM1",147, 0)
  14030    N Q
  14031   "RTN","RCD PEM1",148, 0)
  14032    S CT=CT+1 ,^TMP($J," RCXM",CT)= " "
  14033   "RTN","RCD PEM1",149, 0)
  14034    S CT=CT+1 ,^TMP($J," RCXM",CT)= $J("",20)_ "********* * EFT DEPO SIT RECORD S ******** **"
  14035   "RTN","RCD PEM1",150, 0)
  14036    S CT=CT+1 ,^TMP($J," RCXM",CT)= "  EFT DEP OSIT       EFT RECEIP T      POS TED AMOUNT "
  14037   "RTN","RCD PEM1",151, 0)
  14038    S CT=CT+1 ,^TMP($J," RCXM",CT)= " "
  14039   "RTN","RCD PEM1",152, 0)
  14040    S CT=CT+1 ,^TMP($J," RCXM",CT)= "     TRAC E #"
  14041   "RTN","RCD PEM1",153, 0)
  14042    S CT=CT+1 ,^TMP($J," RCXM",CT)= "     PAYE R NAME/ID"
  14043   "RTN","RCD PEM1",154, 0)
  14044    S CT=CT+1 ,Q="",$P(Q ,"=",79)=" ",^TMP($J, "RCXM",CT) =Q
  14045   "RTN","RCD PEM1",155, 0)
  14046    S HD=1
  14047   "RTN","RCD PEM1",156, 0)
  14048    Q
  14049   "RTN","RCD PEM1",157, 0)
  14050    ;
  14051   "RTN","RCD PEM2")
  14052   0^50^B2472 76843
  14053   "RTN","RCD PEM2",1,0)
  14054   RCDPEM2 ;A LB/TMK/PJH  - MANUAL  ERA AND EF T MATCHING  ;Jun 11,  2014@13:24 :36
  14055   "RTN","RCD PEM2",2,0)
  14056    ;;4.5;Acc ounts Rece ivable;**1 73,208,276 ,284,293,2 98,303,304 ,321**;Mar  20, 1995; Build 46
  14057   "RTN","RCD PEM2",3,0)
  14058    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  14059   "RTN","RCD PEM2",4,0)
  14060    Q
  14061   "RTN","RCD PEM2",5,0)
  14062    ;
  14063   "RTN","RCD PEM2",6,0)
  14064    ; PRCA*4. 5*303 - Ma nually Mat ch EFT fro m Worklist  screen
  14065   "RTN","RCD PEM2",7,0)
  14066   MATCHWL ;  Manually ' match' ERA  to an EFT  that orig inates fro m [RCDPE W ORKLIST ER A LIST]
  14067   "RTN","RCD PEM2",8,0)
  14068    N DA,DIC, DIE,DIR,DR ,DTRNG,DTO UT,DUOUT,E ND,RCEFT,R CERA,RCMBG ,RCMATCH,R CNAME,RCQU IT,START,X ,Y
  14069   "RTN","RCD PEM2",9,0)
  14070    D FULL^VA LM1
  14071   "RTN","RCD PEM2",10,0 )
  14072    ;
  14073   "RTN","RCD PEM2",11,0 )
  14074    ; PRCA*4. 5*303 move d code out  because t his routin e grew too  large
  14075   "RTN","RCD PEM2",12,0 )
  14076    I $$ML0^R CDPRU() G  MWQ ; if t rue then q uit, othew ise contin ue
  14077   "RTN","RCD PEM2",13,0 )
  14078    ;
  14079   "RTN","RCD PEM2",14,0 )
  14080   ML1 ; Sele ct EFT to  Match to t his ERA
  14081   "RTN","RCD PEM2",15,0 )
  14082    S DIR("A" )="SELECT  THE UNMATC HED EFT TO  MATCH TO  AN ERA: "
  14083   "RTN","RCD PEM2",16,0 )
  14084    ;
  14085   "RTN","RCD PEM2",17,0 )
  14086    ; See com ment in Ta g M1 for P RCA*4.5*29 3.
  14087   "RTN","RCD PEM2",18,0 )
  14088    S DIR(0)= "PAO^RCY(3 44.31,:AEM Q",DIR("S" )="I ('$P( ^(0),U,8)) &($P($G(^( 0)),U,7))& ('$P($G(^( 3)),U))"
  14089   "RTN","RCD PEM2",19,0 )
  14090    I $G(DTRN G) S DIR(" S")=DIR("S ")_"&'($P( $G(^(0)),U ,13)<START )&'($P($G( ^(0)),U,13 )>END)"
  14091   "RTN","RCD PEM2",20,0 )
  14092    ; ** end  PRCA*4.5*2 93
  14093   "RTN","RCD PEM2",21,0 )
  14094    ;
  14095   "RTN","RCD PEM2",22,0 )
  14096    W ! D ^DI R K DIR
  14097   "RTN","RCD PEM2",23,0 )
  14098    I $D(DUOU T)!$D(DTOU T)!(Y<0) G  MWQ
  14099   "RTN","RCD PEM2",24,0 )
  14100    S RCEFT=+ Y,RCEFT(0) =$G(^RCY(3 44.31,+Y,0 ))
  14101   "RTN","RCD PEM2",25,0 )
  14102    W !
  14103   "RTN","RCD PEM2",26,0 )
  14104    S DIC="^R CY(344.31, ",DR="0",D A=RCEFT D  EN^DIQ
  14105   "RTN","RCD PEM2",27,0 )
  14106    W !
  14107   "RTN","RCD PEM2",28,0 )
  14108    S DIR("A" )="ARE YOU  SURE THIS  IS THE EF T YOU WANT  TO MATCH? : ",DIR(0) ="YA",DIR( "B")="YES"  D ^DIR K  DIR
  14109   "RTN","RCD PEM2",29,0 )
  14110    I $D(DUOU T)!$D(DTOU T) G MWQ
  14111   "RTN","RCD PEM2",30,0 )
  14112    I Y'=1 G  ML1
  14113   "RTN","RCD PEM2",31,0 )
  14114    ;
  14115   "RTN","RCD PEM2",32,0 )
  14116    D M12A ;  Go to the  Manual mat ch, we hav e the ERA  and EFT
  14117   "RTN","RCD PEM2",33,0 )
  14118    ;
  14119   "RTN","RCD PEM2",34,0 )
  14120   MWQ ; Quit  back to t he worklis t VALMBCK  will be ki lled by Li st Manager .
  14121   "RTN","RCD PEM2",35,0 )
  14122    D INIT^RC DPEWL7 ; R ebuild the  screen be cause we m ay have ch anged it.
  14123   "RTN","RCD PEM2",36,0 )
  14124    S VALMBCK ="R",VALMB G=RCMBG
  14125   "RTN","RCD PEM2",37,0 )
  14126    Q
  14127   "RTN","RCD PEM2",38,0 )
  14128    ;
  14129   "RTN","RCD PEM2",39,0 )
  14130   MATCH1 ; M anually 'm atch' an E RA to an E FT
  14131   "RTN","RCD PEM2",40,0 )
  14132    N DA,DIC, DIE,DIR,DR ,DTRNG,DTO UT,DUOUT,E ND,RCEFT,R CERA,RCMAT CH,RCNAME, RCQUIT,STA RT,X,Y,RCM TFLG
  14133   "RTN","RCD PEM2",41,0 )
  14134    W !,"THIS  OPTION WI LL ALLOW Y OU TO MANU ALLY MATCH  AN EFT DE TAIL RECOR D",!,"WITH  AN ERA RE CORD."
  14135   "RTN","RCD PEM2",42,0 )
  14136    ; PRCA*4. 5*298 - Ad d ability  to specify  a date ra nge
  14137   "RTN","RCD PEM2",43,0 )
  14138    S DIR("A" )="Select  by date Ra nge? (Y/N)  ",DIR(0)= "YA",DIR(" B")="NO" D  ^DIR K DI R
  14139   "RTN","RCD PEM2",44,0 )
  14140    I $D(DUOU T)!$D(DTOU T) G M1Q
  14141   "RTN","RCD PEM2",45,0 )
  14142    I Y<1 G M 1
  14143   "RTN","RCD PEM2",46,0 )
  14144    S DTRNG=Y   ; flag i ndicating  date range  selected
  14145   "RTN","RCD PEM2",47,0 )
  14146    K DIR S D IR("?")="E nter the e arliest da te for the  selection  range."
  14147   "RTN","RCD PEM2",48,0 )
  14148    ; value i n DIR(0) f or %DT = A PE: ask da te, past a ssumed, ec ho answer
  14149   "RTN","RCD PEM2",49,0 )
  14150    S DIR(0)= "DAO^:"_DT _":APE",DI R("A")="St art Date:  " D ^DIR K  DIR
  14151   "RTN","RCD PEM2",50,0 )
  14152    I $D(DTOU T)!$D(DUOU T)!(Y="")  G M1Q
  14153   "RTN","RCD PEM2",51,0 )
  14154    S START=Y  K DIR,X,Y
  14155   "RTN","RCD PEM2",52,0 )
  14156    S DIR("?" )="Enter t he latest  date for t he selecti on range."
  14157   "RTN","RCD PEM2",53,0 )
  14158    S DIR(0)= "DAO^"_STA RT_":"_DT_ ":APE",DIR ("A")="End  Date: ",D IR("B")=$$ FMTE^XLFDT (DT)
  14159   "RTN","RCD PEM2",54,0 )
  14160    D ^DIR K  DIR
  14161   "RTN","RCD PEM2",55,0 )
  14162    I $D(DTOU T)!$D(DUOU T)!(Y="")  G M1Q
  14163   "RTN","RCD PEM2",56,0 )
  14164    S END=Y
  14165   "RTN","RCD PEM2",57,0 )
  14166    ;
  14167   "RTN","RCD PEM2",58,0 )
  14168   M1 ; come  here if no  date rang e slection  
  14169   "RTN","RCD PEM2",59,0 )
  14170    S DIR("A" )="SELECT  THE UNMATC HED EFT TO  MATCH TO  AN ERA: "
  14171   "RTN","RCD PEM2",60,0 )
  14172    ;
  14173   "RTN","RCD PEM2",61,0 )
  14174    ; ** star t PRCA*4.5 *293 Add e xtra check s to filte r out EFTs  that have  
  14175   "RTN","RCD PEM2",62,0 )
  14176    ;      a  payment am ount of ze ro or EFTs  that have  been remo ved.
  14177   "RTN","RCD PEM2",63,0 )
  14178    ;      On ly UNMATCH ED EFTs wi th payment  amt >0 an d not remo ved should
  14179   "RTN","RCD PEM2",64,0 )
  14180    ;      be  selectabl e by the u ser.
  14181   "RTN","RCD PEM2",65,0 )
  14182    ;
  14183   "RTN","RCD PEM2",66,0 )
  14184    S DIR(0)= "PAO^RCY(3 44.31,:AEM Q",DIR("S" )="I ('$P( ^(0),U,8)) &($P($G(^( 0)),U,7))& ('$P($G(^( 3)),U))"
  14185   "RTN","RCD PEM2",67,0 )
  14186    I $G(DTRN G) S DIR(" S")=DIR("S ")_"&'($P( $G(^(0)),U ,13)<START )&'($P($G( ^(0)),U,13 )>END)"
  14187   "RTN","RCD PEM2",68,0 )
  14188    ; ** end  PRCA*4.5*2 93
  14189   "RTN","RCD PEM2",69,0 )
  14190    ;
  14191   "RTN","RCD PEM2",70,0 )
  14192    W ! D ^DI R K DIR
  14193   "RTN","RCD PEM2",71,0 )
  14194    I $D(DUOU T)!$D(DTOU T)!(Y<0) G  M1Q
  14195   "RTN","RCD PEM2",72,0 )
  14196    S RCEFT=+ Y,RCEFT(0) =$G(^RCY(3 44.31,+Y,0 ))
  14197   "RTN","RCD PEM2",73,0 )
  14198    W !
  14199   "RTN","RCD PEM2",74,0 )
  14200    S DIC="^R CY(344.31, ",DR="0",D A=RCEFT D  EN^DIQ
  14201   "RTN","RCD PEM2",75,0 )
  14202    W !
  14203   "RTN","RCD PEM2",76,0 )
  14204    S DIR("A" )="ARE YOU  SURE THIS  IS THE EF T YOU WANT  TO MATCH? : ",DIR(0) ="YA",DIR( "B")="YES"  D ^DIR K  DIR
  14205   "RTN","RCD PEM2",77,0 )
  14206    I $D(DUOU T)!$D(DTOU T) G M1Q
  14207   "RTN","RCD PEM2",78,0 )
  14208    I Y'=1 G  M1
  14209   "RTN","RCD PEM2",79,0 )
  14210   M12 S DIR( "A")="SELE CT THE UNM ATCHED ERA  TO MATCH  TO EFT #"_ RCEFT_": "
  14211   "RTN","RCD PEM2",80,0 )
  14212    S DIR(0)= "PAO^RCY(3 44.4,:AEMQ ",DIR("S") ="I '$P(^( 0),U,9),'$ P(^(0),U,8 )"
  14213   "RTN","RCD PEM2",81,0 )
  14214    W ! D ^DI R K DIR
  14215   "RTN","RCD PEM2",82,0 )
  14216    I $D(DUOU T)!$D(DTOU T)!(Y<0) G  M1Q
  14217   "RTN","RCD PEM2",83,0 )
  14218    S RCERA=+ Y,RCERA(0) =$G(^RCY(3 44.4,+Y,0) )
  14219   "RTN","RCD PEM2",84,0 )
  14220    W !
  14221   "RTN","RCD PEM2",85,0 )
  14222    S DIC="^R CY(344.4," ,DR="0",DA =RCERA D E N^DIQ
  14223   "RTN","RCD PEM2",86,0 )
  14224    W !
  14225   "RTN","RCD PEM2",87,0 )
  14226    S DIR("A" )="ARE YOU  SURE THIS  IS THE CO RRECT ERA  TO MATCH T O?: ",DIR( 0)="YA",DI R("B")="YE S" D ^DIR  K DIR
  14227   "RTN","RCD PEM2",88,0 )
  14228    I $D(DUOU T)!$D(DTOU T) G M1Q
  14229   "RTN","RCD PEM2",89,0 )
  14230    I Y'=1 G  M12
  14231   "RTN","RCD PEM2",90,0 )
  14232    ;
  14233   "RTN","RCD PEM2",91,0 )
  14234   M12A ; PRC A*4.5*303  - MATCH WL  jumps her e to compl ete the ma nual match
  14235   "RTN","RCD PEM2",92,0 )
  14236    S RCMATCH =(+$P(RCER A(0),U,5)= +$P(RCEFT( 0),U,7))
  14237   "RTN","RCD PEM2",93,0 )
  14238    S RCNAME= ($P(RCERA( 0),U,6)=$P (RCEFT(0), U,2))
  14239   "RTN","RCD PEM2",94,0 )
  14240    I 'RCMATC H!'RCNAME  D  G:RCQUI T M1Q
  14241   "RTN","RCD PEM2",95,0 )
  14242    . N Z
  14243   "RTN","RCD PEM2",96,0 )
  14244    . S RCQUI T=0,Z=1
  14245   "RTN","RCD PEM2",97,0 )
  14246    . S DIR(" A",1)="*** WARNING*** "
  14247   "RTN","RCD PEM2",98,0 )
  14248    . I 'RCNA ME S Z=Z+1 ,DIR("A",Z )=$J("",3) _"> The pa yer names  on these t wo records  do not ag ree"
  14249   "RTN","RCD PEM2",99,0 )
  14250    . I 'RCMA TCH S Z=Z+ 1,DIR("A", Z)=$J("",3 )_"> The a mount of p ayment on  these two  records do  not agree "
  14251   "RTN","RCD PEM2",100, 0)
  14252    . S DIR(0 )="YA",DIR ("B")="NO" ,DIR("A")= "ARE YOU S URE YOU WA NT TO MATC H THESE 2  RECORDS?:  " W ! D ^D IR K DIR
  14253   "RTN","RCD PEM2",101, 0)
  14254    . I $S($D (DUOUT)!$D (DTOUT):1, Y'=1:1,1:0 ) S RCQUIT =1 Q
  14255   "RTN","RCD PEM2",102, 0)
  14256    S DIE="^R CY(344.4," ,DR=".09// //1",DA=RC ERA D ^DIE
  14257   "RTN","RCD PEM2",103, 0)
  14258    I '$D(Y)  S DIE="^RC Y(344.31," ,DR=".08// //1;.1//// "_RCERA,DA =RCEFT D ^ DIE
  14259   "RTN","RCD PEM2",104, 0)
  14260    S RCMTFLG =$S('$D(Y) :1,1:0)
  14261   "RTN","RCD PEM2",105, 0)
  14262    W !,"EFT  #"_RCEFT_"  WAS "_$S( RCMTFLG:"S UCCESSFULL Y",1:"NOT" )_" MATCHE D TO ERA # "_RCERA
  14263   "RTN","RCD PEM2",106, 0)
  14264    I 'RCMTFL G S DIR(0) ="E" D ^DI R K DIR G  M1Q
  14265   "RTN","RCD PEM2",107, 0)
  14266    ;PRCA*4.5 *304 add a bility to  use auto-p osting for  a manuall y matched  item
  14267   "RTN","RCD PEM2",108, 0)
  14268    ;  Only i f the amou nt of paym ents match .
  14269   "RTN","RCD PEM2",109, 0)
  14270    I 'RCMATC H D  G M1Q     ;if pa yment amou nts don't  match, don 't allow f or auto-po sting.
  14271   "RTN","RCD PEM2",110, 0)
  14272    . W !,"ER A/EFT bala nces do no t match -  cannot Mar k for Auto -Post. Pre ss any key ." S DIR(0 )="E" D ^D IR K DIR
  14273   "RTN","RCD PEM2",111, 0)
  14274    W !
  14275   "RTN","RCD PEM2",112, 0)
  14276    K DIR
  14277   "RTN","RCD PEM2",113, 0)
  14278    S DIR("A" )="Do you  wish to ma rk this en try for Au to Posting  (Y/N)? "
  14279   "RTN","RCD PEM2",114, 0)
  14280    S DIR(0)= "YA"
  14281   "RTN","RCD PEM2",115, 0)
  14282    D ^DIR
  14283   "RTN","RCD PEM2",116, 0)
  14284    I 'Y K DI R S DIR(0) ="E" D ^DI R G M1Q
  14285   "RTN","RCD PEM2",117, 0)
  14286    N AUTOPOS T
  14287   "RTN","RCD PEM2",118, 0)
  14288    S AUTOPOS T=$$AUTOCH K2^RCDPEAP 1(RCERA,1)  ; Allow a uto-post f or CHK and  ACH type  ERA - PRCA *4.5*321
  14289   "RTN","RCD PEM2",119, 0)
  14290    I AUTOPOS T D
  14291   "RTN","RCD PEM2",120, 0)
  14292    . D SETST A^RCDPEAP( RCERA,0,"M anual Matc h: Marked  as Auto-Po st Candida te")
  14293   "RTN","RCD PEM2",121, 0)
  14294    . W !,"ER A has been  successfu lly Marked  as an Aut o-Post CAN DIDATE"
  14295   "RTN","RCD PEM2",122, 0)
  14296    I 'AUTOPO ST D
  14297   "RTN","RCD PEM2",123, 0)
  14298    . D AUDIT LOG^RCDPEA P(RCERA,"" ,"Manual M atch: Not  Marked as  Auto-Post  Candidate- "_$P(AUTOP OST,U,2))
  14299   "RTN","RCD PEM2",124, 0)
  14300    . W !,"ER A was NOT  Marked as  an Auto-Po st CANDIDA TE - ",$P( AUTOPOST,U ,2)
  14301   "RTN","RCD PEM2",125, 0)
  14302    K DIR S D IR(0)="E"  D ^DIR
  14303   "RTN","RCD PEM2",126, 0)
  14304   M1Q Q
  14305   "RTN","RCD PEM2",127, 0)
  14306    ;
  14307   "RTN","RCD PEM2",128, 0)
  14308   MATCH2 ; M anually 'm atch' a 0- balance EF T to a pap er EOB
  14309   "RTN","RCD PEM2",129, 0)
  14310    N DUOUT,D TOUT,DA,DR ,DIE,DIC,D IR,X,Y,RCE FT,RCRCPT
  14311   "RTN","RCD PEM2",130, 0)
  14312    W !,"THIS  OPTION WI LL ALLOW Y OU TO MANU ALLY MARK  A 0-BALANC E EFT DETA IL RECORD" ,!,"AS MAT CHED TO A  PAPER EOB"
  14313   "RTN","RCD PEM2",131, 0)
  14314   M2 S DIR(" A")="SELEC T THE UNMA TCHED 0-BA LANCE EFT  TO MARK AS  MATCHED T O PAPER EO B: "
  14315   "RTN","RCD PEM2",132, 0)
  14316    S DIR(0)= "PAO^RCY(3 44.31,:AEM Q",DIR("S" )="I '$P(^ (0),U,8),' $P(^(0),U, 7)"
  14317   "RTN","RCD PEM2",133, 0)
  14318    W ! D ^DI R K DIR
  14319   "RTN","RCD PEM2",134, 0)
  14320    I $D(DUOU T)!$D(DTOU T)!(Y'>0)  G M2Q
  14321   "RTN","RCD PEM2",135, 0)
  14322    S RCEFT=+ Y
  14323   "RTN","RCD PEM2",136, 0)
  14324    W !
  14325   "RTN","RCD PEM2",137, 0)
  14326    S DIC="^R CY(344.31, ",DR="0",D A=RCEFT D  EN^DIQ
  14327   "RTN","RCD PEM2",138, 0)
  14328    W !
  14329   "RTN","RCD PEM2",139, 0)
  14330    S DIR("A" )="ARE YOU  SURE THIS  IS THE EF T YOU WANT  TO MARK A S MATCHED? : ",DIR(0) ="YA",DIR( "B")="YES"  D ^DIR K  DIR
  14331   "RTN","RCD PEM2",140, 0)
  14332    I $D(DUOU T)!$D(DTOU T) G M2Q
  14333   "RTN","RCD PEM2",141, 0)
  14334    I Y'=1 G  M2
  14335   "RTN","RCD PEM2",142, 0)
  14336    S DIE="^R CY(344.31, ",DR=".08/ ///2",DA=R CEFT D ^DI E
  14337   "RTN","RCD PEM2",143, 0)
  14338    S DIR(0)= "EA",DIR(" A")="EFT # "_RCEFT_"  WAS "_$S(' $D(Y):"SUC CESSFULLY" ,1:"NOT")_ " MARKED A S MATCHED  TO PAPER E OB" D ^DIR  K DIR
  14339   "RTN","RCD PEM2",144, 0)
  14340   M2Q Q
  14341   "RTN","RCD PEM2",145, 0)
  14342    ;
  14343   "RTN","RCD PEM2",146, 0)
  14344   MANTR ; Ma rk an EFT  detail rec ord as 'TR ' posted m anually
  14345   "RTN","RCD PEM2",147, 0)
  14346    N DA,DR,D IC,DIE,DIR ,X,Y,RCEFT ,DUOUT,DTO UT,RCZ0,RC TR,RCHOW
  14347   "RTN","RCD PEM2",148, 0)
  14348    ; EFT det ail cannot  be associ ated with  a receipt  or TR docu ment
  14349   "RTN","RCD PEM2",149, 0)
  14350    ;
  14351   "RTN","RCD PEM2",150, 0)
  14352    W !,"**** *",!," YOU  SHOULD ON LY USE THI S OPTION I F YOU HAVE  AN EFT DE TAIL RECOR D ON YOUR" ,!," UNAPP LIED DEPOS IT REPORT  WHOSE DETA IL WAS ENT ERED ON LI NE VIA A T R DOCUMENT ",!,"***** ",!
  14353   "RTN","RCD PEM2",151, 0)
  14354    S DIC(0)= "AEMQ",DIC ("S")="I $ P(^(0),U,1 6)="""",$P (^(0),U,11 )",DIC("A" )="SELECT  THE EFT DE TAIL WHOSE  'TR' DOC  WAS MANUAL LY ENTERED  ON LINE:  ",DIC="^RC Y(344.31,"
  14355   "RTN","RCD PEM2",152, 0)
  14356    W ! D ^DI C K DIC
  14357   "RTN","RCD PEM2",153, 0)
  14358    I Y'>0 G  MANTRQ
  14359   "RTN","RCD PEM2",154, 0)
  14360    S RCEFT=+ Y,RCZ0=$G( ^RCY(344.3 1,RCEFT,0) )
  14361   "RTN","RCD PEM2",155, 0)
  14362    S DIR(0)= "FA^2:30^K :X'?1""TR" ".E X",DIR ("A")="ENT ER THE TR  DOC # THAT  WAS ENTER ED ON-LINE  FOR THE E FT DETAIL:  "
  14363   "RTN","RCD PEM2",156, 0)
  14364    W ! D ^DI R K DIR
  14365   "RTN","RCD PEM2",157, 0)
  14366    I $D(DTOU T)!$D(DUOU T) G MANTR Q
  14367   "RTN","RCD PEM2",158, 0)
  14368    S RCTR=Y, DR=""
  14369   "RTN","RCD PEM2",159, 0)
  14370    ;
  14371   "RTN","RCD PEM2",160, 0)
  14372    I '$P(RCZ 0,U,8) D   G:RCQUIT M ANTRQ  ;Un matched
  14373   "RTN","RCD PEM2",161, 0)
  14374    . S DIR(0 )="SA^E:EL ECTRONIC E RA;P:PAPER  EOB",DIR( "A")="WAS  THE EFT DE TAIL RECEI VED BY (E) RA or (P)A PER EOB?:  " W ! D ^D IR K DIR
  14375   "RTN","RCD PEM2",162, 0)
  14376    . I $D(DT OUT)!$D(DU OUT) S RCQ UIT=1 Q
  14377   "RTN","RCD PEM2",163, 0)
  14378    . S RCHOW =Y,DR=""
  14379   "RTN","RCD PEM2",164, 0)
  14380    . I RCHOW ="E" D
  14381   "RTN","RCD PEM2",165, 0)
  14382    .. S DR=" ;.09R;.08/ ///1"
  14383   "RTN","RCD PEM2",166, 0)
  14384    . I RCHOW ="P" D
  14385   "RTN","RCD PEM2",167, 0)
  14386    .. S DR=" ;.08////2"
  14387   "RTN","RCD PEM2",168, 0)
  14388    ;
  14389   "RTN","RCD PEM2",169, 0)
  14390    S DIR(0)= "YA",DIR(" B")="NO",D IR("A",1)= "THIS WILL  MARK EFT  DETAIL #:  "_RCEFT_"  AS MANUALL Y POSTED", DIR("A",2) ="  USING  TR DOC: "_ RCTR
  14391   "RTN","RCD PEM2",170, 0)
  14392    S DIR("A" )="ARE YOU  SURE YOU  WANT TO CO NTINUE?: "  W ! D ^DI R K DIR
  14393   "RTN","RCD PEM2",171, 0)
  14394    I Y'=1 D   G MANTRQ
  14395   "RTN","RCD PEM2",172, 0)
  14396    . S DIR(0 )="EA",DIR ("A")="EFT  NOT UPDAT ED - Press  ENTER to  continue:  " W ! D ^D IR K DIR
  14397   "RTN","RCD PEM2",173, 0)
  14398    S DIE="^R CY(344.31, ",DA=RCEFT ,DR=".16R" _DR D ^DIE
  14399   "RTN","RCD PEM2",174, 0)
  14400    I $D(Y) D
  14401   "RTN","RCD PEM2",175, 0)
  14402    . S DIE=" ^RCY(344.3 1,",DA=RCE FT,DR=".16 ///@;.08// /"_$S($P(R CZ0,U,8)'= "":$P(RCZ0 ,U,8),1:"@ ") D ^DIE
  14403   "RTN","RCD PEM2",176, 0)
  14404    . S DIR(" A")="EFT N OT UPDATED  - Press E NTER to co ntinue: "
  14405   "RTN","RCD PEM2",177, 0)
  14406    E  D
  14407   "RTN","RCD PEM2",178, 0)
  14408    . S DIR(" A")="STATU S UPDATED  FOR EFT DE TAIL #: "_ RCEFT_" -  Press ENTE R to conti nue: "
  14409   "RTN","RCD PEM2",179, 0)
  14410    S DIR(0)= "EA"
  14411   "RTN","RCD PEM2",180, 0)
  14412    W ! D ^DI R K DIR
  14413   "RTN","RCD PEM2",181, 0)
  14414    ;
  14415   "RTN","RCD PEM2",182, 0)
  14416   MANTRQ Q
  14417   "RTN","RCD PEM2",183, 0)
  14418    ;
  14419   "RTN","RCD PEM2",184, 0)
  14420   CHK() ; Fu nction ret urns the i en of CHEC K/MO payme nt type
  14421   "RTN","RCD PEM2",185, 0)
  14422    Q +$O(^RC (341.1,"AC ",4,0))
  14423   "RTN","RCD PEM2",186, 0)
  14424    ;
  14425   "RTN","RCD PEM2",187, 0)
  14426    ;; Begin  PRCA*4.5*2 76 - PJH
  14427   "RTN","RCD PEM2",188, 0)
  14428   POSTED ;
  14429   "RTN","RCD PEM2",189, 0)
  14430    N DIR,X,Y
  14431   "RTN","RCD PEM2",190, 0)
  14432    S DIR("A" )="Select  type of re ceipt to E RA link"
  14433   "RTN","RCD PEM2",191, 0)
  14434    S DIR("B" )="M"
  14435   "RTN","RCD PEM2",192, 0)
  14436    S DIR(0)= "S^M:Manua lly select  receipt t o post;"
  14437   "RTN","RCD PEM2",193, 0)
  14438    S DIR(0)= DIR(0)_"A: Automatic  search for  receipt t o post"
  14439   "RTN","RCD PEM2",194, 0)
  14440    D ^DIR K  DIR
  14441   "RTN","RCD PEM2",195, 0)
  14442    I Y="M" D  MANUAL Q
  14443   "RTN","RCD PEM2",196, 0)
  14444    I Y="A" D  AUTO
  14445   "RTN","RCD PEM2",197, 0)
  14446    Q
  14447   "RTN","RCD PEM2",198, 0)
  14448    ;
  14449   "RTN","RCD PEM2",199, 0)
  14450   MANUAL ; M ark an ERA  as posted  when the  data was p reviously  posted usi ng
  14451   "RTN","RCD PEM2",200, 0)
  14452    ; paper E OB informa tion
  14453   "RTN","RCD PEM2",201, 0)
  14454    N DIC,DIE ,DIR,DA,DR ,ERA,RCPT, X,Y,%
  14455   "RTN","RCD PEM2",202, 0)
  14456    ; Must be  unmatched  or matche d to paper  check, mu st be acce pted by FM S, must no t be poste d yet
  14457   "RTN","RCD PEM2",203, 0)
  14458    W !!,"THI S OPTION I S USED WHE N YOU HAVE  POSTED AN  ERA PAID  WITH A PAP ER CHECK", !,"BY USIN G THE PAPE R EOB AND  YOU DID NO T REFERENC E THE ERA  IN THE REC EIPT",!!
  14459   "RTN","RCD PEM2",204, 0)
  14460   MAN1 S DIC ("S")="I " "02""[+$P( ^(0),U,9), $P(^(0),U, 14)=0",DIC ="^RCY(344 .4,",DIC(0 )="AEMQ"
  14461   "RTN","RCD PEM2",205, 0)
  14462    D ^DIC K  DIC
  14463   "RTN","RCD PEM2",206, 0)
  14464    ;
  14465   "RTN","RCD PEM2",207, 0)
  14466    I Y'>0 G  MANUALQ
  14467   "RTN","RCD PEM2",208, 0)
  14468    ;
  14469   "RTN","RCD PEM2",209, 0)
  14470    ;Check if  ERA is al ready link ed to a re ceipt
  14471   "RTN","RCD PEM2",210, 0)
  14472    I $$RCHEC K(+Y) G MA N1
  14473   "RTN","RCD PEM2",211, 0)
  14474    S ERA=+Y
  14475   "RTN","RCD PEM2",212, 0)
  14476    ;
  14477   "RTN","RCD PEM2",213, 0)
  14478    S DIC="^R CY(344,",D IC(0)="AEM Q",DIC("A" )="RECEIPT : ",DIC("S ")="I $$FM S^RCDPEM2( Y,0)"
  14479   "RTN","RCD PEM2",214, 0)
  14480    D ^DIC K  DIC
  14481   "RTN","RCD PEM2",215, 0)
  14482    I Y'>0 G  MANUALQ
  14483   "RTN","RCD PEM2",216, 0)
  14484    S RCPT=+Y
  14485   "RTN","RCD PEM2",217, 0)
  14486    ;
  14487   "RTN","RCD PEM2",218, 0)
  14488    D NOW^%DT C
  14489   "RTN","RCD PEM2",219, 0)
  14490    ;Update R eceipt #,  EFT Match  Status, De tail Post  Status and  Paper EOB
  14491   "RTN","RCD PEM2",220, 0)
  14492    S DIE="^R CY(344.4," ,DR=".08// //"_RCPT_" ;.09////2; .14////2;2 0.03////1" ,DA=ERA
  14493   "RTN","RCD PEM2",221, 0)
  14494    ;Update D ate/Time P osted and  User field s
  14495   "RTN","RCD PEM2",222, 0)
  14496    S DR=DR_" ;7.01///"_ %_";7.02// /"_DUZ
  14497   "RTN","RCD PEM2",223, 0)
  14498    D ^DIE
  14499   "RTN","RCD PEM2",224, 0)
  14500    I '$D(Y)  D
  14501   "RTN","RCD PEM2",225, 0)
  14502    . S DIR(0 )="EA",DIR ("A",1)="E RA HAS BEE N MARKED A S POSTED U SING PAPER  EOB",DIR( "A")="Pres s ENTER to  continue:  " D ^DIR  K DIR
  14503   "RTN","RCD PEM2",226, 0)
  14504    ;
  14505   "RTN","RCD PEM2",227, 0)
  14506   MANUALQ Q
  14507   "RTN","RCD PEM2",228, 0)
  14508    ;
  14509   "RTN","RCD PEM2",229, 0)
  14510    ;VISN 15  software -  created b y Karen Fl ores
  14511   "RTN","RCD PEM2",230, 0)
  14512    ;
  14513   "RTN","RCD PEM2",231, 0)
  14514   AUTO ;Sele ct ERA's f or linking  to receip t
  14515   "RTN","RCD PEM2",232, 0)
  14516    N EXIT
  14517   "RTN","RCD PEM2",233, 0)
  14518    S EXIT=0  F  D LNKER A Q:EXIT
  14519   "RTN","RCD PEM2",234, 0)
  14520    Q
  14521   "RTN","RCD PEM2",235, 0)
  14522    ;
  14523   "RTN","RCD PEM2",236, 0)
  14524   RCHECK(RCS CR) ;Check  if alread y linked t o a receip t
  14525   "RTN","RCD PEM2",237, 0)
  14526    N REC,RNU M,RNAM,AMT
  14527   "RTN","RCD PEM2",238, 0)
  14528    S REC=$G( ^RCY(344.4 ,RCSCR,0)) ,RNUM=$P(R EC,U,8)
  14529   "RTN","RCD PEM2",239, 0)
  14530    ;Ignore c heck if ze ro amount  ERA
  14531   "RTN","RCD PEM2",240, 0)
  14532    Q:'$P(REC ,U,5) 0
  14533   "RTN","RCD PEM2",241, 0)
  14534    ;Check if  already l inked to a  different  receipt
  14535   "RTN","RCD PEM2",242, 0)
  14536    Q:'RNUM 0
  14537   "RTN","RCD PEM2",243, 0)
  14538    S RNAM=$P ($G(^RCY(3 44,RNUM,0) ),U)
  14539   "RTN","RCD PEM2",244, 0)
  14540    W !!,"ERA  ",RCSCR,"  is alread y linked t o receipt  ",RNAM,!
  14541   "RTN","RCD PEM2",245, 0)
  14542    Q 1
  14543   "RTN","RCD PEM2",246, 0)
  14544    ;
  14545   "RTN","RCD PEM2",247, 0)
  14546   LNKERA ;Se lect ERA
  14547   "RTN","RCD PEM2",248, 0)
  14548    N ABORT,D IC,DUOUT,D TOUT,REC,R CSCR,X,Y
  14549   "RTN","RCD PEM2",249, 0)
  14550    ;Must be  unposted a nd either  unmatched  or matched  to paper  check
  14551   "RTN","RCD PEM2",250, 0)
  14552    S DIC("S" )="I ""02" "[+$P(^(0) ,U,9),$P(^ (0),U,14)= 0"
  14553   "RTN","RCD PEM2",251, 0)
  14554    S DIC="^R CY(344.4," ,DIC(0)="A EMQ" W ! D  ^DIC K DI C
  14555   "RTN","RCD PEM2",252, 0)
  14556    S RCSCR=+ Y I RCSCR' >0 S EXIT= 1 Q
  14557   "RTN","RCD PEM2",253, 0)
  14558    ;Check if  already l inked to a  different  receipt
  14559   "RTN","RCD PEM2",254, 0)
  14560    Q:$$RCHEC K(RCSCR)
  14561   "RTN","RCD PEM2",255, 0)
  14562    ;
  14563   "RTN","RCD PEM2",256, 0)
  14564    ;Finds re ceipt auto matically  from AR TR ANSACTION  file #433 
  14565   "RTN","RCD PEM2",257, 0)
  14566    N AMT,ART ,ARTND1,AT TY,BILL,EO B,EOBND,FO UND,RCND,R CSCR1,RECE PT,TAMT
  14567   "RTN","RCD PEM2",258, 0)
  14568    N TRACE
  14569   "RTN","RCD PEM2",259, 0)
  14570    ;Trace# f rom ERA
  14571   "RTN","RCD PEM2",260, 0)
  14572    S TRACE=$ P($G(^RCY( 344.4,RCSC R,0)),U,2)
  14573   "RTN","RCD PEM2",261, 0)
  14574    ;Clear wo rkfile
  14575   "RTN","RCD PEM2",262, 0)
  14576    K ^TMP("R CDPEM2",$J )
  14577   "RTN","RCD PEM2",263, 0)
  14578    ;
  14579   "RTN","RCD PEM2",264, 0)
  14580    S (FOUND, ABORT,RCSC R1)=0
  14581   "RTN","RCD PEM2",265, 0)
  14582    ;Scan cla im lines i n ERA for  non zero b ills
  14583   "RTN","RCD PEM2",266, 0)
  14584    F  S RCSC R1=$O(^RCY (344.4,RCS CR,1,RCSCR 1)) Q:+RCS CR1=0!(FOU ND)  D
  14585   "RTN","RCD PEM2",267, 0)
  14586    .S RCND=$ G(^RCY(344 .4,RCSCR,1 ,RCSCR1,0) )
  14587   "RTN","RCD PEM2",268, 0)
  14588    .;Ignore  bill if AM OUNT PAID  is zero
  14589   "RTN","RCD PEM2",269, 0)
  14590    .S AMT=$P (RCND,"^", 3) Q:+AMT= 0
  14591   "RTN","RCD PEM2",270, 0)
  14592    .;Ignore  if EOB has  no EOB de tail recor d
  14593   "RTN","RCD PEM2",271, 0)
  14594    .S EOB=+$ P(RCND,"^" ,2) Q:'EOB
  14595   "RTN","RCD PEM2",272, 0)
  14596    .;Get EOB  detail re cord
  14597   "RTN","RCD PEM2",273, 0)
  14598    .S EOBND= $G(^IBM(36 1.1,EOB,0) )
  14599   "RTN","RCD PEM2",274, 0)
  14600    .;Extract  Bill numb er from EO B detail
  14601   "RTN","RCD PEM2",275, 0)
  14602    .S BILL=$ P(EOBND,"^ ",1) Q:BIL L=""
  14603   "RTN","RCD PEM2",276, 0)
  14604    .;Ignore  duplicate  bills on E RA
  14605   "RTN","RCD PEM2",277, 0)
  14606    .Q:$D(^TM P("RCDPEM2 ",$J,BILL) )
  14607   "RTN","RCD PEM2",278, 0)
  14608    .S ^TMP(" RCDPEM2",$ J,BILL)=""
  14609   "RTN","RCD PEM2",279, 0)
  14610    .;Search  AR TRANSAC TION file  #433 for t he bill -  newest fir st
  14611   "RTN","RCD PEM2",280, 0)
  14612    .S ART=""
  14613   "RTN","RCD PEM2",281, 0)
  14614    .F  S ART =$O(^PRCA( 433,"C",BI LL,ART),-1 ) Q:+ART=0 !(FOUND)   D
  14615   "RTN","RCD PEM2",282, 0)
  14616    ..S ARTND 1=$G(^PRCA (433,ART,1 ))
  14617   "RTN","RCD PEM2",283, 0)
  14618    ..;Get tr ansaction  type
  14619   "RTN","RCD PEM2",284, 0)
  14620    ..S ATTY= $P(ARTND1, "^",2) Q:' ATTY
  14621   "RTN","RCD PEM2",285, 0)
  14622    ..;Ignore  if not a  payment
  14623   "RTN","RCD PEM2",286, 0)
  14624    ..S ATTY= $P($G(^PRC A(430.3,AT TY,0)),"^" ,1) Q:ATTY '["PAYMENT "
  14625   "RTN","RCD PEM2",287, 0)
  14626    ..;Get re ceipt numb er
  14627   "RTN","RCD PEM2",288, 0)
  14628    ..S RECEP T=$P(ARTND 1,"^",3) Q :RECEPT=""
  14629   "RTN","RCD PEM2",289, 0)
  14630    ..;Ignore  receipt i f status i s not 'ACC EPTED BY F MS'
  14631   "RTN","RCD PEM2",290, 0)
  14632    ..Q:'$$FM S(RECEPT,1 )
  14633   "RTN","RCD PEM2",291, 0)
  14634    ..W !!,"P ATIENT: "_ $$PNM4^RCD PEWL1(RCSC R,RCSCR1)
  14635   "RTN","RCD PEM2",292, 0)
  14636    ..W !,"Bi ll number:  ",$P($G(^ DGCR(399,B ILL,0)),U)
  14637   "RTN","RCD PEM2",293, 0)
  14638    ..W !,"Ch eck #: ",$ $CHQ(RECEP T,BILL)
  14639   "RTN","RCD PEM2",294, 0)
  14640    ..W !,"Tr ace #: ",T RACE
  14641   "RTN","RCD PEM2",295, 0)
  14642    ..W !,"DO S: ",$$FMT E^XLFDT($P ($G(^DGCR( 399,BILL,0 )),U,3))
  14643   "RTN","RCD PEM2",296, 0)
  14644    ..S TAMT= +$P(ARTND1 ,"^",5)
  14645   "RTN","RCD PEM2",297, 0)
  14646    ..W !,"AR  Transacti on amount:  ",TAMT
  14647   "RTN","RCD PEM2",298, 0)
  14648    ..W !,"RE CEIPT#: ", RECEPT
  14649   "RTN","RCD PEM2",299, 0)
  14650    ..W !,"Da te of Rece ipt: ",$$F MTE^XLFDT( $$RCDATE^R CDPRU(RECE PT))
  14651   "RTN","RCD PEM2",300, 0)
  14652    ..W !,"To tal Receip t AMOUNT:  ",$J($$AMT ^RCDPRU(RE CEPT),2,2) ,!
  14653   "RTN","RCD PEM2",301, 0)
  14654    .. ; PRCA *4.5*284 C hange defa ult respon se from YE S to NO
  14655   "RTN","RCD PEM2",302, 0)
  14656    ..S DIR(0 )="Y",DIR( "B")="NO"
  14657   "RTN","RCD PEM2",303, 0)
  14658    ..S DIR(" A")="Link  to update  Remittance  entry # " _RCSCR
  14659   "RTN","RCD PEM2",304, 0)
  14660    ..S DIR(" A")=DIR("A ")_" with  receipt "_ RECEPT
  14661   "RTN","RCD PEM2",305, 0)
  14662    ..D ^DIR  K DIR
  14663   "RTN","RCD PEM2",306, 0)
  14664    ..;Aborte d
  14665   "RTN","RCD PEM2",307, 0)
  14666    ..I $D(DU OUT)!$D(DT OUT) S ABO RT=1,FOUND =1 Q
  14667   "RTN","RCD PEM2",308, 0)
  14668    ..;Attemp t to updat e ERA - fi nish if su ccessful
  14669   "RTN","RCD PEM2",309, 0)
  14670    ..I +Y>0  D UPDERA(R CSCR,RECEP T,.FOUND)
  14671   "RTN","RCD PEM2",310, 0)
  14672    ;Update f ailed
  14673   "RTN","RCD PEM2",311, 0)
  14674    I FOUND=0  W !!,"No  matching p ayment tra nsactions  found for  this ERA"
  14675   "RTN","RCD PEM2",312, 0)
  14676    ;Clear wo rkfile
  14677   "RTN","RCD PEM2",313, 0)
  14678    K ^TMP("R CDPEM2",$J )
  14679   "RTN","RCD PEM2",314, 0)
  14680    Q
  14681   "RTN","RCD PEM2",315, 0)
  14682    ;
  14683   "RTN","RCD PEM2",316, 0)
  14684    ; Moved t o RCDPRU b ecause of  size issue s PRCA*4.5 *303
  14685   "RTN","RCD PEM2",317, 0)
  14686   UPDERA(DA, RECEPT,FOU ND) ;Mark  ERA as pos ted to pap er EOB
  14687   "RTN","RCD PEM2",318, 0)
  14688    D UPDERA^ RCDPRU(DA, RECEPT,.FO UND)
  14689   "RTN","RCD PEM2",319, 0)
  14690    Q FOUND
  14691   "RTN","RCD PEM2",320, 0)
  14692    ;
  14693   "RTN","RCD PEM2",321, 0)
  14694    ;Check FM S status
  14695   "RTN","RCD PEM2",322, 0)
  14696   FMS(RECEPT ,FLG) ;
  14697   "RTN","RCD PEM2",323, 0)
  14698    ; FLG = 1  if RECEPT  contains  receipt nu mber
  14699   "RTN","RCD PEM2",324, 0)
  14700    ; FLG = 0  if RECEPT  contains  ien of the  receipt
  14701   "RTN","RCD PEM2",325, 0)
  14702    N FMSDOCN O,RCRECTDA ,RES
  14703   "RTN","RCD PEM2",326, 0)
  14704    S RES=0 I  $G(RECEPT )="" G FMS X
  14705   "RTN","RCD PEM2",327, 0)
  14706    ;Get rece ipt IEN
  14707   "RTN","RCD PEM2",328, 0)
  14708    I 'FLG S  RCRECTDA=R ECEPT
  14709   "RTN","RCD PEM2",329, 0)
  14710    I FLG S R CRECTDA=$O (^RCY(344, "B",RECEPT ,0))
  14711   "RTN","RCD PEM2",330, 0)
  14712    I 'RCRECT DA G FMSX
  14713   "RTN","RCD PEM2",331, 0)
  14714    ;Get FMS  document n umber
  14715   "RTN","RCD PEM2",332, 0)
  14716    S FMSDOCN O=$$FMSSTA T^RCDPUREC (RCRECTDA)
  14717   "RTN","RCD PEM2",333, 0)
  14718    ;Ignore i f not acce pted
  14719   "RTN","RCD PEM2",334, 0)
  14720    I $P(FMSD OCNO,U,2)' ="ACCEPTED  BY FMS" G  FMSX
  14721   "RTN","RCD PEM2",335, 0)
  14722    ;Otherwis e can be l inked
  14723   "RTN","RCD PEM2",336, 0)
  14724    S RES=1
  14725   "RTN","RCD PEM2",337, 0)
  14726   FMSX ;
  14727   "RTN","RCD PEM2",338, 0)
  14728    Q RES
  14729   "RTN","RCD PEM2",339, 0)
  14730    ;
  14731   "RTN","RCD PEM2",340, 0)
  14732   CHQ(RECEPT ,BILL) ;Ge t check nu mber for t his bill
  14733   "RTN","RCD PEM2",341, 0)
  14734    N RCRECTD A,RCTRAN,R CCHK,PATBI LL
  14735   "RTN","RCD PEM2",342, 0)
  14736    ;Get rece ipt IEN
  14737   "RTN","RCD PEM2",343, 0)
  14738    S RCRECTD A=$O(^RCY( 344,"B",RE CEPT,0)) Q :'RCRECTDA  ""
  14739   "RTN","RCD PEM2",344, 0)
  14740    ;Scan Rec eipt looki ng for thi s bill IEN
  14741   "RTN","RCD PEM2",345, 0)
  14742    S RCTRAN= 0,RCCHK=""
  14743   "RTN","RCD PEM2",346, 0)
  14744    F  S RCTR AN=$O(^RCY (344,RCREC TDA,1,RCTR AN)) Q:'RC TRAN  D  Q :RCCHK]""
  14745   "RTN","RCD PEM2",347, 0)
  14746    .;Check f or match o n bill IEN
  14747   "RTN","RCD PEM2",348, 0)
  14748    .S PATBIL L=$P($G(^R CY(344,RCR ECTDA,1,RC TRAN,0)),U ,3)
  14749   "RTN","RCD PEM2",349, 0)
  14750    .;Ignore  Patient po inters or  null field
  14751   "RTN","RCD PEM2",350, 0)
  14752    .Q:$P(PAT BILL,";",2 )'="PRCA(4 30,"
  14753   "RTN","RCD PEM2",351, 0)
  14754    .;Compare  bill IEN3 99 to IEN4 30
  14755   "RTN","RCD PEM2",352, 0)
  14756    .Q:$P(PAT BILL,";")' =BILL
  14757   "RTN","RCD PEM2",353, 0)
  14758    .;Get che ck number  for this l ine
  14759   "RTN","RCD PEM2",354, 0)
  14760    .S RCCHK= $P($G(^RCY (344,RCREC TDA,1,RCTR AN,0)),U,7 )
  14761   "RTN","RCD PEM2",355, 0)
  14762    Q RCCHK
  14763   "RTN","RCD PEM2",356, 0)
  14764    ;
  14765   "RTN","RCD PEM2",357, 0)
  14766    ;; End PR CA*4.5*276  - PJH
  14767   "RTN","RCD PEM2",358, 0)
  14768    ;
  14769   "RTN","RCD PEM2",359, 0)
  14770   MATCH3 ; M anually 'm atch' a 0- balance ER A that has  no check  or EFT
  14771   "RTN","RCD PEM2",360, 0)
  14772    N DUOUT,D TOUT,DA,DR ,DIE,DIC,D IR,X,Y,RCE RA,RCRCPT
  14773   "RTN","RCD PEM2",361, 0)
  14774    W !,"THIS  OPTION WI LL ALLOW Y OU TO MANU ALLY MARK  A 0-BALANC E ERA WITH  NO",!,"CH ECK OR EFT  AS 'MATCH -0 PAYMENT ' TO REMOV E IT FROM  THE ERA AG ING REPORT "
  14775   "RTN","RCD PEM2",362, 0)
  14776   M3 S DIR(" A")="SELEC T THE UNMA TCHED 0-BA LANCE ERA  TO MARK AS  MATCHED:  "
  14777   "RTN","RCD PEM2",363, 0)
  14778    S DIR(0)= "PAO^RCY(3 44.4,:AEMQ ",DIR("S") ="I '$P(^( 0),U,9),'$ P(^(0),U,5 )"
  14779   "RTN","RCD PEM2",364, 0)
  14780    W ! D ^DI R K DIR
  14781   "RTN","RCD PEM2",365, 0)
  14782    I $D(DUOU T)!$D(DTOU T)!(Y'>0)  G M3Q
  14783   "RTN","RCD PEM2",366, 0)
  14784    S RCERA=+ Y
  14785   "RTN","RCD PEM2",367, 0)
  14786    W !
  14787   "RTN","RCD PEM2",368, 0)
  14788    S DIC="^R CY(344.4," ,DR="0",DA =RCERA D E N^DIQ
  14789   "RTN","RCD PEM2",369, 0)
  14790    W !
  14791   "RTN","RCD PEM2",370, 0)
  14792    S DIR("A" )="ARE YOU  SURE THIS  IS THE ER A YOU WANT  TO MARK A S MATCH-0  PAYMENT? ( Y/N) ",DIR (0)="YA",D IR("B")="Y ES" D ^DIR  K DIR
  14793   "RTN","RCD PEM2",371, 0)
  14794    I $D(DUOU T)!$D(DTOU T) G M3Q
  14795   "RTN","RCD PEM2",372, 0)
  14796    I Y'=1 G  M3
  14797   "RTN","RCD PEM2",373, 0)
  14798    S DIE="^R CY(344.4," ,DR=".09// //3",DA=RC ERA D ^DIE
  14799   "RTN","RCD PEM2",374, 0)
  14800    S DIR(0)= "EA",DIR(" A")="ERA # "_RCERA_"  WAS "_$S(' $D(Y):"SUC CESSFULLY" ,1:"NOT")_ " MARKED A S MATCH-0  PAYMENT" D  ^DIR K DI R
  14801   "RTN","RCD PEM2",375, 0)
  14802   M3Q Q
  14803   "RTN","RCD PEM2",376, 0)
  14804    ;
  14805   "RTN","RCD PEM2",377, 0)
  14806   UNMATCH ;  Used to 'u nmatch' an  ERA match ed in erro r
  14807   "RTN","RCD PEM2",378, 0)
  14808    N X,Y,DIR ,DIC,DIE,D IK,DA,DR,R CWL,RCEFT, RCQUIT,AUT OPOST
  14809   "RTN","RCD PEM2",379, 0)
  14810    S DIC(0)= "AEMQ",DIC ="^RCY(344 .4,",DIC(" S")="I '$P (^(0),U,8) ,$S('$P(^( 0),U,14):1 ,1:$P(^(0) ,U,9)=3),$ P(^(0),U,9 )" D ^DIC  K DIC
  14811   "RTN","RCD PEM2",380, 0)
  14812    Q:Y'>0
  14813   "RTN","RCD PEM2",381, 0)
  14814    S RCWL=+Y ,RCQUIT=0
  14815   "RTN","RCD PEM2",382, 0)
  14816    I $D(^RCY (344.49,RC WL,0)) D   Q:RCQUIT
  14817   "RTN","RCD PEM2",383, 0)
  14818    . S DIR(0 )="YA",DIR ("A",1)="T HIS ERA AL READY HAS  A WORKLIST  ENTRY AND  MUST BE D ELETED BEF ORE IT CAN  BE UNMATC HED",DIR(" A")="DO YO U WANT TO  DELETE THE  WORKLIST  ENTRY FOR  THIS ERA N OW? "
  14819   "RTN","RCD PEM2",384, 0)
  14820    . W ! D ^ DIR K DIR
  14821   "RTN","RCD PEM2",385, 0)
  14822    . I Y'=1  S RCQUIT=1  Q
  14823   "RTN","RCD PEM2",386, 0)
  14824    . S DIK=" ^RCY(344.4 9,",DA=RCW L D ^DIK
  14825   "RTN","RCD PEM2",387, 0)
  14826    S AUTOPOS T=""
  14827   "RTN","RCD PEM2",388, 0)
  14828    I $O(^RCY (344.31,"A ERA",RCWL, 0)) S RCEF T=+$O(^(0) ) D  Q:RCQ UIT
  14829   "RTN","RCD PEM2",389, 0)
  14830    . S AUTOP OST=$$GET1 ^DIQ(344.4 ,RCWL_",", 4.02,"I")
  14831   "RTN","RCD PEM2",390, 0)
  14832    . W !!,"T HIS ERA IS  MATCHED T O EFT #"_R CEFT
  14833   "RTN","RCD PEM2",391, 0)
  14834    . I AUTOP OST=0 W !, "* WARNING : This ERA  will be U n-Marked a s an Auto- Post CANDI DATE"
  14835   "RTN","RCD PEM2",392, 0)
  14836    . S DIR(" A")="ARE Y OU SURE YO U WANT TO  UNMATCH TH EM? ",DIR( 0)="YA"
  14837   "RTN","RCD PEM2",393, 0)
  14838    . D ^DIR  K DIR
  14839   "RTN","RCD PEM2",394, 0)
  14840    . I Y'=1  S RCQUIT=1  Q
  14841   "RTN","RCD PEM2",395, 0)
  14842    . S DIE=" ^RCY(344.3 1,",DR=".1 ///@;.08// //0",DA=RC EFT D ^DIE
  14843   "RTN","RCD PEM2",396, 0)
  14844    . W !,"EF T #"_RCEFT _" IS NOW  UNMATCHED" ,!
  14845   "RTN","RCD PEM2",397, 0)
  14846    S DIE="^R CY(344.4," ,DR=".09// //0;.13/// @;.14////0 ",DA=RCWL  D ^DIE
  14847   "RTN","RCD PEM2",398, 0)
  14848    I AUTOPOS T=0 D SETS TA^RCDPEAP (RCWL,"@", "Unmatch:  Removed as  Auto-Post  Candidate ")
  14849   "RTN","RCD PEM2",399, 0)
  14850    S DIR("A" )="ERA HAS  BEEN SUCC ESSFULLY U NMATCHED -  Press ENT ER to cont inue: "
  14851   "RTN","RCD PEM2",400, 0)
  14852    S DIR(0)= "EA" W ! D  ^DIR K DI R
  14853   "RTN","RCD PEM2",401, 0)
  14854    Q
  14855   "RTN","RCD PEM2",402, 0)
  14856    ;
  14857   "RTN","RCD PEM2",403, 0)
  14858    ;
  14859   "RTN","RCD PEM2",404, 0)
  14860    ; PRCA*4. 5*284 - Ch anged opti on name fr om 'Mark E RA Return  to Payer'  to 'Remove  ERA from  Active Wor klist'
  14861   "RTN","RCD PEM2",405, 0)
  14862   RETN ; Ent rypoint fo r Remove E RA from Ac tive Workl ist
  14863   "RTN","RCD PEM2",406, 0)
  14864    N DIR,X,Y ,DTOUT,DUO UT,DIC,RCY ,DIE,DA,DR ,MSG,%
  14865   "RTN","RCD PEM2",407, 0)
  14866    D OWNSKEY ^XUSRB(.MS G,"RCDPE M ARK ERA",D UZ)
  14867   "RTN","RCD PEM2",408, 0)
  14868    I 'MSG(0)  W !!,"SOR RY, YOU AR E NOT AUTH ORIZED TO  USE THIS O PTION",!," This optio n is locke d with RCD PE MARK ER A key.",!  S DIR(0)=" E" D ^DIR  K DIR Q
  14869   "RTN","RCD PEM2",409, 0)
  14870    ; PRCA*4. 5*284 - Ch anged desc ription
  14871   "RTN","RCD PEM2",410, 0)
  14872    W !!,"Use  this opti on to remo ve an ERA  from the E EOB Workli st that sh ould not h ave"
  14873   "RTN","RCD PEM2",411, 0)
  14874    W !,"been  sent to y our site b y the paye r; or the  ERA cannot  be remove d off the"
  14875   "RTN","RCD PEM2",412, 0)
  14876    W !,"Work list using  the 'Upda te ERA Pos ted Using  Paper EOB'  option."
  14877   "RTN","RCD PEM2",413, 0)
  14878    W !!,"Thi s option i s only to  be used if  the paper  check has  been sent  back to t he"
  14879   "RTN","RCD PEM2",414, 0)
  14880    W !,"paye r without  being depo sited.  On ce removed , the ERA  can no lon ger be"
  14881   "RTN","RCD PEM2",415, 0)
  14882    W !,"acce ssed for p rocessing,  but can b e viewed u nder the p osted Work list. For"
  14883   "RTN","RCD PEM2",416, 0)
  14884    W !,"audi ting purpo ses, this  option req uires the  user to en ter a reas on for"
  14885   "RTN","RCD PEM2",417, 0)
  14886    W !,"remo ving the E RA.",!
  14887   "RTN","RCD PEM2",418, 0)
  14888    S DIC="^R CY(344.4," ,DIC(0)="A EMQ",DIC(" S")="I '$P (^(0),U,9) ,'$P(^(0), U,14)" D ^ DIC K DIC
  14889   "RTN","RCD PEM2",419, 0)
  14890    Q:Y'>0
  14891   "RTN","RCD PEM2",420, 0)
  14892    S RCY=+Y
  14893   "RTN","RCD PEM2",421, 0)
  14894    S DIR(0)= "YA",DIR(" A",1)="THI S WILL REM OVE THE ER A # "_+Y_"  FROM THE  ACTIVE WOR KLIST",DIR ("A")="ARE  YOU SURE  YOU WANT T O CONTINUE ? " W ! D  ^DIR K DIR
  14895   "RTN","RCD PEM2",422, 0)
  14896    W !
  14897   "RTN","RCD PEM2",423, 0)
  14898    I $D(DUOU T)!$D(DTOU T)!(Y=0) D  NOCHNG Q
  14899   "RTN","RCD PEM2",424, 0)
  14900    S DIE="^R CY(344.4," ,DA=RCY,DR =".18" D ^ DIE
  14901   "RTN","RCD PEM2",425, 0)
  14902    I $D(Y) D  NOCHNG Q
  14903   "RTN","RCD PEM2",426, 0)
  14904    ; PRCA*4. 5*284 Set  EFT MATCH  STATUS (#3 44.4,.09)  as '4' FOR  REMOVED r ather than  '2' FOR M ATCHED TO  PAPER CHEC K
  14905   "RTN","RCD PEM2",427, 0)
  14906    D NOW^%DT C S DR=".1 4////4;.09 ////4;.16/ ///"_DUZ_" ;.17////"_ % D ^DIE
  14907   "RTN","RCD PEM2",428, 0)
  14908    S DIR(0)= "EA",DIR(" A")="Press  ENTER to  continue:  "
  14909   "RTN","RCD PEM2",429, 0)
  14910    W ! D ^DI R
  14911   "RTN","RCD PEM2",430, 0)
  14912    Q
  14913   "RTN","RCD PEM2",431, 0)
  14914    ;
  14915   "RTN","RCD PEM2",432, 0)
  14916   NOCHNG ;
  14917   "RTN","RCD PEM2",433, 0)
  14918    N DIR,X,Y ,DTOUT,DUO UT
  14919   "RTN","RCD PEM2",434, 0)
  14920    D EN^DDIO L("NO CHAN GES HAVE B EEN MADE." ,"","!")
  14921   "RTN","RCD PEM2",435, 0)
  14922    S DIR(0)= "EA",DIR(" A")="Press  ENTER to  continue:  "
  14923   "RTN","RCD PEM2",436, 0)
  14924    W !! D ^D IR
  14925   "RTN","RCD PEM2",437, 0)
  14926    Q
  14927   "RTN","RCD PEM4")
  14928   0^23^B2280 06558
  14929   "RTN","RCD PEM4",1,0)
  14930   RCDPEM4 ;O IFO-BAYPIN ES/PJH - E PAYMENTS A UDIT REPOR TS ;Nov 17 , 2014@17: 00:41
  14931   "RTN","RCD PEM4",2,0)
  14932    ;;4.5;Acc ounts Rece ivable;**2 76,284,298 ,304,321** ;Mar 20, 1 995;Build  46
  14933   "RTN","RCD PEM4",3,0)
  14934    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  14935   "RTN","RCD PEM4",4,0)
  14936    ;
  14937   "RTN","RCD PEM4",5,0)
  14938   EOB ; EEOB  Move/Copy /Rmove Aud it Report  [RCDPE EEO B MOVE/COP Y/RMOVE RP T]
  14939   "RTN","RCD PEM4",6,0)
  14940    N RCRTYP  S RCRTYP=" EOB"  ; re cord type
  14941   "RTN","RCD PEM4",7,0)
  14942    D ASKUSR
  14943   "RTN","RCD PEM4",8,0)
  14944    Q
  14945   "RTN","RCD PEM4",9,0)
  14946    ;
  14947   "RTN","RCD PEM4",10,0 )
  14948   POST ; ERA s Posted w ith Paper  EOB Audit  Report [RC DPE ERA W/ PAPER EOB  REPORT]
  14949   "RTN","RCD PEM4",11,0 )
  14950    N RCRTYP  S RCRTYP=" ERA"  ; re cord type
  14951   "RTN","RCD PEM4",12,0 )
  14952    D ASKUSR
  14953   "RTN","RCD PEM4",13,0 )
  14954    Q
  14955   "RTN","RCD PEM4",14,0 )
  14956    ;
  14957   "RTN","RCD PEM4",15,0 )
  14958   ASKUSR ;co llect filt er and dev ice option s
  14959   "RTN","RCD PEM4",16,0 )
  14960    Q:$G(RCRT YP)=""  ;  must have  record typ e
  14961   "RTN","RCD PEM4",17,0 )
  14962    N %ZIS,PO P,RCACT,RC DISPTY,RCD IV,RCDTRNG ,RCHDR,RCL STMGR,RCLN CNT,RCPGNU M,RCPROG,R CSTA,RCSTO P,RCTMPND, RCXCLUDE,V AUTD,X,Y
  14963   "RTN","RCD PEM4",18,0 )
  14964    ; RCACT -  selected  actions fo r EOB
  14965   "RTN","RCD PEM4",19,0 )
  14966    ; RCDISPT Y - displa y type
  14967   "RTN","RCD PEM4",20,0 )
  14968    ; RCDIV -  selected  divs.
  14969   "RTN","RCD PEM4",21,0 )
  14970    ; RCDTRNG  - date ra nge for re port
  14971   "RTN","RCD PEM4",22,0 )
  14972    ; RCHDR -  header ar ray
  14973   "RTN","RCD PEM4",23,0 )
  14974    ; RCLSTMG R - ListMa n output f lag
  14975   "RTN","RCD PEM4",24,0 )
  14976    ; RCPGNUM  - report  page count
  14977   "RTN","RCD PEM4",25,0 )
  14978    ; RCPROG  - ^TMP sto rage node  for entrie s
  14979   "RTN","RCD PEM4",26,0 )
  14980    ; RCSTA -  station
  14981   "RTN","RCD PEM4",27,0 )
  14982    ; RCSTOP  - flag to  stop repor t
  14983   "RTN","RCD PEM4",28,0 )
  14984    ; RCTMPND  - ListMan  storage n ode
  14985   "RTN","RCD PEM4",29,0 )
  14986    ; RCXCLUD E("CHAMPVA ") - boole an, exclud e CHAMPVA
  14987   "RTN","RCD PEM4",30,0 )
  14988    ; RCXCLUD E("TRICARE ") - boole an, exclud e TriCare
  14989   "RTN","RCD PEM4",31,0 )
  14990    ;
  14991   "RTN","RCD PEM4",32,0 )
  14992    S RCPROG= $T(+0),RCL STMGR="",R CACT="",(R CLNCNT,RCS TOP)=0,RCT MPND=""
  14993   "RTN","RCD PEM4",33,0 )
  14994    S (RCXCLU DE("CHAMPV A"),RCXCLU DE("TRICAR E"))=0  ;  default to  false
  14995   "RTN","RCD PEM4",34,0 )
  14996    ;Select D ate Range  for Report
  14997   "RTN","RCD PEM4",35,0 )
  14998    S RCDTRNG =$$DTRNG()  G:'RCDTRN G EXIT
  14999   "RTN","RCD PEM4",36,0 )
  15000    ;Select F ilter for  Action Typ e (Move,Co py,Remove  or All)
  15001   "RTN","RCD PEM4",37,0 )
  15002    I RCRTYP= "EOB" S RC ACT=$$ACTI ON G:RCACT <0 EXIT
  15003   "RTN","RCD PEM4",38,0 )
  15004    ;Select F ilter/Sort  by Divisi on
  15005   "RTN","RCD PEM4",39,0 )
  15006    D STADIV  G:'RCDIV E XIT
  15007   "RTN","RCD PEM4",40,0 )
  15008    ; Begin P RCA*4.5*32 1
  15009   "RTN","RCD PEM4",41,0 )
  15010    ; CHAMPVA  exclusion  filter
  15011   "RTN","RCD PEM4",42,0 )
  15012    S RCXCLUD E("CHAMPVA ")=$$EXCHM PVA^RCDPEA RL  ; user  is asked  whether to  exclude
  15013   "RTN","RCD PEM4",43,0 )
  15014    G:RCXCLUD E("CHAMPVA ")<0 EXIT
  15015   "RTN","RCD PEM4",44,0 )
  15016    ; TRICARE  exclusion  filter
  15017   "RTN","RCD PEM4",45,0 )
  15018    S RCXCLUD E("TRICARE ")=$$EXTRI CAR^RCDPEA RL  ; user  is asked  whether to  exclude
  15019   "RTN","RCD PEM4",46,0 )
  15020    G:RCXCLUD E("TRICARE ")<0 EXIT
  15021   "RTN","RCD PEM4",47,0 )
  15022    ; End PRC A*4.5*321
  15023   "RTN","RCD PEM4",48,0 )
  15024    ; Select  Display Ty pe , exit  if indicat ed
  15025   "RTN","RCD PEM4",49,0 )
  15026    S RCDISPT Y=$$DISPTY () G:RCDIS PTY<0 EXIT
  15027   "RTN","RCD PEM4",50,0 )
  15028    ;Display  capture in formation  for Excel,  set RCLST MGR to pre vent quest ion
  15029   "RTN","RCD PEM4",51,0 )
  15030    I RCDISPT Y D INFO^R CDPEM6 S R CLSTMGR="^ "
  15031   "RTN","RCD PEM4",52,0 )
  15032    I RCLSTMG R="" S RCL STMGR=$$AS KLM^RCDPEA RL G:RCLST MGR<0 EXIT
  15033   "RTN","RCD PEM4",53,0 )
  15034    I RCLSTMG R D  G EXI T
  15035   "RTN","RCD PEM4",54,0 )
  15036    .X "S RCT MPND=$T(+0 )_U_$$HDR" _RCRTYP K  ^TMP($J,RC TMPND)  ;  ^TMP stora ge node, c lean any r esidue
  15037   "RTN","RCD PEM4",55,0 )
  15038    .D RPRTCM PL
  15039   "RTN","RCD PEM4",56,0 )
  15040    .N H,L,HD R S L=0
  15041   "RTN","RCD PEM4",57,0 )
  15042    .X "S HDR (""TITLE"" )=$$HDR"_R CRTYP
  15043   "RTN","RCD PEM4",58,0 )
  15044    .F H=1:1: 7 I $D(RCH DR(H)) S L =H,HDR(H)= RCHDR(H)   ; take fir st 7 lines  of report  header
  15045   "RTN","RCD PEM4",59,0 )
  15046    .I $O(RCH DR(L)) D   ; any rema ining head er lines a t top of r eport
  15047   "RTN","RCD PEM4",60,0 )
  15048    ..N N S N =0,H=L F   S H=$O(RCH DR(H)) Q:' H  S N=N+. 001,^TMP($ J,RCTMPND, N)=RCHDR(H )
  15049   "RTN","RCD PEM4",61,0 )
  15050    .; invoke  ListMan
  15051   "RTN","RCD PEM4",62,0 )
  15052    .D LMRPT^ RCDPEARL(. HDR,$NA(^T MP($J,RCTM PND))) ; g enerate Li stMan disp lay
  15053   "RTN","RCD PEM4",63,0 )
  15054    ;
  15055   "RTN","RCD PEM4",64,0 )
  15056    ;Select o utput devi ce
  15057   "RTN","RCD PEM4",65,0 )
  15058    S %ZIS="Q M" D ^%ZIS  Q:POP
  15059   "RTN","RCD PEM4",66,0 )
  15060    ;Option t o queue
  15061   "RTN","RCD PEM4",67,0 )
  15062    I 'RCDISP TY,$D(IO(" Q")) D  Q
  15063   "RTN","RCD PEM4",68,0 )
  15064    .N ZTSK,Z TDESC,ZTSA VE,ZTQUEUE D,ZTRTN
  15065   "RTN","RCD PEM4",69,0 )
  15066    .S ZTRTN= "RPRTCMPL^ RCDPEM4"
  15067   "RTN","RCD PEM4",70,0 )
  15068    .S ZTDESC ="EDI LOCK BOX PAPER  EOB AUDIT  REPORT"
  15069   "RTN","RCD PEM4",71,0 )
  15070    .S ZTSAVE ("RC*")="" ,ZTSAVE("V AUTD")=""
  15071   "RTN","RCD PEM4",72,0 )
  15072    .D ^%ZTLO AD
  15073   "RTN","RCD PEM4",73,0 )
  15074    .W !!,$S( $G(ZTSK):" Task numbe r "_ZTSK_"  was queue d.",1:"Una ble to que ue this ta sk."),!
  15075   "RTN","RCD PEM4",74,0 )
  15076    .K ZTSK,I O("Q") D H OME^%ZIS
  15077   "RTN","RCD PEM4",75,0 )
  15078    ;
  15079   "RTN","RCD PEM4",76,0 )
  15080    ;Compile  and Print  Report
  15081   "RTN","RCD PEM4",77,0 )
  15082    D RPRTCMP L
  15083   "RTN","RCD PEM4",78,0 )
  15084    Q
  15085   "RTN","RCD PEM4",79,0 )
  15086    ;
  15087   "RTN","RCD PEM4",80,0 )
  15088   RPRTCMPL ; Compile an d print re port
  15089   "RTN","RCD PEM4",81,0 )
  15090    K ^TMP(RC PROG,$J),^ TMP($J,"RC  TOTAL")
  15091   "RTN","RCD PEM4",82,0 )
  15092    ;Scan ERA  file for  entries in  date rang e
  15093   "RTN","RCD PEM4",83,0 )
  15094    I RCRTYP= "ERA" D CM PLERA
  15095   "RTN","RCD PEM4",84,0 )
  15096    ;Scan EOB  file for  entries in  date rang e
  15097   "RTN","RCD PEM4",85,0 )
  15098    I RCRTYP= "EOB" D CM PLEOB
  15099   "RTN","RCD PEM4",86,0 )
  15100    ;Display  Report
  15101   "RTN","RCD PEM4",87,0 )
  15102    D DISP
  15103   "RTN","RCD PEM4",88,0 )
  15104    ;
  15105   "RTN","RCD PEM4",89,0 )
  15106   EXIT ;
  15107   "RTN","RCD PEM4",90,0 )
  15108    ;Clear ol d data
  15109   "RTN","RCD PEM4",91,0 )
  15110    K ^TMP(RC PROG,$J),^ TMP($J,"RC  TOTAL")
  15111   "RTN","RCD PEM4",92,0 )
  15112    Q
  15113   "RTN","RCD PEM4",93,0 )
  15114    ;
  15115   "RTN","RCD PEM4",94,0 )
  15116   CMPLERA ;G enerate th e ERA post ed with pa per EOB re port ^TMP  array
  15117   "RTN","RCD PEM4",95,0 )
  15118    ; ^RCY(34 4.4,0) = E LECTRONIC  REMITTANCE  ADVICE^34 4.4I^
  15119   "RTN","RCD PEM4",96,0 )
  15120    N START,E ND,ERAIEN, STA,STNAM, STNUM
  15121   "RTN","RCD PEM4",97,0 )
  15122    ;Date Ran ge
  15123   "RTN","RCD PEM4",98,0 )
  15124    S START=0 ,END="9999 999",SUB=0
  15125   "RTN","RCD PEM4",99,0 )
  15126    S:$P(RCDT RNG,U) STA RT=$P(RCDT RNG,U,2),E ND=$P(RCDT RNG,U,3)
  15127   "RTN","RCD PEM4",100, 0)
  15128    ;Selected  division  or All
  15129   "RTN","RCD PEM4",101, 0)
  15130    ;Scan AFL  index for  ERA withi n date ran ge
  15131   "RTN","RCD PEM4",102, 0)
  15132    F  S STAR T=$O(^RCY( 344.4,"AFL ",START))  Q:'START   Q:START>EN D  D
  15133   "RTN","RCD PEM4",103, 0)
  15134    .S ERAIEN =""
  15135   "RTN","RCD PEM4",104, 0)
  15136    .F  S ERA IEN=$O(^RC Y(344.4,"A FL",START, ERAIEN)) Q :'ERAIEN   D
  15137   "RTN","RCD PEM4",105, 0)
  15138    ..;Ignore  if not po sted with  paper EOB
  15139   "RTN","RCD PEM4",106, 0)
  15140    ..Q:'$D(^ RCY(344.4, ERAIEN,7))
  15141   "RTN","RCD PEM4",107, 0)
  15142    ..;Check  division
  15143   "RTN","RCD PEM4",108, 0)
  15144    ..D ERAST A(ERAIEN,. STA,.STNUM ,.STNAM)
  15145   "RTN","RCD PEM4",109, 0)
  15146    ..I RCDIV =2,'$D(VAU TD(STA)) Q
  15147   "RTN","RCD PEM4",110, 0)
  15148    ..; CHAMP VA check
  15149   "RTN","RCD PEM4",111, 0)
  15150    ..I $G(RC XCLUDE("CH AMPVA")),$ $CLMCHMPV^ RCDPEARL(" 344.4;"_ER AIEN) D  Q   ; count  and quit i f true
  15151   "RTN","RCD PEM4",112, 0)
  15152    ...N N S  N=$G(^TMP( $J,"RC TOT AL","CHAMP VA"))+1,^( "CHAMPVA") =N  ; tota l can be l isted
  15153   "RTN","RCD PEM4",113, 0)
  15154    ..;
  15155   "RTN","RCD PEM4",114, 0)
  15156    ..; TRICA RE check
  15157   "RTN","RCD PEM4",115, 0)
  15158    ..I $G(RC XCLUDE("TR ICARE")),$ $CLMTRICR^ RCDPEARL(" 344.4;"_ER AIEN) D  Q   ; count  and quit i f true
  15159   "RTN","RCD PEM4",116, 0)
  15160    ...N N S  N=$G(^TMP( $J,"RC TOT AL","TRICA RE"))+1,^( "TRICARE") =N  ; tota l can be l isted
  15161   "RTN","RCD PEM4",117, 0)
  15162    ..;
  15163   "RTN","RCD PEM4",118, 0)
  15164    ..D SVERA ^RCDPEM41( ERAIEN,STA ,STNUM,STN AM)
  15165   "RTN","RCD PEM4",119, 0)
  15166    ;
  15167   "RTN","RCD PEM4",120, 0)
  15168    Q
  15169   "RTN","RCD PEM4",121, 0)
  15170    ;
  15171   "RTN","RCD PEM4",122, 0)
  15172   CMPLEOB ;G enerate th e EOB Move d/Copy/Rem ove report  ^TMP arra y
  15173   "RTN","RCD PEM4",123, 0)
  15174    N DTSUB,S TART,END,E OBIEN,IEN1 01,STA,STN AM,STNUM
  15175   "RTN","RCD PEM4",124, 0)
  15176    ;Date Ran ge
  15177   "RTN","RCD PEM4",125, 0)
  15178    S START=$ P(RCDTRNG, U,2),END=$ P(RCDTRNG, U,3)
  15179   "RTN","RCD PEM4",126, 0)
  15180    ;Selected  division  or All
  15181   "RTN","RCD PEM4",127, 0)
  15182    ;Scan AEO B index fo r EOB with in date ra nge
  15183   "RTN","RCD PEM4",128, 0)
  15184    F  S STAR T=$O(^IBM( 361.1,"AEO B",START))  Q:'START   Q:(START\ 1)>END  D
  15185   "RTN","RCD PEM4",129, 0)
  15186    .S EOBIEN =""
  15187   "RTN","RCD PEM4",130, 0)
  15188    .F  S EOB IEN=$O(^IB M(361.1,"A EOB",START ,EOBIEN))  Q:'EOBIEN   D
  15189   "RTN","RCD PEM4",131, 0)
  15190    ..; Ignor e if not M OVED/COPIE D
  15191   "RTN","RCD PEM4",132, 0)
  15192    ..S IEN10 1=$O(^IBM( 361.1,"AEO B",START,E OBIEN,""))  Q:'IEN101
  15193   "RTN","RCD PEM4",133, 0)
  15194    ..; Check  division
  15195   "RTN","RCD PEM4",134, 0)
  15196    ..D EOBST A(EOBIEN,. STA,.STNUM ,.STNAM)
  15197   "RTN","RCD PEM4",135, 0)
  15198    ..I RCDIV =2,'$D(VAU TD(STA)) Q
  15199   "RTN","RCD PEM4",136, 0)
  15200    ..; CHAMP VA check
  15201   "RTN","RCD PEM4",137, 0)
  15202    ..I $G(RC XCLUDE("CH AMPVA")),$ $CLMCHMPV^ RCDPEARL(" 361.1;"_EO BIEN) D  Q   ; count  and quit i f true
  15203   "RTN","RCD PEM4",138, 0)
  15204    ...N N S  N=$G(^TMP( $J,"RC TOT AL","CHAMP VA"))+1,^( "CHAMPVA") =N  ; tota l can be l isted
  15205   "RTN","RCD PEM4",139, 0)
  15206    ..; TRICA RE check
  15207   "RTN","RCD PEM4",140, 0)
  15208    ..I $G(RC XCLUDE("TR ICARE")),$ $CLMTRICR^ RCDPEARL(" 361.1;"_EO BIEN) D  Q   ; count  and quit i f true
  15209   "RTN","RCD PEM4",141, 0)
  15210    ...N N S  N=$G(^TMP( $J,"RC TOT AL","TRICA RE"))+1,^( "TRICARE") =N  ; tota l can be l isted
  15211   "RTN","RCD PEM4",142, 0)
  15212    ..;
  15213   "RTN","RCD PEM4",143, 0)
  15214    ..;
  15215   "RTN","RCD PEM4",144, 0)
  15216    ..D SVEOB ^RCDPEM41( EOBIEN,IEN 101,STA,ST NUM,STNAM)
  15217   "RTN","RCD PEM4",145, 0)
  15218    ;
  15219   "RTN","RCD PEM4",146, 0)
  15220    Q
  15221   "RTN","RCD PEM4",147, 0)
  15222    ;
  15223   "RTN","RCD PEM4",148, 0)
  15224   DISP ; For mat the di splay for  screen/pri nter or MS  Excel
  15225   "RTN","RCD PEM4",149, 0)
  15226    N DVFLTR, IEN,RCNTRY ,SUB,Y
  15227   "RTN","RCD PEM4",150, 0)
  15228    ;Format D ivision Fi lter
  15229   "RTN","RCD PEM4",151, 0)
  15230    S DVFLTR= $S(RCRTYP= "EOB":"ALL  STATIONS/ DIVISIONS" ,1:"ALL")  I RCDIV=2  S DVFLTR=$ $LINE(.VAU TD)
  15231   "RTN","RCD PEM4",152, 0)
  15232    D:'RCLSTM GR HDRBLD   ; Report  header
  15233   "RTN","RCD PEM4",153, 0)
  15234    D:RCLSTMG R HDRLM  ;  Listman h eader
  15235   "RTN","RCD PEM4",154, 0)
  15236    ; RCNTRY  - entry fr om ^TMP(RC PROG,$J)
  15237   "RTN","RCD PEM4",155, 0)
  15238    ;
  15239   "RTN","RCD PEM4",156, 0)
  15240    U IO
  15241   "RTN","RCD PEM4",157, 0)
  15242    ;
  15243   "RTN","RCD PEM4",158, 0)
  15244    ; Display  Header fo r first ti me
  15245   "RTN","RCD PEM4",159, 0)
  15246    D:'RCLSTM GR HDRLST^ RCDPEARL(. RCSTOP,.RC HDR)
  15247   "RTN","RCD PEM4",160, 0)
  15248    ;Report b y division  or 'ALL'
  15249   "RTN","RCD PEM4",161, 0)
  15250    S SUB=0,R CSTOP=0
  15251   "RTN","RCD PEM4",162, 0)
  15252    F  S SUB= $O(^TMP(RC PROG,$J,SU B)) Q:SUB= ""!RCSTOP   D
  15253   "RTN","RCD PEM4",163, 0)
  15254    .S IEN=0  F  S IEN=$ O(^TMP(RCP ROG,$J,SUB ,IEN)) Q:' IEN!RCSTOP   S RCNTRY =^(IEN) D
  15255   "RTN","RCD PEM4",164, 0)
  15256    ..I RCDIS PTY W !,RC NTRY Q  ;  spreadshee t format
  15257   "RTN","RCD PEM4",165, 0)
  15258    ..I RCRTY P="ERA" D   ; ERA pos ted with p aper EOB
  15259   "RTN","RCD PEM4",166, 0)
  15260    ...I 'RCL STMGR,$Y>( IOSL-RCHDR (0)) D HDR LST^RCDPEA RL(.RCSTOP ,.RCHDR) Q :RCSTOP
  15261   "RTN","RCD PEM4",167, 0)
  15262    ...S Y=$$ PAD^RCDPEA RL($P(RCNT RY,U,5),11 )  ; ERA#
  15263   "RTN","RCD PEM4",168, 0)
  15264    ...S Y=Y_ $$PAD^RCDP EARL($P(RC NTRY,U,6), 13) ;RECEI PT#
  15265   "RTN","RCD PEM4",169, 0)
  15266    ...S Y=Y_ $$PAD^RCDP EARL($P(RC NTRY,U,3), 18) ;DATE/ TIME
  15267   "RTN","RCD PEM4",170, 0)
  15268    ...S Y=Y_ $$PAD^RCDP EARL($P(RC NTRY,U,4), 16) ;USER  LASTNAME,F IRSTNAME
  15269   "RTN","RCD PEM4",171, 0)
  15270    ...S Y=Y_ $P(RCNTRY, U,7) ;MATC H STATUS
  15271   "RTN","RCD PEM4",172, 0)
  15272    ...D SL^R CDPEARL(Y, .RCLNCNT,R CTMPND)
  15273   "RTN","RCD PEM4",173, 0)
  15274    ...D SL^R CDPEARL($J ("",61)_$P (RCNTRY,U, 8),.RCLNCN T,RCTMPND)  ;POST STA TUS
  15275   "RTN","RCD PEM4",174, 0)
  15276    ..;
  15277   "RTN","RCD PEM4",175, 0)
  15278    ..I RCRTY P="EOB" D   ; EOB Mov ed/Copied
  15279   "RTN","RCD PEM4",176, 0)
  15280    ...I 'RCL STMGR,$Y>( IOSL-RCHDR (0)) D HDR LST^RCDPEA RL(.RCSTOP ,.RCHDR) Q :RCSTOP
  15281   "RTN","RCD PEM4",177, 0)
  15282    ...S Y=$$ PAD^RCDPEA RL($P(RCNT RY,U,5),20 ) ; ORIGIN AL BILL
  15283   "RTN","RCD PEM4",178, 0)
  15284    ...S Y=Y_ $P(RCNTRY, U,8) ; TRA CE #
  15285   "RTN","RCD PEM4",179, 0)
  15286    ...D SL^R CDPEARL(Y, .RCLNCNT,R CTMPND)
  15287   "RTN","RCD PEM4",180, 0)
  15288    ...S Y=$$ PAD^RCDPEA RL($J("",6 )_$P(RCNTR Y,U,7),15)  ;ERA
  15289   "RTN","RCD PEM4",181, 0)
  15290    ...S Y=Y_ $$PAD^RCDP EARL($P(RC NTRY,U,3), 20) ;DATE/ TIME
  15291   "RTN","RCD PEM4",182, 0)
  15292    ...S Y=Y_ $$PAD^RCDP EARL($P(RC NTRY,U,12) ,15) ;MOVE D/COPIED/R EMOVED
  15293   "RTN","RCD PEM4",183, 0)
  15294    ...S Y=Y_ $$PAD^RCDP EARL("$"_$ P(RCNTRY,U ,9),11) ;P AYMENT AMO UNT
  15295   "RTN","RCD PEM4",184, 0)
  15296    ...S Y=Y_ $P(RCNTRY, U,4) ; USE R LASTNAME ,FIRSTNAME
  15297   "RTN","RCD PEM4",185, 0)
  15298    ...D SL^R CDPEARL(Y, .RCLNCNT,R CTMPND)
  15299   "RTN","RCD PEM4",186, 0)
  15300    ...D:$P(R CNTRY,U,12 )'="REMOVE D"
  15301   "RTN","RCD PEM4",187, 0)
  15302    ....S Y=$ $PAD^RCDPE ARL("New B ill: "_$P( RCNTRY,U,6 ),25) ;NEW  BILL
  15303   "RTN","RCD PEM4",188, 0)
  15304    ....S Y=Y _"Other Bi ll Number( s): "_$P(R CNTRY,U,11 ) ;OTHER B ILLS
  15305   "RTN","RCD PEM4",189, 0)
  15306    ....D SL^ RCDPEARL(Y ,.RCLNCNT, RCTMPND)
  15307   "RTN","RCD PEM4",190, 0)
  15308    ...;
  15309   "RTN","RCD PEM4",191, 0)
  15310    ...D WP($ P(RCNTRY,U ,10))  ; J ustificati on comment s
  15311   "RTN","RCD PEM4",192, 0)
  15312    ...D SL^R CDPEARL("" ,.RCLNCNT, RCTMPND)   ; skip a l ine
  15313   "RTN","RCD PEM4",193, 0)
  15314    .;
  15315   "RTN","RCD PEM4",194, 0)
  15316    .; end of  report
  15317   "RTN","RCD PEM4",195, 0)
  15318    .I 'RCSTO P D SL^RCD PEARL(" ", .RCLNCNT,R CTMPND),SL ^RCDPEARL( $$ENDORPRT ^RCDPEARL, .RCLNCNT,R CTMPND)
  15319   "RTN","RCD PEM4",196, 0)
  15320    ;
  15321   "RTN","RCD PEM4",197, 0)
  15322    D:'$D(^TM P(RCPROG,$ J))
  15323   "RTN","RCD PEM4",198, 0)
  15324    .D SL^RCD PEARL(" ", .RCLNCNT,R CTMPND)  ;  skip line
  15325   "RTN","RCD PEM4",199, 0)
  15326    .D SL^RCD PEARL("      *** NO R ECORDS TO  PRINT ***" ,.RCLNCNT, RCTMPND)
  15327   "RTN","RCD PEM4",200, 0)
  15328    ;
  15329   "RTN","RCD PEM4",201, 0)
  15330    ;Close de vice
  15331   "RTN","RCD PEM4",202, 0)
  15332    I '$D(ZTQ UEUED),'RC LSTMGR D ^ %ZISC
  15333   "RTN","RCD PEM4",203, 0)
  15334    S:$D(ZTQU EUED) ZTRE Q="@"
  15335   "RTN","RCD PEM4",204, 0)
  15336    Q
  15337   "RTN","RCD PEM4",205, 0)
  15338    ;
  15339   "RTN","RCD PEM4",206, 0)
  15340   LINE(VAUTD ) ;List se lected sta tions
  15341   "RTN","RCD PEM4",207, 0)
  15342    N LINE,SU B
  15343   "RTN","RCD PEM4",208, 0)
  15344    S LINE="" ,SUB=""
  15345   "RTN","RCD PEM4",209, 0)
  15346    F  S SUB= $O(VAUTD(S UB)) Q:'SU B  D
  15347   "RTN","RCD PEM4",210, 0)
  15348    .S LINE=L INE_$G(VAU TD(SUB))_" , "
  15349   "RTN","RCD PEM4",211, 0)
  15350    Q $E(LINE ,1,$L(LINE )-2)
  15351   "RTN","RCD PEM4",212, 0)
  15352    ;
  15353   "RTN","RCD PEM4",213, 0)
  15354   SELDIV(VAU TD,Z) ;Dev isions are  organized  as Z(1)=" DIV1,DIV2, ..., Z(2)= "DIVN,DIVN +1,... etc .
  15355   "RTN","RCD PEM4",214, 0)
  15356    ; Input:
  15357   "RTN","RCD PEM4",215, 0)
  15358    ;   VAUTD  (required /pass-by-r ef) - Divi sion(s) ar ray; resul t of call  to DIVISIO N^VAUTOMA
  15359   "RTN","RCD PEM4",216, 0)
  15360    ; Output:
  15361   "RTN","RCD PEM4",217, 0)
  15362    ;   Z (re quired/pas s-by-ref)  - reformat ted array  of divisio ns
  15363   "RTN","RCD PEM4",218, 0)
  15364    ;
  15365   "RTN","RCD PEM4",219, 0)
  15366    N SUB,CNT
  15367   "RTN","RCD PEM4",220, 0)
  15368    S CNT=1,Z (CNT)="DIV ISIONS: "
  15369   "RTN","RCD PEM4",221, 0)
  15370    I $D(VAUT D)=1 D  Q
  15371   "RTN","RCD PEM4",222, 0)
  15372    . S Z(CNT )=Z(CNT)_" ALL"
  15373   "RTN","RCD PEM4",223, 0)
  15374    .S Z(CNT) =$J("",80- $L(Z(CNT)) \2)_Z(CNT)
  15375   "RTN","RCD PEM4",224, 0)
  15376    I $D(VAUT D)>1,'VAUT D D
  15377   "RTN","RCD PEM4",225, 0)
  15378    .S SUB=VA UTD
  15379   "RTN","RCD PEM4",226, 0)
  15380    .F  S SUB =$O(VAUTD( SUB)) Q:'S UB  D
  15381   "RTN","RCD PEM4",227, 0)
  15382    ..I Z(CNT )="DIVISIO NS: " S Z( CNT)=Z(CNT )_VAUTD(SU B) Q
  15383   "RTN","RCD PEM4",228, 0)
  15384    ..S Z(CNT )=Z(CNT)_$ S(Z(CNT)]" ":",",1:"" )_VAUTD(SU B)
  15385   "RTN","RCD PEM4",229, 0)
  15386    ..I $L(Z( CNT))>50 S  Z(CNT)=$J ("",80-$L( Z(CNT))\2) _Z(CNT),CN T=CNT+1,Z( CNT)=""
  15387   "RTN","RCD PEM4",230, 0)
  15388    ;
  15389   "RTN","RCD PEM4",231, 0)
  15390    I Z(CNT)] "" S Z(CNT )=$J("",80 -$L(Z(CNT) )\2)_Z(CNT )
  15391   "RTN","RCD PEM4",232, 0)
  15392    I Z(CNT)= "" K Z(CNT )
  15393   "RTN","RCD PEM4",233, 0)
  15394    Q
  15395   "RTN","RCD PEM4",234, 0)
  15396    ;
  15397   "RTN","RCD PEM4",235, 0)
  15398   HDRBLD ; c reate the  report hea der
  15399   "RTN","RCD PEM4",236, 0)
  15400    ; returns  RCHDR, RC PGNUM, RCS TOP
  15401   "RTN","RCD PEM4",237, 0)
  15402    ;   RCHDR (0) = head er text li ne count
  15403   "RTN","RCD PEM4",238, 0)
  15404    ;   RCHDR ("XECUTE")  = M code  for page n umber
  15405   "RTN","RCD PEM4",239, 0)
  15406    ;   RCHDR ("RUNDATE" ) = date/t ime report  generated , external  format
  15407   "RTN","RCD PEM4",240, 0)
  15408    ;   RCPGN UM - page  counter
  15409   "RTN","RCD PEM4",241, 0)
  15410    ;   RCSTO P - flag t o exit
  15411   "RTN","RCD PEM4",242, 0)
  15412    ; INPUT: 
  15413   "RTN","RCD PEM4",243, 0)
  15414    ;   RCDIS PTY - Disp lay/print/ Excel flag
  15415   "RTN","RCD PEM4",244, 0)
  15416    ;   RCDTR NG - date  range
  15417   "RTN","RCD PEM4",245, 0)
  15418    ;   RCRTY P - Report  Type (EOB  or ERA)
  15419   "RTN","RCD PEM4",246, 0)
  15420    ;   VAUTD
  15421   "RTN","RCD PEM4",247, 0)
  15422    K RCHDR S  RCHDR("RU NDATE")=$$ NOW^RCDPEA RL,RCPGNUM =0,RCSTOP= 0
  15423   "RTN","RCD PEM4",248, 0)
  15424    ;
  15425   "RTN","RCD PEM4",249, 0)
  15426    I RCDISPT Y D  Q  ;  Excel form at, xecute  code is Q UIT, null  page numbe r
  15427   "RTN","RCD PEM4",250, 0)
  15428    .S RCHDR( 0)=1,RCHDR (1)="^^^", RCHDR("XEC UTE")="Q", RCPGNUM=""
  15429   "RTN","RCD PEM4",251, 0)
  15430    .S:RCRTYP ="ERA" RCH DR(1)="STA TION^STATI ON NUMBER^ DATE/TIME^ USER^ERA^R ECEIPT^MAT CH STATUS^ POSTED STA TUS"
  15431   "RTN","RCD PEM4",252, 0)
  15432    .S:RCRTYP ="EOB" RCH DR(1)="STA TION^STATI ON NUMBER^ DATE/TIME^ USER^ORIGI NAL BILL^N EW BILL^ER A#^TRACE#^ PAYMENT AM OUNT^JUSTI FICATION^O THER BILLS ^MOVED/COP IED"
  15433   "RTN","RCD PEM4",253, 0)
  15434    ;
  15435   "RTN","RCD PEM4",254, 0)
  15436    N START,E ND,MSG,DAT E,Y,DIV,HC NT,J
  15437   "RTN","RCD PEM4",255, 0)
  15438    S START=$ $FMTE^XLFD T($P(RCDTR NG,U,2),"2 Z"),END=$$ FMTE^XLFDT ($P(RCDTRN G,U,3),"2Z "),HCNT=0
  15439   "RTN","RCD PEM4",256, 0)
  15440    ;
  15441   "RTN","RCD PEM4",257, 0)
  15442    S RCHDR(0 )=0  ; hea der line c ount
  15443   "RTN","RCD PEM4",258, 0)
  15444    X "S Y=$$ HDR"_RCRTY P S HCNT=1
  15445   "RTN","RCD PEM4",259, 0)
  15446    ;
  15447   "RTN","RCD PEM4",260, 0)
  15448    I RCRTYP= "ERA" D
  15449   "RTN","RCD PEM4",261, 0)
  15450    .D HDRXEC (RCRTYP)   ; xecute c ode for li ne 1
  15451   "RTN","RCD PEM4",262, 0)
  15452    .S Y="Run  Date/Time : "_RCHDR( "RUNDATE")
  15453   "RTN","RCD PEM4",263, 0)
  15454    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15455   "RTN","RCD PEM4",264, 0)
  15456    .S Y="DIV ISIONS: "_ $S(VAUTD=1 :"ALL",1:D VFLTR)
  15457   "RTN","RCD PEM4",265, 0)
  15458    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15459   "RTN","RCD PEM4",266, 0)
  15460    .S Y="Dat e Range: " _START_" -  "_END_" ( DATE ERA U PDATED)"
  15461   "RTN","RCD PEM4",267, 0)
  15462    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15463   "RTN","RCD PEM4",268, 0)
  15464    .S Y="" F  J="CHAMPV A","TRICAR E" S Y=Y_"  "_J_": "_ $S($G(RCXC LUDE(J)):" NO",1:"YES ")_"    "
  15465   "RTN","RCD PEM4",269, 0)
  15466    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15467   "RTN","RCD PEM4",270, 0)
  15468    .S HCNT=H CNT+1,RCHD R(HCNT)=""
  15469   "RTN","RCD PEM4",271, 0)
  15470    .S HCNT=H CNT+1,RCHD R(HCNT)="                           Date/Ti me          User Who         EFT  Match Sta tus"
  15471   "RTN","RCD PEM4",272, 0)
  15472    .S HCNT=H CNT+1,RCHD R(HCNT)="E RA #       Receipt #     ERA Upd ated        Updated               Detail Po st Status"
  15473   "RTN","RCD PEM4",273, 0)
  15474    .S RCHDR( 0)=HCNT  ;  header li ne count
  15475   "RTN","RCD PEM4",274, 0)
  15476    ;
  15477   "RTN","RCD PEM4",275, 0)
  15478    I RCRTYP= "EOB" D
  15479   "RTN","RCD PEM4",276, 0)
  15480    .D HDRXEC (RCRTYP)   ; xecute c ode for li ne 1
  15481   "RTN","RCD PEM4",277, 0)
  15482    .S Y="Run  Date/Time : "_RCHDR( "RUNDATE")
  15483   "RTN","RCD PEM4",278, 0)
  15484    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15485   "RTN","RCD PEM4",279, 0)
  15486    .S Y="Div isions: "_ $S(VAUTD=1 :"ALL",1:D VFLTR)
  15487   "RTN","RCD PEM4",280, 0)
  15488    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15489   "RTN","RCD PEM4",281, 0)
  15490    .S Y="Dat e Range: " _START_" -  "_END_" ( Date EEOB  was Moved/ Copied/Rem oved)"
  15491   "RTN","RCD PEM4",282, 0)
  15492    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15493   "RTN","RCD PEM4",283, 0)
  15494    .S Y="" F  J="CHAMPV A","TRICAR E" S Y=Y_"     "_J_":  "_$S($G(R CXCLUDE(J) ):"NO",1:" YES")_"     "
  15495   "RTN","RCD PEM4",284, 0)
  15496    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15497   "RTN","RCD PEM4",285, 0)
  15498    .S Y=" Ac tion(s) Se lected: "_ $S(RCACT=" M":"MOVE", RCACT="C": "COPY",RCA CT="R":"RE MOVE",1:"A LL")
  15499   "RTN","RCD PEM4",286, 0)
  15500    .S HCNT=H CNT+1,RCHD R(HCNT)=$J ("",80-$L( Y)\2)_Y
  15501   "RTN","RCD PEM4",287, 0)
  15502    .S HCNT=H CNT+1,RCHD R(HCNT)=""
  15503   "RTN","RCD PEM4",288, 0)
  15504    .S HCNT=H CNT+1,RCHD R(HCNT)="O rig Bill#           T race #"
  15505   "RTN","RCD PEM4",289, 0)
  15506    .S HCNT=H CNT+1,RCHD R(HCNT)="                                      Moved/C opied/   T otal Amt   User Who M oved/"
  15507   "RTN","RCD PEM4",290, 0)
  15508    .S HCNT=H CNT+1,RCHD R(HCNT)="      ERA #      Date/T ime           Removed          P aid        Copied/Rem oved"
  15509   "RTN","RCD PEM4",291, 0)
  15510    .S RCHDR( 0)=HCNT  ;  header li ne count
  15511   "RTN","RCD PEM4",292, 0)
  15512    ;
  15513   "RTN","RCD PEM4",293, 0)
  15514    ; add row  of equal  signs, not  for ListM an
  15515   "RTN","RCD PEM4",294, 0)
  15516    S Y=RCHDR (0)+1,RCHD R(0)=Y,RCH DR(Y)=$TR( $J("",80), " ","=")
  15517   "RTN","RCD PEM4",295, 0)
  15518    Q
  15519   "RTN","RCD PEM4",296, 0)
  15520    ;
  15521   "RTN","RCD PEM4",297, 0)
  15522   HDRLM ; cr eate the L istman hea der
  15523   "RTN","RCD PEM4",298, 0)
  15524    ; returns  RCHDR
  15525   "RTN","RCD PEM4",299, 0)
  15526    ;   RCHDR (0) = head er text li ne count
  15527   "RTN","RCD PEM4",300, 0)
  15528    ; INPUT: 
  15529   "RTN","RCD PEM4",301, 0)
  15530    ;   RCDTR NG - date  range
  15531   "RTN","RCD PEM4",302, 0)
  15532    ;   VAUTD  - Divisio n  filter  value(s)
  15533   "RTN","RCD PEM4",303, 0)
  15534    N START,E ND,MSG,DAT E,Y,DIV,HC NT,J
  15535   "RTN","RCD PEM4",304, 0)
  15536    S START=$ $FMTE^XLFD T($P(RCDTR NG,U,2),"2 Z"),END=$$ FMTE^XLFDT ($P(RCDTRN G,U,3),"2Z "),HCNT=0
  15537   "RTN","RCD PEM4",305, 0)
  15538    ;
  15539   "RTN","RCD PEM4",306, 0)
  15540    S RCHDR(0 )=0  ; hea der line c ount
  15541   "RTN","RCD PEM4",307, 0)
  15542    X "S Y=$$ HDR"_RCRTY P
  15543   "RTN","RCD PEM4",308, 0)
  15544    I RCRTYP= "ERA" D
  15545   "RTN","RCD PEM4",309, 0)
  15546    .D HDRXEC (RCRTYP)   ; xecute c ode for li ne 1
  15547   "RTN","RCD PEM4",310, 0)
  15548    .S HCNT=1 ,RCHDR(HCN T)=""
  15549   "RTN","RCD PEM4",311, 0)
  15550    .S Y="Div isions: "_ $S(VAUTD=1 :"ALL",1:D VFLTR)
  15551   "RTN","RCD PEM4",312, 0)
  15552    .F J="CHA MPVA","TRI CARE" S Y= Y_"     "_ J_": "_$S( $G(RCXCLUD E(J)):"NO" ,1:"YES")_ "     "
  15553   "RTN","RCD PEM4",313, 0)
  15554    .S HCNT=H CNT+1,RCHD R(HCNT)=Y
  15555   "RTN","RCD PEM4",314, 0)
  15556    .S HCNT=H CNT+1,RCHD R(HCNT)=""
  15557   "RTN","RCD PEM4",315, 0)
  15558    .S Y="Dat e Range: " _START_" -  "_END_" ( DATE ERA U PDATED)"
  15559   "RTN","RCD PEM4",316, 0)
  15560    .S HCNT=H CNT+1,RCHD R(HCNT)=Y
  15561   "RTN","RCD PEM4",317, 0)
  15562    .S HCNT=H CNT+1,RCHD R(HCNT)=""
  15563   "RTN","RCD PEM4",318, 0)
  15564    .S HCNT=H CNT+1,RCHD R(HCNT)="                           Date/Ti me          User Who         EFT  Match Sta tus"
  15565   "RTN","RCD PEM4",319, 0)
  15566    .S HCNT=H CNT+1,RCHD R(HCNT)="E RA #       Receipt #     ERA Upd ated        Updated               Detail Po st Status"
  15567   "RTN","RCD PEM4",320, 0)
  15568    .S RCHDR( 0)=HCNT  ;  header li ne count
  15569   "RTN","RCD PEM4",321, 0)
  15570    ;
  15571   "RTN","RCD PEM4",322, 0)
  15572    I RCRTYP= "EOB" D
  15573   "RTN","RCD PEM4",323, 0)
  15574    .D HDRXEC (RCRTYP)   ; xecute c ode for li ne 1
  15575   "RTN","RCD PEM4",324, 0)
  15576    .S Y="Div isions: "_ $S(VAUTD=1 :"ALL",1:D VFLTR)_"      "
  15577   "RTN","RCD PEM4",325, 0)
  15578    .F J="CHA MPVA","TRI CARE" S Y= Y_"     "_ J_": "_$S( $G(RCXCLUD E(J)):"NO" ,1:"YES")_ "     "
  15579   "RTN","RCD PEM4",326, 0)
  15580    .S HCNT=1 ,RCHDR(HCN T)=Y
  15581   "RTN","RCD PEM4",327, 0)
  15582    .S Y="Dat e Range: " _START_" -  "_END_" ( Date EEOB  was Moved/ Copied/Rem oved)"
  15583   "RTN","RCD PEM4",328, 0)
  15584    .S HCNT=2 ,RCHDR(HCN T)=Y
  15585   "RTN","RCD PEM4",329, 0)
  15586    .S Y="Act ion(s) Sel ected: "_$ S(RCACT="M ":"MOVE",R CACT="C":" COPY",RCAC T="R":"REM OVE",1:"AL L")
  15587   "RTN","RCD PEM4",330, 0)
  15588    .S HCNT=3 ,RCHDR(HCN T)=Y
  15589   "RTN","RCD PEM4",331, 0)
  15590    .S HCNT=4 ,RCHDR(HCN T)=""
  15591   "RTN","RCD PEM4",332, 0)
  15592    .S HCNT=5 ,RCHDR(HCN T)="Orig B ill#           Trace  #"
  15593   "RTN","RCD PEM4",333, 0)
  15594    .S HCNT=6 ,RCHDR(HCN T)="                                     Mo ved/Copied /   Total  Amt  User  Who Moved/ "
  15595   "RTN","RCD PEM4",334, 0)
  15596    .S HCNT=7 ,RCHDR(HCN T)="     E RA #     D ate/Time           Re moved          Paid        Copie d/Removed"
  15597   "RTN","RCD PEM4",335, 0)
  15598    .S RCHDR( 0)=HCNT  ;  header li ne count
  15599   "RTN","RCD PEM4",336, 0)
  15600    ;
  15601   "RTN","RCD PEM4",337, 0)
  15602    ; add row  of equal  signs, not  for ListM an
  15603   "RTN","RCD PEM4",338, 0)
  15604    S:'RCLSTM GR Y=RCHDR (0)+1,RCHD R(0)=Y,RCH DR(Y)=" "_ $TR($J("", 78)," ","= ")
  15605   "RTN","RCD PEM4",339, 0)
  15606    Q
  15607   "RTN","RCD PEM4",340, 0)
  15608    ;
  15609   "RTN","RCD PEM4",341, 0)
  15610   HDREOB() ;  extrinsic  variable,  header fo r EOB repo rt
  15611   "RTN","RCD PEM4",342, 0)
  15612    Q "EEOB M ove/Copy/R emove - Au dit Report "
  15613   "RTN","RCD PEM4",343, 0)
  15614    ;
  15615   "RTN","RCD PEM4",344, 0)
  15616   HDRERA() ;  extrinsic  variable,  header fo r ERA repo rt
  15617   "RTN","RCD PEM4",345, 0)
  15618    Q "ERAs P osted with  Paper EOB  - Audit R eport"
  15619   "RTN","RCD PEM4",346, 0)
  15620    ;
  15621   "RTN","RCD PEM4",347, 0)
  15622   HDRXEC(TYP ) ; create  xecute co de for hea der
  15623   "RTN","RCD PEM4",348, 0)
  15624    S RCHDR(" XECUTE")=" N Y S RCPG NUM=RCPGNU M+1,Y=$$HD R"_TYP_"^" _$T(+0)_", RCHDR(1)=$ J("" "",80 -$L(Y)\2)_ Y"_"_""           Pag e: ""_RCPG NUM"
  15625   "RTN","RCD PEM4",349, 0)
  15626    Q
  15627   "RTN","RCD PEM4",350, 0)
  15628    ;
  15629   "RTN","RCD PEM4",351, 0)
  15630   DTRNG() ;  function,  return dat e range fo r a report
  15631   "RTN","RCD PEM4",352, 0)
  15632    N DIR,DUO UT,X,Y,RCS TART,RCEND
  15633   "RTN","RCD PEM4",353, 0)
  15634    D DATES(. RCSTART,.R CEND)
  15635   "RTN","RCD PEM4",354, 0)
  15636    Q:RCSTART =-1 0
  15637   "RTN","RCD PEM4",355, 0)
  15638    Q:RCSTART  "1^"_RCST ART_"^"_RC END
  15639   "RTN","RCD PEM4",356, 0)
  15640    Q:'RCSTAR T "0^^"
  15641   "RTN","RCD PEM4",357, 0)
  15642    Q 0
  15643   "RTN","RCD PEM4",358, 0)
  15644    ;
  15645   "RTN","RCD PEM4",359, 0)
  15646   DATES(BDAT E,EDATE) ; Get a date  range.
  15647   "RTN","RCD PEM4",360, 0)
  15648    S (BDATE, EDATE)=0
  15649   "RTN","RCD PEM4",361, 0)
  15650    S DIR("?" )="Enter t he latest  date of re ceipt of d eposit to  include on  the repor t."
  15651   "RTN","RCD PEM4",362, 0)
  15652    S DIR(0)= "DAO^:"_DT _":APE",DI R("A")="St art date:  " D ^DIR K  DIR
  15653   "RTN","RCD PEM4",363, 0)
  15654    I $D(DTOU T)!$D(DUOU T)!(Y="")  S BDATE=-1  Q
  15655   "RTN","RCD PEM4",364, 0)
  15656    S BDATE=Y
  15657   "RTN","RCD PEM4",365, 0)
  15658    S DIR("?" )="Enter t he latest  date of re ceipt of d eposit to  include on  the repor t."
  15659   "RTN","RCD PEM4",366, 0)
  15660    S DIR("B" )=Y(0)
  15661   "RTN","RCD PEM4",367, 0)
  15662    S DIR(0)= "DAO^"_BDA TE_":"_DT_ ":APE",DIR ("A")="  E nd date: "  D ^DIR K  DIR
  15663   "RTN","RCD PEM4",368, 0)
  15664    I $D(DTOU T)!$D(DUOU T)!(Y="")  S BDATE=-1  Q
  15665   "RTN","RCD PEM4",369, 0)
  15666    S EDATE=Y
  15667   "RTN","RCD PEM4",370, 0)
  15668    Q
  15669   "RTN","RCD PEM4",371, 0)
  15670    ;
  15671   "RTN","RCD PEM4",372, 0)
  15672   STADIV ;Di vision/Sta tion Filte r/Sort
  15673   "RTN","RCD PEM4",373, 0)
  15674    ;
  15675   "RTN","RCD PEM4",374, 0)
  15676    ;Sort sel ection
  15677   "RTN","RCD PEM4",375, 0)
  15678    N DIR,DUO UT,Y
  15679   "RTN","RCD PEM4",376, 0)
  15680    S RCDIV=0
  15681   "RTN","RCD PEM4",377, 0)
  15682    ;
  15683   "RTN","RCD PEM4",378, 0)
  15684    ;Division  selection  - IA 664
  15685   "RTN","RCD PEM4",379, 0)
  15686    ;RETURNS  Y=-1 (quit ), VAUTD=1  (for all) ,VAUTD=0 ( selected d ivisions i n VAUTD)
  15687   "RTN","RCD PEM4",380, 0)
  15688    D DIVISIO N^VAUTOMA  Q:Y<0
  15689   "RTN","RCD PEM4",381, 0)
  15690    ;
  15691   "RTN","RCD PEM4",382, 0)
  15692    ;If ALL s elected
  15693   "RTN","RCD PEM4",383, 0)
  15694    I VAUTD=1  S RCDIV=1  Q
  15695   "RTN","RCD PEM4",384, 0)
  15696    ;If some  DIVISIONS  selected
  15697   "RTN","RCD PEM4",385, 0)
  15698    S RCDIV=2
  15699   "RTN","RCD PEM4",386, 0)
  15700    Q
  15701   "RTN","RCD PEM4",387, 0)
  15702    ;
  15703   "RTN","RCD PEM4",388, 0)
  15704   ACTION() ;  Get actio n type
  15705   "RTN","RCD PEM4",389, 0)
  15706    N DIR,X,Y ,DIROUT,DU OUT
  15707   "RTN","RCD PEM4",390, 0)
  15708    S DIR("A" )="Move/Co py/Remove  or All (M/ C/R/A): "
  15709   "RTN","RCD PEM4",391, 0)
  15710    S DIR("B" )="All"  ;  default t o ALL
  15711   "RTN","RCD PEM4",392, 0)
  15712    S DIR(0)= "SAB^M:Mov e;C:Copy;R :Remove;A: All"
  15713   "RTN","RCD PEM4",393, 0)
  15714    D ^DIR Q: $G(DIROUT) !$G(DUOUT)  -1
  15715   "RTN","RCD PEM4",394, 0)
  15716    ;
  15717   "RTN","RCD PEM4",395, 0)
  15718    Q Y
  15719   "RTN","RCD PEM4",396, 0)
  15720    ;
  15721   "RTN","RCD PEM4",397, 0)
  15722   DISPTY() ;  Get displ ay/output  type
  15723   "RTN","RCD PEM4",398, 0)
  15724    N DIR,DTO UT,DUOUT,X ,Y
  15725   "RTN","RCD PEM4",399, 0)
  15726    S DIR(0)= "YA"
  15727   "RTN","RCD PEM4",400, 0)
  15728    S DIR("A" )="Export  the report  to Micros oft Excel?  "
  15729   "RTN","RCD PEM4",401, 0)
  15730    S DIR("B" )="NO"
  15731   "RTN","RCD PEM4",402, 0)
  15732    D ^DIR I  $G(DUOUT)  Q -1
  15733   "RTN","RCD PEM4",403, 0)
  15734    Q Y
  15735   "RTN","RCD PEM4",404, 0)
  15736    ;
  15737   "RTN","RCD PEM4",405, 0)
  15738   ERASTA(ERA IEN,STA,ST NUM,STNAM)  ; Get the  station f or this ER A
  15739   "RTN","RCD PEM4",406, 0)
  15740    ; read al lowed on B ILL/CLAIMS  file (#39 9) via IA  3820
  15741   "RTN","RCD PEM4",407, 0)
  15742    ; returns  STA: stat ion IEN, S TNAM: stat ion name,  STNUM: sta tion numbe r
  15743   "RTN","RCD PEM4",408, 0)
  15744    N ERAEOB, ERABILL,ST AIEN
  15745   "RTN","RCD PEM4",409, 0)
  15746    S (ERAEOB ,ERABILL)= ""
  15747   "RTN","RCD PEM4",410, 0)
  15748    S (STA,ST NUM,STNAM) ="UNKNOWN"
  15749   "RTN","RCD PEM4",411, 0)
  15750    D
  15751   "RTN","RCD PEM4",412, 0)
  15752    .S ERAEOB =$P($G(^RC Y(344.4,ER AIEN,1,1,0 )),U,2) Q: 'ERAEOB  ;  if EOB po inter not  on first s ub-file en try then s top
  15753   "RTN","RCD PEM4",413, 0)
  15754    .S ERABIL L=$P($G(^I BM(361.1,E RAEOB,0)), U,1) Q:'ER ABILL  ; E XPLANATION  OF BENEFI TS file (# 361.1)
  15755   "RTN","RCD PEM4",414, 0)
  15756    .S STAIEN =$P($G(^DG CR(399,ERA BILL,0)),U ,22) Q:'ST AIEN  ;(#. 22) DEFAUL T DIVISION  [22P:40.8 ]
  15757   "RTN","RCD PEM4",415, 0)
  15758    .S STA=ST AIEN
  15759   "RTN","RCD PEM4",416, 0)
  15760    .S STNAM= $$EXTERNAL ^DILFD(399 ,.22,,STA)
  15761   "RTN","RCD PEM4",417, 0)
  15762    .S STNUM= $P($G(^DG( 40.8,STAIE N,0)),U,2)  ;IA 417
  15763   "RTN","RCD PEM4",418, 0)
  15764    ;
  15765   "RTN","RCD PEM4",419, 0)
  15766    Q
  15767   "RTN","RCD PEM4",420, 0)
  15768    ;
  15769   "RTN","RCD PEM4",421, 0)
  15770   EOBSTA(EOB IEN,STA,ST NUM,STNAM)  ; Get the  station f or this EO B
  15771   "RTN","RCD PEM4",422, 0)
  15772    ;Allowed  read on 39 9 via IA 3 820
  15773   "RTN","RCD PEM4",423, 0)
  15774    N BILL,ST AIEN
  15775   "RTN","RCD PEM4",424, 0)
  15776    S (BILL)= ""
  15777   "RTN","RCD PEM4",425, 0)
  15778    S (STA,ST NUM,STNAM) ="UNKNOWN"
  15779   "RTN","RCD PEM4",426, 0)
  15780    D
  15781   "RTN","RCD PEM4",427, 0)
  15782    .S BILL=$ P(^IBM(361 .1,EOBIEN, 0),U,1) Q: 'BILL
  15783   "RTN","RCD PEM4",428, 0)
  15784    .S STAIEN =$P($G(^DG CR(399,BIL L,0)),U,22 ) Q:'STAIE N
  15785   "RTN","RCD PEM4",429, 0)
  15786    .S STA=ST AIEN
  15787   "RTN","RCD PEM4",430, 0)
  15788    .S STNAM= $$EXTERNAL ^DILFD(399 ,.22,,STA)
  15789   "RTN","RCD PEM4",431, 0)
  15790    .S STNUM= $P($G(^DG( 40.8,STAIE N,0)),U,2)  ;IA 417
  15791   "RTN","RCD PEM4",432, 0)
  15792    Q
  15793   "RTN","RCD PEM4",433, 0)
  15794    ;
  15795   "RTN","RCD PEM4",434, 0)
  15796   DTPRB() ;  Get the St art Date t ype
  15797   "RTN","RCD PEM4",435, 0)
  15798    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,X,Y
  15799   "RTN","RCD PEM4",436, 0)
  15800    S DIR(0)= "SABO^W:Da te Removed  from Work list;R:Dat e ERA Rece ived;B:Bot h Dates"
  15801   "RTN","RCD PEM4",437, 0)
  15802    S DIR("A" )="Select  Start Date  Type: "
  15803   "RTN","RCD PEM4",438, 0)
  15804    D ^DIR K  DIR
  15805   "RTN","RCD PEM4",439, 0)
  15806    I $D(DTOU T)!$D(DUOU T)!(Y="")  S Y=0
  15807   "RTN","RCD PEM4",440, 0)
  15808    Q Y
  15809   "RTN","RCD PEM4",441, 0)
  15810    ;
  15811   "RTN","RCD PEM4",442, 0)
  15812   WP(JC) ; f ormat just ification  comments
  15813   "RTN","RCD PEM4",443, 0)
  15814    ; JC - Ju stificatio n Comment
  15815   "RTN","RCD PEM4",444, 0)
  15816    I JC="" Q
  15817   "RTN","RCD PEM4",445, 0)
  15818    N PCS,I,C NTR,CMNT,Y
  15819   "RTN","RCD PEM4",446, 0)
  15820    ; PCS - N umber of "  " $pieces  in the co mment
  15821   "RTN","RCD PEM4",447, 0)
  15822    ; CNTR -  CMNT line  counter
  15823   "RTN","RCD PEM4",448, 0)
  15824    ; CMNT -  comment te xt to be d isplayed
  15825   "RTN","RCD PEM4",449, 0)
  15826    S PCS=$L( JC," "),CN TR=1,CMNT( CNTR)=" Ju stificatio n Comments : "
  15827   "RTN","RCD PEM4",450, 0)
  15828    F I=1:1:P CS D
  15829   "RTN","RCD PEM4",451, 0)
  15830    .S Y=$P(J C," ",I)
  15831   "RTN","RCD PEM4",452, 0)
  15832    .S:$L(CMN T(CNTR))+$ L(Y)>72 CN TR=CNTR+1, CMNT(CNTR) =$J(" ",25 )
  15833   "RTN","RCD PEM4",453, 0)
  15834    .S CMNT(C NTR)=CMNT( CNTR)_" "_ Y
  15835   "RTN","RCD PEM4",454, 0)
  15836    ;
  15837   "RTN","RCD PEM4",455, 0)
  15838    F I=1:1:C NTR D SL^R CDPEARL(CM NT(I),.RCL NCNT,RCTMP ND)
  15839   "RTN","RCD PEM4",456, 0)
  15840    Q
  15841   "RTN","RCD PEM4",457, 0)
  15842    ;
  15843   "RTN","RCD PEM5")
  15844   0^21^B1544 73324
  15845   "RTN","RCD PEM5",1,0)
  15846   RCDPEM5 ;A LB/PJH - E PAYMENTS M OVE EEOB T O NEW CLAI M ;Oct 29,  2014@16:4 3:51
  15847   "RTN","RCD PEM5",2,0)
  15848    ;;4.5;Acc ounts Rece ivable;**1 73,208,276 ,298,321** ;Mar 20, 1 995;Build  46
  15849   "RTN","RCD PEM5",3,0)
  15850    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  15851   "RTN","RCD PEM5",4,0)
  15852    Q
  15853   "RTN","RCD PEM5",5,0)
  15854    ;
  15855   "RTN","RCD PEM5",6,0)
  15856   EN ;Entry  point for  EEOB Move/ Copy/Remov e [RCDPE E EOB MOVE/C OPY/REMOVE ] option
  15857   "RTN","RCD PEM5",7,0)
  15858    ;
  15859   "RTN","RCD PEM5",8,0)
  15860    N DIR,X,Y ,DIROUT,DU OUT,MODE
  15861   "RTN","RCD PEM5",9,0)
  15862    S DIR("A" )="Select  action"
  15863   "RTN","RCD PEM5",10,0 )
  15864    S DIR("B" )="M"
  15865   "RTN","RCD PEM5",11,0 )
  15866    S DIR(0)= "S^M:Move  EEOB to di fferent cl aim;"
  15867   "RTN","RCD PEM5",12,0 )
  15868    S DIR(0)= DIR(0)_"C: Copy EEOB  to multipl e claims;"
  15869   "RTN","RCD PEM5",13,0 )
  15870    S DIR(0)= DIR(0)_"R: Remove EEO B from cla im"
  15871   "RTN","RCD PEM5",14,0 )
  15872    D ^DIR Q: $G(DIROUT) !$G(DUOUT)
  15873   "RTN","RCD PEM5",15,0 )
  15874    S MODE=Y
  15875   "RTN","RCD PEM5",16,0 )
  15876    ;
  15877   "RTN","RCD PEM5",17,0 )
  15878    ; - PRCA* 4.5*298 -  OWNSKEY^XU SRB - Supp orted IA 3 277  
  15879   "RTN","RCD PEM5",18,0 )
  15880    I MODE="R " N MSG D  OWNSKEY^XU SRB(.MSG," RCDPE REMO VE EEOB",D UZ) I 'MSG (0) D  Q
  15881   "RTN","RCD PEM5",19,0 )
  15882    .W !!,"SO RRY, YOU A RE NOT AUT HORIZED TO  USE THIS  ACTION"
  15883   "RTN","RCD PEM5",20,0 )
  15884    .W !,"Thi s action i s locked w ith RCDPE  REMOVE EEO B key.",!
  15885   "RTN","RCD PEM5",21,0 )
  15886    .N DIR S  DIR(0)="E"  D ^DIR
  15887   "RTN","RCD PEM5",22,0 )
  15888    ;
  15889   "RTN","RCD PEM5",23,0 )
  15890    ;Read acc ess to fil e #361.1 u nder IA 40 51
  15891   "RTN","RCD PEM5",24,0 )
  15892    ;
  15893   "RTN","RCD PEM5",25,0 )
  15894    N DA,DIC, DIE,DIR,DR ,NCLAIM,OR IG,ORIGNAM ,X,Y
  15895   "RTN","RCD PEM5",26,0 )
  15896    ;
  15897   "RTN","RCD PEM5",27,0 )
  15898    ;Allow se lection of  a origina l third pa rty EOB
  15899   "RTN","RCD PEM5",28,0 )
  15900    S DIC("A" )="Select  EXPLANATIO N OF BENEF IT (EEOB)  to "_$S(MO DE="M":"MO VE",MODE=" R":"REMOVE ",1:"COPY" )_": "
  15901   "RTN","RCD PEM5",29,0 )
  15902    ; screen  to only al low select ion of an  active EEO B (not mar ked as del eted) and  non-MRA ty pe EOB
  15903   "RTN","RCD PEM5",30,0 )
  15904    S DIC("S" )="I ($P(^ (0),U,4)=0 )&('$P($G( ^(102)),U) )",DIC="^I BM(361.1," ,DIC(0)="A EMQ"
  15905   "RTN","RCD PEM5",31,0 )
  15906    W ! D ^DI C K DIC
  15907   "RTN","RCD PEM5",32,0 )
  15908    ;
  15909   "RTN","RCD PEM5",33,0 )
  15910    I Y'>0 Q
  15911   "RTN","RCD PEM5",34,0 )
  15912    ; control led subscr iption IA  1992
  15913   "RTN","RCD PEM5",35,0 )
  15914    S ORIG=+Y ,ORIGNAM=$ $GET1^DIQ( 399,$P(Y,U ,2),.01)
  15915   "RTN","RCD PEM5",36,0 )
  15916    ;
  15917   "RTN","RCD PEM5",37,0 )
  15918    ;Get curr ent bill p ayer seque nce from c laim - IA  3820
  15919   "RTN","RCD PEM5",38,0 )
  15920    D
  15921   "RTN","RCD PEM5",39,0 )
  15922    .N CURR,I EN399
  15923   "RTN","RCD PEM5",40,0 )
  15924    .S IEN399 =$P($G(^IB M(361.1,OR IG,0)),U)  Q:'IEN399
  15925   "RTN","RCD PEM5",41,0 )
  15926    .S CURR=$ P($G(^DGCR (399,IEN39 9,0)),U,21 ) I (CURR' ="T")&(CUR R'="S") Q
  15927   "RTN","RCD PEM5",42,0 )
  15928    .W !!,"Wa rning - se lected EEO B has seco ndary clai ms and may  have tert iary claim s"
  15929   "RTN","RCD PEM5",43,0 )
  15930    ;
  15931   "RTN","RCD PEM5",44,0 )
  15932    ;Lock Ori ginal EOB
  15933   "RTN","RCD PEM5",45,0 )
  15934    Q:'$$LOCK ^IBCEOB4(O RIG)
  15935   "RTN","RCD PEM5",46,0 )
  15936    ;
  15937   "RTN","RCD PEM5",47,0 )
  15938    ;Remove O ption
  15939   "RTN","RCD PEM5",48,0 )
  15940    I MODE="R " D REMOVE (ORIG,MODE ),EXIT Q
  15941   "RTN","RCD PEM5",49,0 )
  15942    ;
  15943   "RTN","RCD PEM5",50,0 )
  15944    ;Select C laim(s) to  Move/Copy  to
  15945   "RTN","RCD PEM5",51,0 )
  15946    N RCBILL, RCBILLNM,N CLAIM,NCLA IMX,QUIT,S UB,LIT
  15947   "RTN","RCD PEM5",52,0 )
  15948    S SUB=0,Q UIT=0,LIT= ""
  15949   "RTN","RCD PEM5",53,0 )
  15950    W !
  15951   "RTN","RCD PEM5",54,0 )
  15952    F  D  Q:Q UIT  Q:SUB &(MODE="M" )
  15953   "RTN","RCD PEM5",55,0 )
  15954    .;Allow s election o f a third  party clai m
  15955   "RTN","RCD PEM5",56,0 )
  15956    .I MODE=" M" S DIC(" A")="Selec t A/R Bill  to MOVE t o: "
  15957   "RTN","RCD PEM5",57,0 )
  15958    .I MODE=" C" S DIC(" A")="Selec t "_LIT_"A /R Bill to  COPY to:  "
  15959   "RTN","RCD PEM5",58,0 )
  15960    .S DIC="^ PRCA(430," ,DIC(0)="A EMQ",DIC(" S")="I $D( ^DGCR(399, +Y,0))&($$ VALSTAT^RC DPEM5(+Y)) "
  15961   "RTN","RCD PEM5",59,0 )
  15962    .D ^DIC K  DIC
  15963   "RTN","RCD PEM5",60,0 )
  15964    .I Y'>0 S  QUIT=1 Q
  15965   "RTN","RCD PEM5",61,0 )
  15966    .S RCBILL =+Y,RCBILL NM=$P($P(Y ,U,2),"-", 2)
  15967   "RTN","RCD PEM5",62,0 )
  15968    .I ORIGNA M=RCBILLNM ,MODE="M"  W !,"Canno t move EEO B to same  claim" Q
  15969   "RTN","RCD PEM5",63,0 )
  15970    .I $D(NCL AIMX(RCBIL L)) W !,"C laim alrea dy entered " Q
  15971   "RTN","RCD PEM5",64,0 )
  15972    .S SUB=SU B+1,NCLAIM (SUB)=RCBI LL,NCLAIMX (RCBILL)=" "
  15973   "RTN","RCD PEM5",65,0 )
  15974    .S:MODE=" C" LIT="an other "
  15975   "RTN","RCD PEM5",66,0 )
  15976    ;
  15977   "RTN","RCD PEM5",67,0 )
  15978    I $G(DUOU T)!$G(DIRO UT) D EXIT  Q
  15979   "RTN","RCD PEM5",68,0 )
  15980    ;
  15981   "RTN","RCD PEM5",69,0 )
  15982    ;User Exi t or no cl aims selec ted
  15983   "RTN","RCD PEM5",70,0 )
  15984    I '$O(NCL AIM("")) D  EXIT Q
  15985   "RTN","RCD PEM5",71,0 )
  15986    ;
  15987   "RTN","RCD PEM5",72,0 )
  15988    ;Prompt u ser to con tinue
  15989   "RTN","RCD PEM5",73,0 )
  15990    N DIR,X,Y ,DIROUT
  15991   "RTN","RCD PEM5",74,0 )
  15992    S DIR(0)= "Y",DIR("B ")="YES"
  15993   "RTN","RCD PEM5",75,0 )
  15994    S DIR("A" )=$$PROMPT (ORIG,.NCL AIM,MODE)
  15995   "RTN","RCD PEM5",76,0 )
  15996    W ! D ^DI R
  15997   "RTN","RCD PEM5",77,0 )
  15998    ;
  15999   "RTN","RCD PEM5",78,0 )
  16000    I $G(DIRO UT)!$G(DUO UT)!(Y=0)  D EXIT Q
  16001   "RTN","RCD PEM5",79,0 )
  16002    ;
  16003   "RTN","RCD PEM5",80,0 )
  16004    ;Enter Ju stificatio n Comment
  16005   "RTN","RCD PEM5",81,0 )
  16006    N DIR,DIR OUT,DUOUT, JCOM,X,Y
  16007   "RTN","RCD PEM5",82,0 )
  16008    S DIR(0)= "FA^1:100^ K:$TR(X,""  "","""")= """" X",DI R("A")="En ter JUSTIF ICATION CO MMENT: "
  16009   "RTN","RCD PEM5",83,0 )
  16010    W ! D ^DI R I $G(DIR OUT)!$G(DU OUT) W !!, "Update no t performe d" D EXIT  Q
  16011   "RTN","RCD PEM5",84,0 )
  16012    S JCOM=Y
  16013   "RTN","RCD PEM5",85,0 )
  16014    ;
  16015   "RTN","RCD PEM5",86,0 )
  16016    ;Update E OB
  16017   "RTN","RCD PEM5",87,0 )
  16018    D UPDATE( ORIG,.NCLA IM,MODE,JC OM),EXIT
  16019   "RTN","RCD PEM5",88,0 )
  16020    ;
  16021   "RTN","RCD PEM5",89,0 )
  16022    Q
  16023   "RTN","RCD PEM5",90,0 )
  16024    ;
  16025   "RTN","RCD PEM5",91,0 )
  16026    ;Unlock o riginal EO B
  16027   "RTN","RCD PEM5",92,0 )
  16028   EXIT D UNL OCK^IBCEOB 4(ORIG)
  16029   "RTN","RCD PEM5",93,0 )
  16030    Q
  16031   "RTN","RCD PEM5",94,0 )
  16032    ;
  16033   "RTN","RCD PEM5",95,0 )
  16034    ;File EOB  #361.1 ch anges - In tegration  Agreement  5671 for I BCEOB4
  16035   "RTN","RCD PEM5",96,0 )
  16036   UPDATE(ORI G,NCLAIM,M ODE,JUST)  ;
  16037   "RTN","RCD PEM5",97,0 )
  16038    ; Input -  ORIG - Or iginal EOB
  16039   "RTN","RCD PEM5",98,0 )
  16040    ;       -  NCLAIM -  New claim  (s)
  16041   "RTN","RCD PEM5",99,0 )
  16042    ;       -  MODE M=Mo ve C=Copy
  16043   "RTN","RCD PEM5",100, 0)
  16044    ;       -  JUST = Us er input j ustificati on text
  16045   "RTN","RCD PEM5",101, 0)
  16046    ; Output  -  Updates  EOB and A udit log
  16047   "RTN","RCD PEM5",102, 0)
  16048    N JUST1
  16049   "RTN","RCD PEM5",103, 0)
  16050    ;Move EOB
  16051   "RTN","RCD PEM5",104, 0)
  16052    I MODE="M " D
  16053   "RTN","RCD PEM5",105, 0)
  16054    .;Auto ge nerate tex t for AR c omments on  original  claim
  16055   "RTN","RCD PEM5",106, 0)
  16056    .S JUST1= $$JUST1(OR IG,.NCLAIM ,"M",0)
  16057   "RTN","RCD PEM5",107, 0)
  16058    .;Update  AR Comment s on the ' from bill'
  16059   "RTN","RCD PEM5",108, 0)
  16060    .D AUDIT^ RCDPAYER(O RIG,JUST_" ^"_JUST1,M ODE)
  16061   "RTN","RCD PEM5",109, 0)
  16062    .;Change  claim numb er on EEOB
  16063   "RTN","RCD PEM5",110, 0)
  16064    .D MOVE^I BCEOB4(ORI G,NCLAIM(1 ),DUZ,$$NO W^XLFDT,JU ST,MODE)
  16065   "RTN","RCD PEM5",111, 0)
  16066    .;Update  AR Comment s on 'to b ill'
  16067   "RTN","RCD PEM5",112, 0)
  16068    .D AUDIT^ RCDPAYER(O RIG,JUST_" ^"_JUST1,M ODE)
  16069   "RTN","RCD PEM5",113, 0)
  16070    ;Copy EOB
  16071   "RTN","RCD PEM5",114, 0)
  16072    I MODE="C " D
  16073   "RTN","RCD PEM5",115, 0)
  16074    .D COPY^I BCEOB4(ORI G,.NCLAIM, DUZ,$$NOW^ XLFDT,JUST ,MODE)
  16075   "RTN","RCD PEM5",116, 0)
  16076    .;Auto ge nerate tex t for AR c omments on  original  claim
  16077   "RTN","RCD PEM5",117, 0)
  16078    .S JUST1= $$JUST1(OR IG,.NCLAIM ,"C",0)
  16079   "RTN","RCD PEM5",118, 0)
  16080    .;Update  AR Comment s on origi nal claim
  16081   "RTN","RCD PEM5",119, 0)
  16082    .D AUDIT^ RCDPAYER(O RIG,JUST_" ^"_JUST1,M ODE)
  16083   "RTN","RCD PEM5",120, 0)
  16084    .;Auto ge nerate tex t for AR c omments on  new claim
  16085   "RTN","RCD PEM5",121, 0)
  16086    .S JUST1= $$JUST1(OR IG,.NCLAIM ,"C",1)
  16087   "RTN","RCD PEM5",122, 0)
  16088    .;Update  AR Comment s on new c laims
  16089   "RTN","RCD PEM5",123, 0)
  16090    .N SUB,NE WEOB
  16091   "RTN","RCD PEM5",124, 0)
  16092    .S SUB=0
  16093   "RTN","RCD PEM5",125, 0)
  16094    .F  S SUB =$O(NCLAIM (SUB)) Q:' SUB  D
  16095   "RTN","RCD PEM5",126, 0)
  16096    ..;Conver t Claim po inter to E OB pointer
  16097   "RTN","RCD PEM5",127, 0)
  16098    ..S NEWEO B=$O(^IBM( 361.1,"B", NCLAIM(SUB ),0)) Q:'N EWEOB
  16099   "RTN","RCD PEM5",128, 0)
  16100    ..D AUDIT ^RCDPAYER( NEWEOB,JUS T_"^"_JUST 1,MODE)
  16101   "RTN","RCD PEM5",129, 0)
  16102    W !!,"EEO B Update C omplete" H  1
  16103   "RTN","RCD PEM5",130, 0)
  16104    Q
  16105   "RTN","RCD PEM5",131, 0)
  16106    ;
  16107   "RTN","RCD PEM5",132, 0)
  16108   PROMPT(ORI G,NCLAIM,M ODE) ;Cons truct prom pt text
  16109   "RTN","RCD PEM5",133, 0)
  16110    ; Input -  ORIG - Or iginal EOB
  16111   "RTN","RCD PEM5",134, 0)
  16112    ;       -  NCLAIM -  New claim  (s)
  16113   "RTN","RCD PEM5",135, 0)
  16114    ;       -  MODE M=Mo ve C=Copy 
  16115   "RTN","RCD PEM5",136, 0)
  16116    ; Output  - Justific ation text
  16117   "RTN","RCD PEM5",137, 0)
  16118    ;
  16119   "RTN","RCD PEM5",138, 0)
  16120    N FIRST,S TR,STR1,SU B,TEXT
  16121   "RTN","RCD PEM5",139, 0)
  16122    ;Move or  copy text
  16123   "RTN","RCD PEM5",140, 0)
  16124    S TEXT=$$ EXTERNAL^D ILFD(361.1 ,.01,,$P($ G(^IBM(361 .1,ORIG,0) ),U))
  16125   "RTN","RCD PEM5",141, 0)
  16126    I MODE="M " S STR="M ove EEOB f rom claim  "_TEXT_" t o claim "
  16127   "RTN","RCD PEM5",142, 0)
  16128    E  S STR= "Copy EEOB  from clai m "_TEXT_"  to claim( s) "
  16129   "RTN","RCD PEM5",143, 0)
  16130    ;Build li st of clai ms
  16131   "RTN","RCD PEM5",144, 0)
  16132    S STR1="" ,SUB="",FI RST=1
  16133   "RTN","RCD PEM5",145, 0)
  16134    F  S SUB= $O(NCLAIM( SUB)) Q:'S UB  D
  16135   "RTN","RCD PEM5",146, 0)
  16136    .S TEXT=$ P($G(^PRCA (430,NCLAI M(SUB),0)) ,U)
  16137   "RTN","RCD PEM5",147, 0)
  16138    .I FIRST  S STR1=STR 1_$P(TEXT, "-",2),FIR ST=0 Q
  16139   "RTN","RCD PEM5",148, 0)
  16140    .S STR1=S TR1_", "_$ P(TEXT,"-" ,2)
  16141   "RTN","RCD PEM5",149, 0)
  16142    ;Return f ull prompt  text
  16143   "RTN","RCD PEM5",150, 0)
  16144    Q STR_STR 1_" "
  16145   "RTN","RCD PEM5",151, 0)
  16146    ;
  16147   "RTN","RCD PEM5",152, 0)
  16148   JUST(ORIG, NCLAIM,MOD E,TYPE,SRC ) ;Constru ct justifi cation tex t for auto matic upda tes
  16149   "RTN","RCD PEM5",153, 0)
  16150    ; Input -  ORIG - Or iginal EOB
  16151   "RTN","RCD PEM5",154, 0)
  16152    ;       -  NCLAIM -  New claim  (s)
  16153   "RTN","RCD PEM5",155, 0)
  16154    ;       -  MODE - "M " = Move " C" =Copy " R" = Remov e
  16155   "RTN","RCD PEM5",156, 0)
  16156    ;       -  TYPE - 0  = old EOB  1 = new EO B
  16157   "RTN","RCD PEM5",157, 0)
  16158    ;       -  SRC - "W"  = Worklis t "A" = Au to-post  
  16159   "RTN","RCD PEM5",158, 0)
  16160    ; Output  - Justific ation text
  16161   "RTN","RCD PEM5",159, 0)
  16162    N FIRST,S TR,STR1,SU B,TEXT
  16163   "RTN","RCD PEM5",160, 0)
  16164    ;Original  bill numb er
  16165   "RTN","RCD PEM5",161, 0)
  16166    S TEXT=$$ EXTERNAL^D ILFD(361.1 ,.01,,$P($ G(^IBM(361 .1,ORIG,0) ),U))
  16167   "RTN","RCD PEM5",162, 0)
  16168    ;Justific ation comm ent for or iginal EOB
  16169   "RTN","RCD PEM5",163, 0)
  16170    I TYPE=0  D
  16171   "RTN","RCD PEM5",164, 0)
  16172    .I MODE=" R" S STR=" EEOB remov ed from cl aim "_TEXT ,STR1="" Q   ;PRCA*4. 5*321
  16173   "RTN","RCD PEM5",165, 0)
  16174    .I MODE=" M" S STR=" EEOB from  claim "_TE XT_" moved  to claim  "
  16175   "RTN","RCD PEM5",166, 0)
  16176    .I MODE=" C" S STR=" EEOB from  claim "_TE XT_" copie d to claim (s) "
  16177   "RTN","RCD PEM5",167, 0)
  16178    .;Build l ist of cla ims
  16179   "RTN","RCD PEM5",168, 0)
  16180    .S STR1=" ",SUB="",F IRST=1
  16181   "RTN","RCD PEM5",169, 0)
  16182    .F  S SUB =$O(NCLAIM (SUB)) Q:' SUB  D
  16183   "RTN","RCD PEM5",170, 0)
  16184    ..S TEXT= $P($G(^PRC A(430,NCLA IM(SUB),0) ),U)
  16185   "RTN","RCD PEM5",171, 0)
  16186    ..I FIRST  S STR1=ST R1_$P(TEXT ,"-",2),FI RST=0 Q
  16187   "RTN","RCD PEM5",172, 0)
  16188    ..S STR1= STR1_", "_ $P(TEXT,"- ",2)
  16189   "RTN","RCD PEM5",173, 0)
  16190    ;Justific ation comm ent for ne w EOB's
  16191   "RTN","RCD PEM5",174, 0)
  16192    I TYPE=1  D
  16193   "RTN","RCD PEM5",175, 0)
  16194    .I MODE=" M" S STR=" EEOB moved  from EEOB  for claim  "_TEXT,ST R1=""
  16195   "RTN","RCD PEM5",176, 0)
  16196    .I MODE=" C" S STR=" EEOB copie d from EEO B for clai m "_TEXT,S TR1=""
  16197   "RTN","RCD PEM5",177, 0)
  16198    ;Return f ull justif ication te xt
  16199   "RTN","RCD PEM5",178, 0)
  16200    Q STR_STR 1_" automa tically by  "_$S(SRC= "A":"Auto- post",1:"W orklist")
  16201   "RTN","RCD PEM5",179, 0)
  16202    ;
  16203   "RTN","RCD PEM5",180, 0)
  16204    ;
  16205   "RTN","RCD PEM5",181, 0)
  16206   JUST1(ORIG ,NCLAIM,MO DE,TYPE) ; Construct  AR comment  for stand -alone MCR  option
  16207   "RTN","RCD PEM5",182, 0)
  16208    ; Input -  ORIG - Or iginal EOB
  16209   "RTN","RCD PEM5",183, 0)
  16210    ;       -  NCLAIM -  New claim  (s)
  16211   "RTN","RCD PEM5",184, 0)
  16212    ;       -  MODE M=Mo ve C=Copy
  16213   "RTN","RCD PEM5",185, 0)
  16214    ;       -  TYPE = 0  - original  EOB 1 - n ew EOB(s) 
  16215   "RTN","RCD PEM5",186, 0)
  16216    ; Output  - Justific ation text
  16217   "RTN","RCD PEM5",187, 0)
  16218    N FIRST,S TR,STR1,SU B,TEXT
  16219   "RTN","RCD PEM5",188, 0)
  16220    ;Original  bill numb er
  16221   "RTN","RCD PEM5",189, 0)
  16222    S TEXT=$$ EXTERNAL^D ILFD(361.1 ,.01,,$P($ G(^IBM(361 .1,ORIG,0) ),U))
  16223   "RTN","RCD PEM5",190, 0)
  16224    ;Justific ation comm ent for or iginal EOB
  16225   "RTN","RCD PEM5",191, 0)
  16226    I TYPE=0  D
  16227   "RTN","RCD PEM5",192, 0)
  16228    .I MODE=" M" S STR=" EEOB from  claim "_TE XT_" moved  to claim  "
  16229   "RTN","RCD PEM5",193, 0)
  16230    .I MODE=" C" S STR=" EEOB from  claim "_TE XT_" copie d to claim (s) "
  16231   "RTN","RCD PEM5",194, 0)
  16232    .;Build l ist of cla ims
  16233   "RTN","RCD PEM5",195, 0)
  16234    .S STR1=" ",SUB="",F IRST=1
  16235   "RTN","RCD PEM5",196, 0)
  16236    .F  S SUB =$O(NCLAIM (SUB)) Q:' SUB  D
  16237   "RTN","RCD PEM5",197, 0)
  16238    ..S TEXT= $P($G(^PRC A(430,NCLA IM(SUB),0) ),U)
  16239   "RTN","RCD PEM5",198, 0)
  16240    ..I FIRST  S STR1=ST R1_$P(TEXT ,"-",2),FI RST=0 Q
  16241   "RTN","RCD PEM5",199, 0)
  16242    ..S STR1= STR1_", "_ $P(TEXT,"- ",2)
  16243   "RTN","RCD PEM5",200, 0)
  16244    ;Justific ation comm ent for ne w EOB's
  16245   "RTN","RCD PEM5",201, 0)
  16246    I TYPE=1  D
  16247   "RTN","RCD PEM5",202, 0)
  16248    .I MODE=" M" S STR=" EEOB moved  from EEOB  for claim  "_TEXT,ST R1=""
  16249   "RTN","RCD PEM5",203, 0)
  16250    .I MODE=" C" S STR=" EEOB copie d from EEO B for clai m "_TEXT,S TR1=""
  16251   "RTN","RCD PEM5",204, 0)
  16252    ;Return c omment tex t
  16253   "RTN","RCD PEM5",205, 0)
  16254    Q STR_STR 1
  16255   "RTN","RCD PEM5",206, 0)
  16256    ;
  16257   "RTN","RCD PEM5",207, 0)
  16258   FINDEOB(IE N3444,BILL ) ;Find EO B for a cl aim within  an ERA
  16259   "RTN","RCD PEM5",208, 0)
  16260    ; Input -  IEN3444 =  ERA ien
  16261   "RTN","RCD PEM5",209, 0)
  16262    ;          BILL = Bi ll number
  16263   "RTN","RCD PEM5",210, 0)
  16264    ; Output  - IEN of E OB in #361 .1
  16265   "RTN","RCD PEM5",211, 0)
  16266    N IEN3611 ,SUB
  16267   "RTN","RCD PEM5",212, 0)
  16268    S (SUB,IE N3611)=0
  16269   "RTN","RCD PEM5",213, 0)
  16270    F  S SUB= $O(^RCY(34 4.4,IEN344 4,1,"AC",S UB)) Q:'SU B  D  Q:IE N3611
  16271   "RTN","RCD PEM5",214, 0)
  16272    .I $$EXTE RNAL^DILFD (344.41,.0 2,,SUB)=BI LL S IEN36 11=SUB
  16273   "RTN","RCD PEM5",215, 0)
  16274    Q IEN3611
  16275   "RTN","RCD PEM5",216, 0)
  16276    ;
  16277   "RTN","RCD PEM5",217, 0)
  16278   REMOVE(ORI G,MODE) ;  Interactiv e option t o Remove E EOB - PRCA *4.5*298
  16279   "RTN","RCD PEM5",218, 0)
  16280    ; Input -  ORIG = or iginal EOB  in #361.1
  16281   "RTN","RCD PEM5",219, 0)
  16282    ; Output  - mode = " R"
  16283   "RTN","RCD PEM5",220, 0)
  16284    ;
  16285   "RTN","RCD PEM5",221, 0)
  16286    ;Prompt u ser to con tinue
  16287   "RTN","RCD PEM5",222, 0)
  16288    N DIR,X,Y ,DIROUT
  16289   "RTN","RCD PEM5",223, 0)
  16290    S DIR(0)= "Y",DIR("B ")="YES"
  16291   "RTN","RCD PEM5",224, 0)
  16292    S DIR("A" )="Are you  sure you  want to re move EEOB  from claim  "_ORIGNAM _" (Y/N)?"
  16293   "RTN","RCD PEM5",225, 0)
  16294    W ! D ^DI R
  16295   "RTN","RCD PEM5",226, 0)
  16296    ;
  16297   "RTN","RCD PEM5",227, 0)
  16298    I $G(DIRO UT)!$G(DUO UT)!(Y=0)  Q
  16299   "RTN","RCD PEM5",228, 0)
  16300    ;
  16301   "RTN","RCD PEM5",229, 0)
  16302    ;Enter Ju stificatio n Comment
  16303   "RTN","RCD PEM5",230, 0)
  16304    N DIR,DIR OUT,DUOUT, JUST,X,Y
  16305   "RTN","RCD PEM5",231, 0)
  16306    S DIR(0)= "FA^1:100^ K:$TR(X,""  "","""")= """" X",DI R("A")="En ter JUSTIF ICATION CO MMENT: "
  16307   "RTN","RCD PEM5",232, 0)
  16308    W ! D ^DI R I $G(DIR OUT)!$G(DU OUT) W !!, "Update no t performe d" D EXIT  Q
  16309   "RTN","RCD PEM5",233, 0)
  16310    S JUST=Y
  16311   "RTN","RCD PEM5",234, 0)
  16312    ;
  16313   "RTN","RCD PEM5",235, 0)
  16314    ;Update E EOB
  16315   "RTN","RCD PEM5",236, 0)
  16316    D REMOVE^ IBCEOB4(OR IG,DUZ,JUS T)
  16317   "RTN","RCD PEM5",237, 0)
  16318    ;Update A R Comments  for remov ed claim
  16319   "RTN","RCD PEM5",238, 0)
  16320    D AUDIT^R CDPAYER(OR IG,JUST,MO DE)
  16321   "RTN","RCD PEM5",239, 0)
  16322    ;
  16323   "RTN","RCD PEM5",240, 0)
  16324    W !!,"EEO B Update C omplete" H  1
  16325   "RTN","RCD PEM5",241, 0)
  16326    Q
  16327   "RTN","RCD PEM5",242, 0)
  16328    ; 
  16329   "RTN","RCD PEM5",243, 0)
  16330   VALSTAT(CL IEN) ; val idation on  current s tatus of t he AR clai m selected  for the m ove/copy e vent  
  16331   "RTN","RCD PEM5",244, 0)
  16332    ; Claims  that are i n a incomp lete state  cannot be  selected
  16333   "RTN","RCD PEM5",245, 0)
  16334    ; incompl ete states  are deter mined at C URRENT STA TUS (8,430 ) of the A R claim
  16335   "RTN","RCD PEM5",246, 0)
  16336    ; AR clai ms with 'B ILL INCOMP LETE', 'IN COMPLETE',  'NEW BILL ' statuses  cannot be  selected 
  16337   "RTN","RCD PEM5",247, 0)
  16338    ; CLIEN=4 30 ien
  16339   "RTN","RCD PEM5",248, 0)
  16340    ; returns  0 or 1
  16341   "RTN","RCD PEM5",249, 0)
  16342    N CSTAT,F LAG
  16343   "RTN","RCD PEM5",250, 0)
  16344    S CSTAT=$ $GET1^DIQ( 430,CLIEN, 8)
  16345   "RTN","RCD PEM5",251, 0)
  16346    S FLAG=$S (CSTAT="BI LL INCOMPL ETE":0,CST AT="INCOMP LETE":0,CS TAT="NEW B ILL":0,1:1 )
  16347   "RTN","RCD PEM5",252, 0)
  16348    Q FLAG
  16349   "RTN","RCD PEM5",253, 0)
  16350    ;
  16351   "RTN","RCD PEM5",254, 0)
  16352    ; BEGIN -  PRCA*4.5* 321
  16353   "RTN","RCD PEM5",255, 0)
  16354   AUTO(OBILL ,RCSPLIT,R CERA,SRC,O RIG) ;  Au tomatic mo ve copy of  EOB - EP  for RCDPEM  and RCDPE MA
  16355   "RTN","RCD PEM5",256, 0)
  16356    ; Input -  OBILL - O riginal Bi ll number  in #399 
  16357   "RTN","RCD PEM5",257, 0)
  16358    ;       -  RCSPLIT -  Array of  split line s
  16359   "RTN","RCD PEM5",258, 0)
  16360    ;       -  RCERA - E RA ien #34 4.4
  16361   "RTN","RCD PEM5",259, 0)
  16362    ;       -  SRC - "W"  = Worklis t "A" = AP AR/Autopos t
  16363   "RTN","RCD PEM5",260, 0)
  16364    ;       -  ORIG - IE N of EOB i n file #36 1.1
  16365   "RTN","RCD PEM5",261, 0)
  16366    ; Output  - Update E OBs and au dit trail
  16367   "RTN","RCD PEM5",262, 0)
  16368    N CCLAIM, IFN,NCLAIM ,SUB,SUB1, NBILL,MOVE ,JUST,JUST 1,VALID
  16369   "RTN","RCD PEM5",263, 0)
  16370    ; EOB for  the origi nal claim  must be pr esent
  16371   "RTN","RCD PEM5",264, 0)
  16372    I 'ORIG Q  1
  16373   "RTN","RCD PEM5",265, 0)
  16374    ; Default  operation  is move
  16375   "RTN","RCD PEM5",266, 0)
  16376    S (SUB,SU B1)=0,MOVE =1,VALID=1
  16377   "RTN","RCD PEM5",267, 0)
  16378    ; Loop th rough spli t lines 
  16379   "RTN","RCD PEM5",268, 0)
  16380    F  S SUB= $O(RCSPLIT (SUB)) Q:' SUB  D
  16381   "RTN","RCD PEM5",269, 0)
  16382    .; Bill N umber on s plit line
  16383   "RTN","RCD PEM5",270, 0)
  16384    .S NBILL= $P(RCSPLIT (SUB),U,2)
  16385   "RTN","RCD PEM5",271, 0)
  16386    .; Ignore  suspense  claims, pi ece 7 is p ointer to  AR claim f ile 430
  16387   "RTN","RCD PEM5",272, 0)
  16388    .S IFN=$P (RCSPLIT(S UB),U,7) Q :'IFN
  16389   "RTN","RCD PEM5",273, 0)
  16390    .; Ignore  split lin es with ze ro value
  16391   "RTN","RCD PEM5",274, 0)
  16392    .Q:+$P(RC SPLIT(SUB) ,U,3)=0
  16393   "RTN","RCD PEM5",275, 0)
  16394    .; If ori ginal bill  is in the  array the n default  operation  is copy
  16395   "RTN","RCD PEM5",276, 0)
  16396    .I OBILL= NBILL S MO VE=0
  16397   "RTN","RCD PEM5",277, 0)
  16398    .; Save P OINTER to  AR Claim f ile 430 (D INUM to 39 9)
  16399   "RTN","RCD PEM5",278, 0)
  16400    .S SUB1=S UB1+1,NCLA IM(SUB1)=I FN
  16401   "RTN","RCD PEM5",279, 0)
  16402    .; Build  list of ne w claims t o copy
  16403   "RTN","RCD PEM5",280, 0)
  16404    .S:OBILL' =NBILL CCL AIM(IFN)=I FN
  16405   "RTN","RCD PEM5",281, 0)
  16406    ;
  16407   "RTN","RCD PEM5",282, 0)
  16408    ; If spli t is betwe en origina l claim an d suspense  (and no o ther claim s) -  do n othing
  16409   "RTN","RCD PEM5",283, 0)
  16410    I SUB1=1, MOVE=0 Q 1
  16411   "RTN","RCD PEM5",284, 0)
  16412    ; If spli t was to m ove entire  claim pay ment to su spense - m ark EOB as  removed
  16413   "RTN","RCD PEM5",285, 0)
  16414    I SUB1=0  D AUTOREM( ORIG,$$JUS T(ORIG,"", "R",0,SRC) ) Q 1
  16415   "RTN","RCD PEM5",286, 0)
  16416    ;
  16417   "RTN","RCD PEM5",287, 0)
  16418    ; Lock Or iginal EOB
  16419   "RTN","RCD PEM5",288, 0)
  16420    I '$$LOCK (ORIG) Q 0
  16421   "RTN","RCD PEM5",289, 0)
  16422    ;
  16423   "RTN","RCD PEM5",290, 0)
  16424    ; If spli t to singl e new clai m move EOB  - i.e. ch ange claim  number on  EOB
  16425   "RTN","RCD PEM5",291, 0)
  16426    I MOVE,SU B1=1 D  Q  1
  16427   "RTN","RCD PEM5",292, 0)
  16428    .S JUST=$ $JUST(ORIG ,.NCLAIM," C",0,SRC)  ;Just. Tex t for orig inal EOB
  16429   "RTN","RCD PEM5",293, 0)
  16430    .; Change  claim num ber on ori ginal EOB  attached t o ERA
  16431   "RTN","RCD PEM5",294, 0)
  16432    .D MOVE^I BCEOB4(ORI G,NCLAIM(1 ),DUZ,$$NO W^XLFDT,JU ST,"M")
  16433   "RTN","RCD PEM5",295, 0)
  16434    .; Update  AR Transa ction for  original c laim
  16435   "RTN","RCD PEM5",296, 0)
  16436    .D AUDIT^ RCDPAYER(O RIG,JUST," W")
  16437   "RTN","RCD PEM5",297, 0)
  16438    ;
  16439   "RTN","RCD PEM5",298, 0)
  16440    ; If spli t was to n ew claims  - copy ori ginal EOB  to new cla ims and th en mark or iginal EOB  as remove d
  16441   "RTN","RCD PEM5",299, 0)
  16442    I MOVE,SU B1>1 D
  16443   "RTN","RCD PEM5",300, 0)
  16444    .S JUST=$ $JUST(ORIG ,.NCLAIM," C",0,SRC)  ;Just. Tex t for orig inal EEOB  (copied to  claims x, y,z - then  removed)
  16445   "RTN","RCD PEM5",301, 0)
  16446    .S JUST1= $$JUST(ORI G,.NCLAIM, "C",1,SRC)  ;Just. Te xt for cop ied to EEO B (copied  from claim  w)
  16447   "RTN","RCD PEM5",302, 0)
  16448    .; Copy E OB to new  EOBs for " to" claims
  16449   "RTN","RCD PEM5",303, 0)
  16450    .;;D AUTO COPY^IBCEO B5(ORIG,.C CLAIM,DUZ, $$NOW^XLFD T,JUST1,"C ")
  16451   "RTN","RCD PEM5",304, 0)
  16452    .D COPY^I BCEOB4(ORI G,.CCLAIM, DUZ,$$NOW^ XLFDT,JUST 1,"C")
  16453   "RTN","RCD PEM5",305, 0)
  16454    .; Mark o riginal EO B removed  but with t ext of 'co pied to cl aims....'
  16455   "RTN","RCD PEM5",306, 0)
  16456    .D AUTORE M(ORIG,JUS T)
  16457   "RTN","RCD PEM5",307, 0)
  16458    ;
  16459   "RTN","RCD PEM5",308, 0)
  16460    ; If spli t was betw een origin al claim a nd other c laims - co py all new  claims to  new EOBs
  16461   "RTN","RCD PEM5",309, 0)
  16462    I 'MOVE D
  16463   "RTN","RCD PEM5",310, 0)
  16464    .S JUST=$ $JUST(ORIG ,.NCLAIM," C",0,SRC)  ;Just. Tex t for orig inal EEOB
  16465   "RTN","RCD PEM5",311, 0)
  16466    .S JUST1= $$JUST(ORI G,.NCLAIM, "C",1,SRC)  ;Just. Te xt for cop ied to EEO B
  16467   "RTN","RCD PEM5",312, 0)
  16468    .D COPY^I BCEOB4(ORI G,.CCLAIM, DUZ,$$NOW^ XLFDT,JUST ,"C")
  16469   "RTN","RCD PEM5",313, 0)
  16470    .; Update  AR Transa ction for  'from clai m'
  16471   "RTN","RCD PEM5",314, 0)
  16472    .D AUDIT^ RCDPAYER(O RIG,JUST," W")
  16473   "RTN","RCD PEM5",315, 0)
  16474    ;
  16475   "RTN","RCD PEM5",316, 0)
  16476    D UNLOCK( ORIG)
  16477   "RTN","RCD PEM5",317, 0)
  16478    Q 1
  16479   "RTN","RCD PEM5",318, 0)
  16480    ;
  16481   "RTN","RCD PEM5",319, 0)
  16482   AUTOREM(OR IG,JUST) ; Silent rem ove of EEO B where en tire payme nt is susp ensed or m oved to ot her claims
  16483   "RTN","RCD PEM5",320, 0)
  16484    ; Input -  ORIG = EO B in #361. 1
  16485   "RTN","RCD PEM5",321, 0)
  16486    ;          JUST = Ju stificatio n text
  16487   "RTN","RCD PEM5",322, 0)
  16488    ; Output  - Update E OB in #361 .1 and aud it trail
  16489   "RTN","RCD PEM5",323, 0)
  16490    ;
  16491   "RTN","RCD PEM5",324, 0)
  16492    ;Lock Ori ginal EOB
  16493   "RTN","RCD PEM5",325, 0)
  16494    I '$$LOCK (ORIG) Q
  16495   "RTN","RCD PEM5",326, 0)
  16496    ;Update E EOB
  16497   "RTN","RCD PEM5",327, 0)
  16498    D REMOVE^ IBCEOB4(OR IG,DUZ,JUS T)
  16499   "RTN","RCD PEM5",328, 0)
  16500    ;Update A R Comments  for remov ed claim
  16501   "RTN","RCD PEM5",329, 0)
  16502    D AUDIT^R CDPAYER(OR IG,JUST,"R ")
  16503   "RTN","RCD PEM5",330, 0)
  16504    ;Unlock o riginal EO B
  16505   "RTN","RCD PEM5",331, 0)
  16506    D UNLOCK( ORIG)
  16507   "RTN","RCD PEM5",332, 0)
  16508    ;
  16509   "RTN","RCD PEM5",333, 0)
  16510    Q
  16511   "RTN","RCD PEM5",334, 0)
  16512    ;
  16513   "RTN","RCD PEM5",335, 0)
  16514    ;Read acc ess to fil e #361.1 u nder IA 40 51
  16515   "RTN","RCD PEM5",336, 0)
  16516   LOCK(EOBIE N) ;Lock O riginal EO B
  16517   "RTN","RCD PEM5",337, 0)
  16518    L +^IBM(3 61.1,EOBIE N):5 I  Q  1
  16519   "RTN","RCD PEM5",338, 0)
  16520    Q 0
  16521   "RTN","RCD PEM5",339, 0)
  16522    ;
  16523   "RTN","RCD PEM5",340, 0)
  16524   UNLOCK(EOB IEN) ;Rele ase EOB
  16525   "RTN","RCD PEM5",341, 0)
  16526    L -^IBM(3 61.1,EOBIE N)
  16527   "RTN","RCD PEM5",342, 0)
  16528    Q
  16529   "RTN","RCD PEM5",343, 0)
  16530    ; END PRC A*4.5*321
  16531   "RTN","RCD PEM5",344, 0)
  16532    ;
  16533   "RTN","RCD PEM5",345, 0)
  16534    ;US1394 A DDITIONS -  EP RCDPRP L1 and RCD PLPL3
  16535   "RTN","RCD PEM5",346, 0)
  16536   EEOB(RCRCP T,RCTRANDA ) ; Option  to restor e associat ed suspend ed/removed  EEOB
  16537   "RTN","RCD PEM5",347, 0)
  16538    ;
  16539   "RTN","RCD PEM5",348, 0)
  16540    ; INPUT   - RCRCPT -  Receipt i en #344
  16541   "RTN","RCD PEM5",349, 0)
  16542    ;         - RCTRANDA  - Receipt  line #344 .01
  16543   "RTN","RCD PEM5",350, 0)
  16544    ;
  16545   "RTN","RCD PEM5",351, 0)
  16546    ; OUTPUT  - RCEEOB -  selected  EEOB ien # 361.1 
  16547   "RTN","RCD PEM5",352, 0)
  16548    ; or 0 if  no EEOB
  16549   "RTN","RCD PEM5",353, 0)
  16550    ; or -1 i f ^ abort 
  16551   "RTN","RCD PEM5",354, 0)
  16552    ;
  16553   "RTN","RCD PEM5",355, 0)
  16554    N CLAIM,D IROUT,DTOU T,DUOUT,RC EEOB,RCEEO BH,RCERA,R CLINE
  16555   "RTN","RCD PEM5",356, 0)
  16556    ; Get new  claim IEN  from rece ipt line
  16557   "RTN","RCD PEM5",357, 0)
  16558    S CLAIM=$ $GET1^DIQ( 344.01,RCT RANDA_","_ RCRCPT_"," ,.09,"I")
  16559   "RTN","RCD PEM5",358, 0)
  16560    ; Quit if  this is n ot a third  party cla im payment
  16561   "RTN","RCD PEM5",359, 0)
  16562    Q:CLAIM'[ "PRCA" 0
  16563   "RTN","RCD PEM5",360, 0)
  16564    ; Check i f ERA has  a suspende d EEOB for  this line
  16565   "RTN","RCD PEM5",361, 0)
  16566    S RCEEOB= $$SUSP(RCR CPT,RCTRAN DA,.RCERA, .RCLINE)
  16567   "RTN","RCD PEM5",362, 0)
  16568    ; If no s uspended E EOB skip p rompt
  16569   "RTN","RCD PEM5",363, 0)
  16570    Q:'RCEEOB  0
  16571   "RTN","RCD PEM5",364, 0)
  16572    ;
  16573   "RTN","RCD PEM5",365, 0)
  16574    ; Get las t move/cop y history  record - R ead access  to file # 361.1 unde r IA 4051
  16575   "RTN","RCD PEM5",366, 0)
  16576    S RCEEOBH =$O(^IBM(3 61.1,RCEEO B,101,"A") ,-1)
  16577   "RTN","RCD PEM5",367, 0)
  16578    ; Quit if  EEOB if n o history  found - sh ould not o ccur since  EEOB is s uspended
  16579   "RTN","RCD PEM5",368, 0)
  16580    Q:'RCEEOB H 0
  16581   "RTN","RCD PEM5",369, 0)
  16582    ; Display  EOB detai l
  16583   "RTN","RCD PEM5",370, 0)
  16584    W !!,"Thi s claim ha s an assoc iated EEOB  on ERA "_ RCERA
  16585   "RTN","RCD PEM5",371, 0)
  16586    W !!,"Cla im Number      : ",$$ GET1^DIQ(3 44.41,RCLI NE_","_RCE RA,.02,"E" )
  16587   "RTN","RCD PEM5",372, 0)
  16588    W !,"Trac e Number      : ",$$G ET1^DIQ(34 4.4,RCERA, .02,"E")
  16589   "RTN","RCD PEM5",373, 0)
  16590    W !,"Tota l Amount P aid: ",$$G ET1^DIQ(36 1.1,RCEEOB ,1.01,"E")
  16591   "RTN","RCD PEM5",374, 0)
  16592    W !,"Date /Time Remo ved: ",$$G ET1^DIQ(36 1.1101,RCE EOBH_","_R CEEOB,.01, "E")
  16593   "RTN","RCD PEM5",375, 0)
  16594    W !,"Remo ved by        : ",$$G ET1^DIQ(36 1.1101,RCE EOBH_","_R CEEOB,.02, "E")
  16595   "RTN","RCD PEM5",376, 0)
  16596    W !,"Just ification     : ",$$G ET1^DIQ(36 1.1101,RCE EOBH_","_R CEEOB,.03, "E"),!
  16597   "RTN","RCD PEM5",377, 0)
  16598    ;
  16599   "RTN","RCD PEM5",378, 0)
  16600    ; Confirm  that this  is the co rrect EEOB
  16601   "RTN","RCD PEM5",379, 0)
  16602    K DIR
  16603   "RTN","RCD PEM5",380, 0)
  16604    S DIR(0)= "YO",DIR(" B")="NO"
  16605   "RTN","RCD PEM5",381, 0)
  16606    S DIR("A" )="Is this  the corre ct EEOB to  associate  with this  claim"
  16607   "RTN","RCD PEM5",382, 0)
  16608    D ^DIR
  16609   "RTN","RCD PEM5",383, 0)
  16610    I $G(DTOU T)!($G(DUO UT)) Q -1
  16611   "RTN","RCD PEM5",384, 0)
  16612    Q:Y'=1 0
  16613   "RTN","RCD PEM5",385, 0)
  16614    ;
  16615   "RTN","RCD PEM5",386, 0)
  16616    ;Return s elected EE OB
  16617   "RTN","RCD PEM5",387, 0)
  16618    Q RCEEOB
  16619   "RTN","RCD PEM5",388, 0)
  16620    ;
  16621   "RTN","RCD PEM5",389, 0)
  16622   SUSP(RCRCP T,RCTRANDA ,RCERA,RCL INE) ; Ide ntify susp ended EEOB
  16623   "RTN","RCD PEM5",390, 0)
  16624    ;
  16625   "RTN","RCD PEM5",391, 0)
  16626    ; INPUT -  RCRCPT -  Receipt ie n #344
  16627   "RTN","RCD PEM5",392, 0)
  16628    ;       -  RCTRANDA  - Receipt  line #344. 01
  16629   "RTN","RCD PEM5",393, 0)
  16630    ;
  16631   "RTN","RCD PEM5",394, 0)
  16632    ; OUTPUT  - RCEEOB -  selected  EEOB ien # 361.1 
  16633   "RTN","RCD PEM5",395, 0)
  16634    ;         - RCERA -  ERA ien #3 44.4
  16635   "RTN","RCD PEM5",396, 0)
  16636    ;         - RCLINE -  ERA line  #344.41;
  16637   "RTN","RCD PEM5",397, 0)
  16638    ;
  16639   "RTN","RCD PEM5",398, 0)
  16640    N RCEEOB, RCORIG,RCR CZ,RCSPLIT
  16641   "RTN","RCD PEM5",399, 0)
  16642    ; Get ERA  from rece ipt
  16643   "RTN","RCD PEM5",400, 0)
  16644    S RCERA=$ $GET1^DIQ( 344,RCRCPT _",",.18," I")
  16645   "RTN","RCD PEM5",401, 0)
  16646    ; Quit if  no ERA
  16647   "RTN","RCD PEM5",402, 0)
  16648    Q:'RCERA  0
  16649   "RTN","RCD PEM5",403, 0)
  16650    ; Get ERA  Scratchpa d line
  16651   "RTN","RCD PEM5",404, 0)
  16652    S RCRCZ=$ $GET1^DIQ( 344.01,RCT RANDA_","_ RCRCPT_"," ,.27,"I")
  16653   "RTN","RCD PEM5",405, 0)
  16654    ; Quit if  ERA scrat chpad line  missing
  16655   "RTN","RCD PEM5",406, 0)
  16656    Q:'RCRCZ  0
  16657   "RTN","RCD PEM5",407, 0)
  16658    ; Get the  original  line seque nce number  from befo re the spl it was per formed
  16659   "RTN","RCD PEM5",408, 0)
  16660    S RCSPLIT =$$GET1^DI Q(344.491, RCRCZ_","_ RCERA_",", .01),RCORI G=RCSPLIT\ 1
  16661   "RTN","RCD PEM5",409, 0)
  16662    ; Convert  sequence  number int o original  line IEN
  16663   "RTN","RCD PEM5",410, 0)
  16664    S RCORIG= $O(^RCY(34 4.49,RCERA ,1,"ASEQ", RCORIG,"") )
  16665   "RTN","RCD PEM5",411, 0)
  16666    ; Quit if  original  scratchpad  line not  found
  16667   "RTN","RCD PEM5",412, 0)
  16668    Q:'RCORIG  0
  16669   "RTN","RCD PEM5",413, 0)
  16670    ; Get ERA  line from  original  scratchpad  line
  16671   "RTN","RCD PEM5",414, 0)
  16672    S RCLINE= $$GET1^DIQ (344.491,R CORIG_","_ RCERA_",", .09,"I")
  16673   "RTN","RCD PEM5",415, 0)
  16674    ; Quit if  ERA line  not found
  16675   "RTN","RCD PEM5",416, 0)
  16676    Q:'RCLINE  0
  16677   "RTN","RCD PEM5",417, 0)
  16678    ; Get EEO B from ERA  line
  16679   "RTN","RCD PEM5",418, 0)
  16680    S RCEEOB= $$GET1^DIQ (344.41,RC LINE_","_R CERA_",",. 02,"I")
  16681   "RTN","RCD PEM5",419, 0)
  16682    ; Quit if  ERA line  pointer to  EEOB is m issing
  16683   "RTN","RCD PEM5",420, 0)
  16684    Q:'RCEEOB  0
  16685   "RTN","RCD PEM5",421, 0)
  16686    ; Ignore  EEOB if st atus is no t removed  - read acc ess to fil e #361.1 u nder IA 40 51
  16687   "RTN","RCD PEM5",422, 0)
  16688    Q:$$GET1^ DIQ(361.1, RCEEOB_"," ,102,"I")' =1 0
  16689   "RTN","RCD PEM5",423, 0)
  16690    ; Return  suspended  EEOB IEN
  16691   "RTN","RCD PEM5",424, 0)
  16692    Q RCEEOB
  16693   "RTN","RCD PEM5",425, 0)
  16694    ;
  16695   "RTN","RCD PEM5",426, 0)
  16696    ; EP RCDP RPL1 and R CDPLPL3
  16697   "RTN","RCD PEM5",427, 0)
  16698   RESTORE(RC PTDA,RCTRA NDA,ORIG,S RC) ; Chan ge bill nu mber on EO B and clea r 'removed ' status
  16699   "RTN","RCD PEM5",428, 0)
  16700    ;
  16701   "RTN","RCD PEM5",429, 0)
  16702    ; INPUT -  RCPTDA    - Receipt  ien #344
  16703   "RTN","RCD PEM5",430, 0)
  16704    ;       -  RCTRANDA  - Receipt  line #344. 01
  16705   "RTN","RCD PEM5",431, 0)
  16706    ;       -  ORIG      - EOB ien  #361.1
  16707   "RTN","RCD PEM5",432, 0)
  16708    ;       -  SRC       - 'L' - Li nk Payment s 'R' - Re ceipt Porc essing
  16709   "RTN","RCD PEM5",433, 0)
  16710    ;
  16711   "RTN","RCD PEM5",434, 0)
  16712    Q:'$$LOCK ^IBCEOB4(O RIG)
  16713   "RTN","RCD PEM5",435, 0)
  16714    ;
  16715   "RTN","RCD PEM5",436, 0)
  16716    W !,"Upda ting EEOB. ..."
  16717   "RTN","RCD PEM5",437, 0)
  16718    ;
  16719   "RTN","RCD PEM5",438, 0)
  16720    N NCLAIM, JUST
  16721   "RTN","RCD PEM5",439, 0)
  16722    ; Get new  claim IEN  from rece ipt line
  16723   "RTN","RCD PEM5",440, 0)
  16724    S NCLAIM= $P($$GET1^ DIQ(344.01 ,RCTRANDA_ ","_RCPTDA _",",.09," I"),";")
  16725   "RTN","RCD PEM5",441, 0)
  16726    ; Set up  justificat ion text
  16727   "RTN","RCD PEM5",442, 0)
  16728    S JUST="E EOB restor ed from su spense in  "_$S(SRC=" L":"Link P ayments",S RC="R":"Ed it Payment s",1:"Othe r")
  16729   "RTN","RCD PEM5",443, 0)
  16730    ; Update  AR comment s on 'from  claim'
  16731   "RTN","RCD PEM5",444, 0)
  16732    D AUDIT^R CDPAYER(OR IG,JUST,"W ")
  16733   "RTN","RCD PEM5",445, 0)
  16734    ; Change  claim numb er on EOB
  16735   "RTN","RCD PEM5",446, 0)
  16736    D MOVE^IB CEOB4(ORIG ,NCLAIM,DU Z,$$NOW^XL FDT,JUST," M")
  16737   "RTN","RCD PEM5",447, 0)
  16738    ; Reset E EOB REMOVE D status
  16739   "RTN","RCD PEM5",448, 0)
  16740    D RESTORE ^IBCEOB4(O RIG)
  16741   "RTN","RCD PEM5",449, 0)
  16742    ;Unlock E OB
  16743   "RTN","RCD PEM5",450, 0)
  16744    D UNLOCK^ IBCEOB4(OR IG)
  16745   "RTN","RCD PEM5",451, 0)
  16746    ;
  16747   "RTN","RCD PEM5",452, 0)
  16748    H 1 W "do ne"
  16749   "RTN","RCD PEM5",453, 0)
  16750    Q
  16751   "RTN","RCD PEM7")
  16752   0^64^B1472 89800
  16753   "RTN","RCD PEM7",1,0)
  16754   RCDPEM7 ;O IFO-BAYPIN ES/PJH - O VERDUE EFT  AND ERA B ULLETINS ; Jun 06, 20 14@19:11:1 9
  16755   "RTN","RCD PEM7",2,0)
  16756    ;;4.5;Acc ounts Rece ivable;**2 76,298,303 ,304,321** ;Mar 20, 1 995;Build  46
  16757   "RTN","RCD PEM7",3,0)
  16758    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  16759   "RTN","RCD PEM7",4,0)
  16760    ;
  16761   "RTN","RCD PEM7",5,0)
  16762   EN ; Main  entry poin t for over due EFT/ER A bulletin s
  16763   "RTN","RCD PEM7",6,0)
  16764    ;
  16765   "RTN","RCD PEM7",7,0)
  16766    N TODAY,E RACNT,ERAT OT,ERA1CNT ,ERA2CNT,E RA1TOT,ERA 2TOT,EFTCN T,EFTTOT,R CPROG,RCSU SCNT,RCSUS AMT,RCMXDY S
  16767   "RTN","RCD PEM7",8,0)
  16768    ;Clear wo rkfiles
  16769   "RTN","RCD PEM7",9,0)
  16770    S RCPROG= "RCDPEM7"  K ^TMP(RCP ROG,$J)
  16771   "RTN","RCD PEM7",10,0 )
  16772    ;Set coun ters and t otals
  16773   "RTN","RCD PEM7",11,0 )
  16774    S (EFTCNT ,ERACNT,ER A1CNT,ERA2 CNT,EFTTOT ,ERATOT,ER A1TOT,ERA2 TOT,RCSUSC NT,RCSUSAM T)=0
  16775   "RTN","RCD PEM7",12,0 )
  16776    ;Cuttoff  of 12:00 a m today
  16777   "RTN","RCD PEM7",13,0 )
  16778    S TODAY=$ P($$NOW^XL FDT,".")
  16779   "RTN","RCD PEM7",14,0 )
  16780    ;
  16781   "RTN","RCD PEM7",15,0 )
  16782    ;Verify t his is cor rect day f or bulleti ns - PRCA* 4.5*321
  16783   "RTN","RCD PEM7",16,0 )
  16784    N X
  16785   "RTN","RCD PEM7",17,0 )
  16786    S X=TODAY
  16787   "RTN","RCD PEM7",18,0 )
  16788    D DW^%DTC
  16789   "RTN","RCD PEM7",19,0 )
  16790    I $$GET1^ DIQ(344.61 ,"1,",.1)' =X Q
  16791   "RTN","RCD PEM7",20,0 )
  16792    ;
  16793   "RTN","RCD PEM7",21,0 )
  16794    ;Retrieve  the max d ays allowe d in suspe nse parame ter
  16795   "RTN","RCD PEM7",22,0 )
  16796    S RCMXDYS =$$GET1^DI Q(342,"1," ,7.04)
  16797   "RTN","RCD PEM7",23,0 )
  16798    ;
  16799   "RTN","RCD PEM7",24,0 )
  16800    ;Scan for  overdue E RA and unp osted ERA
  16801   "RTN","RCD PEM7",25,0 )
  16802    D ERASCAN
  16803   "RTN","RCD PEM7",26,0 )
  16804    ;Scan for  overdue E FT
  16805   "RTN","RCD PEM7",27,0 )
  16806    D EFTSCAN
  16807   "RTN","RCD PEM7",28,0 )
  16808    ;Scan for  overdue S uspended E RA's - PRC A*4.5*304
  16809   "RTN","RCD PEM7",29,0 )
  16810    D SUSPSCA N
  16811   "RTN","RCD PEM7",30,0 )
  16812    ;Bulletin s
  16813   "RTN","RCD PEM7",31,0 )
  16814    D BULLETI N
  16815   "RTN","RCD PEM7",32,0 )
  16816    ;Clear wo rkfiles
  16817   "RTN","RCD PEM7",33,0 )
  16818    K ^TMP(RC PROG,$J)
  16819   "RTN","RCD PEM7",34,0 )
  16820    Q
  16821   "RTN","RCD PEM7",35,0 )
  16822    ;
  16823   "RTN","RCD PEM7",36,0 )
  16824   ERASCAN ;S can ERA
  16825   "RTN","RCD PEM7",37,0 )
  16826    N AMT,ERA IEN,REC0,S UB,STATUS, FDATE,PNAM E
  16827   "RTN","RCD PEM7",38,0 )
  16828    ;Scan for  unmatched  ERA
  16829   "RTN","RCD PEM7",39,0 )
  16830    S ERAIEN= 0,STATUS=0 ,SUB="ERA"
  16831   "RTN","RCD PEM7",40,0 )
  16832    F  S ERAI EN=$O(^RCY (344.4,"AM ATCH",STAT US,ERAIEN) ) Q:'ERAIE N  D
  16833   "RTN","RCD PEM7",41,0 )
  16834    .S REC0=$ G(^RCY(344 .4,ERAIEN, 0))
  16835   "RTN","RCD PEM7",42,0 )
  16836    .;Get ERA  file date /time
  16837   "RTN","RCD PEM7",43,0 )
  16838    .S FDATE= $P(REC0,U, 7) Q:'FDAT E
  16839   "RTN","RCD PEM7",44,0 )
  16840    .;Ignore  if <31 day s overdue
  16841   "RTN","RCD PEM7",45,0 )
  16842    .Q:$$FMDI FF^XLFDT(T ODAY,FDATE ,1)<31
  16843   "RTN","RCD PEM7",46,0 )
  16844    .;Trace,  Payer Name  and Amoun t
  16845   "RTN","RCD PEM7",47,0 )
  16846    .S PNAME= $P(REC0,U, 6),AMT=$P( REC0,U,5)
  16847   "RTN","RCD PEM7",48,0 )
  16848    .I $L(PNA ME)>35 S P NAME=$E(PN AME,1,35)  ; limit si ze of the  name
  16849   "RTN","RCD PEM7",49,0 )
  16850    .;Update  count and  totals
  16851   "RTN","RCD PEM7",50,0 )
  16852    .S ERACNT =ERACNT+1, ERATOT=ERA TOT+AMT
  16853   "RTN","RCD PEM7",51,0 )
  16854    . ; PRCA* 4.5*303 ad ded the FD ATE subscr ipt to the  global so  that the  line
  16855   "RTN","RCD PEM7",52,0 )
  16856    . ; items  collate i n date asc ending ord er.
  16857   "RTN","RCD PEM7",53,0 )
  16858    . ;Save E RA#, Payer  Name, Fil e Date and  Amount Pa id
  16859   "RTN","RCD PEM7",54,0 )
  16860    .S ^TMP(R CPROG,$J," ERA",FDATE ,ERACNT)=$ $ERAL(ERAI EN,PNAME,F DATE,AMT)
  16861   "RTN","RCD PEM7",55,0 )
  16862    ;
  16863   "RTN","RCD PEM7",56,0 )
  16864    ;Scan for  Matched/U nposted ER A
  16865   "RTN","RCD PEM7",57,0 )
  16866    S SUB="ER A1"
  16867   "RTN","RCD PEM7",58,0 )
  16868    F STATUS= -1,1,2,3 D
  16869   "RTN","RCD PEM7",59,0 )
  16870    . S ERAIE N=0 F  S E RAIEN=$O(^ RCY(344.4, "AMATCH",S TATUS,ERAI EN)) Q:'ER AIEN  D
  16871   "RTN","RCD PEM7",60,0 )
  16872    .. S REC0 =$G(^RCY(3 44.4,ERAIE N,0))
  16873   "RTN","RCD PEM7",61,0 )
  16874    .. ;Get E RA file da te/time
  16875   "RTN","RCD PEM7",62,0 )
  16876    .. S FDAT E=$P(REC0, U,7) Q:'FD ATE
  16877   "RTN","RCD PEM7",63,0 )
  16878    .. ;Ignor e if <31 d ays overdu e
  16879   "RTN","RCD PEM7",64,0 )
  16880    .. Q:$$FM DIFF^XLFDT (TODAY,FDA TE,1)<31
  16881   "RTN","RCD PEM7",65,0 )
  16882    .. ;Ignor e if not u nposted po sted
  16883   "RTN","RCD PEM7",66,0 )
  16884    .. Q:$P($ G(^RCY(344 .4,ERAIEN, 0)),U,14)> 0
  16885   "RTN","RCD PEM7",67,0 )
  16886    .. ;Payer  Name and  Amount
  16887   "RTN","RCD PEM7",68,0 )
  16888    .. S PNAM E=$P(REC0, U,6),AMT=$ P(REC0,U,5 )
  16889   "RTN","RCD PEM7",69,0 )
  16890    .. I $L(P NAME)>35 S  PNAME=$E( PNAME,1,35 ) ; limit  size of th e name
  16891   "RTN","RCD PEM7",70,0 )
  16892    .. ; PRCA *4.5*303 S plit into  "ACH" and  not "ACH"
  16893   "RTN","RCD PEM7",71,0 )
  16894    .. ;Updat e count an d totals
  16895   "RTN","RCD PEM7",72,0 )
  16896    .. S:$P(R EC0,U,15)= "ACH" ERA1 CNT=ERA1CN T+1,ERA1TO T=ERA1TOT+ AMT
  16897   "RTN","RCD PEM7",73,0 )
  16898    .. S:$P(R EC0,U,15)' ="ACH" ERA 2CNT=ERA2C NT+1,ERA2T OT=ERA2TOT +AMT
  16899   "RTN","RCD PEM7",74,0 )
  16900    .. ;PRCA* 4.5*303 ad ded the FD ATE subscr ipt to the  global so  that the  line
  16901   "RTN","RCD PEM7",75,0 )
  16902    .. ;items  collate i n date asc ending ord er.
  16903   "RTN","RCD PEM7",76,0 )
  16904    .. ;Save  ERA#, Paye r Name, Fi le Date an d Amount P aid
  16905   "RTN","RCD PEM7",77,0 )
  16906    .. S:$P(R EC0,U,15)= "ACH" ^TMP (RCPROG,$J ,"ERA1",FD ATE,ERA1CN T)=$$ERAL( ERAIEN,PNA ME,FDATE,A MT)
  16907   "RTN","RCD PEM7",78,0 )
  16908    .. S:$P(R EC0,U,15)' ="ACH" ^TM P(RCPROG,$ J,"ERA2",F DATE,ERA2C NT)=$$ERAL (ERAIEN,PN AME,FDATE, AMT)
  16909   "RTN","RCD PEM7",79,0 )
  16910    .. Q
  16911   "RTN","RCD PEM7",80,0 )
  16912    . Q
  16913   "RTN","RCD PEM7",81,0 )
  16914    Q
  16915   "RTN","RCD PEM7",82,0 )
  16916    ;
  16917   "RTN","RCD PEM7",83,0 )
  16918   EFTSCAN ;S can EFT
  16919   "RTN","RCD PEM7",84,0 )
  16920    N DEPN,EF TIEN,IEN34 43,EFTDATE ,TRACE,REC 0,REC31,RE C4,STATUS, PAYER,DEPA MT
  16921   "RTN","RCD PEM7",85,0 )
  16922    ;Scan for  unmatched  EFT
  16923   "RTN","RCD PEM7",86,0 )
  16924    S EFTIEN= 0,STATUS=0
  16925   "RTN","RCD PEM7",87,0 )
  16926    ; PRCA*4. 5*303 Chec k all stat uses repor t on unmat ched EFTs,  Matched E FTs with u nposted ER As
  16927   "RTN","RCD PEM7",88,0 )
  16928    ; 4-7-201 6 Removed  F STATUS=- 1,0,1 per  issue iden tifying du plicate EF Ts this wi ll need to  be
  16929   "RTN","RCD PEM7",89,0 )
  16930    ; address ed in anot her projec t
  16931   "RTN","RCD PEM7",90,0 )
  16932    S STATUS= 0 F  S EFT IEN=$O(^RC Y(344.31," AMATCH",ST ATUS,EFTIE N)) Q:'EFT IEN  D
  16933   "RTN","RCD PEM7",91,0 )
  16934    .S REC31= $G(^RCY(34 4.31,EFTIE N,0))
  16935   "RTN","RCD PEM7",92,0 )
  16936    .;PRCA*4. 5*303 Get  zero node  of the ass ociated ER A if match ed
  16937   "RTN","RCD PEM7",93,0 )
  16938    .S REC4=$ S($P(REC31 ,U,10)'="" :$G(^RCY(3 44.4,$P(RE C31,U,10), 0)),1:"")
  16939   "RTN","RCD PEM7",94,0 )
  16940    .;Get poi nter to EF T file
  16941   "RTN","RCD PEM7",95,0 )
  16942    .S IEN344 3=$P(REC31 ,U) Q:'IEN 3443
  16943   "RTN","RCD PEM7",96,0 )
  16944    .S REC0=$ G(^RCY(344 .3,IEN3443 ,0))
  16945   "RTN","RCD PEM7",97,0 )
  16946    .;Get EFT  file date
  16947   "RTN","RCD PEM7",98,0 )
  16948    .S EFTDAT E=$P(REC0, U,2) Q:'EF TDATE
  16949   "RTN","RCD PEM7",99,0 )
  16950    .;Ignore  if <15 day s overdue
  16951   "RTN","RCD PEM7",100, 0)
  16952    .Q:$$FMDI FF^XLFDT(T ODAY,EFTDA TE,1)<15
  16953   "RTN","RCD PEM7",101, 0)
  16954    .;PRCA*4. 5*303 - if  we have a  ERA check  to see if  we includ e this rec ord or qui t
  16955   "RTN","RCD PEM7",102, 0)
  16956    .I REC4'= "" Q:$P(RE C4,U,14)'= 0  ; Not p osted stat us is 0 -  everything  else is i gnored
  16957   "RTN","RCD PEM7",103, 0)
  16958    .;Deposit  number an d payment  amount
  16959   "RTN","RCD PEM7",104, 0)
  16960    .S DEPN=$ P(REC0,U,6 ),DEPAMT=$ P(REC31,U, 7)
  16961   "RTN","RCD PEM7",105, 0)
  16962    .;Payer I D and Trac e from EFT  detail fi le
  16963   "RTN","RCD PEM7",106, 0)
  16964    .S PAYER= $P(REC31,U ,2),TRACE= $P(REC31,U ,4) S:PAYE R="" PAYER ="NO PAYER  NAME RECE IVED" ; PR CA*4.5*298
  16965   "RTN","RCD PEM7",107, 0)
  16966    .;If paye r and trac e combined  are >40 t runcate pa yer name f irst
  16967   "RTN","RCD PEM7",108, 0)
  16968    .I $L(PAY ER_TRACE)> 40 D
  16969   "RTN","RCD PEM7",109, 0)
  16970    ..I $L(PA YER)>20 S  PAYER=$E(P AYER,1,20)  ; limit s ize of the  name
  16971   "RTN","RCD PEM7",110, 0)
  16972    ..Q:$L(PA YER_TRACE) <41
  16973   "RTN","RCD PEM7",111, 0)
  16974    ..S TRACE =$E(TRACE, 1,20) ; li mit size o f the trac e
  16975   "RTN","RCD PEM7",112, 0)
  16976    .;Update  count and  totals
  16977   "RTN","RCD PEM7",113, 0)
  16978    .S EFTCNT =EFTCNT+1, EFTTOT=EFT TOT+DEPAMT
  16979   "RTN","RCD PEM7",114, 0)
  16980    .; PRCA*4 .5*303 add ed EFTDATE  to the su bscripts b efore EFTC NT so repo rt will so rt in
  16981   "RTN","RCD PEM7",115, 0)
  16982    .; date a scending o rder.
  16983   "RTN","RCD PEM7",116, 0)
  16984    .;Save De posit No,  Receipt, P ayer ID, E FT Date an d Deposit  Amount
  16985   "RTN","RCD PEM7",117, 0)
  16986    .S ^TMP(R CPROG,$J," EFT",EFTDA TE,EFTCNT) =$$EFTL(DE PN,TRACE,P AYER,EFTDA TE,DEPAMT)
  16987   "RTN","RCD PEM7",118, 0)
  16988    Q
  16989   "RTN","RCD PEM7",119, 0)
  16990    ;
  16991   "RTN","RCD PEM7",120, 0)
  16992    ; PRCA*4. 5*304
  16993   "RTN","RCD PEM7",121, 0)
  16994    ; Scan fo r ERA's ol der than a llowed by  parameter
  16995   "RTN","RCD PEM7",122, 0)
  16996   SUSPSCAN ;
  16997   "RTN","RCD PEM7",123, 0)
  16998    N RCCT,RC DATA,RCSDA TE,RCDATA0 ,RCDATA2,R CDATA3,RCM AXDAY,RCRE CTDA,RCTRA NDA
  16999   "RTN","RCD PEM7",124, 0)
  17000    N RCDEP,R CTRACE,RCP AYER,RCEFT DT,RCDEPAM T,RCDAYS,R CUSER,RCRE C,RCDISP,R CRSN,RCSRE C
  17001   "RTN","RCD PEM7",125, 0)
  17002    ;
  17003   "RTN","RCD PEM7",126, 0)
  17004    ;initiali ze counter s
  17005   "RTN","RCD PEM7",127, 0)
  17006    S (RCSUSA MT,RCSUSCN T)=0
  17007   "RTN","RCD PEM7",128, 0)
  17008    ;
  17009   "RTN","RCD PEM7",129, 0)
  17010    ;calculat e the last  date to s top gather ing entrie s on
  17011   "RTN","RCD PEM7",130, 0)
  17012    S RCMAXDA Y=TODAY-RC MXDYS
  17013   "RTN","RCD PEM7",131, 0)
  17014    ;
  17015   "RTN","RCD PEM7",132, 0)
  17016    ;Loop thr ough the I n Suspense  index
  17017   "RTN","RCD PEM7",133, 0)
  17018    S (RCRECT DA,RCCT)=0
  17019   "RTN","RCD PEM7",134, 0)
  17020    F  S RCRE CTDA=$O(^R CY(344,"AN ",RCRECTDA )) Q:'RCRE CTDA  D
  17021   "RTN","RCD PEM7",135, 0)
  17022    . S RCDAT A=$G(^RCY( 344,RCRECT DA,0))
  17023   "RTN","RCD PEM7",136, 0)
  17024    . S RCREC =$P(RCDATA ,U)
  17025   "RTN","RCD PEM7",137, 0)
  17026    . S RCTRA NDA=0 F  S  RCTRANDA= $O(^RCY(34 4,"AN",RCR ECTDA,RCTR ANDA)) Q:' RCTRANDA   D
  17027   "RTN","RCD PEM7",138, 0)
  17028    . . S RCD ATA0=$G(^R CY(344,RCR ECTDA,1,RC TRANDA,0))
  17029   "RTN","RCD PEM7",139, 0)
  17030    . . S RCD ATA2=$G(^R CY(344,RCR ECTDA,1,RC TRANDA,2))
  17031   "RTN","RCD PEM7",140, 0)
  17032    . . S RCD ATA3=$G(^R CY(344,RCR ECTDA,1,RC TRANDA,3))
  17033   "RTN","RCD PEM7",141, 0)
  17034    . . ;get  date into  suspense
  17035   "RTN","RCD PEM7",142, 0)
  17036    . . S RCS DATE=$P(RC DATA3,U,2)
  17037   "RTN","RCD PEM7",143, 0)
  17038    . . S RCD AYS=$$FMTH ^XLFDT(TOD AY,1)-$$FM TH^XLFDT(R CSDATE,1)
  17039   "RTN","RCD PEM7",144, 0)
  17040    . . Q:RCS DATE=""
  17041   "RTN","RCD PEM7",145, 0)
  17042    . . ;
  17043   "RTN","RCD PEM7",146, 0)
  17044    . . ;if y ounger tha n the cuto ff date, q uit
  17045   "RTN","RCD PEM7",147, 0)
  17046    . . Q:RCD AYS'>RCMXD YS
  17047   "RTN","RCD PEM7",148, 0)
  17048    . . ;
  17049   "RTN","RCD PEM7",149, 0)
  17050    . . ; get  the user  and dispos ition
  17051   "RTN","RCD PEM7",150, 0)
  17052    . . S RCU SER=$$GET1 ^DIQ(200,$ P(RCDATA3, U,3)_",",1 ,"E")
  17053   "RTN","RCD PEM7",151, 0)
  17054    . . S RCD ISP=$$UP^X LFSTR($$GE T1^DIQ(344 .01,RCTRAN DA_","_RCR ECTDA_",", 3.01))
  17055   "RTN","RCD PEM7",152, 0)
  17056    . . ;
  17057   "RTN","RCD PEM7",153, 0)
  17058    . . ;Susp ense statu s has been  cleared q uit
  17059   "RTN","RCD PEM7",154, 0)
  17060    . . Q:$P( RCDATA2,U, 6)'="" 
  17061   "RTN","RCD PEM7",155, 0)
  17062    . . ;
  17063   "RTN","RCD PEM7",156, 0)
  17064    . . ;Extr act needed  info for  report
  17065   "RTN","RCD PEM7",157, 0)
  17066    . . S RCE FTDT=$P(RC DATA0,U,6) ,RCDEPAMT= $P(RCDATA0 ,U,4)
  17067   "RTN","RCD PEM7",158, 0)
  17068    . . ;
  17069   "RTN","RCD PEM7",159, 0)
  17070    . . ;upda te counter  and amoun t info
  17071   "RTN","RCD PEM7",160, 0)
  17072    . . S RCS USCNT=RCSU SCNT+1
  17073   "RTN","RCD PEM7",161, 0)
  17074    . . S RCS USAMT=RCSU SAMT+RCDEP AMT
  17075   "RTN","RCD PEM7",162, 0)
  17076    . . S RCR SN=$E($P($ G(^RCY(344 ,RCRECTDA, 1,RCTRANDA ,1)),U,2), 1,12)
  17077   "RTN","RCD PEM7",163, 0)
  17078    . . S RCS REC=RCREC_ "@"_RCTRAN DA
  17079   "RTN","RCD PEM7",164, 0)
  17080    . . ;
  17081   "RTN","RCD PEM7",165, 0)
  17082    . . ;upda te tempora ry array
  17083   "RTN","RCD PEM7",166, 0)
  17084    . . S ^TM P(RCPROG,$ J,"SUSPENS E",RCSDATE ,RCSUSCNT) =$$ESUSPL( RCSDATE,RC DAYS,RCUSE R,RCSREC,R CDEPAMT,RC DISP,RCRSN )
  17085   "RTN","RCD PEM7",167, 0)
  17086    ;
  17087   "RTN","RCD PEM7",168, 0)
  17088    Q
  17089   "RTN","RCD PEM7",169, 0)
  17090    ;
  17091   "RTN","RCD PEM7",170, 0)
  17092   BULLETIN ; Create bul letins onl y if overd ue EFT/ERA  found
  17093   "RTN","RCD PEM7",171, 0)
  17094    ;
  17095   "RTN","RCD PEM7",172, 0)
  17096    N ARRAY,S BJ,SUB,CNT ,CNT1,RCPR OG1,GLB,RC MXDYS,IDX
  17097   "RTN","RCD PEM7",173, 0)
  17098    S RCPROG1 ="RCDPEM7A ",GLB=$NA( ^TMP(RCPRO G1,$J,"XMT EXT"))
  17099   "RTN","RCD PEM7",174, 0)
  17100    ;
  17101   "RTN","RCD PEM7",175, 0)
  17102    ;Unmatche d ERA bull etins
  17103   "RTN","RCD PEM7",176, 0)
  17104    I ERACNT  D
  17105   "RTN","RCD PEM7",177, 0)
  17106    .;Build h eader
  17107   "RTN","RCD PEM7",178, 0)
  17108    .S SUB="E RA" K @GLB
  17109   "RTN","RCD PEM7",179, 0)
  17110    .S SBJ="E DI LBOX-ST A# "_$P($$ SITE^VASIT E,"^",3)_" -ACTION RE Q-Unmatche d ERAs > 3 0 days"
  17111   "RTN","RCD PEM7",180, 0)
  17112    .S @GLB@( 1)="The li sted ERAs  were recei ved more t han 30 day s ago and  have not y et been"
  17113   "RTN","RCD PEM7",181, 0)
  17114    .S @GLB@( 2)="matche d."
  17115   "RTN","RCD PEM7",182, 0)
  17116    .S @GLB@( 3)=" "
  17117   "RTN","RCD PEM7",183, 0)
  17118    .S @GLB@( 4)="Total  # of ERAs  - "_ERACNT
  17119   "RTN","RCD PEM7",184, 0)
  17120    .S @GLB@( 5)="Total  Dollar Amo unt - "_"$ "_$FN(ERAT OT,",",2)
  17121   "RTN","RCD PEM7",185, 0)
  17122    .S @GLB@( 6)=" "
  17123   "RTN","RCD PEM7",186, 0)
  17124    .S @GLB@( 7)="ERA#         PAYE R NAME                                   FI LE DATE     AMOUNT PA ID"
  17125   "RTN","RCD PEM7",187, 0)
  17126    .;
  17127   "RTN","RCD PEM7",188, 0)
  17128    .;Move un matched ER A search f indings in to message
  17129   "RTN","RCD PEM7",189, 0)
  17130    .S CNT=0, CNT1=8,SUB ="ERA"
  17131   "RTN","RCD PEM7",190, 0)
  17132    .S IDX=""  F  S IDX= $O(^TMP(RC PROG,$J,SU B,IDX)) Q: 'IDX  F  S  CNT=$O(^T MP(RCPROG, $J,SUB,IDX ,CNT)) Q:' CNT  D
  17133   "RTN","RCD PEM7",191, 0)
  17134    ..S CNT1= CNT1+1,@GL B@(CNT1)=^ TMP(RCPROG ,$J,SUB,ID X,CNT)
  17135   "RTN","RCD PEM7",192, 0)
  17136    .S @GLB@( CNT1+1)="* * END OF R EPORT **"
  17137   "RTN","RCD PEM7",193, 0)
  17138    .D SEND
  17139   "RTN","RCD PEM7",194, 0)
  17140    .K @GLB
  17141   "RTN","RCD PEM7",195, 0)
  17142    ;
  17143   "RTN","RCD PEM7",196, 0)
  17144    ;Unposted  "ACH" ERA  bulletins
  17145   "RTN","RCD PEM7",197, 0)
  17146    ; PRCA*4. 5*303 - mo dified thi s bulletin  to show o nly "ACH"  expected p ayments
  17147   "RTN","RCD PEM7",198, 0)
  17148    I ERA1CNT  D
  17149   "RTN","RCD PEM7",199, 0)
  17150    .;Build h eader
  17151   "RTN","RCD PEM7",200, 0)
  17152    .S SUB="E RA1" K @GL B
  17153   "RTN","RCD PEM7",201, 0)
  17154    .; PRCA*4 .5*303 - C hanged SBJ  to make s ure it was  less than  65 charac ters
  17155   "RTN","RCD PEM7",202, 0)
  17156    .S SBJ="E DI LBOX-ST A# "_$P($$ SITE^VASIT E,"^",3)_" -ACTION RE Q-EFT:Matc hed/Not Po sted ERA>3 0 days"
  17157   "RTN","RCD PEM7",203, 0)
  17158    .S @GLB@( 1)="The li sted ERAs  were recei ved more t han 30 day s ago and  have been  matched bu t"
  17159   "RTN","RCD PEM7",204, 0)
  17160    .S @GLB@( 2)="have n ot been po sted"
  17161   "RTN","RCD PEM7",205, 0)
  17162    .S @GLB@( 3)=" "
  17163   "RTN","RCD PEM7",206, 0)
  17164    .S @GLB@( 4)="Total  # of ERAs  - ""MATCHE D TO EFT""  - "_ERA1C NT
  17165   "RTN","RCD PEM7",207, 0)
  17166    .S @GLB@( 5)="Total  Dollar Amo unt - "_"$ "_$FN(ERA1 TOT,",",2)
  17167   "RTN","RCD PEM7",208, 0)
  17168    .S @GLB@( 6)=" "
  17169   "RTN","RCD PEM7",209, 0)
  17170    .S @GLB@( 7)="ERA#         PAYE R NAME                                   FI LE DATE     AMOUNT PA ID"
  17171   "RTN","RCD PEM7",210, 0)
  17172    .;
  17173   "RTN","RCD PEM7",211, 0)
  17174    .;Move un posted ERA  search fi ndings int o message
  17175   "RTN","RCD PEM7",212, 0)
  17176    .S CNT=0, CNT1=8,IDX =""
  17177   "RTN","RCD PEM7",213, 0)
  17178    .F  S IDX =$O(^TMP(R CPROG,$J,S UB,IDX)) Q :'IDX  F   S CNT=$O(^ TMP(RCPROG ,$J,SUB,ID X,CNT)) Q: 'CNT  D
  17179   "RTN","RCD PEM7",214, 0)
  17180    ..S CNT1= CNT1+1
  17181   "RTN","RCD PEM7",215, 0)
  17182    ..S @GLB@ (CNT1)=^TM P(RCPROG,$ J,SUB,IDX, CNT)
  17183   "RTN","RCD PEM7",216, 0)
  17184    .S @GLB@( CNT1+1)="* * END OF R EPORT **"
  17185   "RTN","RCD PEM7",217, 0)
  17186    .D SEND
  17187   "RTN","RCD PEM7",218, 0)
  17188    .K @GLB
  17189   "RTN","RCD PEM7",219, 0)
  17190    ;
  17191   "RTN","RCD PEM7",220, 0)
  17192    ;Unposted  "CHK" ERA  bulletins  or ERAs,  that don't  match "AC H"
  17193   "RTN","RCD PEM7",221, 0)
  17194    ; PRCA*4. 5*303 - mo dified thi s bulletin  to show " CHK" expec ted paymen ts (or don 't match " ACH")
  17195   "RTN","RCD PEM7",222, 0)
  17196    I ERA2CNT  D
  17197   "RTN","RCD PEM7",223, 0)
  17198    .;Build h eader
  17199   "RTN","RCD PEM7",224, 0)
  17200    .S SUB="E RA2" K @GL B
  17201   "RTN","RCD PEM7",225, 0)
  17202    .; PRCA*4 .5*303 - C hanged SBJ  to make s ure it was  less than  65 charac ters
  17203   "RTN","RCD PEM7",226, 0)
  17204    .S SBJ="E DI LBOX-ST A# "_$P($$ SITE^VASIT E,"^",3)_" -ACTION RE Q-PAPER:Ma tched/Not  Posted ERA >30 days"
  17205   "RTN","RCD PEM7",227, 0)
  17206    .S @GLB@( 1)="The li sted ERAs  were recei ved more t han 30 day s ago and  have been  matched bu t"
  17207   "RTN","RCD PEM7",228, 0)
  17208    .S @GLB@( 2)="have n ot been po sted"
  17209   "RTN","RCD PEM7",229, 0)
  17210    .S @GLB@( 3)=" "
  17211   "RTN","RCD PEM7",230, 0)
  17212    .S @GLB@( 4)="Total  # of ERAs  - ""MATCHE D TO PAPER  CHECK"" -  "_ERA2CNT
  17213   "RTN","RCD PEM7",231, 0)
  17214    .S @GLB@( 5)="Total  Dollar Amo unt - "_"$ "_$FN(ERA2 TOT,",",2)
  17215   "RTN","RCD PEM7",232, 0)
  17216    .S @GLB@( 6)=" "
  17217   "RTN","RCD PEM7",233, 0)
  17218    .S @GLB@( 7)="ERA#         PAYE R NAME                                   FI LE DATE     AMOUNT PA ID"
  17219   "RTN","RCD PEM7",234, 0)
  17220    .;
  17221   "RTN","RCD PEM7",235, 0)
  17222    .;Move un posted ERA  search fi ndings int o message
  17223   "RTN","RCD PEM7",236, 0)
  17224    .S CNT=0, CNT1=8,IDX =""
  17225   "RTN","RCD PEM7",237, 0)
  17226    .F  S IDX =$O(^TMP(R CPROG,$J,S UB,IDX)) Q :'IDX  F   S CNT=$O(^ TMP(RCPROG ,$J,SUB,ID X,CNT)) Q: 'CNT  D
  17227   "RTN","RCD PEM7",238, 0)
  17228    ..S CNT1= CNT1+1,@GL B@(CNT1)=^ TMP(RCPROG ,$J,SUB,ID X,CNT)
  17229   "RTN","RCD PEM7",239, 0)
  17230    .S @GLB@( CNT1+1)="* * END OF R EPORT **"
  17231   "RTN","RCD PEM7",240, 0)
  17232    .D SEND
  17233   "RTN","RCD PEM7",241, 0)
  17234    .K @GLB
  17235   "RTN","RCD PEM7",242, 0)
  17236    ;
  17237   "RTN","RCD PEM7",243, 0)
  17238    ;Unmatche d EFT bull etins
  17239   "RTN","RCD PEM7",244, 0)
  17240    ; PRCA*4. 5*303 - Ch anged logi c to send  "No EFTs m ore than 1 4 days..."  message i f no EFTs
  17241   "RTN","RCD PEM7",245, 0)
  17242    ;I EFTCNT  D
  17243   "RTN","RCD PEM7",246, 0)
  17244    ;Build he ader
  17245   "RTN","RCD PEM7",247, 0)
  17246    S SUB="EF T" K @GLB
  17247   "RTN","RCD PEM7",248, 0)
  17248    S SBJ="ED I LBOX-STA # "_$P($$S ITE^VASITE ,"^",3)_"- ACTION REQ -EFTs > 14  days"
  17249   "RTN","RCD PEM7",249, 0)
  17250    I EFTCNT= 0 D  G B1
  17251   "RTN","RCD PEM7",250, 0)
  17252    . S @GLB@ (1)="****  There are  NO EFTs mo re than 14  days old  that have  not yet be en matched ."
  17253   "RTN","RCD PEM7",251, 0)
  17254    . S @GLB@ (2)=" "
  17255   "RTN","RCD PEM7",252, 0)
  17256    . S @GLB@ (3)="Total  # of EFTs  - "_EFTCN T
  17257   "RTN","RCD PEM7",253, 0)
  17258    . S @GLB@ (4)="Total  Dollar Am ount - $"_ $FN(0,",", 2)
  17259   "RTN","RCD PEM7",254, 0)
  17260    . S @GLB@ (5)=" "
  17261   "RTN","RCD PEM7",255, 0)
  17262    . S @GLB@ (6)="** EN D OF REPOR T **"
  17263   "RTN","RCD PEM7",256, 0)
  17264    ;
  17265   "RTN","RCD PEM7",257, 0)
  17266    I EFTCNT> 0 D
  17267   "RTN","RCD PEM7",258, 0)
  17268    .S @GLB@( 1)="The fo llowing EF Ts were re ceived mor e than 14  days ago a nd have no t yet"
  17269   "RTN","RCD PEM7",259, 0)
  17270    .S @GLB@( 2)="been m atched."
  17271   "RTN","RCD PEM7",260, 0)
  17272    .S @GLB@( 3)=" "
  17273   "RTN","RCD PEM7",261, 0)
  17274    .S @GLB@( 4)="Total  # of EFTs  - "_EFTCNT
  17275   "RTN","RCD PEM7",262, 0)
  17276    .S @GLB@( 5)="Total  Dollar Amo unt - "_"$ "_$FN(EFTT OT,",",2)
  17277   "RTN","RCD PEM7",263, 0)
  17278    .S @GLB@( 6)=" "
  17279   "RTN","RCD PEM7",264, 0)
  17280    .S @GLB@( 7)="DEPOSI T#   PAYER  NAME/TRAC E#                           EFT  DATE    D EPOSIT AMT "
  17281   "RTN","RCD PEM7",265, 0)
  17282    .;
  17283   "RTN","RCD PEM7",266, 0)
  17284    .;Move EF T search f indings in to message
  17285   "RTN","RCD PEM7",267, 0)
  17286    .S CNT=0, CNT1=8,SUB ="EFT",IDX =""
  17287   "RTN","RCD PEM7",268, 0)
  17288    .F  S IDX =$O(^TMP(R CPROG,$J,S UB,IDX)) Q :'IDX  F   S CNT=$O(^ TMP(RCPROG ,$J,SUB,ID X,CNT)) Q: 'CNT  D
  17289   "RTN","RCD PEM7",269, 0)
  17290    ..S CNT1= CNT1+1,@GL B@(CNT1)=^ TMP(RCPROG ,$J,SUB,ID X,CNT)
  17291   "RTN","RCD PEM7",270, 0)
  17292    .S @GLB@( CNT1+1)="* * END OF R EPORT **"
  17293   "RTN","RCD PEM7",271, 0)
  17294   B1 ;
  17295   "RTN","RCD PEM7",272, 0)
  17296    D SEND
  17297   "RTN","RCD PEM7",273, 0)
  17298    K @GLB
  17299   "RTN","RCD PEM7",274, 0)
  17300    ;
  17301   "RTN","RCD PEM7",275, 0)
  17302    ;PRCA*4.5 *304 - Add  suspense  bulletin
  17303   "RTN","RCD PEM7",276, 0)
  17304    ; Suspens e bulletin s
  17305   "RTN","RCD PEM7",277, 0)
  17306    ;
  17307   "RTN","RCD PEM7",278, 0)
  17308    ; Send bu lletin if  items in s uspense
  17309   "RTN","RCD PEM7",279, 0)
  17310    I RCSUSCN T D
  17311   "RTN","RCD PEM7",280, 0)
  17312    . ;
  17313   "RTN","RCD PEM7",281, 0)
  17314    . N DT
  17315   "RTN","RCD PEM7",282, 0)
  17316    . ;Retrie ve the par ameter
  17317   "RTN","RCD PEM7",283, 0)
  17318    . S RCMXD YS=$$GET1^ DIQ(342,"1 ,",7.04)
  17319   "RTN","RCD PEM7",284, 0)
  17320    . ;
  17321   "RTN","RCD PEM7",285, 0)
  17322    . ;Build  header
  17323   "RTN","RCD PEM7",286, 0)
  17324    . S SUB=" SUSPENSE"  K @GLB
  17325   "RTN","RCD PEM7",287, 0)
  17326    . S SBJ=" EDI LBOX-S TA# "_$P($ $SITE^VASI TE,"^",3)_ "-SUSPENSE  ENTRIES O VERDUE FOR  PROCESSIN G"
  17327   "RTN","RCD PEM7",288, 0)
  17328    . S @GLB@ (1)="The f ollowing e ntries hav e been in  Suspense p ast the #d ays allowe d by site"
  17329   "RTN","RCD PEM7",289, 0)
  17330    . S @GLB@ (2)="param eter - whi ch is curr ently set  at "_RCMXD YS_" days. "
  17331   "RTN","RCD PEM7",290, 0)
  17332    . S @GLB@ (3)=" "
  17333   "RTN","RCD PEM7",291, 0)
  17334    . S @GLB@ (4)="Total  # of Over due Entrie s in Suspe nse  - "_R CSUSCNT
  17335   "RTN","RCD PEM7",292, 0)
  17336    . S @GLB@ (5)="Total  Dollar Am ount Overd ue in Susp ense - "_" $"_$FN(RCS USAMT,",", 2)
  17337   "RTN","RCD PEM7",293, 0)
  17338    . S @GLB@ (6)=" "
  17339   "RTN","RCD PEM7",294, 0)
  17340    . S @GLB@ (7)="SUSP  DATE  #DAY S USER REC EIPT#                 AMOUNT DIS P        R EASON"
  17341   "RTN","RCD PEM7",295, 0)
  17342    . ;
  17343   "RTN","RCD PEM7",296, 0)
  17344    . ;Move S uspense se arch findi ngs into m essage
  17345   "RTN","RCD PEM7",297, 0)
  17346    . S CNT=0 ,CNT1=8,SU B="SUSPENS E",DT=0
  17347   "RTN","RCD PEM7",298, 0)
  17348    . F  S DT =$O(^TMP(R CPROG,$J,S UB,DT)) Q: 'DT  D
  17349   "RTN","RCD PEM7",299, 0)
  17350    . . F  S  CNT=$O(^TM P(RCPROG,$ J,SUB,DT,C NT)) Q:'CN T  D
  17351   "RTN","RCD PEM7",300, 0)
  17352    . . . S C NT1=CNT1+1 ,@GLB@(CNT 1)=^TMP(RC PROG,$J,SU B,DT,CNT)
  17353   "RTN","RCD PEM7",301, 0)
  17354    . S @GLB@ (CNT1+1)=" ** END OF  REPORT **"
  17355   "RTN","RCD PEM7",302, 0)
  17356    . D SEND
  17357   "RTN","RCD PEM7",303, 0)
  17358    . K @GLB
  17359   "RTN","RCD PEM7",304, 0)
  17360    Q
  17361   "RTN","RCD PEM7",305, 0)
  17362    ;
  17363   "RTN","RCD PEM7",306, 0)
  17364   SEND ;Tran smit mail  message
  17365   "RTN","RCD PEM7",307, 0)
  17366    N XMDUZ,X MTEXT,XMSU B,XMY,XMIN STR
  17367   "RTN","RCD PEM7",308, 0)
  17368    S XMDUZ=D UZ,XMTEXT= GLB,XMSUB= SBJ,XMY("I :G.RCDPE A UDIT")=""
  17369   "RTN","RCD PEM7",309, 0)
  17370    S XMINSTR ("FROM")=" POSTMASTER "
  17371   "RTN","RCD PEM7",310, 0)
  17372    S XMINSTR ("FLAGS")= "P"
  17373   "RTN","RCD PEM7",311, 0)
  17374    D SENDMSG ^XMXAPI(XM DUZ,XMSUB, XMTEXT,.XM Y,.XMINSTR )
  17375   "RTN","RCD PEM7",312, 0)
  17376    Q
  17377   "RTN","RCD PEM7",313, 0)
  17378    ;
  17379   "RTN","RCD PEM7",314, 0)
  17380   ERAL(X1,X2 ,X3,X4) ;F ormat ERA  Message li ne
  17381   "RTN","RCD PEM7",315, 0)
  17382    N SPACE
  17383   "RTN","RCD PEM7",316, 0)
  17384    S SPACE=$ J("",80)
  17385   "RTN","RCD PEM7",317, 0)
  17386    S X1=X1_$ E(SPACE,1, 12-$L(X1))
  17387   "RTN","RCD PEM7",318, 0)
  17388    S X2=X1_$ E(X2,1,43) _$E(SPACE, 1,43-$L(X2 ))
  17389   "RTN","RCD PEM7",319, 0)
  17390    S X3=$$FM TE^XLFDT(X 3,"2D")
  17391   "RTN","RCD PEM7",320, 0)
  17392    S X4="$"_ $FN(X4,"," ,2)
  17393   "RTN","RCD PEM7",321, 0)
  17394    Q X2_$J(X 3,8)_$J(X4 ,15)
  17395   "RTN","RCD PEM7",322, 0)
  17396    ;
  17397   "RTN","RCD PEM7",323, 0)
  17398   EFTL(X1,X2 ,X3,X4,X5)  ;Format E FT Message  line
  17399   "RTN","RCD PEM7",324, 0)
  17400    N SPACE
  17401   "RTN","RCD PEM7",325, 0)
  17402    S SPACE=$ J("",80)
  17403   "RTN","RCD PEM7",326, 0)
  17404    S X1=X1_$ E(SPACE,1, 10-$L(X1)) _" "
  17405   "RTN","RCD PEM7",327, 0)
  17406    S X2=X3_" /"_X2 ;Pay er and Tra ce
  17407   "RTN","RCD PEM7",328, 0)
  17408    S X2=X1_$ E(X2,1,41) _$E(SPACE, 1,42-$L(X2 ))
  17409   "RTN","RCD PEM7",329, 0)
  17410    S X4=$$FM TE^XLFDT(X 4,"2D")
  17411   "RTN","RCD PEM7",330, 0)
  17412    S X5="$"_ $FN(X5,"," ,2)
  17413   "RTN","RCD PEM7",331, 0)
  17414    Q X2_$J(X 4,8)_$J(X5 ,15)
  17415   "RTN","RCD PEM7",332, 0)
  17416    ;
  17417   "RTN","RCD PEM7",333, 0)
  17418    ;PRCA*4.5 *304
  17419   "RTN","RCD PEM7",334, 0)
  17420   ESUSPL(X1, X2,X3,X4,X 5,X6,X7) ; Format Sus pense Mess age line
  17421   "RTN","RCD PEM7",335, 0)
  17422    N SPACE
  17423   "RTN","RCD PEM7",336, 0)
  17424    S SPACE=$ J("",80)
  17425   "RTN","RCD PEM7",337, 0)
  17426    ;spacing  for Suspen se Date
  17427   "RTN","RCD PEM7",338, 0)
  17428    S X1=$$FM TE^XLFDT(X 1,"2D")
  17429   "RTN","RCD PEM7",339, 0)
  17430    S X1=X1_$ E(SPACE,1, 10-$L(X1))
  17431   "RTN","RCD PEM7",340, 0)
  17432    ;spacing  for # days  in suspen se
  17433   "RTN","RCD PEM7",341, 0)
  17434    S X2=$E(S PACE,1,6-$ L(X2))_X2
  17435   "RTN","RCD PEM7",342, 0)
  17436    ;spacing  for USER
  17437   "RTN","RCD PEM7",343, 0)
  17438    S X3=" "_ X3_$E(SPAC E,1,5-$L(X 3))
  17439   "RTN","RCD PEM7",344, 0)
  17440    ;spacing  for RECEIP T NUMBER_T RANS #
  17441   "RTN","RCD PEM7",345, 0)
  17442    S X4=$E(X 4_SPACE,1, 16)
  17443   "RTN","RCD PEM7",346, 0)
  17444    ;spacing  for amount  in suspen se
  17445   "RTN","RCD PEM7",347, 0)
  17446    S X5=$J(" $"_$FN(X5, ",",2),13) _" "
  17447   "RTN","RCD PEM7",348, 0)
  17448    ;spacing  for STATUS
  17449   "RTN","RCD PEM7",349, 0)
  17450    S X6=X6_$ E(SPACE,1, 12-$L(X6))
  17451   "RTN","RCD PEM7",350, 0)
  17452    ;spacing  for REASON
  17453   "RTN","RCD PEM7",351, 0)
  17454    S X7=X7_$ E(SPACE,1, 12-$L(X7))
  17455   "RTN","RCD PEM7",352, 0)
  17456    ;return c oncatenate d string
  17457   "RTN","RCD PEM7",353, 0)
  17458    Q X1_X2_X 3_X4_X5_X6 _X7
  17459   "RTN","RCD PEM7",354, 0)
  17460    ;
  17461   "RTN","RCD PEMA")
  17462   0^20^B2998 6515
  17463   "RTN","RCD PEMA",1,0)
  17464   RCDPEMA ;A LB/PJH - A UTO-POSTIN G RECEIPT  CREATION ; Oct 15, 20 14@12:37:5 2
  17465   "RTN","RCD PEMA",2,0)
  17466    ;;4.5;Acc ounts Rece ivable;**2 98,304,318 ,321**;Mar  20, 1995; Build 46
  17467   "RTN","RCD PEMA",3,0)
  17468    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  17469   "RTN","RCD PEMA",4,0)
  17470    ;
  17471   "RTN","RCD PEMA",5,0)
  17472   RCPTDET(RC RZ,RECTDA1 ,RCLINES,R CER) ; Add s detail t o a receip t based on  file 344. 49 and exc eptions in  array RCL INES
  17473   "RTN","RCD PEMA",6,0)
  17474    ; RCRZ =  ien of ERA  entry in  file 344.4 9
  17475   "RTN","RCD PEMA",7,0)
  17476    ; RECTDA1  = ien of  receipt en try in fil e 344
  17477   "RTN","RCD PEMA",8,0)
  17478    ; RCER =  error arra y returned  if passed  by refere nce
  17479   "RTN","RCD PEMA",9,0)
  17480    ; RCLINES  = array t o indicate  which scr atchpad li nes can be  posted (a ssigned a  receipt)
  17481   "RTN","RCD PEMA",10,0 )
  17482    ;
  17483   "RTN","RCD PEMA",11,0 )
  17484    N DA,DIE, DR,Q,RCLIN E,RCQ,RCR, RCSPL,RCTR ANDA,RCZ0, SEQLINES,R CSEQ,X,Y,Z ,Z0,Z1
  17485   "RTN","RCD PEMA",12,0 )
  17486    ;
  17487   "RTN","RCD PEMA",13,0 )
  17488    S RCR=0 F   S RCR=$O (^RCY(344. 49,RCRZ,1, RCR)) Q:'R CR  D
  17489   "RTN","RCD PEMA",14,0 )
  17490    . S RCZ0= $G(^RCY(34 4.49,RCRZ, 1,RCR,0)), RCSEQ=$P(R CZ0,U)
  17491   "RTN","RCD PEMA",15,0 )
  17492    . ;Check  first line  for prefi x to see i f ERA line  is valid  for auto-p ost
  17493   "RTN","RCD PEMA",16,0 )
  17494    . I RCSEQ ?1N.N,$P(R CZ0,U,9),$ P($G(RCLIN ES($P(RCZ0 ,U,9))),U)  S SEQLINE S(RCSEQ)=" "
  17495   "RTN","RCD PEMA",17,0 )
  17496    . ;Skip W ORKLIST li nes that d o not need  associate d receipt  detail
  17497   "RTN","RCD PEMA",18,0 )
  17498    . Q:'$D(S EQLINES(RC SEQ\1))
  17499   "RTN","RCD PEMA",19,0 )
  17500    . I RCSEQ '["." S RC SPL(+RCZ0) =$P(RCZ0,U ,9) Q
  17501   "RTN","RCD PEMA",20,0 )
  17502    . I $S(+$ P(RCZ0,U,3 )=0:$P($G( ^RCY(344.4 9,RCRZ,0)) ,U,3),1:$P (RCZ0,U,3) <0) S RCSP L(RCZ0\1,+ RCZ0)=RCZ0  Q
  17503   "RTN","RCD PEMA",21,0 )
  17504    . S RCTRA NDA=$$ADDT RAN^RCDPUR ET(RECTDA1 )
  17505   "RTN","RCD PEMA",22,0 )
  17506    . ;
  17507   "RTN","RCD PEMA",23,0 )
  17508    . I RCTRA NDA'>0 D   Q  ; Error  adding re ceipt deta il - PRCA* 4.5*318
  17509   "RTN","RCD PEMA",24,0 )
  17510    .. S RCER (1)=$$SETE RR^RCDPEM0 (1) ; PRCA *4.5*318 -  pass RCPR OC value t o $$SETERR  
  17511   "RTN","RCD PEMA",25,0 )
  17512    .. S RCER ($O(RCER(" "),-1)+1)= "  NO DETA IL LINE AD DED TO REC EIPT "_$P( $G(^RCY(34 4,RECTDA1, 0)),U)_" F OR LINE #" _$P(RCZ0,U )_" IN EEO B WORKLIST  SCRATCH P AD"
  17513   "RTN","RCD PEMA",26,0 )
  17514    . ;
  17515   "RTN","RCD PEMA",27,0 )
  17516    . ;Store  receipt li ne detail
  17517   "RTN","RCD PEMA",28,0 )
  17518    . D DET(R CRZ,RCR,RE CTDA1,RCTR ANDA)
  17519   "RTN","RCD PEMA",29,0 )
  17520    . S RCSPL (RCZ0\1,+R CZ0)=RCZ0
  17521   "RTN","RCD PEMA",30,0 )
  17522    ;
  17523   "RTN","RCD PEMA",31,0 )
  17524    ; Update  A/R CORREC TED PAYMEN T multiple  with appo rtionment  for split  lines
  17525   "RTN","RCD PEMA",32,0 )
  17526    S Z=0 F   S Z=$O(RCS PL(Z)) Q:' Z  S RCQ=+ $G(RCSPL(Z )) I RCQ D
  17527   "RTN","RCD PEMA",33,0 )
  17528    .; Move E EOB if one  claim ent ered-chang ed 10/19/1 1-see +25^ RCDPEWL8
  17529   "RTN","RCD PEMA",34,0 )
  17530    . S Z1=$O (RCSPL(Z," ")) Q:Z1=" "
  17531   "RTN","RCD PEMA",35,0 )
  17532    . I $O(RC SPL(Z,""), -1)=Z1,'$$ SPLIT(Z,Z1 ,RCERA) Q   ; No spli t occurred
  17533   "RTN","RCD PEMA",36,0 )
  17534    . S Z1=0  F  S Z1=$O (RCSPL(Z,Z 1)) Q:'Z1   S Z0=$G(R CSPL(Z,Z1) ) D
  17535   "RTN","RCD PEMA",37,0 )
  17536    .. S Q=+$ P($G(^RCY( 344.4,RCRZ ,1,RCQ,0)) ,U,2) ; EO B detail r ec
  17537   "RTN","RCD PEMA",38,0 )
  17538    .. Q:'Q
  17539   "RTN","RCD PEMA",39,0 )
  17540    .. I '$P( Z0,U,7)!($ P(Z0,U,2)= "") D  ; S uspense
  17541   "RTN","RCD PEMA",40,0 )
  17542    ... D SPL 1^IBCEOBAR (Q,$S($P(Z 0,U,2)="": "NO BILL", 1:$P(Z0,U, 2)),"",$P( Z0,U,6)) ;  IA 4050
  17543   "RTN","RCD PEMA",41,0 )
  17544    .. E  D
  17545   "RTN","RCD PEMA",42,0 )
  17546    ... D SPL 1^IBCEOBAR (Q,$P(Z0,U ,2),$P(Z0, U,7),$P(Z0 ,U,6)) ; A dd the spl it bill #  ; IA 4050
  17547   "RTN","RCD PEMA",43,0 )
  17548    . ; BEGIN  - PRCA*4. 5*321
  17549   "RTN","RCD PEMA",44,0 )
  17550    . ;Move/C opy/Remove  EEOB deta il for spl it line
  17551   "RTN","RCD PEMA",45,0 )
  17552    . N CLAIM ,IEN3611,R CSPLIT,RCS UB,RCZSAV
  17553   "RTN","RCD PEMA",46,0 )
  17554    . ; Sub-a rray of sp lit claim  detail for  individua l line
  17555   "RTN","RCD PEMA",47,0 )
  17556    . M RCSPL IT=RCSPL(Z )
  17557   "RTN","RCD PEMA",48,0 )
  17558    . ; Prote ct Z subsc ript varia ble from o verwrite b y triggers
  17559   "RTN","RCD PEMA",49,0 )
  17560    . S RCZSA V=Z
  17561   "RTN","RCD PEMA",50,0 )
  17562    . ; Get s cratchpad  line numbe r for this  ERA line
  17563   "RTN","RCD PEMA",51,0 )
  17564    . S RCSUB =$O(^RCY(3 44.49,RCRZ ,1,"ASEQ", Z,""))
  17565   "RTN","RCD PEMA",52,0 )
  17566    . ; Origi nal claim  number fro m Scratchp ad line
  17567   "RTN","RCD PEMA",53,0 )
  17568    . S CLAIM =$$GET1^DI Q(344.491, RCSUB_","_ RCRZ_",",. 02)
  17569   "RTN","RCD PEMA",54,0 )
  17570    . ; EOB f or origina l claim fr om ERA lin e
  17571   "RTN","RCD PEMA",55,0 )
  17572    . S IEN36 11=$$GET1^ DIQ(344.41 ,RCQ_","_R CRZ_",",.0 2,"I")
  17573   "RTN","RCD PEMA",56,0 )
  17574    . ; Autom atic Move/ Copy/Remov e EOB
  17575   "RTN","RCD PEMA",57,0 )
  17576    . I $$AUT O^RCDPEM5( CLAIM,.RCS PLIT,RCERA ,"A",IEN36 11)
  17577   "RTN","RCD PEMA",58,0 )
  17578    . ; Resto re Z
  17579   "RTN","RCD PEMA",59,0 )
  17580    . S Z=RCZ SAV
  17581   "RTN","RCD PEMA",60,0 )
  17582    . ; END   - PRCA*4.5 *321 ;
  17583   "RTN","RCD PEMA",61,0 )
  17584    Q
  17585   "RTN","RCD PEMA",62,0 )
  17586    ;
  17587   "RTN","RCD PEMA",63,0 )
  17588   SPLIT(Z,Z1 ,RCERA) ;C heck if wo rklist was  split to  single cla im
  17589   "RTN","RCD PEMA",64,0 )
  17590    N SUB,NBI LL,OBILL
  17591   "RTN","RCD PEMA",65,0 )
  17592    ;Find spl it line in  scratchpa d
  17593   "RTN","RCD PEMA",66,0 )
  17594    S SUB=$O( ^RCY(344.4 9,RCERA,1, "B",Z1,"") ) Q:'SUB 0
  17595   "RTN","RCD PEMA",67,0 )
  17596    ;Get orig inal claim  number fr om scratch pad
  17597   "RTN","RCD PEMA",68,0 )
  17598    S OBILL=$ P($G(^RCY( 344.49,RCE RA,1,SUB-1 ,0)),U,2)
  17599   "RTN","RCD PEMA",69,0 )
  17600    ;New clai m number
  17601   "RTN","RCD PEMA",70,0 )
  17602    S NBILL=$ P(RCSPL(Z, Z1),U,2)
  17603   "RTN","RCD PEMA",71,0 )
  17604    ;If new a nd old cla im are not  the same  this is a  move via s plit
  17605   "RTN","RCD PEMA",72,0 )
  17606    I OBILL'= "",OBILL'= NBILL Q 1
  17607   "RTN","RCD PEMA",73,0 )
  17608    ;Otherwis e this is  not a spli t
  17609   "RTN","RCD PEMA",74,0 )
  17610    Q 0
  17611   "RTN","RCD PEMA",75,0 )
  17612    ;
  17613   "RTN","RCD PEMA",76,0 )
  17614   DET(RCZ,RC R,RECTDA1, RCTRANDA)  ; Store re ceipt deta il
  17615   "RTN","RCD PEMA",77,0 )
  17616    ; RCZ = i en of entr y file 344 .49
  17617   "RTN","RCD PEMA",78,0 )
  17618    ; RCR = i en of entr y in file  344.491
  17619   "RTN","RCD PEMA",79,0 )
  17620    ; RECTDA1  = ien of  entry in f ile 344
  17621   "RTN","RCD PEMA",80,0 )
  17622    ; RCTRAND A = ien of  entry in  subfile 34 4.01
  17623   "RTN","RCD PEMA",81,0 )
  17624    ;
  17625   "RTN","RCD PEMA",82,0 )
  17626    N DIE,DA, DR,X,Y,Z,R CUP,RCCOM, RCZ0,RC0
  17627   "RTN","RCD PEMA",83,0 )
  17628    S RC0=$G( ^RCY(344.4 9,RCZ,0))
  17629   "RTN","RCD PEMA",84,0 )
  17630    S RCZ0=$G (^RCY(344. 49,RCZ,1,R CR,0))
  17631   "RTN","RCD PEMA",85,0 )
  17632    S DR="",R CUP=+$O(^R CY(344.49, RCZ,1,"B", +RCZ0/1,0) ),RCUP=$G( ^RCY(344.4 9,RCZ,1,RC UP,0))
  17633   "RTN","RCD PEMA",86,0 )
  17634    I $P(RCZ0 ,U,7) S DR =".09////^ S X="_+$P( RCZ0,U,7)_ "_$C(59)_" "PRCA(430, "";"
  17635   "RTN","RCD PEMA",87,0 )
  17636    S DR=DR_" .04////"_( +$P(RCZ0,U ,3))_";.27 ////"_RCR_ ";"
  17637   "RTN","RCD PEMA",88,0 )
  17638    I $P(RC0, U,5)'="" S  DR=DR_".1 ////"_$P(R C0,U,5)_"; "
  17639   "RTN","RCD PEMA",89,0 )
  17640    I $P(RC0, U,6)'="" S  DR=DR_".0 8////"_$P( RC0,U,6)_" ;"
  17641   "RTN","RCD PEMA",90,0 )
  17642    S Z=0 F   S Z=$O(^RC Y(344.49,R CZ,1,RCR,1 ,Z)) Q:'Z   I $P($G(^ (Z,0)),U,5 )=1 S DR=D R_".28//// 1;" Q  ; U pdate rece ipt line w ith dec ad j flag
  17643   "RTN","RCD PEMA",91,0 )
  17644    S RCCOM=$ P(RCZ0,U,1 0)
  17645   "RTN","RCD PEMA",92,0 )
  17646    I $P(RCUP ,U,2)["**A DJ" S RCCO M=RCCOM_$S (RCCOM'="" :"/",1:"") _$S($P($P( RCUP,U,2), "ADJ",2):" ERA adjust ment - no  bill refer enced",1:" Total of E FT mismatc hed to ERA ")
  17647   "RTN","RCD PEMA",93,0 )
  17648    I RCCOM]" " S DR=DR_ "1.02////" _$E(RCCOM, 1,60)_";"
  17649   "RTN","RCD PEMA",94,0 )
  17650    I $P($G(^ RCY(344.49 ,RCZ,0)),U ,4)'="" S  DR=DR_".07 ////"_$P($ G(^RCY(344 .49,RCZ,0) ),U,4)_";"
  17651   "RTN","RCD PEMA",95,0 )
  17652    S DA(1)=R ECTDA1,DA= RCTRANDA,D IE="^RCY(3 44,"_DA(1) _",1,"
  17653   "RTN","RCD PEMA",96,0 )
  17654    D ^DIE
  17655   "RTN","RCD PEMA",97,0 )
  17656    ;Update c omment his tory - PRC A*4.5*321
  17657   "RTN","RCD PEMA",98,0 )
  17658    D:RCCOM]" " AUDIT^RC DPECH(RECT DA1,RCTRAN DA,RCZ,RCR )
  17659   "RTN","RCD PEMA",99,0 )
  17660    Q
  17661   "RTN","RCD PEMA",100, 0)
  17662    ;
  17663   "RTN","RCD PEMA",101, 0)
  17664   BLDRCPT(RC ERA) ; Cre ate a rece ipt for Au to Posting  ERA with  multiple R eceipts -  alpha char  at the 10 th charact er
  17665   "RTN","RCD PEMA",102, 0)
  17666    ; LAYGO n ew entry t o AR BATCH  PAYMENT f ile (#344)
  17667   "RTN","RCD PEMA",103, 0)
  17668    ; input -  RCERA = P ointer to  344.4
  17669   "RTN","RCD PEMA",104, 0)
  17670    ; returns  new IEN o n success,  else zero
  17671   "RTN","RCD PEMA",105, 0)
  17672    ; called  by auto-po st process  (RCDPEAP)
  17673   "RTN","RCD PEMA",106, 0)
  17674    ;
  17675   "RTN","RCD PEMA",107, 0)
  17676    N RECEIPT ,TYPE,LAST REC
  17677   "RTN","RCD PEMA",108, 0)
  17678    S TYPE=$E ($G(^RC(34 1.1,+$O(^R C(341.1,"A C",14,0)), 0)))  ; ^R C(341.1,0)  = AR EVEN T TYPE
  17679   "RTN","RCD PEMA",109, 0)
  17680    ; retriev e the last  receipt r ecorded on  the ERA ( if it exis ts)
  17681   "RTN","RCD PEMA",110, 0)
  17682    S LASTREC =$$GETREC( RCERA)
  17683   "RTN","RCD PEMA",111, 0)
  17684    ; Make su re last re ceipt for  the ERA is  10-chars  long and t he last ch ar is betw een A - Y  (can't be  Z),
  17685   "RTN","RCD PEMA",112, 0)
  17686    ; Otherwi se grab a  new number  and appen d "A"
  17687   "RTN","RCD PEMA",113, 0)
  17688    I LASTREC '="",$L(LA STREC)=10, $A($E(LAST REC,10))>6 4,$A($E(LA STREC,10)) <90 D
  17689   "RTN","RCD PEMA",114, 0)
  17690    . S RECEI PT=$E(LAST REC,1,9)_$ C($A($E(LA STREC,10)) +1)
  17691   "RTN","RCD PEMA",115, 0)
  17692    E  D
  17693   "RTN","RCD PEMA",116, 0)
  17694    . S RECEI PT=$$NEXT^ RCDPUREC(T YPE_$E(DT, 2,7))_"A"
  17695   "RTN","RCD PEMA",117, 0)
  17696    ;
  17697   "RTN","RCD PEMA",118, 0)
  17698    ; Prevent s duplicat e Receipt  # entries  from being  filed
  17699   "RTN","RCD PEMA",119, 0)
  17700    F  Q:'$D( ^RCY(344," B",RECEIPT ))  D
  17701   "RTN","RCD PEMA",120, 0)
  17702    . S RECEI PT=$E(RECE IPT,1)_$E( 1000001+$E (RECEIPT,2 ,7),2,7)_$ E(RECEIPT, 8,9)_"A"
  17703   "RTN","RCD PEMA",121, 0)
  17704    ;
  17705   "RTN","RCD PEMA",122, 0)
  17706    L +^RCY(3 44,"B",REC EIPT):DILO CKTM E  Q  0  ; if LO CK timeout  return ze ro
  17707   "RTN","RCD PEMA",123, 0)
  17708    ;
  17709   "RTN","RCD PEMA",124, 0)
  17710    ; add ent ry to AR B ATCH PAYME NT file (# 344)
  17711   "RTN","RCD PEMA",125, 0)
  17712    N %,%DT,D 0,DA,DD,DI ,DIC,DIE,D LAYGO,DO,D Q,DR,X,Y
  17713   "RTN","RCD PEMA",126, 0)
  17714    S DIC="^R CY(344,",D IC(0)="L", DLAYGO=344
  17715   "RTN","RCD PEMA",127, 0)
  17716    ;  .02 =  opened by                    .03  = date op ened = tra nsmission  date
  17717   "RTN","RCD PEMA",128, 0)
  17718    ;  .04 =  type of pa yment            
  17719   "RTN","RCD PEMA",129, 0)
  17720    ;  .14 =  status (se t to 1:ope n)
  17721   "RTN","RCD PEMA",130, 0)
  17722    S DIC("DR ")=".02/// /"_DUZ_";. 03///"_DT_ ";.04////1 4;.14////1 ;"
  17723   "RTN","RCD PEMA",131, 0)
  17724    S X=RECEI PT
  17725   "RTN","RCD PEMA",132, 0)
  17726    D FILE^DI CN
  17727   "RTN","RCD PEMA",133, 0)
  17728    L -^RCY(3 44,"B",REC EIPT)
  17729   "RTN","RCD PEMA",134, 0)
  17730    I Y>0 Q + Y  ; Y set  by DICN,  return new  IEN
  17731   "RTN","RCD PEMA",135, 0)
  17732    Q 0  ; en try not cr eated
  17733   "RTN","RCD PEMA",136, 0)
  17734    ;
  17735   "RTN","RCD PEMA",137, 0)
  17736   GETREC(RCE RA) ; retu rns the re ceipt numb er
  17737   "RTN","RCD PEMA",138, 0)
  17738    ; input -  RCERA = i en of entr y in 344.4
  17739   "RTN","RCD PEMA",139, 0)
  17740    ; output  - returns  the receip t number i n external  form
  17741   "RTN","RCD PEMA",140, 0)
  17742    N X,RECEI PT
  17743   "RTN","RCD PEMA",141, 0)
  17744    S RECEIPT =""
  17745   "RTN","RCD PEMA",142, 0)
  17746    S X=$O(^R CY(344.4,R CERA,1,"RE CEIPT","") ,-1)  ; ge t last REC EIPT ien f rom 344.41  subfile
  17747   "RTN","RCD PEMA",143, 0)
  17748    S:X RECEI PT=$P($G(^ RCY(344,X, 0)),U)  ;  get extern al form of  receipt  
  17749   "RTN","RCD PEMA",144, 0)
  17750    Q RECEIPT
  17751   "RTN","RCD PENR2")
  17752   0^29^B2577 19505
  17753   "RTN","RCD PENR2",1,0 )
  17754   RCDPENR2 ; ALB/SAB -  EPay Natio nal Report s - ERA/EF T Trending  Report ;1 2/10/14
  17755   "RTN","RCD PENR2",2,0 )
  17756    ;;4.5;Acc ounts Rece ivable;**3 04,321**;M ar 20, 199 5;Build 46
  17757   "RTN","RCD PENR2",3,0 )
  17758    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  17759   "RTN","RCD PENR2",4,0 )
  17760    ;
  17761   "RTN","RCD PENR2",5,0 )
  17762    ;Read ^DG CR(399) vi a Private  IA 3820
  17763   "RTN","RCD PENR2",6,0 )
  17764    ;Read ^DG (40.8) via  Controlle d IA 417
  17765   "RTN","RCD PENR2",7,0 )
  17766    ;Read ^IB M(361.1) v ia Private  IA 4051
  17767   "RTN","RCD PENR2",8,0 )
  17768    ;Use DIV^ IBJDF2 via  Private I A 3130
  17769   "RTN","RCD PENR2",9,0 )
  17770    ;Use DIVI SION^VAUTO MA via Con trolled IA  664
  17771   "RTN","RCD PENR2",10, 0)
  17772    ;
  17773   "RTN","RCD PENR2",11, 0)
  17774    Q
  17775   "RTN","RCD PENR2",12, 0)
  17776    ;
  17777   "RTN","RCD PENR2",13, 0)
  17778    ;
  17779   "RTN","RCD PENR2",14, 0)
  17780   EFTERA()   ;  EFT/ERA  TRENDING  REPORT
  17781   "RTN","RCD PENR2",15, 0)
  17782    ;
  17783   "RTN","RCD PENR2",16, 0)
  17784    N DIRUT,D IROUT,DTOU T,DUOUT,X, Y,POP
  17785   "RTN","RCD PENR2",17, 0)
  17786    N RCBGDT, RCDATA,RCD ATE,RCDISP ,RCENDDT,R CPYRLST,RC SDT,RCEDT, RCRQDIV,RC RPT
  17787   "RTN","RCD PENR2",18, 0)
  17788    N RCTIN,R CDIV,RCEXC EL,RCEX,RC PAYR,RCTIN R
  17789   "RTN","RCD PENR2",19, 0)
  17790    ;
  17791   "RTN","RCD PENR2",20, 0)
  17792    ; Alert s oftware to  display t o screen
  17793   "RTN","RCD PENR2",21, 0)
  17794    S RCDISP= 1
  17795   "RTN","RCD PENR2",22, 0)
  17796    ;
  17797   "RTN","RCD PENR2",23, 0)
  17798    ; Ask for  Division
  17799   "RTN","RCD PENR2",24, 0)
  17800    S RCRQDIV =$$GETDIV( .RCDIV)
  17801   "RTN","RCD PENR2",25, 0)
  17802    Q:RCRQDIV =-1
  17803   "RTN","RCD PENR2",26, 0)
  17804    ;
  17805   "RTN","RCD PENR2",27, 0)
  17806    ; Ask the  user for  all payers  or range  of payers
  17807   "RTN","RCD PENR2",28, 0)
  17808    S RCEX=$$ GETPAY^RCD PRU(.RCPAY R) Q:'RCEX
  17809   "RTN","RCD PENR2",29, 0)
  17810    Q:'RCEX
  17811   "RTN","RCD PENR2",30, 0)
  17812    S RCPYRLS T("START") =$P($G(RCP AYR("START ")),U,4),R CPYRLST("E ND")=$P($G (RCPAYR("E ND")),U,4)
  17813   "RTN","RCD PENR2",31, 0)
  17814    ;
  17815   "RTN","RCD PENR2",32, 0)
  17816    ; Ask the  user for  all payers  or range  of payers  by Tin
  17817   "RTN","RCD PENR2",33, 0)
  17818    S RCEX=$$ GETTIN^RCD PRU(.RCTIN R)   ;Get  the list o f payers u sing their  TIN's
  17819   "RTN","RCD PENR2",34, 0)
  17820    Q:'RCEX
  17821   "RTN","RCD PENR2",35, 0)
  17822    S RCPYRLS T("TIN","S TART")=$P( $G(RCTINR( "START")), U,2),RCPYR LST("TIN", "END")=$P( $G(RCTINR( "END")),U, 2)
  17823   "RTN","RCD PENR2",36, 0)
  17824    Q:$D(RCPY RLST("QUIT "))
  17825   "RTN","RCD PENR2",37, 0)
  17826    ;
  17827   "RTN","RCD PENR2",38, 0)
  17828    ; Ask the  user for  rate type
  17829   "RTN","RCD PENR2",39, 0)
  17830    S RCRATE= $$GETRATE( )
  17831   "RTN","RCD PENR2",40, 0)
  17832    Q:RCRATE= -1
  17833   "RTN","RCD PENR2",41, 0)
  17834    ;
  17835   "RTN","RCD PENR2",42, 0)
  17836    ; Ask the  user for  report typ e, with a  prompt for  the main  report.
  17837   "RTN","RCD PENR2",43, 0)
  17838    S RCRPT=$ $GETRPT(1)
  17839   "RTN","RCD PENR2",44, 0)
  17840    Q:RCRPT=- 1
  17841   "RTN","RCD PENR2",45, 0)
  17842    ;
  17843   "RTN","RCD PENR2",46, 0)
  17844    ; Retriev e start da te
  17845   "RTN","RCD PENR2",47, 0)
  17846    S RCBGDT= $$GETSDATE ()
  17847   "RTN","RCD PENR2",48, 0)
  17848    Q:RCBGDT= -1
  17849   "RTN","RCD PENR2",49, 0)
  17850    ;
  17851   "RTN","RCD PENR2",50, 0)
  17852    ; Retriev e end date .  Send us er start d ate as the  lower bou nd.
  17853   "RTN","RCD PENR2",51, 0)
  17854    S RCENDDT =$$GETEDAT E(RCBGDT)
  17855   "RTN","RCD PENR2",52, 0)
  17856    Q:RCENDDT =-1
  17857   "RTN","RCD PENR2",53, 0)
  17858    ;
  17859   "RTN","RCD PENR2",54, 0)
  17860    ;If the u ser is run ning the m ain report , ask if t hey wish t o export t o Excel
  17861   "RTN","RCD PENR2",55, 0)
  17862    S RCEXCEL =0
  17863   "RTN","RCD PENR2",56, 0)
  17864    S:RCRPT=" M" RCEXCEL =$$DISPTY^ RCDPRU()
  17865   "RTN","RCD PENR2",57, 0)
  17866    D:RCEXCEL  INFO^RCDP RU
  17867   "RTN","RCD PENR2",58, 0)
  17868    I 'RCEXCE L,(RCRPT=" M") W !!," This repor t requires  132 colum ns.",!!
  17869   "RTN","RCD PENR2",59, 0)
  17870    D AUTO(1, RCBGDT,RCE NDDT,.RCPY RLST,RCRQD IV,RCRPT,R CEXCEL,RCR ATE,.RCDIV )
  17871   "RTN","RCD PENR2",60, 0)
  17872    Q
  17873   "RTN","RCD PENR2",61, 0)
  17874    ;
  17875   "RTN","RCD PENR2",62, 0)
  17876   AUTO(RCDIS P,RCBGDT,R CENDDT,RCP YRLST,RCRQ DIV,RCRPT, RCEXCEL,RC RATE,RCDIV ) ;
  17877   "RTN","RCD PENR2",63, 0)
  17878    ; RCDISP  - Display  results to  screen or  archive f ile flag
  17879   "RTN","RCD PENR2",64, 0)
  17880    ; RCBGDT  - begin da te of the  report
  17881   "RTN","RCD PENR2",65, 0)
  17882    ; RCENDDT  - End dat e of the r eport
  17883   "RTN","RCD PENR2",66, 0)
  17884    ; RCPYRLS T - Payers  to report  on (All,  range, or  single pay er)
  17885   "RTN","RCD PENR2",67, 0)
  17886    ; RCRQDIV  - Divisio n to repor t on - (A) ll or a si ngle divis ion
  17887   "RTN","RCD PENR2",68, 0)
  17888    ; RCRPT -  (M)ain, ( S)ummary o r (G)rand  Total Repo rt
  17889   "RTN","RCD PENR2",69, 0)
  17890    ; RCEXCEL  - Flag to  indicate  output in  "^" delimi ted format
  17891   "RTN","RCD PENR2",70, 0)
  17892    ; RCRATE  - Billing  Rate Type  flag
  17893   "RTN","RCD PENR2",71, 0)
  17894    ; RCDIV -  Divisions  to report  on.
  17895   "RTN","RCD PENR2",72, 0)
  17896    ;
  17897   "RTN","RCD PENR2",73, 0)
  17898    ;Select o utput devi ce
  17899   "RTN","RCD PENR2",74, 0)
  17900    W !
  17901   "RTN","RCD PENR2",75, 0)
  17902    I RCDISP  S %ZIS="QM " D ^%ZIS  Q:POP
  17903   "RTN","RCD PENR2",76, 0)
  17904    ;Option t o queue
  17905   "RTN","RCD PENR2",77, 0)
  17906    I 'RCDISP ,$D(IO("Q" )) D  Q
  17907   "RTN","RCD PENR2",78, 0)
  17908    .N ZTDESC ,ZTQUEUED, ZTRTN,ZTSA VE,ZTSK
  17909   "RTN","RCD PENR2",79, 0)
  17910    .S ZTRTN= "REPORT^RC DPENR2"
  17911   "RTN","RCD PENR2",80, 0)
  17912    .S ZTDESC ="EFT/ERA  Trending R eport"
  17913   "RTN","RCD PENR2",81, 0)
  17914    .S ZTSAVE ("RC*")=""
  17915   "RTN","RCD PENR2",82, 0)
  17916    .D ^%ZTLO AD
  17917   "RTN","RCD PENR2",83, 0)
  17918    .I $D(ZTS K) W !!,"T ask number  "_ZTSK_"  has been q ueued."
  17919   "RTN","RCD PENR2",84, 0)
  17920    .E  W !!, "Unable to  queue thi s job."
  17921   "RTN","RCD PENR2",85, 0)
  17922    .K ZTSK,I O("Q") D H OME^%ZIS
  17923   "RTN","RCD PENR2",86, 0)
  17924    ;
  17925   "RTN","RCD PENR2",87, 0)
  17926    ;Compile  and Print  Report
  17927   "RTN","RCD PENR2",88, 0)
  17928    D REPORT
  17929   "RTN","RCD PENR2",89, 0)
  17930    Q
  17931   "RTN","RCD PENR2",90, 0)
  17932    ;
  17933   "RTN","RCD PENR2",91, 0)
  17934   REPORT   ;  Trace the  ERA file  for the gi ven date r ange
  17935   "RTN","RCD PENR2",92, 0)
  17936    ;
  17937   "RTN","RCD PENR2",93, 0)
  17938    N RCPYRS, RCINS,RCDA TA,RCDTLDT ,RCDTLIEN, RCIEN,RCEO B,RCBILLNO ,RCBATCH,R CTYPE,RCPH ARM,RCPYRF LG,RCPYALL ,RCTINALL
  17939   "RTN","RCD PENR2",94, 0)
  17940    ;
  17941   "RTN","RCD PENR2",95, 0)
  17942    ;Note: RC PYALL an R CTINALL ar e used in  tag HEADER  to determ ine header  output.
  17943   "RTN","RCD PENR2",96, 0)
  17944    ;
  17945   "RTN","RCD PENR2",97, 0)
  17946    ; Clear t emp arrays
  17947   "RTN","RCD PENR2",98, 0)
  17948    K ^TMP("R CDPEADP",$ J),^TMP("R CDPENR2",$ J)
  17949   "RTN","RCD PENR2",99, 0)
  17950    ;
  17951   "RTN","RCD PENR2",100 ,0)
  17952    ; Compile  list of d ivisions
  17953   "RTN","RCD PENR2",101 ,0)
  17954    D DIV(.RC DIV)
  17955   "RTN","RCD PENR2",102 ,0)
  17956    ;
  17957   "RTN","RCD PENR2",103 ,0)
  17958    ; Compile  the list  of payers
  17959   "RTN","RCD PENR2",104 ,0)
  17960    ; by name
  17961   "RTN","RCD PENR2",105 ,0)
  17962    D PYRARY^ RCDPENRU(R CPYRLST("S TART"),RCP YRLST("END "),1)  ; u se insuran ce file pa yer list
  17963   "RTN","RCD PENR2",106 ,0)
  17964    ;
  17965   "RTN","RCD PENR2",107 ,0)
  17966    ; and by  TIN
  17967   "RTN","RCD PENR2",108 ,0)
  17968    D TINARY^ RCDPENR4(R CPYRLST("T IN","START "),RCPYRLS T("TIN","E ND"))  ; u se insuran ce file pa yer list
  17969   "RTN","RCD PENR2",109 ,0)
  17970    ;
  17971   "RTN","RCD PENR2",110 ,0)
  17972    ; Set pri ntout para meters
  17973   "RTN","RCD PENR2",111 ,0)
  17974    I $D(^TMP ("RCDPEADP ",$J,"INS" ,"A")) S R CPYALL=1
  17975   "RTN","RCD PENR2",112 ,0)
  17976    I $D(^TMP ("RCDPEADP ",$J,"TIN" ,"A")) S R CTINALL=1
  17977   "RTN","RCD PENR2",113 ,0)
  17978    ;
  17979   "RTN","RCD PENR2",114 ,0)
  17980    ; Now fin d only tho se payers  in both li sts
  17981   "RTN","RCD PENR2",115 ,0)
  17982    S RCPYRFL G=$$INTRSC T^RCDPENR4 ()
  17983   "RTN","RCD PENR2",116 ,0)
  17984    ;
  17985   "RTN","RCD PENR2",117 ,0)
  17986    ; If no p ayers, qui t.
  17987   "RTN","RCD PENR2",118 ,0)
  17988    Q:'RCPYRF LG 
  17989   "RTN","RCD PENR2",119 ,0)
  17990    ;
  17991   "RTN","RCD PENR2",120 ,0)
  17992    ; Gather  raw data
  17993   "RTN","RCD PENR2",121 ,0)
  17994    D GETEFT^ RCDPENR3(R CBGDT,RCEN DDT,RCRATE )
  17995   "RTN","RCD PENR2",122 ,0)
  17996    D GETERA^ RCDPENR4(R CBGDT,RCEN DDT,RCRATE )
  17997   "RTN","RCD PENR2",123 ,0)
  17998    ;
  17999   "RTN","RCD PENR2",124 ,0)
  18000    ;Check fo r data cap tures
  18001   "RTN","RCD PENR2",125 ,0)
  18002    I '$D(^TM P("RCDPENR 2",$J,"MAI N")) D  Q
  18003   "RTN","RCD PENR2",126 ,0)
  18004    .  W !!," There was  no data av ailable fo r the requ ested repo rt.  Pleas e try agai n."
  18005   "RTN","RCD PENR2",127 ,0)
  18006    ;
  18007   "RTN","RCD PENR2",128 ,0)
  18008    ;Generate  the stati stics if a ny data ca ptured
  18009   "RTN","RCD PENR2",129 ,0)
  18010    D COMPILE ^RCDPENR3
  18011   "RTN","RCD PENR2",130 ,0)
  18012    ;
  18013   "RTN","RCD PENR2",131 ,0)
  18014    ; Print o ut the res ults
  18015   "RTN","RCD PENR2",132 ,0)
  18016    D PRINT(R CRPT)
  18017   "RTN","RCD PENR2",133 ,0)
  18018    ;
  18019   "RTN","RCD PENR2",134 ,0)
  18020    ;Clean up  temp arra y afterwar ds
  18021   "RTN","RCD PENR2",135 ,0)
  18022    K ^TMP("R CDPENR2",$ J)
  18023   "RTN","RCD PENR2",136 ,0)
  18024    Q 
  18025   "RTN","RCD PENR2",137 ,0)
  18026    ;
  18027   "RTN","RCD PENR2",138 ,0)
  18028    ;Print th e results.
  18029   "RTN","RCD PENR2",139 ,0)
  18030   PRINT(RCSU MFLG) ;Pri nt the res ults
  18031   "RTN","RCD PENR2",140 ,0)
  18032    ;
  18033   "RTN","RCD PENR2",141 ,0)
  18034    ; Temp Ar ray format
  18035   "RTN","RCD PENR2",142 ,0)
  18036    ;   ^TMP( "RCDPENR1" ,$J,"TOT") =# Medical  835's ^ #  Pharmacy  835's ^
  18037   "RTN","RCD PENR2",143 ,0)
  18038    N RCSTOP, RCPAGE,RCL INE,RCRUND T,RCRPIEN, RCSUBJ,RCX MZ
  18039   "RTN","RCD PENR2",144 ,0)
  18040    ;
  18041   "RTN","RCD PENR2",145 ,0)
  18042    ;set sepa rator prin t line.
  18043   "RTN","RCD PENR2",146 ,0)
  18044    S RCLINE= "",$P(RCLI NE,"-",IOM )=""
  18045   "RTN","RCD PENR2",147 ,0)
  18046    ;
  18047   "RTN","RCD PENR2",148 ,0)
  18048    ; Init th e stop fla g, page co unt
  18049   "RTN","RCD PENR2",149 ,0)
  18050    S RCSTOP= 0,RCPAGE=0
  18051   "RTN","RCD PENR2",150 ,0)
  18052    ;
  18053   "RTN","RCD PENR2",151 ,0)
  18054    ; Set the  Run date  for the re port
  18055   "RTN","RCD PENR2",152 ,0)
  18056    S RCRUNDT =$$FMTE^XL FDT($$NOW^ XLFDT,2)
  18057   "RTN","RCD PENR2",153 ,0)
  18058    ;
  18059   "RTN","RCD PENR2",154 ,0)
  18060    ; Open th e device
  18061   "RTN","RCD PENR2",155 ,0)
  18062    I RCDISP  U IO
  18063   "RTN","RCD PENR2",156 ,0)
  18064    ;
  18065   "RTN","RCD PENR2",157 ,0)
  18066    I 'RCDISP  D  Q:'RCR PIEN
  18067   "RTN","RCD PENR2",158 ,0)
  18068    . S RCRPI EN=$$INITA RCH^RCDPEN R1("EFT/ER A TRENDING ")
  18069   "RTN","RCD PENR2",159 ,0)
  18070    ;
  18071   "RTN","RCD PENR2",160 ,0)
  18072    ; Display  Header
  18073   "RTN","RCD PENR2",161 ,0)
  18074    D HEADER
  18075   "RTN","RCD PENR2",162 ,0)
  18076    ;
  18077   "RTN","RCD PENR2",163 ,0)
  18078    ; Display  the Main  Level repo rt 
  18079   "RTN","RCD PENR2",164 ,0)
  18080    I RCSUMFL G="M" D
  18081   "RTN","RCD PENR2",165 ,0)
  18082    .  S RCST OP=$$MAIN( )
  18083   "RTN","RCD PENR2",166 ,0)
  18084    Q:RCSTOP
  18085   "RTN","RCD PENR2",167 ,0)
  18086    ;
  18087   "RTN","RCD PENR2",168 ,0)
  18088    S:RCSUMFL G="M" RCSU MFLG="S"    ; Reset s ummary fla g to preve nt Main Co lumn heade rs from ap pearing.
  18089   "RTN","RCD PENR2",169 ,0)
  18090    ;
  18091   "RTN","RCD PENR2",170 ,0)
  18092    ; Display  the Payer /TIN summa ry informa tion
  18093   "RTN","RCD PENR2",171 ,0)
  18094    I RCSUMFL G'="G" S R CSTOP=$$SU MMARY()
  18095   "RTN","RCD PENR2",172 ,0)
  18096    Q:RCSTOP
  18097   "RTN","RCD PENR2",173 ,0)
  18098    ;
  18099   "RTN","RCD PENR2",174 ,0)
  18100    ; Display  the grand  total at  the end
  18101   "RTN","RCD PENR2",175 ,0)
  18102    S RCSTOP= $$GRAND()
  18103   "RTN","RCD PENR2",176 ,0)
  18104    Q:RCSTOP
  18105   "RTN","RCD PENR2",177 ,0)
  18106    ;
  18107   "RTN","RCD PENR2",178 ,0)
  18108    ; If not  displaying  to screen , send
  18109   "RTN","RCD PENR2",179 ,0)
  18110    I 'RCDISP  D
  18111   "RTN","RCD PENR2",180 ,0)
  18112    . S RCSUB J="ERA/EFT  TRENDING  REPORT"
  18113   "RTN","RCD PENR2",181 ,0)
  18114    . S RCXMZ =$$XM^RCDP ENRU(RCRPI EN,RCBGDT, RCENDDT,RC SUBJ)
  18115   "RTN","RCD PENR2",182 ,0)
  18116    ;
  18117   "RTN","RCD PENR2",183 ,0)
  18118    ;Report f inished
  18119   "RTN","RCD PENR2",184 ,0)
  18120    I $Y>(IOS L-7),RCDIS P D ASK^RC DPEADP(.RC STOP,0) Q: RCSTOP  D  HEADER
  18121   "RTN","RCD PENR2",185 ,0)
  18122    I RCDISP  W !,$$ENDO RPRT^RCDPE ARL
  18123   "RTN","RCD PENR2",186 ,0)
  18124    W !
  18125   "RTN","RCD PENR2",187 ,0)
  18126    ;
  18127   "RTN","RCD PENR2",188 ,0)
  18128    ;Close de vice
  18129   "RTN","RCD PENR2",189 ,0)
  18130    I '$D(ZTQ UEUED) D ^ %ZISC
  18131   "RTN","RCD PENR2",190 ,0)
  18132    I $D(ZTQU EUED) S ZT REQ="@"
  18133   "RTN","RCD PENR2",191 ,0)
  18134    Q
  18135   "RTN","RCD PENR2",192 ,0)
  18136    ;
  18137   "RTN","RCD PENR2",193 ,0)
  18138   HEADER ;Pr int the re sults
  18139   "RTN","RCD PENR2",194 ,0)
  18140    ;
  18141   "RTN","RCD PENR2",195 ,0)
  18142    ; Undecla red Parame ters - RCD ISP and RC RPIEN
  18143   "RTN","RCD PENR2",196 ,0)
  18144    ;
  18145   "RTN","RCD PENR2",197 ,0)
  18146    N RCDIVTX T,RCPYRTXT ,RCTINTXT, RCSTR
  18147   "RTN","RCD PENR2",198 ,0)
  18148    ;
  18149   "RTN","RCD PENR2",199 ,0)
  18150    S RCDIVTX T=$$DIVTXT ^RCDPENR1( )
  18151   "RTN","RCD PENR2",200 ,0)
  18152    S RCPYRTX T="ALL PAY ERS" S:$G( RCPYALL)'= 1 RCPYRTXT =$$PAYERTX T^RCDPENR1 (344.6)
  18153   "RTN","RCD PENR2",201 ,0)
  18154    S RCTINTX T="ALL TIN S" S:$G(RC TINALL)'=1  RCTINTXT= $$TINTXT()
  18155   "RTN","RCD PENR2",202 ,0)
  18156    ;
  18157   "RTN","RCD PENR2",203 ,0)
  18158    S RCPAGE= RCPAGE+1
  18159   "RTN","RCD PENR2",204 ,0)
  18160    I '+RCDIS P D  Q
  18161   "RTN","RCD PENR2",205 ,0)
  18162    . S RCSTR ="EFT/ERA  TRENDING R EPORT^PAGE  "_$J(RCPA GE,5)
  18163   "RTN","RCD PENR2",206 ,0)
  18164    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  18165   "RTN","RCD PENR2",207 ,0)
  18166    . S RCSTR ="^"_RCDIV TXT_"^"_RC PYRTXT_"^" _RCTINTXT
  18167   "RTN","RCD PENR2",208 ,0)
  18168    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  18169   "RTN","RCD PENR2",209 ,0)
  18170    . S RCSTR ="^"_"DATE  RANGE: "_ $$FMTE^XLF DT(RCBGDT, 2)_" - "_$ $FMTE^XLFD T(RCENDDT, 2)_"^"_"RU N DATE: "_ RCRUNDT
  18171   "RTN","RCD PENR2",210 ,0)
  18172    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  18173   "RTN","RCD PENR2",211 ,0)
  18174    . D SAVED ATA^RCDPEN R1(RCLINE, RCRPIEN)
  18175   "RTN","RCD PENR2",212 ,0)
  18176    W @IOF,"E FT/ERA TRE NDING REPO RT"
  18177   "RTN","RCD PENR2",213 ,0)
  18178    I '+$G(RC EXCEL) D   Q
  18179   "RTN","RCD PENR2",214 ,0)
  18180    . W ?70," PAGE ",$J( RCPAGE,5), !
  18181   "RTN","RCD PENR2",215 ,0)
  18182    . W ?5,$E (RCDIVTXT, 1,23),?30, $E(RCPYRTX T,1,28),?6 0,$E(RCTIN TXT,1,20), !
  18183   "RTN","RCD PENR2",216 ,0)
  18184    . W ?5,"D ATE RANGE:  ",$$FMTE^ XLFDT(RCBG DT,2)," -  ",$$FMTE^X LFDT(RCEND DT,2)
  18185   "RTN","RCD PENR2",217 ,0)
  18186    . W ?51," RUN DATE:  ",RCRUNDT, !
  18187   "RTN","RCD PENR2",218 ,0)
  18188    . W RCLIN E,!
  18189   "RTN","RCD PENR2",219 ,0)
  18190    I +$G(RCE XCEL) D
  18191   "RTN","RCD PENR2",220 ,0)
  18192    . W "^PAG E ",$J(RCP AGE,5),!
  18193   "RTN","RCD PENR2",221 ,0)
  18194    . W "^",R CDIVTXT,"^ ",RCPYRTXT ,"^",RCTIN TXT,!
  18195   "RTN","RCD PENR2",222 ,0)
  18196    . W "^"," DATE RANGE : ",$$FMTE ^XLFDT(RCB GDT,2)," -  ",$$FMTE^ XLFDT(RCEN DDT,2)
  18197   "RTN","RCD PENR2",223 ,0)
  18198    . W "^"," RUN DATE:  ",RCRUNDT, !
  18199   "RTN","RCD PENR2",224 ,0)
  18200    . W RCLIN E,!
  18201   "RTN","RCD PENR2",225 ,0)
  18202    ;
  18203   "RTN","RCD PENR2",226 ,0)
  18204    ;Re-displ ay the col umn header s
  18205   "RTN","RCD PENR2",227 ,0)
  18206    I (RCSUMF LG="M"),(R CPAGE'=1)  D COLHEAD
  18207   "RTN","RCD PENR2",228 ,0)
  18208    Q
  18209   "RTN","RCD PENR2",229 ,0)
  18210    ;
  18211   "RTN","RCD PENR2",230 ,0)
  18212    ;Print th e Detailed  portion o f the repo rt
  18213   "RTN","RCD PENR2",231 ,0)
  18214   MAIN() ;
  18215   "RTN","RCD PENR2",232 ,0)
  18216    ;
  18217   "RTN","RCD PENR2",233 ,0)
  18218    N RCERATY P,RCDATA,R CERATXT,RC STRING,RCE FTTXT,RCEF T,RCERA,RC INSTIN,RCC LAIM,RCBIL L
  18219   "RTN","RCD PENR2",234 ,0)
  18220    N RCAMTBL ,RCPAID,RC BILLDT,RCE RADT,RCEFT DT,RCPOSTD T,RCTRACE, RCATPST,RC IDX,RCAMTP D
  18221   "RTN","RCD PENR2",235 ,0)
  18222    N RCETRAN ,RCERA,RCE OB,RCEFTNO ,RCBEDY,RC EEDY,RCEPD Y,RCBPDY,R CTOTDY,RCT MP,RCSTOP, RCIDX
  18223   "RTN","RCD PENR2",236 ,0)
  18224    ;
  18225   "RTN","RCD PENR2",237 ,0)
  18226    ; Print E RA/EFT com binations  for each I nsurance C ompany/Tin  combinati on
  18227   "RTN","RCD PENR2",238 ,0)
  18228    S RCINSTI N="",RCSTO P=0
  18229   "RTN","RCD PENR2",239 ,0)
  18230    F  S RCIN STIN=$O(^T MP("RCDPEN R2",$J,"MA IN",RCINST IN)) Q:RCI NSTIN=""   D  Q:RCSTO P
  18231   "RTN","RCD PENR2",240 ,0)
  18232    . S RCSTO P=$$PRINTI NS(RCINSTI N)
  18233   "RTN","RCD PENR2",241 ,0)
  18234    . Q:RCSTO P
  18235   "RTN","RCD PENR2",242 ,0)
  18236    . F I=1:1 :3 D  Q:RC STOP
  18237   "RTN","RCD PENR2",243 ,0)
  18238    . . S RCE RATYP=$S(I =1:"EFT/ER A",I=2:"PA PER CHECK/ ERA",1:"EF T/PAPER EO B")
  18239   "RTN","RCD PENR2",244 ,0)
  18240    . . S RCE FTTXT=$P(R CERATYP,"/ ")
  18241   "RTN","RCD PENR2",245 ,0)
  18242    . . S RCE RATXT=$P(R CERATYP,"/ ",2)
  18243   "RTN","RCD PENR2",246 ,0)
  18244    . . S RCE FT=$S(RCEF TTXT="EFT" :"AN EFT", 1:"A PAPER  CHECK")
  18245   "RTN","RCD PENR2",247 ,0)
  18246    . . S RCS TRING=RCER ATXT_" MAT CHED TO "_ RCEFT
  18247   "RTN","RCD PENR2",248 ,0)
  18248    . . S RCS TOP=$$PRIN THDR(RCSTR ING)
  18249   "RTN","RCD PENR2",249 ,0)
  18250    . . Q:RCS TOP
  18251   "RTN","RCD PENR2",250 ,0)
  18252    . . S RCC LAIM=""
  18253   "RTN","RCD PENR2",251 ,0)
  18254    . . F  S  RCCLAIM=$O (^TMP("RCD PENR2",$J, "MAIN",RCI NSTIN,I,RC CLAIM)) Q: RCCLAIM=""   D  Q:RCS TOP
  18255   "RTN","RCD PENR2",252 ,0)
  18256    . . . I $ Y>(IOSL-7)  D ASK^RCD PEADP(.RCS TOP,0) Q:R CSTOP  D H EADER
  18257   "RTN","RCD PENR2",253 ,0)
  18258    . . . S R CDATA=$G(^ TMP("RCDPE NR2",$J,"M AIN",RCINS TIN,I,RCCL AIM))
  18259   "RTN","RCD PENR2",254 ,0)
  18260    . . . I R CDATA="" D   Q
  18261   "RTN","RCD PENR2",255 ,0)
  18262    . . . . W  !,"No dat a captured  for this  section du ring the s pecified t ime period .",!
  18263   "RTN","RCD PENR2",256 ,0)
  18264    . . . ;
  18265   "RTN","RCD PENR2",257 ,0)
  18266    . . . ;In it display  values fo r the days
  18267   "RTN","RCD PENR2",258 ,0)
  18268    . . . S ( RCBEDY,RCE EDY,RCEPDY ,RCBPDY)=" "
  18269   "RTN","RCD PENR2",259 ,0)
  18270    . . . S R CBILL=$$GE T1^DIQ(399 ,+RCCLAIM_ ",",".01", "E")
  18271   "RTN","RCD PENR2",260 ,0)
  18272    . . . I $ P(RCDATA,U ,9),$P(RCD ATA,U,8) S  RCBEDY=$$ FMTH^XLFDT ($P(RCDATA ,U,9),1)-$ $FMTH^XLFD T($P(RCDAT A,U,8),1)
  18273   "RTN","RCD PENR2",261 ,0)
  18274    . . . I $ P(RCDATA,U ,10),$P(RC DATA,U,9)  S RCEEDY=$ $FMTH^XLFD T($P(RCDAT A,U,10),1) -$$FMTH^XL FDT($P(RCD ATA,U,9),1 )
  18275   "RTN","RCD PENR2",262 ,0)
  18276    . . . S R CIDX=$S($$ FMTH^XLFDT ($P(RCDATA ,U,10),1)> $$FMTH^XLF DT($P(RCDA TA,U,10),1 ):10,1:9)   ; Find th e latest d ate betwee n ERA and  EFT
  18277   "RTN","RCD PENR2",263 ,0)
  18278    . . . I $ P(RCDATA,U ,11),$P(RC DATA,U,RCI DX) S RCEP DY=$$FMTH^ XLFDT($P(R CDATA,U,11 ),1)-$$FMT H^XLFDT($P (RCDATA,U, RCIDX),1)   ; Use lat est date t o determ d ays btw ER A/EFT and  Posting
  18279   "RTN","RCD PENR2",264 ,0)
  18280    . . . I $ P(RCDATA,U ,11),$P(RC DATA,U,8)  S RCBPDY=$ $FMTH^XLFD T($P(RCDAT A,U,11),1) -$$FMTH^XL FDT($P(RCD ATA,U,8),1 )
  18281   "RTN","RCD PENR2",265 ,0)
  18282    . . . I R CEXCEL D
  18283   "RTN","RCD PENR2",266 ,0)
  18284    . . . . S  RCTMP=RCB ILL_"^"_$$ FMTE^XLFDT ($P(RCDATA ,U,5),2)_" ^"_$P(RCDA TA,U,6)_"^ "_$P(RCDAT A,U,7)_"^" _$$FMTE^XL FDT($P(RCD ATA,U,8),2 )
  18285   "RTN","RCD PENR2",267 ,0)
  18286    . . . . S  RCTMP=RCT MP_"^"_$$F MTE^XLFDT( $P(RCDATA, U,9),2)_"^ "_$$FMTE^X LFDT($P(RC DATA,U,10) ,2)_"^"_$$ FMTE^XLFDT ($P(RCDATA ,U,11),2)_ "^"_$P(RCD ATA,U,12)_ "^"_$P(RCD ATA,U,13)
  18287   "RTN","RCD PENR2",268 ,0)
  18288    . . . . S  RCTMP=RCT MP_"^"_$P( RCDATA,U,1 4)_"^"_$P( RCDATA,U,2 )_"^"_$P(R CDATA,U,15 )_"^"_$P(R CDATA,U,3) _"^"
  18289   "RTN","RCD PENR2",269 ,0)
  18290    . . . . S  RCTMP=RCT MP_RCBEDY_ "^"_RCEEDY _"^"_RCEPD Y_"^"_RCBP DY
  18291   "RTN","RCD PENR2",270 ,0)
  18292    . . . . W  RCTMP,!
  18293   "RTN","RCD PENR2",271 ,0)
  18294    . . . I ' RCEXCEL D
  18295   "RTN","RCD PENR2",272 ,0)
  18296    . . . . W  RCBILL,?2 1,$$FMTE^X LFDT($P(RC DATA,U,5), 2),?30,$J( $P(RCDATA, U,6),10,2) ,?41,$J($P (RCDATA,U, 7),10,2),? 52,$$FMTE^ XLFDT($P(R CDATA,U,8) ,2)
  18297   "RTN","RCD PENR2",273 ,0)
  18298    . . . . W  ?61,$$FMT E^XLFDT($P (RCDATA,U, 9),2),?75, $$FMTE^XLF DT($P(RCDA TA,U,10),2 ),?89,$$FM TE^XLFDT($ P(RCDATA,U ,11),2),?9 8,$P(RCDAT A,U,12),?1 09,$P(RCDA TA,U,13),!
  18299   "RTN","RCD PENR2",274 ,0)
  18300    . . . . W  ?5,$P(RCD ATA,U,14), ?17,$P(RCD ATA,U,2),? 28,$J($P(R CDATA,U,15 ),6),?39,$ P(RCDATA,U ,3),?50,$J (RCBEDY,8)
  18301   "RTN","RCD PENR2",275 ,0)
  18302    . . . . W  ?67,$J(RC EEDY,8),?8 3,$J(RCEPD Y,8),?106, $J(RCBPDY, 8),!
  18303   "RTN","RCD PENR2",276 ,0)
  18304    . . W RCL INE,!
  18305   "RTN","RCD PENR2",277 ,0)
  18306    I RCSTOP  Q RCSTOP
  18307   "RTN","RCD PENR2",278 ,0)
  18308    ; Section  break - a sk user if  they wish  to contin ue...
  18309   "RTN","RCD PENR2",279 ,0)
  18310    I +$G(RCE XCEL)=0 D
  18311   "RTN","RCD PENR2",280 ,0)
  18312    . D ASK^R CDPEADP(.R CSTOP,0)
  18313   "RTN","RCD PENR2",281 ,0)
  18314    . Q:RCSTO P
  18315   "RTN","RCD PENR2",282 ,0)
  18316    . D HEADE R
  18317   "RTN","RCD PENR2",283 ,0)
  18318    ;
  18319   "RTN","RCD PENR2",284 ,0)
  18320    Q RCSTOP
  18321   "RTN","RCD PENR2",285 ,0)
  18322    ;
  18323   "RTN","RCD PENR2",286 ,0)
  18324   SUMMARY()  ;Print the  Payer Sum mary porti on of the  report
  18325   "RTN","RCD PENR2",287 ,0)
  18326    ;
  18327   "RTN","RCD PENR2",288 ,0)
  18328    N RCERATY P,RCDATA,R CERATXT,RC STRING,RCE FTTXT,RCEF T,RCERA,RC STOP,RCERA FLG,I
  18329   "RTN","RCD PENR2",289 ,0)
  18330    ;
  18331   "RTN","RCD PENR2",290 ,0)
  18332    ; Print E RA/EFT com binations  for each I nsurance C ompany/Tin  combinati on
  18333   "RTN","RCD PENR2",291 ,0)
  18334    S RCINSTI N="",RCSTO P=0
  18335   "RTN","RCD PENR2",292 ,0)
  18336    F  S RCIN STIN=$O(^T MP("RCDPEN R2",$J,"PA YER",RCINS TIN)) Q:RC INSTIN=""   D  Q:RCST OP
  18337   "RTN","RCD PENR2",293 ,0)
  18338    . I $Y>(I OSL-7) D A SK^RCDPEAD P(.RCSTOP, 0) Q:RCSTO P  D HEADE R
  18339   "RTN","RCD PENR2",294 ,0)
  18340    . D PRINT INS(RCINST IN)
  18341   "RTN","RCD PENR2",295 ,0)
  18342    . ; Print  all 3 com binations
  18343   "RTN","RCD PENR2",296 ,0)
  18344    . F I=1:1 :3 D  Q:RC STOP
  18345   "RTN","RCD PENR2",297 ,0)
  18346    . . S RCD ATA=$G(^TM P("RCDPENR 2",$J,"PAY ER",RCINST IN,I))
  18347   "RTN","RCD PENR2",298 ,0)
  18348    . . S RCE RATYP=$S(I =1:"EFT/ER A",I=2:"PA PER CHECK/ ERA",1:"EF T/PAPER EO B")
  18349   "RTN","RCD PENR2",299 ,0)
  18350    . . S RCE RAFLG=0
  18351   "RTN","RCD PENR2",300 ,0)
  18352    . . S RCE FTTXT=$P(R CERATYP,"/ ")
  18353   "RTN","RCD PENR2",301 ,0)
  18354    . . S RCE RATXT=$P(R CERATYP,"/ ",2)
  18355   "RTN","RCD PENR2",302 ,0)
  18356    . . S RCE FT=$S(RCEF TTXT="EFT" :"AN EFT", 1:"A PAPER  CHECK")
  18357   "RTN","RCD PENR2",303 ,0)
  18358    . . S RCS TRING=RCER ATXT_" MAT CHED TO "_ RCEFT
  18359   "RTN","RCD PENR2",304 ,0)
  18360    . . I (RC EFTTXT="EF T"),(RCERA TXT["ERA")  S RCERAFL G=1
  18361   "RTN","RCD PENR2",305 ,0)
  18362    . . D PRI NTGT^RCDPE NR3(RCSTRI NG,RCDATA, RCDISP,RCE RAFLG,RCEX CEL)
  18363   "RTN","RCD PENR2",306 ,0)
  18364    ;
  18365   "RTN","RCD PENR2",307 ,0)
  18366    Q RCSTOP
  18367   "RTN","RCD PENR2",308 ,0)
  18368    ;
  18369   "RTN","RCD PENR2",309 ,0)
  18370    ;Total fo r all paye rs in repo rt
  18371   "RTN","RCD PENR2",310 ,0)
  18372   GRAND() ;
  18373   "RTN","RCD PENR2",311 ,0)
  18374    ;
  18375   "RTN","RCD PENR2",312 ,0)
  18376    N RCERATY P,RCDATA,R CERATXT,RC STRING,RCE FTTXT,RCEF T,RCERA,RC STOP,RCERA FLG,I
  18377   "RTN","RCD PENR2",313 ,0)
  18378    ;
  18379   "RTN","RCD PENR2",314 ,0)
  18380    S RCSTOP= 0
  18381   "RTN","RCD PENR2",315 ,0)
  18382    ; Print t he Grand T otal Banne r
  18383   "RTN","RCD PENR2",316 ,0)
  18384    I $Y>(IOS L-7),RCDIS P D ASK^RC DPEADP(.RC STOP,0) Q: RCSTOP  D  HEADER
  18385   "RTN","RCD PENR2",317 ,0)
  18386    I RCSUMFL G'="G",RCD ISP D
  18387   "RTN","RCD PENR2",318 ,0)
  18388    . W !,"GR AND TOTALS  ALL PAYER S",!!
  18389   "RTN","RCD PENR2",319 ,0)
  18390    . W RCLIN E,!
  18391   "RTN","RCD PENR2",320 ,0)
  18392    ;
  18393   "RTN","RCD PENR2",321 ,0)
  18394    ; Print a ll 3 EOB/P ayment com binations
  18395   "RTN","RCD PENR2",322 ,0)
  18396    F I=1:1:3  D  Q:RCST OP
  18397   "RTN","RCD PENR2",323 ,0)
  18398    . S RCDAT A=$G(^TMP( "RCDPENR2" ,$J,"GTOT" ,I))
  18399   "RTN","RCD PENR2",324 ,0)
  18400    . S RCERA TYP=$S(I=1 :"EFT/ERA" ,I=2:"PAPE R CHECK/ER A",1:"EFT/ PAPER EOB" )
  18401   "RTN","RCD PENR2",325 ,0)
  18402    . S RCERA FLG=0
  18403   "RTN","RCD PENR2",326 ,0)
  18404    . S RCEFT TXT=$P(RCE RATYP,"/")
  18405   "RTN","RCD PENR2",327 ,0)
  18406    . S RCERA TXT=$P(RCE RATYP,"/", 2)
  18407   "RTN","RCD PENR2",328 ,0)
  18408    . S RCEFT =$S(RCEFTT XT="EFT":" AN EFT",1: "A PAPER C HECK")
  18409   "RTN","RCD PENR2",329 ,0)
  18410    . S RCSTR ING=RCERAT XT_" MATCH ED TO "_RC EFT
  18411   "RTN","RCD PENR2",330 ,0)
  18412    . I (RCEF TTXT="EFT" ),(RCERATX T["ERA") S  RCERAFLG= 1
  18413   "RTN","RCD PENR2",331 ,0)
  18414    . D PRINT GT^RCDPENR 3(RCSTRING ,RCDATA,RC DISP,RCERA FLG,RCEXCE L)
  18415   "RTN","RCD PENR2",332 ,0)
  18416    ;
  18417   "RTN","RCD PENR2",333 ,0)
  18418    Q RCSTOP
  18419   "RTN","RCD PENR2",334 ,0)
  18420    ;
  18421   "RTN","RCD PENR2",335 ,0)
  18422   PRINTINS(R CINS) ; Pr int the in surance he ader line
  18423   "RTN","RCD PENR2",336 ,0)
  18424    ; Input:    RCINS    - Payer Na me/TIN to  be display ed
  18425   "RTN","RCD PENR2",337 ,0)
  18426    ;           RCLINE   - line of  dashes use d for sepa ration
  18427   "RTN","RCD PENR2",338 ,0)
  18428    ; Returns  1 - User  quit out o f report,  0 otherwis e
  18429   "RTN","RCD PENR2",339 ,0)
  18430    N RCSTOP, XX,YY,ZZ
  18431   "RTN","RCD PENR2",340 ,0)
  18432    ;
  18433   "RTN","RCD PENR2",341 ,0)
  18434    S RCSTOP= 0
  18435   "RTN","RCD PENR2",342 ,0)
  18436    I $Y>(IOS L-7) D
  18437   "RTN","RCD PENR2",343 ,0)
  18438    . D ASK^R CDPEADP(.R CSTOP,0)
  18439   "RTN","RCD PENR2",344 ,0)
  18440    . Q:RCSTO P
  18441   "RTN","RCD PENR2",345 ,0)
  18442    . D HEADE R
  18443   "RTN","RCD PENR2",346 ,0)
  18444    I RCSTOP  Q RCSTOP
  18445   "RTN","RCD PENR2",347 ,0)
  18446    W "PAYER  NAME/TIN", !                         ; PRCA *4.5*321
  18447   "RTN","RCD PENR2",348 ,0)
  18448    W " ",$$P AYTIN^RCDP RU2(RCINS, 78),!          ; PRCA *4.5*321
  18449   "RTN","RCD PENR2",349 ,0)
  18450    W RCLINE, !
  18451   "RTN","RCD PENR2",350 ,0)
  18452    Q RCSTOP
  18453   "RTN","RCD PENR2",351 ,0)
  18454    ;
  18455   "RTN","RCD PENR2",352 ,0)
  18456    ;Print th e Payment  Method hea der lines
  18457   "RTN","RCD PENR2",353 ,0)
  18458   PRINTHDR(R CTITLE) ;
  18459   "RTN","RCD PENR2",354 ,0)
  18460    ; Undecla red parame ters
  18461   "RTN","RCD PENR2",355 ,0)
  18462    ;   RCLIN E - line o f "-" for  report for mating
  18463   "RTN","RCD PENR2",356 ,0)
  18464    ;   RCSUM FLG - Type  of report  (M=Main,S =Summary,G =Grand Tot al)
  18465   "RTN","RCD PENR2",357 ,0)
  18466    ;   RCDIS P - Is the  report be ing email  (0) or Pri nted (1)
  18467   "RTN","RCD PENR2",358 ,0)
  18468    ;   RCRPI EN - IEN t o store th e report i f emailing
  18469   "RTN","RCD PENR2",359 ,0)
  18470    ;
  18471   "RTN","RCD PENR2",360 ,0)
  18472    N RCBORDE R,RCSTOP,R CSTR
  18473   "RTN","RCD PENR2",361 ,0)
  18474    ;
  18475   "RTN","RCD PENR2",362 ,0)
  18476    S RCBORDE R="",$P(RC BORDER,"*" ,20)="",RC STOP=0
  18477   "RTN","RCD PENR2",363 ,0)
  18478    I $Y>(IOS L-7),RCDIS P D
  18479   "RTN","RCD PENR2",364 ,0)
  18480    . D ASK^R CDPEADP(.R CSTOP,0)
  18481   "RTN","RCD PENR2",365 ,0)
  18482    . Q:RCSTO P
  18483   "RTN","RCD PENR2",366 ,0)
  18484    . D HEADE R
  18485   "RTN","RCD PENR2",367 ,0)
  18486    I RCSTOP  Q RCSTOP
  18487   "RTN","RCD PENR2",368 ,0)
  18488    ;
  18489   "RTN","RCD PENR2",369 ,0)
  18490    ; Display  report ty pe being d isplayed
  18491   "RTN","RCD PENR2",370 ,0)
  18492    I 'RCDISP  D  Q
  18493   "RTN","RCD PENR2",371 ,0)
  18494    . S RCSTR =RCBORDER_ "     "_RC TITLE_"      "_RCBORD ER
  18495   "RTN","RCD PENR2",372 ,0)
  18496    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  18497   "RTN","RCD PENR2",373 ,0)
  18498    . D SAVED ATA^RCDPEN R1(RCLINE, RCRPIEN)
  18499   "RTN","RCD PENR2",374 ,0)
  18500    I RCDISP  D
  18501   "RTN","RCD PENR2",375 ,0)
  18502    . W RCBOR DER,"      ",RCTITLE, "     ",RC BORDER,!
  18503   "RTN","RCD PENR2",376 ,0)
  18504    . W RCLIN E,!
  18505   "RTN","RCD PENR2",377 ,0)
  18506    ;
  18507   "RTN","RCD PENR2",378 ,0)
  18508    D:RCSUMFL G="M" COLH EAD    ;di splay colu mn headers
  18509   "RTN","RCD PENR2",379 ,0)
  18510    ;
  18511   "RTN","RCD PENR2",380 ,0)
  18512    Q RCSTOP
  18513   "RTN","RCD PENR2",381 ,0)
  18514    ;
  18515   "RTN","RCD PENR2",382 ,0)
  18516    ; Retriev e the Divi sion
  18517   "RTN","RCD PENR2",383 ,0)
  18518   GETDIV(RCD IV) ;
  18519   "RTN","RCD PENR2",384 ,0)
  18520    ;
  18521   "RTN","RCD PENR2",385 ,0)
  18522    ; The use  of DIVISI ON^VAUTOMA  Supported  by IA 107 7
  18523   "RTN","RCD PENR2",386 ,0)
  18524    ;
  18525   "RTN","RCD PENR2",387 ,0)
  18526    N VAUTD
  18527   "RTN","RCD PENR2",388 ,0)
  18528    D DIVISIO N^VAUTOMA
  18529   "RTN","RCD PENR2",389 ,0)
  18530    I VAUTD=1  S RCDIV(" A")="" Q 1
  18531   "RTN","RCD PENR2",390 ,0)
  18532    I 'VAUTD& ($D(VAUTD) '=11) Q -1
  18533   "RTN","RCD PENR2",391 ,0)
  18534    M RCDIV=V AUTD
  18535   "RTN","RCD PENR2",392 ,0)
  18536    Q 1
  18537   "RTN","RCD PENR2",393 ,0)
  18538    ;
  18539   "RTN","RCD PENR2",394 ,0)
  18540    ;Retrieve  the Repor t Type
  18541   "RTN","RCD PENR2",395 ,0)
  18542   GETRATE()  ;
  18543   "RTN","RCD PENR2",396 ,0)
  18544    ;
  18545   "RTN","RCD PENR2",397 ,0)
  18546    ;RCMNFLG  - Ask to p rint the M ain report  (Detailed ) report.   0=No, 1=Y es
  18547   "RTN","RCD PENR2",398 ,0)
  18548    N X,Y,DIC ,DTOUT,DUO UT
  18549   "RTN","RCD PENR2",399 ,0)
  18550    ;
  18551   "RTN","RCD PENR2",400 ,0)
  18552    S DIC="^D GCR(399.3, ",DIC(0)=" AEQMN"
  18553   "RTN","RCD PENR2",401 ,0)
  18554    S DIC("S" )="I $P(^( 0),U,7)="" i"""
  18555   "RTN","RCD PENR2",402 ,0)
  18556    D ^DIC K  DIC
  18557   "RTN","RCD PENR2",403 ,0)
  18558    Q +Y
  18559   "RTN","RCD PENR2",404 ,0)
  18560    ;
  18561   "RTN","RCD PENR2",405 ,0)
  18562    ;Retrieve  the Repor t Type
  18563   "RTN","RCD PENR2",406 ,0)
  18564   GETRPT(RCM NFLG) ;
  18565   "RTN","RCD PENR2",407 ,0)
  18566    ;
  18567   "RTN","RCD PENR2",408 ,0)
  18568    ;RCMNFLG  - Ask to p rint the M ain report  (Detailed ) report.   0=No, 1=Y es
  18569   "RTN","RCD PENR2",409 ,0)
  18570    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT
  18571   "RTN","RCD PENR2",410 ,0)
  18572    ;
  18573   "RTN","RCD PENR2",411 ,0)
  18574    ; Prompt  with Main  (EFT/ERA T rending re port (from  RCDPENR2) )
  18575   "RTN","RCD PENR2",412 ,0)
  18576    I $G(RCMN FLG) D
  18577   "RTN","RCD PENR2",413 ,0)
  18578    . S DIR(" A")="Print  (M)AIN Re port, (S)U MMARY by P ayer or (G )RAND TOTA LS ONLY: "
  18579   "RTN","RCD PENR2",414 ,0)
  18580    . S DIR(0 )="SA^M:MA IN;S:SUMMA RY;G:GRAND  TOTAL"
  18581   "RTN","RCD PENR2",415 ,0)
  18582    ;
  18583   "RTN","RCD PENR2",416 ,0)
  18584    ; Prompt  w/o main ( Volume Sta tistics re port (from  RCDPENR1) )
  18585   "RTN","RCD PENR2",417 ,0)
  18586    I '$G(RCM NFLG) D
  18587   "RTN","RCD PENR2",418 ,0)
  18588    . S DIR(" A")="(S)UM MARY by Pa yer or (G) RAND TOTAL S ONLY: "
  18589   "RTN","RCD PENR2",419 ,0)
  18590    . S DIR(0 )="SA^S:SU MMARY;G:GR AND TOTAL"
  18591   "RTN","RCD PENR2",420 ,0)
  18592    ;
  18593   "RTN","RCD PENR2",421 ,0)
  18594    S DIR("?" )="Select  the type o f report t o Generate ."
  18595   "RTN","RCD PENR2",422 ,0)
  18596    S DIR("B" )="G"
  18597   "RTN","RCD PENR2",423 ,0)
  18598    D ^DIR K  DIR
  18599   "RTN","RCD PENR2",424 ,0)
  18600    I $D(DTOU T)!$D(DUOU T)!(Y="")   Q -1
  18601   "RTN","RCD PENR2",425 ,0)
  18602    Q Y
  18603   "RTN","RCD PENR2",426 ,0)
  18604    ;
  18605   "RTN","RCD PENR2",427 ,0)
  18606    ;
  18607   "RTN","RCD PENR2",428 ,0)
  18608   GETSDATE()   ;
  18609   "RTN","RCD PENR2",429 ,0)
  18610    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT,RCTO DAY
  18611   "RTN","RCD PENR2",430 ,0)
  18612    ;
  18613   "RTN","RCD PENR2",431 ,0)
  18614    ;Assume t he start d ate is 45  days prior  to the en d date
  18615   "RTN","RCD PENR2",432 ,0)
  18616    ;
  18617   "RTN","RCD PENR2",433 ,0)
  18618    ;Get the  start date .  
  18619   "RTN","RCD PENR2",434 ,0)
  18620    S RCTODAY =$P($$NOW^ XLFDT,".")
  18621   "RTN","RCD PENR2",435 ,0)
  18622    S DIR("?" )="ENTER T HE EARLIES T DATE TO  INCLUDE ON  THE REPOR T"
  18623   "RTN","RCD PENR2",436 ,0)
  18624    S DIR(0)= "DA^:"_RCT ODAY_":APE ",DIR("A") ="Start wi th DATE: "
  18625   "RTN","RCD PENR2",437 ,0)
  18626    D ^DIR K  DIR
  18627   "RTN","RCD PENR2",438 ,0)
  18628    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q -1
  18629   "RTN","RCD PENR2",439 ,0)
  18630    Q Y
  18631   "RTN","RCD PENR2",440 ,0)
  18632    ;
  18633   "RTN","RCD PENR2",441 ,0)
  18634    ; Retriev e the end  date of th e report f rom the us er.
  18635   "RTN","RCD PENR2",442 ,0)
  18636   GETEDATE(R CBDATE)  ;
  18637   "RTN","RCD PENR2",443 ,0)
  18638    ; RCBDATE  - Begin d ate of the  report.   Used as a  lower boun d
  18639   "RTN","RCD PENR2",444 ,0)
  18640    ;
  18641   "RTN","RCD PENR2",445 ,0)
  18642    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT,RCTO DAY
  18643   "RTN","RCD PENR2",446 ,0)
  18644    ;
  18645   "RTN","RCD PENR2",447 ,0)
  18646    ; Get the  End date  first.  As sume the e nd date is  today.
  18647   "RTN","RCD PENR2",448 ,0)
  18648    S RCTODAY =$P($$NOW^ XLFDT,".")
  18649   "RTN","RCD PENR2",449 ,0)
  18650    S DIR("?" )="ENTER T HE LATEST  DATE TO IN CLUDE ON T HE REPORT"
  18651   "RTN","RCD PENR2",450 ,0)
  18652    S DIR("B" )=$$FMTE^X LFDT(RCTOD AY,2)
  18653   "RTN","RCD PENR2",451 ,0)
  18654    S DIR(0)= "DAO^"_$G( RCBDATE)_" :"_RCTODAY _":APE",DI R("A")="Go  to DATE:  " D ^DIR K  DIR
  18655   "RTN","RCD PENR2",452 ,0)
  18656    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q -1
  18657   "RTN","RCD PENR2",453 ,0)
  18658    Q Y
  18659   "RTN","RCD PENR2",454 ,0)
  18660    ; 
  18661   "RTN","RCD PENR2",455 ,0)
  18662   GETARPYR(R CTIN,RCPAY ) ; Retrie ve the Pay er IEN fro m the RCDP E AUTO-PAY  EXCLUSION  file (#34 4.6)
  18663   "RTN","RCD PENR2",456 ,0)
  18664    ; Input:  RCTIN - Pa yer ID
  18665   "RTN","RCD PENR2",457 ,0)
  18666    ;         RCPAY - Pa yer Name ( optional)
  18667   "RTN","RCD PENR2",458 ,0)
  18668    ; Return:  Payer IEN  (#344.6)
  18669   "RTN","RCD PENR2",459 ,0)
  18670    ;
  18671   "RTN","RCD PENR2",460 ,0)
  18672    N RCIEN,Q UIT,ZZ
  18673   "RTN","RCD PENR2",461 ,0)
  18674    S RCPAY=$ G(RCPAY)
  18675   "RTN","RCD PENR2",462 ,0)
  18676    ;
  18677   "RTN","RCD PENR2",463 ,0)
  18678    ; Send th e IEN entr y in the f ile if the  Payer is  in it.  Ot herwise, s end 0.
  18679   "RTN","RCD PENR2",464 ,0)
  18680    S RCIEN=0
  18681   "RTN","RCD PENR2",465 ,0)
  18682    ;
  18683   "RTN","RCD PENR2",466 ,0)
  18684    ; PRCA*4. 5*321 - Ad d optional  payer nam e to searc h to narro w down pay er
  18685   "RTN","RCD PENR2",467 ,0)
  18686    I RCPAY'= "" D  ;
  18687   "RTN","RCD PENR2",468 ,0)
  18688    . S ZZ="" ,QUIT=0
  18689   "RTN","RCD PENR2",469 ,0)
  18690    . F  S ZZ =$O(^RCY(3 44.6,"C",R CTIN_" ",Z Z)) Q:ZZ=" "  D  I RC IEN Q  ;
  18691   "RTN","RCD PENR2",470 ,0)
  18692    . . I $$G ET1^DIQ(34 4.6,ZZ_"," ,.01,"E")= RCPAY S RC IEN=ZZ
  18693   "RTN","RCD PENR2",471 ,0)
  18694    ;
  18695   "RTN","RCD PENR2",472 ,0)
  18696    I 'RCIEN  D  ;
  18697   "RTN","RCD PENR2",473 ,0)
  18698    . S RCIEN =$O(^RCY(3 44.6,"C",R CTIN_" "," "))
  18699   "RTN","RCD PENR2",474 ,0)
  18700    ;
  18701   "RTN","RCD PENR2",475 ,0)
  18702    Q +RCIEN
  18703   "RTN","RCD PENR2",476 ,0)
  18704    ;
  18705   "RTN","RCD PENR2",477 ,0)
  18706    ; Determi ne if the  payer in t he ERA or  EFT should  be includ ed in the  report.
  18707   "RTN","RCD PENR2",478 ,0)
  18708   INSCHK(RCI NS) ;
  18709   "RTN","RCD PENR2",479 ,0)
  18710    ;
  18711   "RTN","RCD PENR2",480 ,0)
  18712    ;Send yes  if all pa yers are b eing repor ted on.
  18713   "RTN","RCD PENR2",481 ,0)
  18714    Q:$D(^TMP ("RCDPENR2 ",$J,"INS" ,"A")) 1
  18715   "RTN","RCD PENR2",482 ,0)
  18716    ;
  18717   "RTN","RCD PENR2",483 ,0)
  18718    ; Send ye s if Payer  is in the  list to r eport on
  18719   "RTN","RCD PENR2",484 ,0)
  18720    Q:$D(^TMP ("RCDPENR2 ",$J,"INS" ,RCINS)) 1
  18721   "RTN","RCD PENR2",485 ,0)
  18722    ;
  18723   "RTN","RCD PENR2",486 ,0)
  18724    ; Otherwi se, send n o
  18725   "RTN","RCD PENR2",487 ,0)
  18726    Q 0
  18727   "RTN","RCD PENR2",488 ,0)
  18728    ;
  18729   "RTN","RCD PENR2",489 ,0)
  18730    ; build t he list of  divisions  to report  on.
  18731   "RTN","RCD PENR2",490 ,0)
  18732   DIV(RCDIV)  ;
  18733   "RTN","RCD PENR2",491 ,0)
  18734    ;
  18735   "RTN","RCD PENR2",492 ,0)
  18736    N RCI
  18737   "RTN","RCD PENR2",493 ,0)
  18738    ;
  18739   "RTN","RCD PENR2",494 ,0)
  18740    ; If all  divisions  selected,  set the al l division  flag
  18741   "RTN","RCD PENR2",495 ,0)
  18742    I $D(RCDI V("A")) S  ^TMP("RCDP ENR2",$J," DIVALL")=" " Q
  18743   "RTN","RCD PENR2",496 ,0)
  18744    ;
  18745   "RTN","RCD PENR2",497 ,0)
  18746    ; Loop th rough divi sion list  and build  temp array  for it.
  18747   "RTN","RCD PENR2",498 ,0)
  18748    S RCI=0
  18749   "RTN","RCD PENR2",499 ,0)
  18750    F  S RCI= $O(RCDIV(R CI)) Q:'RC I  S ^TMP( "RCDPENR2" ,$J,"DIV", RCDIV(RCI) )=""
  18751   "RTN","RCD PENR2",500 ,0)
  18752    Q
  18753   "RTN","RCD PENR2",501 ,0)
  18754    ;Determin e the text  to displa y for the  Payer TINs
  18755   "RTN","RCD PENR2",502 ,0)
  18756   TINTXT() ;
  18757   "RTN","RCD PENR2",503 ,0)
  18758    ;
  18759   "RTN","RCD PENR2",504 ,0)
  18760    N RCTIN,R CTXT,RCTNT XT
  18761   "RTN","RCD PENR2",505 ,0)
  18762    ; 
  18763   "RTN","RCD PENR2",506 ,0)
  18764    Q:$D(^TMP ("RCDPEADP ",$J,"TIN" ,"A")) "AL L PAYER TI NS"
  18765   "RTN","RCD PENR2",507 ,0)
  18766    ;
  18767   "RTN","RCD PENR2",508 ,0)
  18768    ;Build li st of Paye r Tins
  18769   "RTN","RCD PENR2",509 ,0)
  18770    ;
  18771   "RTN","RCD PENR2",510 ,0)
  18772    S RCTIN=" ",RCTXT=""
  18773   "RTN","RCD PENR2",511 ,0)
  18774    F  S RCTI N=$O(^TMP( "RCDPEADP" ,$J,"TIN", RCTIN)) Q: RCTIN=""   D
  18775   "RTN","RCD PENR2",512 ,0)
  18776    . S RCTNT XT=$$GET1^ DIQ(344.6, +RCTIN_"," ,".02","I" )
  18777   "RTN","RCD PENR2",513 ,0)
  18778    . S RCTXT =RCTXT_RCT NTXT_","
  18779   "RTN","RCD PENR2",514 ,0)
  18780    ;
  18781   "RTN","RCD PENR2",515 ,0)
  18782    ; Remove  comma at t he end. 
  18783   "RTN","RCD PENR2",516 ,0)
  18784    S RCTXT=$ E(RCTXT,1, $L(RCTXT)- 1)
  18785   "RTN","RCD PENR2",517 ,0)
  18786    ;
  18787   "RTN","RCD PENR2",518 ,0)
  18788    ; Display  the first  35 charac ters of th e division  text list ,
  18789   "RTN","RCD PENR2",519 ,0)
  18790    Q $E(RCTX T,1,35)
  18791   "RTN","RCD PENR2",520 ,0)
  18792    ;
  18793   "RTN","RCD PENR2",521 ,0)
  18794   COLHEAD ;
  18795   "RTN","RCD PENR2",522 ,0)
  18796    ;
  18797   "RTN","RCD PENR2",523 ,0)
  18798    N RCTMP
  18799   "RTN","RCD PENR2",524 ,0)
  18800    ;
  18801   "RTN","RCD PENR2",525 ,0)
  18802    ;Display  the column  headers
  18803   "RTN","RCD PENR2",526 ,0)
  18804    I RCEXCEL  D
  18805   "RTN","RCD PENR2",527 ,0)
  18806    . S RCTMP ="CLAIM#^D OS^AMT BIL LED^AMT PA ID^BILLED^ ERA/EOB RE C'D^EFT/PM T REC'D^PO STED^TRACE  #"
  18807   "RTN","RCD PENR2",528 ,0)
  18808    . S RCTMP =RCTMP_"^E TRANS TYPE ^ERA#^#EEO BS^EFT#^#D AYS:(BILL/ ERA)^#DAYS :(ERA/EFT) ^#DAYS:(ER A+EFT/POST ED)^TOTAL  #DAYS(BILL /POSTED)"
  18809   "RTN","RCD PENR2",529 ,0)
  18810    . W RCTMP ,!
  18811   "RTN","RCD PENR2",530 ,0)
  18812    I 'RCEXCE L D
  18813   "RTN","RCD PENR2",531 ,0)
  18814    . W "CLAI M#",?21,"D OS",?30,"A MT BILLED" ,?41,"AMT  PAID",?52, "BILLED",? 61,"ERA/EO B REC'D",? 75,"EFT/PM T REC'D",? 89,"POSTED ",?98,"TRA CE #",?109 ,"AUTOPOST /MANUAL",!
  18815   "RTN","RCD PENR2",532 ,0)
  18816    . W ?5,"E TRANS TYPE ",?17,"ERA #",?28,"#E EOBS",?39, "EFT#",?50 ,"#DAYS:(B ILL/ERA)", ?67,"#DAYS :(ERA/EFT) ",?83,"#DA YS:(ERA+EF T/POSTED)" ,?106,"TOT AL #DAYS(B ILL/POSTED )",!
  18817   "RTN","RCD PENR2",533 ,0)
  18818    . W RCLIN E,!
  18819   "RTN","RCD PENR2",534 ,0)
  18820    Q
  18821   "RTN","RCD PENR2",535 ,0)
  18822    ;
  18823   "RTN","RCD PENR2",536 ,0)
  18824    ;Entry po int for re printing t he header.
  18825   "RTN","RCD PENR2",537 ,0)
  18826   REPRINT(RC IEN) ;
  18827   "RTN","RCD PENR2",538 ,0)
  18828    ;
  18829   "RTN","RCD PENR2",539 ,0)
  18830    N I,RCDAT A,J,RCSTOP ,PAGE
  18831   "RTN","RCD PENR2",540 ,0)
  18832    ;
  18833   "RTN","RCD PENR2",541 ,0)
  18834    ;
  18835   "RTN","RCD PENR2",542 ,0)
  18836    S PAGE=1
  18837   "RTN","RCD PENR2",543 ,0)
  18838    D RPTHDR( RCIEN,PAGE )
  18839   "RTN","RCD PENR2",544 ,0)
  18840    ;
  18841   "RTN","RCD PENR2",545 ,0)
  18842    S I=4,RCS TOP=0  ;lo op through  the main  body
  18843   "RTN","RCD PENR2",546 ,0)
  18844    F  S I=$O (^RCDM(344 .91,RCIEN, 1,I)) Q:'I   D  Q:RCS TOP
  18845   "RTN","RCD PENR2",547 ,0)
  18846    .  S RCDA TA=$G(^RCD M(344.91,R CIEN,1,I,0 ))
  18847   "RTN","RCD PENR2",548 ,0)
  18848    .  ;
  18849   "RTN","RCD PENR2",549 ,0)
  18850    .  I $Y>( IOSL-4) D   Q:RCSTOP
  18851   "RTN","RCD PENR2",550 ,0)
  18852    .  . D AS K^RCDPEADP (.RCSTOP,0 )
  18853   "RTN","RCD PENR2",551 ,0)
  18854    .  . Q:RC STOP
  18855   "RTN","RCD PENR2",552 ,0)
  18856    .  . S PA GE=PAGE+1
  18857   "RTN","RCD PENR2",553 ,0)
  18858    .  . D RP THDR(RCIEN ,PAGE)
  18859   "RTN","RCD PENR2",554 ,0)
  18860    .  ; main  body of r eport
  18861   "RTN","RCD PENR2",555 ,0)
  18862    .  W $P(R CDATA,U)
  18863   "RTN","RCD PENR2",556 ,0)
  18864    .  I RCDA TA["^" W ? 65,$P(RCDA TA,U,2)
  18865   "RTN","RCD PENR2",557 ,0)
  18866    .  W !       ;Add <C RLF>
  18867   "RTN","RCD PENR2",558 ,0)
  18868    Q
  18869   "RTN","RCD PENR2",559 ,0)
  18870    ;
  18871   "RTN","RCD PENR2",560 ,0)
  18872   RPTHDR(RCI EN,PAGE) ;  Reprint t he header
  18873   "RTN","RCD PENR2",561 ,0)
  18874    ;
  18875   "RTN","RCD PENR2",562 ,0)
  18876    N I,RCDAT A
  18877   "RTN","RCD PENR2",563 ,0)
  18878    ;
  18879   "RTN","RCD PENR2",564 ,0)
  18880    W @IOF    ; Create n ew page
  18881   "RTN","RCD PENR2",565 ,0)
  18882    ;
  18883   "RTN","RCD PENR2",566 ,0)
  18884    F I=1:1:4  D
  18885   "RTN","RCD PENR2",567 ,0)
  18886    . S RCDAT A=$G(^RCDM (344.91,RC IEN,1,I,0) )
  18887   "RTN","RCD PENR2",568 ,0)
  18888    . ; heade r lines fo rmatting
  18889   "RTN","RCD PENR2",569 ,0)
  18890    . I I=1 W  ?15,$P(RC DATA,U),?7 0,PAGE,! Q
  18891   "RTN","RCD PENR2",570 ,0)
  18892    . I I=2 W  ?5,$P(RCD ATA,U,2),!  Q
  18893   "RTN","RCD PENR2",571 ,0)
  18894    . I I=3!( I=4) W ?5, $P(RCDATA, U,2),?45,$ P(RCDATA,U ,3),! Q
  18895   "RTN","RCD PENR2",572 ,0)
  18896    Q
  18897   "RTN","RCD PENR3")
  18898   0^34^B1984 55458
  18899   "RTN","RCD PENR3",1,0 )
  18900   RCDPENR3 ; ALB/SAB -  EPay Natio nal Report s - ERA/EF T Trending  Report, p art 2 ;06/ 30/15
  18901   "RTN","RCD PENR3",2,0 )
  18902    ;;4.5;Acc ounts Rece ivable;**3 04,321**;M ar 20, 199 5;Build 46
  18903   "RTN","RCD PENR3",3,0 )
  18904    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  18905   "RTN","RCD PENR3",4,0 )
  18906    ;
  18907   "RTN","RCD PENR3",5,0 )
  18908    ;Read ^DG CR(399) vi a Private  IA 3820
  18909   "RTN","RCD PENR3",6,0 )
  18910    ;Read ^DG (40.8) via  Controlle d IA 417
  18911   "RTN","RCD PENR3",7,0 )
  18912    ;Read ^IB M(361.1) v ia Private  IA 4051
  18913   "RTN","RCD PENR3",8,0 )
  18914    ;Use DIV^ IBJDF2 via  Private I A 3130
  18915   "RTN","RCD PENR3",9,0 )
  18916    ;
  18917   "RTN","RCD PENR3",10, 0)
  18918    Q
  18919   "RTN","RCD PENR3",11, 0)
  18920    ;
  18921   "RTN","RCD PENR3",12, 0)
  18922    ;
  18923   "RTN","RCD PENR3",13, 0)
  18924    ;Generate  the neede d statisti cs for the  report
  18925   "RTN","RCD PENR3",14, 0)
  18926   COMPILE ;
  18927   "RTN","RCD PENR3",15, 0)
  18928    ;
  18929   "RTN","RCD PENR3",16, 0)
  18930    ;RCERATYP  values 1= "ERA/EFT"   2="ERA/PA PER CHECK"   3="PAPER  EOB/EFT"
  18931   "RTN","RCD PENR3",17, 0)
  18932    ;     nee ded for th e correct  report sor t order
  18933   "RTN","RCD PENR3",18, 0)
  18934    N I,RCINS TIN,RCERAT YP,RCCLAIM ,RCDATA,RC DAYS,RCEFT PD,RCEPDT, RCERAIEN,R CERANUM,RC EFTIEN  ;  Looping va riable
  18935   "RTN","RCD PENR3",19, 0)
  18936    N RCGPDAT A,RCGPCT,R CGPBILL,RC GPPD,RCGPB ECT,RCGPBE DY,RCGPEEC T,RCGPEEDY ,RCGPEPCT, RCGPEPDY,R CGPBPCT,RC GPBPDY,RCG PECT,RCGPE NM,RCGPFCT ,RCGPFPD   ; Grand To tal W/Paym ent method  variables  
  18937   "RTN","RCD PENR3",20, 0)
  18938    N RCPPDAT A,RCPPCT,R CPPBILL,RC PPPD,RCPPB ECT,RCPPBE DY,RCPPEEC T,RCPPEEDY ,RCPPEPCT, RCPPEPDY,R CPPBPCT,RC PPBPDY,RCP PECT,RCPPE NM,RCPPFCT ,RCPPFPD   ; Payer W/ Payment me thod varia bles 
  18939   "RTN","RCD PENR3",21, 0)
  18940    ;
  18941   "RTN","RCD PENR3",22, 0)
  18942    ;Initiali ze all val id ERA/EFT  combinati ons to rep ort on.
  18943   "RTN","RCD PENR3",23, 0)
  18944    ; init gr and total
  18945   "RTN","RCD PENR3",24, 0)
  18946    F I=1:1:3  I '$D(^TM P("RCDPENR 2",$J,"GTO T",I)) S ^ TMP("RCDPE NR2",$J,"G TOT",I)=0
  18947   "RTN","RCD PENR3",25, 0)
  18948    ;
  18949   "RTN","RCD PENR3",26, 0)
  18950    ; init in surance gr and totals
  18951   "RTN","RCD PENR3",27, 0)
  18952    S RCINSTI N=""
  18953   "RTN","RCD PENR3",28, 0)
  18954    F  S RCIN STIN=$O(^T MP("RCDPEN R2",$J,"PA YER",RCINS TIN)) Q:RC INSTIN=""   D
  18955   "RTN","RCD PENR3",29, 0)
  18956    . F I=1:1 :3 I '$D(^ TMP("RCDPE NR2",$J,"P AYER",RCIN STIN,I)) S  ^TMP("RCD PENR2",$J, "PAYER",RC INSTIN,I)= 0
  18957   "RTN","RCD PENR3",30, 0)
  18958    ;
  18959   "RTN","RCD PENR3",31, 0)
  18960    ; Compile  results
  18961   "RTN","RCD PENR3",32, 0)
  18962    S RCINSTI N=""
  18963   "RTN","RCD PENR3",33, 0)
  18964    F  S RCIN STIN=$O(^T MP("RCDPEN R2",$J,"MA IN",RCINST IN)) Q:RCI NSTIN=""   D
  18965   "RTN","RCD PENR3",34, 0)
  18966    . S RCERA TYP=""
  18967   "RTN","RCD PENR3",35, 0)
  18968    . F  S RC ERATYP=$O( ^TMP("RCDP ENR2",$J," MAIN",RCIN STIN,RCERA TYP)) Q:RC ERATYP=""   D
  18969   "RTN","RCD PENR3",36, 0)
  18970    . . S RCC LAIM=""
  18971   "RTN","RCD PENR3",37, 0)
  18972    . . F  S  RCCLAIM=$O (^TMP("RCD PENR2",$J, "MAIN",RCI NSTIN,RCER ATYP,RCCLA IM)) Q:RCC LAIM=""  D
  18973   "RTN","RCD PENR3",38, 0)
  18974    . . . S R CDATA=$G(^ TMP("RCDPE NR2",$J,"M AIN",RCINS TIN,RCERAT YP,RCCLAIM ))
  18975   "RTN","RCD PENR3",39, 0)
  18976    . . . Q:R CDATA=""
  18977   "RTN","RCD PENR3",40, 0)
  18978    . . . ;
  18979   "RTN","RCD PENR3",41, 0)
  18980    . . . ; E xtract the  Grand Tot al by EFT/ ERA type
  18981   "RTN","RCD PENR3",42, 0)
  18982    . . . S R CGPDATA=$G (^TMP("RCD PENR2",$J, "GTOT",RCE RATYP))
  18983   "RTN","RCD PENR3",43, 0)
  18984    . . . S R CGPCT=$P(R CGPDATA,U)
  18985   "RTN","RCD PENR3",44, 0)
  18986    . . . S R CGPBILL=$P (RCGPDATA, U,2)
  18987   "RTN","RCD PENR3",45, 0)
  18988    . . . S R CGPPD=$P(R CGPDATA,U, 3)
  18989   "RTN","RCD PENR3",46, 0)
  18990    . . . S R CGPBECT=$P (RCGPDATA, U,4)
  18991   "RTN","RCD PENR3",47, 0)
  18992    . . . S R CGPBEDY=$P (RCGPDATA, U,5)
  18993   "RTN","RCD PENR3",48, 0)
  18994    . . . S R CGPEECT=$P (RCGPDATA, U,6)
  18995   "RTN","RCD PENR3",49, 0)
  18996    . . . S R CGPEEDY=$P (RCGPDATA, U,7)
  18997   "RTN","RCD PENR3",50, 0)
  18998    . . . S R CGPEPCT=$P (RCGPDATA, U,8)
  18999   "RTN","RCD PENR3",51, 0)
  19000    . . . S R CGPEPDY=$P (RCGPDATA, U,9)
  19001   "RTN","RCD PENR3",52, 0)
  19002    . . . S R CGPBPCT=$P (RCGPDATA, U,10)
  19003   "RTN","RCD PENR3",53, 0)
  19004    . . . S R CGPBPDY=$P (RCGPDATA, U,11)
  19005   "RTN","RCD PENR3",54, 0)
  19006    . . . S R CGPECT=$P( RCGPDATA,U ,12)
  19007   "RTN","RCD PENR3",55, 0)
  19008    . . . S R CGPENM=$P( RCGPDATA,U ,13)
  19009   "RTN","RCD PENR3",56, 0)
  19010    . . . S R CGPFCT=$P( RCGPDATA,U ,14)
  19011   "RTN","RCD PENR3",57, 0)
  19012    . . . S R CGPFPD=$P( RCGPDATA,U ,15)
  19013   "RTN","RCD PENR3",58, 0)
  19014    . . . ;
  19015   "RTN","RCD PENR3",59, 0)
  19016    . . . ; E xtract the  Payer spe cific info rmation by  EFT/ERA t ype
  19017   "RTN","RCD PENR3",60, 0)
  19018    . . . S R CPPDATA=$G (^TMP("RCD PENR2",$J, "PAYER",RC INSTIN,RCE RATYP))
  19019   "RTN","RCD PENR3",61, 0)
  19020    . . . S R CPPCT=$P(R CPPDATA,U)
  19021   "RTN","RCD PENR3",62, 0)
  19022    . . . S R CPPBILL=$P (RCPPDATA, U,2)
  19023   "RTN","RCD PENR3",63, 0)
  19024    . . . S R CPPPD=$P(R CPPDATA,U, 3)
  19025   "RTN","RCD PENR3",64, 0)
  19026    . . . S R CPPBECT=$P (RCPPDATA, U,4)
  19027   "RTN","RCD PENR3",65, 0)
  19028    . . . S R CPPBEDY=$P (RCPPDATA, U,5)
  19029   "RTN","RCD PENR3",66, 0)
  19030    . . . S R CPPEECT=$P (RCPPDATA, U,6)
  19031   "RTN","RCD PENR3",67, 0)
  19032    . . . S R CPPEEDY=$P (RCPPDATA, U,7)
  19033   "RTN","RCD PENR3",68, 0)
  19034    . . . S R CPPEPCT=$P (RCPPDATA, U,8)
  19035   "RTN","RCD PENR3",69, 0)
  19036    . . . S R CPPEPDY=$P (RCPPDATA, U,9)
  19037   "RTN","RCD PENR3",70, 0)
  19038    . . . S R CPPBPCT=$P (RCPPDATA, U,10)
  19039   "RTN","RCD PENR3",71, 0)
  19040    . . . S R CPPBPDY=$P (RCPPDATA, U,11)
  19041   "RTN","RCD PENR3",72, 0)
  19042    . . . S R CPPECT=$P( RCPPDATA,U ,12)
  19043   "RTN","RCD PENR3",73, 0)
  19044    . . . S R CPPENM=$P( RCPPDATA,U ,13)
  19045   "RTN","RCD PENR3",74, 0)
  19046    . . . S R CPPFCT=$P( RCPPDATA,U ,14)
  19047   "RTN","RCD PENR3",75, 0)
  19048    . . . S R CPPFPD=$P( RCPPDATA,U ,15)
  19049   "RTN","RCD PENR3",76, 0)
  19050    . . . ;
  19051   "RTN","RCD PENR3",77, 0)
  19052    . . . ; T otal count s - Grand/ Payment Me thod
  19053   "RTN","RCD PENR3",78, 0)
  19054    . . . S R CGPCT=RCGP CT+1
  19055   "RTN","RCD PENR3",79, 0)
  19056    . . . S R CGPBILL=RC GPBILL+$P( RCDATA,U,6 )
  19057   "RTN","RCD PENR3",80, 0)
  19058    . . . S R CGPPD=RCGP PD+$P(RCDA TA,U,7)
  19059   "RTN","RCD PENR3",81, 0)
  19060    . . . ;
  19061   "RTN","RCD PENR3",82, 0)
  19062    . . . ; T otal count s - Payer/ Payment me thod
  19063   "RTN","RCD PENR3",83, 0)
  19064    . . . S R CPPCT=RCPP CT+1
  19065   "RTN","RCD PENR3",84, 0)
  19066    . . . S R CPPBILL=RC PPBILL+$P( RCDATA,U,6 )
  19067   "RTN","RCD PENR3",85, 0)
  19068    . . . S R CPPPD=RCPP PD+$P(RCDA TA,U,7)
  19069   "RTN","RCD PENR3",86, 0)
  19070    . . . ;
  19071   "RTN","RCD PENR3",87, 0)
  19072    . . . ; B illed to E RA receive d
  19073   "RTN","RCD PENR3",88, 0)
  19074    . . . I $ P(RCDATA,U ,8),$P(RCD ATA,U,9) D
  19075   "RTN","RCD PENR3",89, 0)
  19076    . . . . S  RCGPBECT= RCGPBECT+1
  19077   "RTN","RCD PENR3",90, 0)
  19078    . . . . S  RCPPBECT= RCPPBECT+1
  19079   "RTN","RCD PENR3",91, 0)
  19080    . . . . S  RCDAYS=$$ FMDIFF^XLF DT($P(RCDA TA,U,9),$P (RCDATA,U, 8),1)
  19081   "RTN","RCD PENR3",92, 0)
  19082    . . . . S  RCGPBEDY= RCGPBEDY+R CDAYS
  19083   "RTN","RCD PENR3",93, 0)
  19084    . . . . S  RCPPBEDY= RCPPBEDY+R CDAYS
  19085   "RTN","RCD PENR3",94, 0)
  19086    . . . ;
  19087   "RTN","RCD PENR3",95, 0)
  19088    . . . ; E RA to EFT  received
  19089   "RTN","RCD PENR3",96, 0)
  19090    . . . I $ P(RCDATA,U ,10),$P(RC DATA,U,9)  D
  19091   "RTN","RCD PENR3",97, 0)
  19092    . . . . S  RCGPEECT= RCGPEECT+1
  19093   "RTN","RCD PENR3",98, 0)
  19094    . . . . S  RCPPEECT= RCPPEECT+1
  19095   "RTN","RCD PENR3",99, 0)
  19096    . . . . S  RCDAYS=$$ FMDIFF^XLF DT($P(RCDA TA,U,10),$ P(RCDATA,U ,9),1)
  19097   "RTN","RCD PENR3",100 ,0)
  19098    . . . . S  RCGPEEDY= RCGPEEDY+R CDAYS
  19099   "RTN","RCD PENR3",101 ,0)
  19100    . . . . S  RCPPEEDY= RCPPEEDY+R CDAYS
  19101   "RTN","RCD PENR3",102 ,0)
  19102    . . . ;
  19103   "RTN","RCD PENR3",103 ,0)
  19104    . . . ; E RA and EFT  received,  and payme nt Posted
  19105   "RTN","RCD PENR3",104 ,0)
  19106    . . . I $ P(RCDATA,U ,10),$P(RC DATA,U,9), $P(RCDATA, U,11) D
  19107   "RTN","RCD PENR3",105 ,0)
  19108    . . . . S  RCGPEPCT= RCGPEPCT+1
  19109   "RTN","RCD PENR3",106 ,0)
  19110    . . . . S  RCPPEPCT= RCPPEPCT+1
  19111   "RTN","RCD PENR3",107 ,0)
  19112    . . . . S  RCEPDT=$S ($P(RCDATA ,U,9)>$P(R CDATA,U,10 ):9,1:10)   ;determin e which da te is late r
  19113   "RTN","RCD PENR3",108 ,0)
  19114    . . . . S  RCDAYS=$$ FMDIFF^XLF DT($P(RCDA TA,U,11),$ P(RCDATA,U ,RCEPDT),1 )
  19115   "RTN","RCD PENR3",109 ,0)
  19116    . . . . S  RCGPEPDY= RCGPEPDY+R CDAYS
  19117   "RTN","RCD PENR3",110 ,0)
  19118    . . . . S  RCPPEPDY= RCPPEPDY+R CDAYS
  19119   "RTN","RCD PENR3",111 ,0)
  19120    . . . ;
  19121   "RTN","RCD PENR3",112 ,0)
  19122    . . . ; B ill to Pay ment Poste d
  19123   "RTN","RCD PENR3",113 ,0)
  19124    . . . I $ P(RCDATA,U ,8),$P(RCD ATA,U,11)  D
  19125   "RTN","RCD PENR3",114 ,0)
  19126    . . . . S  RCGPBPCT= RCGPBPCT+1
  19127   "RTN","RCD PENR3",115 ,0)
  19128    . . . . S  RCPPBPCT= RCPPBPCT+1
  19129   "RTN","RCD PENR3",116 ,0)
  19130    . . . . S  RCDAYS=$$ FMDIFF^XLF DT($P(RCDA TA,U,11),$ P(RCDATA,U ,8),1)
  19131   "RTN","RCD PENR3",117 ,0)
  19132    . . . . S  RCGPBPDY= RCGPBPDY+R CDAYS
  19133   "RTN","RCD PENR3",118 ,0)
  19134    . . . . S  RCPPBPDY= RCPPBPDY+R CDAYS
  19135   "RTN","RCD PENR3",119 ,0)
  19136    . . . ;
  19137   "RTN","RCD PENR3",120 ,0)
  19138    . . . ; I f the ERA  hasn't alr eady been  counted, a dd it to t he totals
  19139   "RTN","RCD PENR3",121 ,0)
  19140    . . . S R CERAIEN=$P (RCDATA,U, 2)
  19141   "RTN","RCD PENR3",122 ,0)
  19142    . . . I R CERAIEN,'$ D(^TMP("RC DPENR2",$J ,"ERA",RCE RAIEN)) D
  19143   "RTN","RCD PENR3",123 ,0)
  19144    . . . . S  ^TMP("RCD PENR2",$J, "ERA",RCER AIEN)=""
  19145   "RTN","RCD PENR3",124 ,0)
  19146    . . . . S  RCERANUM= $P(RCDATA, U,15)
  19147   "RTN","RCD PENR3",125 ,0)
  19148    . . . . S  RCGPECT=R CGPECT+1,R CPPECT=RCP PECT+1
  19149   "RTN","RCD PENR3",126 ,0)
  19150    . . . . S  RCGPENM=R CGPENM+RCE RANUM,RCPP ENM=RCPPEN M+RCERANUM
  19151   "RTN","RCD PENR3",127 ,0)
  19152    . . . ;
  19153   "RTN","RCD PENR3",128 ,0)
  19154    . . . ; I f the EFT  hasn't alr eady been  counted, a dd it to t he totals
  19155   "RTN","RCD PENR3",129 ,0)
  19156    . . . S R CEFTIEN=$P (RCDATA,U, 3)
  19157   "RTN","RCD PENR3",130 ,0)
  19158    . . . I ( RCEFTIEN), ('$D(^TMP( "RCDPENR2" ,$J,"EFT", RCEFTIEN)) ) D
  19159   "RTN","RCD PENR3",131 ,0)
  19160    . . . . S  ^TMP("RCD PENR2",$J, "EFT",RCEF TIEN)=""
  19161   "RTN","RCD PENR3",132 ,0)
  19162    . . . . S  RCEFTPD=$ P(RCDATA,U ,18)
  19163   "RTN","RCD PENR3",133 ,0)
  19164    . . . . S  RCGPFCT=R CGPFCT+1,R CPPFCT=RCP PFCT+1
  19165   "RTN","RCD PENR3",134 ,0)
  19166    . . . . S  RCGPFPD=R CGPFPD+RCE FTPD,RCPPF PD=RCPPFPD +RCEFTPD
  19167   "RTN","RCD PENR3",135 ,0)
  19168    . . . ;
  19169   "RTN","RCD PENR3",136 ,0)
  19170    . . . ; U pdate the  payer spec ific infor mation By  Payment Me thod
  19171   "RTN","RCD PENR3",137 ,0)
  19172    . . . S $ P(RCPPDATA ,U)=RCPPCT
  19173   "RTN","RCD PENR3",138 ,0)
  19174    . . . S $ P(RCPPDATA ,U,2)=RCPP BILL
  19175   "RTN","RCD PENR3",139 ,0)
  19176    . . . S $ P(RCPPDATA ,U,3)=RCPP PD
  19177   "RTN","RCD PENR3",140 ,0)
  19178    . . . S $ P(RCPPDATA ,U,4)=RCPP BECT
  19179   "RTN","RCD PENR3",141 ,0)
  19180    . . . S $ P(RCPPDATA ,U,5)=RCPP BEDY
  19181   "RTN","RCD PENR3",142 ,0)
  19182    . . . S $ P(RCPPDATA ,U,6)=RCPP EECT
  19183   "RTN","RCD PENR3",143 ,0)
  19184    . . . S $ P(RCPPDATA ,U,7)=RCPP EEDY
  19185   "RTN","RCD PENR3",144 ,0)
  19186    . . . S $ P(RCPPDATA ,U,8)=RCPP EPCT
  19187   "RTN","RCD PENR3",145 ,0)
  19188    . . . S $ P(RCPPDATA ,U,9)=RCPP EPDY
  19189   "RTN","RCD PENR3",146 ,0)
  19190    . . . S $ P(RCPPDATA ,U,10)=RCP PBPCT
  19191   "RTN","RCD PENR3",147 ,0)
  19192    . . . S $ P(RCPPDATA ,U,11)=RCP PBPDY
  19193   "RTN","RCD PENR3",148 ,0)
  19194    . . . S $ P(RCPPDATA ,U,12)=RCP PECT
  19195   "RTN","RCD PENR3",149 ,0)
  19196    . . . S $ P(RCPPDATA ,U,13)=RCP PENM
  19197   "RTN","RCD PENR3",150 ,0)
  19198    . . . S $ P(RCPPDATA ,U,14)=RCP PFCT
  19199   "RTN","RCD PENR3",151 ,0)
  19200    . . . S $ P(RCPPDATA ,U,15)=RCP PFPD
  19201   "RTN","RCD PENR3",152 ,0)
  19202    . . . S ^ TMP("RCDPE NR2",$J,"P AYER",RCIN STIN,RCERA TYP)=RCPPD ATA
  19203   "RTN","RCD PENR3",153 ,0)
  19204    . . . ;
  19205   "RTN","RCD PENR3",154 ,0)
  19206    . . . ; U pdate the  Grand Tota l specific  informati on By Paym ent Method
  19207   "RTN","RCD PENR3",155 ,0)
  19208    . . . S $ P(RCGPDATA ,U)=RCGPCT
  19209   "RTN","RCD PENR3",156 ,0)
  19210    . . . S $ P(RCGPDATA ,U,2)=RCGP BILL
  19211   "RTN","RCD PENR3",157 ,0)
  19212    . . . S $ P(RCGPDATA ,U,3)=RCGP PD
  19213   "RTN","RCD PENR3",158 ,0)
  19214    . . . S $ P(RCGPDATA ,U,4)=RCGP BECT
  19215   "RTN","RCD PENR3",159 ,0)
  19216    . . . S $ P(RCGPDATA ,U,5)=RCGP BEDY
  19217   "RTN","RCD PENR3",160 ,0)
  19218    . . . S $ P(RCGPDATA ,U,6)=RCGP EECT
  19219   "RTN","RCD PENR3",161 ,0)
  19220    . . . S $ P(RCGPDATA ,U,7)=RCGP EEDY
  19221   "RTN","RCD PENR3",162 ,0)
  19222    . . . S $ P(RCGPDATA ,U,8)=RCGP EPCT
  19223   "RTN","RCD PENR3",163 ,0)
  19224    . . . S $ P(RCGPDATA ,U,9)=RCGP EPDY
  19225   "RTN","RCD PENR3",164 ,0)
  19226    . . . S $ P(RCGPDATA ,U,10)=RCG PBPCT
  19227   "RTN","RCD PENR3",165 ,0)
  19228    . . . S $ P(RCGPDATA ,U,11)=RCG PBPDY
  19229   "RTN","RCD PENR3",166 ,0)
  19230    . . . S $ P(RCGPDATA ,U,12)=RCG PECT
  19231   "RTN","RCD PENR3",167 ,0)
  19232    . . . S $ P(RCGPDATA ,U,13)=RCG PENM
  19233   "RTN","RCD PENR3",168 ,0)
  19234    . . . S $ P(RCGPDATA ,U,14)=RCG PFCT
  19235   "RTN","RCD PENR3",169 ,0)
  19236    . . . S $ P(RCGPDATA ,U,15)=RCG PFPD
  19237   "RTN","RCD PENR3",170 ,0)
  19238    . . . S ^ TMP("RCDPE NR2",$J,"G TOT",RCERA TYP)=RCGPD ATA
  19239   "RTN","RCD PENR3",171 ,0)
  19240    Q
  19241   "RTN","RCD PENR3",172 ,0)
  19242    ;
  19243   "RTN","RCD PENR3",173 ,0)
  19244    ;Retrieve  all neces sary infor mation for  the EFTs  sent durin g the requ ested peri od.
  19245   "RTN","RCD PENR3",174 ,0)
  19246   GETEFT(RCS DATE,RCEDA TE,RCRATE)  ;
  19247   "RTN","RCD PENR3",175 ,0)
  19248    ;RCSDATE  - Start da te of extr action
  19249   "RTN","RCD PENR3",176 ,0)
  19250    ;RCEDATE  - End date  of extrac tion
  19251   "RTN","RCD PENR3",177 ,0)
  19252    ;
  19253   "RTN","RCD PENR3",178 ,0)
  19254    ;^TMP("RC DPENR2",$J ,"MAIN",IE N of Claim /Bill #) =
  19255   "RTN","RCD PENR3",179 ,0)
  19256    ; Where:
  19257   "RTN","RCD PENR3",180 ,0)
  19258    ; Piece   Variable
  19259   "RTN","RCD PENR3",181 ,0)
  19260    ; 1       RCBILL   -  IEN of Bi ll/Claim #
  19261   "RTN","RCD PENR3",182 ,0)
  19262    ; 2       RCERA    -  IEN of th e ERA the  bill was p aid on.
  19263   "RTN","RCD PENR3",183 ,0)
  19264    ; 3       RCIEN    -  IEN of th e EFT the  money for  the bill a rrived on
  19265   "RTN","RCD PENR3",184 ,0)
  19266    ; 4       RCEOB    -  IEN of th e EOB with in the ERA  
  19267   "RTN","RCD PENR3",185 ,0)
  19268    ; 5       RCDOS    -  Date of S ervice
  19269   "RTN","RCD PENR3",186 ,0)
  19270    ; 6       RCAMTBL  -  Amount Bi lled
  19271   "RTN","RCD PENR3",187 ,0)
  19272    ; 7       RCAMTPD  -  Amount Pa id
  19273   "RTN","RCD PENR3",188 ,0)
  19274    ; 8       RCDTBILL -  Date of B ill
  19275   "RTN","RCD PENR3",189 ,0)
  19276    ; 9       RCERARCD -  Date ERA  received
  19277   "RTN","RCD PENR3",190 ,0)
  19278    ; 10      RCEFTRCD -  Date EFT  received
  19279   "RTN","RCD PENR3",191 ,0)
  19280    ; 11      RCPOSTED -  Date Paym ent Posted  to claim
  19281   "RTN","RCD PENR3",192 ,0)
  19282    ; 12      RCTRACE  -  ERA Trace  number fo r EOB
  19283   "RTN","RCD PENR3",193 ,0)
  19284    ; 13      RCMETHOD -  Method of  Payment t ransmittal
  19285   "RTN","RCD PENR3",194 ,0)
  19286    ; 14      RCTRNTYP -  Was payme nt EFT or  Paper Chec k / Was th e ERA Pape r or EDI L ockbox
  19287   "RTN","RCD PENR3",195 ,0)
  19288    ; 15      RCERANUM -  # EOB'S i n ERA
  19289   "RTN","RCD PENR3",196 ,0)
  19290    ; 16      RCDIV    -  Division  of the bil l
  19291   "RTN","RCD PENR3",197 ,0)
  19292    ; 17      RCINSTIN -  Insurance /Insurance  TIN
  19293   "RTN","RCD PENR3",198 ,0)
  19294    ; 18      RCEFTPD  -  Amount pa id as an E FT, not as  a check.
  19295   "RTN","RCD PENR3",199 ,0)
  19296    ;
  19297   "RTN","RCD PENR3",200 ,0)
  19298    N RCLDATE ,RCINS,RCI EN,RCEFTDT ,RCERA,RCE FT,RCRCPT, RCPOSTED,R CPAYTYP,RC ERADT,RCTR ACE,RCERAI DX
  19299   "RTN","RCD PENR3",201 ,0)
  19300    N RCTRLN, RCTRBD,RCE RANUM,RCTI N,RCPAYER, RCINSTIN,R CLPIEN,RCD TDATA,RCEO B,RCBILL,R CDIV,RCDOS ,RCAMTBL
  19301   "RTN","RCD PENR3",202 ,0)
  19302    N RCDTBIL L,RCMETHOD ,RCPAPER,R CEFTTYP,RC EFTPD,RCTR NTYP,RCDAT A,RCAMTPD, RCEFTRCD,R CERARCD,RC RATETP
  19303   "RTN","RCD PENR3",203 ,0)
  19304    N RCMSTAT ,RCESUMDT, RCPSUMDT,Z ZPNAME
  19305   "RTN","RCD PENR3",204 ,0)
  19306    ;
  19307   "RTN","RCD PENR3",205 ,0)
  19308    ;Get the  EFT Detail  informati on for the  report ba tches sent  within th e given da te range.
  19309   "RTN","RCD PENR3",206 ,0)
  19310    S RCLDATE =RCSDATE-. 001
  19311   "RTN","RCD PENR3",207 ,0)
  19312    F  S RCLD ATE=$O(^RC Y(344.31," ADR",RCLDA TE)) Q:RCL DATE=""  Q :RCLDATE>R CEDATE  D
  19313   "RTN","RCD PENR3",208 ,0)
  19314    . S RCIEN =0
  19315   "RTN","RCD PENR3",209 ,0)
  19316    . F  S RC IEN=$O(^RC Y(344.31," ADR",RCLDA TE,RCIEN))  Q:'RCIEN   D
  19317   "RTN","RCD PENR3",210 ,0)
  19318    . . S RCE FTDT=$G(^R CY(344.31, RCIEN,0))
  19319   "RTN","RCD PENR3",211 ,0)
  19320    . . Q:RCE FTDT=""
  19321   "RTN","RCD PENR3",212 ,0)
  19322    . . S RCE RA=$P(RCEF TDT,U,10)              ; ERA IEN
  19323   "RTN","RCD PENR3",213 ,0)
  19324    . . S RCE FTRCD=$P(R CEFTDT,U,1 3)
  19325   "RTN","RCD PENR3",214 ,0)
  19326    . . S RCE FT=$P(RCEF TDT,U)
  19327   "RTN","RCD PENR3",215 ,0)
  19328    . . S ZZP NAME=$P(RC EFTDT,U,2)
  19329   "RTN","RCD PENR3",216 ,0)
  19330    . . S RCM STAT=$P(RC EFTDT,U,8)
  19331   "RTN","RCD PENR3",217 ,0)
  19332    . . S RCR CPT=$P(RCE FTDT,U,9)
  19333   "RTN","RCD PENR3",218 ,0)
  19334    . . S RCE FTPD=$P(RC EFTDT,U,7)
  19335   "RTN","RCD PENR3",219 ,0)
  19336    . . S RCP OSTED=$$GE T1^DIQ(344 .3,RCEFT_" ,",.11,"I" )
  19337   "RTN","RCD PENR3",220 ,0)
  19338    . . S RCP AYTYP=$$GE T1^DIQ(344 ,RCRCPT_", ",.04,"I")
  19339   "RTN","RCD PENR3",221 ,0)
  19340    . . I RCE RA D  Q
  19341   "RTN","RCD PENR3",222 ,0)
  19342    . . . S R CERADT=$G( ^RCY(344.4 ,RCERA,0))  ; ERA Dat a extracte d
  19343   "RTN","RCD PENR3",223 ,0)
  19344    . . . Q:' RCERADT
  19345   "RTN","RCD PENR3",224 ,0)
  19346    . . . S R CTRACE=$P( RCERADT,U, 2)          ; Trace #
  19347   "RTN","RCD PENR3",225 ,0)
  19348    . . . S R CTRLN=$L(R CTRACE),RC TRBD=$S(RC TRLN<11:1, 1:RCTRLN-9 )
  19349   "RTN","RCD PENR3",226 ,0)
  19350    . . . S R CTRACE=$E( RCTRACE,RC TRBD,RCTRL N)  ; get  the last 1 0 digits o f Trace #
  19351   "RTN","RCD PENR3",227 ,0)
  19352    . . . S R CERARCD=$P ($P(RCERAD T,U,7),"." ,1)  ;get  the date o f the ERA
  19353   "RTN","RCD PENR3",228 ,0)
  19354    . . . S R CERANUM=$P (RCERADT,U ,11)
  19355   "RTN","RCD PENR3",229 ,0)
  19356    . . . S R CTIN=$P(RC ERADT,U,3)
  19357   "RTN","RCD PENR3",230 ,0)
  19358    . . . S R CINS=$P(RC ERADT,U,6)
  19359   "RTN","RCD PENR3",231 ,0)
  19360    . . . S R CPAYER=$$G ETARPYR^RC DPENR2(RCT IN,ZZPNAME ) ; find t he AR Paye r IEN
  19361   "RTN","RCD PENR3",232 ,0)
  19362    . . . Q:' RCPAYER                    ; Qui t if Payer /TIN not f ound
  19363   "RTN","RCD PENR3",233 ,0)
  19364    . . . Q:' $$INSCHK^R CDPENR2(RC PAYER)     ; Payer is  not in th e included  list for  the report
  19365   "RTN","RCD PENR3",234 ,0)
  19366    . . . S R CINSTIN=RC INS_"/"_RC TIN
  19367   "RTN","RCD PENR3",235 ,0)
  19368    . . . S R CLPIEN=0
  19369   "RTN","RCD PENR3",236 ,0)
  19370    . . . F   S RCLPIEN= $O(^RCY(34 4.4,RCERA, 1,RCLPIEN) ) Q:'RCLPI EN  D
  19371   "RTN","RCD PENR3",237 ,0)
  19372    . . . . S  RCDTDATA= $G(^RCY(34 4.4,RCERA, 1,RCLPIEN, 0))
  19373   "RTN","RCD PENR3",238 ,0)
  19374    . . . . S  RCEOB=$P( RCDTDATA,U ,2)
  19375   "RTN","RCD PENR3",239 ,0)
  19376    . . . . S  RCBILL=$$ BILLIEN^RC DPENR1(RCE OB)
  19377   "RTN","RCD PENR3",240 ,0)
  19378    . . . . Q :RCBILL=""    ; no bi lling info rmation
  19379   "RTN","RCD PENR3",241 ,0)
  19380    . . . . Q :$D(^TMP(" RCDPENR2", $J,"MAIN", RCBILL))   ;already c aptured.
  19381   "RTN","RCD PENR3",242 ,0)
  19382    . . . . S  RCDIV=$$D IV^IBJDF2( RCBILL)
  19383   "RTN","RCD PENR3",243 ,0)
  19384    . . . . S  RCDIV=$$G ET1^DIQ(40 .8,RCDIV_" ,",".01"," E")
  19385   "RTN","RCD PENR3",244 ,0)
  19386    . . . . ;
  19387   "RTN","RCD PENR3",245 ,0)
  19388    . . . . S  RCRATETP= $$GET1^DIQ (399,RCBIL L_",",.07, "I")
  19389   "RTN","RCD PENR3",246 ,0)
  19390    . . . . Q :RCRATETP' =RCRATE
  19391   "RTN","RCD PENR3",247 ,0)
  19392    . . . . ;  Quit if u ser specif ied a spec ific divis ion and bi ll is not  in that Di vision
  19393   "RTN","RCD PENR3",248 ,0)
  19394    . . . . I  '$D(^TMP( "RCDPENR2" ,$J,"DIVAL L"))&'$D(^ TMP("RCDPE NR2",$J,"D IV",RCDIV) ) Q 
  19395   "RTN","RCD PENR3",249 ,0)
  19396    . . . . S  RCDOS=$$G ET1^DIQ(39 9,RCBILL_" ,",.03,"I" )
  19397   "RTN","RCD PENR3",250 ,0)
  19398    . . . . S  RCAMTBL=$ $GET1^DIQ( 361.1,RCEO B_",",2.04 ,"I")
  19399   "RTN","RCD PENR3",251 ,0)
  19400    . . . . S  RCAMTPD=$ $GET1^DIQ( 361.1,RCEO B_",",1.01 ,"I")
  19401   "RTN","RCD PENR3",252 ,0)
  19402    . . . . S  RCDTBILL= $$GET1^DIQ (399,RCBIL L_",",12," I")
  19403   "RTN","RCD PENR3",253 ,0)
  19404    . . . . Q :RCDTBILL= ""   ;cant  calculate  if date f irst print ed is NULL
  19405   "RTN","RCD PENR3",254 ,0)
  19406    . . . . ;
  19407   "RTN","RCD PENR3",255 ,0)
  19408    . . . . S  RCMETHOD= $S($$GET1^ DIQ(344,RC ERA_",",4. 02,"I")="" :"MANUAL", 1:"AUTOPOS T")
  19409   "RTN","RCD PENR3",256 ,0)
  19410    . . . . S  RCPAPER=$ P($G(^RCY( 344.4,RCER A,20)),U,3 )  ; Paper  EOB ERA?
  19411   "RTN","RCD PENR3",257 ,0)
  19412    . . . . ; ERA not a  paper ERA,  is the EO B a Paper  EOB
  19413   "RTN","RCD PENR3",258 ,0)
  19414    . . . . S :'RCPAPER  RCPAPER=$S ($$GET1^DI Q(361.1,RC EOB_",",.1 7,"I")=0:" ERA",1:"PA PER")
  19415   "RTN","RCD PENR3",259 ,0)
  19416    . . . . S  RCEFTTYP= $S(RCPAYTY P=4:"PAPER ",1:"EFT")
  19417   "RTN","RCD PENR3",260 ,0)
  19418    . . . . S  RCTRNTYP= RCPAPER_"/ "_RCEFTTYP
  19419   "RTN","RCD PENR3",261 ,0)
  19420    . . . . S  RCERAIDX= $S(RCTRNTY P="ERA/EFT ":1,RCTRNT YP="ERA/PA PER":2,RCT RNTYP="PAP ER/EFT":3, 1:4)
  19421   "RTN","RCD PENR3",262 ,0)
  19422    . . . . Q :RCERAIDX= 4   ;Paper  Check Pap er EOB not  supported
  19423   "RTN","RCD PENR3",263 ,0)
  19424    . . . . S  RCDATA=RC BILL_U_RCE RA_U_RCIEN _U_RCEOB_U _RCDOS_U_R CAMTBL_U_R CAMTPD_U_R CDTBILL_U_ RCERARCD
  19425   "RTN","RCD PENR3",264 ,0)
  19426    . . . . S  RCDATA=RC DATA_U_RCE FTRCD_U_RC POSTED_U_R CTRACE_U_R CMETHOD_U
  19427   "RTN","RCD PENR3",265 ,0)
  19428    . . . . S  RCDATA=RC DATA_RCTRN TYP_U_RCER ANUM_U_RCD IV_U_RCINS TIN_U_RCEF TPD
  19429   "RTN","RCD PENR3",266 ,0)
  19430    . . . . S  ^TMP("RCD PENR2",$J, "MAIN",RCI NSTIN,RCER AIDX,RCBIL L)=RCDATA
  19431   "RTN","RCD PENR3",267 ,0)
  19432    . . I (RC MSTAT=2),( RCIEN),('$ D(^TMP("RC DPENR2",$J ,"EFT",RCI EN))) D
  19433   "RTN","RCD PENR3",268 ,0)
  19434    . . . S R CTIN=$P(RC EFTDT,U,3)
  19435   "RTN","RCD PENR3",269 ,0)
  19436    . . . S R CINS=$P(RC EFTDT,U,2)
  19437   "RTN","RCD PENR3",270 ,0)
  19438    . . . S R CPAYER=$$G ETARPYR^RC DPENR2(RCT IN,ZZPNAME ) ; find t he AR Paye r IEN
  19439   "RTN","RCD PENR3",271 ,0)
  19440    . . . Q:' RCPAYER                    ; Qui t if Payer /TIN not f ound
  19441   "RTN","RCD PENR3",272 ,0)
  19442    . . . Q:' $$INSCHK^R CDPENR2(RC PAYER)     ; Payer is  not in th e included  list for  the report
  19443   "RTN","RCD PENR3",273 ,0)
  19444    . . . S R CINSTIN=RC INS_"/"_RC TIN
  19445   "RTN","RCD PENR3",274 ,0)
  19446    . . . S R CESUMDT=$G (^TMP("RCD PENR2",$J, "GTOT",3))
  19447   "RTN","RCD PENR3",275 ,0)
  19448    . . . S R CPSUMDT=$G (^TMP("RCD PENR2",$J, "PAYER",RC INSTIN,3))
  19449   "RTN","RCD PENR3",276 ,0)
  19450    . . . S $ P(RCESUMDT ,U,14)=$P( RCESUMDT,U ,14)+1
  19451   "RTN","RCD PENR3",277 ,0)
  19452    . . . S $ P(RCPSUMDT ,U,14)=$P( RCPSUMDT,U ,14)+1
  19453   "RTN","RCD PENR3",278 ,0)
  19454    . . . S $ P(RCESUMDT ,U,15)=$P( RCESUMDT,U ,15)+RCEFT PD
  19455   "RTN","RCD PENR3",279 ,0)
  19456    . . . S $ P(RCPSUMDT ,U,15)=$P( RCPSUMDT,U ,15)+RCEFT PD
  19457   "RTN","RCD PENR3",280 ,0)
  19458    . . . S ^ TMP("RCDPE NR2",$J,"G TOT",3)=RC ESUMDT
  19459   "RTN","RCD PENR3",281 ,0)
  19460    . . . S ^ TMP("RCDPE NR2",$J,"P AYER",RCIN STIN,3)=RC PSUMDT
  19461   "RTN","RCD PENR3",282 ,0)
  19462    Q
  19463   "RTN","RCD PENR3",283 ,0)
  19464    ;
  19465   "RTN","RCD PENR3",284 ,0)
  19466    ;Print th e Grand To tal/Summar y data for  the EFT/E RA Trendin g Report
  19467   "RTN","RCD PENR3",285 ,0)
  19468   PRINTGT(RC TITLE,RCDA TA,RCDISP, RCERAFLG,R CEXCEL) ;
  19469   "RTN","RCD PENR3",286 ,0)
  19470    ;
  19471   "RTN","RCD PENR3",287 ,0)
  19472    ; Undecla red Parame ter(s) - R CRPIEN,RCL INE,RCSTOP
  19473   "RTN","RCD PENR3",288 ,0)
  19474    ;
  19475   "RTN","RCD PENR3",289 ,0)
  19476    N RCCOUNT ,RCBILL,RC PAID,RCPCT ,RCBECT,RC BEDY,RCAVG BE,RCEECT, RCEEDY
  19477   "RTN","RCD PENR3",290 ,0)
  19478    N RCEPCT, RCEPDY,RCA VGEP,RCBPC T,RCBPDY,R CAVGBP,RCB ORDER,RCSC DATA
  19479   "RTN","RCD PENR3",291 ,0)
  19480    N RCC,RCB ,RCAVGEE,R CLTXT,I,RC STRDTA,RCS TRNG,RCDTX T
  19481   "RTN","RCD PENR3",292 ,0)
  19482    ;
  19483   "RTN","RCD PENR3",293 ,0)
  19484    S RCERAFL G=+$G(RCER AFLG),RCDI SP=$G(RCDI SP)
  19485   "RTN","RCD PENR3",294 ,0)
  19486    I $Y>(IOS L-7),RCDIS P D ASK^RC DPEADP(.RC STOP,0) Q: RCSTOP  D  HEADER^RCD PENR2
  19487   "RTN","RCD PENR3",295 ,0)
  19488    ;
  19489   "RTN","RCD PENR3",296 ,0)
  19490    ; Display  report ty pe being d isplayed
  19491   "RTN","RCD PENR3",297 ,0)
  19492    D PRINTHD R^RCDPENR2 (RCTITLE)
  19493   "RTN","RCD PENR3",298 ,0)
  19494    ;
  19495   "RTN","RCD PENR3",299 ,0)
  19496    ; Extract  data from  string an d build st ring for o utput
  19497   "RTN","RCD PENR3",300 ,0)
  19498    S $P(RCSC DATA,U,1)= +$P(RCDATA ,U)
  19499   "RTN","RCD PENR3",301 ,0)
  19500    S RCBILL= +$P(RCDATA ,U,2)
  19501   "RTN","RCD PENR3",302 ,0)
  19502    S RCPAID= +$P(RCDATA ,U,3)
  19503   "RTN","RCD PENR3",303 ,0)
  19504    S $P(RCSC DATA,U,2)= RCBILL
  19505   "RTN","RCD PENR3",304 ,0)
  19506    S $P(RCSC DATA,U,3)= RCPAID
  19507   "RTN","RCD PENR3",305 ,0)
  19508    S $P(RCSC DATA,U,4)= $S(+RCBILL =0:0,1:RCP AID/RCBILL )*100  ; C onvert to  percent fo rmat
  19509   "RTN","RCD PENR3",306 ,0)
  19510    S RCBECT= +$P(RCDATA ,U,4)
  19511   "RTN","RCD PENR3",307 ,0)
  19512    S RCBEDY= +$P(RCDATA ,U,5)
  19513   "RTN","RCD PENR3",308 ,0)
  19514    S $P(RCSC DATA,U,6)= $FN($S(+RC BECT=0:0,1 :RCBEDY/RC BECT),"",0 )
  19515   "RTN","RCD PENR3",309 ,0)
  19516    S RCEECT= +$P(RCDATA ,U,6)
  19517   "RTN","RCD PENR3",310 ,0)
  19518    S RCEEDY= +$P(RCDATA ,U,7)
  19519   "RTN","RCD PENR3",311 ,0)
  19520    S $P(RCSC DATA,U,7)= $FN($S(+RC EECT=0:0,1 :RCEEDY/RC EECT),"",0 )
  19521   "RTN","RCD PENR3",312 ,0)
  19522    S RCEPCT= +$P(RCDATA ,U,8)
  19523   "RTN","RCD PENR3",313 ,0)
  19524    S RCEPDY= +$P(RCDATA ,U,9)
  19525   "RTN","RCD PENR3",314 ,0)
  19526    S $P(RCSC DATA,U,8)= $FN($S(+RC EPCT=0:0,1 :RCEPDY/RC EPCT),"",0 )
  19527   "RTN","RCD PENR3",315 ,0)
  19528    S RCBPCT= +$P(RCDATA ,U,10)
  19529   "RTN","RCD PENR3",316 ,0)
  19530    S RCBPDY= +$P(RCDATA ,U,11)
  19531   "RTN","RCD PENR3",317 ,0)
  19532    S $P(RCSC DATA,U,9)= $FN($S(+RC BPCT=0:0,1 :RCBPDY/RC BPCT),"",0 )
  19533   "RTN","RCD PENR3",318 ,0)
  19534    S $P(RCSC DATA,U,11) =+$P(RCDAT A,U,12)
  19535   "RTN","RCD PENR3",319 ,0)
  19536    S $P(RCSC DATA,U,12) =+$P(RCDAT A,U,13)
  19537   "RTN","RCD PENR3",320 ,0)
  19538    S $P(RCSC DATA,U,14) =+$P(RCDAT A,U,14)
  19539   "RTN","RCD PENR3",321 ,0)
  19540    S $P(RCSC DATA,U,15) =+$P(RCDAT A,U,15)
  19541   "RTN","RCD PENR3",322 ,0)
  19542    S $P(RCSC DATA,U,16) =RCPAID-$P (RCDATA,U, 15)
  19543   "RTN","RCD PENR3",323 ,0)
  19544    F I=1:1:1 6 D  Q:RCS TOP
  19545   "RTN","RCD PENR3",324 ,0)
  19546    . I RCDIS P,($Y>(IOS L-4)) D  Q :RCSTOP
  19547   "RTN","RCD PENR3",325 ,0)
  19548    . .  D AS K^RCDPEADP (.RCSTOP,0 )
  19549   "RTN","RCD PENR3",326 ,0)
  19550    . .  Q:RC STOP
  19551   "RTN","RCD PENR3",327 ,0)
  19552    . .  D HE ADER^RCDPE NR2
  19553   "RTN","RCD PENR3",328 ,0)
  19554    . ;if pri nting from  monthly b ackground  job save i n file and  quit
  19555   "RTN","RCD PENR3",329 ,0)
  19556    . ;Otherw ise print  to screen
  19557   "RTN","RCD PENR3",330 ,0)
  19558    . S (RCLT XT,RCDTXT) =$P($T(GDT XT+I),";;" ,2)
  19559   "RTN","RCD PENR3",331 ,0)
  19560    . I RCTIT LE["PAPER"  D
  19561   "RTN","RCD PENR3",332 ,0)
  19562    . . I (I> 5),(I<9) D       ; co rrect disp lay for li nes 6,7,8, 16
  19563   "RTN","RCD PENR3",333 ,0)
  19564    . . . I ( I=6),RCTIT LE["CHECK"  Q     ;Do nt change  line 6 if  Paper chec k section
  19565   "RTN","RCD PENR3",334 ,0)
  19566    . . . S R CB="EFT",R CC="CHK"   ; Correct  display fo r Paper ch eck sectio n
  19567   "RTN","RCD PENR3",335 ,0)
  19568    . . . I R CTITLE["EO B" S RCB=" ERA",RCC=" EOB"   ;co rrect disp lay for pa per eob
  19569   "RTN","RCD PENR3",336 ,0)
  19570    . . . S R CDTXT=$P(R CLTXT,RCB, 1)_RCC_$P( RCLTXT,RCB ,2)
  19571   "RTN","RCD PENR3",337 ,0)
  19572    . I 'RCDI SP!RCEXCEL  D  Q
  19573   "RTN","RCD PENR3",338 ,0)
  19574    . . S RCS TRDTA=$P(R CSCDATA,U, I)
  19575   "RTN","RCD PENR3",339 ,0)
  19576    . . ;Form at lines:  lines 2&3  are amount s, 4 is a  percentage , remainde r are inte gers.
  19577   "RTN","RCD PENR3",340 ,0)
  19578    . . S RCS TRNG=RCDTX T_"^"_$S(I =4:$J($P(R CSTRDTA,". "),2)_"%", 1:RCSTRDTA )
  19579   "RTN","RCD PENR3",341 ,0)
  19580    . . I 'RC DISP D SAV EDATA^RCDP ENR1(RCSTR NG,RCRPIEN ) Q
  19581   "RTN","RCD PENR3",342 ,0)
  19582    . .;if pr inting in  an EXCEL f ormat, pri nt "^" del imited and  quit
  19583   "RTN","RCD PENR3",343 ,0)
  19584    . . I RCE XCEL W RCS TRNG,! Q
  19585   "RTN","RCD PENR3",344 ,0)
  19586    . ;Output  to screen
  19587   "RTN","RCD PENR3",345 ,0)
  19588    . ;curren cy format
  19589   "RTN","RCD PENR3",346 ,0)
  19590    . I (I=2) !(I=3)!(I= 15) W RCDT XT,?65,$J( $P(RCSCDAT A,U,I),13, 2),! Q
  19591   "RTN","RCD PENR3",347 ,0)
  19592    . ; For t he line it ems that a re percent ages.  Not  using $J  formatting  due to ro unding err ors.
  19593   "RTN","RCD PENR3",348 ,0)
  19594    . I I=4 W  RCDTXT,?6 5,$J($P($P (RCSCDATA, U,I),"."), 12),"%",!  Q
  19595   "RTN","RCD PENR3",349 ,0)
  19596    . ;Otherw ise print  Number for mat
  19597   "RTN","RCD PENR3",350 ,0)
  19598    . I (I=16 ) D  Q
  19599   "RTN","RCD PENR3",351 ,0)
  19600    . . W:RCE RAFLG RCDT XT,?65,$J( $P(RCSCDAT A,U,I),13, 2),!
  19601   "RTN","RCD PENR3",352 ,0)
  19602    . W RCDTX T,?65,$J($ P(RCSCDATA ,U,I),13), !
  19603   "RTN","RCD PENR3",353 ,0)
  19604    I RCSTOP  Q RCSTOP
  19605   "RTN","RCD PENR3",354 ,0)
  19606    I RCDISP  W RCLINE,!  ;Otherwis e print Nu mber forma t
  19607   "RTN","RCD PENR3",355 ,0)
  19608    I 'RCDISP  D SAVEDAT A^RCDPENR1 (RCLINE,RC RPIEN)
  19609   "RTN","RCD PENR3",356 ,0)
  19610    Q RCSTOP
  19611   "RTN","RCD PENR3",357 ,0)
  19612    ;
  19613   "RTN","RCD PENR3",358 ,0)
  19614   GDTXT ;
  19615   "RTN","RCD PENR3",359 ,0)
  19616    ;;TOTAL N UMBER OF C LAIMS
  19617   "RTN","RCD PENR3",360 ,0)
  19618    ;;TOTAL A MOUNT BILL ED
  19619   "RTN","RCD PENR3",361 ,0)
  19620    ;;TOTAL A MOUNT PAID
  19621   "RTN","RCD PENR3",362 ,0)
  19622    ;;PERCENT AGE AMOUNT  PAID: (%T otal Paid/ Billed)
  19623   "RTN","RCD PENR3",363 ,0)
  19624    ;;
  19625   "RTN","RCD PENR3",364 ,0)
  19626    ;;AVG #DA YS BETWEEN  BILLED/ER A
  19627   "RTN","RCD PENR3",365 ,0)
  19628    ;;AVG #DA YS BETWEEN  ERA/EFT
  19629   "RTN","RCD PENR3",366 ,0)
  19630    ;;AVG #DA YS BETWEEN  ERA+EFT R EC'D/PMT P OSTED
  19631   "RTN","RCD PENR3",367 ,0)
  19632    ;;AVG #DA YS BETWEEN  BILLED/PM T POSTED
  19633   "RTN","RCD PENR3",368 ,0)
  19634    ;;
  19635   "RTN","RCD PENR3",369 ,0)
  19636    ;;TOTAL N UMBER OF E RAs
  19637   "RTN","RCD PENR3",370 ,0)
  19638    ;;TOTAL N UMBER OF E EOBs
  19639   "RTN","RCD PENR3",371 ,0)
  19640    ;;
  19641   "RTN","RCD PENR3",372 ,0)
  19642    ;;TOTAL N UMBER OF E FTs
  19643   "RTN","RCD PENR3",373 ,0)
  19644    ;;TOTAL A MOUNT COLL ECTED
  19645   "RTN","RCD PENR3",374 ,0)
  19646    ;;TOTAL D IFFERENCE  BETWEEN ER As (PAID)  - EFTs (CO LLECTED):
  19647   "RTN","RCD PENR3",375 ,0)
  19648    Q
  19649   "RTN","RCD PENR4")
  19650   0^35^B6959 8566
  19651   "RTN","RCD PENR4",1,0 )
  19652   RCDPENR4 ; ALB/SAB -  EPay Natio nal Report s - ERA/EF T Report U tilities ; 12/14/15
  19653   "RTN","RCD PENR4",2,0 )
  19654    ;;4.5;Acc ounts Rece ivable;**3 04,321**;M ar 20, 199 5;Build 46
  19655   "RTN","RCD PENR4",3,0 )
  19656    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  19657   "RTN","RCD PENR4",4,0 )
  19658    ;
  19659   "RTN","RCD PENR4",5,0 )
  19660    ;Read ^DG CR(399) vi a Private  IA 3820
  19661   "RTN","RCD PENR4",6,0 )
  19662    ;Read ^DG (40.8) via  Controlle d IA 417
  19663   "RTN","RCD PENR4",7,0 )
  19664    ;Read ^IB M(361.1) v ia Private  IA 4051
  19665   "RTN","RCD PENR4",8,0 )
  19666    ;Use DIV^ IBJDF2 via  Private I A 3130
  19667   "RTN","RCD PENR4",9,0 )
  19668    Q
  19669   "RTN","RCD PENR4",10, 0)
  19670    ;
  19671   "RTN","RCD PENR4",11, 0)
  19672    ; Retriev e a single  payer fro m the 
  19673   "RTN","RCD PENR4",12, 0)
  19674   SPAY() ;
  19675   "RTN","RCD PENR4",13, 0)
  19676    ;
  19677   "RTN","RCD PENR4",14, 0)
  19678    N DIC,X,Y ,DTOUT,DUO UT,DINUM,D LAYGO,NAME
  19679   "RTN","RCD PENR4",15, 0)
  19680    ;
  19681   "RTN","RCD PENR4",16, 0)
  19682    S DIC="^D IC(36,",DI C(0)="AEQM Z",DIC("S" )="I '$G(^ (5))"
  19683   "RTN","RCD PENR4",17, 0)
  19684    S DIC("?" )="Enter t he Payer n ame to run  this repo rt on."
  19685   "RTN","RCD PENR4",18, 0)
  19686    S DIC("A" )="Select  Payer: "
  19687   "RTN","RCD PENR4",19, 0)
  19688    D ^DIC K  DIC
  19689   "RTN","RCD PENR4",20, 0)
  19690    ; timeout  or user r equested e xit
  19691   "RTN","RCD PENR4",21, 0)
  19692    I $G(DUOU T)!$G(DTOU T) Q -1
  19693   "RTN","RCD PENR4",22, 0)
  19694    ;
  19695   "RTN","RCD PENR4",23, 0)
  19696    ;Return t he name in stead of t he IEN
  19697   "RTN","RCD PENR4",24, 0)
  19698    Q $P(Y,U, 2)
  19699   "RTN","RCD PENR4",25, 0)
  19700    ;
  19701   "RTN","RCD PENR4",26, 0)
  19702    ; - Retur n first/la st day of  month (if  Y=0), prev ious month  (if Y=1),
  19703   "RTN","RCD PENR4",27, 0)
  19704   M1(X,Y) ;
  19705   "RTN","RCD PENR4",28, 0)
  19706    ;   first /last day  of month i n MMDDYYYY  format (i f Y=2), or  date in
  19707   "RTN","RCD PENR4",29, 0)
  19708    ;   exter nal format  (if Y=3).
  19709   "RTN","RCD PENR4",30, 0)
  19710    N X1,X2 S :'$G(X)!(X '?7N.1".". 6N) X=DT S :'$G(Y) Y= 0
  19711   "RTN","RCD PENR4",31, 0)
  19712    S X2="31^ "_$S($E(X, 1,3)#4=0:2 9,1:28)_"^ 31^30^31^3 0^31^31^30 ^31^30^31"
  19713   "RTN","RCD PENR4",32, 0)
  19714    I 'Y S X= $E(X,1,5), X=X_"01"_U _X_$P(X2,U ,+$E(X,4,5 )) Q X
  19715   "RTN","RCD PENR4",33, 0)
  19716    I Y=1 S X =($E(X,1,5 )_"00")-$S (+$E(X,4,5 )=1:8900,1 :100) Q X
  19717   "RTN","RCD PENR4",34, 0)
  19718    I Y=2 D   Q X
  19719   "RTN","RCD PENR4",35, 0)
  19720    .S X1=170 0+$E(X,1,3 ),X=$E(X,4 ,5),X=X_"0 1"_X1_U_X_ $P(X2,U,+X )_X1
  19721   "RTN","RCD PENR4",36, 0)
  19722    S Y=X X ^ DD("DD") S  X=Y
  19723   "RTN","RCD PENR4",37, 0)
  19724    Q X
  19725   "RTN","RCD PENR4",38, 0)
  19726    ;
  19727   "RTN","RCD PENR4",39, 0)
  19728    ; Retriev e the need ed 835 inf ormation.
  19729   "RTN","RCD PENR4",40, 0)
  19730   GETERA(RCS DATE,RCEDA TE,RCRATE)  ;
  19731   "RTN","RCD PENR4",41, 0)
  19732    ;
  19733   "RTN","RCD PENR4",42, 0)
  19734    N RCLDATE ,RCBDIV,RC IEN,RCDATA ,RCLIEN,RC DTLDT,RCEO B,RCBILL,R CTRACE
  19735   "RTN","RCD PENR4",43, 0)
  19736    N RCEFTST ,RCDOS,RCA MTBL,RCAMT PD,RCDTBIL L,RCTIN,RC INS,RCERAR CD,RCINS
  19737   "RTN","RCD PENR4",44, 0)
  19738    N RCPAPER ,RCMETHOD, RCEFTTYP,R CTRNTYP,RC INSTIN,RCE RAIDX,RCEF TST
  19739   "RTN","RCD PENR4",45, 0)
  19740    N RCEFTPD ,RCDIV,RCE RANUM,RCRA TETP,RCPAY ER,RCTRLN, RCTRBD,RCP OSTED
  19741   "RTN","RCD PENR4",46, 0)
  19742    ;
  19743   "RTN","RCD PENR4",47, 0)
  19744    S RCLDATE =RCSDATE-. 001
  19745   "RTN","RCD PENR4",48, 0)
  19746    ;
  19747   "RTN","RCD PENR4",49, 0)
  19748    F  S RCLD ATE=$O(^RC Y(344.4,"A FD",RCLDAT E)) Q:RCLD ATE>RCEDAT E  Q:RCLDA TE=""  D
  19749   "RTN","RCD PENR4",50, 0)
  19750    . S RCIEN =""
  19751   "RTN","RCD PENR4",51, 0)
  19752    . F  S RC IEN=$O(^RC Y(344.4,"A FD",RCLDAT E,RCIEN))  Q:'RCIEN   D  Q
  19753   "RTN","RCD PENR4",52, 0)
  19754    .. S RCDA TA=$G(^RCY (344.4,RCI EN,0))
  19755   "RTN","RCD PENR4",53, 0)
  19756    .. Q:RCDA TA=""          ;No da ta defined  in the tr ansaction
  19757   "RTN","RCD PENR4",54, 0)
  19758    .. Q:'$P( RCDATA,U,1 0)  ;Trans action is  an MRA
  19759   "RTN","RCD PENR4",55, 0)
  19760    .. ;
  19761   "RTN","RCD PENR4",56, 0)
  19762    .. ; Only  calculate  if status  is NULL,  Unmatched  or Matched  to Paper  Check
  19763   "RTN","RCD PENR4",57, 0)
  19764    .. ; GETE FT will ha ve grabbed  there res t
  19765   "RTN","RCD PENR4",58, 0)
  19766    .. S RCEF TST=$P(RCD ATA,U,9)
  19767   "RTN","RCD PENR4",59, 0)
  19768    .. I (RCE FTST=1)!(R CEFTST>2)  Q
  19769   "RTN","RCD PENR4",60, 0)
  19770    .. ;
  19771   "RTN","RCD PENR4",61, 0)
  19772    .. S RCER ARCD=$P($P (RCDATA,U, 7),".",1)   ;get the  date of th e ERA
  19773   "RTN","RCD PENR4",62, 0)
  19774    .. S RCTR ACE=$P(RCD ATA,U,2)               ;get the  trace numb er
  19775   "RTN","RCD PENR4",63, 0)
  19776    .. S RCTR LN=$L(RCTR ACE),RCTRB D=$S(RCTRL N<11:1,1:R CTRLN-9)
  19777   "RTN","RCD PENR4",64, 0)
  19778    .. S RCTR ACE=$E(RCT RACE,RCTRB D,RCTRLN)   ; get the  last 10 d igits of T race #
  19779   "RTN","RCD PENR4",65, 0)
  19780    .. S RCTI N=$P(RCDAT A,U,3)                 ;Payer TI N
  19781   "RTN","RCD PENR4",66, 0)
  19782    .. S RCIN S=$P(RCDAT A,U,6)                 ;Insuranc e free tex t
  19783   "RTN","RCD PENR4",67, 0)
  19784    .. S RCPA YER=$$GETA RPYR^RCDPE NR2(RCTIN, RCINS) ; f ind the AR  Payer IEN  PRCA*4.5* 321
  19785   "RTN","RCD PENR4",68, 0)
  19786    .. Q:'RCP AYER                              ; Quit if  Payer/TIN  not found
  19787   "RTN","RCD PENR4",69, 0)
  19788    .. Q:'$$I NSCHK^RCDP ENR2(RCPAY ER)         ; Payer i s not in t he include d list for  the repor t
  19789   "RTN","RCD PENR4",70, 0)
  19790    .. S RCER ANUM=$P(RC DATA,U,11)             ;# EOBs i n ERA
  19791   "RTN","RCD PENR4",71, 0)
  19792    .. ;
  19793   "RTN","RCD PENR4",72, 0)
  19794    .. S RCLI EN=0
  19795   "RTN","RCD PENR4",73, 0)
  19796    .. F  S R CLIEN=$O(^ RCY(344.4, RCIEN,1,RC LIEN)) Q:R CLIEN=""   D  Q
  19797   "RTN","RCD PENR4",74, 0)
  19798    ... S RCD TLDT=$G(^R CY(344.4,R CIEN,1,RCL IEN,0))    ;Get the E RA Detail
  19799   "RTN","RCD PENR4",75, 0)
  19800    ... Q:RCD TLDT=""               ;Quit if n o ERA Deta il
  19801   "RTN","RCD PENR4",76, 0)
  19802    ... ;
  19803   "RTN","RCD PENR4",77, 0)
  19804    ... S RCE OB=$P(RCDT LDT,U,2)   ;Get the E OB info
  19805   "RTN","RCD PENR4",78, 0)
  19806    ... Q:'RC EOB                   ;quit if n o info
  19807   "RTN","RCD PENR4",79, 0)
  19808    ... ;
  19809   "RTN","RCD PENR4",80, 0)
  19810    ... ; Get  the BILL/ CLAIM IEN  from the # 399 file
  19811   "RTN","RCD PENR4",81, 0)
  19812    ... S RCB ILL=$$BILL IEN^RCDPEN R1(RCEOB)
  19813   "RTN","RCD PENR4",82, 0)
  19814    ... Q:RCB ILL=""     ;EEOB corr upted, qui t
  19815   "RTN","RCD PENR4",83, 0)
  19816    ... ;
  19817   "RTN","RCD PENR4",84, 0)
  19818    ... S RCD IV=$$DIV^I BJDF2(RCBI LL)
  19819   "RTN","RCD PENR4",85, 0)
  19820    ... S RCD IV=$$GET1^ DIQ(40.8,R CDIV_","," .01","E")
  19821   "RTN","RCD PENR4",86, 0)
  19822    ... ;
  19823   "RTN","RCD PENR4",87, 0)
  19824    ... S RCR ATETP=$$GE T1^DIQ(399 ,RCBILL_", ",.07,"I")
  19825   "RTN","RCD PENR4",88, 0)
  19826    ... Q:RCR ATETP'=RCR ATE        ;Not reque sted Rate  Type
  19827   "RTN","RCD PENR4",89, 0)
  19828    ... ;
  19829   "RTN","RCD PENR4",90, 0)
  19830    ... S RCD OS=$$GET1^ DIQ(399,RC BILL_",",. 03,"I")
  19831   "RTN","RCD PENR4",91, 0)
  19832    ... S RCA MTBL=$$GET 1^DIQ(361. 1,RCEOB_", ",2.04,"I" )
  19833   "RTN","RCD PENR4",92, 0)
  19834    ... S RCA MTPD=$$GET 1^DIQ(361. 1,RCEOB_", ",1.01,"I" )
  19835   "RTN","RCD PENR4",93, 0)
  19836    ... S RCD TBILL=$$GE T1^DIQ(399 ,RCBILL_", ",12,"I")
  19837   "RTN","RCD PENR4",94, 0)
  19838    ... Q:RCD TBILL=""    ;cant cal culate if  date first  printed i s NULL
  19839   "RTN","RCD PENR4",95, 0)
  19840    ... S RCM ETHOD=$S($ P($G(^RCY( 344.4,RCIE N,1,RCLIEN ,4)),U)="" :"MANUAL", 1:"AUTOPOS T")
  19841   "RTN","RCD PENR4",96, 0)
  19842    ... S RCP APER=$P($G (^RCY(344. 4,RCLIEN,2 0)),U,3)   ; Paper EO B ERA?
  19843   "RTN","RCD PENR4",97, 0)
  19844    ... ;ERA  not a pape r ERA, is  the EOB a  Paper EOB
  19845   "RTN","RCD PENR4",98, 0)
  19846    ... S:'RC PAPER RCPA PER=$S($$G ET1^DIQ(36 1.1,RCEOB_ ",",.17,"I ")=0:"ERA" ,1:"PAPER" )
  19847   "RTN","RCD PENR4",99, 0)
  19848    ... S RCE FTTYP=$S(R CEFTST=2:" PAPER",1:" EFT")
  19849   "RTN","RCD PENR4",100 ,0)
  19850    ... S RCT RNTYP=RCPA PER_"/"_RC EFTTYP
  19851   "RTN","RCD PENR4",101 ,0)
  19852    ... S RCE RAIDX=$S(R CTRNTYP="E RA/EFT":1, RCTRNTYP=" ERA/PAPER" :2,RCTRNTY P="PAPER/E FT":3,1:4)
  19853   "RTN","RCD PENR4",102 ,0)
  19854    ... Q:RCE RAIDX=4    ;Paper Che ck Paper E OB not sup ported
  19855   "RTN","RCD PENR4",103 ,0)
  19856    ... ;
  19857   "RTN","RCD PENR4",104 ,0)
  19858    ... S RCP OSTED=$P($ G(^RCY(344 .4,RCIEN,7 )),U)
  19859   "RTN","RCD PENR4",105 ,0)
  19860    ... S RCI NSTIN=RCIN S_"/"_RCTI N
  19861   "RTN","RCD PENR4",106 ,0)
  19862    ... ;
  19863   "RTN","RCD PENR4",107 ,0)
  19864    ... S RCD ATA=RCBILL _U_RCIEN_U _U_RCEOB_U _RCDOS_U_R CAMTBL_U_R CAMTPD_U_R CDTBILL_U_ RCERARCD
  19865   "RTN","RCD PENR4",108 ,0)
  19866    ... S RCD ATA=RCDATA _U_U_RCPOS TED_U_RCTR ACE_U_RCME THOD_U
  19867   "RTN","RCD PENR4",109 ,0)
  19868    ... S RCD ATA=RCDATA _RCTRNTYP_ U_RCERANUM _U_RCDIV_U _RCINSTIN_ U
  19869   "RTN","RCD PENR4",110 ,0)
  19870    ... S ^TM P("RCDPENR 2",$J,"MAI N",RCINSTI N,RCERAIDX ,RCBILL)=R CDATA
  19871   "RTN","RCD PENR4",111 ,0)
  19872    ;
  19873   "RTN","RCD PENR4",112 ,0)
  19874    ; Compile  the list  of payers  using the  payer TIN.   The Paye r IENS are  extracted
  19875   "RTN","RCD PENR4",113 ,0)
  19876   TINARY(RCS TART,RCEND ) ;
  19877   "RTN","RCD PENR4",114 ,0)
  19878    ;
  19879   "RTN","RCD PENR4",115 ,0)
  19880    ;RCSTART  - The text  to start  the search  for insur ance compa nies
  19881   "RTN","RCD PENR4",116 ,0)
  19882    ;RCEND -  The text t o end the  search for  insurance  companies ,
  19883   "RTN","RCD PENR4",117 ,0)
  19884    ;
  19885   "RTN","RCD PENR4",118 ,0)
  19886    N RCI,RCJ ,RCFILE
  19887   "RTN","RCD PENR4",119 ,0)
  19888    ;
  19889   "RTN","RCD PENR4",120 ,0)
  19890    ; Clear o ld data ou t
  19891   "RTN","RCD PENR4",121 ,0)
  19892    K ^TMP("R CDPEADP",$ J,"TIN")
  19893   "RTN","RCD PENR4",122 ,0)
  19894    ;
  19895   "RTN","RCD PENR4",123 ,0)
  19896    ; If star t and end  are NULL,  then User  wishes all  payers, s et flag an d quit
  19897   "RTN","RCD PENR4",124 ,0)
  19898    I (RCSTAR T=""),(RCE ND="") S ^ TMP("RCDPE ADP",$J,"T IN","A")=" " Q
  19899   "RTN","RCD PENR4",125 ,0)
  19900    ;
  19901   "RTN","RCD PENR4",126 ,0)
  19902    ; If sing le payer,  find the I EN if it e xists and  post it.
  19903   "RTN","RCD PENR4",127 ,0)
  19904    I RCSTART =RCEND D   Q
  19905   "RTN","RCD PENR4",128 ,0)
  19906    . S RCJ=" "
  19907   "RTN","RCD PENR4",129 ,0)
  19908    . F  S RC J=$O(^RCY( 344.6,"C", RCSTART,RC J)) Q:RCJ= ""  D
  19909   "RTN","RCD PENR4",130 ,0)
  19910    . . S ^TM P("RCDPEAD P",$J,"TIN ",RCJ)=""
  19911   "RTN","RCD PENR4",131 ,0)
  19912    ;
  19913   "RTN","RCD PENR4",132 ,0)
  19914    ; For a r ange of pa yers, loop  through t he Payer n ame list u ntil 
  19915   "RTN","RCD PENR4",133 ,0)
  19916    ; you rea ch the las t payer in  the range  (RCEND)
  19917   "RTN","RCD PENR4",134 ,0)
  19918    ;
  19919   "RTN","RCD PENR4",135 ,0)
  19920    S RCI=$O( ^RCY(344.6 ,"C",RCSTA RT),-1)     ; Set the  starting  location f or the loo p
  19921   "RTN","RCD PENR4",136 ,0)
  19922    ; Loop th rough the  index to f ind the co rrect entr ies.  Appe nd a space
  19923   "RTN","RCD PENR4",137 ,0)
  19924    F  S RCI= $O(^RCY(34 4.6,"C",RC I)) Q:RCI= ""  Q:RCI] RCEND  D
  19925   "RTN","RCD PENR4",138 ,0)
  19926    . S RCJ=" "
  19927   "RTN","RCD PENR4",139 ,0)
  19928    . F  S RC J=$O(^RCY( 344.6,"C", RCI,RCJ))  Q:RCJ=""   D
  19929   "RTN","RCD PENR4",140 ,0)
  19930    . . S ^TM P("RCDPEAD P",$J,"TIN ",RCJ)=""
  19931   "RTN","RCD PENR4",141 ,0)
  19932    ;
  19933   "RTN","RCD PENR4",142 ,0)
  19934    Q
  19935   "RTN","RCD PENR4",143 ,0)
  19936    ;
  19937   "RTN","RCD PENR4",144 ,0)
  19938    ;Look at  both Payer  and Payer  Tin lists  and find  insurance  companies  on both li sts to rep ort on.
  19939   "RTN","RCD PENR4",145 ,0)
  19940   INTRSCT()  ;
  19941   "RTN","RCD PENR4",146 ,0)
  19942    ;
  19943   "RTN","RCD PENR4",147 ,0)
  19944    N RCLPIEN ,RCPYRFLG
  19945   "RTN","RCD PENR4",148 ,0)
  19946    ;
  19947   "RTN","RCD PENR4",149 ,0)
  19948    ; If ALL  payers was  selected  for both t he Payer N ame and Pa yer TIN pa rameters,  set the al l flag and  quit.
  19949   "RTN","RCD PENR4",150 ,0)
  19950    I $D(^TMP ("RCDPEADP ",$J,"TIN" ,"A"))&$D( ^TMP("RCDP EADP",$J," INS","A"))  S ^TMP("R CDPENR2",$ J,"INS","A ")="" Q 1
  19951   "RTN","RCD PENR4",151 ,0)
  19952    ;
  19953   "RTN","RCD PENR4",152 ,0)
  19954    ; If All  payers was  elected f or Payer N ame and Pa yer TIN ha d entries
  19955   "RTN","RCD PENR4",153 ,0)
  19956    ; Loop th rough the  Payer TIN  array and  update val id report  array and  quit
  19957   "RTN","RCD PENR4",154 ,0)
  19958    I $D(^TMP ("RCDPEADP ",$J,"INS" ,"A")) D   Q 1
  19959   "RTN","RCD PENR4",155 ,0)
  19960    . M ^TMP( "RCDPENR2" ,$J,"INS") =^TMP("RCD PEADP",$J, "TIN")
  19961   "RTN","RCD PENR4",156 ,0)
  19962    . K ^TMP( "RCDPEADP" ,$J,"INS", "A")  ;rem ove the al l flag fro m the list
  19963   "RTN","RCD PENR4",157 ,0)
  19964    ;
  19965   "RTN","RCD PENR4",158 ,0)
  19966    ; If All  payers was  elected f or Payer T IN and Pay er NAME ha d entries
  19967   "RTN","RCD PENR4",159 ,0)
  19968    ; Loop th rough the  Payer TIN  array and  update val id report  array and  quit
  19969   "RTN","RCD PENR4",160 ,0)
  19970    I $D(^TMP ("RCDPEADP ",$J,"TIN" ,"A")) D   Q 1
  19971   "RTN","RCD PENR4",161 ,0)
  19972    . M ^TMP( "RCDPENR2" ,$J,"INS") =^TMP("RCD PEADP",$J, "INS")
  19973   "RTN","RCD PENR4",162 ,0)
  19974    . K ^TMP( "RCDPENR2" ,$J,"TIN", "A")  ;rem ove the al l flag fro m the list
  19975   "RTN","RCD PENR4",163 ,0)
  19976    ;
  19977   "RTN","RCD PENR4",164 ,0)
  19978    ; A range  of payers  (1 or mor e) were se lected for  both Paye r lists (N ame and TI N)
  19979   "RTN","RCD PENR4",165 ,0)
  19980    ; Loop th rough the  TIN array  and see if  the Payer  Name IEN  is in the  TIN array.
  19981   "RTN","RCD PENR4",166 ,0)
  19982    ; If so,  update the  valid rep ort array  and quit.
  19983   "RTN","RCD PENR4",167 ,0)
  19984    S RCPYRFL G=0,RCLPIE N=""
  19985   "RTN","RCD PENR4",168 ,0)
  19986    F  S RCLP IEN=$O(^TM P("RCDPEAD P",$J,"TIN ",RCLPIEN) ) Q:'RCLPI EN  D
  19987   "RTN","RCD PENR4",169 ,0)
  19988    . I $D(^T MP("RCDPEA DP",$J,"IN S",RCLPIEN )) D
  19989   "RTN","RCD PENR4",170 ,0)
  19990    . . S ^TM P("RCDPENR 2",$J,"INS ",RCLPIEN) =""
  19991   "RTN","RCD PENR4",171 ,0)
  19992    . . S:'RC PYRFLG RCP YRFLG=1
  19993   "RTN","RCD PENR4",172 ,0)
  19994    ;
  19995   "RTN","RCD PENR4",173 ,0)
  19996    ; No paye rs found
  19997   "RTN","RCD PENR4",174 ,0)
  19998    Q RCPYRFL G
  19999   "RTN","RCD PENR4",175 ,0)
  20000    ;
  20001   "RTN","RCD PENR4",176 ,0)
  20002    ;Print th e data req uested (Vo lume Stati stics Repo rt)
  20003   "RTN","RCD PENR4",177 ,0)
  20004   PRINTRP(RC TITLE,RCDA TA,RCRPIEN ,RCDISP,RC TFLG) ;
  20005   "RTN","RCD PENR4",178 ,0)
  20006    ;
  20007   "RTN","RCD PENR4",179 ,0)
  20008    ;Expected  "^" delim eted forma t of RCDAT A is:
  20009   "RTN","RCD PENR4",180 ,0)
  20010    ; Piece 1  - # 837s
  20011   "RTN","RCD PENR4",181 ,0)
  20012    ; Piece 2  - # NCPDP s
  20013   "RTN","RCD PENR4",182 ,0)
  20014    ; Piece 3  - # 835s
  20015   "RTN","RCD PENR4",183 ,0)
  20016    ; Piece 4  - # 837s  with 835s
  20017   "RTN","RCD PENR4",184 ,0)
  20018    ; Piece 5  - # NCPDP s with 835 s
  20019   "RTN","RCD PENR4",185 ,0)
  20020    ; Piece 6  - Avg day s from 837  send to 8 35 receipt
  20021   "RTN","RCD PENR4",186 ,0)
  20022    ; Piece 7  - Avg day s from NCP DP send to  835 recei pt
  20023   "RTN","RCD PENR4",187 ,0)
  20024    ;
  20025   "RTN","RCD PENR4",188 ,0)
  20026    ; Undecla red parame ters RCLIN E (line of  "-" chara cters) RCS TOP (user  requested  stop flag)
  20027   "RTN","RCD PENR4",189 ,0)
  20028    ;
  20029   "RTN","RCD PENR4",190 ,0)
  20030    N RC835,R CNCPDP,RC8 37,RCNO837 ,RCNNCPDP, RCANCPDP,R CAVG837,RC SPACE,RCST R,RCFLG
  20031   "RTN","RCD PENR4",191 ,0)
  20032    ;
  20033   "RTN","RCD PENR4",192 ,0)
  20034    I $Y>(IOS L-12),RCDI SP D  Q:RC STOP RCFLG
  20035   "RTN","RCD PENR4",193 ,0)
  20036    . D ASK^R CDPEADP(.R CSTOP,0)
  20037   "RTN","RCD PENR4",194 ,0)
  20038    . I RCSTO P S RCFLG= -1 Q
  20039   "RTN","RCD PENR4",195 ,0)
  20040    . D HEADE R^RCDPENR1
  20041   "RTN","RCD PENR4",196 ,0)
  20042    ;
  20043   "RTN","RCD PENR4",197 ,0)
  20044    S RCDISP= $G(RCDISP) ,RCTFLG=$G (RCTFLG)
  20045   "RTN","RCD PENR4",198 ,0)
  20046    I RCDISP, RCTFLG D
  20047   "RTN","RCD PENR4",199 ,0)
  20048    . W !,RCT ITLE,!!
  20049   "RTN","RCD PENR4",200 ,0)
  20050    . W RCLIN E,!
  20051   "RTN","RCD PENR4",201 ,0)
  20052    ;
  20053   "RTN","RCD PENR4",202 ,0)
  20054    S RCSPACE =""
  20055   "RTN","RCD PENR4",203 ,0)
  20056    S $P(RCSP ACE," ",80 )=""
  20057   "RTN","RCD PENR4",204 ,0)
  20058    ;
  20059   "RTN","RCD PENR4",205 ,0)
  20060    I RCDISP  D  Q 1
  20061   "RTN","RCD PENR4",206 ,0)
  20062    . W "NUMB ER OF 837s  TRANSMITT ED TO MEDI CAL PAYERS ",?65,$J(+ $P(RCDATA, U),10)
  20063   "RTN","RCD PENR4",207 ,0)
  20064    . W !,"NU MBER OF NC PDP CLAIMS  TRANSMITT ED TO PHAR MACY PBMs" ,?65,$J(+$ P(RCDATA,U ,2),10)
  20065   "RTN","RCD PENR4",208 ,0)
  20066    . W !,"NU MBER OF 83 5s RECEIVE D FROM MED ICAL PAYER S",?65,$J( +$P(RCDATA ,U,3),10)
  20067   "RTN","RCD PENR4",209 ,0)
  20068    . W !,"NU MBER OF 83 5s RECEIVE D FROM PHA RMACY PBMS ",?65,$J(+ $P(RCDATA, U,4),10)
  20069   "RTN","RCD PENR4",210 ,0)
  20070    . W !,"NU MBER OF 83 7s WITH A  CORRESPOND ING 835 (M RA Exclude d)",?65,$J (+$P(RCDAT A,U,5),10)
  20071   "RTN","RCD PENR4",211 ,0)
  20072    . W !,"NU MBER OF NC PDP CLAIM  WITH A COR RESPONDING  835",?65, $J(+$P(RCD ATA,U,6),1 0)
  20073   "RTN","RCD PENR4",212 ,0)
  20074    . W !,"AV G #DAYS BE TWEEN 837  TRANSMIT A ND 835 REC EIVED",?65 ,$J(+$P(RC DATA,U,7), 10,1)
  20075   "RTN","RCD PENR4",213 ,0)
  20076    . W !,"AV G #DAYS BE TWEEN NCPD P CLAIM TR ANSMIT AND  835 RCVD" ,?65,$J(+$ P(RCDATA,U ,8),10,1)
  20077   "RTN","RCD PENR4",214 ,0)
  20078    . W !,RCL INE,!
  20079   "RTN","RCD PENR4",215 ,0)
  20080    I 'RCDISP  D
  20081   "RTN","RCD PENR4",216 ,0)
  20082    . S RCSTR ="NUMBER O F 837s TRA NSMITTED T O MEDICAL  PAYERS^"_+ $P(RCDATA, U)
  20083   "RTN","RCD PENR4",217 ,0)
  20084    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20085   "RTN","RCD PENR4",218 ,0)
  20086    . S RCSTR ="NUMBER O F NCPDP CL AIMS TRANS MITTED TO  PHARMACY P BMs^"_+$P( RCDATA,U,2 )
  20087   "RTN","RCD PENR4",219 ,0)
  20088    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20089   "RTN","RCD PENR4",220 ,0)
  20090    . S RCSTR ="NUMBER O F 835s REC EIVED FROM  MEDICAL P AYERS^"_+$ P(RCDATA,U ,3)
  20091   "RTN","RCD PENR4",221 ,0)
  20092    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20093   "RTN","RCD PENR4",222 ,0)
  20094    . S RCSTR ="NUMBER O F 835s REC EIVED FROM  PHARMACY  PBMS^"_+$P (RCDATA,U, 4)
  20095   "RTN","RCD PENR4",223 ,0)
  20096    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20097   "RTN","RCD PENR4",224 ,0)
  20098    . S RCSTR ="NUMBER O F 837s WIT H A CORRES PONDING 83 5 (MRA Exc luded)^"_+ $P(RCDATA, U,5)
  20099   "RTN","RCD PENR4",225 ,0)
  20100    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20101   "RTN","RCD PENR4",226 ,0)
  20102    . S RCSTR ="NUMBER O F NCPDP CL AIM WITH A  CORRESPON DING 835^" _+$P(RCDAT A,U,6)
  20103   "RTN","RCD PENR4",227 ,0)
  20104    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20105   "RTN","RCD PENR4",228 ,0)
  20106    . S RCSTR ="AVG #DAY S BETWEEN  837 TRANSM IT AND 835  RECEIVED^ "_+$P(RCDA TA,U,7)
  20107   "RTN","RCD PENR4",229 ,0)
  20108    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20109   "RTN","RCD PENR4",230 ,0)
  20110    . S RCSTR ="AVG #DAY S BETWEEN  NCPDP CLAI M TRANSMIT  AND 835 R CVD^"_+$P( RCDATA,U,8 )
  20111   "RTN","RCD PENR4",231 ,0)
  20112    . D SAVED ATA^RCDPEN R1(RCSTR,R CRPIEN)
  20113   "RTN","RCD PENR4",232 ,0)
  20114    Q 1
  20115   "RTN","RCD PEP")
  20116   0^57^B1476 39796
  20117   "RTN","RCD PEP",1,0)
  20118   RCDPEP ;AI TC/CJE - F LAG PAYERS  AS PHARMA CY/TRICARE  ; 19-APR- 2017
  20119   "RTN","RCD PEP",2,0)
  20120    ;;4.5;Acc ounts Rece ivable;**3 21**;;Buil d 46
  20121   "RTN","RCD PEP",3,0)
  20122    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  20123   "RTN","RCD PEP",4,0)
  20124    ;
  20125   "RTN","RCD PEP",5,0)
  20126   EN(FILTER, DATEFILT)  ; -- main  entry poin t for RCDP E PAYER FL AGS templa te
  20127   "RTN","RCD PEP",6,0)
  20128    ; Input:  FILTER - A =All payer s, P=Pharm acy payers , T=Tricar e payers,
  20129   "RTN","RCD PEP",7,0)
  20130    ; M=Medic al (Neithe r Pharmacy  nor Trica re)
  20131   "RTN","RCD PEP",8,0)
  20132    ; DATEFIL T - Additi onal Filte r by Date.  Has 3 pie ces by '^'
  20133   "RTN","RCD PEP",9,0)
  20134    ;             Piece  1 - 1=Filt er by date , 0=Don't
  20135   "RTN","RCD PEP",10,0)
  20136    ;             Piece  2 - START  - First DA TE ADDED t o include( FM format)
  20137   "RTN","RCD PEP",11,0)
  20138    ;             Piece  3 - END -  Last DATE  ADDED to i nclude (FM  format)
  20139   "RTN","RCD PEP",12,0)
  20140    ; 
  20141   "RTN","RCD PEP",13,0)
  20142    I '$D(DAT EFILT) S D ATEFILT=$$ GETDATE()
  20143   "RTN","RCD PEP",14,0)
  20144    I DATEFIL T=-1 Q  ;
  20145   "RTN","RCD PEP",15,0)
  20146    I '$D(FIL TER) S FIL TER=$$GETF ILT()
  20147   "RTN","RCD PEP",16,0)
  20148    I FILTER= -1 Q  ;
  20149   "RTN","RCD PEP",17,0)
  20150    ;
  20151   "RTN","RCD PEP",18,0)
  20152    D EN^VALM ("RCDPE PA YER FLAGS" )
  20153   "RTN","RCD PEP",19,0)
  20154    Q
  20155   "RTN","RCD PEP",20,0)
  20156    ;
  20157   "RTN","RCD PEP",21,0)
  20158   GETDATE()  ; Ask if t he user wa nts to fil ter by dat e. If so p rompt for  start
  20159   "RTN","RCD PEP",22,0)
  20160              ; and end  dates.
  20161   "RTN","RCD PEP",23,0)
  20162    ; Input:  None
  20163   "RTN","RCD PEP",24,0)
  20164    ; Output:  Return va lue=date f ilter para meters del imiter by  '^'
  20165   "RTN","RCD PEP",25,0)
  20166    ;          Piece 1 -  1=Filter  by date, 0 =Don't
  20167   "RTN","RCD PEP",26,0)
  20168    ;          Piece 2 -  START - F irst DATE  ADDED to i nclude(FM  format)
  20169   "RTN","RCD PEP",27,0)
  20170    ;          Piece 3 -  END - Las t DATE ADD ED to incl ude (FM fo rmat)
  20171   "RTN","RCD PEP",28,0)
  20172    ; 
  20173   "RTN","RCD PEP",29,0)
  20174    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,FD1,FD2, FILTER,OLD DATE,OD1,O D2,RETURN, X,XX,Y
  20175   "RTN","RCD PEP",30,0)
  20176    D FULL^VA LM1
  20177   "RTN","RCD PEP",31,0)
  20178    S VALMBCK ="R"
  20179   "RTN","RCD PEP",32,0)
  20180    S RETURN= "0"
  20181   "RTN","RCD PEP",33,0)
  20182    ;
  20183   "RTN","RCD PEP",34,0)
  20184    S XX=$P($ P($G(XQORN OD(0)),"^" ,4),"=",2)  ; User se lection wi th action
  20185   "RTN","RCD PEP",35,0)
  20186    S FD1=$P( XX,";",2), FD2=$P(XX, ";",3)
  20187   "RTN","RCD PEP",36,0)
  20188    ; See if  user selec tion is va lid (must  be T + or  - N days)
  20189   "RTN","RCD PEP",37,0)
  20190    S FD1=$$P ARSED(FD1)
  20191   "RTN","RCD PEP",38,0)
  20192    S FD2=$$P ARSED(FD2)
  20193   "RTN","RCD PEP",39,0)
  20194    I FD1,FD2  Q 1_"^"_F D1_"^"_FD2
  20195   "RTN","RCD PEP",40,0)
  20196    ;
  20197   "RTN","RCD PEP",41,0)
  20198    S OLDDATE =$G(DATEFI LT,0)
  20199   "RTN","RCD PEP",42,0)
  20200    S OD1=$P( OLDDATE,"^ ",2),OD2=$ P(OLDDATE, "^",3)
  20201   "RTN","RCD PEP",43,0)
  20202    ;
  20203   "RTN","RCD PEP",44,0)
  20204    S DIR(0)= "YA"
  20205   "RTN","RCD PEP",45,0)
  20206    S DIR("A" )="Filter  by Date Ad ded? "
  20207   "RTN","RCD PEP",46,0)
  20208    S DIR("B" )=$S(OLDDA TE:"YES",1 :"NO")
  20209   "RTN","RCD PEP",47,0)
  20210    S DIR("?" ,1)="Enter  'Y' or 'Y es' to fil ter the li st by DATE  ADDED"
  20211   "RTN","RCD PEP",48,0)
  20212    S DIR("?" )="Enter ' N' or 'No'  if you do  not wish  to filter  the list b y date"
  20213   "RTN","RCD PEP",49,0)
  20214    D ^DIR
  20215   "RTN","RCD PEP",50,0)
  20216    I $D(DIRU T) Q -1
  20217   "RTN","RCD PEP",51,0)
  20218    I Y=0 Q 0
  20219   "RTN","RCD PEP",52,0)
  20220    S RETURN= 1
  20221   "RTN","RCD PEP",53,0)
  20222    ;
  20223   "RTN","RCD PEP",54,0)
  20224    ; Prompt  for start  and end da te
  20225   "RTN","RCD PEP",55,0)
  20226    K DIR
  20227   "RTN","RCD PEP",56,0)
  20228    S DIR(0)= "DA^"
  20229   "RTN","RCD PEP",57,0)
  20230    S DIR("A" )="Filter  start date : "
  20231   "RTN","RCD PEP",58,0)
  20232    ; set def ault to ex isting fil ter start  date if it  is set.
  20233   "RTN","RCD PEP",59,0)
  20234    I OD1'=""  S DIR("B" )=$$FMTE^X LFDT(OD1," 2DZ")
  20235   "RTN","RCD PEP",60,0)
  20236    D ^DIR
  20237   "RTN","RCD PEP",61,0)
  20238    I $D(DIRU T) Q -1
  20239   "RTN","RCD PEP",62,0)
  20240    S (FD1,$P (RETURN,"^ ",2))=Y
  20241   "RTN","RCD PEP",63,0)
  20242    ;
  20243   "RTN","RCD PEP",64,0)
  20244    K DIR
  20245   "RTN","RCD PEP",65,0)
  20246    S DIR(0)= "DA^"_FD1_ ":"_DT
  20247   "RTN","RCD PEP",66,0)
  20248    S DIR("A" )="Filter  end date ( "
  20249   "RTN","RCD PEP",67,0)
  20250    S DIR("A" )=DIR("A") _$$FMTE^XL FDT(FD1,"2 DZ")_"-"
  20251   "RTN","RCD PEP",68,0)
  20252    S DIR("A" )=DIR("A") _$$FMTE^XL FDT(DT,"2D Z")_"): "
  20253   "RTN","RCD PEP",69,0)
  20254    ; Set def ault to ex isting fil ter end da te if it i s valid.
  20255   "RTN","RCD PEP",70,0)
  20256    ; (it mus t follow t he selecte d start da te). Other wise defau lt to toda y.
  20257   "RTN","RCD PEP",71,0)
  20258    I OD2'="" ,OD2'<FD1  S DIR("B") =$$FMTE^XL FDT(OD2,"2 DZ")
  20259   "RTN","RCD PEP",72,0)
  20260    I '$D(DIR ("B")) S D IR("B")="T "
  20261   "RTN","RCD PEP",73,0)
  20262    D ^DIR
  20263   "RTN","RCD PEP",74,0)
  20264    I $D(DIRU T) Q -1
  20265   "RTN","RCD PEP",75,0)
  20266    S (FD2,$P (RETURN,"^ ",3))=Y
  20267   "RTN","RCD PEP",76,0)
  20268    ;
  20269   "RTN","RCD PEP",77,0)
  20270    Q RETURN
  20271   "RTN","RCD PEP",78,0)
  20272    ;
  20273   "RTN","RCD PEP",79,0)
  20274   GETFILT()  ; Get filt er on paye r type
  20275   "RTN","RCD PEP",80,0)
  20276    ; Input:  None
  20277   "RTN","RCD PEP",81,0)
  20278    ; Return:  Filter ty pe.
  20279   "RTN","RCD PEP",82,0)
  20280    ;          A=All pay ers, P=Pha rmacy paye rs, T=Tric are payers ,
  20281   "RTN","RCD PEP",83,0)
  20282    ;          M=Medical  (Neither  Pharmacy n or Tricare )
  20283   "RTN","RCD PEP",84,0)
  20284    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,FILTER,X ,XX,Y
  20285   "RTN","RCD PEP",85,0)
  20286    ; Check f or value s pecified o n protocol
  20287   "RTN","RCD PEP",86,0)
  20288    S XX=$P($ P($G(XQORN OD(0)),"^" ,4),"=",2)  ; User se lection wi th action
  20289   "RTN","RCD PEP",87,0)
  20290    S XX=$E(X X)
  20291   "RTN","RCD PEP",88,0)
  20292    I XX'="", "APTM"[XX  Q XX
  20293   "RTN","RCD PEP",89,0)
  20294    ;
  20295   "RTN","RCD PEP",90,0)
  20296    S DIR(0)= "SA^A:All; P:Pharmacy  only;T:Tr icare only ;M:Medical "
  20297   "RTN","RCD PEP",91,0)
  20298    S DIR("A" )="Select  payers to  show. (A)l l, (P)harm acy, (T)ri care, (M)e dical: "
  20299   "RTN","RCD PEP",92,0)
  20300    S DIR("B" )="A"
  20301   "RTN","RCD PEP",93,0)
  20302    S DIR("?" ,1)="Selec t the type  of filter  to determ ine what p ayers will "
  20303   "RTN","RCD PEP",94,0)
  20304    S DIR("?" ,2)="be di splayed as  follows:"
  20305   "RTN","RCD PEP",95,0)
  20306    S DIR("?" ,3)=" A -  All payers  including  those wit h and with out a flag "
  20307   "RTN","RCD PEP",96,0)
  20308    S DIR("?" ,4)=" P -  Only payer s flagged  for Pharma cy"
  20309   "RTN","RCD PEP",97,0)
  20310    S DIR("?" ,5)=" T -  Only payer s flagged  for Tricar e"
  20311   "RTN","RCD PEP",98,0)
  20312    S DIR("?" )=" M - Pa yers NOT f lagged for  Pharmacy  or Tricare "
  20313   "RTN","RCD PEP",99,0)
  20314    ; S DIR(" ??")="RCDP E PAYER FL AGS FILTER "
  20315   "RTN","RCD PEP",100,0 )
  20316    ;
  20317   "RTN","RCD PEP",101,0 )
  20318    D ^DIR
  20319   "RTN","RCD PEP",102,0 )
  20320    I $D(DIRU T) Q -1
  20321   "RTN","RCD PEP",103,0 )
  20322    Q Y
  20323   "RTN","RCD PEP",104,0 )
  20324    ;
  20325   "RTN","RCD PEP",105,0 )
  20326   HDR ; EP -  header co de for RCD PE PAYER F LAGS templ ate
  20327   "RTN","RCD PEP",106,0 )
  20328    ; Input:  Variables  FILTER and  DATEFILT  are assume d to exist
  20329   "RTN","RCD PEP",107,0 )
  20330    ; Output:  ListMan t emplate he ader in VA LMHDR arra y
  20331   "RTN","RCD PEP",108,0 )
  20332    ;
  20333   "RTN","RCD PEP",109,0 )
  20334    ; Show ac tive filte rs in the  template h eader
  20335   "RTN","RCD PEP",110,0 )
  20336    N FTEXT
  20337   "RTN","RCD PEP",111,0 )
  20338    S FTEXT=$ S(FILTER=" P":"Pharma cy",FILTER ="T":"Tric are",FILTE R="M":"Med ical",1:"A ll")
  20339   "RTN","RCD PEP",112,0 )
  20340    S FTEXT=$ $UP^XLFSTR (FTEXT)
  20341   "RTN","RCD PEP",113,0 )
  20342    S FTEXT=F TEXT_" Pay ers"
  20343   "RTN","RCD PEP",114,0 )
  20344    I DATEFIL T D  ;
  20345   "RTN","RCD PEP",115,0 )
  20346    . S FTEXT =FTEXT_" a dded betwe en "
  20347   "RTN","RCD PEP",116,0 )
  20348    . S FTEXT =FTEXT_$$F MTE^XLFDT( $P(DATEFIL T,"^",2)," 2DZ")
  20349   "RTN","RCD PEP",117,0 )
  20350    . S FTEXT =FTEXT_" a nd "_$$FMT E^XLFDT($P (DATEFILT, "^",3),"2D Z")
  20351   "RTN","RCD PEP",118,0 )
  20352    S VALMHDR (1)="Curre nt Filter:  "_FTEXT
  20353   "RTN","RCD PEP",119,0 )
  20354    Q
  20355   "RTN","RCD PEP",120,0 )
  20356    ;
  20357   "RTN","RCD PEP",121,0 )
  20358   INIT ; EP  - init var iables and  list arra y for RCDP E PAYER FL AGS templa te
  20359   "RTN","RCD PEP",122,0 )
  20360    ; Input:  Variables  FILTER and  DATEFILT  are assume d to exist
  20361   "RTN","RCD PEP",123,0 )
  20362    ; Output:  ^TMP("RCD PEP",$J) -  Body line s to displ ay for sel ected temp late
  20363   "RTN","RCD PEP",124,0 )
  20364    ;                                ^TMP($J," RCDPEPIX")  - Index o f displaye d payers
  20365   "RTN","RCD PEP",125,0 )
  20366    S SORT="B "
  20367   "RTN","RCD PEP",126,0 )
  20368    I $G(FILT ER)="" S F ILTER="A"
  20369   "RTN","RCD PEP",127,0 )
  20370    I $G(DATE FILT)="" S  DATEFILT= 0
  20371   "RTN","RCD PEP",128,0 )
  20372    K ^TMP("R CDPEP",$J) ,^TMP($J," RCDPEPIX")
  20373   "RTN","RCD PEP",129,0 )
  20374    D BLD(SOR T,FILTER,D ATEFILT)
  20375   "RTN","RCD PEP",130,0 )
  20376    Q  ;
  20377   "RTN","RCD PEP",131,0 )
  20378    ;
  20379   "RTN","RCD PEP",132,0 )
  20380   BLD(SORT,F ILTER,DATE FILT) ; -  Build the  listman bo dy templat e
  20381   "RTN","RCD PEP",133,0 )
  20382    ; Input:  SORT=Index  on 344.6  to use for  display o rder
  20383   "RTN","RCD PEP",134,0 )
  20384    ; FILTER= Filter bas ed on FLAG  (see EN s ubroutine  for detail )
  20385   "RTN","RCD PEP",135,0 )
  20386    ; DATEFIL T=Filter b ased on da te added.
  20387   "RTN","RCD PEP",136,0 )
  20388    N CNT,LIN E,LN,XX
  20389   "RTN","RCD PEP",137,0 )
  20390    D GETPAY( FILTER,DAT EFILT) ; g et the lis t of payer s sorted a nd filtere d.
  20391   "RTN","RCD PEP",138,0 )
  20392    S VALMBG= 1,VALMCNT= 0,LINE="", CNT=""
  20393   "RTN","RCD PEP",139,0 )
  20394    ;
  20395   "RTN","RCD PEP",140,0 )
  20396    F  D  Q:C NT=""  ;
  20397   "RTN","RCD PEP",141,0 )
  20398    . S CNT=$ O(^TMP($J, "RCDPEPIX" ,CNT))
  20399   "RTN","RCD PEP",142,0 )
  20400    . Q:CNT=" "  ;
  20401   "RTN","RCD PEP",143,0 )
  20402    . S VALMC NT=VALMCNT +1
  20403   "RTN","RCD PEP",144,0 )
  20404    . D BLD1P AY(CNT)
  20405   "RTN","RCD PEP",145,0 )
  20406    Q
  20407   "RTN","RCD PEP",146,0 )
  20408    ;
  20409   "RTN","RCD PEP",147,0 )
  20410   BLD1PAY(PA YCNT) ; (R e)build on e payor li ne into th e listman  array
  20411   "RTN","RCD PEP",148,0 )
  20412    ; Input P AYCNT - Th e sequence  number of  the payer  being bui lt
  20413   "RTN","RCD PEP",149,0 )
  20414    ; Output  - Lines se t into tem plate arra y (^TMP("R CDPEP",$J) ).
  20415   "RTN","RCD PEP",150,0 )
  20416    N DATALN, LINE,XX
  20417   "RTN","RCD PEP",151,0 )
  20418    S LINE=$$ SETSTR^VAL M1(" "_PAY CNT,"",1,4 )
  20419   "RTN","RCD PEP",152,0 )
  20420    S DATALN= ^TMP($J,"R CDPEPIX",P AYCNT)
  20421   "RTN","RCD PEP",153,0 )
  20422    S XX=$P(D ATALN,"^", 2) ; Name
  20423   "RTN","RCD PEP",154,0 )
  20424    S XX=$E(X X,1,55) ;  Truncate n ame to 55  characters  to fit
  20425   "RTN","RCD PEP",155,0 )
  20426    S LINE=$$ SETSTR^VAL M1(XX,LINE ,6,55)
  20427   "RTN","RCD PEP",156,0 )
  20428    S XX=$P(D ATALN,"^", 3) ; Payer  ID
  20429   "RTN","RCD PEP",157,0 )
  20430    S LINE=$$ SETSTR^VAL M1(XX,LINE ,63,10)
  20431   "RTN","RCD PEP",158,0 )
  20432    S XX=$P(D ATALN,"^", 5) ; Phama cy payer f lag
  20433   "RTN","RCD PEP",159,0 )
  20434    S LINE=$$ SETSTR^VAL M1(XX,LINE ,75,2)
  20435   "RTN","RCD PEP",160,0 )
  20436    S XX=$P(D ATALN,"^", 6) ; Trica re payer f lag
  20437   "RTN","RCD PEP",161,0 )
  20438    S LINE=$$ SETSTR^VAL M1(XX,LINE ,79,2)
  20439   "RTN","RCD PEP",162,0 )
  20440    S XX=$P(D ATALN,"^", 4) ; Date  added
  20441   "RTN","RCD PEP",163,0 )
  20442    S LINE=$$ SETSTR^VAL M1(XX,LINE ,82,10)
  20443   "RTN","RCD PEP",164,0 )
  20444    D SET^VAL M10(PAYCNT ,LINE,PAYC NT)
  20445   "RTN","RCD PEP",165,0 )
  20446    Q
  20447   "RTN","RCD PEP",166,0 )
  20448    ;
  20449   "RTN","RCD PEP",167,0 )
  20450   GETPAY(FIL TER,DATEFI LT) ; Retr ieve the p ayors sort ed and fil tered
  20451   "RTN","RCD PEP",168,0 )
  20452    ; Input:  FILTER=Typ e of filte r by Pharm acy or Tri care flag
  20453   "RTN","RCD PEP",169,0 )
  20454    ; DATEFIL T=Filter b y date add ed
  20455   "RTN","RCD PEP",170,0 )
  20456    ; Output:  ^TMP($J," RCDPEPIX") =PIEN^NAME ^PHARMACY_ FLAG^TRICA RE_FLAG
  20457   "RTN","RCD PEP",171,0 )
  20458    N CNT,NAM E,PIEN
  20459   "RTN","RCD PEP",172,0 )
  20460    S CNT=0,N AME=""
  20461   "RTN","RCD PEP",173,0 )
  20462    I $G(SORT )="" S SOR T="B"
  20463   "RTN","RCD PEP",174,0 )
  20464    S FILTER= $G(FILTER)
  20465   "RTN","RCD PEP",175,0 )
  20466    F  D  Q:N AME=""  ;
  20467   "RTN","RCD PEP",176,0 )
  20468    . S NAME= $O(^RCY(34 4.6,SORT,N AME))
  20469   "RTN","RCD PEP",177,0 )
  20470    . Q:NAME= ""
  20471   "RTN","RCD PEP",178,0 )
  20472    . S PIEN= ""
  20473   "RTN","RCD PEP",179,0 )
  20474    . S PIEN= $O(^RCY(34 4.6,SORT,N AME,PIEN))
  20475   "RTN","RCD PEP",180,0 )
  20476    . Q:PIEN= ""
  20477   "RTN","RCD PEP",181,0 )
  20478    . I '$$CH KPAY(PIEN, FILTER,DAT EFILT) Q   ;
  20479   "RTN","RCD PEP",182,0 )
  20480    . S CNT=C NT+1 D GET 1PAY(PIEN, CNT)
  20481   "RTN","RCD PEP",183,0 )
  20482    Q  ;
  20483   "RTN","RCD PEP",184,0 )
  20484    ;
  20485   "RTN","RCD PEP",185,0 )
  20486   GET1PAY(PI EN,CNT) ;  Get the da ta for one  payer and  add it to  the list
  20487   "RTN","RCD PEP",186,0 )
  20488    ; Input:  PIEN - Int ernal entr y number t o file 344 .6
  20489   "RTN","RCD PEP",187,0 )
  20490    ; CNT - I ncremental  counter
  20491   "RTN","RCD PEP",188,0 )
  20492    ; Output:  ^TMP($J," RCDPEPIX", CNT)=A1^A2 ^A3^A4^A5^ A6
  20493   "RTN","RCD PEP",189,0 )
  20494    ; Where A 1=PIEN - T he payer i nternal en try number  on file 3 44.6
  20495   "RTN","RCD PEP",190,0 )
  20496    ;       A 2=NAME - T he payer n ame
  20497   "RTN","RCD PEP",191,0 )
  20498    ;       A 3=PAYER ID  (also kno wn as TIN)
  20499   "RTN","RCD PEP",192,0 )
  20500    ;       A 4=DATE ADD ED
  20501   "RTN","RCD PEP",193,0 )
  20502    ;       A 5=PHARMACY  PAYER - A  Yes/No/Nu ll field t o flag a p ayer as ph armacy
  20503   "RTN","RCD PEP",194,0 )
  20504    ;       A 6=TRICARE  PAYER - A  Yes/No/Nul l filed to  flag a pa yer as tri care
  20505   "RTN","RCD PEP",195,0 )
  20506    ;
  20507   "RTN","RCD PEP",196,0 )
  20508    N DATAOUT ,DATEA,OUT ARR,RCPF,R CTF
  20509   "RTN","RCD PEP",197,0 )
  20510    D GETS^DI Q(344.6,PI EN_",",".0 1;.02;.03; .09;.1","E I","OUTARR ")
  20511   "RTN","RCD PEP",198,0 )
  20512    S DATAOUT =PIEN
  20513   "RTN","RCD PEP",199,0 )
  20514    S DATAOUT =DATAOUT_" ^"_OUTARR( 344.6,PIEN _",",.01," E") ; Name
  20515   "RTN","RCD PEP",200,0 )
  20516    S DATAOUT =DATAOUT_" ^"_OUTARR( 344.6,PIEN _",",.02," E") ; Paye r ID
  20517   "RTN","RCD PEP",201,0 )
  20518    S DATEA=O UTARR(344. 6,PIEN_"," ,.03,"I")  ; Date add ed
  20519   "RTN","RCD PEP",202,0 )
  20520    S DATEA=$ $FMTE^XLFD T(DATEA,"2 DZ") ; For mat as MM/ DD/YY
  20521   "RTN","RCD PEP",203,0 )
  20522    S DATAOUT =DATAOUT_" ^"_DATEA
  20523   "RTN","RCD PEP",204,0 )
  20524    S RCPF=$S (OUTARR(34 4.6,PIEN_" ,",.09,"I" ):"Y",1:"" )
  20525   "RTN","RCD PEP",205,0 )
  20526    S DATAOUT =DATAOUT_" ^"_RCPF ;  Pharmacy p ayer flag
  20527   "RTN","RCD PEP",206,0 )
  20528    S RCTF=$S (OUTARR(34 4.6,PIEN_" ,",.1,"I") :"Y",1:"")
  20529   "RTN","RCD PEP",207,0 )
  20530    S DATAOUT =DATAOUT_" ^"_RCTF ;  Tricare pa yer flag
  20531   "RTN","RCD PEP",208,0 )
  20532    S ^TMP($J ,"RCDPEPIX ",CNT)=DAT AOUT
  20533   "RTN","RCD PEP",209,0 )
  20534    Q
  20535   "RTN","RCD PEP",210,0 )
  20536    ;
  20537   "RTN","RCD PEP",211,0 )
  20538   CHKPAY(PIE N,FILTER,D ATEFILT) ;  Apply sel ected filt ers to a p ayer
  20539   "RTN","RCD PEP",212,0 )
  20540    ; Input:  PIEN - Int ernal entr y number t o file 344 .6
  20541   "RTN","RCD PEP",213,0 )
  20542    ; FILTER  - A=All pa yers, P=Ph armacy pay ers, T=Tri care payer s,
  20543   "RTN","RCD PEP",214,0 )
  20544    ;           M=Medica l (Neither  Pharmacy  nor Tricar e)
  20545   "RTN","RCD PEP",215,0 )
  20546    ; DATEFIL T - Additi onal Filte r by Date.  Has 3 pie ces by '^'
  20547   "RTN","RCD PEP",216,0 )
  20548    ;             Piece  1 - 1=Filt er by date , 0=Don't
  20549   "RTN","RCD PEP",217,0 )
  20550    ;             Piece  2 - START  - First DA TE ADDED t o include( FM format)
  20551   "RTN","RCD PEP",218,0 )
  20552    ;             Piece  3 - END -  Last DATE  ADDED to i nclude (FM  format)
  20553   "RTN","RCD PEP",219,0 )
  20554    ; Returns : 1 if rec ord matche s filter,  otherwise  0.
  20555   "RTN","RCD PEP",220,0 )
  20556    N D1,D2,D C,CREATED, MATCHT,MAT CHD,PFLAG, TFLAG
  20557   "RTN","RCD PEP",221,0 )
  20558    S (MATCHT ,MATCHD)=0
  20559   "RTN","RCD PEP",222,0 )
  20560    I FILTER= "A" D  ;
  20561   "RTN","RCD PEP",223,0 )
  20562    . S MATCH T=1
  20563   "RTN","RCD PEP",224,0 )
  20564    E  D  ;
  20565   "RTN","RCD PEP",225,0 )
  20566    . S PFLAG =$$GET1^DI Q(344.6,PI EN_",",.09 ,"I")
  20567   "RTN","RCD PEP",226,0 )
  20568    . S TFLAG =$$GET1^DI Q(344.6,PI EN_",",.1, "I")
  20569   "RTN","RCD PEP",227,0 )
  20570    . I FILTE R="P",PFLA G S MATCHT =1
  20571   "RTN","RCD PEP",228,0 )
  20572    . I FILTE R="T",TFLA G S MATCHT =1
  20573   "RTN","RCD PEP",229,0 )
  20574    . I FILTE R="M",'PFL AG,'TFLAG  S MATCHT=1
  20575   "RTN","RCD PEP",230,0 )
  20576    ;
  20577   "RTN","RCD PEP",231,0 )
  20578    I 'DATEFI LT D  ;
  20579   "RTN","RCD PEP",232,0 )
  20580    . S MATCH D=1
  20581   "RTN","RCD PEP",233,0 )
  20582    E  D  ;
  20583   "RTN","RCD PEP",234,0 )
  20584    . S D1=$P (DATEFILT, "^",2)
  20585   "RTN","RCD PEP",235,0 )
  20586    . S D2=$P (DATEFILT, "^",3)
  20587   "RTN","RCD PEP",236,0 )
  20588    . S DC=$$ GET1^DIQ(3 44.6,PIEN_ ",",.03,"I ")
  20589   "RTN","RCD PEP",237,0 )
  20590    . S DC=$P (DC,".",1)  ; strip o ff the tim e portion  for compar ison
  20591   "RTN","RCD PEP",238,0 )
  20592    . I DC=D1 !(DC=D2)!( DC>D1&(DC< D2)) S MAT CHD=1
  20593   "RTN","RCD PEP",239,0 )
  20594    ; 
  20595   "RTN","RCD PEP",240,0 )
  20596    Q MATCHT& MATCHD
  20597   "RTN","RCD PEP",241,0 )
  20598    ;
  20599   "RTN","RCD PEP",242,0 )
  20600   CHKKEY() ;  Check sec urity key  for editin g
  20601   "RTN","RCD PEP",243,0 )
  20602    ; Inputs:  None
  20603   "RTN","RCD PEP",244,0 )
  20604    ; Returns : 1 - User  has secur ity key ed iting, 0 -  User does  not have  key
  20605   "RTN","RCD PEP",245,0 )
  20606    ;
  20607   "RTN","RCD PEP",246,0 )
  20608    Q 1 ; Alw ays return  1 since s ecurity ke y is no lo nger requi red.
  20609   "RTN","RCD PEP",247,0 )
  20610    N RET
  20611   "RTN","RCD PEP",248,0 )
  20612    D OWNSKEY ^XUSRB(.RE T,"RCDPE P AYER IDENT IFY")
  20613   "RTN","RCD PEP",249,0 )
  20614    I 'RET(0)  D  ;
  20615   "RTN","RCD PEP",250,0 )
  20616    . W !!,*7 ,">>>> Sec urity key  RCDPE PAYE R IDENTIFY  is requir ed for thi s action"
  20617   "RTN","RCD PEP",251,0 )
  20618    . D PAUSE ^VALM1
  20619   "RTN","RCD PEP",252,0 )
  20620    Q RET(0)
  20621   "RTN","RCD PEP",253,0 )
  20622    ;
  20623   "RTN","RCD PEP",254,0 )
  20624   EDIT ; EP  - for RCDP E PAYER FL AGS EDIT p rotocol
  20625   "RTN","RCD PEP",255,0 )
  20626    ; Input:  None
  20627   "RTN","RCD PEP",256,0 )
  20628    ; Output:  File 344. 6 is updat ed
  20629   "RTN","RCD PEP",257,0 )
  20630    ;          Listman a rray is up dated
  20631   "RTN","RCD PEP",258,0 )
  20632    ;
  20633   "RTN","RCD PEP",259,0 )
  20634    N DA,DIC, DIE,DO,DR, DTOUT,EDT, LINE,PCNT, PIEN,PROMP T,RET,SEL, X,XX,Y
  20635   "RTN","RCD PEP",260,0 )
  20636    S VALMBCK ="R"
  20637   "RTN","RCD PEP",261,0 )
  20638    D FULL^VA LM1
  20639   "RTN","RCD PEP",262,0 )
  20640    ; Check s ecurity ke y for edit  access
  20641   "RTN","RCD PEP",263,0 )
  20642    I '$$CHKK EY() Q  ;
  20643   "RTN","RCD PEP",264,0 )
  20644    ;
  20645   "RTN","RCD PEP",265,0 )
  20646    S PROMPT= "Select a  Payer Entr y to edit:  "
  20647   "RTN","RCD PEP",266,0 )
  20648    S PIEN=$$ SELENT(1,P ROMPT,VALM BG,VALMLST ,.SEL,"RCD PEPIX",0)
  20649   "RTN","RCD PEP",267,0 )
  20650    Q:'PIEN
  20651   "RTN","RCD PEP",268,0 )
  20652    ;
  20653   "RTN","RCD PEP",269,0 )
  20654    ; Lock Ed iting of t his payer  entry
  20655   "RTN","RCD PEP",270,0 )
  20656    L +^RCY(3 44.6,PIEN) :3 I '$T D   Q
  20657   "RTN","RCD PEP",271,0 )
  20658     . W !!,* 7,"Someone  else is e diting thi s Payer En try."
  20659   "RTN","RCD PEP",272,0 )
  20660     . W !,"T ry again l ater."
  20661   "RTN","RCD PEP",273,0 )
  20662     . D PAUS E^VALM1
  20663   "RTN","RCD PEP",274,0 )
  20664    ;
  20665   "RTN","RCD PEP",275,0 )
  20666    ; Let the  user edit  the payer  entry
  20667   "RTN","RCD PEP",276,0 )
  20668    S DIE="^R CY(344.6,"
  20669   "RTN","RCD PEP",277,0 )
  20670    W !!,"Edi t flags fo r payer :  "_$$GET1^D IQ(344.6,P IEN_",",.0 1,"E"),!
  20671   "RTN","RCD PEP",278,0 )
  20672    S DA=PIEN
  20673   "RTN","RCD PEP",279,0 )
  20674    S DR=".09 Pharmacy F lag;.1Tric are Flag"
  20675   "RTN","RCD PEP",280,0 )
  20676    D ^DIE
  20677   "RTN","RCD PEP",281,0 )
  20678    ;
  20679   "RTN","RCD PEP",282,0 )
  20680    L -^RCY(3 44.6,PIEN)
  20681   "RTN","RCD PEP",283,0 )
  20682    D GET1PAY (PIEN,+SEL )
  20683   "RTN","RCD PEP",284,0 )
  20684    D BLD1PAY (+SEL)
  20685   "RTN","RCD PEP",285,0 )
  20686    Q
  20687   "RTN","RCD PEP",286,0 )
  20688    ;
  20689   "RTN","RCD PEP",287,0 )
  20690   SELENT(FUL L,PROMPT,S TART,END,P CNT,WLIST, MULT) ; EP  - Protoco l Action
  20691   "RTN","RCD PEP",288,0 )
  20692    ; Select  Entry(s) t o perform  an action  upon
  20693   "RTN","RCD PEP",289,0 )
  20694    ; Called  from proto cols : RCD PE PAYER F LAGS EDIT
  20695   "RTN","RCD PEP",290,0 )
  20696    ; RCDPE P AYER FLAG  PHARM
  20697   "RTN","RCD PEP",291,0 )
  20698    ; RCDPE P AYER FLAG  TRIC
  20699   "RTN","RCD PEP",292,0 )
  20700    ; Input:  FULL - 1 -  full scre en mode, 0  otherwise
  20701   "RTN","RCD PEP",293,0 )
  20702    ;         PROMPT - P rompt to b e displaye d to the u ser
  20703   "RTN","RCD PEP",294,0 )
  20704    ;         START - St arting sel ection val ue
  20705   "RTN","RCD PEP",295,0 )
  20706    ;         END - Endi ng selecti on value
  20707   "RTN","RCD PEP",296,0 )
  20708    ;         WLIST - Wo rklist, th e user is  selecting  from
  20709   "RTN","RCD PEP",297,0 )
  20710    ;                 Op tional, de faults to  'RCDPEPIX'
  20711   "RTN","RCD PEP",298,0 )
  20712    ;         MULT - 1 t o allow mu ltiple sel ection,
  20713   "RTN","RCD PEP",299,0 )
  20714    ;                0 o r null oth erwise
  20715   "RTN","RCD PEP",300,0 )
  20716    ;                Opt ional defa ults to 0
  20717   "RTN","RCD PEP",301,0 )
  20718    ; Output:  PCNT - Se lected Pho ne Book En try line(s )
  20719   "RTN","RCD PEP",302,0 )
  20720    ; Returns : Selected  Payer Ent ry IEN(s)
  20721   "RTN","RCD PEP",303,0 )
  20722    ;           Error me ssage if i nvalid sel ection
  20723   "RTN","RCD PEP",304,0 )
  20724    N CTR,DIR OUT,DIRUT, DLINE,DTOU T,DUOUT,PI EN,PIENS,X ,XX,Y,YY
  20725   "RTN","RCD PEP",305,0 )
  20726    S:'$D(WLI ST) WLIST= "RCDPEPIX"
  20727   "RTN","RCD PEP",306,0 )
  20728    S:'$D(MUL T) MULT=0
  20729   "RTN","RCD PEP",307,0 )
  20730    D:FULL FU LL^VALM1
  20731   "RTN","RCD PEP",308,0 )
  20732    ; Check f or multi-s election
  20733   "RTN","RCD PEP",309,0 )
  20734    S PCNT=$$ PARSEL($G( XQORNOD(0) ),START,EN D)
  20735   "RTN","RCD PEP",310,0 )
  20736    ;
  20737   "RTN","RCD PEP",311,0 )
  20738    ; W !!!," PCNT="_PCN T_" MULT=" _MULT H 10
  20739   "RTN","RCD PEP",312,0 )
  20740    I 'MULT,$ P(PCNT,"," ,2) D  Q " "                        ; Inval id multi-s election
  20741   "RTN","RCD PEP",313,0 )
  20742    . W !,*7, ">>>> Only  single en try select ion is all owed"
  20743   "RTN","RCD PEP",314,0 )
  20744    . K DIR
  20745   "RTN","RCD PEP",315,0 )
  20746    . D PAUSE ^VALM1
  20747   "RTN","RCD PEP",316,0 )
  20748    S:PCNT=""  PCNT=$$SE LENTRY(PRO MPT,START, END,MULT)
  20749   "RTN","RCD PEP",317,0 )
  20750    Q:'PCNT " "
  20751   "RTN","RCD PEP",318,0 )
  20752    ;
  20753   "RTN","RCD PEP",319,0 )
  20754    S PIENS=" "
  20755   "RTN","RCD PEP",320,0 )
  20756    F CTR=1:1 :$L(PCNT," ,") D
  20757   "RTN","RCD PEP",321,0 )
  20758    . S XX=$P (PCNT,",", CTR)
  20759   "RTN","RCD PEP",322,0 )
  20760    . I XX'=" " D  ;
  20761   "RTN","RCD PEP",323,0 )
  20762    . . S YY= $P(^TMP($J ,WLIST,XX) ,"^",1)
  20763   "RTN","RCD PEP",324,0 )
  20764    . . S PIE NS=$S(PIEN S="":YY,1: PIENS_","_ YY)
  20765   "RTN","RCD PEP",325,0 )
  20766    Q PIENS
  20767   "RTN","RCD PEP",326,0 )
  20768    ;
  20769   "RTN","RCD PEP",327,0 )
  20770   SELENTRY(P ROMPT,STAR T,END,MULT ) ; Select  a line 
  20771   "RTN","RCD PEP",328,0 )
  20772    ; Input:  PROMPT - P rompt to b e displaye d to the u ser
  20773   "RTN","RCD PEP",329,0 )
  20774    ; START -  Start com ment # tha t can be s elected
  20775   "RTN","RCD PEP",330,0 )
  20776    ; END - E nding comm ent # that  can be se lected
  20777   "RTN","RCD PEP",331,0 )
  20778    ; MULT -  1=Multiple  selection  allowed,  0=otherwis e
  20779   "RTN","RCD PEP",332,0 )
  20780    ; Returns : Selected  Comment #  or "" if  not select ed
  20781   "RTN","RCD PEP",333,0 )
  20782    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  20783   "RTN","RCD PEP",334,0 )
  20784    S MULT=+$ G(MULT)
  20785   "RTN","RCD PEP",335,0 )
  20786    S DIR(0)= $S(MULT:"L ",1:"N")_" O^"_START_ ":"_END_": 0"
  20787   "RTN","RCD PEP",336,0 )
  20788    S DIR("A" )=PROMPT
  20789   "RTN","RCD PEP",337,0 )
  20790    D ^DIR K  DIR
  20791   "RTN","RCD PEP",338,0 )
  20792    Q X
  20793   "RTN","RCD PEP",339,0 )
  20794    ;
  20795   "RTN","RCD PEP",340,0 )
  20796   FLAGP ; EP  - for RCD PE PAYER F LAG PHARM  protocol
  20797   "RTN","RCD PEP",341,0 )
  20798    ; Toggle  pharmacy f lag on sel ected line s
  20799   "RTN","RCD PEP",342,0 )
  20800    ; Input:  None
  20801   "RTN","RCD PEP",343,0 )
  20802    ; Output:  None 
  20803   "RTN","RCD PEP",344,0 )
  20804    D FLAG("P ")
  20805   "RTN","RCD PEP",345,0 )
  20806    Q
  20807   "RTN","RCD PEP",346,0 )
  20808    ;
  20809   "RTN","RCD PEP",347,0 )
  20810   FLAGT ; EP  - for RCD PE PAYER F LAG TRIC p rotocol
  20811   "RTN","RCD PEP",348,0 )
  20812    ; Toggle  Tricare fl ag on sele cted lines
  20813   "RTN","RCD PEP",349,0 )
  20814    ; Input:  None
  20815   "RTN","RCD PEP",350,0 )
  20816    ; Output:  None 
  20817   "RTN","RCD PEP",351,0 )
  20818    D FLAG("T ")
  20819   "RTN","RCD PEP",352,0 )
  20820    Q
  20821   "RTN","RCD PEP",353,0 )
  20822    ;
  20823   "RTN","RCD PEP",354,0 )
  20824   FLAG(TYPE)  ; Flag a  list of en tries as P harmacy or  Tricare
  20825   "RTN","RCD PEP",355,0 )
  20826    ; Input:  TYPE - P=P harmacy, T =Tricare
  20827   "RTN","RCD PEP",356,0 )
  20828    ; Output:  File 344. 6 is updat ed
  20829   "RTN","RCD PEP",357,0 )
  20830    ; ListMan  array is  updated
  20831   "RTN","RCD PEP",358,0 )
  20832    N CONTINU E,CTR,FIEL D,PERR,PIE N,PIENS,PR OMPT,SELS, STOP,XX,ZS ,ZZ
  20833   "RTN","RCD PEP",359,0 )
  20834    S FIELD=$ S(TYPE="P" :.09,1:.1)
  20835   "RTN","RCD PEP",360,0 )
  20836    S VALMBCK ="R"
  20837   "RTN","RCD PEP",361,0 )
  20838    ; Check s ecurity ke y for edit  access
  20839   "RTN","RCD PEP",362,0 )
  20840    I '$$CHKK EY() Q  ;
  20841   "RTN","RCD PEP",363,0 )
  20842    ;
  20843   "RTN","RCD PEP",364,0 )
  20844    S PROMPT= "Select li nes on whi ch to togg le "
  20845   "RTN","RCD PEP",365,0 )
  20846    S PROMPT= PROMPT_$S( TYPE="P":" Pharmacy", 1:"Tricare ")_" Flag"
  20847   "RTN","RCD PEP",366,0 )
  20848    S PIENS=$ $SELENT(1, PROMPT,VAL MBG,VALMLS T,.SELS,"R CDPEPIX",1 )
  20849   "RTN","RCD PEP",367,0 )
  20850    Q:PIENS=" "  ;
  20851   "RTN","RCD PEP",368,0 )
  20852    S (PERR,P IEN,ZZ,ZS) =""
  20853   "RTN","RCD PEP",369,0 )
  20854    ;
  20855   "RTN","RCD PEP",370,0 )
  20856    ; First l ock all en tries to b e deleted
  20857   "RTN","RCD PEP",371,0 )
  20858    F CTR=1:1 :$L(PIENS, ",") D
  20859   "RTN","RCD PEP",372,0 )
  20860    . S PIEN= $P(PIENS," ,",CTR) I  PIEN="" Q   ;
  20861   "RTN","RCD PEP",373,0 )
  20862    . S XX=$P (SELS,",", CTR)
  20863   "RTN","RCD PEP",374,0 )
  20864    . ;
  20865   "RTN","RCD PEP",375,0 )
  20866    . ; Lock  this payer  exclusion  for editi ng 
  20867   "RTN","RCD PEP",376,0 )
  20868    . L +^RCY (344.6,PIE N):3 I '$T  D  Q
  20869   "RTN","RCD PEP",377,0 )
  20870    . . S PER R=$S(PERR= "":XX,1:PE RR_","_XX)
  20871   "RTN","RCD PEP",378,0 )
  20872    . S ZZ=$S (ZZ="":PIE N,1:ZZ_"," _PIEN)
  20873   "RTN","RCD PEP",379,0 )
  20874    . S ZS=$S (ZS="":XX, 1:ZS_","_X X)
  20875   "RTN","RCD PEP",380,0 )
  20876    S PIENS=Z Z                                   ; Entry (s) that c an be dele ted
  20877   "RTN","RCD PEP",381,0 )
  20878    S SELS=ZS
  20879   "RTN","RCD PEP",382,0 )
  20880    ;
  20881   "RTN","RCD PEP",383,0 )
  20882    ; Did we  lock at le ast one en try?
  20883   "RTN","RCD PEP",384,0 )
  20884    I PIENS=" " D  Q
  20885   "RTN","RCD PEP",385,0 )
  20886    . W !!,*7 ,"All entr ies are be ing edited  by anothe r user - N othing don e."
  20887   "RTN","RCD PEP",386,0 )
  20888    . D PAUSE ^VALM1
  20889   "RTN","RCD PEP",387,0 )
  20890    ;
  20891   "RTN","RCD PEP",388,0 )
  20892    ; Next wa rn the use r if we co uldn't loc k them all
  20893   "RTN","RCD PEP",389,0 )
  20894    I PERR'=" " D  Q:STO P
  20895   "RTN","RCD PEP",390,0 )
  20896    . S STOP= 0
  20897   "RTN","RCD PEP",391,0 )
  20898    . W !!,*7 ,"Warning:  The follo wing entri es: ",PERR ," are bei ng edited  by another  user"
  20899   "RTN","RCD PEP",392,0 )
  20900    . W !,"Th ese entrie s will not  be update d."
  20901   "RTN","RCD PEP",393,0 )
  20902    . S CONTI NUE=$$ASKY N("Continu e with upd ate of oth er payers? ")
  20903   "RTN","RCD PEP",394,0 )
  20904    . I 'CONT INUE D
  20905   "RTN","RCD PEP",395,0 )
  20906    . . S STO P=1
  20907   "RTN","RCD PEP",396,0 )
  20908    . . F CTR =1:1:$L(PI ENS,",") D
  20909   "RTN","RCD PEP",397,0 )
  20910    . . . S P IEN=$P(PIE NS,",",CTR )
  20911   "RTN","RCD PEP",398,0 )
  20912    . . . L - ^RCY(344.6 ,PIEN)
  20913   "RTN","RCD PEP",399,0 )
  20914    ;
  20915   "RTN","RCD PEP",400,0 )
  20916    ; Flag se lected ent ries
  20917   "RTN","RCD PEP",401,0 )
  20918    F CTR=1:1 :$L(PIENS, ",") D  ;
  20919   "RTN","RCD PEP",402,0 )
  20920    . N FDA,I ENS,OLDVAL ,VALUE
  20921   "RTN","RCD PEP",403,0 )
  20922    . S PIEN= $P(PIENS," ,",CTR)
  20923   "RTN","RCD PEP",404,0 )
  20924    . S IENS= PIEN_","
  20925   "RTN","RCD PEP",405,0 )
  20926    . S SEL=$ P(SELS,"," ,CTR)
  20927   "RTN","RCD PEP",406,0 )
  20928    . S OLDVA L=$$GET1^D IQ(344.6,I ENS,FIELD, "I")
  20929   "RTN","RCD PEP",407,0 )
  20930    . S VALUE =$S('OLDVA L:1,1:0)
  20931   "RTN","RCD PEP",408,0 )
  20932    . S FDA(3 44.6,IENS, FIELD)=VAL UE
  20933   "RTN","RCD PEP",409,0 )
  20934    . L -^RCY (344.6,PIE N)
  20935   "RTN","RCD PEP",410,0 )
  20936    . D FILE^ DIE("","FD A")
  20937   "RTN","RCD PEP",411,0 )
  20938    . D GET1P AY(PIEN,SE L)
  20939   "RTN","RCD PEP",412,0 )
  20940    . D BLD1P AY(SEL)
  20941   "RTN","RCD PEP",413,0 )
  20942    Q
  20943   "RTN","RCD PEP",414,0 )
  20944    ;
  20945   "RTN","RCD PEP",415,0 )
  20946   FILTER ; E P - for RC DPE PAYER  FLAGS FILT ER protoco l
  20947   "RTN","RCD PEP",416,0 )
  20948    ; Change  the filter  from a pr otocol
  20949   "RTN","RCD PEP",417,0 )
  20950    ; Inputs  - None
  20951   "RTN","RCD PEP",418,0 )
  20952    ; Output  - Sets var iables FIL TER and DA TEFILT
  20953   "RTN","RCD PEP",419,0 )
  20954    N NEWDATE ,NEWFILT
  20955   "RTN","RCD PEP",420,0 )
  20956    S VALMBCK ="R"
  20957   "RTN","RCD PEP",421,0 )
  20958    D FULL^VA LM1
  20959   "RTN","RCD PEP",422,0 )
  20960    S NEWDATE =$$GETDATE ()
  20961   "RTN","RCD PEP",423,0 )
  20962    I NEWDATE =-1 Q  ;
  20963   "RTN","RCD PEP",424,0 )
  20964    S NEWFILT =$$GETFILT ()
  20965   "RTN","RCD PEP",425,0 )
  20966    I NEWFILT =-1 Q  ;
  20967   "RTN","RCD PEP",426,0 )
  20968    S DATEFIL T=NEWDATE
  20969   "RTN","RCD PEP",427,0 )
  20970    S FILTER= NEWFILT
  20971   "RTN","RCD PEP",428,0 )
  20972    D HDR,INI T
  20973   "RTN","RCD PEP",429,0 )
  20974    Q
  20975   "RTN","RCD PEP",430,0 )
  20976    ;
  20977   "RTN","RCD PEP",431,0 )
  20978   PARSEL(VAL MNOD,BEG,E ND) ; -- s plit out p re-answers  from user
  20979   "RTN","RCD PEP",432,0 )
  20980    ; Inputs  - VALMNOD=  User inpu t from pro tocol menu  including  pre-answe rs
  20981   "RTN","RCD PEP",433,0 )
  20982    ;           BEG=Begi ning of th e valid nu meric rang e
  20983   "RTN","RCD PEP",434,0 )
  20984    ;           END=End  of the val id numeric  range
  20985   "RTN","RCD PEP",435,0 )
  20986    ; Returns  - Y=Comma  separated  list of v alid numer ic entries
  20987   "RTN","RCD PEP",436,0 )
  20988    ;
  20989   "RTN","RCD PEP",437,0 )
  20990    ; This co de is adap ted from V ALM2. 
  20991   "RTN","RCD PEP",438,0 )
  20992    N I,J,L,X ,Y
  20993   "RTN","RCD PEP",439,0 )
  20994    S Y=$TR($ P($P(VALMN OD,U,4),"= ",2),"/\;  .",",,,,," )
  20995   "RTN","RCD PEP",440,0 )
  20996    ; Run thr ough the l ist, skip  invalid se lections a nd expand  ranges
  20997   "RTN","RCD PEP",441,0 )
  20998    S X=Y,Y=" "
  20999   "RTN","RCD PEP",442,0 )
  21000    F I=1:1 S  J=$P(X,", ",I) Q:J=" "  D  ;
  21001   "RTN","RCD PEP",443,0 )
  21002    . I J'["- ",J>(BEG-1 ),J<(END+1 ) S Y=Y_J_ "," ; sing le valid s election 
  21003   "RTN","RCD PEP",444,0 )
  21004    . I J["-" ,J,J<$P(J, "-",2) D   ;
  21005   "RTN","RCD PEP",445,0 )
  21006    . . F L=+ J:1:+$P(J, "-",2) D   ;
  21007   "RTN","RCD PEP",446,0 )
  21008    . . . I L >(BEG-1),L <(END+1) S  Y=Y_L_","  ; valid s election f rom expand ed range
  21009   "RTN","RCD PEP",447,0 )
  21010    Q Y
  21011   "RTN","RCD PEP",448,0 )
  21012    ;
  21013   "RTN","RCD PEP",449,0 )
  21014   PARSED(X)  ; Take a d ate in ext ernal form at and che ck if it i s a valid
  21015   "RTN","RCD PEP",450,0 )
  21016              ; DATE ADD ED (.03) i n file 344 .6
  21017   "RTN","RCD PEP",451,0 )
  21018    ; Input -  Date in E xternal fo rmat
  21019   "RTN","RCD PEP",452,0 )
  21020    ; Output  - Date in  Fileman fo rmat or 0  if the inp ut was inv alid
  21021   "RTN","RCD PEP",453,0 )
  21022    D VAL^DIE (344.6,"+1 ,",.03,"", X,.RET)
  21023   "RTN","RCD PEP",454,0 )
  21024    Q RET
  21025   "RTN","RCD PEP",455,0 )
  21026    ;
  21027   "RTN","RCD PEP",456,0 )
  21028   ASKYN(PROM PT,DEFAULT ) ; Ask a  yes/no que stion
  21029   "RTN","RCD PEP",457,0 )
  21030    ; Input:  PROMPT - Q uestion to  be asked
  21031   "RTN","RCD PEP",458,0 )
  21032    ;         DEFAULT -  Default An swer
  21033   "RTN","RCD PEP",459,0 )
  21034    ;         1 - YES, 0  - NO
  21035   "RTN","RCD PEP",460,0 )
  21036    ;         Optional,  defaults t o 0
  21037   "RTN","RCD PEP",461,0 )
  21038    ; Returns : 1 - User  answered  YES, 0 oth ewise
  21039   "RTN","RCD PEP",462,0 )
  21040    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  21041   "RTN","RCD PEP",463,0 )
  21042    S:$G(DEFA ULT)'=1 DE FAULT=0
  21043   "RTN","RCD PEP",464,0 )
  21044    S DIR(0)= "Y",DIR("A ")=PROMPT
  21045   "RTN","RCD PEP",465,0 )
  21046    S DIR("B" )=$S(DEFAU LT:"YES",1 :"NO")
  21047   "RTN","RCD PEP",466,0 )
  21048    D ^DIR
  21049   "RTN","RCD PEP",467,0 )
  21050    Q Y
  21051   "RTN","RCD PEP",468,0 )
  21052    ;
  21053   "RTN","RCD PEP",469,0 )
  21054   HELP ; EP  - for temp late RCDPE  PAYER FLA GS help
  21055   "RTN","RCD PEP",470,0 )
  21056    ; Input:  None
  21057   "RTN","RCD PEP",471,0 )
  21058    ; Output:  Text from  a help fr ame displa yed to the  screen
  21059   "RTN","RCD PEP",472,0 )
  21060    N FILTER, DATEFILT,X QH
  21061   "RTN","RCD PEP",473,0 )
  21062    S VALMBCK ="R"
  21063   "RTN","RCD PEP",474,0 )
  21064    S XQH="RC DPE PAYER  FLAGS GENE RAL"
  21065   "RTN","RCD PEP",475,0 )
  21066    D EN^XQH
  21067   "RTN","RCD PEP",476,0 )
  21068    Q
  21069   "RTN","RCD PEP",477,0 )
  21070    ;
  21071   "RTN","RCD PEP",478,0 )
  21072   EXIT ; --  exit code
  21073   "RTN","RCD PEP",479,0 )
  21074    D FULL^VA LM1
  21075   "RTN","RCD PEP",480,0 )
  21076    Q
  21077   "RTN","RCD PESP")
  21078   0^55^B1663 35480
  21079   "RTN","RCD PESP",1,0)
  21080   RCDPESP ;B IRM/EWL -  ePayment L ockbox Sit e Paramete rs Definit ion - File s 344.61 &  344.6 ;No v 19, 2014 @15:26:16
  21081   "RTN","RCD PESP",2,0)
  21082    ;;4.5;Acc ounts Rece ivable;**2 98,304,318 ,321**;Mar  20, 1995; Build 46
  21083   "RTN","RCD PESP",3,0)
  21084    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  21085   "RTN","RCD PESP",4,0)
  21086    ;
  21087   "RTN","RCD PESP",5,0)
  21088   EN ; entry  point for  EDI Lockb ox Paramet ers [RCDPE  EDI LOCKB OX PARAMET ERS]
  21089   "RTN","RCD PESP",6,0)
  21090    N DA,DIC, DIE,DIR,DI RUT,DLAYGO ,DR,DTOUT, DUOUT,X,Y   ; FileMan  variables
  21091   "RTN","RCD PESP",7,0)
  21092    ;
  21093   "RTN","RCD PESP",8,0)
  21094    W !," Upd ate AR Sit e Paramete rs",!
  21095   "RTN","RCD PESP",9,0)
  21096    ;
  21097   "RTN","RCD PESP",10,0 )
  21098    S X="RCDP E AUTO DEC " I '$D(^X USEC(X,DUZ )) W !!,"Y ou do not  hold the " _X_" secur ity key."  Q
  21099   "RTN","RCD PESP",11,0 )
  21100    ; Lock th e paramete r file
  21101   "RTN","RCD PESP",12,0 )
  21102    L +^RCY(3 44.61,1):D ILOCKTM E   D  Q
  21103   "RTN","RCD PESP",13,0 )
  21104    .W !!," A nother use r is curre ntly using  the AR Si te Paramet ers option ."
  21105   "RTN","RCD PESP",14,0 )
  21106    .W !," Pl ease try a gain later ."
  21107   "RTN","RCD PESP",15,0 )
  21108    ;
  21109   "RTN","RCD PESP",16,0 )
  21110    ; Check p arameter f ile
  21111   "RTN","RCD PESP",17,0 )
  21112    N FDAEDI, FDAPAYER,I EN,IENS,RC QUIT
  21113   "RTN","RCD PESP",18,0 )
  21114    ; FDAPAYE R - FDA ar ray for RC DPE AUTO-P AY EXCLUSI ON file (# 344.6)
  21115   "RTN","RCD PESP",19,0 )
  21116    ; FDAEDI  - FDA arra y for RCDP E PARAMETE R file (#3 44.61)
  21117   "RTN","RCD PESP",20,0 )
  21118    ; RCAUDVA L - audit  data for R CDPE PARAM ETER AUDIT  file (#34 4.7)
  21119   "RTN","RCD PESP",21,0 )
  21120    ; IEN - e ntry #
  21121   "RTN","RCD PESP",22,0 )
  21122    ; IENS -  IEN_comma
  21123   "RTN","RCD PESP",23,0 )
  21124    ; RCQUIT  - exit fla g
  21125   "RTN","RCD PESP",24,0 )
  21126    ;
  21127   "RTN","RCD PESP",25,0 )
  21128    ; functio n returns  1 on succe ss
  21129   "RTN","RCD PESP",26,0 )
  21130    S Y=$$EDI LOCK^RCMSI TE  ; Upda te EDI Loc kbox site  parameters
  21131   "RTN","RCD PESP",27,0 )
  21132    I 'Y G AB ORT  ; use r entered  '^'
  21133   "RTN","RCD PESP",28,0 )
  21134    ;
  21135   "RTN","RCD PESP",29,0 )
  21136    ;-------- ---------- ---------- ---------- --------
  21137   "RTN","RCD PESP",30,0 )
  21138    ; prca*4. 5*304
  21139   "RTN","RCD PESP",31,0 )
  21140    ; Enable/ disable au to-auditin g of paper  bills
  21141   "RTN","RCD PESP",32,0 )
  21142    ;-------- ---------- ---------- ---------- --------
  21143   "RTN","RCD PESP",33,0 )
  21144    ;
  21145   "RTN","RCD PESP",34,0 )
  21146    S RCQUIT= 0 W !
  21147   "RTN","RCD PESP",35,0 )
  21148    S RCQUIT= $$AUDIT^RC DPESP5
  21149   "RTN","RCD PESP",36,0 )
  21150    Q:RCQUIT
  21151   "RTN","RCD PESP",37,0 )
  21152    ;
  21153   "RTN","RCD PESP",38,0 )
  21154    W !
  21155   "RTN","RCD PESP",39,0 )
  21156    I '$D(^RC Y(344.61,1 ,0)) W !," There is a  problem w ith the RC DPE PARAME TER file ( #344.61)."  G EXIT
  21157   "RTN","RCD PESP",40,0 )
  21158    ;
  21159   "RTN","RCD PESP",41,0 )
  21160    ;-------- ---------- ---------- ---------- --------
  21161   "RTN","RCD PESP",42,0 )
  21162    ; prca*4. 5*321
  21163   "RTN","RCD PESP",43,0 )
  21164    ; WORKLOA D NOTIFICA TION BULLE TIN DAYS
  21165   "RTN","RCD PESP",44,0 )
  21166    ;-------- ---------- ---------- ---------- --------
  21167   "RTN","RCD PESP",45,0 )
  21168    N BULL S  BULL=$$GET 1^DIQ(344. 61,"1,",.1 ,"I")
  21169   "RTN","RCD PESP",46,0 )
  21170    K DIR S:B ULL]"" DIR ("B")=$$GE T1^DIQ(344 .61,"1,",. 1,"E")
  21171   "RTN","RCD PESP",47,0 )
  21172    S DIR("?" )=$$GET1^D ID(344.61, .1,,"HELP- PROMPT")
  21173   "RTN","RCD PESP",48,0 )
  21174    S DIR("A" )=$$GET1^D ID(344.61, .1,,"TITLE ")
  21175   "RTN","RCD PESP",49,0 )
  21176    S DIR(0)= "344.61,.1 "
  21177   "RTN","RCD PESP",50,0 )
  21178    D ^DIR I  $D(DTOUT)! $D(DUOUT)  G ABORT
  21179   "RTN","RCD PESP",51,0 )
  21180    I BULL'=Y  D  ; upda te and aud it
  21181   "RTN","RCD PESP",52,0 )
  21182    .S RCAUDV AL(1)="344 .61^.1^1^" _Y_U_BULL
  21183   "RTN","RCD PESP",53,0 )
  21184    .S FDAEDI (344.61,"1 ,",.1)=Y D  FILE^DIE( ,"FDAEDI")
  21185   "RTN","RCD PESP",54,0 )
  21186    .D AUDIT( .RCAUDVAL)  K RCAUDVA L
  21187   "RTN","RCD PESP",55,0 )
  21188    W !
  21189   "RTN","RCD PESP",56,0 )
  21190    ;
  21191   "RTN","RCD PESP",57,0 )
  21192    ;-------- ---------- ---------- ---------- --------
  21193   "RTN","RCD PESP",58,0 )
  21194    ; Enable/ disable au to-posting  of medica l claims
  21195   "RTN","RCD PESP",59,0 )
  21196    ;-------- ---------- ---------- ---------- --------
  21197   "RTN","RCD PESP",60,0 )
  21198    N APMC,AP MCT
  21199   "RTN","RCD PESP",61,0 )
  21200    ;PRCA*4.5 *304 Move  from Medic al Auto de crease sec tion below
  21201   "RTN","RCD PESP",62,0 )
  21202    N ADMC  ;  ^DD(344.6 1,.03,0)=" AUTO-DECRE ASE MED EN ABLED^S^0: No;1:Yes;^ 0;3^Q"
  21203   "RTN","RCD PESP",63,0 )
  21204    S ADMC=""   ; Init i n case Med ical Auto  Posting is  turned of f.
  21205   "RTN","RCD PESP",64,0 )
  21206    ;end PRCA *4.5*304
  21207   "RTN","RCD PESP",65,0 )
  21208    ; APMC=AU TO POSTING  OF MEDICA L CLAIMS E NABLED
  21209   "RTN","RCD PESP",66,0 )
  21210    ; APMCT=T EMP APMC
  21211   "RTN","RCD PESP",67,0 )
  21212    S APMCT=$ $GET1^DIQ( 344.61,"1, ",.02,"I") ,APMC=$S(A PMCT=1:"Ye s",APMCT=0 :"No",1:"" )
  21213   "RTN","RCD PESP",68,0 )
  21214    K DIR S D IR(0)="YA" ,DIR("B")= $S(APMC="" :"Y",1:APM C)
  21215   "RTN","RCD PESP",69,0 )
  21216    S DIR("A" )=$$GET1^D ID(344.61, .02,,"TITL E")
  21217   "RTN","RCD PESP",70,0 )
  21218    S DIR("?" )=$$GET1^D ID(344.61, .02,,"HELP -PROMPT")
  21219   "RTN","RCD PESP",71,0 )
  21220    D ^DIR I  $D(DTOUT)! $D(DUOUT)  G ABORT
  21221   "RTN","RCD PESP",72,0 )
  21222    I APMCT'= Y D  ; use r updated  value
  21223   "RTN","RCD PESP",73,0 )
  21224    .S FDAEDI (344.61,"1 ,",.02)=Y  D FILE^DIE (,"FDAEDI" ) K FDAEDI
  21225   "RTN","RCD PESP",74,0 )
  21226    .D NOTIFY ($S(Y=1:"Y es",Y=0:"N o",1:"*mis sing*"))
  21227   "RTN","RCD PESP",75,0 )
  21228    .S RCAUDV AL(1)="344 .61^.02^1^ "_Y_U_('Y)  D AUDIT(. RCAUDVAL)  K RCAUDVAL
  21229   "RTN","RCD PESP",76,0 )
  21230    ;
  21231   "RTN","RCD PESP",77,0 )
  21232    I Y=0 G R XPARMS
  21233   "RTN","RCD PESP",78,0 )
  21234    ;
  21235   "RTN","RCD PESP",79,0 )
  21236    ; Set/Res et payer e xclusions  for medica l claim po sting
  21237   "RTN","RCD PESP",80,0 )
  21238    D EXCLLIS T(1) ; Dis play the e xclusion l ist
  21239   "RTN","RCD PESP",81,0 )
  21240    D SETEXCL (1) I $G(R CQUIT) G A BORT ; SET /RESET exc lusions
  21241   "RTN","RCD PESP",82,0 )
  21242    D EXCLLIS T(1) ; Dis play the e xclusion l ist
  21243   "RTN","RCD PESP",83,0 )
  21244    W !
  21245   "RTN","RCD PESP",84,0 )
  21246    ;
  21247   "RTN","RCD PESP",85,0 )
  21248    ; Enable/ disable au to-decreas e of medic al claims
  21249   "RTN","RCD PESP",86,0 )
  21250    K FDAEDI   ; used fo r FILE^DIE  call
  21251   "RTN","RCD PESP",87,0 )
  21252    S ADMC=$$ GET1^DIQ(3 44.61,"1," ,.03,"I")  ; get curr ent value
  21253   "RTN","RCD PESP",88,0 )
  21254    K DIR S D IR(0)="YA" ,DIR("B")= $S(ADMC="" !(ADMC=1): "Yes",1:"N o")
  21255   "RTN","RCD PESP",89,0 )
  21256    S DIR("A" )=$$GET1^D ID(344.61, .03,,"TITL E")
  21257   "RTN","RCD PESP",90,0 )
  21258    S DIR("?" )=$$GET1^D ID(344.61, .03,,"HELP -PROMPT")
  21259   "RTN","RCD PESP",91,0 )
  21260    D ^DIR I  $D(DTOUT)! $D(DUOUT)  G ABORT
  21261   "RTN","RCD PESP",92,0 )
  21262    ; if user  changed v alue, upda te and aud it
  21263   "RTN","RCD PESP",93,0 )
  21264    S:ADMC'=Y  FDAEDI(34 4.61,"1,", .03)=Y,RCA UDVAL(1)=" 344.61^.03 ^1^"_Y_U_A DMC
  21265   "RTN","RCD PESP",94,0 )
  21266    I Y=0 D   G RXPARMS   ; value s et to No,  update (if  needed),  go to Phar macy param s.
  21267   "RTN","RCD PESP",95,0 )
  21268    . D:$D(FD AEDI) FILE ^DIE(,"FDA EDI"),AUDI T(.RCAUDVA L) K RCAUD VAL
  21269   "RTN","RCD PESP",96,0 )
  21270    ;
  21271   "RTN","RCD PESP",97,0 )
  21272    ; If auto -decrease  (medical f or now) on , ask abou t CARC/RAR C auto-dec rease setu p
  21273   "RTN","RCD PESP",98,0 )
  21274    W !
  21275   "RTN","RCD PESP",99,0 )
  21276    S RCQUIT= 0
  21277   "RTN","RCD PESP",100, 0)
  21278    D CARC^RC DPESP5(.RC QUIT) ; pa ss RCQUIT  by referen ce - PRCA* 4.5*321
  21279   "RTN","RCD PESP",101, 0)
  21280    W !
  21281   "RTN","RCD PESP",102, 0)
  21282    ; If no a ctive CARC s Turn med ical auto- decrease o ff, Then g o to Phara cy params
  21283   "RTN","RCD PESP",103, 0)
  21284    I ($$COUN T(1)=0)&($ $GET1^DIQ( 344.61,"1, ",.03,"I") =1) D  G R XPARMS
  21285   "RTN","RCD PESP",104, 0)
  21286    . K FDAED I,RCAUDVAL
  21287   "RTN","RCD PESP",105, 0)
  21288    . S ADMC= $$GET1^DIQ (344.61,"1 ,",.03,"I" )
  21289   "RTN","RCD PESP",106, 0)
  21290    . S FDAED I(344.61," 1,",.03)=0 ,RCAUDVAL( 1)="344.61 ^.03^1^"_0 _U_ADMC_U_ "SYSTEM di sabled Med ical Auto- decrease,  there are  NO active  CARCs"
  21291   "RTN","RCD PESP",107, 0)
  21292    . D FILE^ DIE(,"FDAE DI"),AUDIT (.RCAUDVAL ) K RCAUDV AL
  21293   "RTN","RCD PESP",108, 0)
  21294    . W !,"** * System h as DISABLE D Medical  Auto-decre ase, there  are NO ac tive CARCs .",!
  21295   "RTN","RCD PESP",109, 0)
  21296    . D PAUSE
  21297   "RTN","RCD PESP",110, 0)
  21298    Q:RCQUIT
  21299   "RTN","RCD PESP",111, 0)
  21300    ;
  21301   "RTN","RCD PESP",112, 0)
  21302    ; Set num ber of day s to wait  before aut o-decrease  amount
  21303   "RTN","RCD PESP",113, 0)
  21304    N ADMT ;  ^DD(344.61 ,.04,0) =  AUTO-DECRE ASE MED DA YS DEFAULT
  21305   "RTN","RCD PESP",114, 0)
  21306    S ADMT=$$ GET1^DIQ(3 44.61,"1," ,.04)
  21307   "RTN","RCD PESP",115, 0)
  21308    K DIR S:A DMT]"" DIR ("B")=ADMT
  21309   "RTN","RCD PESP",116, 0)
  21310    S (DIR("? "),DIR("?? "))=$$GET1 ^DID(344.6 1,.04,,"HE LP-PROMPT" )
  21311   "RTN","RCD PESP",117, 0)
  21312    S DIR(0)= "NA^0:7:0" ,DIR("A")= $$GET1^DID (344.61,.0 4,,"TITLE" )
  21313   "RTN","RCD PESP",118, 0)
  21314    D ^DIR I  $D(DTOUT)! $D(DUOUT)  G ABORT
  21315   "RTN","RCD PESP",119, 0)
  21316    S:ADMT'=Y  FDAEDI(34 4.61,"1,", .04)=Y,RCA UDVAL(2)=" 344.61^.04 ^1^"_Y_U_A DMT
  21317   "RTN","RCD PESP",120, 0)
  21318    ;
  21319   "RTN","RCD PESP",121, 0)
  21320    ; PRCA*4. 5*304 - re moved gene ral auto-d ecrease am ount in fa vor of aut o-decrease  by CARC
  21321   "RTN","RCD PESP",122, 0)
  21322    ;
  21323   "RTN","RCD PESP",123, 0)
  21324    ; file ch anges to m edical aut o-post and  auto-decr ease param eters
  21325   "RTN","RCD PESP",124, 0)
  21326    D FILE^DI E(,"FDAEDI ")
  21327   "RTN","RCD PESP",125, 0)
  21328    D:$D(RCAU DVAL) AUDI T(.RCAUDVA L)
  21329   "RTN","RCD PESP",126, 0)
  21330    K RCAUDVA L
  21331   "RTN","RCD PESP",127, 0)
  21332    ;
  21333   "RTN","RCD PESP",128, 0)
  21334    ; Set/Res et payer e xclusions  for medica l claim de crease
  21335   "RTN","RCD PESP",129, 0)
  21336    D EXCLLIS T(2) ; Dis play the e xclusion l ist
  21337   "RTN","RCD PESP",130, 0)
  21338    D SETEXCL (2) I $G(R CQUIT) G A BORT ; SET /RESET exc lusions
  21339   "RTN","RCD PESP",131, 0)
  21340    D EXCLLIS T(2) ; Dis play the e xclusion l ist
  21341   "RTN","RCD PESP",132, 0)
  21342    W !
  21343   "RTN","RCD PESP",133, 0)
  21344    ;
  21345   "RTN","RCD PESP",134, 0)
  21346    ; code fa lls throug h
  21347   "RTN","RCD PESP",135, 0)
  21348    ;
  21349   "RTN","RCD PESP",136, 0)
  21350   RXPARMS ;  branch her e from abo ve
  21351   "RTN","RCD PESP",137, 0)
  21352    ;-------- ---------- ---------- ---------- --------
  21353   "RTN","RCD PESP",138, 0)
  21354    ; Enable/ disable au to-posting  of pharma cy claims
  21355   "RTN","RCD PESP",139, 0)
  21356    ;-------- ---------- ---------- ---------- --------
  21357   "RTN","RCD PESP",140, 0)
  21358    N APPC,AP PCT
  21359   "RTN","RCD PESP",141, 0)
  21360    ; APPC=AU TO POSTING  OF PHARMA CY CLAIMS  ENABLED
  21361   "RTN","RCD PESP",142, 0)
  21362    ; APPCT=T EMP APMC
  21363   "RTN","RCD PESP",143, 0)
  21364    S APPCT=$ $GET1^DIQ( 344.61,"1, ",1.01,"I" ),APPC=$S( APPCT=1:"Y es",APPCT= 0:"No",1:" ")
  21365   "RTN","RCD PESP",144, 0)
  21366    K DIR S D IR(0)="YA" ,DIR("B")= $S(APPC="" :"Yes",1:A PPC)
  21367   "RTN","RCD PESP",145, 0)
  21368    S DIR("A" )=$$GET1^D ID(344.61, 1.01,,"TIT LE")
  21369   "RTN","RCD PESP",146, 0)
  21370    S DIR("?" )=$$GET1^D ID(344.61, 1.01,,"HEL P-PROMPT")
  21371   "RTN","RCD PESP",147, 0)
  21372    D ^DIR I  $D(DTOUT)! $D(DUOUT)  G ABORT
  21373   "RTN","RCD PESP",148, 0)
  21374    I APPCT'= Y D  ; use r updated  value
  21375   "RTN","RCD PESP",149, 0)
  21376    .S FDAEDI (344.61,"1 ,",1.01)=Y  D FILE^DI E(,"FDAEDI ") K FDAED I
  21377   "RTN","RCD PESP",150, 0)
  21378    .D NOTIFY ($S(Y=1:"Y es",Y=0:"N o",1:"*mis sing*"),1)
  21379   "RTN","RCD PESP",151, 0)
  21380    .S RCAUDV AL(1)="344 .61^1.01^1 ^"_Y_U_('Y ) D AUDIT( .RCAUDVAL)  K RCAUDVA L
  21381   "RTN","RCD PESP",152, 0)
  21382    ;
  21383   "RTN","RCD PESP",153, 0)
  21384    ; If yes,  set/Reset  payer exc lusions fo r pharmacy  claims po sting
  21385   "RTN","RCD PESP",154, 0)
  21386    I Y=1 D   G:$G(RCQUI T)=1 ABORT
  21387   "RTN","RCD PESP",155, 0)
  21388    . D EXCLL IST(3) ; D isplay the  exclusion  list
  21389   "RTN","RCD PESP",156, 0)
  21390    . D SETEX CL(3) Q:$G (RCQUIT)   ; SET/RESE T exclusio ns
  21391   "RTN","RCD PESP",157, 0)
  21392    . D EXCLL IST(3) ; D isplay the  exclusion  list
  21393   "RTN","RCD PESP",158, 0)
  21394    . W !
  21395   "RTN","RCD PESP",159, 0)
  21396    . ;
  21397   "RTN","RCD PESP",160, 0)
  21398    ;
  21399   "RTN","RCD PESP",161, 0)
  21400    ; Show Ph armacy pro mpt but do n't allow  change
  21401   "RTN","RCD PESP",162, 0)
  21402    D:$$GET1^ DIQ(344.61 ,"1,",1.01 ,"I")=1  G :$G(RCQUIT )=1 ABORT
  21403   "RTN","RCD PESP",163, 0)
  21404    . W !,"EN ABLE AUTO- DECREASE O F PHARMACY  CLAIMS (Y /N): NO//"
  21405   "RTN","RCD PESP",164, 0)
  21406    . W !,"    Determine s if auto- decrease o f pharmacy  claims ar e enabled  for this s ite."
  21407   "RTN","RCD PESP",165, 0)
  21408    . W !,"    NOTE:  No t editable  and set t o Disabled  until fur ther notic e.",!
  21409   "RTN","RCD PESP",166, 0)
  21410    . K DIR S  DIR(0)="E A"
  21411   "RTN","RCD PESP",167, 0)
  21412    . S DIR(" A")="Press  Enter to  continue:  "
  21413   "RTN","RCD PESP",168, 0)
  21414    . D ^DIR  I $D(DTOUT )!$D(DUOUT ) S RCQUIT =1
  21415   "RTN","RCD PESP",169, 0)
  21416    . W !
  21417   "RTN","RCD PESP",170, 0)
  21418    ;
  21419   "RTN","RCD PESP",171, 0)
  21420    ; set MED ICAL EFT O VERRIDE ^D D(344.61,. 06,0) = ME DICAL EFT  POST PREVE NT DAYS
  21421   "RTN","RCD PESP",172, 0)
  21422    N MEO S M EO=$$GET1^ DIQ(344.61 ,"1,",.06)
  21423   "RTN","RCD PESP",173, 0)
  21424    K DIR S:M EO]"" DIR( "B")=MEO
  21425   "RTN","RCD PESP",174, 0)
  21426    S DIR("?" )=$$GET1^D ID(344.61, .06,,"HELP -PROMPT")
  21427   "RTN","RCD PESP",175, 0)
  21428    S DIR(0)= "NA^14:60: 0",DIR("A" )=$$GET1^D ID(344.61, .06,,"TITL E") ; PRCA *4.5*321 C hange max  from 99 to  60
  21429   "RTN","RCD PESP",176, 0)
  21430    D ^DIR I  $D(DTOUT)! $D(DUOUT)  G ABORT
  21431   "RTN","RCD PESP",177, 0)
  21432    I MEO'=Y  D  ; updat e and audi t
  21433   "RTN","RCD PESP",178, 0)
  21434    .S RCAUDV AL(1)="344 .61^.06^1^ "_Y_U_MEO
  21435   "RTN","RCD PESP",179, 0)
  21436    .S FDAEDI (344.61,"1 ,",.06)=Y  D FILE^DIE (,"FDAEDI" )
  21437   "RTN","RCD PESP",180, 0)
  21438    .D AUDIT( .RCAUDVAL)  K RCAUDVA L
  21439   "RTN","RCD PESP",181, 0)
  21440    ;
  21441   "RTN","RCD PESP",182, 0)
  21442    ;-------- ---------- ---------- ---------- --------
  21443   "RTN","RCD PESP",183, 0)
  21444    ; Set PHA RMACY EFT  OVERRIDE
  21445   "RTN","RCD PESP",184, 0)
  21446    ;-------- ---------- ---------- ---------- --------
  21447   "RTN","RCD PESP",185, 0)
  21448    N PEO S P EO=$$GET1^ DIQ(344.61 ,"1,",.07)
  21449   "RTN","RCD PESP",186, 0)
  21450    K DIR S:P EO]"" DIR( "B")=PEO
  21451   "RTN","RCD PESP",187, 0)
  21452    S DIR("?" )=$$GET1^D ID(344.61, .07,,"HELP -PROMPT")
  21453   "RTN","RCD PESP",188, 0)
  21454    S DIR(0)= "NA^21:365 :0",DIR("A ")=$$GET1^ DID(344.61 ,.07,,"TIT LE") ; PRC A*4.5*321  Change max  from 999  to 365
  21455   "RTN","RCD PESP",189, 0)
  21456    D ^DIR I  $D(DTOUT)! $D(DUOUT)  G ABORT
  21457   "RTN","RCD PESP",190, 0)
  21458    I PEO'=Y  D  ; updat e and audi t
  21459   "RTN","RCD PESP",191, 0)
  21460    .S RCAUDV AL(1)="344 .61^.07^1^ "_Y_U_PEO
  21461   "RTN","RCD PESP",192, 0)
  21462    .S FDAEDI (344.61,"1 ,",.07)=Y  D FILE^DIE (,"FDAEDI" )
  21463   "RTN","RCD PESP",193, 0)
  21464    .D AUDIT( .RCAUDVAL)  K RCAUDVA L
  21465   "RTN","RCD PESP",194, 0)
  21466    ;
  21467   "RTN","RCD PESP",195, 0)
  21468    G EXIT
  21469   "RTN","RCD PESP",196, 0)
  21470    ;
  21471   "RTN","RCD PESP",197, 0)
  21472   ABORT ; Ca lled when  user enter s a '^' or  times out
  21473   "RTN","RCD PESP",198, 0)
  21474    ; fall th rough to E XIT
  21475   "RTN","RCD PESP",199, 0)
  21476    ;
  21477   "RTN","RCD PESP",200, 0)
  21478   EXIT ; Unl ock, ask u ser to pre ss return,  exit
  21479   "RTN","RCD PESP",201, 0)
  21480    L -^RCY(3 44.61,1)
  21481   "RTN","RCD PESP",202, 0)
  21482    D PAUSE
  21483   "RTN","RCD PESP",203, 0)
  21484    Q
  21485   "RTN","RCD PESP",204, 0)
  21486    ;
  21487   "RTN","RCD PESP",205, 0)
  21488   PAUSE ; pr ompt user  to press r eturn
  21489   "RTN","RCD PESP",206, 0)
  21490    W ! N DIR
  21491   "RTN","RCD PESP",207, 0)
  21492    S DIR("T" )=3,DIR(0) ="E",DIR(" A")="Press  RETURN to  continue"  D ^DIR
  21493   "RTN","RCD PESP",208, 0)
  21494    Q
  21495   "RTN","RCD PESP",209, 0)
  21496    ;
  21497   "RTN","RCD PESP",210, 0)
  21498   COUNT(TYPE ) ; Count  active CAR Cs in file  344.62 (R CDPE CARC- RARC AUTO  DEC)
  21499   "RTN","RCD PESP",211, 0)
  21500    N NUM,I
  21501   "RTN","RCD PESP",212, 0)
  21502    I (TYPE'= 1)&(TYPE'= 0) Q 0  ;  If TYPE is  not activ e (1) or i n-active ( 0) quit wi th count =  0
  21503   "RTN","RCD PESP",213, 0)
  21504    S NUM=0
  21505   "RTN","RCD PESP",214, 0)
  21506    S I="" F   S I=$O(^R CY(344.62, "ACTV",TYP E,I)) Q:I= ""  S NUM= NUM+1
  21507   "RTN","RCD PESP",215, 0)
  21508    Q NUM
  21509   "RTN","RCD PESP",216, 0)
  21510    ;
  21511   "RTN","RCD PESP",217, 0)
  21512   EXCLLIST(T YP) ; CHOI CE determi nes which  exclusions  to list
  21513   "RTN","RCD PESP",218, 0)
  21514    ; TYP - T YPE OF EXL USION - RE QUIRED
  21515   "RTN","RCD PESP",219, 0)
  21516    ; IX - wh ich index  to use
  21517   "RTN","RCD PESP",220, 0)
  21518    ; IEN - p oints to a n excluded  payer for  the selec ted choice
  21519   "RTN","RCD PESP",221, 0)
  21520    Q:'("^1^2 ^3^"[(U_$G (TYP)_U))   ; one or  two only
  21521   "RTN","RCD PESP",222, 0)
  21522    N IX,IEN, CT,LIST S  (IEN,CT)=0  W !
  21523   "RTN","RCD PESP",223, 0)
  21524    S IX=$S(T YP=1:"EXMD POST",TYP= 2:"EXMDDEC R",TYP=3:" EXRXPOST", 1:"") ;,TY P=4:"EXRXD ECR",1:"")
  21525   "RTN","RCD PESP",224, 0)
  21526    S LIST=$S (TYP=1:"", TYP=3:"",1 :"** Addit ional ")_" Payers exc luded from  "_$S(TYP= 1:"Medical  Auto-Post ing:",TYP= 3:"Pharmac y Auto-Pos ting",1:"M edical Aut o-Decrease :")
  21527   "RTN","RCD PESP",225, 0)
  21528    F  S IEN= $O(^RCY(34 4.6,IX,1,I EN)) Q:'IE N  D
  21529   "RTN","RCD PESP",226, 0)
  21530    . S CT=CT +1
  21531   "RTN","RCD PESP",227, 0)
  21532    . W:CT=1  !,LIST
  21533   "RTN","RCD PESP",228, 0)
  21534    . W !,"   "_$P(^RCY( 344.6,IEN, 0),U,1)_"  "_$P(^RCY( 344.6,IEN, 0),U,2)
  21535   "RTN","RCD PESP",229, 0)
  21536    ;
  21537   "RTN","RCD PESP",230, 0)
  21538    I TYP=2 W  !,"All pa yers exclu ded from A uto-Postin g are also  excluded  from Auto- Decrease."
  21539   "RTN","RCD PESP",231, 0)
  21540    W:CT=0 !, "   No "_$ S(TYP=2:"a dditional  ",1:"")_"p ayers excl uded from  "_$S(TYP=1 :"Medical  Auto-Posti ng:",TYP=3 :"Pharmacy  Auto-Post ing",1:"Me dical Auto -Decrease: ")
  21541   "RTN","RCD PESP",232, 0)
  21542    ; if list  is for au to-decreas e and ther e are excl usions wri te a messa ge
  21543   "RTN","RCD PESP",233, 0)
  21544    Q
  21545   "RTN","RCD PESP",234, 0)
  21546    ;
  21547   "RTN","RCD PESP",235, 0)
  21548   SETEXCL(TY P) ; LOOP  FOR SETTIN G PAYER EX CLUSIONS
  21549   "RTN","RCD PESP",236, 0)
  21550    ; TYP - T YPE OF EXL USION - RE QUIRED
  21551   "RTN","RCD PESP",237, 0)
  21552    N FDAPAYE R,IEN,DONE ,CT,X,Y,FL D,RTYP,DIC ,DIR,RCAUD VAL,PREC,C MT
  21553   "RTN","RCD PESP",238, 0)
  21554    ; FDAPAYE R - FDA FO R FILE 344 .6
  21555   "RTN","RCD PESP",239, 0)
  21556    ; FLD - F IELD BEING  MODIFIED
  21557   "RTN","RCD PESP",240, 0)
  21558    ; RTYP -  STRING REP RESENTING  FIELD
  21559   "RTN","RCD PESP",241, 0)
  21560    ; DONE -  INDICATOR  TO LEAVE L OOP
  21561   "RTN","RCD PESP",242, 0)
  21562    ; RCAUDVA L - ARRAY  FOR AUDITI NG
  21563   "RTN","RCD PESP",243, 0)
  21564    ; PREC -  HOLDER FOR  Y(0) AFTE R ^DIC CAL L
  21565   "RTN","RCD PESP",244, 0)
  21566    ;          FILE NUMB ER^FIELD N UMBER^IEN^ NEW VALUE^ OLD VALUE, COMMENT
  21567   "RTN","RCD PESP",245, 0)
  21568    I $G(TYP) =1 S FLD=. 06,CMT=1,R TYP="MEDIC AL CLAIMS  POSTING"
  21569   "RTN","RCD PESP",246, 0)
  21570    I $G(TYP) =2 S FLD=. 07,CMT=2,R TYP="MEDIC AL CLAIMS  DECREASE"
  21571   "RTN","RCD PESP",247, 0)
  21572    I $G(TYP) =3 S FLD=. 08,CMT=3,R TYP="PHARM ACY CLAIMS  POSTING"
  21573   "RTN","RCD PESP",248, 0)
  21574    I '$D(FLD ) Q 
  21575   "RTN","RCD PESP",249, 0)
  21576    ;
  21577   "RTN","RCD PESP",250, 0)
  21578    W !!,"Sel ect a Paye r to add o r remove f rom the ex clusion li st.",!
  21579   "RTN","RCD PESP",251, 0)
  21580    S (RCQUIT ,CT,DONE)= 0 F  Q:DON E!RCQUIT   D
  21581   "RTN","RCD PESP",252, 0)
  21582    . S DIC=" ^RCY(344.6 ,",DIC(0)= "AEMQZ",DI C("A")="Pa yer: " D ^ DIC I X="^ " S RCQUIT =1 Q
  21583   "RTN","RCD PESP",253, 0)
  21584    . I +$G(Y )<1 S DONE =1 Q
  21585   "RTN","RCD PESP",254, 0)
  21586    . S CT=CT +1,IEN=+Y, IENS=IEN_" ,",PREC=Y( 0)
  21587   "RTN","RCD PESP",255, 0)
  21588    . K FDAPA YER
  21589   "RTN","RCD PESP",256, 0)
  21590    . N COMME NT,STAT
  21591   "RTN","RCD PESP",257, 0)
  21592    . S COMME NT=""
  21593   "RTN","RCD PESP",258, 0)
  21594    . S STAT= '$$GET1^DI Q(344.6,IE NS,FLD,"I" )
  21595   "RTN","RCD PESP",259, 0)
  21596    . S FDAPA YER(344.6, IENS,FLD)= STAT
  21597   "RTN","RCD PESP",260, 0)
  21598    . ; GET C OMMENT HER E
  21599   "RTN","RCD PESP",261, 0)
  21600    . K Y S D IR("A")="C OMMENT: ", DIR(0)="FA ^3:72"
  21601   "RTN","RCD PESP",262, 0)
  21602    . S DIR(" PRE")="S X =$$TRIM^XL FSTR(X,""L R"")" ; co mment requ ired and s hould be s ignificant
  21603   "RTN","RCD PESP",263, 0)
  21604    . S DIR(" ?")="Enter  an explan ation for  "_$S(STAT: "adding th e payer to ",1:"remov ing the pa yer from") _" the lis t of Exclu ded Payers ."
  21605   "RTN","RCD PESP",264, 0)
  21606    . D ^DIR  I $D(DTOUT )!$D(DUOUT )!(Y="") S  RCQUIT=1  Q
  21607   "RTN","RCD PESP",265, 0)
  21608    . S COMME NT=Y
  21609   "RTN","RCD PESP",266, 0)
  21610    . I COMME NT]"" D
  21611   "RTN","RCD PESP",267, 0)
  21612    . . I STA T S FDAPAY ER(344.6,I ENS,CMT)=C OMMENT
  21613   "RTN","RCD PESP",268, 0)
  21614    . . E  S  FDAPAYER(3 44.6,IENS, CMT)=""
  21615   "RTN","RCD PESP",269, 0)
  21616    . . W !,$ P(PREC,U,1 )_" "_$P(P REC,U,2)_"  has been  "
  21617   "RTN","RCD PESP",270, 0)
  21618    . . W $S( STAT:"adde d to",1:"r emoved fro m")_" the  list of Ex cluded Pay ers"
  21619   "RTN","RCD PESP",271, 0)
  21620    . . I TYP =1 D
  21621   "RTN","RCD PESP",272, 0)
  21622    . . . W ! ,"If medic al auto-de crease is  turned on,  "
  21623   "RTN","RCD PESP",273, 0)
  21624    . . . I S TAT W "thi s payer wi ll be excl uded from  medical au to-decreas e too."
  21625   "RTN","RCD PESP",274, 0)
  21626    . . . I ' STAT,'$$GE T1^DIQ(344 .6,IEN_"," ,.07,"I")  W "this pa yer will n o longer b e excluded  from Medi cal Auto-D ecrease."
  21627   "RTN","RCD PESP",275, 0)
  21628    . . . I ' STAT,$$GET 1^DIQ(344. 6,IEN_",", .07,"I") W  "Medical  Auto-Decre ase is set  to be exc luded for  this payer ."
  21629   "RTN","RCD PESP",276, 0)
  21630    . . K RCA UDVAL
  21631   "RTN","RCD PESP",277, 0)
  21632    . . D FIL E^DIE(,"FD APAYER")
  21633   "RTN","RCD PESP",278, 0)
  21634    . . S RCA UDVAL(1)=" 344.6"_U_F LD_U_IEN_U _STAT_U_(' STAT)_U_CO MMENT
  21635   "RTN","RCD PESP",279, 0)
  21636    . . D AUD IT(.RCAUDV AL) K RCAU DVAL
  21637   "RTN","RCD PESP",280, 0)
  21638    Q
  21639   "RTN","RCD PESP",281, 0)
  21640    ;
  21641   "RTN","RCD PESP",282, 0)
  21642   NOTIFY(VAL ,TYPE) ; N otify CBO  team of ch ange to Si te Paramet ers
  21643   "RTN","RCD PESP",283, 0)
  21644    N GLB,GLO ,MSG,SITE, SUBJ,XMINS TR,XMTO
  21645   "RTN","RCD PESP",284, 0)
  21646    S SITE=$$ SITE^VASIT E
  21647   "RTN","RCD PESP",285, 0)
  21648    S TYPE=+$ G(TYPE)  ; init optio nal parame ter
  21649   "RTN","RCD PESP",286, 0)
  21650    ; limit s ubject to  65 chars.
  21651   "RTN","RCD PESP",287, 0)
  21652    S SUBJ=$E ("Site Par ameter edi t, Station  #"_$P(SIT E,U,3)_" -  "_$P(SITE ,U,2),1,65 )
  21653   "RTN","RCD PESP",288, 0)
  21654    S MSG(1)= " "
  21655   "RTN","RCD PESP",289, 0)
  21656    S MSG(2)= "        S ite: "_$P( SITE,U,2)
  21657   "RTN","RCD PESP",290, 0)
  21658    S MSG(3)= "   Statio n #: "_$P( SITE,U,3)
  21659   "RTN","RCD PESP",291, 0)
  21660    S MSG(4)= "      Dom ain: "_$G( ^XMB("NETN AME"))
  21661   "RTN","RCD PESP",292, 0)
  21662    S MSG(5)= "   Date/T ime: "_$$F MTE^XLFDT( $$NOW^XLFD T,"5ZPM")
  21663   "RTN","RCD PESP",293, 0)
  21664    S MSG(6)= "  Changed  by: "_$P( $G(^VA(200 ,DUZ,0)),U )
  21665   "RTN","RCD PESP",294, 0)
  21666    S MSG(7)= " "
  21667   "RTN","RCD PESP",295, 0)
  21668    S MSG(8)= "  ENABLE  AUTO-POSTI NG OF "_$S (TYPE=1:"P HARMACY",1 :"MEDICAL" )_" CLAIMS  = "_VAL
  21669   "RTN","RCD PESP",296, 0)
  21670    S MSG(9)= " "
  21671   "RTN","RCD PESP",297, 0)
  21672    ;Copy mes sage to eP ayments CB O team
  21673   "RTN","RCD PESP",298, 0)
  21674    S XMTO(DU Z)=""
  21675   "RTN","RCD PESP",299, 0)
  21676    S:$$PROD^ XUPROD XMT O("
P II                   ")=""
  21677   "RTN","RCD PESP",300, 0)
  21678    ;
  21679   "RTN","RCD PESP",301, 0)
  21680    K ^TMP("X MERR",$J)
  21681   "RTN","RCD PESP",302, 0)
  21682    D SENDMSG ^XMXAPI(DU Z,SUBJ,"MS G",.XMTO,. XMINSTR)
  21683   "RTN","RCD PESP",303, 0)
  21684    ;
  21685   "RTN","RCD PESP",304, 0)
  21686    I $D(^TMP ("XMERR",$ J)) D
  21687   "RTN","RCD PESP",305, 0)
  21688    .D MES^XP DUTL("Mail Man report ed a probl em trying  to send th e notifica tion messa ge.")
  21689   "RTN","RCD PESP",306, 0)
  21690    .D MES^XP DUTL("  ")
  21691   "RTN","RCD PESP",307, 0)
  21692    .S (GLO,G LB)="^TMP( ""XMERR"", "_$J
  21693   "RTN","RCD PESP",308, 0)
  21694    .S GLO=GL O_")"
  21695   "RTN","RCD PESP",309, 0)
  21696    .F  S GLO =$Q(@GLO)  Q:GLO'[GLB   D MES^XP DUTL("   " _GLO_" = " _$G(@GLO))
  21697   "RTN","RCD PESP",310, 0)
  21698    .D MES^XP DUTL("  ")
  21699   "RTN","RCD PESP",311, 0)
  21700    Q
  21701   "RTN","RCD PESP",312, 0)
  21702    ;
  21703   "RTN","RCD PESP",313, 0)
  21704   AUDIT(INP)  ; WRITE A UDIT RECOR D(S)
  21705   "RTN","RCD PESP",314, 0)
  21706    ; INP = a udit value  in this f ormat:
  21707   "RTN","RCD PESP",315, 0)
  21708    ;       F ILE NUMBER ^FIELD NUM BER^IEN^NE W VALUE^OL D VALUE^CO MMENT
  21709   "RTN","RCD PESP",316, 0)
  21710    Q:'$O(INP (0))   ; n othing to  audit
  21711   "RTN","RCD PESP",317, 0)
  21712    N FDAUDT   ; FileMan  FDA array  for audit s
  21713   "RTN","RCD PESP",318, 0)
  21714    N IDX S I DX=0
  21715   "RTN","RCD PESP",319, 0)
  21716    F  S IDX= $O(INP(IDX )) Q:'IDX   D
  21717   "RTN","RCD PESP",320, 0)
  21718    . K FDAUD T
  21719   "RTN","RCD PESP",321, 0)
  21720    . S FDAUD T(344.7,"+ 1,",.01)=$ $NOW^XLFDT
  21721   "RTN","RCD PESP",322, 0)
  21722    . S FDAUD T(344.7,"+ 1,",.02)=$ P(INP(IDX) ,U,3) ; IE N
  21723   "RTN","RCD PESP",323, 0)
  21724    . S FDAUD T(344.7,"+ 1,",.03)=D UZ  ; user
  21725   "RTN","RCD PESP",324, 0)
  21726    . S FDAUD T(344.7,"+ 1,",.04)=$ P(INP(IDX) ,U,2) ; FI ELD NUMBER
  21727   "RTN","RCD PESP",325, 0)
  21728    . S FDAUD T(344.7,"+ 1,",.05)=$ P(INP(IDX) ,U,1) ; FI LE NUMBER
  21729   "RTN","RCD PESP",326, 0)
  21730    . S FDAUD T(344.7,"+ 1,",.06)=$ P(INP(IDX) ,U,4) ; NE W VALUE
  21731   "RTN","RCD PESP",327, 0)
  21732    . S FDAUD T(344.7,"+ 1,",.07)=$ P(INP(IDX) ,U,5) ; OL D VALUE
  21733   "RTN","RCD PESP",328, 0)
  21734    . S FDAUD T(344.7,"+ 1,",.08)=$ P(INP(IDX) ,U,6) ; CO MMENT
  21735   "RTN","RCD PESP",329, 0)
  21736    . D UPDAT E^DIE(,"FD AUDT")
  21737   "RTN","RCD PESP",330, 0)
  21738    Q
  21739   "RTN","RCD PESP",331, 0)
  21740    ;
  21741   "RTN","RCD PESP",332, 0)
  21742    ; ******* ********** ********** ********** ********** ********** ****
  21743   "RTN","RCD PESP",333, 0)
  21744    ; CALLS R ELATED TO  CREATING E PAYMENT PA YER EXCLUS ION PARAME TERS
  21745   "RTN","RCD PESP",334, 0)
  21746    ; ******* ********** ********** ********** ********** ********** ****
  21747   "RTN","RCD PESP",335, 0)
  21748    ;
  21749   "RTN","RCD PESP",336, 0)
  21750   NEWPYR ;Ad d new paye rs to paye r table -  called fro m AR Night ly Job (EN ^RCDPEM)
  21751   "RTN","RCD PESP",337, 0)
  21752    N RCDATE, RCERA,RCUP D
  21753   "RTN","RCD PESP",338, 0)
  21754    ;Get date /time of l ast run ot herwise st art at pre vious day
  21755   "RTN","RCD PESP",339, 0)
  21756    S RCDATE= $P($G(^RCY (344.61,1, 0)),U,8) S :RCDATE=""  RCDATE=$$ FMADD^XLFD T($$NOW^XL FDT\1,-1)
  21757   "RTN","RCD PESP",340, 0)
  21758    F  S RCDA TE=$O(^RCY (344.4,"AF D",RCDATE) ) Q:'RCDAT E  D
  21759   "RTN","RCD PESP",341, 0)
  21760    .S RCERA= "" F  S RC ERA=$O(^RC Y(344.4,"A FD",RCDATE ,RCERA)) Q :'RCERA  S  RCUPD=$$P AYRINIT(RC ERA)
  21761   "RTN","RCD PESP",342, 0)
  21762    ;Update l ast run da te
  21763   "RTN","RCD PESP",343, 0)
  21764    S $P(^RCY (344.61,1, 0),U,8)=$$ NOW^XLFDT
  21765   "RTN","RCD PESP",344, 0)
  21766    Q
  21767   "RTN","RCD PESP",345, 0)
  21768    ;
  21769   "RTN","RCD PESP",346, 0)
  21770   PAYERPRM(I EN,EXMDPOS T,EXMDDECR ) ; USED T O UPDATE A  NEW PAYER
  21771   "RTN","RCD PESP",347, 0)
  21772    ; CHECK I EN FOR VAL ID INPUT
  21773   "RTN","RCD PESP",348, 0)
  21774    Q:'$G(IEN )!('$D(^RC Y(344.4,+$ G(IEN),0)) ) 0
  21775   "RTN","RCD PESP",349, 0)
  21776    N PFDA,PA YER,ID,CPA YERID,PIEN S
  21777   "RTN","RCD PESP",350, 0)
  21778    S PAYER=$ E($$GET1^D IQ(344.4,I EN_",",.06 ),1,35)
  21779   "RTN","RCD PESP",351, 0)
  21780    Q:PAYER=" " 0
  21781   "RTN","RCD PESP",352, 0)
  21782    S ID=$E($ $GET1^DIQ( 344.4,IEN_ ",",.03),1 ,30)
  21783   "RTN","RCD PESP",353, 0)
  21784    I '$D(^RC Y(344.6,"C PID",PAYER ,ID)) Q 0
  21785   "RTN","RCD PESP",354, 0)
  21786    ; FILE CU RRENT SETT INGS
  21787   "RTN","RCD PESP",355, 0)
  21788    S PIENS=$ O(^RCY(344 .6,"CPID", PAYER,ID,0 ))_","
  21789   "RTN","RCD PESP",356, 0)
  21790    S PFDA(34 4.6,PIENS, .04)=DUZ
  21791   "RTN","RCD PESP",357, 0)
  21792    S PFDA(34 4.6,PIENS, .05)=$$NOW ^XLFDT
  21793   "RTN","RCD PESP",358, 0)
  21794    S PFDA(34 4.6,PIENS, .06)=+$G(E XMDPOST)
  21795   "RTN","RCD PESP",359, 0)
  21796    S PFDA(34 4.6,PIENS, .07)=+$G(E XMDDECR)
  21797   "RTN","RCD PESP",360, 0)
  21798    D FILE^DI E(,"PFDA")
  21799   "RTN","RCD PESP",361, 0)
  21800    Q 1
  21801   "RTN","RCD PESP",362, 0)
  21802    ;
  21803   "RTN","RCD PESP",363, 0)
  21804   PAYRINIT(I EN) ; Add  Payer Name  and Payer  ID to Pay er table # 344.6 
  21805   "RTN","RCD PESP",364, 0)
  21806    ;
  21807   "RTN","RCD PESP",365, 0)
  21808    N PFDA,PA YER,ID,PIE NS,ERADATE
  21809   "RTN","RCD PESP",366, 0)
  21810    ;
  21811   "RTN","RCD PESP",367, 0)
  21812    Q:'$G(IEN )!('$D(^RC Y(344.4,+$ G(IEN))))  0
  21813   "RTN","RCD PESP",368, 0)
  21814    S PAYER=$ P($G(^RCY( 344.4,IEN, 0)),U,6) Q :PAYER=""  0
  21815   "RTN","RCD PESP",369, 0)
  21816    S ID=$P($ G(^RCY(344 .4,IEN,0)) ,U,3) Q:ID ="" 0
  21817   "RTN","RCD PESP",370, 0)
  21818    I $D(^RCY (344.6,"CP ID",PAYER, ID)) Q 1
  21819   "RTN","RCD PESP",371, 0)
  21820    S ERADATE =$P($G(^RC Y(344.4,IE N,0)),U,7)
  21821   "RTN","RCD PESP",372, 0)
  21822    ; UPDATE  PAYER PARA METERS
  21823   "RTN","RCD PESP",373, 0)
  21824    S PIENS=" +1,"
  21825   "RTN","RCD PESP",374, 0)
  21826    S PFDA(34 4.6,PIENS, .01)=PAYER
  21827   "RTN","RCD PESP",375, 0)
  21828    S PFDA(34 4.6,PIENS, .02)=ID
  21829   "RTN","RCD PESP",376, 0)
  21830    S PFDA(34 4.6,PIENS, .03)=ERADA TE
  21831   "RTN","RCD PESP",377, 0)
  21832    S PFDA(34 4.6,PIENS, .04)=.5
  21833   "RTN","RCD PESP",378, 0)
  21834    S PFDA(34 4.6,PIENS, .05)=$$NOW ^XLFDT
  21835   "RTN","RCD PESP",379, 0)
  21836    S PFDA(34 4.6,PIENS, .06)=0
  21837   "RTN","RCD PESP",380, 0)
  21838    S PFDA(34 4.6,PIENS, .07)=0
  21839   "RTN","RCD PESP",381, 0)
  21840    D UPDATE^ DIE(,"PFDA ")
  21841   "RTN","RCD PESP",382, 0)
  21842    Q 1
  21843   "RTN","RCD PESP1")
  21844   0^68^B1060 87451
  21845   "RTN","RCD PESP1",1,0 )
  21846   RCDPESP1 ; BIRM/SAB,h rubovcak -  ePayment  Lockbox Si te Paramet er Reports  ;7/1/15
  21847   "RTN","RCD PESP1",2,0 )
  21848    ;;4.5;Acc ounts Rece ivable;**2 98,304,318 ,321**;Mar  20, 1995; Build 46
  21849   "RTN","RCD PESP1",3,0 )
  21850    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  21851   "RTN","RCD PESP1",4,0 )
  21852    ;
  21853   "RTN","RCD PESP1",5,0 )
  21854    Q
  21855   "RTN","RCD PESP1",6,0 )
  21856    ;
  21857   "RTN","RCD PESP1",7,0 )
  21858   RPT ; EDI  Lockbox Pa rameters R eport [RCD PE SITE PA RAMETER RE PORT]
  21859   "RTN","RCD PESP1",8,0 )
  21860    ; report  data from:
  21861   "RTN","RCD PESP1",9,0 )
  21862    ;    AR S ITE PARAME TER file ( #342)
  21863   "RTN","RCD PESP1",10, 0)
  21864    ;    RCDP E PARAMETE R file (#3 44.61)
  21865   "RTN","RCD PESP1",11, 0)
  21866    ;    RCDP E AUTO-PAY  EXCLUSION  file (#34 4.6)
  21867   "RTN","RCD PESP1",12, 0)
  21868    ;
  21869   "RTN","RCD PESP1",13, 0)
  21870    ; LOCAL V ARIABLES:
  21871   "RTN","RCD PESP1",14, 0)
  21872    ;    RTYP E - Type o f Report t o run (Med ical, Phar macy, or B oth)
  21873   "RTN","RCD PESP1",15, 0)
  21874    ;
  21875   "RTN","RCD PESP1",16, 0)
  21876    N RCTYPE
  21877   "RTN","RCD PESP1",17, 0)
  21878    W !,$$HDR LN,!
  21879   "RTN","RCD PESP1",18, 0)
  21880    ;
  21881   "RTN","RCD PESP1",19, 0)
  21882    S RCTYPE= $$RTYPE^RC DPESP2() G :RCTYPE=-1  RPTQ
  21883   "RTN","RCD PESP1",20, 0)
  21884    W !!   ;S pacing bef ore the ne xt prompt
  21885   "RTN","RCD PESP1",21, 0)
  21886    ;
  21887   "RTN","RCD PESP1",22, 0)
  21888    N %ZIS,PO P S %ZIS=" QM" D ^%ZI S Q:POP
  21889   "RTN","RCD PESP1",23, 0)
  21890    I $D(IO(" Q")) D  Q
  21891   "RTN","RCD PESP1",24, 0)
  21892    .N ZTDESC ,ZTQUEUED, ZTRTN,ZTSA VE,ZTSK
  21893   "RTN","RCD PESP1",25, 0)
  21894    .S ZTRTN= "SPRPT^RCD PESP1",ZTD ESC=$$HDRL N,ZTSAVE(" RC*")=""
  21895   "RTN","RCD PESP1",26, 0)
  21896    .D ^%ZTLO AD
  21897   "RTN","RCD PESP1",27, 0)
  21898    .W !!,$S( $G(ZTSK):" Task numbe r "_ZTSK_"  has been  queued.",1 :"Unable t o queue th is task.")
  21899   "RTN","RCD PESP1",28, 0)
  21900    .K IO("Q" ) D HOME^% ZIS
  21901   "RTN","RCD PESP1",29, 0)
  21902    ;
  21903   "RTN","RCD PESP1",30, 0)
  21904    D SPRPT
  21905   "RTN","RCD PESP1",31, 0)
  21906   RPTQ Q
  21907   "RTN","RCD PESP1",32, 0)
  21908    ;
  21909   "RTN","RCD PESP1",33, 0)
  21910   SPRPT ; si te paramet er report  entry poin t
  21911   "RTN","RCD PESP1",34, 0)
  21912    ; RCNTR -  counter
  21913   "RTN","RCD PESP1",35, 0)
  21914    ; RCFLD -  DD field  number
  21915   "RTN","RCD PESP1",36, 0)
  21916    ; RCHDR -  header in formation
  21917   "RTN","RCD PESP1",37, 0)
  21918    ; RCPARM  - paramete rs
  21919   "RTN","RCD PESP1",38, 0)
  21920    ; RCSTOP  - exit fla g
  21921   "RTN","RCD PESP1",39, 0)
  21922    N J,RCNTR ,RCFLD,RCG LB,RCHDR,R CPARM,RCST OP,V,X,Y,R CSTRING
  21923   "RTN","RCD PESP1",40, 0)
  21924    N RCDATA, RCCODE,RCD ESC,RCSTAT ,RCI,RCCAR CD,RCCIEN, RCITEM,RCA CTV
  21925   "RTN","RCD PESP1",41, 0)
  21926    ;
  21927   "RTN","RCD PESP1",42, 0)
  21928    S X="RC"  F  S X=$O( ^TMP($J,X) ) Q:'($E(X ,1,2)="RC" )  K ^TMP( $J,X) ; cl ear out ol d data
  21929   "RTN","RCD PESP1",43, 0)
  21930    ;
  21931   "RTN","RCD PESP1",44, 0)
  21932    ; RCGLB -  ^TMP glob al storage  locations
  21933   "RTN","RCD PESP1",45, 0)
  21934    ;     ^TM P($J,"RC34 2") - AR S ITE PARAME TER file ( #342)
  21935   "RTN","RCD PESP1",46, 0)
  21936    ;   ^TMP( $J,"RC344. 6") - RCDP E AUTO-PAY  EXCLUSION  file (#34 4.6)
  21937   "RTN","RCD PESP1",47, 0)
  21938    ;  ^TMP($ J,"RC344.6 1") - RCDP E PARAMETE R file (#3 44.61)
  21939   "RTN","RCD PESP1",48, 0)
  21940    F J=342,3 44.6,344.6 1 S RCGLB( J)=$NA(^TM P($J,"RC"_ J)) K @RCG LB(J)
  21941   "RTN","RCD PESP1",49, 0)
  21942    ;
  21943   "RTN","RCD PESP1",50, 0)
  21944    S RCHDR(" RUNDATE")= $$FMTE^XLF DT($$NOW^X LFDT,"10S" )
  21945   "RTN","RCD PESP1",51, 0)
  21946    S RCHDR(" PGNMBR")=0   ; page n umber
  21947   "RTN","RCD PESP1",52, 0)
  21948    ;
  21949   "RTN","RCD PESP1",53, 0)
  21950    ; AR SITE  PARAMETER  file (#34 2)
  21951   "RTN","RCD PESP1",54, 0)
  21952    D GETS^DI Q(342,"1," ,".01;7.02 ;7.03;7.04 ;7.05;7.06 ;7.07;7.08 ;","E",RCG LB(342))
  21953   "RTN","RCD PESP1",55, 0)
  21954    ; add sit e to heade r data
  21955   "RTN","RCD PESP1",56, 0)
  21956    S RCHDR(" SITE")="Si te: "_@RCG LB(342)@(3 42,"1,",.0 1,"E")
  21957   "RTN","RCD PESP1",57, 0)
  21958    ;
  21959   "RTN","RCD PESP1",58, 0)
  21960    F RCFLD=7 .02,7.03,7 .04,7.05,7 .06,7.07,7 .08 S RCIT EM=$S(RCFL D>7.04:"TI TLE",1:"LA BEL") D  ;  EFT and E RA days un matched  -  PRCA*4.5* 321
  21961   "RTN","RCD PESP1",59, 0)
  21962    . I RCTYP E="P",(RCF LD=7.05)!( RCFLD=7.07 ) Q  ; Don t display  if only sh owing Phar macy param eters - PR CA*4.5*321
  21963   "RTN","RCD PESP1",60, 0)
  21964    . I RCTYP E="M",(RCF LD=7.06)!( RCFLD=7.08 ) Q  ; Don t display  if only sh owing medi cal parame ters - PRC A*4.5*321
  21965   "RTN","RCD PESP1",61, 0)
  21966    . S Y=$$G ET1^DID(34 2,RCFLD,,R CITEM)_":  "_@RCGLB(3 42)@(342," 1,",RCFLD, "E")
  21967   "RTN","RCD PESP1",62, 0)
  21968    . I RCFLD =7.05 D AD 2RPT(" ")
  21969   "RTN","RCD PESP1",63, 0)
  21970    . I (RCFL D=7.06)&(R CTYPE="P")  D AD2RPT( " ")
  21971   "RTN","RCD PESP1",64, 0)
  21972    . D AD2RP T(Y)
  21973   "RTN","RCD PESP1",65, 0)
  21974    ;
  21975   "RTN","RCD PESP1",66, 0)
  21976    D AD2RPT( " ")
  21977   "RTN","RCD PESP1",67, 0)
  21978    ;
  21979   "RTN","RCD PESP1",68, 0)
  21980    ; Display  Medical P arameters
  21981   "RTN","RCD PESP1",69, 0)
  21982    ; RCDPE P ARAMETER f ile (#344. 61)
  21983   "RTN","RCD PESP1",70, 0)
  21984    D GETS^DI Q(344.61," 1,",".02;. 03;.04;.05 ;.06;.07;. 1;1.01;1.0 2","E",RCG LB(344.61) ) ; PRCA*4 .5*321
  21985   "RTN","RCD PESP1",71, 0)
  21986    ;
  21987   "RTN","RCD PESP1",72, 0)
  21988    S Y=$$GET 1^DID(344. 61,.1,,"LA BEL")_": " _@RCGLB(34 4.61)@(344 .61,"1,",. 1,"E") ; P RCA*4.5*32 1
  21989   "RTN","RCD PESP1",73, 0)
  21990    D AD2RPT( Y) ; PRCA* 4.5*321
  21991   "RTN","RCD PESP1",74, 0)
  21992    D AD2RPT( " ") ;  PR CA*4.5*321
  21993   "RTN","RCD PESP1",75, 0)
  21994    ;
  21995   "RTN","RCD PESP1",76, 0)
  21996    ; get aut o-post and  auto-decr ease setti ngs, save  zero node
  21997   "RTN","RCD PESP1",77, 0)
  21998    S X=$G(^R CY(344.61, 1,0)),RCPA RM("AUTO-P OST")=$P(X ,U,2),RCPA RM("AUTO-D ECREASE")= $P(X,U,3), RCPARM(344 .61,0)=X
  21999   "RTN","RCD PESP1",78, 0)
  22000    S RCPARM( "RX AUTO-P OST")=$P($ G(^RCY(344 .61,1,1)), U)
  22001   "RTN","RCD PESP1",79, 0)
  22002    ;
  22003   "RTN","RCD PESP1",80, 0)
  22004    ; RCDPE A UTO-PAY EX CLUSION fi le (#344.6 )
  22005   "RTN","RCD PESP1",81, 0)
  22006    ;   scree ning logic : ^DD(344. 6,.06,0)=" EXCLUDE ME D CLAIMS P OSTING^S^0 :No;1:Yes; ^0;6^Q"
  22007   "RTN","RCD PESP1",82, 0)
  22008    D LIST^DI C(344.6,," @;.01;.02; .06;1","P" ,,,,,"I $P (^(0),U,6) =1",,RCGLB (344.6))
  22009   "RTN","RCD PESP1",83, 0)
  22010    ;
  22011   "RTN","RCD PESP1",84, 0)
  22012    ; PRCA*4. 5*304 - Pr int Medica l Claim Pa rameters
  22013   "RTN","RCD PESP1",85, 0)
  22014    I RCTYPE' ="P" D
  22015   "RTN","RCD PESP1",86, 0)
  22016    .; RCDPE  PARAMETER  file (#344 .61), auto -posting o f medical  claims
  22017   "RTN","RCD PESP1",87, 0)
  22018    .S X=$$GE T1^DID(344 .61,.02,," TITLE"),V= " (Y/N)" S :X[V X=$P( X,V)_$P(X, V,2)  ; re move yes/n o prompt
  22019   "RTN","RCD PESP1",88, 0)
  22020    .S Y=X_"  "_@RCGLB(3 44.61)@(34 4.61,"1,", .02,"E")
  22021   "RTN","RCD PESP1",89, 0)
  22022    .D AD2RPT (Y)
  22023   "RTN","RCD PESP1",90, 0)
  22024    .;
  22025   "RTN","RCD PESP1",91, 0)
  22026    .I (RCPAR M("AUTO-PO ST")!RCPAR M("AUTO-DE CREASE"))  D  ; list  auto-post  excluded p ayers
  22027   "RTN","RCD PESP1",92, 0)
  22028    ..I '$D(@ RCGLB(344. 6)@("DILIS T",1,0)) D   Q
  22029   "RTN","RCD PESP1",93, 0)
  22030    ...S X="      No pay ers exclud ed from me dical auto -posting."  D AD2RPT( $J(" ",80- $L(X)\2)_X )
  22031   "RTN","RCD PESP1",94, 0)
  22032    ..;
  22033   "RTN","RCD PESP1",95, 0)
  22034    ..D AD2RP T("   Excl uded Payer                         Comment" )
  22035   "RTN","RCD PESP1",96, 0)
  22036    ..S RCNTR =0
  22037   "RTN","RCD PESP1",97, 0)
  22038    ..F  S RC NTR=$O(@RC GLB(344.6) @("DILIST" ,RCNTR)) Q :'RCNTR  D
  22039   "RTN","RCD PESP1",98, 0)
  22040    ...S V=@R CGLB(344.6 )@("DILIST ",RCNTR,0) ,X=$E($P(V ,U,2),1,35 )
  22041   "RTN","RCD PESP1",99, 0)
  22042    ...S Y="    "_X_$J("  ",36-$L(X ))_$P(V,U, 5)
  22043   "RTN","RCD PESP1",100 ,0)
  22044    ...D AD2R PT($E(Y,1, IOM))
  22045   "RTN","RCD PESP1",101 ,0)
  22046    .;
  22047   "RTN","RCD PESP1",102 ,0)
  22048    .I RCPARM ("AUTO-POS T") D AD2R PT(" ")  ;  blank lin e
  22049   "RTN","RCD PESP1",103 ,0)
  22050    .;
  22051   "RTN","RCD PESP1",104 ,0)
  22052    .K @RCGLB (344.6)  ;  delete ol d data
  22053   "RTN","RCD PESP1",105 ,0)
  22054    .; RCDPE  AUTO-PAY E XCLUSION f ile (#344. 6)
  22055   "RTN","RCD PESP1",106 ,0)
  22056    .;   scre ening logi c: ^DD(344 .6,.07,0)= "EXCLUDE M ED CLAIMS  DECREASE^S ^0:No;1:Ye s;^0;7^Q"
  22057   "RTN","RCD PESP1",107 ,0)
  22058    .D LIST^D IC(344.6,, "@;.01;.02 ;.07;2","P ",,,,,"I $ P(^(0),U,7 )=1",,RCGL B(344.6))
  22059   "RTN","RCD PESP1",108 ,0)
  22060    .;
  22061   "RTN","RCD PESP1",109 ,0)
  22062    .; RCDPE  PARAMETER  file (#344 .61), auto -decrease  of medical  claims
  22063   "RTN","RCD PESP1",110 ,0)
  22064    .S X=$$GE T1^DID(344 .61,.03,," TITLE"),V= " (Y/N): " ,V=" (Y/N) " S:X[V X= $P(X,V)_$P (X,V,2)  ;  remove ye s/no promp t
  22065   "RTN","RCD PESP1",111 ,0)
  22066    .S Y=$J(X ,45)_@RCGL B(344.61)@ (344.61,"1 ,",.03,"E" )
  22067   "RTN","RCD PESP1",112 ,0)
  22068    .D AD2RPT (Y) ; ,AD2 RPT(" ")
  22069   "RTN","RCD PESP1",113 ,0)
  22070    .; PRCA*4 .5*304 - R emoved bec ause auto- decrease a mounts are  based on  CARCs
  22071   "RTN","RCD PESP1",114 ,0)
  22072    .;I RCPAR M("AUTO-DE CREASE") D   ; list t hese 2 fie lds only i f auto-dec rease enab led
  22073   "RTN","RCD PESP1",115 ,0)
  22074    .;.D AD2R PT("NUMBER  OF DAYS T O WAIT BEF ORE AUTO-D ECREASE: " _(+$P(RCPA RM(344.61, 0),U,4)))
  22075   "RTN","RCD PESP1",116 ,0)
  22076    .;.D AD2R PT("     M AXIMUM DOL LAR AMOUNT  TO AUTO-D ECREASE: " _"$"_(+$P( RCPARM(344 .61,0),U,5 )))
  22077   "RTN","RCD PESP1",117 ,0)
  22078    .;
  22079   "RTN","RCD PESP1",118 ,0)
  22080    .; PRCA*4 .5*304 - P rint the C ARC Auto-d ecrease pa rameters
  22081   "RTN","RCD PESP1",119 ,0)
  22082    . I $$CAR CCHK(RCTYP E,"M") D
  22083   "RTN","RCD PESP1",120 ,0)
  22084    .. D AD2R PT(" "),AD 2RPT("      AUTO-DECR EASE MEDIC AL CLAIMS  FOR THE FO LLOWING CA RC/AMOUNTS  ONLY:"),A D2RPT(" ")
  22085   "RTN","RCD PESP1",121 ,0)
  22086    .. S RCST RING=$TR($ J("",70),"  ","-"),RC I=0
  22087   "RTN","RCD PESP1",122 ,0)
  22088    .. D AD2R PT("     C ARC  Descr iption                                                  Max. Amt" )
  22089   "RTN","RCD PESP1",123 ,0)
  22090    .. D AD2R PT("     " _RCSTRING)
  22091   "RTN","RCD PESP1",124 ,0)
  22092    .. ;
  22093   "RTN","RCD PESP1",125 ,0)
  22094    .. ; Loop  and print  entries
  22095   "RTN","RCD PESP1",126 ,0)
  22096    .. F  S R CI=$O(^RCY (344.62,RC I)) Q:'RCI   D
  22097   "RTN","RCD PESP1",127 ,0)
  22098    .. . S RC DATA=$G(^R CY(344.62, RCI,0)),Y= ""
  22099   "RTN","RCD PESP1",128 ,0)
  22100    .. . Q:RC DATA=""
  22101   "RTN","RCD PESP1",129 ,0)
  22102    .. . S RC CODE=$P(RC DATA,U),RC CIEN=$O(^R C(345,"B", RCCODE,"") )
  22103   "RTN","RCD PESP1",130 ,0)
  22104    .. . S RC DESC=$G(^R C(345,RCCI EN,1,1,0))
  22105   "RTN","RCD PESP1",131 ,0)
  22106    .. . S RC STAT=$P(RC DATA,U,2)
  22107   "RTN","RCD PESP1",132 ,0)
  22108    .. . Q:RC STAT'=1
  22109   "RTN","RCD PESP1",133 ,0)
  22110    .. . I $L (RCDESC)>5 0 S RCDESC =$E(RCDESC ,1,50)_" . .."
  22111   "RTN","RCD PESP1",134 ,0)
  22112    .. . D GE TCODES^RCD PCRR(RCCOD E,"","A",$ $DT^XLFDT, "RCCARCD", "1^70")
  22113   "RTN","RCD PESP1",135 ,0)
  22114    .. . S Y= "     "_$J (RCCODE,4) _"  "
  22115   "RTN","RCD PESP1",136 ,0)
  22116    .. . S Y= Y_$E(RCDES C,1,53) S: $L(RCDESC) <53 Y=Y_$J ("",(53-$L (RCDESC)))  S Y=Y_$J( $P(RCDATA, U,6),10,0)
  22117   "RTN","RCD PESP1",137 ,0)
  22118    .. . I '$ $ACT^RCDPR U(345,RCCO DE,) S Y=Y _" (I)"  ;  if inacti ve, displa y (i)
  22119   "RTN","RCD PESP1",138 ,0)
  22120    .. . D AD 2RPT(Y)
  22121   "RTN","RCD PESP1",139 ,0)
  22122    .. ;
  22123   "RTN","RCD PESP1",140 ,0)
  22124    ..D AD2RP T(" ")  ;  blank line
  22125   "RTN","RCD PESP1",141 ,0)
  22126    .I (RCPAR M("AUTO-PO ST")!RCPAR M("AUTO-DE CREASE"))  D  ; list  excluded a uto-decrea se payers
  22127   "RTN","RCD PESP1",142 ,0)
  22128    .. S X=$P ($$GET1^DI D(344.61,. 04,,"TITLE ")," (",1) _": "
  22129   "RTN","RCD PESP1",143 ,0)
  22130    .. S Y=$J (X,50)_@RC GLB(344.61 )@(344.61, "1,",.04," E")
  22131   "RTN","RCD PESP1",144 ,0)
  22132    .. D AD2R PT(Y),AD2R PT(" ")
  22133   "RTN","RCD PESP1",145 ,0)
  22134    .. D AD2R PT("     A ll payers  excluded f rom Auto-P osting are  excluded  from Auto- Decrease." )
  22135   "RTN","RCD PESP1",146 ,0)
  22136    .. Q:'RCP ARM("AUTO- DECREASE")
  22137   "RTN","RCD PESP1",147 ,0)
  22138    .. I '$D( @RCGLB(344 .6)@("DILI ST",1,0))  D  Q
  22139   "RTN","RCD PESP1",148 ,0)
  22140    ... S X="        No  additional  payers ex cluded fro m Medical  Auto-Decre ase." D AD 2RPT($J("  ",80-$L(X) \2)_X)
  22141   "RTN","RCD PESP1",149 ,0)
  22142    ..;
  22143   "RTN","RCD PESP1",150 ,0)
  22144    .. D AD2R PT("     A dditional  Excluded P ayer            Comme nt")
  22145   "RTN","RCD PESP1",151 ,0)
  22146    .. S RCNT R=0
  22147   "RTN","RCD PESP1",152 ,0)
  22148    .. F  S R CNTR=$O(@R CGLB(344.6 )@("DILIST ",RCNTR))  Q:'RCNTR   D
  22149   "RTN","RCD PESP1",153 ,0)
  22150    ... S V=@ RCGLB(344. 6)@("DILIS T",RCNTR,0 ),X=$E($P( V,U,2),1,3 5)
  22151   "RTN","RCD PESP1",154 ,0)
  22152    ... S Y="      "_X_$ J(" ",36-$ L(X))_$P(V ,U,5)
  22153   "RTN","RCD PESP1",155 ,0)
  22154    ... D AD2 RPT($E(Y,1 ,IOM))
  22155   "RTN","RCD PESP1",156 ,0)
  22156    .;
  22157   "RTN","RCD PESP1",157 ,0)
  22158    .D AD2RPT (" ")  ; b lank line
  22159   "RTN","RCD PESP1",158 ,0)
  22160    ;
  22161   "RTN","RCD PESP1",159 ,0)
  22162    K @RCGLB( 344.6)  ;  delete old  data
  22163   "RTN","RCD PESP1",160 ,0)
  22164    ; RCDPE A UTO-PAY EX CLUSION fi le (#344.6 )
  22165   "RTN","RCD PESP1",161 ,0)
  22166    ;   scree ning logic : ^DD(344. 6,.06,0)=" EXCLUDE ME D CLAIMS P OSTING^S^0 :No;1:Yes; ^0;6^Q"
  22167   "RTN","RCD PESP1",162 ,0)
  22168    D LIST^DI C(344.6,," @;.01;.02; .08;3","P" ,,,,,"I $P (^(0),U,8) =1",,RCGLB (344.6))
  22169   "RTN","RCD PESP1",163 ,0)
  22170    ;
  22171   "RTN","RCD PESP1",164 ,0)
  22172    ; PRCA*4. 5*304 - Pr int Pharma cy Claim P arameters
  22173   "RTN","RCD PESP1",165 ,0)
  22174    I RCTYPE' ="M" D
  22175   "RTN","RCD PESP1",166 ,0)
  22176    .; RCDPE  PARAMETER  file (#344 .61), auto -posting o f pharmacy  claims
  22177   "RTN","RCD PESP1",167 ,0)
  22178    .S X=$$GE T1^DID(344 .61,1.01,, "TITLE"),V =" (Y/N)"  S:X[V X=$P (X,V)_$P(X ,V,2)  ; r emove yes/ no prompt
  22179   "RTN","RCD PESP1",168 ,0)
  22180    .S Y=X_"  "_@RCGLB(3 44.61)@(34 4.61,"1,", 1.01,"E")
  22181   "RTN","RCD PESP1",169 ,0)
  22182    .D AD2RPT (Y)
  22183   "RTN","RCD PESP1",170 ,0)
  22184    .;
  22185   "RTN","RCD PESP1",171 ,0)
  22186    . I RCPAR M("RX AUTO -POST") D   ; list au to-post ex cluded pay ers
  22187   "RTN","RCD PESP1",172 ,0)
  22188    .. I '$D( @RCGLB(344 .6)@("DILI ST",1,0))  D  Q
  22189   "RTN","RCD PESP1",173 ,0)
  22190    ... S X="      No pa yers exclu ded from p harmacy au to-posting ." D AD2RP T($J(" ",8 0-$L(X)\2) _X)
  22191   "RTN","RCD PESP1",174 ,0)
  22192    ..;
  22193   "RTN","RCD PESP1",175 ,0)
  22194    .. D AD2R PT("   Exc luded Paye r                        Comment ")
  22195   "RTN","RCD PESP1",176 ,0)
  22196    .. S RCNT R=0
  22197   "RTN","RCD PESP1",177 ,0)
  22198    .. F  S R CNTR=$O(@R CGLB(344.6 )@("DILIST ",RCNTR))  Q:'RCNTR   D
  22199   "RTN","RCD PESP1",178 ,0)
  22200    ... S V=@ RCGLB(344. 6)@("DILIS T",RCNTR,0 ),X=$E($P( V,U,2),1,3 5)
  22201   "RTN","RCD PESP1",179 ,0)
  22202    ... S Y="    "_X_$J( " ",36-$L( X))_$P(V,U ,5)
  22203   "RTN","RCD PESP1",180 ,0)
  22204    ... D AD2 RPT($E(Y,1 ,IOM))
  22205   "RTN","RCD PESP1",181 ,0)
  22206    .. S X=$P ($$GET1^DI D(344.61,1 .02,,"TITL E")," (",1 )_": "  ;  remove yes /no prompt
  22207   "RTN","RCD PESP1",182 ,0)
  22208    .. S Y="      "_X_"  "_$S(@RCGL B(344.61)@ (344.61,"1 ,",1.02,"E ")="":"No" ,1:@RCGLB( 344.61)@(3 44.61,"1," ,1.02,"E") )
  22209   "RTN","RCD PESP1",183 ,0)
  22210    .. D AD2R PT(" "),AD 2RPT(Y)
  22211   "RTN","RCD PESP1",184 ,0)
  22212    .;
  22213   "RTN","RCD PESP1",185 ,0)
  22214    .I RCPARM ("RX AUTO- POST") D A D2RPT(" ")   ; blank  line
  22215   "RTN","RCD PESP1",186 ,0)
  22216    .;
  22217   "RTN","RCD PESP1",187 ,0)
  22218    .K @RCGLB (344.6)  ;  delete ol d data
  22219   "RTN","RCD PESP1",188 ,0)
  22220    .;
  22221   "RTN","RCD PESP1",189 ,0)
  22222    .; PRCA*4 .5*304 - P rint the C ARC Auto-d ecrease pa rameters
  22223   "RTN","RCD PESP1",190 ,0)
  22224    . I $$CAR CCHK(RCTYP E,"P") D
  22225   "RTN","RCD PESP1",191 ,0)
  22226    .. S RCST RING=$TR($ J("",73),"  ","-"),RC I=0
  22227   "RTN","RCD PESP1",192 ,0)
  22228    .. D AD2R PT("  CARC   Descript ion                                                 Ma x. Amt")
  22229   "RTN","RCD PESP1",193 ,0)
  22230    .. D AD2R PT(RCSTRIN G)
  22231   "RTN","RCD PESP1",194 ,0)
  22232    .. ;
  22233   "RTN","RCD PESP1",195 ,0)
  22234    .. ; Loop  and print  entries
  22235   "RTN","RCD PESP1",196 ,0)
  22236    .. F  S R CI=$O(^RCY (344.62,RC I)) Q:'RCI   D
  22237   "RTN","RCD PESP1",197 ,0)
  22238    .. . S RC DATA=$G(^R CY(344.62, RCI,0)),Y= ""
  22239   "RTN","RCD PESP1",198 ,0)
  22240    .. . Q:RC DATA=""
  22241   "RTN","RCD PESP1",199 ,0)
  22242    .. . S RC CODE=$P(RC DATA,U),RC CIEN=$O(^R C(345,"B", RCCODE,"") )
  22243   "RTN","RCD PESP1",200 ,0)
  22244    .. . S RC DESC=$G(^R C(345,RCCI EN,1,1,0))
  22245   "RTN","RCD PESP1",201 ,0)
  22246    .. . S RC STAT=$P(RC DATA,U,2)
  22247   "RTN","RCD PESP1",202 ,0)
  22248    .. . Q:RC STAT'=1
  22249   "RTN","RCD PESP1",203 ,0)
  22250    .. . I $L (RCDESC)>5 0 S RCDESC =$E(RCDESC ,1,50)_" . .."
  22251   "RTN","RCD PESP1",204 ,0)
  22252    .. . D GE TCODES^RCD PCRR(RCCOD E,"","A",$ $DT^XLFDT, "RCCARCD", "1^70")
  22253   "RTN","RCD PESP1",205 ,0)
  22254    .. . S Y= "  "_$E(RC CODE,1,4)_ "  "
  22255   "RTN","RCD PESP1",206 ,0)
  22256    .. . S Y= Y_$E(RCDES C,1,55)_$J ($P(RCDATA ,U,6),10,0 )
  22257   "RTN","RCD PESP1",207 ,0)
  22258    .. . I '$ $ACT^RCDPR U(345,RCCO DE,) S Y=Y _" (I)"  ;  if inacti ve, displa y (i)
  22259   "RTN","RCD PESP1",208 ,0)
  22260    .. . D AD 2RPT(Y)
  22261   "RTN","RCD PESP1",209 ,0)
  22262    ;
  22263   "RTN","RCD PESP1",210 ,0)
  22264    ; RCDPE P ARAMETER f ile (#344. 61)
  22265   "RTN","RCD PESP1",211 ,0)
  22266    F RCFLD=. 06,.07 D
  22267   "RTN","RCD PESP1",212 ,0)
  22268    . Q:(RCFL D=.06)&(RC TYPE="P")   ; Dont di splay if o nly showin g Pharmacy  parameter s
  22269   "RTN","RCD PESP1",213 ,0)
  22270    . Q:(RCFL D=.07)&(RC TYPE="M")   ; Dont di splay if o nly showin g medical  parameters
  22271   "RTN","RCD PESP1",214 ,0)
  22272    . S Y=$$G ET1^DID(34 4.61,RCFLD ,,"TITLE") _" "_@RCGL B(344.61)@ (344.61,"1 ,",RCFLD," E")
  22273   "RTN","RCD PESP1",215 ,0)
  22274    . D AD2RP T(Y)
  22275   "RTN","RCD PESP1",216 ,0)
  22276    ;
  22277   "RTN","RCD PESP1",217 ,0)
  22278    D AD2RPT( " "),AD2RP T($$ENDORP RT^RCDPEAR L)
  22279   "RTN","RCD PESP1",218 ,0)
  22280    ;
  22281   "RTN","RCD PESP1",219 ,0)
  22282    S RCSTOP= 0 U IO D S PHDR(.RCHD R)
  22283   "RTN","RCD PESP1",220 ,0)
  22284    S J=0 F   S J=$O(^TM P($J,"RC S P REPORT", J)) Q:'J!R CSTOP  S Y =^TMP($J," RC SP REPO RT",J,0) D
  22285   "RTN","RCD PESP1",221 ,0)
  22286    .W !,Y Q: '$O(^TMP($ J,"RC SP R EPORT",J))   ; quit i f last lin e
  22287   "RTN","RCD PESP1",222 ,0)
  22288    .I '$G(ZT SK),$E(IOS T,1,2)="C- ",$Y+3>IOS L D ASK^RC DPEARL(.RC STOP) I 'R CSTOP D SP HDR(.RCHDR ) Q
  22289   "RTN","RCD PESP1",223 ,0)
  22290    .Q:RCSTOP   Q:$Y+2<I OSL
  22291   "RTN","RCD PESP1",224 ,0)
  22292    .D SPHDR( .RCHDR)
  22293   "RTN","RCD PESP1",225 ,0)
  22294    ;
  22295   "RTN","RCD PESP1",226 ,0)
  22296    I '$G(ZTS K),$E(IOST ,1,2)="C-" ,'RCSTOP D  ASK^RCDPE ARL(.RCSTO P)
  22297   "RTN","RCD PESP1",227 ,0)
  22298    ;
  22299   "RTN","RCD PESP1",228 ,0)
  22300    ; close d evice
  22301   "RTN","RCD PESP1",229 ,0)
  22302    U IO(0) D  ^%ZISC
  22303   "RTN","RCD PESP1",230 ,0)
  22304    ;
  22305   "RTN","RCD PESP1",231 ,0)
  22306    S X="RC"  F  S X=$O( ^TMP($J,X) ) Q:'($E(X ,1,2)="RC" )  K ^TMP( $J,X) ; cl ean up
  22307   "RTN","RCD PESP1",232 ,0)
  22308    ;
  22309   "RTN","RCD PESP1",233 ,0)
  22310    Q
  22311   "RTN","RCD PESP1",234 ,0)
  22312    ;
  22313   "RTN","RCD PESP1",235 ,0)
  22314   SPHDR(HDR)  ; HDR pas sed by ref .
  22315   "RTN","RCD PESP1",236 ,0)
  22316    ; HDR("RU NDATE") -  run date,  external f ormat
  22317   "RTN","RCD PESP1",237 ,0)
  22318    ;  HDR("P GNMBR") -  page numbe r
  22319   "RTN","RCD PESP1",238 ,0)
  22320    ;    HDR( "SITE") -  site name
  22321   "RTN","RCD PESP1",239 ,0)
  22322    N P,X,Y
  22323   "RTN","RCD PESP1",240 ,0)
  22324    S P=$G(HD R("PGNMBR" ))+1,HDR(" PGNMBR")=P   ; increm ent page c ount
  22325   "RTN","RCD PESP1",241 ,0)
  22326    ; 
  22327   "RTN","RCD PESP1",242 ,0)
  22328    S X=$$HDR LN
  22329   "RTN","RCD PESP1",243 ,0)
  22330    S P=IOM-( $L(X)+10)\ 2,Y=$J(" " ,P)_X_$J("  ",P)_" Pa ge: "_HDR( "PGNMBR")
  22331   "RTN","RCD PESP1",244 ,0)
  22332    W @IOF,Y
  22333   "RTN","RCD PESP1",245 ,0)
  22334    S X="   R un Date: " _HDR("RUND ATE"),Y=X_ $J(HDR("SI TE"),IOM-( $L(X)+1))
  22335   "RTN","RCD PESP1",246 ,0)
  22336    W !,Y
  22337   "RTN","RCD PESP1",247 ,0)
  22338    S Y=" "_$ TR($J("",I OM-2)," ", "-")  ; sp ace_row of  hyphens
  22339   "RTN","RCD PESP1",248 ,0)
  22340    W !,Y
  22341   "RTN","RCD PESP1",249 ,0)
  22342    Q
  22343   "RTN","RCD PESP1",250 ,0)
  22344    ;
  22345   "RTN","RCD PESP1",251 ,0)
  22346   AD2RPT(A)  ; add line  to report
  22347   "RTN","RCD PESP1",252 ,0)
  22348    Q:$G(A)=" "
  22349   "RTN","RCD PESP1",253 ,0)
  22350    N C S C=$ G(^TMP($J, "RC SP REP ORT",0))+1 ,^TMP($J," RC SP REPO RT",0)=C
  22351   "RTN","RCD PESP1",254 ,0)
  22352    S ^TMP($J ,"RC SP RE PORT",C,0) =A Q
  22353   "RTN","RCD PESP1",255 ,0)
  22354    ;
  22355   "RTN","RCD PESP1",256 ,0)
  22356   HDRLN() Q  "EDI Lockb ox Paramet ers Report "_$S($G(RC TYPE)="B": " - ALL",$ G(RCTYPE)= "M":" - ME DICAL",$G( RCTYPE)="P ":" - PHAR MACY",1:"" )  ; extri nsic varia ble
  22357   "RTN","RCD PESP1",257 ,0)
  22358    ;
  22359   "RTN","RCD PESP1",258 ,0)
  22360    ;Function  to check  to see if  the CARC p arameters  are to app ear on the  report
  22361   "RTN","RCD PESP1",259 ,0)
  22362   CARCCHK(RC TYPE,TYPE)  ;
  22363   "RTN","RCD PESP1",260 ,0)
  22364    ;
  22365   "RTN","RCD PESP1",261 ,0)
  22366    N RCMEN,R CREN
  22367   "RTN","RCD PESP1",262 ,0)
  22368    ;
  22369   "RTN","RCD PESP1",263 ,0)
  22370    ; Return  1 if valid  to print,  0 otherwi se
  22371   "RTN","RCD PESP1",264 ,0)
  22372    ;
  22373   "RTN","RCD PESP1",265 ,0)
  22374    Q:RCTYPE= "B"&($G(TY PE)="M") + $P($G(^RCY (344.61,1, 0)),U,3)   ;User want s all para meters and  we are ch ecking for  medical a uto decrea se
  22375   "RTN","RCD PESP1",266 ,0)
  22376    ;
  22377   "RTN","RCD PESP1",267 ,0)
  22378    Q:RCTYPE= "B"&($G(TY PE)="P") + $P($G(^RCY (344.61,1, 1)),U,2)   ;User want s all para meters and  we are ch ecking for  Pharmacy  auto decre ase
  22379   "RTN","RCD PESP1",268 ,0)
  22380    ;
  22381   "RTN","RCD PESP1",269 ,0)
  22382    S (RCMEN, RCREN)=""
  22383   "RTN","RCD PESP1",270 ,0)
  22384    ;
  22385   "RTN","RCD PESP1",271 ,0)
  22386    ;Print if  Report ty pe is medi cal and au to-decreas e for medi cal is on
  22387   "RTN","RCD PESP1",272 ,0)
  22388    I RCTYPE= "M" S RCME N=+$P($G(^ RCY(344.61 ,1,0)),U,3 ) Q RCMEN
  22389   "RTN","RCD PESP1",273 ,0)
  22390    ;
  22391   "RTN","RCD PESP1",274 ,0)
  22392    ;Print if  Report ty pe is phar macy and a uto-decrea se for pha rmacy is o n
  22393   "RTN","RCD PESP1",275 ,0)
  22394    I RCTYPE= "P" S RCRE N=+$P($G(^ RCY(344.61 ,1,1)),U,2 ) Q RCREN
  22395   "RTN","RCD PESP1",276 ,0)
  22396    ;
  22397   "RTN","RCD PESP1",277 ,0)
  22398    Q 0  ;Don 't print t he CARCs
  22399   "RTN","RCD PESP1",278 ,0)
  22400    ;
  22401   "RTN","RCD PESP2")
  22402   0^58^B1767 14545
  22403   "RTN","RCD PESP2",1,0 )
  22404   RCDPESP2 ; BIRM/SAB -  ePayment  Lockbox Pa rameter Au dit and Ex clusion Re ports ;07/ 01/15
  22405   "RTN","RCD PESP2",2,0 )
  22406    ;;4.5;Acc ounts Rece ivable;**2 98,304,317 ,321**;Mar  20, 1995; Build 46
  22407   "RTN","RCD PESP2",3,0 )
  22408    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  22409   "RTN","RCD PESP2",4,0 )
  22410    ;
  22411   "RTN","RCD PESP2",5,0 )
  22412    Q
  22413   "RTN","RCD PESP2",6,0 )
  22414    ;
  22415   "RTN","RCD PESP2",7,0 )
  22416   RPT1 ; EDI  Lockbox P arameters  Report [RC DPE SITE P ARAMETER R EPORT]
  22417   "RTN","RCD PESP2",8,0 )
  22418    ;
  22419   "RTN","RCD PESP2",9,0 )
  22420    ; DESCRIP TION: This  report is  a simple  listing of  the RCDPE  PARAMETER  AUDIT fil e
  22421   "RTN","RCD PESP2",10, 0)
  22422    ;               incl uding data  concernin g changes  to the RCD PE PPARAME TER file.
  22423   "RTN","RCD PESP2",11, 0)
  22424    ;
  22425   "RTN","RCD PESP2",12, 0)
  22426    ; Input:        None
  22427   "RTN","RCD PESP2",13, 0)
  22428    ;
  22429   "RTN","RCD PESP2",14, 0)
  22430    ; GLOBALS :     ^RCY (344.7,                RCDPE PAR AMETER AUD IT
  22431   "RTN","RCD PESP2",15, 0)
  22432    ;               ^TMP ("RCDPESP2 ",$J,       TMP FILE  FOR LIST^D IC OUTPUT
  22433   "RTN","RCD PESP2",16, 0)
  22434    ;
  22435   "RTN","RCD PESP2",17, 0)
  22436    ; GLOBALS :     ^RCY (344.7, -  RCDPE PARA METER AUDI T
  22437   "RTN","RCD PESP2",18, 0)
  22438    ;
  22439   "RTN","RCD PESP2",19, 0)
  22440    ; INPUT P ARAMETERS:  NONE
  22441   "RTN","RCD PESP2",20, 0)
  22442    ;
  22443   "RTN","RCD PESP2",21, 0)
  22444    ; LOCAL V ARIABLES:
  22445   "RTN","RCD PESP2",22, 0)
  22446    ;    RCRA NGE - RETU RN VALUE F OR DATE RA NGE FOR TH E REPORT
  22447   "RTN","RCD PESP2",23, 0)
  22448    ;    RCST DT  - STAR TING DATE  FOR THE RE PORT
  22449   "RTN","RCD PESP2",24, 0)
  22450    ;    RCEN DT  - END  DATE FOR T HE REPORT
  22451   "RTN","RCD PESP2",25, 0)
  22452    ;    RCEX CEL - INDI ATES IF OU TPUT IS GO ING TO EXC EL
  22453   "RTN","RCD PESP2",26, 0)
  22454    ;    RCSC R   - SCRE EN FOR LIS T^DIC CALL
  22455   "RTN","RCD PESP2",27, 0)
  22456    ;    RCFL DS  - FIEL DS TO BE C APTURED IN  LIST^DIC  CALL
  22457   "RTN","RCD PESP2",28, 0)
  22458    ;    RCDI GET   - ^T MP GLOBAL  RESULTS FR OM LIST^DI C CALL
  22459   "RTN","RCD PESP2",29, 0)
  22460    ;    RCDI ERR   - HO LDS ERRORS  FROM LIST ^DIC
  22461   "RTN","RCD PESP2",30, 0)
  22462    ;    RCHD R("RUNDATE ")   - DAT E THE REPO RT RAN
  22463   "RTN","RCD PESP2",31, 0)
  22464    ;    RCHD R("PAGE")   - PAGE CO UNTER
  22465   "RTN","RCD PESP2",32, 0)
  22466    ;    RCST OP  - STOP  DISPLAYIN G THE REPO RT
  22467   "RTN","RCD PESP2",33, 0)
  22468    ;    RCPA RAM - PARA METER THAT  WAS CHANG ED
  22469   "RTN","RCD PESP2",34, 0)
  22470    ;    RCPA RAM("OLDVA L")   - OL D PARAMETE R VALUE
  22471   "RTN","RCD PESP2",35, 0)
  22472    ;    RCPA RAM("TIME" )  - TIME  PARAMETER  WAS CHANGE D
  22473   "RTN","RCD PESP2",36, 0)
  22474    ;    RCPA RAM("NEWVA L")   - NE W PARAMETE R VALUE
  22475   "RTN","RCD PESP2",37, 0)
  22476    ;    RCPA RAM("USER" )  - USER  WHO CHANGE D A PARAME TER
  22477   "RTN","RCD PESP2",38, 0)
  22478    ;    RCTM P   - HOLD S ONE LINE  OF DATA F ROM LIST^D IC OUTPUT
  22479   "RTN","RCD PESP2",39, 0)
  22480    ;    RCTY PE  - TYPE  OF REPORT  TO RUN (M EDICAL, PH ARMACY, OR  BOTH)
  22481   "RTN","RCD PESP2",40, 0)
  22482    ;
  22483   "RTN","RCD PESP2",41, 0)
  22484    N RCDIERR ,RCDIGET,R CENDT,RCEX CEL,RCFLDS ,RCHDR,RCI EN,RCPARAM ,RCRANGE,R CSCR,RCSTD T,RCSTOP,R CTMP,RCTYP E,RCFILE,R CSL
  22485   "RTN","RCD PESP2",42, 0)
  22486    ; Kernel  variables
  22487   "RTN","RCD PESP2",43, 0)
  22488    N X1,X2,X ,Y,%ZIS,PO P
  22489   "RTN","RCD PESP2",44, 0)
  22490    S RCSTOP= 0,RCSL=0
  22491   "RTN","RCD PESP2",45, 0)
  22492    W !!,"EDI  Lockbox P arameters  Audit Repo rt",!
  22493   "RTN","RCD PESP2",46, 0)
  22494    ;
  22495   "RTN","RCD PESP2",47, 0)
  22496    S (RCHDR( "PAGE"),RC STOP,RCHDR ,RCEXCEL)= 0
  22497   "RTN","RCD PESP2",48, 0)
  22498    ;
  22499   "RTN","RCD PESP2",49, 0)
  22500    ; retriev e report t ype (Medic al, Pharma cy, or Bot h)
  22501   "RTN","RCD PESP2",50, 0)
  22502    S RCTYPE= $$RTYPE()
  22503   "RTN","RCD PESP2",51, 0)
  22504    Q:RCTYPE= -1
  22505   "RTN","RCD PESP2",52, 0)
  22506    S RCHDR(" REPORTTYPE ")=RCTYPE
  22507   "RTN","RCD PESP2",53, 0)
  22508    ;
  22509   "RTN","RCD PESP2",54, 0)
  22510    S RCRANGE =$$DTRNG()
  22511   "RTN","RCD PESP2",55, 0)
  22512    Q:RCRANGE =0
  22513   "RTN","RCD PESP2",56, 0)
  22514    S RCSTDT= $P(RCRANGE ,U,2),RCEN DT=$P(RCRA NGE,U,3)
  22515   "RTN","RCD PESP2",57, 0)
  22516    S RCEXCEL =$$DISPTY^ RCDPEM3()  Q:+RCEXCEL =-1
  22517   "RTN","RCD PESP2",58, 0)
  22518    ; Display  capture i nformation  for Excel
  22519   "RTN","RCD PESP2",59, 0)
  22520    I RCEXCEL  D INFO^RC DPEM6
  22521   "RTN","RCD PESP2",60, 0)
  22522    ;Select o utput devi ce
  22523   "RTN","RCD PESP2",61, 0)
  22524    S %ZIS="M " D ^%ZIS  Q:POP  U I O
  22525   "RTN","RCD PESP2",62, 0)
  22526    ; INPUT P ARAMETER:
  22527   "RTN","RCD PESP2",63, 0)
  22528    ;   RCEXC EL - IF 1  THEN OUTPU T FOR EXCE L
  22529   "RTN","RCD PESP2",64, 0)
  22530    ;
  22531   "RTN","RCD PESP2",65, 0)
  22532    S RCHDR(" RUNDATE")= $$FMTE^XLF DT($$NOW^X LFDT,"5S")
  22533   "RTN","RCD PESP2",66, 0)
  22534    S RCHDR(" DATERANGE" )=$$FMTE^X LFDT(RCSTD T,"5D")_"  - "_$$FMTE ^XLFDT(RCE NDT,"5D")
  22535   "RTN","RCD PESP2",67, 0)
  22536    ;
  22537   "RTN","RCD PESP2",68, 0)
  22538    S RCENDT= RCENDT+.99 9999
  22539   "RTN","RCD PESP2",69, 0)
  22540    ;S RCSCR= "I ($P(^(0 ),U,5)=344 .61)&($P(^ (0),U,1)>" _RCSTDT_") &($P(^(0), U,1)<"_RCE NDT_")"
  22541   "RTN","RCD PESP2",70, 0)
  22542    S RCSCR=" I ($P(^(0) ,U,1)>"_RC STDT_")&($ P(^(0),U,1 )<"_RCENDT _")"
  22543   "RTN","RCD PESP2",71, 0)
  22544    S RCFLDS= "@;.04;.01 I;.07;.06; .03;.05I;. 02"
  22545   "RTN","RCD PESP2",72, 0)
  22546    S RCDIGET =$NA(^TMP( "RCDPESP2" ,$J)) K @R CDIGET
  22547   "RTN","RCD PESP2",73, 0)
  22548    D LIST^DI C(344.7,,R CFLDS,"P", ,,,,RCSCR, ,RCDIGET," RCDIERR")
  22549   "RTN","RCD PESP2",74, 0)
  22550    I $D(RCDI ERR) W !!, "ERROR COL LECTING TH E REPORT D ATA" D ASK ^RCDPEARL( ) Q
  22551   "RTN","RCD PESP2",75, 0)
  22552    I '$D(@RC DIGET@("DI LIST",1))  D  Q
  22553   "RTN","RCD PESP2",76, 0)
  22554    . D HDRLP R(RCEXCEL, .RCHDR,.RC STOP) S RC SL=9
  22555   "RTN","RCD PESP2",77, 0)
  22556    . W !,"NO  PARAMETER  AUDIT ENT RIES TO RE PORT",!
  22557   "RTN","RCD PESP2",78, 0)
  22558    . D ASK^R CDPEARL(.R CSTOP)
  22559   "RTN","RCD PESP2",79, 0)
  22560    S RCIEN=0  F  S RCIE N=$O(@RCDI GET@("DILI ST",RCIEN) ) Q:RCSTOP !('RCIEN)   D
  22561   "RTN","RCD PESP2",80, 0)
  22562    . I 'RCHD R("PAGE")  D
  22563   "RTN","RCD PESP2",81, 0)
  22564    . . D HDR LPR(RCEXCE L,.RCHDR,. RCSTOP) S  RCSL=9
  22565   "RTN","RCD PESP2",82, 0)
  22566    . Q:RCSTO P
  22567   "RTN","RCD PESP2",83, 0)
  22568    . K RCPAR AM
  22569   "RTN","RCD PESP2",84, 0)
  22570    . S RCTMP =$P(@RCDIG ET@("DILIS T",RCIEN,0 ),U,2,8)
  22571   "RTN","RCD PESP2",85, 0)
  22572    . S RCFIL E=$P(RCTMP ,U,6)
  22573   "RTN","RCD PESP2",86, 0)
  22574    . ;
  22575   "RTN","RCD PESP2",87, 0)
  22576    . Q:RCFIL E=344.6  ;  Excluded  payers rep orted elsw here
  22577   "RTN","RCD PESP2",88, 0)
  22578    . ;
  22579   "RTN","RCD PESP2",89, 0)
  22580    . S RCPAR AM=$$GET1^ DID(RCFILE ,$P(RCTMP, U,1),,"LAB EL")
  22581   "RTN","RCD PESP2",90, 0)
  22582    . ;
  22583   "RTN","RCD PESP2",91, 0)
  22584    . Q:'$$RP TYPE(RCTYP E,RCPARAM)
  22585   "RTN","RCD PESP2",92, 0)
  22586    . S RCPAR AM("TIME") =$$FMTE^XL FDT($P(RCT MP,U,2),"2 ")
  22587   "RTN","RCD PESP2",93, 0)
  22588    . S RCPAR AM("USER") =$P(RCTMP, U,5)
  22589   "RTN","RCD PESP2",94, 0)
  22590    . I ($P(R CTMP,U,1)= .02)!($P(R CTMP,U,1)= 1.01) D
  22591   "RTN","RCD PESP2",95, 0)
  22592    . . I RCF ILE=344.62  S RCPARAM =RCPARAM_"  ("_$S($P( RCTMP,U,7) '="":$P($G (^RCY(RCFI LE,$P(RCTM P,U,7),0)) ,U,1),1:"E RR")_")"
  22593   "RTN","RCD PESP2",96, 0)
  22594    . . S RCP ARAM("OLDV AL")=$S(+$ P(RCTMP,U, 3)=0:"No", +$P(RCTMP, U,3)=1:"Ye s",1:"Err" )
  22595   "RTN","RCD PESP2",97, 0)
  22596    . . S RCP ARAM("NEWV AL")=$S(+$ P(RCTMP,U, 4)=0:"No", +$P(RCTMP, U,4)=1:"Ye s",1:"Err" )
  22597   "RTN","RCD PESP2",98, 0)
  22598    . ; Next  line - add ed EDI cla im auto-au dit parame ter fields  - PRCA*4. 5*321
  22599   "RTN","RCD PESP2",99, 0)
  22600    . I ($P(R CTMP,U,1)= .03)!($P(R CTMP,U,1)= 7.05)!($P( RCTMP,U,1) =7.06)!($P (RCTMP,U,1 )=7.07)!($ P(RCTMP,U, 1)=7.08) D
  22601   "RTN","RCD PESP2",100 ,0)
  22602    . . S RCP ARAM("OLDV AL")=$S($P (RCTMP,U,3 ):"Yes",1: "No")
  22603   "RTN","RCD PESP2",101 ,0)
  22604    . . S RCP ARAM("NEWV AL")=$S($P (RCTMP,U,4 ):"Yes",1: "No")
  22605   "RTN","RCD PESP2",102 ,0)
  22606    . I (RCFI LE=344.62) &($P(RCTMP ,U,1)=.06)  D
  22607   "RTN","RCD PESP2",103 ,0)
  22608    . . S RCP ARAM=RCPAR AM_" ("_$S ($P(RCTMP, U,7)'="":$ P($G(^RCY( RCFILE,$P( RCTMP,U,7) ,0)),U,1), 1:"ERR")_" )"
  22609   "RTN","RCD PESP2",104 ,0)
  22610    . ; Next  line - add ed EDI cla im auto-au dit parame ter fields  - PRCA*4. 5*321
  22611   "RTN","RCD PESP2",105 ,0)
  22612    . I ($P(R CTMP,U,1)' =.02),($P( RCTMP,U,1) '=.03),($P (RCTMP,U,1 )'=1.01),( $P(RCTMP,U ,1)'=7.05) ,($P(RCTMP ,U,1)'=7.0 6),($P(RCT MP,U,1)'=7 .07),($P(R CTMP,U,1)' =7.08) D
  22613   "RTN","RCD PESP2",106 ,0)
  22614    . . S RCP ARAM("OLDV AL")=$P(RC TMP,U,3)
  22615   "RTN","RCD PESP2",107 ,0)
  22616    . . S RCP ARAM("NEWV AL")=$P(RC TMP,U,4)
  22617   "RTN","RCD PESP2",108 ,0)
  22618    . I 'RCEX CEL D
  22619   "RTN","RCD PESP2",109 ,0)
  22620    . . W !,R CPARAM,?32 ,RCPARAM(" TIME"),?51 ,RCPARAM(" OLDVAL"),? 56,RCPARAM ("NEWVAL") ,?61,$E(RC PARAM("USE R"),1,IOM- 61) S RCSL =RCSL+1
  22621   "RTN","RCD PESP2",110 ,0)
  22622    . . I RCS L>=(IOSL-2 ) D HDRLPR (RCEXCEL,. RCHDR,.RCS TOP) Q:RCS TOP  S RCS L=9
  22623   "RTN","RCD PESP2",111 ,0)
  22624    . I RCEXC EL W !,RCP ARAM_U_RCP ARAM("TIME ")_U_RCPAR AM("OLDVAL ")_U_RCPAR AM("NEWVAL ")_U_RCPAR AM("USER")
  22625   "RTN","RCD PESP2",112 ,0)
  22626    ;
  22627   "RTN","RCD PESP2",113 ,0)
  22628    ; end of  report
  22629   "RTN","RCD PESP2",114 ,0)
  22630    I 'RCSTOP  W !!,$$EN DORPRT^RCD PEARL D AS K^RCDPEARL (.RCSTOP)
  22631   "RTN","RCD PESP2",115 ,0)
  22632   RPT1Q K @R CDIGET
  22633   "RTN","RCD PESP2",116 ,0)
  22634    Q
  22635   "RTN","RCD PESP2",117 ,0)
  22636    ;
  22637   "RTN","RCD PESP2",118 ,0)
  22638   HDRLPR(RCE XCEL,RCHDR ,RCSTOP) ;  Report he ader Lockb ox Paramet er Report
  22639   "RTN","RCD PESP2",119 ,0)
  22640    ;   RCEXC EL - if tr ue output  for Excel
  22641   "RTN","RCD PESP2",120 ,0)
  22642    ;   RCHDR ("PAGE") -  page coun t, passed  by ref.
  22643   "RTN","RCD PESP2",121 ,0)
  22644    ;   RCSTO P  - repor t exit fla g
  22645   "RTN","RCD PESP2",122 ,0)
  22646    ;   RCTYP E  - Type  of report  to run
  22647   "RTN","RCD PESP2",123 ,0)
  22648    ;
  22649   "RTN","RCD PESP2",124 ,0)
  22650    N RCTYPED
  22651   "RTN","RCD PESP2",125 ,0)
  22652    S RCTYPED =$S(RCHDR( "REPORTTYP E")="M":"M EDICAL",RC HDR("REPOR TTYPE")="P ":"PHARMAC Y",1:"ALL" )
  22653   "RTN","RCD PESP2",126 ,0)
  22654    ;
  22655   "RTN","RCD PESP2",127 ,0)
  22656    I RCEXCEL  D  Q  ; E xcel heade r for PARA METER AUDI TS
  22657   "RTN","RCD PESP2",128 ,0)
  22658    .Q:RCHDR( "PAGE")
  22659   "RTN","RCD PESP2",129 ,0)
  22660    .W !,"PAR AMETER^DAT E/TIME EDI TED^OLD VA LUE^NEW VA LUE^USER"
  22661   "RTN","RCD PESP2",130 ,0)
  22662    .S RCHDR( "PAGE")=1   ; only pr int once
  22663   "RTN","RCD PESP2",131 ,0)
  22664    ;
  22665   "RTN","RCD PESP2",132 ,0)
  22666    I 'RCEXCE L D
  22667   "RTN","RCD PESP2",133 ,0)
  22668    .I RCHDR( "PAGE") D  ASK^RCDPEA RL(.RCSTOP ) Q:RCSTOP
  22669   "RTN","RCD PESP2",134 ,0)
  22670    .W @IOF
  22671   "RTN","RCD PESP2",135 ,0)
  22672    .S RCHDR( "PAGE")=RC HDR("PAGE" )+1
  22673   "RTN","RCD PESP2",136 ,0)
  22674    . W $$CNT R("EDI Loc kbox Param eter Audit  Report"), ?IOM-8,"Pa ge: "_RCHD R("PAGE")
  22675   "RTN","RCD PESP2",137 ,0)
  22676    . W !,$$C NTR("RUN D ATE: "_RCH DR("RUNDAT E"))
  22677   "RTN","RCD PESP2",138 ,0)
  22678    . W !,$$C NTR("DATE  RANGE: "_R CHDR("DATE RANGE"))
  22679   "RTN","RCD PESP2",139 ,0)
  22680    . W !,$$C NTR("REPOR T TYPE: "_ RCTYPED)
  22681   "RTN","RCD PESP2",140 ,0)
  22682    . W !!,"L OCKBOX PAR AMETER UPD ATES"
  22683   "RTN","RCD PESP2",141 ,0)
  22684    . W !,"-- ---------- ---------- ---                              Values"
  22685   "RTN","RCD PESP2",142 ,0)
  22686    . W !,"Pa rameter                          Date/Time  Edited   O ld  New  U ser"
  22687   "RTN","RCD PESP2",143 ,0)
  22688    . N I S $ P(I,"=",IO M+1)="" W  !,I
  22689   "RTN","RCD PESP2",144 ,0)
  22690    Q
  22691   "RTN","RCD PESP2",145 ,0)
  22692    ;
  22693   "RTN","RCD PESP2",146 ,0)
  22694   RPT2 ; EDI  Lockbox E xclusion A udit Repor t [RCDPE E XCLUSION A UDIT REPOR T]
  22695   "RTN","RCD PESP2",147 ,0)
  22696    ;
  22697   "RTN","RCD PESP2",148 ,0)
  22698    ; DESCRIP TION: This  report is  a simple  listing of  the RCDPE  PARAMETER  AUDIT fil e
  22699   "RTN","RCD PESP2",149 ,0)
  22700    ;               incl uding data  concernin g changes  to the RCD PE AUTO-PA Y EXCLUSIO N file.
  22701   "RTN","RCD PESP2",150 ,0)
  22702    ;
  22703   "RTN","RCD PESP2",151 ,0)
  22704    ; GLOBALS :     ^RCY (344.7,                RCDPE PAR AMETER AUD IT
  22705   "RTN","RCD PESP2",152 ,0)
  22706    ;               ^RCY (344.6,                RCDPE AUT O-PAY EXCL USION
  22707   "RTN","RCD PESP2",153 ,0)
  22708    ;               ^TMP ("RCDPESP2 ",$J,       TMP FILE  FOR LIST D IC OUTPUT
  22709   "RTN","RCD PESP2",154 ,0)
  22710    ;
  22711   "RTN","RCD PESP2",155 ,0)
  22712    ; INPUT P ARAMETERS:  NONE
  22713   "RTN","RCD PESP2",156 ,0)
  22714    ;
  22715   "RTN","RCD PESP2",157 ,0)
  22716    ; LOCAL V ARIABLES:
  22717   "RTN","RCD PESP2",158 ,0)
  22718    ;    RCRA NGE - date  range for  report
  22719   "RTN","RCD PESP2",159 ,0)
  22720    ;    RCST DT  - repo rt start d ate
  22721   "RTN","RCD PESP2",160 ,0)
  22722    ;    RCEN DT  - repo rt end dat e
  22723   "RTN","RCD PESP2",161 ,0)
  22724    ;    RCEX CEL - true  if report  in Excel  format
  22725   "RTN","RCD PESP2",162 ,0)
  22726    ;    RCSC R - screen ing logic  for LIST^D IC
  22727   "RTN","RCD PESP2",163 ,0)
  22728    ;    RCFL DS  - fiel ds for LIS T^DIC
  22729   "RTN","RCD PESP2",164 ,0)
  22730    ;    RCDI GET - stor age for re sults from  LIST^DIC
  22731   "RTN","RCD PESP2",165 ,0)
  22732    ;    RCDI ERR - erro rs from LI ST^DIC
  22733   "RTN","RCD PESP2",166 ,0)
  22734    ;    RCHD R("PAGE")   - page co unter
  22735   "RTN","RCD PESP2",167 ,0)
  22736    ;    RCHD R("RUNDATE ") - date/ time repor t was run 
  22737   "RTN","RCD PESP2",168 ,0)
  22738    ;    RCST OP  - repo rt exit fl ag
  22739   "RTN","RCD PESP2",169 ,0)
  22740    ;    RCPA RAM - para meter that  was chang ed
  22741   "RTN","RCD PESP2",170 ,0)
  22742    ;    RCPA RAM("TIME" )   - time  parameter  changed
  22743   "RTN","RCD PESP2",171 ,0)
  22744    ;    RCPA RAM("OLDVA L") - old  parameter  value
  22745   "RTN","RCD PESP2",172 ,0)
  22746    ;    RCPA RAM("NEWVA L") - new  parameter  value
  22747   "RTN","RCD PESP2",173 ,0)
  22748    ;    RCPA RAM("USER" )  - USER  WHO CHANGE D A PARAME TER
  22749   "RTN","RCD PESP2",174 ,0)
  22750    ;    RCTM P - one re cord from  LIST^DIC
  22751   "RTN","RCD PESP2",175 ,0)
  22752    ;    RCFN D - flag i ndicating  records re turned
  22753   "RTN","RCD PESP2",176 ,0)
  22754    ;    RCTY PE  - TYPE  OF REPORT  TO RUN (M EDICAL, PH ARMACY, OR  BOTH)
  22755   "RTN","RCD PESP2",177 ,0)
  22756    ;
  22757   "RTN","RCD PESP2",178 ,0)
  22758    W !!,"    EDI Lockbo x Exclusio n Audit Re port",!
  22759   "RTN","RCD PESP2",179 ,0)
  22760    ;
  22761   "RTN","RCD PESP2",180 ,0)
  22762    N RCENDT, RCEXCEL,RC FLDS,RCFND ,RCDIGET,R CHDR,RCIEN ,RCDIERR,R CPARAM,RCR ANGE,RCSCR ,RCSTDT,RC STOP,RCTMP ,RCTYPE,RC SCRTYP,RCD IMED,RCDIR X
  22763   "RTN","RCD PESP2",181 ,0)
  22764    ; Kernel  variables
  22765   "RTN","RCD PESP2",182 ,0)
  22766    N X1,X2,X ,Y,%ZIS,PO P
  22767   "RTN","RCD PESP2",183 ,0)
  22768    ; initial ize values
  22769   "RTN","RCD PESP2",184 ,0)
  22770    S (RCHDR( "PAGE"),RC STOP,RCIEN ,RCEXCEL,R CFND)=0
  22771   "RTN","RCD PESP2",185 ,0)
  22772    S RCDIGET =$NA(^TMP( "RCDPESP2" ,$J)) K @R CDIGET
  22773   "RTN","RCD PESP2",186 ,0)
  22774    ; PRCA*4. 5*304 - Me dical and  RX audit e ntries
  22775   "RTN","RCD PESP2",187 ,0)
  22776    S RCDIMED =$NA(^TMP( "RCDPESP2- MED",$J))  K @RCDIMED
  22777   "RTN","RCD PESP2",188 ,0)
  22778    S RCDIRX= $NA(^TMP(" RCDPESP2-R X",$J)) K  @RCDIRX
  22779   "RTN","RCD PESP2",189 ,0)
  22780    ;
  22781   "RTN","RCD PESP2",190 ,0)
  22782    S RCTYPE= $$RTYPE()
  22783   "RTN","RCD PESP2",191 ,0)
  22784    Q:RCTYPE= -1
  22785   "RTN","RCD PESP2",192 ,0)
  22786    S RCHDR(" REPORTTYPE ")=RCTYPE
  22787   "RTN","RCD PESP2",193 ,0)
  22788    ;
  22789   "RTN","RCD PESP2",194 ,0)
  22790    ; GET DAT E RANGES
  22791   "RTN","RCD PESP2",195 ,0)
  22792    S RCRANGE =$$DTRNG()
  22793   "RTN","RCD PESP2",196 ,0)
  22794    Q:RCRANGE =0
  22795   "RTN","RCD PESP2",197 ,0)
  22796    S RCSTDT= $P(RCRANGE ,U,2)-.000 0001,RCEND T=$P(RCRAN GE,U,3)+.9 999999
  22797   "RTN","RCD PESP2",198 ,0)
  22798    ;
  22799   "RTN","RCD PESP2",199 ,0)
  22800    ; output  fields for  LIST^DIC
  22801   "RTN","RCD PESP2",200 ,0)
  22802    S RCFLDS= "@;.04;.01 I;.06;.03; .08;.02"
  22803   "RTN","RCD PESP2",201 ,0)
  22804    ; .04 - C HANGED FIE LD  .01 -  TIMESTAMP       .06 -  NEW VALUE
  22805   "RTN","RCD PESP2",202 ,0)
  22806    ; .03 - C HANGED BY      .08 -  COMMENT         .02 -  MODIFIED  IEN
  22807   "RTN","RCD PESP2",203 ,0)
  22808    ;
  22809   "RTN","RCD PESP2",204 ,0)
  22810    ; first p art of LIS T^DIC scre ening logi c
  22811   "RTN","RCD PESP2",205 ,0)
  22812    S RCSCR=" I ($P(^(0) ,U,5)=344. 6)&($P(^(0 ),U,1)>"_R CSTDT_")&( $P(^(0),U, 1)<"_RCEND T_")"
  22813   "RTN","RCD PESP2",206 ,0)
  22814    ;
  22815   "RTN","RCD PESP2",207 ,0)
  22816    ; OUTPUT  TO EXCEL?
  22817   "RTN","RCD PESP2",208 ,0)
  22818    S RCEXCEL =$$DISPTY^ RCDPEM3()  Q:+RCEXCEL =-1
  22819   "RTN","RCD PESP2",209 ,0)
  22820    I RCEXCEL  D INFO^RC DPEM6
  22821   "RTN","RCD PESP2",210 ,0)
  22822    ;
  22823   "RTN","RCD PESP2",211 ,0)
  22824    ;Select o utput devi ce
  22825   "RTN","RCD PESP2",212 ,0)
  22826    S %ZIS="M " D ^%ZIS  Q:POP  U I O
  22827   "RTN","RCD PESP2",213 ,0)
  22828    ;
  22829   "RTN","RCD PESP2",214 ,0)
  22830    S RCHDR(" RUNDATE")= $$FMTE^XLF DT($$NOW^X LFDT,"5S")
  22831   "RTN","RCD PESP2",215 ,0)
  22832    ;
  22833   "RTN","RCD PESP2",216 ,0)
  22834    ; PROCESS  AUTO-POST  EXCLUSION S
  22835   "RTN","RCD PESP2",217 ,0)
  22836    ;
  22837   "RTN","RCD PESP2",218 ,0)
  22838    ; PRCA*4. 5*304 - Ge t the corr ect screen ing logic,  based on  the type o f audit re eport to r un
  22839   "RTN","RCD PESP2",219 ,0)
  22840    S RCSCR(. 06)=RCSCR_ "&($P(^(0) ,U,4)=.06) " ; screen ing logic  for medica l auto-pos t
  22841   "RTN","RCD PESP2",220 ,0)
  22842    S RCSCR(. 07)=RCSCR_ "&($P(^(0) ,U,4)=.07) " ; screen ing logic  for medica l auto-dec rease
  22843   "RTN","RCD PESP2",221 ,0)
  22844    S RCSCR(. 08)=RCSCR_ "&($P(^(0) ,U,4)=.08) " ; screen ing logic  for pharma cy auto-po st
  22845   "RTN","RCD PESP2",222 ,0)
  22846    ;
  22847   "RTN","RCD PESP2",223 ,0)
  22848    ;PRCA*4.5 *304 - Get  the medic al and RX  audit entr ies for Au to-Post ex clusions
  22849   "RTN","RCD PESP2",224 ,0)
  22850    D LIST^DI C(344.7,,R CFLDS,"P", ,,,,RCSCR( .06),,RCDI MED,"RCDIE RR")
  22851   "RTN","RCD PESP2",225 ,0)
  22852    ; CHECK F OR AN ERRO R
  22853   "RTN","RCD PESP2",226 ,0)
  22854    I $D(RCDI ERR) W !!, "Error col lecting au to-post re port data. " D ASK^RC DPEARL(.RC STOP) Q
  22855   "RTN","RCD PESP2",227 ,0)
  22856    ;
  22857   "RTN","RCD PESP2",228 ,0)
  22858    ; Get the  correct s creening l ogic, base d on the t ype of aud it to run
  22859   "RTN","RCD PESP2",229 ,0)
  22860    D LIST^DI C(344.7,,R CFLDS,"P", ,,,,RCSCR( .07),,RCDI GET,"RCDIE RR")
  22861   "RTN","RCD PESP2",230 ,0)
  22862    ;
  22863   "RTN","RCD PESP2",231 ,0)
  22864    ; CHECK F OR AN ERRO R
  22865   "RTN","RCD PESP2",232 ,0)
  22866    I $D(RCDI ERR) W !!, "Error col lecting au to-decreas e report d ata." D AS K^RCDPEARL (.RCSTOP)  Q
  22867   "RTN","RCD PESP2",233 ,0)
  22868    ;
  22869   "RTN","RCD PESP2",234 ,0)
  22870    D LIST^DI C(344.7,,R CFLDS,"P", ,,,,RCSCR( .08),,RCDI RX,"RCDIER R")
  22871   "RTN","RCD PESP2",235 ,0)
  22872    ; CHECK F OR AN ERRO R
  22873   "RTN","RCD PESP2",236 ,0)
  22874    I $D(RCDI ERR) W !!, "Error col lecting au to-post re port data. " D ASK^RC DPEARL(.RC STOP) Q
  22875   "RTN","RCD PESP2",237 ,0)
  22876    ;
  22877   "RTN","RCD PESP2",238 ,0)
  22878    I (RCTYPE ="B")!(RCT YPE="M") D   G:RCSTOP  RPT2Q
  22879   "RTN","RCD PESP2",239 ,0)
  22880    . D HDRXA R(.06,RCTY PE)  ; com plete head er
  22881   "RTN","RCD PESP2",240 ,0)
  22882    . ;
  22883   "RTN","RCD PESP2",241 ,0)
  22884    . S RCFND =$D(@RCDIM ED@("DILIS T",1))  ;  CHECK FOR  RECORDS RE TURNED
  22885   "RTN","RCD PESP2",242 ,0)
  22886    . I 'RCFN D W !,"No  Auto-post  Exclusions  to Displa y",!
  22887   "RTN","RCD PESP2",243 ,0)
  22888    . ;
  22889   "RTN","RCD PESP2",244 ,0)
  22890    . I RCFND  S RCIEN=0  D
  22891   "RTN","RCD PESP2",245 ,0)
  22892    .. F  S R CIEN=$O(@R CDIMED@("D ILIST",RCI EN)) Q:RCS TOP!('RCIE N)  D
  22893   "RTN","RCD PESP2",246 ,0)
  22894    ... S RCT MP=$P(@RCD IMED@("DIL IST",RCIEN ,0),U,2,7)
  22895   "RTN","RCD PESP2",247 ,0)
  22896    ... I 'RC EXCEL,$Y+4 >IOSL D HD RXAR(.06,R CTYPE) Q:R CSTOP
  22897   "RTN","RCD PESP2",248 ,0)
  22898    ... D DSP XCLSN(RCTM P)
  22899   "RTN","RCD PESP2",249 ,0)
  22900    . ; PROCE SS MEDICAL  AUTO-DECR EASE EXCLU SIONS
  22901   "RTN","RCD PESP2",250 ,0)
  22902    . D  ; co mplete hea der or jus t the sect ion
  22903   "RTN","RCD PESP2",251 ,0)
  22904    .. I $Y+1 1<IOSL D S ECTHDR(.07 )  Q  ; ju st section  header
  22905   "RTN","RCD PESP2",252 ,0)
  22906    .. D HDRX AR(.07,RCT YPE)  ; co mplete hea der
  22907   "RTN","RCD PESP2",253 ,0)
  22908    . ;
  22909   "RTN","RCD PESP2",254 ,0)
  22910    . S RCFND =$D(@RCDIG ET@("DILIS T",1))  ;  CHECK FOR  RECORDS RE TURNED
  22911   "RTN","RCD PESP2",255 ,0)
  22912    . I 'RCFN D W !,"No  Auto-decre ase Exclus ions to Di splay",!
  22913   "RTN","RCD PESP2",256 ,0)
  22914    . ; RECOR DS RETURNE D
  22915   "RTN","RCD PESP2",257 ,0)
  22916    . I RCFND  S RCIEN=0  F  S RCIE N=$O(@RCDI GET@("DILI ST",RCIEN) ) Q:RCSTOP !('RCIEN)   D
  22917   "RTN","RCD PESP2",258 ,0)
  22918    .. S RCTM P=$P(@RCDI GET@("DILI ST",RCIEN, 0),U,2,7)
  22919   "RTN","RCD PESP2",259 ,0)
  22920    .. I $Y+4 >IOSL D HD RXAR(.07,R CTYPE) Q:R CSTOP
  22921   "RTN","RCD PESP2",260 ,0)
  22922    .. D DSPX CLSN(RCTMP )
  22923   "RTN","RCD PESP2",261 ,0)
  22924    ;
  22925   "RTN","RCD PESP2",262 ,0)
  22926    I (RCTYPE ="B")!(RCT YPE="P") D   G:RCSTOP  RPT2Q
  22927   "RTN","RCD PESP2",263 ,0)
  22928    . I RCTYP E="P" D HD RXAR(.08,R CTYPE)  ;  complete h eader
  22929   "RTN","RCD PESP2",264 ,0)
  22930    . I RCTYP E'="P" D   ; complete  header or  just the  section
  22931   "RTN","RCD PESP2",265 ,0)
  22932    .. I $Y+1 1<IOSL D S ECTHDR(.08 )  Q  ; ju st section  header
  22933   "RTN","RCD PESP2",266 ,0)
  22934    .. D HDRX AR(.08,RCT YPE)  ; co mplete hea der
  22935   "RTN","RCD PESP2",267 ,0)
  22936    . ;
  22937   "RTN","RCD PESP2",268 ,0)
  22938    . S RCFND =$D(@RCDIR X@("DILIST ",1))  ; C HECK FOR R ECORDS RET URNED
  22939   "RTN","RCD PESP2",269 ,0)
  22940    . I 'RCFN D W !,"No  Auto-decre ase Exclus ions to Di splay",!
  22941   "RTN","RCD PESP2",270 ,0)
  22942    . ; RECOR DS RETURNE D
  22943   "RTN","RCD PESP2",271 ,0)
  22944    . I RCFND  S RCIEN=0  F  S RCIE N=$O(@RCDI RX@("DILIS T",RCIEN))  Q:RCSTOP! ('RCIEN)   D
  22945   "RTN","RCD PESP2",272 ,0)
  22946    .. S RCTM P=$P(@RCDI RX@("DILIS T",RCIEN,0 ),U,2,7)
  22947   "RTN","RCD PESP2",273 ,0)
  22948    .. I $Y+4 >IOSL D HD RXAR(.08,R CTYPE) Q:R CSTOP
  22949   "RTN","RCD PESP2",274 ,0)
  22950    .. D DSPX CLSN(RCTMP )
  22951   "RTN","RCD PESP2",275 ,0)
  22952    ;
  22953   "RTN","RCD PESP2",276 ,0)
  22954    ; end of  report
  22955   "RTN","RCD PESP2",277 ,0)
  22956    W !!,$$EN DORPRT^RCD PEARL
  22957   "RTN","RCD PESP2",278 ,0)
  22958    D ASK^RCD PEARL(.RCS TOP)
  22959   "RTN","RCD PESP2",279 ,0)
  22960    ;
  22961   "RTN","RCD PESP2",280 ,0)
  22962   RPT2Q ;
  22963   "RTN","RCD PESP2",281 ,0)
  22964    K @RCDIGE T,@RCDIMED ,@RCDIRX   ; clean up
  22965   "RTN","RCD PESP2",282 ,0)
  22966    Q
  22967   "RTN","RCD PESP2",283 ,0)
  22968    ;
  22969   "RTN","RCD PESP2",284 ,0)
  22970   GETPAYER()  ; GET THE  PAYER NAM E + PAYER  ID
  22971   "RTN","RCD PESP2",285 ,0)
  22972    N RCIEN,R CPAYR
  22973   "RTN","RCD PESP2",286 ,0)
  22974    S RCIEN=$ P(RCTMP,U, 6)
  22975   "RTN","RCD PESP2",287 ,0)
  22976    I '$D(^RC Y(344.6,RC IEN)) Q ""
  22977   "RTN","RCD PESP2",288 ,0)
  22978    S RCPAYR= $$GET1^DIQ (344.6,RCI EN_",",.01 )_" "_$$GE T1^DIQ(344 .6,RCIEN_" ,",.02)
  22979   "RTN","RCD PESP2",289 ,0)
  22980    Q RCPAYR
  22981   "RTN","RCD PESP2",290 ,0)
  22982    ;
  22983   "RTN","RCD PESP2",291 ,0)
  22984   HDRXAR(RCT YP,RCTYPD)  ; Report  header for  exclusin  auto repor t
  22985   "RTN","RCD PESP2",292 ,0)
  22986    ;   RCTYP  -   .06 =  AUTO-POST ING EXCLUS ION (medic al)
  22987   "RTN","RCD PESP2",293 ,0)
  22988    ;              .07 =  AUTO-DECR EASE EXCLU SION (medi cal)
  22989   "RTN","RCD PESP2",294 ,0)
  22990    ;              .08 =  AUTO-POST ING EXCLUS ION (pharm acy)
  22991   "RTN","RCD PESP2",295 ,0)
  22992    ;   RCTYP D  - M = M edical
  22993   "RTN","RCD PESP2",296 ,0)
  22994    ;              P = P harmacy
  22995   "RTN","RCD PESP2",297 ,0)
  22996    ;              B = B oth
  22997   "RTN","RCD PESP2",298 ,0)
  22998    ;
  22999   "RTN","RCD PESP2",299 ,0)
  23000    N RCTYPED
  23001   "RTN","RCD PESP2",300 ,0)
  23002    S RCTYPED =$S(RCTYPD ="M":"MEDI CAL",RCTYP D="P":"PHA RMACY",1:" ALL")
  23003   "RTN","RCD PESP2",301 ,0)
  23004    ;
  23005   "RTN","RCD PESP2",302 ,0)
  23006    I RCEXCEL  D  Q
  23007   "RTN","RCD PESP2",303 ,0)
  23008    .Q:RCHDR( "PAGE")
  23009   "RTN","RCD PESP2",304 ,0)
  23010    .; Excel  header for  parameter  audits
  23011   "RTN","RCD PESP2",305 ,0)
  23012    .W !!,"TY PE^CHANGE^ PAYER^TIME STAMP^USER ^COMMENT"
  23013   "RTN","RCD PESP2",306 ,0)
  23014    .S RCHDR( "PAGE")=1   ; only pr int it onc e
  23015   "RTN","RCD PESP2",307 ,0)
  23016    ;
  23017   "RTN","RCD PESP2",308 ,0)
  23018    I RCHDR(" PAGE") D A SK^RCDPEAR L(.RCSTOP)  Q:RCSTOP
  23019   "RTN","RCD PESP2",309 ,0)
  23020    W @IOF
  23021   "RTN","RCD PESP2",310 ,0)
  23022    S RCHDR(" PAGE")=RCH DR("PAGE") +1
  23023   "RTN","RCD PESP2",311 ,0)
  23024    ; report  header for  parameter  audits
  23025   "RTN","RCD PESP2",312 ,0)
  23026    W $$CNTR( "EDI Lockb ox Exclusi on Audit R eport"),?I OM-8,"Page : "_RCHDR( "PAGE")
  23027   "RTN","RCD PESP2",313 ,0)
  23028    W !,$$CNT R("DIVISIO NS: ALL")
  23029   "RTN","RCD PESP2",314 ,0)
  23030    W !,$$CNT R("RUN DAT E: "_$G(RC HDR("RUNDA TE")))
  23031   "RTN","RCD PESP2",315 ,0)
  23032    W !,$$CNT R("DATE RA NGE: "_$$F MTE^XLFDT( $P(RCRANGE ,U,2),"5D" )_" - "_$$ FMTE^XLFDT ($P(RCRANG E,U,3),"5D "))
  23033   "RTN","RCD PESP2",316 ,0)
  23034    W !,$$CNT R("REPORT  TYPE: "_RC TYPED)
  23035   "RTN","RCD PESP2",317 ,0)
  23036    D SECTHDR (RCTYP,RCT YPD)
  23037   "RTN","RCD PESP2",318 ,0)
  23038    Q
  23039   "RTN","RCD PESP2",319 ,0)
  23040    ;
  23041   "RTN","RCD PESP2",320 ,0)
  23042   SECTHDR(RC TYPE,RCREP T) ; SECTI ON HEADER
  23043   "RTN","RCD PESP2",321 ,0)
  23044    ;   RCTYP  - .06 = A UTO-POSTIN G EXCLUSIO N (medical )
  23045   "RTN","RCD PESP2",322 ,0)
  23046    ;            .07 = A UTO-DECREA SE EXCLUSI ON (medica l)
  23047   "RTN","RCD PESP2",323 ,0)
  23048    ;            .08 = A UTO-POSTIN G EXCLUSIO N (pharmac y)
  23049   "RTN","RCD PESP2",324 ,0)
  23050    ;   RCREP T - "M" =  "MEDICAL"
  23051   "RTN","RCD PESP2",325 ,0)
  23052    ;             "P" =  "PHARMACY"
  23053   "RTN","RCD PESP2",326 ,0)
  23054    Q:$G(RCEX CEL)
  23055   "RTN","RCD PESP2",327 ,0)
  23056    ;
  23057   "RTN","RCD PESP2",328 ,0)
  23058    I RCTYPE= .06 D
  23059   "RTN","RCD PESP2",329 ,0)
  23060    .W !!,"ME DICAL AUTO -POSTING P AYER EXCLU SION LIST"
  23061   "RTN","RCD PESP2",330 ,0)
  23062    .W !,"--- ---------- ---------- ---------- --------"
  23063   "RTN","RCD PESP2",331 ,0)
  23064    ;
  23065   "RTN","RCD PESP2",332 ,0)
  23066    I RCTYPE= .07 D
  23067   "RTN","RCD PESP2",333 ,0)
  23068    .W !!,"ME DICAL AUTO -DECREASE  PAYER EXCL USION LIST "
  23069   "RTN","RCD PESP2",334 ,0)
  23070    .W !,"--- ---------- ---------- ---------- ---------"
  23071   "RTN","RCD PESP2",335 ,0)
  23072    ;
  23073   "RTN","RCD PESP2",336 ,0)
  23074     I RCTYPE =.08 D
  23075   "RTN","RCD PESP2",337 ,0)
  23076    .W !!,"PH ARMACY AUT O-POSTING  PAYER EXCL USION LIST "
  23077   "RTN","RCD PESP2",338 ,0)
  23078    .W !,"--- ---------- ---------- ---------- ---------"
  23079   "RTN","RCD PESP2",339 ,0)
  23080    ;
  23081   "RTN","RCD PESP2",340 ,0)
  23082    W !,"Chan ge Payer                               Date /Time Edit ed   User"
  23083   "RTN","RCD PESP2",341 ,0)
  23084    W !,$TR($ J("",IOM-1 )," ","=")   ; row of  equal sig ns
  23085   "RTN","RCD PESP2",342 ,0)
  23086    Q
  23087   "RTN","RCD PESP2",343 ,0)
  23088    ;
  23089   "RTN","RCD PESP2",344 ,0)
  23090   CNTR(TXT)  ; center T XT
  23091   "RTN","RCD PESP2",345 ,0)
  23092    Q $J("",I OM-$L(TXT) \2)_TXT
  23093   "RTN","RCD PESP2",346 ,0)
  23094    ;
  23095   "RTN","RCD PESP2",347 ,0)
  23096   DTRNG() ;  function,  returns da te range f or the rep ort
  23097   "RTN","RCD PESP2",348 ,0)
  23098    N DIR,DUO UT,RNGFLG, X,Y,RCSTAR T,RCEND
  23099   "RTN","RCD PESP2",349 ,0)
  23100    S (RCSTAR T,RCEND)=0  D DATES(. RCSTART,.R CEND)
  23101   "RTN","RCD PESP2",350 ,0)
  23102    Q:RCSTART =-1 0
  23103   "RTN","RCD PESP2",351 ,0)
  23104    Q:RCSTART  "1^"_RCST ART_"^"_RC END
  23105   "RTN","RCD PESP2",352 ,0)
  23106    Q:'RCSTAR T "0^^"
  23107   "RTN","RCD PESP2",353 ,0)
  23108    Q 0
  23109   "RTN","RCD PESP2",354 ,0)
  23110    ;
  23111   "RTN","RCD PESP2",355 ,0)
  23112   DATES(BDAT E,EDATE) ;  Get a dat e range, b oth values  passed by  ref.
  23113   "RTN","RCD PESP2",356 ,0)
  23114    N DIR,DTO UT,DUOUT,X ,Y
  23115   "RTN","RCD PESP2",357 ,0)
  23116    S (BDATE, EDATE)=0
  23117   "RTN","RCD PESP2",358 ,0)
  23118    S DIR("?" )="Enter t he earlies t AUDIT DA TE to incl ude on the  report"
  23119   "RTN","RCD PESP2",359 ,0)
  23120    S DIR(0)= "DAO^:"_DT _":APE",DI R("A")="Re port start  date: " D  ^DIR K DI R
  23121   "RTN","RCD PESP2",360 ,0)
  23122    I $D(DTOU T)!$D(DUOU T)!(Y="")  S BDATE=-1  Q
  23123   "RTN","RCD PESP2",361 ,0)
  23124    S BDATE=Y  K DIR,X,Y
  23125   "RTN","RCD PESP2",362 ,0)
  23126    S DIR("?" )="Enter t he latest  AUDIT DATE  to includ e on the r eport"
  23127   "RTN","RCD PESP2",363 ,0)
  23128    S DIR(0)= "DAO^"_BDA TE_":"_DT_ ":APE",DIR ("A")="Rep ort end da te: ",DIR( "B")=$$FMT E^XLFDT(DT )
  23129   "RTN","RCD PESP2",364 ,0)
  23130    D ^DIR K  DIR
  23131   "RTN","RCD PESP2",365 ,0)
  23132    I $D(DTOU T)!$D(DUOU T)!(Y="")  S BDATE=-1  Q
  23133   "RTN","RCD PESP2",366 ,0)
  23134    S EDATE=Y
  23135   "RTN","RCD PESP2",367 ,0)
  23136    Q
  23137   "RTN","RCD PESP2",368 ,0)
  23138    ;
  23139   "RTN","RCD PESP2",369 ,0)
  23140   DSPXCLSN(R CX) ; disp lay exclus ion
  23141   "RTN","RCD PESP2",370 ,0)
  23142    ; RCX - e xclusion v alue from  ^DIC call
  23143   "RTN","RCD PESP2",371 ,0)
  23144    N RCXCLSN
  23145   "RTN","RCD PESP2",372 ,0)
  23146    S RCXCLSN ("CHANGE") =$S($P(RCX ,U,3):"Add ed",1:"Rem oved")
  23147   "RTN","RCD PESP2",373 ,0)
  23148    S RCXCLSN ("TIME")=$ $FMTE^XLFD T($P(RCX,U ,2),"2")
  23149   "RTN","RCD PESP2",374 ,0)
  23150    S RCXCLSN ("USER")=$ P(RCX,U,4)
  23151   "RTN","RCD PESP2",375 ,0)
  23152    S RCXCLSN ("PAYER")= $$GETPAYER
  23153   "RTN","RCD PESP2",376 ,0)
  23154    S RCXCLSN ("COMMENT" )=$P(RCX,U ,5)
  23155   "RTN","RCD PESP2",377 ,0)
  23156    ;
  23157   "RTN","RCD PESP2",378 ,0)
  23158    I 'RCEXCE L D  Q
  23159   "RTN","RCD PESP2",379 ,0)
  23160    .N Y S Y= RCXCLSN("C HANGE"),$E (Y,9)=$E(R CXCLSN("PA YER"),1,30 ),$E(Y,41) =" "_RCXCL SN("TIME") ,Y=Y_" "_R CXCLSN("US ER")
  23161   "RTN","RCD PESP2",380 ,0)
  23162    .W !,Y,!, "  Comment : "_RCXCLS N("COMMENT ")
  23163   "RTN","RCD PESP2",381 ,0)
  23164    ; Excel f ormat
  23165   "RTN","RCD PESP2",382 ,0)
  23166    S RCXCLSN ("LABEL")= $$GET1^DID (344.6,$P( RCX,U,1),, "LABEL")
  23167   "RTN","RCD PESP2",383 ,0)
  23168    W !,RCXCL SN("LABEL" )_U_RCXCLS N("CHANGE" )_U_RCXCLS N("PAYER") _U_RCXCLSN ("TIME")_U _RCXCLSN(" USER")_U_R CXCLSN("CO MMENT")
  23169   "RTN","RCD PESP2",384 ,0)
  23170    ;
  23171   "RTN","RCD PESP2",385 ,0)
  23172    Q
  23173   "RTN","RCD PESP2",386 ,0)
  23174    ;
  23175   "RTN","RCD PESP2",387 ,0)
  23176    ;Retrieve  the param eter for t he type of  informati on to disp lay
  23177   "RTN","RCD PESP2",388 ,0)
  23178   RTYPE(DEF)  ;EP from  RCDPEAA1
  23179   "RTN","RCD PESP2",389 ,0)
  23180    ; Input:    DEF      - Value to  use a def ault
  23181   "RTN","RCD PESP2",390 ,0)
  23182    ; Returns : -1       - User ^ o r timed ou t
  23183   "RTN","RCD PESP2",391 ,0)
  23184    ;            M       - User sel ected MEDI CAL
  23185   "RTN","RCD PESP2",392 ,0)
  23186    ;            P       - User sel ected PHAR MACY
  23187   "RTN","RCD PESP2",393 ,0)
  23188    ;            B       - User sel ected BOTH
  23189   "RTN","RCD PESP2",394 ,0)
  23190    N DA,DIR, DTOUT,DUOU T,X,Y,DIRU T,DIROUT,R CTYPE
  23191   "RTN","RCD PESP2",395 ,0)
  23192    S RCTYPE= ""
  23193   "RTN","RCD PESP2",396 ,0)
  23194    S DIR("?" )="Enter t he type of  informati on to disp lay on the  report"
  23195   "RTN","RCD PESP2",397 ,0)
  23196    S DIR(0)= "SA^M:MEDI CAL;P:PHAR MACY;B:BOT H"
  23197   "RTN","RCD PESP2",398 ,0)
  23198    S DIR("A" )="(M)EDIC AL, (P)HAR MACY, or ( B)OTH: "     ; PRCA*4 .5*317 cha nged 'OR'  to 'or'
  23199   "RTN","RCD PESP2",399 ,0)
  23200    S DIR("B" )=$S($G(DE F)'="":DEF ,1:"BOTH")
  23201   "RTN","RCD PESP2",400 ,0)
  23202    D ^DIR
  23203   "RTN","RCD PESP2",401 ,0)
  23204    K DIR
  23205   "RTN","RCD PESP2",402 ,0)
  23206    I $D(DTOU T)!$D(DUOU T) Q -1
  23207   "RTN","RCD PESP2",403 ,0)
  23208    Q:Y="" "B "
  23209   "RTN","RCD PESP2",404 ,0)
  23210    Q $E(Y)
  23211   "RTN","RCD PESP2",405 ,0)
  23212    ;
  23213   "RTN","RCD PESP2",406 ,0)
  23214    ;Check to  see if th e Data ele ment match es the rep ort type
  23215   "RTN","RCD PESP2",407 ,0)
  23216   RPTYPE(RCT YPE,RCPARA M) ;
  23217   "RTN","RCD PESP2",408 ,0)
  23218    ; Return  1 if valid  to print,  0 otherwi se
  23219   "RTN","RCD PESP2",409 ,0)
  23220    N RCDATA, RCMEN,RCRE N
  23221   "RTN","RCD PESP2",410 ,0)
  23222    ;
  23223   "RTN","RCD PESP2",411 ,0)
  23224    S (RCMEN, RCREN)=""
  23225   "RTN","RCD PESP2",412 ,0)
  23226    ; Get Aut o Decrease  parameter s
  23227   "RTN","RCD PESP2",413 ,0)
  23228    I RCTYPE= "M" S RCME N=$P($G(^R CY(344.61, 1,0)),U,3)
  23229   "RTN","RCD PESP2",414 ,0)
  23230    I RCTYPE= "P" S RCRE N=$P($G(^R CY(344.61, 1,1)),U,2)
  23231   "RTN","RCD PESP2",415 ,0)
  23232    ;
  23233   "RTN","RCD PESP2",416 ,0)
  23234    Q:RCTYPE= "B" 1
  23235   "RTN","RCD PESP2",417 ,0)
  23236    Q:(RCTYPE ="M")&(RCP ARAM["MED" ) 1        ; Medical  Parameters
  23237   "RTN","RCD PESP2",418 ,0)
  23238    Q:(RCTYPE ="P")&(RCP ARAM["RX")  1         ; Pharmacy  parameter s
  23239   "RTN","RCD PESP2",419 ,0)
  23240    Q:(RCTYPE ="P")&(RCP ARAM["PHAR M") 1         ; Pharm acy parame ters
  23241   "RTN","RCD PESP2",420 ,0)
  23242    Q:(RCTYPE ="M")&(RCM EN)&(RCPAR AM["DECREA SE") 1          ; Aut o-decrease  for med i s on
  23243   "RTN","RCD PESP2",421 ,0)
  23244    Q:(RCTYPE ="P")&(RCR EN)&(RCPAR AM["DECREA SE") 1          ; Aut o-decrease  for pharm acy
  23245   "RTN","RCD PESP2",422 ,0)
  23246    Q 0
  23247   "RTN","RCD PESP5")
  23248   0^56^B1478 32556
  23249   "RTN","RCD PESP5",1,0 )
  23250   RCDPESP5 ; ALB/SAB -  ePayment L ockbox Sit e Paramete rs Definit ion - File s 344.71 ; 03/19/2015
  23251   "RTN","RCD PESP5",2,0 )
  23252    ;;4.5;Acc ounts Rece ivable;**3 04,321**;M ar 20, 199 5;Build 46
  23253   "RTN","RCD PESP5",3,0 )
  23254    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  23255   "RTN","RCD PESP5",4,0 )
  23256    ;
  23257   "RTN","RCD PESP5",5,0 )
  23258    Q
  23259   "RTN","RCD PESP5",6,0 )
  23260    ;
  23261   "RTN","RCD PESP5",7,0 )
  23262   CARC(RCQUI T) ;Update  the CARC/ RARC inclu sion table  - added R CQUIT as i nput param eter - PRC A*4.5*321
  23263   "RTN","RCD PESP5",8,0 )
  23264    ;
  23265   "RTN","RCD PESP5",9,0 )
  23266    ;initiali ze
  23267   "RTN","RCD PESP5",10, 0)
  23268    N RCANS,R CCARC,RCCH G,RCCDATA, RCCIEN,RCE DIT,RCRSN, RCSTAT
  23269   "RTN","RCD PESP5",11, 0)
  23270    N RCAMT,R CNAMT,RCAU DARY,RCCAR CDS,RCYN,R CVAL,RCINA CT,RCACTV
  23271   "RTN","RCD PESP5",12, 0)
  23272    S RCEDIT= "",RCANS=" "
  23273   "RTN","RCD PESP5",13, 0)
  23274    ;
  23275   "RTN","RCD PESP5",14, 0)
  23276    ;Display  initial en try line.
  23277   "RTN","RCD PESP5",15, 0)
  23278    W !,"AUTO -DECREASE  MEDICAL CL AIMS FOR T HE FOLLOWI NG CARC/AM OUNTS ONLY :",!
  23279   "RTN","RCD PESP5",16, 0)
  23280    ;
  23281   "RTN","RCD PESP5",17, 0)
  23282    ;
  23283   "RTN","RCD PESP5",18, 0)
  23284    ;Loop unt il the use r quits
  23285   "RTN","RCD PESP5",19, 0)
  23286    F  D  Q:R CANS="Q"
  23287   "RTN","RCD PESP5",20, 0)
  23288    . ;
  23289   "RTN","RCD PESP5",21, 0)
  23290    . ;displa y list of  currently  enabled/di sabled CAR Cs/RARCs
  23291   "RTN","RCD PESP5",22, 0)
  23292    . D PRTCA RC()
  23293   "RTN","RCD PESP5",23, 0)
  23294    . ;
  23295   "RTN","RCD PESP5",24, 0)
  23296    . ; add s ome spacin g
  23297   "RTN","RCD PESP5",25, 0)
  23298    . W !!
  23299   "RTN","RCD PESP5",26, 0)
  23300    . ;
  23301   "RTN","RCD PESP5",27, 0)
  23302    . ;Ask us er for the  CARC/RARC  to enable /disable ( QUIT) [def ault] to e xit
  23303   "RTN","RCD PESP5",28, 0)
  23304    . ;
  23305   "RTN","RCD PESP5",29, 0)
  23306    . S RCCAR C=$$GETCAR C()
  23307   "RTN","RCD PESP5",30, 0)
  23308    . I RCCAR C=-1 S RCQ UIT=1,RCAN S="Q" Q
  23309   "RTN","RCD PESP5",31, 0)
  23310    . I RCCAR C=0 S RCAN S="Q" Q
  23311   "RTN","RCD PESP5",32, 0)
  23312    . ;
  23313   "RTN","RCD PESP5",33, 0)
  23314    . ;Valida te CARC en tered
  23315   "RTN","RCD PESP5",34, 0)
  23316    . S RCVAL =$$VAL^RCD PCRR(345,R CCARC)  ;  Validate t he CARC ag ainst File  345
  23317   "RTN","RCD PESP5",35, 0)
  23318    . S RCACT V=$$ACT^RC DPRU(345,R CCARC,)  ;  Check if  CARC is an  active co de
  23319   "RTN","RCD PESP5",36, 0)
  23320    . ;
  23321   "RTN","RCD PESP5",37, 0)
  23322    . ;If the  CARC is i nvalid, wa rn user an d exit bac k to the C ARC prompt
  23323   "RTN","RCD PESP5",38, 0)
  23324    . I 'RCVA L W !,"The  CARC code  you have  entered is  not a val id CARC co de.  Pleas e try agai n" Q
  23325   "RTN","RCD PESP5",39, 0)
  23326    . ;
  23327   "RTN","RCD PESP5",40, 0)
  23328    . ; Print  CARC and  descriptio n and init ialize ina ctive vari able
  23329   "RTN","RCD PESP5",41, 0)
  23330    . S RCCAR CDS="",RCI NACT=""
  23331   "RTN","RCD PESP5",42, 0)
  23332    . D GETCO DES^RCDPCR R(RCCARC," ","A",$$DT ^XLFDT,"RC CARCDS","1 ^70")
  23333   "RTN","RCD PESP5",43, 0)
  23334    . I $D(RC CARCDS("CA RC",RCCARC ))'=10 D
  23335   "RTN","RCD PESP5",44, 0)
  23336    . . S RCI NACT=1
  23337   "RTN","RCD PESP5",45, 0)
  23338    . . D GET CODES^RCDP CRR(RCCARC ,"","I",$$ DT^XLFDT," RCCARCDS", "1^70")
  23339   "RTN","RCD PESP5",46, 0)
  23340    . S RCCIE N=$O(RCCAR CDS("CARC" ,RCCARC,"" ))
  23341   "RTN","RCD PESP5",47, 0)
  23342    . S RCDES C=$P(RCCAR CDS("CARC" ,RCCARC,RC CIEN),U,6)
  23343   "RTN","RCD PESP5",48, 0)
  23344    . ;
  23345   "RTN","RCD PESP5",49, 0)
  23346    . ; If th e descript ion is 70  characters , add elli psis to th e string t o indicate  there is  more to th e descript ion
  23347   "RTN","RCD PESP5",50, 0)
  23348    . S:$E(RC DESC)=70 R CDESC=RCDE SC_" ..."
  23349   "RTN","RCD PESP5",51, 0)
  23350    . W !,?3, RCDESC,!
  23351   "RTN","RCD PESP5",52, 0)
  23352    . I 'RCAC TV W "   * ** WARNING : CARC cod e "_RCCARC _" is no l onger acti ve.",!
  23353   "RTN","RCD PESP5",53, 0)
  23354    . ;
  23355   "RTN","RCD PESP5",54, 0)
  23356    . ; Look  up CARC/RA RC in tabl e.
  23357   "RTN","RCD PESP5",55, 0)
  23358    . S RCCIE N=$O(^RCY( 344.62,"B" ,RCCARC,"" ))
  23359   "RTN","RCD PESP5",56, 0)
  23360    . S (RCAM T,RCSTAT)= 0  ; Initi alize if n ew code en try for ta ble
  23361   "RTN","RCD PESP5",57, 0)
  23362    . I RCCIE N D          ; Code e xists in t able
  23363   "RTN","RCD PESP5",58, 0)
  23364    . . S RCC DATA=$G(^R CY(344.62, RCCIEN,0))
  23365   "RTN","RCD PESP5",59, 0)
  23366    . . ;
  23367   "RTN","RCD PESP5",60, 0)
  23368    . . ; Get  current A uto-decrea se status  and Max de crease amo unt
  23369   "RTN","RCD PESP5",61, 0)
  23370    . . S RCS TAT=$P(RCC DATA,U,2)
  23371   "RTN","RCD PESP5",62, 0)
  23372    . . S RCA MT=$P(RCCD ATA,U,6)
  23373   "RTN","RCD PESP5",63, 0)
  23374    . ;
  23375   "RTN","RCD PESP5",64, 0)
  23376    . ; Init  Audit arra y to send  each updat e individu ally
  23377   "RTN","RCD PESP5",65, 0)
  23378    . S RCAUD ARY(1)=""
  23379   "RTN","RCD PESP5",66, 0)
  23380    . S RCAUD ARY(2)=""
  23381   "RTN","RCD PESP5",67, 0)
  23382    . ;
  23383   "RTN","RCD PESP5",68, 0)
  23384    . ; If pr esent and  enabled
  23385   "RTN","RCD PESP5",69, 0)
  23386    . I RCCIE N,RCSTAT D   Q
  23387   "RTN","RCD PESP5",70, 0)
  23388    . . ;
  23389   "RTN","RCD PESP5",71, 0)
  23390    . . S RCN AMT=0,RCRS N=""  ;Ini tialize va riables
  23391   "RTN","RCD PESP5",72, 0)
  23392    . . ;
  23393   "RTN","RCD PESP5",73, 0)
  23394    . . ; Con firm that  this is th e correct  CARC
  23395   "RTN","RCD PESP5",74, 0)
  23396    . . S RCY N=$$CONFIR M(4)
  23397   "RTN","RCD PESP5",75, 0)
  23398    . . Q:RCY N=-1
  23399   "RTN","RCD PESP5",76, 0)
  23400    . . ;
  23401   "RTN","RCD PESP5",77, 0)
  23402    . . ; Ask  for reaso n
  23403   "RTN","RCD PESP5",78, 0)
  23404    . . S RCR SN=$$GETRE ASN(RCCARC )
  23405   "RTN","RCD PESP5",79, 0)
  23406    . . Q:RCR SN=-1   ;  User reque sted to qu it
  23407   "RTN","RCD PESP5",80, 0)
  23408    . . ;
  23409   "RTN","RCD PESP5",81, 0)
  23410    . . ; Con firm the d isabling
  23411   "RTN","RCD PESP5",82, 0)
  23412    . . S RCY N=$$CONFIR M(3)
  23413   "RTN","RCD PESP5",83, 0)
  23414    . . Q:RCY N=-1
  23415   "RTN","RCD PESP5",84, 0)
  23416    . . ;
  23417   "RTN","RCD PESP5",85, 0)
  23418    . . D UPD DATA(RCCIE N,0,RCAMT, RCRSN) ; I f disablin g
  23419   "RTN","RCD PESP5",86, 0)
  23420    . . ;
  23421   "RTN","RCD PESP5",87, 0)
  23422    . . ;At l east 1 ite m was chan ge/updated /added so  set flag f or reprint
  23423   "RTN","RCD PESP5",88, 0)
  23424    . . I 'RC EDIT S RCE DIT=1
  23425   "RTN","RCD PESP5",89, 0)
  23426    . . ;
  23427   "RTN","RCD PESP5",90, 0)
  23428    . . ;Don' t need a s econd entr y in the a udit file  so kill it  to preven t audit lo gging from  crashing
  23429   "RTN","RCD PESP5",91, 0)
  23430    . . K RCA UDARY(2)
  23431   "RTN","RCD PESP5",92, 0)
  23432    . . ;
  23433   "RTN","RCD PESP5",93, 0)
  23434    . . ; Upd ate audit  log for di sable CARC
  23435   "RTN","RCD PESP5",94, 0)
  23436    . . ; Ord er - File  ; Field ;  IEN ; New  Value ; Ol d Value ;  Comment
  23437   "RTN","RCD PESP5",95, 0)
  23438    . . S RCA UDARY(1)=" 344.62^.02 ^"_RCCIEN_ "^0^1^"_RC RSN
  23439   "RTN","RCD PESP5",96, 0)
  23440    . . D AUD IT^RCDPESP (.RCAUDARY )
  23441   "RTN","RCD PESP5",97, 0)
  23442    . ;
  23443   "RTN","RCD PESP5",98, 0)
  23444    . ; Confi rm that th is is the  correct CA RC to Enab le
  23445   "RTN","RCD PESP5",99, 0)
  23446    . S RCYN= $$CONFIRM( 1)
  23447   "RTN","RCD PESP5",100 ,0)
  23448    . Q:RCYN= -1
  23449   "RTN","RCD PESP5",101 ,0)
  23450    . ;
  23451   "RTN","RCD PESP5",102 ,0)
  23452    . ; Ask f or new amo unt
  23453   "RTN","RCD PESP5",103 ,0)
  23454    . S RCNAM T=$$GETAMT ()
  23455   "RTN","RCD PESP5",104 ,0)
  23456    . Q:RCNAM T=-1   ; U ser reques ted to qui t
  23457   "RTN","RCD PESP5",105 ,0)
  23458    . ;
  23459   "RTN","RCD PESP5",106 ,0)
  23460    . ; Ask f or reason
  23461   "RTN","RCD PESP5",107 ,0)
  23462    . S RCRSN =$$GETREAS N(RCCARC)
  23463   "RTN","RCD PESP5",108 ,0)
  23464    . Q:RCRSN =-1   ; Us er request ed to quit
  23465   "RTN","RCD PESP5",109 ,0)
  23466    . ;
  23467   "RTN","RCD PESP5",110 ,0)
  23468    . ; Confi rm save
  23469   "RTN","RCD PESP5",111 ,0)
  23470    . S RCYN= $$CONFIRM( 2)
  23471   "RTN","RCD PESP5",112 ,0)
  23472    . I (RCYN ="N")!(RCY N=-1) W !, "NOT SAVED ",!! Q
  23473   "RTN","RCD PESP5",113 ,0)
  23474    . ;   
  23475   "RTN","RCD PESP5",114 ,0)
  23476    . ; Re-en able if di sabled and  quit
  23477   "RTN","RCD PESP5",115 ,0)
  23478    . I RCCIE N D  Q
  23479   "RTN","RCD PESP5",116 ,0)
  23480    . . D UPD DATA(RCCIE N,1,RCNAMT ,RCRSN)  ;  Renable a nd update  amount
  23481   "RTN","RCD PESP5",117 ,0)
  23482    . . ;
  23483   "RTN","RCD PESP5",118 ,0)
  23484    . . ;Upda te audit f ile with r eason and  amount cha nges.
  23485   "RTN","RCD PESP5",119 ,0)
  23486    . . ; Ord er - File  ; Field ;  IEN ; New  Value ; Ol d Value ;  Comment
  23487   "RTN","RCD PESP5",120 ,0)
  23488    . . S RCA UDARY(1)=" 344.62^.02 ^"_RCCIEN_ "^1^"_RCST AT_"^"_RCR SN
  23489   "RTN","RCD PESP5",121 ,0)
  23490    . . S RCA UDARY(2)=" 344.62^.06 ^"_RCCIEN_ "^"_RCNAMT _"^"_RCAMT _"^"_RCRSN
  23491   "RTN","RCD PESP5",122 ,0)
  23492    . . D AUD IT^RCDPESP (.RCAUDARY )
  23493   "RTN","RCD PESP5",123 ,0)
  23494    . . ;
  23495   "RTN","RCD PESP5",124 ,0)
  23496    . . ;At l east 1 ite m was chan ge/updated /added so  set flag f or reprint
  23497   "RTN","RCD PESP5",125 ,0)
  23498    . . I 'RC EDIT S RCE DIT=1
  23499   "RTN","RCD PESP5",126 ,0)
  23500    . ;
  23501   "RTN","RCD PESP5",127 ,0)
  23502    . ; Store  new entry
  23503   "RTN","RCD PESP5",128 ,0)
  23504    . D ADDDA TA(RCCARC, RCNAMT,RCR SN)
  23505   "RTN","RCD PESP5",129 ,0)
  23506    . ;
  23507   "RTN","RCD PESP5",130 ,0)
  23508    . ;Update  audit fil e with rea son and am ount chang es.
  23509   "RTN","RCD PESP5",131 ,0)
  23510    . S RCCIE N=$$FIND1^ DIC(344.62 ,"","",RCC ARC,"","", "RCERR") I  RCCIEN=""  S RCCIEN= "ERROR"
  23511   "RTN","RCD PESP5",132 ,0)
  23512    . ;
  23513   "RTN","RCD PESP5",133 ,0)
  23514    . ; Order  - File ;  Field ; IE N ; New Va lue ; Old  Value ; Co mment
  23515   "RTN","RCD PESP5",134 ,0)
  23516    . S RCAUD ARY(1)="34 4.62^.02^" _RCCIEN_"^ 1^0^"_RCRS N
  23517   "RTN","RCD PESP5",135 ,0)
  23518    . S RCAUD ARY(2)="34 4.62^.06^" _RCCIEN_"^ "_RCNAMT_" ^0^"_RCRSN
  23519   "RTN","RCD PESP5",136 ,0)
  23520    . D AUDIT ^RCDPESP(. RCAUDARY)
  23521   "RTN","RCD PESP5",137 ,0)
  23522    . ;
  23523   "RTN","RCD PESP5",138 ,0)
  23524    . ;At lea st 1 item  was change /updated/a dded so se t flag for  reprint
  23525   "RTN","RCD PESP5",139 ,0)
  23526    . I 'RCED IT S RCEDI T=1
  23527   "RTN","RCD PESP5",140 ,0)
  23528    ;
  23529   "RTN","RCD PESP5",141 ,0)
  23530    Q
  23531   "RTN","RCD PESP5",142 ,0)
  23532    ;
  23533   "RTN","RCD PESP5",143 ,0)
  23534   PRTCARC()  ;Display c urrent ent ries that  have been  defined fo r inclusio n or exclu sion into 
  23535   "RTN","RCD PESP5",144 ,0)
  23536    ;
  23537   "RTN","RCD PESP5",145 ,0)
  23538    N RCI,RCC T,RCSTRING ,RCDATA,RC INACT,RCCA RCD,RCDESC ,RCCIEN,RC STAT,RCCOD E
  23539   "RTN","RCD PESP5",146 ,0)
  23540    ;
  23541   "RTN","RCD PESP5",147 ,0)
  23542    S RCI=0,R CCT=0,RCST RING=""
  23543   "RTN","RCD PESP5",148 ,0)
  23544    S RCSTRIN G=$TR($J(" ",73)," ", "-")
  23545   "RTN","RCD PESP5",149 ,0)
  23546    ;
  23547   "RTN","RCD PESP5",150 ,0)
  23548    ; Print H eader
  23549   "RTN","RCD PESP5",151 ,0)
  23550    ;
  23551   "RTN","RCD PESP5",152 ,0)
  23552    W !!,?3," CARC ",?9, "Descripti on",?65,"M ax. Amt"
  23553   "RTN","RCD PESP5",153 ,0)
  23554    W !,?3,RC STRING
  23555   "RTN","RCD PESP5",154 ,0)
  23556    ;
  23557   "RTN","RCD PESP5",155 ,0)
  23558    ; Loop an d print en tries
  23559   "RTN","RCD PESP5",156 ,0)
  23560    F  S RCI= $O(^RCY(34 4.62,RCI))  Q:'RCI  D
  23561   "RTN","RCD PESP5",157 ,0)
  23562    . S RCDAT A=$G(^RCY( 344.62,RCI ,0))
  23563   "RTN","RCD PESP5",158 ,0)
  23564    . Q:RCDAT A=""
  23565   "RTN","RCD PESP5",159 ,0)
  23566    . S RCCOD E=$P(RCDAT A,U),RCCIE N=$O(^RC(3 45,"B",RCC ODE,""))
  23567   "RTN","RCD PESP5",160 ,0)
  23568    . S RCDES C=$G(^RC(3 45,RCCIEN, 1,1,0))
  23569   "RTN","RCD PESP5",161 ,0)
  23570    . S RCSTA T=$P(RCDAT A,U,2)
  23571   "RTN","RCD PESP5",162 ,0)
  23572    . Q:RCSTA T'=1
  23573   "RTN","RCD PESP5",163 ,0)
  23574    . S RCCT= RCCT+1
  23575   "RTN","RCD PESP5",164 ,0)
  23576    . I $L(RC DESC)>50 S  RCDESC=$E (RCDESC,1, 50)_" ..."
  23577   "RTN","RCD PESP5",165 ,0)
  23578    . D GETCO DES^RCDPCR R(RCCODE," ","B",$$DT ^XLFDT,"RC CARCD","1^ 70")
  23579   "RTN","RCD PESP5",166 ,0)
  23580    . W !,?3, RCCODE,?9, $E(RCDESC, 1,55),?63, $J($P(RCDA TA,U,6),10 ,0)
  23581   "RTN","RCD PESP5",167 ,0)
  23582    . I $P(RC CARCD("CAR C",RCCODE, RCCIEN),U, 3)'="" W "  (I)"  ; i f inactive , display  (I)
  23583   "RTN","RCD PESP5",168 ,0)
  23584    . K RCCAR CD
  23585   "RTN","RCD PESP5",169 ,0)
  23586    ;
  23587   "RTN","RCD PESP5",170 ,0)
  23588    I RCCT=0  W !,?5,"NO  CARC/AMOU NTS ENTERE D"
  23589   "RTN","RCD PESP5",171 ,0)
  23590    Q
  23591   "RTN","RCD PESP5",172 ,0)
  23592    ;
  23593   "RTN","RCD PESP5",173 ,0)
  23594    ;Retrieve  the next  CARC code  to enable/ disable
  23595   "RTN","RCD PESP5",174 ,0)
  23596   GETCARC()  ;
  23597   "RTN","RCD PESP5",175 ,0)
  23598    N DA,DIR, DTOUT,DUOU T,X,Y,DIRU T,DIROUT
  23599   "RTN","RCD PESP5",176 ,0)
  23600    S DIR("?" )="Enter a  CARC code  to enable /disable o r Q to Qui t."
  23601   "RTN","RCD PESP5",177 ,0)
  23602    S DIR(0)= "FAO"
  23603   "RTN","RCD PESP5",178 ,0)
  23604    S DIR("?? ")="^D LIS T^RCDPCRR( 345)"
  23605   "RTN","RCD PESP5",179 ,0)
  23606    S DIR("A" )="CARC: "
  23607   "RTN","RCD PESP5",180 ,0)
  23608    D ^DIR
  23609   "RTN","RCD PESP5",181 ,0)
  23610    K DIR
  23611   "RTN","RCD PESP5",182 ,0)
  23612    I $D(DTOU T)!$D(DUOU T) Q -1
  23613   "RTN","RCD PESP5",183 ,0)
  23614    I Y="" Q  0
  23615   "RTN","RCD PESP5",184 ,0)
  23616    Q Y
  23617   "RTN","RCD PESP5",185 ,0)
  23618    ;
  23619   "RTN","RCD PESP5",186 ,0)
  23620    ;Ask user  to change  or disabl e an enabl ed CARC au to-decreme nt
  23621   "RTN","RCD PESP5",187 ,0)
  23622   CHGDIS() ;
  23623   "RTN","RCD PESP5",188 ,0)
  23624    N DA,DIR, DTOUT,DUOU T,X,Y,DIRU T,DIROUT
  23625   "RTN","RCD PESP5",189 ,0)
  23626    S DIR("?" )="Either  (D)isable  the CARC f rom Auto-D ecrease or  (C)hange  the maximu m amount o f Auto-Dec rease."
  23627   "RTN","RCD PESP5",190 ,0)
  23628    S DIR(0)= "FA"
  23629   "RTN","RCD PESP5",191 ,0)
  23630    S DIR("A" )="(C)hang e or (D)is able: "
  23631   "RTN","RCD PESP5",192 ,0)
  23632    S DIR("S" )="C:Chang e;D:Disabl e"
  23633   "RTN","RCD PESP5",193 ,0)
  23634    D ^DIR
  23635   "RTN","RCD PESP5",194 ,0)
  23636    K DIR
  23637   "RTN","RCD PESP5",195 ,0)
  23638    Q Y
  23639   "RTN","RCD PESP5",196 ,0)
  23640    ;
  23641   "RTN","RCD PESP5",197 ,0)
  23642    ;Ask user  to change  or disabl e an enabl ed CARC au to-decreme nt
  23643   "RTN","RCD PESP5",198 ,0)
  23644   CONFIRM(RC IDX) ;
  23645   "RTN","RCD PESP5",199 ,0)
  23646    N DA,DIR, DTOUT,DUOU T,X,Y,DIRU T,DIROUT
  23647   "RTN","RCD PESP5",200 ,0)
  23648    ;
  23649   "RTN","RCD PESP5",201 ,0)
  23650    ; Confirm  if the CA RC code is  correct
  23651   "RTN","RCD PESP5",202 ,0)
  23652    I RCIDX=1  D
  23653   "RTN","RCD PESP5",203 ,0)
  23654    . S DIR(" ?")="Eithe r (Y)es to  confirm t hat this i s the corr ect code o r (N)o to  enter a di fferent co de."
  23655   "RTN","RCD PESP5",204 ,0)
  23656    . S DIR(" A")="ENABL E this CAR C for Auto -Decrease  of Medical  Claims (Y /N)? "
  23657   "RTN","RCD PESP5",205 ,0)
  23658    ;
  23659   "RTN","RCD PESP5",206 ,0)
  23660    ; Confirm  if the us er wishes  to Enable  the change s
  23661   "RTN","RCD PESP5",207 ,0)
  23662    I RCIDX=2  D
  23663   "RTN","RCD PESP5",208 ,0)
  23664    . S DIR(" ?")="Eithe r (Y)es to  confirm c hanges or  (N)o to ex it without  saving."
  23665   "RTN","RCD PESP5",209 ,0)
  23666    . S DIR(" A")="Save  this CARC?  (Y)es or  (N)o: "
  23667   "RTN","RCD PESP5",210 ,0)
  23668    ;
  23669   "RTN","RCD PESP5",211 ,0)
  23670    ; Confirm  if the us er wishes  to Disable  the chang es
  23671   "RTN","RCD PESP5",212 ,0)
  23672    I RCIDX=3  D
  23673   "RTN","RCD PESP5",213 ,0)
  23674    . S DIR(" ?")="Eithe r (Y)es to  confirm c hanges or  (N)o to ex it without  saving."
  23675   "RTN","RCD PESP5",214 ,0)
  23676    . S DIR(" A")="Remov e this CAR C? (Y)es o r (N)o: "
  23677   "RTN","RCD PESP5",215 ,0)
  23678    ;
  23679   "RTN","RCD PESP5",216 ,0)
  23680    ; Confirm  if the CA RC code is  correct
  23681   "RTN","RCD PESP5",217 ,0)
  23682    I RCIDX=4  D
  23683   "RTN","RCD PESP5",218 ,0)
  23684    . S DIR(" ?")="Eithe r (Y)es to  confirm t hat this i s the corr ect code o r (N)o to  enter a di fferent co de."
  23685   "RTN","RCD PESP5",219 ,0)
  23686    . S DIR(" A")="DISAB LE this CA RC for Aut o-Decrease  of Medica l Claims ( Y/N)? "
  23687   "RTN","RCD PESP5",220 ,0)
  23688    ;
  23689   "RTN","RCD PESP5",221 ,0)
  23690    S DIR(0)= "YA"
  23691   "RTN","RCD PESP5",222 ,0)
  23692    S DIR("S" )="Y:Yes;N :No"
  23693   "RTN","RCD PESP5",223 ,0)
  23694    D ^DIR
  23695   "RTN","RCD PESP5",224 ,0)
  23696    K DIR
  23697   "RTN","RCD PESP5",225 ,0)
  23698    I $G(DTOU T)!$G(DUOU T) S Y=-1
  23699   "RTN","RCD PESP5",226 ,0)
  23700    I Y="0" S  Y=-1
  23701   "RTN","RCD PESP5",227 ,0)
  23702    Q Y
  23703   "RTN","RCD PESP5",228 ,0)
  23704    ;
  23705   "RTN","RCD PESP5",229 ,0)
  23706    ;Ask user  the maxim um amount  to allow f or auto-de crease
  23707   "RTN","RCD PESP5",230 ,0)
  23708   GETAMT() ;
  23709   "RTN","RCD PESP5",231 ,0)
  23710    N DA,DIR, DTOUT,DUOU T,X,Y,DIRU T,DIROUT
  23711   "RTN","RCD PESP5",232 ,0)
  23712    S DIR("?" )="Enter t he maximum  amount th e CARC can  be auto-d ecreased b etween $1  and $1500"
  23713   "RTN","RCD PESP5",233 ,0)
  23714    S DIR(0)= "NA^1:1500 :0"
  23715   "RTN","RCD PESP5",234 ,0)
  23716    S DIR("A" )="MAXIMUM  DOLLAR AM OUNT TO AU TO-DECREAS E (1-1500) : "
  23717   "RTN","RCD PESP5",235 ,0)
  23718    D ^DIR
  23719   "RTN","RCD PESP5",236 ,0)
  23720    K DIR
  23721   "RTN","RCD PESP5",237 ,0)
  23722    I $G(DUOU T) S Y=-1
  23723   "RTN","RCD PESP5",238 ,0)
  23724    Q Y
  23725   "RTN","RCD PESP5",239 ,0)
  23726    ;
  23727   "RTN","RCD PESP5",240 ,0)
  23728    ;Get the  reason for  modificat ion
  23729   "RTN","RCD PESP5",241 ,0)
  23730   GETREASN(R CCARC) ;
  23731   "RTN","RCD PESP5",242 ,0)
  23732    N DA,DIR, DTOUT,DUOU T,X,Y,DIRU T,DIROUT
  23733   "RTN","RCD PESP5",243 ,0)
  23734    S DIR("?" )="Enter r eason for  enabling/d isabling,  or changin g the Maxi mum Dollar  decrease  amount for  CARC "_RC CARC_" (3- 50 chars). "
  23735   "RTN","RCD PESP5",244 ,0)
  23736    S DIR(0)= "FA^3:50"
  23737   "RTN","RCD PESP5",245 ,0)
  23738    S DIR("A" )="COMMENT : "
  23739   "RTN","RCD PESP5",246 ,0)
  23740    S DIR("PR E")="S X=$ $TRIM^XLFS TR(X,""LR" ")" ; comm ent requir ed and sho uld be sig nificant
  23741   "RTN","RCD PESP5",247 ,0)
  23742    D ^DIR
  23743   "RTN","RCD PESP5",248 ,0)
  23744    K DIR
  23745   "RTN","RCD PESP5",249 ,0)
  23746    I $G(DUOU T) S Y=-1
  23747   "RTN","RCD PESP5",250 ,0)
  23748    Q Y
  23749   "RTN","RCD PESP5",251 ,0)
  23750    ;
  23751   "RTN","RCD PESP5",252 ,0)
  23752    ;Update t he databas e and audi t log
  23753   "RTN","RCD PESP5",253 ,0)
  23754   UPDDATA(RC CIEN,RCSTA T,RCAMT,RC RSN) ;
  23755   "RTN","RCD PESP5",254 ,0)
  23756    N DA,DR,D IE,DTOUT,X ,Y,DIC
  23757   "RTN","RCD PESP5",255 ,0)
  23758    ; replace d //// wit h /// in f ollowing 5  lines - P RCA*4.5*32 1
  23759   "RTN","RCD PESP5",256 ,0)
  23760    S DA=RCCI EN,(DIC,DI E)="^RCY(3 44.62,"
  23761   "RTN","RCD PESP5",257 ,0)
  23762    S DR=".02 ///"_RCSTA T_";"
  23763   "RTN","RCD PESP5",258 ,0)
  23764    S DR=DR_" .05///"_$$ NOW^XLFDT_ ";"
  23765   "RTN","RCD PESP5",259 ,0)
  23766    S DR=DR_" .04///"_DU Z_";"
  23767   "RTN","RCD PESP5",260 ,0)
  23768    S DR=DR_" .06///"_RC AMT_";"
  23769   "RTN","RCD PESP5",261 ,0)
  23770    S DR=DR_" .07///"_RC RSN_";"
  23771   "RTN","RCD PESP5",262 ,0)
  23772    ;
  23773   "RTN","RCD PESP5",263 ,0)
  23774    L +^RCY(3 44.62,RCCI EN):10
  23775   "RTN","RCD PESP5",264 ,0)
  23776    D ^DIE
  23777   "RTN","RCD PESP5",265 ,0)
  23778    L -^RCY(3 44.62,RCCI EN)
  23779   "RTN","RCD PESP5",266 ,0)
  23780    Q $D(Y)=0
  23781   "RTN","RCD PESP5",267 ,0)
  23782    ;
  23783   "RTN","RCD PESP5",268 ,0)
  23784    ;Add new  entry to t he table
  23785   "RTN","RCD PESP5",269 ,0)
  23786   ADDDATA(RC CARC,RCAMT ,RCRSN) ;
  23787   "RTN","RCD PESP5",270 ,0)
  23788    N RCENTRY ,RCROOT,MS GROOT
  23789   "RTN","RCD PESP5",271 ,0)
  23790    ;
  23791   "RTN","RCD PESP5",272 ,0)
  23792    ; set up  array
  23793   "RTN","RCD PESP5",273 ,0)
  23794    S RCENTRY (344.62,"+ 1,",.01)=R CCARC         ;CARC C ode
  23795   "RTN","RCD PESP5",274 ,0)
  23796    S RCENTRY (344.62,"+ 1,",.02)=1               ;Enable d status
  23797   "RTN","RCD PESP5",275 ,0)
  23798    S RCENTRY (344.62,"+ 1,",.03)=$ $NOW^XLFDT    ;Date/T ime added
  23799   "RTN","RCD PESP5",276 ,0)
  23800    S RCENTRY (344.62,"+ 1,",.04)=D UZ            ;User
  23801   "RTN","RCD PESP5",277 ,0)
  23802    S RCENTRY (344.62,"+ 1,",.06)=R CAMT          ;Max am ount
  23803   "RTN","RCD PESP5",278 ,0)
  23804    S RCENTRY (344.62,"+ 1,",.07)=R CRSN          ;Commen t
  23805   "RTN","RCD PESP5",279 ,0)
  23806    ;
  23807   "RTN","RCD PESP5",280 ,0)
  23808    ;file ent ry
  23809   "RTN","RCD PESP5",281 ,0)
  23810    D UPDATE^ DIE(,"RCEN TRY","RCRO OT","MSGRO OT")
  23811   "RTN","RCD PESP5",282 ,0)
  23812    Q
  23813   "RTN","RCD PESP5",283 ,0)
  23814   AUDIT() ;
  23815   "RTN","RCD PESP5",284 ,0)
  23816    ;
  23817   "RTN","RCD PESP5",285 ,0)
  23818    N EMEDANS ,EOLDMED,E OLDRX,ERXA NS,MEDANS, OLDMED,OLD RX,RXANS ;  PRCA*4.5* 321
  23819   "RTN","RCD PESP5",286 ,0)
  23820    ;
  23821   "RTN","RCD PESP5",287 ,0)
  23822    ; Get exi sting answ ers for Me dical and  Pharmacy p aper bills
  23823   "RTN","RCD PESP5",288 ,0)
  23824    S OLDMED= $$GET1^DIQ (342,"1,", 7.05,"I")
  23825   "RTN","RCD PESP5",289 ,0)
  23826    S OLDRX=$ $GET1^DIQ( 342,"1,",7 .06,"I")
  23827   "RTN","RCD PESP5",290 ,0)
  23828    ;
  23829   "RTN","RCD PESP5",291 ,0)
  23830    ; Get exi sting answ ers for Me dical and  Pharmacy E DI (electr onic) bill s ; PRCA*4 .5*321
  23831   "RTN","RCD PESP5",292 ,0)
  23832    S EOLDMED =$$GET1^DI Q(342,"1," ,7.07,"I")  ; PRCA*4. 5*321
  23833   "RTN","RCD PESP5",293 ,0)
  23834    S EOLDRX= $$GET1^DIQ (342,"1,", 7.08,"I")  ; PRCA*4.5 *321
  23835   "RTN","RCD PESP5",294 ,0)
  23836    ;
  23837   "RTN","RCD PESP5",295 ,0)
  23838    ; Get Med ical paper  bills
  23839   "RTN","RCD PESP5",296 ,0)
  23840    S MEDANS= $$GETAUDIT (1)
  23841   "RTN","RCD PESP5",297 ,0)
  23842    Q:MEDANS= -1 1
  23843   "RTN","RCD PESP5",298 ,0)
  23844    ; File Me dical pape r bills
  23845   "RTN","RCD PESP5",299 ,0)
  23846    I MEDANS' =OLDMED D
  23847   "RTN","RCD PESP5",300 ,0)
  23848    . N RCAUD VAL
  23849   "RTN","RCD PESP5",301 ,0)
  23850    . D FILEA NS(7.05,ME DANS)
  23851   "RTN","RCD PESP5",302 ,0)
  23852    . ; FILE  NUMBER^FIE LD NUMBER^ IEN^NEW VA LUE^OLD VA LUE^COMMEN T
  23853   "RTN","RCD PESP5",303 ,0)
  23854    . S RCAUD VAL(1)="34 2^7.05^1^" _MEDANS_U_ OLDMED_U_" Updating t he Medical  Auto-Audi t of paper  bills"
  23855   "RTN","RCD PESP5",304 ,0)
  23856    . D AUDIT ^RCDPESP(. RCAUDVAL)
  23857   "RTN","RCD PESP5",305 ,0)
  23858    ;
  23859   "RTN","RCD PESP5",306 ,0)
  23860    ; Get Pha rmacy pape r bills
  23861   "RTN","RCD PESP5",307 ,0)
  23862    S RXANS=$ $GETAUDIT( 2)
  23863   "RTN","RCD PESP5",308 ,0)
  23864    Q:RXANS=- 1 1
  23865   "RTN","RCD PESP5",309 ,0)
  23866    ;
  23867   "RTN","RCD PESP5",310 ,0)
  23868    ; File Ph armacy pap er bills
  23869   "RTN","RCD PESP5",311 ,0)
  23870    I RXANS'= OLDRX D
  23871   "RTN","RCD PESP5",312 ,0)
  23872    . N RCAUD VAL
  23873   "RTN","RCD PESP5",313 ,0)
  23874    . D FILEA NS(7.06,RX ANS)
  23875   "RTN","RCD PESP5",314 ,0)
  23876    . S RCAUD VAL(1)="34 2^7.06^1^" _RXANS_U_O LDRX_U_"Up dating the  Pharmacy  Auto-Audit  of paper  bills"
  23877   "RTN","RCD PESP5",315 ,0)
  23878    . D AUDIT ^RCDPESP(. RCAUDVAL)
  23879   "RTN","RCD PESP5",316 ,0)
  23880    ; 
  23881   "RTN","RCD PESP5",317 ,0)
  23882    ; BEGIN P RCA*4.5*32 1
  23883   "RTN","RCD PESP5",318 ,0)
  23884    ; Get Med ical elect ronic bill s
  23885   "RTN","RCD PESP5",319 ,0)
  23886    S EMEDANS =$$GETAUDI T(3)
  23887   "RTN","RCD PESP5",320 ,0)
  23888    Q:EMEDANS =-1 1
  23889   "RTN","RCD PESP5",321 ,0)
  23890    ; File Me dical elec tronic bil ls
  23891   "RTN","RCD PESP5",322 ,0)
  23892    I EMEDANS '=EOLDMED  D
  23893   "RTN","RCD PESP5",323 ,0)
  23894    . N RCAUD VAL
  23895   "RTN","RCD PESP5",324 ,0)
  23896    . D FILEA NS(7.07,EM EDANS)
  23897   "RTN","RCD PESP5",325 ,0)
  23898    . ; FILE  NUMBER^FIE LD NUMBER^ IEN^NEW VA LUE^OLD VA LUE^COMMEN T
  23899   "RTN","RCD PESP5",326 ,0)
  23900    . S RCAUD VAL(1)="34 2^7.07^1^" _EMEDANS_U _EOLDMED_U _"Updating  the Medic al Auto-Au dit of ele ctronic bi lls"
  23901   "RTN","RCD PESP5",327 ,0)
  23902    . D AUDIT ^RCDPESP(. RCAUDVAL)
  23903   "RTN","RCD PESP5",328 ,0)
  23904    ;
  23905   "RTN","RCD PESP5",329 ,0)
  23906    ; Get Pha rmacy elec tronic bil ls
  23907   "RTN","RCD PESP5",330 ,0)
  23908    S ERXANS= $$GETAUDIT (4)
  23909   "RTN","RCD PESP5",331 ,0)
  23910    Q:ERXANS= -1 1
  23911   "RTN","RCD PESP5",332 ,0)
  23912    ;
  23913   "RTN","RCD PESP5",333 ,0)
  23914    ; File Ph armacy ele ctronic bi lls
  23915   "RTN","RCD PESP5",334 ,0)
  23916    I ERXANS' =EOLDRX D
  23917   "RTN","RCD PESP5",335 ,0)
  23918    . N RCAUD VAL
  23919   "RTN","RCD PESP5",336 ,0)
  23920    . D FILEA NS(7.08,ER XANS)
  23921   "RTN","RCD PESP5",337 ,0)
  23922    . S RCAUD VAL(1)="34 2^7.08^1^" _ERXANS_U_ EOLDRX_U_" Updating t he Pharmac y Auto-Aud it of elec tronic bil ls"
  23923   "RTN","RCD PESP5",338 ,0)
  23924    . D AUDIT ^RCDPESP(. RCAUDVAL)
  23925   "RTN","RCD PESP5",339 ,0)
  23926    ; END PRC A*4.5*321
  23927   "RTN","RCD PESP5",340 ,0)
  23928    ;
  23929   "RTN","RCD PESP5",341 ,0)
  23930    Q 0
  23931   "RTN","RCD PESP5",342 ,0)
  23932    ;
  23933   "RTN","RCD PESP5",343 ,0)
  23934    ;Retrieve  the param eter for t he bill ty pe
  23935   "RTN","RCD PESP5",344 ,0)
  23936   GETAUDIT(F LAG) ;
  23937   "RTN","RCD PESP5",345 ,0)
  23938    ; BEGIN P RCA*4.5*32 1
  23939   "RTN","RCD PESP5",346 ,0)
  23940    ;FLAG - W hat audit  type (1=Me d Paper, 2 =RX Paper,  3=Med EDI , 4=Rx EDI )
  23941   "RTN","RCD PESP5",347 ,0)
  23942    Q:'$G(FLA G) -1
  23943   "RTN","RCD PESP5",348 ,0)
  23944    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,FLDNO,RC ANS,TYPL,T YPU,X,Y
  23945   "RTN","RCD PESP5",349 ,0)
  23946    S TYPL=$S (FLAG>2:"e lectronic" ,1:"paper" )
  23947   "RTN","RCD PESP5",350 ,0)
  23948    S TYPU=$S (FLAG>2:"E LECTRONIC" ,1:"PAPER" )
  23949   "RTN","RCD PESP5",351 ,0)
  23950    S FLDNO=$ S(FLAG=1:7 .05,FLAG=2 :7.06,FLAG =3:7.07,FL AG=4:7.08, 1:0)
  23951   "RTN","RCD PESP5",352 ,0)
  23952    Q:'FLDNO  -1
  23953   "RTN","RCD PESP5",353 ,0)
  23954    ;
  23955   "RTN","RCD PESP5",354 ,0)
  23956    ; Prompt  for Medica l Auto-aud it
  23957   "RTN","RCD PESP5",355 ,0)
  23958    D:$G(FLAG )#2=1
  23959   "RTN","RCD PESP5",356 ,0)
  23960    . S DIR(" A")="ENABL E AUTO-AUD IT FOR MED ICAL "_TYP U_" BILLS  (Y/N): "
  23961   "RTN","RCD PESP5",357 ,0)
  23962    . S DIR(" ?",1)="All ow a site  to automat ically aud it their M edical "_T YPL_" Bill s"
  23963   "RTN","RCD PESP5",358 ,0)
  23964    . S DIR(" ?",2)="dur ing the AR  Nightly P rocess."
  23965   "RTN","RCD PESP5",359 ,0)
  23966    . S DIR(" ?",3)=" "
  23967   "RTN","RCD PESP5",360 ,0)
  23968    . S RCANS =$$GET1^DI Q(342,"1," ,FLDNO)
  23969   "RTN","RCD PESP5",361 ,0)
  23970    ;
  23971   "RTN","RCD PESP5",362 ,0)
  23972    ; Prompt  for Pharma cy Auto-au dit
  23973   "RTN","RCD PESP5",363 ,0)
  23974    D:$G(FLAG )#2=0
  23975   "RTN","RCD PESP5",364 ,0)
  23976    . S DIR(" A")="ENABL E AUTO-AUD IT FOR PHA RMACY "_TY PU_" BILLS  (Y/N): "
  23977   "RTN","RCD PESP5",365 ,0)
  23978    . S DIR(" ?",1)="All ow a site  to automat ically aud it their P harmacy "_ TYPL_" Bil ls"
  23979   "RTN","RCD PESP5",366 ,0)
  23980    . S DIR(" ?",2)="dur ing the AR  Nightly P rocess."
  23981   "RTN","RCD PESP5",367 ,0)
  23982    . S DIR(" ?",3)=" "
  23983   "RTN","RCD PESP5",368 ,0)
  23984    . S RCANS =$$GET1^DI Q(342,"1," ,FLDNO)
  23985   "RTN","RCD PESP5",369 ,0)
  23986    ; END PRC A*4.5*321
  23987   "RTN","RCD PESP5",370 ,0)
  23988    ;
  23989   "RTN","RCD PESP5",371 ,0)
  23990    S DIR(0)= "YAO"
  23991   "RTN","RCD PESP5",372 ,0)
  23992    S DIR("?" )="Enter Y es or No t o select a utomatic p rocessing  of "_TYPL_ " bills."  ; PRCA*4.5 *321
  23993   "RTN","RCD PESP5",373 ,0)
  23994    S DIR("B" )=$S($G(RC ANS)'="":R CANS,1:"No ")
  23995   "RTN","RCD PESP5",374 ,0)
  23996    D ^DIR K  DIR
  23997   "RTN","RCD PESP5",375 ,0)
  23998    I Y="" Q  ""
  23999   "RTN","RCD PESP5",376 ,0)
  24000    I $D(DTOU T)!$D(DUOU T)!(Y="")   Q -1
  24001   "RTN","RCD PESP5",377 ,0)
  24002    Q Y
  24003   "RTN","RCD PESP5",378 ,0)
  24004    ;
  24005   "RTN","RCD PESP5",379 ,0)
  24006    ;File the  answer
  24007   "RTN","RCD PESP5",380 ,0)
  24008   FILEANS(FI ELD,ANS) ;
  24009   "RTN","RCD PESP5",381 ,0)
  24010    ;
  24011   "RTN","RCD PESP5",382 ,0)
  24012    N DR,DIE, DA,DTOUT,D IDEL,X,Y
  24013   "RTN","RCD PESP5",383 ,0)
  24014    ;
  24015   "RTN","RCD PESP5",384 ,0)
  24016    ;Update T ransaction
  24017   "RTN","RCD PESP5",385 ,0)
  24018    S DR=FIEL D_"///"_AN S            ;Origina l Confirma tion #
  24019   "RTN","RCD PESP5",386 ,0)
  24020    S DIE="^R C(342,"
  24021   "RTN","RCD PESP5",387 ,0)
  24022    S DA=1
  24023   "RTN","RCD PESP5",388 ,0)
  24024    D ^DIE
  24025   "RTN","RCD PESP5",389 ,0)
  24026    ;
  24027   "RTN","RCD PESP5",390 ,0)
  24028    Q
  24029   "RTN","RCD PESR2")
  24030   0^46^B9123 3703
  24031   "RTN","RCD PESR2",1,0 )
  24032   RCDPESR2 ; ALB/TMK/DW A - Server  auto-upd  - EDI Lock box ;Jun 0 6, 2014@19 :11:19
  24033   "RTN","RCD PESR2",2,0 )
  24034    ;;4.5;Acc ounts Rece ivable;**1 73,216,208 ,230,252,2 64,269,271 ,298,321** ;Mar 20, 1 995;Build  46
  24035   "RTN","RCD PESR2",3,0 )
  24036    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  24037   "RTN","RCD PESR2",4,0 )
  24038    ; IA 4042  (IBCEOB)
  24039   "RTN","RCD PESR2",5,0 )
  24040    ;Referenc e to $$VAL ECME^BPSUT IL2 suppor ted by IA#  6139
  24041   "RTN","RCD PESR2",6,0 )
  24042    ;
  24043   "RTN","RCD PESR2",7,0 )
  24044   TASKERA(RC TDA) ; Tas k to upd E RA
  24045   "RTN","RCD PESR2",8,0 )
  24046    ; RCTDA =  ien 344.5
  24047   "RTN","RCD PESR2",9,0 )
  24048    N ZTDTH,Z TUCI,ZTSAV E,ZTIO,ZTD ESC,ZTRTN, ZTSK,DIE,D R,DA
  24049   "RTN","RCD PESR2",10, 0)
  24050    S (ZTSAVE ("DT"),ZTS AVE("U"),Z TSAVE("DUZ "))="",ZTS AVE("ZTREQ ")="@",ZTR TN="NEWERA ^RCDPESR2( "_RCTDA_", 0)",ZTDTH= $H,ZTIO=""
  24051   "RTN","RCD PESR2",11, 0)
  24052    D ^%ZTLOA D
  24053   "RTN","RCD PESR2",12, 0)
  24054    Q
  24055   "RTN","RCD PESR2",13, 0)
  24056    ;
  24057   "RTN","RCD PESR2",14, 0)
  24058   NEWERA(RCT DA,RCREFIL E) ;Tasked
  24059   "RTN","RCD PESR2",15, 0)
  24060    ; Add new  EOB's to  IB & ERA t ot rec to  AR
  24061   "RTN","RCD PESR2",16, 0)
  24062    ; RCTDA =  ien 344.5
  24063   "RTN","RCD PESR2",17, 0)
  24064    ; RCREFIL E = 1: re- filing rec  via exc p roc
  24065   "RTN","RCD PESR2",18, 0)
  24066    N RCDUPER R,RCPAYER, RCRTOT,RCE ,RCEC,RCER R,RCR1,RCA DJ,DIE,DR, DA,Z,Q
  24067   "RTN","RCD PESR2",19, 0)
  24068    S ZTREQ=" @"
  24069   "RTN","RCD PESR2",20, 0)
  24070    K ^TMP($J ,"RCDPERA" )
  24071   "RTN","RCD PESR2",21, 0)
  24072    L +^RCY(3 44.5,RCTDA ):5
  24073   "RTN","RCD PESR2",22, 0)
  24074    I $D(ZTQU EUED) S DI E="^RCY(34 4.5,",DA=R CTDA,DR=". 05////"_ZT SK_";.04// //1" D ^DI E
  24075   "RTN","RCD PESR2",23, 0)
  24076    I $P($G(^ RCY(344.5, RCTDA,0)), U,5),'$G(R CREFILE) S  DIE="^RCY (344.5,",D A=RCTDA,DR =".1////4; .08///1" D  ^DIE
  24077   "RTN","RCD PESR2",24, 0)
  24078    S RCR1=$P ($G(^RCY(3 44.5,RCTDA ,0)),U,7), RCPAYER=$P ($G(^RCY(3 44.5,RCTDA ,3)),U)
  24079   "RTN","RCD PESR2",25, 0)
  24080    S RCRTOT= $S(RCR1:RC R1,1:$$ERA TOT^RCDPES R6(RCTDA,. RCERR)) ;  ERA rec
  24081   "RTN","RCD PESR2",26, 0)
  24082    S RCDUPER R=$S($G(RC ERR)="DUP" !($G(RCERR (1))=-2):$ G(RCERR(1) ),1:0) K R CERR(1)
  24083   "RTN","RCD PESR2",27, 0)
  24084    I RCRTOT, 'RCR1 S DI E="^RCY(34 4.5,",DR=" .07////"_R CRTOT,DA=R CTDA D ^DI E
  24085   "RTN","RCD PESR2",28, 0)
  24086    D:RCDUPER R'=-2 UPDE OB(RCTDA,5 ,$S('$G(RC REFILE):RC DUPERR,1:- 1)) ; Add  EOB det to  IB
  24087   "RTN","RCD PESR2",29, 0)
  24088    I RCRTOT  D UPDCON^R CDPESR6(RC RTOT),UPDA DJ^RCDPESR 6(RCRTOT), UPD3444^RC DPESR6(.RC RTOT) ; Bi lls added  344.41
  24089   "RTN","RCD PESR2",30, 0)
  24090    I RCRTOT, RCTDA S DI E="^RCY(34 4.5,",DR=" .08////0;. 1///@",DA= RCTDA D ^D IE
  24091   "RTN","RCD PESR2",31, 0)
  24092    I 'RCRTOT  D  G QNEW
  24093   "RTN","RCD PESR2",32, 0)
  24094    .I RCDUPE RR Q:'RCTD A  D  S RC TDA="" Q
  24095   "RTN","RCD PESR2",33, 0)
  24096    ..I RCDUP ERR=-2 D B ULLERA^RCD PESR0("D", RCTDA,$P($ G(^RCY(344 .5,RCTDA,0 )),U,11)," EDI LBOX -  DUPLICATE  ERA NOT F ILED "_$E( RCPAYER,1, 20),.RCERR ,0)
  24097   "RTN","RCD PESR2",34, 0)
  24098    ..D TEMPD EL^RCDPESR 1(RCTDA)
  24099   "RTN","RCD PESR2",35, 0)
  24100    .S RCE(1) =$$FMTE^XL FDT($$NOW^ XLFDT(),2) _" An erro r occurred  while sto ring ERA d ata.",RCE( 2)="No tot als data w as stored  for this E RA record" _$S('$G(RC REFILE):"  and an",1: " on this  re-file at tempt.")
  24101   "RTN","RCD PESR2",36, 0)
  24102    .S RCE(3) =$S('$G(RC REFILE):"E RA transmi ssion exce ption was  created.", 1:"")
  24103   "RTN","RCD PESR2",37, 0)
  24104    .D WP^DIE (344.5,RCT DA_",",5," A","RCE")
  24105   "RTN","RCD PESR2",38, 0)
  24106    .S DIE="^ RCY(344.5, ",DA=RCTDA ,DR=".07// /@;.08//// 1;.1////1"  D ^DIE
  24107   "RTN","RCD PESR2",39, 0)
  24108    .K RCERR
  24109   "RTN","RCD PESR2",40, 0)
  24110    .S RCERR( 1)=$$FMTE^ XLFDT($$NO W^XLFDT(), 2)_" The E RA data co uld not be  stored. T he AR rece ipt",RCERR (2)=" for  this data  must be cr eated/proc essed manu ally for t he bills i ncluded"
  24111   "RTN","RCD PESR2",41, 0)
  24112    .S RCERR( 3)=" in th is ERA."_$ S('$G(RCRE FILE):"",1 :"  This e rror occur red during  a refile  attempt.") ,RCERR(4)= " "
  24113   "RTN","RCD PESR2",42, 0)
  24114    .D BULLER A^RCDPESR0 ("DF",RCTD A,$P($G(^R CY(344.5,R CTDA,0)),U ,11),"EDI  LBOX - TOT ALS FILE E XCEPTION " _$E(RCPAYE R,1,20),.R CERR,0)
  24115   "RTN","RCD PESR2",43, 0)
  24116    .K RCERR
  24117   "RTN","RCD PESR2",44, 0)
  24118    ;-----
  24119   "RTN","RCD PESR2",45, 0)
  24120    ; PRCA*4. 5*298 - Ma ilMan mess age disabl ed, logic  retained -  14 Feb 20 14
  24121   "RTN","RCD PESR2",46, 0)
  24122    ;I $$ADJ^ RCDPEU(RCR TOT,.RCADJ ) D  ;Bull etin adjs
  24123   "RTN","RCD PESR2",47, 0)
  24124    ;.S RCEC= $$ADJERR^R CDPESR3(.R CERR)
  24125   "RTN","RCD PESR2",48, 0)
  24126    ;.I RCADJ '=2 S RCEC =RCEC+1,RC ERR(RCEC)= " THERE AR E ERA LEVE L ADJUSTME NT(S)",RCE C=RCEC+1,R CERR(RCEC) =" "
  24127   "RTN","RCD PESR2",49, 0)
  24128    ;.I RCADJ '=1 S RCEC =RCEC+1,RC ERR(RCEC)= " THE FOLL OWING BILL (S) HAVE R ETRACTIONS :" D
  24129   "RTN","RCD PESR2",50, 0)
  24130    ;..S (Q,Z )=0 S Z=0  F  S Z=$O( RCADJ(RCRT OT,Z)) Q:' Z  S:'Q RC EC=RCEC+1, RCERR(RCEC )="  " S Q =Q+1,RCERR (RCEC)=RCE RR(RCEC)_"   "_RCADJ( RCRTOT,Z)  S:Q=4 Q=0
  24131   "RTN","RCD PESR2",51, 0)
  24132    ;..S RCEC =RCEC+1,RC ERR(RCEC)= " "
  24133   "RTN","RCD PESR2",52, 0)
  24134    ;.D BULLE RA^RCDPESR 0("D",RCTD A,$P($G(^R CY(344.5,R CTDA,0)),U ,11),"EDI  LBOX - ERA  HAS ADJ/T AKEBACKS " _$E(RCPAYE R,1,20),.R CERR,0)
  24135   "RTN","RCD PESR2",53, 0)
  24136    ;-----
  24137   "RTN","RCD PESR2",54, 0)
  24138    ;
  24139   "RTN","RCD PESR2",55, 0)
  24140   QNEW I RCT DA,'$P($G( ^RCY(344.5 ,RCTDA,0)) ,U,8) D TE MPDEL^RCDP ESR1(RCTDA ) S RCTDA= ""
  24141   "RTN","RCD PESR2",56, 0)
  24142    I RCTDA,$ P($G(^RCY( 344.5,RCTD A,0)),U)'= "" S DIE=" ^RCY(344.5 ,",DR=".04 ////0;.05/ //@"_$S('$ G(RCR1)&$G (RCRTOT):" ;.07////"_ RCRTOT,1:" "),DA=RCTD A D ^DIE
  24143   "RTN","RCD PESR2",57, 0)
  24144    K ^TMP($J ,"RCDPERA" )
  24145   "RTN","RCD PESR2",58, 0)
  24146    I RCTDA L  -^RCY(344 .5,RCTDA)
  24147   "RTN","RCD PESR2",59, 0)
  24148    Q
  24149   "RTN","RCD PESR2",60, 0)
  24150    ;
  24151   "RTN","RCD PESR2",61, 0)
  24152   UPDEOB(RCT DA,RCFILE, DUP) ;Upd  361.1 from  ERA msg i n 344.5 or  .4
  24153   "RTN","RCD PESR2",62, 0)
  24154    ;RCTDA =  ien ERA ms g in 344.5  or ;subfi le in 344. 4
  24155   "RTN","RCD PESR2",63, 0)
  24156    ;RCFILE =  4 file 34 4.4, 5 if  344.5
  24157   "RTN","RCD PESR2",64, 0)
  24158    ;DUP = ms g # if dup  msg, but  not same #  or -1 if  same msg #
  24159   "RTN","RCD PESR2",65, 0)
  24160    ;Returned  for each  bill in ER A:
  24161   "RTN","RCD PESR2",66, 0)
  24162    ;^TMP($J, "RCDPEOB", n)=Bill ie n^AR bill# ^SrvDt^ECM E#
  24163   "RTN","RCD PESR2",67, 0)
  24164    ;^TMP($J, "RCDPEOB", n,"EOB")=E OB ien^amt  pd^ins co  ptr^rev f lg^EEOB pn ^amtbld^^^ ^BPNPI^RNP I^ETQual^L N^FN
  24165   "RTN","RCD PESR2",68, 0)
  24166    ;^TMP($J, "RCDPEOB", "ADJ",x)=a dj rec ('0 2')
  24167   "RTN","RCD PESR2",69, 0)
  24168    ;Also:
  24169   "RTN","RCD PESR2",70, 0)
  24170    ;^TMP($J, "RCDPEOB", "HDR")=hdr  rec from  txmn
  24171   "RTN","RCD PESR2",71, 0)
  24172    ;^TMP($J, "RCDPEOB", "CONTACT") =ERA conta ct rec ('0 1')
  24173   "RTN","RCD PESR2",72, 0)
  24174    ;
  24175   "RTN","RCD PESR2",73, 0)
  24176    ;N RCGBL, RC,RC0,RCC T,RCCT1,RC EOB,RCBILL ,RCDPBNPI, RCMNUM,RCI FN,RCIB,RC ERR,RCSTAR ,RCET,RCX, RCXMG,Z,Q, DA,DR,DIE
  24177   "RTN","RCD PESR2",74, 0)
  24178    ;N RCPAYE R,RCFILED, RCEOBD,RCN OUPD,REFOR M,RCSD,RCE RR1,C5,ECM ENUM
  24179   "RTN","RCD PESR2",75, 0)
  24180    ; PRCA*4. 5*321 - re -ordered n ewed field s and adde d RCSTART
  24181   "RTN","RCD PESR2",76, 0)
  24182    N C5,DA,D IE,DR,ECME NUM,N,Q,RC ,RC0,RCBIL L,RCCT,RCC T1,RCDPBNP I,RCEOB,RC EOBD,RCERR
  24183   "RTN","RCD PESR2",77, 0)
  24184    N RCERR1, RCET,RCFIL ED,RCGBL,R CIB,RCIFN, RCMNUM,RCN OUPD,RCPAY ER,RCSD,RC STAR,RCSTA RT
  24185   "RTN","RCD PESR2",78, 0)
  24186    N RCX,RCX MG,REFORM, X,Y,Z
  24187   "RTN","RCD PESR2",79, 0)
  24188    K ^TMP($J ,"RCDP-EOB "),^TMP("R CDPERR-EOB ",$J)
  24189   "RTN","RCD PESR2",80, 0)
  24190    ;
  24191   "RTN","RCD PESR2",81, 0)
  24192    S RCPAYER ="",RCFILE D=1,RCNOUP D=0
  24193   "RTN","RCD PESR2",82, 0)
  24194    I RCFILE= 5 D
  24195   "RTN","RCD PESR2",83, 0)
  24196    .S RCGBL= $NA(^RCY(3 44.5,RCTDA ,2))
  24197   "RTN","RCD PESR2",84, 0)
  24198    .S RCMNUM =+$G(^RCY( 344.5,RCTD A,0)),RCXM G=$P($G(^( 0)),U,11)
  24199   "RTN","RCD PESR2",85, 0)
  24200    .I $G(DUP ) S RCNOUP D=$S(DUP>0 :+DUP,1:RC XMG)
  24201   "RTN","RCD PESR2",86, 0)
  24202    .S ^TMP($ J,"RCDPEOB ","HDR")=$ G(^RCY(344 .5,RCTDA,2 ,1,0))
  24203   "RTN","RCD PESR2",87, 0)
  24204    .I $P(^TM P($J,"RCDP EOB","HDR" ),U)["XFR" ,'$P($G(^R CY(344.5,R CTDA,0)),U ,14) D
  24205   "RTN","RCD PESR2",88, 0)
  24206    ..D SENDA CK^RCDPESR 5(RCTDA,1)
  24207   "RTN","RCD PESR2",89, 0)
  24208    ..S DR=". 14////1",D IE="^RCY(3 44.5,",DA= RCTDA D ^D IE
  24209   "RTN","RCD PESR2",90, 0)
  24210    ;
  24211   "RTN","RCD PESR2",91, 0)
  24212    I RCFILE= 4 D
  24213   "RTN","RCD PESR2",92, 0)
  24214    .S RCGBL= $NA(^RCY(3 44.4,+RCTD A,1,+$P(RC TDA,";",2) ,1))
  24215   "RTN","RCD PESR2",93, 0)
  24216    .S RCMNUM =$P($G(^RC Y(344.4,+R CTDA,0)),U ,12),RCXMG =$P($G(^(0 )),U,12)
  24217   "RTN","RCD PESR2",94, 0)
  24218    .S ^TMP($ J,"RCDPEOB ","HDR")=$ G(^RCY(344 .4,+RCTDA, 1,+$P(RCTD A,";",2),1 ,1,0))
  24219   "RTN","RCD PESR2",95, 0)
  24220    ;
  24221   "RTN","RCD PESR2",96, 0)
  24222    S RCPAYER =$P($G(^TM P($J,"RCDP EOB","HDR" )),U,6)
  24223   "RTN","RCD PESR2",97, 0)
  24224    S RCDPBNP I=$P($G(^T MP($J,"RCD PEOB","HDR ")),U,18)
  24225   "RTN","RCD PESR2",98, 0)
  24226    ;
  24227   "RTN","RCD PESR2",99, 0)
  24228    ;srv date s
  24229   "RTN","RCD PESR2",100 ,0)
  24230    S RCSD=$N A(^TMP($J, "RCSRVDT") ) K @RCSD
  24231   "RTN","RCD PESR2",101 ,0)
  24232    S RCSTART =0 ; PRCA* 4.5*321
  24233   "RTN","RCD PESR2",102 ,0)
  24234    N CP5 S C P5="",RC=1 ,C5=0 ;ret rofit 264  into 269
  24235   "RTN","RCD PESR2",103 ,0)
  24236    F  S RC=$ O(@RCGBL@( RC)) Q:'RC   S RC0=$G (^(RC,0))  D
  24237   "RTN","RCD PESR2",104 ,0)
  24238    .I RC0<5  Q
  24239   "RTN","RCD PESR2",105 ,0)
  24240    .;Stateme nt Start D ate - 05 R ecord is m andatory
  24241   "RTN","RCD PESR2",106 ,0)
  24242    .I +RC0=5  S RCSTART =+$P(RC0,U ,9) ; PRCA *4.5*321
  24243   "RTN","RCD PESR2",107 ,0)
  24244    .I +RC0=5  S C5=RC,C P5=$P(RC0, U,2) Q  ;r etrofit 26 4 into 269
  24245   "RTN","RCD PESR2",108 ,0)
  24246    .; servic e date for  possible  ECME# matc hing
  24247   "RTN","RCD PESR2",109 ,0)
  24248    .; PRCA*4 .3*321 BEG IN
  24249   "RTN","RCD PESR2",110 ,0)
  24250    .I +RC0=4 0,$$VALECM E^BPSUTIL2 (CP5),C5,' $D(@RCSD@( C5)) D
  24251   "RTN","RCD PESR2",111 ,0)
  24252    . I $P(RC 0,U,19) S  @RCSD@(C5) =+$P(RC0,U ,19) Q
  24253   "RTN","RCD PESR2",112 ,0)
  24254    . ; If se rvice date  not prese nt use sta tement sta rt date in stead
  24255   "RTN","RCD PESR2",113 ,0)
  24256    . S:RCSTA RT @RCSD@( C5)=RCSTAR T
  24257   "RTN","RCD PESR2",114 ,0)
  24258    ; PRCA*4. 5*321 END
  24259   "RTN","RCD PESR2",115 ,0)
  24260    ;
  24261   "RTN","RCD PESR2",116 ,0)
  24262    S RC=1,(R CCT,RCCT1, RCX,REFORM )=0,RCBILL =""
  24263   "RTN","RCD PESR2",117 ,0)
  24264    S RCERR1= $NA(^TMP(" RCERR1",$J )) K @RCER R1
  24265   "RTN","RCD PESR2",118 ,0)
  24266    F  S RC=$ O(@RCGBL@( RC)) Q:'RC   S RC0=$G (^(RC,0))  D
  24267   "RTN","RCD PESR2",119 ,0)
  24268    .I RCFILE =5,+RC0=1  D  Q
  24269   "RTN","RCD PESR2",120 ,0)
  24270    ..S ^TMP( $J,"RCDPEO B","CONTAC T")=RC0
  24271   "RTN","RCD PESR2",121 ,0)
  24272    .;
  24273   "RTN","RCD PESR2",122 ,0)
  24274    .I RCFILE =5,+RC0=2  D  Q
  24275   "RTN","RCD PESR2",123 ,0)
  24276    ..S RCX=R CX+1,^TMP( $J,"RCDPEO B","ADJ",R CX)=RC0
  24277   "RTN","RCD PESR2",124 ,0)
  24278    .I RCFILE =5,+RC0=3  D  Q  ; Ad ding logic  for line  type 03,Pa tch 269,DW A
  24279   "RTN","RCD PESR2",125 ,0)
  24280    ..S $P(^T MP($J,"RCD PEOB","ADJ ",RCX),U,5 )=$P(RC0,U ,2)
  24281   "RTN","RCD PESR2",126 ,0)
  24282    .;
  24283   "RTN","RCD PESR2",127 ,0)
  24284    .I +RC0=5  S RCCT=RC CT+1,RCCT1 =0 D
  24285   "RTN","RCD PESR2",128 ,0)
  24286    ..S REFOR M=0,ECMENU M="" I $$V ALECME^BPS UTIL2($P(R C0,U,2)) S  ECMENUM=$ P(RC0,U,2)
  24287   "RTN","RCD PESR2",129 ,0)
  24288    ..S Z=$$B ILL^RCDPES R1($P(RC0, U,2),$G(@R CSD@(RC)), .RCIB)   ;  look up c laim ien b y claim# o r by ECME#
  24289   "RTN","RCD PESR2",130 ,0)
  24290    ..I Z S R CBILL=$P($ G(^PRCA(43 0,Z,0)),U)  I RCBILL' ="",RCBILL '=$P(RC0,U ,2) S REFO RM=1,$P(RC 0,U,2)=RCB ILL
  24291   "RTN","RCD PESR2",131 ,0)
  24292    ..S RCBIL L=$P(RC0,U ,2)
  24293   "RTN","RCD PESR2",132 ,0)
  24294    ..S Z=$S( Z>0:$S($G( RCIB):Z,1: -1),1:-1)
  24295   "RTN","RCD PESR2",133 ,0)
  24296    ..S ^TMP( $J,"RCDP-E OB",RCCT,0 )=Z_U_RCBI LL_U_$G(@R CSD@(RC))_ U_ECMENUM
  24297   "RTN","RCD PESR2",134 ,0)
  24298    ..S $P(^T MP($J,"RCD PEOB",RCCT ,"EOB"),U, 5)=$P(RC0, U,3)_","_$ P(RC0,U,4) _" "_$P(RC 0,U,5) ;Sa ve pt nm
  24299   "RTN","RCD PESR2",135 ,0)
  24300    ..I Z>0 S  Q=+$P($G( ^PRCA(430, Z,0)),U,9)  I $P($G(^ RCD(340,Q, 0)),U)["DI C(36," S $ P(^TMP($J, "RCDPEOB", RCCT,"EOB" ),U,3)=+^R CD(340,Q,0 ) ;Save in s co
  24301   "RTN","RCD PESR2",136 ,0)
  24302    .;
  24303   "RTN","RCD PESR2",137 ,0)
  24304    .I +RC0>5 ,REFORM S  $P(RC0,U,2 )=RCBILL ;
  24305   "RTN","RCD PESR2",138 ,0)
  24306    .I +RC0=1 0 D  ;Save  amt pd/bi lled, rev  flg
  24307   "RTN","RCD PESR2",139 ,0)
  24308    ..S $P(^T MP($J,"RCD PEOB",RCCT ,"EOB"),U, 2)=$S(+$P( RC0,U,11): $J($P(RC0, U,11)/100, "",2),1:0) ,$P(^TMP($ J,"RCDPEOB ",RCCT,"EO B"),U,6)=$ J($P(RC0,U ,11),"",2)
  24309   "RTN","RCD PESR2",140 ,0)
  24310    ..I $P(RC 0,U,6)="Y" !($P(RC0,U ,7)=22) S  $P(^TMP($J ,"RCDPEOB" ,RCCT,"EOB "),U,4)=1
  24311   "RTN","RCD PESR2",141 ,0)
  24312    ..S $P(^T MP($J,"RCD PEOB",RCCT ,"EOB"),U, 10,14)=RCD PBNPI_U_$P (RC0,U,16, 19)
  24313   "RTN","RCD PESR2",142 ,0)
  24314    .I +RC0=1 1 D  ; Sav e Renderin g Provider  informati on from ne w style me ssage
  24315   "RTN","RCD PESR2",143 ,0)
  24316    ..S $P(^T MP($J,"RCD PEOB",RCCT ,"EOB"),U, 10,14)=RCD PBNPI_U_$P (RC0,U,3,6 )
  24317   "RTN","RCD PESR2",144 ,0)
  24318    ..; End s ave of Ren dering Pro vider
  24319   "RTN","RCD PESR2",145 ,0)
  24320    .I RCBILL =$P(RC0,U, 2) S RCCT1 =RCCT1+1,^ TMP($J,"RC DP-EOB",RC CT,RCCT1,0 )=RC0
  24321   "RTN","RCD PESR2",146 ,0)
  24322    ;
  24323   "RTN","RCD PESR2",147 ,0)
  24324    S RCSTAR= $TR($J("", 15)," ","* "),RCET=RC STAR_"ERRO R/WARNING  EEOB DETAI L SEQ #"
  24325   "RTN","RCD PESR2",148 ,0)
  24326    S RCCT=0  F  S RCCT= $O(^TMP($J ,"RCDP-EOB ",RCCT)) Q :'RCCT  S  RCIFN=+$G( ^(RCCT,0)) ,RCBILL=$P ($G(^(0)), U,2),^TMP( $J,"RCDPEO B",RCCT)=$ G(^TMP($J, "RCDP-EOB" ,RCCT,0))  D
  24327   "RTN","RCD PESR2",149 ,0)
  24328    .S RCEOB= -1,RCEOBD= ""
  24329   "RTN","RCD PESR2",150 ,0)
  24330    .I $S(RCI FN>0:$P(^P RCA(430.3, +$P($G(^PR CA(430,+RC IFN,0)),U, 8),0),U,3) '=102,RCIF N'>0&($G(D UP)'>0):1, 1:0) D
  24331   "RTN","RCD PESR2",151 ,0)
  24332    ..S @RCER R1@(RCCT)= " ",@RCERR 1@(RCCT,1) =RCET_RCCT _RCSTAR
  24333   "RTN","RCD PESR2",152 ,0)
  24334    ..S @RCER R1@(RCCT,2 )="Bill "_ RCBILL_" i s"_$S(RCIF N>0:" not  in an ACTI VE status  in your A/ R",1:"n't  valid/wasn 't found s o its deta il wasn't  stored in  IB")
  24335   "RTN","RCD PESR2",153 ,0)
  24336    ..S:RCFIL E=5 @RCERR 1@(RCCT,"* ")=@RCERR1 @(RCCT,2)
  24337   "RTN","RCD PESR2",154 ,0)
  24338    ..S @RCER R1@(RCCT,3 )="  The r eported am ount paid  on this bi ll was: "_ $P(^TMP($J ,"RCDPEOB" ,RCCT,"EOB "),U,2)
  24339   "RTN","RCD PESR2",155 ,0)
  24340    ..I RCIFN '>0 D
  24341   "RTN","RCD PESR2",156 ,0)
  24342    ...S @RCE RR1@(RCCT, 4)="  If t he bill is  not for y our site,  it must be  transferr ed to the"
  24343   "RTN","RCD PESR2",157 ,0)
  24344    ...S @RCE RR1@(RCCT, 5)="   cor rect site  and manual ly adjuste d in your  AR."
  24345   "RTN","RCD PESR2",158 ,0)
  24346    ...S @RCE RR1@(RCCT, 6)="  You  can perfor m this tra nsfer usin g EDI Lock box ERA/EE OB excepti on process ."
  24347   "RTN","RCD PESR2",159 ,0)
  24348    ...S @RCE RR1@(RCCT, 7)=" "
  24349   "RTN","RCD PESR2",160 ,0)
  24350    ..D DISP1 ^RCDPESR5( RCCT,1)
  24351   "RTN","RCD PESR2",161 ,0)
  24352    ..S Q=0 F   S Q=$O(^ TMP($J,"RC DP-EOB",RC CT,Q)) Q:' Q  S ^TMP( $J,"RCDPEO B",RCCT,Q) =$G(^TMP($ J,"RCDP-EO B",RCCT,Q, 0))
  24353   "RTN","RCD PESR2",162 ,0)
  24354    ..S ^TMP( $J,"RCDPEO B",RCCT)=^ TMP($J,"RC DP-EOB",RC CT,0) M ^T MP($J,"RCD PEOB",RCCT ,"ERR")=@R CERR1@(RCC T)
  24355   "RTN","RCD PESR2",163 ,0)
  24356    ..I RCFIL E=5 D  ;St ore err if  trans-in  failed
  24357   "RTN","RCD PESR2",164 ,0)
  24358    ...N RCE, RC,DIE,X,Y ,DA,DR
  24359   "RTN","RCD PESR2",165 ,0)
  24360    ...S RCE( 1)=$$FMTE^ XLFDT($$NO W^XLFDT(), 2)_" "_$G( @RCERR1@(R CCT,"*"))
  24361   "RTN","RCD PESR2",166 ,0)
  24362    ...S RCE( 2)=" ",RCF ILED=0
  24363   "RTN","RCD PESR2",167 ,0)
  24364    ...D WP^D IE(344.5,R CTDA_",",5 ,"A","RCE" )
  24365   "RTN","RCD PESR2",168 ,0)
  24366    .I RCIFN> 0 D
  24367   "RTN","RCD PESR2",169 ,0)
  24368    ..N RCDUP EOB,RCALLD UP
  24369   "RTN","RCD PESR2",170 ,0)
  24370    ..;Chk re c exists
  24371   "RTN","RCD PESR2",171 ,0)
  24372    ..S RCDUP EOB=0
  24373   "RTN","RCD PESR2",172 ,0)
  24374    ..S RCEOB =$$DUP^RCD PESR3(RCMN UM,RCIFN,$ P($G(^TMP( $J,"RCDPEO B",RCCT,"E OB")),U,2) ,$P($G(^TM P($J,"RCDP EOB",RCCT, "EOB")),U, 6)) ;Same  msg for up date?
  24375   "RTN","RCD PESR2",173 ,0)
  24376    ..I RCEOB ,$P(RCEOB, U,2) S RCE OB=0  ;If  chksum exi sts, let b elow check  it
  24377   "RTN","RCD PESR2",174 ,0)
  24378    ..S ^TMP( $J,"RCDP-E OB",RCCT,. 5,0)="835E RA" ;Neede d - checks um
  24379   "RTN","RCD PESR2",175 ,0)
  24380    ..S RCALL DUP=$$DUP^ IBCEOB("^T MP("_$J_", ""RCDP-EOB "","_RCCT_ ")",RCIFN)
  24381   "RTN","RCD PESR2",176 ,0)
  24382    ..I $S(RC ALLDUP:1,R CEOB:$G(DU P)'>0,1:0)  D
  24383   "RTN","RCD PESR2",177 ,0)
  24384    ...S RCDU PEOB=1
  24385   "RTN","RCD PESR2",178 ,0)
  24386    ...D DUPR EC^RCDPESR 6(RCET,RCC T,RCSTAR,R CFILE,RCAL LDUP,RCEOB ,RCBILL,.R CDUPEOB)
  24387   "RTN","RCD PESR2",179 ,0)
  24388    ...S:RCAL LDUP RCEOB D=RCALLDUP
  24389   "RTN","RCD PESR2",180 ,0)
  24390    ..;Add st ub to 361. 1
  24391   "RTN","RCD PESR2",181 ,0)
  24392    ..I 'RCDU PEOB S RCE OB=+$$ADD3 611^IBCEOB (RCMNUM,"" ,"",RCIFN, 1,"^TMP("_ $J_",""RCD P-EOB"","_ RCCT_")")  ;IA 4042
  24393   "RTN","RCD PESR2",182 ,0)
  24394    ..K ^TMP( $J,"RCDP-E OB",RCCT,. 5,0)
  24395   "RTN","RCD PESR2",183 ,0)
  24396    ..I RCEOB <0 D:$G(DU P)'>0  Q
  24397   "RTN","RCD PESR2",184 ,0)
  24398    ...S @RCE RR1@(RCCT) =" ",^(RCC T,1)=RCET_ RCCT_RCSTA R,RCFILED= 0
  24399   "RTN","RCD PESR2",185 ,0)
  24400    ...S @RCE RR1@(RCCT, 2)="Error  - EEOB det ail not ad ded to IB  for bill " _RCBILL,$P (^TMP($J," RCDPEOB",R CCT,"EOB") ,U)=""
  24401   "RTN","RCD PESR2",186 ,0)
  24402    ...S:RCFI LE=5 @RCER R1@(RCCT," *")=@RCERR 1@(RCCT,2)
  24403   "RTN","RCD PESR2",187 ,0)
  24404    ...D DISP 1^RCDPESR5 (RCCT,1)
  24405   "RTN","RCD PESR2",188 ,0)
  24406    ...S Q=0  F  S Q=$O( ^TMP($J,"R CDP-EOB",R CCT,Q)) Q: 'Q  S ^TMP ($J,"RCDPE OB",RCCT,Q )=$G(^TMP( $J,"RCDP-E OB",RCCT,Q ,0))
  24407   "RTN","RCD PESR2",189 ,0)
  24408    ...S ^TMP ($J,"RCDPE OB",RCCT)= ^TMP($J,"R CDP-EOB",R CCT,0) M ^ TMP($J,"RC DPEOB",RCC T,"ERR")=@ RCERR1@(RC CT)
  24409   "RTN","RCD PESR2",190 ,0)
  24410    ..;Upd 36 1.1, needs  ^TMP($J," RCDPEOB"," HDR" and $ J,"RCDP-EO B"
  24411   "RTN","RCD PESR2",191 ,0)
  24412    ..I RCDUP EOB'<0 S R CNOUPD=0 D  UPD3611^I BCEOB(RCEO B,RCCT,1)
  24413   "RTN","RCD PESR2",192 ,0)
  24414    ..;errors  in ^TMP(" RCDPERR-EO B",$J
  24415   "RTN","RCD PESR2",193 ,0)
  24416    ..I $O(^T MP("RCDPER R-EOB",$J, 0)) D ERRU PD^IBCEOB( RCEOB,"RCD PERR-EOB")
  24417   "RTN","RCD PESR2",194 ,0)
  24418    ..S $P(^T MP($J,"RCD PEOB",RCCT ,"EOB"),U) =$S('$G(RC EOBD):RCEO B,1:RCEOBD )
  24419   "RTN","RCD PESR2",195 ,0)
  24420    .K ^TMP(" RCDPERR-EO B",$J)
  24421   "RTN","RCD PESR2",196 ,0)
  24422    ;
  24423   "RTN","RCD PESR2",197 ,0)
  24424    I RCNOUPD  D DUPERA^ RCDPESR3($ G(DUP),RCN OUPD)
  24425   "RTN","RCD PESR2",198 ,0)
  24426    I $O(@RCE RR1@(""))  D BULLS^RC DPESR3(RCF ILE,RCTDA, $S(RCNOUPD :RCNOUPD,1 :$G(DUP)), $G(RCXMG))
  24427   "RTN","RCD PESR2",199 ,0)
  24428    K ^TMP("R CDPERR-EOB ",$J),^TMP ($J,"RCDP- EOB"),@RCE RR1,@RCSD
  24429   "RTN","RCD PESR2",200 ,0)
  24430    D CLEAN^D ILF
  24431   "RTN","RCD PESR2",201 ,0)
  24432    Q
  24433   "RTN","RCD PESR3")
  24434   0^16^B5532 0528
  24435   "RTN","RCD PESR3",1,0 )
  24436   RCDPESR3 ; ALB/TMK/PJ H - Server  auto-upda te utiliti es - EDI L ockbox ;Ju n 06, 2014 @19:11:19
  24437   "RTN","RCD PESR3",2,0 )
  24438    ;;4.5;Acc ounts Rece ivable;**1 73,214,208 ,255,269,2 83,298,321 **;Mar 20,  1995;Buil d 46
  24439   "RTN","RCD PESR3",3,0 )
  24440    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  24441   "RTN","RCD PESR3",4,0 )
  24442    Q
  24443   "RTN","RCD PESR3",5,0 )
  24444    ;
  24445   "RTN","RCD PESR3",6,0 )
  24446   EFTIN(RCTX N,RCD,XMZ, RCGBL,RCEF LG) ; Adds  a new EFT  record to  AR file 3 44.3
  24447   "RTN","RCD PESR3",7,0 )
  24448    ;  from L ockbox EFT  msg
  24449   "RTN","RCD PESR3",8,0 )
  24450    ; Input:    RCTXN    - Data on  the header  record of  the messa ge text
  24451   "RTN","RCD PESR3",9,0 )
  24452    ;           RCD      - Array co ntaining f ormatted m ail messag e header d ata
  24453   "RTN","RCD PESR3",10, 0)
  24454    ;           XMZ      - Mail mes sage numbe r
  24455   "RTN","RCD PESR3",11, 0)
  24456    ;           RCGBL    - Name of  the array  or global  where the  message is  stored
  24457   "RTN","RCD PESR3",12, 0)
  24458    ; Output:   RCEFLG   - Error fl ag returne d if passe d by refer ence
  24459   "RTN","RCD PESR3",13, 0)
  24460    ;
  24461   "RTN","RCD PESR3",14, 0)
  24462    N CT,DA,D IK,DLAYGO, RC,RC1,RCL AST,RCEFT, RCTDA,RCER R,RCTYP1,R CZ,XX,Z,Z0
  24463   "RTN","RCD PESR3",15, 0)
  24464    ;
  24465   "RTN","RCD PESR3",16, 0)
  24466    ; Take da ta out of  mail messa ge
  24467   "RTN","RCD PESR3",17, 0)
  24468    S (RCEFLG ,RCLAST)=0 ,CT=0,RCTY P1="835EFT "
  24469   "RTN","RCD PESR3",18, 0)
  24470    F  X XMRE C Q:XMER<0   D  Q:RCL AST
  24471   "RTN","RCD PESR3",19, 0)
  24472    . I +XMRG =99,$P(XMR G,U,2)="$"  S RCLAST= 1 Q
  24473   "RTN","RCD PESR3",20, 0)
  24474    . S:XMRG' ="" CT=CT+ 1,@RCGBL@( 2,"D",CT)= XMRG
  24475   "RTN","RCD PESR3",21, 0)
  24476    ;
  24477   "RTN","RCD PESR3",22, 0)
  24478    I 'RCLAST ,'$G(RCERR ) K @RCGBL  S RCERR=2     ; No $  as last c haracter o f msg
  24479   "RTN","RCD PESR3",23, 0)
  24480    ;
  24481   "RTN","RCD PESR3",24, 0)
  24482    I $G(RCER R)>0 D  G  EFTQ
  24483   "RTN","RCD PESR3",25, 0)
  24484    . D ERRUP D^RCDPESR1 (RCGBL,.RC D,RCTYP1,. RCERR)
  24485   "RTN","RCD PESR3",26, 0)
  24486    . S RCEFL G=1
  24487   "RTN","RCD PESR3",27, 0)
  24488    ;
  24489   "RTN","RCD PESR3",28, 0)
  24490    ; Add top -level ent ry to file  344.3
  24491   "RTN","RCD PESR3",29, 0)
  24492    S RCEFT=$ $ADDEFT(RC TXN,XMZ,RC GBL,.RCERR )
  24493   "RTN","RCD PESR3",30, 0)
  24494    ;
  24495   "RTN","RCD PESR3",31, 0)
  24496    I $G(RCER R) D  G EF TQ                        ; 'BAD ' EFT's
  24497   "RTN","RCD PESR3",32, 0)
  24498    . D ERRUP D^RCDPESR1 (RCGBL,.RC D,RCTYP1,. RCERR)
  24499   "RTN","RCD PESR3",33, 0)
  24500    . S RCEFL G=1
  24501   "RTN","RCD PESR3",34, 0)
  24502    ;
  24503   "RTN","RCD PESR3",35, 0)
  24504    G:'RCEFT  EFTQ
  24505   "RTN","RCD PESR3",36, 0)
  24506    ;
  24507   "RTN","RCD PESR3",37, 0)
  24508    ; Add the  detail da ta to file  344.31 fo r this EFT  record
  24509   "RTN","RCD PESR3",38, 0)
  24510    S Z=0
  24511   "RTN","RCD PESR3",39, 0)
  24512    F  S Z=$O (^RCY(344. 31,"B",RCE FT,Z)) Q:' Z  D
  24513   "RTN","RCD PESR3",40, 0)
  24514    . S DA=Z, DIK="^RCY( 344.31,"
  24515   "RTN","RCD PESR3",41, 0)
  24516    . D ^DIK                                       ; Dele te any det ail data a lready the re
  24517   "RTN","RCD PESR3",42, 0)
  24518    ;
  24519   "RTN","RCD PESR3",43, 0)
  24520    S (RC,RC1 ,RCZ)=0
  24521   "RTN","RCD PESR3",44, 0)
  24522    F  S RCZ= $O(@RCGBL@ (2,"D",RCZ )) Q:'RCZ   S Z0=$G(^ (RCZ)) I Z 0'="" D  Q :$G(RCERR)
  24523   "RTN","RCD PESR3",45, 0)
  24524    . I $P(Z0 ,U)="01" D   ; Each p ayer's dat a
  24525   "RTN","RCD PESR3",46, 0)
  24526    . . N DA, DD,DIC,DIE ,DO,DR,X,Y
  24527   "RTN","RCD PESR3",47, 0)
  24528    . . S X=R CEFT
  24529   "RTN","RCD PESR3",48, 0)
  24530    . . S DIC ("DR")=".1 1////0;.04 ////"_$P(Z 0,U,2)_";. 08////0"
  24531   "RTN","RCD PESR3",49, 0)
  24532    . . S DIC ("DR")=DIC ("DR")_$S( $P(Z0,U,5) '="":";.02 ////"_$P(Z 0,U,5),1:" ")
  24533   "RTN","RCD PESR3",50, 0)
  24534    . . S DIC ("DR")=DIC ("DR")_$S( $P(Z0,U,6) '="":";.03 ////"_$P(Z 0,U,6),1:" ")
  24535   "RTN","RCD PESR3",51, 0)
  24536    . . S DIC ("DR")=DIC ("DR")_";. 07////"_$J (+$P(Z0,U, 4)/100,"", 2)
  24537   "RTN","RCD PESR3",52, 0)
  24538    . . S DIC ("DR")=DIC ("DR")_";. 06////"_$S ($P(Z0,U,8 )'="":1,1: 0)
  24539   "RTN","RCD PESR3",53, 0)
  24540    . . S DIC ("DR")=DIC ("DR")_";. 12///"_$$F DT^RCDPESR 9($P(Z0,U, 3))
  24541   "RTN","RCD PESR3",54, 0)
  24542    . . S DIC ("DR")=DIC ("DR")_";. 13////"_DT _$S($P(Z0, U,7)'="":" ;.05////"_ $P(Z0,U,7) ,1:"")
  24543   "RTN","RCD PESR3",55, 0)
  24544    . . S DIC ("DR")=DIC ("DR")_$S( $P(Z0,U,9) '="":";.15 ////"_$P(Z 0,U,9),1:" ")
  24545   "RTN","RCD PESR3",56, 0)
  24546    . . S XX= $S($P(Z0,U ,10)="D":" D",$P(Z0,U ,10)="-":" D",1:"")
  24547   "RTN","RCD PESR3",57, 0)
  24548    . . S DIC ("DR")=DIC ("DR")_";3 ////"_XX       ; PRCA *4.5*321 a dded filin g of this  field
  24549   "RTN","RCD PESR3",58, 0)
  24550    . . ;
  24551   "RTN","RCD PESR3",59, 0)
  24552    . . I $P( Z0,U,8)'=" " D                       ; Tax  id error
  24553   "RTN","RCD PESR3",60, 0)
  24554    . . . S X X=$P(Z0,U, 5)_"  Paye r ID: "_$P (RCTXN,U,6 )
  24555   "RTN","RCD PESR3",61, 0)
  24556    . . . D T AXERR^RCDP ESR1("EFT" ,XX,$P(RCT XN,U,7),$P (RCTXN,U,8 )) ; Send  bad tax id  bulletin
  24557   "RTN","RCD PESR3",62, 0)
  24558    . . ;
  24559   "RTN","RCD PESR3",63, 0)
  24560    . . S DIC (0)="L",DI C="^RCY(34 4.31,",DLA YGO=344.31
  24561   "RTN","RCD PESR3",64, 0)
  24562    . . D FIL E^DICN
  24563   "RTN","RCD PESR3",65, 0)
  24564    . . K DIC ,DLAYGO,DO ,DD
  24565   "RTN","RCD PESR3",66, 0)
  24566    . . I Y'> 0 D  ; Err or filing  data
  24567   "RTN","RCD PESR3",67, 0)
  24568    . . . S D IK="^RCY(3 44.3,",DA= RCEFT D ^D IK
  24569   "RTN","RCD PESR3",68, 0)
  24570    . . . S Z =0 F  S Z= $O(^RCY(34 4.31,"B",R CEFT,Z)) Q :'Z  S DIK ="^RCY(344 .31,",DA=Z  D ^DIK
  24571   "RTN","RCD PESR3",69, 0)
  24572    . . . S R CEFLG=1,RC ERR=3
  24573   "RTN","RCD PESR3",70, 0)
  24574    . . . D E RRUPD^RCDP ESR1(RCGBL ,.RCD,RCTY P1,RCERR)
  24575   "RTN","RCD PESR3",71, 0)
  24576    ;
  24577   "RTN","RCD PESR3",72, 0)
  24578    I '$G(RCE FLG) D
  24579   "RTN","RCD PESR3",73, 0)
  24580    . S DIE=" ^RCY(344.3 ,",DA=RCEF T,DR=".09/ ///"_$$CHK SUM(RCEFT)  D ^DIE
  24581   "RTN","RCD PESR3",74, 0)
  24582    ;
  24583   "RTN","RCD PESR3",75, 0)
  24584   EFTQ ;
  24585   "RTN","RCD PESR3",76, 0)
  24586    D CLEAN^D ILF
  24587   "RTN","RCD PESR3",77, 0)
  24588    Q
  24589   "RTN","RCD PESR3",78, 0)
  24590    ;
  24591   "RTN","RCD PESR3",79, 0)
  24592   ADDEFT(RCT XN,RCXMZ,R CGBL,RCERR ) ; File E FT TOTAL r ecord in f ile 344.3
  24593   "RTN","RCD PESR3",80, 0)
  24594    ; RCTXN =  the data  on the hea der record  of the me ssage text
  24595   "RTN","RCD PESR3",81, 0)
  24596    ; RCXMZ =  the mail  message nu mber
  24597   "RTN","RCD PESR3",82, 0)
  24598    ; RCGBL =  the name  of the arr ay or glob al where t he message  is stored
  24599   "RTN","RCD PESR3",83, 0)
  24600    ; Functio n returns  the ien of  the total  record fo und/added
  24601   "RTN","RCD PESR3",84, 0)
  24602    ;    and  also retur ns RCERR i f passed b y referenc e
  24603   "RTN","RCD PESR3",85, 0)
  24604    ;
  24605   "RTN","RCD PESR3",86, 0)
  24606    N RCTDA,R CRCPT,RCDU P,RCHAC,Z, Z0
  24607   "RTN","RCD PESR3",87, 0)
  24608    S (RCERR, RCTDA)=""
  24609   "RTN","RCD PESR3",88, 0)
  24610    ;
  24611   "RTN","RCD PESR3",89, 0)
  24612    ;----- ch anged for  PRCA*4.5*2 83
  24613   "RTN","RCD PESR3",90, 0)
  24614    ;I $E($P( RCTXN,U,6) ,1,3)'="46 9",$E($P(R CTXN,U,6), 1,3)'="569 ",$E($P(RC TXN,U,6),1 ,3)'="HAC"  D  G ADDQ  ; Invalid  EFT depos it number
  24615   "RTN","RCD PESR3",91, 0)
  24616    ;. N RCDX M,RCCT
  24617   "RTN","RCD PESR3",92, 0)
  24618    ;. S RCCT =0
  24619   "RTN","RCD PESR3",93, 0)
  24620    ;. S RCCT =RCCT+1,RC DXM(RCCT)= "This EFT  has an inv alid depos it number  for EDI Lo ckbox and  has been r ejected.", RCCT=RCCT+ 1,RCDXM(RC CT)=" "
  24621   "RTN","RCD PESR3",94, 0)
  24622    ;. S RCCT =RCCT+1,RC DXM(RCCT)= " ",RCCT=R CCT+1,RCDX M(RCCT)="H ere are th e contents  of this m essage:"
  24623   "RTN","RCD PESR3",95, 0)
  24624    ;. D DISP ("EDI LBOX  INVALID E FT DEPOSIT  #",RCCT,. RCDXM,RCXM Z)
  24625   "RTN","RCD PESR3",96, 0)
  24626    ;-----
  24627   "RTN","RCD PESR3",97, 0)
  24628    ;
  24629   "RTN","RCD PESR3",98, 0)
  24630    ; Make su re it's no t already  there or i f so, it h as no ptr  to a depos it
  24631   "RTN","RCD PESR3",99, 0)
  24632    ; or if a  deposit e xists, tha t the depo sit does n ot yet hav e a receip t
  24633   "RTN","RCD PESR3",100 ,0)
  24634    S RCDUP=0 ,RCHAC=$E( $P(RCTXN,U ,6),1,3)=" HAC" ; Thi s is a HAC  deposit
  24635   "RTN","RCD PESR3",101 ,0)
  24636    I $P(RCTX N,U,6)'=""  D
  24637   "RTN","RCD PESR3",102 ,0)
  24638    . ;Format  Deposit D ate as FM  date
  24639   "RTN","RCD PESR3",103 ,0)
  24640    . N RCDDA T
  24641   "RTN","RCD PESR3",104 ,0)
  24642    . S X=$$F DT^RCDPESR 9($P(RCTXN ,U,7))
  24643   "RTN","RCD PESR3",105 ,0)
  24644    . S RCDDA T=0,%DT="X " D ^%DT S :Y>0 RCDDA T=Y
  24645   "RTN","RCD PESR3",106 ,0)
  24646    . S Z=0 ;  Lookup de posit by d eposit #
  24647   "RTN","RCD PESR3",107 ,0)
  24648    . F  S Z= $O(^RCY(34 4.3,"ADEP" ,RCDDAT,$P (RCTXN,U,6 ),Z)) Q:'Z   S Z0=$G( ^RCY(344.3 ,Z,0)) S:' $P(Z0,U,3)  RCTDA=Z Q :RCTDA  D   Q
  24649   "RTN","RCD PESR3",108 ,0)
  24650    .. ; Depo sit found  - find rec eipt
  24651   "RTN","RCD PESR3",109 ,0)
  24652    .. I $O(^ RCY(344,"A D",$P(Z0,U ,3),0)) S  RCDUP=Z Q
  24653   "RTN","RCD PESR3",110 ,0)
  24654    .. S RCTD A=Z
  24655   "RTN","RCD PESR3",111 ,0)
  24656    ;
  24657   "RTN","RCD PESR3",112 ,0)
  24658    ;-----
  24659   "RTN","RCD PESR3",113 ,0)
  24660    ; PRCA*4. 5*298 - Ma ilMan mess age disabl ed, logic  retained -  14 Feb 20 14
  24661   "RTN","RCD PESR3",114 ,0)
  24662    ;I RCDUP  D  ; Send  bulletin t hat duplic ate EFT re ceived
  24663   "RTN","RCD PESR3",115 ,0)
  24664    ;. N RCDX M,RCCT
  24665   "RTN","RCD PESR3",116 ,0)
  24666    ;. S RCCT =0
  24667   "RTN","RCD PESR3",117 ,0)
  24668    ;. S RCCT =RCCT+1,RC DXM(RCCT)= "This EFT  appears to  be a dupl icate tran saction an d has been  rejected. ",RCCT=RCC T+1,RCDXM( RCCT)=" "
  24669   "RTN","RCD PESR3",118 ,0)
  24670    ;. S RCCT =RCCT+1,RC DXM(RCCT)= " ",RCCT=R CCT+1,RCDX M(RCCT)="H ere are th e contents  of this m essage:"
  24671   "RTN","RCD PESR3",119 ,0)
  24672    ;. D DISP ("EDI LBOX  DUP EFT D EPOSIT REC EIVED",RCC T,.RCDXM,R CXMZ)
  24673   "RTN","RCD PESR3",120 ,0)
  24674    ;-----
  24675   "RTN","RCD PESR3",121 ,0)
  24676    ;
  24677   "RTN","RCD PESR3",122 ,0)
  24678    I 'RCDUP  D  ; Add o r update t he record
  24679   "RTN","RCD PESR3",123 ,0)
  24680    . N RCX,R CDTTM,DIE, DIC,DLAYGO ,DD,DA,DO, DR,X,Y,%DT ,DINUM
  24681   "RTN","RCD PESR3",124 ,0)
  24682    . ;
  24683   "RTN","RCD PESR3",125 ,0)
  24684    . S X=$$F DT^RCDPESR 9($P(RCTXN ,U,3))_"@" _$P(RCTXN, U,4)
  24685   "RTN","RCD PESR3",126 ,0)
  24686    . S %DT=" XTS" D ^%D T S:Y>0 RC DTTM=Y
  24687   "RTN","RCD PESR3",127 ,0)
  24688    . ;
  24689   "RTN","RCD PESR3",128 ,0)
  24690    . S DIC(" DR")=""
  24691   "RTN","RCD PESR3",129 ,0)
  24692    . S DIC(" DR")=$S(RC DTTM'="":" .02////"_R CDTTM,1:"" )
  24693   "RTN","RCD PESR3",130 ,0)
  24694    . S DIC(" DR")=DIC(" DR")_$S(DI C("DR")'=" ":";",1:"" )_".06//// "_$P(RCTXN ,U,6)_";.0 7///"_$$FD T^RCDPESR9 ($P(RCTXN, U,7))
  24695   "RTN","RCD PESR3",131 ,0)
  24696    . S DIC(" DR")=DIC(" DR")_";.08 ////"_$$ZE RO^RCDPESR 9($P(RCTXN ,U,8),1)_" ;.13////"_ $$NOW^XLFD T()_";.05/ ///"_RCXMZ _";.14//// 0;.12////0 "
  24697   "RTN","RCD PESR3",132 ,0)
  24698    . ;
  24699   "RTN","RCD PESR3",133 ,0)
  24700    . I RCTDA  D  ; Over write the  data alrea dy there
  24701   "RTN","RCD PESR3",134 ,0)
  24702    .. L +^RC Y(344.3,RC TDA):1 I ' $T S RCTDA =-1 Q
  24703   "RTN","RCD PESR3",135 ,0)
  24704    .. S DIE= "^RCY(344. 3,",DA=RCT DA,DR=DIC( "DR") K DI C D ^DIE
  24705   "RTN","RCD PESR3",136 ,0)
  24706    .. L -^RC Y(344.3,RC TDA)
  24707   "RTN","RCD PESR3",137 ,0)
  24708    . ;
  24709   "RTN","RCD PESR3",138 ,0)
  24710    . I 'RCTD A D
  24711   "RTN","RCD PESR3",139 ,0)
  24712    .. S RCX= +$O(^RCY(3 44.3," "), -1)
  24713   "RTN","RCD PESR3",140 ,0)
  24714    .. F RCX= RCX+1:1 I  '$D(^RCY(3 44.3,RCX,0 )) L +^RCY (344.3,RCX ,0):1 I $T  S X=RCX Q
  24715   "RTN","RCD PESR3",141 ,0)
  24716    .. S DIC( 0)="L",DIC ="^RCY(344 .3,",DLAYG O=344.3,DI NUM=RCX
  24717   "RTN","RCD PESR3",142 ,0)
  24718    .. D FILE ^DICN K DO ,DD,DLAYGO ,DIC,DINUM
  24719   "RTN","RCD PESR3",143 ,0)
  24720    .. L -^RC Y(344.3,RC X,0)
  24721   "RTN","RCD PESR3",144 ,0)
  24722    .. S RCTD A=$S(Y<0:" ",1:+Y)
  24723   "RTN","RCD PESR3",145 ,0)
  24724    . ;
  24725   "RTN","RCD PESR3",146 ,0)
  24726    . I 'RCTD A S RCERR= 3 ; Error  in add of  EFT record  to file 3 44.3 
  24727   "RTN","RCD PESR3",147 ,0)
  24728    ;
  24729   "RTN","RCD PESR3",148 ,0)
  24730   ADDQ Q $S( RCTDA>0:RC TDA,1:"")
  24731   "RTN","RCD PESR3",149 ,0)
  24732    ;
  24733   "RTN","RCD PESR3",150 ,0)
  24734   CHKSUM(RCT DA) ; Calc  the check sum for EF T record s tored in R CTDA in 34 4.3
  24735   "RTN","RCD PESR3",151 ,0)
  24736    ;
  24737   "RTN","RCD PESR3",152 ,0)
  24738    N RCDPCSU M,RCDPDATA ,X,Y,Z,Z0
  24739   "RTN","RCD PESR3",153 ,0)
  24740    ;
  24741   "RTN","RCD PESR3",154 ,0)
  24742    S (RCDPCS UM,X)=0,Z0 =$G(^RCY(3 44.3,RCTDA ,0))
  24743   "RTN","RCD PESR3",155 ,0)
  24744    ; Use pcs  1-8, leav ing out pi ece 3
  24745   "RTN","RCD PESR3",156 ,0)
  24746    S RCDPDAT A=$P(Z0,U, 1,8),$P(RC DPDATA,U,3 )=""
  24747   "RTN","RCD PESR3",157 ,0)
  24748    S X=RCDPC SUM_RCDPDA TA X $S($G (^%ZOSF("L PC"))'="": ^("LPC"),1 :"S Y="""" ") S RCDPC SUM=Y
  24749   "RTN","RCD PESR3",158 ,0)
  24750    ; Use det ail iens a nd pieces  3,4,7 to c omplete th e checksum
  24751   "RTN","RCD PESR3",159 ,0)
  24752    S Z=0 F   S Z=$O(^RC Y(344.31," B",RCTDA,Z )) Q:'Z  S  Z0=$G(^RC Y(344.31,Z ,0)),RCDPD ATA=Z_U_$P (Z0,U,3,4) _U_$P(Z0,U ,7),X=RCDP CSUM_RCDPD ATA X $S($ G(^%ZOSF(" LPC"))'="" :^("LPC"), 1:"S Y=""" "") S RCDP CSUM=Y
  24753   "RTN","RCD PESR3",160 ,0)
  24754    Q RCDPCSU M
  24755   "RTN","RCD PESR3",161 ,0)
  24756    ;
  24757   "RTN","RCD PESR3",162 ,0)
  24758   DISP(RCTIT ,RCCT,RCDX M,RCXMZ) ;  Sends bul letin with  formatted  data from  message
  24759   "RTN","RCD PESR3",163 ,0)
  24760    ; RCTIT =  title of  bulletin
  24761   "RTN","RCD PESR3",164 ,0)
  24762    ; RCCT =  # of lines  previousl y populate d
  24763   "RTN","RCD PESR3",165 ,0)
  24764    ; RCXDM =  array con taining th e text of  the bullet in
  24765   "RTN","RCD PESR3",166 ,0)
  24766    N RC,Z
  24767   "RTN","RCD PESR3",167 ,0)
  24768    K ^TMP("R C1",$J),^T MP("RC",$J ),^TMP("RC TEMP",$J)
  24769   "RTN","RCD PESR3",168 ,0)
  24770    S RC=1,^T MP("RCTEMP ",$J,RC)=$ G(^TMP("RC MSGH",$J,0 ))
  24771   "RTN","RCD PESR3",169 ,0)
  24772    S Z=0 F   S Z=$O(^TM P("RCMSG", $J,2,"D",Z )) Q:'Z  S  RC=RC+1,^ TMP("RCTEM P",$J,RC)= $G(^TMP("R CMSG",$J,2 ,"D",Z))
  24773   "RTN","RCD PESR3",170 ,0)
  24774    D DISP^RC DPESR8("^T MP(""RCTEM P"",$J)"," ^TMP(""RC1 "",$J)",1, "^TMP(""RC "",$J)",75 )
  24775   "RTN","RCD PESR3",171 ,0)
  24776    S Z=0 F   S Z=$O(^TM P("RC",$J, Z)) Q:'Z   S RCCT=RCC T+1,RCDXM( RCCT)=$G(^ TMP("RC",$ J,Z))
  24777   "RTN","RCD PESR3",172 ,0)
  24778    D BULLEFT ^RCDPESR0( "",RCXMZ,R CTIT,.RCDX M)
  24779   "RTN","RCD PESR3",173 ,0)
  24780    K ^TMP("R C1",$J),^T MP("RC",$J ),^TMP("RC TEMP",$J)
  24781   "RTN","RCD PESR3",174 ,0)
  24782    Q
  24783   "RTN","RCD PESR3",175 ,0)
  24784    ;
  24785   "RTN","RCD PESR3",176 ,0)
  24786   DUP(RCM,RC IFN,RCAMT, RCAMT1) ;  EOB in mai l message  already st ored in 36 1.1?
  24787   "RTN","RCD PESR3",177 ,0)
  24788    ; RCM = m sg # EOB w as receive d in
  24789   "RTN","RCD PESR3",178 ,0)
  24790    ; RCIFN =  bill ien
  24791   "RTN","RCD PESR3",179 ,0)
  24792    ; RCAMT =  amt pd
  24793   "RTN","RCD PESR3",180 ,0)
  24794    ; RCAMT1  = amt repo rted bille d
  24795   "RTN","RCD PESR3",181 ,0)
  24796    ; Returns  0 if none  found, en try #^mess age checks um on file  if found
  24797   "RTN","RCD PESR3",182 ,0)
  24798    N Z,DUP,D UP1
  24799   "RTN","RCD PESR3",183 ,0)
  24800    S (DUP,DU P1,Z)=0
  24801   "RTN","RCD PESR3",184 ,0)
  24802    F  S Z=$O (^IBM(361. 1,"AC",RCM ,Z)) Q:'Z   I +$G(^IB M(361.1,Z, 0))=RCIFN  D  Q:DUP
  24803   "RTN","RCD PESR3",185 ,0)
  24804    . I '$P($ G(^IBM(361 .1,Z,100)) ,U,5) S DU P1=Z Q  ;  Partially  filed befo re
  24805   "RTN","RCD PESR3",186 ,0)
  24806    . I +$G(^ IBM(361.1, Z,1))=+RCA MT,+$P($G( ^IBM(361.1 ,1,Z,2)),U ,4)=+RCAMT 1 S DUP=Z_ U_+$P($G(^ IBM(361.1, Z,100)),U, 5) Q
  24807   "RTN","RCD PESR3",187 ,0)
  24808    I 'DUP,DU P1 S DUP=D UP1_"^0"
  24809   "RTN","RCD PESR3",188 ,0)
  24810    Q DUP
  24811   "RTN","RCD PESR3",189 ,0)
  24812    ;
  24813   "RTN","RCD PESR3",190 ,0)
  24814   DUPERA(DUP ,RCNOUPD)  ; Msg for  duplicate  ERA
  24815   "RTN","RCD PESR3",191 ,0)
  24816    ; RCNOUPD  = # of me ssage with  duplicate  data
  24817   "RTN","RCD PESR3",192 ,0)
  24818    ; DUP = f lag = -1 i f duplicat e message  received i n same mai l msg #
  24819   "RTN","RCD PESR3",193 ,0)
  24820    K ^TMP("R CERR1",$J)
  24821   "RTN","RCD PESR3",194 ,0)
  24822    S ^TMP("R CERR1",$J, 1)=$S(DUP> 0:"This an  exact dup licate of  an ERA rec eived prev iously in  mail msg " _RCNOUPD,1 :"This ERA  message w as already  fully pro cessed - m essage was  ignored")
  24823   "RTN","RCD PESR3",195 ,0)
  24824    Q
  24825   "RTN","RCD PESR3",196 ,0)
  24826    ;
  24827   "RTN","RCD PESR3",197 ,0)
  24828   BULLS(RCFI LE,RCTDA,D UP,RCXMSG)  ; Error b ulletins f or ERA
  24829   "RTN","RCD PESR3",198 ,0)
  24830    ; PRCA*4. 5*298 - DU PLICATE TR ANSMISSION  MSG AND E EOB - EXCE PTIONS mes sage disab led - 14 F eb 2014
  24831   "RTN","RCD PESR3",199 ,0)
  24832    ;I RCFILE =5 D BULL1 ^RCDPESR5( RCTDA,"^TM P(""RCERR1 "",$J)",$S ($G(DUP)>0 :$G(DUP),1 :""))
  24833   "RTN","RCD PESR3",200 ,0)
  24834    I RCFILE= 4 D BULL2^ RCDPESR5(R CTDA,"^TMP (""RCERR1" ",$J)",RCX MSG)
  24835   "RTN","RCD PESR3",201 ,0)
  24836    Q
  24837   "RTN","RCD PESR3",202 ,0)
  24838    ;
  24839   "RTN","RCD PESR3",203 ,0)
  24840   ADJERR(RCE RR) ; Set  up adj err or text in  RCERR(n)  - pass by  ref
  24841   "RTN","RCD PESR3",204 ,0)
  24842    ; Functio n returns  # of lines  for error  text
  24843   "RTN","RCD PESR3",205 ,0)
  24844    S RCERR(1 )="At leas t 1 adjust ment trans action has  been foun d on this  ERA.  Befo re the",RC ERR(2)="    receipt f or this ER A can be p rocessed,  the approp riate adju stments",R CERR(3)="    must be  made using  the EEOB  Worklist", RCERR(4)="  "
  24845   "RTN","RCD PESR3",206 ,0)
  24846    Q 4
  24847   "RTN","RCD PESR3",207 ,0)
  24848    ;
  24849   "RTN","RCD PESR4")
  24850   0^47^B8570 9407
  24851   "RTN","RCD PESR4",1,0 )
  24852   RCDPESR4 ; ALB/TMK/PJ H - Server  interface  835ERA pr ocessing ; Jun 06, 20 14@19:11:1 9
  24853   "RTN","RCD PESR4",2,0 )
  24854    ;;4.5;Acc ounts Rece ivable;**1 73,216,208 ,230,269,2 71,298,321 **;Mar 20,  1995;Buil d 46
  24855   "RTN","RCD PESR4",3,0 )
  24856    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  24857   "RTN","RCD PESR4",4,0 )
  24858    ;
  24859   "RTN","RCD PESR4",5,0 )
  24860    ;Referenc e to $$VAL ECME^BPSUT IL2 suppor ted by IA#  6139
  24861   "RTN","RCD PESR4",6,0 )
  24862    ;
  24863   "RTN","RCD PESR4",7,0 )
  24864   ERAEOBIN(R CTXN,RCD,R CGBL,RCEFL G) ; Store /process 8 35ERA or 8 35XFR
  24865   "RTN","RCD PESR4",8,0 )
  24866    ;  transa ction comi ng into th e site
  24867   "RTN","RCD PESR4",9,0 )
  24868    ; RCTXN =  data on t he hdr rec ord of the  msg text
  24869   "RTN","RCD PESR4",10, 0)
  24870    ; RCD = a rray with  formatted  hdr data
  24871   "RTN","RCD PESR4",11, 0)
  24872    ; RCGBL =  name of t he array o r global w here the m sg is stor ed
  24873   "RTN","RCD PESR4",12, 0)
  24874    ; RCEFLG  = error fl ag returne d if passe d by REF
  24875   "RTN","RCD PESR4",13, 0)
  24876    ;
  24877   "RTN","RCD PESR4",14, 0)
  24878    N RCLAST, RCBILL,RCT DA,RCMSG,R CERR
  24879   "RTN","RCD PESR4",15, 0)
  24880    S (RCTDA, RCEFLG)=0
  24881   "RTN","RCD PESR4",16, 0)
  24882    ;
  24883   "RTN","RCD PESR4",17, 0)
  24884    ;
  24885   "RTN","RCD PESR4",18, 0)
  24886    F  L +^RC Y(344.5,"A MSEQ",+$P( RCTXN,U,13 )):30 Q:$T
  24887   "RTN","RCD PESR4",19, 0)
  24888    S RCMSG=$ $EXTERA(RC TXN,.RCLAS T,.RCBILL)  ; Extract  from mail  msg
  24889   "RTN","RCD PESR4",20, 0)
  24890    ;
  24891   "RTN","RCD PESR4",21, 0)
  24892    ; If full  msg recei ved (99^$  record exi sts), file  it
  24893   "RTN","RCD PESR4",22, 0)
  24894    I 'RCLAST ,'$G(RCERR ) D  ;No $  as last c haracter o f msg
  24895   "RTN","RCD PESR4",23, 0)
  24896    . S RCERR =2
  24897   "RTN","RCD PESR4",24, 0)
  24898    ;
  24899   "RTN","RCD PESR4",25, 0)
  24900    I RCLAST  S RCTDA=+$ $ADD(RCGBL ,RCD("MSG# "),RCMSG,. RCBILL,.RC ERR,.RCD)
  24901   "RTN","RCD PESR4",26, 0)
  24902    ;
  24903   "RTN","RCD PESR4",27, 0)
  24904    I $G(RCER R)>0 D
  24905   "RTN","RCD PESR4",28, 0)
  24906    . D ERRUP D^RCDPESR1 (RCGBL,.RC D,$P(RCTXN ,U),.RCERR )
  24907   "RTN","RCD PESR4",29, 0)
  24908    . I RCTDA  D  ; Stor e exceptio n msgs in  file 344.5
  24909   "RTN","RCD PESR4",30, 0)
  24910    .. N A,C, Z
  24911   "RTN","RCD PESR4",31, 0)
  24912    .. S C=1, A(1)="Date : "_$$FMTE ^XLFDT($$N OW^XLFDT() ,2)
  24913   "RTN","RCD PESR4",32, 0)
  24914    .. I $G(^ TMP("RCERR ",$J,"TEXT "))'="" S  C=C+1,A(C) =^TMP("RCE RR",$J,"TE XT"),C=C+1 ,A(C)=" "
  24915   "RTN","RCD PESR4",33, 0)
  24916    .. S Z=0  F  S Z=$O( ^TMP("RCER R",$J,"MSG ",Z)) Q:'Z   S C=C+1, A(C)=^(Z)
  24917   "RTN","RCD PESR4",34, 0)
  24918    .. I $O(A (0)) D WP^ DIE(344.5, RCTDA_",", 5,"A","A")
  24919   "RTN","RCD PESR4",35, 0)
  24920    . S RCEFL G=1
  24921   "RTN","RCD PESR4",36, 0)
  24922    ;
  24923   "RTN","RCD PESR4",37, 0)
  24924    L -^RCY(3 44.5,"AMSE Q",+$P(RCT XN,U,13))
  24925   "RTN","RCD PESR4",38, 0)
  24926    I $P(RCTX N,U)'["XFR ",$P(RCTXN ,U,12)'=""  D TAXERR^ RCDPESR1(" ERA",$P(RC TXN,U,6)_"   Payer ID : "_$P(RCT XN,U,7),$P (RCTXN,U,1 1),$P(RCTX N,U,12)) ;  Send bad  tax id bul letin
  24927   "RTN","RCD PESR4",39, 0)
  24928    ;
  24929   "RTN","RCD PESR4",40, 0)
  24930    Q
  24931   "RTN","RCD PESR4",41, 0)
  24932    ;
  24933   "RTN","RCD PESR4",42, 0)
  24934   EXTERA(RCT XN,RCLAST, RCBILL) ;E xtract 835 ERA or 835 XFR transa ction
  24935   "RTN","RCD PESR4",43, 0)
  24936    ;INPUT:
  24937   "RTN","RCD PESR4",44, 0)
  24938    ; RCTXN =  data on 8 35ERA/835X FR hdr rec ord
  24939   "RTN","RCD PESR4",45, 0)
  24940    ; RCLAST  = passed b y REF and  returned=1  if entire  record ex ists
  24941   "RTN","RCD PESR4",46, 0)
  24942    ;
  24943   "RTN","RCD PESR4",47, 0)
  24944    ;OUTPUT:
  24945   "RTN","RCD PESR4",48, 0)
  24946    ; ^TMP("R CMSG",$J,1 ,"D",line  #)=formatt ed hdr dat a
  24947   "RTN","RCD PESR4",49, 0)
  24948    ; ^TMP("R CMSG",$J,2 ,"D",line  #)=raw msg  data
  24949   "RTN","RCD PESR4",50, 0)
  24950    ;  if pas sed by ref , RCLAST =  1 if '99'  record fo und
  24951   "RTN","RCD PESR4",51, 0)
  24952    ;  if pas sed by ref , RCBILL(A R bill num ber) is re turned
  24953   "RTN","RCD PESR4",52, 0)
  24954    ;    with  a 'list'  of bills i ncluded in  the ERA.   If an
  24955   "RTN","RCD PESR4",53, 0)
  24956    ;    entr y = 1, 3rd  party bil l was foun d in file  430.
  24957   "RTN","RCD PESR4",54, 0)
  24958    ;    If t he entry =  2, the 3r d party bi ll found w as not act ive
  24959   "RTN","RCD PESR4",55, 0)
  24960    ; Functio n returns  existing i en in file  344.5 for  multi par t ERAs
  24961   "RTN","RCD PESR4",56, 0)
  24962    ;
  24963   "RTN","RCD PESR4",57, 0)
  24964    ;N CT,CT1 ,LINE,HCT, RCH,RCMSG, RCREFORM,R CINS,RCSTA T,B,RCSD,C 5
  24965   "RTN","RCD PESR4",58, 0)
  24966    N B,C5,CT ,CT1,HCT,L INE,RCH,RC INS,RCMSG, RCREFORM,R CSD,RCSTAR T,RCSTAT   ;PRCA*4.5* 321 reorde red and RC START adde d
  24967   "RTN","RCD PESR4",59, 0)
  24968    S (HCT,RC H)=0
  24969   "RTN","RCD PESR4",60, 0)
  24970    ;
  24971   "RTN","RCD PESR4",61, 0)
  24972    ;
  24973   "RTN","RCD PESR4",62, 0)
  24974    ; Check i f sequence  control #  already e xists or i f a new re cord neede d
  24975   "RTN","RCD PESR4",63, 0)
  24976    S RCMSG=+ $O(^RCY(34 4.5,"AMSEQ ",+$P(RCTX N,U,13),0) )
  24977   "RTN","RCD PESR4",64, 0)
  24978    S CT=0
  24979   "RTN","RCD PESR4",65, 0)
  24980    I 'RCMSG  D  ; Build  display d ata for th e first se quence onl y
  24981   "RTN","RCD PESR4",66, 0)
  24982    . S HCT=H CT+1 S LIN E(HCT)="Pa yer Name:  "_$P(RCTXN ,U,6)
  24983   "RTN","RCD PESR4",67, 0)
  24984    . S HCT=H CT+1 S LIN E(HCT)="Pa yer ID: "_ $P(RCTXN,U ,7)
  24985   "RTN","RCD PESR4",68, 0)
  24986    . S HCT=H CT+1,LINE( HCT)="Trac e #: "_$P( RCTXN,U,8)
  24987   "RTN","RCD PESR4",69, 0)
  24988    . S HCT=H CT+1,LINE( HCT)="Date  Paid: "_$ $FDT^RCDPE SR9($P(RCT XN,U,9))_"     Total  Amt Paid:  "_$J($P(RC TXN,U,10)/ 100,0,2)
  24989   "RTN","RCD PESR4",70, 0)
  24990    . I $P(RC TXN,U)["XF R",$P(RCTX N,U,19)'=" " S HCT=HC T+1,LINE(H CT)="Conta ct Info: " _$P(RCTXN, U,19)
  24991   "RTN","RCD PESR4",71, 0)
  24992    . M ^TMP( "RCMSG",$J ,1,"D")=LI NE
  24993   "RTN","RCD PESR4",72, 0)
  24994    . S CT=CT +1,^TMP("R CMSG",$J,2 ,"D",CT)=R CTXN
  24995   "RTN","RCD PESR4",73, 0)
  24996    ;
  24997   "RTN","RCD PESR4",74, 0)
  24998    S CT1=CT
  24999   "RTN","RCD PESR4",75, 0)
  25000    S ^TMP("R CMSG",$J,0 )=RCTXN
  25001   "RTN","RCD PESR4",76, 0)
  25002    ;
  25003   "RTN","RCD PESR4",77, 0)
  25004    S RCSD=$N A(^TMP($J, "RCSRVDT") ) K @RCSD  ;service d ates
  25005   "RTN","RCD PESR4",78, 0)
  25006    S C5=0
  25007   "RTN","RCD PESR4",79, 0)
  25008    S RCLAST= 0,RCSTART= 0 ; PRCA*4 .5*321
  25009   "RTN","RCD PESR4",80, 0)
  25010    F  X XMRE C Q:XMER<0   D  Q:RCL AST
  25011   "RTN","RCD PESR4",81, 0)
  25012    . Q:XMRG= ""
  25013   "RTN","RCD PESR4",82, 0)
  25014    . I +XMRG =99,$P(XMR G,U,2)="$"  S RCLAST= 1 Q
  25015   "RTN","RCD PESR4",83, 0)
  25016    . S CT=CT +1
  25017   "RTN","RCD PESR4",84, 0)
  25018    . I +XMRG =5,$P(XMRG ,U,2)'=""  S C5=CT
  25019   "RTN","RCD PESR4",85, 0)
  25020    . ;Statem ent Start  Date - 05  Record is  mandatory
  25021   "RTN","RCD PESR4",86, 0)
  25022    . I +XMRG =5 S RCSTA RT=+$P(XMR G,U,9) ;PR CA*4.5*321
  25023   "RTN","RCD PESR4",87, 0)
  25024    . ; save  the servic e date for  possible  ECME# look  up
  25025   "RTN","RCD PESR4",88, 0)
  25026    . ;PRCA*4 .5*321 BEG IN
  25027   "RTN","RCD PESR4",89, 0)
  25028    . I +XMRG =40,$$VALE CME^BPSUTI L2($P(XMRG ,U,2)),C5, '$D(@RCSD@ (C5)) D
  25029   "RTN","RCD PESR4",90, 0)
  25030    . . I $P( XMRG,U,19)  S @RCSD@( C5)=+$P(XM RG,U,19) Q
  25031   "RTN","RCD PESR4",91, 0)
  25032    . . ; If  service da te not pre sent use s tatement s tart date  instead
  25033   "RTN","RCD PESR4",92, 0)
  25034    . . S:RCS TART @RCSD @(C5)=RCST ART
  25035   "RTN","RCD PESR4",93, 0)
  25036    . ; PRCA* 4.5*321 EN D
  25037   "RTN","RCD PESR4",94, 0)
  25038    . S ^TMP( "RCMSG",$J ,2,"D",CT) =XMRG
  25039   "RTN","RCD PESR4",95, 0)
  25040    ;
  25041   "RTN","RCD PESR4",96, 0)
  25042    ; reforma t bill# if  needed
  25043   "RTN","RCD PESR4",97, 0)
  25044    S RCREFOR M=""
  25045   "RTN","RCD PESR4",98, 0)
  25046    S CT=CT1
  25047   "RTN","RCD PESR4",99, 0)
  25048    F  S CT=$ O(^TMP("RC MSG",$J,2, "D",CT)) Q :'CT  S XM RG=$G(^(CT )) D
  25049   "RTN","RCD PESR4",100 ,0)
  25050    . Q:XMRG= ""
  25051   "RTN","RCD PESR4",101 ,0)
  25052    . I +XMRG =5,$P(XMRG ,U,2)'=""  D
  25053   "RTN","RCD PESR4",102 ,0)
  25054    .. S RCRE FORM="",RC STAT=1
  25055   "RTN","RCD PESR4",103 ,0)
  25056    .. ; Chec k if bill  is in AR &  is a 3rd  party bill
  25057   "RTN","RCD PESR4",104 ,0)
  25058    .. S RCBI LL=$$BILL^ RCDPESR1($ P(XMRG,U,2 ),$G(@RCSD @(CT)),.RC INS)    ;  look up cl aim ien by  claim# or  ECME#
  25059   "RTN","RCD PESR4",105 ,0)
  25060    .. I '$G( RCINS)!(RC BILL<0) S  (RCBILL,RC STAT)=0
  25061   "RTN","RCD PESR4",106 ,0)
  25062    .. I RCBI LL S B=$P( $G(^PRCA(4 30,RCBILL, 0)),U) I B '=$P(XMRG, U,2) S $P( XMRG,U,2)= B,RCREFORM =B
  25063   "RTN","RCD PESR4",107 ,0)
  25064    .. I RCBI LL,$P(^PRC A(430.3,+$ P($G(^PRCA (430,+RCBI LL,0)),U,8 ),0),U,3)' =102 S RCS TAT=2
  25065   "RTN","RCD PESR4",108 ,0)
  25066    .. S RCBI LL($P(XMRG ,U,2))=RCS TAT
  25067   "RTN","RCD PESR4",109 ,0)
  25068    . I RCREF ORM'="",+X MRG>5 S $P (XMRG,U,2) =RCREFORM, ^TMP("RCMS G",$J,2,"D ",CT)=XMRG
  25069   "RTN","RCD PESR4",110 ,0)
  25070    ;
  25071   "RTN","RCD PESR4",111 ,0)
  25072    K @RCSD
  25073   "RTN","RCD PESR4",112 ,0)
  25074    Q RCMSG
  25075   "RTN","RCD PESR4",113 ,0)
  25076    ;
  25077   "RTN","RCD PESR4",114 ,0)
  25078   ADD(RCGBL, RCDMSG,RCM SG,RCBILL, RCERR,RCD)  ; Add msg (s) in @RC GBL to
  25079   "RTN","RCD PESR4",115 ,0)
  25080    ;  file 3 44.5
  25081   "RTN","RCD PESR4",116 ,0)
  25082    ; RCGBL =  name of t he global  used to st ore the ms g data
  25083   "RTN","RCD PESR4",117 ,0)
  25084    ; RCDMSG  = Mailman  msg number  the ERA a rrived in.
  25085   "RTN","RCD PESR4",118 ,0)
  25086    ; RCMSG =  ien of th e existing  entry in  file 344.5  for multi part ERAs
  25087   "RTN","RCD PESR4",119 ,0)
  25088    ; RCBILL( AR bill nu mber) = li st of bill s included , pass by  REF
  25089   "RTN","RCD PESR4",120 ,0)
  25090    ; RCD = a rray with  formatted  hdr data
  25091   "RTN","RCD PESR4",121 ,0)
  25092    ;
  25093   "RTN","RCD PESR4",122 ,0)
  25094    ; Errors  returned i n RCERR an d RCERR(n)
  25095   "RTN","RCD PESR4",123 ,0)
  25096    ; Functio n returns  entry # of  msg added  or "" if  none added
  25097   "RTN","RCD PESR4",124 ,0)
  25098    ;
  25099   "RTN","RCD PESR4",125 ,0)
  25100    ;
  25101   "RTN","RCD PESR4",126 ,0)
  25102    N RCHDR,R CTYP,RCIEN
  25103   "RTN","RCD PESR4",127 ,0)
  25104    S RCHDR=$ G(^TMP("RC MSGH",$J,0 ))
  25105   "RTN","RCD PESR4",128 ,0)
  25106    S RCTYP=$ P(RCHDR,U)
  25107   "RTN","RCD PESR4",129 ,0)
  25108    S RCIEN=$ S($G(RCMSG ):RCMSG,1: $$ADDTXN(R CHDR,RCDMS G)) ;File  msg hdr
  25109   "RTN","RCD PESR4",130 ,0)
  25110    I RCIEN'> 0 S RCERR= 3 ;msg hdr  can't be  filed
  25111   "RTN","RCD PESR4",131 ,0)
  25112    I '$G(RCE RR) D LOAD DET(RCIEN, RCGBL,RCHD R,.RCBILL, .RCD,.RCER R)
  25113   "RTN","RCD PESR4",132 ,0)
  25114    I '$G(RCE RR),'$O(RC ERR(0)),RC TYP["835ER A",'$P($G( ^RCY(344.5 ,RCIEN,0)) ,U,8) D TA SKERA^RCDP ESR2(RCIEN ) ;Task to  upd VistA  for compl ete 835ERA  only
  25115   "RTN","RCD PESR4",133 ,0)
  25116    ;
  25117   "RTN","RCD PESR4",134 ,0)
  25118    Q $S($G(R CIEN)>0&'$ G(RCERR):R CIEN,1:"")
  25119   "RTN","RCD PESR4",135 ,0)
  25120    ;
  25121   "RTN","RCD PESR4",136 ,0)
  25122   ADDTXN(RCD ATA,RCDMSG ) ; Add a  trxn for m sg in RCDA TA to file  344.5
  25123   "RTN","RCD PESR4",137 ,0)
  25124    ; RCDATA  = data on  the msg hd r record
  25125   "RTN","RCD PESR4",138 ,0)
  25126    ; RCDMSG  = Mailman  msg number  the ERA a rrived in
  25127   "RTN","RCD PESR4",139 ,0)
  25128    ;Function  returns i en of the  new entry  in file 34 4.5 or ""  if an erro r
  25129   "RTN","RCD PESR4",140 ,0)
  25130    ;
  25131   "RTN","RCD PESR4",141 ,0)
  25132    N A,RCY,D LAYGO,DIC, DD,DO,DA,X ,Y,Z
  25133   "RTN","RCD PESR4",142 ,0)
  25134    ;
  25135   "RTN","RCD PESR4",143 ,0)
  25136    ;
  25137   "RTN","RCD PESR4",144 ,0)
  25138    S (X,A)=R CDMSG ;Use  msg ID as  basis for  the .01 f ield
  25139   "RTN","RCD PESR4",145 ,0)
  25140    F Z=1:1 Q :'$D(^RCY( 344.5,"B", A))  S A=X _"."_Z
  25141   "RTN","RCD PESR4",146 ,0)
  25142    S X=A
  25143   "RTN","RCD PESR4",147 ,0)
  25144    S DIC(0)= "L",DIC="^ RCY(344.5, ",DLAYGO=3 44.5
  25145   "RTN","RCD PESR4",148 ,0)
  25146    S DIC("DR ")=".02/// /"_$E($P(R CDATA,U),1 ,6)_";.03/ //^S X=""N OW"";.04// //0;.06/// /"_$S($P(R CDATA,U)'[ "XFR":1,1: 0)_$S($P(R CDATA,U,13 )'="":";.0 9////"_+$P (RCDATA,U, 13)_";.08/ ///1",1:"" )_";.1//// 2;.11////" _RCDMSG
  25147   "RTN","RCD PESR4",149 ,0)
  25148    I $P(RCDA TA,U,6)'=" " S DIC("D R")=DIC("D R")_";3.01 ////"_$P(R CDATA,U,6)
  25149   "RTN","RCD PESR4",150 ,0)
  25150    D FILE^DI CN K DO,DD ,DLAYGO,DA ,DIC
  25151   "RTN","RCD PESR4",151 ,0)
  25152    S RCY=+Y
  25153   "RTN","RCD PESR4",152 ,0)
  25154    ;
  25155   "RTN","RCD PESR4",153 ,0)
  25156    ;
  25157   "RTN","RCD PESR4",154 ,0)
  25158    Q $S(RCY> 0:+RCY,1:" ")
  25159   "RTN","RCD PESR4",155 ,0)
  25160    ;
  25161   "RTN","RCD PESR4",156 ,0)
  25162   LOADDET(RC TDA,RCGBL, RCHDR,RCBI LL,RCD,RCE RR) ; Load  the rest  of the tex t
  25163   "RTN","RCD PESR4",157 ,0)
  25164    ; into th e msg
  25165   "RTN","RCD PESR4",158 ,0)
  25166    ; RCTDA =  ien in fi le 344.5
  25167   "RTN","RCD PESR4",159 ,0)
  25168    ; RCGBL =  name of t he array h olding the  detail ms g text to  be loaded
  25169   "RTN","RCD PESR4",160 ,0)
  25170    ; RCHDR =  data on E RA hdr rec ord
  25171   "RTN","RCD PESR4",161 ,0)
  25172    ; RCBILL( AR bill nu mber) = li st of bill s included , pass by  REF
  25173   "RTN","RCD PESR4",162 ,0)
  25174    ; RCD = a rray with  formatted  hdr data
  25175   "RTN","RCD PESR4",163 ,0)
  25176    ;
  25177   "RTN","RCD PESR4",164 ,0)
  25178    ; OUTPUT:  RCERR if  any errors  found, pa ss by REF
  25179   "RTN","RCD PESR4",165 ,0)
  25180    ;
  25181   "RTN","RCD PESR4",166 ,0)
  25182    ;
  25183   "RTN","RCD PESR4",167 ,0)
  25184    N RCE,RCD ATA,RCMSG, RCFROM,Z,Z 0
  25185   "RTN","RCD PESR4",168 ,0)
  25186    K ^TMP("R CTEXT",$J) ,^TMP("RCR AW",$J)
  25187   "RTN","RCD PESR4",169 ,0)
  25188    M ^TMP("R CTEXT",$J) =@RCGBL@(1 ,"D")
  25189   "RTN","RCD PESR4",170 ,0)
  25190    M ^TMP("R CRAW",$J)= @RCGBL@(2, "D")
  25191   "RTN","RCD PESR4",171 ,0)
  25192    ;
  25193   "RTN","RCD PESR4",172 ,0)
  25194    S RCDATA= $G(^RCY(34 4.5,RCTDA, 0)),RCMSG= $G(RCD("MS G#")),RCFR OM=$G(RCD( "FROM"))
  25195   "RTN","RCD PESR4",173 ,0)
  25196    ;
  25197   "RTN","RCD PESR4",174 ,0)
  25198    ; For mul ti-part ER A, don't u pdate if s equence al ready file d
  25199   "RTN","RCD PESR4",175 ,0)
  25200    ; Add seq  # if not  already th ere
  25201   "RTN","RCD PESR4",176 ,0)
  25202    I $P(RCHD R,U)'["XFR ",$P(RCHDR ,U,13) Q:$ D(^RCY(344 .5,RCTDA," S","B",+$P (RCHDR,U,1 4)))
  25203   "RTN","RCD PESR4",177 ,0)
  25204    ;
  25205   "RTN","RCD PESR4",178 ,0)
  25206    D STOREM( +$G(RCTDA) ,"^TMP(""R CTEXT"",$J )","^TMP(" "RCRAW"",$ J)",.RCE)
  25207   "RTN","RCD PESR4",179 ,0)
  25208    ;
  25209   "RTN","RCD PESR4",180 ,0)
  25210    I $D(RCE( "DIERR"))  D  ; Extra ct error
  25211   "RTN","RCD PESR4",181 ,0)
  25212    . N DIE,D A,DR,X,Y
  25213   "RTN","RCD PESR4",182 ,0)
  25214    . D EXTER R^RCDPESR1 (.RCERR,.R CE)
  25215   "RTN","RCD PESR4",183 ,0)
  25216    . S:$L($G (RCE)) RCE RR(+$O(RCE RR(""),-1) +1)=RCE
  25217   "RTN","RCD PESR4",184 ,0)
  25218    . I $D(^R CY(344.5,R CTDA,0)) S  DIE="^RCY (344.5,",D R=".1////4 ",DA=RCTDA  D ^DIE
  25219   "RTN","RCD PESR4",185 ,0)
  25220    E  D  ; N o error -  store rest  of data
  25221   "RTN","RCD PESR4",186 ,0)
  25222    . N Z,RCT ,RCCT,RCX, RCB ; Add  bills incl uded in ER A
  25223   "RTN","RCD PESR4",187 ,0)
  25224    . S RCT=0 ,RCCT=0,RC X=$J("",4)
  25225   "RTN","RCD PESR4",188 ,0)
  25226    . S Z=""  F  S Z=$O( RCBILL(Z))  Q:Z=""  D
  25227   "RTN","RCD PESR4",189 ,0)
  25228    .. N DO,D D,DIC,DLAY GO,X,Y
  25229   "RTN","RCD PESR4",190 ,0)
  25230    .. S:RCT= 4 RCCT=RCC T+1,RCB(RC CT)=RCX,RC T=0,RCX=$J ("",4) S R CX=RCX_$E( $S(+RCBILL (Z):"",1:" *")_Z_$J(" ",15),1,15 ),RCT=RCT+ 1
  25231   "RTN","RCD PESR4",191 ,0)
  25232    .. S DIC( 0)="L",DIC ("DR")=".0 2////"_$S( $G(RCBILL( Z)):1,1:0) ,X=Z,DA(1) =RCTDA,DIC ="^RCY(344 .5,"_DA(1) _",""B""," ,DLAYGO=34 4.54 D FIL E^DICN K D O,DD,DLAYG O,DIC
  25233   "RTN","RCD PESR4",192 ,0)
  25234    .. ;
  25235   "RTN","RCD PESR4",193 ,0)
  25236    . I $L(RC X)>4 S RCC T=RCCT+1,R CB(RCCT)=R CX
  25237   "RTN","RCD PESR4",194 ,0)
  25238    . ; Add l ist of bil ls to disp lay data
  25239   "RTN","RCD PESR4",195 ,0)
  25240    . I $O(RC B(0)) D WP ^DIE(344.5 ,RCTDA_"," ,1,"A","RC B")
  25241   "RTN","RCD PESR4",196 ,0)
  25242    . ; Add s eq #
  25243   "RTN","RCD PESR4",197 ,0)
  25244    . S DA(1) =RCTDA,DIC ="^RCY(344 .5,"_DA(1) _",""S""," ,DIC(0)="L ",X=$P(RCH DR,U,14),D IC("DR")=" .02////"_$ S($P(RCHDR ,U,15)="Y" :1,1:0)_"; .03///^S X =""NOW"";. 04////"_RC MSG,X=+$P( RCHDR,U,14 ),DLAYGO=3 44.53
  25245   "RTN","RCD PESR4",198 ,0)
  25246    . D FILE^ DICN K DO, DD,DLAYGO, DIC
  25247   "RTN","RCD PESR4",199 ,0)
  25248    . ;
  25249   "RTN","RCD PESR4",200 ,0)
  25250    . I $P(RC HDR,U)["83 5XFR" D XF R^RCDPESR5 (RCTDA,RCF ROM,RCMSG, .RCD) Q
  25251   "RTN","RCD PESR4",201 ,0)
  25252    . ;
  25253   "RTN","RCD PESR4",202 ,0)
  25254    . ; Proce ed only if  not a tra nsfer reco rd
  25255   "RTN","RCD PESR4",203 ,0)
  25256    . I $P(RC DATA,U,9)' ="" D  ; D etermine i f all sequ ences rece ived yet
  25257   "RTN","RCD PESR4",204 ,0)
  25258    .. N RCOK ,RCLAST
  25259   "RTN","RCD PESR4",205 ,0)
  25260    .. S RCOK =1,RCLAST= 0
  25261   "RTN","RCD PESR4",206 ,0)
  25262    .. F Z=1: 1 Q:'RCOK! RCLAST  D
  25263   "RTN","RCD PESR4",207 ,0)
  25264    ... I 'RC LAST,'$D(^ RCY(344.5, RCTDA,"S", "B",Z)) S  RCOK=0 Q
  25265   "RTN","RCD PESR4",208 ,0)
  25266    ... S Z0= +$O(^RCY(3 44.5,RCTDA ,"S","B",Z ,0)),Z0=$G (^RCY(344. 5,RCTDA,"S ",Z0,0))
  25267   "RTN","RCD PESR4",209 ,0)
  25268    ... I Z0= "" S RCOK= 0 Q
  25269   "RTN","RCD PESR4",210 ,0)
  25270    ... I $P( Z0,U,2) S  RCLAST=1 ;  Last sequ ence recei ved and al l before i t
  25271   "RTN","RCD PESR4",211 ,0)
  25272    .. ;
  25273   "RTN","RCD PESR4",212 ,0)
  25274    .. I RCOK  D
  25275   "RTN","RCD PESR4",213 ,0)
  25276    ... N DA, DIE,DR,X,Y
  25277   "RTN","RCD PESR4",214 ,0)
  25278    ... S DA= RCTDA,DR=" .08////0;. 1///@",DIE ="^RCY(344 .5," D ^DI E
  25279   "RTN","RCD PESR4",215 ,0)
  25280    ... I '$O (^RCY(344. 5,RCTDA,"B ","AV",1,0 )) D  ; No  valid bil ls found
  25281   "RTN","RCD PESR4",216 ,0)
  25282    ....;---- -
  25283   "RTN","RCD PESR4",217 ,0)
  25284    ....; PRC A*4.5*298  - MailMan  message di sabled, lo gic retain ed - 14 Fe b 2014
  25285   "RTN","RCD PESR4",218 ,0)
  25286    ....;N RC E
  25287   "RTN","RCD PESR4",219 ,0)
  25288    ....;S RC E(1)="No v alid bills  for this  site were  found in t his ERA"
  25289   "RTN","RCD PESR4",220 ,0)
  25290    ....;S RC E(2)="Revi ew/correct  the bill  #'s on thi s ERA in y our transm ission exc eptions"
  25291   "RTN","RCD PESR4",221 ,0)
  25292    ....;S RC E(3)="Plea se contact  the Imple mentation  Manager gr oup to rep ort this s ituation", RCE(4)=" "
  25293   "RTN","RCD PESR4",222 ,0)
  25294    ....;D BU LLERA^RCDP ESR0("D"_$ S($O(^RCY( 344.5,RCTD A,2,0)):"F ",1:""),RC TDA,$G(RCD ("MSG#")), "EDI LBOX  - NO VALID  BILLS ON  ERA "_$E($ G(RCD("PAY FROM")),1, 20),.RCE,0 )
  25295   "RTN","RCD PESR4",223 ,0)
  25296    ....;---- -
  25297   "RTN","RCD PESR4",224 ,0)
  25298    .... S DA =RCTDA,DR= ".08////1; .1////6",D IE="^RCY(3 44.5," D ^ DIE
  25299   "RTN","RCD PESR4",225 ,0)
  25300    ;
  25301   "RTN","RCD PESR4",226 ,0)
  25302    ;
  25303   "RTN","RCD PESR4",227 ,0)
  25304    K ^TMP("R CTEXT",$J) ,^TMP("RCR AW",$J)
  25305   "RTN","RCD PESR4",228 ,0)
  25306    Q
  25307   "RTN","RCD PESR4",229 ,0)
  25308    ;
  25309   "RTN","RCD PESR4",230 ,0)
  25310   STOREM(RCT DA,RCDISP, RCTEXT,RCE ) ;Store m sg text in  file 344. 5
  25311   "RTN","RCD PESR4",231 ,0)
  25312    ;INPUT:
  25313   "RTN","RCD PESR4",232 ,0)
  25314    ; RCTDA =  ien of th e entry in  file 344. 5
  25315   "RTN","RCD PESR4",233 ,0)
  25316    ; RCDISP  = name of  the array  where disp lay msg te xt is retr ieved from
  25317   "RTN","RCD PESR4",234 ,0)
  25318    ;   or "@ " to delet e the text  from the  display te xt field
  25319   "RTN","RCD PESR4",235 ,0)
  25320    ; RCTEXT  = name of  the array  where raw  msg text i s retrieve d from
  25321   "RTN","RCD PESR4",236 ,0)
  25322    ;   or "@ " to delet e the text  from the  raw msg fi eld
  25323   "RTN","RCD PESR4",237 ,0)
  25324    ;OUTPUT:
  25325   "RTN","RCD PESR4",238 ,0)
  25326    ; RCE = a rray of er rors (RCE( "DIERR"))  returned,  pass by RE F
  25327   "RTN","RCD PESR4",239 ,0)
  25328    ;
  25329   "RTN","RCD PESR4",240 ,0)
  25330    N RCZ,X,Y ,DIE
  25331   "RTN","RCD PESR4",241 ,0)
  25332    K RCE("DI ERR")
  25333   "RTN","RCD PESR4",242 ,0)
  25334    ;
  25335   "RTN","RCD PESR4",243 ,0)
  25336    I $S($G(R CDISP)="@" :1,1:$D(@R CDISP)'<10 ) D
  25337   "RTN","RCD PESR4",244 ,0)
  25338    . F RCZ=1 :1:20 D WP ^DIE(344.5 ,RCTDA_"," ,1,"AK","" _RCDISP_"" ,"RCE") Q: $S('$D(RCE ("DIERR")) :1,+RCE("D IERR")=1:$ G(RCE("DIE RR",1))'=1 10,1:1)  K :RCZ<20 RC E("DIERR")  ; On lock  error, re try up to  20 times
  25339   "RTN","RCD PESR4",245 ,0)
  25340    ;
  25341   "RTN","RCD PESR4",246 ,0)
  25342    I '$O(RCE ("DIERR",0 )),$S($G(R CTEXT)="@" :1,1:$D(@R CTEXT)'<10 ) D
  25343   "RTN","RCD PESR4",247 ,0)
  25344    . F RCZ=1 :1:20 D WP ^DIE(344.5 ,RCTDA_"," ,2,"AK","" _RCTEXT_"" ,"RCE") Q: $S('$D(RCE ("DIERR")) :1,+RCE("D IERR")=1:$ G(RCE("DIE RR",1))'=1 10,1:1)  K :RCZ<20 RC E("DIERR")  ; On lock  error, re try up to  20 times
  25345   "RTN","RCD PESR4",248 ,0)
  25346    Q
  25347   "RTN","RCD PESR6")
  25348   0^41^B4702 6238
  25349   "RTN","RCD PESR6",1,0 )
  25350   RCDPESR6 ; ALB/TMK/DW A - Server  auto-upda te file 34 4.4 - EDI  Lockbox ;J un 06, 201 4@19:11:19
  25351   "RTN","RCD PESR6",2,0 )
  25352    ;;4.5;Acc ounts Rece ivable;**1 73,214,208 ,230,252,2 69,271,298 ,321**;Mar  20, 1995; Build 46
  25353   "RTN","RCD PESR6",3,0 )
  25354    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  25355   "RTN","RCD PESR6",4,0 )
  25356    ;
  25357   "RTN","RCD PESR6",5,0 )
  25358    ;Referenc e to $$VAL ECME^BPSUT IL2 suppor ted by IA#  6139
  25359   "RTN","RCD PESR6",6,0 )
  25360    ;
  25361   "RTN","RCD PESR6",7,0 )
  25362   UPD3444(RC RTOT) ; Ad d EOB deta il to list  in 344.41  for file  344.4 entr y RCRTOT
  25363   "RTN","RCD PESR6",8,0 )
  25364    ; If pass ed by refe rence, RCR TOT is ret urned = ""  if errors
  25365   "RTN","RCD PESR6",9,0 )
  25366    ;
  25367   "RTN","RCD PESR6",10, 0)
  25368    N RC,RCCO M1,RCCOM2, RCCT,RC1,R C2,RCDPNM, RCEOB,RCNP I1,RCNPI2, DA,DR,DO,D D,DLAYGO,D IC,DIK,X,Y ,Z
  25369   "RTN","RCD PESR6",11, 0)
  25370    S RC=0 F   S RC=$O(^ TMP($J,"RC DPEOB",RC) ) Q:'RC  S  RC1=$G(^( RC)),RC2=$ G(^(RC,"EO B")),RCEOB =+RC2 D  Q :'RCRTOT
  25371   "RTN","RCD PESR6",12, 0)
  25372    . ; Updat e 344.41 w ith refere nce to thi s record i f it doesn 't already  exist
  25373   "RTN","RCD PESR6",13, 0)
  25374    . I RCEOB >0 Q:$D(^R CY(344.4,R CRTOT,1,"A C",RCEOB,R C))
  25375   "RTN","RCD PESR6",14, 0)
  25376    . I RCEOB '>0,$S($P( RC1,U,2)'= "":$D(^RCY (344.4,RCR TOT,1,"AD" ,$P(RC1,U, 2),RC)),1: 0) Q
  25377   "RTN","RCD PESR6",15, 0)
  25378    . ; Disre gard ECME  reject rel ated EEOBs ; ECME# ca n be 7 dig its or 12  digits
  25379   "RTN","RCD PESR6",16, 0)
  25380    . I RCEOB '>0,'$P(RC 2,U,2),$$V ALECME^BPS UTIL2($P(R C1,U,2)),$ $REJECT^IB NCPDPU($P( RC1,U,2),$ P(RC1,U,3) ) Q
  25381   "RTN","RCD PESR6",17, 0)
  25382    . ;
  25383   "RTN","RCD PESR6",18, 0)
  25384    . S DA(1) =RCRTOT,X= RC,DIC="^R CY(344.4," _DA(1)_",1 ,",DIC(0)= "L",DLAYGO =344.41
  25385   "RTN","RCD PESR6",19, 0)
  25386    . S DIC(" DR")=$S($G (RCEOB)>0: ".02////"_ RCEOB,1:". 05////"_$P (RC1,U,2)_ ";.07////1 ")
  25387   "RTN","RCD PESR6",20, 0)
  25388    . I $P(RC 2,U,2)'=""  S DIC("DR ")=DIC("DR ")_$S($L(D IC("DR")): ";",1:"")_ ".03///"_$ P(RC2,U,2)  ; amt
  25389   "RTN","RCD PESR6",21, 0)
  25390    . I $P(RC 2,U,3)'=""  S DIC("DR ")=DIC("DR ")_$S($L(D IC("DR")): ";",1:"")_ ".04////"_ $P(RC2,U,3 ) ; ins co
  25391   "RTN","RCD PESR6",22, 0)
  25392    . I $P(RC 2,U,4) S D IC("DR")=D IC("DR")_$ S($L(DIC(" DR")):";", 1:"")_".14 ////1" ; r eversal
  25393   "RTN","RCD PESR6",23, 0)
  25394    . I $P(RC 2,U,5)'=""  S DIC("DR ")=DIC("DR ")_$S($L(D IC("DR")): ";",1:"")_ ".15////^S  X=$E($P(R C2,U,5),1, 30)" ; Pat ient name
  25395   "RTN","RCD PESR6",24, 0)
  25396    . ; Proce ss Billing  Prov NPI,  Rendering /Servicing  NPI & nam e
  25397   "RTN","RCD PESR6",25, 0)
  25398    . S (RCCO M1,RCCOM2) =""
  25399   "RTN","RCD PESR6",26, 0)
  25400    . S RCNPI 1=$P(RC2,U ,10),RCNPI 2=$P(RC2,U ,11)
  25401   "RTN","RCD PESR6",27, 0)
  25402    . I RCNPI 1'="",'$$C HKDGT^XUSN PI(RCNPI1)  S RCCOM1= "The Billi ng Provide r NPI rece ived on th e 835 ("_$ E(RCNPI1,1 ,10)_") is  not a val id format. "
  25403   "RTN","RCD PESR6",28, 0)
  25404    . I RCNPI 2'="",'$$C HKDGT^XUSN PI(RCNPI2)  S RCCOM2= "The "_$S( $P(RC2,U,1 2)=1:"Rend ering",1:" Servicing" )_" NPI re ceived on  the 835 (" _$E(RCNPI2 ,1,10)_")  is not a v alid forma t."
  25405   "RTN","RCD PESR6",29, 0)
  25406    . I RCCOM 1="" S DIC ("DR")=DIC ("DR")_";. 18////^S X =$P(RC2,U, 10)"  ;Bil ling Provi der NPI
  25407   "RTN","RCD PESR6",30, 0)
  25408    . I RCCOM 2="" S DIC ("DR")=DIC ("DR")_";. 19////^S X =$P(RC2,U, 11)"  ;Ren dering Pro vider NPI
  25409   "RTN","RCD PESR6",31, 0)
  25410    . S RCDPN M=$P(RC2,U ,13) I $P( RC2,U,14)] "" S RCDPN M=RCDPNM_$ S(RCDPNM]" ":",",1:"" )_$P(RC2,U ,14)
  25411   "RTN","RCD PESR6",32, 0)
  25412    . S DIC(" DR")=DIC(" DR")_";.2/ ///^S X=$P (RC2,U,12) ;.21////^S  X=RCDPNM"   ; Entity  Type Qual ifier ^ La st name,Fi rst Name
  25413   "RTN","RCD PESR6",33, 0)
  25414    . S DIC(" DR")=DIC(" DR")_";.22 ////^S X=R CCOM1;.23/ ///^S X=RC COM2"  ;Co mment on B illing pro vider^comm ent on ren dering/ser vicing pro vider NPI
  25415   "RTN","RCD PESR6",34, 0)
  25416    . I $$VAL ECME^BPSUT IL2($P(RC1 ,U,4)) D
  25417   "RTN","RCD PESR6",35, 0)
  25418    .. S DIC( "DR")=DIC( "DR")_";.2 4////^S X= $P(RC1,U,4 )"  ;Add E CME number  (if valid ) PRCA*4.5 *298
  25419   "RTN","RCD PESR6",36, 0)
  25420    . D FILE^ DICN K DO, DD,DLAYGO, DIC,DIK
  25421   "RTN","RCD PESR6",37, 0)
  25422    . S RCCT= +Y
  25423   "RTN","RCD PESR6",38, 0)
  25424    . I RCCT< 0 D  Q
  25425   "RTN","RCD PESR6",39, 0)
  25426    .. S DA=R CRTOT,DIK= "^RCY(344. 4," D ^DIK
  25427   "RTN","RCD PESR6",40, 0)
  25428    .. S RCRT OT=0
  25429   "RTN","RCD PESR6",41, 0)
  25430    . ; If th ere is no  IB EOB rec ord, store  the raw d ata in 344 .411
  25431   "RTN","RCD PESR6",42, 0)
  25432    . I RC1'> 0!(RCEOB'> 0) D
  25433   "RTN","RCD PESR6",43, 0)
  25434    .. N RCDA TA,RCC,RCD A
  25435   "RTN","RCD PESR6",44, 0)
  25436    .. S RCC= 2,RCDATA(1 )=$G(^TMP( $J,"RCDPEO B","HDR"))
  25437   "RTN","RCD PESR6",45, 0)
  25438    .. ; PRCA *4.5*321 -  use RC in  place of  RCCT to al low for ga ps in ERA  sequence n umbers (du e to ECME  rejects)
  25439   "RTN","RCD PESR6",46, 0)
  25440    .. S Z=0  F  S Z=$O( ^TMP($J,"R CDPEOB",RC ,Z)) Q:'Z   S RCC=RCC +1,RCDATA( RCC)=$G(^T MP($J,"RCD PEOB",RC,Z ))
  25441   "RTN","RCD PESR6",47, 0)
  25442    .. S RCDA (1)=RCRTOT ,RCDA=RCCT
  25443   "RTN","RCD PESR6",48, 0)
  25444    .. D WP^D IE(344.41, $$IENS^DIL F(.RCDA),1 ,"A","RCDA TA")
  25445   "RTN","RCD PESR6",49, 0)
  25446    Q
  25447   "RTN","RCD PESR6",50, 0)
  25448    ;
  25449   "RTN","RCD PESR6",51, 0)
  25450    ;
  25451   "RTN","RCD PESR6",52, 0)
  25452   ERATOT(RCT DA,RCERR)  ; File ERA  TOTAL rec  in 344.4  from entry  RCTDA in  344.5
  25453   "RTN","RCD PESR6",53, 0)
  25454    ; RCTDA =  ien file  344.5
  25455   "RTN","RCD PESR6",54, 0)
  25456    ; Returns : the ien  file 344.4
  25457   "RTN","RCD PESR6",55, 0)
  25458    ;           RCERR if  passed by  reference , with err or text
  25459   "RTN","RCD PESR6",56, 0)
  25460    ;           RCERR(1) =duplicate d message
  25461   "RTN","RCD PESR6",57, 0)
  25462    N RCTYPE, RCDA,RCMET H,RCTRACE, RCID,RCDT, RCAMT,RCDU P,RCZ,RCX, RCPAYER,DI E,DIK,DIC, DLAYGO,DD, DO,DR,DA,X ,Y,Z0,Z1
  25463   "RTN","RCD PESR6",58, 0)
  25464    S (RCERR, RCDA)=""
  25465   "RTN","RCD PESR6",59, 0)
  25466    S RCZ=$G( ^RCY(344.5 ,RCTDA,2,1 ,0))
  25467   "RTN","RCD PESR6",60, 0)
  25468    S RCTYPE= $P(RCZ,U), RCTRACE=$P (RCZ,U,8), RCID=$P(RC Z,U,7),RCP AYER=$P(RC Z,U,6),RCM ETH=$P(RCZ ,U,17)
  25469   "RTN","RCD PESR6",61, 0)
  25470    ; Need he ader recor d as first  entry in  field
  25471   "RTN","RCD PESR6",62, 0)
  25472    I RCTYPE' ["835ERA"  S RCERR="N o header r ecord foun d in messa ge.  An EE OB excepti on record  was create d" G ERATO TQ
  25473   "RTN","RCD PESR6",63, 0)
  25474    ;
  25475   "RTN","RCD PESR6",64, 0)
  25476    S RCDT=$$ FMDT^RCDPE SR1($P(RCZ ,U,9)),RCA MT=$J(($P( RCZ,U,10)/ 100),0,2)
  25477   "RTN","RCD PESR6",65, 0)
  25478    ;Elec ERA 's must ha ve a trace  # and an  ins co id
  25479   "RTN","RCD PESR6",66, 0)
  25480    I RCTRACE =""!(RCID= "") S RCER R="Trace #  or ins ID  missing o n ERA tran saction.   An EEOB ex ception re cord was c reated." G  ERATOTQ
  25481   "RTN","RCD PESR6",67, 0)
  25482    ; Make su re it's no t already  there
  25483   "RTN","RCD PESR6",68, 0)
  25484    S (RCDUP, Z1)=0
  25485   "RTN","RCD PESR6",69, 0)
  25486    F  S Z1=$ O(^RCY(344 .4,"ATRIDU P",$$UP^XL FSTR(RCTRA CE),$$UP^X LFSTR(RCID ),Z1)) Q:' Z1  S Z0=$ G(^RCY(344 .4,Z1,0))  I $P(Z0,U, 4)=RCDT,+$ P(Z0,U,5)= +RCAMT S R CDUP=1 Q
  25487   "RTN","RCD PESR6",70, 0)
  25488    ;
  25489   "RTN","RCD PESR6",71, 0)
  25490    I RCDUP,$ P(Z0,U,8)  D  G ERATO TQ ; Recei pt already  exists -  no update
  25491   "RTN","RCD PESR6",72, 0)
  25492    . S RCERR ="This is  a duplicat e ERA and  has alread y been pos ted",RCERR (1)=-2
  25493   "RTN","RCD PESR6",73, 0)
  25494    I RCDUP S  RCERR="DU P",RCERR(1 )=$S($P(Z0 ,U,12)'=$P ($G(^RCY(3 44.5,RCTDA ,0)),U,11) :$P(Z0,U,1 2),1:-1) G  ERATOTQ
  25495   "RTN","RCD PESR6",74, 0)
  25496    ;
  25497   "RTN","RCD PESR6",75, 0)
  25498    S RCX=+$O (^RCY(344. 4," "),-1)
  25499   "RTN","RCD PESR6",76, 0)
  25500    S DIC(0)= "L",DIC="^ RCY(344.4, ",DLAYGO=3 44.4
  25501   "RTN","RCD PESR6",77, 0)
  25502    S DIC("DR ")=".02/// /"_RCTRACE _";.03//// "_RCID_";. 04////"_RC DT_";.05// //"_RCAMT_ ";.06////" _$P(RCZ,U, 6)_";.09// //0;.12/// /"_$P($G(^ RCY(344.5, RCTDA,0)), U,11)_";.0 7////"_$$N OW^XLFDT() _";.1////1 "
  25503   "RTN","RCD PESR6",78, 0)
  25504    I RCMETH' ="" S DIC( "DR")=DIC( "DR")_";.1 5////"_RCM ETH
  25505   "RTN","RCD PESR6",79, 0)
  25506    F RCX=RCX +1:1 L +^R CY(344.4,R CX,0):1 I  $T,'$D(^RC Y(344.4,RC X,0)) S X= RCX Q
  25507   "RTN","RCD PESR6",80, 0)
  25508    D FILE^DI CN K DO,DL AYGO,DD,DI C
  25509   "RTN","RCD PESR6",81, 0)
  25510    L -^RCY(3 44.4,RCX,0 )
  25511   "RTN","RCD PESR6",82, 0)
  25512    S RCDA=$S (Y<0:"",1: +Y)
  25513   "RTN","RCD PESR6",83, 0)
  25514    I 'RCDA D
  25515   "RTN","RCD PESR6",84, 0)
  25516    . S RCERR ="An error  was encou ntered tha t prevente d the addi ng of an E RA totals  record.  A n EEOB exc eption rec ord was cr eated."
  25517   "RTN","RCD PESR6",85, 0)
  25518    ;
  25519   "RTN","RCD PESR6",86, 0)
  25520   ERATOTQ Q  RCDA
  25521   "RTN","RCD PESR6",87, 0)
  25522    ;
  25523   "RTN","RCD PESR6",88, 0)
  25524   UPDCON(RCR TOT) ; Add  contact i nformation  to file 3 44.4 for a n ERA
  25525   "RTN","RCD PESR6",89, 0)
  25526    N DIE,DA, DR,Z,Q,X,Y ,A,TYPE
  25527   "RTN","RCD PESR6",90, 0)
  25528    S Z=$G(^T MP($J,"RCD PEOB","CON TACT"))
  25529   "RTN","RCD PESR6",91, 0)
  25530    Q:$TR($P( Z,U,3,9),U )=""
  25531   "RTN","RCD PESR6",92, 0)
  25532    S DA=RCRT OT,DIE="^R CY(344.4," ,DR=""
  25533   "RTN","RCD PESR6",93, 0)
  25534    ;
  25535   "RTN","RCD PESR6",94, 0)
  25536    ; If old  format do
  25537   "RTN","RCD PESR6",95, 0)
  25538    I +$P($G( ^TMP($J,"R CDPEOB","H DR")),U,16 )'>0 D
  25539   "RTN","RCD PESR6",96, 0)
  25540    . F Q=2:1 :8 S DR=DR _$S(DR'="" :";3.0",1: "3.0")_(Q- 1)_"///"_$ S($P(Z,U,Q )="":"@",1 :"/"_$P(Z, U,Q))
  25541   "RTN","RCD PESR6",97, 0)
  25542    ;
  25543   "RTN","RCD PESR6",98, 0)
  25544    ; If new  format (50 10) do
  25545   "RTN","RCD PESR6",99, 0)
  25546    I +$P($G( ^TMP($J,"R CDPEOB","H DR")),U,16 )>0 D
  25547   "RTN","RCD PESR6",100 ,0)
  25548    . N CNT S  CNT=0
  25549   "RTN","RCD PESR6",101 ,0)
  25550    . I $P(Z, U,2)'="" S  DR="3.01/ ///"_$P(Z, U,2)
  25551   "RTN","RCD PESR6",102 ,0)
  25552    .I $P(Z,U ,3)'="" S  DR=DR_$S(D R'="":";3. 02",1:"3.0 2")_"////" _$P(Z,U,3) _";3.03/// /TE",CNT=C NT+1
  25553   "RTN","RCD PESR6",103 ,0)
  25554    .I $P(Z,U ,4)'="" D
  25555   "RTN","RCD PESR6",104 ,0)
  25556    ..S:CNT=1  DR=DR_$S( DR'="":";3 .04",1:"3. 04")_"//// "_$P(Z,U,4 )_";3.05// //FX"
  25557   "RTN","RCD PESR6",105 ,0)
  25558    ..S:CNT=0  DR=DR_$S( DR'="":";3 .02",1:"3. 02")_"//// "_$P(Z,U,4 )_";3.03// //FX"
  25559   "RTN","RCD PESR6",106 ,0)
  25560    ..S CNT=C NT+1
  25561   "RTN","RCD PESR6",107 ,0)
  25562    .I $P(Z,U ,5)'="" D
  25563   "RTN","RCD PESR6",108 ,0)
  25564    ..S:CNT=2  DR=DR_$S( DR'="":";3 .06",1:"3. 06")_"//// "_$P(Z,U,5 )_";3.07// //EM"
  25565   "RTN","RCD PESR6",109 ,0)
  25566    ..S:CNT=1  DR=DR_$S( DR'="":";3 .04",1:"3. 04")_"//// "_$P(Z,U,5 )_";3.05// //EM"
  25567   "RTN","RCD PESR6",110 ,0)
  25568    ..S:CNT=0  DR=DR_$S( DR'="":";3 .02",1:"3. 02")_"//// "_$P(Z,U,5 )_";3.03// //EM"
  25569   "RTN","RCD PESR6",111 ,0)
  25570    . I $P(Z, U,6)'="" S  DR=DR_$S( DR'="":";5 .01",1:"5. 01")_"//// "_$P(Z,U,6 )
  25571   "RTN","RCD PESR6",112 ,0)
  25572    D ^DIE
  25573   "RTN","RCD PESR6",113 ,0)
  25574    Q
  25575   "RTN","RCD PESR6",114 ,0)
  25576    ;
  25577   "RTN","RCD PESR6",115 ,0)
  25578   UPDADJ(RCR TOT) ; Add  ERA level  adj data  to file 34 4.4
  25579   "RTN","RCD PESR6",116 ,0)
  25580    N Z,Z0,DA ,DIC,DLAYG O,DR,X,Y,D O,DD
  25581   "RTN","RCD PESR6",117 ,0)
  25582    ; Remove  any alread y there
  25583   "RTN","RCD PESR6",118 ,0)
  25584    S Z=0 F   S Z=$O(^RC Y(344.4,RC RTOT,2,Z))  Q:'Z  S D A(1)=RCRTO T,DA=Z D ^ DIK
  25585   "RTN","RCD PESR6",119 ,0)
  25586    ;
  25587   "RTN","RCD PESR6",120 ,0)
  25588    S Z=0 F   S Z=$O(^TM P($J,"RCDP EOB","ADJ" ,Z)) Q:'Z   S Z0=$G(^ (Z)) D
  25589   "RTN","RCD PESR6",121 ,0)
  25590    . S DIC(0 )="L",X=$P (Z0,U,3)_"  ",DA(1)=R CRTOT,DIC= "^RCY(344. 4,"_DA(1)_ ",2,",DIC( "DR")=$S($ P(Z0,U,2)' ="":".02// //"_$P(Z0, U,2),1:"")
  25591   "RTN","RCD PESR6",122 ,0)
  25592    . S DIC(" DR")=DIC(" DR")_$S(DI C("DR")'=" ":";",1:"" )_$S($P(Z0 ,U,4)'="": ".03////"_ $J(-$P(Z0, U,4)/100," ",2),1:"")
  25593   "RTN","RCD PESR6",123 ,0)
  25594    . S DIC(" DR")=DIC(" DR")_$S(DI C("DR")'=" ":";",1:"" )_$S($P(Z0 ,U,5)'="": ".04////"_ $P(Z0,U,5) ,1:""),DLA YGO=344.42
  25595   "RTN","RCD PESR6",124 ,0)
  25596    . S:$O(^R CY(344.4,R CRTOT,2,"B ",X,0)) X= """"_X_""" "
  25597   "RTN","RCD PESR6",125 ,0)
  25598    . D FILE^ DICN K DIC ,DO,DD
  25599   "RTN","RCD PESR6",126 ,0)
  25600    Q
  25601   "RTN","RCD PESR6",127 ,0)
  25602    ;
  25603   "RTN","RCD PESR6",128 ,0)
  25604   DUPREC(RCE T,RCCT,RCS TAR,RCFILE ,RCALLDUP, RCEOB,RCBI LL,RCDUPEO B) ; Overf low from R CDPESR2
  25605   "RTN","RCD PESR6",129 ,0)
  25606    S ^TMP("R CERR1",$J, RCCT)=" ", ^TMP("RCER R1",$J,RCC T,1)=RCET_ RCCT_RCSTA R
  25607   "RTN","RCD PESR6",130 ,0)
  25608    S ^TMP("R CERR1",$J, RCCT,2)="( Warning):  EEOB detai l already  filed for  "_RCBILL_"  - "_$S(RC ALLDUP:"Du plicate no t stored", 1:"EEOB up dated"),^T MP("RCERR1 ",$J,RCCT, 3)=" " S:R CFILE=5 ^T MP("RCERR1 ",$J,RCCT, "*")=^TMP( "RCERR1",$ J,RCCT,2)
  25609   "RTN","RCD PESR6",131 ,0)
  25610    I RCALLDU P S RCEOB= "",RCDUPEO B=-1 Q
  25611   "RTN","RCD PESR6",132 ,0)
  25612    S $P(^TMP ($J,"RCDPE OB",RCCT," EOB"),U)=R CEOB
  25613   "RTN","RCD PESR6",133 ,0)
  25614    Q
  25615   "RTN","RCD PESR6",134 ,0)
  25616    ;
  25617   "RTN","RCD PEWL0")
  25618   0^65^B2424 11211
  25619   "RTN","RCD PEWL0",1,0 )
  25620   RCDPEWL0 ; ALB/TMK/PJ H - ELECTR ONIC EOB W ORKLIST AC TIONS ;Jun  06, 2014@ 19:11:19
  25621   "RTN","RCD PEWL0",2,0 )
  25622    ;;4.5;Acc ounts Rece ivable;**1 73,208,252 ,269,298,3 17,321**;M ar 20, 199 5;Build 46
  25623   "RTN","RCD PEWL0",3,0 )
  25624    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  25625   "RTN","RCD PEWL0",4,0 )
  25626    Q
  25627   "RTN","RCD PEWL0",5,0 )
  25628    ;
  25629   "RTN","RCD PEWL0",6,0 )
  25630   PARAMS(SOU RCE) ; Ret rieve/Edit /Save View  Parameter s for ERA  Worklist
  25631   "RTN","RCD PEWL0",7,0 )
  25632    ; Input:    SOURCE       - "MO"  - Menu Op tion
  25633   "RTN","RCD PEWL0",8,0 )
  25634    ;                          "CV"  - Change  View Actio n
  25635   "RTN","RCD PEWL0",9,0 )
  25636    ; Output:  Sort/Filt ering Crit eria for t he worklis t sent int o ^TMP("RC ERA_PARAMS ",$J)
  25637   "RTN","RCD PEWL0",10, 0)
  25638    ;          ^TMP("RCE RA_PARAMS" ,$J,"RCPOS T") - ERA  Posting St atus ("P": Posted/"U" :Unposted)
  25639   "RTN","RCD PEWL0",11, 0)
  25640    ;          ^TMP("RCE RA_PARAMS" ,$J,"RCAUT OP")- Auto -Posting S tatus
  25641   "RTN","RCD PEWL0",12, 0)
  25642    ;                                                ("A" :Auto-Post ing/"N":No n Auto-Pos ting/"B":B oth)
  25643   "RTN","RCD PEWL0",13, 0)
  25644    ;          ^TMP("RCE RA_PARAMS" ,$J,"RCMAT CH")- ERA  Matching S tatus ("M" :Matched/" U":Unmatch ed)
  25645   "RTN","RCD PEWL0",14, 0)
  25646    ;          ^TMP("RCE RA_PARAMS" ,$J,"RCTYP E") - ERA  Claim Type  ("M":Medi cal/"P":Ph armacy/"B" :Both)
  25647   "RTN","RCD PEWL0",15, 0)
  25648    ;          ^TMP("RCE RA_PARAMS" ,$J,"RCDT" )   - A1^A 2 Where:
  25649   "RTN","RCD PEWL0",16, 0)
  25650    ;                                                A1 -  ERA Recei ved EARLIE ST DATE (R ange Limit ed Only)
  25651   "RTN","RCD PEWL0",17, 0)
  25652    ;                                                A2 -  ERA Recei ved LATEST  DATE (Ran ge Limited  Only)
  25653   "RTN","RCD PEWL0",18, 0)
  25654    ;          ^TMP("RCE RA_PARAMS" ,$J,"RCPAY R") - B1^B 2^B3 Where :
  25655   "RTN","RCD PEWL0",19, 0)
  25656    ;                                                B1 -  All Payer s/Range of  Payers
  25657   "RTN","RCD PEWL0",20, 0)
  25658    ;                                                      ("A": All /"R":Range  of Payers )
  25659   "RTN","RCD PEWL0",21, 0)
  25660    ;                                                B2 -  START WIT H PAYER (e .g.,'AET')
  25661   "RTN","RCD PEWL0",22, 0)
  25662    ;                                                      (Range Li mited Only )
  25663   "RTN","RCD PEWL0",23, 0)
  25664    ;                                                B3 -  GO TO PAY ER (e.g.,' AETZ') (Ra nge Limite d Only)
  25665   "RTN","RCD PEWL0",24, 0)
  25666    ;
  25667   "RTN","RCD PEWL0",25, 0)
  25668    ;          ^TMP("RCE RA_PVW",$J ) - Same l ayout as ^ TMP("RCERA _PARAMS",$ J).  This  global con tains
  25669   "RTN","RCD PEWL0",26, 0)
  25670    ;                                   the so rt/filters  of the us er's prefe rred view  (for ERA m ain page)
  25671   "RTN","RCD PEWL0",27, 0)
  25672    ;                                   while  ^TMP("RCER A_PARAMS", $J) contai ns the sor t/filters  of what is
  25673   "RTN","RCD PEWL0",28, 0)
  25674    ;                                   curren tly displa yed.  They  may or ma y not be t he same va lues.
  25675   "RTN","RCD PEWL0",29, 0)
  25676    ;
  25677   "RTN","RCD PEWL0",30, 0)
  25678    ;           ^TMP("RC SCRATCH_PV W",$J)   -  This glob al contain s the sort /filters o f the user 's preferr ed view
  25679   "RTN","RCD PEWL0",31, 0)
  25680    ;                                   for th e Scratch  Pad.  See  PARAMS^RCD PEWLA for  the layout .
  25681   "RTN","RCD PEWL0",32, 0)
  25682    ;
  25683   "RTN","RCD PEWL0",33, 0)
  25684    ;          RCQUIT=1  if the use r exited o ut, 0 othe rwise
  25685   "RTN","RCD PEWL0",34, 0)
  25686    ;
  25687   "RTN","RCD PEWL0",35, 0)
  25688    N RCXPAR, USEPVW,X,X X,Y                 ;  PRCA*4.5* 317 Added  USEPVW,XX
  25689   "RTN","RCD PEWL0",36, 0)
  25690    S RCQUIT= 0
  25691   "RTN","RCD PEWL0",37, 0)
  25692    ;
  25693   "RTN","RCD PEWL0",38, 0)
  25694    ; Ask Dat e Range Se lection wh en coming  straight f rom the me nu option
  25695   "RTN","RCD PEWL0",39, 0)
  25696    I SOURCE= "MO" D  Q: RCQUIT
  25697   "RTN","RCD PEWL0",40, 0)
  25698    . K ^TMP( "RCERA_PAR AMS",$J),^ TMP("RCERA _PVW",$J), ^TMP("RCSC RATCH_PVW" ,$J)
  25699   "RTN","RCD PEWL0",41, 0)
  25700    . S RCQUI T=$$DTR()   ; Set dat e range fi lter
  25701   "RTN","RCD PEWL0",42, 0)
  25702    . Q:RCQUI T
  25703   "RTN","RCD PEWL0",43, 0)
  25704    . ;
  25705   "RTN","RCD PEWL0",44, 0)
  25706    . ;Retrie ve user's  saved pref erred view  (if any)
  25707   "RTN","RCD PEWL0",45, 0)
  25708    . D GETWL PVW(.RCXPA R)
  25709   "RTN","RCD PEWL0",46, 0)
  25710    ;
  25711   "RTN","RCD PEWL0",47, 0)
  25712    ;Only ask  user if t hey want t o use thei r preferre d view in  the follow ing scenar ios:
  25713   "RTN","RCD PEWL0",48, 0)
  25714    ; a) Sour ce is "MO"  and user  has a pref erred view  on file
  25715   "RTN","RCD PEWL0",49, 0)
  25716    ; b) Sour ce is "CV"  (change v iew action ), user ha s a prefer red view b ut is
  25717   "RTN","RCD PEWL0",50, 0)
  25718    ;    not  using the  preferred  view crite ria at thi s time.
  25719   "RTN","RCD PEWL0",51, 0)
  25720    S XX=$$PR EFVW(SOURC E)
  25721   "RTN","RCD PEWL0",52, 0)
  25722    I ((XX=1) &(SOURCE=" MO"))!((XX =0)&(SOURC E="CV")) D   Q:USEPVW
  25723   "RTN","RCD PEWL0",53, 0)
  25724    . ;
  25725   "RTN","RCD PEWL0",54, 0)
  25726    . ; Ask t he user if  they want  to use th e preferre d view
  25727   "RTN","RCD PEWL0",55, 0)
  25728    . S USEPV W=$$ASKUVW ()
  25729   "RTN","RCD PEWL0",56, 0)
  25730    . I USEPV W=-1 S RCQ UIT=1 Q
  25731   "RTN","RCD PEWL0",57, 0)
  25732    . Q:'USEP VW
  25733   "RTN","RCD PEWL0",58, 0)
  25734    . ;
  25735   "RTN","RCD PEWL0",59, 0)
  25736    . ; Set t he Sort/Fi ltering Cr iteria fro m the pref erred view  
  25737   "RTN","RCD PEWL0",60, 0)
  25738    . M ^TMP( "RCERA_PAR AMS",$J)=^ TMP("RCERA _PVW",$J)
  25739   "RTN","RCD PEWL0",61, 0)
  25740    ;
  25741   "RTN","RCD PEWL0",62, 0)
  25742    W !!,"Sel ect parame ters for d isplaying  the list o f ERAs"
  25743   "RTN","RCD PEWL0",63, 0)
  25744    S RCQUIT= $$PARAMS2^ RCDPEWLD()
  25745   "RTN","RCD PEWL0",64, 0)
  25746    Q:RCQUIT
  25747   "RTN","RCD PEWL0",65, 0)
  25748    D SAVEPVW                                      ; Ask  if they wa nt to save  as prefer red view
  25749   "RTN","RCD PEWL0",66, 0)
  25750    Q
  25751   "RTN","RCD PEWL0",67, 0)
  25752    ;
  25753   "RTN","RCD PEWL0",68, 0)
  25754   GETWLPVW(R CXPAR) ;   Retrieves  the prefer red view s ettings fo r the ERA  worklist
  25755   "RTN","RCD PEWL0",69, 0)
  25756    ; for the  user
  25757   "RTN","RCD PEWL0",70, 0)
  25758    ; Input:    None
  25759   "RTN","RCD PEWL0",71, 0)
  25760    ; Output:   RCXPAR()                 - Arr ay of pref erred view  sort/filt er criteri a
  25761   "RTN","RCD PEWL0",72, 0)
  25762    ;           ^TMP("RC ERA_PARAMS ",$J)- Glo bal array  of preferr ed view se ttings
  25763   "RTN","RCD PEWL0",73, 0)
  25764    ;           ^TMP("RC ERA_PVW")       - A c opy of the  preferred  settings  (if any)
  25765   "RTN","RCD PEWL0",74, 0)
  25766    N XX
  25767   "RTN","RCD PEWL0",75, 0)
  25768    K RCXPAR
  25769   "RTN","RCD PEWL0",76, 0)
  25770    D GETLST^ XPAR(.RCXP AR,"USR"," RCDPE EDI  LOCKBOX WO RKLIST","I ")
  25771   "RTN","RCD PEWL0",77, 0)
  25772    D:$D(RCXP AR("ERA_PO STING_STAT US")) PVWS AVE(.RCXPA R)
  25773   "RTN","RCD PEWL0",78, 0)
  25774    ;
  25775   "RTN","RCD PEWL0",79, 0)
  25776    S XX=$G(R CXPAR("ERA _POSTING_S TATUS"))
  25777   "RTN","RCD PEWL0",80, 0)
  25778    S ^TMP("R CERA_PARAM S",$J,"RCP OST")=$S(X X'="":XX,1 :"U")
  25779   "RTN","RCD PEWL0",81, 0)
  25780    S XX=$G(R CXPAR("ERA _AUTO_POST ING"))
  25781   "RTN","RCD PEWL0",82, 0)
  25782    S ^TMP("R CERA_PARAM S",$J,"RCA UTOP")=$S( XX'="":XX, 1:"B")
  25783   "RTN","RCD PEWL0",83, 0)
  25784    S XX=$G(R CXPAR("ERA -EFT_MATCH _STATUS"))
  25785   "RTN","RCD PEWL0",84, 0)
  25786    S ^TMP("R CERA_PARAM S",$J,"RCM ATCH")=$S( XX'="":XX, 1:"B")
  25787   "RTN","RCD PEWL0",85, 0)
  25788    S XX=$G(R CXPAR("ERA _CLAIM_TYP E"))
  25789   "RTN","RCD PEWL0",86, 0)
  25790    ; S ^TMP( "RCERA_PAR AMS",$J,"R CTYPE")=$S (XX'="":XX ,1:"B")      ; PRCA*4 .5*321
  25791   "RTN","RCD PEWL0",87, 0)
  25792    S ^TMP("R CERA_PARAM S",$J,"RCT YPE")=$S(X X'="":XX,1 :"A")        ; PRCA*4 .5*321 cha nge defaul t to (A)LL
  25793   "RTN","RCD PEWL0",88, 0)
  25794    S XX=$G(R CXPAR("ALL _PAYERS/RA NGE_OF_PAY ERS"))
  25795   "RTN","RCD PEWL0",89, 0)
  25796    S ^TMP("R CERA_PARAM S",$J,"RCP AYR")=$S(X X'="":$TR( XX,";","^" ),1:"A")
  25797   "RTN","RCD PEWL0",90, 0)
  25798    S XX=$G(R CXPAR("ERA _PAYMENT_T YPE"))                                    ;  PRCA*4.5* 321 new fi lter
  25799   "RTN","RCD PEWL0",91, 0)
  25800    S ^TMP("R CERA_PARAM S",$J,"RCP AYMNT")=$S (XX'="":XX ,1:"B")             ;  PRCA*4.5* 321
  25801   "RTN","RCD PEWL0",92, 0)
  25802    Q
  25803   "RTN","RCD PEWL0",93, 0)
  25804    ;
  25805   "RTN","RCD PEWL0",94, 0)
  25806   PVWSAVE(RC XPAR) ; Sa ve a copy  of the pre ferred vie w on file
  25807   "RTN","RCD PEWL0",95, 0)
  25808    ; PRCA*4. 5*317 adde d subrouti ne
  25809   "RTN","RCD PEWL0",96, 0)
  25810    ; Input:    RCXPAR              - array of  preferred  view sett ing for th e user
  25811   "RTN","RCD PEWL0",97, 0)
  25812    ; Output:   ^TMP("RC ERA_PVW")  - a copy o f the pref erred sett ings
  25813   "RTN","RCD PEWL0",98, 0)
  25814    ;
  25815   "RTN","RCD PEWL0",99, 0)
  25816    K ^TMP("R CERA_PVW", $J)
  25817   "RTN","RCD PEWL0",100 ,0)
  25818    ; only co ntinue if  we have an swers to a ll ERA Wor klist rela ted prefer red view p rompts
  25819   "RTN","RCD PEWL0",101 ,0)
  25820    Q:'$D(RCX PAR("ERA_P OSTING_STA TUS"))
  25821   "RTN","RCD PEWL0",102 ,0)
  25822    Q:'$D(RCX PAR("ERA_A UTO_POSTIN G"))
  25823   "RTN","RCD PEWL0",103 ,0)
  25824    Q:'$D(RCX PAR("ERA-E FT_MATCH_S TATUS"))
  25825   "RTN","RCD PEWL0",104 ,0)
  25826    Q:'$D(RCX PAR("ERA_C LAIM_TYPE" ))
  25827   "RTN","RCD PEWL0",105 ,0)
  25828    Q:'$D(RCX PAR("ALL_P AYERS/RANG E_OF_PAYER S"))
  25829   "RTN","RCD PEWL0",106 ,0)
  25830    Q:'$D(RCX PAR("ERA_P AYMENT_TYP E"))  ; PR CA*4.5*321
  25831   "RTN","RCD PEWL0",107 ,0)
  25832    ;
  25833   "RTN","RCD PEWL0",108 ,0)
  25834    S ^TMP("R CERA_PVW", $J,"RCPOST ")=RCXPAR( "ERA_POSTI NG_STATUS" )
  25835   "RTN","RCD PEWL0",109 ,0)
  25836    S ^TMP("R CERA_PVW", $J,"RCAUTO P")=RCXPAR ("ERA_AUTO _POSTING")
  25837   "RTN","RCD PEWL0",110 ,0)
  25838    S ^TMP("R CERA_PVW", $J,"RCMATC H")=RCXPAR ("ERA-EFT_ MATCH_STAT US")
  25839   "RTN","RCD PEWL0",111 ,0)
  25840    S ^TMP("R CERA_PVW", $J,"RCTYPE ")=RCXPAR( "ERA_CLAIM _TYPE")
  25841   "RTN","RCD PEWL0",112 ,0)
  25842    S ^TMP("R CERA_PVW", $J,"RCPAYR ")=$TR(RCX PAR("ALL_P AYERS/RANG E_OF_PAYER S"),";","^ ")
  25843   "RTN","RCD PEWL0",113 ,0)
  25844    S ^TMP("R CERA_PVW", $J,"RCPAYM NT")=RCXPA R("ERA_PAY MENT_TYPE" ) ; PRCA*4 .5*321 new  filter
  25845   "RTN","RCD PEWL0",114 ,0)
  25846    Q
  25847   "RTN","RCD PEWL0",115 ,0)
  25848    ;
  25849   "RTN","RCD PEWL0",116 ,0)
  25850   PREFVW(SOU RCE) ; Che cks to see  if the us er has a p referred v iew
  25851   "RTN","RCD PEWL0",117 ,0)
  25852    ; PRCA*4. 5*317 adde d subrouti ne
  25853   "RTN","RCD PEWL0",118 ,0)
  25854    ; When so urce is 'C V', checks  to see if  the prefe rred view  is being u sed
  25855   "RTN","RCD PEWL0",119 ,0)
  25856    ; Input:    SOURCE                    - 'M O' - When  called fro m the Work list menu
  25857   "RTN","RCD PEWL0",120 ,0)
  25858    ;                                               optio n
  25859   "RTN","RCD PEWL0",121 ,0)
  25860    ;                                       'C V' - When  called fro m the Chan ge View
  25861   "RTN","RCD PEWL0",122 ,0)
  25862    ;                                               actio n
  25863   "RTN","RCD PEWL0",123 ,0)
  25864    ;
  25865   "RTN","RCD PEWL0",124 ,0)
  25866    ;           ^TMP("RC ERA_PVW")        - Gl obal array  of prefer red view s ettings
  25867   "RTN","RCD PEWL0",125 ,0)
  25868    ;           ^TMP("RC ERA_PARAMS ")    - Gl obal array  of curren tly in use  defaults
  25869   "RTN","RCD PEWL0",126 ,0)
  25870    ; Returns : 1 - User  has prefe rred view  if SOURCE  is 'MO' or  is using
  25871   "RTN","RCD PEWL0",127 ,0)
  25872    ;               thei r preferre d view if  SOURCE is  'CV'
  25873   "RTN","RCD PEWL0",128 ,0)
  25874    ;           0 - User  is not us ing their  preferred  view
  25875   "RTN","RCD PEWL0",129 ,0)
  25876    ;          -1 - User  does not  have a pre ferred vie
  25877   "RTN","RCD PEWL0",130 ,0)
  25878    I SOURCE= "MO" Q $S( $D(^TMP("R CERA_PVW", $J)):1,1:- 1)
  25879   "RTN","RCD PEWL0",131 ,0)
  25880    Q:'$D(^TM P("RCERA_P VW",$J)) - 1  ; No st ored prefe rred view
  25881   "RTN","RCD PEWL0",132 ,0)
  25882    Q:$G(^TMP ("RCERA_PA RAMS",$J," RCPOST"))' =$G(^TMP(" RCERA_PVW" ,$J,"RCPOS T")) 0
  25883   "RTN","RCD PEWL0",133 ,0)
  25884    Q:$G(^TMP ("RCERA_PA RAMS",$J," RCAUTOP")) '=$G(^TMP( "RCERA_PVW ",$J,"RCAU TOP")) 0
  25885   "RTN","RCD PEWL0",134 ,0)
  25886    Q:$G(^TMP ("RCERA_PA RAMS",$J," RCMATCH")) '=$G(^TMP( "RCERA_PVW ",$J,"RCMA TCH")) 0
  25887   "RTN","RCD PEWL0",135 ,0)
  25888    Q:$G(^TMP ("RCERA_PA RAMS",$J," RCTYPE"))' =$G(^TMP(" RCERA_PVW" ,$J,"RCTYP E")) 0
  25889   "RTN","RCD PEWL0",136 ,0)
  25890    Q:$G(^TMP ("RCERA_PA RAMS",$J," RCPAYR"))' =$G(^TMP(" RCERA_PVW" ,$J,"RCPAY R")) 0
  25891   "RTN","RCD PEWL0",137 ,0)
  25892    Q:$G(^TMP ("RCERA_PA RAMS",$J," RCPAYMNT") )'=$G(^TMP ("RCERA_PV W",$J,"RCP AYMNT")) 0   ; PRCA*4 .5*321
  25893   "RTN","RCD PEWL0",138 ,0)
  25894    Q 1
  25895   "RTN","RCD PEWL0",139 ,0)
  25896    ;
  25897   "RTN","RCD PEWL0",140 ,0)
  25898   ASKUVW() ; EP from PA RAMS^RCDPE WLA, PARAM S^RCDPEAA1
  25899   "RTN","RCD PEWL0",141 ,0)
  25900    ; Prompts  the user  to see if  they want  to use the ir preferr ed view
  25901   "RTN","RCD PEWL0",142 ,0)
  25902    ; PRCA*4. 5*317 adde d function
  25903   "RTN","RCD PEWL0",143 ,0)
  25904    ; Input:    None
  25905   "RTN","RCD PEWL0",144 ,0)
  25906    ; Returns : 1 - User  wants to  use their  preferred  view
  25907   "RTN","RCD PEWL0",145 ,0)
  25908    ;           0 - User  does not  want to us e their pr eferred vi ew
  25909   "RTN","RCD PEWL0",146 ,0)
  25910    ;          -1 - User  typed '^'
  25911   "RTN","RCD PEWL0",147 ,0)
  25912    N DIR,DTO UT,DUOUT
  25913   "RTN","RCD PEWL0",148 ,0)
  25914    S DIR(0)= "Y"
  25915   "RTN","RCD PEWL0",149 ,0)
  25916    S DIR("A" )="Use pre ferred vie w"
  25917   "RTN","RCD PEWL0",150 ,0)
  25918    S DIR("B" )="N"
  25919   "RTN","RCD PEWL0",151 ,0)
  25920    W !
  25921   "RTN","RCD PEWL0",152 ,0)
  25922    D ^DIR
  25923   "RTN","RCD PEWL0",153 ,0)
  25924    I $D(DTOU T)!$D(DUOU T) Q -1
  25925   "RTN","RCD PEWL0",154 ,0)
  25926    Q:Y 1   ;  response  is YES
  25927   "RTN","RCD PEWL0",155 ,0)
  25928    Q 0
  25929   "RTN","RCD PEWL0",156 ,0)
  25930    ;
  25931   "RTN","RCD PEWL0",157 ,0)
  25932   SAVEPVW ;  Option to  save as Us er Preferr ed View
  25933   "RTN","RCD PEWL0",158 ,0)
  25934    ; PRCA*4. 5*317 adde d subrouti ne
  25935   "RTN","RCD PEWL0",159 ,0)
  25936    ; Input:    ^TMP("RC ERA_PARAMS ")    - Gl obal array  of curren t worklist  settings
  25937   "RTN","RCD PEWL0",160 ,0)
  25938    ; Output    Current  worklist s ettings se t as prefe rred view  (potential ly)
  25939   "RTN","RCD PEWL0",161 ,0)
  25940    N DIR,DTO UT,DUOUT,R CERROR,XX
  25941   "RTN","RCD PEWL0",162 ,0)
  25942    K DIR
  25943   "RTN","RCD PEWL0",163 ,0)
  25944    S DIR(0)= "YA",DIR(" B")="NO"
  25945   "RTN","RCD PEWL0",164 ,0)
  25946    S DIR("A" )="Do you  want to sa ve this as  your pref erred view  (Y/N)? "
  25947   "RTN","RCD PEWL0",165 ,0)
  25948    W !
  25949   "RTN","RCD PEWL0",166 ,0)
  25950    D ^DIR
  25951   "RTN","RCD PEWL0",167 ,0)
  25952    Q:Y'=1
  25953   "RTN","RCD PEWL0",168 ,0)
  25954    S XX=^TMP ("RCERA_PA RAMS",$J," RCPOST")
  25955   "RTN","RCD PEWL0",169 ,0)
  25956    D EN^XPAR (DUZ_";VA( 200,","RCD PE EDI LOC KBOX WORKL IST","ERA_ POSTING_ST ATUS",XX,. RCERROR)
  25957   "RTN","RCD PEWL0",170 ,0)
  25958    S XX=^TMP ("RCERA_PA RAMS",$J," RCAUTOP")
  25959   "RTN","RCD PEWL0",171 ,0)
  25960    D EN^XPAR (DUZ_";VA( 200,","RCD PE EDI LOC KBOX WORKL IST","ERA_ AUTO_POSTI NG",XX,.RC ERROR)
  25961   "RTN","RCD PEWL0",172 ,0)
  25962    S XX=^TMP ("RCERA_PA RAMS",$J," RCMATCH")
  25963   "RTN","RCD PEWL0",173 ,0)
  25964    D EN^XPAR (DUZ_";VA( 200,","RCD PE EDI LOC KBOX WORKL IST","ERA- EFT_MATCH_ STATUS",XX ,.RCERROR)
  25965   "RTN","RCD PEWL0",174 ,0)
  25966    S XX=^TMP ("RCERA_PA RAMS",$J," RCTYPE")
  25967   "RTN","RCD PEWL0",175 ,0)
  25968    D EN^XPAR (DUZ_";VA( 200,","RCD PE EDI LOC KBOX WORKL IST","ERA_ CLAIM_TYPE ",XX,.RCER ROR)
  25969   "RTN","RCD PEWL0",176 ,0)
  25970    S XX=$TR( ^TMP("RCER A_PARAMS", $J,"RCPAYR "),"^",";" )
  25971   "RTN","RCD PEWL0",177 ,0)
  25972    D EN^XPAR (DUZ_";VA( 200,","RCD PE EDI LOC KBOX WORKL IST","ALL_ PAYERS/RAN GE_OF_PAYE RS",XX,.RC ERROR)
  25973   "RTN","RCD PEWL0",178 ,0)
  25974    S XX=^TMP ("RCERA_PA RAMS",$J," RCPAYMNT")                                                    ; P RCA*4.5*32 1
  25975   "RTN","RCD PEWL0",179 ,0)
  25976    D EN^XPAR (DUZ_";VA( 200,","RCD PE EDI LOC KBOX WORKL IST","ERA_ PAYMENT_TY PE",XX,.RC ERROR) ; P RCA*4.5*32 1
  25977   "RTN","RCD PEWL0",180 ,0)
  25978    ;
  25979   "RTN","RCD PEWL0",181 ,0)
  25980    K ^TMP("R CERA_PVW", $J)
  25981   "RTN","RCD PEWL0",182 ,0)
  25982    M ^TMP("R CERA_PVW", $J)=^TMP(" RCERA_PARA MS",$J)  ;  capture n ew preferr ed setting s for comp arison
  25983   "RTN","RCD PEWL0",183 ,0)
  25984    Q
  25985   "RTN","RCD PEWL0",184 ,0)
  25986    ;
  25987   "RTN","RCD PEWL0",185 ,0)
  25988   DTR() ; Da te Range S election
  25989   "RTN","RCD PEWL0",186 ,0)
  25990    ; Input:    ^TMP("RC ERA_PARAMS ",$J,"RCDT ") - Curre nt selecte d Date Ran ge (if any )
  25991   "RTN","RCD PEWL0",187 ,0)
  25992    ; Output:   ^TMP("RC ERA_PARAMS ",$J,"RCDT ") - Updat ed Selecte d Date Ran ge
  25993   "RTN","RCD PEWL0",188 ,0)
  25994    ; Returns : 1 if use r quit or  timed out,  0 otherwi se
  25995   "RTN","RCD PEWL0",189 ,0)
  25996   DTR1 ;
  25997   "RTN","RCD PEWL0",190 ,0)
  25998    N DIR,DTO UT,DTQUIT, DUOUT,Y,FR OM,TO,RCDT RNG
  25999   "RTN","RCD PEWL0",191 ,0)
  26000    S ^TMP("R CERA_PARAM S",$J,"RCD T")="0^"_D T
  26001   "RTN","RCD PEWL0",192 ,0)
  26002    K DIR S D IR(0)="YA"
  26003   "RTN","RCD PEWL0",193 ,0)
  26004    S DIR("A" )="Limit t he selecti on to a da te range w hen the ER A was rece ived?: "
  26005   "RTN","RCD PEWL0",194 ,0)
  26006    S DIR("B" )="NO"
  26007   "RTN","RCD PEWL0",195 ,0)
  26008    S DIR("?" )="Enter Y ES to spec ify a date  range fil ter."
  26009   "RTN","RCD PEWL0",196 ,0)
  26010    W !
  26011   "RTN","RCD PEWL0",197 ,0)
  26012    D ^DIR
  26013   "RTN","RCD PEWL0",198 ,0)
  26014    I $D(DTOU T)!$D(DUOU T) Q 1
  26015   "RTN","RCD PEWL0",199 ,0)
  26016    I Y D  G: DTQUIT DTR 1
  26017   "RTN","RCD PEWL0",200 ,0)
  26018    . S DTQUI T=0
  26019   "RTN","RCD PEWL0",201 ,0)
  26020    . S FROM= $P($G(^TMP ("RCERA_PA RAMS",$J," RCDT")),"^ ",1)
  26021   "RTN","RCD PEWL0",202 ,0)
  26022    . S TO=$P ($G(^TMP(" RCERA_PARA MS",$J,"RC DT")),"^", 2)
  26023   "RTN","RCD PEWL0",203 ,0)
  26024    . W !
  26025   "RTN","RCD PEWL0",204 ,0)
  26026    . S RCDTR NG=$$DTRAN GE(FROM,TO )
  26027   "RTN","RCD PEWL0",205 ,0)
  26028    . I RCDTR NG="^" S D TQUIT=1 Q
  26029   "RTN","RCD PEWL0",206 ,0)
  26030    . S ^TMP( "RCERA_PAR AMS",$J,"R CDT")=RCDT RNG
  26031   "RTN","RCD PEWL0",207 ,0)
  26032    Q 0
  26033   "RTN","RCD PEWL0",208 ,0)
  26034    ;
  26035   "RTN","RCD PEWL0",209 ,0)
  26036   DTRANGE(DE FFROM,DEFT O) ; Asks  for and re turns a Da te Range
  26037   "RTN","RCD PEWL0",210 ,0)
  26038    ; Input:  DEFFROM -  Default FR OM date
  26039   "RTN","RCD PEWL0",211 ,0)
  26040    ;         DEFTO   -  Default TO  date
  26041   "RTN","RCD PEWL0",212 ,0)
  26042    ;Output:  From_Date^ To_Date (Y YYMMDD^YYY DDMM) or " ^" (timeou t or ^ ent ered)
  26043   "RTN","RCD PEWL0",213 ,0)
  26044    ;
  26045   "RTN","RCD PEWL0",214 ,0)
  26046    N DIR,Y,D TOUT,DUOUT ,RCDFR,STA RT
  26047   "RTN","RCD PEWL0",215 ,0)
  26048    S RCQUIT= 0
  26049   "RTN","RCD PEWL0",216 ,0)
  26050    S DIR(0)= "DAE^:"_DT _":E"
  26051   "RTN","RCD PEWL0",217 ,0)
  26052    S DIR("A" )="Earlies t date: "
  26053   "RTN","RCD PEWL0",218 ,0)
  26054    S DIR("?" )="Enter t he start o f the date  range."
  26055   "RTN","RCD PEWL0",219 ,0)
  26056    S:($G(DEF FROM)) DIR ("B")=$$FM TE^XLFDT(D EFFROM,2)
  26057   "RTN","RCD PEWL0",220 ,0)
  26058    D ^DIR
  26059   "RTN","RCD PEWL0",221 ,0)
  26060    I $D(DTOU T)!$D(DUOU T) Q "^"
  26061   "RTN","RCD PEWL0",222 ,0)
  26062    S RCDFR=Y ,START=$$F MTE^XLFDT( RCDFR,"2DZ ")
  26063   "RTN","RCD PEWL0",223 ,0)
  26064    K DIR
  26065   "RTN","RCD PEWL0",224 ,0)
  26066    S DIR(0)= "DAE^"_RCD FR_":"_DT_ ":E"
  26067   "RTN","RCD PEWL0",225 ,0)
  26068    S DIR("A" )="Latest  date: "
  26069   "RTN","RCD PEWL0",226 ,0)
  26070    S DIR("?" ,1)="Enter  the end o f the date  range. Th e ending d ate must b e greater  than "
  26071   "RTN","RCD PEWL0",227 ,0)
  26072    S DIR("?" )="or equa l to "_STA RT_"."
  26073   "RTN","RCD PEWL0",228 ,0)
  26074    S:($G(DEF TO)) DIR(" B")=$$FMTE ^XLFDT(DEF TO,2)
  26075   "RTN","RCD PEWL0",229 ,0)
  26076    D ^DIR
  26077   "RTN","RCD PEWL0",230 ,0)
  26078    I $D(DTOU T)!$D(DUOU T) Q "^"
  26079   "RTN","RCD PEWL0",231 ,0)
  26080    Q (RCDFR_ "^"_Y)
  26081   "RTN","RCD PEWL0",232 ,0)
  26082    ;
  26083   "RTN","RCD PEWL0",233 ,0)
  26084   FILTER(IEN 344P4) ; R eturns 1 i f record i n entry IE N344P4 in  344.4 pass es
  26085   "RTN","RCD PEWL0",234 ,0)
  26086    ; the edi ts for the  worklist  selection  of ERAs
  26087   "RTN","RCD PEWL0",235 ,0)
  26088    ; Paramet ers found  in ^TMP("R CERA_PARAM S",$J)
  26089   "RTN","RCD PEWL0",236 ,0)
  26090    N OK,RCPO ST,RCAUTOP ,RCMATCH,R CTYPE,RCDF R,RCDTO,RC PAYFR,RCPA YMNT,RCPAY TO,RCPAYR, RC0,RC4
  26091   "RTN","RCD PEWL0",237 ,0)
  26092    S OK=1,RC 0=$G(^RCY( 344.4,IEN3 44P4,0)),R C4=$G(^RCY (344.4,IEN 344P4,4))
  26093   "RTN","RCD PEWL0",238 ,0)
  26094    ;
  26095   "RTN","RCD PEWL0",239 ,0)
  26096    S RCMATCH =$G(^TMP(" RCERA_PARA MS",$J,"RC MATCH")),R CPOST=$G(^ TMP("RCERA _PARAMS",$ J,"RCPOST" ))
  26097   "RTN","RCD PEWL0",240 ,0)
  26098    S RCAUTOP =$G(^TMP(" RCERA_PARA MS",$J,"RC AUTOP")),R CTYPE=$G(^ TMP("RCERA _PARAMS",$ J,"RCTYPE" ))
  26099   "RTN","RCD PEWL0",241 ,0)
  26100    S RCDFR=+ $P($G(^TMP ("RCERA_PA RAMS",$J," RCDT")),U) ,RCDTO=+$P ($G(^TMP(" RCERA_PARA MS",$J,"RC DT")),U,2)
  26101   "RTN","RCD PEWL0",242 ,0)
  26102    S RCPAYR= $P($G(^TMP ("RCERA_PA RAMS",$J," RCPAYR")), U),RCPAYFR =$P($G(^TM P("RCERA_P ARAMS",$J, "RCPAYR")) ,U,2),RCPA YTO=$P($G( ^TMP("RCER A_PARAMS", $J,"RCPAYR ")),U,3)
  26103   "RTN","RCD PEWL0",243 ,0)
  26104    S RCPAYMN T=$G(^TMP( "RCERA_PAR AMS",$J,"R CPAYMNT"))     ; PRCA *4.5*321
  26105   "RTN","RCD PEWL0",244 ,0)
  26106    ;
  26107   "RTN","RCD PEWL0",245 ,0)
  26108    ; Post st atus
  26109   "RTN","RCD PEWL0",246 ,0)
  26110    I $S(RCPO ST="B":0,R CPOST="U": $P(RC0,U,1 4),1:'$P(R C0,U,14))  S OK=0 G F Q
  26111   "RTN","RCD PEWL0",247 ,0)
  26112    ; Auto-Po sting stat us
  26113   "RTN","RCD PEWL0",248 ,0)
  26114    I $S(RCAU TOP="B":0, RCAUTOP="A ":($P(RC4, U,2)=""),1 :($P(RC4,U ,2)'=""))  S OK=0 G F Q
  26115   "RTN","RCD PEWL0",249 ,0)
  26116    ; Match s tatus
  26117   "RTN","RCD PEWL0",250 ,0)
  26118    I $S(RCMA TCH="B":0, RCMATCH="N ":$P(RC0,U ,9),1:'$P( RC0,U,9))  S OK=0 G F Q
  26119   "RTN","RCD PEWL0",251 ,0)
  26120    ; Medical /Pharmacy/ Tricare Cl aim
  26121   "RTN","RCD PEWL0",252 ,0)
  26122    ; I $S(RC TYPE="B":0 ,RCTYPE="M ":$$PHARM^ RCDPEWLP(I EN344P4),1 :'$$PHARM^ RCDPEWLP(I EN344P4))  S OK=0 G F Q
  26123   "RTN","RCD PEWL0",253 ,0)
  26124    I RCTYPE' ="A" D  I  'OK G FQ
  26125   "RTN","RCD PEWL0",254 ,0)
  26126    . N RCFLA G
  26127   "RTN","RCD PEWL0",255 ,0)
  26128    . I '$$PA YFLAGS^RCD PEWL7(IEN3 44P4,.RCFL AG) S OK=0  Q
  26129   "RTN","RCD PEWL0",256 ,0)
  26130    . I RCTYP E="P",'RCF LAG("P") S  OK=0 Q
  26131   "RTN","RCD PEWL0",257 ,0)
  26132    . I RCTYP E="T",'RCF LAG("T") S  OK=0 Q
  26133   "RTN","RCD PEWL0",258 ,0)
  26134    . I RCTYP E="M",(RCF LAG("P")!R CFLAG("T") ) S OK=0
  26135   "RTN","RCD PEWL0",259 ,0)
  26136    ; dt rec' d range
  26137   "RTN","RCD PEWL0",260 ,0)
  26138    I $S(RCDF R=0:0,1:$P (RC0,U,7)\ 1<RCDFR) S  OK=0 G FQ
  26139   "RTN","RCD PEWL0",261 ,0)
  26140    I $S(RCDT O=DT:0,1:$ P(RC0,U,7) \1>RCDTO)  S OK=0 G F Q
  26141   "RTN","RCD PEWL0",262 ,0)
  26142    ; Payer n ame
  26143   "RTN","RCD PEWL0",263 ,0)
  26144    I RCPAYR' ="A" D  G: 'OK FQ
  26145   "RTN","RCD PEWL0",264 ,0)
  26146    . N Q
  26147   "RTN","RCD PEWL0",265 ,0)
  26148    . S Q=$$U P^RCDPEARL ($P(RC0,U, 6))
  26149   "RTN","RCD PEWL0",266 ,0)
  26150    . I $S(Q= RCPAYFR:1, Q=RCPAYTO: 1,Q]RCPAYF R:RCPAYTO] Q,1:0) Q
  26151   "RTN","RCD PEWL0",267 ,0)
  26152    . S OK=0
  26153   "RTN","RCD PEWL0",268 ,0)
  26154    ; PRCA*4. 5*321 - St art modifi ed code bl ock
  26155   "RTN","RCD PEWL0",269 ,0)
  26156    ; Zero am ount or pa yment
  26157   "RTN","RCD PEWL0",270 ,0)
  26158    I RCPAYMN T'="B" D   ;
  26159   "RTN","RCD PEWL0",271 ,0)
  26160    . I RCPAY MNT="Z",$P (RC0,U,5)  S OK=0 Q
  26161   "RTN","RCD PEWL0",272 ,0)
  26162    . I RCPAY MNT="P",'$ P(RC0,U,5)  S OK=0
  26163   "RTN","RCD PEWL0",273 ,0)
  26164    ; PRCA*4. 5*321 - En d modified  code bloc k
  26165   "RTN","RCD PEWL0",274 ,0)
  26166    ;
  26167   "RTN","RCD PEWL0",275 ,0)
  26168   FQ Q OK
  26169   "RTN","RCD PEWL0",276 ,0)
  26170    ;
  26171   "RTN","RCD PEWL0",277 ,0)
  26172   SPLIT ; Sp lit line i n ERA list
  26173   "RTN","RCD PEWL0",278 ,0)
  26174    ; input -  RCSCR = i en of 344. 49 and 344 .4
  26175   "RTN","RCD PEWL0",279 ,0)
  26176    N RCLINE, RCZ,RCDA,Q ,Q0,Z,Z0,D IR,X,Y,CT, L,L1,RCONE ,RCQUIT
  26177   "RTN","RCD PEWL0",280 ,0)
  26178    D FULL^VA LM1
  26179   "RTN","RCD PEWL0",281 ,0)
  26180    I $S($P($ G(^RCY(344 .4,RCSCR,4 )),U,2)]"" :1,1:0) D  NOEDIT^RCD PEWLP G SP LITQ   ;pr ca*4.5*298   auto-pos ted ERAs c annot ente r Split/Ed it action
  26181   "RTN","RCD PEWL0",282 ,0)
  26182    I $G(RCSC R("NOEDIT" )) D NOEDI T^RCDPEWL  G SPLITQ
  26183   "RTN","RCD PEWL0",283 ,0)
  26184    W !!,"Sel ect the en try that h as a line  you need t o Split/Ed it",!
  26185   "RTN","RCD PEWL0",284 ,0)
  26186    D SEL^RCD PEWL(.RCDA )
  26187   "RTN","RCD PEWL0",285 ,0)
  26188    S Z=+$O(R CDA(0)) G: '$G(RCDA(Z )) SPLITQ
  26189   "RTN","RCD PEWL0",286 ,0)
  26190    S RCLINE= +RCDA(Z),Z 0=+$O(^TMP ("RCDPE-EO B_WLDX",$J ,Z_".999") ,-1)
  26191   "RTN","RCD PEWL0",287 ,0)
  26192    S RCZ=Z F   S RCZ=$O (^TMP("RCD PE-EOB_WLD X",$J,RCZ) ) Q:'RCZ!( RCZ\1'=Z)   D
  26193   "RTN","RCD PEWL0",288 ,0)
  26194    . S Q=$P( $G(^TMP("R CDPE-EOB_W LDX",$J,RC Z)),U,2)
  26195   "RTN","RCD PEWL0",289 ,0)
  26196    . Q:'Q
  26197   "RTN","RCD PEWL0",290 ,0)
  26198    . S RCZ(R CZ)=Q
  26199   "RTN","RCD PEWL0",291 ,0)
  26200    . S Q0=0  F  S Q0=$O (^RCY(344. 49,RCSCR,1 ,Q,1,Q0))  Q:'Q0  I " 01"[$P($G( ^(Q0,0)),U ,2) K RCZ( RCZ) Q
  26201   "RTN","RCD PEWL0",292 ,0)
  26202    I '$O(RCZ (0)) D  G  SPLITQ
  26203   "RTN","RCD PEWL0",293 ,0)
  26204    . S DIR(0 )="EA",DIR ("A",1)="T his entry  has no lin es availab le to Edit /Split",DI R("A")="PR ESS RETURN  TO CONTIN UE " W ! D  ^DIR K DI R
  26205   "RTN","RCD PEWL0",294 ,0)
  26206    S RCQUIT= 0
  26207   "RTN","RCD PEWL0",295 ,0)
  26208    I $P($G(^ RCY(344.49 ,RCSCR,1,R CLINE,0)), U,13) D  G :RCQUIT SP LITQ
  26209   "RTN","RCD PEWL0",296 ,0)
  26210    . S DIR(" A",1)="WAR NING!  Thi s line has  already b een VERIFI ED",DIR("A ")="Are yo u sure you  want to c ontinue?:  ",DIR(0)=" YA",DIR("B ")="NO" W  ! D ^DIR K  DIR
  26211   "RTN","RCD PEWL0",297 ,0)
  26212    . I Y'=1  S RCQUIT=1
  26213   "RTN","RCD PEWL0",298 ,0)
  26214    S CT=0,CT =CT+1,DIR( "?",CT)="E nter the l ine # that  you want  to split o r edit:",R CONE=1
  26215   "RTN","RCD PEWL0",299 ,0)
  26216    S L=Z F   S L=$O(RCZ (L)) Q:'L   D
  26217   "RTN","RCD PEWL0",300 ,0)
  26218    . S L1=+$ G(^TMP("RC DPE-EOB_WL DX",$J,L))
  26219   "RTN","RCD PEWL0",301 ,0)
  26220    . S CT=CT +1
  26221   "RTN","RCD PEWL0",302 ,0)
  26222    . S DIR(" ?",CT)=$G( ^TMP("RCDP E-EOB_WL", $J,L1,0)), CT=CT+1,DI R("?",CT)= $G(^TMP("R CDPE-EOB_W L",$J,L1+1 ,0)) S RCO NE(1)=$S(R CONE:L,1:" ") S RCONE =0
  26223   "RTN","RCD PEWL0",303 ,0)
  26224    S DIR("?" )=" ",Y=-1
  26225   "RTN","RCD PEWL0",304 ,0)
  26226    I $G(RCON E(1)) S Y= +RCONE(1)  K DIR G:'Y  SPLITQ
  26227   "RTN","RCD PEWL0",305 ,0)
  26228    I '$G(RCO NE(1)) D   K DIR I $D (DTOUT)!$D (DUOUT)!(Y \1'=Z) G S PLITQ
  26229   "RTN","RCD PEWL0",306 ,0)
  26230    . F  S DI R(0)="NAO^ "_(Z+.001) _":"_Z0_": 3",DIR("A" )="Which l ine of ent ry "_Z_" d o you want  to Split/ Edit?: " S :$G(RCONE( 1))'="" DI R("B")=RCO NE(1) D ^D IR Q:'Y!$D (DUOUT)!$D (DTOUT)  D   Q:Y>0
  26231   "RTN","RCD PEWL0",307 ,0)
  26232    .. I '$D( ^TMP("RCDP E-EOB_WLDX ",$J,Y)) W  !!,"Line  "_Y_" does  NOT exist  - TRY AGA IN",! S Y= -1 Q
  26233   "RTN","RCD PEWL0",308 ,0)
  26234    .. I '$D( RCZ(Y)) W  !!,"Line " _Y_" has b een used i n a DISTRI BUTE ADJ a ction and  can't be e dited",! S  Y=-1 Q
  26235   "RTN","RCD PEWL0",309 ,0)
  26236    .. S Q=+$ O(^RCY(344 .49,RCSCR, 1,"B",Y,0) )
  26237   "RTN","RCD PEWL0",310 ,0)
  26238    ;
  26239   "RTN","RCD PEWL0",311 ,0)
  26240    K ^TMP("R CDPE_SPLIT _REBLD",$J )
  26241   "RTN","RCD PEWL0",312 ,0)
  26242    D SPLIT^R CDPEWL3(RC SCR,+Y)
  26243   "RTN","RCD PEWL0",313 ,0)
  26244    I $G(^TMP ("RCDPE_SP LIT_REBLD" ,$J)) K ^T MP("RCDPE_ SPLIT_REBL D",$J) D B LD^RCDPEWL 1($G(^TMP( $J,"RC_SOR TPARM")))
  26245   "RTN","RCD PEWL0",314 ,0)
  26246    ;
  26247   "RTN","RCD PEWL0",315 ,0)
  26248   SPLITQ S V ALMBCK="R"
  26249   "RTN","RCD PEWL0",316 ,0)
  26250    Q
  26251   "RTN","RCD PEWL0",317 ,0)
  26252    ;
  26253   "RTN","RCD PEWL0",318 ,0)
  26254   PRTERA ; V iew/prt
  26255   "RTN","RCD PEWL0",319 ,0)
  26256    N DIC,X,Y ,RCSCR
  26257   "RTN","RCD PEWL0",320 ,0)
  26258    S DIC="^R CY(344.4," ,DIC(0)="A EMQ" D ^DI C
  26259   "RTN","RCD PEWL0",321 ,0)
  26260    Q:Y'>0
  26261   "RTN","RCD PEWL0",322 ,0)
  26262    S RCSCR=+ Y
  26263   "RTN","RCD PEWL0",323 ,0)
  26264    D PRERA1
  26265   "RTN","RCD PEWL0",324 ,0)
  26266    Q
  26267   "RTN","RCD PEWL0",325 ,0)
  26268    ;
  26269   "RTN","RCD PEWL0",326 ,0)
  26270   PRERA ; RC SCR is ass umed to be  defined
  26271   "RTN","RCD PEWL0",327 ,0)
  26272    D FULL^VA LM1 ; Prot ocol entry
  26273   "RTN","RCD PEWL0",328 ,0)
  26274   PRERA1 ; O ption entr y
  26275   "RTN","RCD PEWL0",329 ,0)
  26276    N %ZIS,ZT RTN,ZTSAVE ,ZTDESC,PO P,DIR,X,Y, RCERADET
  26277   "RTN","RCD PEWL0",330 ,0)
  26278    D EXCWARN ^RCDPEWLP( RCSCR)
  26279   "RTN","RCD PEWL0",331 ,0)
  26280    S DIR("?" ,1)="Inclu ding expan ded detail  will sign ificantly  increase t he size of  this repo rt",DIR("? ",2)="IF Y OU CHOOSE  TO INCLUDE  IT, ALL P AYMENT DET AILS FOR E ACH EEOB W ILL BE"
  26281   "RTN","RCD PEWL0",332 ,0)
  26282    S DIR("?" )="listed.   If you w ant just s ummary dat a for each  EEOB, do  NOT includ e it."
  26283   "RTN","RCD PEWL0",333 ,0)
  26284    S DIR(0)= "YA",DIR(" A")="Do yo u want to  include ex panded EEO B detail?:  ",DIR("B" )="NO" W !  D ^DIR K  DIR
  26285   "RTN","RCD PEWL0",334 ,0)
  26286    I $D(DUOU T)!$D(DTOU T) G PRERA Q
  26287   "RTN","RCD PEWL0",335 ,0)
  26288    S RCERADE T=+Y
  26289   "RTN","RCD PEWL0",336 ,0)
  26290    S %ZIS="Q M" D ^%ZIS  G:POP PRE RAQ
  26291   "RTN","RCD PEWL0",337 ,0)
  26292    I $D(IO(" Q")) D  G  PRERAQ
  26293   "RTN","RCD PEWL0",338 ,0)
  26294    . S ZTRTN ="VPERA^RC DPEWL0("_R CSCR_","_R CERADET_") ",ZTDESC=" AR - Print  ERA From  Worklist"
  26295   "RTN","RCD PEWL0",339 ,0)
  26296    . D ^%ZTL OAD
  26297   "RTN","RCD PEWL0",340 ,0)
  26298    . W !!,$S ($D(ZTSK): "Your task  # "_ZTSK_ " has been  queued.", 1:"Unable  to queue t his job.")
  26299   "RTN","RCD PEWL0",341 ,0)
  26300    . K ZTSK, IO("Q") D  HOME^%ZIS
  26301   "RTN","RCD PEWL0",342 ,0)
  26302    U IO
  26303   "RTN","RCD PEWL0",343 ,0)
  26304    D VPERA(R CSCR,RCERA DET)
  26305   "RTN","RCD PEWL0",344 ,0)
  26306    Q
  26307   "RTN","RCD PEWL0",345 ,0)
  26308    ;
  26309   "RTN","RCD PEWL0",346 ,0)
  26310   VPERA(RCSC R,RCERADET ) ; Queued  entry
  26311   "RTN","RCD PEWL0",347 ,0)
  26312    ; RCSCR =  ien of en try in fil e 344.4
  26313   "RTN","RCD PEWL0",348 ,0)
  26314    ; RCERADE T = 1 if i nclusion o f all EOB  details fr om file 36 1.1 is
  26315   "RTN","RCD PEWL0",349 ,0)
  26316    ;  desire d, 0 if no t
  26317   "RTN","RCD PEWL0",350 ,0)
  26318    N Z,Z0,RC STOP,RCZ,R CPG,RCDOT, RCDIQ,RCDI Q1,RCDIQ2, RCXM1,RC,R CSCR1,RC36 11
  26319   "RTN","RCD PEWL0",351 ,0)
  26320    K ^TMP($J ,"RC_SUMRA W"),^TMP($ J,"RC_SUMO UT"),^TMP( $J,"RC_SUM ALL")
  26321   "RTN","RCD PEWL0",352 ,0)
  26322    S (RCSTOP ,RCPG)=0,R CDOT="",$P (RCDOT,"." ,79)=""
  26323   "RTN","RCD PEWL0",353 ,0)
  26324    D GETS^DI Q(344.4,RC SCR_",","* ","IEN","R CDIQ")
  26325   "RTN","RCD PEWL0",354 ,0)
  26326    D TXT0^RC DPEX31(RCS CR,.RCDIQ, .RCXM1,.RC ) ; Get to p level 0- node capti oned flds
  26327   "RTN","RCD PEWL0",355 ,0)
  26328    I $O(^RCY (344.4,RCS CR,2,0)) S  RC=RC+1,R CXM1(RC)="   **ERA LE VEL ADJUST MENTS**"
  26329   "RTN","RCD PEWL0",356 ,0)
  26330    S RCSCR1= 0 F  S RCS CR1=$O(^RC Y(344.4,RC SCR,2,RCSC R1)) Q:'RC SCR1  D
  26331   "RTN","RCD PEWL0",357 ,0)
  26332    . K RCDIQ 2
  26333   "RTN","RCD PEWL0",358 ,0)
  26334    . D GETS^ DIQ(344.42 ,RCSCR1_", "_RCSCR_", ","*","IEN ","RCDIQ2" )
  26335   "RTN","RCD PEWL0",359 ,0)
  26336    . D TXT2^ RCDPEX31(R CSCR,RCSCR 1,.RCDIQ2, .RCXM1,.RC ) ; Get to p level ER A adjs
  26337   "RTN","RCD PEWL0",360 ,0)
  26338    S RCSCR1= 0 F  S RCS CR1=$O(^RC Y(344.4,RC SCR,1,RCSC R1)) Q:'RC SCR1  D
  26339   "RTN","RCD PEWL0",361 ,0)
  26340    . K RCDIQ 1
  26341   "RTN","RCD PEWL0",362 ,0)
  26342    . D GETS^ DIQ(344.41 ,RCSCR1_", "_RCSCR_", ","*","IE" ,"RCDIQ1")   ;PRCA*4. 5*298  nee d to retri eve all fi elds even  if null  ( changed "I EN" to "IE ")
  26343   "RTN","RCD PEWL0",363 ,0)
  26344    . D TXT00 ^RCDPEX31( RCSCR,RCSC R1,.RCDIQ1 ,.RCXM1,.R C)
  26345   "RTN","RCD PEWL0",364 ,0)
  26346    . ;HIPAA  5010
  26347   "RTN","RCD PEWL0",365 ,0)
  26348    . N PNAME 4
  26349   "RTN","RCD PEWL0",366 ,0)
  26350    . S PNAME 4=$$PNM4^R CDPEWL1(RC SCR,RCSCR1 )
  26351   "RTN","RCD PEWL0",367 ,0)
  26352    . I $L(PN AME4)<32 D
  26353   "RTN","RCD PEWL0",368 ,0)
  26354    . .S RC=R C+1,RCXM1( RC-1)=$E(" PATIENT: " _PNAME4_$J ("",41),1, 41)_"CLAIM  #: "_$$BI LLREF^RCDP ESR0(RCSCR ,RCSCR1),R CXM1(RC)="  "
  26355   "RTN","RCD PEWL0",369 ,0)
  26356    . I $L(PN AME4)>31 D
  26357   "RTN","RCD PEWL0",370 ,0)
  26358    . .S RC=R C+1,RCXM1( RC-1)=$J(" ",41)_"CLA IM #: "_$$ BILLREF^RC DPESR0(RCS CR,RCSCR1)
  26359   "RTN","RCD PEWL0",371 ,0)
  26360    . .S RC=R C+1,RCXM1( RC-1)=$E(" PATIENT: " _PNAME4,1, 78),RCXM1( RC)=" "
  26361   "RTN","RCD PEWL0",372 ,0)
  26362    . D PROV^ RCDPEWLD(R CSCR,RCSCR 1,.RCXM1,. RC)
  26363   "RTN","RCD PEWL0",373 ,0)
  26364    . S RC361 1=$P($G(^R CY(344.4,R CSCR,1,RCS CR1,0)),U, 2)
  26365   "RTN","RCD PEWL0",374 ,0)
  26366    . I RCERA DET D
  26367   "RTN","RCD PEWL0",375 ,0)
  26368    .. I 'RC3 611 D  Q
  26369   "RTN","RCD PEWL0",376 ,0)
  26370    ... D DIS P^RCDPESR0 ("^RCY(344 .4,"_RCSCR _",1,"_RCS CR1_",1)", "^TMP($J," "RC_SUMRAW "")",1,"^T MP($J,""RC _SUMOUT"") ",75,1)
  26371   "RTN","RCD PEWL0",377 ,0)
  26372    ..;
  26373   "RTN","RCD PEWL0",378 ,0)
  26374    .. E  D   ; Detail r ecord is i n 361.1
  26375   "RTN","RCD PEWL0",379 ,0)
  26376    ... K ^TM P("PRCA_EO B",$J)
  26377   "RTN","RCD PEWL0",380 ,0)
  26378    ... D GET EOB^IBCECS A6(RC3611, 2)
  26379   "RTN","RCD PEWL0",381 ,0)
  26380    ... I $O( ^IBM(361.1 ,RC3611,"E RR",0)) D  GETERR^RCD PEDS(RC361 1,+$O(^TMP ("PRCA_EOB ",$J,RC361 1," "),-1) ) ; get fi ling error s
  26381   "RTN","RCD PEWL0",382 ,0)
  26382    ... S Z=0  F  S Z=$O (^TMP("PRC A_EOB",$J, RC3611,Z))  Q:'Z  S R C=RC+1,^TM P($J,"RC_S UMOUT",RC) =$G(^TMP(" PRCA_EOB", $J,RC3611, Z))
  26383   "RTN","RCD PEWL0",383 ,0)
  26384    ... S RC= RC+2,^TMP( $J,"RC_SUM OUT",RC-1) =" ",^TMP( $J,"RC_SUM OUT",RC)="  "
  26385   "RTN","RCD PEWL0",384 ,0)
  26386    ... K ^TM P("PRCA_EO B",$J)
  26387   "RTN","RCD PEWL0",385 ,0)
  26388    . I $D(RC DIQ1(344.4 1,RCSCR1_" ,"_RCSCR_" ,",2)) D
  26389   "RTN","RCD PEWL0",386 ,0)
  26390    .. S RC=R C+1,RCXM1( RC)="  **E XCEPTION R ESOLUTION  LOG DATA** "
  26391   "RTN","RCD PEWL0",387 ,0)
  26392    .. S Z=0  F  S Z=$O( RCDIQ1(344 .41,RCSCR1 _","_RCSCR _",",2,Z))  Q:'Z  S R C=RC+1,RCX M1(RC)=RCD IQ1(344.41 ,RCSCR1_", "_RCSCR_", ",2,Z)
  26393   "RTN","RCD PEWL0",388 ,0)
  26394    . S RC=RC +1,RCXM1(R C)=" "
  26395   "RTN","RCD PEWL0",389 ,0)
  26396    . S Z0=+$ O(^TMP($J, "RC_SUMALL "," "),-1)
  26397   "RTN","RCD PEWL0",390 ,0)
  26398    . S Z=0 F   S Z=$O(R CXM1(Z)) Q :'Z  S Z0= Z0+1,^TMP( $J,"RC_SUM ALL",Z0)=R CXM1(Z)
  26399   "RTN","RCD PEWL0",391 ,0)
  26400    . K RCXM1  S RC=0
  26401   "RTN","RCD PEWL0",392 ,0)
  26402    . S Z=0 F   S Z=$O(^ TMP($J,"RC _SUMOUT",Z )) Q:'Z  S  Z0=Z0+1,^ TMP($J,"RC _SUMALL",Z 0)=$G(^TMP ($J,"RC_SU MOUT",Z))
  26403   "RTN","RCD PEWL0",393 ,0)
  26404    S RCSTOP= 0,Z=""
  26405   "RTN","RCD PEWL0",394 ,0)
  26406    F  S Z=$O (^TMP($J," RC_SUMALL" ,Z)) Q:'Z   D  Q:RCST OP
  26407   "RTN","RCD PEWL0",395 ,0)
  26408    . I $D(ZT QUEUED),$$ S^%ZTLOAD  S (RCSTOP, ZTSTOP)=1  K ZTREQ I  +$G(RCPG)  W !!,"***T ASK STOPPE D BY USER* **" Q
  26409   "RTN","RCD PEWL0",396 ,0)
  26410    . I 'RCPG !(($Y+5)>I OSL) D  I  RCSTOP Q
  26411   "RTN","RCD PEWL0",397 ,0)
  26412    .. D:RCPG  ASK(.RCST OP) I RCST OP Q
  26413   "RTN","RCD PEWL0",398 ,0)
  26414    .. D HDR( .RCPG)
  26415   "RTN","RCD PEWL0",399 ,0)
  26416    . W !,$G( ^TMP($J,"R C_SUMALL", Z))
  26417   "RTN","RCD PEWL0",400 ,0)
  26418    ;
  26419   "RTN","RCD PEWL0",401 ,0)
  26420    I 'RCSTOP ,RCPG D AS K(.RCSTOP)
  26421   "RTN","RCD PEWL0",402 ,0)
  26422    ;
  26423   "RTN","RCD PEWL0",403 ,0)
  26424    I $D(ZTQU EUED) S ZT REQ="@"
  26425   "RTN","RCD PEWL0",404 ,0)
  26426    I '$D(ZTQ UEUED) D ^ %ZISC
  26427   "RTN","RCD PEWL0",405 ,0)
  26428    ;
  26429   "RTN","RCD PEWL0",406 ,0)
  26430   PRERAQ K ^ TMP($J,"RC _SUMRAW"), ^TMP($J,"R C_SUMOUT") ,^TMP($J," SUMALL")
  26431   "RTN","RCD PEWL0",407 ,0)
  26432    S VALMBCK ="R"
  26433   "RTN","RCD PEWL0",408 ,0)
  26434    Q
  26435   "RTN","RCD PEWL0",409 ,0)
  26436    ;
  26437   "RTN","RCD PEWL0",410 ,0)
  26438   HDR(RCPG)  ;Report hd r
  26439   "RTN","RCD PEWL0",411 ,0)
  26440    ; RCPG =  last page  #
  26441   "RTN","RCD PEWL0",412 ,0)
  26442    I RCPG!($ E(IOST,1,2 )="C-") W  @IOF,*13
  26443   "RTN","RCD PEWL0",413 ,0)
  26444    S RCPG=$G (RCPG)+1
  26445   "RTN","RCD PEWL0",414 ,0)
  26446    W !,?5,"E DI LOCKBOX  WORKLIST  - ERA DETA IL",?55,$$ FMTE^XLFDT (DT,2),?70 ,"Page: ", RCPG,!,$TR ($J("",IOM )," ","=")
  26447   "RTN","RCD PEWL0",415 ,0)
  26448    Q
  26449   "RTN","RCD PEWL0",416 ,0)
  26450    ;
  26451   "RTN","RCD PEWL0",417 ,0)
  26452   ASK(RCSTOP ) ;
  26453   "RTN","RCD PEWL0",418 ,0)
  26454    I $E(IOST ,1,2)'["C- " Q
  26455   "RTN","RCD PEWL0",419 ,0)
  26456    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T
  26457   "RTN","RCD PEWL0",420 ,0)
  26458    S DIR(0)= "E" W ! D  ^DIR
  26459   "RTN","RCD PEWL0",421 ,0)
  26460    I ($D(DIR UT))!($D(D UOUT)) S R CSTOP=1 Q
  26461   "RTN","RCD PEWL0",422 ,0)
  26462    Q
  26463   "RTN","RCD PEWL0",423 ,0)
  26464    ;
  26465   "RTN","RCD PEWL1")
  26466   0^8^B78442 494
  26467   "RTN","RCD PEWL1",1,0 )
  26468   RCDPEWL1 ; ALB/TMK -  ELECTRONIC  EOB WORKL IST SCREEN  ;Jun 06,  2014@19:11 :19
  26469   "RTN","RCD PEWL1",2,0 )
  26470    ;;4.5;Acc ounts Rece ivable;**1 73,208,222 ,298,304,3 21**;Mar 2 0, 1995;Bu ild 46
  26471   "RTN","RCD PEWL1",3,0 )
  26472    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  26473   "RTN","RCD PEWL1",4,0 )
  26474    ; IA for  read acces s to ^IBM( 361.1 = 40 51
  26475   "RTN","RCD PEWL1",5,0 )
  26476    ; IA for  call to ^D GENA = 381 2
  26477   "RTN","RCD PEWL1",6,0 )
  26478    Q
  26479   "RTN","RCD PEWL1",7,0 )
  26480    ;
  26481   "RTN","RCD PEWL1",8,0 )
  26482   BLD(RCSORT ) ; Build  the detail  display r ecord for  the WL scr atch pad r ecord
  26483   "RTN","RCD PEWL1",9,0 )
  26484    ; Assume  RCSCR = ie n from fil e 344.49
  26485   "RTN","RCD PEWL1",10, 0)
  26486    ; RCSORT  = "" or 'N ' for no s ort  'F' f or 0-pays  first, 'L'  for last
  26487   "RTN","RCD PEWL1",11, 0)
  26488    ;
  26489   "RTN","RCD PEWL1",12, 0)
  26490    N A,A0,B, B0,Q,Q0,Q1 ,QQ,V1,X,Y ,Z,Z0,Z3,Z Z,ZZ1,RCT, RCZ,RCZ0,R CZZ0,RCSA, RCAZ,RCAZ0 ,RCSCT,RCS 1,RCLI1,RC Y34441,RCZ ERO,RCTS,R CTL,RCCL,R CCL1
  26491   "RTN","RCD PEWL1",13, 0)
  26492    N RCECME, RXARRAY,RC 4,RECEIPT, AUTOERA  ; prca*4.5*2 98
  26493   "RTN","RCD PEWL1",14, 0)
  26494    S RCSORT= $P($G(RCSO RT),U),RCS ORT=$S(RCS ORT="":"N" ,1:RCSORT)
  26495   "RTN","RCD PEWL1",15, 0)
  26496    K ^TMP("R CDPE-EOB_W L",$J),^TM P("RCDPE-E OB_WLDX",$ J),^TMP($J ,"RCS"),^T MP("RC_BIL L",$J)
  26497   "RTN","RCD PEWL1",16, 0)
  26498    ;
  26499   "RTN","RCD PEWL1",17, 0)
  26500    S VALMCNT =0
  26501   "RTN","RCD PEWL1",18, 0)
  26502    S Z=0 F   S Z=$O(^RC Y(344.49,R CSCR,1,"B" ,Z)) Q:'Z   I Z#1=0 S  ZZ=+$O(^R CY(344.49, RCSCR,1,"B ",Z,0)) I  ZZ D
  26503   "RTN","RCD PEWL1",19, 0)
  26504    . S RCZ=Z Z,RCZ0=$G( ^RCY(344.4 9,RCSCR,1, ZZ,0)),RCS 1=$P(RCZ0, U,6)
  26505   "RTN","RCD PEWL1",20, 0)
  26506    . ; prca* 4.5*298  p er patch r equirement s, keep co de related  to 
  26507   "RTN","RCD PEWL1",21, 0)
  26508    . ; creat ing/mainta ining batc hes but ju st remove  from execu tion.
  26509   "RTN","RCD PEWL1",22, 0)
  26510    . ;Q:$S(' $G(^TMP("R CBATCH_SEL ECTED",$J) ):0,1:$P(R CZ0,U,14)' =+^TMP("RC BATCH_SELE CTED",$J))   ; Must b e entire E RA or matc h the sele cted batch  to contin ue
  26511   "RTN","RCD PEWL1",23, 0)
  26512    . S RCZER O=$S($P(RC Z0,U,2)["* *ADJ":"-1" ,RCSORT="N ":1,RCSORT ="F":+RCS1 '=0,1:+RCS 1=0)
  26513   "RTN","RCD PEWL1",24, 0)
  26514    . ;
  26515   "RTN","RCD PEWL1",25, 0)
  26516    . ; This  is a top-l evel entry  - find th e sublines
  26517   "RTN","RCD PEWL1",26, 0)
  26518    . S Z0=Z  F  S Z0=$O (^RCY(344. 49,RCSCR,1 ,"B",Z0))  Q:((Z0\1)' =(Z\1))  S  Z=Z0,ZZ1= +$O(^RCY(3 44.49,RCSC R,1,"B",Z0 ,0)) I ZZ1  D
  26519   "RTN","RCD PEWL1",27, 0)
  26520    .. S ^TMP ($J,"RCS", RCZERO,ZZ, ZZ1)=""
  26521   "RTN","RCD PEWL1",28, 0)
  26522    . S ^TMP( $J,"RCS",R CZERO,ZZ)= ""
  26523   "RTN","RCD PEWL1",29, 0)
  26524    ;
  26525   "RTN","RCD PEWL1",30, 0)
  26526    S RCZERO= "",RCTS=0  F  S RCZER O=$O(^TMP( $J,"RCS",R CZERO)) Q: RCZERO=""   S ZZ=0 F   S ZZ=$O(^ TMP($J,"RC S",RCZERO, ZZ)) Q:'ZZ   D
  26527   "RTN","RCD PEWL1",31, 0)
  26528    . N A
  26529   "RTN","RCD PEWL1",32, 0)
  26530    . S RCZ0= $G(^RCY(34 4.49,RCSCR ,1,ZZ,0)), RCY34441=$ G(^RCY(344 .4,RCSCR,1 ,+$P(RCZ0, U,9),0))
  26531   "RTN","RCD PEWL1",33, 0)
  26532    .;  get E CME# and R eceipt fro m EEOB
  26533   "RTN","RCD PEWL1",34, 0)
  26534    . S RC4=$ P($G(^RCY( 344.4,RCSC R,1,+$P(RC Z0,U,9),4) ),U,2,3)
  26535   "RTN","RCD PEWL1",35, 0)
  26536    . S RCECM E=$P(RC4,U )
  26537   "RTN","RCD PEWL1",36, 0)
  26538    . S RECEI PT=$S(+$P( RC4,U,2):$ P($G(^RCY( 344,$P(RC4 ,U,2),0)), U),1:"")
  26539   "RTN","RCD PEWL1",37, 0)
  26540    . ; get a uto-post s tatus
  26541   "RTN","RCD PEWL1",38, 0)
  26542    . S AUTOE RA=$S($P($ G(^RCY(344 .4,RCSCR,4 )),U,2)]"" :1,1:0)
  26543   "RTN","RCD PEWL1",39, 0)
  26544    . ;Filter ing Posted /Unposted  EEOBs (Aut o-Posting  ERAs only)
  26545   "RTN","RCD PEWL1",40, 0)
  26546    . I $G(^T MP($J,"RC_ EEOBPOST") )="P",RECE IPT="" Q
  26547   "RTN","RCD PEWL1",41, 0)
  26548    . I $G(^T MP($J,"RC_ EEOBPOST") )="U",RECE IPT'="" Q
  26549   "RTN","RCD PEWL1",42, 0)
  26550    . S RCTS= RCTS+1,A=$ $TOPLINE(R CZ0,RCTS)
  26551   "RTN","RCD PEWL1",43, 0)
  26552    . D SET(A ,RCTS,RCTS ,ZZ)
  26553   "RTN","RCD PEWL1",44, 0)
  26554    . ; PRCA* 4.5*304 -  Add claim  comment to  screen if  it exists  for this  ERA EEOB d etail line
  26555   "RTN","RCD PEWL1",45, 0)
  26556    . S:$P(RC Z0,U,9)'=" " RCCL=$$G ET1^DIQ(34 4.41,$P(RC Z0,U,9)_", "_RCSCR_", ",4)
  26557   "RTN","RCD PEWL1",46, 0)
  26558    . D:$G(RC CL)'=""  ;  If we hav e a ERA De tail line  comment, d isplay it
  26559   "RTN","RCD PEWL1",47, 0)
  26560    . . D SLI NE^RCDPEAA 2(RCCL,"RC CL1",56,74 )
  26561   "RTN","RCD PEWL1",48, 0)
  26562    . . N TLI NE S TLINE =$J("",8)_ "Claim Com ment: "_RC CL1(1)
  26563   "RTN","RCD PEWL1",49, 0)
  26564    . . D SET (TLINE,RCT S,RCTS,ZZ)
  26565   "RTN","RCD PEWL1",50, 0)
  26566    . . ; If  we have a  second or  third line  for the c omment the n put it o n the scre en
  26567   "RTN","RCD PEWL1",51, 0)
  26568    . . I RCC L1>1 D SET ($J("",8)_ RCCL1(2),R CTS,RCTS,Z Z) I RCCL1 =3 D SET($ J("",8)_RC CL1(3),RCT S,RCTS,ZZ)
  26569   "RTN","RCD PEWL1",52, 0)
  26570    . ; **End  of *304 m odificatio ns**
  26571   "RTN","RCD PEWL1",53, 0)
  26572    . I $P(RC Y34441,U,1 1) D
  26573   "RTN","RCD PEWL1",54, 0)
  26574    .. D SET( "EEOB TRAN SFERRED TO  "_$E($P($ G(^DIC(4,+ $P(RCY3444 1,U,11),0) ),U),1,20) _" "_$$FMT E^XLFDT($P (RCY34441, U,12),"2D" )_" STATUS : "_$$EXTE RNAL^DILFD (344.41,.1 ,"",+$P(RC Y34441,U,1 0)),RCTS,R CTS,ZZ)
  26575   "RTN","RCD PEWL1",55, 0)
  26576    . ;
  26577   "RTN","RCD PEWL1",56, 0)
  26578    . S RCT=R CTS
  26579   "RTN","RCD PEWL1",57, 0)
  26580    . S ZZ1=0  F  S ZZ1= $O(^TMP($J ,"RCS",RCZ ERO,ZZ,ZZ1 )) Q:'ZZ1   D
  26581   "RTN","RCD PEWL1",58, 0)
  26582    .. S RCT= RCT+.001
  26583   "RTN","RCD PEWL1",59, 0)
  26584    .. S RCTL =$L(RCT)
  26585   "RTN","RCD PEWL1",60, 0)
  26586    .. S RCZZ 0=$G(^RCY( 344.49,RCS CR,1,ZZ1,0 ))
  26587   "RTN","RCD PEWL1",61, 0)
  26588    .. S V1=$ S($P(RCZ0, U,2)'["**A DJ":"",$P( $P(RCZ0,U, 2),"ADJ",2 ):"***ADJU STMENT AT  ERA LEVEL" ,1:"*** AD JUSTMENT L INE FOR TO TALS MISMA TCH")
  26589   "RTN","RCD PEWL1",62, 0)
  26590    .. S RCLI 1=$S(V1="" :" Claim # : "_$P(RCZ Z0,U,2)_"  Patient/La st 4: "_$S ($P(RCZZ0, U,7):$$PNM 4("","",$P (RCZZ0,U,7 )),'$P($G( ^RCY(344.4 9,RCSCR,1, ZZ1,2)),U, 3):$$PNM4( +$G(^RCY(3 44.49,RCSC R,0)),RCZ) ,1:"??"),1 :V1)
  26591   "RTN","RCD PEWL1",63, 0)
  26592    .. D SET( $J("",4)_$ P("   ^(V) ",U,$P(RCZ Z0,U,13)+1 )_RCT_RCLI 1,RCTS,RCT ,ZZ1)
  26593   "RTN","RCD PEWL1",64, 0)
  26594    .. I '$P( RCZZ0,U,7) ,$P(RCZ0,U ,2)'["**AD J" D SET($ J("",4+RCT L)_"***CLA IM NOT FOU ND IN YOUR  AR ***",R CTS,RCT,ZZ 1)
  26595   "RTN","RCD PEWL1",65, 0)
  26596    .. I $P(R CZZ0,U,7)  D
  26597   "RTN","RCD PEWL1",66, 0)
  26598    ... N A,R CX,Q
  26599   "RTN","RCD PEWL1",67, 0)
  26600    ... S A(" OA")=$$ORI ^PRCAFN(+$ P(RCZZ0,U, 7)),A("SDT ")=$P($G(^ DGCR(399,+ $P(RCZZ0,U ,7),"U")), U),A("DFN" )=+$P($G(^ (0)),U,2), A("ENRPR") =""
  26601   "RTN","RCD PEWL1",68, 0)
  26602    ... ; Fin d Rx copay  status
  26603   "RTN","RCD PEWL1",69, 0)
  26604    ... S A(" RXCP")=$S( 'A("SDT"): "",1:$$RXS T^IBARXEU( A("DFN"),A ("SDT"))), A("RXCP")= $S($P(A("R XCP"),U)'= "":$P(A("R XCP"),U,2) ,1:"UNKNOW N") ;IA #1 0147
  26605   "RTN","RCD PEWL1",70, 0)
  26606    ... ; Fin d M/T stat us
  26607   "RTN","RCD PEWL1",71, 0)
  26608    ... S RCX =$$LST^DGM TU(A("DFN" ),A("SDT") ),A("M/T") =$P(RCX,U, 4)
  26609   "RTN","RCD PEWL1",72, 0)
  26610    ... S A(" M/T")=$S(' RCX:"??",A ("M/T")="P ":"PEN",A( "M/T")="C" :"YES",A(" M/T")="G": "GMT",A("M /T")="R":" REQ",1:"NO ")
  26611   "RTN","RCD PEWL1",73, 0)
  26612    ... ;
  26613   "RTN","RCD PEWL1",74, 0)
  26614    ... S QQ= "   Billed  Amt: "_$J (A("OA")," ",2)_"   A mt To Post : "_$J(+$P (RCZZ0,U,3 ),"",2)
  26615   "RTN","RCD PEWL1",75, 0)
  26616    ... D SET ($J("",4+R CTL)_"Clai m Bal: "_$ J(+$P($$BI LL^RCJIBFN 2(+$P(RCZZ 0,U,7)),U, 3),"",2)_Q Q,RCTS,RCT ,ZZ1)
  26617   "RTN","RCD PEWL1",76, 0)
  26618    ... S ^TM P("RC_BILL ",$J,$P(RC ZZ0,U,7),R CT)=QQ
  26619   "RTN","RCD PEWL1",77, 0)
  26620    ... S Z3= $J("",4+RC TL)_"Svc D t: "_$S(A( "SDT")'="" :$$FMTE^XL FDT(A("SDT "),2),1:"U NKNOWN")
  26621   "RTN","RCD PEWL1",78, 0)
  26622    ... S Z3= Z3_"  COB:  "_$S($D(^ DGCR(399,+ $P(RCZZ0,U ,7),"I"_($ $COBN(+$P( RCZZ0,U,7) )+1))):"YE S",1:"NO " )
  26623   "RTN","RCD PEWL1",79, 0)
  26624    ... D SET (Z3_"  Rx  Copay: "_$ E(A("RXCP" ),1,17)_"   Means Tst : "_A("M/T "),RCTS,RC T,ZZ1)
  26625   "RTN","RCD PEWL1",80, 0)
  26626    .. ;
  26627   "RTN","RCD PEWL1",81, 0)
  26628    .. D SET( $J("",4+RC TL)_"Payme nt Amt: "_ $J(+$P(RCZ Z0,U,5),"" ,2)_"   To tal Adjust ments: "_$ J(+$P(RCZZ 0,U,8),"", 2)_"  Net:  "_$J($P(R CZZ0,U,5)+ $P(RCZZ0,U ,8),"",2), RCTS,RCT,Z Z1)
  26629   "RTN","RCD PEWL1",82, 0)
  26630    .. I AUTO ERA,$P(RCZ Z0,U,3)>0  D SET($J(" ",9)_"Rece ipt: "_REC EIPT,RCTS, RCT,ZZ1)    ; if auto -posted ER A display  EEOB level  receipt n umber
  26631   "RTN","RCD PEWL1",83, 0)
  26632    .. ; disp lay pharma cy EEOB da ta  
  26633   "RTN","RCD PEWL1",84, 0)
  26634    .. I RCEC ME]"" D PH ARM(RCZZ0, RCECME,RCT ,ZZ1)
  26635   "RTN","RCD PEWL1",85, 0)
  26636    .. ; PRCA *4.5*321 B EGIN
  26637   "RTN","RCD PEWL1",86, 0)
  26638    .. I $P(R CZZ0,U,10) '="" D
  26639   "RTN","RCD PEWL1",87, 0)
  26640    ... D SET ($J("",9)_ "Receipt C omment: "_ $P(RCZZ0,U ,10),RCTS, RCT,ZZ1)
  26641   "RTN","RCD PEWL1",88, 0)
  26642    ... D SET ($J("",9)_ "Added By  User: "_$$ GET1^DIQ(3 44.491,ZZ1 _","_RCSCR _",",2.03) ,RCTS,RCT, ZZ1)
  26643   "RTN","RCD PEWL1",89, 0)
  26644    ... D SET ($J("",9)_ "Date/Time  Added: "_ $$GET1^DIQ (344.491,Z Z1_","_RCS CR_",",2.0 4),RCTS,RC T,ZZ1)
  26645   "RTN","RCD PEWL1",90, 0)
  26646    .. ; PRCA *4.5*321 E ND
  26647   "RTN","RCD PEWL1",91, 0)
  26648    .. I $O(^ RCY(344.49 ,RCSCR,1,Z Z1,1,0)) D
  26649   "RTN","RCD PEWL1",92, 0)
  26650    ... S Z3= ""
  26651   "RTN","RCD PEWL1",93, 0)
  26652    ... D SET ($J("",4+R CTL)_"ADJU STMENTS:", RCTS,RCT,Z Z1)
  26653   "RTN","RCD PEWL1",94, 0)
  26654    ... S RCA Z=0 F  S R CAZ=$O(^RC Y(344.49,R CSCR,1,ZZ1 ,1,RCAZ))  Q:'RCAZ  S  RCAZ0=$G( ^(RCAZ,0))  D
  26655   "RTN","RCD PEWL1",95, 0)
  26656    .... S Z3 =$J("",6+R CTL)_+RCAZ 0_".  ",Q= $L(Z3)
  26657   "RTN","RCD PEWL1",96, 0)
  26658    .... ;
  26659   "RTN","RCD PEWL1",97, 0)
  26660    .... I $P (RCAZ0,U,2 )=0 S Z3=Z 3_"Distrib uted adj d ec for ret raction "_ $P(RCAZ0,U ,4)_": "_$ P(RCAZ0,U, 3)
  26661   "RTN","RCD PEWL1",98, 0)
  26662    .... I $P (RCAZ0,U,2 )=1 S Z3=Z 3_"Adjustm ent distri bution to  balance re ceipt: "_$ P(RCAZ0,U, 3)
  26663   "RTN","RCD PEWL1",99, 0)
  26664    .... ;
  26665   "RTN","RCD PEWL1",100 ,0)
  26666    .... I $P (RCAZ0,U,2 )=2!($P(RC AZ0,U,2)=4 ) D
  26667   "RTN","RCD PEWL1",101 ,0)
  26668    ..... S Z 3=Z3_"ERA  payment ad justed fro m "_$J($P( RCZZ0,U,5) -$P(RCZZ0, U,6),"",2) _" to "_$J (+$P(RCZZ0 ,U,5),"",2 )_"  NET:  "_$J($P(RC ZZ0,U,5)+$ P(RCAZ0,U, 3),"",2)
  26669   "RTN","RCD PEWL1",102 ,0)
  26670    .... I $P (RCAZ0,U,2 )=5 S Z3=Z 3_"Non-spe cific paym ent (ref#  "_$P(RCAZ0 ,U,4)_"):  "_$P(RCAZ0 ,U,3)
  26671   "RTN","RCD PEWL1",103 ,0)
  26672    .... I $P (RCAZ0,U,2 )=3 S Z3=Z 3_"Non-spe cific retr action (re f# "_$P(RC AZ0,U,4)_" ): "_$P(RC AZ0,U,3)
  26673   "RTN","RCD PEWL1",104 ,0)
  26674    .... D SE T(Z3,RCTS, RCT,ZZ1)
  26675   "RTN","RCD PEWL1",105 ,0)
  26676    .... I $P (RCAZ0,U,9 )'="" D SE T($J("",Q) _$P(RCAZ0, U,9),RCTS, RCT,ZZ1)
  26677   "RTN","RCD PEWL1",106 ,0)
  26678    .. ;
  26679   "RTN","RCD PEWL1",107 ,0)
  26680    .. I $P($ G(^TMP($J, "RC_SORTPA RM")),U,2)  D
  26681   "RTN","RCD PEWL1",108 ,0)
  26682    ... S A=$ J("",10)_" REVIEW STA TUS: ("_$S ($P(RCZ0,U ,11)="I":" REVIEW IN  PROCESS",$ P(RCZ0,U,1 1)=1:"REVI EWED",1:"N OT REVIEWE D")
  26683   "RTN","RCD PEWL1",109 ,0)
  26684    ... I $P( RCZ0,U,12)  S A=A_"    SET BY: " _$E($P($G( ^VA(200,$P (RCZ0,U,12 ),0)),U),1 ,20)
  26685   "RTN","RCD PEWL1",110 ,0)
  26686    ... D SET (A_")",+RC TS,RCT,ZZ1 )
  26687   "RTN","RCD PEWL1",111 ,0)
  26688    ... S A=0  F  S A=$O (^RCY(344. 49,RCSCR,1 ,ZZ,4,A))  Q:'A  S A0 =$G(^(A,0) ) D
  26689   "RTN","RCD PEWL1",112 ,0)
  26690    .... D SE T($J("",12 )_$$FMTE^X LFDT($P(A0 ,U),2)_"   "_$P($G(^V A(200,+$P( A0,U,2),0) ),U)_$S($P (A0,U,4):"   LAST EDI T: "_$$FMT E^XLFDT($P (A0,U,4),2 ),1:""),RC TS,RCT,ZZ1 )
  26691   "RTN","RCD PEWL1",113 ,0)
  26692    .... S B= 0 F  S B=$ O(^RCY(344 .49,RCSCR, 1,ZZ,4,A,1 ,B)) Q:'B   S B0=$G(^ (B,0)) D
  26693   "RTN","RCD PEWL1",114 ,0)
  26694    ..... I $ L(B0)>64 D  SET($J("" ,15)_$E(B0 ,1,64),RCT S,RCT,ZZ1)  S B0="  " _$E(B0,65, $L(B0)) ;  Split line  if > 64 c haracters  in comment  line
  26695   "RTN","RCD PEWL1",115 ,0)
  26696    ..... D S ET($J("",1 5)_B0,RCTS ,RCT,ZZ1)
  26697   "RTN","RCD PEWL1",116 ,0)
  26698    .. S A="" ,$P(A,".", 79)="" D S ET(A,RCTS, RCT,ZZ1)
  26699   "RTN","RCD PEWL1",117 ,0)
  26700    ; prca*4. 5*298  per  patch req uirements,  keep code  related t o creating /maintaini ng
  26701   "RTN","RCD PEWL1",118 ,0)
  26702    ; batches  but just  remove fro m executio n.
  26703   "RTN","RCD PEWL1",119 ,0)
  26704    ; I VALMC NT=0 D
  26705   "RTN","RCD PEWL1",120 ,0)
  26706    ;. I $G(^ TMP("RCBAT CH_SELECTE D",$J)) D
  26707   "RTN","RCD PEWL1",121 ,0)
  26708    ;. . D SE T("THERE A RE NO EEOB s ASSIGNED  TO THIS B ATCH")
  26709   "RTN","RCD PEWL1",122 ,0)
  26710    ;. E  D S ET("THERE  ARE NO EEO Bs MATCHIN G YOUR SEL ECTION CRI TERIA")
  26711   "RTN","RCD PEWL1",123 ,0)
  26712    I VALMCNT =0 D SET(" THERE ARE  NO EEOBs M ATCHING YO UR SELECTI ON CRITERI A")
  26713   "RTN","RCD PEWL1",124 ,0)
  26714    K ^TMP($J ,"RCS")
  26715   "RTN","RCD PEWL1",125 ,0)
  26716    Q
  26717   "RTN","RCD PEWL1",126 ,0)
  26718    ;
  26719   "RTN","RCD PEWL1",127 ,0)
  26720   TOPLINE(RC Z0,RCTS) ;  Function  returns th e top line  of the EE OB display
  26721   "RTN","RCD PEWL1",128 ,0)
  26722    ; RCZ0 =  the 0-node  of the wh ole number  entry lin e for the  EEOB
  26723   "RTN","RCD PEWL1",129 ,0)
  26724    ; RCTS =  the select able line  #
  26725   "RTN","RCD PEWL1",130 ,0)
  26726    N A
  26727   "RTN","RCD PEWL1",131 ,0)
  26728    S A=" "_$ S($P(RCZ0, U,13):"(V) ",1:"   ") _"EEOB Seq  #"_$S($P( RCZ0,U,9)[ ",":"'s",1 :"")_" On  ERA: "_$S( $P(RCZ0,U, 9)'="":$P( RCZ0,U,9), 1:"None")_ "   Net Pa yment Amt:  "_$J(+$P( RCZ0,U,6), "",2)
  26729   "RTN","RCD PEWL1",132 ,0)
  26730    I $P($G(^ TMP($J,"RC _SORTPARM" )),U,2) S  A=A_"  Rev iewed?: "_ $S($P(RCZ0 ,U,11)="": "NO",1:$$E XTERNAL^DI LFD(344.49 1,.11,,$P( RCZ0,U,11) ))
  26731   "RTN","RCD PEWL1",133 ,0)
  26732    S A=$E(RC TS_$J("",4 ),1,4)_A
  26733   "RTN","RCD PEWL1",134 ,0)
  26734    Q A
  26735   "RTN","RCD PEWL1",135 ,0)
  26736    ;
  26737   "RTN","RCD PEWL1",136 ,0)
  26738   PHARM(RCZZ 0,RCECME,R CT,ZZ1) ;
  26739   "RTN","RCD PEWL1",137 ,0)
  26740    N RXARRAY
  26741   "RTN","RCD PEWL1",138 ,0)
  26742    D GETPHAR M^RCDPEWLP ($P(RCZZ0, U,7),.RXAR RAY)
  26743   "RTN","RCD PEWL1",139 ,0)
  26744    D SET($J( "",9)_"ECM E #: "_RCE CME,$P(RCZ Z0,U),RCT, ZZ1)
  26745   "RTN","RCD PEWL1",140 ,0)
  26746    I '$D(RXA RRAY) D SE T($J("",9) _" Pharmac y data doe s not exis t for this  claim",$P (RCZZ0,U), RCT,ZZ1) Q
  26747   "RTN","RCD PEWL1",141 ,0)
  26748    D SET($J( "",9)_"Rx/ Fill/Relea se Status:  "_RXARRAY ("RX")_"/" _RXARRAY(" FILL")_"/" _RXARRAY(" RELEASED S TATUS"),$P (RCZZ0,U), RCT,ZZ1)
  26749   "RTN","RCD PEWL1",142 ,0)
  26750    D SET($J( "",9)_"DOS : "_RXARRA Y("DOS"),$ P(RCZZ0,U) ,RCT,ZZ1)
  26751   "RTN","RCD PEWL1",143 ,0)
  26752    Q
  26753   "RTN","RCD PEWL1",144 ,0)
  26754    ;
  26755   "RTN","RCD PEWL1",145 ,0)
  26756   INIT ;
  26757   "RTN","RCD PEWL1",146 ,0)
  26758    S VALMBG= $G(^TMP($J ,"RC_VALMB G"))
  26759   "RTN","RCD PEWL1",147 ,0)
  26760    Q
  26761   "RTN","RCD PEWL1",148 ,0)
  26762    ;
  26763   "RTN","RCD PEWL1",149 ,0)
  26764   HDR ;
  26765   "RTN","RCD PEWL1",150 ,0)
  26766    D HDR^RCD PEWL
  26767   "RTN","RCD PEWL1",151 ,0)
  26768    Q
  26769   "RTN","RCD PEWL1",152 ,0)
  26770    ;
  26771   "RTN","RCD PEWL1",153 ,0)
  26772   FNL ; -- C lean up li st
  26773   "RTN","RCD PEWL1",154 ,0)
  26774    K RCFASTX T
  26775   "RTN","RCD PEWL1",155 ,0)
  26776    Q
  26777   "RTN","RCD PEWL1",156 ,0)
  26778    ;
  26779   "RTN","RCD PEWL1",157 ,0)
  26780   SET(X,RCSE Q,RCSEQ1,R CZ9) ; --  set arrays
  26781   "RTN","RCD PEWL1",158 ,0)
  26782    ; X = the  data to s et into th e global
  26783   "RTN","RCD PEWL1",159 ,0)
  26784    ; RCSEQ =  the selec table line  #
  26785   "RTN","RCD PEWL1",160 ,0)
  26786    ; RCSEQ1  = the sub  line #
  26787   "RTN","RCD PEWL1",161 ,0)
  26788    ; RCZ9 =  reference  to the lin e(s) in fi le 344.41  or to the  subline in
  26789   "RTN","RCD PEWL1",162 ,0)
  26790    ;         file 344.4 9 for RCSE Q having a  decimal
  26791   "RTN","RCD PEWL1",163 ,0)
  26792    S VALMCNT =VALMCNT+1 ,^TMP("RCD PE-EOB_WL" ,$J,VALMCN T,0)=X
  26793   "RTN","RCD PEWL1",164 ,0)
  26794    I $G(RCSE Q) S ^TMP( "RCDPE-EOB _WL",$J,"I DX",VALMCN T,RCSEQ)=" "
  26795   "RTN","RCD PEWL1",165 ,0)
  26796    I $G(RCSE Q1),'$D(^T MP("RCDPE- EOB_WLDX", $J,RCSEQ1) ) S ^TMP(" RCDPE-EOB_ WLDX",$J,R CSEQ1)=VAL MCNT_U_$G( RCZ9)
  26797   "RTN","RCD PEWL1",166 ,0)
  26798    Q
  26799   "RTN","RCD PEWL1",167 ,0)
  26800    ;
  26801   "RTN","RCD PEWL1",168 ,0)
  26802   PNM4(RCIFN ,RCDA,RC)  ; Returns  either the  patient n ame or pat ient name/ last 4
  26803   "RTN","RCD PEWL1",169 ,0)
  26804    ; RCIFN =  ien of fi le 344.4
  26805   "RTN","RCD PEWL1",170 ,0)
  26806    ; RCDA =  ien of fil e 344.41
  26807   "RTN","RCD PEWL1",171 ,0)
  26808    ; RC = th e ien of f ile 430
  26809   "RTN","RCD PEWL1",172 ,0)
  26810    N Z,Z0,Q
  26811   "RTN","RCD PEWL1",173 ,0)
  26812    S Z=""
  26813   "RTN","RCD PEWL1",174 ,0)
  26814    I $G(RCIF N)'="" D
  26815   "RTN","RCD PEWL1",175 ,0)
  26816    . S Z0=$G (^RCY(344. 4,RCIFN,1, RCDA,0)),Z =""
  26817   "RTN","RCD PEWL1",176 ,0)
  26818    . I $P(Z0 ,U,2) S Q= +$P($G(^DG CR(399,+$G (^IBM(361. 1,+$P(Z0,U ,2),0)),0) ),U,2),Z=$ P($G(^DPT( Q,0)),U)_" /"_$E($P($ G(^(0)),U, 9),6,9) ;  IA 4051
  26819   "RTN","RCD PEWL1",177 ,0)
  26820    . I $TR(Z ,"/")="" S  Z=$P(Z0,U ,15)
  26821   "RTN","RCD PEWL1",178 ,0)
  26822    I $G(RC)' ="" D
  26823   "RTN","RCD PEWL1",179 ,0)
  26824    . S Q=+$P ($G(^PRCA( 430,RC,0)) ,U,7)
  26825   "RTN","RCD PEWL1",180 ,0)
  26826    . I Q S Z =$P($G(^DP T(Q,0)),U) _"/"_$E($P ($G(^(0)), U,9),6,9)
  26827   "RTN","RCD PEWL1",181 ,0)
  26828    Q Z
  26829   "RTN","RCD PEWL1",182 ,0)
  26830    ;
  26831   "RTN","RCD PEWL1",183 ,0)
  26832   COBN(RC,A)  ; Return  seq # of s elected pa yer
  26833   "RTN","RCD PEWL1",184 ,0)
  26834    ; A = 'PS T' or null  to get cu rrent bill  payer seq  #
  26835   "RTN","RCD PEWL1",185 ,0)
  26836    I $G(A)=" " S A=$P($ G(^DGCR(39 9,RC,0)),U ,21) S:A=" " A="P" S: "PST"'[A A ="P"
  26837   "RTN","RCD PEWL1",186 ,0)
  26838    I 'A S A= $F("PST",A )-1 S:A<1  A=1
  26839   "RTN","RCD PEWL1",187 ,0)
  26840    Q A
  26841   "RTN","RCD PEWL1",188 ,0)
  26842    ;
  26843   "RTN","RCD PEWL1",189 ,0)
  26844   COPAY(RCIF N)       ;  Returns 1  if any no t cancelle d 1st part y bills ex ist for
  26845   "RTN","RCD PEWL1",190 ,0)
  26846    ; a 3rd p arty bill  or any bil ls related  to this 3 rd party b ill
  26847   "RTN","RCD PEWL1",191 ,0)
  26848    ; RCIFN =  the 3rd p arty bill  #
  26849   "RTN","RCD PEWL1",192 ,0)
  26850    N FIRST,R CTP0,RCTP1 ,RCTP2
  26851   "RTN","RCD PEWL1",193 ,0)
  26852    K ^TMP("I BRBF",$J), ^TMP($J,"I BRBF")
  26853   "RTN","RCD PEWL1",194 ,0)
  26854    D RELBILL ^IBRFN(RCI FN) ; DBIA  3124
  26855   "RTN","RCD PEWL1",195 ,0)
  26856    S RCTP0=0  F  S RCTP 0=$O(^TMP( "IBRBF",$J ,RCIFN,RCT P0)) Q:RCT P0=""  S R CTP1=$G(^( RCTP0)) D
  26857   "RTN","RCD PEWL1",196 ,0)
  26858    . I $P(RC TP1,U,3) K  ^TMP("IBR BF",$J,RCI FN,RCTP0)  Q  ; IB ca ncelled
  26859   "RTN","RCD PEWL1",197 ,0)
  26860    . S RCTP2 =$O(^PRCA( 430,"B",+$ P(RCTP1,U, 4),0)) I $ P($G(^PRCA (430,+RCTP 2,0)),U,8) =39 K ^TMP ("IBRBF",$ J,RCIFN,RC TP0) ; AR  cancelled
  26861   "RTN","RCD PEWL1",198 ,0)
  26862    S FIRST=$ S($O(^TMP( "IBRBF",$J ,RCIFN,0)) :1,1:0)
  26863   "RTN","RCD PEWL1",199 ,0)
  26864    K ^TMP("I BRBF",$J), ^TMP($J,"I BRBF")
  26865   "RTN","RCD PEWL1",200 ,0)
  26866    Q FIRST
  26867   "RTN","RCD PEWL1",201 ,0)
  26868    ;
  26869   "RTN","RCD PEWL3")
  26870   0^7^B88451 997
  26871   "RTN","RCD PEWL3",1,0 )
  26872   RCDPEWL3 ; ALB/TMK/KM L - ELECTR ONIC EOB W ORKLIST AC TIONS ;24- FEB-03
  26873   "RTN","RCD PEWL3",2,0 )
  26874    ;;4.5;Acc ounts Rece ivable;**1 73,276,321 **;Mar 20,  1995;Buil d 46
  26875   "RTN","RCD PEWL3",3,0 )
  26876    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  26877   "RTN","RCD PEWL3",4,0 )
  26878    Q
  26879   "RTN","RCD PEWL3",5,0 )
  26880    ;
  26881   "RTN","RCD PEWL3",6,0 )
  26882   SPLIT(RCSC R,RCL) ; P erform lin e splits
  26883   "RTN","RCD PEWL3",7,0 )
  26884    N Z,Z0,DI R,X,Y,RCL1 ,DA,DR,DIE ,DIC,RCDON E,RCDIR,RC SPLIT,RCTO T,RCOK,RCL INE
  26885   "RTN","RCD PEWL3",8,0 )
  26886    ;
  26887   "RTN","RCD PEWL3",9,0 )
  26888    D CLEAR^V ALM1
  26889   "RTN","RCD PEWL3",10, 0)
  26890    S ^TMP($J ,"RCDPE_SP LIT")=""
  26891   "RTN","RCD PEWL3",11, 0)
  26892    S RCLINE= $G(^TMP("R CDPE-EOB_W LDX",$J,RC L)),RCL1=$ G(^TMP("RC DPE-EOB_WL DX",$J,RCL \1))
  26893   "RTN","RCD PEWL3",12, 0)
  26894    ;
  26895   "RTN","RCD PEWL3",13, 0)
  26896    S Z=+$O(^ TMP("RCDPE -EOB_WLDX" ,$J,RCL)), Z0=+$G(^TM P("RCDPE-E OB_WLDX",$ J,Z)) S:'Z 0 Z0=999
  26897   "RTN","RCD PEWL3",14, 0)
  26898    W !
  26899   "RTN","RCD PEWL3",15, 0)
  26900    F Z=+RCLI NE:1:Z0 Q: '$D(^TMP(" RCDPE-EOB_ WL",$J,Z,0 ))!(Z'<Z0)   W !,^TMP ("RCDPE-EO B_WL",$J,Z ,0)
  26901   "RTN","RCD PEWL3",16, 0)
  26902    ;
  26903   "RTN","RCD PEWL3",17, 0)
  26904    I $E($P(R CL1,U,2),1 ,3)["ADJ"  D  G SPLIT Q
  26905   "RTN","RCD PEWL3",18, 0)
  26906    . W !,"TH IS IS AN E RA-LEVEL A DJUSTMENT  - ONLY THE  ADJUSTMEN T COMMENT  CAN BE EDI TED"
  26907   "RTN","RCD PEWL3",19, 0)
  26908    . S DIR(0 )="A" D ^D IR K DIR
  26909   "RTN","RCD PEWL3",20, 0)
  26910    . S DA(2) =RCSCR,DA( 1)=+$P(RCL INE,U,2),D A=+$P($P(R CL1,U,2)," ADJ",2)
  26911   "RTN","RCD PEWL3",21, 0)
  26912    . Q:'DA
  26913   "RTN","RCD PEWL3",22, 0)
  26914    . D EDITC OM(.DA)
  26915   "RTN","RCD PEWL3",23, 0)
  26916    ;
  26917   "RTN","RCD PEWL3",24, 0)
  26918    S RCDONE= 0,RCDIR(1) =$P($G(^RC Y(344.49,R CSCR,1,+$P (RCLINE,U, 2),0)),U,2 ),RCDIR(2) =$P($G(^RC Y(344.49,R CSCR,1,+$P (RCLINE,U, 2),0)),U,5 ),RCDIR(3) =$P($G(^RC Y(344.49,R CSCR,1,+$P (RCLINE,U, 2),0)),U,8 ),RCDIR(6) =+$P(RCLIN E,U,2)
  26919   "RTN","RCD PEWL3",25, 0)
  26920    S RCDIR=R CDIR(1)_U_ RCDIR(2)_U _RCDIR(3)
  26921   "RTN","RCD PEWL3",26, 0)
  26922    ;
  26923   "RTN","RCD PEWL3",27, 0)
  26924    S RCSPLIT =0
  26925   "RTN","RCD PEWL3",28, 0)
  26926    I $P(RCDI R,U,3) W ! !,"NOTE: T HIS LINE H AS AN ADJU STMENT REC ORD ASSOCI ATED WITH  IT",!
  26927   "RTN","RCD PEWL3",29, 0)
  26928    F  D  Q:R CDONE
  26929   "RTN","RCD PEWL3",30, 0)
  26930    . S RCSPL IT=RCSPLIT +1
  26931   "RTN","RCD PEWL3",31, 0)
  26932    . D EDIT( RCSCR,RCLI NE,.RCDIR, .RCSPLIT," ",.RCDONE)
  26933   "RTN","RCD PEWL3",32, 0)
  26934    . I '$D(R CSPLIT(RCS PLIT)) S R CSPLIT=RCS PLIT-1
  26935   "RTN","RCD PEWL3",33, 0)
  26936    ;
  26937   "RTN","RCD PEWL3",34, 0)
  26938    G:'$O(RCS PLIT(0)) S PLITQ
  26939   "RTN","RCD PEWL3",35, 0)
  26940    N VALMCNT ,VALMBG
  26941   "RTN","RCD PEWL3",36, 0)
  26942    S VALMCNT =0,VALMBG= 1
  26943   "RTN","RCD PEWL3",37, 0)
  26944    S ^TMP($J ,"RCDPE_SP LIT_FILE") =1
  26945   "RTN","RCD PEWL3",38, 0)
  26946    D EN^VALM ("RCDPE EO B WORKLIST  SPLIT")
  26947   "RTN","RCD PEWL3",39, 0)
  26948    ;
  26949   "RTN","RCD PEWL3",40, 0)
  26950   SPLITQ Q
  26951   "RTN","RCD PEWL3",41, 0)
  26952    ;
  26953   "RTN","RCD PEWL3",42, 0)
  26954   TOT(N,RCSP LIT,RCLINE ) ; CALCUL ATE TOTAL  OF PAY (N= 2) or ADJ  (N=3)
  26955   "RTN","RCD PEWL3",43, 0)
  26956    ; RCSPLIT  = the arr ay (passed  by ref) w here the a mounts are  stored
  26957   "RTN","RCD PEWL3",44, 0)
  26958    ; RCLINE  = if editi ng, this i s the line  # NOT to  add in whe n
  26959   "RTN","RCD PEWL3",45, 0)
  26960    ;           determin ing previo us amounts  entered
  26961   "RTN","RCD PEWL3",46, 0)
  26962    N Z,Z0
  26963   "RTN","RCD PEWL3",47, 0)
  26964    S (Z,Z0)= 0
  26965   "RTN","RCD PEWL3",48, 0)
  26966    F  S Z=$O (RCSPLIT(Z )) Q:'Z  I  $S('$G(RC LINE):1,1: RCLINE'=Z)  S Z0=Z0+$ P(RCSPLIT( Z),U,N)
  26967   "RTN","RCD PEWL3",49, 0)
  26968    Q $J(Z0," ",2)
  26969   "RTN","RCD PEWL3",50, 0)
  26970    ;
  26971   "RTN","RCD PEWL3",51, 0)
  26972   UPD(Q,Q1)  ;
  26973   "RTN","RCD PEWL3",52, 0)
  26974    N DA,DIE, DR,X,Y
  26975   "RTN","RCD PEWL3",53, 0)
  26976    S DA(1)=Q ,DA=Q1
  26977   "RTN","RCD PEWL3",54, 0)
  26978    S DIE="^R CY(344.49, "_DA(1)_", 1,",DR="2. 03////"_DU Z_";2.04// //"_$$NOW^ XLFDT() D  ^DIE
  26979   "RTN","RCD PEWL3",55, 0)
  26980    S ^TMP("R CDPE_SPLIT _REBLD",$J )=1
  26981   "RTN","RCD PEWL3",56, 0)
  26982    Q
  26983   "RTN","RCD PEWL3",57, 0)
  26984    ;
  26985   "RTN","RCD PEWL3",58, 0)
  26986   HDR ;
  26987   "RTN","RCD PEWL3",59, 0)
  26988    N Z,Z0,ZC T
  26989   "RTN","RCD PEWL3",60, 0)
  26990    S ZCT=0
  26991   "RTN","RCD PEWL3",61, 0)
  26992    S Z=+$O(^ TMP("RCDPE -EOB_WLDX" ,$J,RCL)), Z0=+$G(^TM P("RCDPE-E OB_WLDX",$ J,Z)) S:'Z 0 Z0=999
  26993   "RTN","RCD PEWL3",62, 0)
  26994    F Z=+RCLI NE:1:Z0 Q: '$D(^TMP(" RCDPE-EOB_ WL",$J,Z,0 ))!(Z'<Z0) !(ZCT'<6)   S ZCT=ZCT +1,VALMHDR (ZCT)=^TMP ("RCDPE-EO B_WL",$J,Z ,0)
  26995   "RTN","RCD PEWL3",63, 0)
  26996    S ZCT=ZCT +1,VALMHDR (ZCT)=" "
  26997   "RTN","RCD PEWL3",64, 0)
  26998    Q
  26999   "RTN","RCD PEWL3",65, 0)
  27000    ;
  27001   "RTN","RCD PEWL3",66, 0)
  27002   FNL ;
  27003   "RTN","RCD PEWL3",67, 0)
  27004    K ^TMP("R CDPE_EOB_S PLIT",$J), ^TMP("RCDP E_EOB_SPLI T_OK",$J), ^TMP("RCDP E_EOB_SPLI TDX",$J)
  27005   "RTN","RCD PEWL3",68, 0)
  27006    Q
  27007   "RTN","RCD PEWL3",69, 0)
  27008    ;
  27009   "RTN","RCD PEWL3",70, 0)
  27010   INIT ; Bui ld screen  for displa y
  27011   "RTN","RCD PEWL3",71, 0)
  27012    ; RCSCR,  RCDIR, RCS PLIT must  already ex ist
  27013   "RTN","RCD PEWL3",72, 0)
  27014    N Z,RCTOT ,DIR,X,Y,R CNT,RCCT,Q ,RCT
  27015   "RTN","RCD PEWL3",73, 0)
  27016    K ^TMP("R CDPE_EOB_S PLIT",$J)
  27017   "RTN","RCD PEWL3",74, 0)
  27018    S (VALMCN T,RCNT)=0
  27019   "RTN","RCD PEWL3",75, 0)
  27020    S ^TMP("R CDPE_EOB_S PLIT_OK",$ J)=1
  27021   "RTN","RCD PEWL3",76, 0)
  27022    F Z=2,3 S  RCTOT(Z)= $$TOT(Z,.R CSPLIT)
  27023   "RTN","RCD PEWL3",77, 0)
  27024    I +RCTOT( 2)'=+$P(RC DIR,U,2)!( +RCTOT(3)' =+$P(RCDIR ,U,3)) D
  27025   "RTN","RCD PEWL3",78, 0)
  27026    . D SET(" **** TOTAL  AMOUNTS E NTERED DO  NOT MATCH  THE ORIGIN AL AMOUNTS  ****",1), SET(" ",1)
  27027   "RTN","RCD PEWL3",79, 0)
  27028    . S ^TMP( "RCDPE_EOB _SPLIT_OK" ,$J)=0
  27029   "RTN","RCD PEWL3",80, 0)
  27030    ;
  27031   "RTN","RCD PEWL3",81, 0)
  27032    S (RCCT,Z ,RCT(1),RC T(2),RCT(3 ))=0
  27033   "RTN","RCD PEWL3",82, 0)
  27034    F  S Z=$O (RCSPLIT(Z )) Q:'Z  D
  27035   "RTN","RCD PEWL3",83, 0)
  27036    . S X="", RCCT=RCCT+ 1
  27037   "RTN","RCD PEWL3",84, 0)
  27038    . S X=$$S ETFLD^VALM 1(RCCT,X," NUM")
  27039   "RTN","RCD PEWL3",85, 0)
  27040    . S X=$$S ETFLD^VALM 1($P(RCSPL IT(Z),U)_$ S('$P(RCSP LIT(Z),U,5 ):" (NOT I N A/R)",1: ""),X,"CLA IM")
  27041   "RTN","RCD PEWL3",86, 0)
  27042    . S X=$$S ETFLD^VALM 1($J(+$P(R CSPLIT(Z), U,2),15,2) ,X,"PAYMEN T"),RCT(1) =RCT(1)+$P (RCSPLIT(Z ),U,2)
  27043   "RTN","RCD PEWL3",87, 0)
  27044    . S X=$$S ETFLD^VALM 1($J(+$P(R CSPLIT(Z), U,3),15,2) ,X,"ADJUST MENT"),RCT (2)=RCT(2) +$P(RCSPLI T(Z),U,3)
  27045   "RTN","RCD PEWL3",88, 0)
  27046    . S X=$$S ETFLD^VALM 1($J($P(RC SPLIT(Z),U ,2)+$P(RCS PLIT(Z),U, 3),15,2),X ,"NET"),RC T(3)=RCT(3 )+$P(RCSPL IT(Z),U,2) +$P(RCSPLI T(Z),U,3)
  27047   "RTN","RCD PEWL3",89, 0)
  27048    . D SET(X ,RCCT)
  27049   "RTN","RCD PEWL3",90, 0)
  27050    . I $P(RC SPLIT(Z),U ,6)'="",$P (RCSPLIT(Z ),U,6)'="@ " S X=$$SE TSTR^VALM1 ($J("",10) _$P(RCSPLI T(Z),U,6), "",1,70) D  SET(X,RCC T)
  27051   "RTN","RCD PEWL3",91, 0)
  27052    S Q="",$P (Q,"=",15) =""
  27053   "RTN","RCD PEWL3",92, 0)
  27054    D SET($J( "",32)_Q_"    "_Q_"    "_Q,RCCT) ,SET($E("     TOTALS:  "_$J("",3 1),1,31)_$ E($J(+RCT( 1),15,2)_$ J("",17),1 ,17)_$E($J (+RCT(2),1 5,2)_$J("" ,17),1,17) _$E($J(+RC T(3),15,2) _$J("",17) ,1,17),RCC T)
  27055   "RTN","RCD PEWL3",93, 0)
  27056    ;
  27057   "RTN","RCD PEWL3",94, 0)
  27058    Q
  27059   "RTN","RCD PEWL3",95, 0)
  27060    ;
  27061   "RTN","RCD PEWL3",96, 0)
  27062   SET(X,RCSE Q) ;
  27063   "RTN","RCD PEWL3",97, 0)
  27064    S VALMCNT =VALMCNT+1
  27065   "RTN","RCD PEWL3",98, 0)
  27066    S ^TMP("R CDPE_EOB_S PLIT",$J,V ALMCNT,0)= X
  27067   "RTN","RCD PEWL3",99, 0)
  27068    S ^TMP("R CDPE_EOB_S PLIT",$J," IDX",VALMC NT,RCSEQ)= ""
  27069   "RTN","RCD PEWL3",100 ,0)
  27070    S ^TMP("R CDPE_EOB_S PLITDX",$J ,RCSEQ)=VA LMCNT
  27071   "RTN","RCD PEWL3",101 ,0)
  27072    Q
  27073   "RTN","RCD PEWL3",102 ,0)
  27074    ;
  27075   "RTN","RCD PEWL3",103 ,0)
  27076   EDITCOM(DA ) ; Edit t he comment  for an ad justment e ntry
  27077   "RTN","RCD PEWL3",104 ,0)
  27078    N RCX,DIE ,X,Y,DR
  27079   "RTN","RCD PEWL3",105 ,0)
  27080    S RCX=$P( $G(^RCY(34 4.49,DA(2) ,1,DA(1),1 ,DA,0)),U, 9)
  27081   "RTN","RCD PEWL3",106 ,0)
  27082    S DIE="^R CY(344.49, "_DA(2)_", 1,"_DA(1)_ ",1,",DR=" .09"
  27083   "RTN","RCD PEWL3",107 ,0)
  27084    D ^DIE
  27085   "RTN","RCD PEWL3",108 ,0)
  27086    Q:$P($G(^ RCY(344.49 ,DA(2),1,D A(1),1,DA, 0)),U,9)=R CX
  27087   "RTN","RCD PEWL3",109 ,0)
  27088    D UPD(DA( 2),DA(1))
  27089   "RTN","RCD PEWL3",110 ,0)
  27090    Q
  27091   "RTN","RCD PEWL3",111 ,0)
  27092    ;
  27093   "RTN","RCD PEWL3",112 ,0)
  27094   EDIT(RCSCR ,RCLINE,RC DIR,RCSPLI T,RCDEF,RC DONE) ; Ed it a split  line
  27095   "RTN","RCD PEWL3",113 ,0)
  27096    ;
  27097   "RTN","RCD PEWL3",114 ,0)
  27098    N CT,DIC, DIR,DIRUT, DTOUT,DUOU T,RCOK,RCL ,X,Y,Z
  27099   "RTN","RCD PEWL3",115 ,0)
  27100    ; Enter c laim #
  27101   "RTN","RCD PEWL3",116 ,0)
  27102    S RCL=$G( RCDIR(6))
  27103   "RTN","RCD PEWL3",117 ,0)
  27104   EDCL ;
  27105   "RTN","RCD PEWL3",118 ,0)
  27106    S DIR("?" ,1)="ENTER  THE CLAIM  # TO WHIC H THE PAYM ENT OR ADJ USTMENT WI LL BE APPL IED."
  27107   "RTN","RCD PEWL3",119 ,0)
  27108    S DIR("?" ,2)="THE C LAIM # DOE S NOT HAVE  TO EXIST  IN YOUR AR  IF THE PA YMENT/ADJU STMENT"
  27109   "RTN","RCD PEWL3",120 ,0)
  27110    S DIR("?" )="BELONGS  TO ANOTHE R SITE."
  27111   "RTN","RCD PEWL3",121 ,0)
  27112    S DIR(0)= "FAO^1:15" ,DIR("A")= "CLAIM #:  "
  27113   "RTN","RCD PEWL3",122 ,0)
  27114    S:$P($G(R CDEF),U)'= "" DIR("B" )=$P(RCDEF ,U)
  27115   "RTN","RCD PEWL3",123 ,0)
  27116    S:$G(RCDI R(1))'=""& ($G(DIR("B "))="") DI R("B")=RCD IR(1)
  27117   "RTN","RCD PEWL3",124 ,0)
  27118    W ! D ^DI R K DIR
  27119   "RTN","RCD PEWL3",125 ,0)
  27120    I $D(DTOU T)!$D(DUOU T) D ABORT  Q
  27121   "RTN","RCD PEWL3",126 ,0)
  27122    I Y="" D   G:'RCDONE  EDCL Q
  27123   "RTN","RCD PEWL3",127 ,0)
  27124    . S DIR(0 )="YA",DIR ("A",1)="Y OU MUST SP LIT THE EN TIRE AMOUN T OF THE L INE."
  27125   "RTN","RCD PEWL3",128 ,0)
  27126    . S DIR(" A",2)=" $" _$J(+RCDIR (2),"",2)_ " PAYMENT  IS LEFT"_$ S($P(RCDIR ,U,3)&$G(R CDIR(3)):"  AND $"_$J (+RCDIR(3) ,"",2)_" A DJ IS LEFT ",1:"")
  27127   "RTN","RCD PEWL3",129 ,0)
  27128    . S DIR(" A")="DO YO U WANT TO  ABORT THIS  SPLIT NOW ?: ",DIR(" B")="NO"
  27129   "RTN","RCD PEWL3",130 ,0)
  27130    . W ! D ^ DIR K DIR
  27131   "RTN","RCD PEWL3",131 ,0)
  27132    . I Y'=0  D ABORT Q
  27133   "RTN","RCD PEWL3",132 ,0)
  27134    S $P(RCSP LIT(RCSPLI T),U)=Y
  27135   "RTN","RCD PEWL3",133 ,0)
  27136    ;
  27137   "RTN","RCD PEWL3",134 ,0)
  27138    I $E(Y,1, 3)?3N,$L(Y )>7,Y'["-"  S Y=$E(Y, 1,3)_"-"_$ E(Y,4,$L(Y ))
  27139   "RTN","RCD PEWL3",135 ,0)
  27140    I $TR(Y,"  ")="" S Y =-1
  27141   "RTN","RCD PEWL3",136 ,0)
  27142    I Y'=-1 S  DIC="^PRC A(430,",DI C(0)="M" D  ^DIC K DI C
  27143   "RTN","RCD PEWL3",137 ,0)
  27144    I +Y>0 D   I 'RCOK K  RCSPLIT(R CSPLIT) G  EDCL
  27145   "RTN","RCD PEWL3",138 ,0)
  27146    . S RCOK= 1
  27147   "RTN","RCD PEWL3",139 ,0)
  27148    . I '$D(^ DGCR(399,+ Y,0)) D  Q     ; prca 276 place  screen to  only allow  selection  of third  party clai ms
  27149   "RTN","RCD PEWL3",140 ,0)
  27150    . . W !,"    THIS IS  NOT A 3RD  PARTY CLA IM. CLAIMS  NEED TO B E 3RD PART Y."
  27151   "RTN","RCD PEWL3",141 ,0)
  27152    . . S RCO K=0
  27153   "RTN","RCD PEWL3",142 ,0)
  27154    . I '$$VA LSTAT^RCDP EM5(+Y) W  !,"  CLAIM  IS IN AN  INCOMPLETE  STATUS. E NTER ANOTH ER CLAIM."  S RCOK=0   ; prca276  do not al low incomp lete claim s
  27155   "RTN","RCD PEWL3",143 ,0)
  27156    I Y<0 D   G:'RCOK ED CL
  27157   "RTN","RCD PEWL3",144 ,0)
  27158    . S RCOK= 1
  27159   "RTN","RCD PEWL3",145 ,0)
  27160    . S DIR(" A")="   TH IS CLAIM W AS NOT FOU ND IN YOUR  AR.  DO Y OU WANT TO  CONTINUE? : ",DIR("B ")="NO",DI R(0)="YA"  D ^DIR K D IR W ! I Y '=1 K RCSP LIT(RCSPLI T) S RCOK= 0
  27161   "RTN","RCD PEWL3",146 ,0)
  27162    E  D
  27163   "RTN","RCD PEWL3",147 ,0)
  27164    . S $P(RC SPLIT(RCSP LIT),U,5)= +Y
  27165   "RTN","RCD PEWL3",148 ,0)
  27166    . W "  >> Current cl aim balanc e is: ",$J (+$P($$BIL L^RCJIBFN2 (+Y),U,3), "",2)
  27167   "RTN","RCD PEWL3",149 ,0)
  27168    ; Enter p ayment
  27169   "RTN","RCD PEWL3",150 ,0)
  27170    S RCDIR(1 )=""
  27171   "RTN","RCD PEWL3",151 ,0)
  27172    S DIR("?" ,1)="***** *********"
  27173   "RTN","RCD PEWL3",152 ,0)
  27174    S CT=1
  27175   "RTN","RCD PEWL3",153 ,0)
  27176    I $P(RCDI R,U,3) D
  27177   "RTN","RCD PEWL3",154 ,0)
  27178    . S DIR(" ?",CT+1)=" SINCE THIS  LINE HAS  AN ADJUSTM ENT, THE A MOUNT ENTE RED HERE S HOULD BE T HE",DIR("? ",CT+2)="C ORRECTED A MOUNT THE  PAYER INDI CATED THEY  SHOULD HA VE PAID FO R THE CLAI M",DIR("?" ,CT+3)=" " ,CT=CT+3
  27179   "RTN","RCD PEWL3",155 ,0)
  27180    S CT=CT+1 ,DIR("?",C T)="ENTER  THE AMT FR OM THE PAY MENT TOTAL  FOR THIS  LINE ("_$J (+$P(RCDIR ,U,2),"",2 )_")"
  27181   "RTN","RCD PEWL3",156 ,0)
  27182    I $G(RCDE F)="" D
  27183   "RTN","RCD PEWL3",157 ,0)
  27184    . S CT=CT +1,DIR("?" ,CT)=" THA T APPLIES  TO THIS CL AIM.  THE  PAYMENT AM OUNT ALREA DY USED FO R THIS"
  27185   "RTN","RCD PEWL3",158 ,0)
  27186    . S CT=CT +1,DIR("?" ,CT)=" LIN E SPLIT IS : "_$J(+$$ TOT(2,.RCS PLIT,$S(RC DEF="":"", 1:RCSPLIT) ),"",2)_"  LEAVING A  BALANCE TO  DISTRIBUT E OF: "_$J ($P(RCDIR, U,2)-$$TOT (2,.RCSPLI T,$S(RCDEF ="":"",1:R CSPLIT))," ",2)
  27187   "RTN","RCD PEWL3",159 ,0)
  27188    S CT=CT+1 ,DIR("?",C T)="THE TO TAL PAYMEN TS ENTERED  DURING TH IS SPLIT M UST EQUAL  THE ORIGIN AL LINE",D IR("?")="  PAYMENT AM OUNT OF $" _$J(+$P(RC DIR,U,2)," ",2)
  27189   "RTN","RCD PEWL3",160 ,0)
  27190    S DIR(0)= "NAO^0:"_$ S(RCDEF="" :$P(RCDIR, U,2)-$$TOT (2,.RCSPLI T,RCSPLIT) ,1:$P(RCDI R,U,2))_": 2"
  27191   "RTN","RCD PEWL3",161 ,0)
  27192    S DIR("A" )="PAYMENT  AMOUNT TO  APPLY TO  THIS CLAIM : " S:$P($ G(RCDEF),U ,2)'="" DI R("B")=$J( +$P(RCDEF, U,2),"",2)  S:$G(RCDI R(2))'=""& ($G(DIR("B "))="") DI R("B")=RCD IR(2) D ^D IR K DIR
  27193   "RTN","RCD PEWL3",162 ,0)
  27194    I $D(DTOU T)!$D(DUOU T) K RCSPL IT(RCSPLIT ) G EDCL
  27195   "RTN","RCD PEWL3",163 ,0)
  27196    S $P(RCSP LIT(RCSPLI T),U,2)=Y, RCDIR(2)=$ J($P(RCDIR ,U,2)-$$TO T(2,.RCSPL IT),"",2)
  27197   "RTN","RCD PEWL3",164 ,0)
  27198    ; Enter a dj
  27199   "RTN","RCD PEWL3",165 ,0)
  27200    I $O(^RCY (344.49,RC SCR,1,+$P( RCLINE,U,2 ),1,0)) D   G:'RCOK E DCL
  27201   "RTN","RCD PEWL3",166 ,0)
  27202    . S RCOK= 1
  27203   "RTN","RCD PEWL3",167 ,0)
  27204    . W !!,$J ("",5)_"TH IS LINE CO NTAINS AN  ADJUSTMENT  AMOUNT OF  $"_$J(+$P (RCDIR,U,3 ),"",2),!, $J("",5)_" THIS AMT I S USUALLY  THE AMT TH E PAYER PR EVIOUSLY P AID",!,$J( "",5),"ON  A CLAIM WH ICH THEY H AVE NOW AM ENDED.  IF  THERE WAS "
  27205   "RTN","RCD PEWL3",168 ,0)
  27206    . W !,$J( "",5)_"AN  AMT PREVIO USLY PAID  FOR THIS C LAIM, ENTE R THAT AMO UNT",!,$J( "",5),"AS  A NEGATIVE  AMOUNT HE RE.",!
  27207   "RTN","RCD PEWL3",169 ,0)
  27208    . S DIR(" ?",1)="*** ********** *"
  27209   "RTN","RCD PEWL3",170 ,0)
  27210    . S DIR(" ?",2)="ENT ER THE AMT  FROM THE  ADJUSTMENT  TOTAL FOR  THIS LINE  ("_$J(+$P (RCDIR,U,3 ),"",2)_") ",DIR("?", 3)=" THAT  APPLIES TO  THIS CLAI M.  THE AD JUSTMENT A MOUNT ALRE ADY USED F OR THIS"
  27211   "RTN","RCD PEWL3",171 ,0)
  27212    . S DIR(" ?",4)=" LI NE SPLIT I S "_$J(+$$ TOT(3,.RCS PLIT,$S(RC DEF="":"", 1:RCSPLIT) ),"",2)_"  LEAVING A  BALANCE OF  "_$J($P(R CDIR,U,3)- $$TOT(3,.R CSPLIT,$S( RCDEF="":" ",1:RCSPLI T)),"",2)_ " TO DISTR IBUTE"
  27213   "RTN","RCD PEWL3",172 ,0)
  27214    . S DIR(" ?",5)=" EN TER IT AS  THE NEGATI VE OF THE  AMT THE PA YER PREVIO USLY PAID  ON THIS CL AIM"
  27215   "RTN","RCD PEWL3",173 ,0)
  27216    . S DIR(" ?",6)="THE  TOTAL ADJ USTMENTS E NTERED DUR ING THIS S PLIT MUST  EQUAL THE  ORIGINAL L INE",DIR(" ?")=" ADJU STMENT AMO UNT OF $"_ $J(+$P(RCD IR,U,3),"" ,2)
  27217   "RTN","RCD PEWL3",174 ,0)
  27218    . S DIR(0 )="NAO^"_$ J($P(RCDIR ,U,3)-$$TO T(3,.RCSPL IT,$S(RCDE F="":"",1: RCSPLIT)), "",2)_":0: 2",DIR("A" )="ADJUSTM ENT AMOUNT : " S:$P($ G(RCDEF),U ,3)'="" DI R("B")=$J( +$P(RCDEF, U,3),"",2)  S:$G(RCDI R(3))'=""& ($G(DIR("B "))="") DI R("B")=RCD IR(3)
  27219   "RTN","RCD PEWL3",175 ,0)
  27220    . D ^DIR  K DIR
  27221   "RTN","RCD PEWL3",176 ,0)
  27222    . I $D(DT OUT)!$D(DU OUT) S RCO K=0 K RCSP LIT(RCSPLI T) Q
  27223   "RTN","RCD PEWL3",177 ,0)
  27224    . S $P(RC SPLIT(RCSP LIT),U,3)= Y,RCDIR(3) =$J($P(RCD IR,U,3)-$$ TOT(3,.RCS PLIT),"",2 )
  27225   "RTN","RCD PEWL3",178 ,0)
  27226    I +RCDIR( 2)=0,+RCDI R(3)=0 S R CDONE=1
  27227   "RTN","RCD PEWL3",179 ,0)
  27228    ; PRCA*4. 5*321 - BE GIN
  27229   "RTN","RCD PEWL3",180 ,0)
  27230    S DIR("A" )="RECEIPT  LINE COMM ENT: "
  27231   "RTN","RCD PEWL3",181 ,0)
  27232    ;Retrieve  comment p reviously  entered fr om RCSPLIT  if presen t
  27233   "RTN","RCD PEWL3",182 ,0)
  27234    I $P($G(R CSPLIT(RCS PLIT)),U,6 )'="" D
  27235   "RTN","RCD PEWL3",183 ,0)
  27236    . I $P(RC SPLIT(RCSP LIT),U,6)' ="@" S DIR ("B")=$P(R CSPLIT(RCS PLIT),U,6)
  27237   "RTN","RCD PEWL3",184 ,0)
  27238    ;Otherwis e retrieve  comment p reviously  filed in s cratchpad
  27239   "RTN","RCD PEWL3",185 ,0)
  27240    E  D
  27241   "RTN","RCD PEWL3",186 ,0)
  27242    . I $P($G (^RCY(344. 49,RCSCR,1 ,+RCL,0)), U,10)'=""  S DIR("B") =$P(^(0),U ,10)
  27243   "RTN","RCD PEWL3",187 ,0)
  27244    ;If non-s uspensed l ine allow  optional f ree text e ntry
  27245   "RTN","RCD PEWL3",188 ,0)
  27246    I $P(RCSP LIT(RCSPLI T),U,5) D
  27247   "RTN","RCD PEWL3",189 ,0)
  27248    . S DIR(0 )="344.491 ,.1AO"
  27249   "RTN","RCD PEWL3",190 ,0)
  27250    . D ^DIR
  27251   "RTN","RCD PEWL3",191 ,0)
  27252    ;if suspe nse force  selection  from drop  down list
  27253   "RTN","RCD PEWL3",192 ,0)
  27254    I '$P(RCS PLIT(RCSPL IT),U,5) S  Y=$$COM^R CDPECH I Y =-1 K RCSP LIT(RCSPLI T) G EDCL
  27255   "RTN","RCD PEWL3",193 ,0)
  27256    ; PRCA*4. 5*321 - EN D
  27257   "RTN","RCD PEWL3",194 ,0)
  27258    ;
  27259   "RTN","RCD PEWL3",195 ,0)
  27260    I Y="",$G (DIR("B")) '="" W "    Comment w ill be del eted"
  27261   "RTN","RCD PEWL3",196 ,0)
  27262    K DIR
  27263   "RTN","RCD PEWL3",197 ,0)
  27264    I $D(DTOU T)!$D(DUOU T) K RCSPL IT(RCSPLIT ) G EDCL
  27265   "RTN","RCD PEWL3",198 ,0)
  27266    S $P(RCSP LIT(RCSPLI T),U,6)=$S (Y="":"@", 1:Y)
  27267   "RTN","RCD PEWL3",199 ,0)
  27268    Q
  27269   "RTN","RCD PEWL3",200 ,0)
  27270    ;
  27271   "RTN","RCD PEWL3",201 ,0)
  27272   ABORT ; Us er aborted  split - k ill split  array
  27273   "RTN","RCD PEWL3",202 ,0)
  27274    N Z
  27275   "RTN","RCD PEWL3",203 ,0)
  27276    S Z=RCSPL IT K RCSPL IT S RCSPL IT=Z,RCDON E=1
  27277   "RTN","RCD PEWL3",204 ,0)
  27278    Q
  27279   "RTN","RCD PEWL3",205 ,0)
  27280    ;
  27281   "RTN","RCD PEWL7")
  27282   0^66^B1239 91907
  27283   "RTN","RCD PEWL7",1,0 )
  27284   RCDPEWL7 ; ALB/TMK/KM L - EDI LO CKBOX WORK LIST ERA D ISPLAY SCR EEN ;Jun 0 6, 2014@19 :11:19
  27285   "RTN","RCD PEWL7",2,0 )
  27286    ;;4.5;Acc ounts Rece ivable;**2 08,222,269 ,276,298,3 04,318,321 **;Mar 20,  1995;Buil d 46
  27287   "RTN","RCD PEWL7",3,0 )
  27288    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  27289   "RTN","RCD PEWL7",4,0 )
  27290    Q
  27291   "RTN","RCD PEWL7",5,0 )
  27292    ;
  27293   "RTN","RCD PEWL7",6,0 )
  27294   BLD(RCSORT ) ; Build  list with  sort crite ria
  27295   "RTN","RCD PEWL7",7,0 )
  27296    ; RCSORT  = the sort  levels to  use to di splay the  data in ^  pieces
  27297   "RTN","RCD PEWL7",8,0 )
  27298    ;  piece  1 = the co des for th e first le vel sort ( sort code; null or -)
  27299   "RTN","RCD PEWL7",9,0 )
  27300    ;  piece  2 = the co des for th e second l evel sort
  27301   "RTN","RCD PEWL7",10, 0)
  27302    ;     sor t code is  the type o f data to  sort by;-  indicates  reverse or der
  27303   "RTN","RCD PEWL7",11, 0)
  27304    N Z,Z1,RC T,RCZ
  27305   "RTN","RCD PEWL7",12, 0)
  27306    S (RCT,VA LMCNT)=0
  27307   "RTN","RCD PEWL7",13, 0)
  27308    I '$D(^TM P($J,"RCER A_LIST"))  D
  27309   "RTN","RCD PEWL7",14, 0)
  27310    . S Z=0 F   S Z=$O(^ TMP("RCDPE -ERA_WLDX" ,$J,Z)) Q: 'Z  S RCZ= $P($G(^(Z) ),U,2) D
  27311   "RTN","RCD PEWL7",15, 0)
  27312    .. I $$FI LTER^RCDPE WL0(RCZ) S  ^TMP($J," RCERA_LIST ",$$SL(RCZ ,$P(RCSORT ,U)),$$SL( RCZ,$P(RCS ORT,U,2)), RCZ)=""
  27313   "RTN","RCD PEWL7",16, 0)
  27314    . K ^TMP( "RCDPE-ERA _WLDX",$J) ,^TMP("RCD PE-ERA_WL" ,$J)
  27315   "RTN","RCD PEWL7",17, 0)
  27316    ;
  27317   "RTN","RCD PEWL7",18, 0)
  27318    S Z=""
  27319   "RTN","RCD PEWL7",19, 0)
  27320    I RCSORT' ["PN;-" D
  27321   "RTN","RCD PEWL7",20, 0)
  27322    . F  S Z= $O(^TMP($J ,"RCERA_LI ST",Z)) Q: Z=""  S Z1 ="" F  S Z 1=$O(^TMP( $J,"RCERA_ LIST",Z,Z1 )) Q:Z1=""   D EXTRAC T(Z,Z1,.RC T)
  27323   "RTN","RCD PEWL7",21, 0)
  27324    ;
  27325   "RTN","RCD PEWL7",22, 0)
  27326    I $P(RCSO RT,U)["PN; -" D
  27327   "RTN","RCD PEWL7",23, 0)
  27328    . F  S Z= $O(^TMP($J ,"RCERA_LI ST",Z),-1)  Q:Z=""  S  Z1="" F   S Z1=$O(^T MP($J,"RCE RA_LIST",Z ,Z1)) Q:Z1 =""  D EXT RACT(Z,Z1, .RCT)
  27329   "RTN","RCD PEWL7",24, 0)
  27330    ;
  27331   "RTN","RCD PEWL7",25, 0)
  27332    I $P(RCSO RT,U,2)["P N;-" D
  27333   "RTN","RCD PEWL7",26, 0)
  27334    . F  S Z= $O(^TMP($J ,"RCERA_LI ST",Z)) Q: Z=""  S Z1 ="" F  S Z 1=$O(^TMP( $J,"RCERA_ LIST",Z,Z1 ),-1) Q:Z1 =""  D EXT RACT(Z,Z1, .RCT)
  27335   "RTN","RCD PEWL7",27, 0)
  27336    ;
  27337   "RTN","RCD PEWL7",28, 0)
  27338    I '$O(^TM P($J,"RCER A_LIST",0) ) D SET("N o ERAs lef t for your  selection  criteria" )
  27339   "RTN","RCD PEWL7",29, 0)
  27340    K ^TMP($J ,"RCERA_LI ST")
  27341   "RTN","RCD PEWL7",30, 0)
  27342    S ^TMP("R CERA_PARAM S",$J,"SOR T")=RCSORT
  27343   "RTN","RCD PEWL7",31, 0)
  27344    Q
  27345   "RTN","RCD PEWL7",32, 0)
  27346    ;
  27347   "RTN","RCD PEWL7",33, 0)
  27348   EXTRACT(RC SRT1,RCSRT 2,RCT) ; E xtract the  data
  27349   "RTN","RCD PEWL7",34, 0)
  27350    ; RCSRT1  = data val ue at 1st  sort level
  27351   "RTN","RCD PEWL7",35, 0)
  27352    ; RCSRT2  = data val ue at 2nd  sort level
  27353   "RTN","RCD PEWL7",36, 0)
  27354    ; RCT = r unning ent ry counter  - returne d if passe d by ref
  27355   "RTN","RCD PEWL7",37, 0)
  27356    N AUTOCOM P,FIRST,RC 0,RCEFT,RC EXCEP,RCPO ST,RCSTAT, RCZ,X,XX,Z ,Z0 ;PRCA* 4.5*318 Va riable XX  added
  27357   "RTN","RCD PEWL7",38, 0)
  27358    S RCZ=0 F   S RCZ=$O (^TMP($J," RCERA_LIST ",RCSRT1,R CSRT2,RCZ) ) Q:'RCZ   D
  27359   "RTN","RCD PEWL7",39, 0)
  27360    . S RCT=R CT+1,RC0=$ G(^RCY(344 .4,RCZ,0))
  27361   "RTN","RCD PEWL7",40, 0)
  27362    . S RCEFT =+$O(^RCY( 344.31,"AE RA",RCZ,0) )
  27363   "RTN","RCD PEWL7",41, 0)
  27364    . S RCEXC EP=$$XCEPT ^RCDPEWLP( RCZ)  ; pr ca*4.5*298   assignme nt of ERA  exception  flag
  27365   "RTN","RCD PEWL7",42, 0)
  27366    . S AUTOC OMP=$S($P( $G(^RCY(34 4.4,RCZ,4) ),U,2)=2:" A",1:"")    ;prca*4.5 *298  AUTO -POSTED CO MPLETE ind icator ("A ")
  27367   "RTN","RCD PEWL7",43, 0)
  27368    . S RCSTA T=$S('RCEF T:U_$S($P( RC0,U,15)= "CHK":"(CH ECK PAYMEN T EXPECTED )",$P(RC0, U,15)="NON ":"(NO PAY MENT EXPEC TED)",$P(R C0,U,9)=2: "(CHECK PA YMENT CHOS EN)",1:"N/ A"),1:$$FM SSTAT^RCDP UREC(+$P($ G(^RCY(344 .31,RCEFT, 0)),U,9)))
  27369   "RTN","RCD PEWL7",44, 0)
  27370    . S RCPOS T=$S(RCEFT :"EFT RECE IPT STATUS : ",1:"")_ $P(RCSTAT, U,2)
  27371   "RTN","RCD PEWL7",45, 0)
  27372    . ;prca*4 .5*298 inc lude Auto- Post Compl ete indica tor and ER A exceptio n flag in  $SELECT st atement
  27373   "RTN","RCD PEWL7",46, 0)
  27374    . S X=$E( RCT_$J("", 5),1,5)_"   "_$S(RCEX CEP]"":RCE XCEP,AUTOC OMP]"":AUT OCOMP,$D(^ RCY(344.49 ,RCZ)):" " ,1:"-")_$E ($P(RC0,U) _$J("",10) ,1,10)_"   "_$E($P(RC 0,U,2)_$J( "",50),1,5 0)
  27375   "RTN","RCD PEWL7",47, 0)
  27376    . D SET(X ,RCT,RCZ)
  27377   "RTN","RCD PEWL7",48, 0)
  27378    . S X=$J( "",40)_$J( $$FMTE^XLF DT($P(RC0, U,7),"2D") ,8)_$J("", 5)_$J(+$P( RC0,U,5),1 2,2)
  27379   "RTN","RCD PEWL7",49, 0)
  27380    . S $E(X, 73,80)=$$F MTE^XLFDT( $P(RC0,U,7 ),"2D")
  27381   "RTN","RCD PEWL7",50, 0)
  27382    . D SET(X ,RCT,RCZ)
  27383   "RTN","RCD PEWL7",51, 0)
  27384    . S X=$J( "",12)_$E( $P(RC0,U,6 )_$J("",30 ),1,30)_"   APPROX #  EEOBs: "_+ $$CTEEOB^R CDPEWLB(RC Z)
  27385   "RTN","RCD PEWL7",52, 0)
  27386    . D SET(X ,RCT,RCZ)
  27387   "RTN","RCD PEWL7",53, 0)
  27388    . S XX=$$ EXTERNAL^D ILFD(344.4 ,.09,"",$P (RC0,U,9))
  27389   "RTN","RCD PEWL7",54, 0)
  27390    . S:$$UNB AL^RCDPEAP 1(RCZ) XX= XX_" - UNB ALANCED" ; PRCA*4.5*3 18 added l ine 
  27391   "RTN","RCD PEWL7",55, 0)
  27392    . S X=$J( "",12)_$E( XX_$J("",3 0),1,30)_"   "_RCPOST  ;PRCA*4.5 *318 modif ied line 
  27393   "RTN","RCD PEWL7",56, 0)
  27394    . D SET(X ,RCT)
  27395   "RTN","RCD PEWL7",57, 0)
  27396    . D SET("  ",RCT)
  27397   "RTN","RCD PEWL7",58, 0)
  27398    ;.; prca* 4.5*298  p er patch r equirement s, keep co de related  to
  27399   "RTN","RCD PEWL7",59, 0)
  27400    ;. ; crea ting/maint aining bat ches but j ust remove  from exec ution.
  27401   "RTN","RCD PEWL7",60, 0)
  27402    ;. ;I $G( ^TMP("RCER A_PARAMS", $J,"BATCHO N")) D
  27403   "RTN","RCD PEWL7",61, 0)
  27404    ;.. ;S Z= 0 F  S Z=$ O(^RCY(344 .49,RCZ,3, Z)) Q:'Z   S Z0=$G(^( Z,0)) I Z0 '="" D
  27405   "RTN","RCD PEWL7",62, 0)
  27406    ;...; S X =$J("",12) _$E("- BAT CH #"_$P(Z 0,U)_$J("" ,4),1,13)_ " "_$E($P( Z0,U,2)_$J ("",30),1, 30)_"  "_$ S('$P(Z0,U ,3):"NOT " ,1:"")_"RE ADY TO POS T"
  27407   "RTN","RCD PEWL7",63, 0)
  27408    ;... ;D S ET(X,RCT)
  27409   "RTN","RCD PEWL7",64, 0)
  27410    ;
  27411   "RTN","RCD PEWL7",65, 0)
  27412    S VALMSG= "|'-' No s cratchpad| 'x' EXC |' A' autopos t complete "
  27413   "RTN","RCD PEWL7",66, 0)
  27414    ;
  27415   "RTN","RCD PEWL7",67, 0)
  27416    Q
  27417   "RTN","RCD PEWL7",68, 0)
  27418    ;
  27419   "RTN","RCD PEWL7",69, 0)
  27420   SL(Y,SORT)  ; Returns  data for  sort level  from entr y Y in fil e 344.4
  27421   "RTN","RCD PEWL7",70, 0)
  27422    ; SORT =  the sort d ata in ';'  delimited  pieces
  27423   "RTN","RCD PEWL7",71, 0)
  27424    ;    pc 1  = code fo r sort dat a
  27425   "RTN","RCD PEWL7",72, 0)
  27426    ;    pc 2  = the ord er request ed (- or n ull)
  27427   "RTN","RCD PEWL7",73, 0)
  27428    ;
  27429   "RTN","RCD PEWL7",74, 0)
  27430    N RC0,DAT ,SORT1,SOR T2
  27431   "RTN","RCD PEWL7",75, 0)
  27432    S SORT1=$ P(SORT,";" ),SORT2=$P (SORT,";", 2)
  27433   "RTN","RCD PEWL7",76, 0)
  27434    S RC0=$G( ^RCY(344.4 ,Y,0)),DAT =" "
  27435   "RTN","RCD PEWL7",77, 0)
  27436    ; No sort
  27437   "RTN","RCD PEWL7",78, 0)
  27438    I SORT=""  G SLQ
  27439   "RTN","RCD PEWL7",79, 0)
  27440    ; Amt pai d
  27441   "RTN","RCD PEWL7",80, 0)
  27442    I SORT1=" AP" D  G S LQ
  27443   "RTN","RCD PEWL7",81, 0)
  27444    . S DAT=S ORT2_+$P(R C0,U,5)
  27445   "RTN","RCD PEWL7",82, 0)
  27446    ; ERA dat e pd
  27447   "RTN","RCD PEWL7",83, 0)
  27448    I SORT1=" DP" D  G S LQ
  27449   "RTN","RCD PEWL7",84, 0)
  27450    . S DAT=S ORT2_($P(R C0,U,4)\1)
  27451   "RTN","RCD PEWL7",85, 0)
  27452    ; Payer n ame
  27453   "RTN","RCD PEWL7",86, 0)
  27454    I SORT1=" PN" D  G S LQ
  27455   "RTN","RCD PEWL7",87, 0)
  27456    . S DAT=$ $UP^RCDPEA RL($P(RC0, U,6))
  27457   "RTN","RCD PEWL7",88, 0)
  27458    ; ERA dat e received
  27459   "RTN","RCD PEWL7",89, 0)
  27460    I SORT1=" DR" D  G S LQ
  27461   "RTN","RCD PEWL7",90, 0)
  27462    . S DAT=S ORT2_($P(R C0,U,7)\1)
  27463   "RTN","RCD PEWL7",91, 0)
  27464    ;
  27465   "RTN","RCD PEWL7",92, 0)
  27466   SLQ Q $S(D AT'="":DAT ,1:" ")
  27467   "RTN","RCD PEWL7",93, 0)
  27468    ;
  27469   "RTN","RCD PEWL7",94, 0)
  27470   INIT ; Ent ry point f or List te mplate to  build the  display of  ERAs
  27471   "RTN","RCD PEWL7",95, 0)
  27472    ;
  27473   "RTN","RCD PEWL7",96, 0)
  27474    ; Paramet ers for se lecting ER As to be i ncluded in  the list  are
  27475   "RTN","RCD PEWL7",97, 0)
  27476    ; contain ed in the  global ^TM P("RCERA_P ARAMS",$J, parameter  name)
  27477   "RTN","RCD PEWL7",98, 0)
  27478    ;
  27479   "RTN","RCD PEWL7",99, 0)
  27480    N RCZ,RC0 ,RCT,RCTT, RCQUIT,RCD TFR,RCDTTO ,DTOUT,DUO UT,DIR,X,Y ,Z,Z1,RCPO ST,RCEFT,R CINDX,QFLG
  27481   "RTN","RCD PEWL7",100 ,0)
  27482    D CLEAN^V ALM10
  27483   "RTN","RCD PEWL7",101 ,0)
  27484    K ^TMP("R CDPE-ERA_W L",$J),^TM P("RCDPE-E RA_WLDX",$ J),^TMP($J ,"RCERA_LI ST")
  27485   "RTN","RCD PEWL7",102 ,0)
  27486    ;
  27487   "RTN","RCD PEWL7",103 ,0)
  27488    S (RCT,RC TT,RCQUIT) =0
  27489   "RTN","RCD PEWL7",104 ,0)
  27490    ;
  27491   "RTN","RCD PEWL7",105 ,0)
  27492    S RCDTFR= +$P($G(^TM P("RCERA_P ARAMS",$J, "RCDT")),U ),RCDTTO=$ S($P($G(^T MP("RCERA_ PARAMS",$J ,"RCDT")), U,2):$P(^( "RCDT"),U, 2),1:DT)
  27493   "RTN","RCD PEWL7",106 ,0)
  27494    ;
  27495   "RTN","RCD PEWL7",107 ,0)
  27496    S RCINDX= $S(RCDTFR: RCDTFR-.00 000001,1:0 )
  27497   "RTN","RCD PEWL7",108 ,0)
  27498    W !!,"SEA RCHING, PL EASE STAND BY (PRESS  '^' TO QUI T SEARCH)" ,!!
  27499   "RTN","RCD PEWL7",109 ,0)
  27500    F  S RCIN DX=$O(^RCY (344.4,"AF D",RCINDX) ) Q:'RCIND X!(RCINDX\ 1>RCDTTO)! RCQUIT  S  RCZ=0 F  S  RCZ=$O(^R CY(344.4," AFD",RCIND X,RCZ)) Q: 'RCZ  D  Q :RCQUIT
  27501   "RTN","RCD PEWL7",110 ,0)
  27502    . S RCTT= RCTT+1
  27503   "RTN","RCD PEWL7",111 ,0)
  27504    . I (RCTT #10000=0)  D  Q:RCQUI T=1
  27505   "RTN","RCD PEWL7",112 ,0)
  27506    . . S RCT T=0
  27507   "RTN","RCD PEWL7",113 ,0)
  27508    . . D WAI T^DICD
  27509   "RTN","RCD PEWL7",114 ,0)
  27510    . . D INI TKB^XGF ;  supported  by DBIA 31 73
  27511   "RTN","RCD PEWL7",115 ,0)
  27512    . . S QFL G=$$READ^X GF(1,1)
  27513   "RTN","RCD PEWL7",116 ,0)
  27514    . . Q:$G( DTOUT)
  27515   "RTN","RCD PEWL7",117 ,0)
  27516    . . S:QFL G="^" RCQU IT=1 Q
  27517   "RTN","RCD PEWL7",118 ,0)
  27518    . . I $D( DUOUT)!(Y= 0) S RCQUI T=1 Q
  27519   "RTN","RCD PEWL7",119 ,0)
  27520    . . D RES ETKB^XGF
  27521   "RTN","RCD PEWL7",120 ,0)
  27522    . ;
  27523   "RTN","RCD PEWL7",121 ,0)
  27524    . S RC0=$ G(^RCY(344 .4,RCZ,0))
  27525   "RTN","RCD PEWL7",122 ,0)
  27526    . I $$FIL TER^RCDPEW L0(RCZ) S  ^TMP($J,"R CERA_LIST" ,$$SL(RCZ, "DR"),$$SL (RCZ,""),R CZ)=""
  27527   "RTN","RCD PEWL7",123 ,0)
  27528    ;
  27529   "RTN","RCD PEWL7",124 ,0)
  27530    ; Output  the list
  27531   "RTN","RCD PEWL7",125 ,0)
  27532    I 'RCQUIT  D
  27533   "RTN","RCD PEWL7",126 ,0)
  27534    . D:$D(^T MP($J,"RCE RA_LIST"))  BLD("DR^N ")
  27535   "RTN","RCD PEWL7",127 ,0)
  27536    . ; If no  ERAs foun d display  the messag e below in  the list  area
  27537   "RTN","RCD PEWL7",128 ,0)
  27538    . I '$O(^ TMP("RCDPE -ERA_WL",$ J,0)) D
  27539   "RTN","RCD PEWL7",129 ,0)
  27540    . . S ^TM P("RCDPE-E RA_WL",$J, 1,0)="THER E ARE NO E RAs MATCHI NG YOUR SE LECTION CR ITERIA" S  VALMCNT=2
  27541   "RTN","RCD PEWL7",130 ,0)
  27542    I RCQUIT  K ^TMP("RC DPE-ERA_WL ",$J),^TMP ("RCDPE-ER A_WLDX",$J ),^TMP($J, "RCERA_LIS T") S VALM QUIT=""
  27543   "RTN","RCD PEWL7",131 ,0)
  27544    Q
  27545   "RTN","RCD PEWL7",132 ,0)
  27546    ;
  27547   "RTN","RCD PEWL7",133 ,0)
  27548   HDR ; Head er for ERA  Worklist  (List user  Current S creen View  selection s)
  27549   "RTN","RCD PEWL7",134 ,0)
  27550    ; Input:  ^TMP("RCER A_PARAMS", $J)
  27551   "RTN","RCD PEWL7",135 ,0)
  27552    ; Output:  VALMHDR
  27553   "RTN","RCD PEWL7",136 ,0)
  27554    N X,XX,XX 2
  27555   "RTN","RCD PEWL7",137 ,0)
  27556    ;
  27557   "RTN","RCD PEWL7",138 ,0)
  27558    ; PRCA*4. 5*321 - To tal re-wri te of head er subrout ine to add  new filte rs and sho rten lines  etc.
  27559   "RTN","RCD PEWL7",139 ,0)
  27560    ; First h eader line . Date ran ge and Pha rmacy/Tric are/Medica l
  27561   "RTN","RCD PEWL7",140 ,0)
  27562    S X=$G(^T MP("RCERA_ PARAMS",$J ,"RCDT"))
  27563   "RTN","RCD PEWL7",141 ,0)
  27564    S XX="DAT E RANGE  :  "
  27565   "RTN","RCD PEWL7",142 ,0)
  27566    I $P(X,U)  D  ;
  27567   "RTN","RCD PEWL7",143 ,0)
  27568    . S XX=XX _$$FMTE^XL FDT($P(X,U ),2)
  27569   "RTN","RCD PEWL7",144 ,0)
  27570    . I $P(X, U,2) S XX= XX_"-"_$$F MTE^XLFDT( $P(X,U,2), 2)
  27571   "RTN","RCD PEWL7",145 ,0)
  27572    E  S XX=X X_"NONE SE LECTED"
  27573   "RTN","RCD PEWL7",146 ,0)
  27574    S X=$G(^T MP("RCERA_ PARAMS",$J ,"RCTYPE") )
  27575   "RTN","RCD PEWL7",147 ,0)
  27576    S XX2="PH ARM/TRIC/M EDICAL: "
  27577   "RTN","RCD PEWL7",148 ,0)
  27578    S XX2=XX2 _$S(X="M": "MEDICAL O NLY",X="P" :"PHARMACY  ONLY",X=" T":"TRICAR E ONLY",1: "ALL")
  27579   "RTN","RCD PEWL7",149 ,0)
  27580    S XX=$$SE TSTR^VALM1 (XX2,XX,40 ,41)
  27581   "RTN","RCD PEWL7",150 ,0)
  27582    S VALMHDR (1)=XX
  27583   "RTN","RCD PEWL7",151 ,0)
  27584    ;
  27585   "RTN","RCD PEWL7",152 ,0)
  27586    ; Second  header lin e. Match/U nmatched a nd Auto-po sting/Non  Autopostin g
  27587   "RTN","RCD PEWL7",153 ,0)
  27588    S X=$G(^T MP("RCERA_ PARAMS",$J ,"RCMATCH" ))
  27589   "RTN","RCD PEWL7",154 ,0)
  27590    S XX="MAT CH STATUS:  "_$S(X="N ":"NOT MAT CHED",X="M ":"MATCHED ",1:"BOTH" )
  27591   "RTN","RCD PEWL7",155 ,0)
  27592    S X=$G(^T MP("RCERA_ PARAMS",$J ,"RCAUTOP" ))
  27593   "RTN","RCD PEWL7",156 ,0)
  27594    S XX2="AU TO-POSTING : "
  27595   "RTN","RCD PEWL7",157 ,0)
  27596    S XX2=XX2 _$S(X="A": "AUTO-POST ING ONLY", X="N":"NON  AUTO-POST ING ONLY", 1:"BOTH")
  27597   "RTN","RCD PEWL7",158 ,0)
  27598    S XX=$$SE TSTR^VALM1 (XX2,XX,46 ,35)
  27599   "RTN","RCD PEWL7",159 ,0)
  27600    S VALMHDR (2)=XX
  27601   "RTN","RCD PEWL7",160 ,0)
  27602    ;
  27603   "RTN","RCD PEWL7",161 ,0)
  27604    ; Third h eader line . Post sta tus, payer  name rang e and zero  payment/p ayment
  27605   "RTN","RCD PEWL7",162 ,0)
  27606    S X=$G(^T MP("RCERA_ PARAMS",$J ,"RCPOST") )
  27607   "RTN","RCD PEWL7",163 ,0)
  27608    S XX="POS T STATUS :  "_$S(X="U ":"UNPOSTE D",X="P":" POSTED",1: "BOTH")
  27609   "RTN","RCD PEWL7",164 ,0)
  27610    S X=$G(^T MP("RCERA_ PARAMS",$J ,"RCPAYR") )
  27611   "RTN","RCD PEWL7",165 ,0)
  27612    I $P(X,U) ="A"!(X="" ) D  ;
  27613   "RTN","RCD PEWL7",166 ,0)
  27614    . S XX2=" ALL PAYERS "
  27615   "RTN","RCD PEWL7",167 ,0)
  27616    E  D  ;
  27617   "RTN","RCD PEWL7",168 ,0)
  27618    . S XX2=$ P(X,U,2)_" -"_$P(X,U, 3)
  27619   "RTN","RCD PEWL7",169 ,0)
  27620    . I $L(XX 2)>11 S XX 2="RANGE"
  27621   "RTN","RCD PEWL7",170 ,0)
  27622    S XX2="PA YERS: "_XX 2
  27623   "RTN","RCD PEWL7",171 ,0)
  27624    S XX=$$SE TSTR^VALM1 (XX2,XX,26 ,20)
  27625   "RTN","RCD PEWL7",172 ,0)
  27626    S X=$G(^T MP("RCERA_ PARAMS",$J ,"RCPAYMNT "))
  27627   "RTN","RCD PEWL7",173 ,0)
  27628    S XX2="PA YMENT TYPE : "
  27629   "RTN","RCD PEWL7",174 ,0)
  27630    S XX2=XX2 _$S(X="Z": "ZERO PAYM ENTS ONLY" ,X="P":"PA YMENTS ONL Y",1:"BOTH ")
  27631   "RTN","RCD PEWL7",175 ,0)
  27632    S XX=$$SE TSTR^VALM1 (XX2,XX,46 ,35)
  27633   "RTN","RCD PEWL7",176 ,0)
  27634    S VALMHDR (3)=XX
  27635   "RTN","RCD PEWL7",177 ,0)
  27636    ;
  27637   "RTN","RCD PEWL7",178 ,0)
  27638    S VALMHDR (4)="#        ERA #              Trace#"
  27639   "RTN","RCD PEWL7",179 ,0)
  27640    Q
  27641   "RTN","RCD PEWL7",180 ,0)
  27642    ;
  27643   "RTN","RCD PEWL7",181 ,0)
  27644   FNL ; -- C lean up li st
  27645   "RTN","RCD PEWL7",182 ,0)
  27646    K ^TMP("R CDPE-ERA_W L",$J),^TM P("RCDPE-E RA_WLDX",$ J),^TMP("R CERA_PARAM S",$J),^TM P($J,"RCER A_LIST")
  27647   "RTN","RCD PEWL7",183 ,0)
  27648    Q
  27649   "RTN","RCD PEWL7",184 ,0)
  27650    ;
  27651   "RTN","RCD PEWL7",185 ,0)
  27652   SET(X,RCSE Q,RCSEQ1)  ; -- set a rrays
  27653   "RTN","RCD PEWL7",186 ,0)
  27654    ; X = the  data to s et into th e global
  27655   "RTN","RCD PEWL7",187 ,0)
  27656    ; RCSEQ =  the selec table line  #
  27657   "RTN","RCD PEWL7",188 ,0)
  27658    ; RCSEQ1  = the ien  of the ent ry in file  344.4
  27659   "RTN","RCD PEWL7",189 ,0)
  27660    S VALMCNT =VALMCNT+1 ,^TMP("RCD PE-ERA_WL" ,$J,VALMCN T,0)=X
  27661   "RTN","RCD PEWL7",190 ,0)
  27662    I $G(RCSE Q) S ^TMP( "RCDPE-ERA _WL",$J,"I DX",VALMCN T,RCSEQ)=$ G(RCSEQ1)
  27663   "RTN","RCD PEWL7",191 ,0)
  27664    I $G(RCSE Q1) S ^TMP ("RCDPE-ER A_WLDX",$J ,RCSEQ)=VA LMCNT_U_RC SEQ1
  27665   "RTN","RCD PEWL7",192 ,0)
  27666    Q
  27667   "RTN","RCD PEWL7",193 ,0)
  27668    ;
  27669   "RTN","RCD PEWL7",194 ,0)
  27670   ENTERWL ;  Enter the  worklist w ith an ERA
  27671   "RTN","RCD PEWL7",195 ,0)
  27672    D WL($$SE L())
  27673   "RTN","RCD PEWL7",196 ,0)
  27674    D BLD($G( ^TMP("RCER A_PARAMS", $J,"SORT") ))
  27675   "RTN","RCD PEWL7",197 ,0)
  27676    S VALMBCK ="R"
  27677   "RTN","RCD PEWL7",198 ,0)
  27678    Q
  27679   "RTN","RCD PEWL7",199 ,0)
  27680    ;
  27681   "RTN","RCD PEWL7",200 ,0)
  27682   SEL() ; Se lect an ER A from the  ERA list
  27683   "RTN","RCD PEWL7",201 ,0)
  27684    N RCDA,VA LMY
  27685   "RTN","RCD PEWL7",202 ,0)
  27686    D FULL^VA LM1
  27687   "RTN","RCD PEWL7",203 ,0)
  27688    D EN^VALM 2($G(XQORN OD(0)),"S" )
  27689   "RTN","RCD PEWL7",204 ,0)
  27690    S RCERA=0
  27691   "RTN","RCD PEWL7",205 ,0)
  27692    S RCDA=0  F  S RCDA= $O(VALMY(R CDA)) Q:'R CDA  S RCE RA=+$P($G( ^TMP("RCDP E-ERA_WLDX ",$J,RCDA) ),U,2)
  27693   "RTN","RCD PEWL7",206 ,0)
  27694    ;
  27695   "RTN","RCD PEWL7",207 ,0)
  27696    Q RCERA
  27697   "RTN","RCD PEWL7",208 ,0)
  27698    ;
  27699   "RTN","RCD PEWL7",209 ,0)
  27700   WL(RCERA)  ; Enter wo rklist
  27701   "RTN","RCD PEWL7",210 ,0)
  27702    ;
  27703   "RTN","RCD PEWL7",211 ,0)
  27704    ;              input  - RCERA =  ien of th e ERA entr y in file  344.4
  27705   "RTN","RCD PEWL7",212 ,0)
  27706    ;
  27707   "RTN","RCD PEWL7",213 ,0)
  27708    N DA,DIE, DIR,DR,DTO UT,DUOUT,I ,PREVENT,R C0,RCNOED, RCQUIT,RCS ORT,RCEXC, RETCODES,S TATE,TYPE, X,Y
  27709   "RTN","RCD PEWL7",214 ,0)
  27710    Q:RCERA'> 0
  27711   "RTN","RCD PEWL7",215 ,0)
  27712    ; PRCA*4. 5*304 - Re entry if w e cleared  exceptions
  27713   "RTN","RCD PEWL7",216 ,0)
  27714   WL1 ; rete st to make  sure this  ERA does  not have a n exceptio n
  27715   "RTN","RCD PEWL7",217 ,0)
  27716    S TYPE=$S ($$PAYTYPE ("P"):"P", 1:"M"),RCE XC=0 ; PRC A*4.5*321
  27717   "RTN","RCD PEWL7",218 ,0)
  27718    ; PRCA*4. 5*304 - se e if we ha ve the ERA  and go to  WL1 to re test.
  27719   "RTN","RCD PEWL7",219 ,0)
  27720    I ($$XCEP T^RCDPEWLP (RCERA)]"" )&(TYPE="M ") D EXCDE NY^RCDPEWL P Q  ;cann ot process  MEDICAL E RA if exce ption exis ts then fa ll back to  Worklist.
  27721   "RTN","RCD PEWL7",220 ,0)
  27722    ; PRCA*4. 5*304 - Re moved the  G:($G(RCER A)'="")&&( $G(RCEXC)= 1) WL1 fro m above so  it falls  back to th e worklist  instead o f going fo rward to t he "Select  ERA"
  27723   "RTN","RCD PEWL7",221 ,0)
  27724    ; I ($$XC EPT^RCDPEW LP(RCERA)] "")&(TYPE= "M") D EXC DENY^RCDPE WLP G:($G( RCERA)'="" )&&($G(RCE XC)=1) WL1  Q
  27725   "RTN","RCD PEWL7",222 ,0)
  27726    S (RCQUIT ,RCNOED,PR EVENT)=0,R C0=$G(^RCY (344.4,RCE RA,0)),RCS ORT=""
  27727   "RTN","RCD PEWL7",223 ,0)
  27728    I $P(RC0, U,8) D
  27729   "RTN","RCD PEWL7",224 ,0)
  27730    . I '$D(^ RCY(344.49 ,RCERA,0))  D  Q
  27731   "RTN","RCD PEWL7",225 ,0)
  27732    .. S RCQU IT=1
  27733   "RTN","RCD PEWL7",226 ,0)
  27734    .. W ! S  DIR(0)="EA ",DIR("A", 1)="A SCRA TCH PAD WA S NOT CREA TED FOR TH IS ERA BEF ORE POSTIN G",DIR("A" ,2)="USE T HE VIEW/PR INT ERA OP TION TO SE E ITS DETA IL",DIR("A ")="Press  ENTER to c ontinue: "  D ^DIR K  DIR Q
  27735   "RTN","RCD PEWL7",227 ,0)
  27736    . ;
  27737   "RTN","RCD PEWL7",228 ,0)
  27738    . S RCNOE D=+$P(RC0, U,8)
  27739   "RTN","RCD PEWL7",229 ,0)
  27740    . S DIR(0 )="EA",DIR ("A",1)="T HIS ERA AL READY HAS  A RECEIPT  - YOU MAY  ONLY VIEW  ITS SCRATC H PAD",DIR ("A")="Pre ss ENTER t o continue : "
  27741   "RTN","RCD PEWL7",230 ,0)
  27742    . W ! D ^ DIR K DIR  W !
  27743   "RTN","RCD PEWL7",231 ,0)
  27744    G:RCQUIT  WLQ
  27745   "RTN","RCD PEWL7",232 ,0)
  27746    G:RCNOED  WLD   ; al ready has  a receipt  so no need  to check  for older  unposted E FTs
  27747   "RTN","RCD PEWL7",233 ,0)
  27748    ; functio n $$AGEDEF TS - searc h for any  UNPOSTED E FTs older  than 14 da ys (medica l) or 30 d ays (pharm acy)
  27749   "RTN","RCD PEWL7",234 ,0)
  27750    ; return  value of 0 , 2, or 3  represent  that entry  into scra tchpad can  occur
  27751   "RTN","RCD PEWL7",235 ,0)
  27752    S RETCODE S=$$AGEDEF TS^RCDPEWL P(RCERA,TY PE)
  27753   "RTN","RCD PEWL7",236 ,0)
  27754    F I=1:1 S  STATE=$P( RETCODES,U ,I) Q:STAT E=""  S PR EVENT=$S($ E(STATE,1) =1:1,1:0)
  27755   "RTN","RCD PEWL7",237 ,0)
  27756    Q:PREVENT    ; preve nt user fr om enterin g scratchp ad; there  are older  EFTs on th e system t hat need t o be worke d.
  27757   "RTN","RCD PEWL7",238 ,0)
  27758   WLD ;
  27759   "RTN","RCD PEWL7",239 ,0)
  27760    D DISP^RC DPEWL(RCER A,RCNOED)
  27761   "RTN","RCD PEWL7",240 ,0)
  27762    ;
  27763   "RTN","RCD PEWL7",241 ,0)
  27764    ; prca*4. 5*298  per  patch req uirements,  keep code  related t
  27765   "RTN","RCD PEWL7",242 ,0)
  27766    ; creatin g/maintain ing batche s but just  remove fr om executi on.
  27767   "RTN","RCD PEWL7",243 ,0)
  27768    ;I 'RCQUI T,$G(^TMP( "RCBATCH_S ELECTED",$ J)) D
  27769   "RTN","RCD PEWL7",244 ,0)
  27770    ;. S DA(1 )=RCERA,DA =+$G(^TMP( "RCBATCH_S ELECTED",$ J)),DR=".0 5////0",DI E="^RCY(34 4.49,"_DA( 1)_",3," D  ^DIE
  27771   "RTN","RCD PEWL7",245 ,0)
  27772    ;. L -^RC Y(344.49,D A(1),3,DA, 0)
  27773   "RTN","RCD PEWL7",246 ,0)
  27774    ;. K ^TMP ("RCBATCH_ SELECTED", $J)
  27775   "RTN","RCD PEWL7",247 ,0)
  27776    ;E  D
  27777   "RTN","RCD PEWL7",248 ,0)
  27778    ;L -^RCY( 344.4,RCER A,0)
  27779   "RTN","RCD PEWL7",249 ,0)
  27780   WLQ ;
  27781   "RTN","RCD PEWL7",250 ,0)
  27782    L -^RCY(3 44.4,RCERA ,0)
  27783   "RTN","RCD PEWL7",251 ,0)
  27784    Q
  27785   "RTN","RCD PEWL7",252 ,0)
  27786    ;
  27787   "RTN","RCD PEWL7",253 ,0)
  27788   PRERA ; Vi ew/Print E RA from ER A list men u
  27789   "RTN","RCD PEWL7",254 ,0)
  27790    N RCSCR
  27791   "RTN","RCD PEWL7",255 ,0)
  27792    S RCSCR=$ $SEL()
  27793   "RTN","RCD PEWL7",256 ,0)
  27794    I RCSCR>0  D PRERA^R CDPEWL0
  27795   "RTN","RCD PEWL7",257 ,0)
  27796    S VALMBCK ="R"
  27797   "RTN","RCD PEWL7",258 ,0)
  27798    Q
  27799   "RTN","RCD PEWL7",259 ,0)
  27800    ;
  27801   "RTN","RCD PEWL7",260 ,0)
  27802   BAT(RCERA)  ; Select  batch, if  needed
  27803   "RTN","RCD PEWL7",261 ,0)
  27804    ; Returns  1 if batc h selected  OK or no  batch need ed
  27805   "RTN","RCD PEWL7",262 ,0)
  27806    ; RCERA =  ien of en try in fil e 344.49
  27807   "RTN","RCD PEWL7",263 ,0)
  27808    N RCINUSE ,RCQUIT,RC ADJ,RC0,RC OK,DIR,DTO UT,DUOUT,X ,Y,Z
  27809   "RTN","RCD PEWL7",264 ,0)
  27810    K ^TMP("R CBATCH_SEL ECTED",$J)
  27811   "RTN","RCD PEWL7",265 ,0)
  27812    S RCOK=1
  27813   "RTN","RCD PEWL7",266 ,0)
  27814    I '$O(^RC Y(344.49,R CERA,3,0))  G BATQ
  27815   "RTN","RCD PEWL7",267 ,0)
  27816    S RC0=$G( ^RCY(344.4 ,RCERA,0))
  27817   "RTN","RCD PEWL7",268 ,0)
  27818    S (RCQUIT ,RCADJ)=0
  27819   "RTN","RCD PEWL7",269 ,0)
  27820    I $$HASAD J^RCDPEWL8 (RCERA) D
  27821   "RTN","RCD PEWL7",270 ,0)
  27822    . S RCADJ =1
  27823   "RTN","RCD PEWL7",271 ,0)
  27824    . S DIR(" A",1)="THI S ERA HAS  NEGATIVE A DJUSTMENTS  THAT NEED  TO BE DIS TRIBUTED T O OTHER",D IR("A",2)= "PAYMENTS  ON THE ERA .  YOU CAN NOT SELECT  ANY INDIV IDUAL BATC HES UNTIL" ,DIR("A",3 )="THE DIS TRIBUTIONS  ARE COMPL ETE."
  27825   "RTN","RCD PEWL7",272 ,0)
  27826    . S DIR(" A")="Press  ENTER to  continue:  ",DIR(0)=" EA" W ! D  ^DIR K DIR
  27827   "RTN","RCD PEWL7",273 ,0)
  27828    S RCINUSE =+$O(^RCY( 344.49,"AI NUSE",1,RC ERA,0))
  27829   "RTN","RCD PEWL7",274 ,0)
  27830    I RCINUSE  D
  27831   "RTN","RCD PEWL7",275 ,0)
  27832    . N OK,Z
  27833   "RTN","RCD PEWL7",276 ,0)
  27834    . Q:RCADJ !$P(RC0,U, 8)
  27835   "RTN","RCD PEWL7",277 ,0)
  27836    . S OK=0  S Z=0 F  S  Z=$O(^RCY (344.49,RC ERA,3,Z))  Q:'Z  I '$ P($G(^RCY( 344.49,RCE RA,3,Z,0)) ,U,5) S OK =1 Q
  27837   "RTN","RCD PEWL7",278 ,0)
  27838    . I 'OK D   Q
  27839   "RTN","RCD PEWL7",279 ,0)
  27840    .. S DIR( "A",1)="AL L BATCHES  WITHIN THI S ERA ARE  CURRENTLY  IN USE - T RY AGAIN L ATER",DIR( "A")="Pres s ENTER to  continue:  ",DIR(0)= "EA" W ! D  ^DIR K DI R S RCQUIT =1,RCOK=0  Q
  27841   "RTN","RCD PEWL7",280 ,0)
  27842    . W !!,"A T LEAST 1  BATCH WITH IN THIS ER A IS CURRE NTLY IN US E",!,"AT T HIS TIME,  YOU CAN ON LY ACCESS  INDIVIDUAL  BATCHES", !
  27843   "RTN","RCD PEWL7",281 ,0)
  27844    . D SELBA T^RCDPEWL8 (RCERA,.RC QUIT)
  27845   "RTN","RCD PEWL7",282 ,0)
  27846    . I RCQUI T S RCOK=0
  27847   "RTN","RCD PEWL7",283 ,0)
  27848    E  D
  27849   "RTN","RCD PEWL7",284 ,0)
  27850    . Q:$P(RC 0,U,8)!RCA DJ  ; Alwa ys require  the entir e ERA be u sed
  27851   "RTN","RCD PEWL7",285 ,0)
  27852    . S DIR(0 )="SA^E:(E )NTIRE ERA ;B:(B)ATCH ",DIR("A") ="DO YOU W ANT THE (E )NTIRE ERA  OR JUST A  (B)ATCH?:  " W ! D ^ DIR K DIR
  27853   "RTN","RCD PEWL7",286 ,0)
  27854    . I $D(DT OUT)!$D(DU OUT) S RCQ UIT=1,RCOK =0 Q
  27855   "RTN","RCD PEWL7",287 ,0)
  27856    . I Y="E"  D  Q
  27857   "RTN","RCD PEWL7",288 ,0)
  27858    .. S RCQU IT=1 F Z=1 :1:2 L +^R CY(344.4,R CERA,0):5  I $T S RCQ UIT=0 Q
  27859   "RTN","RCD PEWL7",289 ,0)
  27860    .. I RCQU IT S RCOK= 0,DIR(0)=" EA",DIR("A ",1)="ANOT HER USER I S CURRENTL Y USING TH IS ERA, TR Y AGAIN LA TER",DIR(" A")="Press  ENTER to  continue:  " W ! D ^D IR K DIR Q
  27861   "RTN","RCD PEWL7",290 ,0)
  27862    . D SELBA T^RCDPEWL8 (RCERA,.RC QUIT)
  27863   "RTN","RCD PEWL7",291 ,0)
  27864    . I RCQUI T S RCOK=0
  27865   "RTN","RCD PEWL7",292 ,0)
  27866    ;
  27867   "RTN","RCD PEWL7",293 ,0)
  27868   BATQ Q RCO K
  27869   "RTN","RCD PEWL7",294 ,0)
  27870    ;
  27871   "RTN","RCD PEWL7",295 ,0)
  27872   PAYTYPE(IE N,TYPE) ;  EP - New w ay to tell  if a paye r is phara mcy, Trica re or medi cal - Adde d for PRCA *4.5*321
  27873   "RTN","RCD PEWL7",296 ,0)
  27874    ; Input:  IEN - Inte rnal entry  number of  an ERA (# 344.4)
  27875   "RTN","RCD PEWL7",297 ,0)
  27876    ;         TYPE="P" -  Pharmacy,  "T" - Tri care, "M"  - Medical
  27877   "RTN","RCD PEWL7",298 ,0)
  27878    ;         ("M" is ne ither phar macy nor T ricare)
  27879   "RTN","RCD PEWL7",299 ,0)
  27880    ; Return:  1 - Payer  on ERA ma tches the  TYPE
  27881   "RTN","RCD PEWL7",300 ,0)
  27882    ;          0 - Payer  on ERA do es not mat ch the typ e. Or can' t find pay er.
  27883   "RTN","RCD PEWL7",301 ,0)
  27884    ;
  27885   "RTN","RCD PEWL7",302 ,0)
  27886    N FLAG,RE TURN
  27887   "RTN","RCD PEWL7",303 ,0)
  27888    S RETURN= 0
  27889   "RTN","RCD PEWL7",304 ,0)
  27890    I '$$PAYF LAGS(IEN,. FLAG) Q 0
  27891   "RTN","RCD PEWL7",305 ,0)
  27892    I TYPE="P ",FLAG("P" ) S RETURN =1
  27893   "RTN","RCD PEWL7",306 ,0)
  27894    I TYPE="T ",FLAG("T" ) S RETURN =1
  27895   "RTN","RCD PEWL7",307 ,0)
  27896    I TYPE="M ",'FLAG("P "),'FLAG(" T") S RETU RN=1
  27897   "RTN","RCD PEWL7",308 ,0)
  27898    Q RETURN
  27899   "RTN","RCD PEWL7",309 ,0)
  27900    ;
  27901   "RTN","RCD PEWL7",310 ,0)
  27902   PAYFLAGS(I EN,FLAG) ;  EP - Retu rn the pha rmacy and  tricare fl ags for an  ERA
  27903   "RTN","RCD PEWL7",311 ,0)
  27904    ; Input:  IEN - Inte rnal entry  number of  an ERA (# 344.4)
  27905   "RTN","RCD PEWL7",312 ,0)
  27906    ; Return:  1 - Payer  found
  27907   "RTN","RCD PEWL7",313 ,0)
  27908    ;          0 - Can't  find paye r.
  27909   "RTN","RCD PEWL7",314 ,0)
  27910    ; Variabl e FLAG pas sed by ref erence to  return val ues of the  pharamcy  and Tricar e flags.
  27911   "RTN","RCD PEWL7",315 ,0)
  27912    ;
  27913   "RTN","RCD PEWL7",316 ,0)
  27914    N RCINS,R CPAYIEN,RC TIN,X
  27915   "RTN","RCD PEWL7",317 ,0)
  27916    S RCTIN=$ $GET1^DIQ( 344.4,IEN_ ",",.03)
  27917   "RTN","RCD PEWL7",318 ,0)
  27918    I RCTIN=" " Q 0
  27919   "RTN","RCD PEWL7",319 ,0)
  27920    S RCINS=$ $GET1^DIQ( 344.4,IEN_ ",",.06)
  27921   "RTN","RCD PEWL7",320 ,0)
  27922    I RCINS=" " Q 0
  27923   "RTN","RCD PEWL7",321 ,0)
  27924    ;
  27925   "RTN","RCD PEWL7",322 ,0)
  27926    ; Find a  payer that  matches b oth TIN an d PAYER NA ME from th e ERA
  27927   "RTN","RCD PEWL7",323 ,0)
  27928    S RCPAYIE N=""
  27929   "RTN","RCD PEWL7",324 ,0)
  27930    S X=0
  27931   "RTN","RCD PEWL7",325 ,0)
  27932    F  S X=$O (^RCY(344. 6,"C",RCTI N_" ",X))  Q:'X  D  Q :RCPAYIEN   ;
  27933   "RTN","RCD PEWL7",326 ,0)
  27934    . N PAYNA ME
  27935   "RTN","RCD PEWL7",327 ,0)
  27936    . S PAYNA ME=$$GET1^ DIQ(344.6, X_",",.01)
  27937   "RTN","RCD PEWL7",328 ,0)
  27938    . I PAYNA ME=RCINS S  RCPAYIEN= X
  27939   "RTN","RCD PEWL7",329 ,0)
  27940    I 'RCPAYI EN Q 0
  27941   "RTN","RCD PEWL7",330 ,0)
  27942    ;
  27943   "RTN","RCD PEWL7",331 ,0)
  27944    S FLAG("P ")=+$$GET1 ^DIQ(344.6 ,RCPAYIEN_ ",",.09,"I ")
  27945   "RTN","RCD PEWL7",332 ,0)
  27946    S FLAG("T ")=+$$GET1 ^DIQ(344.6 ,RCPAYIEN_ ",",.1,"I" )
  27947   "RTN","RCD PEWL7",333 ,0)
  27948    Q 1
  27949   "RTN","RCD PEWL7",334 ,0)
  27950    ;
  27951   "RTN","RCD PEWL7",335 ,0)
  27952   HELP ; --  help code
  27953   "RTN","RCD PEWL7",336 ,0)
  27954    S X="?" D  DISP^XQOR M1 W !!
  27955   "RTN","RCD PEWL7",337 ,0)
  27956    Q
  27957   "RTN","RCD PEWL7",338 ,0)
  27958    ;
  27959   "RTN","RCD PEWL8")
  27960   0^51^B1027 69103
  27961   "RTN","RCD PEWL8",1,0 )
  27962   RCDPEWL8 ; ALB/TMK/PJ H - EDI LO CKBOX WORK LIST ERA L EVEL ;Jun  06, 2014@1 9:11:19
  27963   "RTN","RCD PEWL8",2,0 )
  27964    ;;4.5;Acc ounts Rece ivable;**2 08,269,276 ,298,304,3 18,321**;M ar 20, 199 5;Build 46
  27965   "RTN","RCD PEWL8",3,0 )
  27966    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  27967   "RTN","RCD PEWL8",4,0 )
  27968    Q
  27969   "RTN","RCD PEWL8",5,0 )
  27970    ;
  27971   "RTN","RCD PEWL8",6,0 )
  27972   FILESP ; A ction that  files the  split lin es
  27973   "RTN","RCD PEWL8",7,0 )
  27974    ; Assumes  RCDIR,RCL INE,RCSCR, RCSPLIT ar ray define d
  27975   "RTN","RCD PEWL8",8,0 )
  27976    N RCTOT,Z ,RCZ0,RCZ1 ,DTOUT,DUO UT,DIR,X,Y ,DIE,DA,DR ,DIC,DD,DO ,DLAYGO,RC Z,RCZZ,RCZ T,VALBCK
  27977   "RTN","RCD PEWL8",9,0 )
  27978    D FULL^VA LM1
  27979   "RTN","RCD PEWL8",10, 0)
  27980    I '$G(^TM P("RCDPE_E OB_SPLIT_O K",$J)) D   Q
  27981   "RTN","RCD PEWL8",11, 0)
  27982    . S VALMB CK="R"
  27983   "RTN","RCD PEWL8",12, 0)
  27984    . F Z=2,3  S RCTOT(Z )=$$TOT^RC DPEWL3(Z,. RCSPLIT)
  27985   "RTN","RCD PEWL8",13, 0)
  27986    . S DIR(0 )="EA"
  27987   "RTN","RCD PEWL8",14, 0)
  27988    . S DIR(" A",1)="TOT AL "_$S(+R CTOT(2)'=+ $P(RCDIR,U ,2):"PAYME NTS",1:"AD JUSTMENTS" )_$S(+RCTO T(3)=+$P(R CDIR,U,3): "",+RCTOT( 2)'=+$P(RC DIR,U,2):"  AND ADJUS TMENTS",1: "")_" DO N OT MATCH T HE ORIGINA L AMOUNT(s ):"
  27989   "RTN","RCD PEWL8",15, 0)
  27990    . S DIR(" A",2)=$E("   ORIG PAY  AMT: "_$J (+$P(RCDIR ,U,2),"",2 )_$J("",35 ),1,35)_"  ORIG ADJ A MT: "_$J(+ $P(RCDIR,U ,3),"",2)
  27991   "RTN","RCD PEWL8",16, 0)
  27992    . S DIR(" A",3)=$E("    AMT ENT ERED: "_$J (+RCTOT(2) ,"",2)_$J( "",35),1,3 5)_"  AMT  ENTERED: " _$J(+RCTOT (3),"",2)
  27993   "RTN","RCD PEWL8",17, 0)
  27994    . S DIR(" A")="PRESS  RETURN TO  CONTINUE  " W ! D ^D IR K DIR
  27995   "RTN","RCD PEWL8",18, 0)
  27996    S DA(1)=R CSCR
  27997   "RTN","RCD PEWL8",19, 0)
  27998    S RCZ0=+$ P(RCLINE,U ,2),RCZZ=+ $G(^RCY(34 4.49,DA(1) ,1,RCZ0,0) ),RCZZ(1)= ""
  27999   "RTN","RCD PEWL8",20, 0)
  28000    S RCZ=+$O (RCSPLIT(0 ))
  28001   "RTN","RCD PEWL8",21, 0)
  28002    ;
  28003   "RTN","RCD PEWL8",22, 0)
  28004    ;Option t o move/cop y EOB
  28005   "RTN","RCD PEWL8",23, 0)
  28006    I RCZ D   Q:$G(VALMB CK)="Q"
  28007   "RTN","RCD PEWL8",24, 0)
  28008    .;;Move/C opy remove d 10/19/11 -now in re ceipt crea tion +136^ RCDPEM
  28009   "RTN","RCD PEWL8",25, 0)
  28010    .;;Q:$$UP DWL^RCDPEM 5($P(RCDIR ,U),.RCSPL IT,RCERA)
  28011   "RTN","RCD PEWL8",26, 0)
  28012    .;;User a bort
  28013   "RTN","RCD PEWL8",27, 0)
  28014    .;;K ^TMP ($J,"RCDPE _SPLIT_FIL E") S VALM BCK="Q"
  28015   "RTN","RCD PEWL8",28, 0)
  28016    ;
  28017   "RTN","RCD PEWL8",29, 0)
  28018    I RCZ D
  28019   "RTN","RCD PEWL8",30, 0)
  28020    . S DIE=" ^RCY(344.4 9,"_DA(1)_ ",1,",DA=R CZ0,RCZT=$ P(RCSPLIT( RCZ),U,2)+ $P(RCSPLIT (RCZ),U,3)
  28021   "RTN","RCD PEWL8",31, 0)
  28022    . S DR=". 02////"_$P (RCSPLIT(R CZ),U)_";. 05////"_$J (+$P(RCSPL IT(RCZ),U, 2),"",2)_" ;.06////"_ $J(+RCZT," ",2)_";.08 ////"_$J($ P(RCSPLIT( RCZ),U,3), "",2)
  28023   "RTN","RCD PEWL8",32, 0)
  28024    . S DR=DR _";.07///" _$S($P(RCS PLIT(RCZ), U,5):"/"_$ P(RCSPLIT( RCZ),U,5), 1:"@")_";. 03////"_$S (RCZT'<0:$ J(+RCZT,"" ,2),1:"0.0 0")_$S($P( RCSPLIT(RC Z),U,6)'=" ":";.1///" _$S($P(RCS PLIT(RCZ), U,6)'="@": "/^S X=$P( RCSPLIT(RC Z),U,6)",1 :"@"),1:"" )
  28025   "RTN","RCD PEWL8",33, 0)
  28026    . D ^DIE, UPD^RCDPEW L3(DA(1),D A)
  28027   "RTN","RCD PEWL8",34, 0)
  28028    . I $P(RC DIR,U,3) D
  28029   "RTN","RCD PEWL8",35, 0)
  28030    .. N DA
  28031   "RTN","RCD PEWL8",36, 0)
  28032    .. S DA(2 )=RCSCR,DA (1)=RCZ0,D A=1,DIE="^ RCY(344.49 ,"_DA(2)_" ,1,"_DA(1) _",1,"
  28033   "RTN","RCD PEWL8",37, 0)
  28034    .. S RCZZ (1)=$G(^RC Y(344.49,D A(2),1,DA( 1),1,1,0))
  28035   "RTN","RCD PEWL8",38, 0)
  28036    .. S DR=" .03////"_$ J(+$P(RCSP LIT(RCZ),U ,3),"",2)_ $S($P(RCSP LIT(RCZ),U ,4)'="":". 09////"_$P (RCSPLIT(R CZ),U,4),1 :"")
  28037   "RTN","RCD PEWL8",39, 0)
  28038    .. D ^DIE
  28039   "RTN","RCD PEWL8",40, 0)
  28040    F  S RCZ= $O(RCSPLIT (RCZ)) Q:' RCZ  D
  28041   "RTN","RCD PEWL8",41, 0)
  28042    . S DIC(0 )="L",DLAY GO=344.491 ,DIC="^RCY (344.49,"_ DA(1)_",1, ",X=+$O(^R CY(344.49, RCSCR,1,"B ",RCZZ\1+. 999),-1)+. 001
  28043   "RTN","RCD PEWL8",42, 0)
  28044    . S DIC(" DR")=".02/ ///"_$P(RC SPLIT(RCZ) ,U)_";.05/ ///"_$J(+$ P(RCSPLIT( RCZ),U,2), "",2)_";.0 8////"_$J( +$P(RCSPLI T(RCZ),U,3 ),"",2)_"; .06////"_$ J($P(RCSPL IT(RCZ),U, 2)+$P(RCSP LIT(RCZ),U ,3),"",2)
  28045   "RTN","RCD PEWL8",43, 0)
  28046    . I $P(RC SPLIT(RCZ) ,U,6)'=""  S DIC("DR" )=DIC("DR" )_";.1///" _$S($P(RCS PLIT(RCZ), U,6)'="@": "/^S X=$P( RCSPLIT(RC Z),U,6)",1 :"@")
  28047   "RTN","RCD PEWL8",44, 0)
  28048    . I $P(RC SPLIT(RCZ) ,U,5) S DI C("DR")=DI C("DR")_"; .07////"_$ P(RCSPLIT( RCZ),U,5)
  28049   "RTN","RCD PEWL8",45, 0)
  28050    . K DD,DO  D FILE^DI CN K DIC,D LAYGO,DD,D O
  28051   "RTN","RCD PEWL8",46, 0)
  28052    . S RCZ1= +Y
  28053   "RTN","RCD PEWL8",47, 0)
  28054    . I Y D U PD^RCDPEWL 3(RCSCR,RC Z1)
  28055   "RTN","RCD PEWL8",48, 0)
  28056    . I Y,$P( RCDIR,U,3)  D
  28057   "RTN","RCD PEWL8",49, 0)
  28058    .. N DA
  28059   "RTN","RCD PEWL8",50, 0)
  28060    .. S DA(2 )=RCSCR,DA (1)=RCZ1,X =1,DIC(0)= "L",DIC="^ RCY(344.49 ,"_DA(2)_" ,1,"_DA(1) _",1,"
  28061   "RTN","RCD PEWL8",51, 0)
  28062    .. S DIC( "DR")=".02 ////"_$P(R CZZ(1),U,2 )_";.03/// /"_$J(+$P( RCSPLIT(RC Z),U,3),"" ,2)_$S($P( RCSPLIT(RC Z),U,4)'=" ":";.09/// /"_$P(RCSP LIT(RCZ),U ,4),$P(RCZ Z(1),U,9)' ="":";.09/ ///"_$P(RC ZZ(1),U,9) ,1:"")
  28063   "RTN","RCD PEWL8",52, 0)
  28064    .. F Z=4: 1:8 I $P(R CZZ(1),U,Z )'="" S DI C("DR")=DI C("DR")_"; "_(Z/100)_ "////"_$P( RCZZ(1),U, Z)
  28065   "RTN","RCD PEWL8",53, 0)
  28066    .. D FILE ^DICN K DI C,DLAYGO,D D,DO
  28067   "RTN","RCD PEWL8",54, 0)
  28068    K ^TMP($J ,"RCDPE_SP LIT_FILE")
  28069   "RTN","RCD PEWL8",55, 0)
  28070    S VALMBCK ="Q"
  28071   "RTN","RCD PEWL8",56, 0)
  28072    Q
  28073   "RTN","RCD PEWL8",57, 0)
  28074    ;
  28075   "RTN","RCD PEWL8",58, 0)
  28076   SELBAT(RCE RA,RCQUIT)  ; Select  a batch
  28077   "RTN","RCD PEWL8",59, 0)
  28078    ; If batc h is selec ted, globa l ^TMP("RC BATCH_SELE CTED",$J)  is set = 
  28079   "RTN","RCD PEWL8",60, 0)
  28080    ;   batch  ien selec ted
  28081   "RTN","RCD PEWL8",61, 0)
  28082    ; RCQUIT  = 1 if sel ection not  made
  28083   "RTN","RCD PEWL8",62, 0)
  28084    ; prca*4. 5*298 per  requiremen ts, keep c ode for cr eating/mai ntaining b atches but  remove fr om executi on
  28085   "RTN","RCD PEWL8",63, 0)
  28086    Q  ;prca* 4.5*298
  28087   "RTN","RCD PEWL8",64, 0)
  28088    N DA,DIC, DIE,DIR,DR ,DTOUT,DUO UT,RCBAT,X ,Y
  28089   "RTN","RCD PEWL8",65, 0)
  28090    S RCQUIT= 0
  28091   "RTN","RCD PEWL8",66, 0)
  28092    S DA(1)=R CERA,DIC(0 )="AEMQ",D IC="^RCY(3 44.49,"_DA (1)_",3,", DIC("S")=" I '$P(^(0) ,U,5)" D ^ DIC
  28093   "RTN","RCD PEWL8",67, 0)
  28094    I Y'>0 S  RCQUIT=1 Q
  28095   "RTN","RCD PEWL8",68, 0)
  28096    S RCBAT=+ Y
  28097   "RTN","RCD PEWL8",69, 0)
  28098    L +^RCY(3 44.4,RCERA ,0):5 I '$ T S DIR("A ",1)="ANOT HER USER H AS JUST AC CESSED THE  ENTIRE ER A - TRY AG AIN LATER" ,DIR("A")= "PRESS RET URN TO CON TINUE ",DI R(0)="EA"  W ! D ^DIR  K DIR S R CQUIT=1 Q
  28099   "RTN","RCD PEWL8",70, 0)
  28100    L +^RCY(3 44.49,RCER A,3,RCBAT, 0):5 I '$T !$P($G(^(0 )),U,5) S  DIR("A",1) ="ANOTHER  USER HAS J UST OPENED  THIS BATC H - TRY AG AIN LATER" ,DIR("A")= "PRESS RET URN TO CON TINUE ",DI R(0)=-"EA"  W ! D ^DI R K DIR S  RCQUIT=1 Q
  28101   "RTN","RCD PEWL8",71, 0)
  28102    S DA=RCBA T,DA(1)=RC ERA,DIE="^ RCY(344.49 ,"_DA(1)_" ,3,",DR=". 05////1" D  ^DIE L -^ RCY(344.49 ,RCERA,3,R CBAT,0)
  28103   "RTN","RCD PEWL8",72, 0)
  28104    I $P($G(^ RCY(344.49 ,RCERA,3,R CBAT,0)),U ,3) D
  28105   "RTN","RCD PEWL8",73, 0)
  28106    . S DIR(0 )="EA",DIR ("A",1)="* * WARNING  - THIS BAT CH HAS BEE N FLAGGED  AS READY T O POST",DI R("A")="PR ESS RETURN  TO CONTIN UE " W ! D  ^DIR K DI R
  28107   "RTN","RCD PEWL8",74, 0)
  28108    S ^TMP("R CBATCH_SEL ECTED",$J) =RCBAT
  28109   "RTN","RCD PEWL8",75, 0)
  28110    L -^RCY(3 44.4,RCERA ,0)
  28111   "RTN","RCD PEWL8",76, 0)
  28112    Q
  28113   "RTN","RCD PEWL8",77, 0)
  28114    ;
  28115   "RTN","RCD PEWL8",78, 0)
  28116   SORT ; Sel ect a new  sort for t he list of  ERAs
  28117   "RTN","RCD PEWL8",79, 0)
  28118    D FULL^VA LM1
  28119   "RTN","RCD PEWL8",80, 0)
  28120    N RCSORT, DUOUT,DTOU T,DIR,X,Y, RCS1,RCS2, RCORD
  28121   "RTN","RCD PEWL8",81, 0)
  28122    S VALMBCK ="R"
  28123   "RTN","RCD PEWL8",82, 0)
  28124    S DIR("L" ,1)="  SEL ECT A FIRS T LEVEL SO RT",DIR("L ",2)=" "
  28125   "RTN","RCD PEWL8",83, 0)
  28126    S DIR("L" ,3)="    A   AMOUNT P AID      E   ERA PAID  DATE"
  28127   "RTN","RCD PEWL8",84, 0)
  28128    S DIR("L" )="    P   PAYER NAME        D   DATE ERA R ECEIVED"
  28129   "RTN","RCD PEWL8",85, 0)
  28130    S DIR(0)= "S^A:AMOUN T PAID;E:E RA PAID DA TE;P:PAYER  NAME;D:DA TE ERA REC EIVED",DIR ("B")=$P($ P(DIR(0)," D:",2),";" )
  28131   "RTN","RCD PEWL8",86, 0)
  28132    W ! D ^DI R K DIR
  28133   "RTN","RCD PEWL8",87, 0)
  28134    I $D(DTOU T)!$D(DUOU T) Q
  28135   "RTN","RCD PEWL8",88, 0)
  28136    S RCS1=$S (Y="A":"AP ",Y="E":"D P",Y="P":" PN",1:"DR" )
  28137   "RTN","RCD PEWL8",89, 0)
  28138    S RCORD=$ $ORD(.RCS1 )
  28139   "RTN","RCD PEWL8",90, 0)
  28140    Q:'$D(RCS 1)
  28141   "RTN","RCD PEWL8",91, 0)
  28142    S $P(RCSO RT,U)=(RCS 1_";"_RCOR D)
  28143   "RTN","RCD PEWL8",92, 0)
  28144    K X
  28145   "RTN","RCD PEWL8",93, 0)
  28146    S X(1)=$S (RCS1'="AP ":"A:AMOUN T PAID",1: "E:ERA PAI D DATE")
  28147   "RTN","RCD PEWL8",94, 0)
  28148    S X(2)=$S (RCS1'="AP "&(RCS1'=" DP"):"E:ER A PAID DAT E",1:"P:PA YER NAME")
  28149   "RTN","RCD PEWL8",95, 0)
  28150    S X(3)=$S (RCS1="DR" :"P:PAYER  NAME",1:"D :DATE ERA  RECEIVED")
  28151   "RTN","RCD PEWL8",96, 0)
  28152    S DIR(0)= "S^N:NONE; "_X(1)_";" _X(2)_";"_ X(3)
  28153   "RTN","RCD PEWL8",97, 0)
  28154    S DIR("B" )="NONE"
  28155   "RTN","RCD PEWL8",98, 0)
  28156    S DIR("L" ,1)="  SEL ECT A SECO ND LEVEL S ORT",DIR(" L",2)=" "
  28157   "RTN","RCD PEWL8",99, 0)
  28158    S DIR("L" ,3)="    N   NONE"_$J ("",13)_$P (X(1),":") _"  "_$P(X (1),":",2)
  28159   "RTN","RCD PEWL8",100 ,0)
  28160    S DIR("L" )="    "_$ E($P(X(2), ":")_"  "_ $P(X(2),": ",2)_$J("" ,20),1,20) _$P(X(3)," :")_"  "_$ P(X(3),":" ,2)
  28161   "RTN","RCD PEWL8",101 ,0)
  28162    K X W ! D  ^DIR K DI R
  28163   "RTN","RCD PEWL8",102 ,0)
  28164    I $D(DTOU T)!$D(DUOU T) Q
  28165   "RTN","RCD PEWL8",103 ,0)
  28166    S RCS2=$S (Y="N":"N" ,Y="A":"AP ",Y="E":"D P",Y="P":" PN",1:"DR" )
  28167   "RTN","RCD PEWL8",104 ,0)
  28168    S RCORD=$ $ORD(.RCS2 )
  28169   "RTN","RCD PEWL8",105 ,0)
  28170    Q:'$D(RCS 2)
  28171   "RTN","RCD PEWL8",106 ,0)
  28172    S $P(RCSO RT,U,2)=(R CS2_";"_RC ORD)
  28173   "RTN","RCD PEWL8",107 ,0)
  28174    K ^TMP($J ,"RCERA_LI ST") D BLD ^RCDPEWL7( RCSORT)
  28175   "RTN","RCD PEWL8",108 ,0)
  28176    Q
  28177   "RTN","RCD PEWL8",109 ,0)
  28178    ;
  28179   "RTN","RCD PEWL8",110 ,0)
  28180   ORD(RCS) ;  Select an  order for  the sorte d field co de in RCS
  28181   "RTN","RCD PEWL8",111 ,0)
  28182    ; Kill RC S if nothi ng selecte d, passed  by referen ce
  28183   "RTN","RCD PEWL8",112 ,0)
  28184    ; Returns  '-' if re verse orde r selected
  28185   "RTN","RCD PEWL8",113 ,0)
  28186    N DIR,X,Y ,ORD,RCQUI T
  28187   "RTN","RCD PEWL8",114 ,0)
  28188    S RCQUIT= 0,ORD=""
  28189   "RTN","RCD PEWL8",115 ,0)
  28190    I RCS="N"  G ORDQ
  28191   "RTN","RCD PEWL8",116 ,0)
  28192    I RCS="PN " D  G ORD Q
  28193   "RTN","RCD PEWL8",117 ,0)
  28194    . S DIR(0 )="SA^F:FI RST TO LAS T;L:LAST T O FIRST"
  28195   "RTN","RCD PEWL8",118 ,0)
  28196    . S DIR(" B")=$P($P( DIR(0),"F: ",2),";")
  28197   "RTN","RCD PEWL8",119 ,0)
  28198    . S DIR(" A")="  SOR T (F)IRST  TO LAST OR  (L)AST TO  FIRST?: "
  28199   "RTN","RCD PEWL8",120 ,0)
  28200    . D ^DIR  K DIR
  28201   "RTN","RCD PEWL8",121 ,0)
  28202    . I $D(DU OUT)!$D(DT OUT) S RCQ UIT=1 Q
  28203   "RTN","RCD PEWL8",122 ,0)
  28204    . S ORD=$ S(Y="F":"" ,1:"-")
  28205   "RTN","RCD PEWL8",123 ,0)
  28206    ;
  28207   "RTN","RCD PEWL8",124 ,0)
  28208    I RCS="AP " D  G ORD Q
  28209   "RTN","RCD PEWL8",125 ,0)
  28210    . S DIR(" A")="  SOR T (L)OWEST  TO HIGHES T OR (H)IG HEST TO LO WEST?: "
  28211   "RTN","RCD PEWL8",126 ,0)
  28212    . S DIR(0 )="SA^L:LO WEST TO HI GHEST;H:HI GHEST TO L OWEST"
  28213   "RTN","RCD PEWL8",127 ,0)
  28214    . S DIR(" B")=$P($P( DIR(0),"L: ",2),";")
  28215   "RTN","RCD PEWL8",128 ,0)
  28216    . D ^DIR  K DIR
  28217   "RTN","RCD PEWL8",129 ,0)
  28218    . I $D(DU OUT)!$D(DT OUT) S RCQ UIT=1 Q
  28219   "RTN","RCD PEWL8",130 ,0)
  28220    . S ORD=$ S(Y="L":"" ,1:"-")
  28221   "RTN","RCD PEWL8",131 ,0)
  28222    ;
  28223   "RTN","RCD PEWL8",132 ,0)
  28224    I RCS="DP "!(RCS="DR ") D  G OR DQ
  28225   "RTN","RCD PEWL8",133 ,0)
  28226    . S DIR(" A")="  SOR T (E)ARLIE ST TO LATE ST OR (L)A TEST TO EA RLIEST?: "
  28227   "RTN","RCD PEWL8",134 ,0)
  28228    . S DIR(0 )="SA^E:EA RLIEST TO  LATEST;L:L ATEST TO E ARLIEST"
  28229   "RTN","RCD PEWL8",135 ,0)
  28230    . S DIR(" B")=$P($P( DIR(0),"E: ",2),";")
  28231   "RTN","RCD PEWL8",136 ,0)
  28232    . D ^DIR  K DIR
  28233   "RTN","RCD PEWL8",137 ,0)
  28234    . I $D(DU OUT)!$D(DT OUT) S RCQ UIT=1 Q
  28235   "RTN","RCD PEWL8",138 ,0)
  28236    . S ORD=$ S(Y="E":"" ,1:"-")
  28237   "RTN","RCD PEWL8",139 ,0)
  28238    ;
  28239   "RTN","RCD PEWL8",140 ,0)
  28240    ; Invalid  sort code
  28241   "RTN","RCD PEWL8",141 ,0)
  28242    S RCQUIT= 1
  28243   "RTN","RCD PEWL8",142 ,0)
  28244    ;
  28245   "RTN","RCD PEWL8",143 ,0)
  28246   ORDQ I RCQ UIT K RCS
  28247   "RTN","RCD PEWL8",144 ,0)
  28248    Q ORD
  28249   "RTN","RCD PEWL8",145 ,0)
  28250    ;
  28251   "RTN","RCD PEWL8",146 ,0)
  28252   BATDSP ; A sk Display /Hide batc h info on  ERA list s creen
  28253   "RTN","RCD PEWL8",147 ,0)
  28254    ; prca*4. 5*298 per  requiremen ts, keep c ode for cr eating/mai ntaining b atches but  remove fr om executi on
  28255   "RTN","RCD PEWL8",148 ,0)
  28256    Q  ;prca* 4.5*298
  28257   "RTN","RCD PEWL8",149 ,0)
  28258    N DIR,DTO UT,DUOUT,R CZ,X,Y
  28259   "RTN","RCD PEWL8",150 ,0)
  28260    D FULL^VA LM1
  28261   "RTN","RCD PEWL8",151 ,0)
  28262    S RCZ=+$G (^TMP("RCE RA_PARAMS" ,$J,"BATCH ON"))
  28263   "RTN","RCD PEWL8",152 ,0)
  28264    S DIR("A" ,1)="BATCH  INFO DISP LAY IS CUR RENTLY TUR NED "_$S(' RCZ:"OFF", 1:"ON"),DI R("A")="DO  YOU WANT  TO TURN IT  "_$S('RCZ :"ON",1:"O FF")_" NOW ?: "
  28265   "RTN","RCD PEWL8",153 ,0)
  28266    S DIR(0)= "YA",DIR(" B")="YES"  W ! D ^DIR  K DIR
  28267   "RTN","RCD PEWL8",154 ,0)
  28268    S VALMBCK ="R"
  28269   "RTN","RCD PEWL8",155 ,0)
  28270    Q:$D(DUOU T)!$D(DTOU T)!'Y
  28271   "RTN","RCD PEWL8",156 ,0)
  28272    S ^TMP("R CERA_PARAM S",$J,"BAT CHON")=$S( RCZ:0,1:1)
  28273   "RTN","RCD PEWL8",157 ,0)
  28274    D BLD^RCD PEWL7($G(^ TMP("RCERA _PARAMS",$ J,"SORT")) )
  28275   "RTN","RCD PEWL8",158 ,0)
  28276    Q
  28277   "RTN","RCD PEWL8",159 ,0)
  28278    ;
  28279   "RTN","RCD PEWL8",160 ,0)
  28280   HASADJ(RCS CR,RCOK) ;  Function= 1 if WL en try has an y adj not  yet distri buted
  28281   "RTN","RCD PEWL8",161 ,0)
  28282    ; RCSCR =  ien of en try in fil e 344.49
  28283   "RTN","RCD PEWL8",162 ,0)
  28284    ; RCOK =  if passed  by referen ce, return s 1 if ANY  postable  lines exis t
  28285   "RTN","RCD PEWL8",163 ,0)
  28286    N Z,Z0,RC STOP
  28287   "RTN","RCD PEWL8",164 ,0)
  28288    S RCSTOP= 0,RCOK=0
  28289   "RTN","RCD PEWL8",165 ,0)
  28290    S Z=0 F   S Z=$O(^RC Y(344.49,R CSCR,1,Z))  Q:'Z  S Z 0=$G(^(Z,0 )) D  Q:RC STOP
  28291   "RTN","RCD PEWL8",166 ,0)
  28292    . ;HIPAA  5010 - neg ative valu e now take s preceden ce over ad justment
  28293   "RTN","RCD PEWL8",167 ,0)
  28294    . I $P(Z0 ,U,6)>0!$O (^RCY(344. 49,RCSCR,1 ,Z,1,0)) S  RCOK=1
  28295   "RTN","RCD PEWL8",168 ,0)
  28296    . I $P(Z0 ,U,6)<0 S  RCSTOP=1
  28297   "RTN","RCD PEWL8",169 ,0)
  28298    Q RCSTOP
  28299   "RTN","RCD PEWL8",170 ,0)
  28300    ;
  28301   "RTN","RCD PEWL8",171 ,0)
  28302   VERIF ;EP  - Protocol  action -  RCDPE EOB  WORKLIST V ERIFY
  28303   "RTN","RCD PEWL8",172 ,0)
  28304    ; Entrypo int to ver ification  options
  28305   "RTN","RCD PEWL8",173 ,0)
  28306    N DIR,X,Y ,RCQUIT,DT OUT,DUOUT
  28307   "RTN","RCD PEWL8",174 ,0)
  28308    D FULL^VA LM1
  28309   "RTN","RCD PEWL8",175 ,0)
  28310    I '$D(^XU SEC("RCDPE PP",DUZ))  D  Q  ; PR CA*4.5*318  Added sec urity key  check
  28311   "RTN","RCD PEWL8",176 ,0)
  28312    . W !!,"T his action  can only  be taken b y users th at have th e RCDPEPP  security k ey.",!
  28313   "RTN","RCD PEWL8",177 ,0)
  28314    . D PAUSE ^VALM1
  28315   "RTN","RCD PEWL8",178 ,0)
  28316    . S VALMB CK="R"
  28317   "RTN","RCD PEWL8",179 ,0)
  28318    I $S($P($ G(^RCY(344 .4,RCSCR,4 )),U,2)]"" :1,1:0) D  NOEDIT^RCD PEWLP G VE RIFQ   ;pr ca*4.5*298   auto-pos ted ERAs c annot ente r VERIFY a ction         
  28319   "RTN","RCD PEWL8",180 ,0)
  28320    ;
  28321   "RTN","RCD PEWL8",181 ,0)
  28322    W !!!!
  28323   "RTN","RCD PEWL8",182 ,0)
  28324    S RCQUIT= 0
  28325   "RTN","RCD PEWL8",183 ,0)
  28326    F  D  Q:R CQUIT
  28327   "RTN","RCD PEWL8",184 ,0)
  28328    . W !,"VE RIFY EEOBs :",!,?10," 1",$J("",5 ),"MANUALL Y MARK AS  VERIFIED", !,?10,"2", $J("",5)," REPORT OF  UNVERIFIED  WITH DISC REPANCIES" ,!,?10,"3" ,$J("",5), "QUIT AND  RETURN TO  WORKLIST"
  28329   "RTN","RCD PEWL8",185 ,0)
  28330    . S DIR(0 )="SAO^1:M ANUAL VERI FICATION;2 :REPORT UN VERIFIED D ISCREPANCI ES;3:QUIT"
  28331   "RTN","RCD PEWL8",186 ,0)
  28332    . S DIR(" A")="Selec t Action:  ",DIR("B") ="QUIT" W  ! D ^DIR K  DIR
  28333   "RTN","RCD PEWL8",187 ,0)
  28334    . I Y=3!( Y="")!$D(D UOUT)!$D(D TOUT) S RC QUIT=1 Q
  28335   "RTN","RCD PEWL8",188 ,0)
  28336    . ;
  28337   "RTN","RCD PEWL8",189 ,0)
  28338    . I Y=1 D  MVER^RCDP EV(RCERA)  W !! Q
  28339   "RTN","RCD PEWL8",190 ,0)
  28340    . ;
  28341   "RTN","RCD PEWL8",191 ,0)
  28342    . I Y=2 D  RPT^RCDPE V0(RCERA)  W !! Q
  28343   "RTN","RCD PEWL8",192 ,0)
  28344    ;
  28345   "RTN","RCD PEWL8",193 ,0)
  28346   VERIFQ S V ALMBCK="R"
  28347   "RTN","RCD PEWL8",194 ,0)
  28348    Q
  28349   "RTN","RCD PEWL8",195 ,0)
  28350    ;
  28351   "RTN","RCD PEWL8",196 ,0)
  28352   BATED ; En try point  to batch e dit option s
  28353   "RTN","RCD PEWL8",197 ,0)
  28354    ; prca*4. 5*298  per  requireme nts, keep  code for c reating/ma intaining  batches bu t remove f rom execut ion
  28355   "RTN","RCD PEWL8",198 ,0)
  28356    Q  ; prca *4.5*298
  28357   "RTN","RCD PEWL8",199 ,0)
  28358    N DA,DIC, DIR,DTOUT, DUOUT,RCQU IT,X,Y
  28359   "RTN","RCD PEWL8",200 ,0)
  28360    D FULL^VA LM1
  28361   "RTN","RCD PEWL8",201 ,0)
  28362    ;
  28363   "RTN","RCD PEWL8",202 ,0)
  28364    W !!!!
  28365   "RTN","RCD PEWL8",203 ,0)
  28366    S RCQUIT= 0
  28367   "RTN","RCD PEWL8",204 ,0)
  28368    I '$O(^RC Y(344.49,R CERA,3,0))  W !,"**** * THERE AR E CURRENTL Y NO BATCH ES DEFINED  FOR THIS  ERA *****" ,!
  28369   "RTN","RCD PEWL8",205 ,0)
  28370    ; No menu  if enteri ng from a  batch leve l
  28371   "RTN","RCD PEWL8",206 ,0)
  28372    I $G(^TMP ("RCBATCH_ SELECTED", $J)) W !," EDITING BA TCH #"_+^T MP("RCBATC H_SELECTED ",$J) D ED IT^RCDPEWL B(RCERA,+^ TMP("RCBAT CH_SELECTE D",$J)) G  BATEDQ
  28373   "RTN","RCD PEWL8",207 ,0)
  28374    F  D  Q:R CQUIT
  28375   "RTN","RCD PEWL8",208 ,0)
  28376    . I '$D(^ XUSEC("PRC A ERA BATC H MAINT",D UZ)) D  Q
  28377   "RTN","RCD PEWL8",209 ,0)
  28378    .. S RCQU IT=1
  28379   "RTN","RCD PEWL8",210 ,0)
  28380    .. S DIR( 0)="EA",DI R("A")="YO U DO NOT H AVE SECURI TY ACCESS  TO THIS AC TION - Pre ss ENTER t o continue : " W ! D  ^DIR K DIR
  28381   "RTN","RCD PEWL8",211 ,0)
  28382    .;
  28383   "RTN","RCD PEWL8",212 ,0)
  28384    . W !,"BA TCH MAINTE NANCE:",!, ?10,"1",$J ("",5),"ED IT BATCH", !,?10,"2", $J("",5)," NEW BATCH  ASSIGNMENT ",!,?10,"3 ",$J("",5) ,"MARK ALL  READY TO  POST",!,?1 0,"4",$J(" ",5),"BATC H SUMMARY  REPORT",!, ?10,"5",$J ("",5),"QU IT AND RET URN TO WOR KLIST"
  28385   "RTN","RCD PEWL8",213 ,0)
  28386    . S DIR(0 )="SAO^1:E DIT BATCH; 2:NEW BATC HES;3:MARK  ALL;4:BAT CH SUMMARY ;5:QUIT"
  28387   "RTN","RCD PEWL8",214 ,0)
  28388    . S DIR(" A")="Selec t Action:  ",DIR("B") ="Quit" W  ! D ^DIR K  DIR
  28389   "RTN","RCD PEWL8",215 ,0)
  28390    . I Y="5" !(Y="")!$D (DUOUT)!$D (DTOUT) S  RCQUIT=1 Q
  28391   "RTN","RCD PEWL8",216 ,0)
  28392    . ;
  28393   "RTN","RCD PEWL8",217 ,0)
  28394    . I Y=1 D   W !! Q
  28395   "RTN","RCD PEWL8",218 ,0)
  28396    .. I '$O( ^RCY(344.4 9,RCERA,3, 0)) D NOTS ET^RCDPEWL C Q
  28397   "RTN","RCD PEWL8",219 ,0)
  28398    .. S DIR( "B")="ONE" ,DIR(0)="S A^A:ALL;O: ONE",DIR(" A")="EDIT( A)LL or (O )NE BATCH? : " W ! D  ^DIR K DIR
  28399   "RTN","RCD PEWL8",220 ,0)
  28400    .. I $D(D TOUT)!$D(D UOUT) Q
  28401   "RTN","RCD PEWL8",221 ,0)
  28402    .. I Y="A " D EDITAL L^RCDPEWLB (RCERA) Q
  28403   "RTN","RCD PEWL8",222 ,0)
  28404    .. S DA(1 )=RCERA,DI C="^RCY(34 4.49,"_DA( 1)_",3,",D IC(0)="AEM Q" D ^DIC
  28405   "RTN","RCD PEWL8",223 ,0)
  28406    .. Q:Y'>0
  28407   "RTN","RCD PEWL8",224 ,0)
  28408    .. D EDIT ^RCDPEWLB( RCERA,+Y)
  28409   "RTN","RCD PEWL8",225 ,0)
  28410    . ;
  28411   "RTN","RCD PEWL8",226 ,0)
  28412    . I Y=2 D  REBATCH^R CDPEWLB(RC ERA) W !!  Q
  28413   "RTN","RCD PEWL8",227 ,0)
  28414    . ;
  28415   "RTN","RCD PEWL8",228 ,0)
  28416    . I Y=3 D  MARKALL^R CDPEWLB(RC ERA) W !!  Q
  28417   "RTN","RCD PEWL8",229 ,0)
  28418    . ;
  28419   "RTN","RCD PEWL8",230 ,0)
  28420    . I Y=4 D  SUMRPT^RC DPEWLC(RCE RA) W !! Q
  28421   "RTN","RCD PEWL8",231 ,0)
  28422    ;
  28423   "RTN","RCD PEWL8",232 ,0)
  28424   BATEDQ S V ALMBCK="R"
  28425   "RTN","RCD PEWL8",233 ,0)
  28426    Q
  28427   "RTN","RCD PEWL8",234 ,0)
  28428    ;
  28429   "RTN","RCD PEWL8",235 ,0)
  28430   AUTOPOST(S OURCE) ;EP  Protocol  action - R CDPE EOB W ORKLIST MA RK FOR AUT O POST
  28431   "RTN","RCD PEWL8",236 ,0)
  28432    ; Input:
  28433   "RTN","RCD PEWL8",237 ,0)
  28434    ;   SOURC E
  28435   "RTN","RCD PEWL8",238 ,0)
  28436    ;      1: Called by  Worklist ( RCDPE WORK LIST ERA M ARK FOR AU TO POST)
  28437   "RTN","RCD PEWL8",239 ,0)
  28438    ;      2: Called by  Scratchpad  (RCDPE WO RKLIST EOB  MARK FOR  AUTO POST)
  28439   "RTN","RCD PEWL8",240 ,0)
  28440    ;   If SO URCE=2, RC SCR will b e set to t he IEN of  344.4
  28441   "RTN","RCD PEWL8",241 ,0)
  28442    ;
  28443   "RTN","RCD PEWL8",242 ,0)
  28444    D FULL^VA LM1
  28445   "RTN","RCD PEWL8",243 ,0)
  28446    I '$D(^XU SEC("RCDPE PP",DUZ))  D  Q  ; PR CA*4.5*318  Added sec urity key  check
  28447   "RTN","RCD PEWL8",244 ,0)
  28448    . W !!,"T his action  can only  be taken b y users th at have th e RCDPEPP  security k ey.",!
  28449   "RTN","RCD PEWL8",245 ,0)
  28450    . D PAUSE ^VALM1
  28451   "RTN","RCD PEWL8",246 ,0)
  28452    . S VALMB CK="R"
  28453   "RTN","RCD PEWL8",247 ,0)
  28454    ;
  28455   "RTN","RCD PEWL8",248 ,0)
  28456    ; If call ed by Work list (SOUR CE=1), the n ask whic h ERA
  28457   "RTN","RCD PEWL8",249 ,0)
  28458    ; If call ed by Scra tchpad (SO URCE=2), E RA is alre ady in var iable RCSC R
  28459   "RTN","RCD PEWL8",250 ,0)
  28460    N RCERA
  28461   "RTN","RCD PEWL8",251 ,0)
  28462    I SOURCE= 1 S RCERA= $$SEL^RCDP EWL7()
  28463   "RTN","RCD PEWL8",252 ,0)
  28464    I SOURCE= 2 S RCERA= $G(RCSCR)
  28465   "RTN","RCD PEWL8",253 ,0)
  28466    I 'RCERA  S VALMBCK= "R" Q
  28467   "RTN","RCD PEWL8",254 ,0)
  28468    ;
  28469   "RTN","RCD PEWL8",255 ,0)
  28470    N AUTOPOS T
  28471   "RTN","RCD PEWL8",256 ,0)
  28472    S AUTOPOS T=$$AUTOCH K2^RCDPEAP 1(RCERA,0)  ; added p arameter -  PRCA*4.5* 321
  28473   "RTN","RCD PEWL8",257 ,0)
  28474    I AUTOPOS T D
  28475   "RTN","RCD PEWL8",258 ,0)
  28476    . D SETST A^RCDPEAP( RCERA,0,"W orklist: M arked as A uto-Post C andidate")
  28477   "RTN","RCD PEWL8",259 ,0)
  28478    . W !,"ER A has been  successfu lly Marked  as an Aut o-Post CAN DIDATE"
  28479   "RTN","RCD PEWL8",260 ,0)
  28480    I 'AUTOPO ST D
  28481   "RTN","RCD PEWL8",261 ,0)
  28482    . D AUDIT LOG^RCDPEA P(RCERA,"" ,"Worklist : Not Mark ed as Auto -Post Cand idate-"_$P (AUTOPOST, U,2))
  28483   "RTN","RCD PEWL8",262 ,0)
  28484    . W !,"ER A was NOT  Marked as  an Auto-Po st CANDIDA TE - ",$P( AUTOPOST,U ,2)
  28485   "RTN","RCD PEWL8",263 ,0)
  28486    ;
  28487   "RTN","RCD PEWL8",264 ,0)
  28488   AUTOPSTQ ;
  28489   "RTN","RCD PEWL8",265 ,0)
  28490    K DIR
  28491   "RTN","RCD PEWL8",266 ,0)
  28492    S DIR(0)= "E" D ^DIR
  28493   "RTN","RCD PEWL8",267 ,0)
  28494    S VALMBCK ="R"
  28495   "RTN","RCD PEWL8",268 ,0)
  28496    Q
  28497   "RTN","RCD PEWLD")
  28498   0^67^B1013 21313
  28499   "RTN","RCD PEWLD",1,0 )
  28500   RCDPEWLD ; ALB/CLT -  Continuati on of rout ine RCDPEW L0 ;09 DEC  2016
  28501   "RTN","RCD PEWLD",2,0 )
  28502    ;;4.5;Acc ounts Rece ivable;**2 52,317,321 **;Mar 20,  1995;Buil d 46
  28503   "RTN","RCD PEWLD",3,0 )
  28504    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  28505   "RTN","RCD PEWLD",4,0 )
  28506    Q
  28507   "RTN","RCD PEWLD",5,0 )
  28508    ;
  28509   "RTN","RCD PEWLD",6,0 )
  28510   PROV(RCSCR ,RCSCR1,RC XM1,RC) ;G et prov da ta from ER A (FILE 34 4.4) and c laim (FILE  399)
  28511   "RTN","RCD PEWLD",7,0 )
  28512    N RCXXX,R CYYY,RCDPE PV,RCCLAIM ,RCIEN,RCB ILL,RCID,R CBLANK,RCN PI,DIC,X,Y
  28513   "RTN","RCD PEWLD",8,0 )
  28514    N RCPROV, RCEXP,XUSN PI,RCRTN,R CBNM,RCCOM 1,RCCOM2,R CWARN,RCYN ODE3
  28515   "RTN","RCD PEWLD",9,0 )
  28516    ;
  28517   "RTN","RCD PEWLD",10, 0)
  28518    S RCBLANK ="" F X=1: 1:30 S RCB LANK=RCBLA NK_" "
  28519   "RTN","RCD PEWLD",11, 0)
  28520    S RC=RC+1  S RCXM1(R C-1)=RCBLA NK
  28521   "RTN","RCD PEWLD",12, 0)
  28522    S RCYNODE 3=$G(^RCY( 344.4,RCSC R,1,RCSCR1 ,3))
  28523   "RTN","RCD PEWLD",13, 0)
  28524    ;
  28525   "RTN","RCD PEWLD",14, 0)
  28526   LKBOX ;Get  provider  data from  ELECTRONIC  REMITTANC E ADVICE f ile (#344. 4)
  28527   "RTN","RCD PEWLD",15, 0)
  28528    S RC=RC+1 ,RCXM1(RC- 1)=$E("**E OB PROVIDE R(S)/NPI"_ $J(" ",39) ,1,39)_"CL AIM PROVID ER(S)/NPI* *"  ;setti ng sub-hea der for wo rklist
  28529   "RTN","RCD PEWLD",16, 0)
  28530    S RC=RC+1 ,RCXM1(RC- 1)=$E("--- ---------- --------"_ $J(" ",39) ,1,39)_"-- ---------- ---------- -"
  28531   "RTN","RCD PEWLD",17, 0)
  28532    ;
  28533   "RTN","RCD PEWLD",18, 0)
  28534    S RCPROV= "BILLING", $P(RCYYY(R CPROV),U,3 )=0         ; piece 3  initializ e for erro r msgs
  28535   "RTN","RCD PEWLD",19, 0)
  28536    I $P(RCYN ODE3,U)'=" " S RCYYY( RCPROV)="/ "_$P(RCYNO DE3,U)   ;  Billing P rov NPI 
  28537   "RTN","RCD PEWLD",20, 0)
  28538    ;
  28539   "RTN","RCD PEWLD",21, 0)
  28540    S RCPROV= "RENDERING "
  28541   "RTN","RCD PEWLD",22, 0)
  28542    I $P(RCYN ODE3,U,3)= 2 S RCPROV ="SERVICIN G"
  28543   "RTN","RCD PEWLD",23, 0)
  28544    I $P(RCYN ODE3,U,3)= "",($P(RCY NODE3,U,4) '[","),($P (RCYNODE3, U,4)'="")  S RCPROV=" SERVICING"
  28545   "RTN","RCD PEWLD",24, 0)
  28546    I $P(RCYN ODE3,U,2)' =""!($P(RC YNODE3,U,4 )'="") S R CYYY(RCPRO V)=$E($P(R CYNODE3,U, 4),1,20)_" /"_$P(RCYN ODE3,U,2)
  28547   "RTN","RCD PEWLD",25, 0)
  28548    S $P(RCYY Y(RCPROV), U,3)=0                             ; initia lize for e rror msgs
  28549   "RTN","RCD PEWLD",26, 0)
  28550    D NPICHK         ; R CPROV has  to be "REN DERING" or  "SERVICIN G" when th is tag is  called !
  28551   "RTN","RCD PEWLD",27, 0)
  28552    ;
  28553   "RTN","RCD PEWLD",28, 0)
  28554   CLAIM ;Ret rieve prov ider data  from the c laim
  28555   "RTN","RCD PEWLD",29, 0)
  28556    S RCCLAIM =$$GET1^DI Q(361.1,$P (^RCY(344. 4,RCSCR,1, RCSCR1,0), U,2),.01)  ;determine  claim num  based on  entry in 3 44.4
  28557   "RTN","RCD PEWLD",30, 0)
  28558    S DIC="^D GCR(399,", DIC(0)="", X=RCCLAIM  D ^DIC S R CCLAIM=+Y       ;find  ien for f ile 399
  28559   "RTN","RCD PEWLD",31, 0)
  28560    D GETS^DI Q(399,RCCL AIM,"222*" ,"IE","RCX XX")          ;retrie ve prov in formation
  28561   "RTN","RCD PEWLD",32, 0)
  28562    S RCBILL= $$GET1^DIQ (399,RCCLA IM,.22,"I" )             ;retrie ve default  division
  28563   "RTN","RCD PEWLD",33, 0)
  28564    S RCBNM=$ $GET1^DIQ( 4,$$GET1^D IQ(40.8,RC BILL,.07," I"),.01)   ;get name  from insti tution fil e
  28565   "RTN","RCD PEWLD",34, 0)
  28566    S RCBILL= $$GET1^DIQ (4,$$GET1^ DIQ(40.8,R CBILL,.07, "I"),41.99 )  ;get NP I from ins titution f ile
  28567   "RTN","RCD PEWLD",35, 0)
  28568    ;
  28569   "RTN","RCD PEWLD",36, 0)
  28570    S $P(RCYY Y("BILLING "),U,2)=RC BNM_"/"_RC BILL_"^"_0   ;NPI set  into loca l array
  28571   "RTN","RCD PEWLD",37, 0)
  28572    I $D(RCXX X) S RCPRO V="" F  S  RCPROV=$O( RCXXX(399. 0222,RCPRO V)) Q:RCPR OV=""  D   ;loop thro ugh claim  providers
  28573   "RTN","RCD PEWLD",38, 0)
  28574    . S RCIEN =$P(RCXXX( 399.0222,R CPROV,.02, "I"),";",1 )
  28575   "RTN","RCD PEWLD",39, 0)
  28576    . S RCID= $S($P(RCXX X(399.0222 ,RCPROV,.0 2,"I"),";" ,2)["VA(20 0":"Indivi dual_ID",1 :"Non_VA_P rovider_ID ")
  28577   "RTN","RCD PEWLD",40, 0)
  28578    . S RCNPI =$$NPI^XUS NPI(RCID,R CIEN)                    ;retrie ve provide r NPI
  28579   "RTN","RCD PEWLD",41, 0)
  28580    . S $P(RC YYY(RCXXX( 399.0222,R CPROV,.01, "E")),U,2) =$E(RCXXX( 399.0222,R CPROV,.02, "E"),1,20) _"/"_$S(+R CNPI=0:"No  NPI on fi le",+RCNPI =-1:"Can't  look up N PI",1:+RCN PI)
  28581   "RTN","RCD PEWLD",42, 0)
  28582    . S:$P(RC YYY(RCXXX( 399.0222,R CPROV,.01, "E")),U,3) ="" $P(RCY YY(RCXXX(3 99.0222,RC PROV,.01," E")),U,3)= 0
  28583   "RTN","RCD PEWLD",43, 0)
  28584   LINESET ;S ET THE PRI NT LINES
  28585   "RTN","RCD PEWLD",44, 0)
  28586    S (RCWARN ,RCPROV)=" " F  S RCP ROV=$O(RCY YY(RCPROV) ) Q:RCPROV =""  D  ;l oop throug h the foun d provider  types
  28587   "RTN","RCD PEWLD",45, 0)
  28588    . S RC=RC +1                                              ;incre ment line  counter
  28589   "RTN","RCD PEWLD",46, 0)
  28590    . ; build  display d etail line
  28591   "RTN","RCD PEWLD",47, 0)
  28592    . S RCXM1 (RC-1)=RCP ROV_": "_$ P(RCYYY(RC PROV),U,1)
  28593   "RTN","RCD PEWLD",48, 0)
  28594    . I $L(RC XM1(RC-1)) >39 D
  28595   "RTN","RCD PEWLD",49, 0)
  28596    .. S RCXM 1(RC-1)=$E ($P(RCXM1( RC-1),"/") ,1,27)_"/" _$P(RCXM1( RC-1),"/", 2)
  28597   "RTN","RCD PEWLD",50, 0)
  28598    . S RCXM1 (RC-1)=$E( RCXM1(RC-1 )_RCBLANK, 1,39)_$P(R CYYY(RCPRO V),U,2)
  28599   "RTN","RCD PEWLD",51, 0)
  28600    . I $P(RC YYY(RCPROV ),U,3)'=0  S RCWARN=$ P(RCYYY(RC PROV),U,3)
  28601   "RTN","RCD PEWLD",52, 0)
  28602    I RCWARN' ="" D
  28603   "RTN","RCD PEWLD",53, 0)
  28604    . S RC=RC +1,RCXM1(R C-1)=" "                             ;Blank  line for  separation
  28605   "RTN","RCD PEWLD",54, 0)
  28606    . S RC=RC +1,RCXM1(R C-1)="Rend ering/Serv icing Prov ider NPI W arning:"
  28607   "RTN","RCD PEWLD",55, 0)
  28608    . S RC=RC +1,RCXM1(R C-1)=RCWAR N
  28609   "RTN","RCD PEWLD",56, 0)
  28610    S RC=RC+1 ,RCXM1(RC- 1)=" "                               ;Blank  line to s eparate fr om possibl e comments
  28611   "RTN","RCD PEWLD",57, 0)
  28612    S RCCOM1= $P(RCYNODE 3,U,5),RCC OM2=$P(RCY NODE3,U,6)  D  ;Error  in NPI fo rmat
  28613   "RTN","RCD PEWLD",58, 0)
  28614    . I $G(RC COM1)'=""  S RC=RC+1, RCXM1(RC-1 )=RCCOM1
  28615   "RTN","RCD PEWLD",59, 0)
  28616    . I $G(RC COM2)'=""  S RC=RC+1, RCXM1(RC-1 )=RCCOM2
  28617   "RTN","RCD PEWLD",60, 0)
  28618    Q
  28619   "RTN","RCD PEWLD",61, 0)
  28620    ;
  28621   "RTN","RCD PEWLD",62, 0)
  28622   NPICHK ;CH ECK THAT T HE NPI RET URNED MATC HES THE EN TITY TYPE  QUALIFIER
  28623   "RTN","RCD PEWLD",63, 0)
  28624    S RCEXP=" " Q:$P(RCY NODE3,U,3) =""                ;  ENTITY TYP E QUALIFIE R
  28625   "RTN","RCD PEWLD",64, 0)
  28626    ;
  28627   "RTN","RCD PEWLD",65, 0)
  28628    S RCCOM2= $P(RCYNODE 3,U,6) ; R en/Serv co mment
  28629   "RTN","RCD PEWLD",66, 0)
  28630    S XUSNPI= $P(RCYNODE 3,U,2)
  28631   "RTN","RCD PEWLD",67, 0)
  28632    I RCCOM2= "",(XUSNPI ="") S RCE XP="**NO S ERVICING/R ENDERING N PI INCLUDE D IN 835** " D EXPSET  Q
  28633   "RTN","RCD PEWLD",68, 0)
  28634    S RCRTN=$ $QI^XUSNPI (XUSNPI)
  28635   "RTN","RCD PEWLD",69, 0)
  28636    I $P(RCRT N,U,1)="In dividual_I D" D  Q
  28637   "RTN","RCD PEWLD",70, 0)
  28638    . I $P(RC YNODE3,U,3 )'=1 S RCE XP="**NPI  from 835 i ndicated o rganizatio nal but is  associate d with an  individual **" D EXPS ET Q
  28639   "RTN","RCD PEWLD",71, 0)
  28640    I $P(RCRT N,U,1)="Or ganization _ID" D  Q
  28641   "RTN","RCD PEWLD",72, 0)
  28642    . I $P(RC YNODE3,U,3 )'=2 S RCE XP="**NPI  from 835 i ndicated i ndividual  but is ass ociated wi th an orga nization** " D EXPSET  Q
  28643   "RTN","RCD PEWLD",73, 0)
  28644    I $E($P(R CRTN,U,1), 1,3)="Non"  D  Q
  28645   "RTN","RCD PEWLD",74, 0)
  28646    . N RCIEN ,RCTYPE S  RCIEN=$P(R CRTN,U,2), RCTYPE=$$G ET1^DIQ(35 5.93,RCIEN ,.02,"I")  Q:$G(RCTYP E)=""
  28647   "RTN","RCD PEWLD",75, 0)
  28648    . I $P(RC YNODE3,U,3 )=1,RCTYPE =1 S RCEXP ="**NPI fr om 835 ind icated ind ividual bu t is assoc iated with  an organi zation**"  D EXPSET Q
  28649   "RTN","RCD PEWLD",76, 0)
  28650    . I $P(RC YNODE3,U,3 )=2,RCTYPE =2 S RCEXP ="**NPI fr om 835 ind icated org anizationa l but is a ssociated  with an in dividual** " D EXPSET  Q
  28651   "RTN","RCD PEWLD",77, 0)
  28652    I RCCOM2= "",(+RCRTN =0) S RCEX P="**The N PI returne d on the 8 35 is not  associated  with this  VistA sys tem**" D E XPSET Q
  28653   "RTN","RCD PEWLD",78, 0)
  28654    Q
  28655   "RTN","RCD PEWLD",79, 0)
  28656    ;
  28657   "RTN","RCD PEWLD",80, 0)
  28658   EXPSET ;SE T THE PRIN T LINE WIT H THE ERRO R AS DEFIN ED IN RCEX P
  28659   "RTN","RCD PEWLD",81, 0)
  28660    S $P(RCYY Y(RCPROV), U,3)=RCEXP
  28661   "RTN","RCD PEWLD",82, 0)
  28662    Q
  28663   "RTN","RCD PEWLD",83, 0)
  28664    ;
  28665   "RTN","RCD PEWLD",84, 0)
  28666   PARAMS(RCQ UIT) ;PARA METERS ENT RY CONTINU ED FROM RC DPEWL0
  28667   "RTN","RCD PEWLD",85, 0)
  28668    I $G(RCQU IT) K ^TMP ("RCERA_PA RAMS",$J)
  28669   "RTN","RCD PEWLD",86, 0)
  28670   PARMSQ ;
  28671   "RTN","RCD PEWLD",87, 0)
  28672    Q
  28673   "RTN","RCD PEWLD",88, 0)
  28674    ;
  28675   "RTN","RCD PEWLD",89, 0)
  28676   PARAMS2()  ;EP from R CDPEWL0
  28677   "RTN","RCD PEWLD",90, 0)
  28678    ; PRCA*4. 5*317 - Mo ved due to  routine s ize issues
  28679   "RTN","RCD PEWLD",91, 0)
  28680    ; Input:    None
  28681   "RTN","RCD PEWLD",92, 0)
  28682    ; Returns : RCQUIT   - 1 if use r ^ or tim ed out, 0  otherwise
  28683   "RTN","RCD PEWLD",93, 0)
  28684    S RCQUIT= $$PAYMNT()                           ; Ask  for zero/p ayment PRC A*4.5*321
  28685   "RTN","RCD PEWLD",94, 0)
  28686    Q:RCQUIT  1                                                           ; PRC A*4.5*321
  28687   "RTN","RCD PEWLD",95, 0)
  28688    S RCQUIT= $$POSTSTAT ()                        ; Ask  Posting St atus
  28689   "RTN","RCD PEWLD",96, 0)
  28690    Q:RCQUIT  1
  28691   "RTN","RCD PEWLD",97, 0)
  28692    S RCQUIT= $$POSTMETH                           ; Ask  Posting Me thod
  28693   "RTN","RCD PEWLD",98, 0)
  28694    Q:RCQUIT  1
  28695   "RTN","RCD PEWLD",99, 0)
  28696    S RCQUIT= $$MATCHST                            ; Ask  ERA-EFT Ma tching Sta tus
  28697   "RTN","RCD PEWLD",100 ,0)
  28698    Q:RCQUIT  1
  28699   "RTN","RCD PEWLD",101 ,0)
  28700    S RCQUIT= $$CLAIMTYP ()                        ; Ask  Claim Type
  28701   "RTN","RCD PEWLD",102 ,0)
  28702    Q:RCQUIT  1
  28703   "RTN","RCD PEWLD",103 ,0)
  28704    S RCQUIT= $$PAYR()                             ; Ask  for select ed payers
  28705   "RTN","RCD PEWLD",104 ,0)
  28706    Q RCQUIT
  28707   "RTN","RCD PEWLD",105 ,0)
  28708    ;
  28709   "RTN","RCD PEWLD",106 ,0)
  28710   PAYMNT() ;  Payment T ype (Zero/ Payment or  Both) Sel ection ; P RCA*4.5*32 1 this who le subrout ine
  28711   "RTN","RCD PEWLD",107 ,0)
  28712    ; Input:    ^TMP("RC ERA_PARAMS ")                - G lobal arra y of prefe rred value s (if any)
  28713   "RTN","RCD PEWLD",108 ,0)
  28714    ; Output:   ^TMP("RC ERA_PARAMS ",$J,"RCPA YMNT") - E RA Posting  Status fi lter
  28715   "RTN","RCD PEWLD",109 ,0)
  28716    ; Returns : 1 if use r quit or  timed out,  0 otherwi se
  28717   "RTN","RCD PEWLD",110 ,0)
  28718    N DIR,DTO UT,DUOUT,R CTYPEDF
  28719   "RTN","RCD PEWLD",111 ,0)
  28720    S RCTYPED F=$G(^TMP( "RCERA_PAR AMS",$J,"R CPAYMNT"))
  28721   "RTN","RCD PEWLD",112 ,0)
  28722    K DIR S D IR(0)="SA^ Z:ZERO;P:P AYMENT;B:B OTH"
  28723   "RTN","RCD PEWLD",113 ,0)
  28724    S DIR("A" )="(Z)ERO,  (P)AYMENT , or (B)OT H: "
  28725   "RTN","RCD PEWLD",114 ,0)
  28726    S DIR("B" )="B"
  28727   "RTN","RCD PEWLD",115 ,0)
  28728    S DIR("?" ,1)="Selec t ZERO to  only see E RAs with a  zero tota l amount p aid."
  28729   "RTN","RCD PEWLD",116 ,0)
  28730    S DIR("?" ,2)="Selec t PAYMENT  to only se e ERAs wit h a non-ze ro amount  paid."
  28731   "RTN","RCD PEWLD",117 ,0)
  28732    S DIR("?" )="Select  BOTH to se e both zer o and non- zero amoun t ERAs."
  28733   "RTN","RCD PEWLD",118 ,0)
  28734    S:RCTYPED F'="" DIR( "B")=RCTYP EDF     ;S tored pref erred valu e, use as  default
  28735   "RTN","RCD PEWLD",119 ,0)
  28736    W !
  28737   "RTN","RCD PEWLD",120 ,0)
  28738    D ^DIR
  28739   "RTN","RCD PEWLD",121 ,0)
  28740    I $D(DTOU T)!$D(DUOU T) Q 1
  28741   "RTN","RCD PEWLD",122 ,0)
  28742    S ^TMP("R CERA_PARAM S",$J,"RCP AYMNT")=Y
  28743   "RTN","RCD PEWLD",123 ,0)
  28744    Q 0
  28745   "RTN","RCD PEWLD",124 ,0)
  28746    ;
  28747   "RTN","RCD PEWLD",125 ,0)
  28748   POSTSTAT()  ; ERA Pos ting Statu s (Posted/ Unposted/B oth) Selec tion
  28749   "RTN","RCD PEWLD",126 ,0)
  28750    ; Input:    ^TMP("RC ERA_PARAMS ")             - Glob al array o f preferre d values ( if any)
  28751   "RTN","RCD PEWLD",127 ,0)
  28752    ; Output:   ^TMP("RC ERA_PARAMS ",$J,"RCPO ST")- ERA  Posting St atus filte r
  28753   "RTN","RCD PEWLD",128 ,0)
  28754    ; Returns : 1 if use r quit or  timed out,  0 otherwi se
  28755   "RTN","RCD PEWLD",129 ,0)
  28756    N DIR,DTO UT,DUOUT,R CPOSTDF
  28757   "RTN","RCD PEWLD",130 ,0)
  28758    S RCPOSTD F=$G(^TMP( "RCERA_PAR AMS",$J,"R CPOST"))
  28759   "RTN","RCD PEWLD",131 ,0)
  28760    K DIR S D IR(0)="SA^ U:UNPOSTED ;P:POSTED; B:BOTH"
  28761   "RTN","RCD PEWLD",132 ,0)
  28762    S DIR("A" )="ERA pos ting statu s: (U)NPOS TED, (P)OS TED, or (B )OTH: "
  28763   "RTN","RCD PEWLD",133 ,0)
  28764    S DIR("B" )="U"
  28765   "RTN","RCD PEWLD",134 ,0)
  28766    S DIR("?" ,1)="Selec t UNPOSTED  to only s ee ERAs wi th a statu s of UNPOS TED."
  28767   "RTN","RCD PEWLD",135 ,0)
  28768    S DIR("?" ,2)="Selec t POSTED t o only see  ERAs with  a status  of POSTED. "
  28769   "RTN","RCD PEWLD",136 ,0)
  28770    S DIR("?" )="Select  BOTH to se e both unp osted and  posted ERA s."
  28771   "RTN","RCD PEWLD",137 ,0)
  28772    S:RCPOSTD F'="" DIR( "B")=RCPOS TDF    ; S tored pref erred valu e, use as  default
  28773   "RTN","RCD PEWLD",138 ,0)
  28774    W !
  28775   "RTN","RCD PEWLD",139 ,0)
  28776    D ^DIR
  28777   "RTN","RCD PEWLD",140 ,0)
  28778    I $D(DTOU T)!$D(DUOU T) Q 1
  28779   "RTN","RCD PEWLD",141 ,0)
  28780    S ^TMP("R CERA_PARAM S",$J,"RCP OST")=Y
  28781   "RTN","RCD PEWLD",142 ,0)
  28782    Q 0
  28783   "RTN","RCD PEWLD",143 ,0)
  28784    ;
  28785   "RTN","RCD PEWLD",144 ,0)
  28786   POSTMETH()   ; PRCA*4 .5*317 mov ed from RC DPEWL0 bec ause of ro utine size  issues
  28787   "RTN","RCD PEWLD",145 ,0)
  28788    ; ERA Pos ting Metho d (Auto-Po sting/Non  Auto-Posti ng/Both) S election
  28789   "RTN","RCD PEWLD",146 ,0)
  28790    ; Input:    ^TMP("RC ERA_PARAMS ")              - Glo bal array  of preferr ed values  (if any)
  28791   "RTN","RCD PEWLD",147 ,0)
  28792    ; Output:   ^TMP("RC ERA_PARAMS ",$J,"RCAU TOP")- ERA  Posting S tatus filt er
  28793   "RTN","RCD PEWLD",148 ,0)
  28794    ; Returns : 1 if use r quit or  timed out,  0 otherwi se
  28795   "RTN","RCD PEWLD",149 ,0)
  28796    N DIR,DTO UT,DUOUT,R CAUTOPDF
  28797   "RTN","RCD PEWLD",150 ,0)
  28798    S RCAUTOP DF=$G(^TMP ("RCERA_PA RAMS",$J," RCAUTOP"))
  28799   "RTN","RCD PEWLD",151 ,0)
  28800    K DIR S D IR(0)="SA^ A:AUTO-POS TING;N:NON  AUTO-POST ING;B:BOTH "
  28801   "RTN","RCD PEWLD",152 ,0)
  28802    S DIR("A" )="Display  (A)UTO-PO STING, (N) ON AUTO-PO STING, or  (B)OTH: "
  28803   "RTN","RCD PEWLD",153 ,0)
  28804    S DIR("B" )="B"
  28805   "RTN","RCD PEWLD",154 ,0)
  28806    S DIR("?" ,1)="Selec t AUTO-POS TING to on ly see aut o-posted E RAs."
  28807   "RTN","RCD PEWLD",155 ,0)
  28808    S DIR("?" ,2)="Selec t NON AUTO -POSTING t o only see  ERAs that  were NOT  auto-poste d."
  28809   "RTN","RCD PEWLD",156 ,0)
  28810    S DIR("?" )="Select  BOTH to se e both aut o-posted a nd non aut o-posted E RAs."
  28811   "RTN","RCD PEWLD",157 ,0)
  28812    S:RCAUTOP DF'="" DIR ("B")=RCAU TOPDF    ; Stored pre ferred val ue, use as  default
  28813   "RTN","RCD PEWLD",158 ,0)
  28814    W !
  28815   "RTN","RCD PEWLD",159 ,0)
  28816    D ^DIR
  28817   "RTN","RCD PEWLD",160 ,0)
  28818    I $D(DTOU T)!$D(DUOU T) Q 1
  28819   "RTN","RCD PEWLD",161 ,0)
  28820    S ^TMP("R CERA_PARAM S",$J,"RCA UTOP")=Y
  28821   "RTN","RCD PEWLD",162 ,0)
  28822    Q 0
  28823   "RTN","RCD PEWLD",163 ,0)
  28824    ;
  28825   "RTN","RCD PEWLD",164 ,0)
  28826   MATCHST()   ; ERA-EFT  Matching  Status(Mat ched/Unmat ched/Both)  Selection
  28827   "RTN","RCD PEWLD",165 ,0)
  28828    ; Input:    ^TMP("RC ERA_PARAMS ")              - Glo bal array  of preferr ed values  (if any)
  28829   "RTN","RCD PEWLD",166 ,0)
  28830    ; Output:   ^TMP("RC ERA_PARAMS ",$J,"RCMA TCH")- ERA  Posting S tatus filt er
  28831   "RTN","RCD PEWLD",167 ,0)
  28832    ; Returns : 1 if use r quit or  timed out,  0 otherwi se
  28833   "RTN","RCD PEWLD",168 ,0)
  28834    N DIR,DTO UT,DUOUT,R CMATCHD
  28835   "RTN","RCD PEWLD",169 ,0)
  28836    S RCMATCH D=$G(^TMP( "RCERA_PAR AMS",$J,"R CMATCH"))
  28837   "RTN","RCD PEWLD",170 ,0)
  28838    K DIR S D IR(0)="SA^ N:NOT MATC HED;M:MATC HED;B:BOTH "
  28839   "RTN","RCD PEWLD",171 ,0)
  28840    S DIR("A" )="ERA-EFT  match sta tus: (N)OT  MATCHED,  (M)ATCHED,  or (B)OTH : "
  28841   "RTN","RCD PEWLD",172 ,0)
  28842    S DIR("B" )="B"
  28843   "RTN","RCD PEWLD",173 ,0)
  28844    S DIR("?" ,1)="Selec t NOT MATC HED to onl y see unma tched ERAs ."
  28845   "RTN","RCD PEWLD",174 ,0)
  28846    S DIR("?" ,2)="Selec t MATCHED  to only se e matched  ERAs."
  28847   "RTN","RCD PEWLD",175 ,0)
  28848    S DIR("?" )="Select  BOTH to se e both mat ched and u nmatched E RAs."
  28849   "RTN","RCD PEWLD",176 ,0)
  28850    S:RCMATCH D'="" DIR( "B")=RCMAT CHD      ; Stored pre ferred val ue, use as  default
  28851   "RTN","RCD PEWLD",177 ,0)
  28852    W !
  28853   "RTN","RCD PEWLD",178 ,0)
  28854    D ^DIR
  28855   "RTN","RCD PEWLD",179 ,0)
  28856    I $D(DTOU T)!$D(DUOU T) Q 1
  28857   "RTN","RCD PEWLD",180 ,0)
  28858    S ^TMP("R CERA_PARAM S",$J,"RCM ATCH")=Y
  28859   "RTN","RCD PEWLD",181 ,0)
  28860    Q 0
  28861   "RTN","RCD PEWLD",182 ,0)
  28862    ;
  28863   "RTN","RCD PEWLD",183 ,0)
  28864   CLAIMTYP()   ; Claim  Type (Medi cal/Pharma cy/Both) S election
  28865   "RTN","RCD PEWLD",184 ,0)
  28866    ; Input:    ^TMP("RC ERA_PARAMS ")              - Glo bal array  of preferr ed values  (if any)
  28867   "RTN","RCD PEWLD",185 ,0)
  28868    ; Output:   ^TMP("RC ERA_PARAMS ",$J,"RCTY PE") - ERA  Posting S tatus filt er
  28869   "RTN","RCD PEWLD",186 ,0)
  28870    ; Returns : 1 if use r quit or  timed out,  0 otherwi se
  28871   "RTN","RCD PEWLD",187 ,0)
  28872    N DIR,DTO UT,DUOUT,R CTYPEDF
  28873   "RTN","RCD PEWLD",188 ,0)
  28874    S RCTYPED F=$G(^TMP( "RCERA_PAR AMS",$J,"R CTYPE"))
  28875   "RTN","RCD PEWLD",189 ,0)
  28876    ; PRCA*4. 5*321 - Ch anged set  of codes a nd help
  28877   "RTN","RCD PEWLD",190 ,0)
  28878    K DIR S D IR(0)="SA^ M:MEDICAL; P:PHARMACY ;T:TRICARE ;A:ALL"
  28879   "RTN","RCD PEWLD",191 ,0)
  28880    S DIR("A" )="(M)EDIC AL, (P)HAR MACY, (T)R ICARE or ( A)LL: "
  28881   "RTN","RCD PEWLD",192 ,0)
  28882    S DIR("B" )="A"
  28883   "RTN","RCD PEWLD",193 ,0)
  28884    S DIR("?" ,1)="Selec t MEDICAL  to only se e ERAs wit h a payer  type of me dical."
  28885   "RTN","RCD PEWLD",194 ,0)
  28886    S DIR("?" ,2)="Selec t PHARMACY  to only s ee ERAs wi th a payer  type of p harmacy."
  28887   "RTN","RCD PEWLD",195 ,0)
  28888    S DIR("?" ,3)="Selec t TRICARE  to only se e ERAs wit h a payer  type of Tr icare."
  28889   "RTN","RCD PEWLD",196 ,0)
  28890    S DIR("?" )="Select  ALL to see  medical,  pharmacy a nd Tricare  ERAs."
  28891   "RTN","RCD PEWLD",197 ,0)
  28892    ; PRCA*4. 5*321 - En d modified  code bloc k
  28893   "RTN","RCD PEWLD",198 ,0)
  28894    S:RCTYPED F'="" DIR( "B")=RCTYP EDF     ;S tored pref erred valu e, use as  default
  28895   "RTN","RCD PEWLD",199 ,0)
  28896    W !
  28897   "RTN","RCD PEWLD",200 ,0)
  28898    D ^DIR
  28899   "RTN","RCD PEWLD",201 ,0)
  28900    I $D(DTOU T)!$D(DUOU T) Q 1
  28901   "RTN","RCD PEWLD",202 ,0)
  28902    S ^TMP("R CERA_PARAM S",$J,"RCT YPE")=Y
  28903   "RTN","RCD PEWLD",203 ,0)
  28904    Q 0
  28905   "RTN","RCD PEWLD",204 ,0)
  28906    ;
  28907   "RTN","RCD PEWLD",205 ,0)
  28908   PAYR() ; P ayer Selec tion
  28909   "RTN","RCD PEWLD",206 ,0)
  28910    ; Input:    ^TMP("RC ERA_PARAMS ",$J)           - Glo bal array  of preferr ed values  (if any)
  28911   "RTN","RCD PEWLD",207 ,0)
  28912    ; Output:   ^TMP("RC ERA_PARAMS ",$J,"RCTY PE") - ERA  Posting S tatus filt er
  28913   "RTN","RCD PEWLD",208 ,0)
  28914    ; Returns : 1 if use r quit or  timed out,  0 otherwi se
  28915   "RTN","RCD PEWLD",209 ,0)
  28916    N DIR,DTO UT,DUOUT,P QUIT,RCPAY R,RCPAYRDF
  28917   "RTN","RCD PEWLD",210 ,0)
  28918    S RCPAYRD F=$G(^TMP( "RCERA_PAR AMS",$J,"R CPAYR"))
  28919   "RTN","RCD PEWLD",211 ,0)
  28920    S RCQUIT= 0
  28921   "RTN","RCD PEWLD",212 ,0)
  28922    K DIR S D IR(0)="SA^ A:ALL;R:RA NGE"
  28923   "RTN","RCD PEWLD",213 ,0)
  28924    S DIR("A" )="(A)LL p ayers, (R) ANGE of pa yer names:  "
  28925   "RTN","RCD PEWLD",214 ,0)
  28926    S DIR("B" )="ALL"
  28927   "RTN","RCD PEWLD",215 ,0)
  28928    S DIR("?" ,1)="Enter ing ALL wi ll select  all payers ."
  28929   "RTN","RCD PEWLD",216 ,0)
  28930    S DIR("?" )="If RANG E is enter ed, you wi ll be prom pted for a  payer ran ge."
  28931   "RTN","RCD PEWLD",217 ,0)
  28932    S:$P(RCPA YRDF,"^")' ="" DIR("B ")=$P(RCPA YRDF,"^",1 )      ;St ored prefe rred value , use as d efault
  28933   "RTN","RCD PEWLD",218 ,0)
  28934    W !
  28935   "RTN","RCD PEWLD",219 ,0)
  28936    D ^DIR
  28937   "RTN","RCD PEWLD",220 ,0)
  28938    I $D(DTOU T)!$D(DUOU T) Q 1
  28939   "RTN","RCD PEWLD",221 ,0)
  28940    S RCPAYR= Y
  28941   "RTN","RCD PEWLD",222 ,0)
  28942    I RCPAYR= "A" S ^TMP ("RCERA_PA RAMS",$J," RCPAYR")=Y        ;Al l payers s elected
  28943   "RTN","RCD PEWLD",223 ,0)
  28944    I RCPAYR= "R" D  G:P QUIT PAYR
  28945   "RTN","RCD PEWLD",224 ,0)
  28946    . S PQUIT =0
  28947   "RTN","RCD PEWLD",225 ,0)
  28948    . W !,"Na mes you se lect here  will be th e payer na mes from t he ERA, no t the ins.  file"
  28949   "RTN","RCD PEWLD",226 ,0)
  28950    . K DIR
  28951   "RTN","RCD PEWLD",227 ,0)
  28952    . S DIR(" ?")="Enter  a name fr om 1 to 30  character s in UPPER  CASE."
  28953   "RTN","RCD PEWLD",228 ,0)
  28954    . S DIR(0 )="FA^1:30 ^K:X'?.U X "
  28955   "RTN","RCD PEWLD",229 ,0)
  28956    . S DIR(" A")="Start  with paye r name: "
  28957   "RTN","RCD PEWLD",230 ,0)
  28958    . S:$P(RC PAYRDF,"^" ,2)'="" DI R("B")=$P( RCPAYRDF," ^",2)  ;St ored prefe rred value , use as d efault
  28959   "RTN","RCD PEWLD",231 ,0)
  28960    . W !
  28961   "RTN","RCD PEWLD",232 ,0)
  28962    . D ^DIR
  28963   "RTN","RCD PEWLD",233 ,0)
  28964    . I $D(DT OUT)!$D(DU OUT) D  Q
  28965   "RTN","RCD PEWLD",234 ,0)
  28966    . . S PQU IT=1
  28967   "RTN","RCD PEWLD",235 ,0)
  28968    . . K ^TM P("RCERA_P ARAMS",$J, "RCPAYR")
  28969   "RTN","RCD PEWLD",236 ,0)
  28970    . S RCPAY R("FROM")= Y
  28971   "RTN","RCD PEWLD",237 ,0)
  28972    . K DIR
  28973   "RTN","RCD PEWLD",238 ,0)
  28974    . S DIR(" ?")="Enter  a name fr om 1 to 30  character s in UPPER  CASE."
  28975   "RTN","RCD PEWLD",239 ,0)
  28976    . S DIR(0 )="FA^1:30 ^K:X'?.U X ",DIR("A") ="Go to pa yer name:  "
  28977   "RTN","RCD PEWLD",240 ,0)
  28978    . S DIR(" B")=$E(RCP AYR("FROM" ),1,27)_"Z ZZ"
  28979   "RTN","RCD PEWLD",241 ,0)
  28980    . S:$P(RC PAYRDF,"^" ,3)'="" DI R("B")=$P( RCPAYRDF," ^",3)   ;S tored pref erred valu e, use as  default
  28981   "RTN","RCD PEWLD",242 ,0)
  28982    . W !
  28983   "RTN","RCD PEWLD",243 ,0)
  28984    . D ^DIR
  28985   "RTN","RCD PEWLD",244 ,0)
  28986    . I $D(DT OUT)!$D(DU OUT) S PQU IT=1 Q
  28987   "RTN","RCD PEWLD",245 ,0)
  28988    . S ^TMP( "RCERA_PAR AMS",$J,"R CPAYR")=RC PAYR_"^"_R CPAYR("FRO M")_"^"_Y
  28989   "RTN","RCD PEWLD",246 ,0)
  28990    Q 0
  28991   "RTN","RCD PEWLD",247 ,0)
  28992    ;
  28993   "RTN","RCD PEX3")
  28994   0^42^B7658 2678
  28995   "RTN","RCD PEX3",1,0)
  28996   RCDPEX3 ;A LB/TMK/PJH  - ELECTRO NIC EOB EX CEPTION PR OCESSING -  FILE 344. 4 ; 3/30/1 1 7:19pm
  28997   "RTN","RCD PEX3",2,0)
  28998    ;;4.5;Acc ounts Rece ivable;**1 73,208,258 ,269,321** ;Mar 20, 1 995;Build  46
  28999   "RTN","RCD PEX3",3,0)
  29000    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  29001   "RTN","RCD PEX3",4,0)
  29002    ; IA# 528 6 for call  to $$PRVP HONE^IBJPS 3()
  29003   "RTN","RCD PEX3",5,0)
  29004    Q
  29005   "RTN","RCD PEX3",6,0)
  29006    ;
  29007   "RTN","RCD PEX3",7,0)
  29008   VP ; View/ Print ERA  Msgs - Fil e 344.4
  29009   "RTN","RCD PEX3",8,0)
  29010    N X,Y,RCD A,RCTDA,RC ALL,DIR,PO P
  29011   "RTN","RCD PEX3",9,0)
  29012    D FULL^VA LM1
  29013   "RTN","RCD PEX3",10,0 )
  29014    S DIR(0)= "SA^A:ALL; S:SELECTED ",DIR("A") ="PRINT (A )LL or (S) ELECTED RE CORDS?: "
  29015   "RTN","RCD PEX3",11,0 )
  29016    S DIR("B" )="ALL"
  29017   "RTN","RCD PEX3",12,0 )
  29018    D ^DIR K  DIR
  29019   "RTN","RCD PEX3",13,0 )
  29020    G:$D(DUOU T)!$D(DTOU T) VPQ
  29021   "RTN","RCD PEX3",14,0 )
  29022    S RCALL=( Y="A")
  29023   "RTN","RCD PEX3",15,0 )
  29024    ;
  29025   "RTN","RCD PEX3",16,0 )
  29026    I 'RCALL  D  G:'$O(R CDA("")) V PQ
  29027   "RTN","RCD PEX3",17,0 )
  29028    . D SEL(. RCDA)
  29029   "RTN","RCD PEX3",18,0 )
  29030    ;
  29031   "RTN","RCD PEX3",19,0 )
  29032    ; device
  29033   "RTN","RCD PEX3",20,0 )
  29034    N %ZIS,ZT RTN,ZTSAVE ,ZTDESC
  29035   "RTN","RCD PEX3",21,0 )
  29036    S %ZIS="Q M" D ^%ZIS  G:POP VPQ
  29037   "RTN","RCD PEX3",22,0 )
  29038    I $D(IO(" Q")) D  G  VPQ
  29039   "RTN","RCD PEX3",23,0 )
  29040    . S ZTRTN ="VPOUT^RC DPEX3",ZTD ESC="AR -  Print ERA/ EEOB Data  With Excep tions"
  29041   "RTN","RCD PEX3",24,0 )
  29042    . S ZTSAV E("RCDA")= "",ZTSAVE( "RCALL")=" ",ZTSAVE(" ^TMP(""RCD PEX_SUM-EO BDX"",$J," )=""
  29043   "RTN","RCD PEX3",25,0 )
  29044    . D ^%ZTL OAD
  29045   "RTN","RCD PEX3",26,0 )
  29046    . W !!,$S ($D(ZTSK): "Your task  number"_Z TSK_" has  been queue d.",1:"Una ble to que ue this jo b.")
  29047   "RTN","RCD PEX3",27,0 )
  29048    . K ZTSK, IO("Q") D  HOME^%ZIS
  29049   "RTN","RCD PEX3",28,0 )
  29050    U IO
  29051   "RTN","RCD PEX3",29,0 )
  29052    ;
  29053   "RTN","RCD PEX3",30,0 )
  29054   VPOUT ; En trypoint q ueued job
  29055   "RTN","RCD PEX3",31,0 )
  29056    ; RCDA, R CALL must  be defined
  29057   "RTN","RCD PEX3",32,0 )
  29058    N Z,RCSTO P,RCZ,RCPG ,RCDOT,RCT DA1
  29059   "RTN","RCD PEX3",33,0 )
  29060    K ^TMP($J ,"RC_SUMRA W"),^TMP($ J,"RC_SUMO UT")
  29061   "RTN","RCD PEX3",34,0 )
  29062    S (RCSTOP ,RCPG)=0,R CDOT="",$P (RCDOT,"." ,79)=""
  29063   "RTN","RCD PEX3",35,0 )
  29064    I RCALL D
  29065   "RTN","RCD PEX3",36,0 )
  29066    . S RCZ=0  F  S RCZ= $O(^TMP("R CDPEX_SUM- EOBDX",$J, RCZ)) Q:'R CZ  S RCTD A=$G(^(RCZ )),RCTDA1= +$P(RCTDA, U,3),RCTDA =+$P(RCTDA ,U,2) D  Q :RCSTOP
  29067   "RTN","RCD PEX3",37,0 )
  29068    .. D PRT( RCTDA,RCTD A1,.RCPG,. RCSTOP)
  29069   "RTN","RCD PEX3",38,0 )
  29070    .. I $O(^ TMP("RCDPE X_SUM-EOBD X",$J,RCZ) ) D WRTSEP (RCDOT,RCP G)
  29071   "RTN","RCD PEX3",39,0 )
  29072    I 'RCALL  D
  29073   "RTN","RCD PEX3",40,0 )
  29074    . S RCZ=0  F  S RCZ= $O(RCDA(RC Z)) Q:'RCZ   D
  29075   "RTN","RCD PEX3",41,0 )
  29076    .. S RCTD A1=+$P(RCD A(RCZ),U,2 ),RCTDA=+R CDA(RCZ) D  PRT(RCTDA ,RCTDA1,.R CPG,.RCSTO P) I $O(RC DA(RCZ)) D  WRTSEP(RC DOT,RCPG)
  29077   "RTN","RCD PEX3",42,0 )
  29078    ;
  29079   "RTN","RCD PEX3",43,0 )
  29080    I '$D(ZTQ UEUED),'RC STOP,RCPG  D ASK(.RCS TOP)
  29081   "RTN","RCD PEX3",44,0 )
  29082    ;
  29083   "RTN","RCD PEX3",45,0 )
  29084    I $D(ZTQU EUED) S ZT REQ="@"
  29085   "RTN","RCD PEX3",46,0 )
  29086    I '$D(ZTQ UEUED) D ^ %ZISC
  29087   "RTN","RCD PEX3",47,0 )
  29088    ;
  29089   "RTN","RCD PEX3",48,0 )
  29090   VPQ K ^TMP ($J,"RC_SU MRAW"),^TM P($J,"RC_S UMOUT")
  29091   "RTN","RCD PEX3",49,0 )
  29092    S VALMBCK ="R"
  29093   "RTN","RCD PEX3",50,0 )
  29094    Q
  29095   "RTN","RCD PEX3",51,0 )
  29096    ;
  29097   "RTN","RCD PEX3",52,0 )
  29098   WRTSEP(RCD OT,RCPG) ;  Separatin g lines if  more reco rds to pri nt
  29099   "RTN","RCD PEX3",53,0 )
  29100    W !,RCDOT ,!,RCDOT
  29101   "RTN","RCD PEX3",54,0 )
  29102    I (($Y+5) >IOSL) D H DR(.RCPG)  Q
  29103   "RTN","RCD PEX3",55,0 )
  29104    W !!
  29105   "RTN","RCD PEX3",56,0 )
  29106    Q
  29107   "RTN","RCD PEX3",57,0 )
  29108    ;
  29109   "RTN","RCD PEX3",58,0 )
  29110   PRT(RCTDA, RCTDA1,RCP G,RCSTOP)  ; Print da ta from fi le 344.4 a nd 344.41
  29111   "RTN","RCD PEX3",59,0 )
  29112    ; RCTDA =  ien file  344.4
  29113   "RTN","RCD PEX3",60,0 )
  29114    ; RCTDA1  = ien file  344.41
  29115   "RTN","RCD PEX3",61,0 )
  29116    ; RCPG =  last page  extracted
  29117   "RTN","RCD PEX3",62,0 )
  29118    ; RCSTOP  = returned  1 if pass ed by ref  and proces s stopped
  29119   "RTN","RCD PEX3",63,0 )
  29120    ;
  29121   "RTN","RCD PEX3",64,0 )
  29122    N RCDIQ,R CDIQ1,RCDI Q2,RCXM1,R C,Z
  29123   "RTN","RCD PEX3",65,0 )
  29124    D GETS^DI Q(344.4,RC TDA_",","* ","IEN","R CDIQ")
  29125   "RTN","RCD PEX3",66,0 )
  29126    D TXT0^RC DPEX31(RCT DA,.RCDIQ, .RCXM1,.RC ) ; Get to p level 0- node capti oned field s
  29127   "RTN","RCD PEX3",67,0 )
  29128    ;
  29129   "RTN","RCD PEX3",68,0 )
  29130    I $O(^RCY (344.4,RCT DA,2,0)) S  RC=RC+1,R CXM1(RC)="   **ERA LE VEL ADJUST MENTS**"
  29131   "RTN","RCD PEX3",69,0 )
  29132    S Z=0 F   S Z=$O(^RC Y(344.4,RC TDA,2,Z))  Q:'Z  D
  29133   "RTN","RCD PEX3",70,0 )
  29134    . D GETS^ DIQ(344.42 ,Z_","_RCT DA_",","*" ,"IEN","RC DIQ2")
  29135   "RTN","RCD PEX3",71,0 )
  29136    . D TXT2^ RCDPEX31(R CTDA,Z,.RC DIQ2,.RCXM 1,.RC) ; G et top lev el ERA adj s
  29137   "RTN","RCD PEX3",72,0 )
  29138    ;
  29139   "RTN","RCD PEX3",73,0 )
  29140    D GETS^DI Q(344.41,R CTDA1_","_ RCTDA_",", "*","IEN", "RCDIQ1")
  29141   "RTN","RCD PEX3",74,0 )
  29142    D TXT00^R CDPEX31(RC TDA,RCTDA1 ,.RCDIQ1,. RCXM1,.RC)
  29143   "RTN","RCD PEX3",75,0 )
  29144    D DISP^RC DPESR0("^R CY(344.4," _RCTDA_",1 ,"_RCTDA1_ ",1)","^TM P($J,""RC_ SUMRAW"")" ,1,"^TMP($ J,""RC_SUM OUT"")",75 ) ; Get fo rmatted 'r aw' data
  29145   "RTN","RCD PEX3",76,0 )
  29146    ;
  29147   "RTN","RCD PEX3",77,0 )
  29148    I $D(RCDI Q1(344.41, RCTDA1_"," _RCTDA_"," ,2)) D
  29149   "RTN","RCD PEX3",78,0 )
  29150    . S RC=RC +1,RCXM1(R C)="  **RE SOLUTION L OG DATA**"
  29151   "RTN","RCD PEX3",79,0 )
  29152    . S Z=0 F   S Z=$O(R CDIQ1(344. 41,RCTDA1_ ","_RCTDA_ ",",2,Z))  Q:'Z  S RC =RC+1,RCXM 1(RC)=RCDI Q1(344.41, RCTDA1_"," _RCTDA_"," ,2,Z)
  29153   "RTN","RCD PEX3",80,0 )
  29154    . S RC=RC +1,RCXM1(R C)=" "
  29155   "RTN","RCD PEX3",81,0 )
  29156    S (RCSTOP ,Z)=0
  29157   "RTN","RCD PEX3",82,0 )
  29158    F  S Z=$O (RCXM1(Z))  Q:'Z  S ^ TMP($J,"RC _SUMOUT",Z -999)=RCXM 1(Z)
  29159   "RTN","RCD PEX3",83,0 )
  29160    S Z=""
  29161   "RTN","RCD PEX3",84,0 )
  29162    F  S Z=$O (^TMP($J," RC_SUMOUT" ,Z)) Q:'Z   D  Q:RCST OP
  29163   "RTN","RCD PEX3",85,0 )
  29164    . I $D(ZT QUEUED),$$ S^%ZTLOAD  S (RCSTOP, ZTSTOP)=1  K ZTREQ I  +$G(RCPG)  W !!,"***T ASK STOPPE D BY USER* **" Q
  29165   "RTN","RCD PEX3",86,0 )
  29166    . I 'RCPG !(($Y+5)>I OSL) D  I  RCSTOP Q
  29167   "RTN","RCD PEX3",87,0 )
  29168    .. D:RCPG  ASK(.RCST OP) I RCST OP Q
  29169   "RTN","RCD PEX3",88,0 )
  29170    .. D HDR( .RCPG)
  29171   "RTN","RCD PEX3",89,0 )
  29172    . W !,$G( ^TMP($J,"R C_SUMOUT", Z))
  29173   "RTN","RCD PEX3",90,0 )
  29174    ;
  29175   "RTN","RCD PEX3",91,0 )
  29176    K ^TMP($J ,"RC_SUMRA W"),^TMP($ J,"RC_SUMO UT") ; Cle ar arrays  before nex t exceptio n - PRCA*4 .5*321 
  29177   "RTN","RCD PEX3",92,0 )
  29178    Q
  29179   "RTN","RCD PEX3",93,0 )
  29180    ;
  29181   "RTN","RCD PEX3",94,0 )
  29182   XFR ; Tran sfer EOB(s ) to other  site
  29183   "RTN","RCD PEX3",95,0 )
  29184    N RC,RC0, RCCHG,RCOK ,RCDOMAIN, RCDEF,RCDA ,RCWHY,RCE R,RCECT,RC XTO,RCALL, RCCONT,DIR ,X,Y,DA,DI E,DR,POP,R CDA,RCXDA, RCXDA1,RCD UZ,XMBODY, XMTO
  29185   "RTN","RCD PEX3",96,0 )
  29186    D FULL^VA LM1
  29187   "RTN","RCD PEX3",97,0 )
  29188    D SEL(.RC DA)
  29189   "RTN","RCD PEX3",98,0 )
  29190    ;
  29191   "RTN","RCD PEX3",99,0 )
  29192    G:'$O(RCD A(0)) XFRQ
  29193   "RTN","RCD PEX3",100, 0)
  29194    S DIR("S" )="I +$G(^ DIC(4,+Y,6 ))",DIR(0) ="PA^4:AME ",DIR("A") ="TRANSFER  TO WHICH  SITE?: " D  ^DIR K DI R
  29195   "RTN","RCD PEX3",101, 0)
  29196    I $D(DUOU T)!$D(DTOU T) G XFRQ
  29197   "RTN","RCD PEX3",102, 0)
  29198    S RCXTO=+ Y,RCCHG=0
  29199   "RTN","RCD PEX3",103, 0)
  29200    ;
  29201   "RTN","RCD PEX3",104, 0)
  29202    S RCDOMAI N=$$EXTERN AL^DILFD(4 ,60,,+$G(^ DIC(4,+RCX TO,6))),RC ECT=0
  29203   "RTN","RCD PEX3",105, 0)
  29204    I RCDOMAI N="" D  G  XFRQ
  29205   "RTN","RCD PEX3",106, 0)
  29206    . S DIR(" A",1)="THE RE IS NO V ALID DOMAI N SET UP F OR THIS SI TE. YOU MU ST CHOOSE  ANOTHER ON E.",DIR("A ")="PRESS  RETURN TO  CONTINUE", DIR(0)="EA " W ! D ^D IR K DIR
  29207   "RTN","RCD PEX3",107, 0)
  29208    ;
  29209   "RTN","RCD PEX3",108, 0)
  29210    S RCDEF=$ $PRVPHONE^ IBJPS3()                    ; IA  5286
  29211   "RTN","RCD PEX3",109, 0)
  29212    I RCDEF'= "" S RCDEF ="AGENT CA SHIER-"_RC DEF
  29213   "RTN","RCD PEX3",110, 0)
  29214    ;
  29215   "RTN","RCD PEX3",111, 0)
  29216    S DIR("A" ,1)="ENTER  THE CONTA CT INFORMA TION FOR T HE PERSON  AT YOUR SI TE"
  29217   "RTN","RCD PEX3",112, 0)
  29218    S DIR("A" ,2)="   WH O MAY BE C ONTACTED B Y THE OTHE R SITE REG ARDING THI S EEOB"
  29219   "RTN","RCD PEX3",113, 0)
  29220    S DIR("A" )="   (1-4 5 CHARACTE RS): "_$S( RCDEF'="": RCDEF_"//  ",1:"")
  29221   "RTN","RCD PEX3",114, 0)
  29222    S DIR(0)= "FA"_$S(RC DEF'="":"O ",1:"")_"^ 1:45" W !  D ^DIR K D IR
  29223   "RTN","RCD PEX3",115, 0)
  29224    I $D(DUOU T)!$D(DTOU T) G XFRQ
  29225   "RTN","RCD PEX3",116, 0)
  29226    I Y="" S  Y=RCDEF
  29227   "RTN","RCD PEX3",117, 0)
  29228    S RCCONT= Y
  29229   "RTN","RCD PEX3",118, 0)
  29230    ;
  29231   "RTN","RCD PEX3",119, 0)
  29232    S DIR(0)= "YA",DIR(" A")="DO YO U WANT TO  PRINT THE  EEOB(s)?:  ",DIR("B") ="Y"
  29233   "RTN","RCD PEX3",120, 0)
  29234    D ^DIR K  DIR
  29235   "RTN","RCD PEX3",121, 0)
  29236    I $D(DUOU T)!$D(DTOU T) G XFRQ
  29237   "RTN","RCD PEX3",122, 0)
  29238    I Y=1 S R CER=0 D  I  RCER G XF RQ
  29239   "RTN","RCD PEX3",123, 0)
  29240    . N %ZIS, ZTRTN,ZTSA VE,ZTDESC
  29241   "RTN","RCD PEX3",124, 0)
  29242    . S %ZIS= "QM" D ^%Z IS I POP S  RCER=1 Q
  29243   "RTN","RCD PEX3",125, 0)
  29244    . I $D(IO ("Q")) D   Q
  29245   "RTN","RCD PEX3",126, 0)
  29246    .. S RCAL L=0
  29247   "RTN","RCD PEX3",127, 0)
  29248    .. S ZTRT N="VPOUT^R CDPEX3",ZT DESC="AR -  Print EEO B Data Bef ore Transf er"
  29249   "RTN","RCD PEX3",128, 0)
  29250    .. S ZTSA VE("RCDA") ="",ZTSAVE ("RCALL")= "",ZTSAVE( "^TMP(""RC DPEX_SUM-E OBDX"",$J) ")=""
  29251   "RTN","RCD PEX3",129, 0)
  29252    .. D ^%ZT LOAD
  29253   "RTN","RCD PEX3",130, 0)
  29254    .. I '$D( ZTSK) S RC ER=1
  29255   "RTN","RCD PEX3",131, 0)
  29256    .. K ZTSK ,IO("Q") D  HOME^%ZIS
  29257   "RTN","RCD PEX3",132, 0)
  29258    . S RCALL =0
  29259   "RTN","RCD PEX3",133, 0)
  29260    . D VPOUT ^RCDPEX3
  29261   "RTN","RCD PEX3",134, 0)
  29262    ;
  29263   "RTN","RCD PEX3",135, 0)
  29264    S RCWHY(1 )="Transfe r EEOB det ail to ano ther site"
  29265   "RTN","RCD PEX3",136, 0)
  29266    S RC=0 F   S RC=$O(R CDA(RC)) Q :'RC  D  L  -^RCY(344 .4,RCXDA,1 ,RCXDA1,0)
  29267   "RTN","RCD PEX3",137, 0)
  29268    . N RCBOD Y,RCAMT,RC BILL,RCX,X MZ
  29269   "RTN","RCD PEX3",138, 0)
  29270    . S RCXDA =+RCDA(RC) ,RCXDA1=+$ P(RCDA(RC) ,U,2),RCWH Y(2)=""
  29271   "RTN","RCD PEX3",139, 0)
  29272    . I '$$LO CK^RCDPEX3 1(RCXDA,RC XDA1,1) D   Q
  29273   "RTN","RCD PEX3",140, 0)
  29274    .. S RCEC T=RCECT+1, RCER(RCECT )="**Selec tion #"_RC _" is bein g edited b y another  user - ...  please tr y again la ter"
  29275   "RTN","RCD PEX3",141, 0)
  29276    . ;
  29277   "RTN","RCD PEX3",142, 0)
  29278    . S RC0=$ G(^RCY(344 .4,RCXDA,1 ,RCXDA1,0) )
  29279   "RTN","RCD PEX3",143, 0)
  29280    . M RCBOD Y=^RCY(344 .4,RCXDA,1 ,RCXDA1,1)
  29281   "RTN","RCD PEX3",144, 0)
  29282    . S RCAMT =$P(RC0,U, 3)*100
  29283   "RTN","RCD PEX3",145, 0)
  29284    . S RCBIL L=$P(RC0,U ,5)
  29285   "RTN","RCD PEX3",146, 0)
  29286    . S DIR(" A",1)="ONC E THIS EEO B HAS BEEN  TRANSFERR ED, ITS BI LL # CANNO T BE EDITE D",DIR("A" )="ARE YOU  SURE THIS  IS NOT A  CLAIM FOR  YOUR SITE? : ",DIR(0) ="YA",DIR( "B")="NO"  W ! D ^DIR  K DIR
  29287   "RTN","RCD PEX3",147, 0)
  29288    . Q:Y'=1
  29289   "RTN","RCD PEX3",148, 0)
  29290    . I $P(RC 0,U,11) D   Q:'RCOK
  29291   "RTN","RCD PEX3",149, 0)
  29292    .. S RCOK =1
  29293   "RTN","RCD PEX3",150, 0)
  29294    .. S DIR( "A",1)="WA RNING: EEO B FOR #"_R C_" ("_RCB ILL_") HAS  ALREADY B EEN TRANSF ERRED",DIR ("A",2)="    TO "_$P( $G(^DIC(4, +$P(RC0,U, 11),0)),U) _"   ON: " _$$FMTE^XL FDT($P(RC0 ,U,12),2)
  29295   "RTN","RCD PEX3",151, 0)
  29296    .. S DIR( "A")="ARE  YOU SURE Y OU WANT TO  TRANSFER  IT AGAIN?:  "
  29297   "RTN","RCD PEX3",152, 0)
  29298    .. S DIR( 0)="YA",DI R("B")="NO " W ! D ^D IR K DIR
  29299   "RTN","RCD PEX3",153, 0)
  29300    .. I Y=1  Q
  29301   "RTN","RCD PEX3",154, 0)
  29302    .. S RCOK =0
  29303   "RTN","RCD PEX3",155, 0)
  29304    .. S RCEC T=RCECT+1, RCER(RCECT )="**Selec tion #"_RC _" already  transferr ed - "_RCB ILL_" NOT  transferre d again"
  29305   "RTN","RCD PEX3",156, 0)
  29306    . K RCBOD Y(0)
  29307   "RTN","RCD PEX3",157, 0)
  29308    . S RCX=$ G(RCBODY(1 ,0))
  29309   "RTN","RCD PEX3",158, 0)
  29310    . ;
  29311   "RTN","RCD PEX3",159, 0)
  29312    . I $P($G (^RCY(344. 4,RCXDA,1, RCXDA1,0)) ,U,7)'=1 D   Q
  29313   "RTN","RCD PEX3",160, 0)
  29314    .. S RCEC T=RCECT+1, RCER(RCECT )="**Selec tion #"_RC _" is not  available  for transf er - "_RCB ILL_" NOT  transferre d"
  29315   "RTN","RCD PEX3",161, 0)
  29316    . ;
  29317   "RTN","RCD PEX3",162, 0)
  29318    . I $P(RC X,U)'["835 ERA"!'$O(R CBODY(1))  D  Q
  29319   "RTN","RCD PEX3",163, 0)
  29320    .. S RCEC T=RCECT+1, RCER(RCECT )="**Selec tion #"_RC _" format  is not val id for tra nsfer - "_ RCBILL_" N OT transfe rred"
  29321   "RTN","RCD PEX3",164, 0)
  29322    . ;
  29323   "RTN","RCD PEX3",165, 0)
  29324    . S $P(RC X,U)="835X FR",$P(RCX ,U,10,15)= (RCAMT_"^^ ^^^")
  29325   "RTN","RCD PEX3",166, 0)
  29326    . S $P(RC X,U,19)=RC CONT
  29327   "RTN","RCD PEX3",167, 0)
  29328    . S RCBOD Y(1,0)=RCX
  29329   "RTN","RCD PEX3",168, 0)
  29330    . S RCBOD Y(+$O(RCBO DY(""),-1) +1,0)="99^ $"
  29331   "RTN","RCD PEX3",169, 0)
  29332    . S RCBOD Y(+$O(RCBO DY(""),-1) +1,0)="NNN N"
  29333   "RTN","RCD PEX3",170, 0)
  29334    . S XMTO( "S.RCDPE E DI LOCKBOX  SERVER@"_ RCDOMAIN)= ""
  29335   "RTN","RCD PEX3",171, 0)
  29336    . S XMBOD Y="RCBODY" ,RCDUZ=$G( DUZ),DUZ=. 5
  29337   "RTN","RCD PEX3",172, 0)
  29338    . D SENDM SG^XMXAPI( .5,"TRANSF ER 3RD PAR TY EEOB "_ RCBILL_"(R EF #"_RCXD A_";"_RCXD A1_"#)",XM BODY,.XMTO ,,.XMZ)
  29339   "RTN","RCD PEX3",173, 0)
  29340    . ;
  29341   "RTN","RCD PEX3",174, 0)
  29342    . S DUZ=R CDUZ
  29343   "RTN","RCD PEX3",175, 0)
  29344    . I $G(XM Z) D  ; Re port msg #
  29345   "RTN","RCD PEX3",176, 0)
  29346    .. S RCCH G=1
  29347   "RTN","RCD PEX3",177, 0)
  29348    .. S RCEC T=RCECT+1, RCER(RCECT )="Entry # "_RC_" was  successfu lly transf erred - ms g # is "_X MZ
  29349   "RTN","RCD PEX3",178, 0)
  29350    .. S DA(1 )=RCXDA,DA =RCXDA1,DI E="^RCY(34 4.4,"_DA(1 )_",1,",DR =".09////" _XMZ_";.11 ////"_RCXT O_";.12/// /"_$E($$NO W^XLFDT(), 1,12) D ^D IE
  29351   "RTN","RCD PEX3",179, 0)
  29352    .. S RCWH Y(2)=" Tra nsfer to " _$P($G(^DI C(4,+RCXTO ,0)),U)_"  was succes sful"
  29353   "RTN","RCD PEX3",180, 0)
  29354    .. ;
  29355   "RTN","RCD PEX3",181, 0)
  29356    . E  D  ;  error - t ransfer no t done
  29357   "RTN","RCD PEX3",182, 0)
  29358    .. S RCEC T=RCECT+1, RCER(RCECT )="**Entry  #"_RC_" w as NOT tra nsferred d ue to a ms g build er ror ("_RCB ILL_")"
  29359   "RTN","RCD PEX3",183, 0)
  29360    .. S RCWH Y(2)=" Tra nsfer to " _$P($G(^DI C(4,+RCXTO ,0)),U)_"  was UNSUCC ESSFUL"
  29361   "RTN","RCD PEX3",184, 0)
  29362    .. ;
  29363   "RTN","RCD PEX3",185, 0)
  29364    . D STORA CT^RCDPEX3 1(RCXDA,RC XDA1,.RCWH Y)
  29365   "RTN","RCD PEX3",186, 0)
  29366    ;
  29367   "RTN","RCD PEX3",187, 0)
  29368    I $O(RCER (0)) D
  29369   "RTN","RCD PEX3",188, 0)
  29370    . ; Write  msgs
  29371   "RTN","RCD PEX3",189, 0)
  29372    . W !!,"T RANSFER OF  EEOB TO " _$P($G(^DI C(4,RCXTO, 0)),U)_" R ESULTS: ", !
  29373   "RTN","RCD PEX3",190, 0)
  29374    . S RCECT =0 F  S RC ECT=$O(RCE R(RCECT))  Q:'RCECT   W !,"  ",R CER(RCECT)
  29375   "RTN","RCD PEX3",191, 0)
  29376    . W !
  29377   "RTN","RCD PEX3",192, 0)
  29378    ;
  29379   "RTN","RCD PEX3",193, 0)
  29380    D PAUSE^V ALM1
  29381   "RTN","RCD PEX3",194, 0)
  29382    ;
  29383   "RTN","RCD PEX3",195, 0)
  29384   XFRQ I $G( RCCHG) D B LD^RCDPEX2
  29385   "RTN","RCD PEX3",196, 0)
  29386    S VALMBCK ="R"
  29387   "RTN","RCD PEX3",197, 0)
  29388    Q
  29389   "RTN","RCD PEX3",198, 0)
  29390    ;
  29391   "RTN","RCD PEX3",199, 0)
  29392   SEL(RCDA,O NE) ; Sele ct entry(s ) from lis t
  29393   "RTN","RCD PEX3",200, 0)
  29394    ; RCDA =  array retu rned if se lections m ade
  29395   "RTN","RCD PEX3",201, 0)
  29396    ;    RCDA (n)=ien of  bill sele cted file  344.4
  29397   "RTN","RCD PEX3",202, 0)
  29398    ; ONE = i f set to 1 , only one  selection  can be ma de at a ti me
  29399   "RTN","RCD PEX3",203, 0)
  29400    N RC
  29401   "RTN","RCD PEX3",204, 0)
  29402    K RCDA
  29403   "RTN","RCD PEX3",205, 0)
  29404    D EN^VALM 2($G(XQORN OD(0)),$S( '$G(ONE):" ",1:"S"))
  29405   "RTN","RCD PEX3",206, 0)
  29406    S RCDA=0  F  S RCDA= $O(VALMY(R CDA)) Q:'R CDA  S RC= $G(^TMP("R CDPEX_SUM- EOBDX",$J, RCDA)),RCD A(RCDA)=+$ P(RC,U,2)_ U_+$P(RC,U ,3)
  29407   "RTN","RCD PEX3",207, 0)
  29408    Q
  29409   "RTN","RCD PEX3",208, 0)
  29410    ;
  29411   "RTN","RCD PEX3",209, 0)
  29412   HDR(RCPG)  ;Print rep ort hdr
  29413   "RTN","RCD PEX3",210, 0)
  29414    ; RCPG =  last page  #
  29415   "RTN","RCD PEX3",211, 0)
  29416    I RCPG!($ E(IOST,1,2 )="C-") W  @IOF,*13
  29417   "RTN","RCD PEX3",212, 0)
  29418    S RCPG=$G (RCPG)+1
  29419   "RTN","RCD PEX3",213, 0)
  29420    W !,?5,"E DI LOCKBOX  EEOB DATA  EXCEPTION S - EEOB D ETAIL",?55 ,$$FMTE^XL FDT(DT,2), ?70,"Page:  ",RCPG,!, $TR($J("", IOM)," "," =")
  29421   "RTN","RCD PEX3",214, 0)
  29422    Q
  29423   "RTN","RCD PEX3",215, 0)
  29424    ;
  29425   "RTN","RCD PEX3",216, 0)
  29426   ASK(RCSTOP ) ;
  29427   "RTN","RCD PEX3",217, 0)
  29428    I $E(IOST ,1,2)'["C- " Q
  29429   "RTN","RCD PEX3",218, 0)
  29430    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T
  29431   "RTN","RCD PEX3",219, 0)
  29432    S DIR(0)= "E" W ! D  ^DIR
  29433   "RTN","RCD PEX3",220, 0)
  29434    I ($D(DIR UT))!($D(D UOUT)) S R CSTOP=1 Q
  29435   "RTN","RCD PEX3",221, 0)
  29436    Q
  29437   "RTN","RCD PEX3",222, 0)
  29438    ; ***
  29439   "RTN","RCD PEX3",223, 0)
  29440    ; *** Ent rypoints T XT* assume  these var iable defi nitions ** *
  29441   "RTN","RCD PEX3",224, 0)
  29442    ; ***
  29443   "RTN","RCD PEX3",225, 0)
  29444    ; FUNCTIO Ns returns  RCXM1 and  RC if pas sed by ref erence
  29445   "RTN","RCD PEX3",226, 0)
  29446    ; RCTDA =  ien, file  344.4
  29447   "RTN","RCD PEX3",227, 0)
  29448    ; RCXM1 =  array ret urned with  text, cap tioned
  29449   "RTN","RCD PEX3",228, 0)
  29450    ; RC = #  of lines a lready in  array (opt ional)
  29451   "RTN","RCD PEX3",229, 0)
  29452    ; RCDIQ a nd RCDIQ1  = arrays r eturned fr om GETS^DI Q
  29453   "RTN","RCD PEX3",230, 0)
  29454    ; ***
  29455   "RTN","RCD PEX3",231, 0)
  29456    ;
  29457   "RTN","RCD PEX3",232, 0)
  29458   UPD ; Try  to update  the IB EOB  file from  exception  in 344.41
  29459   "RTN","RCD PEX3",233, 0)
  29460    D UPD^RCD PEX31 ; Mo ved for sp ace
  29461   "RTN","RCD PEX3",234, 0)
  29462    Q
  29463   "RTN","RCD PEX3",235, 0)
  29464    ;
  29465   "RTN","RCD PEX31")
  29466   0^43^B4206 0337
  29467   "RTN","RCD PEX31",1,0 )
  29468   RCDPEX31 ; ALB/TMK -  ELECTRONIC  EOB EXCEP TION PROCE SSING - FI LE 344.4 ; Jun 11, 20 14@15:50:5 9
  29469   "RTN","RCD PEX31",2,0 )
  29470    ;;4.5;Acc ounts Rece ivable;**1 73,208,298 ,321**;Mar  20, 1995; Build 46
  29471   "RTN","RCD PEX31",3,0 )
  29472    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  29473   "RTN","RCD PEX31",4,0 )
  29474    ;
  29475   "RTN","RCD PEX31",5,0 )
  29476   UPD ; Try  to update  the IB EOB  file from  exception  in 344.41
  29477   "RTN","RCD PEX31",6,0 )
  29478    N RCDA,RC TDA,RCTDA1 ,RCWHY,Z,D A,DIE,DR
  29479   "RTN","RCD PEX31",7,0 )
  29480    D FULL^VA LM1
  29481   "RTN","RCD PEX31",8,0 )
  29482    D SEL^RCD PEX3(.RCDA ,1)
  29483   "RTN","RCD PEX31",9,0 )
  29484    S RCDA=$O (RCDA(0))  G:'RCDA UP DQ
  29485   "RTN","RCD PEX31",10, 0)
  29486    S RCTDA=+ RCDA(RCDA) ,RCTDA1=+$ P(RCDA(RCD A),U,2)
  29487   "RTN","RCD PEX31",11, 0)
  29488    I '$$LOCK (RCTDA,RCT DA1,0) G U PDQ
  29489   "RTN","RCD PEX31",12, 0)
  29490    I $P($G(^ RCY(344.4, RCTDA,1,RC TDA1,0)),U ,7)'=2 D   G UPDQ
  29491   "RTN","RCD PEX31",13, 0)
  29492    . W !,"EE OB cannot  be filed i n IB"_$S($ P($G(^RCY( 344.4,RCTD A,1,RCTDA1 ,0)),U,7)= 1:" - the  bill # is  invalid",1 :"")
  29493   "RTN","RCD PEX31",14, 0)
  29494    . D PAUSE ^VALM1
  29495   "RTN","RCD PEX31",15, 0)
  29496    I RCTDA,R CTDA1 D UP DEOB^RCDPE SR2(RCTDA_ ";"_RCTDA1 ,4)
  29497   "RTN","RCD PEX31",16, 0)
  29498    S Z=$P($G (^RCY(344. 4,RCTDA,1, RCTDA1,0)) ,U,2)
  29499   "RTN","RCD PEX31",17, 0)
  29500    I Z D  ;  Update fil e 344.41 r ecord
  29501   "RTN","RCD PEX31",18, 0)
  29502    . S DA(1) =RCTDA,DA= RCTDA1,DR= ".07///@;. 13////1;.0 2////"_Z,D IE="^RCY(3 44.4,"_DA( 1)_",1," D  ^DIE
  29503   "RTN","RCD PEX31",19, 0)
  29504    W !,"EEOB  DETAIL UP DATE ",$S( Z:"WAS SUC CESSFUL",1 :"ENCOUNTE RED ERRORS ")
  29505   "RTN","RCD PEX31",20, 0)
  29506    S RCWHY(1 )="Update  IB with EE OB detail" ,RCWHY(2)= "Update EE OB detail  was "_$S(' Z:"NOT",1: "")_" succ essful"
  29507   "RTN","RCD PEX31",21, 0)
  29508    D STORACT (RCTDA,RCT DA1,.RCWHY )
  29509   "RTN","RCD PEX31",22, 0)
  29510    D PAUSE^V ALM1
  29511   "RTN","RCD PEX31",23, 0)
  29512    D BLD^RCD PEX2
  29513   "RTN","RCD PEX31",24, 0)
  29514    ;
  29515   "RTN","RCD PEX31",25, 0)
  29516   UPDQ S VAL MBCK="R"
  29517   "RTN","RCD PEX31",26, 0)
  29518    Q
  29519   "RTN","RCD PEX31",27, 0)
  29520    ;
  29521   "RTN","RCD PEX31",28, 0)
  29522   DEL ; Dele te excepti on conditi ons from E OB detail  list - fil e 344.4
  29523   "RTN","RCD PEX31",29, 0)
  29524    N DIR,DA, DIE,DR,DTO UT,DUOUT,R C0,RC00,RC DA,RCDIQ,R CDIQ1,RCE, RCOK,RCT,R CTDA,RCTDA 1,RCWHY,RC WHYTXT,RCX ,X,Y,Z
  29525   "RTN","RCD PEX31",30, 0)
  29526    D FULL^VA LM1
  29527   "RTN","RCD PEX31",31, 0)
  29528    D SEL^RCD PEX3(.RCDA ,1)
  29529   "RTN","RCD PEX31",32, 0)
  29530    S RCDA=$O (RCDA(""))
  29531   "RTN","RCD PEX31",33, 0)
  29532    I RCDA=""  G DELQ
  29533   "RTN","RCD PEX31",34, 0)
  29534    S RCTDA=+ RCDA(RCDA) ,RCTDA1=$P (RCDA(RCDA ),U,2)
  29535   "RTN","RCD PEX31",35, 0)
  29536    I '$$LOCK (RCTDA,RCT DA1,0) G D ELQ
  29537   "RTN","RCD PEX31",36, 0)
  29538    W !
  29539   "RTN","RCD PEX31",37, 0)
  29540    S DIR(0)= "YA",DIR(" A",1)="Thi s action w ill mark t his EEOB d etail reco rd so it n o longer a ppears as  an",DIR("A ",2)="exce ption.  A  MailMan me ssage will  be sent t o report t his action .",DIR("A" ,3)=" "
  29541   "RTN","RCD PEX31",38, 0)
  29542    S DIR("A" )="ARE YOU  SURE YOU  WANT TO CO NTINUE? ", DIR("B")=" NO"
  29543   "RTN","RCD PEX31",39, 0)
  29544    D ^DIR K  DIR
  29545   "RTN","RCD PEX31",40, 0)
  29546    G:Y'=1 DE LQ
  29547   "RTN","RCD PEX31",41, 0)
  29548    S DIR(0)= "FA;3:60", DIR("A")=" ENTER A RE ASON FOR T HIS ACTION : ",DIR("? ",1)="Ente r the reas on why thi s EEOB exc eption is  being remo ved from t he",DIR("? ")=" excep tion list  (3-60 char acters are  REQUIRED) "
  29549   "RTN","RCD PEX31",42, 0)
  29550    D ^DIR K  DIR
  29551   "RTN","RCD PEX31",43, 0)
  29552    I $D(DUOU T)!$D(DTOU T) G DELQ
  29553   "RTN","RCD PEX31",44, 0)
  29554    S RCWHY(1 )="Removal  of EEOB d etail entr y from the  exception  list",RCW HY(2)="  R eason Ente red: "_Y,R CWHYTXT=Y
  29555   "RTN","RCD PEX31",45, 0)
  29556    S RC0=$G( ^RCY(344.4 ,RCTDA,0)) ,RC00=$G(^ (1,RCTDA1, 0))
  29557   "RTN","RCD PEX31",46, 0)
  29558    ;
  29559   "RTN","RCD PEX31",47, 0)
  29560    D GETS^DI Q(344.4,RC TDA_",","* ","IEN","R CDIQ")
  29561   "RTN","RCD PEX31",48, 0)
  29562    D GETS^DI Q(344.41,R CTDA1_","_ RCTDA_",", "*","IEN", "RCDIQ1")
  29563   "RTN","RCD PEX31",49, 0)
  29564    S RCE=0
  29565   "RTN","RCD PEX31",50, 0)
  29566    D TXT0(RC TDA,.RCDIQ ,.RCX,.RCE )
  29567   "RTN","RCD PEX31",51, 0)
  29568    S RCE=RCE +1,RCX(RCE )="RAW MES SAGE DATA: "
  29569   "RTN","RCD PEX31",52, 0)
  29570    D TXT00(R CTDA,RCTDA 1,.RCDIQ1, .RCX,.RCE)
  29571   "RTN","RCD PEX31",53, 0)
  29572    S DA=RCTD A1,DA(1)=R CTDA,DR=". 07///@;.13 ////0",DIE ="^RCY(344 .4,"_DA(1) _",1," D ^ DIE
  29573   "RTN","RCD PEX31",54, 0)
  29574    D STORACT (RCTDA,RCT DA1,.RCWHY )
  29575   "RTN","RCD PEX31",55, 0)
  29576    ;
  29577   "RTN","RCD PEX31",56, 0)
  29578    S RCT(1)= "The elect ronic EEOB  detail fo r Trace #:  "_$P(RC0, U,2)_" and  Seq #"_$P (RC00,U),R CT(2)=" is  no longer  flagged f or an exce ption cond ition"
  29579   "RTN","RCD PEX31",57, 0)
  29580    S RCT(3)= "PAYMENT F ROM: "_$P( RC0,U,6)_"  on "_$$FM TE^XLFDT($ P(RC0,U,4) ,2)
  29581   "RTN","RCD PEX31",58, 0)
  29582    S RCT(4)= " "
  29583   "RTN","RCD PEX31",59, 0)
  29584    S RCT(5)= "REASON: " _RCWHYTXT
  29585   "RTN","RCD PEX31",60, 0)
  29586    S RCT(6)= "ACTION PE RFORMED BY : "_$P($G( ^VA(200,+$ G(DUZ),0)) ,U)_"   "_ $$FMTE^XLF DT($$NOW^X LFDT,2)
  29587   "RTN","RCD PEX31",61, 0)
  29588    S RCT(7)= " ",RCE=+$ O(RCT(""), -1)
  29589   "RTN","RCD PEX31",62, 0)
  29590    S Z=0 F   S Z=$O(RCX (Z)) Q:'Z   S RCE=RCE +1,RCT(RCE )=RCX(Z)
  29591   "RTN","RCD PEX31",63, 0)
  29592    S RCE=RCE +1,RCT(RCE )=" "
  29593   "RTN","RCD PEX31",64, 0)
  29594    D  ; send  MailMan m essage
  29595   "RTN","RCD PEX31",65, 0)
  29596    .N XMBODY ,XMINSTR,X MSUBJ,XMZ
  29597   "RTN","RCD PEX31",66, 0)
  29598    .S XMSUBJ ="EDI LBOX  EEOB DETA IL EXCEPTI ON REMOVED ",XMBODY=" RCT",XMTO( "G.RCDPE P AYMENTS")= "",XMTO(DU Z)="",XMIN STR("FROM" )="POSTMAS TER"
  29599   "RTN","RCD PEX31",67, 0)
  29600    .D SENDMS G^XMXAPI(. 5,XMSUBJ,X MBODY,.XMT O,.XMINSTR ,.XMZ)
  29601   "RTN","RCD PEX31",68, 0)
  29602    ;
  29603   "RTN","RCD PEX31",69, 0)
  29604    W !,"A Ma ilMan mess age has be en sent to  report th is action. ",!
  29605   "RTN","RCD PEX31",70, 0)
  29606    D PAUSE^V ALM1
  29607   "RTN","RCD PEX31",71, 0)
  29608    D BLD^RCD PEX2
  29609   "RTN","RCD PEX31",72, 0)
  29610    ;
  29611   "RTN","RCD PEX31",73, 0)
  29612   DELQ I $G( RCTDA),$G( RCTDA1) L  -^RCY(344. 4,RCTDA,1, RCTDA1,0)
  29613   "RTN","RCD PEX31",74, 0)
  29614    S VALMBCK ="R"
  29615   "RTN","RCD PEX31",75, 0)
  29616    Q
  29617   "RTN","RCD PEX31",76, 0)
  29618    ;
  29619   "RTN","RCD PEX31",77, 0)
  29620   TXT0(RCTDA ,RCDIQ,RCX M1,RC) ; A ppend 0-no de caption ed data to  array RCX M1
  29621   "RTN","RCD PEX31",78, 0)
  29622    ;
  29623   "RTN","RCD PEX31",79, 0)
  29624    N LINE,DA T,Z,Z0,Z1
  29625   "RTN","RCD PEX31",80, 0)
  29626    S LINE="" ,RC=+$G(RC )
  29627   "RTN","RCD PEX31",81, 0)
  29628    S RC=RC+1 ,RCXM1(RC) ="  **ERA  SUMMARY DA TA**"
  29629   "RTN","RCD PEX31",82, 0)
  29630    S Z=0 F   S Z=$O(RCD IQ(344.4,R CTDA_",",Z )) Q:'Z  D    ;prca*4 .5*298  ne ed to get  additional  fields fo r display
  29631   "RTN","RCD PEX31",83, 0)
  29632    . I $G(RC DIQ(344.4, RCTDA_",", Z,"E"))=""  Q
  29633   "RTN","RCD PEX31",84, 0)
  29634    . S Z0=$$ GET1^DID(3 44.4,Z,,"L ABEL")
  29635   "RTN","RCD PEX31",85, 0)
  29636    . S DAT=Z 0_": "_$G( RCDIQ(344. 4,RCTDA_", ",Z,"E"))
  29637   "RTN","RCD PEX31",86, 0)
  29638    . I $L(DA T)>39 S:$L (LINE) RC= RC+1,RCXM1 (RC)=LINE  S RC=RC+1, RCXM1(RC)= DAT,LINE=" " Q
  29639   "RTN","RCD PEX31",87, 0)
  29640    . I $L(LI NE) D  Q:L INE=""  ;  Left side  exists
  29641   "RTN","RCD PEX31",88, 0)
  29642    .. I $L(L INE)+$L(DA T)>75 S RC =RC+1,RCXM 1(RC)=LINE ,LINE=DAT  Q
  29643   "RTN","RCD PEX31",89, 0)
  29644    .. S LINE =LINE_"  " _DAT,RC=RC +1,RCXM1(R C)=LINE,LI NE=""
  29645   "RTN","RCD PEX31",90, 0)
  29646    . S LINE= $E(DAT_$J( "",39),1,3 9)
  29647   "RTN","RCD PEX31",91, 0)
  29648    I $L(LINE ) S RC=RC+ 1,RCXM1(RC )=LINE
  29649   "RTN","RCD PEX31",92, 0)
  29650    S:RC RC=R C+1,RCXM1( RC)=" "
  29651   "RTN","RCD PEX31",93, 0)
  29652    Q
  29653   "RTN","RCD PEX31",94, 0)
  29654    ;
  29655   "RTN","RCD PEX31",95, 0)
  29656   TXT00(RCTD A,RCTDA1,R CDIQ1,RCXM 1,RC) ; Ex tract 0-no de data fo r file 344 .41
  29657   "RTN","RCD PEX31",96, 0)
  29658    ;
  29659   "RTN","RCD PEX31",97, 0)
  29660    N RCT,LIN E,DAT,Z,Z0 ,Z1
  29661   "RTN","RCD PEX31",98, 0)
  29662    S LINE="" ,RC=+$G(RC )
  29663   "RTN","RCD PEX31",99, 0)
  29664    S RC=RC+1 ,RCXM1(RC) ="  **EEOB  DETAIL DA TA**",RCT= RCTDA1_"," _RCTDA_","
  29665   "RTN","RCD PEX31",100 ,0)
  29666    S Z=0 F   S Z=$O(RCD IQ1(344.41 ,RCT,Z)) Q :'Z  D   ; prca*4.5*2 98  need t o get addi tional fie lds for di splay
  29667   "RTN","RCD PEX31",101 ,0)
  29668    . I (Z'=. 25),$G(RCD IQ1(344.41 ,RCT,Z,"E" ))="" Q    ;prca*4.5* 298  even  if RECEIPT  # (.25) i s null, di splay the  label
  29669   "RTN","RCD PEX31",102 ,0)
  29670    . I (Z=1) !(Z=2) Q   ; Suppress  display o f RAW DATA  and EXCEP TION LOG f ield - PRC A*4.5*321
  29671   "RTN","RCD PEX31",103 ,0)
  29672    . S Z0=$$ GET1^DID(3 44.41,Z,," LABEL")
  29673   "RTN","RCD PEX31",104 ,0)
  29674    . S DAT=Z 0_": "_$G( RCDIQ1(344 .41,RCT,Z, "E"))
  29675   "RTN","RCD PEX31",105 ,0)
  29676    . ; PRCA* 4.5*321 -  END
  29677   "RTN","RCD PEX31",106 ,0)
  29678    . I $L(DA T)>39 S:$L (LINE) RC= RC+1,RCXM1 (RC)=LINE  S RC=RC+1, RCXM1(RC)= DAT,LINE=" " Q
  29679   "RTN","RCD PEX31",107 ,0)
  29680    . I $L(LI NE) D  Q:L INE=""  ;  Left side  exists
  29681   "RTN","RCD PEX31",108 ,0)
  29682    .. I $L(L INE)+$L(DA T)>75 S RC =RC+1,RCXM 1(RC)=LINE ,LINE=DAT  Q
  29683   "RTN","RCD PEX31",109 ,0)
  29684    .. S LINE =LINE_"  " _DAT,RC=RC +1,RCXM1(R C)=LINE,LI NE=""
  29685   "RTN","RCD PEX31",110 ,0)
  29686    . S LINE= $E(DAT_$J( "",39),1,3 9)
  29687   "RTN","RCD PEX31",111 ,0)
  29688    I $L(LINE ) S RC=RC+ 1,RCXM1(RC )=LINE
  29689   "RTN","RCD PEX31",112 ,0)
  29690    S:RC RC=R C+1,RCXM1( RC)=" "
  29691   "RTN","RCD PEX31",113 ,0)
  29692    Q
  29693   "RTN","RCD PEX31",114 ,0)
  29694    ;
  29695   "RTN","RCD PEX31",115 ,0)
  29696   TXT2(RCTDA ,RCTDA1,RC DIQ2,RCXM1 ,RC) ; Ext ract all d ata for fi le 344.42
  29697   "RTN","RCD PEX31",116 ,0)
  29698    ;
  29699   "RTN","RCD PEX31",117 ,0)
  29700    N RCT,LIN E,DAT,Z,Z0
  29701   "RTN","RCD PEX31",118 ,0)
  29702    S LINE="" ,RC=+$G(RC )
  29703   "RTN","RCD PEX31",119 ,0)
  29704    S RCT=RCT DA1_","_RC TDA_","
  29705   "RTN","RCD PEX31",120 ,0)
  29706    S Z=0 F   S Z=$O(RCD IQ2(344.42 ,RCT,Z)) Q :'Z  D
  29707   "RTN","RCD PEX31",121 ,0)
  29708    . I $G(RC DIQ2(344.4 2,RCT,Z,"E "))="" Q
  29709   "RTN","RCD PEX31",122 ,0)
  29710    . S Z0=$$ GET1^DID(3 44.42,Z,," LABEL")
  29711   "RTN","RCD PEX31",123 ,0)
  29712    . S DAT=Z 0_": "_$G( RCDIQ2(344 .42,RCT,Z, "E"))
  29713   "RTN","RCD PEX31",124 ,0)
  29714    . I $L(DA T)>39 S:$L (LINE) RC= RC+1,RCXM1 (RC)=LINE  S RC=RC+1, RCXM1(RC)= DAT,LINE=" " Q
  29715   "RTN","RCD PEX31",125 ,0)
  29716    . I $L(LI NE) D  Q:L INE=""  ;  Left side  exists
  29717   "RTN","RCD PEX31",126 ,0)
  29718    .. I $L(L INE)+$L(DA T)>75 S RC =RC+1,RCXM 1(RC)=LINE ,LINE=DAT  Q
  29719   "RTN","RCD PEX31",127 ,0)
  29720    .. S LINE =LINE_"  " _DAT,RC=RC +1,RCXM1(R C)=LINE,LI NE=""
  29721   "RTN","RCD PEX31",128 ,0)
  29722    . S LINE= $E(DAT_$J( "",39),1,3 9)
  29723   "RTN","RCD PEX31",129 ,0)
  29724    I $L(LINE ) S RC=RC+ 1,RCXM1(RC )=LINE
  29725   "RTN","RCD PEX31",130 ,0)
  29726    S:RC RC=R C+1,RCXM1( RC)=" "
  29727   "RTN","RCD PEX31",131 ,0)
  29728    Q
  29729   "RTN","RCD PEX31",132 ,0)
  29730    ;
  29731   "RTN","RCD PEX31",133 ,0)
  29732   LOCK(RCTDA ,RCTDA1,RC SHH) ; Att empt to lo ck file en try in fil e 344.41
  29733   "RTN","RCD PEX31",134 ,0)
  29734    ; Return  1 if succe ssful, 0 i f not able  to lock
  29735   "RTN","RCD PEX31",135 ,0)
  29736    ; RCSHH =  1 if ther e should b e no direc t writes
  29737   "RTN","RCD PEX31",136 ,0)
  29738    ;
  29739   "RTN","RCD PEX31",137 ,0)
  29740    N OK
  29741   "RTN","RCD PEX31",138 ,0)
  29742    S OK=1
  29743   "RTN","RCD PEX31",139 ,0)
  29744    L +^RCY(3 44.4,RCTDA ,1,RCTDA1, 0):5
  29745   "RTN","RCD PEX31",140 ,0)
  29746    I '$T D
  29747   "RTN","RCD PEX31",141 ,0)
  29748    . I '$D(D IQUIET),'$ G(RCSHH) W  !,*7,"Ano ther user  is editing  this entr y ... plea se try aga in later"  D PAUSE^VA LM1
  29749   "RTN","RCD PEX31",142 ,0)
  29750    . S OK=0
  29751   "RTN","RCD PEX31",143 ,0)
  29752    Q OK
  29753   "RTN","RCD PEX31",144 ,0)
  29754    ;
  29755   "RTN","RCD PEX31",145 ,0)
  29756   STORACT(RC TDA,RCTDA1 ,RCWHY) ;  Store the  detail for  the actio n taken fo r
  29757   "RTN","RCD PEX31",146 ,0)
  29758    ; the exc eption rec ord at ^RC Y(344.4,RC TDA,1,RCTD A,0)
  29759   "RTN","RCD PEX31",147 ,0)
  29760    ; RCWHY(# ) = lines  containing  the reaso n/explanat ion for th e action
  29761   "RTN","RCD PEX31",148 ,0)
  29762    ;   RCWHY (1) should  contain t he descrip tion of th e action t aken
  29763   "RTN","RCD PEX31",149 ,0)
  29764    ;             It wil l be appen ded to the  first lin e of the m essage aft er
  29765   "RTN","RCD PEX31",150 ,0)
  29766    ;             the da te and use r who made  the chang e.
  29767   "RTN","RCD PEX31",151 ,0)
  29768    ;
  29769   "RTN","RCD PEX31",152 ,0)
  29770    N RCDA,RC TXT,RC,Z
  29771   "RTN","RCD PEX31",153 ,0)
  29772    S RCDA(1) =RCTDA,RCD A=RCTDA1
  29773   "RTN","RCD PEX31",154 ,0)
  29774    S RCTXT(1 )=$$FMTE^X LFDT($$NOW ^XLFDT(),2 )_" "_$P($ G(^VA(200, +DUZ,0)),U )_" "_$G(R CWHY(1))
  29775   "RTN","RCD PEX31",155 ,0)
  29776    S (RC,Z)= 1
  29777   "RTN","RCD PEX31",156 ,0)
  29778    F  S Z=$O (RCWHY(Z))  Q:'Z  S R C=RC+1,RCT XT(RC)=" " _RCWHY(Z)
  29779   "RTN","RCD PEX31",157 ,0)
  29780    D WP^DIE( 344.41,$$I ENS^DILF(. RCDA),2,"A ","RCTXT")
  29781   "RTN","RCD PEX31",158 ,0)
  29782    Q
  29783   "RTN","RCD PEX31",159 ,0)
  29784    ;
  29785   "RTN","RCD PEX32")
  29786   0^52^B5517 4770
  29787   "RTN","RCD PEX32",1,0 )
  29788   RCDPEX32 ; ALB/TMK -  ELECTRONIC  EOB EXCEP TION PROCE SSING - FI LE 344.4 ; Aug 14, 20 14@16:27:3 2
  29789   "RTN","RCD PEX32",2,0 )
  29790    ;;4.5;Acc ounts Rece ivable;**1 73,249,298 ,304,321** ;Mar 20, 1 995;Build  46
  29791   "RTN","RCD PEX32",3,0 )
  29792    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  29793   "RTN","RCD PEX32",4,0 )
  29794    ;
  29795   "RTN","RCD PEX32",5,0 )
  29796   EDITNUM ;  Edit inval id claim #  to valid,  refile EO B
  29797   "RTN","RCD PEX32",6,0 )
  29798    N RC,RC0, RCDA,RCXDA ,RCXDA1,RC SAVE,RCEOB ,RCWARN,Q, Q0,DA,DR,D IE,DIC,DIR ,DTOUT,DIR UT,X,Y,RCB ILL,RCCHG, RCSUSP,RCQ UIT,RCDONE
  29799   "RTN","RCD PEX32",7,0 )
  29800    D FULL^VA LM1
  29801   "RTN","RCD PEX32",8,0 )
  29802    D SEL^RCD PEX3(.RCDA )
  29803   "RTN","RCD PEX32",9,0 )
  29804    G:'$O(RCD A(0)) EDIT NQ
  29805   "RTN","RCD PEX32",10, 0)
  29806    ;
  29807   "RTN","RCD PEX32",11, 0)
  29808    S RC=0 F   S RC=$O(R CDA(RC)) Q :'RC  D  L  -^RCY(344 .4,RCXDA1, 1,RCXDA,0)
  29809   "RTN","RCD PEX32",12, 0)
  29810    . S RCXDA 1=+RCDA(RC ),RCXDA=+$ P(RCDA(RC) ,U,2),RCSA VE=""
  29811   "RTN","RCD PEX32",13, 0)
  29812    . I '$$LO CK^RCDPEX3 1(RCXDA1,R CXDA,1) D   Q
  29813   "RTN","RCD PEX32",14, 0)
  29814    .. S DIR( 0)="EA",DI R("A",1)=" **Selectio n #"_RC_"  is being e dited by a nother use r - ... pl ease try a gain later ",DIR("A") ="PRESS RE TURN TO CO NTINUE" D  ^DIR K DIR
  29815   "RTN","RCD PEX32",15, 0)
  29816    . S RC0=$ G(^RCY(344 .4,RCXDA1, 1,RCXDA,0) )
  29817   "RTN","RCD PEX32",16, 0)
  29818    . I $P(RC 0,U,5)=""  D  Q
  29819   "RTN","RCD PEX32",17, 0)
  29820    .. S DIR( 0)="EA",DI R("A",1)=" The claim  for select ion #"_RC_ " can't be  edited as  the bill  # is not i nvalid",DI R("A")="PR ESS RETURN  TO CONTIN UE" D ^DIR  K DIR
  29821   "RTN","RCD PEX32",18, 0)
  29822    . I $P(RC 0,U,9) D   Q
  29823   "RTN","RCD PEX32",19, 0)
  29824    .. S DIR( 0)="EA",DI R("A",1)=" The claim  for select ion #"_RC_ " can't be  edited as  the claim  has alrea dy",DIR("A ")="been t ransferred  to anothe r site - P RESS RETUR N TO CONTI NUE" W ! D  ^DIR K DI R
  29825   "RTN","RCD PEX32",20, 0)
  29826    . ;
  29827   "RTN","RCD PEX32",21, 0)
  29828    . I $D(^R CY(344.49, RCXDA1)) D
  29829   "RTN","RCD PEX32",22, 0)
  29830    .. N X
  29831   "RTN","RCD PEX32",23, 0)
  29832    .. S X=$G (^RCY(344, +$P($G(^RC Y(344.49,R CXDA1,0)), U,2),0))
  29833   "RTN","RCD PEX32",24, 0)
  29834    .. W !!,* 7,"Warning : EEOB Wor klist entr y #"_RCXDA 1_$S($P(X, U)'="":" a nd receipt  "_$P(X,U) ,1:"")_" e xist for t his EEOB"
  29835   "RTN","RCD PEX32",25, 0)
  29836    .. I X=""  W !,"You  should ref resh the w orklist en try to inc lude the n ew claim # ",!," befo re creatin g the rece ipt",!
  29837   "RTN","RCD PEX32",26, 0)
  29838    . I $P($G (^RCY(344. 4,RCXDA1,0 )),U,8) D
  29839   "RTN","RCD PEX32",27, 0)
  29840    .. W !,"S ince the r eceipt for  this EEOB  ("_$P($G( ^RCY(344,+ $P($G(^RCY (344.4,RCX DA1,0)),U, 8),0)),U)_ ") already  exists"
  29841   "RTN","RCD PEX32",28, 0)
  29842    .. I '$P( $G(^RCY(34 4,+$P($G(^ RCY(344.4, RCXDA1,0)) ,U,8),0)), U,14) W !, " and is c losed, you  will need  to use li nk payment  to apply  the paymen t",!," to  the correc t account" ,! Q
  29843   "RTN","RCD PEX32",29, 0)
  29844    .. W !,"  you should  edit the  receipt an d change t he claim #  so it pos ts to the" ,!," corre ct account ",!
  29845   "RTN","RCD PEX32",30, 0)
  29846    . ;
  29847   "RTN","RCD PEX32",31, 0)
  29848    . I $P(RC 0,U,17)=""  S RCSAVE= $P(RC0,U,5 )
  29849   "RTN","RCD PEX32",32, 0)
  29850    . W !,"Se lection #:  "_RC_$J(" ",5)_$P(RC 0,U,5)
  29851   "RTN","RCD PEX32",33, 0)
  29852    . S (RCQU IT,RCDONE) =0
  29853   "RTN","RCD PEX32",34, 0)
  29854    . F  D  Q :RCQUIT!RC DONE
  29855   "RTN","RCD PEX32",35, 0)
  29856    .. K DIR
  29857   "RTN","RCD PEX32",36, 0)
  29858    .. S DIR( "?",1)="An swer with  ACCOUNTS R ECEIVABLE  BILL NO.,  or PATIENT , or DEBTO R, or"
  29859   "RTN","RCD PEX32",37, 0)
  29860    .. S DIR( "?")="     TOP REFUND  STATUS, o r FMS TRAN SMISSION D ATE"
  29861   "RTN","RCD PEX32",38, 0)
  29862    .. S DIR( 0)="FAO^1: 15",DIR("A ")="Select  A/R Bill  this EEOB  is actuall y paying o n: "
  29863   "RTN","RCD PEX32",39, 0)
  29864    .. D ^DIR  I $D(DIRU T)!$D(DTOU T) S RCQUI T=1 Q
  29865   "RTN","RCD PEX32",40, 0)
  29866    .. S DIC= "^PRCA(430 ,",DIC(0)= "EM",DIC(" S")="I $D( ^DGCR(399, +Y,0))" W  ! D ^DIC I  X="^" S R CQUIT=1 Q
  29867   "RTN","RCD PEX32",41, 0)
  29868    .. S RCSU SP=X
  29869   "RTN","RCD PEX32",42, 0)
  29870    .. I '(Y> 0) D  Q:RC QUIT
  29871   "RTN","RCD PEX32",43, 0)
  29872    ... S DIR ("A")="    THIS CLAIM  WAS NOT F OUND IN YO UR AR.  DO  YOU WANT  TO CONTINU E?: "
  29873   "RTN","RCD PEX32",44, 0)
  29874    ... S DIR ("B")="NO" ,DIR(0)="Y A" D ^DIR  K DIR W !  I $D(DIRUT )!$D(DTOUT ) S RCQUIT =1 Q
  29875   "RTN","RCD PEX32",45, 0)
  29876    ... I Y=1  S RCBILL= 0,RCBILL(1 )=RCSUSP,R CWARN=0,RC DONE=1
  29877   "RTN","RCD PEX32",46, 0)
  29878    .. E  D
  29879   "RTN","RCD PEX32",47, 0)
  29880    ... S RCB ILL=+Y,RCB ILL(1)=$P( $G(^PRCA(4 30,RCBILL, 0)),U),RCW ARN=0,RCDO NE=1
  29881   "RTN","RCD PEX32",48, 0)
  29882    . Q:RCQUI T
  29883   "RTN","RCD PEX32",49, 0)
  29884    . I $P($G (^RCY(344. 4,RCXDA1,0 )),U,14) S  RCWARN=RC WARN+1,DIR ("A",RCWAR N+1)=$J("" ,4)_"THE R ECEIPT FOR  THIS EEOB  HAS ALREA DY BEEN PO STED."
  29885   "RTN","RCD PEX32",50, 0)
  29886    . I RCBIL L>0,$P($G( ^PRCA(430. 3,+$P($G(^ PRCA(430,R CBILL,0)), U,8),0)),U ,3)'=102 S  RCWARN=RC WARN+1,DIR ("A",RCWAR N+1)=$J("" ,4)_"THIS  IS NOT AN  ACTIVE ACC OUNTS RECE IVABLE."
  29887   "RTN","RCD PEX32",51, 0)
  29888    . I RCWAR N>0 D  I Y '=1 Q
  29889   "RTN","RCD PEX32",52, 0)
  29890    .. S DIR( "A",1)="**  WARNING"_ $S(RCWARN> 1:"S",1:"" )_":"
  29891   "RTN","RCD PEX32",53, 0)
  29892    .. S DIR( "A",RCWARN +2)=" "
  29893   "RTN","RCD PEX32",54, 0)
  29894    .. S DIR( 0)="YA",DI R("A")="AR E YOU SURE  YOU WANT  TO FILE TH IS EEOB FO R CLAIM #:  "_RCBILL( 1)_"?: ",D IR("B")="N O" W ! D ^ DIR K DIR
  29895   "RTN","RCD PEX32",55, 0)
  29896    .. ;
  29897   "RTN","RCD PEX32",56, 0)
  29898    . ; File  EOB for ne w claim #
  29899   "RTN","RCD PEX32",57, 0)
  29900    . K ^TMP( $J,"RCDP-E OB"),^TMP( $J,"RCDPEO B","HDR")
  29901   "RTN","RCD PEX32",58, 0)
  29902    . S Q=0 F   S Q=$O(^ RCY(344.4, RCXDA1,1,R CXDA,1,Q))  Q:'Q  S Q 0=$G(^(Q,0 )) D
  29903   "RTN","RCD PEX32",59, 0)
  29904    .. I $P(Q 0,U)["835E RA" S ^TMP ($J,"RCDPE OB","HDR") =Q0
  29905   "RTN","RCD PEX32",60, 0)
  29906    .. I $P(Q 0,U,2)=$P( RC0,U,5) S  $P(Q0,U,2 )=RCBILL(1 )
  29907   "RTN","RCD PEX32",61, 0)
  29908    .. S ^TMP ($J,"RCDP- EOB",1,Q,0 )=Q0
  29909   "RTN","RCD PEX32",62, 0)
  29910    . S ^TMP( $J,"RCDP-E OB",1,.5,0 )="835ERA"
  29911   "RTN","RCD PEX32",63, 0)
  29912    . S RCEOB =0 I RCBIL L>0 S RCEO B=$$DUP^IB CEOB("^TMP ("_$J_","" RCDP-EOB"" ,1)",RCBIL L) ; IA 40 42
  29913   "RTN","RCD PEX32",64, 0)
  29914    . K ^TMP( $J,"RCDP-E OB",1,.5,0 )
  29915   "RTN","RCD PEX32",65, 0)
  29916    . I RCEOB  D  Q
  29917   "RTN","RCD PEX32",66, 0)
  29918    .. N RCWH Y S RCWHY( 1)="EEOB a lready fou nd on file  while try ing to cha nge claim  # and fili ng into IB "
  29919   "RTN","RCD PEX32",67, 0)
  29920    .. D STOR ACT^RCDPEX 31(RCXDA1, RCXDA,.RCW HY)
  29921   "RTN","RCD PEX32",68, 0)
  29922    .. S RCCH G=1,DA(1)= RCXDA1,DA= RCXDA D CH GED(.DA,RC EOB,RCSAVE ,.RCBILL)
  29923   "RTN","RCD PEX32",69, 0)
  29924    .. S DIR( 0)="E"
  29925   "RTN","RCD PEX32",70, 0)
  29926    .. S DIR( "A",1)="EE OB detail  is already  on file f or "_RCBIL L(1)_" - E xception r emoved",DI R("A")="PR ESS RETURN  TO CONTIN UE" D ^DIR  K DIR
  29927   "RTN","RCD PEX32",71, 0)
  29928    . ;
  29929   "RTN","RCD PEX32",72, 0)
  29930    . ; Add s tub rec to  361.1 if  not there
  29931   "RTN","RCD PEX32",73, 0)
  29932    . I RCBIL L>0 S RCEO B=+$$ADD36 11^IBCEOB( +$P($G(^RC Y(344.4,RC XDA1,0)),U ,12),"","" ,RCBILL,1, "^TMP("_$J _",""RCDP- EOB"",1)")  ; IA 4042
  29933   "RTN","RCD PEX32",74, 0)
  29934    . ;
  29935   "RTN","RCD PEX32",75, 0)
  29936    . I RCEOB <0 D  Q
  29937   "RTN","RCD PEX32",76, 0)
  29938    .. N RCWH Y S RCWHY( 1)="Error  encountere d trying t o change c laim # and  file into  IB"
  29939   "RTN","RCD PEX32",77, 0)
  29940    .. D STOR ACT^RCDPEX 31(RCXDA1, RCXDA,.RCW HY)
  29941   "RTN","RCD PEX32",78, 0)
  29942    .. S DIR( "A")="EA", DIR("A",1) ="Error -  EEOB detai l not adde d to IB fo r bill "_R CBILL(1),D IR("A")="P RESS RETUR N TO CONTI NUE" D ^DI R K DIR
  29943   "RTN","RCD PEX32",79, 0)
  29944    . ;
  29945   "RTN","RCD PEX32",80, 0)
  29946    . ; Updat e EOB in f ile 361.1
  29947   "RTN","RCD PEX32",81, 0)
  29948    . ; Call  needs ^TMP  arrays: $ J,"RCDPEOB ","HDR" an d $J,"RCDP -EOB"
  29949   "RTN","RCD PEX32",82, 0)
  29950    . I RCEOB >0 D
  29951   "RTN","RCD PEX32",83, 0)
  29952    .. D UPD3 611^IBCEOB (RCEOB,1,1 ) ; IA 404 2
  29953   "RTN","RCD PEX32",84, 0)
  29954    .. ; erro rs in ^TMP ("RCDPERR- EOB",$J
  29955   "RTN","RCD PEX32",85, 0)
  29956    .. I $O(^ TMP("RCDPE RR-EOB",$J ,0)) D
  29957   "RTN","RCD PEX32",86, 0)
  29958    ... D ERR UPD^IBCEOB (RCEOB,"RC DPERR-EOB" ) ; Adds e rror msgs  to IB file  361.1 ; I A 4042
  29959   "RTN","RCD PEX32",87, 0)
  29960    . ;
  29961   "RTN","RCD PEX32",88, 0)
  29962    . S RCCHG =1
  29963   "RTN","RCD PEX32",89, 0)
  29964    . N RCWHY  S RCWHY(1 )="EEOB cl aim # chan ged and fi led into I B under ne w claim #"
  29965   "RTN","RCD PEX32",90, 0)
  29966    . D STORA CT^RCDPEX3 1(RCXDA1,R CXDA,.RCWH Y)
  29967   "RTN","RCD PEX32",91, 0)
  29968    . S DA(1) =RCXDA1,DA =RCXDA
  29969   "RTN","RCD PEX32",92, 0)
  29970    . D CHGED (.DA,RCEOB ,RCSAVE,.R CBILL)
  29971   "RTN","RCD PEX32",93, 0)
  29972    . S DIE=" ^RCY(344.4 ,"_DA(1)_" ,1,",DR="1 ///@" D ^D IE
  29973   "RTN","RCD PEX32",94, 0)
  29974    . D ^DIE
  29975   "RTN","RCD PEX32",95, 0)
  29976    . W !!,"E EOB Filed.  "_$S(RCBI LL>0:"Its  detail may  be viewed  using Thi rd Party J oint Inqui ry.",1:"")
  29977   "RTN","RCD PEX32",96, 0)
  29978    . ; Check  if auto-p ost candid ate
  29979   "RTN","RCD PEX32",97, 0)
  29980    . N AUTOP OST
  29981   "RTN","RCD PEX32",98, 0)
  29982    . S AUTOP OST=$$AUTO CHK2^RCDPE AP1(RCXDA1 ,0) ; adde d paramete r - PRCA*4 .5*321
  29983   "RTN","RCD PEX32",99, 0)
  29984    . I AUTOP OST D
  29985   "RTN","RCD PEX32",100 ,0)
  29986    .. D SETS TA^RCDPEAP (RCXDA1,0, "Exception s: Marked  as Auto-Po st Candida te")
  29987   "RTN","RCD PEX32",101 ,0)
  29988    .. W !,"E RA has bee n successf ully Marke d as an Au to-Post CA NDIDATE"
  29989   "RTN","RCD PEX32",102 ,0)
  29990    . I 'AUTO POST D
  29991   "RTN","RCD PEX32",103 ,0)
  29992    .. D AUDI TLOG^RCDPE AP(RCXDA1, "","Except ions: Not  Marked as  Auto-Post  Candidate- "_$P(AUTOP OST,U,2))
  29993   "RTN","RCD PEX32",104 ,0)
  29994    .. W !,"E RA was NOT  Marked as  an Auto-P ost CANDID ATE - ",$P (AUTOPOST, U,2)
  29995   "RTN","RCD PEX32",105 ,0)
  29996    . ;
  29997   "RTN","RCD PEX32",106 ,0)
  29998    . K DIR
  29999   "RTN","RCD PEX32",107 ,0)
  30000    . S DIR(" A")="PRESS  RETURN TO  CONTINUE  ",DIR(0)=" EA"
  30001   "RTN","RCD PEX32",108 ,0)
  30002    . D ^DIR  K DIR
  30003   "RTN","RCD PEX32",109 ,0)
  30004    . S VALMB G=1
  30005   "RTN","RCD PEX32",110 ,0)
  30006    ;
  30007   "RTN","RCD PEX32",111 ,0)
  30008   EDITNQ I $ G(RCCHG) D  BLD^RCDPE X2
  30009   "RTN","RCD PEX32",112 ,0)
  30010    K ^TMP($J ,"RCDP-EOB "),^TMP($J ,"RCDPEOB" ,"HDR"),^T MP("RCDPER R-EOB",$J)
  30011   "RTN","RCD PEX32",113 ,0)
  30012    S VALMBCK ="R"
  30013   "RTN","RCD PEX32",114 ,0)
  30014    Q
  30015   "RTN","RCD PEX32",115 ,0)
  30016    ;
  30017   "RTN","RCD PEX32",116 ,0)
  30018   CHGED(DA,R CEOB,RCSAV E,RCBILL)  ;  Update  Invalid Bi ll # for E OB
  30019   "RTN","RCD PEX32",117 ,0)
  30020    ; DA = DA  and DA(1)  to use fo r DIE call
  30021   "RTN","RCD PEX32",118 ,0)
  30022    ; RCEOB =  the ien o f the entr y in file  361.1
  30023   "RTN","RCD PEX32",119 ,0)
  30024    ; RCSAVE  = the free  text of t he origina l bill #
  30025   "RTN","RCD PEX32",120 ,0)
  30026    ; RCBILL  = Array co ntaining B ill Inform ation
  30027   "RTN","RCD PEX32",121 ,0)
  30028    N DIE,DR, X,Y,INVBIL L
  30029   "RTN","RCD PEX32",122 ,0)
  30030    S INVBILL ="@" I +$G (RCBILL)=0  S INVBILL =$G(RCBILL (1))
  30031   "RTN","RCD PEX32",123 ,0)
  30032    S DIE="^R CY(344.4," _DA(1)_",1 ,",DR=".05 ///"_INVBI LL_";.02// //"_RCEOB_ ";.13////1 "_$S(RCSAV E'="":";.1 7////"_RCS AVE,1:"")_ ";.07///@"  D ^DIE
  30033   "RTN","RCD PEX32",124 ,0)
  30034    Q
  30035   "RTN","RCD PEX32",125 ,0)
  30036    ;
  30037   "RTN","RCD PEX32",126 ,0)
  30038   EDITRXC ;  Edit pharm acy commen t - PRCA*4 .5*298
  30039   "RTN","RCD PEX32",127 ,0)
  30040    N DA,DIC, DIE,DIR,DR ,Q,Q0,RC,R C0,RCBILL, RCDA,RCDSE L,RCEOB,RC SAVE,RCWAR N,RCXDA,RC XDA1,X,Y
  30041   "RTN","RCD PEX32",128 ,0)
  30042    D FULL^VA LM1
  30043   "RTN","RCD PEX32",129 ,0)
  30044    ; PRCA*4. 5*304 - Ph armacy cla im selecti on based c oming from  Exception  or APAR s creen 
  30045   "RTN","RCD PEX32",130 ,0)
  30046    I '$D(RCA PAR) D SEL ^RCDPEX3(. RCDA)
  30047   "RTN","RCD PEX32",131 ,0)
  30048    I $D(RCAP AR) D SEL^ RCDPEX3(.R CDA,1)
  30049   "RTN","RCD PEX32",132 ,0)
  30050    ;Only all ow action  if the sel ected exce ption has  an ECME nu mber
  30051   "RTN","RCD PEX32",133 ,0)
  30052    S RCDSEL= $O(RCDA(0) ) D:RCDSEL
  30053   "RTN","RCD PEX32",134 ,0)
  30054    .N IENS,R CRXNO,RCRL SDT   ; IE NS for Fil eMan, Rx n umber, Rx  release da te
  30055   "RTN","RCD PEX32",135 ,0)
  30056    .S IENS=$ P(RCDA(RCD SEL),U,2)_ ","_$P(RCD A(RCDSEL), U,1)_","
  30057   "RTN","RCD PEX32",136 ,0)
  30058    .S RCRXNO =$$GET1^DI Q(344.41,I ENS,.24) I  RCRXNO=""   D  Q
  30059   "RTN","RCD PEX32",137 ,0)
  30060    ..W !,"Co mment not  allowed. T his is not  a pharmac y exceptio n." D WAIT ^VALM1
  30061   "RTN","RCD PEX32",138 ,0)
  30062    .;
  30063   "RTN","RCD PEX32",139 ,0)
  30064    .; IA #47 01, RELEAS E DATE for  the presc ription/fi ll
  30065   "RTN","RCD PEX32",140 ,0)
  30066    .S RCRLSD T=$$RXRLDT ^PSOBPSUT( RCRXNO)    ; get rele ase date
  30067   "RTN","RCD PEX32",141 ,0)
  30068    .I RCRLSD T]"" D  Q
  30069   "RTN","RCD PEX32",142 ,0)
  30070    ..W !!,"R elease Dat e: "_$$FMT E^XLFDT(RC RLSDT)
  30071   "RTN","RCD PEX32",143 ,0)
  30072    ..W !,"Co mment not  allowed fo r Rx with  Release Da te." D WAI T^VALM1
  30073   "RTN","RCD PEX32",144 ,0)
  30074    .;
  30075   "RTN","RCD PEX32",145 ,0)
  30076    .;Display  sequence  and INVALI D BILL NUM BER
  30077   "RTN","RCD PEX32",146 ,0)
  30078    .W !,"Sel ection #:  ",RCDSEL,"      ",$$G ET1^DIQ(34 4.41,IENS, .05)
  30079   "RTN","RCD PEX32",147 ,0)
  30080    .;Allow e dit of pha rmacy comm ent
  30081   "RTN","RCD PEX32",148 ,0)
  30082    .S DIE="^ RCY(344.4, "_$P(RCDA( RCDSEL),U, 1)_",1,",D A=$P(RCDA( RCDSEL),U, 2),DA(1)=$ P(RCDA(RCD SEL),U,1), DR="9.01Co mment" D ^ DIE Q:$D(D UOUT)!$D(D TOUT)
  30083   "RTN","RCD PEX32",149 ,0)
  30084    .D WAIT^V ALM1,BLD^R CDPEX2
  30085   "RTN","RCD PEX32",150 ,0)
  30086    ;
  30087   "RTN","RCD PEX32",151 ,0)
  30088    K ^TMP($J ,"RCDP-EOB "),^TMP($J ,"RCDPEOB" ,"HDR"),^T MP("RCDPER R-EOB",$J)
  30089   "RTN","RCD PEX32",152 ,0)
  30090    S VALMBCK ="R"
  30091   "RTN","RCD PEX32",153 ,0)
  30092    Q
  30093   "RTN","RCD PLPL1")
  30094   0^12^B3661 7409
  30095   "RTN","RCD PLPL1",1,0 )
  30096   RCDPLPL1 ; WISC/RFJ/P JH - link  payments l istmanager  options ; 5/25/11 2: 53pm
  30097   "RTN","RCD PLPL1",2,0 )
  30098    ;;4.5;Acc ounts Rece ivable;**1 14,148,153 ,208,269,3 04,321**;M ar 20, 199 5;Build 46
  30099   "RTN","RCD PLPL1",3,0 )
  30100    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  30101   "RTN","RCD PLPL1",4,0 )
  30102    Q
  30103   "RTN","RCD PLPL1",5,0 )
  30104    ;
  30105   "RTN","RCD PLPL1",6,0 )
  30106   CHKTRACE ; EP Protoco l action -  RCDP LINK  PAYMENTS  SEARCH CHE CK
  30107   "RTN","RCD PLPL1",7,0 )
  30108    ; Ask to  search by  check # or  trace #
  30109   "RTN","RCD PLPL1",8,0 )
  30110    N DIR,X,Y
  30111   "RTN","RCD PLPL1",9,0 )
  30112    D FULL^VA LM1
  30113   "RTN","RCD PLPL1",10, 0)
  30114    S DIR("A" )="SEARCH  BY (C)HECK  OR (T)RAC E #?: "
  30115   "RTN","RCD PLPL1",11, 0)
  30116    S DIR(0)= "SA^C:CHEC K;T:TRACE" ,DIR("B")= "CHECK"
  30117   "RTN","RCD PLPL1",12, 0)
  30118    W ! D ^DI R K DIR
  30119   "RTN","RCD PLPL1",13, 0)
  30120    Q:$D(DTOU T)!$D(DUOU T)
  30121   "RTN","RCD PLPL1",14, 0)
  30122    I Y="C" D   Q
  30123   "RTN","RCD PLPL1",15, 0)
  30124    . D FINDC HEK
  30125   "RTN","RCD PLPL1",16, 0)
  30126    I Y="T" D   Q
  30127   "RTN","RCD PLPL1",17, 0)
  30128    . D FINDT RAC
  30129   "RTN","RCD PLPL1",18, 0)
  30130    Q
  30131   "RTN","RCD PLPL1",19, 0)
  30132    ;
  30133   "RTN","RCD PLPL1",20, 0)
  30134   FINDCHEK ;  Find a sp ecific che ck used fo r payments
  30135   "RTN","RCD PLPL1",21, 0)
  30136    D FULL^VA LM1
  30137   "RTN","RCD PLPL1",22, 0)
  30138    S VALMBCK ="R"
  30139   "RTN","RCD PLPL1",23, 0)
  30140    ;
  30141   "RTN","RCD PLPL1",24, 0)
  30142    N RCCHECK ,RCTYPE
  30143   "RTN","RCD PLPL1",25, 0)
  30144    K RCFCHEC K,RCFCREDT ,RCFTRACE
  30145   "RTN","RCD PLPL1",26, 0)
  30146    W !
  30147   "RTN","RCD PLPL1",27, 0)
  30148    S RCCHECK =$$ASKCHEK  I RCCHECK =-1 D INIT ^RCDPLPLM  Q
  30149   "RTN","RCD PLPL1",28, 0)
  30150    ;
  30151   "RTN","RCD PLPL1",29, 0)
  30152    S RCTYPE= $$ASKTYPE  I RCTYPE=- 1 D INIT^R CDPLPLM Q
  30153   "RTN","RCD PLPL1",30, 0)
  30154    S RCFCHEC K=RCCHECK_ "^"_RCTYPE
  30155   "RTN","RCD PLPL1",31, 0)
  30156    D INIT^RC DPLPLM
  30157   "RTN","RCD PLPL1",32, 0)
  30158    Q
  30159   "RTN","RCD PLPL1",33, 0)
  30160    ;
  30161   "RTN","RCD PLPL1",34, 0)
  30162   FINDTRAC ;  Find a sp ecific tra ce # used  for EFT/ER A payments
  30163   "RTN","RCD PLPL1",35, 0)
  30164    D FULL^VA LM1
  30165   "RTN","RCD PLPL1",36, 0)
  30166    S VALMBCK ="R"
  30167   "RTN","RCD PLPL1",37, 0)
  30168    ;
  30169   "RTN","RCD PLPL1",38, 0)
  30170    N RCTRACE ,RCTYPE
  30171   "RTN","RCD PLPL1",39, 0)
  30172    K RCFTRAC E,RCFCREDT ,RCFCHECK
  30173   "RTN","RCD PLPL1",40, 0)
  30174    W !
  30175   "RTN","RCD PLPL1",41, 0)
  30176    S RCTRACE =$$ASKTRAC E I RCTRAC E=-1 D INI T^RCDPLPLM  Q
  30177   "RTN","RCD PLPL1",42, 0)
  30178    ;
  30179   "RTN","RCD PLPL1",43, 0)
  30180    S RCTYPE= $$ASKTYPE  I RCTYPE=- 1 D INIT^R CDPLPLM Q
  30181   "RTN","RCD PLPL1",44, 0)
  30182    S RCFTRAC E=RCTRACE_ "^"_RCTYPE
  30183   "RTN","RCD PLPL1",45, 0)
  30184    D INIT^RC DPLPLM
  30185   "RTN","RCD PLPL1",46, 0)
  30186    Q
  30187   "RTN","RCD PLPL1",47, 0)
  30188    ;
  30189   "RTN","RCD PLPL1",48, 0)
  30190    ;
  30191   "RTN","RCD PLPL1",49, 0)
  30192   FINDCRED ; EP Protoco l Action -   RCDP LIN K PAYMENTS  SEARCH CR EDIT
  30193   "RTN","RCD PLPL1",50, 0)
  30194    ; Find a  specific c redit card  used for  payments
  30195   "RTN","RCD PLPL1",51, 0)
  30196    D FULL^VA LM1
  30197   "RTN","RCD PLPL1",52, 0)
  30198    S VALMBCK ="R"
  30199   "RTN","RCD PLPL1",53, 0)
  30200    ;
  30201   "RTN","RCD PLPL1",54, 0)
  30202    N RCCREDT ,RCTYPE
  30203   "RTN","RCD PLPL1",55, 0)
  30204    K RCFCHEC K,RCFCREDT ,RCFTRACE
  30205   "RTN","RCD PLPL1",56, 0)
  30206    W !
  30207   "RTN","RCD PLPL1",57, 0)
  30208    S RCCREDT =$$ASKCRED  I RCCREDT =-1 D INIT ^RCDPLPLM  Q
  30209   "RTN","RCD PLPL1",58, 0)
  30210    ;
  30211   "RTN","RCD PLPL1",59, 0)
  30212    S RCTYPE= $$ASKTYPE  I RCTYPE=- 1 D INIT^R CDPLPLM Q
  30213   "RTN","RCD PLPL1",60, 0)
  30214    S RCFCRED T=RCCREDT_ "^"_RCTYPE
  30215   "RTN","RCD PLPL1",61, 0)
  30216    D INIT^RC DPLPLM
  30217   "RTN","RCD PLPL1",62, 0)
  30218    Q
  30219   "RTN","RCD PLPL1",63, 0)
  30220    ;
  30221   "RTN","RCD PLPL1",64, 0)
  30222    ;
  30223   "RTN","RCD PLPL1",65, 0)
  30224   ACCOUNT ;E P Protocol  Action -  RCDP LINK  PAYMENTS A CCOUNT PRO FILE
  30225   "RTN","RCD PLPL1",66, 0)
  30226    ; Account  profile
  30227   "RTN","RCD PLPL1",67, 0)
  30228    D FULL^VA LM1
  30229   "RTN","RCD PLPL1",68, 0)
  30230    D ACCTPRO F^RCDPAPLM
  30231   "RTN","RCD PLPL1",69, 0)
  30232    D INIT^RC DPLPLM
  30233   "RTN","RCD PLPL1",70, 0)
  30234    S VALMBCK ="R"
  30235   "RTN","RCD PLPL1",71, 0)
  30236    ;  fast e xit
  30237   "RTN","RCD PLPL1",72, 0)
  30238    I $G(RCDP FXIT) S VA LMBCK="Q"
  30239   "RTN","RCD PLPL1",73, 0)
  30240    Q
  30241   "RTN","RCD PLPL1",74, 0)
  30242    ;
  30243   "RTN","RCD PLPL1",75, 0)
  30244    ;
  30245   "RTN","RCD PLPL1",76, 0)
  30246   RECEIPT ;E P Protocol  Action -  RCDP LINK  PAYMENTS R ECEIPT PRO FILE
  30247   "RTN","RCD PLPL1",77, 0)
  30248    ; Receipt  profile
  30249   "RTN","RCD PLPL1",78, 0)
  30250    D FULL^VA LM1
  30251   "RTN","RCD PLPL1",79, 0)
  30252    D RECTPRO F^RCDPRPLM
  30253   "RTN","RCD PLPL1",80, 0)
  30254    D INIT^RC DPLPLM
  30255   "RTN","RCD PLPL1",81, 0)
  30256    S VALMBCK ="R"
  30257   "RTN","RCD PLPL1",82, 0)
  30258    I $G(RCDP FXIT) S VA LMBCK="Q"
  30259   "RTN","RCD PLPL1",83, 0)
  30260    Q
  30261   "RTN","RCD PLPL1",84, 0)
  30262    ;
  30263   "RTN","RCD PLPL1",85, 0)
  30264   CLEARSUS ; EP Protoco l action -  RCDP LINK  PAYMENTS  CLEAR SUSP ENSE
  30265   "RTN","RCD PLPL1",86, 0)
  30266    ; Flag a  payment as  being cle ared from  suspense
  30267   "RTN","RCD PLPL1",87, 0)
  30268    D FULL^VA LM1
  30269   "RTN","RCD PLPL1",88, 0)
  30270    S VALMBCK ="R"
  30271   "RTN","RCD PLPL1",89, 0)
  30272    ;
  30273   "RTN","RCD PLPL1",90, 0)
  30274    W !!,"Thi s option w ill allow  you to ent er the FMS  Document  Number use d"
  30275   "RTN","RCD PLPL1",91, 0)
  30276    W !,"to c lear the p ayment fro m the susp ense accou nt in FMS.   Once an"
  30277   "RTN","RCD PLPL1",92, 0)
  30278    W !,"FMS  Document N umber is e ntered, th e payment  will no lo nger appea r"
  30279   "RTN","RCD PLPL1",93, 0)
  30280    W !,"on t he list as  Unlinked. ",!
  30281   "RTN","RCD PLPL1",94, 0)
  30282    N INDEX,R CPAY,RCREC TDA,RCTRAN DA
  30283   "RTN","RCD PLPL1",95, 0)
  30284    S INDEX=$ $SELPAY
  30285   "RTN","RCD PLPL1",96, 0)
  30286    I INDEX D
  30287   "RTN","RCD PLPL1",97, 0)
  30288    .   S RCP AY=$G(^TMP ("RCDPLPLM ",$J,"IDX" ,INDEX,IND EX))
  30289   "RTN","RCD PLPL1",98, 0)
  30290    .   S RCR ECTDA=+$P( RCPAY,"^") ,RCTRANDA= +$P(RCPAY, "^",2)
  30291   "RTN","RCD PLPL1",99, 0)
  30292    I 'INDEX  D
  30293   "RTN","RCD PLPL1",100 ,0)
  30294    .   W ! S  RCRECTDA= +$$SELRECT ^RCDPUREC( 0,0) I RCR ECTDA<1 Q
  30295   "RTN","RCD PLPL1",101 ,0)
  30296    .   S RCT RANDA=+$$S ELTRAN^RCD PURET(RCRE CTDA) I RC TRANDA<1 S  RCTRANDA= 0
  30297   "RTN","RCD PLPL1",102 ,0)
  30298    I '$G(RCR ECTDA)!('$ G(RCTRANDA )) S VALMB CK="R" Q
  30299   "RTN","RCD PLPL1",103 ,0)
  30300    ;
  30301   "RTN","RCD PLPL1",104 ,0)
  30302    W !!,"                     Rece ipt: ",$P( ^RCY(344,R CRECTDA,0) ,"^")
  30303   "RTN","RCD PLPL1",105 ,0)
  30304    W !,"                 Transacti on: ",RCTR ANDA
  30305   "RTN","RCD PLPL1",106 ,0)
  30306    W !,"  Un applied De posit Numb er: ",$P($ G(^RCY(344 ,RCRECTDA, 1,RCTRANDA ,2)),"^",5 )
  30307   "RTN","RCD PLPL1",107 ,0)
  30308    D EDITFMS ^RCDPURET( RCRECTDA,R CTRANDA,"" )
  30309   "RTN","RCD PLPL1",108 ,0)
  30310    ;
  30311   "RTN","RCD PLPL1",109 ,0)
  30312    ;PRCA*4.5 *304 Force  a comment  and updat e audit Lo g
  30313   "RTN","RCD PLPL1",110 ,0)
  30314    ;ask for  comment
  30315   "RTN","RCD PLPL1",111 ,0)
  30316    D ADDCMT( RCRECTDA,R CTRANDA)
  30317   "RTN","RCD PLPL1",112 ,0)
  30318    ;
  30319   "RTN","RCD PLPL1",113 ,0)
  30320    ;If the C R document  was filed , update t he Audit L og and sus pense stat us
  30321   "RTN","RCD PLPL1",114 ,0)
  30322    I $P($G(^ RCY(344,RC RECTDA,1,R CTRANDA,2) ),U,6)'=""  D
  30323   "RTN","RCD PLPL1",115 ,0)
  30324    . D AUDIT ^RCBEPAY(R CRECTDA,RC TRANDA,"R" )
  30325   "RTN","RCD PLPL1",116 ,0)
  30326    . D SUSPD IS^RCBEPAY (RCRECTDA, RCTRANDA," R")
  30327   "RTN","RCD PLPL1",117 ,0)
  30328    ;end PRCA *4.5*304
  30329   "RTN","RCD PLPL1",118 ,0)
  30330    ;
  30331   "RTN","RCD PLPL1",119 ,0)
  30332    S VALMBCK ="R"
  30333   "RTN","RCD PLPL1",120 ,0)
  30334    D INIT^RC DPLPLM
  30335   "RTN","RCD PLPL1",121 ,0)
  30336    Q
  30337   "RTN","RCD PLPL1",122 ,0)
  30338    ;
  30339   "RTN","RCD PLPL1",123 ,0)
  30340   SELPAY() ;  Select a  payment fr om the for m list
  30341   "RTN","RCD PLPL1",124 ,0)
  30342    N VALMBG, VALMLST
  30343   "RTN","RCD PLPL1",125 ,0)
  30344    ;  if no  payments,  quit
  30345   "RTN","RCD PLPL1",126 ,0)
  30346    I '$O(^TM P("RCDPLPL M",$J,"IDX ",0)) S VA LMSG="Ther e are NO p ayments on  the form  to select. " Q 0
  30347   "RTN","RCD PLPL1",127 ,0)
  30348    ;
  30349   "RTN","RCD PLPL1",128 ,0)
  30350    ;  if onl y one paym ent, selec t that one  automatic ally
  30351   "RTN","RCD PLPL1",129 ,0)
  30352    I '$O(^TM P("RCDPLPL M",$J,"IDX ",1)) Q 1
  30353   "RTN","RCD PLPL1",130 ,0)
  30354    ;
  30355   "RTN","RCD PLPL1",131 ,0)
  30356    ;  select  the entry  from the  list
  30357   "RTN","RCD PLPL1",132 ,0)
  30358    ;  if not  on first  screen, ma ke sure se lection be gins with  1
  30359   "RTN","RCD PLPL1",133 ,0)
  30360    S VALMBG= 1
  30361   "RTN","RCD PLPL1",134 ,0)
  30362    ;  if not  on last s creen, mak e sure sel ection end s with las t
  30363   "RTN","RCD PLPL1",135 ,0)
  30364    S VALMLST =$O(^TMP(" RCDPLPLM", $J,"IDX",9 99999999), -1)
  30365   "RTN","RCD PLPL1",136 ,0)
  30366    D EN^VALM 2($G(XQORN OD(0)),"OS ")
  30367   "RTN","RCD PLPL1",137 ,0)
  30368    Q $O(VALM Y(0))
  30369   "RTN","RCD PLPL1",138 ,0)
  30370    ;
  30371   "RTN","RCD PLPL1",139 ,0)
  30372   ASKCHEK()  ; Ask the  check numb er
  30373   "RTN","RCD PLPL1",140 ,0)
  30374    N DIR,X,Y
  30375   "RTN","RCD PLPL1",141 ,0)
  30376    S DIR(0)= "FAO^1:50"
  30377   "RTN","RCD PLPL1",142 ,0)
  30378    S DIR("A" )="Enter t he Check N umber to S earch for:  "
  30379   "RTN","RCD PLPL1",143 ,0)
  30380    S DIR("?" )="Enter t he check n umber from  1 to 50 c haracters  free text. "
  30381   "RTN","RCD PLPL1",144 ,0)
  30382    D ^DIR
  30383   "RTN","RCD PLPL1",145 ,0)
  30384    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  30385   "RTN","RCD PLPL1",146 ,0)
  30386    Q $S(Y'=" ":Y,1:-1)
  30387   "RTN","RCD PLPL1",147 ,0)
  30388    ;
  30389   "RTN","RCD PLPL1",148 ,0)
  30390   ASKTRACE()  ; Ask the  e-payment s trace nu mber
  30391   "RTN","RCD PLPL1",149 ,0)
  30392    N DIR,X,Y
  30393   "RTN","RCD PLPL1",150 ,0)
  30394    S DIR(0)= "FAO^1:50"
  30395   "RTN","RCD PLPL1",151 ,0)
  30396    S DIR("A" )="Enter t he e-Payme nts Trace  Number to  Search for : "
  30397   "RTN","RCD PLPL1",152 ,0)
  30398    S DIR("?" )="Enter t he trace n umber from  1 to 50 c haracters  free text. "
  30399   "RTN","RCD PLPL1",153 ,0)
  30400    D ^DIR
  30401   "RTN","RCD PLPL1",154 ,0)
  30402    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  30403   "RTN","RCD PLPL1",155 ,0)
  30404    Q $S(Y'=" ":Y,1:-1)
  30405   "RTN","RCD PLPL1",156 ,0)
  30406    ;
  30407   "RTN","RCD PLPL1",157 ,0)
  30408   ASKCRED()  ; Ask the  credit car d number
  30409   "RTN","RCD PLPL1",158 ,0)
  30410    N DIR,DIR UT,DTOUT,D UOUT,X,Y
  30411   "RTN","RCD PLPL1",159 ,0)
  30412    S DIR(0)= "NAO^0:999 9999999999 999"
  30413   "RTN","RCD PLPL1",160 ,0)
  30414    S DIR("A" )="Enter t he Credit  Card Numbe r to Searc h for: "
  30415   "RTN","RCD PLPL1",161 ,0)
  30416    S DIR("?" )="Enter t he check c ard number  from 1 to  16 number s."
  30417   "RTN","RCD PLPL1",162 ,0)
  30418    D ^DIR
  30419   "RTN","RCD PLPL1",163 ,0)
  30420    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  30421   "RTN","RCD PLPL1",164 ,0)
  30422    Q $S(Y'=" ":Y,1:-1)
  30423   "RTN","RCD PLPL1",165 ,0)
  30424    ;
  30425   "RTN","RCD PLPL1",166 ,0)
  30426   ASKTYPE()  ; Ask the  type of ma tch
  30427   "RTN","RCD PLPL1",167 ,0)
  30428    N DIR,DIR UT,DTOUT,D UOUT,X,Y
  30429   "RTN","RCD PLPL1",168 ,0)
  30430    S DIR(0)= "SAO^1:Exa ct Match;2 :Contains; "
  30431   "RTN","RCD PLPL1",169 ,0)
  30432    S DIR("A" )="Type of  Match: "
  30433   "RTN","RCD PLPL1",170 ,0)
  30434    S DIR("B" )="Contain s"
  30435   "RTN","RCD PLPL1",171 ,0)
  30436    D ^DIR
  30437   "RTN","RCD PLPL1",172 ,0)
  30438    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  30439   "RTN","RCD PLPL1",173 ,0)
  30440    Q $S(Y=1: "EQUAL TO" ,Y=2:"CONT AINING",1: -1)
  30441   "RTN","RCD PLPL1",174 ,0)
  30442    ;
  30443   "RTN","RCD PLPL1",175 ,0)
  30444    ;PRCA*4.5 *304
  30445   "RTN","RCD PLPL1",176 ,0)
  30446   ADDCMT(RCR ECTDA,RCTR ANDA)   ;  Ask for a  comment fo r the susp ense entry
  30447   "RTN","RCD PLPL1",177 ,0)
  30448    ;
  30449   "RTN","RCD PLPL1",178 ,0)
  30450    N DA,DIDE L,DIE,DIR, DIRUT,DIRO UT,DR,DTOU T,DUOUT,RC DCMT,X,Y
  30451   "RTN","RCD PLPL1",179 ,0)
  30452    S RCDCMT= ""
  30453   "RTN","RCD PLPL1",180 ,0)
  30454    F  D  Q:R CDCMT'=""
  30455   "RTN","RCD PLPL1",181 ,0)
  30456    . S Y=$$C OM^RCDPECH  ; PRCA*4. 5*321
  30457   "RTN","RCD PLPL1",182 ,0)
  30458    . ;strip  all leadin g and trai ling space s
  30459   "RTN","RCD PLPL1",183 ,0)
  30460    . S Y=$$T RIM^XLFSTR (Y)
  30461   "RTN","RCD PLPL1",184 ,0)
  30462    . I (Y="" )!(Y=-1) D   Q
  30463   "RTN","RCD PLPL1",185 ,0)
  30464    . . W !," A comment  is require d when cha nging the  status of  an item in  Suspense.   Please t ry again."
  30465   "RTN","RCD PLPL1",186 ,0)
  30466    . S RCDCM T=Y
  30467   "RTN","RCD PLPL1",187 ,0)
  30468    ;
  30469   "RTN","RCD PLPL1",188 ,0)
  30470    ; Update  the commen t field
  30471   "RTN","RCD PLPL1",189 ,0)
  30472    S DR="1.0 2////"_RCD CMT
  30473   "RTN","RCD PLPL1",190 ,0)
  30474    S DIE="^R CY(344,"_R CRECTDA_", 1,"
  30475   "RTN","RCD PLPL1",191 ,0)
  30476    S DA=RCTR ANDA,DA(1) =RCRECTDA
  30477   "RTN","RCD PLPL1",192 ,0)
  30478    D ^DIE
  30479   "RTN","RCD PLPL1",193 ,0)
  30480    D LASTEDI T^RCDPUREC (RCRECTDA)
  30481   "RTN","RCD PLPL1",194 ,0)
  30482    ;Update c omment his tory - PRC A*4.5*321
  30483   "RTN","RCD PLPL1",195 ,0)
  30484    D AUDIT^R CDPECH(RCR ECTDA,RCTR ANDA,"","" )
  30485   "RTN","RCD PLPL1",196 ,0)
  30486    Q
  30487   "RTN","RCD PLPL3")
  30488   0^36^B5976 1517
  30489   "RTN","RCD PLPL3",1,0 )
  30490   RCDPLPL3 ; WISC/RFJ -  link paym ents listm anager opt ions (link  payment)  ;1 Jun 00
  30491   "RTN","RCD PLPL3",2,0 )
  30492    ;;4.5;Acc ounts Rece ivable;**1 53,304,301 ,321**;Mar  20, 1995; Build 46
  30493   "RTN","RCD PLPL3",3,0 )
  30494    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  30495   "RTN","RCD PLPL3",4,0 )
  30496    Q
  30497   "RTN","RCD PLPL3",5,0 )
  30498    ;
  30499   "RTN","RCD PLPL3",6,0 )
  30500    ;
  30501   "RTN","RCD PLPL3",7,0 )
  30502   LINKPAY ;   link a pa yment to a n account
  30503   "RTN","RCD PLPL3",8,0 )
  30504    N DA,DIR, DIRUT,DIRO UT,DTOUT,D UOUT,RCEEO B,X,Y ; PR CA*4.5*321  - added R CEEOB
  30505   "RTN","RCD PLPL3",9,0 )
  30506    ;
  30507   "RTN","RCD PLPL3",10, 0)
  30508    D FULL^VA LM1
  30509   "RTN","RCD PLPL3",11, 0)
  30510    S VALMBCK ="R"
  30511   "RTN","RCD PLPL3",12, 0)
  30512    ;
  30513   "RTN","RCD PLPL3",13, 0)
  30514    W !!,"Thi s option w ill allow  the accoun t to be en tered for  an unappli ed"
  30515   "RTN","RCD PLPL3",14, 0)
  30516    W !,"paym ent transa ction sele cted from  the above  list.  If  the select ed"
  30517   "RTN","RCD PLPL3",15, 0)
  30518    W !,"rece ipt has be en previou sly proces sed, the s elected ac count in t he"
  30519   "RTN","RCD PLPL3",16, 0)
  30520    W !,"acco unts recei vable pack age will b e updated  with the p ayment.",!
  30521   "RTN","RCD PLPL3",17, 0)
  30522    N INDEX,R CDPFLAG,RC ERROR,RCGE CSCR,RCPAY ,RCRECTDA, RCSTATUS,R CTRANDA,RC DCHKSW,HRC DCKSW,RCDP TYPE
  30523   "RTN","RCD PLPL3",18, 0)
  30524    S INDEX=$ $SELPAY^RC DPLPL1 I ' INDEX Q
  30525   "RTN","RCD PLPL3",19, 0)
  30526    S RCPAY=$ G(^TMP("RC DPLPLM",$J ,"IDX",IND EX,INDEX))
  30527   "RTN","RCD PLPL3",20, 0)
  30528    S RCRECTD A=+$P(RCPA Y,"^"),RCT RANDA=+$P( RCPAY,"^", 2)
  30529   "RTN","RCD PLPL3",21, 0)
  30530    ;
  30531   "RTN","RCD PLPL3",22, 0)
  30532    I '$$LOCK REC^RCDPRP LU(RCRECTD A) Q
  30533   "RTN","RCD PLPL3",23, 0)
  30534    S RCDPTYP E=$P(^RCY( 344,RCRECT DA,1,RCTRA NDA,0),"^" ,19)
  30535   "RTN","RCD PLPL3",24, 0)
  30536    ;
  30537   "RTN","RCD PLPL3",25, 0)
  30538    ;  check  to see if  the cr doc ument has  been sent  for the re ceipt
  30539   "RTN","RCD PLPL3",26, 0)
  30540    S RCGECSC R=$P($G(^R CY(344,RCR ECTDA,2)), "^")
  30541   "RTN","RCD PLPL3",27, 0)
  30542    ;  code s heet alrea dy sent on ce, this i s a retran smission,  check it
  30543   "RTN","RCD PLPL3",28, 0)
  30544    I RCGECSC R'="" D
  30545   "RTN","RCD PLPL3",29, 0)
  30546    .   S RCS TATUS=$$ST ATUS^GECSS GET(RCGECS CR)
  30547   "RTN","RCD PLPL3",30, 0)
  30548    .   W !!, "This rece ipt has be en process ed to FMS  with cash  receipt do cument"
  30549   "RTN","RCD PLPL3",31, 0)
  30550    .   W !,$ TR(RCGECSC R," "),".   The curre nt status  for this d ocument in  the"
  30551   "RTN","RCD PLPL3",32, 0)
  30552    .   W !," Generic Co de Sheet S tack file  is ",RCSTA TUS,"."
  30553   "RTN","RCD PLPL3",33, 0)
  30554    .   ;
  30555   "RTN","RCD PLPL3",34, 0)
  30556    .   ;  ok ay to cont inue if st atus is Er ror, Rejec ted, or no t defined  (-1)
  30557   "RTN","RCD PLPL3",35, 0)
  30558    .   I $E( RCSTATUS)= "E"!($E(RC STATUS)="R ")!(RCSTAT US=-1) Q
  30559   "RTN","RCD PLPL3",36, 0)
  30560    .   ;  ok ay to cont inue if st atus is Ac cepted
  30561   "RTN","RCD PLPL3",37, 0)
  30562    .   I $E( RCSTATUS)= "A" Q
  30563   "RTN","RCD PLPL3",38, 0)
  30564    .   ;  ok ay to cont inue if do cument is  transmitte d for 2 da ys
  30565   "RTN","RCD PLPL3",39, 0)
  30566    .   I $E( RCSTATUS)= "T",$$FMDI FF^XLFDT(D T,$P(^RCY( 344,RCRECT DA,0),"^", 8))>1 Q
  30567   "RTN","RCD PLPL3",40, 0)
  30568    .   ;
  30569   "RTN","RCD PLPL3",41, 0)
  30570    .   W !!, "You canno t link the  payment t o an accou nt until t he FMS cas h receipt"
  30571   "RTN","RCD PLPL3",42, 0)
  30572    .   W !," document i s either A ccepted or  Rejected  by FMS."
  30573   "RTN","RCD PLPL3",43, 0)
  30574    .   W !,"   1.  If t he FMS cas h receipt  is Accepte d by FMS,  you will n eed to"
  30575   "RTN","RCD PLPL3",44, 0)
  30576    .   W !,"       remo ve the pay ment from  the statio n's suspen se account  online"
  30577   "RTN","RCD PLPL3",45, 0)
  30578    .   W !,"       in F MS."
  30579   "RTN","RCD PLPL3",46, 0)
  30580    .   W !,"   2.  If t he FMS cas h receipt  document i s rejected  by FMS, y ou can"
  30581   "RTN","RCD PLPL3",47, 0)
  30582    .   W !,"       use  the option  Process R eceipt und er the Rec eipt Proce ssing"
  30583   "RTN","RCD PLPL3",48, 0)
  30584    .   W !,"       list manager sc reen to re generate t he documen t.  The pa yment"
  30585   "RTN","RCD PLPL3",49, 0)
  30586    .   W !,"       has  not been d eposited i n the stat ion's susp ense accou nt by"
  30587   "RTN","RCD PLPL3",50, 0)
  30588    .   W !,"       FMS  since the  cash recei pt documen t rejected .",!
  30589   "RTN","RCD PLPL3",51, 0)
  30590    .   S VAL MSG="Try l inking thi s payment  again tomo rrow."
  30591   "RTN","RCD PLPL3",52, 0)
  30592    .   D WRI TE^RCDPRPL U(VALMSG)
  30593   "RTN","RCD PLPL3",53, 0)
  30594    .   S RCD PFLAG=1
  30595   "RTN","RCD PLPL3",54, 0)
  30596    I $G(RCDP FLAG) D QU IT Q
  30597   "RTN","RCD PLPL3",55, 0)
  30598    ;
  30599   "RTN","RCD PLPL3",56, 0)
  30600    ;  show p ayment tra nsaction
  30601   "RTN","RCD PLPL3",57, 0)
  30602    W !!,"The  current p ayment tra nsaction:" ,?40,"RECE IPT: ",$P( ^RCY(344,R CRECTDA,0) ,"^")
  30603   "RTN","RCD PLPL3",58, 0)
  30604    W !,"---- ---------- ---------- --------"
  30605   "RTN","RCD PLPL3",59, 0)
  30606    D SHOWPAY (RCRECTDA, RCTRANDA)
  30607   "RTN","RCD PLPL3",60, 0)
  30608    ;
  30609   "RTN","RCD PLPL3",61, 0)
  30610    ;  transa ction has  account en tered
  30611   "RTN","RCD PLPL3",62, 0)
  30612    I $P(^RCY (344,RCREC TDA,1,RCTR ANDA,0),"^ ",3) D  Q
  30613   "RTN","RCD PLPL3",63, 0)
  30614    .   S VAL MSG="An ac count has  been assig ned to thi s payment. "
  30615   "RTN","RCD PLPL3",64, 0)
  30616    .   D QUI T
  30617   "RTN","RCD PLPL3",65, 0)
  30618    ;
  30619   "RTN","RCD PLPL3",66, 0)
  30620    ;  transa ction is c ancelled,  cannot edi t
  30621   "RTN","RCD PLPL3",67, 0)
  30622    I '$P(^RC Y(344,RCRE CTDA,1,RCT RANDA,0)," ^",4),$P($ G(^RCY(344 ,RCRECTDA, 1,RCTRANDA ,1)),"^")' ="" D  Q
  30623   "RTN","RCD PLPL3",68, 0)
  30624    .   S VAL MSG="Payme nt Transac tion "_RCT RANDA_" is  CANCELLED ."
  30625   "RTN","RCD PLPL3",69, 0)
  30626    .   D WRI TE^RCDPRPL U(VALMSG)
  30627   "RTN","RCD PLPL3",70, 0)
  30628    .   D QUI T
  30629   "RTN","RCD PLPL3",71, 0)
  30630    ;
  30631   "RTN","RCD PLPL3",72, 0)
  30632    ;PRCA*4.5 *304
  30633   "RTN","RCD PLPL3",73, 0)
  30634    ; Will th is link pa yment link  to multip le bills
  30635   "RTN","RCD PLPL3",74, 0)
  30636    ; Note:   some of th e code and  logic bel ow is also  in tag PR OCESS^RCDP LPL4.  
  30637   "RTN","RCD PLPL3",75, 0)
  30638    ;         If changes  in logic  are made b elow, plea se review  this tag a s well.
  30639   "RTN","RCD PLPL3",76, 0)
  30640    ;    
  30641   "RTN","RCD PLPL3",77, 0)
  30642    S DIR(0)= "YO",DIR(" B")="NO"
  30643   "RTN","RCD PLPL3",78, 0)
  30644    S DIR("A" )="  Will  this trans action be  linked to  multiple c laims (Y/N )"
  30645   "RTN","RCD PLPL3",79, 0)
  30646    D ^DIR
  30647   "RTN","RCD PLPL3",80, 0)
  30648    I $G(DTOU T)!($G(DUO UT)) D QUI T Q
  30649   "RTN","RCD PLPL3",81, 0)
  30650    I +Y D MU LTIPLE^RCD PLPL4(RCRE CTDA,RCTRA NDA,RCGECS CR,$G(RCST ATUS)) D Q UIT Q
  30651   "RTN","RCD PLPL3",82, 0)
  30652    ;end PRCA *4.5*304
  30653   "RTN","RCD PLPL3",83, 0)
  30654    ;
  30655   "RTN","RCD PLPL3",84, 0)
  30656    W !!,"Edi ting Payme nt: ",RCTR ANDA
  30657   "RTN","RCD PLPL3",85, 0)
  30658   DBTRBIL S  RCDCHKSW=1 ,HRCDCKSW= 0 D EDITAC CT^RCDPURE T(RCRECTDA ,RCTRANDA)  I RCDCHKS W=0 G DBTR BIL   ;prc a*4.5*301
  30659   "RTN","RCD PLPL3",86, 0)
  30660    W !
  30661   "RTN","RCD PLPL3",87, 0)
  30662    ;  accoun t not ente red
  30663   "RTN","RCD PLPL3",88, 0)
  30664    I '$P(^RC Y(344,RCRE CTDA,1,RCT RANDA,0)," ^",3) D  Q
  30665   "RTN","RCD PLPL3",89, 0)
  30666    .   S VAL MSG="Accou nt was not  linked."
  30667   "RTN","RCD PLPL3",90, 0)
  30668    .   D WRI TE^RCDPRPL U(VALMSG)
  30669   "RTN","RCD PLPL3",91, 0)
  30670    .   D QUI T
  30671   "RTN","RCD PLPL3",92, 0)
  30672    ;
  30673   "RTN","RCD PLPL3",93, 0)
  30674    ;  show p ayment tra nsaction
  30675   "RTN","RCD PLPL3",94, 0)
  30676    W !,"The  NEW paymen t transact ion:",?40, "RECEIPT:  ",$P(^RCY( 344,RCRECT DA,0),"^")
  30677   "RTN","RCD PLPL3",95, 0)
  30678    W !,"---- ---------- ---------- -----"
  30679   "RTN","RCD PLPL3",96, 0)
  30680    D SHOWPAY (RCRECTDA, RCTRANDA)
  30681   "RTN","RCD PLPL3",97, 0)
  30682    ;
  30683   "RTN","RCD PLPL3",98, 0)
  30684    I $$ASKAC CT()'=1 D   Q
  30685   "RTN","RCD PLPL3",99, 0)
  30686    .   D DEL EACCT^RCDP URET(RCREC TDA,RCTRAN DA)
  30687   "RTN","RCD PLPL3",100 ,0)
  30688    .   S VAL MSG="Accou nt was del eted and n ot linked. "
  30689   "RTN","RCD PLPL3",101 ,0)
  30690    .   D WRI TE^RCDPRPL U(VALMSG)
  30691   "RTN","RCD PLPL3",102 ,0)
  30692    .   D QUI T
  30693   "RTN","RCD PLPL3",103 ,0)
  30694    ;
  30695   "RTN","RCD PLPL3",104 ,0)
  30696    ; Option  to restore  suspense  EEOB - PRC A*4.5*321
  30697   "RTN","RCD PLPL3",105 ,0)
  30698    S RCEEOB= $$EEOB^RCD PEM5(RCREC TDA,RCTRAN DA)
  30699   "RTN","RCD PLPL3",106 ,0)
  30700    Q:RCEEOB< 0
  30701   "RTN","RCD PLPL3",107 ,0)
  30702    ;
  30703   "RTN","RCD PLPL3",108 ,0)
  30704    ;  receip t has been  processed  since the  cash rece ipt docume nt
  30705   "RTN","RCD PLPL3",109 ,0)
  30706    ;  has be en generat ed.  updat e the new  account wi th payment
  30707   "RTN","RCD PLPL3",110 ,0)
  30708    W !
  30709   "RTN","RCD PLPL3",111 ,0)
  30710    I RCGECSC R'="" D  I  RCERROR Q
  30711   "RTN","RCD PLPL3",112 ,0)
  30712    .   W !," Updating t he Linked  Account wi th the pay ment ..."
  30713   "RTN","RCD PLPL3",113 ,0)
  30714    .   S RCE RROR=$$PRO CESS^RCBEP AY(RCRECTD A,RCTRANDA )
  30715   "RTN","RCD PLPL3",114 ,0)
  30716    .   ;  an  error occ urred duri ng process ing a paym ent
  30717   "RTN","RCD PLPL3",115 ,0)
  30718    .   I RCE RROR D  Q
  30719   "RTN","RCD PLPL3",116 ,0)
  30720    .   .   W  !
  30721   "RTN","RCD PLPL3",117 ,0)
  30722    .   .   W  !,"+----- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---+"
  30723   "RTN","RCD PLPL3",118 ,0)
  30724    .   .   W  !,"|  An  ERROR has  occurred w hen proces sing payme nt ",RCTRA NDA," on r eceipt ",$ P(^RCY(344 ,RCRECTDA, 0),"^"),". ",?79,"|"
  30725   "RTN","RCD PLPL3",119 ,0)
  30726    .   .   W  !,"|  The  error mes sage retur ned during  processin g is:",?79 ,"|"
  30727   "RTN","RCD PLPL3",120 ,0)
  30728    .   .   W  !,"|",?79 ,"|"
  30729   "RTN","RCD PLPL3",121 ,0)
  30730    .   .   W  !,"|  ",$ P(RCERROR, "^",2),?79 ,"|"
  30731   "RTN","RCD PLPL3",122 ,0)
  30732    .   .   W  !,"|",?79 ,"|"
  30733   "RTN","RCD PLPL3",123 ,0)
  30734    .   .   W  !,"|  You  will need  to correc t the erro r before y ou can lin k the paym ent.",?79, "|"
  30735   "RTN","RCD PLPL3",124 ,0)
  30736    .   .   W  !,"+----- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---+"
  30737   "RTN","RCD PLPL3",125 ,0)
  30738    .   .   W  !
  30739   "RTN","RCD PLPL3",126 ,0)
  30740    .   .   D  DELEACCT^ RCDPURET(R CRECTDA,RC TRANDA)
  30741   "RTN","RCD PLPL3",127 ,0)
  30742    .   .   S  VALMSG="A ccount was  deleted a nd not lin ked."
  30743   "RTN","RCD PLPL3",128 ,0)
  30744    .   .   D  WRITE^RCD PRPLU(VALM SG)
  30745   "RTN","RCD PLPL3",129 ,0)
  30746    .   .   D  QUIT
  30747   "RTN","RCD PLPL3",130 ,0)
  30748    .   ;
  30749   "RTN","RCD PLPL3",131 ,0)
  30750    .   ;  pa yment proc essed corr ectly
  30751   "RTN","RCD PLPL3",132 ,0)
  30752    .   W "   done."
  30753   "RTN","RCD PLPL3",133 ,0)
  30754    .   W !
  30755   "RTN","RCD PLPL3",134 ,0)
  30756    .   ;
  30757   "RTN","RCD PLPL3",135 ,0)
  30758    .   ;PRCA *4.5*304
  30759   "RTN","RCD PLPL3",136 ,0)
  30760    .   D REM CMT^RCDPLP L4(RCRECTD A,RCTRANDA )   ; Remo ve the sus pense comm ent.  No l onger need ed. 
  30761   "RTN","RCD PLPL3",137 ,0)
  30762    .   ;
  30763   "RTN","RCD PLPL3",138 ,0)
  30764    .   ;File  entry in  Audit Log
  30765   "RTN","RCD PLPL3",139 ,0)
  30766    .   D AUD IT^RCBEPAY (RCRECTDA, RCTRANDA," P")
  30767   "RTN","RCD PLPL3",140 ,0)
  30768    .   ;
  30769   "RTN","RCD PLPL3",141 ,0)
  30770    .   ; Upd ate Suspen se Status
  30771   "RTN","RCD PLPL3",142 ,0)
  30772    .   D SUS PDIS^RCBEP AY(RCRECTD A,RCTRANDA ,"PD")
  30773   "RTN","RCD PLPL3",143 ,0)
  30774    .   ;end  PRCA*4.5*3 04
  30775   "RTN","RCD PLPL3",144 ,0)
  30776    .   ;
  30777   "RTN","RCD PLPL3",145 ,0)
  30778    .   ; Upd ate EEOB c laim numbe r and rest ore to act ive status  - PRCA*4. 5*321
  30779   "RTN","RCD PLPL3",146 ,0)
  30780    .   D:RCE EOB RESTOR E^RCDPEM5( RCRECTDA,R CTRANDA,RC EEOB,"L")
  30781   "RTN","RCD PLPL3",147 ,0)
  30782    .   ;
  30783   "RTN","RCD PLPL3",148 ,0)
  30784    .   I $E( RCSTATUS)= "A" D
  30785   "RTN","RCD PLPL3",149 ,0)
  30786    .   .   W  !,"Since  the FMS ca sh receipt  document  is Accepte d in FMS,  you need t o go"
  30787   "RTN","RCD PLPL3",150 ,0)
  30788    .   .   W  !,"online  in FMS an d transfer  the amoun t paid out  of the st ation's su spense"
  30789   "RTN","RCD PLPL3",151 ,0)
  30790    .   .   W  !,"accoun t.",!
  30791   "RTN","RCD PLPL3",152 ,0)
  30792    .   .   ;   send mai l message  to the RCD P PAYMENTS  mail grou p
  30793   "RTN","RCD PLPL3",153 ,0)
  30794    .   .   W  !,"Sendin g mail mes sage to RC DP PAYMENT S mail gro up."
  30795   "RTN","RCD PLPL3",154 ,0)
  30796    .   .   D  MAILMSG^R CDPLPSR(RC RECTDA,RCT RANDA)
  30797   "RTN","RCD PLPL3",155 ,0)
  30798    .   .   ;   place an  x in the  fms doc fi eld so it  will show  on the
  30799   "RTN","RCD PLPL3",156 ,0)
  30800    .   .   ;   suspense  report
  30801   "RTN","RCD PLPL3",157 ,0)
  30802    .   .   D  EDITFMS^R CDPURET(RC RECTDA,RCT RANDA,"x")
  30803   "RTN","RCD PLPL3",158 ,0)
  30804    .   I $E( RCSTATUS)' ="A" D
  30805   "RTN","RCD PLPL3",159 ,0)
  30806    .   .   W  !,"Since  the FMS ca sh receipt  document  is NOT Acc epted in F MS, you ca n use"
  30807   "RTN","RCD PLPL3",160 ,0)
  30808    .   .   W  !,"the op tion Proce ss Receipt  located u nder the R eceipt Pro cessing Me nu"
  30809   "RTN","RCD PLPL3",161 ,0)
  30810    .   .   W  !,"to reg enerate th e cash rec eipt docum ent to FMS .",!
  30811   "RTN","RCD PLPL3",162 ,0)
  30812    .   S VAL MSG="Payme nt linked  and remove d from lis t."
  30813   "RTN","RCD PLPL3",163 ,0)
  30814    .   D WRI TE^RCDPRPL U(VALMSG)
  30815   "RTN","RCD PLPL3",164 ,0)
  30816    ;
  30817   "RTN","RCD PLPL3",165 ,0)
  30818    ;  receip t has not  been proce ssed
  30819   "RTN","RCD PLPL3",166 ,0)
  30820    I RCGECSC R="" D
  30821   "RTN","RCD PLPL3",167 ,0)
  30822    .   S VAL MSG="Since  the recei pt has not  been proc essed, acc ounts will  not be up dated."
  30823   "RTN","RCD PLPL3",168 ,0)
  30824    .   D WRI TE^RCDPRPL U(VALMSG)
  30825   "RTN","RCD PLPL3",169 ,0)
  30826    .   S VAL MSG="Payme nt linked  and remove d from lis t."
  30827   "RTN","RCD PLPL3",170 ,0)
  30828    .   ; Upd ate EEOB c laim numbe r and rest ore to act ive status  - PRCA*4. 5*321
  30829   "RTN","RCD PLPL3",171 ,0)
  30830    .   D:RCE EOB RESTOR E^RCDPEM5( RCRECTDA,R CTRANDA,RC EEOB,"L")
  30831   "RTN","RCD PLPL3",172 ,0)
  30832    ;
  30833   "RTN","RCD PLPL3",173 ,0)
  30834   QUIT ;  ca ll here to  unlock an d rebuild  list
  30835   "RTN","RCD PLPL3",174 ,0)
  30836    L -^RCY(3 44,RCRECTD A)
  30837   "RTN","RCD PLPL3",175 ,0)
  30838    D INIT^RC DPLPLM
  30839   "RTN","RCD PLPL3",176 ,0)
  30840    Q
  30841   "RTN","RCD PLPL3",177 ,0)
  30842    ;
  30843   "RTN","RCD PLPL3",178 ,0)
  30844    ;
  30845   "RTN","RCD PLPL3",179 ,0)
  30846   SHOWPAY(RC RECTDA,RCT RANDA) ;   show the p ayment tra nsaction
  30847   "RTN","RCD PLPL3",180 ,0)
  30848    N A,D0,DA ,DIC,DIQ,D K,DL,DX,S, Y
  30849   "RTN","RCD PLPL3",181 ,0)
  30850    S DIC="^R CY(344,"_R CRECTDA_", 1,",DA(1)= RCRECTDA,D A=RCTRANDA ,DIQ(0)="C "
  30851   "RTN","RCD PLPL3",182 ,0)
  30852    D EN^DIQ
  30853   "RTN","RCD PLPL3",183 ,0)
  30854    Q
  30855   "RTN","RCD PLPL3",184 ,0)
  30856    ;
  30857   "RTN","RCD PLPL3",185 ,0)
  30858    ;
  30859   "RTN","RCD PLPL3",186 ,0)
  30860   ASKACCT()  ; ask if i ts the cor rect accou nt
  30861   "RTN","RCD PLPL3",187 ,0)
  30862    ;  1 is y es, otherw ise no
  30863   "RTN","RCD PLPL3",188 ,0)
  30864    N DIR,DIQ 2,DTOUT,DU OUT,X,Y
  30865   "RTN","RCD PLPL3",189 ,0)
  30866    S DIR(0)= "YO",DIR(" B")="NO"
  30867   "RTN","RCD PLPL3",190 ,0)
  30868    S DIR("A" )="  Is th is the cor rect ACCOU NT to appl y the paym ent to"
  30869   "RTN","RCD PLPL3",191 ,0)
  30870    D ^DIR
  30871   "RTN","RCD PLPL3",192 ,0)
  30872    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  30873   "RTN","RCD PLPL3",193 ,0)
  30874    Q Y
  30875   "RTN","RCD PLPL4")
  30876   0^13^B2399 90272
  30877   "RTN","RCD PLPL4",1,0 )
  30878   RCDPLPL4 ; ALB/SAB -  Multiple B ill Link P ayments ;1 7 Mar 16
  30879   "RTN","RCD PLPL4",2,0 )
  30880    ;;4.5;Acc ounts Rece ivable;**3 04,301,321 **;Mar 20,  1995;Buil d 46
  30881   "RTN","RCD PLPL4",3,0 )
  30882    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  30883   "RTN","RCD PLPL4",4,0 )
  30884    ;
  30885   "RTN","RCD PLPL4",5,0 )
  30886    Q
  30887   "RTN","RCD PLPL4",6,0 )
  30888    ;
  30889   "RTN","RCD PLPL4",7,0 )
  30890   MULTIPLE(R CRECTDA,RC TRANDA,RCG ECSCR,RCST ATUS) ; Pr ocess mult iple bills  for the s ame receip t transact ion.
  30891   "RTN","RCD PLPL4",8,0 )
  30892    ;
  30893   "RTN","RCD PLPL4",9,0 )
  30894    N RCAMT,R CCT,RCAMTR M,RCEXIT,R CMSG,RCNWT RAN,RCTACC T,RCTAMT,R CTDATA,RCA CT,RCARRAY ,RCEXT,RCR SP,RCSPRSS
  30895   "RTN","RCD PLPL4",10, 0)
  30896    N RCDACNO ,I,RCNM,RC BLIEN,RCDA CNOI,RCUNA PN,RCQTSP, RCANS,RCDA CT,RCDATA, RCPIEN,RCT ACCTT
  30897   "RTN","RCD PLPL4",11, 0)
  30898    N RCTAMT, RCTCMT,RCT DNM,RCUNRC N,RCDCHKSW ,HRCDCKSW
  30899   "RTN","RCD PLPL4",12, 0)
  30900    ;
  30901   "RTN","RCD PLPL4",13, 0)
  30902    S (RCSPRS S,RCEXIT,R CCT)=0
  30903   "RTN","RCD PLPL4",14, 0)
  30904    S RCTDATA =$G(^RCY(3 44,RCRECTD A,1,RCTRAN DA,0))
  30905   "RTN","RCD PLPL4",15, 0)
  30906    I RCTDATA ="" D  Q
  30907   "RTN","RCD PLPL4",16, 0)
  30908    .  S RCMS G="The ini tial recei pt transac tion data  is missing .  Unable  to link a  claim to t his transa ction."
  30909   "RTN","RCD PLPL4",17, 0)
  30910    .  D WRIT E^RCDPRPLU (RCMSG)
  30911   "RTN","RCD PLPL4",18, 0)
  30912    ;
  30913   "RTN","RCD PLPL4",19, 0)
  30914    ; Retriev e payment  amount on  the transa ction
  30915   "RTN","RCD PLPL4",20, 0)
  30916    S (RCAMT, RCAMTRM)=+ $P(RCTDATA ,U,4)
  30917   "RTN","RCD PLPL4",21, 0)
  30918    ;
  30919   "RTN","RCD PLPL4",22, 0)
  30920    I RCAMT=0  D  Q
  30921   "RTN","RCD PLPL4",23, 0)
  30922    .  S RCMS G="The tra nsaction b alance is  0.  Unable  to link a  claim to  this trans action."
  30923   "RTN","RCD PLPL4",24, 0)
  30924    .  D WRIT E^RCDPRPLU (RCMSG)
  30925   "RTN","RCD PLPL4",25, 0)
  30926    ;
  30927   "RTN","RCD PLPL4",26, 0)
  30928    ;Retrieve  list of B ills to li nk to paym ent
  30929   "RTN","RCD PLPL4",27, 0)
  30930    F  D  Q:R CAMTRM=0   Q:RCEXIT
  30931   "RTN","RCD PLPL4",28, 0)
  30932    . ;
  30933   "RTN","RCD PLPL4",29, 0)
  30934    . ;Re-ini t the susp ense quit  flag
  30935   "RTN","RCD PLPL4",30, 0)
  30936    . S RCQTS P=0
  30937   "RTN","RCD PLPL4",31, 0)
  30938    . ;
  30939   "RTN","RCD PLPL4",32, 0)
  30940    . ;Ask th e user for  the accou nt
  30941   "RTN","RCD PLPL4",33, 0)
  30942    . S RCDCH KSW=1,HRCD CKSW=0,RCA CCT=$$GETA CCT(RCRECT DA) I RCDC HKSW=0 W !  Q    ;prc a*4.5*301
  30943   "RTN","RCD PLPL4",34, 0)
  30944    . I RCACC T=-1 D  Q
  30945   "RTN","RCD PLPL4",35, 0)
  30946    . . S RCR SP=$$CONQU IT()
  30947   "RTN","RCD PLPL4",36, 0)
  30948    . . S:RCR SP=1 RCEXI T=1
  30949   "RTN","RCD PLPL4",37, 0)
  30950    . ;
  30951   "RTN","RCD PLPL4",38, 0)
  30952    . I RCACC T=0 D  Q
  30953   "RTN","RCD PLPL4",39, 0)
  30954    . . W !,? 6,"Invalid  Bill Numb er, Please  try again ...."
  30955   "RTN","RCD PLPL4",40, 0)
  30956    . S:RCACC T="SUSPENS E" RCACCT= ""     ;Pa yment need s to remai n in suspe nse.
  30957   "RTN","RCD PLPL4",41, 0)
  30958    . ;
  30959   "RTN","RCD PLPL4",42, 0)
  30960    . ;Ask th e user for  the amoun t
  30961   "RTN","RCD PLPL4",43, 0)
  30962    . S RCAMT =$$GETAMT( RCACCT,RCA MTRM)
  30963   "RTN","RCD PLPL4",44, 0)
  30964    . Q:RCAMT =-1
  30965   "RTN","RCD PLPL4",45, 0)
  30966    . ;
  30967   "RTN","RCD PLPL4",46, 0)
  30968    . ;Ask th e user for  Comment i f no accou nt is ente red.
  30969   "RTN","RCD PLPL4",47, 0)
  30970    . S RCCMT =""
  30971   "RTN","RCD PLPL4",48, 0)
  30972    . I RCACC T="" S RCC MT=$$GETCM T()
  30973   "RTN","RCD PLPL4",49, 0)
  30974    . ;timed  out or ^ -  exit.
  30975   "RTN","RCD PLPL4",50, 0)
  30976    . I (RCCM T=-1)!(RCC MT="^") Q
  30977   "RTN","RCD PLPL4",51, 0)
  30978    . ;
  30979   "RTN","RCD PLPL4",52, 0)
  30980    . ;Update  the array  and amoun t remainin g.
  30981   "RTN","RCD PLPL4",53, 0)
  30982    . S RCCT= RCCT+1
  30983   "RTN","RCD PLPL4",54, 0)
  30984    . S RCARR AY(RCCT)=R CACCT_U_RC AMT_U_RCCM T_U_$$GETA CTNM(RCACC T)
  30985   "RTN","RCD PLPL4",55, 0)
  30986    . S RCAMT RM=RCAMTRM -RCAMT
  30987   "RTN","RCD PLPL4",56, 0)
  30988    . ;
  30989   "RTN","RCD PLPL4",57, 0)
  30990    . ;Check  to see if  user wishe s to conti nue
  30991   "RTN","RCD PLPL4",58, 0)
  30992    . I RCAMT RM>0 D
  30993   "RTN","RCD PLPL4",59, 0)
  30994    . . ;
  30995   "RTN","RCD PLPL4",60, 0)
  30996    . . ;ask  if user wi shes to co ntinue
  30997   "RTN","RCD PLPL4",61, 0)
  30998    . . S RCR SP=$$CONTI NUE(RCAMTR M)
  30999   "RTN","RCD PLPL4",62, 0)
  31000    . . ;
  31001   "RTN","RCD PLPL4",63, 0)
  31002    . . ;User  wishes to  continue
  31003   "RTN","RCD PLPL4",64, 0)
  31004    . . Q:RCR SP=1
  31005   "RTN","RCD PLPL4",65, 0)
  31006    . . ;
  31007   "RTN","RCD PLPL4",66, 0)
  31008    . . ;if n o, ask if  user is su re and tha t all sele cted payme nts will n ot be link ed.
  31009   "RTN","RCD PLPL4",67, 0)
  31010    . . S RCR SP=$$CONQU IT()
  31011   "RTN","RCD PLPL4",68, 0)
  31012    . . I RCR SP=1 S RCE XIT=1
  31013   "RTN","RCD PLPL4",69, 0)
  31014    ;
  31015   "RTN","RCD PLPL4",70, 0)
  31016    ; If the  user is ex iting befo re complet ion, quit.
  31017   "RTN","RCD PLPL4",71, 0)
  31018    Q:RCEXIT
  31019   "RTN","RCD PLPL4",72, 0)
  31020    ;
  31021   "RTN","RCD PLPL4",73, 0)
  31022    ;State al l money is  disbursed  and displ ay all acc ounts for  confirmati on
  31023   "RTN","RCD PLPL4",74, 0)
  31024    W !!,"***  RECEIPT H AS BEEN FU LLY DISBUR SED ***",!
  31025   "RTN","RCD PLPL4",75, 0)
  31026    ;
  31027   "RTN","RCD PLPL4",76, 0)
  31028    ; Ask if  user wishe s to revie w the list  again
  31029   "RTN","RCD PLPL4",77, 0)
  31030    S RCANS=$ $GETANS(1)
  31031   "RTN","RCD PLPL4",78, 0)
  31032    ;
  31033   "RTN","RCD PLPL4",79, 0)
  31034    ;Spacing  line
  31035   "RTN","RCD PLPL4",80, 0)
  31036    W !
  31037   "RTN","RCD PLPL4",81, 0)
  31038    ;
  31039   "RTN","RCD PLPL4",82, 0)
  31040    ; Review  the list i f necessar y
  31041   "RTN","RCD PLPL4",83, 0)
  31042    I RCANS=1  D
  31043   "RTN","RCD PLPL4",84, 0)
  31044    . S I=0
  31045   "RTN","RCD PLPL4",85, 0)
  31046    . W !,?5, "PATIENT N AME",?36," ACCOUNT",? 50,"PAYMEN T TO APPLY ",!
  31047   "RTN","RCD PLPL4",86, 0)
  31048    . F I=1:1 :RCCT D
  31049   "RTN","RCD PLPL4",87, 0)
  31050    . . S (RC NM,RCDACNO ,RCDACNOI) =""
  31051   "RTN","RCD PLPL4",88, 0)
  31052    . . S RCD ATA=$G(RCA RRAY(I))
  31053   "RTN","RCD PLPL4",89, 0)
  31054    . . S RCD ACT=$P(RCD ATA,U)
  31055   "RTN","RCD PLPL4",90, 0)
  31056    . . S:RCD ACT="" RCN M="SUSPENS E"
  31057   "RTN","RCD PLPL4",91, 0)
  31058    . . I RCD ACT[";DPT"  D
  31059   "RTN","RCD PLPL4",92, 0)
  31060    . . . S R CNM=$P($G( ^DPT($P(RC DACT,";"), 0)),U)
  31061   "RTN","RCD PLPL4",93, 0)
  31062    . . . S R CDACNO=""
  31063   "RTN","RCD PLPL4",94, 0)
  31064    . . I RCD ACT[";PRCA " D
  31065   "RTN","RCD PLPL4",95, 0)
  31066    . . . S R CDACNOI=$P (RCDACT,"; ")
  31067   "RTN","RCD PLPL4",96, 0)
  31068    . . . S R CDACNO=$P( $G(^PRCA(4 30,$P(RCDA CNOI,U),0) ),U)
  31069   "RTN","RCD PLPL4",97, 0)
  31070    . . . S R CPIEN=$P($ G(^DGCR(39 9,RCDACNOI ,0)),U,2)
  31071   "RTN","RCD PLPL4",98, 0)
  31072    . . . I R CPIEN="" S  RCNM="PAT IENT NAME  NOT FOUND"  Q
  31073   "RTN","RCD PLPL4",99, 0)
  31074    . . . S R CNM=$P($G( ^DPT(RCPIE N,0)),U)
  31075   "RTN","RCD PLPL4",100 ,0)
  31076    . . . I R CNM="" S R CNM="PATIE NT NAME NO T FOUND"
  31077   "RTN","RCD PLPL4",101 ,0)
  31078    . . W ?5, RCNM,?36,R CDACNO,?50 ,"$",$J($F N($P(RCDAT A,U,2),"," ,2),15),!
  31079   "RTN","RCD PLPL4",102 ,0)
  31080    ;
  31081   "RTN","RCD PLPL4",103 ,0)
  31082    ; Ask the  user if t hey wish t o update.   Quit if t hey time o ut, "^" ou t, or say  No to upda ting.
  31083   "RTN","RCD PLPL4",104 ,0)
  31084    S RCANS=$ $GETANS(2)
  31085   "RTN","RCD PLPL4",105 ,0)
  31086    Q:RCANS'= 1
  31087   "RTN","RCD PLPL4",106 ,0)
  31088    ;
  31089   "RTN","RCD PLPL4",107 ,0)
  31090    ;Initiali ze error f lag
  31091   "RTN","RCD PLPL4",108 ,0)
  31092    S RCERROR =0
  31093   "RTN","RCD PLPL4",109 ,0)
  31094    ;
  31095   "RTN","RCD PLPL4",110 ,0)
  31096    ;Surpress  PNORBILL^ RCDPURED o utput
  31097   "RTN","RCD PLPL4",111 ,0)
  31098    S RCSPRSS =1
  31099   "RTN","RCD PLPL4",112 ,0)
  31100    ;
  31101   "RTN","RCD PLPL4",113 ,0)
  31102    ;create l ine spacin g
  31103   "RTN","RCD PLPL4",114 ,0)
  31104    W !!
  31105   "RTN","RCD PLPL4",115 ,0)
  31106    ;
  31107   "RTN","RCD PLPL4",116 ,0)
  31108    ;Link the  payments
  31109   "RTN","RCD PLPL4",117 ,0)
  31110    F RCACT=1 :1:RCCT D   Q:RCERROR
  31111   "RTN","RCD PLPL4",118 ,0)
  31112    . ;
  31113   "RTN","RCD PLPL4",119 ,0)
  31114    . ;Extrac t data to  update
  31115   "RTN","RCD PLPL4",120 ,0)
  31116    . S RCTAM T=$P(RCARR AY(RCACT), U,2)   ;Pa yment Amou nt
  31117   "RTN","RCD PLPL4",121 ,0)
  31118    . S RCTAC CT=$P(RCAR RAY(RCACT) ,U,1)    ; Account to  link to.
  31119   "RTN","RCD PLPL4",122 ,0)
  31120    . S RCTCM T=$P(RCARR AY(RCACT), U,3)
  31121   "RTN","RCD PLPL4",123 ,0)
  31122    . S RCTDN M=$P(RCARR AY(RCACT), U,4)
  31123   "RTN","RCD PLPL4",124 ,0)
  31124    . S RCTAC CTT=$S(RCT ACCT="":"t he Suspens e Item",1: RCTACCT)
  31125   "RTN","RCD PLPL4",125 ,0)
  31126    . ;
  31127   "RTN","RCD PLPL4",126 ,0)
  31128    . ;If not  the first  transacti on, create  a new one
  31129   "RTN","RCD PLPL4",127 ,0)
  31130    . I RCACT '=1 D  Q
  31131   "RTN","RCD PLPL4",128 ,0)
  31132    . . ;
  31133   "RTN","RCD PLPL4",129 ,0)
  31134    . . ; Cre ate new tr ansaction
  31135   "RTN","RCD PLPL4",130 ,0)
  31136    . . S RCN WTRAN=$$CO PYTRAN(RCR ECTDA,RCTD ATA,RCTAMT ,RCGECSCR)
  31137   "RTN","RCD PLPL4",131 ,0)
  31138    . . ;
  31139   "RTN","RCD PLPL4",132 ,0)
  31140    . . ; Lin k the Paym ent using  the displa y name
  31141   "RTN","RCD PLPL4",133 ,0)
  31142    . . D LIN KPAY(RCREC TDA,RCNWTR AN,RCTDNM)
  31143   "RTN","RCD PLPL4",134 ,0)
  31144    . . ;
  31145   "RTN","RCD PLPL4",135 ,0)
  31146    . . ; bui ld unappli ed deposit  number
  31147   "RTN","RCD PLPL4",136 ,0)
  31148    . . S RCU NRCN=$P($G (^RCY(344, RCRECTDA,0 )),U)
  31149   "RTN","RCD PLPL4",137 ,0)
  31150    . . S RCU NAPN=$S($L (RCUNRCN)> 9:$E(RCUNR CN,$L(RCUN RCN-9),$L( RCUNRCN)), 1:RCUNRCN)
  31151   "RTN","RCD PLPL4",138 ,0)
  31152    . . S RCU NAPN=RCUNA PN_$E("000 0",1,4-$L( RCNWTRAN)) _RCNWTRAN
  31153   "RTN","RCD PLPL4",139 ,0)
  31154    . . D SET UNAPP^RCDP URET(RCREC TDA,RCNWTR AN,RCUNAPN ) ; add ne w unapplie d deposit  #
  31155   "RTN","RCD PLPL4",140 ,0)
  31156    . . ;
  31157   "RTN","RCD PLPL4",141 ,0)
  31158    . . ; If  creating a  new suspe nse item,  update the  comment f ield and a udit logs
  31159   "RTN","RCD PLPL4",142 ,0)
  31160    . . I RCT CMT'="" D
  31161   "RTN","RCD PLPL4",143 ,0)
  31162    . . . ;
  31163   "RTN","RCD PLPL4",144 ,0)
  31164    . . . D U PDCMT(RCRE CTDA,RCNWT RAN,RCTCMT )  ; add c omment
  31165   "RTN","RCD PLPL4",145 ,0)
  31166    . . . I $ G(RCGECSCR )'="" D
  31167   "RTN","RCD PLPL4",146 ,0)
  31168    . . . . D  AUDIT^RCB EPAY(RCREC TDA,RCNWTR AN,"I")
  31169   "RTN","RCD PLPL4",147 ,0)
  31170    . . . . D  SUSPDIS^R CBEPAY(RCR ECTDA,RCNW TRAN,"P")
  31171   "RTN","RCD PLPL4",148 ,0)
  31172    . . . W ! ,"***** PA YMENT AMOU NT LEFT IN  SUSPENSE  = $",$J(RC TAMT,"",2) ," ... don e."
  31173   "RTN","RCD PLPL4",149 ,0)
  31174    . . ;
  31175   "RTN","RCD PLPL4",150 ,0)
  31176    . . ; If  linking an  account,  process th e linking
  31177   "RTN","RCD PLPL4",151 ,0)
  31178    . . I RCT CMT="" D
  31179   "RTN","RCD PLPL4",152 ,0)
  31180    . . . ;
  31181   "RTN","RCD PLPL4",153 ,0)
  31182    . . . ; I f the rece ipt has be en process ed, proces s the paym ent
  31183   "RTN","RCD PLPL4",154 ,0)
  31184    . . . I $ G(RCGECSCR )'="" D  Q
  31185   "RTN","RCD PLPL4",155 ,0)
  31186    . . . . W  !,RCTDNM, " - Updati ng the Lin ked Accoun t with PMT  = $",$J(R CTAMT,"",2 )," ... do ne."
  31187   "RTN","RCD PLPL4",156 ,0)
  31188    . . . . D  REMCMT(RC RECTDA,RCN WTRAN)   ;  Remove th e supense  comment.   No longer  needed.
  31189   "RTN","RCD PLPL4",157 ,0)
  31190    . . . . D  PROCESS(R CRECTDA,RC NWTRAN,RCT DNM)
  31191   "RTN","RCD PLPL4",158 ,0)
  31192    . . . ;
  31193   "RTN","RCD PLPL4",159 ,0)
  31194    . . . ; T he receipt  has not b een proces sed
  31195   "RTN","RCD PLPL4",160 ,0)
  31196    . . . W ! ,RCTDNM,"  - Receipt  has not be en process ed.  Accou nt linked  but not"
  31197   "RTN","RCD PLPL4",161 ,0)
  31198    . . . W ! ,?6,"updat ed for the  PMT = $", $J(RCTAMT, "",2)
  31199   "RTN","RCD PLPL4",162 ,0)
  31200    . ;
  31201   "RTN","RCD PLPL4",163 ,0)
  31202    . ;If thi s is the f irst trans action, ad just the p ayment amo unt to be  the amount  not split  out.
  31203   "RTN","RCD PLPL4",164 ,0)
  31204    . I RCACT =1 D
  31205   "RTN","RCD PLPL4",165 ,0)
  31206    . . ;
  31207   "RTN","RCD PLPL4",166 ,0)
  31208    . . ; Mod ify the or iginal pay ment amoun t
  31209   "RTN","RCD PLPL4",167 ,0)
  31210    . . D ADJ TRAMT(RCRE CTDA,RCTRA NDA,RCTAMT ,RCGECSCR)
  31211   "RTN","RCD PLPL4",168 ,0)
  31212    . . ;
  31213   "RTN","RCD PLPL4",169 ,0)
  31214    . . ; Adj usting the  amount in  suspense,  update th e comment  field and  audit logs
  31215   "RTN","RCD PLPL4",170 ,0)
  31216    . . I RCT CMT'="" D   Q
  31217   "RTN","RCD PLPL4",171 ,0)
  31218    . . . D U PDCMT(RCRE CTDA,RCTRA NDA,RCTCMT )  ; add c omment
  31219   "RTN","RCD PLPL4",172 ,0)
  31220    . . . I $ G(RCGECSCR )'="" D
  31221   "RTN","RCD PLPL4",173 ,0)
  31222    . . . . D  AUDIT^RCB EPAY(RCREC TDA,RCTRAN DA,"I")
  31223   "RTN","RCD PLPL4",174 ,0)
  31224    . . . . D  SUSPDIS^R CBEPAY(RCR ECTDA,RCTR ANDA,"P")
  31225   "RTN","RCD PLPL4",175 ,0)
  31226    . . . W ! ,"***** PA YMENT AMOU NT LEFT IN  SUSPENSE  = $",$J(RC TAMT,"",2) ," ... don e."
  31227   "RTN","RCD PLPL4",176 ,0)
  31228    . . ;
  31229   "RTN","RCD PLPL4",177 ,0)
  31230    . . ; Lin k the Paym ent, send  account if  PRCA, Pat ient name  in Patient
  31231   "RTN","RCD PLPL4",178 ,0)
  31232    . . D LIN KPAY(RCREC TDA,RCTRAN DA,RCTDNM)
  31233   "RTN","RCD PLPL4",179 ,0)
  31234    . . ;
  31235   "RTN","RCD PLPL4",180 ,0)
  31236    . . ;Remo ve the com ment, item  is no lon ger in sus pense
  31237   "RTN","RCD PLPL4",181 ,0)
  31238    . . D REM CMT(RCRECT DA,RCTRAND A)
  31239   "RTN","RCD PLPL4",182 ,0)
  31240    . . ;
  31241   "RTN","RCD PLPL4",183 ,0)
  31242    . . ; If  the receip t has been  processed , process  the paymen t
  31243   "RTN","RCD PLPL4",184 ,0)
  31244    . . I $G( RCGECSCR)' ="" D  Q
  31245   "RTN","RCD PLPL4",185 ,0)
  31246    . . . W ! ,RCTDNM,"  - Updating  the Linke d Account  with PMT =  $",$J(RCT AMT,"",2), " ... done ."
  31247   "RTN","RCD PLPL4",186 ,0)
  31248    . . . D P ROCESS(RCR ECTDA,RCTR ANDA,RCTDN M)
  31249   "RTN","RCD PLPL4",187 ,0)
  31250    . . ;
  31251   "RTN","RCD PLPL4",188 ,0)
  31252    . . ; The  receipt h as not bee n processe d
  31253   "RTN","RCD PLPL4",189 ,0)
  31254    . . W !,R CTDNM," -  Receipt ha s not been  processed .  Account  linked bu t not"
  31255   "RTN","RCD PLPL4",190 ,0)
  31256    . . W !,? 6,"updated  for the P MT = $",$J (RCTAMT,"" ,2)
  31257   "RTN","RCD PLPL4",191 ,0)
  31258    ;
  31259   "RTN","RCD PLPL4",192 ,0)
  31260    W !!
  31261   "RTN","RCD PLPL4",193 ,0)
  31262    ;
  31263   "RTN","RCD PLPL4",194 ,0)
  31264    D ENDMSG( RCSTATUS)
  31265   "RTN","RCD PLPL4",195 ,0)
  31266    ;
  31267   "RTN","RCD PLPL4",196 ,0)
  31268    D WRITE^R CDPRPLU("  ")
  31269   "RTN","RCD PLPL4",197 ,0)
  31270    ;
  31271   "RTN","RCD PLPL4",198 ,0)
  31272    Q
  31273   "RTN","RCD PLPL4",199 ,0)
  31274    ;
  31275   "RTN","RCD PLPL4",200 ,0)
  31276   GETACCT(RC RECTDA) ;  Ask the us er for the  account
  31277   "RTN","RCD PLPL4",201 ,0)
  31278    ;
  31279   "RTN","RCD PLPL4",202 ,0)
  31280    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT,DA,R CSUSFLG,RC STAT
  31281   "RTN","RCD PLPL4",203 ,0)
  31282    ;
  31283   "RTN","RCD PLPL4",204 ,0)
  31284    S RCSUSFL G=0
  31285   "RTN","RCD PLPL4",205 ,0)
  31286    S DIR("A" )="BILL NU MBER: ",DI R(0)="FAO"
  31287   "RTN","RCD PLPL4",206 ,0)
  31288    S DIR("PR E")="I X=" "SUSPENSE" " S X=""^" ",RCSUSFLG =1"
  31289   "RTN","RCD PLPL4",207 ,0)
  31290    D ^DIR
  31291   "RTN","RCD PLPL4",208 ,0)
  31292    Q:RCSUSFL G "SUSPENS E"
  31293   "RTN","RCD PLPL4",209 ,0)
  31294    I $D(DTOU T)!$D(DUOU T)!(Y="")   Q -1
  31295   "RTN","RCD PLPL4",210 ,0)
  31296    ;
  31297   "RTN","RCD PLPL4",211 ,0)
  31298    ;Force to  all caps
  31299   "RTN","RCD PLPL4",212 ,0)
  31300    S Y=$$UP^ XLFSTR(Y)
  31301   "RTN","RCD PLPL4",213 ,0)
  31302    ;
  31303   "RTN","RCD PLPL4",214 ,0)
  31304    ; Check f or valid b ill number
  31305   "RTN","RCD PLPL4",215 ,0)
  31306    I '$O(^PR CA(430,"D" ,Y,"")) S  Y=""       ; Not a va lid bill n umber
  31307   "RTN","RCD PLPL4",216 ,0)
  31308    ;
  31309   "RTN","RCD PLPL4",217 ,0)
  31310    Q:Y="" 0    ; quit i f invalid  bill numbe r or looku p number
  31311   "RTN","RCD PLPL4",218 ,0)
  31312    ;
  31313   "RTN","RCD PLPL4",219 ,0)
  31314    S X=Y
  31315   "RTN","RCD PLPL4",220 ,0)
  31316    S DA(1)=R CRECTDA
  31317   "RTN","RCD PLPL4",221 ,0)
  31318    D PNORBIL L^RCDPURED
  31319   "RTN","RCD PLPL4",222 ,0)
  31320    ; 
  31321   "RTN","RCD PLPL4",223 ,0)
  31322    ;if this  is an acco unt, is it  active?   If not, re quest a ne w account.
  31323   "RTN","RCD PLPL4",224 ,0)
  31324    I $G(X)[" ;PRCA" D   Q:RCSTAT'= "ACTIVE" 0
  31325   "RTN","RCD PLPL4",225 ,0)
  31326    . S RCSTA T=$$GET1^D IQ(430,$P( $G(X),";") _",",8,"E" )
  31327   "RTN","RCD PLPL4",226 ,0)
  31328    . I RCSTA T'="ACTIVE ",$P($G(^R CD(340,+$P (^PRCA(430 ,$P($G(X), ";"),0),"^ ",9),0))," ^")[";DPT( " W !,"Thi s bill's s tatus is c urrently " ,RCSTAT,". ",!,"Pleas e select a  different  account."
  31329   "RTN","RCD PLPL4",227 ,0)
  31330    ;
  31331   "RTN","RCD PLPL4",228 ,0)
  31332    ;Somethin g went wro ng.  Try a gain.
  31333   "RTN","RCD PLPL4",229 ,0)
  31334    I '$D(X)  Q 0
  31335   "RTN","RCD PLPL4",230 ,0)
  31336    ;
  31337   "RTN","RCD PLPL4",231 ,0)
  31338    ; Account  found, re turn it
  31339   "RTN","RCD PLPL4",232 ,0)
  31340    Q X
  31341   "RTN","RCD PLPL4",233 ,0)
  31342    ;
  31343   "RTN","RCD PLPL4",234 ,0)
  31344   GETAMT(RCA CCT,RCAMT)  ; Ask the  user for  the amount
  31345   "RTN","RCD PLPL4",235 ,0)
  31346    ;
  31347   "RTN","RCD PLPL4",236 ,0)
  31348    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT,DA,R CFLG,AMTFL G
  31349   "RTN","RCD PLPL4",237 ,0)
  31350    ;
  31351   "RTN","RCD PLPL4",238 ,0)
  31352    ;
  31353   "RTN","RCD PLPL4",239 ,0)
  31354    S RCFLG=0
  31355   "RTN","RCD PLPL4",240 ,0)
  31356    F  D  Q:R CFLG
  31357   "RTN","RCD PLPL4",241 ,0)
  31358    . S AMTFL G=1  ; Set  amount fl ag check t o 1 in cas e the acco unt is a S USPENSE ac count
  31359   "RTN","RCD PLPL4",242 ,0)
  31360    . S DIR(" A")="Amoun t to apply  to Accoun t",DIR(0)= "N^0.01:"_ $J(RCAMT," ",2)_":2"
  31361   "RTN","RCD PLPL4",243 ,0)
  31362    . D ^DIR
  31363   "RTN","RCD PLPL4",244 ,0)
  31364    . I $D(DT OUT)!$D(DU OUT)!(Y="" )  S Y=-1, RCFLG=1 Q
  31365   "RTN","RCD PLPL4",245 ,0)
  31366    . ;If not  a SUSPENS E account,  check the  balance.
  31367   "RTN","RCD PLPL4",246 ,0)
  31368    . I RCACC T'="" S AM TFLG=$$PAY CHK(RCACCT ,Y)
  31369   "RTN","RCD PLPL4",247 ,0)
  31370    . ;amount  applied i s greater  than the a mount owed .  Try aga in
  31371   "RTN","RCD PLPL4",248 ,0)
  31372    . Q:'AMTF LG
  31373   "RTN","RCD PLPL4",249 ,0)
  31374    . I +Y>0  S RCFLG=1  Q
  31375   "RTN","RCD PLPL4",250 ,0)
  31376    . S Y=0,R CFLG=1
  31377   "RTN","RCD PLPL4",251 ,0)
  31378    Q Y
  31379   "RTN","RCD PLPL4",252 ,0)
  31380    ;
  31381   "RTN","RCD PLPL4",253 ,0)
  31382   GETCMT() ;  Ask the u ser for a  comment
  31383   "RTN","RCD PLPL4",254 ,0)
  31384    ;
  31385   "RTN","RCD PLPL4",255 ,0)
  31386    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT
  31387   "RTN","RCD PLPL4",256 ,0)
  31388    F  D  Q:Y '=""
  31389   "RTN","RCD PLPL4",257 ,0)
  31390    . S Y=$$C OM^RCDPECH  ; PRCA*4. 5*321
  31391   "RTN","RCD PLPL4",258 ,0)
  31392    . ;strip  all leadin g and trai ling space s
  31393   "RTN","RCD PLPL4",259 ,0)
  31394    . S Y=$$T RIM^XLFSTR (Y)
  31395   "RTN","RCD PLPL4",260 ,0)
  31396    . I Y=""  W !,"A com ment is re quired whe n changing  the statu s of an it em in Susp ense.  Ple ase",!,"tr y again."  Q
  31397   "RTN","RCD PLPL4",261 ,0)
  31398    . I $D(DT OUT) S Y=- 1
  31399   "RTN","RCD PLPL4",262 ,0)
  31400    Q Y
  31401   "RTN","RCD PLPL4",263 ,0)
  31402    ;
  31403   "RTN","RCD PLPL4",264 ,0)
  31404   CONTINUE(R CAMTRM) ;  Ask the us er to see  if they wi sh to cont inue
  31405   "RTN","RCD PLPL4",265 ,0)
  31406    ;
  31407   "RTN","RCD PLPL4",266 ,0)
  31408    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT
  31409   "RTN","RCD PLPL4",267 ,0)
  31410    S DIR("A" )="Receipt  has $"_$J (RCAMTRM,1 0,2)_" lef t to link.   Do you w ish to lin k another?  ",DIR(0)= "YA"
  31411   "RTN","RCD PLPL4",268 ,0)
  31412    D ^DIR
  31413   "RTN","RCD PLPL4",269 ,0)
  31414    I $D(DTOU T)!$D(DUOU T)!(Y="")   Q -1
  31415   "RTN","RCD PLPL4",270 ,0)
  31416    Q Y
  31417   "RTN","RCD PLPL4",271 ,0)
  31418    ;
  31419   "RTN","RCD PLPL4",272 ,0)
  31420    ; Confirm  with the  user that  the wish t o stop bef ore comple ting the l inking of  payments
  31421   "RTN","RCD PLPL4",273 ,0)
  31422   CONQUIT()  ;
  31423   "RTN","RCD PLPL4",274 ,0)
  31424    ;
  31425   "RTN","RCD PLPL4",275 ,0)
  31426    N X,Y,DTO UT,DUOUT,D IR,DIROUT, DIRUT
  31427   "RTN","RCD PLPL4",276 ,0)
  31428    S DIR("A" ,1)="Exiti ng now wil l prevent  the linkin g of any p reviously  selected c laims to t his"
  31429   "RTN","RCD PLPL4",277 ,0)
  31430    S DIR("A" )="receipt .  Are you  sure? ",D IR(0)="YA"
  31431   "RTN","RCD PLPL4",278 ,0)
  31432    D ^DIR
  31433   "RTN","RCD PLPL4",279 ,0)
  31434    I $D(DTOU T)!$D(DUOU T)!(Y="")   Q 1
  31435   "RTN","RCD PLPL4",280 ,0)
  31436    Q Y
  31437   "RTN","RCD PLPL4",281 ,0)
  31438    ;
  31439   "RTN","RCD PLPL4",282 ,0)
  31440    ;Create a  new trans action usi ng an exis ting trans action as  the founda tion.
  31441   "RTN","RCD PLPL4",283 ,0)
  31442   COPYTRAN(R CRECTDA,RC TDATA,RCAM T,RCGECSCR ) ;
  31443   "RTN","RCD PLPL4",284 ,0)
  31444    ;
  31445   "RTN","RCD PLPL4",285 ,0)
  31446    N RCNWTRA N,DR,DA,DT OUT,DIE,X, Y,RCTDATA3
  31447   "RTN","RCD PLPL4",286 ,0)
  31448    ;
  31449   "RTN","RCD PLPL4",287 ,0)
  31450    S RCTDATA 3=$G(^RCY( 344,RCRECT DA,1,RCTRA NDA,3))
  31451   "RTN","RCD PLPL4",288 ,0)
  31452    ;Create a  new trans action
  31453   "RTN","RCD PLPL4",289 ,0)
  31454    S RCNWTRA N=$$ADDTRA N^RCDPURET (RCRECTDA)
  31455   "RTN","RCD PLPL4",290 ,0)
  31456    S RCCMT=" Multi-Tran s Split"
  31457   "RTN","RCD PLPL4",291 ,0)
  31458    ;
  31459   "RTN","RCD PLPL4",292 ,0)
  31460    ;Update T ransaction
  31461   "RTN","RCD PLPL4",293 ,0)
  31462    S DR=".02 ////"_$P(R CTDATA,U,2 )       ;O riginal Co nfirmation  #
  31463   "RTN","RCD PLPL4",294 ,0)
  31464    S DR=DR_" ;.04///"_R CAMT               ;A mount
  31465   "RTN","RCD PLPL4",295 ,0)
  31466    S DR=DR_" ;.06////"_ $P(RCTDATA ,U,6)   ;O riginal da te of paym ent
  31467   "RTN","RCD PLPL4",296 ,0)
  31468    S DR=DR_" ;.07////"_ $P(RCTDATA ,U,7)   ;O riginal Ch eck #
  31469   "RTN","RCD PLPL4",297 ,0)
  31470    S DR=DR_" ;.08////"_ $P(RCTDATA ,U,8)   ;O riginal Ch eck routin g #
  31471   "RTN","RCD PLPL4",298 ,0)
  31472    S DR=DR_" ;.1////"_$ P(RCTDATA, U,10)   ;O riginal da te on the  check
  31473   "RTN","RCD PLPL4",299 ,0)
  31474    S DR=DR_" ;.11////"_ $P(RCTDATA ,U,11)  ;O riginal CC  number
  31475   "RTN","RCD PLPL4",300 ,0)
  31476    S DR=DR_" ;.12////"_ $P(RCTDATA ,U,12)  ;O riginal us er who ent ered the c heck
  31477   "RTN","RCD PLPL4",301 ,0)
  31478    S DR=DR_" ;.13////"_ $P(RCTDATA ,U,13)  ;O riginal ch eck accoun t #
  31479   "RTN","RCD PLPL4",302 ,0)
  31480    S DR=DR_" ;.14///"_D UZ                 ;U ser Linkin g the paym ent
  31481   "RTN","RCD PLPL4",303 ,0)
  31482    S DR=DR_" ;1.02////" _RCCMT             ;I nitial Com ment
  31483   "RTN","RCD PLPL4",304 ,0)
  31484    S DR=DR_" ;3.02////" _$P(RCTDAT A3,U,2) ;D ate Trans.  originall y suspense
  31485   "RTN","RCD PLPL4",305 ,0)
  31486    S DR=DR_" ;3.03////" _$P(RCTDAT A3,U,3) ;U ser who or iginally s uspended T rans.
  31487   "RTN","RCD PLPL4",306 ,0)
  31488    S DIE="^R CY(344,"_R CRECTDA_", 1,"
  31489   "RTN","RCD PLPL4",307 ,0)
  31490    S DA=RCNW TRAN,DA(1) =RCRECTDA
  31491   "RTN","RCD PLPL4",308 ,0)
  31492    D ^DIE
  31493   "RTN","RCD PLPL4",309 ,0)
  31494    S $P(^RCY (344,RCREC TDA,1,RCNW TRAN,0),"^ ",19)=$G(R CDPTYPE)
  31495   "RTN","RCD PLPL4",310 ,0)
  31496    ;
  31497   "RTN","RCD PLPL4",311 ,0)
  31498    ;Update t he Audit L og
  31499   "RTN","RCD PLPL4",312 ,0)
  31500    I $G(RCGE CSCR)'=""  D AUDIT^RC BEPAY(RCRE CTDA,RCNWT RAN,"I")
  31501   "RTN","RCD PLPL4",313 ,0)
  31502    ;
  31503   "RTN","RCD PLPL4",314 ,0)
  31504    Q RCNWTRA N
  31505   "RTN","RCD PLPL4",315 ,0)
  31506    ;
  31507   "RTN","RCD PLPL4",316 ,0)
  31508    ;Adjust t he origina l transact ion's paym ent amount  to match  to the act ual, split  amount.
  31509   "RTN","RCD PLPL4",317 ,0)
  31510   ADJTRAMT(R CRECTDA,RC TRANDA,RCA MT,RCGECSC R) ;
  31511   "RTN","RCD PLPL4",318 ,0)
  31512    ;
  31513   "RTN","RCD PLPL4",319 ,0)
  31514    N RCCMT,D R,DIE,DA,D TOUT
  31515   "RTN","RCD PLPL4",320 ,0)
  31516    S RCCMT=" Multi-Tran s Split"
  31517   "RTN","RCD PLPL4",321 ,0)
  31518    ;
  31519   "RTN","RCD PLPL4",322 ,0)
  31520    S DR=".04 ///"_RCAMT _";1.02/// "_RCCMT
  31521   "RTN","RCD PLPL4",323 ,0)
  31522    S DIE="^R CY(344,"_R CRECTDA_", 1,"
  31523   "RTN","RCD PLPL4",324 ,0)
  31524    S DA=RCTR ANDA,DA(1) =RCRECTDA
  31525   "RTN","RCD PLPL4",325 ,0)
  31526    D ^DIE
  31527   "RTN","RCD PLPL4",326 ,0)
  31528    D LASTEDI T^RCDPUREC (RCRECTDA)
  31529   "RTN","RCD PLPL4",327 ,0)
  31530    ;
  31531   "RTN","RCD PLPL4",328 ,0)
  31532    ;Update t he Audit L og
  31533   "RTN","RCD PLPL4",329 ,0)
  31534    I $G(RCGE CSCR)'=""  D AUDIT^RC BEPAY(RCRE CTDA,RCTRA NDA,"I")
  31535   "RTN","RCD PLPL4",330 ,0)
  31536    ;Update c omment his tory - PRC A*4.5*321
  31537   "RTN","RCD PLPL4",331 ,0)
  31538    D AUDIT^R CDPECH(RCR ECTDA,RCTR ANDA,"","" )
  31539   "RTN","RCD PLPL4",332 ,0)
  31540    Q
  31541   "RTN","RCD PLPL4",333 ,0)
  31542    ;
  31543   "RTN","RCD PLPL4",334 ,0)
  31544    ;Link the  Transacti on to an e xisting ac count
  31545   "RTN","RCD PLPL4",335 ,0)
  31546   LINKPAY(RC RECTDA,RCT RANDA,RCAC CT) ;
  31547   "RTN","RCD PLPL4",336 ,0)
  31548    ;
  31549   "RTN","RCD PLPL4",337 ,0)
  31550    N DR,DIE, DA,DTOUT
  31551   "RTN","RCD PLPL4",338 ,0)
  31552    S DR=".09 ///"_RCACC T
  31553   "RTN","RCD PLPL4",339 ,0)
  31554    S DIE="^R CY(344,"_R CRECTDA_", 1,"
  31555   "RTN","RCD PLPL4",340 ,0)
  31556    S DA=RCTR ANDA,DA(1) =RCRECTDA
  31557   "RTN","RCD PLPL4",341 ,0)
  31558    D ^DIE
  31559   "RTN","RCD PLPL4",342 ,0)
  31560    D LASTEDI T^RCDPUREC (RCRECTDA)
  31561   "RTN","RCD PLPL4",343 ,0)
  31562    Q
  31563   "RTN","RCD PLPL4",344 ,0)
  31564    ;
  31565   "RTN","RCD PLPL4",345 ,0)
  31566    ;Remove t he suspens e comment,  item no l onger in s uspense
  31567   "RTN","RCD PLPL4",346 ,0)
  31568   REMCMT(RCR ECTDA,RCTR ANDA) ;
  31569   "RTN","RCD PLPL4",347 ,0)
  31570    ;
  31571   "RTN","RCD PLPL4",348 ,0)
  31572    N DR,DIE, DA,DTOUT
  31573   "RTN","RCD PLPL4",349 ,0)
  31574    S DR="1.0 2///@"
  31575   "RTN","RCD PLPL4",350 ,0)
  31576    S DIE="^R CY(344,"_R CRECTDA_", 1,"
  31577   "RTN","RCD PLPL4",351 ,0)
  31578    S DA=RCTR ANDA,DA(1) =RCRECTDA
  31579   "RTN","RCD PLPL4",352 ,0)
  31580    D ^DIE
  31581   "RTN","RCD PLPL4",353 ,0)
  31582    D LASTEDI T^RCDPUREC (RCRECTDA)
  31583   "RTN","RCD PLPL4",354 ,0)
  31584    Q
  31585   "RTN","RCD PLPL4",355 ,0)
  31586    ;
  31587   "RTN","RCD PLPL4",356 ,0)
  31588   GETACTNM(R CACCT) ;
  31589   "RTN","RCD PLPL4",357 ,0)
  31590    N RCACCTL ,RCIEN,RCF ILE
  31591   "RTN","RCD PLPL4",358 ,0)
  31592    S RCACCTL =""
  31593   "RTN","RCD PLPL4",359 ,0)
  31594    Q:RCACCT= "" RCACCTL
  31595   "RTN","RCD PLPL4",360 ,0)
  31596    S RCFILE= $S(RCACCT[ ";PRCA(430 ":430,1:2)
  31597   "RTN","RCD PLPL4",361 ,0)
  31598    S RCIEN=$ P(RCACCT," ;")
  31599   "RTN","RCD PLPL4",362 ,0)
  31600    S RCACCTL =$$GET1^DI Q(RCFILE,R CIEN_","," .01","E")
  31601   "RTN","RCD PLPL4",363 ,0)
  31602    S:$L(RCAC CTL,"-")>1  RCACCTL=$ P(RCACCTL, "-",2)
  31603   "RTN","RCD PLPL4",364 ,0)
  31604    Q RCACCTL
  31605   "RTN","RCD PLPL4",365 ,0)
  31606    ;
  31607   "RTN","RCD PLPL4",366 ,0)
  31608    ;Update t he suspens e comment
  31609   "RTN","RCD PLPL4",367 ,0)
  31610   UPDCMT(RCR ECTDA,RCTR ANDA,RCCMT ) ;
  31611   "RTN","RCD PLPL4",368 ,0)
  31612    ;
  31613   "RTN","RCD PLPL4",369 ,0)
  31614    N DR,DIE, DA,DTOUT
  31615   "RTN","RCD PLPL4",370 ,0)
  31616    S DR="1.0 2///"_RCCM T_";" S DI E="^RCY(34 4,"_RCRECT DA_",1,"
  31617   "RTN","RCD PLPL4",371 ,0)
  31618    S DA=RCTR ANDA,DA(1) =RCRECTDA
  31619   "RTN","RCD PLPL4",372 ,0)
  31620    D ^DIE
  31621   "RTN","RCD PLPL4",373 ,0)
  31622    ;Update c omment his tory - PRC A*4.5*321
  31623   "RTN","RCD PLPL4",374 ,0)
  31624    D AUDIT^R CDPECH(RCR ECTDA,RCTR ANDA,"","" )
  31625   "RTN","RCD PLPL4",375 ,0)
  31626    Q
  31627   "RTN","RCD PLPL4",376 ,0)
  31628    ;
  31629   "RTN","RCD PLPL4",377 ,0)
  31630    ;Process  and update  the payme nt amounts
  31631   "RTN","RCD PLPL4",378 ,0)
  31632    ;Note:  s ome of the  code and  logic belo w is also  in tag PRO CESS^RCDPL PL3.  
  31633   "RTN","RCD PLPL4",379 ,0)
  31634    ;       I f changes  in logic a re made be low, pleas e review t his tag as  well.
  31635   "RTN","RCD PLPL4",380 ,0)
  31636   PROCESS(RC RECTDA,RCT RANDA,RCTD NM) ;
  31637   "RTN","RCD PLPL4",381 ,0)
  31638    ;
  31639   "RTN","RCD PLPL4",382 ,0)
  31640    N RCERROR
  31641   "RTN","RCD PLPL4",383 ,0)
  31642    S RCERROR =$$PROCESS ^RCBEPAY(R CRECTDA,RC TRANDA)
  31643   "RTN","RCD PLPL4",384 ,0)
  31644    ;  an err or occurre d during p rocessing  a payment
  31645   "RTN","RCD PLPL4",385 ,0)
  31646    I RCERROR  D  Q
  31647   "RTN","RCD PLPL4",386 ,0)
  31648    . W !
  31649   "RTN","RCD PLPL4",387 ,0)
  31650    . W !,"+- ---------- ---------- ---------- ---------- ---------- ---------- ---------- -------+"
  31651   "RTN","RCD PLPL4",388 ,0)
  31652    . W !,"|   An ERROR  has occurr ed when pr ocessing p ayment ",R CTRANDA,"  on receipt  ",$P(^RCY (344,RCREC TDA,0),"^" ),".",?79, "|"
  31653   "RTN","RCD PLPL4",389 ,0)
  31654    . W !,"|   The error  message r eturned du ring proce ssing is:" ,?79,"|"
  31655   "RTN","RCD PLPL4",390 ,0)
  31656    . W !,"|" ,?79,"|"
  31657   "RTN","RCD PLPL4",391 ,0)
  31658    . W !,"|   ",$P(RCER ROR,"^",2) ,?79,"|"
  31659   "RTN","RCD PLPL4",392 ,0)
  31660    . W !,"|" ,?79,"|"
  31661   "RTN","RCD PLPL4",393 ,0)
  31662    . W !,"|   You will  need to co rrect the  error befo re you can  link the  payment.", ?79,"|"
  31663   "RTN","RCD PLPL4",394 ,0)
  31664    . W !,"+- ---------- ---------- ---------- ---------- ---------- ---------- ---------- -------+"
  31665   "RTN","RCD PLPL4",395 ,0)
  31666    . W !
  31667   "RTN","RCD PLPL4",396 ,0)
  31668    . D DELEA CCT^RCDPUR ET(RCRECTD A,RCTRANDA )
  31669   "RTN","RCD PLPL4",397 ,0)
  31670    . W !,"Ac count "_RC TDNM_" was  deleted a nd not lin ked."
  31671   "RTN","RCD PLPL4",398 ,0)
  31672    ;
  31673   "RTN","RCD PLPL4",399 ,0)
  31674    ;File ent ry in Audi t Log
  31675   "RTN","RCD PLPL4",400 ,0)
  31676    D AUDIT^R CBEPAY(RCR ECTDA,RCTR ANDA,"P")
  31677   "RTN","RCD PLPL4",401 ,0)
  31678    ;
  31679   "RTN","RCD PLPL4",402 ,0)
  31680    ; Update  Suspense S tatus
  31681   "RTN","RCD PLPL4",403 ,0)
  31682    D SUSPDIS ^RCBEPAY(R CRECTDA,RC TRANDA,"PD ")
  31683   "RTN","RCD PLPL4",404 ,0)
  31684    ;
  31685   "RTN","RCD PLPL4",405 ,0)
  31686    I $E(RCST ATUS)="A"  D
  31687   "RTN","RCD PLPL4",406 ,0)
  31688    . ;  send  mail mess age to the  RCDP PAYM ENTS mail  group
  31689   "RTN","RCD PLPL4",407 ,0)
  31690    . D MAILM SG^RCDPLPS R(RCRECTDA ,RCTRANDA)
  31691   "RTN","RCD PLPL4",408 ,0)
  31692    . ;  plac e an x in  the fms do c field so  it will s how on the
  31693   "RTN","RCD PLPL4",409 ,0)
  31694    . ;  susp ense repor t
  31695   "RTN","RCD PLPL4",410 ,0)
  31696    . D EDITF MS^RCDPURE T(RCRECTDA ,RCTRANDA, "x")
  31697   "RTN","RCD PLPL4",411 ,0)
  31698    Q
  31699   "RTN","RCD PLPL4",412 ,0)
  31700    ;
  31701   "RTN","RCD PLPL4",413 ,0)
  31702    ;Display  end of pro cessing me ssage.
  31703   "RTN","RCD PLPL4",414 ,0)
  31704   ENDMSG(RCS TATUS) ;
  31705   "RTN","RCD PLPL4",415 ,0)
  31706    ;
  31707   "RTN","RCD PLPL4",416 ,0)
  31708    I $E(RCST ATUS)="A"  D
  31709   "RTN","RCD PLPL4",417 ,0)
  31710    . W !,"Si nce the FM S cash rec eipt docum ent is Acc epted in F MS, you ne ed to go"
  31711   "RTN","RCD PLPL4",418 ,0)
  31712    . W !,"on line in FM S and tran sfer the a mount paid  out of th e station' s suspense "
  31713   "RTN","RCD PLPL4",419 ,0)
  31714    . W !,"ac count.",!
  31715   "RTN","RCD PLPL4",420 ,0)
  31716    . W !,"Ma il message (s) sent t o RCDP PAY MENTS mail  group.",!
  31717   "RTN","RCD PLPL4",421 ,0)
  31718    I $E(RCST ATUS)'="A"  D
  31719   "RTN","RCD PLPL4",422 ,0)
  31720    . W !,"Si nce the FM S cash rec eipt docum ent is NOT  Accepted  in FMS, yo u can use"
  31721   "RTN","RCD PLPL4",423 ,0)
  31722    . W !,"th e option P rocess Rec eipt locat ed under t he Receipt  Processin g Menu"
  31723   "RTN","RCD PLPL4",424 ,0)
  31724    . W !,"to  regenerat e the cash  receipt d ocument to  FMS.",!
  31725   "RTN","RCD PLPL4",425 ,0)
  31726    Q
  31727   "RTN","RCD PLPL4",426 ,0)
  31728    ;
  31729   "RTN","RCD PLPL4",427 ,0)
  31730    ;Get user s answers  to questio ns for rep orts.
  31731   "RTN","RCD PLPL4",428 ,0)
  31732   GETANS(RCI DX) ;
  31733   "RTN","RCD PLPL4",429 ,0)
  31734    N DA,DIR, DTOUT,DUOU T,X,Y,DIRU T,DIROUT
  31735   "RTN","RCD PLPL4",430 ,0)
  31736    ;
  31737   "RTN","RCD PLPL4",431 ,0)
  31738    ; Ask the  user what  kind of r eport
  31739   "RTN","RCD PLPL4",432 ,0)
  31740    I RCIDX=1  D
  31741   "RTN","RCD PLPL4",433 ,0)
  31742    . S DIR(" ?")="Selec t to Y to  review the  payments,  N to skip  the revie w."
  31743   "RTN","RCD PLPL4",434 ,0)
  31744    . S DIR(" A")="Do yo u want to  review the  payment l ist before  updating  accounts ( Y/N)? "
  31745   "RTN","RCD PLPL4",435 ,0)
  31746    ;
  31747   "RTN","RCD PLPL4",436 ,0)
  31748    ; Ask the  user for  the payer  to start t he reporti ng on (Ran ge Option)
  31749   "RTN","RCD PLPL4",437 ,0)
  31750    I RCIDX=2  D
  31751   "RTN","RCD PLPL4",438 ,0)
  31752    . S DIR(" ?")="Enter  Y to upda te the acc ounts, N t o return t o the LP m enu"
  31753   "RTN","RCD PLPL4",439 ,0)
  31754    . S DIR(" A")="Do yo u want to  update acc ounts with  these pay ments (Y/N )? "
  31755   "RTN","RCD PLPL4",440 ,0)
  31756    ;
  31757   "RTN","RCD PLPL4",441 ,0)
  31758    S DIR(0)= "YA"
  31759   "RTN","RCD PLPL4",442 ,0)
  31760    D ^DIR
  31761   "RTN","RCD PLPL4",443 ,0)
  31762    K DIR
  31763   "RTN","RCD PLPL4",444 ,0)
  31764    I $G(DTOU T)!$G(DUOU T) Q -1
  31765   "RTN","RCD PLPL4",445 ,0)
  31766    Q Y
  31767   "RTN","RCD PLPL4",446 ,0)
  31768    ;
  31769   "RTN","RCD PLPL4",447 ,0)
  31770    ;Retrieve  the revie w response  question  from the u ser
  31771   "RTN","RCD PLPL4",448 ,0)
  31772   GETANS1()  ;
  31773   "RTN","RCD PLPL4",449 ,0)
  31774    ;
  31775   "RTN","RCD PLPL4",450 ,0)
  31776    N FLG,X,Y
  31777   "RTN","RCD PLPL4",451 ,0)
  31778    S FLG=0,Y =0
  31779   "RTN","RCD PLPL4",452 ,0)
  31780    F  D  Q:F LG=1
  31781   "RTN","RCD PLPL4",453 ,0)
  31782    . R !,"Do  you want  to review  the paymen t list bef ore updati ng account s (Y/N)? " ,X:DTIME
  31783   "RTN","RCD PLPL4",454 ,0)
  31784    . ;I $G(D TOUT) S FL G=1 Q    ; If it time s out, tre at it like  a No and  go to the  next promp t.
  31785   "RTN","RCD PLPL4",455 ,0)
  31786    . I X=""  W !,"Enter  Y or N to  continue. " Q
  31787   "RTN","RCD PLPL4",456 ,0)
  31788    . I X["?"  W !,"Sele ct to Y to  review th e payments , N to ski p the revi ew." Q
  31789   "RTN","RCD PLPL4",457 ,0)
  31790    . S X=$$U P^XLFSTR(X )
  31791   "RTN","RCD PLPL4",458 ,0)
  31792    . I X="Y"  S Y=1,FLG =1 Q
  31793   "RTN","RCD PLPL4",459 ,0)
  31794    . I X="N"  S Y=0,FLG =1 Q
  31795   "RTN","RCD PLPL4",460 ,0)
  31796    . W !,"Se lect to Y  to review  the paymen ts, N to s kip the re view."
  31797   "RTN","RCD PLPL4",461 ,0)
  31798    Q Y
  31799   "RTN","RCD PLPL4",462 ,0)
  31800    ;
  31801   "RTN","RCD PLPL4",463 ,0)
  31802    ;Is the a mount ente red < the  amount owe d. (AR ACC OUNTS ONLY , NO DEBTO RS)
  31803   "RTN","RCD PLPL4",464 ,0)
  31804   PAYCHK(RCA CCT,RCAMT)  ;
  31805   "RTN","RCD PLPL4",465 ,0)
  31806    ;
  31807   "RTN","RCD PLPL4",466 ,0)
  31808    N OWED,FL G
  31809   "RTN","RCD PLPL4",467 ,0)
  31810    ;
  31811   "RTN","RCD PLPL4",468 ,0)
  31812    S FLG=0
  31813   "RTN","RCD PLPL4",469 ,0)
  31814    ; account  is the de btor accou nt. No nee d to check ...
  31815   "RTN","RCD PLPL4",470 ,0)
  31816    Q:RCACCT' ["PRCA" 1
  31817   "RTN","RCD PLPL4",471 ,0)
  31818    ;  calcul ate amount  owed for  a bill
  31819   "RTN","RCD PLPL4",472 ,0)
  31820    S OWED=$G (^PRCA(430 ,+RCACCT,7 ))
  31821   "RTN","RCD PLPL4",473 ,0)
  31822    S OWED=$P (OWED,"^") +$P(OWED," ^",2)+$P(O WED,"^",3) +$P(OWED," ^",4)+$P(O WED,"^",5)
  31823   "RTN","RCD PLPL4",474 ,0)
  31824    I RCAMT>O WED W !,"T he request ed payment  is greate r than the n amount o wed please  try again .",! Q FLG
  31825   "RTN","RCD PLPL4",475 ,0)
  31826    S FLG=1
  31827   "RTN","RCD PLPL4",476 ,0)
  31828    Q FLG
  31829   "RTN","RCD PPLB")
  31830   0^30^B1971 82060
  31831   "RTN","RCD PPLB",1,0)
  31832   RCDPPLB ;A LB/TJB - E RA/PROVIDE R LEVEL AD JUSTMENTS  REPORT ;1/ 02/15 10:0 0am
  31833   "RTN","RCD PPLB",2,0)
  31834    ;;4.5;Acc ounts Rece ivable;**3 03,321**;M ar 20, 199 5;Build 46
  31835   "RTN","RCD PPLB",3,0)
  31836    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  31837   "RTN","RCD PPLB",4,0)
  31838    Q
  31839   "RTN","RCD PPLB",5,0)
  31840    ; PRCA*4. 5*303 - ER A/PROVIDER  LEVEL ADJ USTMENTS R EPORT 
  31841   "RTN","RCD PPLB",6,0)
  31842    ;
  31843   "RTN","RCD PPLB",7,0)
  31844    ; DESCRIP TION : The  following  generates  a report  to display  ERA data  with PLB
  31845   "RTN","RCD PPLB",8,0)
  31846    ;     dat a details.  The repor t is ad-ho c and allo w the user  to extrac t report
  31847   "RTN","RCD PPLB",9,0)
  31848    ;     dat a, as well  as view a nd manage  refund req uests for  all PLB ad justment
  31849   "RTN","RCD PPLB",10,0 )
  31850    ;     cod es (FB, WO , 72, IR,  J1, L6, CS , WU, etc. ):
  31851   "RTN","RCD PPLB",11,0 )
  31852    ;
  31853   "RTN","RCD PPLB",12,0 )
  31854   EN ; Entry  point for  Report
  31855   "RTN","RCD PPLB",13,0 )
  31856    N %ZIS,CD ,CRHDR,CZ, DIVHDR,DUO UT,DTOUT,D IR,DTOK,DL ,DX0,EXLN, FILE,I,IEN ,IDX,IX,JJ ,KK,PCT,PO P,PY,R,RCC D,RCODE
  31857   "RTN","RCD PPLB",14,0 )
  31858    N RCDET,R CDISP,RCDO NE,RCDT1,R CDT2,RCDET ,RCDONE,RC EXCEL,RCHR ,RCJOB,RCP G,RCTLIST, RCRD,RCNOW ,RCLPAY,RC PAY
  31859   "RTN","RCD PPLB",15,0 )
  31860    N RCQUIT, RCSORT,RCS TAT,RCTIN, TY,X,XCNT, Y,Z,ZN,ZPP Y,ZPY,ZTDE SC,ZTRTN,Z TSAVE,ZTSK ,ZTSTOP,ZZ ,ZZPNAME
  31861   "RTN","RCD PPLB",16,0 )
  31862    S RCQUIT= 0,RCODE=""  ; Global  variable t o signal e xit
  31863   "RTN","RCD PPLB",17,0 )
  31864    ;
  31865   "RTN","RCD PPLB",18,0 )
  31866    ; ICR 107 7 - Get di vision/sta tion
  31867   "RTN","RCD PPLB",19,0 )
  31868    D DIVISIO N^VAUTOMA
  31869   "RTN","RCD PPLB",20,0 )
  31870    I 'VAUTD& ($D(VAUTD) '=11) G PL BQ
  31871   "RTN","RCD PPLB",21,0 )
  31872    S DIR("A" )="(S)umma ry or(D)et ail Report  format? " ,DIR(0)="S A^S:Summar y Informat ion only;D :Detail an d Totals"
  31873   "RTN","RCD PPLB",22,0 )
  31874    S DIR("B" )="SUMMARY " D ^DIR K  DIR
  31875   "RTN","RCD PPLB",23,0 )
  31876    I $D(DTOU T)!$D(DUOU T)!(Y="")  G PLBQ
  31877   "RTN","RCD PPLB",24,0 )
  31878    S RCDET=( Y="D")
  31879   "RTN","RCD PPLB",25,0 )
  31880    ;
  31881   "RTN","RCD PPLB",26,0 )
  31882    ; Get PLB  Codes for  report
  31883   "RTN","RCD PPLB",27,0 )
  31884    D PLBC(.R CODE) G:$G (RCODE)']" " PLBQ
  31885   "RTN","RCD PPLB",28,0 )
  31886    ; Payer N ames from  344.6
  31887   "RTN","RCD PPLB",29,0 )
  31888    S RCDONE= $$GETPAY^R CDPRU(.RCP AY) G:RCDO NE=0 PLBQ
  31889   "RTN","RCD PPLB",30,0 )
  31890    S:$G(RCPA Y("DATA")) '="" RCPAY =$G(RCPAY( "DATA"))
  31891   "RTN","RCD PPLB",31,0 )
  31892    ;
  31893   "RTN","RCD PPLB",32,0 )
  31894    S RCDONE= $$GETTIN^R CDPRU(.RCT IN) G:RCDO NE=0 PLBQ
  31895   "RTN","RCD PPLB",33,0 )
  31896    S:$G(RCTI N("DATA")) '="" RCTIN =$G(RCTIN( "DATA"))
  31897   "RTN","RCD PPLB",34,0 )
  31898    ;
  31899   "RTN","RCD PPLB",35,0 )
  31900    S DIR("A" )="Sort Re port (C)od es or (P)a yer?: ",DI R(0)="SA^C :PLB Codes ;P:Payer N ame;CODES: PLB Codes"
  31901   "RTN","RCD PPLB",36,0 )
  31902    S DIR("B" )="CODES"  D ^DIR K D IR
  31903   "RTN","RCD PPLB",37,0 )
  31904    I $D(DTOU T)!$D(DUOU T)!(Y="")  G PLBQ
  31905   "RTN","RCD PPLB",38,0 )
  31906    S RCSORT= $E(Y,1)
  31907   "RTN","RCD PPLB",39,0 )
  31908    ;
  31909   "RTN","RCD PPLB",40,0 )
  31910    S DIR("?" )="Enter t he Beginni ng date fo r the repo rt"
  31911   "RTN","RCD PPLB",41,0 )
  31912    S DIR(0)= "DAO^:"_DT _":APE",DI R("A")="St art Date:  ",DIR("B") ="T" D ^DI R K DIR
  31913   "RTN","RCD PPLB",42,0 )
  31914    I $D(DTOU T)!$D(DUOU T)!(Y="")  G PLBQ
  31915   "RTN","RCD PPLB",43,0 )
  31916    S RCDT1=Y
  31917   "RTN","RCD PPLB",44,0 )
  31918    S DIR("?" )="Enter t he end dat e for the  report"
  31919   "RTN","RCD PPLB",45,0 )
  31920    S DIR("B" )="T"
  31921   "RTN","RCD PPLB",46,0 )
  31922    S DIR(0)= "DAO^"_RCD T1_":"_DT_ ":APE",DIR ("A")="End  Date: " D  ^DIR K DI R
  31923   "RTN","RCD PPLB",47,0 )
  31924    I $D(DTOU T)!$D(DUOU T)!(Y="")  G PLBQ
  31925   "RTN","RCD PPLB",48,0 )
  31926    S RCDT2=Y
  31927   "RTN","RCD PPLB",49,0 )
  31928    S DTOK=$$ CHECKDT^RC DPRU(RCDT1 ,RCDT2,344 .4)
  31929   "RTN","RCD PPLB",50,0 )
  31930    I 'DTOK W  !!,"*** N ote: Date  Range "_$$ DATE^RCDPR U(RCDT1)_"  - "_$$DAT E^RCDPRU(R CDT2)," ** *",! W "** * No Recor ds found * **",! D AS K^RCDPRU(. RCQUIT) G  PLBQ
  31931   "RTN","RCD PPLB",51,0 )
  31932    ; Removed  Excel per  Susan on  03/24/2015  meeting
  31933   "RTN","RCD PPLB",52,0 )
  31934    ; Get inp ut to expo rt to exce l.
  31935   "RTN","RCD PPLB",53,0 )
  31936    S RCEXCEL =""
  31937   "RTN","RCD PPLB",54,0 )
  31938    ;S RCEXCE L=$$DISPTY ^RCDPRU()
  31939   "RTN","RCD PPLB",55,0 )
  31940    ;D:RCEXCE L INFO^RCD PRU
  31941   "RTN","RCD PPLB",56,0 )
  31942    ;
  31943   "RTN","RCD PPLB",57,0 )
  31944    S %ZIS="Q M" D ^%ZIS  Q:POP
  31945   "RTN","RCD PPLB",58,0 )
  31946    I $D(IO(" Q")) D  Q
  31947   "RTN","RCD PPLB",59,0 )
  31948    . S ZTRTN ="ENQ^RCDP ARC",ZTDES C="AR - 83 5 Provider  Adjustmen t & Payer  Data Repor t",ZTSAVE( "*")=""
  31949   "RTN","RCD PPLB",60,0 )
  31950    . D ^%ZTL OAD
  31951   "RTN","RCD PPLB",61,0 )
  31952    . W !!,$S ($D(ZTSK): "Your task  number"_Z TSK_" has  been queue d.",1:"Una ble to que ue this jo b.")
  31953   "RTN","RCD PPLB",62,0 )
  31954    . K ZTSK, IO("Q") D  HOME^%ZIS
  31955   "RTN","RCD PPLB",63,0 )
  31956    U IO
  31957   "RTN","RCD PPLB",64,0 )
  31958    ;
  31959   "RTN","RCD PPLB",65,0 )
  31960   ENQ ; Star t here for  queued re port
  31961   "RTN","RCD PPLB",66,0 )
  31962    S RCNOW=$ $NOW^RCDPR U(),RCPG=0 ,$P(RCHR," =",IOM)=""
  31963   "RTN","RCD PPLB",67,0 )
  31964    ;
  31965   "RTN","RCD PPLB",68,0 )
  31966    K ^TMP("R CDPPLB_REP ORT",$J)
  31967   "RTN","RCD PPLB",69,0 )
  31968    ; Collect  the data  and put it  into the  ^TMP globa l
  31969   "RTN","RCD PPLB",70,0 )
  31970    D GETDATA ($G(RCODE) ,.RCPAY,.R CTIN,$G(RC SORT),RCDT 1,RCDT2,$N A(^TMP("RC DPPLB_REPO RT",$J)),. VAUTD)
  31971   "RTN","RCD PPLB",71,0 )
  31972    ;
  31973   "RTN","RCD PPLB",72,0 )
  31974   REPORT ; P rint out t he report
  31975   "RTN","RCD PPLB",73,0 )
  31976    ; Set up  Division H eader Text  and PLB C ode Header  Text
  31977   "RTN","RCD PPLB",74,0 )
  31978    S RCSL=0
  31979   "RTN","RCD PPLB",75,0 )
  31980    S:VAUTD=1  DIVHDR="A LL" D:VAUT D=0
  31981   "RTN","RCD PPLB",76,0 )
  31982    . N I S D IVHDR="",I ="" F  S I =$O(VAUTD( I)) Q:I=""   S:DIVHDR '="" DIVHD R=DIVHDR_" , "_VAUTD( I) S:DIVHD R="" DIVHD R=VAUTD(I)
  31983   "RTN","RCD PPLB",77,0 )
  31984    S CRHDR=R CODE
  31985   "RTN","RCD PPLB",78,0 )
  31986    ; Trim in formation  so it will  fit on an  80 or IOM  character  line
  31987   "RTN","RCD PPLB",79,0 )
  31988    D:($L(DIV HDR)+$L(CR HDR))>(IOM -25)
  31989   "RTN","RCD PPLB",80,0 )
  31990    . N VAL,D H,CH,R1,R2  S DH=0,CH =0,R1=0,R2 =0,VAL=(IO M-25)\2 ;  get half o f the scre en length
  31991   "RTN","RCD PPLB",81,0 )
  31992    . S:$L(DI VHDR)>VAL  DH=1 S:$L( CRHDR)>VAL  CH=1 S:DH =0 R1=VAL- $L(DIVHDR)  S:CH=0 R2 =VAL-$L(CR HDR)
  31993   "RTN","RCD PPLB",82,0 )
  31994    . I $L(DI VHDR)>(VAL +R2) S DIV HDR=$E(DIV HDR,1,(VAL +R2))_"... "
  31995   "RTN","RCD PPLB",83,0 )
  31996    . I $L(CR HDR)>(VAL+ R1) S CRHD R=$E(CRHDR ,1,(VAL+R2 ))_"..."
  31997   "RTN","RCD PPLB",84,0 )
  31998    ;
  31999   "RTN","RCD PPLB",85,0 )
  32000    I 'RCEXCE L D
  32001   "RTN","RCD PPLB",86,0 )
  32002    . S RCPG= RCPG+1 W @ IOF
  32003   "RTN","RCD PPLB",87,0 )
  32004    . D HDRP( $$HDR(RCDE T),1,"Page : "_RCPG_"  ")
  32005   "RTN","RCD PPLB",88,0 )
  32006    . D HDRP( "SORT by " _$S($E(RCS ORT,1)="C" :"PLB CODE S",1:"PAYE R NAMES")_ "  REPORT  RUN DATE:  "_RCNOW,1)
  32007   "RTN","RCD PPLB",89,0 )
  32008    . D HDRP( "DIVISION:  "_DIVHDR_ " Codes: " _CRHDR,1)
  32009   "RTN","RCD PPLB",90,0 )
  32010    . D HDRP( "835 PAYER S: "_$S(RC PAY="ALL": "ALL",1:"S elected")_ " 835 PAYE R TINs: "_ $S($E(RCTI N)="A":"AL L",1:"Sele cted"),1)
  32011   "RTN","RCD PPLB",91,0 )
  32012    . D HDRP( "EOB PAID  DATE RANGE : "_$$DATE ^RCDPRU(RC DT1)_" - " _$$DATE^RC DPRU(RCDT2 ),1)
  32013   "RTN","RCD PPLB",92,0 )
  32014    . W !,RCH R,!
  32015   "RTN","RCD PPLB",93,0 )
  32016    E  D
  32017   "RTN","RCD PPLB",94,0 )
  32018    . ; Excel  Report
  32019   "RTN","RCD PPLB",95,0 )
  32020    . W "CODE ^PAYER^TIN ^REP_DATE^ AMOUNT",!
  32021   "RTN","RCD PPLB",96,0 )
  32022    ;
  32023   "RTN","RCD PPLB",97,0 )
  32024    S $P(ZLN, "-",80)="" ,$P(ZDLN," =",80)="", $P(ZLN2,"- ",78)="",Z LN2="  "_Z LN2,RCSL=7
  32025   "RTN","RCD PPLB",98,0 )
  32026    ; Do Gran d totals f irst - per  Susan 7/1 6/2015
  32027   "RTN","RCD PPLB",99,0 )
  32028    S DX0=$G( ^TMP("RCDP PLB_REPORT ",$J,"TOTA LS")),PCT= 0
  32029   "RTN","RCD PPLB",100, 0)
  32030    S:+$P(DX0 ,U,5)'=0 P CT=$J(($P( DX0,U,1)/$ P(DX0,U,5) )*100,3,0)
  32031   "RTN","RCD PPLB",101, 0)
  32032    S:+$P(DX0 ,U,5)=0 PC T="ERR"
  32033   "RTN","RCD PPLB",102, 0)
  32034    I RCSL>=( IOSL-4) S  RCQUIT=$$N EWPG(.RCPG ,1,.RCSL,R CSORT) Q:R CQUIT
  32035   "RTN","RCD PPLB",103, 0)
  32036    W ! S RCS L=RCSL+1
  32037   "RTN","RCD PPLB",104, 0)
  32038    W "GRAND  TOTALS FOR  ALL PLB C ODES & PAY ERS ON REP ORT",! S R CSL=RCSL+1
  32039   "RTN","RCD PPLB",105, 0)
  32040    W "   TOT AL #ERAs:   ",$J($P(D X0,U,3),6, 0),"  ADJ:  ",PCT,"%  [TOT AMT A DJUSTED /  TOT AMT BI LLED]",! S  RCSL=RCSL +1
  32041   "RTN","RCD PPLB",106, 0)
  32042    W "   AMT  ADJUST: $ ",$J($P(DX 0,U,1),11, 2),"  AMT  BILLED: $" ,$J($P(DX0 ,U,5),11,2 ),"  AMT P AID: $",$J ($P(DX0,U, 2),11,2),!  S RCSL=RC SL+1
  32043   "RTN","RCD PPLB",107, 0)
  32044    W !,ZDLN, !! S RCSL= RCSL+1
  32045   "RTN","RCD PPLB",108, 0)
  32046    I RCSL>=( IOSL-2) S  RCQUIT=$$N EWPG(.RCPG ,0,.RCSL,R CSORT) G:R CQUIT PLBQ
  32047   "RTN","RCD PPLB",109, 0)
  32048    ;
  32049   "RTN","RCD PPLB",110, 0)
  32050    S ZZ="" F   S ZZ=$O( ^TMP("RCDP PLB_REPORT ",$J,"SUMM ARY",ZZ))  Q:ZZ=""  S  ZDAT=^TMP ("RCDPPLB_ REPORT",$J ,"SUMMARY" ,ZZ) D  Q: RCQUIT
  32051   "RTN","RCD PPLB",111, 0)
  32052    . D:RCSOR T="C"  Q:R CQUIT
  32053   "RTN","RCD PPLB",112, 0)
  32054    .. W "ADJ  CODE: ",Z Z,"  # ERA s: ",$J($P (ZDAT,U,3) ,5),"  ADJ : ",$S(+$P (ZDAT,U,5) >0:$J((($P (ZDAT,U,1) /$P(ZDAT,U ,5))*100), 3,0),1:"ER R"),"% [TO T AMT ADJU STED / TOT  AMT BILLE D]",! S RC SL=RCSL+1
  32055   "RTN","RCD PPLB",113, 0)
  32056    .. I RCSL >=(IOSL-2)  S RCQUIT= $$NEWPG(.R CPG,0,.RCS L,RCSORT)  Q:RCQUIT
  32057   "RTN","RCD PPLB",114, 0)
  32058    .. W "    AMT ADJUST : ",$J($P( ZDAT,U,1), 8,2),"  AM T BILLED:  ",$J($P(ZD AT,U,5),9, 2),"  AMT  PAID: ",$J ($P(ZDAT,U ,2),9,2),!  S RCSL=RC SL+1
  32059   "RTN","RCD PPLB",115, 0)
  32060    .. I RCSL >=(IOSL-2)  S RCQUIT= $$NEWPG(.R CPG,0,.RCS L,RCSORT)  Q:RCQUIT
  32061   "RTN","RCD PPLB",116, 0)
  32062    .. W "ADJ  CODE TEXT : ",$P(ZDA T,U,4),! S  RCSL=RCSL +1
  32063   "RTN","RCD PPLB",117, 0)
  32064    .. I RCSL >=(IOSL-2)  S RCQUIT= $$NEWPG(.R CPG,0,.RCS L,RCSORT)  Q:RCQUIT
  32065   "RTN","RCD PPLB",118, 0)
  32066    .. W ZLN, ! S RCSL=R CSL+1
  32067   "RTN","RCD PPLB",119, 0)
  32068    .. I RCSL >=(IOSL-2)  S RCQUIT= $$NEWPG(.R CPG,0,.RCS L,RCSORT)  Q:RCQUIT
  32069   "RTN","RCD PPLB",120, 0)
  32070    .. S PY=" ",CZ=0 F   S PY=$O(^T MP("RCDPPL B_REPORT", $J,"SUMMAR Y",ZZ,PY))  Q:PY=""   S ZPY=^TMP ("RCDPPLB_ REPORT",$J ,"SUMMARY" ,ZZ,PY) D   Q:RCQUIT   S CZ=CZ+1
  32071   "RTN","RCD PPLB",121, 0)
  32072    ... S:+($ P(ZPY,U,5) )'=0 ZPPY= $J((($P(ZP Y,U,1)/$P( ZPY,U,5))* 100),3,0)
  32073   "RTN","RCD PPLB",122, 0)
  32074    ... S:+($ P(ZPY,U,5) )=0 ZPPY=" ERR"
  32075   "RTN","RCD PPLB",123, 0)
  32076    ... I CZ> 0 W ZLN2,!  S RCSL=RC SL+1
  32077   "RTN","RCD PPLB",124, 0)
  32078    ... W " P AYER NAME/ TIN",!
  32079   "RTN","RCD PPLB",125, 0)
  32080    ... S RCS L=RCSL+1
  32081   "RTN","RCD PPLB",126, 0)
  32082    ... W " " ,$$PAYTIN^ RCDPRU2(PY ,76),! ; P RCA*4.5*32 1
  32083   "RTN","RCD PPLB",127, 0)
  32084    ... S RCS L=RCSL+1                     ; P RCA*4.5*32 1
  32085   "RTN","RCD PPLB",128, 0)
  32086    ... I RCS L>=(IOSL-2 ) S RCQUIT =$$NEWPG(. RCPG,0,.RC SL,RCSORT)  Q:RCQUIT
  32087   "RTN","RCD PPLB",129, 0)
  32088    ... W "   #ERAs: ",$ J($P(ZPY,U ,3),4),"   ADJ: ",ZPP Y,"% [ADJ:  ",$J($P(Z PY,U,1),8, 2),"/ BILL ED: ",$J($ P(ZPY,U,5) ,9,2),"] P AID: ",$J( $P(ZPY,U,2 ),9,2),! S  RCSL=RCSL +1
  32089   "RTN","RCD PPLB",130, 0)
  32090    ... D:RCD ET DETAIL( RCSORT,ZZ, PY,$NA(^TM P("RCDPPLB _REPORT",$ J))) Q:RCQ UIT
  32091   "RTN","RCD PPLB",131, 0)
  32092    .. W:'RCQ UIT ZLN,!  S RCSL=RCS L+1
  32093   "RTN","RCD PPLB",132, 0)
  32094    . D:RCSOR T="P"  Q:R CQUIT
  32095   "RTN","RCD PPLB",133, 0)
  32096    .. W " PA YER NAME/T IN",!
  32097   "RTN","RCD PPLB",134, 0)
  32098    .. S RCSL =RCSL+1
  32099   "RTN","RCD PPLB",135, 0)
  32100    .. W " ", $$PAYTIN^R CDPRU2(ZZ, 76),! ; PR CA*4.5*321
  32101   "RTN","RCD PPLB",136, 0)
  32102    .. S RCSL =RCSL+1                     ; PR CA*4.5*321
  32103   "RTN","RCD PPLB",137, 0)
  32104    .. ; PRCA *4.5*321 E nd modifie d code blo ck
  32105   "RTN","RCD PPLB",138, 0)
  32106    .. I RCSL >=(IOSL-2)  S RCQUIT= $$NEWPG(.R CPG,0,.RCS L,RCSORT)  Q:RCQUIT
  32107   "RTN","RCD PPLB",139, 0)
  32108    .. W "# E RAs:",$J($ P(ZDAT,U,3 ),5),"  AD J: ",$S(+$ P(ZDAT,U,5 )>0:$J((($ P(ZDAT,U,1 )/$P(ZDAT, U,5))*100) ,3,0),1:"E RR"),"% [A MT ADJ:",$ J($P(ZDAT, U,1),8,2), "/ BILLED: ",$J($P(ZD AT,U,5),9, 2),"] PAID :",$J($P(Z DAT,U,2),9 ,2),! S RC SL=RCSL+1
  32109   "RTN","RCD PPLB",140, 0)
  32110    .. I RCSL >=(IOSL-2)  S RCQUIT= $$NEWPG(.R CPG,0,.RCS L,RCSORT)  Q:RCQUIT
  32111   "RTN","RCD PPLB",141, 0)
  32112    .. W ZLN, ! S RCSL=R CSL+1
  32113   "RTN","RCD PPLB",142, 0)
  32114    .. I RCSL >=(IOSL-2)  S RCQUIT= $$NEWPG(.R CPG,0,.RCS L,RCSORT)  Q:RCQUIT
  32115   "RTN","RCD PPLB",143, 0)
  32116    .. S PY=" ",CZ=0 F   S PY=$O(^T MP("RCDPPL B_REPORT", $J,"SUMMAR Y",ZZ,PY))  Q:PY=""   S ZPY=^TMP ("RCDPPLB_ REPORT",$J ,"SUMMARY" ,ZZ,PY) D   Q:RCQUIT   S CZ=CZ+1
  32117   "RTN","RCD PPLB",144, 0)
  32118    ... S ZPP Y=$S(+$P(Z PY,U,5)'=0 :$J((($P(Z PY,U,1)/$P (ZPY,U,5)) *100),3,0) ,1:"ERR")
  32119   "RTN","RCD PPLB",145, 0)
  32120    ... I CZ> 0 W ZLN2,!  S RCSL=RC SL+1
  32121   "RTN","RCD PPLB",146, 0)
  32122    ... W "   ADJ CODE:  ",PY,"  AD J CODE TXT : ",$P(ZPY ,U,4),! S  RCSL=RCSL+ 1
  32123   "RTN","RCD PPLB",147, 0)
  32124    ... I RCS L>=(IOSL-2 ) S RCQUIT =$$NEWPG(. RCPG,0,.RC SL,RCSORT)  Q:RCQUIT
  32125   "RTN","RCD PPLB",148, 0)
  32126    ... W "   #ERAs: ",$ J($P(ZPY,U ,3),4),"   ADJ: ",ZPP Y,"% [ADJ:  ",$J($P(Z PY,U,1),8, 2),"/ BILL ED: ",$J($ P(ZPY,U,5) ,9,2),"] P AID: ",$J( $P(ZPY,U,2 ),9,2),! S  RCSL=RCSL +1
  32127   "RTN","RCD PPLB",149, 0)
  32128    ... D:RCD ET DETAIL( RCSORT,ZZ, PY,$NA(^TM P("RCDPPLB _REPORT",$ J))) Q:RCQ UIT
  32129   "RTN","RCD PPLB",150, 0)
  32130    .. I 'RCQ UIT W ZLN, ! S RCSL=R CSL+1
  32131   "RTN","RCD PPLB",151, 0)
  32132    D:'RCQUIT  ASK^RCDPR U(.RCQUIT)
  32133   "RTN","RCD PPLB",152, 0)
  32134   PLBQ ;
  32135   "RTN","RCD PPLB",153, 0)
  32136    K RCQUIT, VAUTD,ZDAT ,ZLN,ZDLN, ZLN2
  32137   "RTN","RCD PPLB",154, 0)
  32138    K ^TMP("R CDPPLB_REP ORT",$J)
  32139   "RTN","RCD PPLB",155, 0)
  32140    Q
  32141   "RTN","RCD PPLB",156, 0)
  32142    ;
  32143   "RTN","RCD PPLB",157, 0)
  32144    ; SORT =  by CODES o r Payer; C AT = CODE  or Payer/T IN to look up
  32145   "RTN","RCD PPLB",158, 0)
  32146    ; DET = S econd subs cipt eithe r Payer/TI N if Sort= "C" or PLB  Code if S ort="P"; Z GBL = Glob al to use  through in direction
  32147   "RTN","RCD PPLB",159, 0)
  32148   DETAIL(SOR T,CAT,DET, ZGBL) ; De tail Repor t
  32149   "RTN","RCD PPLB",160, 0)
  32150    N ZLN1,ZF S,ZZ,ZDET, ZDZN,ZPCT, ZADJ,ZBIL, ZPD S $P(Z LN1,"-",77 )="-",ZLN1 ="  "_ZLN1
  32151   "RTN","RCD PPLB",161, 0)
  32152    S ZFS=$S( SORT="C":" ERA",1:"PA YR")
  32153   "RTN","RCD PPLB",162, 0)
  32154    W ZLN1,!  S RCSL=RCS L+1
  32155   "RTN","RCD PPLB",163, 0)
  32156    I RCSL>=( IOSL-2) S  RCQUIT=$$N EWPG(.RCPG ,0,.RCSL,R CSORT) Q:R CQUIT
  32157   "RTN","RCD PPLB",164, 0)
  32158    W "  #ERA         DA TE     %AD J    ADJUS T       BI LLED        PAID       CHECK#",!  S RCSL=RC SL+1
  32159   "RTN","RCD PPLB",165, 0)
  32160    I RCSL>=( IOSL-2) S  RCQUIT=$$N EWPG(.RCPG ,0,.RCSL,R CSORT) Q:R CQUIT
  32161   "RTN","RCD PPLB",166, 0)
  32162    W "     T RACE#",! S  RCSL=RCSL +1
  32163   "RTN","RCD PPLB",167, 0)
  32164    I RCSL>=( IOSL-2) S  RCQUIT=$$N EWPG(.RCPG ,0,.RCSL,R CSORT) Q:R CQUIT
  32165   "RTN","RCD PPLB",168, 0)
  32166    ;W "        COMMENTS  ",! S RCS L=RCSL+1
  32167   "RTN","RCD PPLB",169, 0)
  32168    W "     R EFERENCE#" ,! S RCSL= RCSL+1
  32169   "RTN","RCD PPLB",170, 0)
  32170    I RCSL>=( IOSL-2) S  RCQUIT=$$N EWPG(.RCPG ,0,.RCSL,R CSORT) Q:R CQUIT
  32171   "RTN","RCD PPLB",171, 0)
  32172    S ZZ="" F   S ZZ=$O( @ZGBL@(ZFS ,CAT,ZZ))  Q:ZZ=""  S  ZDZN=@ZGB L@(ZFS,CAT ,ZZ,0) D   Q:RCQUIT
  32173   "RTN","RCD PPLB",172, 0)
  32174    . S ZDET= $$GETDT(SO RT,CAT,DET ,ZDZN,ZGBL )
  32175   "RTN","RCD PPLB",173, 0)
  32176    . Q:ZDET' =DET  ; If  this isn' t the same  then skip
  32177   "RTN","RCD PPLB",174, 0)
  32178    . S ZADJ= $$DAMT("A" ,$S(SORT=" C":CAT,1:D ET),$P(ZDZ N,U,1),ZFS ,ZGBL),ZBI L=$$DAMT(" B",CAT,$P( ZDZN,U,1), ZFS,ZGBL), ZPD=$$DAMT ("P",CAT,$ P(ZDZN,U,1 ),ZFS,ZGBL )
  32179   "RTN","RCD PPLB",175, 0)
  32180    . S ZPCT= $S(ZBIL'=0 :$J(((ZADJ /ZBIL)*100 ),3,0),1:" ERR")
  32181   "RTN","RCD PPLB",176, 0)
  32182    . W $J($P (ZDZN,U,1) ,9),?12,$$ DATE^RCDPR U($P(ZDZN, U,4)),?23, $J(ZPCT,3, 0),?29,$J( ZADJ,9,2), ?42,$J(ZBI L,9,2),?54 ,$J(ZPD,9, 2),?68,$P( ZDZN,U,13) ,! S RCSL= RCSL+1
  32183   "RTN","RCD PPLB",177, 0)
  32184    . I RCSL> =(IOSL-2)  S RCQUIT=$ $NEWPG(.RC PG,0,.RCSL ,RCSORT) Q :RCQUIT
  32185   "RTN","RCD PPLB",178, 0)
  32186    . W ?9,$P (ZDZN,U,2) ,! S RCSL= RCSL+1 ; T race
  32187   "RTN","RCD PPLB",179, 0)
  32188    . I RCSL> =(IOSL-2)  S RCQUIT=$ $NEWPG(.RC PG,0,.RCSL ,RCSORT) Q :RCQUIT
  32189   "RTN","RCD PPLB",180, 0)
  32190    . W ?9,$$ DTCM(CAT,$ P(ZDZN,U,1 ),ZFS,ZGBL ),! S RCSL =RCSL+1 ;  Reference  #
  32191   "RTN","RCD PPLB",181, 0)
  32192    Q:RCQUIT
  32193   "RTN","RCD PPLB",182, 0)
  32194    I RCSL>=( IOSL-2) S  RCQUIT=$$N EWPG(.RCPG ,0,.RCSL,R CSORT) Q:R CQUIT
  32195   "RTN","RCD PPLB",183, 0)
  32196    ;W ZLN1,!  S RCSL=RC SL+1
  32197   "RTN","RCD PPLB",184, 0)
  32198    Q
  32199   "RTN","RCD PPLB",185, 0)
  32200    ;
  32201   "RTN","RCD PPLB",186, 0)
  32202   GETDT(SORT ,CAT,DT,ZN D,ZGBL) ;  Get detail  informati on for thi s entry
  32203   "RTN","RCD PPLB",187, 0)
  32204    N MYDT,MM
  32205   "RTN","RCD PPLB",188, 0)
  32206    S MYDT=""
  32207   "RTN","RCD PPLB",189, 0)
  32208    I SORT="C " Q $P(ZND ,U,6)_"/"_ $P(ZND,U,3 )
  32209   "RTN","RCD PPLB",190, 0)
  32210    ; Otherwi se we have  a payer s ort and ne ed to do m ore work
  32211   "RTN","RCD PPLB",191, 0)
  32212    S MM=0.11  F  S MM=$ O(@ZGBL@(" 00_ERA",$P (ZND,U,1), MM)) Q:MM= ""  I $P(@ ZGBL@("00_ ERA",$P(ZN D,U,1),MM) ,U,1)=DT S  MYDT=$P(@ ZGBL@("00_ ERA",$P(ZN D,U,1),MM) ,U,1) Q
  32213   "RTN","RCD PPLB",192, 0)
  32214    Q MYDT
  32215   "RTN","RCD PPLB",193, 0)
  32216    ;
  32217   "RTN","RCD PPLB",194, 0)
  32218    ; Get the  type of a mount from  the ^TMP  global
  32219   "RTN","RCD PPLB",195, 0)
  32220   DAMT(TYPE, FIRST,ZIEN ,XFS,XGBL)  ; Get amo unts
  32221   "RTN","RCD PPLB",196, 0)
  32222    N ZAMT,XD N S ZAMT=0
  32223   "RTN","RCD PPLB",197, 0)
  32224    ; Adjustm ent amount
  32225   "RTN","RCD PPLB",198, 0)
  32226    I TYPE="A " D  Q ZAM T
  32227   "RTN","RCD PPLB",199, 0)
  32228    . S AA=0. 1 F  S AA= $O(@XGBL@( "00_ERA",Z IEN,AA)) Q :AA=""  D
  32229   "RTN","RCD PPLB",200, 0)
  32230    .. Q:$P(@ XGBL@("00_ ERA",ZIEN, AA),U,1)'= FIRST  ; N ot the cor rect recor d
  32231   "RTN","RCD PPLB",201, 0)
  32232    .. ; Othe rwise we h ave the ri ght record  get the a djustment  amount
  32233   "RTN","RCD PPLB",202, 0)
  32234    .. S ZAMT =ZAMT+$P(@ XGBL@("00_ ERA",ZIEN, AA),U,2)
  32235   "RTN","RCD PPLB",203, 0)
  32236    ; Total b illed on E RA
  32237   "RTN","RCD PPLB",204, 0)
  32238    I TYPE="B " Q @XGBL@ ("00_ERA", ZIEN,0.1)
  32239   "RTN","RCD PPLB",205, 0)
  32240    ; Paid Am ount
  32241   "RTN","RCD PPLB",206, 0)
  32242    I TYPE="P " Q $P(@XG BL@("00_ER A",ZIEN,0) ,U,5)
  32243   "RTN","RCD PPLB",207, 0)
  32244    Q ZAMT
  32245   "RTN","RCD PPLB",208, 0)
  32246    ;
  32247   "RTN","RCD PPLB",209, 0)
  32248   DTCM(FIRST ,ZIEN,XFS, XGBL) ; Ge t comment  or referen ce number
  32249   "RTN","RCD PPLB",210, 0)
  32250    N AA,XDN, ZCM
  32251   "RTN","RCD PPLB",211, 0)
  32252    S XDN=0,Z CM=""
  32253   "RTN","RCD PPLB",212, 0)
  32254    D
  32255   "RTN","RCD PPLB",213, 0)
  32256    . S AA=0. 1 F  S AA= $O(@XGBL@( "00_ERA",Z IEN,AA)) Q :AA=""!(XD N=1)  D
  32257   "RTN","RCD PPLB",214, 0)
  32258    .. Q:$P(@ XGBL@("00_ ERA",ZIEN, AA),U,1)'= FIRST  ; N ot the cor rect recor d
  32259   "RTN","RCD PPLB",215, 0)
  32260    .. ; Othe rwise we h ave the ri ght record  get the a djustment  amount
  32261   "RTN","RCD PPLB",216, 0)
  32262    .. S ZCM= $P(@XGBL@( "00_ERA",Z IEN,AA),U, 3),XDN=1
  32263   "RTN","RCD PPLB",217, 0)
  32264    Q ZCM
  32265   "RTN","RCD PPLB",218, 0)
  32266    ;
  32267   "RTN","RCD PPLB",219, 0)
  32268   HDR(CD) ;  Report hea der
  32269   "RTN","RCD PPLB",220, 0)
  32270    Q:CD "EDI  LOCKBOX 8 35 PROVIDE R LEVEL AD JUSTMENT ( PLB) REPOR T - DETAIL "
  32271   "RTN","RCD PPLB",221, 0)
  32272    Q "EDI LO CKBOX 835  PROVIDER L EVEL ADJUS TMENT (PLB ) REPORT -  SUMMARY"
  32273   "RTN","RCD PPLB",222, 0)
  32274    ;
  32275   "RTN","RCD PPLB",223, 0)
  32276   HDRP(Z,X,Z 1) ; Print  Header (Z =String, X =1 (line f eed) X=0 ( no LF), Z1  (page num ber right  justified)
  32277   "RTN","RCD PPLB",224, 0)
  32278    N LGT S L GT=$L(Z)+$ L($G(Z1))
  32279   "RTN","RCD PPLB",225, 0)
  32280    I $G(X)=1  W !
  32281   "RTN","RCD PPLB",226, 0)
  32282    W ?(IOM-L GT\2),Z W: $G(Z1)]""  ?(IOM-$L(Z 1)),Z1
  32283   "RTN","RCD PPLB",227, 0)
  32284    Q
  32285   "RTN","RCD PPLB",228, 0)
  32286    ;
  32287   "RTN","RCD PPLB",229, 0)
  32288   NEWPG(RCPG ,RCNEW,RCS L,CD) ; Ch eck for ne w page nee ded, outpu t header
  32289   "RTN","RCD PPLB",230, 0)
  32290    ; RCPG =  Page numbe r passwd b y referece
  32291   "RTN","RCD PPLB",231, 0)
  32292    ; RCNEW =  1 to forc e new page
  32293   "RTN","RCD PPLB",232, 0)
  32294    ; RCSL =  page lengt h passed b y referenc e
  32295   "RTN","RCD PPLB",233, 0)
  32296    ; Functio n returns  1 if user  chooses to  stop outp ut
  32297   "RTN","RCD PPLB",234, 0)
  32298    N ZSTOP S  ZSTOP=0
  32299   "RTN","RCD PPLB",235, 0)
  32300    I RCNEW!' RCPG!(($Y+ 5)>IOSL) D
  32301   "RTN","RCD PPLB",236, 0)
  32302    . D:RCPG  ASK^RCDPRU (.ZSTOP) Q :ZSTOP
  32303   "RTN","RCD PPLB",237, 0)
  32304    . S RCPG= RCPG+1 W @ IOF
  32305   "RTN","RCD PPLB",238, 0)
  32306    . D HDRP( $$HDR(RCDE T),1,"Page : "_RCPG)
  32307   "RTN","RCD PPLB",239, 0)
  32308    . D HDRP( "SORT by " _$S($E(CD, 1)="C":"PL B CODES",1 :"PAYER NA MES")_"  R EPORT RUN  DATE: "_RC NOW,1)
  32309   "RTN","RCD PPLB",240, 0)
  32310    . D HDRP( "DIVISION:  "_DIVHDR_ " Codes: " _CRHDR,1)
  32311   "RTN","RCD PPLB",241, 0)
  32312    . D HDRP( "835 PAYER S: "_$S(RC PAY="ALL": "ALL",1:"S elected")_ " 835 PAYE R TINs: "_ $S(RCTIN=" A":"ALL",1 :"Selected "),1)
  32313   "RTN","RCD PPLB",242, 0)
  32314    . D HDRP( "Date Rang e: "_$$DAT E^RCDPRU(R CDT1)_" -  "_$$DATE^R CDPRU(RCDT 2),1)
  32315   "RTN","RCD PPLB",243, 0)
  32316    . W !,RCH R,! S RCSL =7
  32317   "RTN","RCD PPLB",244, 0)
  32318    Q ZSTOP
  32319   "RTN","RCD PPLB",245, 0)
  32320    ;
  32321   "RTN","RCD PPLB",246, 0)
  32322    ; Get dat a for repo rt and app ly filters  if necess ary
  32323   "RTN","RCD PPLB",247, 0)
  32324   GETDATA(GP LB,GPAYER, GTIN,GSORT ,GSTART,GS TOP,GARRAY ,GDIV) ;
  32325   "RTN","RCD PPLB",248, 0)
  32326    N SDT,IEN ,CD,CNT,IX ,ZX,XY,RM, PARR,PNARR ,PTARR,RCS ET,GLINE,Z N,ZED,ZEN, ZPAY,ZTIN, ZDESC,ZZ,R CERR,RCGX, RCEB,EOBTO T,STA,STNU M,STNAM,ZL VL
  32327   "RTN","RCD PPLB",249, 0)
  32328    S SDT=$O( ^RCY(344.4 ,"AC",GSTA RT),-1)
  32329   "RTN","RCD PPLB",250, 0)
  32330    S ZLVL=$S (GSORT="C" :"ERA",1:" PAYR")
  32331   "RTN","RCD PPLB",251, 0)
  32332    ; Set up  arrays for  filtering  on PLB, P AYER name  and Payer  TINs
  32333   "RTN","RCD PPLB",252, 0)
  32334    D RNG^RCD PRU("PLB", .GPLB,.PAR R),RNG^RCD PRU("PAYER ",GPAYER,. PARR),RNG^ RCDPRU("TI N",GTIN,.P ARR)
  32335   "RTN","RCD PPLB",253, 0)
  32336    ;Get poss ible ERAs  to work on  from ^RCY (344.4,"AC ") index
  32337   "RTN","RCD PPLB",254, 0)
  32338    F  S SDT= $O(^RCY(34 4.4,"AC",S DT)) Q:SDT =""!(SDT>G STOP)  D
  32339   "RTN","RCD PPLB",255, 0)
  32340    . S IEN=" " F  S IEN =$O(^RCY(3 44.4,"AC", SDT,IEN))  Q:IEN=""   S ZN=^RCY( 344.4,IEN, 0) D
  32341   "RTN","RCD PPLB",256, 0)
  32342    .. I GDIV =0 D ERAST A^RCDPEM4( IEN,.STA,. STNUM,.STN AM) Q:'$D( GDIV(STA))   ; If not  the right  Division/ station th en get nex t ERA
  32343   "RTN","RCD PPLB",257, 0)
  32344    .. K RCGX  D GETS^DI Q(344.4,IE N_",","2*; ","E","RCG X") Q:$D(R CGX)=0  ;  Quit if no  PLBs on t his ERA
  32345   "RTN","RCD PPLB",258, 0)
  32346    .. S ZTIN =$$GET1^DI Q(344.4,IE N_",",.03, "E"),ZPAY= $$GET1^DIQ (344.4,IEN _",",.06," E")
  32347   "RTN","RCD PPLB",259, 0)
  32348    .. Q:'$$C HECK("TIN" ,ZTIN,.PAR R)  Q:'$$C HECK("PAYE R",ZPAY,.P ARR)  ; Qu it if not  including  this tin o r payer
  32349   "RTN","RCD PPLB",260, 0)
  32350    .. ; Bill ed amount  on the EOB s, Get EOB  Details
  32351   "RTN","RCD PPLB",261, 0)
  32352    .. K RCEB  D GETS^DI Q(344.4,IE N_",","1*; ","I","RCE B")
  32353   "RTN","RCD PPLB",262, 0)
  32354    .. ; Walk  EOB Detai ls and get  the total  amount bi lled
  32355   "RTN","RCD PPLB",263, 0)
  32356    .. S EOBT OT=0
  32357   "RTN","RCD PPLB",264, 0)
  32358    .. I $D(R CEB)>9 S X Y="" F  S  XY=$O(RCEB (344.41,XY )) Q:XY=""   S EOBTOT =EOBTOT+$$ GET1^DIQ(3 61.1,RCEB( 344.41,XY, .02,"I")_" ,","2.04", "E")
  32359   "RTN","RCD PPLB",265, 0)
  32360    .. ; Get  list of PL B Codes fo r this ERA
  32361   "RTN","RCD PPLB",266, 0)
  32362    .. S IX=" " K CD F Z Z=1:1 S IX =$O(RCGX(3 44.42,IX))  Q:IX=""   D
  32363   "RTN","RCD PPLB",267, 0)
  32364    ... I '$$ CHECK("PLB ",RCGX(344 .42,IX,.02 ,"E"),.PAR R) Q  ; If  plb not i ncluded in  report qu it and go  to the nex t entry 
  32365   "RTN","RCD PPLB",268, 0)
  32366    ... ; Get  IEN for P LB Code, t hen get de scription  for code f rom file 3 45.1
  32367   "RTN","RCD PPLB",269, 0)
  32368    ... S ZEN =$$FIND1^D IC(345.1," ","",RCGX( 344.42,IX, .02,"E")," B","","RCE RR") S:$G( ZEN)]"" ZD ESC=$$GET1 ^DIQ(345.1 ,ZEN_",",. 05,"","RCE RR")
  32369   "RTN","RCD PPLB",270, 0)
  32370    ... S:$G( ZDESC)=""  ZDESC=$G(R CGX(344.42 ,IX,.04,"E ")) ; If n o descript ion use th e Descript ion from F SC
  32371   "RTN","RCD PPLB",271, 0)
  32372    ... S:$G( ZDESC)=""  ZDESC="Bad  data reci eved from  FSC" ; Oth erwise mak e one up.
  32373   "RTN","RCD PPLB",272, 0)
  32374    ... ; PLB  Code ^ Ad j. Amount  ^ Referenc e / Commen t ^ Code D escription
  32375   "RTN","RCD PPLB",273, 0)
  32376    ... S CD( ZZ)=$S(RCG X(344.42,I X,.02,"E") '="":RCGX( 344.42,IX, .02,"E"),1 :"00")_U_R CGX(344.42 ,IX,.03,"E ")_U_RCGX( 344.42,IX, .01,"E")_U _ZDESC
  32377   "RTN","RCD PPLB",274, 0)
  32378    ... S @GA RRAY@("00_ ERA",IEN,Z Z)=CD(ZZ)
  32379   "RTN","RCD PPLB",275, 0)
  32380    ... ; Add  items to  report glo bal sorted  by Payer  or PLB Cod e
  32381   "RTN","RCD PPLB",276, 0)
  32382    ... S @GA RRAY@("00_ ERA",IEN,0 )=ZN,@GARR AY@("00_ER A",IEN,0.1 )=EOBTOT
  32383   "RTN","RCD PPLB",277, 0)
  32384    ... ;D:GS ORT="C" BY CODE^RCDPR U(ZN,.CD,I EN,GARRAY, EOBTOT) D: GSORT="P"  BYPAYR^RCD PRU(ZN,.CD ,IEN,GARRA Y,EOBTOT)
  32385   "RTN","RCD PPLB",278, 0)
  32386    ... S ZED =$S(GSORT= "C":$P(CD( ZZ),U,1),1 :$P(ZN,U,6 )_"/"_$P(Z N,U,3)),@G ARRAY@(ZLV L,ZED,IEN, 0)=ZN
  32387   "RTN","RCD PPLB",279, 0)
  32388    D SUMIT^R CDPRU(GARR AY,ZLVL,GS ORT)
  32389   "RTN","RCD PPLB",280, 0)
  32390    Q
  32391   "RTN","RCD PPLB",281, 0)
  32392    ; Check t o see if t his ITEM i s included  for proce ssing
  32393   "RTN","RCD PPLB",282, 0)
  32394   CHECK(TYPE ,ITEM,ARRA Y) ;
  32395   "RTN","RCD PPLB",283, 0)
  32396    ; If all  are includ ed no need  to check  further
  32397   "RTN","RCD PPLB",284, 0)
  32398    I TYPE="T IN" S:$E(I TEM,$L(ITE M))'=" " I TEM=ITEM_"  " ; Add s pace to TI N if neede d.
  32399   "RTN","RCD PPLB",285, 0)
  32400    Q:$G(ARRA Y(TYPE))=" ALL" 1
  32401   "RTN","RCD PPLB",286, 0)
  32402    Q:$G(ARRA Y(TYPE,ITE M))=1 1
  32403   "RTN","RCD PPLB",287, 0)
  32404    Q 0
  32405   "RTN","RCD PPLB",288, 0)
  32406    ;
  32407   "RTN","RCD PPLB",289, 0)
  32408   PLBC(RET)  ; Get PLB  Codes to l imit for r eport or a ll
  32409   "RTN","RCD PPLB",290, 0)
  32410    N PLLIST, PLCODE,DTO UT,DUOUT,F ILE S FILE =345.1
  32411   "RTN","RCD PPLB",291, 0)
  32412    S DIR("A" )="Select  (C)ode, (R )ange of C odes or (A )ll ?: ",D IR(0)="SA^ A:All Code s;C:Single  Code;R:Ra nge/List o f Codes"
  32413   "RTN","RCD PPLB",292, 0)
  32414    S DIR("B" )="ALL" D  ^DIR K DIR
  32415   "RTN","RCD PPLB",293, 0)
  32416    I $D(DTOU T)!$D(DUOU T)!(Y="")  S RCQUIT=1  Q
  32417   "RTN","RCD PPLB",294, 0)
  32418    S PLLIST= Y
  32419   "RTN","RCD PPLB",295, 0)
  32420    I PLLIST= "A" S RET= "ALL" Q
  32421   "RTN","RCD PPLB",296, 0)
  32422    I PLLIST= "C" D  Q
  32423   "RTN","RCD PPLB",297, 0)
  32424    .; if inv alid code  return her e
  32425   "RTN","RCD PPLB",298, 0)
  32426   C1 .;
  32427   "RTN","RCD PPLB",299, 0)
  32428    . S DIR(" A")="Enter  a Code: " ,DIR(0)="F A^1:200"
  32429   "RTN","RCD PPLB",300, 0)
  32430    . S DIR(" ?")="Only  a single c odes can b e entered  as: WO"
  32431   "RTN","RCD PPLB",301, 0)
  32432    . S DIR(" ?",1)="Ple ase enter  one Code f or the rep ort."
  32433   "RTN","RCD PPLB",302, 0)
  32434    . S DIR(" ?",2)="The  single va lidated co de will be  included  in the rep ort."
  32435   "RTN","RCD PPLB",303, 0)
  32436    . D ^DIR  K DIR
  32437   "RTN","RCD PPLB",304, 0)
  32438    . I $D(DT OUT)!$D(DU OUT)!(Y="" ) S RCQUIT =1 Q
  32439   "RTN","RCD PPLB",305, 0)
  32440    . S PLCOD E=$$UP^RCD PRU(X),PLC ODE=$TR(PL CODE," "," ")
  32441   "RTN","RCD PPLB",306, 0)
  32442    . I (PLCO DE[":"),(P LCODE["-") ,(PLCODE[" ,") W !!," PLB Code:  "_PLCODE_"  not found , Please t ry again.. .",! S X=" ",PLCODE=" " G C1
  32443   "RTN","RCD PPLB",307, 0)
  32444    . I '$$VA L(FILE,.PL CODE) W !! ,"PLB Code : "_PLCODE _" not fou nd, Please  try again ...",! S X ="",PLCODE ="" G C1
  32445   "RTN","RCD PPLB",308, 0)
  32446    . S RET=P LCODE
  32447   "RTN","RCD PPLB",309, 0)
  32448    ;
  32449   "RTN","RCD PPLB",310, 0)
  32450    I PLLIST= "R" D
  32451   "RTN","RCD PPLB",311, 0)
  32452    . ; if in valid rang e/list of  codes retu rn here
  32453   "RTN","RCD PPLB",312, 0)
  32454   C2 . ;
  32455   "RTN","RCD PPLB",313, 0)
  32456    . S DIR(" A")="Enter  a List or  Range of  Codes",DIR (0)="F^1:2 00"
  32457   "RTN","RCD PPLB",314, 0)
  32458    . S DIR(" ?")="Codes  can be en tered as:  WO,51,AH:C T"
  32459   "RTN","RCD PPLB",315, 0)
  32460    . S DIR(" ?",1)="Ple ase enter  a list or  range of C odes, use  a comma be tween elem ents"
  32461   "RTN","RCD PPLB",316, 0)
  32462    . S DIR(" ?",2)="and  a colon ' :' or '-'  to delimit  ranges of  codes."
  32463   "RTN","RCD PPLB",317, 0)
  32464    . D ^DIR  K DIR
  32465   "RTN","RCD PPLB",318, 0)
  32466    . I $D(DT OUT)!$D(DU OUT)!(Y="" ) S RCQUIT =1 Q
  32467   "RTN","RCD PPLB",319, 0)
  32468    . S PLCOD E=$$UP^RCD PRU(X) I ' $$VAL(FILE ,.PLCODE)  W !!,"PLB  Code: "_PL CODE_" not  found, Pl ease try a gain...",!  S X="",PL CODE="" G  C2
  32469   "RTN","RCD PPLB",320, 0)
  32470    . S RET=P LCODE
  32471   "RTN","RCD PPLB",321, 0)
  32472    Q
  32473   "RTN","RCD PPLB",322, 0)
  32474    ;
  32475   "RTN","RCD PPLB",323, 0)
  32476   VAL(XF,COD E) ; Valid ate a rang e or list  of PLB Cod es
  32477   "RTN","RCD PPLB",324, 0)
  32478    ; If inva lid code i s found VA ILD = 0 an d CODE wil l contain  the offend ing codes
  32479   "RTN","RCD PPLB",325, 0)
  32480    Q $$VAL^R CDPRU(XF,. CODE)
  32481   "RTN","RCD PPLB",326, 0)
  32482    ;
  32483   "RTN","RCD PR215")
  32484   0^11^B4478 7625
  32485   "RTN","RCD PR215",1,0 )
  32486   RCDPR215 ; WISC/RFJ-r eceipt pro cessing sf 215 report  ;1 Jun 99
  32487   "RTN","RCD PR215",2,0 )
  32488    ;;4.5;Acc ounts Rece ivable;**1 14,173,211 ,220,321** ;Mar 20, 1 995;Build  46
  32489   "RTN","RCD PR215",3,0 )
  32490    ;;Per VHA  Directive  10-93-142 , this rou tine shoul d not be m odified.
  32491   "RTN","RCD PR215",4,0 )
  32492    Q
  32493   "RTN","RCD PR215",5,0 )
  32494    ;
  32495   "RTN","RCD PR215",6,0 )
  32496   DQ ;  queu ed report  starts her e, input R ECEIPDA
  32497   "RTN","RCD PR215",7,0 )
  32498    ;  RCTYPE ="D"etail  or "A"ccru al
  32499   "RTN","RCD PR215",8,0 )
  32500    N %I,AMOU NT,BILL,BI LLDA,COMME NTS,COUNT, DA,DATA,DE POSIT,DETA IL,FMSDOCN O,FUND,NOW ,PAGE,PIEC E,PRINTOTL ,RCSTFLAG, RCYLINE,RE CEIPT,SCRE EN,TOTAL,T OTLAMT,UNA PPLY,X,Y,T OT,%,REPRO DT,EFTFUND
  32501   "RTN","RCD PR215",9,0 )
  32502    ;
  32503   "RTN","RCD PR215",10, 0)
  32504    ;  calcul ate report
  32505   "RTN","RCD PR215",11, 0)
  32506    ;  input  receipda ( ien of rec eipt)
  32507   "RTN","RCD PR215",12, 0)
  32508    K ^TMP($J ,"RCFMSCR" ),^TMP($J, "RCDPR215" )
  32509   "RTN","RCD PR215",13, 0)
  32510    S EFTFUND =$S(DT<$$A DDPTEDT^PR CAACC():"5 287.4/8NZZ ",1:"52870 4/8NZZ")
  32511   "RTN","RCD PR215",14, 0)
  32512    S REPRODT =$P($P($G( ^RCY(344,R ECEIPDA,0) ),"^",8)," .")
  32513   "RTN","RCD PR215",15, 0)
  32514    D FMSLINE S^RCXFMSC1 (RECEIPDA)
  32515   "RTN","RCD PR215",16, 0)
  32516    I $$EDILB ^RCDPEU(RE CEIPDA)=1  D  ; EFT d eposit rec eipt
  32517   "RTN","RCD PR215",17, 0)
  32518    . S TOT=0
  32519   "RTN","RCD PR215",18, 0)
  32520    . S Z=0 F   S Z=$O(^ RCY(344,RE CEIPDA,1,Z )) Q:'Z  S  TOT=TOT+$ P($G(^(Z,0 )),U,4)
  32521   "RTN","RCD PR215",19, 0)
  32522    . S ^TMP( $J,"RCFMSC R",EFTFUND )=TOT
  32523   "RTN","RCD PR215",20, 0)
  32524    ;
  32525   "RTN","RCD PR215",21, 0)
  32526    ;  print  report
  32527   "RTN","RCD PR215",22, 0)
  32528    S DATA=$G (^RCY(344, RECEIPDA,0 ))
  32529   "RTN","RCD PR215",23, 0)
  32530    S RECEIPT =$P(DATA," ^")
  32531   "RTN","RCD PR215",24, 0)
  32532    S DEPOSIT =$P($G(^RC Y(344.1,+$ P(DATA,"^" ,6),0)),"^ ")
  32533   "RTN","RCD PR215",25, 0)
  32534    S FMSDOCN O=$P($G(^R CY(344.1,+ $P(DATA,"^ ",6),2))," ^")
  32535   "RTN","RCD PR215",26, 0)
  32536    ;
  32537   "RTN","RCD PR215",27, 0)
  32538    D NOW^%DT C S Y=% D  DD^%DT S N OW=Y
  32539   "RTN","RCD PR215",28, 0)
  32540    S PAGE=0, RCYLINE="" ,$P(RCYLIN E,"-",81)= ""
  32541   "RTN","RCD PR215",29, 0)
  32542    S SCREEN= 0 I '$D(ZT QUEUED),IO =IO(0),$E( IOST)="C"  S SCREEN=1
  32543   "RTN","RCD PR215",30, 0)
  32544    U IO D H
  32545   "RTN","RCD PR215",31, 0)
  32546    ;
  32547   "RTN","RCD PR215",32, 0)
  32548    S TOTAL=" "  ;  stor es printot al^inttota l^admintot al^marshto tal^cctota l
  32549   "RTN","RCD PR215",33, 0)
  32550    S FUND=""  F  S FUND =$O(^TMP($ J,"RCFMSCR ",FUND)) Q :'FUND!($G (RCSTFLAG) )  D
  32551   "RTN","RCD PR215",34, 0)
  32552    .   I $Y> (IOSL-6) D :SCREEN PA USE Q:$G(R CSTFLAG)   D H
  32553   "RTN","RCD PR215",35, 0)
  32554    .   W !!? 5,"Appropr iation: ", FUND
  32555   "RTN","RCD PR215",36, 0)
  32556    .   I RCT YPE="D" W  !
  32557   "RTN","RCD PR215",37, 0)
  32558    .   ;
  32559   "RTN","RCD PR215",38, 0)
  32560    .   S PRI NTOTL=0
  32561   "RTN","RCD PR215",39, 0)
  32562    .   S COU NT=0
  32563   "RTN","RCD PR215",40, 0)
  32564    .   I FUN D=EFTFUND  S PRINTOTL =PRINTOTL+ $G(^TMP($J ,"RCFMSCR" ,FUND))
  32565   "RTN","RCD PR215",41, 0)
  32566    .   S BIL LDA=0 F  S  BILLDA=$O (^TMP($J," RCFMSCR",F UND,BILLDA )) Q:'BILL DA!($G(RCS TFLAG))  D
  32567   "RTN","RCD PR215",42, 0)
  32568    .   .   I  $Y>(IOSL- 5) D:SCREE N PAUSE Q: $G(RCSTFLA G)  D H
  32569   "RTN","RCD PR215",43, 0)
  32570    .   .   S  COUNT=COU NT+1
  32571   "RTN","RCD PR215",44, 0)
  32572    .   .   S  BILL=$P($ G(^PRCA(43 0,BILLDA,0 )),"^")
  32573   "RTN","RCD PR215",45, 0)
  32574    .   .   S  DATA=^TMP ($J,"RCFMS CR",FUND,B ILLDA)
  32575   "RTN","RCD PR215",46, 0)
  32576    .   .   S  PRINTOTL= PRINTOTL+$ P(DATA,"^" )
  32577   "RTN","RCD PR215",47, 0)
  32578    .   .   F  PIECE=1:1 :5 S $P(TO TAL,"^",PI ECE)=$P(TO TAL,"^",PI ECE)+$P(DA TA,"^",PIE CE)
  32579   "RTN","RCD PR215",48, 0)
  32580    .   .   ;   if accru ed report,  do not sh ow detail
  32581   "RTN","RCD PR215",49, 0)
  32582    .   .   I  RCTYPE="A " Q
  32583   "RTN","RCD PR215",50, 0)
  32584    .   .   ;
  32585   "RTN","RCD PR215",51, 0)
  32586    .   .   W  !?5,COUNT ,")",?10,B ILL,?30,$J ($P(DATA," ^"),10,2), ?45,"DEBTO R: ",$E($$ DEBTOR(BIL LDA),1,25)
  32587   "RTN","RCD PR215",52, 0)
  32588    .   .   W  !?15,"INT :",$J($P(D ATA,"^",2) ,10,2)," A DMIN:",$J( $P(DATA,"^ ",3),10,2) ," MARS: " ,$J($P(DAT A,"^",4),1 0,2)," CC:  ",$J($P(D ATA,"^",5) ,10,2)
  32589   "RTN","RCD PR215",53, 0)
  32590    .   ;
  32591   "RTN","RCD PR215",54, 0)
  32592    .   I $G( RCSTFLAG)  Q
  32593   "RTN","RCD PR215",55, 0)
  32594    .   I RCT YPE="D" W  !?30,"---- ------",!? 5,"TOTAL f or ",FUND
  32595   "RTN","RCD PR215",56, 0)
  32596    .   W ?30 ,$J(PRINTO TL,10,2)
  32597   "RTN","RCD PR215",57, 0)
  32598    .   I FUN D="0160a1"  W ?45,"01 60a1 sub-t otals Cham pva receip ts",!?45," not sent t o FMS on t he CR docu ment."
  32599   "RTN","RCD PR215",58, 0)
  32600    ;
  32601   "RTN","RCD PR215",59, 0)
  32602    I $G(RCST FLAG) D Q  Q
  32603   "RTN","RCD PR215",60, 0)
  32604    I $Y>(IOS L-6) D:SCR EEN PAUSE  I '$G(RCST FLAG) D H
  32605   "RTN","RCD PR215",61, 0)
  32606    I $G(RCST FLAG) D Q  Q
  32607   "RTN","RCD PR215",62, 0)
  32608    ;
  32609   "RTN","RCD PR215",63, 0)
  32610    ;  show i nt, admin,  etc total s
  32611   "RTN","RCD PR215",64, 0)
  32612    W !
  32613   "RTN","RCD PR215",65, 0)
  32614    W !?5,"IN TEREST : ( APP: 1435) ",?30,$J($ P(TOTAL,"^ ",2),10,2)
  32615   "RTN","RCD PR215",66, 0)
  32616    W !?5,"AD MIN    : ( APP: 3220) ",?30,$J($ P(TOTAL,"^ ",3),10,2)
  32617   "RTN","RCD PR215",67, 0)
  32618    W !?5,"MA RSHALL : ( APP: 0869) ",?30,$J($ P(TOTAL,"^ ",4),10,2)
  32619   "RTN","RCD PR215",68, 0)
  32620    W !?5,"CO URTCOST: ( APP: 0869) ",?30,$J($ P(TOTAL,"^ ",5),10,2)
  32621   "RTN","RCD PR215",69, 0)
  32622    W !?30,"- ---------"
  32623   "RTN","RCD PR215",70, 0)
  32624    W !?30,$J ($P(TOTAL, "^",2)+$P( TOTAL,"^", 3)+$P(TOTA L,"^",4)+$ P(TOTAL,"^ ",5),10,2)
  32625   "RTN","RCD PR215",71, 0)
  32626    ;
  32627   "RTN","RCD PR215",72, 0)
  32628    I $Y>(IOS L-8) D:SCR EEN PAUSE  I '$G(RCST FLAG) D H
  32629   "RTN","RCD PR215",73, 0)
  32630    I $G(RCST FLAG) D Q  Q
  32631   "RTN","RCD PR215",74, 0)
  32632    ;
  32633   "RTN","RCD PR215",75, 0)
  32634    I $G(^TMP ($J,"RCFMS CR",EFTFUN D)) S $P(T OTAL,U)=$P (TOTAL,U)+ ^TMP($J,"R CFMSCR",EF TFUND)
  32635   "RTN","RCD PR215",76, 0)
  32636    ;  compil e unapplie d amounts  that went  to suspens e
  32637   "RTN","RCD PR215",77, 0)
  32638    S DA=0 F   S DA=$O(^ RCY(344,RE CEIPDA,1,D A)) Q:'DA   D
  32639   "RTN","RCD PR215",78, 0)
  32640    .   S AMO UNT=$P($G( ^RCY(344,R ECEIPDA,1, DA,0)),"^" ,4) I 'AMO UNT Q
  32641   "RTN","RCD PR215",79, 0)
  32642    .   S UNA PPLY=$P($G (^RCY(344, RECEIPDA,1 ,DA,2)),"^ ",5) I UNA PPLY="" Q
  32643   "RTN","RCD PR215",80, 0)
  32644    .   ;  if  amount ha s not been  processed , show it  in suspens e
  32645   "RTN","RCD PR215",81, 0)
  32646    .   I '$P (^RCY(344, RECEIPDA,1 ,DA,0),"^" ,5) S ^TMP ($J,"RCDPR 215",DA)=U NAPPLY_"^" _AMOUNT_"^ "_$P($G(^R CY(344,REC EIPDA,1,DA ,1)),"^",2 )
  32647   "RTN","RCD PR215",82, 0)
  32648    ;
  32649   "RTN","RCD PR215",83, 0)
  32650    ;  print  unapplied  amounts th at went to  suspense
  32651   "RTN","RCD PR215",84, 0)
  32652    I $O(^TMP ($J,"RCDPR 215",0)) D
  32653   "RTN","RCD PR215",85, 0)
  32654    .   W !!? 5,"Appropr iation: 38 75"
  32655   "RTN","RCD PR215",86, 0)
  32656    .   I RCT YPE="D" W  !
  32657   "RTN","RCD PR215",87, 0)
  32658    .   ;
  32659   "RTN","RCD PR215",88, 0)
  32660    .   S COU NT=0,PRINT OTL=0
  32661   "RTN","RCD PR215",89, 0)
  32662    .   S DA= 0 F  S DA= $O(^TMP($J ,"RCDPR215 ",DA)) Q:' DA!($G(RCS TFLAG))  D
  32663   "RTN","RCD PR215",90, 0)
  32664    .   .   I  $Y>(IOSL- 6) D:SCREE N PAUSE Q: $G(RCSTFLA G)  D H
  32665   "RTN","RCD PR215",91, 0)
  32666    .   .   ;
  32667   "RTN","RCD PR215",92, 0)
  32668    .   .   S  UNAPPLY=$ P(^TMP($J, "RCDPR215" ,DA),"^"), AMOUNT=$P( ^(DA),"^", 2),COMMENT S=$P(^(DA) ,"^",3)
  32669   "RTN","RCD PR215",93, 0)
  32670    .   .   S  PRINTOTL= PRINTOTL+A MOUNT
  32671   "RTN","RCD PR215",94, 0)
  32672    .   .   S  $P(TOTAL, "^")=$P(TO TAL,"^")+A MOUNT
  32673   "RTN","RCD PR215",95, 0)
  32674    .   .   ;   if accru ed report,  do not sh ow detail
  32675   "RTN","RCD PR215",96, 0)
  32676    .   .   I  RCTYPE="A " Q
  32677   "RTN","RCD PR215",97, 0)
  32678    .   .   ;
  32679   "RTN","RCD PR215",98, 0)
  32680    .   .   S  COUNT=COU NT+1
  32681   "RTN","RCD PR215",99, 0)
  32682    .   .   W  !?5,COUNT ,")",?10,U NAPPLY,?30 ,$J(AMOUNT ,10,2),?45 ,"COMMENTS : ",$E(COM MENTS,1,25 )
  32683   "RTN","RCD PR215",100 ,0)
  32684    .   .   I  $TR($E(CO MMENTS,26, 80)," ")'= "" W !?25, $E(COMMENT S,26,80)
  32685   "RTN","RCD PR215",101 ,0)
  32686    .   .   ; PRCA*4.5*3 21 - BEGIN
  32687   "RTN","RCD PR215",102 ,0)
  32688    .   .   ;  Get comme nt history  from RCDP E COMMENT  HISTORY fi le #344.73
  32689   "RTN","RCD PR215",103 ,0)
  32690    .   .   N  RCCHIS,RC SUB,RCCOM
  32691   "RTN","RCD PR215",104 ,0)
  32692    .   .   D  GET^RCDPE CH(.RCCHIS ,RECEIPDA, DA)
  32693   "RTN","RCD PR215",105 ,0)
  32694    .   .   S  RCSUB=0
  32695   "RTN","RCD PR215",106 ,0)
  32696    .   .   F   S RCSUB= $O(RCCHIS( RCSUB)) Q: 'RCSUB  D
  32697   "RTN","RCD PR215",107 ,0)
  32698    .   .   .   I RCSUB> 1 D
  32699   "RTN","RCD PR215",108 ,0)
  32700    .   .   .   .  S RCC OM=$P(RCCH IS(RCSUB), U,3)
  32701   "RTN","RCD PR215",109 ,0)
  32702    .   .   .   .  I $Y> (IOSL-6) D :SCREEN PA USE Q:$G(R CSTFLAG)   D H
  32703   "RTN","RCD PR215",110 ,0)
  32704    .   .   .   .  W !,? 45,"COMMEN TS: "_$E(R CCOM,1,25)
  32705   "RTN","RCD PR215",111 ,0)
  32706    .   .   .   .  Q:$TR ($E(RCCOM, 26,80)," " )=""
  32707   "RTN","RCD PR215",112 ,0)
  32708    .   .   .   .  I $Y> (IOSL-6) D :SCREEN PA USE Q:$G(R CSTFLAG)   D H
  32709   "RTN","RCD PR215",113 ,0)
  32710    .   .   .   .  W !?2 5,$E(RCCOM ,26,80)
  32711   "RTN","RCD PR215",114 ,0)
  32712    .   .   .   I RCSUB> 1,$Y>(IOSL -6) D:SCRE EN PAUSE Q :$G(RCSTFL AG)  D H
  32713   "RTN","RCD PR215",115 ,0)
  32714    .   .   .   W !,?45, "ADDED BY  USER: "_$P (RCCHIS(RC SUB),U,2)
  32715   "RTN","RCD PR215",116 ,0)
  32716    .   .   .   I $Y>(IO SL-6) D:SC REEN PAUSE  Q:$G(RCST FLAG)  D H
  32717   "RTN","RCD PR215",117 ,0)
  32718    .   .   .   W !,?45, "ADDED: "_ $P(RCCHIS( RCSUB),U,1 )
  32719   "RTN","RCD PR215",118 ,0)
  32720    .   .   ; PRCA*4.5*3 21 - END
  32721   "RTN","RCD PR215",119 ,0)
  32722    .   ;
  32723   "RTN","RCD PR215",120 ,0)
  32724    .   I $G( RCSTFLAG)  Q
  32725   "RTN","RCD PR215",121 ,0)
  32726    .   I RCT YPE="D" W  !?30,"---- ------",!? 5,"TOTAL f or 3875"
  32727   "RTN","RCD PR215",122 ,0)
  32728    .   W ?30 ,$J(PRINTO TL,10,2)
  32729   "RTN","RCD PR215",123 ,0)
  32730    I $G(RCST FLAG) D Q  Q
  32731   "RTN","RCD PR215",124 ,0)
  32732    ;
  32733   "RTN","RCD PR215",125 ,0)
  32734    S TOTLAMT =0 F PIECE =1:1:5 S T OTLAMT=TOT LAMT+$P(TO TAL,"^",PI ECE)
  32735   "RTN","RCD PR215",126 ,0)
  32736    W !!,"TOT ALS: "
  32737   "RTN","RCD PR215",127 ,0)
  32738    W !?5,"TO TAL AMOUNT  POSTED:", ?30,$J(TOT LAMT,10,2)
  32739   "RTN","RCD PR215",128 ,0)
  32740    ;
  32741   "RTN","RCD PR215",129 ,0)
  32742    I SCREEN  W !,"Press  RETURN to  continue:  " R X:DTI ME
  32743   "RTN","RCD PR215",130 ,0)
  32744   Q D ^%ZISC
  32745   "RTN","RCD PR215",131 ,0)
  32746    K ^TMP($J ,"RCFMSCR" ),^TMP($J, "RCDPR215" )
  32747   "RTN","RCD PR215",132 ,0)
  32748    Q
  32749   "RTN","RCD PR215",133 ,0)
  32750    ;
  32751   "RTN","RCD PR215",134 ,0)
  32752    ;
  32753   "RTN","RCD PR215",135 ,0)
  32754   GETTYPE()  ;  ask the  type of r eport to p rint
  32755   "RTN","RCD PR215",136 ,0)
  32756    N DIR,X,Y
  32757   "RTN","RCD PR215",137 ,0)
  32758    S DIR(0)= "S^A:ACCRU ED;D:DETAI LED",DIR(" A")="ACCRU ED OR DETA ILED REPOR T",DIR("B" )="ACCRUED ",DIR("?") ="A DETAIL ED Report  will list  out accrue d bills se parately"
  32759   "RTN","RCD PR215",138 ,0)
  32760    S DIR("?" ,1)="An AC CRUED Repo rt will li st just th e accrued  total unde r each app ropriation "
  32761   "RTN","RCD PR215",139 ,0)
  32762    D ^DIR
  32763   "RTN","RCD PR215",140 ,0)
  32764    I Y'="A", Y'="D" Q " "
  32765   "RTN","RCD PR215",141 ,0)
  32766    Q Y
  32767   "RTN","RCD PR215",142 ,0)
  32768    ;
  32769   "RTN","RCD PR215",143 ,0)
  32770    ;
  32771   "RTN","RCD PR215",144 ,0)
  32772   DEBTOR(DA)  ;  return s the debt or name fo r ien of b ill (da) i n file 430
  32773   "RTN","RCD PR215",145 ,0)
  32774    N D0,DEBT OR,DIC,DIQ ,DR
  32775   "RTN","RCD PR215",146 ,0)
  32776    S DIC="^P RCA(430,", DR=9,DIQ(0 )="E",DIQ= "DEBTOR"
  32777   "RTN","RCD PR215",147 ,0)
  32778    D EN^DIQ1
  32779   "RTN","RCD PR215",148 ,0)
  32780    Q $G(DEBT OR(430,DA, 9,"E"))
  32781   "RTN","RCD PR215",149 ,0)
  32782    ;
  32783   "RTN","RCD PR215",150 ,0)
  32784    ;
  32785   "RTN","RCD PR215",151 ,0)
  32786   H ;  heade r
  32787   "RTN","RCD PR215",152 ,0)
  32788    N Z
  32789   "RTN","RCD PR215",153 ,0)
  32790    S PAGE=PA GE+1 I PAG E'=1!(SCRE EN) W @IOF
  32791   "RTN","RCD PR215",154 ,0)
  32792    W $C(13), "Page ",PA GE,?(80-$L (NOW)),NOW
  32793   "RTN","RCD PR215",155 ,0)
  32794    W !,$E($T R(RCYLINE, "-","*"),1 ,34)," 215  REPORT ", $E($TR(RCY LINE,"-"," *"),1,34)
  32795   "RTN","RCD PR215",156 ,0)
  32796    W !!,"REC EIPT #: ", RECEIPT,?2 5,"for DEP OSIT #: ", DEPOSIT
  32797   "RTN","RCD PR215",157 ,0)
  32798    I FMSDOCN O'="" W ?5 1,"FMS Doc ument #: " ,FMSDOCNO
  32799   "RTN","RCD PR215",158 ,0)
  32800    S Z=""
  32801   "RTN","RCD PR215",159 ,0)
  32802    I $P($G(^ RCY(344,RE CEIPDA,0)) ,U,18) S Z =$E(" REFE RENCE ERA  #: "_$P($G (^RCY(344. 4,+$P($G(^ RCY(344,RE CEIPDA,0)) ,U,18),0)) ,U)_" ("_$ P($G(^RCY( 344.4,+$P( $G(^RCY(34 4,RECEIPDA ,0)),U,18) ,0)),U,2)_ ")"_$J("", 51),1,51)
  32803   "RTN","RCD PR215",160 ,0)
  32804    I Z'="" W  !,Z
  32805   "RTN","RCD PR215",161 ,0)
  32806    W !,RCYLI NE
  32807   "RTN","RCD PR215",162 ,0)
  32808    Q
  32809   "RTN","RCD PR215",163 ,0)
  32810    ;
  32811   "RTN","RCD PR215",164 ,0)
  32812    ;
  32813   "RTN","RCD PR215",165 ,0)
  32814   PAUSE ;  p ause at en d of page
  32815   "RTN","RCD PR215",166 ,0)
  32816    N X U IO( 0) W !,"Pr ess RETURN  to contin ue, '^' to  exit:" R  X:DTIME S: '$T X="^"  S:X["^" RC STFLAG=1 U  IO
  32817   "RTN","RCD PR215",167 ,0)
  32818    Q
  32819   "RTN","RCD PRL")
  32820   0^60^B2015 972
  32821   "RTN","RCD PRL",1,0)
  32822   RCDPRL ;AI TC/CJE - l ist of rec eipts repo rt ;23 Aug  2017
  32823   "RTN","RCD PRL",2,0)
  32824    ;;4.5;Acc ounts Rece ivable;**3 21**;;Buil d 46
  32825   "RTN","RCD PRL",3,0)
  32826    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  32827   "RTN","RCD PRL",4,0)
  32828    ;
  32829   "RTN","RCD PRL",5,0)
  32830   EN ; -- ma in entry p oint for R CDP LIST O F RECIEPTS  REPORT
  32831   "RTN","RCD PRL",6,0)
  32832    N RCDPFXI T
  32833   "RTN","RCD PRL",7,0)
  32834    D EN^VALM ("RCDP LIS T OF RECEI PTS REPORT ")
  32835   "RTN","RCD PRL",8,0)
  32836    Q
  32837   "RTN","RCD PRL",9,0)
  32838    ;
  32839   "RTN","RCD PRL",10,0)
  32840   HDR ; -- h eader code
  32841   "RTN","RCD PRL",11,0)
  32842    S VALMHDR (1)=^TMP($ J,"RCDPRLI S","HDR",2 )
  32843   "RTN","RCD PRL",12,0)
  32844    S VALMHDR (2)=^TMP($ J,"RCDPRLI S","HDR",3 )
  32845   "RTN","RCD PRL",13,0)
  32846    S VALMHDR (3)=^TMP($ J,"RCDPRLI S","HDR",4 )
  32847   "RTN","RCD PRL",14,0)
  32848    Q
  32849   "RTN","RCD PRL",15,0)
  32850    ;
  32851   "RTN","RCD PRL",16,0)
  32852   INIT ; --  init varia bles and l ist array
  32853   "RTN","RCD PRL",17,0)
  32854    N K
  32855   "RTN","RCD PRL",18,0)
  32856    S (K,VALM CNT)=0
  32857   "RTN","RCD PRL",19,0)
  32858    F  S K=$O (^TMP($J," RCDPRLIS", K)) Q:'K   D  ;
  32859   "RTN","RCD PRL",20,0)
  32860    . S VALMC NT=VALMCNT +1
  32861   "RTN","RCD PRL",21,0)
  32862    . D SET^V ALM10(VALM CNT,^TMP($ J,"RCDPRLI S",K),VALM CNT)
  32863   "RTN","RCD PRL",22,0)
  32864    Q
  32865   "RTN","RCD PRL",23,0)
  32866    ;
  32867   "RTN","RCD PRL",24,0)
  32868   RP ; EP -  Launch rec eipt proce ssing list  template
  32869   "RTN","RCD PRL",25,0)
  32870    ; Input:  None
  32871   "RTN","RCD PRL",26,0)
  32872    ; Output:  None
  32873   "RTN","RCD PRL",27,0)
  32874    ;
  32875   "RTN","RCD PRL",28,0)
  32876    N IBFASTX T,RCRECTDA ,RCK
  32877   "RTN","RCD PRL",29,0)
  32878    D EN^VALM 2($G(XQORN OD(0)),"S" )
  32879   "RTN","RCD PRL",30,0)
  32880    I '$D(VAL MY) Q
  32881   "RTN","RCD PRL",31,0)
  32882    ;
  32883   "RTN","RCD PRL",32,0)
  32884    S VALMBCK ="R"
  32885   "RTN","RCD PRL",33,0)
  32886    S RCK=0
  32887   "RTN","RCD PRL",34,0)
  32888    F  S RCK= $O(VALMY(R CK)) Q:'RC K!$G(RCDPF XIT)  D  ;
  32889   "RTN","RCD PRL",35,0)
  32890    . S RCREC TDA=$G(^TM P($J,"RCDP RLIS","IDX ",RCK))
  32891   "RTN","RCD PRL",36,0)
  32892    . D EN^VA LM("RCDP R ECEIPT PRO FILE")
  32893   "RTN","RCD PRL",37,0)
  32894    . ; fast  exit
  32895   "RTN","RCD PRL",38,0)
  32896    . I $G(RC DPFXIT) S  RCRECTDA=0
  32897   "RTN","RCD PRL",39,0)
  32898    I $G(RCDP FXIT) S VA LMBCK="Q"
  32899   "RTN","RCD PRL",40,0)
  32900    Q
  32901   "RTN","RCD PRL",41,0)
  32902    ;
  32903   "RTN","RCD PRL",42,0)
  32904   HELP ; --  help code
  32905   "RTN","RCD PRL",43,0)
  32906    N X
  32907   "RTN","RCD PRL",44,0)
  32908    S X="?" D  DISP^XQOR M1 W !!
  32909   "RTN","RCD PRL",45,0)
  32910    Q
  32911   "RTN","RCD PRL",46,0)
  32912    ;
  32913   "RTN","RCD PRL",47,0)
  32914   EXIT ; --  exit code
  32915   "RTN","RCD PRL",48,0)
  32916    Q
  32917   "RTN","RCD PRL",49,0)
  32918    ;
  32919   "RTN","RCD PRLIS")
  32920   0^59^B1284 05994
  32921   "RTN","RCD PRLIS",1,0 )
  32922   RCDPRLIS ; WISC/RFJ -  list of r eceipts re port ;1 Ju n 99
  32923   "RTN","RCD PRLIS",2,0 )
  32924    ;;4.5;Acc ounts Rece ivable;**1 14,304,321 **;Mar 20,  1995;Buil d 46
  32925   "RTN","RCD PRLIS",3,0 )
  32926    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  32927   "RTN","RCD PRLIS",4,0 )
  32928    ;
  32929   "RTN","RCD PRLIS",5,0 )
  32930    N %ZIS,DA TEEND,DATE STRT,POP,R CFILTF,RCF ILTT,RCLST MGR,RCSORT
  32931   "RTN","RCD PRLIS",6,0 )
  32932    N ZTDESC, ZTQUEUED,Z TRTN,ZTSAV E,ZTSK
  32933   "RTN","RCD PRLIS",7,0 )
  32934    W !
  32935   "RTN","RCD PRLIS",8,0 )
  32936    D DATESEL ^RCRJRTRA( "RECEIPT O pened")
  32937   "RTN","RCD PRLIS",9,0 )
  32938    I '$G(DAT ESTRT)!('$ G(DATEEND) ) Q
  32939   "RTN","RCD PRLIS",10, 0)
  32940    ;
  32941   "RTN","RCD PRLIS",11, 0)
  32942    ; Prompt  for sort o rder PRCA* 4.5*321
  32943   "RTN","RCD PRLIS",12, 0)
  32944    S RCSORT= $$SORTSEL( )
  32945   "RTN","RCD PRLIS",13, 0)
  32946    I RCSORT= -1 Q
  32947   "RTN","RCD PRLIS",14, 0)
  32948    ;
  32949   "RTN","RCD PRLIS",15, 0)
  32950    ; Prompt  for filter  by FMS St atus PRCA* 4.5*321
  32951   "RTN","RCD PRLIS",16, 0)
  32952    D SELFILT F(.RCFILTF )
  32953   "RTN","RCD PRLIS",17, 0)
  32954    I RCFILTF =-1 Q
  32955   "RTN","RCD PRLIS",18, 0)
  32956    ;
  32957   "RTN","RCD PRLIS",19, 0)
  32958    ; Prompt  for filter  by Paymen t Type PRC A*4.5*321
  32959   "RTN","RCD PRLIS",20, 0)
  32960    D SELFILT T(.RCFILTT )
  32961   "RTN","RCD PRLIS",21, 0)
  32962    I RCFILTT =-1 Q
  32963   "RTN","RCD PRLIS",22, 0)
  32964    ;
  32965   "RTN","RCD PRLIS",23, 0)
  32966    ; Ask for  ListMan d isplay, ex it if time out or '^'
  32967   "RTN","RCD PRLIS",24, 0)
  32968    W !
  32969   "RTN","RCD PRLIS",25, 0)
  32970    S RCLSTMG R=$$ASKLM^ RCDPEARL()  I RCLSTMG R<0 Q
  32971   "RTN","RCD PRLIS",26, 0)
  32972    ;
  32973   "RTN","RCD PRLIS",27, 0)
  32974    ; Send re port to Li stman if r equested
  32975   "RTN","RCD PRLIS",28, 0)
  32976    I RCLSTMG R D  D CLE AN Q
  32977   "RTN","RCD PRLIS",29, 0)
  32978    . D DQ
  32979   "RTN","RCD PRLIS",30, 0)
  32980    . D EN^RC DPRL
  32981   "RTN","RCD PRLIS",31, 0)
  32982    ;
  32983   "RTN","RCD PRLIS",32, 0)
  32984    ;  select  device
  32985   "RTN","RCD PRLIS",33, 0)
  32986    W ! S %ZI S="Q" D ^% ZIS I POP  Q
  32987   "RTN","RCD PRLIS",34, 0)
  32988    I $D(IO(" Q")) D  D  ^%ZTLOAD K  IO("Q"),Z TSK Q
  32989   "RTN","RCD PRLIS",35, 0)
  32990    .   S ZTD ESC="List  of Receipt s",ZTRTN=" DQ^RCDPRLI S"
  32991   "RTN","RCD PRLIS",36, 0)
  32992    .   S ZTS AVE("DATE* ")="",ZTSA VE("RC*")= "",ZTSAVE( "ZTREQ")=" @"
  32993   "RTN","RCD PRLIS",37, 0)
  32994    W !!,"<*>  please wa it <*>"
  32995   "RTN","RCD PRLIS",38, 0)
  32996    D DQ
  32997   "RTN","RCD PRLIS",39, 0)
  32998    Q
  32999   "RTN","RCD PRLIS",40, 0)
  33000    ;
  33001   "RTN","RCD PRLIS",41, 0)
  33002   DQ ;  queu ed report  starts her e
  33003   "RTN","RCD PRLIS",42, 0)
  33004    ; PRCA*4. 5*321 Exte nsive chan ges to thi s subrouti ne for fil ter/sort/L istMan
  33005   "RTN","RCD PRLIS",43, 0)
  33006    N %,%I,CN T,DATA,DAT E,DATEDIS1 ,DATEDIS2, FMSDOCNO,F MSTATUS,NO W,PAGE,PTY PE,RCDK,RC DPDATA
  33007   "RTN","RCD PRLIS",44, 0)
  33008    N RCDPFPR E,RCIX,RCR ECTDA,RCRJ FLAG,RCRJL INE,RCUSER ,SCREEN,SP ACE,TOTALS ,TYPE,X,Y
  33009   "RTN","RCD PRLIS",45, 0)
  33010    K ^TMP($J ,"RCDPRLIS ")
  33011   "RTN","RCD PRLIS",46, 0)
  33012    S SPACE=$ J("",80)
  33013   "RTN","RCD PRLIS",47, 0)
  33014    S RCDK=$$ FMADD^XLFD T(DATESTRT ,-1)_".24"  ; Initial ize start  date for f irst $ORDE R
  33015   "RTN","RCD PRLIS",48, 0)
  33016    S DATEEND =DATEEND_" .24" ; Rec eipt date  opened can  include t ime, so co mpare with  midnight  on the end  date.
  33017   "RTN","RCD PRLIS",49, 0)
  33018    F  S RCDK =$O(^RCY(3 44,"AO",RC DK)) Q:(RC DK=""!(RCD K>DATEEND) )  D  ;
  33019   "RTN","RCD PRLIS",50, 0)
  33020    . S RCREC TDA=0 F  S  RCRECTDA= $O(^RCY(34 4,"AO",RCD K,RCRECTDA )) Q:'RCRE CTDA  D
  33021   "RTN","RCD PRLIS",51, 0)
  33022    . . K RCD PDATA
  33023   "RTN","RCD PRLIS",52, 0)
  33024    . . D DIQ 344^RCDPRP LM(RCRECTD A,".01:200 ")
  33025   "RTN","RCD PRLIS",53, 0)
  33026    . . ;  ge t fms docu ment ^ sta tus ^ pre  lockbox pa tch
  33027   "RTN","RCD PRLIS",54, 0)
  33028    . . S FMS DOCNO=$$FM SSTAT^RCDP UREC(RCREC TDA)
  33029   "RTN","RCD PRLIS",55, 0)
  33030    . . ; App ly filter  by FMS Sta tus
  33031   "RTN","RCD PRLIS",56, 0)
  33032    . . S FMS TATUS=$P(F MSDOCNO,"^ ",2)
  33033   "RTN","RCD PRLIS",57, 0)
  33034    . . I RCF ILTF,FMSTA TUS'="",'$ D(RCFILTF( FMSTATUS))  Q  ; this  status no t included
  33035   "RTN","RCD PRLIS",58, 0)
  33036    . . ; App ly filter  by Payment  Type
  33037   "RTN","RCD PRLIS",59, 0)
  33038    . . S PTY PE=RCDPDAT A(344,RCRE CTDA,.04," E")
  33039   "RTN","RCD PRLIS",60, 0)
  33040    . . I RCF ILTT,PTYPE '="",'$D(R CFILTT(PTY PE)) Q  ;  this statu s not incl uded
  33041   "RTN","RCD PRLIS",61, 0)
  33042    . . ;
  33043   "RTN","RCD PRLIS",62, 0)
  33044    . . ;  co mpute tota ls by type
  33045   "RTN","RCD PRLIS",63, 0)
  33046    . . I RCD PDATA(344, RCRECTDA,. 04,"E")=""  S RCDPDAT A(344,RCRE CTDA,.04," E")="UNKNO WN"
  33047   "RTN","RCD PRLIS",64, 0)
  33048    . . S $P( TOTALS(PTY PE),"^",1) =$P($G(TOT ALS(PTYPE) ),"^",1)+R CDPDATA(34 4,RCRECTDA ,101,"E")
  33049   "RTN","RCD PRLIS",65, 0)
  33050    . . S $P( TOTALS(PTY PE),"^",2) =$P($G(TOT ALS(PTYPE) ),"^",2)+R CDPDATA(34 4,RCRECTDA ,.15,"E")
  33051   "RTN","RCD PRLIS",66, 0)
  33052    . . S $P( TOTALS,"^" ,1)=$P($G( TOTALS),"^ ",1)+RCDPD ATA(344,RC RECTDA,101 ,"E")
  33053   "RTN","RCD PRLIS",67, 0)
  33054    . . S $P( TOTALS,"^" ,2)=$P($G( TOTALS),"^ ",2)+RCDPD ATA(344,RC RECTDA,.15 ,"E")
  33055   "RTN","RCD PRLIS",68, 0)
  33056    . . ;
  33057   "RTN","RCD PRLIS",69, 0)
  33058    . . ;  op ened by
  33059   "RTN","RCD PRLIS",70, 0)
  33060    . . I RCD PDATA(344, RCRECTDA,. 02,"I")=.5  D  ;
  33061   "RTN","RCD PRLIS",71, 0)
  33062    . . . S R CUSER="ar"
  33063   "RTN","RCD PRLIS",72, 0)
  33064    . . E  D   ;
  33065   "RTN","RCD PRLIS",73, 0)
  33066    . . . S R CUSER=RCDP DATA(344,R CRECTDA,.0 2,"E")
  33067   "RTN","RCD PRLIS",74, 0)
  33068    . . . I R CUSER'=""  D
  33069   "RTN","RCD PRLIS",75, 0)
  33070    . . . . S  RCUSER=$E ($P(RCUSER ,",",2))_$ E(RCUSER)
  33071   "RTN","RCD PRLIS",76, 0)
  33072    . . ;
  33073   "RTN","RCD PRLIS",77, 0)
  33074    . . S DAT A=RCDPDATA (344,RCREC TDA,.01,"E ")             ;recei pt number
  33075   "RTN","RCD PRLIS",78, 0)
  33076    . . S DAT A=DATA_"^" _RCDPDATA( 344,RCRECT DA,.03,"I" )   ;date  opened
  33077   "RTN","RCD PRLIS",79, 0)
  33078    . . S DAT A=DATA_"^" _RCDPDATA( 344,RCRECT DA,.04,"E" )   ;payme nt type
  33079   "RTN","RCD PRLIS",80, 0)
  33080    . . S DAT A=DATA_"^" _RCUSER                              ;user  initials
  33081   "RTN","RCD PRLIS",81, 0)
  33082    . . S DAT A=DATA_"^" _RCDPDATA( 344,RCRECT DA,101,"E" )   ;payme nt count
  33083   "RTN","RCD PRLIS",82, 0)
  33084    . . S DAT A=DATA_"^" _RCDPDATA( 344,RCRECT DA,.15,"E" )   ;payme nt amount
  33085   "RTN","RCD PRLIS",83, 0)
  33086    . . S DAT A=DATA_"^" _$S($P(FMS DOCNO,"^", 3):"*",1:"  ") ;pre l ockbox
  33087   "RTN","RCD PRLIS",84, 0)
  33088    . . S DAT A=DATA_"^" _$P(FMSDOC NO,"^")                   ;fms c r document
  33089   "RTN","RCD PRLIS",85, 0)
  33090    . . S DAT A=DATA_"^" _$P(FMSDOC NO,"^",2)                 ;fms c r doc stat us
  33091   "RTN","RCD PRLIS",86, 0)
  33092    . . S DAT A=DATA_"^" _RCRECTDA                            ;ien o f file 344
  33093   "RTN","RCD PRLIS",87, 0)
  33094    . . ;
  33095   "RTN","RCD PRLIS",88, 0)
  33096    . . ; Ind ex ^TMP gl obal by us er selecte d sort ord er
  33097   "RTN","RCD PRLIS",89, 0)
  33098    . . I RCS ORT="D" S  RCIX=RCDPD ATA(344,RC RECTDA,.03 ,"I")
  33099   "RTN","RCD PRLIS",90, 0)
  33100    . . I RCS ORT="F" S  RCIX=FMSTA TUS
  33101   "RTN","RCD PRLIS",91, 0)
  33102    . . I RCS ORT="T" S  RCIX=PTYPE
  33103   "RTN","RCD PRLIS",92, 0)
  33104    . . S ^TM P($J,"RCDP RLIS","SOR T",RCIX,RC RECTDA)=DA TA
  33105   "RTN","RCD PRLIS",93, 0)
  33106    ;
  33107   "RTN","RCD PRLIS",94, 0)
  33108    S Y=$P(DA TESTRT,"." ) S DATEDI S1=$$FMTE^ XLFDT(Y,"2 DZ")
  33109   "RTN","RCD PRLIS",95, 0)
  33110    S Y=$P(DA TEEND,".")  S DATEDIS 2=$$FMTE^X LFDT(Y,"2D Z")
  33111   "RTN","RCD PRLIS",96, 0)
  33112    D NOW^%DT C S Y=% D  DD^%DT S N OW=Y
  33113   "RTN","RCD PRLIS",97, 0)
  33114    S PAGE=1, RCRJLINE=" ",$P(RCRJL INE,"-",81 )=""
  33115   "RTN","RCD PRLIS",98, 0)
  33116    S SCREEN= 0 I '$D(ZT QUEUED),'$ G(RCLSTMGR ),IO=IO(0) ,$E(IOST)= "C" S SCRE EN=1
  33117   "RTN","RCD PRLIS",99, 0)
  33118    D HDR ; C ompile hea der in to  ^TMP for u se in repo rt or List Man
  33119   "RTN","RCD PRLIS",100 ,0)
  33120    U IO D:'$ G(RCLSTMGR ) H
  33121   "RTN","RCD PRLIS",101 ,0)
  33122    S CNT=0
  33123   "RTN","RCD PRLIS",102 ,0)
  33124    S RCIX=0  F  S RCIX= $O(^TMP($J ,"RCDPRLIS ","SORT",R CIX)) Q:RC IX=""!($G( RCRJFLAG))   D
  33125   "RTN","RCD PRLIS",103 ,0)
  33126    . S RCREC TDA=0 F  S  RCRECTDA= $O(^TMP($J ,"RCDPRLIS ","SORT",R CIX,RCRECT DA)) Q:'RC RECTDA!($G (RCRJFLAG) )  D
  33127   "RTN","RCD PRLIS",104 ,0)
  33128    . . S DAT A=^TMP($J, "RCDPRLIS" ,"SORT",RC IX,RCRECTD A)
  33129   "RTN","RCD PRLIS",105 ,0)
  33130    . . S DAT E=$P(DATA, "^",2)
  33131   "RTN","RCD PRLIS",106 ,0)
  33132    . . S CNT =CNT+1
  33133   "RTN","RCD PRLIS",107 ,0)
  33134    . . S XX= ""
  33135   "RTN","RCD PRLIS",108 ,0)
  33136    . . I RCL STMGR S XX =" "_$E(CN T_SPACE,1, 4)_" "                             ; line n umber (for  listman)
  33137   "RTN","RCD PRLIS",109 ,0)
  33138    . . S XX= XX_$$FMTE^ XLFDT(DATE ,"2ZD")_"  "                                  ; date o pened
  33139   "RTN","RCD PRLIS",110 ,0)
  33140    . . S XX= XX_$E($P(D ATA,"^")_S PACE,1,12) _" "                               ; receip t number
  33141   "RTN","RCD PRLIS",111 ,0)
  33142    . . S XX= XX_$E($P($ P(DATA,"^" ,3)," ")_S PACE,1,$S( RCLSTMGR:5 ,1:8))_" "   ; paymen t type 
  33143   "RTN","RCD PRLIS",112 ,0)
  33144    . . S XX= XX_$E($P(D ATA,"^",4) _SPACE,1,2 )                                  ; user i nitials
  33145   "RTN","RCD PRLIS",113 ,0)
  33146    . . S XX= XX_$J($P(D ATA,"^",5) ,6)                                           ; paymen t count
  33147   "RTN","RCD PRLIS",114 ,0)
  33148    . . S XX= XX_$J($P(D ATA,"^",6) ,$S(RCLSTM GR:11,1:13 ),2)_" "                ; paymen t amount
  33149   "RTN","RCD PRLIS",115 ,0)
  33150    . . S XX= XX_$E($P(D ATA,"^",7) _SPACE,1)                                     ; pre lo ckbox
  33151   "RTN","RCD PRLIS",116 ,0)
  33152    . . S XX= XX_$E($P(D ATA,"^",8) _SPACE,1,1 6)_" "                             ; fms cr  document
  33153   "RTN","RCD PRLIS",117 ,0)
  33154    . . S XX= XX_$E($P(D ATA,"^",9) ,1,$S(RCLS TMGR:8,1:9 ))                      ; fms cr  doc statu s
  33155   "RTN","RCD PRLIS",118 ,0)
  33156    . . ;
  33157   "RTN","RCD PRLIS",119 ,0)
  33158    . . ; Wri te line or  put it to  global
  33159   "RTN","RCD PRLIS",120 ,0)
  33160    . . I '$G (RCLSTMGR)  D  ;
  33161   "RTN","RCD PRLIS",121 ,0)
  33162    . . . W ! ,XX
  33163   "RTN","RCD PRLIS",122 ,0)
  33164    . . E  D   ;
  33165   "RTN","RCD PRLIS",123 ,0)
  33166    . . . S ^ TMP($J,"RC DPRLIS",CN T)=XX
  33167   "RTN","RCD PRLIS",124 ,0)
  33168    . . . S ^ TMP($J,"RC DPRLIS","I DX",CNT)=$ P(DATA,"^" ,10) ; Cro ss referen ce line# v s file 344  DA
  33169   "RTN","RCD PRLIS",125 ,0)
  33170    . . ;
  33171   "RTN","RCD PRLIS",126 ,0)
  33172    . . ;  se t pre lock box flag t o 1 to sho w note at  end of rep ort
  33173   "RTN","RCD PRLIS",127 ,0)
  33174    . . I $P( DATA,"^",7 )="*" S RC DPFPRE=1
  33175   "RTN","RCD PRLIS",128 ,0)
  33176    . . ;
  33177   "RTN","RCD PRLIS",129 ,0)
  33178    . . I '$G (RCLSTMGR) ,$Y>(IOSL- 6) D:SCREE N PAUSE^RC RJRTR1 Q:$ G(RCRJFLAG )  D H
  33179   "RTN","RCD PRLIS",130 ,0)
  33180    ;
  33181   "RTN","RCD PRLIS",131 ,0)
  33182    I $G(RCLS TMGR) Q  ;  PRCA*4.5* 321 - Tota ls don't h ave a plac e in a pro tocol list  with acti ons
  33183   "RTN","RCD PRLIS",132 ,0)
  33184    ;
  33185   "RTN","RCD PRLIS",133 ,0)
  33186    I $G(RCRJ FLAG) D CL EAN Q
  33187   "RTN","RCD PRLIS",134 ,0)
  33188    I $G(RCDP FPRE) W !? 54,"*CR ti ed to depo sit"
  33189   "RTN","RCD PRLIS",135 ,0)
  33190    W !?33,"- -----  --- --------"
  33191   "RTN","RCD PRLIS",136 ,0)
  33192    W !?33,$J ($P($G(TOT ALS),"^"), 6),$J($P($ G(TOTALS), "^",2),13, 2)
  33193   "RTN","RCD PRLIS",137 ,0)
  33194    ;
  33195   "RTN","RCD PRLIS",138 ,0)
  33196    ;  show t otals by t ype of pay ment
  33197   "RTN","RCD PRLIS",139 ,0)
  33198    W !!,"TOT ALS BY TYP E OF PAYME NT"
  33199   "RTN","RCD PRLIS",140 ,0)
  33200    W !,"---- ---------- ---------- -"
  33201   "RTN","RCD PRLIS",141 ,0)
  33202    S TYPE=""  F  S TYPE =$O(TOTALS (TYPE)) Q: TYPE=""!($ G(RCRJFLAG ))  D
  33203   "RTN","RCD PRLIS",142 ,0)
  33204    .   W !,T YPE,?33,$J ($P(TOTALS (TYPE),"^" ),6),$J($P (TOTALS(TY PE),"^",2) ,13,2)
  33205   "RTN","RCD PRLIS",143 ,0)
  33206    .   I $Y> (IOSL-6) D :SCREEN PA USE^RCRJRT R1 Q:$G(RC RJFLAG)  D  H
  33207   "RTN","RCD PRLIS",144 ,0)
  33208    ;
  33209   "RTN","RCD PRLIS",145 ,0)
  33210    W !!,"***  END OF RE PORT ***", !
  33211   "RTN","RCD PRLIS",146 ,0)
  33212    ;
  33213   "RTN","RCD PRLIS",147 ,0)
  33214    I $G(RCRJ FLAG) D CL EAN Q
  33215   "RTN","RCD PRLIS",148 ,0)
  33216    I SCREEN  U IO(0) R  !,"Press R ETURN to c ontinue:", %:DTIME
  33217   "RTN","RCD PRLIS",149 ,0)
  33218    ;
  33219   "RTN","RCD PRLIS",150 ,0)
  33220    I '$G(RCL STMGR) D C LEAN
  33221   "RTN","RCD PRLIS",151 ,0)
  33222    Q
  33223   "RTN","RCD PRLIS",152 ,0)
  33224   CLEAN ; Cl ean up ^TM P arrays
  33225   "RTN","RCD PRLIS",153 ,0)
  33226    D ^%ZISC
  33227   "RTN","RCD PRLIS",154 ,0)
  33228    K ^TMP($J ,"RCDPRLIS ")
  33229   "RTN","RCD PRLIS",155 ,0)
  33230    Q
  33231   "RTN","RCD PRLIS",156 ,0)
  33232    ;
  33233   "RTN","RCD PRLIS",157 ,0)
  33234   SORTSEL()  ; Select s ort order  for report , by Date  Opened, FM S Status o r Payment  Type
  33235   "RTN","RCD PRLIS",158 ,0)
  33236    ; Input:  None
  33237   "RTN","RCD PRLIS",159 ,0)
  33238    ; Return:  Sort Type  D - Date,  F - FMS S tatus, T -  Payment T ype
  33239   "RTN","RCD PRLIS",160 ,0)
  33240    N DIR,X,Y ,DUOUT,DTO UT,DIRUT,D IROUT,RCRE P
  33241   "RTN","RCD PRLIS",161 ,0)
  33242    W !
  33243   "RTN","RCD PRLIS",162 ,0)
  33244    S DIR(0)= "SOA^D:Dat e;F:FMS St atus;T:Typ e of payme nt"
  33245   "RTN","RCD PRLIS",163 ,0)
  33246    S DIR("A" )="Sort By  (D)ATE OP ENED, (F)M S STATUS O R (T)YPE O F PAYMENT:  "
  33247   "RTN","RCD PRLIS",164 ,0)
  33248    S DIR("B" )="D"
  33249   "RTN","RCD PRLIS",165 ,0)
  33250    S DIR("?" ,1)="Selec t the orde r you wish  the recei pts to app ear in on  the report ."
  33251   "RTN","RCD PRLIS",166 ,0)
  33252    S DIR("?" ,2)=" "
  33253   "RTN","RCD PRLIS",167 ,0)
  33254    S DIR("?" ,3)="    D  - Sort by  the date  the receip t was open ed"
  33255   "RTN","RCD PRLIS",168 ,0)
  33256    S DIR("?" ,4)="    S  - Sort by  the FMS S tatus"
  33257   "RTN","RCD PRLIS",169 ,0)
  33258    S DIR("?" )="    T -  Sort by t he Payment  Type"
  33259   "RTN","RCD PRLIS",170 ,0)
  33260    D ^DIR
  33261   "RTN","RCD PRLIS",171 ,0)
  33262    I $D(DTOU T)!$D(DUOU T)!(Y="")  S RETURN=- 1
  33263   "RTN","RCD PRLIS",172 ,0)
  33264    E  S RETU RN=Y
  33265   "RTN","RCD PRLIS",173 ,0)
  33266    Q RETURN
  33267   "RTN","RCD PRLIS",174 ,0)
  33268    ;
  33269   "RTN","RCD PRLIS",175 ,0)
  33270   SELFILTF(R ETURN) ; A sk if user  want to f ilter by F MS status.  If yes ge t list of  status.
  33271   "RTN","RCD PRLIS",176 ,0)
  33272    ; Input:  None
  33273   "RTN","RCD PRLIS",177 ,0)
  33274    ; Output:  RETURN, p assed by r eference
  33275   "RTN","RCD PRLIS",178 ,0)
  33276    ;          RETURN -  1=Filter b y FMS Stat us, 0=Don' t
  33277   "RTN","RCD PRLIS",179 ,0)
  33278    ;          RETURN(ST ATUS) - ar ray of FMS  Status to  include i n the repo rt
  33279   "RTN","RCD PRLIS",180 ,0)
  33280    ; 
  33281   "RTN","RCD PRLIS",181 ,0)
  33282    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,J,QUIT,R CODES,RCOU T,X,Y
  33283   "RTN","RCD PRLIS",182 ,0)
  33284    K RETURN
  33285   "RTN","RCD PRLIS",183 ,0)
  33286    S RETURN= 0
  33287   "RTN","RCD PRLIS",184 ,0)
  33288    ;
  33289   "RTN","RCD PRLIS",185 ,0)
  33290    W !
  33291   "RTN","RCD PRLIS",186 ,0)
  33292    S DIR(0)= "YA"
  33293   "RTN","RCD PRLIS",187 ,0)
  33294    S DIR("A" )="Filter  by FMS Sta tus? (Y/N) : "
  33295   "RTN","RCD PRLIS",188 ,0)
  33296    S DIR("B" )="NO"
  33297   "RTN","RCD PRLIS",189 ,0)
  33298    S DIR("?" ,1)="Enter  'Y' or 'Y es' to onl y show rec eipts with  selected  FMS Status "
  33299   "RTN","RCD PRLIS",190 ,0)
  33300    S DIR("?" ,2)="Enter  'N' or 'N o' if you  wish to sh ow receipt s includin g all FMS  Status"
  33301   "RTN","RCD PRLIS",191 ,0)
  33302    S DIR("?" )="If you  select yes , you will  be prompt ed for the  FMS Statu s' you wis h to inclu de"
  33303   "RTN","RCD PRLIS",192 ,0)
  33304    D ^DIR
  33305   "RTN","RCD PRLIS",193 ,0)
  33306    I $D(DIRU T) S RETUR N=-1 Q
  33307   "RTN","RCD PRLIS",194 ,0)
  33308    I Y=0 Q
  33309   "RTN","RCD PRLIS",195 ,0)
  33310    S RETURN= 1
  33311   "RTN","RCD PRLIS",196 ,0)
  33312    ;
  33313   "RTN","RCD PRLIS",197 ,0)
  33314    ; Prompt  for status ' to be in cluded. Mu lti-select
  33315   "RTN","RCD PRLIS",198 ,0)
  33316    W !
  33317   "RTN","RCD PRLIS",199 ,0)
  33318    D FIELD^D ID(2100.1, 3,"","POIN TER","RCOU T")
  33319   "RTN","RCD PRLIS",200 ,0)
  33320    S RCODES= RCOUT("POI NTER")
  33321   "RTN","RCD PRLIS",201 ,0)
  33322    ; Add pse udo code t o list for  "NOT ENTE RED", retu rned by FM SSTAT^RCDP UREC
  33323   "RTN","RCD PRLIS",202 ,0)
  33324    I $E(RCOD ES,$L(RCOD ES))'=";"  S RCODES=R CODES_";"
  33325   "RTN","RCD PRLIS",203 ,0)
  33326    S RCODES= RCODES_"N: NOT ENTERE D"
  33327   "RTN","RCD PRLIS",204 ,0)
  33328    K DIR
  33329   "RTN","RCD PRLIS",205 ,0)
  33330    S DIR(0)= "SOA^"_RCO DES
  33331   "RTN","RCD PRLIS",206 ,0)
  33332    S DIR("A" )="Select  an FMS Sta tus to inc lude in th e report:  "
  33333   "RTN","RCD PRLIS",207 ,0)
  33334    K DIR("?" )
  33335   "RTN","RCD PRLIS",208 ,0)
  33336    S DIR("?" ,1)="Selec t an FMS S tatus to s how in the  report."
  33337   "RTN","RCD PRLIS",209 ,0)
  33338    S DIR("?" ,2)="You w ill be pro mpted mult iple times , until yo u hit ENTE R"
  33339   "RTN","RCD PRLIS",210 ,0)
  33340    S DIR("?" )="without  making a  selection. "
  33341   "RTN","RCD PRLIS",211 ,0)
  33342    S QUIT=0
  33343   "RTN","RCD PRLIS",212 ,0)
  33344    F  D  I Q UIT Q
  33345   "RTN","RCD PRLIS",213 ,0)
  33346    . W !
  33347   "RTN","RCD PRLIS",214 ,0)
  33348    . D ^DIR
  33349   "RTN","RCD PRLIS",215 ,0)
  33350    . I $D(DT OUT)!$D(DU OUT) K RET URN S RETU RN=-1,QUIT =1 Q
  33351   "RTN","RCD PRLIS",216 ,0)
  33352    . I Y=""  S QUIT=1 Q
  33353   "RTN","RCD PRLIS",217 ,0)
  33354    . S RETUR N(Y(0))=""
  33355   "RTN","RCD PRLIS",218 ,0)
  33356    . ; Rebui d DIR(0) t o only inc lude codes  not yet s elected
  33357   "RTN","RCD PRLIS",219 ,0)
  33358    . S DIR(0 )=$$BLDS(R CODES,.RET URN)
  33359   "RTN","RCD PRLIS",220 ,0)
  33360    . I $P(DI R(0),"^",2 )="" S QUI T=1 ; All  status sel ected so s top prompt ing.
  33361   "RTN","RCD PRLIS",221 ,0)
  33362    I RETURN= -1 Q
  33363   "RTN","RCD PRLIS",222 ,0)
  33364    ; If no F MS Status'  were sele cted, don' t filter b y it.
  33365   "RTN","RCD PRLIS",223 ,0)
  33366    I $O(RETU RN(""))=""  D  ;
  33367   "RTN","RCD PRLIS",224 ,0)
  33368    . S RETUR N=0
  33369   "RTN","RCD PRLIS",225 ,0)
  33370    . W !!,"N o FMS Stat us' were s elected. A ll FMS Sta tus' will  be shown", !
  33371   "RTN","RCD PRLIS",226 ,0)
  33372    Q
  33373   "RTN","RCD PRLIS",227 ,0)
  33374    ;
  33375   "RTN","RCD PRLIS",228 ,0)
  33376   SELFILTT(R ETURN) ; A sk if user  want to f ilter by P ayment Typ e. If yes  get list o f types.
  33377   "RTN","RCD PRLIS",229 ,0)
  33378    ; Input:  None
  33379   "RTN","RCD PRLIS",230 ,0)
  33380    ; Output:  RETURN, p assed by r eference
  33381   "RTN","RCD PRLIS",231 ,0)
  33382    ;          RETURN -  1=Filter b y FMS Stat us, 0=Don' t
  33383   "RTN","RCD PRLIS",232 ,0)
  33384    ;          RETURN(ST ATUS) - ar ray of FMS  Status to  include i n the repo rt
  33385   "RTN","RCD PRLIS",233 ,0)
  33386    ; 
  33387   "RTN","RCD PRLIS",234 ,0)
  33388    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,RCODES,R CIEN,RCNAM E,QUIT,X,Y
  33389   "RTN","RCD PRLIS",235 ,0)
  33390    K RETURN
  33391   "RTN","RCD PRLIS",236 ,0)
  33392    S RETURN= 0
  33393   "RTN","RCD PRLIS",237 ,0)
  33394    ;
  33395   "RTN","RCD PRLIS",238 ,0)
  33396    W !
  33397   "RTN","RCD PRLIS",239 ,0)
  33398    S DIR(0)= "YA"
  33399   "RTN","RCD PRLIS",240 ,0)
  33400    S DIR("A" )="Filter  by Payment  Type? (Y/ N): "
  33401   "RTN","RCD PRLIS",241 ,0)
  33402    S DIR("B" )="NO"
  33403   "RTN","RCD PRLIS",242 ,0)
  33404    S DIR("?" ,1)="Enter  'Y' or 'Y es' to onl y show rec eipts with  selected  Payment Ty pes"
  33405   "RTN","RCD PRLIS",243 ,0)
  33406    S DIR("?" ,2)="Enter  'N' or 'N o' if you  wish to sh ow receipt s includin g all Paym ent Types"
  33407   "RTN","RCD PRLIS",244 ,0)
  33408    S DIR("?" )="If you  select yes , you will  be prompt ed for the  Payment T ypes you w ish to inc lude"
  33409   "RTN","RCD PRLIS",245 ,0)
  33410    D ^DIR
  33411   "RTN","RCD PRLIS",246 ,0)
  33412    I $D(DIRU T) S RETUR N=-1 Q
  33413   "RTN","RCD PRLIS",247 ,0)
  33414    I Y=0 Q
  33415   "RTN","RCD PRLIS",248 ,0)
  33416    S RETURN= 1
  33417   "RTN","RCD PRLIS",249 ,0)
  33418    ;
  33419   "RTN","RCD PRLIS",250 ,0)
  33420    ; Prompt  for types  to be incl uded. Mult i-select
  33421   "RTN","RCD PRLIS",251 ,0)
  33422    W !
  33423   "RTN","RCD PRLIS",252 ,0)
  33424    K DIR
  33425   "RTN","RCD PRLIS",253 ,0)
  33426    ; Present  payment t ypes as a  set of cod es to stre amline use r interfac e/selectio n/help
  33427   "RTN","RCD PRLIS",254 ,0)
  33428    S (RCODES ,RCNAME)=" "
  33429   "RTN","RCD PRLIS",255 ,0)
  33430    F  S RCNA ME=$O(^RC( 341.1,"B", RCNAME)) Q :RCNAME=""   D  ;
  33431   "RTN","RCD PRLIS",256 ,0)
  33432    . S RCIEN =0 F  S RC IEN=$O(^RC (341.1,"B" ,RCNAME,RC IEN)) Q:'R CIEN  D  ;
  33433   "RTN","RCD PRLIS",257 ,0)
  33434    . . I $$G ET1^DIQ(34 1.1,RCIEN_ ",",.06,"I ")=1 D  ;
  33435   "RTN","RCD PRLIS",258 ,0)
  33436    . . . S R CODES=RCOD ES_RCIEN_" :"_$$GET1^ DIQ(341.1, RCIEN_",", .01,"E")_" ;"
  33437   "RTN","RCD PRLIS",259 ,0)
  33438    S DIR(0)= "SOA^"_RCO DES
  33439   "RTN","RCD PRLIS",260 ,0)
  33440    S DIR("A" )="Select  a Payment  Type to in clude in t he report:  "
  33441   "RTN","RCD PRLIS",261 ,0)
  33442    K DIR("?" )
  33443   "RTN","RCD PRLIS",262 ,0)
  33444    S DIR("?" ,1)="Selec t an Payme nt Type to  include i n the repo rt."
  33445   "RTN","RCD PRLIS",263 ,0)
  33446    S DIR("?" ,2)="You w ill be pro mpted mult iple times , until yo u hit ENTE R"
  33447   "RTN","RCD PRLIS",264 ,0)
  33448    S DIR("?" )="without  making a  selection. "
  33449   "RTN","RCD PRLIS",265 ,0)
  33450    S QUIT=0
  33451   "RTN","RCD PRLIS",266 ,0)
  33452    F  D  I Q UIT Q
  33453   "RTN","RCD PRLIS",267 ,0)
  33454    . W !
  33455   "RTN","RCD PRLIS",268 ,0)
  33456    . D ^DIR
  33457   "RTN","RCD PRLIS",269 ,0)
  33458    . I $D(DT OUT)!$D(DU OUT) K RET URN S RETU RN=-1,QUIT =1 Q
  33459   "RTN","RCD PRLIS",270 ,0)
  33460    . I Y=""  S QUIT=1 Q
  33461   "RTN","RCD PRLIS",271 ,0)
  33462    . S RETUR N(Y(0))=""
  33463   "RTN","RCD PRLIS",272 ,0)
  33464    . ; Rebui d DIR(0) t o only inc lude codes  not yet s elected
  33465   "RTN","RCD PRLIS",273 ,0)
  33466    . S DIR(0 )=$$BLDS(R CODES,.RET URN)
  33467   "RTN","RCD PRLIS",274 ,0)
  33468    . I $P(DI R(0),"^",2 )="" S QUI T=1 ; All  status sel ected so s top prompt ing.
  33469   "RTN","RCD PRLIS",275 ,0)
  33470    ;
  33471   "RTN","RCD PRLIS",276 ,0)
  33472    I RETURN= -1 Q
  33473   "RTN","RCD PRLIS",277 ,0)
  33474    ; If no p ayment typ es were se lected, do n't filter  by it.
  33475   "RTN","RCD PRLIS",278 ,0)
  33476    I $O(RETU RN(""))=""  D  ;
  33477   "RTN","RCD PRLIS",279 ,0)
  33478    . S RETUR N=0
  33479   "RTN","RCD PRLIS",280 ,0)
  33480    . W !!,"N o Payment  Types were  selected.  Filter wi ll not be  used",!
  33481   "RTN","RCD PRLIS",281 ,0)
  33482    Q
  33483   "RTN","RCD PRLIS",282 ,0)
  33484    ;
  33485   "RTN","RCD PRLIS",283 ,0)
  33486   BLDS(CODES ,PICKED) ;  Build DIR (0) string  taking in to account  codes alr eady picke d.
  33487   "RTN","RCD PRLIS",284 ,0)
  33488    ; Input:  CODES - Se t of codes  string in  fileman f ormat e.g.  A:Apple;B :Ball;
  33489   "RTN","RCD PRLIS",285 ,0)
  33490    ;         PICKED - A rray of va lues alrea dy picked,  subscript ed by exte rnal value  e.g. PICK ED("Apple" )=""
  33491   "RTN","RCD PRLIS",286 ,0)
  33492    ; Return:  RETURN in  DIR(0) fo rmat. Set  of codes t hat only i ncludes on es not pic ked.
  33493   "RTN","RCD PRLIS",287 ,0)
  33494    ;          e.g "SAO^ B:Ball"
  33495   "RTN","RCD PRLIS",288 ,0)
  33496    ; 
  33497   "RTN","RCD PRLIS",289 ,0)
  33498    N RETURN
  33499   "RTN","RCD PRLIS",290 ,0)
  33500    S RETURN= "SOA^"
  33501   "RTN","RCD PRLIS",291 ,0)
  33502    F J=1:1:$ L(CODES,"; ") D  ;
  33503   "RTN","RCD PRLIS",292 ,0)
  33504    . S X=$P( $P(CODES," ;",J),":", 2)
  33505   "RTN","RCD PRLIS",293 ,0)
  33506    . I X'="" ,'$D(PICKE D(X)) S RE TURN=RETUR N_$P(CODES ,";",J)_"; "
  33507   "RTN","RCD PRLIS",294 ,0)
  33508    Q RETURN
  33509   "RTN","RCD PRLIS",295 ,0)
  33510    ;
  33511   "RTN","RCD PRLIS",296 ,0)
  33512   HDR ; Comp ile header  into ^TMP  for use i n ListMan  or report
  33513   "RTN","RCD PRLIS",297 ,0)
  33514    ; Input:  None
  33515   "RTN","RCD PRLIS",298 ,0)
  33516    ; Output:  Header in formation  in ^TMP($J ,"RCDPRLIS ","HDR",n)  for us in  report or  ListMan f ormats
  33517   "RTN","RCD PRLIS",299 ,0)
  33518    N K,XX
  33519   "RTN","RCD PRLIS",300 ,0)
  33520    S ^TMP($J ,"RCDPRLIS ","HDR",1) ="LIST OF  RECEIPTS R EPORT"
  33521   "RTN","RCD PRLIS",301 ,0)
  33522    s XX="  D ATE RANGE    : "_DATE DIS1_"  TO   "_DATEDI S2_"          "
  33523   "RTN","RCD PRLIS",302 ,0)
  33524    S XX=XX_" SORT ORDER : "_$S(RCS ORT="D":"D ATE OPENED ",RCSORT=" F":"FMS ST ATUS",1:"P AYMENT TYP E")
  33525   "RTN","RCD PRLIS",303 ,0)
  33526    S ^TMP($J ,"RCDPRLIS ","HDR",2) =XX
  33527   "RTN","RCD PRLIS",304 ,0)
  33528    ;
  33529   "RTN","RCD PRLIS",305 ,0)
  33530    I 'RCFILT F D  ;
  33531   "RTN","RCD PRLIS",306 ,0)
  33532    . S XX="A LL"
  33533   "RTN","RCD PRLIS",307 ,0)
  33534    E  D  ;
  33535   "RTN","RCD PRLIS",308 ,0)
  33536    . S XX=""
  33537   "RTN","RCD PRLIS",309 ,0)
  33538    . S K=""  F  S K=$O( RCFILTF(K) ) Q:K=""   S:XX'="" X X=XX_"; "  S XX=XX_K
  33539   "RTN","RCD PRLIS",310 ,0)
  33540    S ^TMP($J ,"RCDPRLIS ","HDR",3) ="  FMS ST ATUS   : " _$S($L(XX) >63:"SELEC TED",1:XX)
  33541   "RTN","RCD PRLIS",311 ,0)
  33542    ;
  33543   "RTN","RCD PRLIS",312 ,0)
  33544     I 'RCFIL TT D  ;
  33545   "RTN","RCD PRLIS",313 ,0)
  33546    . S XX="A LL"
  33547   "RTN","RCD PRLIS",314 ,0)
  33548    E  D  ;
  33549   "RTN","RCD PRLIS",315 ,0)
  33550    . S XX=""
  33551   "RTN","RCD PRLIS",316 ,0)
  33552    . S K=""  F  S K=$O( RCFILTT(K) ) Q:K=""   S:XX'="" X X=XX_"; "  S XX=XX_K
  33553   "RTN","RCD PRLIS",317 ,0)
  33554    S ^TMP($J ,"RCDPRLIS ","HDR",4) ="  PAYMEN T TYPES: " _$S($L(XX) >63:"SELEC TED",1:XX)
  33555   "RTN","RCD PRLIS",318 ,0)
  33556    S ^TMP($J ,"RCDPRLIS ","HDR",5) ="DATE      RECEIPT       TYPE      US COUN T       AM OUNT  FMS  CR DOC        STATUS"
  33557   "RTN","RCD PRLIS",319 ,0)
  33558    W !,RCRJL INE
  33559   "RTN","RCD PRLIS",320 ,0)
  33560    Q
  33561   "RTN","RCD PRLIS",321 ,0)
  33562    ;
  33563   "RTN","RCD PRLIS",322 ,0)
  33564   H ;  heade r
  33565   "RTN","RCD PRLIS",323 ,0)
  33566    N %
  33567   "RTN","RCD PRLIS",324 ,0)
  33568    S %=NOW_"   PAGE "_P AGE,PAGE=P AGE+1 I PA GE'=2!(SCR EEN) W @IO F
  33569   "RTN","RCD PRLIS",325 ,0)
  33570    W $C(13), ^TMP($J,"R CDPRLIS"," HDR",1),?( 80-$L(%)), %
  33571   "RTN","RCD PRLIS",326 ,0)
  33572    W !,^TMP( $J,"RCDPRL IS","HDR", 2)
  33573   "RTN","RCD PRLIS",327 ,0)
  33574    W !,^TMP( $J,"RCDPRL IS","HDR", 3)
  33575   "RTN","RCD PRLIS",328 ,0)
  33576    W !,^TMP( $J,"RCDPRL IS","HDR", 4)
  33577   "RTN","RCD PRLIS",329 ,0)
  33578    W !,^TMP( $J,"RCDPRL IS","HDR", 5)
  33579   "RTN","RCD PRLIS",330 ,0)
  33580    W !,RCRJL INE
  33581   "RTN","RCD PRLIS",331 ,0)
  33582    Q
  33583   "RTN","RCD PRPL1")
  33584   0^37^B3385 7605
  33585   "RTN","RCD PRPL1",1,0 )
  33586   RCDPRPL1 ; WISC/RFJ-r eceipt pro file listm anager opt ions ;1 Ju n 99
  33587   "RTN","RCD PRPL1",2,0 )
  33588    ;;4.5;Acc ounts Rece ivable;**1 14,321**;M ar 20, 199 5;Build 46
  33589   "RTN","RCD PRPL1",3,0 )
  33590    ;;Per VHA  Directive  10-93-142 , this rou tine shoul d not be m odified.
  33591   "RTN","RCD PRPL1",4,0 )
  33592    Q
  33593   "RTN","RCD PRPL1",5,0 )
  33594    ;
  33595   "RTN","RCD PRPL1",6,0 )
  33596    ;  this r outine con tains the  entry poin ts for pay ment trans actions
  33597   "RTN","RCD PRPL1",7,0 )
  33598    ;
  33599   "RTN","RCD PRPL1",8,0 )
  33600    ;
  33601   "RTN","RCD PRPL1",9,0 )
  33602   ENTRTRAN ;   option:  enter a pa yment tran saction
  33603   "RTN","RCD PRPL1",10, 0)
  33604    ;  this o ption can  only be se lected for  unapprove d receipts
  33605   "RTN","RCD PRPL1",11, 0)
  33606    ;  screen  placed in  protocol  file and b elow as ba ckup
  33607   "RTN","RCD PRPL1",12, 0)
  33608    D FULL^VA LM1
  33609   "RTN","RCD PRPL1",13, 0)
  33610    S VALMBCK ="R"
  33611   "RTN","RCD PRPL1",14, 0)
  33612    ;
  33613   "RTN","RCD PRPL1",15, 0)
  33614    I '$$LOCK REC^RCDPRP LU(RCRECTD A) Q
  33615   "RTN","RCD PRPL1",16, 0)
  33616    ;
  33617   "RTN","RCD PRPL1",17, 0)
  33618    N %,RCTRA NDA,RCTYPE
  33619   "RTN","RCD PRPL1",18, 0)
  33620    S RCTYPE= $P($G(^RC( 341.1,+$P( ^RCY(344,R CRECTDA,0) ,"^",4),0) ),"^",2)
  33621   "RTN","RCD PRPL1",19, 0)
  33622    ;
  33623   "RTN","RCD PRPL1",20, 0)
  33624    W !
  33625   "RTN","RCD PRPL1",21, 0)
  33626    W !,"                   Type of  payment:  ",$P($G(^R C(341.1,+$ P(^RCY(344 ,RCRECTDA, 0),"^",4), 0)),"^")
  33627   "RTN","RCD PRPL1",22, 0)
  33628    W !,"Addi ng a NEW p ayment tra nsaction:  "
  33629   "RTN","RCD PRPL1",23, 0)
  33630    S RCTRAND A=$$ADDTRA N^RCDPURET (RCRECTDA)
  33631   "RTN","RCD PRPL1",24, 0)
  33632    I 'RCTRAN DA D  Q
  33633   "RTN","RCD PRPL1",25, 0)
  33634    .   S VAL MSG="Unabl e to ADD a  new payme nt transac tion."
  33635   "RTN","RCD PRPL1",26, 0)
  33636    .   D WRI TE^RCDPRPL U(VALMSG)
  33637   "RTN","RCD PRPL1",27, 0)
  33638    .   L -^R CY(344,RCR ECTDA)
  33639   "RTN","RCD PRPL1",28, 0)
  33640    ;
  33641   "RTN","RCD PRPL1",29, 0)
  33642    W "# ",RC TRANDA
  33643   "RTN","RCD PRPL1",30, 0)
  33644    S %=$$EDI TTRAN^RCDP URET(RCREC TDA,RCTRAN DA)
  33645   "RTN","RCD PRPL1",31, 0)
  33646    I '% D  Q
  33647   "RTN","RCD PRPL1",32, 0)
  33648    .   S VAL MSG=%
  33649   "RTN","RCD PRPL1",33, 0)
  33650    .   D WRI TE^RCDPRPL U(VALMSG)
  33651   "RTN","RCD PRPL1",34, 0)
  33652    .   L -^R CY(344,RCR ECTDA)
  33653   "RTN","RCD PRPL1",35, 0)
  33654    ;
  33655   "RTN","RCD PRPL1",36, 0)
  33656    S VALMSG= "Transacti on # "_RCT RANDA_" ha s been ADD ED."
  33657   "RTN","RCD PRPL1",37, 0)
  33658    ;
  33659   "RTN","RCD PRPL1",38, 0)
  33660    D INIT^RC DPRPLM
  33661   "RTN","RCD PRPL1",39, 0)
  33662    L -^RCY(3 44,RCRECTD A)
  33663   "RTN","RCD PRPL1",40, 0)
  33664    Q
  33665   "RTN","RCD PRPL1",41, 0)
  33666    ;
  33667   "RTN","RCD PRPL1",42, 0)
  33668    ;
  33669   "RTN","RCD PRPL1",43, 0)
  33670   EDITTRAN ;   option:  edit a pay ment trans action
  33671   "RTN","RCD PRPL1",44, 0)
  33672    ;  this o ption can  only be se lected for  unapprove d receipts
  33673   "RTN","RCD PRPL1",45, 0)
  33674    ;  screen  placed in  protocol  file and b elow as ba ckup
  33675   "RTN","RCD PRPL1",46, 0)
  33676    D FULL^VA LM1
  33677   "RTN","RCD PRPL1",47, 0)
  33678    S VALMBCK ="R"
  33679   "RTN","RCD PRPL1",48, 0)
  33680    ;
  33681   "RTN","RCD PRPL1",49, 0)
  33682    N %,RCEEO B,RCTRANDA  ; prca*4. 5*321 - ad ded RCEEOB
  33683   "RTN","RCD PRPL1",50, 0)
  33684    ;  select  the payme nt transac tion
  33685   "RTN","RCD PRPL1",51, 0)
  33686    S RCTRAND A=$$SELPAY (RCRECTDA)  I RCTRAND A<1 Q
  33687   "RTN","RCD PRPL1",52, 0)
  33688    ;
  33689   "RTN","RCD PRPL1",53, 0)
  33690    I '$$LOCK REC^RCDPRP LU(RCRECTD A) Q
  33691   "RTN","RCD PRPL1",54, 0)
  33692    ;
  33693   "RTN","RCD PRPL1",55, 0)
  33694    ;  transa ction is c ancelled,  cannot edi t
  33695   "RTN","RCD PRPL1",56, 0)
  33696    I '$P(^RC Y(344,RCRE CTDA,1,RCT RANDA,0)," ^",4),$P($ G(^RCY(344 ,RCRECTDA, 1,RCTRANDA ,1)),"^")' ="" D  Q
  33697   "RTN","RCD PRPL1",57, 0)
  33698    .   S VAL MSG="Payme nt Transac tion "_RCT RANDA_" is  CANCELLED ."
  33699   "RTN","RCD PRPL1",58, 0)
  33700    .   D WRI TE^RCDPRPL U(VALMSG)
  33701   "RTN","RCD PRPL1",59, 0)
  33702    .   L -^R CY(344,RCR ECTDA)
  33703   "RTN","RCD PRPL1",60, 0)
  33704    ;
  33705   "RTN","RCD PRPL1",61, 0)
  33706    W !!,"Edi ting Payme nt: ",RCTR ANDA
  33707   "RTN","RCD PRPL1",62, 0)
  33708    S %=$$EDI TTRAN^RCDP URET(RCREC TDA,RCTRAN DA)
  33709   "RTN","RCD PRPL1",63, 0)
  33710    I '% S VA LMSG="Tran saction DE LETED." D  WRITE^RCDP RPLU(VALMS G)
  33711   "RTN","RCD PRPL1",64, 0)
  33712    ; BEGIN -  PRCA*4.5* 321
  33713   "RTN","RCD PRPL1",65, 0)
  33714    I % D
  33715   "RTN","RCD PRPL1",66, 0)
  33716    . ; Optio n to resto re suspens e EEOB
  33717   "RTN","RCD PRPL1",67, 0)
  33718    . S RCEEO B=$$EEOB^R CDPEM5(RCR ECTDA,RCTR ANDA)
  33719   "RTN","RCD PRPL1",68, 0)
  33720    . ; Updat e EEOB cla im number  and restor e to activ e status
  33721   "RTN","RCD PRPL1",69, 0)
  33722    . D:RCEEO B>0 RESTOR E^RCDPEM5( RCRECTDA,R CTRANDA,RC EEOB,"R")
  33723   "RTN","RCD PRPL1",70, 0)
  33724    ; END - P RCA*4.5*32 1
  33725   "RTN","RCD PRPL1",71, 0)
  33726    ;
  33727   "RTN","RCD PRPL1",72, 0)
  33728    D INIT^RC DPRPLM
  33729   "RTN","RCD PRPL1",73, 0)
  33730    L -^RCY(3 44,RCRECTD A)
  33731   "RTN","RCD PRPL1",74, 0)
  33732    Q
  33733   "RTN","RCD PRPL1",75, 0)
  33734    ;
  33735   "RTN","RCD PRPL1",76, 0)
  33736    ;
  33737   "RTN","RCD PRPL1",77, 0)
  33738   CANCTRAN ;   option:  cancel a t ransaction
  33739   "RTN","RCD PRPL1",78, 0)
  33740    ;  this o ption can  only be se lected for  unapprove d receipts
  33741   "RTN","RCD PRPL1",79, 0)
  33742    ;  screen  placed in  protocol  file and b elow as ba ckup
  33743   "RTN","RCD PRPL1",80, 0)
  33744    D FULL^VA LM1
  33745   "RTN","RCD PRPL1",81, 0)
  33746    S VALMBCK ="R"
  33747   "RTN","RCD PRPL1",82, 0)
  33748    ;
  33749   "RTN","RCD PRPL1",83, 0)
  33750    N RCTRAND A
  33751   "RTN","RCD PRPL1",84, 0)
  33752    ;  select  the payme nt transac tion
  33753   "RTN","RCD PRPL1",85, 0)
  33754    S RCTRAND A=$$SELPAY (RCRECTDA)  I RCTRAND A<1 Q
  33755   "RTN","RCD PRPL1",86, 0)
  33756    ;
  33757   "RTN","RCD PRPL1",87, 0)
  33758    I '$$LOCK REC^RCDPRP LU(RCRECTD A) Q
  33759   "RTN","RCD PRPL1",88, 0)
  33760    ;
  33761   "RTN","RCD PRPL1",89, 0)
  33762    ;  check  to see if  already ca ncelled
  33763   "RTN","RCD PRPL1",90, 0)
  33764    I $P($G(^ RCY(344,RC RECTDA,1,R CTRANDA,0) ),"^",4)=0 ,$P($G(^(1 )),"^")'=" " D  Q
  33765   "RTN","RCD PRPL1",91, 0)
  33766    .   S VAL MSG="Payme nt Transac tion "_RCT RANDA_" is  already C ANCELLED."
  33767   "RTN","RCD PRPL1",92, 0)
  33768    .   D WRI TE^RCDPRPL U(VALMSG)
  33769   "RTN","RCD PRPL1",93, 0)
  33770    .   L -^R CY(344,RCR ECTDA)
  33771   "RTN","RCD PRPL1",94, 0)
  33772    ;
  33773   "RTN","RCD PRPL1",95, 0)
  33774    ;  ask to  cancel
  33775   "RTN","RCD PRPL1",96, 0)
  33776    I $$ASKCA NC(RCTRAND A)=1 D
  33777   "RTN","RCD PRPL1",97, 0)
  33778    .   D CAN CTRAN^RCDP URET(RCREC TDA,RCTRAN DA)
  33779   "RTN","RCD PRPL1",98, 0)
  33780    .   S VAL MSG="Trans action # " _RCTRANDA_ " has been  CANCELLED "
  33781   "RTN","RCD PRPL1",99, 0)
  33782    ;
  33783   "RTN","RCD PRPL1",100 ,0)
  33784    D INIT^RC DPRPLM
  33785   "RTN","RCD PRPL1",101 ,0)
  33786    L -^RCY(3 44,RCRECTD A)
  33787   "RTN","RCD PRPL1",102 ,0)
  33788    Q
  33789   "RTN","RCD PRPL1",103 ,0)
  33790    ;
  33791   "RTN","RCD PRPL1",104 ,0)
  33792    ;
  33793   "RTN","RCD PRPL1",105 ,0)
  33794   MOVETRAN ;   move a t ransaction  from one  receipt to  another
  33795   "RTN","RCD PRPL1",106 ,0)
  33796    D FULL^VA LM1
  33797   "RTN","RCD PRPL1",107 ,0)
  33798    S VALMBCK ="R"
  33799   "RTN","RCD PRPL1",108 ,0)
  33800    ;
  33801   "RTN","RCD PRPL1",109 ,0)
  33802    N RCNEWRE C,RCNEWTRA ,RCTRANDA
  33803   "RTN","RCD PRPL1",110 ,0)
  33804    ;  select  the payme nt transac tion
  33805   "RTN","RCD PRPL1",111 ,0)
  33806    S RCTRAND A=$$SELPAY (RCRECTDA)  I RCTRAND A<1 Q
  33807   "RTN","RCD PRPL1",112 ,0)
  33808    ;
  33809   "RTN","RCD PRPL1",113 ,0)
  33810    I '$$LOCK REC^RCDPRP LU(RCRECTD A) Q
  33811   "RTN","RCD PRPL1",114 ,0)
  33812    ;
  33813   "RTN","RCD PRPL1",115 ,0)
  33814    ;  transa ction is c ancelled,  cannot edi t
  33815   "RTN","RCD PRPL1",116 ,0)
  33816    I '$P(^RC Y(344,RCRE CTDA,1,RCT RANDA,0)," ^",4),$P($ G(^RCY(344 ,RCRECTDA, 1,RCTRANDA ,1)),"^")' ="" D  Q
  33817   "RTN","RCD PRPL1",117 ,0)
  33818    .   S VAL MSG="Payme nt Transac tion "_RCT RANDA_" is  CANCELLED ."
  33819   "RTN","RCD PRPL1",118 ,0)
  33820    .   D WRI TE^RCDPRPL U(VALMSG)
  33821   "RTN","RCD PRPL1",119 ,0)
  33822    .   D UNL OCK
  33823   "RTN","RCD PRPL1",120 ,0)
  33824    ;
  33825   "RTN","RCD PRPL1",121 ,0)
  33826    ;  select  the recei pt to move  transacti on to (can  add new o ne)
  33827   "RTN","RCD PRPL1",122 ,0)
  33828    F  D  Q:R CNEWREC
  33829   "RTN","RCD PRPL1",123 ,0)
  33830    .   W !!, "Select th e RECEIPT  to move th e payment  transactio n #"_RCTRA NDA_" to:"
  33831   "RTN","RCD PRPL1",124 ,0)
  33832    .   S RCN EWREC=$$SE LRECT^RCDP UREC(1)
  33833   "RTN","RCD PRPL1",125 ,0)
  33834    .   I RCN EWREC<1 S  RCNEWREC=- 1 Q
  33835   "RTN","RCD PRPL1",126 ,0)
  33836    .   I RCN EWREC=RCRE CTDA W !," Cannot cop y transact ion to sam e receipt. " S RCNEWR EC=0 Q
  33837   "RTN","RCD PRPL1",127 ,0)
  33838    .   I '$$ CHECKREC^R CDPRPLU(RC NEWREC) W  !,"Cannot  copy to a  receipt wh ich is CLO SED." S RC NEWREC=0 Q
  33839   "RTN","RCD PRPL1",128 ,0)
  33840    I RCNEWRE C<1 D UNLO CK Q
  33841   "RTN","RCD PRPL1",129 ,0)
  33842    ;
  33843   "RTN","RCD PRPL1",130 ,0)
  33844    I '$$LOCK REC^RCDPRP LU(RCNEWRE C) D UNLOC K Q
  33845   "RTN","RCD PRPL1",131 ,0)
  33846    ;
  33847   "RTN","RCD PRPL1",132 ,0)
  33848    W !
  33849   "RTN","RCD PRPL1",133 ,0)
  33850    I $P($G(^ RCY(344,RC NEWREC,0)) ,"^",4)'=$ P(^RCY(344 ,RCRECTDA, 0),"^",4)  W !,"WARNI NG, receip t types of  payment a re not the  same type  of paymen t."
  33851   "RTN","RCD PRPL1",134 ,0)
  33852    ;
  33853   "RTN","RCD PRPL1",135 ,0)
  33854    I $$ASKMO VE(RCNEWRE C)'=1 D UN LOCK Q
  33855   "RTN","RCD PRPL1",136 ,0)
  33856    ;
  33857   "RTN","RCD PRPL1",137 ,0)
  33858    ;  MOVETR AN will ad d the new  transactio n, and all ow the use r to
  33859   "RTN","RCD PRPL1",138 ,0)
  33860    ;  edit t he data.   returns er ror messag e if not s uccessful  or
  33861   "RTN","RCD PRPL1",139 ,0)
  33862    ;  return s the tran saction nu mber.
  33863   "RTN","RCD PRPL1",140 ,0)
  33864    S RCNEWTR A=$$MOVETR AN^RCDPURE T(RCRECTDA ,RCTRANDA, RCNEWREC)
  33865   "RTN","RCD PRPL1",141 ,0)
  33866    I 'RCNEWT RA D  Q
  33867   "RTN","RCD PRPL1",142 ,0)
  33868    .   S VAL MSG=%
  33869   "RTN","RCD PRPL1",143 ,0)
  33870    .   D WRI TE^RCDPRPL U(VALMSG)
  33871   "RTN","RCD PRPL1",144 ,0)
  33872    .   D UNL OCK
  33873   "RTN","RCD PRPL1",145 ,0)
  33874    ;
  33875   "RTN","RCD PRPL1",146 ,0)
  33876    ;  delete  the trans action jus t moved
  33877   "RTN","RCD PRPL1",147 ,0)
  33878    D DELETRA N^RCDPURET (RCRECTDA, RCTRANDA)
  33879   "RTN","RCD PRPL1",148 ,0)
  33880    ;
  33881   "RTN","RCD PRPL1",149 ,0)
  33882    D INIT^RC DPRPLM
  33883   "RTN","RCD PRPL1",150 ,0)
  33884    S VALMSG= "Transacti on # "_RCT RANDA_" ha s been MOV ED/DELETED ."
  33885   "RTN","RCD PRPL1",151 ,0)
  33886    ;
  33887   "RTN","RCD PRPL1",152 ,0)
  33888   UNLOCK ;   unlock rec eipts
  33889   "RTN","RCD PRPL1",153 ,0)
  33890    L -^RCY(3 44,RCRECTD A)
  33891   "RTN","RCD PRPL1",154 ,0)
  33892    I $G(RCNE WREC)>0 L  -^RCY(344, RCNEWREC)
  33893   "RTN","RCD PRPL1",155 ,0)
  33894    Q
  33895   "RTN","RCD PRPL1",156 ,0)
  33896    ;
  33897   "RTN","RCD PRPL1",157 ,0)
  33898    ;
  33899   "RTN","RCD PRPL1",158 ,0)
  33900   SELPAY(RCR ECTDA) ;   select the  payment t ransaction  for the r eceipt (fr om listman ager optio ns)
  33901   "RTN","RCD PRPL1",159 ,0)
  33902    N RCTRAND A
  33903   "RTN","RCD PRPL1",160 ,0)
  33904    ;  if no  payments,  quit
  33905   "RTN","RCD PRPL1",161 ,0)
  33906    I '$O(^RC Y(344,RCRE CTDA,1,0))  S VALMSG= "There are  NO paymen ts." Q 0
  33907   "RTN","RCD PRPL1",162 ,0)
  33908    ;  if onl y one paym ent, selec t that one  automatic ally
  33909   "RTN","RCD PRPL1",163 ,0)
  33910    I $P($G(^ RCY(344,RC RECTDA,1,0 )),"^",4)= 1 S RCTRAN DA=$O(^RCY (344,RCREC TDA,1,0))
  33911   "RTN","RCD PRPL1",164 ,0)
  33912    ;  select  the payme nt transac tion
  33913   "RTN","RCD PRPL1",165 ,0)
  33914    I '$G(RCT RANDA) W !  S RCTRAND A=$$SELTRA N^RCDPURET (RCRECTDA)
  33915   "RTN","RCD PRPL1",166 ,0)
  33916    Q RCTRAND A
  33917   "RTN","RCD PRPL1",167 ,0)
  33918    ;
  33919   "RTN","RCD PRPL1",168 ,0)
  33920    ;
  33921   "RTN","RCD PRPL1",169 ,0)
  33922   ASKCANC(RC TRANDA) ;   ask if it 's okay to  cancel a  transactio n
  33923   "RTN","RCD PRPL1",170 ,0)
  33924    ;  1 is y es, otherw ise no
  33925   "RTN","RCD PRPL1",171 ,0)
  33926    N DIR,DIQ 2,DTOUT,DU OUT,X,Y
  33927   "RTN","RCD PRPL1",172 ,0)
  33928    S DIR(0)= "YO",DIR(" B")="NO"
  33929   "RTN","RCD PRPL1",173 ,0)
  33930    S DIR("A" )="  Are y ou sure yo u want to  CANCEL tra nsaction #  "_RCTRAND A
  33931   "RTN","RCD PRPL1",174 ,0)
  33932    W ! D ^DI R
  33933   "RTN","RCD PRPL1",175 ,0)
  33934    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  33935   "RTN","RCD PRPL1",176 ,0)
  33936    Q Y
  33937   "RTN","RCD PRPL1",177 ,0)
  33938    ;
  33939   "RTN","RCD PRPL1",178 ,0)
  33940    ;
  33941   "RTN","RCD PRPL1",179 ,0)
  33942   ASKMOVE(RE CTDA) ;  a sk if its  okay to mo ve the tra nsaction
  33943   "RTN","RCD PRPL1",180 ,0)
  33944    ;  1 is y es, otherw ise no
  33945   "RTN","RCD PRPL1",181 ,0)
  33946    N DIR,DIQ 2,DTOUT,DU OUT,X,Y
  33947   "RTN","RCD PRPL1",182 ,0)
  33948    S DIR(0)= "YO",DIR(" B")="NO"
  33949   "RTN","RCD PRPL1",183 ,0)
  33950    S DIR("A" )="  Are y ou sure yo u want to  MOVE this  payment to  receipt " _$P($G(^RC Y(344,RECT DA,0)),"^" )
  33951   "RTN","RCD PRPL1",184 ,0)
  33952    D ^DIR
  33953   "RTN","RCD PRPL1",185 ,0)
  33954    I $G(DTOU T)!($G(DUO UT)) S Y=- 1
  33955   "RTN","RCD PRPL1",186 ,0)
  33956    Q Y
  33957   "RTN","RCD PRPLM")
  33958   0^40^B9136 7884
  33959   "RTN","RCD PRPLM",1,0 )
  33960   RCDPRPLM ; ;WISC/RFJ- receipt pr ofile list manager to p routine  ;1 Jun 99
  33961   "RTN","RCD PRPLM",2,0 )
  33962    ;;4.5;Acc ounts Rece ivable;**1 14,148,149 ,173,196,2 20,217,321 **;Mar 20,  1995;Buil d 46
  33963   "RTN","RCD PRPLM",3,0 )
  33964    ;;Per VHA  Directive  10-93-142 , this rou tine shoul d not be m odified.
  33965   "RTN","RCD PRPLM",4,0 )
  33966    ;
  33967   "RTN","RCD PRPLM",5,0 )
  33968    N RCDPFXI T
  33969   "RTN","RCD PRPLM",6,0 )
  33970    ;
  33971   "RTN","RCD PRPLM",7,0 )
  33972   RECTPROF ;   entry po int called  by link p ayment to  prevent ne wing
  33973   "RTN","RCD PRPLM",8,0 )
  33974    ; fast ex it var RCD PFXIT
  33975   "RTN","RCD PRPLM",9,0 )
  33976    N RCRECTD A
  33977   "RTN","RCD PRPLM",10, 0)
  33978    ;
  33979   "RTN","RCD PRPLM",11, 0)
  33980    F  D  Q:' RCRECTDA
  33981   "RTN","RCD PRPLM",12, 0)
  33982    . W !! S  RCRECTDA=$ $SELRECT^R CDPUREC(1)   ;allow a dding new  receipt
  33983   "RTN","RCD PRPLM",13, 0)
  33984    . I RCREC TDA<1 S RC RECTDA=0 Q
  33985   "RTN","RCD PRPLM",14, 0)
  33986    . D EN^VA LM("RCDP R ECEIPT PRO FILE")
  33987   "RTN","RCD PRPLM",15, 0)
  33988    . ; fast  exit
  33989   "RTN","RCD PRPLM",16, 0)
  33990    . I $G(RC DPFXIT) S  RCRECTDA=0
  33991   "RTN","RCD PRPLM",17, 0)
  33992    Q
  33993   "RTN","RCD PRPLM",18, 0)
  33994    ;
  33995   "RTN","RCD PRPLM",19, 0)
  33996    ;
  33997   "RTN","RCD PRPLM",20, 0)
  33998   INIT ; ini t for list  manager
  33999   "RTN","RCD PRPLM",21, 0)
  34000    N DATE,FM SDOC,GECSD A1,GECSDAT A,RCCANCEL ,RCDPDATA, RCDPFCAN,R CLINE,RCTO TAL,RCTRDA ,SPACE,RCE FT,X,Z,Z0, RCZ,RCZ0,R CZ1,RCZ2,E FTFUND
  34001   "RTN","RCD PRPLM",22, 0)
  34002    K ^TMP("R CDPRPLM",$ J),^TMP("V ALM VIDEO" ,$J)
  34003   "RTN","RCD PRPLM",23, 0)
  34004    ;
  34005   "RTN","RCD PRPLM",24, 0)
  34006    ; fast ex it
  34007   "RTN","RCD PRPLM",25, 0)
  34008    I $G(RCDP FXIT) S VA LMQUIT=1 Q
  34009   "RTN","RCD PRPLM",26, 0)
  34010    ;
  34011   "RTN","RCD PRPLM",27, 0)
  34012    D DIQ344( RCRECTDA," .02:200")
  34013   "RTN","RCD PRPLM",28, 0)
  34014    ;
  34015   "RTN","RCD PRPLM",29, 0)
  34016    ; set lis tmanager l ine #
  34017   "RTN","RCD PRPLM",30, 0)
  34018    S RCLINE= 0
  34019   "RTN","RCD PRPLM",31, 0)
  34020    ;
  34021   "RTN","RCD PRPLM",32, 0)
  34022    K ^TMP($J ,"RCEFT")
  34023   "RTN","RCD PRPLM",33, 0)
  34024    S EFTFUND =$S(DT<$$A DDPTEDT^PR CAACC():"5 287.4/8NZZ  ",1:"5287 04/8NZZ ")
  34025   "RTN","RCD PRPLM",34, 0)
  34026    S RCEFT=+ $O(^RCY(34 4.3,"ARDEP ",+$P($G(^ RCY(344,RC RECTDA,0)) ,U,6),0))
  34027   "RTN","RCD PRPLM",35, 0)
  34028    I RCEFT D
  34029   "RTN","RCD PRPLM",36, 0)
  34030    . S Z=0 F   S Z=$O(^ RCY(344.31 ,"B",RCEFT ,Z)) Q:'Z   S Z0=$G(^ RCY(344.31 ,+Z,0)) I  $P(Z0,U,14 ) S ^TMP($ J,"RCEFT", $P(Z0,U,14 ))=Z_U_$E( $P(Z0,U,2) ,1,12)
  34031   "RTN","RCD PRPLM",37, 0)
  34032    S RCTRDA= 0 F  S RCT RDA=$O(^RC Y(344,RCRE CTDA,1,RCT RDA)) Q:'R CTRDA  D
  34033   "RTN","RCD PRPLM",38, 0)
  34034    . D DIQ34 401(RCRECT DA,RCTRDA)
  34035   "RTN","RCD PRPLM",39, 0)
  34036    . S RCLIN E=RCLINE+1  D SET("", RCLINE,1,8 0,.01)
  34037   "RTN","RCD PRPLM",40, 0)
  34038    . ;check  for paymen t cancelle d
  34039   "RTN","RCD PRPLM",41, 0)
  34040    . S RCCAN CEL=0
  34041   "RTN","RCD PRPLM",42, 0)
  34042    . I $P($G (^RCY(344, RCRECTDA,1 ,RCTRDA,0) ),"^",4)=0 ,$P($G(^(1 )),"^")'=" " D
  34043   "RTN","RCD PRPLM",43, 0)
  34044    . . S RCC ANCEL=1,RC DPFCAN=1
  34045   "RTN","RCD PRPLM",44, 0)
  34046    . . D SET ("**",RCLI NE,5,6)
  34047   "RTN","RCD PRPLM",45, 0)
  34048    . ;accoun t
  34049   "RTN","RCD PRPLM",46, 0)
  34050    . I $G(RC DPDATA(344 .01,RCTRDA ,.03,"E")) ="" D
  34051   "RTN","RCD PRPLM",47, 0)
  34052    . . S RCD PDATA(344. 01,RCTRDA, .03,"E")=" [ "_$S(RCE FT:EFTFUND _$P($G(^TM P($J,"RCEF T",RCTRDA) ),U,2),1:" suspense"_ $$GETUNAPP ^RCXFMSCR( RCRECTDA,R CTRDA,0))_ " ]"
  34053   "RTN","RCD PRPLM",48, 0)
  34054    . D SET(" ",RCLINE,7 ,33,.03)
  34055   "RTN","RCD PRPLM",49, 0)
  34056    . ;date o f payment
  34057   "RTN","RCD PRPLM",50, 0)
  34058    . I RCDPD ATA(344.01 ,RCTRDA,.0 6,"I") D
  34059   "RTN","RCD PRPLM",51, 0)
  34060    . . D SET ($E(RCDPDA TA(344.01, RCTRDA,.06 ,"I"),4,5) _"/"_$E(RC DPDATA(344 .01,RCTRDA ,.06,"I"), 6,7)_"/"_$ E(RCDPDATA (344.01,RC TRDA,.06," I"),2,3),R CLINE,35,4 2)
  34061   "RTN","RCD PRPLM",52, 0)
  34062    . ;entere d by
  34063   "RTN","RCD PRPLM",53, 0)
  34064    . I RCDPD ATA(344.01 ,RCTRDA,.1 2,"E")'=""  D
  34065   "RTN","RCD PRPLM",54, 0)
  34066    . . S X=$ E($P(RCDPD ATA(344.01 ,RCTRDA,.1 2,"E"),"," ,2))_$E(RC DPDATA(344 .01,RCTRDA ,.12,"E"))
  34067   "RTN","RCD PRPLM",55, 0)
  34068    . . I RCD PDATA(344. 01,RCTRDA, .12,"I")=. 5 S X="ar"
  34069   "RTN","RCD PRPLM",56, 0)
  34070    . . D SET (X,RCLINE, 45,46)
  34071   "RTN","RCD PRPLM",57, 0)
  34072    . I RCDPD ATA(344.01 ,RCTRDA,.1 4,"E")'=""  D
  34073   "RTN","RCD PRPLM",58, 0)
  34074    . . S X=$ E($P(RCDPD ATA(344.01 ,RCTRDA,.1 4,"E"),"," ,2))_$E(RC DPDATA(344 .01,RCTRDA ,.14,"E"))
  34075   "RTN","RCD PRPLM",59, 0)
  34076    . . D SET (X,RCLINE, 54,55)
  34077   "RTN","RCD PRPLM",60, 0)
  34078    . D SET($ J(RCDPDATA (344.01,RC TRDA,.04," E"),8,2),R CLINE,62,7 0)
  34079   "RTN","RCD PRPLM",61, 0)
  34080    . D SET($ J(RCDPDATA (344.01,RC TRDA,.05," E"),8,2),R CLINE,72,8 0)
  34081   "RTN","RCD PRPLM",62, 0)
  34082    . ;
  34083   "RTN","RCD PRPLM",63, 0)
  34084    . ;if not  processed , show if  amount > b ill
  34085   "RTN","RCD PRPLM",64, 0)
  34086    . S X=$$C HECKPAY^RC DPRPL3(RCR ECTDA,RCTR DA) I X D
  34087   "RTN","RCD PRPLM",65, 0)
  34088    . . S RCL INE=RCLINE +1
  34089   "RTN","RCD PRPLM",66, 0)
  34090    . . D SET ("  WARNIN G: Pending  Payments  ($ "_$J($P (X,"^",3), 0,2)_") ex ceed amoun t billed ( $ "_$J($P( X,"^",2),0 ,2)_")",RC LINE,1,80)
  34091   "RTN","RCD PRPLM",67, 0)
  34092    . ;
  34093   "RTN","RCD PRPLM",68, 0)
  34094    . ;show l ine 2 for  check/cred it payment
  34095   "RTN","RCD PRPLM",69, 0)
  34096    . I $$OPT CK^RCDPRPL 2("SHOWCHE CK",2) D
  34097   "RTN","RCD PRPLM",70, 0)
  34098    . . ;rece ipt type o f payment  is check
  34099   "RTN","RCD PRPLM",71, 0)
  34100    . . I RCD PDATA(344, RCRECTDA,. 04,"I")=4! (RCDPDATA( 344,RCRECT DA,.04,"I" )=12) D  Q
  34101   "RTN","RCD PRPLM",72, 0)
  34102    . . . S R CLINE=RCLI NE+1
  34103   "RTN","RCD PRPLM",73, 0)
  34104    . . . D S ET("       Check #",R CLINE,1,80 ,.07)
  34105   "RTN","RCD PRPLM",74, 0)
  34106    . . . I ' RCDPDATA(3 44.01,RCTR DA,.1,"I")  S RCDPDAT A(344.01,R CTRDA,.1," I")="????? ??"
  34107   "RTN","RCD PRPLM",75, 0)
  34108    . . . D S ET("Date:  "_$E(RCDPD ATA(344.01 ,RCTRDA,.1 ,"I"),4,5) _"/"_$E(RC DPDATA(344 .01,RCTRDA ,.1,"I"),6 ,7)_"/"_$E (RCDPDATA( 344.01,RCT RDA,.1,"I" ),2,3),RCL INE,32,80)
  34109   "RTN","RCD PRPLM",76, 0)
  34110    . . . D S ET("Bank # ",RCLINE,4 7,80,.08)
  34111   "RTN","RCD PRPLM",77, 0)
  34112    . . ;rece ipt type o f payment  is credit
  34113   "RTN","RCD PRPLM",78, 0)
  34114    . . I RCD PDATA(344, RCRECTDA,. 04,"I")=7  D
  34115   "RTN","RCD PRPLM",79, 0)
  34116    . . . S R CLINE=RCLI NE+1
  34117   "RTN","RCD PRPLM",80, 0)
  34118    . . . D S ET("       Card #",RC LINE,1,80, .11)
  34119   "RTN","RCD PRPLM",81, 0)
  34120    . . . D S ET("Confir mation #", RCLINE,35, 80,.02)
  34121   "RTN","RCD PRPLM",82, 0)
  34122    . ;
  34123   "RTN","RCD PRPLM",83, 0)
  34124    . ;show l ine 3 for  acct looku p, batch a nd seq #
  34125   "RTN","RCD PRPLM",84, 0)
  34126    . I $$OPT CK^RCDPRPL 2("SHOWACC T",2) D
  34127   "RTN","RCD PRPLM",85, 0)
  34128    . . I RCD PDATA(344. 01,RCTRDA, .21,"E")=" ",RCDPDATA (344.01,RC TRDA,.22," E")="",RCD PDATA(344. 01,RCTRDA, .23,"E")=" " Q
  34129   "RTN","RCD PRPLM",86, 0)
  34130    . . S RCL INE=RCLINE +1
  34131   "RTN","RCD PRPLM",87, 0)
  34132    . . D SET ("      Ac ctLU",RCLI NE,1,80,.2 1)
  34133   "RTN","RCD PRPLM",88, 0)
  34134    . . D SET ("Batch/Se quence: "_ RCDPDATA(3 44.01,RCTR DA,.22,"E" )_"/"_RCDP DATA(344.0 1,RCTRDA,. 23,"E"),RC LINE,37,80 )
  34135   "RTN","RCD PRPLM",89, 0)
  34136    . ;
  34137   "RTN","RCD PRPLM",90, 0)
  34138    . ;show i f posting  error
  34139   "RTN","RCD PRPLM",91, 0)
  34140    . I $$OPT CK^RCDPRPL 2("SHOWCOM MENTS",2), RCDPDATA(3 44.01,RCTR DA,1.01,"E ")'="" D
  34141   "RTN","RCD PRPLM",92, 0)
  34142    . . S RCL INE=RCLINE +1
  34143   "RTN","RCD PRPLM",93, 0)
  34144    . . S X=" Posting Er ror"
  34145   "RTN","RCD PRPLM",94, 0)
  34146    . . I RCC ANCEL S X= "Cancel Da ta"
  34147   "RTN","RCD PRPLM",95, 0)
  34148    . . D SET ("      "_ X,RCLINE,1 ,80,1.01)
  34149   "RTN","RCD PRPLM",96, 0)
  34150    . ;
  34151   "RTN","RCD PRPLM",97, 0)
  34152    . ;show i f comment
  34153   "RTN","RCD PRPLM",98, 0)
  34154    . I $$OPT CK^RCDPRPL 2("SHOWCOM MENTS",2), RCDPDATA(3 44.01,RCTR DA,1.02,"E ")'="" D
  34155   "RTN","RCD PRPLM",99, 0)
  34156    . . S RCL INE=RCLINE +1
  34157   "RTN","RCD PRPLM",100 ,0)
  34158    . . D SET ("      Co mment",RCL INE,1,80,1 .02)
  34159   "RTN","RCD PRPLM",101 ,0)
  34160    . ;
  34161   "RTN","RCD PRPLM",102 ,0)
  34162    . ;if EDI  Lockbox p ending adj ustments,  show it
  34163   "RTN","RCD PRPLM",103 ,0)
  34164    . I $P($G (^RCY(344, RCRECTDA,0 )),U,18),$ G(RCDPDATA (344.01,RC TRDA,.27," E")) D
  34165   "RTN","RCD PRPLM",104 ,0)
  34166    . . S RCZ =$P(^RCY(3 44,RCRECTD A,0),U,18) ,RCZ0=RCDP DATA(344.0 1,RCTRDA,. 27,"E")
  34167   "RTN","RCD PRPLM",105 ,0)
  34168    . . S RCZ 1=0 F  S R CZ1=$O(^RC Y(344.49,R CZ,1,RCZ0, 1,RCZ1)) Q :'RCZ1  S  RCZ2=$G(^( RCZ1,0)) I  $P(RCZ2,U ,5)'="","1 2"[$P(RCZ2 ,U,5),'$P( RCZ2,U,8)  D
  34169   "RTN","RCD PRPLM",106 ,0)
  34170    . . . I $ P(RCZ2,U,5 )=1 S RCLI NE=RCLINE+ 1 D SET("       Pendi ng decreas e adjustme nt for "_$ J($P(RCZ2, U,3),"",2) ,RCLINE,1, 80) Q
  34171   "RTN","RCD PRPLM",107 ,0)
  34172    . . . I $ $OPTCK^RCD PRPL2("SHO WCOMMENTS" ,2),$P(RCZ 2,U,5)=2 S  RCLINE=RC LINE+1 D S ET("       Comment: " _$P(RCZ2,U ,9),RCLINE ,1,80) Q
  34173   "RTN","RCD PRPLM",108 ,0)
  34174    . ;
  34175   "RTN","RCD PRPLM",109 ,0)
  34176    . ;calcul ate totals
  34177   "RTN","RCD PRPLM",110 ,0)
  34178    . S RCTOT AL(1)=$G(R CTOTAL(1)) +RCDPDATA( 344.01,RCT RDA,.04,"E ")
  34179   "RTN","RCD PRPLM",111 ,0)
  34180    . S RCTOT AL(2)=$G(R CTOTAL(2)) +RCDPDATA( 344.01,RCT RDA,.05,"E ")
  34181   "RTN","RCD PRPLM",112 ,0)
  34182    . ;
  34183   "RTN","RCD PRPLM",113 ,0)
  34184    . ;kill l ocal varia ble to pre vent store  errors
  34185   "RTN","RCD PRPLM",114 ,0)
  34186    . K RCDPD ATA(344.01 ,RCTRDA)
  34187   "RTN","RCD PRPLM",115 ,0)
  34188    ;
  34189   "RTN","RCD PRPLM",116 ,0)
  34190    ; show to tals
  34191   "RTN","RCD PRPLM",117 ,0)
  34192    K ^TMP($J ,"RCEFT")
  34193   "RTN","RCD PRPLM",118 ,0)
  34194    S RCLINE= RCLINE+1 D  SET("",RC LINE,1,80)
  34195   "RTN","RCD PRPLM",119 ,0)
  34196    D SET("-- ------  -- ------",RC LINE,62,80 )
  34197   "RTN","RCD PRPLM",120 ,0)
  34198    S RCLINE= RCLINE+1
  34199   "RTN","RCD PRPLM",121 ,0)
  34200    D SET("       TOTAL  DOLLARS FO R RECEIPT" ,RCLINE,1, 80)
  34201   "RTN","RCD PRPLM",122 ,0)
  34202    D SET($J( $G(RCTOTAL (1)),8,2), RCLINE,62, 70)
  34203   "RTN","RCD PRPLM",123 ,0)
  34204    D SET($J( $G(RCTOTAL (2)),8,2), RCLINE,72, 80)
  34205   "RTN","RCD PRPLM",124 ,0)
  34206    ; show ca ncelled
  34207   "RTN","RCD PRPLM",125 ,0)
  34208    I $G(RCDP FCAN) D
  34209   "RTN","RCD PRPLM",126 ,0)
  34210    . S RCLIN E=RCLINE+1
  34211   "RTN","RCD PRPLM",127 ,0)
  34212    . D SET(" **indicate s payment  is CANCELL ED",RCLINE ,5,80)
  34213   "RTN","RCD PRPLM",128 ,0)
  34214    ;
  34215   "RTN","RCD PRPLM",129 ,0)
  34216    ; show hi story
  34217   "RTN","RCD PRPLM",130 ,0)
  34218    S RCLINE= RCLINE+1
  34219   "RTN","RCD PRPLM",131 ,0)
  34220    D SET(" " ,RCLINE,1, 80)
  34221   "RTN","RCD PRPLM",132 ,0)
  34222    ; start h istory on  first line  of a scre en if it d oes not fi t on
  34223   "RTN","RCD PRPLM",133 ,0)
  34224    ; current  screen
  34225   "RTN","RCD PRPLM",134 ,0)
  34226    I (RCLINE #12)>8 F S PACE=(RCLI NE#12):1:1 2 S RCLINE =RCLINE+1  D SET(" ", RCLINE,1,8 0)
  34227   "RTN","RCD PRPLM",135 ,0)
  34228    S RCLINE= RCLINE+1
  34229   "RTN","RCD PRPLM",136 ,0)
  34230    D SET("Re ceipt Hist ory",RCLIN E,1,80,0,I OUON,IOUOF F)
  34231   "RTN","RCD PRPLM",137 ,0)
  34232    S DATE=RC DPDATA(344 ,RCRECTDA, .03,"E"),D ATE=$P(DAT E,"@")_"   "_$P($P(DA TE,"@",2), ":",1,2)
  34233   "RTN","RCD PRPLM",138 ,0)
  34234    S RCLINE= RCLINE+1
  34235   "RTN","RCD PRPLM",139 ,0)
  34236    S SPACE=" ",$P(SPACE ," ",80)=" "
  34237   "RTN","RCD PRPLM",140 ,0)
  34238    I RCDPDAT A(344,RCRE CTDA,.02," I")=.5 S R CDPDATA(34 4,RCRECTDA ,.02,"E")= "accounts  receivable "
  34239   "RTN","RCD PRPLM",141 ,0)
  34240    D SET($E( "   Opened  By: "_RCD PDATA(344, RCRECTDA,. 02,"E")_SP ACE,1,39)_ "Date/Time     Opened : "_DATE,R CLINE,1,80 )
  34241   "RTN","RCD PRPLM",142 ,0)
  34242    S DATE=RC DPDATA(344 ,RCRECTDA, .12,"E"),D ATE=$P(DAT E,"@")_"   "_$P($P(DA TE,"@",2), ":",1,2)
  34243   "RTN","RCD PRPLM",143 ,0)
  34244    S RCLINE= RCLINE+1
  34245   "RTN","RCD PRPLM",144 ,0)
  34246    I RCDPDAT A(344,RCRE CTDA,.11," I")=.5 S R CDPDATA(34 4,RCRECTDA ,.11,"E")= "accounts  receivable "
  34247   "RTN","RCD PRPLM",145 ,0)
  34248    D SET($E( "Last Edit  By: "_RCD PDATA(344, RCRECTDA,. 11,"E")_SP ACE,1,39)_ "Date/Time  Last Edit : "_DATE,R CLINE,1,80 )
  34249   "RTN","RCD PRPLM",146 ,0)
  34250    S DATE=RC DPDATA(344 ,RCRECTDA, .08,"E"),D ATE=$P(DAT E,"@")_"   "_$P($P(DA TE,"@",2), ":",1,2)
  34251   "RTN","RCD PRPLM",147 ,0)
  34252    S RCLINE= RCLINE+1
  34253   "RTN","RCD PRPLM",148 ,0)
  34254    I RCDPDAT A(344,RCRE CTDA,.07," I")=.5 S R CDPDATA(34 4,RCRECTDA ,.07,"E")= "accounts  receivable "
  34255   "RTN","RCD PRPLM",149 ,0)
  34256    D SET($E( "Processed  By: "_RCD PDATA(344, RCRECTDA,. 07,"E")_SP ACE,1,39)_ "Date/Time  Processed : "_DATE,R CLINE,1,80 )
  34257   "RTN","RCD PRPLM",150 ,0)
  34258    ;
  34259   "RTN","RCD PRPLM",151 ,0)
  34260    ;show fms  code shee ts if swit ch on
  34261   "RTN","RCD PRPLM",152 ,0)
  34262    I $$OPTCK ^RCDPRPL2( "SHOWFMS", 2) D
  34263   "RTN","RCD PRPLM",153 ,0)
  34264    . S FMSDO C=$$FMSSTA T^RCDPUREC (RCRECTDA)
  34265   "RTN","RCD PRPLM",154 ,0)
  34266    . S RCLIN E=RCLINE+1  D SET(" " ,RCLINE,1, 80)
  34267   "RTN","RCD PRPLM",155 ,0)
  34268    . S RCLIN E=RCLINE+1  D SET("FM S Cash Rec eipt Docum ent:",RCLI NE,1,80,0, IOUON,IOUO FF)
  34269   "RTN","RCD PRPLM",156 ,0)
  34270    . D SET($ P(FMSDOC," ^")_$S($P( FMSDOC,"^" ,3):"(on d eposit)",1 :""),RCLIN E,28,80)
  34271   "RTN","RCD PRPLM",157 ,0)
  34272    . D SET(" Status: "_ $P(FMSDOC, "^",2),RCL INE,55,80)
  34273   "RTN","RCD PRPLM",158 ,0)
  34274    . N DIQ2  D DATA^GEC SSGET($P(F MSDOC,"^") ,1)
  34275   "RTN","RCD PRPLM",159 ,0)
  34276    . I '$G(G ECSDATA) Q
  34277   "RTN","RCD PRPLM",160 ,0)
  34278    . S GECSD A1=0 F  S  GECSDA1=$O (GECSDATA( 2100.1,GEC SDATA,10,G ECSDA1)) Q :'GECSDA1   D
  34279   "RTN","RCD PRPLM",161 ,0)
  34280    . . S RCL INE=RCLINE +1 D SET(G ECSDATA(21 00.1,GECSD ATA,10,GEC SDA1),RCLI NE,1,80)
  34281   "RTN","RCD PRPLM",162 ,0)
  34282    ;
  34283   "RTN","RCD PRPLM",163 ,0)
  34284    ; show EE OB detail  if switch  on
  34285   "RTN","RCD PRPLM",164 ,0)
  34286    D SHEOB^R CDPRPL2
  34287   "RTN","RCD PRPLM",165 ,0)
  34288    ;
  34289   "RTN","RCD PRPLM",166 ,0)
  34290    ; set val mcnt to #  of lines i n list
  34291   "RTN","RCD PRPLM",167 ,0)
  34292    S VALMCNT =RCLINE
  34293   "RTN","RCD PRPLM",168 ,0)
  34294    D HDR
  34295   "RTN","RCD PRPLM",169 ,0)
  34296    Q
  34297   "RTN","RCD PRPLM",170 ,0)
  34298    ;
  34299   "RTN","RCD PRPLM",171 ,0)
  34300    ;
  34301   "RTN","RCD PRPLM",172 ,0)
  34302   SET(STRING ,LINE,COLB EG,COLEND, FIELD,ON,O FF) ;  set  array
  34303   "RTN","RCD PRPLM",173 ,0)
  34304    I $G(FIEL D) S STRIN G=STRING_$ S(STRING=" ":"",1:":  ")_$G(RCDP DATA(344.0 1,RCTRDA,F IELD,"E"))
  34305   "RTN","RCD PRPLM",174 ,0)
  34306    I STRING= "",'$G(FIE LD) D SET^ VALM10(LIN E,$J("",80 )) Q
  34307   "RTN","RCD PRPLM",175 ,0)
  34308    I '$D(@VA LMAR@(LINE ,0)) D SET ^VALM10(LI NE,$J("",8 0))
  34309   "RTN","RCD PRPLM",176 ,0)
  34310    D SET^VAL M10(LINE,$ $SETSTR^VA LM1(STRING ,@VALMAR@( LINE,0),CO LBEG,COLEN D-COLBEG+1 ))
  34311   "RTN","RCD PRPLM",177 ,0)
  34312    I $G(ON)] ""!($G(OFF )]"") D CN TRL^VALM10 (LINE,COLB EG,$L(STRI NG),ON,OFF )
  34313   "RTN","RCD PRPLM",178 ,0)
  34314    Q
  34315   "RTN","RCD PRPLM",179 ,0)
  34316    ;
  34317   "RTN","RCD PRPLM",180 ,0)
  34318    ;
  34319   "RTN","RCD PRPLM",181 ,0)
  34320   DIQ344(DA, DR) ; retr ieves data  for flds  in file 34 4
  34321   "RTN","RCD PRPLM",182 ,0)
  34322    N %I,D0,D IC,DIQ,DIQ 2,YY
  34323   "RTN","RCD PRPLM",183 ,0)
  34324    K RCDPDAT A(344,DA)
  34325   "RTN","RCD PRPLM",184 ,0)
  34326    S DIQ(0)= "IE",DIC=" ^RCY(344," ,DIQ="RCDP DATA" D EN ^DIQ1
  34327   "RTN","RCD PRPLM",185 ,0)
  34328    Q
  34329   "RTN","RCD PRPLM",186 ,0)
  34330    ;
  34331   "RTN","RCD PRPLM",187 ,0)
  34332    ;
  34333   "RTN","RCD PRPLM",188 ,0)
  34334   DIQ34401(D A,SUBDA) ;  retrieves  data for  flds in fi le 344
  34335   "RTN","RCD PRPLM",189 ,0)
  34336    ; da = re ceipt da
  34337   "RTN","RCD PRPLM",190 ,0)
  34338    N %I,D0,D IC,DIQ,DIQ 2,DR
  34339   "RTN","RCD PRPLM",191 ,0)
  34340    K RCDPDAT A(344.01,S UBDA)
  34341   "RTN","RCD PRPLM",192 ,0)
  34342    S DR=1,DR (344.01)=" .01:1.02", DA(344.01) =SUBDA
  34343   "RTN","RCD PRPLM",193 ,0)
  34344    S DIQ(0)= "IE",DIC=" ^RCY(344," ,DIQ="RCDP DATA" D EN ^DIQ1
  34345   "RTN","RCD PRPLM",194 ,0)
  34346    Q
  34347   "RTN","RCD PRPLM",195 ,0)
  34348    ;
  34349   "RTN","RCD PRPLM",196 ,0)
  34350    ;
  34351   "RTN","RCD PRPLM",197 ,0)
  34352   HDR ; head er code fo r list man ager displ ay
  34353   "RTN","RCD PRPLM",198 ,0)
  34354    N DATE,DE PIEN,EFTIE N,ERAIEN,F MSDOC,FMST TR,PAYER,R CDPDATA,RC EFT,SPACE, XX,Z
  34355   "RTN","RCD PRPLM",199 ,0)
  34356    D DIQ344( RCRECTDA," .01;.04;.0 6;.08;.14; .17;.18;")
  34357   "RTN","RCD PRPLM",200 ,0)
  34358    S SPACE=" ",$P(SPACE ," ",80)=" "
  34359   "RTN","RCD PRPLM",201 ,0)
  34360    ;
  34361   "RTN","RCD PRPLM",202 ,0)
  34362    ; PRCA*4. 5*321 - St art of mod ified code  block
  34363   "RTN","RCD PRPLM",203 ,0)
  34364    S XX=$E("    Receipt  #: "_RCDP DATA(344,R CRECTDA,.0 1,"E")_SPA CE,1,39)
  34365   "RTN","RCD PRPLM",204 ,0)
  34366    S XX=XX_" Type of Pa yment: "_R CDPDATA(34 4,RCRECTDA ,.04,"E")
  34367   "RTN","RCD PRPLM",205 ,0)
  34368    S VALMHDR (1)=XX
  34369   "RTN","RCD PRPLM",206 ,0)
  34370    ;
  34371   "RTN","RCD PRPLM",207 ,0)
  34372    S Z=RCDPD ATA(344,RC RECTDA,.06 ,"E")
  34373   "RTN","RCD PRPLM",208 ,0)
  34374    S DEPIEN= +$P($G(^RC Y(344,RCRE CTDA,0)),U ,6)
  34375   "RTN","RCD PRPLM",209 ,0)
  34376    S RCEFT=+ $O(^RCY(34 4.3,"ARDEP ",DEPIEN,0 ))
  34377   "RTN","RCD PRPLM",210 ,0)
  34378    S EFTIEN= RCDPDATA(3 44,RCRECTD A,.17,"I")
  34379   "RTN","RCD PRPLM",211 ,0)
  34380    S FMSDOC= $$FMSSTAT^ RCDPUREC(R CRECTDA)
  34381   "RTN","RCD PRPLM",212 ,0)
  34382    S FMSTTR= $S($P(FMSD OC,"-",1)= "TR":1,1:0 )
  34383   "RTN","RCD PRPLM",213 ,0)
  34384    S XX=""
  34385   "RTN","RCD PRPLM",214 ,0)
  34386    I 'RCEFT& 'EFTIEN D   ;
  34387   "RTN","RCD PRPLM",215 ,0)
  34388    . S XX="    Deposit  #: "_Z
  34389   "RTN","RCD PRPLM",216 ,0)
  34390    E  D  ;
  34391   "RTN","RCD PRPLM",217 ,0)
  34392    . I RCEFT  D  ;
  34393   "RTN","RCD PRPLM",218 ,0)
  34394    . . S XX= " EFT Depo sit: "_Z
  34395   "RTN","RCD PRPLM",219 ,0)
  34396    . E  D  ;
  34397   "RTN","RCD PRPLM",220 ,0)
  34398    . . ; PRC A*4.5*321  - Since EF T and ERA  are now di splayed on  their own  line, put  TIN/Payer  here 
  34399   "RTN","RCD PRPLM",221 ,0)
  34400    . . N TIN
  34401   "RTN","RCD PRPLM",222 ,0)
  34402    . . S PAY ER=$$GET1^ DIQ(344.31 ,EFTIEN_", ",.02,"E")
  34403   "RTN","RCD PRPLM",223 ,0)
  34404    . . S TIN =$$GET1^DI Q(344.31,E FTIEN_",", .03,"E")
  34405   "RTN","RCD PRPLM",224 ,0)
  34406    . . S XX= "   Payer:  "_TIN_"/" _PAYER
  34407   "RTN","RCD PRPLM",225 ,0)
  34408    S XX=$E(X X_SPACE,1, 39)
  34409   "RTN","RCD PRPLM",226 ,0)
  34410    S XX=XX_"  Receipt S tatus: "_R CDPDATA(34 4,RCRECTDA ,.14,"E")
  34411   "RTN","RCD PRPLM",227 ,0)
  34412    S VALMHDR (2)=XX
  34413   "RTN","RCD PRPLM",228 ,0)
  34414    ;
  34415   "RTN","RCD PRPLM",229 ,0)
  34416    S ERAIEN= RCDPDATA(3 44,RCRECTD A,.18,"I")
  34417   "RTN","RCD PRPLM",230 ,0)
  34418    S XX=""
  34419   "RTN","RCD PRPLM",231 ,0)
  34420    I FMSTTR! ERAIEN S X X="   ERA  #: "_RCDPD ATA(344,RC RECTDA,.18 ,"E")
  34421   "RTN","RCD PRPLM",232 ,0)
  34422    S XX=$E(X X_SPACE,1, 21)
  34423   "RTN","RCD PRPLM",233 ,0)
  34424    I FMSTTR! ERAIEN S X X=XX_"ERA  TTL: "_$J( $$GET1^DIQ (344.4,ERA IEN_",",.0 5,"E"),9)
  34425   "RTN","RCD PRPLM",234 ,0)
  34426    S XX=$E(X X_SPACE,1, 39)
  34427   "RTN","RCD PRPLM",235 ,0)
  34428    ; get fms  document  and status
  34429   "RTN","RCD PRPLM",236 ,0)
  34430    S XX=XX_"  FMS Docum ent: "_$TR ($P(FMSDOC ,"^")," ") _$S($P(FMS DOC,"^",3) :"(on depo sit)",1:"" )
  34431   "RTN","RCD PRPLM",237 ,0)
  34432    S VALMHDR (3)=XX
  34433   "RTN","RCD PRPLM",238 ,0)
  34434    ;
  34435   "RTN","RCD PRPLM",239 ,0)
  34436    S XX=""
  34437   "RTN","RCD PRPLM",240 ,0)
  34438    I FMSTTR! EFTIEN S X X="   EFT  #: "_RCDPD ATA(344,RC RECTDA,.17 ,"E")
  34439   "RTN","RCD PRPLM",241 ,0)
  34440    S XX=$E(X X_SPACE,1, 21)
  34441   "RTN","RCD PRPLM",242 ,0)
  34442    I FMSTTR! EFTIEN S X X=XX_"EFT  TTL: "_$J( $$GET1^DIQ (344.31,EF TIEN_",",. 07,"E"),9) _" "
  34443   "RTN","RCD PRPLM",243 ,0)
  34444    S XX=$E(X X_SPACE,1, 39)
  34445   "RTN","RCD PRPLM",244 ,0)
  34446    S XX=XX_"  FMS Doc S tatus: "_$ P(FMSDOC," ^",2)
  34447   "RTN","RCD PRPLM",245 ,0)
  34448    S VALMHDR (4)=XX
  34449   "RTN","RCD PRPLM",246 ,0)
  34450    ; PRCA*4. 5*321 - En d of modif ied code b lock
  34451   "RTN","RCD PRPLM",247 ,0)
  34452    ;
  34453   "RTN","RCD PRPLM",248 ,0)
  34454    I RCDPDAT A(344,RCRE CTDA,.08," I") S VALM SG="Receip t processe d on "_RCD PDATA(344, RCRECTDA,. 08,"E")
  34455   "RTN","RCD PRPLM",249 ,0)
  34456    Q
  34457   "RTN","RCD PRPLM",250 ,0)
  34458    ;
  34459   "RTN","RCD PRPLM",251 ,0)
  34460    ;
  34461   "RTN","RCD PRPLM",252 ,0)
  34462   EXIT ; exi t option/c lean up
  34463   "RTN","RCD PRPLM",253 ,0)
  34464    K ^TMP("R CDPRPLM",$ J)
  34465   "RTN","RCD PRPLM",254 ,0)
  34466    Q
  34467   "RTN","RCD PRU")
  34468   0^31^B1912 18781
  34469   "RTN","RCD PRU",1,0)
  34470   RCDPRU ;AL B/TJB - CA RC REPORT  ON PAYER O R CARC COD E ;9/15/14  3:00pm
  34471   "RTN","RCD PRU",2,0)
  34472    ;;4.5;Acc ounts Rece ivable;**3 03,321**;M ar 20, 199 5;Build 46
  34473   "RTN","RCD PRU",3,0)
  34474    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  34475   "RTN","RCD PRU",4,0)
  34476    Q
  34477   "RTN","RCD PRU",5,0)
  34478    ; PRCA*4. 5*303 - CA RC and Pay er report  utilities
  34479   "RTN","RCD PRU",6,0)
  34480    ; IA 594  - ACCOUNTS  RECEIVABL E CATEGORY  file (#43 0.2)
  34481   "RTN","RCD PRU",7,0)
  34482    ; IA 1077  - Using D IVISION^VA UTOMA to q uery for d ivision
  34483   "RTN","RCD PRU",8,0)
  34484    ; IA 1992  - BILL/CL AIMS file  (#399)
  34485   "RTN","RCD PRU",9,0)
  34486    ; IA 3820  - BILL/CL AIMS file  (#399)
  34487   "RTN","RCD PRU",10,0)
  34488    ; IA 3822  - RATE TY PE file (# 399.3)
  34489   "RTN","RCD PRU",11,0)
  34490    ; IA 4051  - EXPLANA TION OF BE NEFITS fil e (#361.1)
  34491   "RTN","RCD PRU",12,0)
  34492    ; IA 4996  - BILL/CL AIMS file  (#399)
  34493   "RTN","RCD PRU",13,0)
  34494    ;
  34495   "RTN","RCD PRU",14,0)
  34496   DISPTY() ;  function,  ask displ ay/output  type
  34497   "RTN","RCD PRU",15,0)
  34498            ;  processes  input fro m user
  34499   "RTN","RCD PRU",16,0)
  34500            ;  returns:  Output des tination ( 0=Display,  1=MS Exce l, -1=time out or '^)
  34501   "RTN","RCD PRU",17,0)
  34502    N DIR,DUO UT,DIRUT,X ,Y
  34503   "RTN","RCD PRU",18,0)
  34504    S DIR(0)= "YA",DIR(" A")="Expor t the repo rt to Micr osoft Exce l? (Y/N):  ",DIR("B") ="NO"
  34505   "RTN","RCD PRU",19,0)
  34506    D ^DIR
  34507   "RTN","RCD PRU",20,0)
  34508    I $D(DUOU T)!$D(DIRU T) S Y=-1
  34509   "RTN","RCD PRU",21,0)
  34510    Q Y
  34511   "RTN","RCD PRU",22,0)
  34512    ;
  34513   "RTN","RCD PRU",23,0)
  34514   INFO ; Use ful Info f or Excel c apture
  34515   "RTN","RCD PRU",24,0)
  34516    N SP S SP =$J(" ",10 )  ; space s
  34517   "RTN","RCD PRU",25,0)
  34518    W !!!,SP_ "Before co ntinuing,  please set  up your t erminal to  capture t he"
  34519   "RTN","RCD PRU",26,0)
  34520    W !,SP_"r eport data  as this r eport may  take a whi le to run. "
  34521   "RTN","RCD PRU",27,0)
  34522    W !!,SP_" To avoid u ndesired w rapping of  the data  saved to t he"
  34523   "RTN","RCD PRU",28,0)
  34524    W !,SP_"f ile, pleas e enter '0 ;256;999'  at the 'DE VICE:' pro mpt."
  34525   "RTN","RCD PRU",29,0)
  34526    W !!,SP_" It may be  necessary  to set the  terminal' s display  width"
  34527   "RTN","RCD PRU",30,0)
  34528    W !,SP_"t o 256 char acters, wh ich can be  performed  by select ing the"
  34529   "RTN","RCD PRU",31,0)
  34530    W !,SP_"D isplay opt ion locate d within t he 'Setup'  menu on t he"
  34531   "RTN","RCD PRU",32,0)
  34532    W !,SP_"t ool bar of  the termi nal emulat ion softwa re (e.g. K EA,"
  34533   "RTN","RCD PRU",33,0)
  34534    W !,SP_"R eflection,  or Smarte rm).",!!
  34535   "RTN","RCD PRU",34,0)
  34536    Q
  34537   "RTN","RCD PRU",35,0)
  34538    ;
  34539   "RTN","RCD PRU",36,0)
  34540   ASK(RCSTOP ) ; User i f you want  to quit o r continue
  34541   "RTN","RCD PRU",37,0)
  34542    S RCSTOP= 0
  34543   "RTN","RCD PRU",38,0)
  34544    I $E(IOST ,1,2)'["C- " Q
  34545   "RTN","RCD PRU",39,0)
  34546    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  34547   "RTN","RCD PRU",40,0)
  34548    S DIR(0)= "E" W ! D  ^DIR
  34549   "RTN","RCD PRU",41,0)
  34550    I ($D(DIR UT))!($D(D UOUT)) S R CSTOP=1 Q
  34551   "RTN","RCD PRU",42,0)
  34552    Q
  34553   "RTN","RCD PRU",43,0)
  34554    ;
  34555   "RTN","RCD PRU",44,0)
  34556   UP(TEXT) ;  Translate  text to u pper case
  34557   "RTN","RCD PRU",45,0)
  34558    Q $$UP^XL FSTR($G(TE XT))
  34559   "RTN","RCD PRU",46,0)
  34560    ;
  34561   "RTN","RCD PRU",47,0)
  34562   DATE(X,F)  ; date in  external f ormat
  34563   "RTN","RCD PRU",48,0)
  34564    I $G(F)=" " S F="2Z"  ; set dat e to retur n mm/dd/yy  
  34565   "RTN","RCD PRU",49,0)
  34566    Q $$FMTE^ XLFDT(X,F)
  34567   "RTN","RCD PRU",50,0)
  34568    ;
  34569   "RTN","RCD PRU",51,0)
  34570   NOW(F) ; D ate/Time o f right no w in exter nal format
  34571   "RTN","RCD PRU",52,0)
  34572    S:$G(F)=" " F=1 ; Da te format  Mon dd, yy yy@hh:mm:s s see kern el documen tation
  34573   "RTN","RCD PRU",53,0)
  34574    Q $$FMTE^ XLFDT($$NO W^XLFDT,F)
  34575   "RTN","RCD PRU",54,0)
  34576    ;
  34577   "RTN","RCD PRU",55,0)
  34578   VAL(XF,COD E) ; Valid ate a rang e or list  of CARC (3 45), RARC  (346) or P LB (345.1)  Codes
  34579   "RTN","RCD PRU",56,0)
  34580    ; If inva lid code i s found VA ILD = 0 an d CODE wil l contain  the offend ing codes
  34581   "RTN","RCD PRU",57,0)
  34582    N VALID,E LEM,I,RNG1 ,RNG2,O1,O 2,NWCD,RET  S RET=""
  34583   "RTN","RCD PRU",58,0)
  34584    S VALID=1 ,NWCD=$TR( CODE,";"," :"),NWCD=$ TR(NWCD,"- ",":") ; F ix ";" or  "-" to ":"  (colons)  for parsin g
  34585   "RTN","RCD PRU",59,0)
  34586    F I=1:1 S  ELEM=$P(N WCD,",",I)  Q:ELEM=""   D
  34587   "RTN","RCD PRU",60,0)
  34588    .; Is thi s a single  code or r ange:
  34589   "RTN","RCD PRU",61,0)
  34590    .I $L(ELE M,":")>2 S  VALID=0,R ET=$$PUSH( .RET,ELEM)  Q
  34591   "RTN","RCD PRU",62,0)
  34592    .I ELEM[" :" D  Q  ;  Range
  34593   "RTN","RCD PRU",63,0)
  34594    ..S RNG1= $P(ELEM,": ",1),RNG2= $P(ELEM,": ",2)
  34595   "RTN","RCD PRU",64,0)
  34596    ..;Lookup  the codes
  34597   "RTN","RCD PRU",65,0)
  34598    ..S O1=$O (^RC(XF,"B ",RNG1),-1 ),O1=$O(^R C(XF,"B",O 1))
  34599   "RTN","RCD PRU",66,0)
  34600    ..S O2=$O (^RC(XF,"B ",RNG2),-1 ),O2=$O(^R C(XF,"B",O 2))
  34601   "RTN","RCD PRU",67,0)
  34602    ..I RNG1' =O1 S VALI D=0,RET=$$ PUSH(.RET, RNG1)
  34603   "RTN","RCD PRU",68,0)
  34604    ..I RNG2' =O2 S VALI D=0,RET=$$ PUSH(.RET, RNG2)
  34605   "RTN","RCD PRU",69,0)
  34606    .E  D
  34607   "RTN","RCD PRU",70,0)
  34608    ..;Valida te individ ual items
  34609   "RTN","RCD PRU",71,0)
  34610    ..S O1=$O (^RC(XF,"B ",ELEM),-1 ),O1=$O(^R C(XF,"B",O 1))
  34611   "RTN","RCD PRU",72,0)
  34612    ..I ELEM' =O1 S VALI D=0,RET=$$ PUSH(.RET, ELEM)
  34613   "RTN","RCD PRU",73,0)
  34614    ;
  34615   "RTN","RCD PRU",74,0)
  34616    S:VALID C ODE=NWCD
  34617   "RTN","RCD PRU",75,0)
  34618    S:'VALID  CODE=RET
  34619   "RTN","RCD PRU",76,0)
  34620    Q VALID
  34621   "RTN","RCD PRU",77,0)
  34622    ;
  34623   "RTN","RCD PRU",78,0)
  34624   ACT(XF,COD E,DATE) ;  Is the cod e active o n Date
  34625   "RTN","RCD PRU",79,0)
  34626    ; If code  is active  return 1.  If no dat e use toda y, date sh ould be in  fileman f ormat.
  34627   "RTN","RCD PRU",80,0)
  34628    N VALID,X IEN,XDT S  VALID=0
  34629   "RTN","RCD PRU",81,0)
  34630    I '$D(XF)  Q VALID   ; No file  return 0
  34631   "RTN","RCD PRU",82,0)
  34632    I $G(CODE )="" Q VAL ID  ; No c ode return  0
  34633   "RTN","RCD PRU",83,0)
  34634    S:'$D(DAT E) DATE=$$ DT^XLFDT
  34635   "RTN","RCD PRU",84,0)
  34636    S XIEN=$$ FIND1^DIC( XF,,"O",CO DE)
  34637   "RTN","RCD PRU",85,0)
  34638    I XIEN=""  Q VALID   ; No IEN f or this co de return  0
  34639   "RTN","RCD PRU",86,0)
  34640    S XDT=$$G ET1^DIQ(XF ,XIEN_",", 2,"I") ; G et date in  FM format
  34641   "RTN","RCD PRU",87,0)
  34642    S:XDT=""  VALID=1 ;  No stop da te so it i s active
  34643   "RTN","RCD PRU",88,0)
  34644    I (XDT'=" ")&(XDT>DA TE) S VALI D=1
  34645   "RTN","RCD PRU",89,0)
  34646    Q VALID
  34647   "RTN","RCD PRU",90,0)
  34648    ;
  34649   "RTN","RCD PRU",91,0)
  34650   PUSH(VAR,V ALUE) ;
  34651   "RTN","RCD PRU",92,0)
  34652    Q:VAR=""  VALUE ; Em pty variab le
  34653   "RTN","RCD PRU",93,0)
  34654    Q VAR_U_V ALUE
  34655   "RTN","RCD PRU",94,0)
  34656    ;
  34657   "RTN","RCD PRU",95,0)
  34658   RNG(TYPE,I TEM,ARRAY)  ; EP
  34659   "RTN","RCD PRU",96,0)
  34660    ; Collect  data in a  list or r ange to an  array
  34661   "RTN","RCD PRU",97,0)
  34662    ; Input:    TYPE             -  Type of da ta being c ollected
  34663   "RTN","RCD PRU",98,0)
  34664    ;                               CARC  - Ca rc codes
  34665   "RTN","RCD PRU",99,0)
  34666    ;                               PAYER - Pa yer names
  34667   "RTN","RCD PRU",100,0 )
  34668    ;                               PLB   - Pr ovider Lev el Balance  Codes
  34669   "RTN","RCD PRU",101,0 )
  34670    ;                               TIN   - Pa yer IDs
  34671   "RTN","RCD PRU",102,0 )
  34672    ;           ITEM             -  Comma deli mitted lis t of codes  and/or ra nges to pa rse
  34673   "RTN","RCD PRU",103,0 )
  34674    ; Output:   ARRAY            -  Array cont aining all  of the da ta parsed  from ITEM
  34675   "RTN","RCD PRU",104,0 )
  34676    I $G(ITEM )="ALL"!($ G(ITEM)="A ") S ARRAY (TYPE)="AL L" Q
  34677   "RTN","RCD PRU",105,0 )
  34678    N DELIM,E LEM,I,NW,X 1,X2
  34679   "RTN","RCD PRU",106,0 )
  34680    ;
  34681   "RTN","RCD PRU",107,0 )
  34682    ; Before  processing  CARC and  PLB Codes,  translate  any dashe s found in  ranges
  34683   "RTN","RCD PRU",108,0 )
  34684    ; to colo ns
  34685   "RTN","RCD PRU",109,0 )
  34686    I TYPE'=" PAYER",TYP E'="TIN" D
  34687   "RTN","RCD PRU",110,0 )
  34688    . S NW=$T R(ITEM,";" ,":"),NW=$ TR(NW,"-", ":"),DELIM =":"
  34689   "RTN","RCD PRU",111,0 )
  34690    E  D  ;
  34691   "RTN","RCD PRU",112,0 )
  34692    . S NW=IT EM
  34693   "RTN","RCD PRU",113,0 )
  34694    . S DELIM ="~:~"
  34695   "RTN","RCD PRU",114,0 )
  34696    ;
  34697   "RTN","RCD PRU",115,0 )
  34698    ; Process  each code  or range  int the co mma delimi tted list
  34699   "RTN","RCD PRU",116,0 )
  34700    F I=1:1 S  ELEM=$P(N W,",",I) Q :ELEM=""   D
  34701   "RTN","RCD PRU",117,0 )
  34702    . ; Singl e element  set into a rray 
  34703   "RTN","RCD PRU",118,0 )
  34704    . I ELEM' [DELIM S A RRAY(TYPE, ELEM)=1 Q
  34705   "RTN","RCD PRU",119,0 )
  34706    . D RNGIT (TYPE,ELEM ,DELIM,.AR RAY)
  34707   "RTN","RCD PRU",120,0 )
  34708    Q
  34709   "RTN","RCD PRU",121,0 )
  34710    ;
  34711   "RTN","RCD PRU",122,0 )
  34712   RNGIT(TYPE ,ITEM,DELI M,ZAR) ; P rocess ran ges for CA RC/PLB/PAY ER/TIN
  34713   "RTN","RCD PRU",123,0 )
  34714    ; Input:    TYPE             -  Type of da ta being c ollected
  34715   "RTN","RCD PRU",124,0 )
  34716    ;                               CARC  - Ca rc codes
  34717   "RTN","RCD PRU",125,0 )
  34718    ;                               PAYER - Pa yer names
  34719   "RTN","RCD PRU",126,0 )
  34720    ;                               PLB   - Pr ovider Lev el Balance  Codes
  34721   "RTN","RCD PRU",127,0 )
  34722    ;                               TIN   - Pa yer IDs
  34723   "RTN","RCD PRU",128,0 )
  34724    ;           ITEM             -  Code or Co de range b eing proce ssed
  34725   "RTN","RCD PRU",129,0 )
  34726    ;           DELIM            -  Range deli mitter to  use
  34727   "RTN","RCD PRU",130,0 )
  34728    ; Output:   ZAR              -  Array cont aining all  of the da ta parsed  from ITEM
  34729   "RTN","RCD PRU",131,0 )
  34730    N ELEM,FI LE,IDX,O1, X1,X2,ZGBL
  34731   "RTN","RCD PRU",132,0 )
  34732    ;
  34733   "RTN","RCD PRU",133,0 )
  34734    ; Set fil e # and in dex for th e range lo okup
  34735   "RTN","RCD PRU",134,0 )
  34736    S FILE=$S (TYPE="CAR C":345,TYP E="PAYER": 344.6,TYPE ="TIN":344 .6,TYPE="P LB":345.1, 1:0)
  34737   "RTN","RCD PRU",135,0 )
  34738    S IDX=$S( TYPE="CARC ":"B",TYPE ="PAYER":" B",TYPE="T IN":"C",TY PE="PLB":" B",1:0)
  34739   "RTN","RCD PRU",136,0 )
  34740    ;
  34741   "RTN","RCD PRU",137,0 )
  34742    ; Get clo sed root o f the Glob al
  34743   "RTN","RCD PRU",138,0 )
  34744    S ZGBL=$$ ROOT^DILFD (FILE,"",1 ,"")
  34745   "RTN","RCD PRU",139,0 )
  34746    Q:ZGBL=""
  34747   "RTN","RCD PRU",140,0 )
  34748    ;
  34749   "RTN","RCD PRU",141,0 )
  34750    ; Process  range of  things in  ITEM
  34751   "RTN","RCD PRU",142,0 )
  34752    S X1=$P(I TEM,DELIM, 1),X2=$P(I TEM,DELIM, 2)
  34753   "RTN","RCD PRU",143,0 )
  34754    S O1=$O(@ ZGBL@(IDX, X1),-1)                   ; Set  the start
  34755   "RTN","RCD PRU",144,0 )
  34756    F  S O1=$ O(@ZGBL@(I DX,O1)) Q: (O1="")!($ $AFTER(O1, X2))  S ZA R(TYPE,O1) =1
  34757   "RTN","RCD PRU",145,0 )
  34758    Q
  34759   "RTN","RCD PRU",146,0 )
  34760    ;
  34761   "RTN","RCD PRU",147,0 )
  34762   AFTER(ZZ1, ZZ2) ; Is  ZZ1 after  (or collat es after)  ZZ2
  34763   "RTN","RCD PRU",148,0 )
  34764    N XZ1,XZ2
  34765   "RTN","RCD PRU",149,0 )
  34766    S XZ1=+ZZ 1,XZ2=+ZZ2
  34767   "RTN","RCD PRU",150,0 )
  34768    I (XZ1'=0 )&(XZ2'=0)  Q (XZ1>XZ 2)  ; Nume ric
  34769   "RTN","RCD PRU",151,0 )
  34770    I (XZ1=0) &(XZ2'=0)  Q 1  ; XZ1  not numer ic, XZ2 nu meric, XZ1  is after  XZ2
  34771   "RTN","RCD PRU",152,0 )
  34772    I (XZ1=0) &(XZ2=0) Q  (ZZ1]ZZ2)   ; Both n ot numeric  see if XZ 1 collates  after XZ2
  34773   "RTN","RCD PRU",153,0 )
  34774    Q 1 ; Def ault to af ter 
  34775   "RTN","RCD PRU",154,0 )
  34776    ;
  34777   "RTN","RCD PRU",155,0 )
  34778   GLIST(FILE ,IDX,GLARR ) ;Build l ist for th is file
  34779   "RTN","RCD PRU",156,0 )
  34780    ; Build l ist of ava ilable pay ers
  34781   "RTN","RCD PRU",157,0 )
  34782    N CNT,RCP AY S CNT=0 ,RCPAY=""
  34783   "RTN","RCD PRU",158,0 )
  34784    F  S RCPA Y=$O(^RCY( FILE,IDX,R CPAY)) Q:R CPAY=""  D
  34785   "RTN","RCD PRU",159,0 )
  34786    .S CNT=CN T+1
  34787   "RTN","RCD PRU",160,0 )
  34788    .S @GLARR @(CNT)=RCP AY
  34789   "RTN","RCD PRU",161,0 )
  34790    .S @GLARR @(IDX,RCPA Y,CNT)=""
  34791   "RTN","RCD PRU",162,0 )
  34792    ;
  34793   "RTN","RCD PRU",163,0 )
  34794    Q
  34795   "RTN","RCD PRU",164,0 )
  34796    ;
  34797   "RTN","RCD PRU",165,0 )
  34798   GETPAY(RCP AY) ; EP
  34799   "RTN","RCD PRU",166,0 )
  34800    ; Get sel ected paye rs using f ile 344.6
  34801   "RTN","RCD PRU",167,0 )
  34802    ; Note: S imilar to  GETPAY^RCD PEM9 excep t that met hod uses 3 44.4 or 34 4.31
  34803   "RTN","RCD PRU",168,0 )
  34804    ; Input:    None
  34805   "RTN","RCD PRU",169,0 )
  34806    ; Output:   RCPAY        - ALL  if all pay ers select ed
  34807   "RTN","RCD PRU",170,0 )
  34808    ;           RCPAY(DA TA) - 'ALL ' - all pa yers selec ted
  34809   "RTN","RCD PRU",171,0 )
  34810    ; Returns : 1 - Paye r selectio n made, 0  otherwise
  34811   "RTN","RCD PRU",172,0 )
  34812    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,EX,RCLPA Y,Y
  34813   "RTN","RCD PRU",173,0 )
  34814    S EX=1 ;  Exit statu s
  34815   "RTN","RCD PRU",174,0 )
  34816    S DIR("A" )="Select  (A)ll or ( R)ange of  835 Payer  Names?: "
  34817   "RTN","RCD PRU",175,0 )
  34818    S DIR(0)= "SA^A:All  Payer Name s;R:Range  or List of  Payer Nam es"
  34819   "RTN","RCD PRU",176,0 )
  34820    S DIR("B" )="ALL"
  34821   "RTN","RCD PRU",177,0 )
  34822    D ^DIR
  34823   "RTN","RCD PRU",178,0 )
  34824    K DIR
  34825   "RTN","RCD PRU",179,0 )
  34826    I $D(DTOU T)!$D(DUOU T)!(Y="")  S EX=0 Q E X
  34827   "RTN","RCD PRU",180,0 )
  34828    S RCLPAY= Y
  34829   "RTN","RCD PRU",181,0 )
  34830    I $G(Y)=" A" S RCPAY ="ALL",RCP AY("DATA") ="ALL" Q E X
  34831   "RTN","RCD PRU",182,0 )
  34832    ;
  34833   "RTN","RCD PRU",183,0 )
  34834    ; Get Ran ge of 835  Payers
  34835   "RTN","RCD PRU",184,0 )
  34836    I RCLPAY= "R" S EX=$ $GETRNG(.R CPAY,"P"), RCPAY="R"
  34837   "RTN","RCD PRU",185,0 )
  34838    Q EX
  34839   "RTN","RCD PRU",186,0 )
  34840    ;
  34841   "RTN","RCD PRU",187,0 )
  34842   GETTIN(RCT IN) ; EP
  34843   "RTN","RCD PRU",188,0 )
  34844    ; Get sel ected Paye r TINs
  34845   "RTN","RCD PRU",189,0 )
  34846    ; Input:    None
  34847   "RTN","RCD PRU",190,0 )
  34848    ; Output:   RCTIN        - ALL  if all pay er TINs se lected
  34849   "RTN","RCD PRU",191,0 )
  34850    ;           RCPAY(DA TA) - 'ALL ' - all pa yer TINs s elected
  34851   "RTN","RCD PRU",192,0 )
  34852    ; Returns : 1 - Paye r selectio n made, 0  otherwise
  34853   "RTN","RCD PRU",193,0 )
  34854    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,EX,RCTLI ST,X,Y
  34855   "RTN","RCD PRU",194,0 )
  34856    S EX=1 ;  Exit statu s
  34857   "RTN","RCD PRU",195,0 )
  34858    S DIR("A" )="Select  (A)ll or ( R)ange of  835 Payer  TINs?: "
  34859   "RTN","RCD PRU",196,0 )
  34860    S DIR(0)= "SA^A:All  Payer TINs ;R:Range o r List of  Payer TINs "
  34861   "RTN","RCD PRU",197,0 )
  34862    S DIR("B" )="ALL"
  34863   "RTN","RCD PRU",198,0 )
  34864    D ^DIR K  DIR
  34865   "RTN","RCD PRU",199,0 )
  34866    I $D(DTOU T)!$D(DUOU T)!(Y="")  S EX=0 Q E X
  34867   "RTN","RCD PRU",200,0 )
  34868    S RCTLIST =Y
  34869   "RTN","RCD PRU",201,0 )
  34870    I $G(Y)=" A" S RCTIN ="ALL",RCT IN("DATA") ="ALL" Q E X
  34871   "RTN","RCD PRU",202,0 )
  34872    ;
  34873   "RTN","RCD PRU",203,0 )
  34874    ; Get Ran ge of 835  Payer TINs
  34875   "RTN","RCD PRU",204,0 )
  34876    I RCTLIST ="R" S EX= $$GETRNG(. RCTIN,"T") ,RCTIN="R"
  34877   "RTN","RCD PRU",205,0 )
  34878    Q EX
  34879   "RTN","RCD PRU",206,0 )
  34880    ;
  34881   "RTN","RCD PRU",207,0 )
  34882   GETRNG(RTN ARR,TYPE)  ; Allows t he user to  specify a  payer nam e or TIN r ange
  34883   "RTN","RCD PRU",208,0 )
  34884    ; Input:    TYPE             -  'P' - Paye r Name ran ge selecti on
  34885   "RTN","RCD PRU",209,0 )
  34886    ;                               'T' - Paye r TIN rang e selectio n
  34887   "RTN","RCD PRU",210,0 )
  34888    ; Output:   RTNARR           -  'ERROR' -  Invalid TY PE of rang e selected
  34889   "RTN","RCD PRU",211,0 )
  34890    ;           RTNARR(D ATA)    -  A1~:~A2 Wh ere:
  34891   "RTN","RCD PRU",212,0 )
  34892    ;                                A1 - Exte rnal Payer  Name or T IN of sele cted 
  34893   "RTN","RCD PRU",213,0 )
  34894    ;                                     344. 6 Payer fo r range st art
  34895   "RTN","RCD PRU",214,0 )
  34896    ;                                A2 - Exte rnal Payer  Name or T IN of sele cted
  34897   "RTN","RCD PRU",215,0 )
  34898    ;                                     344. 6 Payer fo r range en d
  34899   "RTN","RCD PRU",216,0 )
  34900    ;           RTNARR(S TART)   -  Starting R ange Value  A1^A2^A3^ A4 Where:
  34901   "RTN","RCD PRU",217,0 )
  34902    ;                                A1 - Inte rnal IEN o f selected  344.6 Pay er for
  34903   "RTN","RCD PRU",218,0 )
  34904    ;                                      ran ge start
  34905   "RTN","RCD PRU",219,0 )
  34906    ;                                A2 - Exte rnal Payer  Name or T IN for ran ge start
  34907   "RTN","RCD PRU",220,0 )
  34908    ;                                A3 - Inte rnal IEN o f selected  344.6 Pay er for
  34909   "RTN","RCD PRU",221,0 )
  34910    ;                                     rang e start
  34911   "RTN","RCD PRU",222,0 )
  34912    ;                                A4 - Exte rnal Payer  Name or T IN for ran ge end
  34913   "RTN","RCD PRU",223,0 )
  34914    ;           RTNARR(E ND)     -  Ending Ran ge Value A 1^A2^A3^A4  Where:
  34915   "RTN","RCD PRU",224,0 )
  34916    ;                                A1 - Inte rnal IEN o f selected  344.6 Pay er for 
  34917   "RTN","RCD PRU",225,0 )
  34918    ;                                     rang e end
  34919   "RTN","RCD PRU",226,0 )
  34920    ;                                A2 - Exte rnal Payer  Name or T IN for ran ge end
  34921   "RTN","RCD PRU",227,0 )
  34922    ;                                A3 - Inte rnal IEN o f selected  344.6 for  range end
  34923   "RTN","RCD PRU",228,0 )
  34924    ;                                A4 - Exte rnal Payer  Name or T IN for ran ge end
  34925   "RTN","RCD PRU",229,0 )
  34926    N D,DIC,D IROUT,DIRU T,DTOUT,DU OUT,IDX,RC DTN,RCDN,R CPT,X,Y
  34927   "RTN","RCD PRU",230,0 )
  34928    I $G(TYPE )=""!("PT" '[$G(TYPE) ) S RTNARR ="ERROR" Q   ; Quit i f TYPE not  correct
  34929   "RTN","RCD PRU",231,0 )
  34930    S IDX=$S( TYPE="P":" B",TYPE="T ":"C")
  34931   "RTN","RCD PRU",232,0 )
  34932    K DIC
  34933   "RTN","RCD PRU",233,0 )
  34934    S DIC="^R CY(344.6," ,DIC(0)="A ES",D=IDX
  34935   "RTN","RCD PRU",234,0 )
  34936    S DIC("A" )="Start w ith 835 "_ $S(TYPE="P ":"Payer N ame",TYPE= "T":"Payer  TIN")_":  "
  34937   "RTN","RCD PRU",235,0 )
  34938    I TYPE="P " S DIC("W ")="D EN^D DIOL($P(^( 0),U,2),," "?35"")"
  34939   "RTN","RCD PRU",236,0 )
  34940    E  S DIC( "W")="D EN ^DDIOL($P( ^(0),U,1), ,""?35"")"
  34941   "RTN","RCD PRU",237,0 )
  34942    D IX^DIC
  34943   "RTN","RCD PRU",238,0 )
  34944    I $D(DTOU T)!$D(DUOU T)!(Y="")! (Y=-1) Q 0
  34945   "RTN","RCD PRU",239,0 )
  34946    S RCDN=$O (^RCY(344. 6,IDX,X,"" ))
  34947   "RTN","RCD PRU",240,0 )
  34948    S RTNARR( "START")=R CDN_U_X_U_ Y,RTNARR(" DATA")=X
  34949   "RTN","RCD PRU",241,0 )
  34950    ;
  34951   "RTN","RCD PRU",242,0 )
  34952    K DIC
  34953   "RTN","RCD PRU",243,0 )
  34954    S DIC="^R CY(344.6," ,DIC(0)="A ES",D=IDX
  34955   "RTN","RCD PRU",244,0 )
  34956    S DIC("A" )="Go to w ith 835 "_ $S(TYPE="P ":"Payer N ame",TYPE= "T":"Payer  TIN")_":  "
  34957   "RTN","RCD PRU",245,0 )
  34958    I TYPE="P " S DIC("W ")="D EN^D DIOL($P(^( 0),U,2),," "?35"")"
  34959   "RTN","RCD PRU",246,0 )
  34960    E  S DIC( "W")="D EN ^DDIOL($P( ^(0),U,1), ,""?35"")"
  34961   "RTN","RCD PRU",247,0 )
  34962    D IX^DIC
  34963   "RTN","RCD PRU",248,0 )
  34964    I $D(DTOU T)!$D(DUOU T)!(Y="")! (Y=-1) Q 0
  34965   "RTN","RCD PRU",249,0 )
  34966    S RCDN=$O (^RCY(344. 6,IDX,X,"" ))
  34967   "RTN","RCD PRU",250,0 )
  34968    S RTNARR( "END")=RCD N_U_X_U_Y
  34969   "RTN","RCD PRU",251,0 )
  34970    I TYPE="P " S RTNARR ("DATA")=$ P(RTNARR(" START"),U, 4)_"~:~"_$ P(RTNARR(" END"),U,4)  ;PCRA*4.5 *321
  34971   "RTN","RCD PRU",252,0 )
  34972    I TYPE="T " S RTNARR ("DATA")=$ P(RTNARR(" START"),U, 2)_"~:~"_$ P(RTNARR(" END"),U,2)  ;PCRA*4.5 *321
  34973   "RTN","RCD PRU",253,0 )
  34974    Q 1
  34975   "RTN","RCD PRU",254,0 )
  34976    ;
  34977   "RTN","RCD PRU",255,0 )
  34978   CHECKDT(GS TART,GSTOP ,GFILE) ;  See if we  have any p ossible da ta to repo rt
  34979   "RTN","RCD PRU",256,0 )
  34980    N SDT,IEN ,PTR,COUNT ,RCGX
  34981   "RTN","RCD PRU",257,0 )
  34982    S COUNT=0
  34983   "RTN","RCD PRU",258,0 )
  34984    I GFILE=3 61.1 D
  34985   "RTN","RCD PRU",259,0 )
  34986    . S SDT=G START-0.00 1
  34987   "RTN","RCD PRU",260,0 )
  34988    . F  S SD T=$O(^IBM( 361.1,"E", SDT)) Q:(S DT="")!(SD T>GSTOP)!( COUNT>0)   S COUNT=CO UNT+1
  34989   "RTN","RCD PRU",261,0 )
  34990    I GFILE=3 44.4 D
  34991   "RTN","RCD PRU",262,0 )
  34992    . S SDT=G START-.001
  34993   "RTN","RCD PRU",263,0 )
  34994    . F  S SD T=$O(^RCY( 344.4,"AC" ,SDT)) Q:( SDT="")!(S DT>GSTOP)! (COUNT>0)   D
  34995   "RTN","RCD PRU",264,0 )
  34996    .. S IEN= "" F  S IE N=$O(^RCY( 344.4,"AC" ,SDT,IEN))  Q:IEN=""   D
  34997   "RTN","RCD PRU",265,0 )
  34998    ... K RCG X D GETS^D IQ(344.4,I EN_",","2* ;","E","RC GX") Q:$D( RCGX)=0
  34999   "RTN","RCD PRU",266,0 )
  35000    ... S COU NT=COUNT+1  ; We have  at least  1 ERA with  a PLB
  35001   "RTN","RCD PRU",267,0 )
  35002    Q COUNT
  35003   "RTN","RCD PRU",268,0 )
  35004    ;
  35005   "RTN","RCD PRU",269,0 )
  35006    ; RARR -  Report arr ay to walk ; SUBS - S ubscript t o walk to  sum the re port
  35007   "RTN","RCD PRU",270,0 )
  35008    ; ZSORT -  Sorting o n PLB Code s "C" or P ayer/TIN " P"
  35009   "RTN","RCD PRU",271,0 )
  35010   SUMIT(RARR ,SUBS,ZSOR T) ; Summa rize data  in the arr ay referen ce for PLB  Report
  35011   "RTN","RCD PRU",272,0 )
  35012    N LVL2,ZZ ,XX,ZAD,ZC O,ZDC,ZN,Z PAT,ZPD,ZT ,ZC,ZCT,ZS ,ZTOT,YY,Q Q,OLD,TADJ ,ZIDX
  35013   "RTN","RCD PRU",273,0 )
  35014    S ZT=0,ZC =0,ZTOT=0, ZAD=0,ZCO= "",OLD=""
  35015   "RTN","RCD PRU",274,0 )
  35016    I $G(SUBS )="" Q  ;  We should  always hav e this Var iable
  35017   "RTN","RCD PRU",275,0 )
  35018    S ZZ="",Z CT=0,ZAD=0
  35019   "RTN","RCD PRU",276,0 )
  35020    ; Walk th e collecti on in "ERA " or "PAYR " this wil l have all  of the ER As for thi s report a nd summari ze
  35021   "RTN","RCD PRU",277,0 )
  35022    F  S ZZ=$ O(@RARR@(S UBS,ZZ)) Q :ZZ=""  D
  35023   "RTN","RCD PRU",278,0 )
  35024    . K ZCT S  XX="",ZCT =0,ZTOT=0, ZAD=0,ZPD= 0,ZDC=""
  35025   "RTN","RCD PRU",279,0 )
  35026    . ; XX wi ll be the  IEN of the  ERA to co unt.
  35027   "RTN","RCD PRU",280,0 )
  35028    . F  S XX =$O(@RARR@ (SUBS,ZZ,X X)) Q:XX=" "  S ZN=@R ARR@(SUBS, ZZ,XX,0),Z PD=ZPD+$P( ZN,U,5),ZP AT=$P(ZN,U ,6)_"/"_$P (ZN,U,3) D
  35029   "RTN","RCD PRU",281,0 )
  35030    .. S ZCT= ZCT+1 S:ZS ORT="C" ZC T(ZPAT)=$G (ZCT(ZPAT) )+1,ZPD(ZZ _ZPAT)=$G( ZPD(ZZ_ZPA T))+$P(ZN, U,5) ; Cou nt the ERA s and get  paid for t his payer
  35031   "RTN","RCD PRU",282,0 )
  35032    .. S ZTOT =+$G(@RARR @("00_ERA" ,XX,.1))
  35033   "RTN","RCD PRU",283,0 )
  35034    .. ; Get  the adjust ed amounts  for the P LB codes ( in ZZ if b y Code)
  35035   "RTN","RCD PRU",284,0 )
  35036    .. I ZSOR T="C" S ZA D=$$TAMT(X X,RARR,ZZ) ,ZDC=$$TCD (XX,RARR,Z Z)
  35037   "RTN","RCD PRU",285,0 )
  35038    .. I ZSOR T="P" S YY =0.11 F  S  YY=$O(@RA RR@("00_ER A",XX,YY))  Q:YY=""  
  35039   "RTN","RCD PRU",286,0 )
  35040    ... ; Get  PLB Code,  Adjusted  amt and Co de Descrip tion for B y Payer su mmary
  35041   "RTN","RCD PRU",287,0 )
  35042    ... N QPD  S QPD=0,Z CO=$P($G(@ RARR@("00_ ERA",XX,YY )),U,1),QP D("ADJ")=$ P($G(@RARR @("00_ERA" ,XX,YY)),U ,2),ZDC=$P ($G(@RARR@ ("00_ERA", XX,YY)),U, 4)
  35043   "RTN","RCD PRU",288,0 )
  35044    ... S QPD =$G(@RARR@ ("SUMMARY" ,ZZ,ZCO))  ; existing  data for  this PLB C ode (QPD)
  35045   "RTN","RCD PRU",289,0 )
  35046    ... I ($G (OLD(ZZ,ZC O,XX))'=1)  S QPD("PA ID")=$P(QP D,U,2)+$P( ZN,U,5),QP D("COUNT") =$P(QPD,U, 3)+1,QPD(" TBILLED")= $P(QPD,U,5 )+ZTOT
  35047   "RTN","RCD PRU",290,0 )
  35048    ... E  S  QPD("PAID" )=$P(QPD,U ,2),QPD("C OUNT")=$P( QPD,U,3),Q PD("TBILLE D")=$P(QPD ,U,5)
  35049   "RTN","RCD PRU",291,0 )
  35050    ... ; Adj  Amt ^ Pai d ^ Count  of ERAs ^  Descriptio n ^ Total  Billed
  35051   "RTN","RCD PRU",292,0 )
  35052    ... S ZAD =($P(QPD,U ,1)+QPD("A DJ")),ZPD= QPD("PAID" ),ZCT=QPD( "COUNT"),Z TOT=QPD("T BILLED")
  35053   "RTN","RCD PRU",293,0 )
  35054    ... S @RA RR@("SUMMA RY",ZZ,ZCO )=ZAD_U_ZP D_U_ZCT_U_ ZDC_U_ZTOT
  35055   "RTN","RCD PRU",294,0 )
  35056    ... S OLD (ZZ,ZCO,XX )=1
  35057   "RTN","RCD PRU",295,0 )
  35058    .. S LVL2 =$S(ZSORT= "C":ZPAT,Z SORT="P":Z CO,1:XX)
  35059   "RTN","RCD PRU",296,0 )
  35060    .. S:ZSOR T="C" ZAD= ZAD+$P($G( @RARR@("SU MMARY",ZZ, LVL2)),U,1 ),ZTOT=ZTO T+$P($G(@R ARR@("SUMM ARY",ZZ,LV L2)),U,5)  ; Sum the  ADJ & BILL ED amounts
  35061   "RTN","RCD PRU",297,0 )
  35062    .. ; Adj  Amt ^ Paid  ^ Count o f ERAs ^ ^  Total Bil led
  35063   "RTN","RCD PRU",298,0 )
  35064    .. I ZSOR T="C" S @R ARR@("SUMM ARY",ZZ,LV L2)=ZAD_U_ ZPD(ZZ_ZPA T)_U_ZCT(Z PAT)_U_U_Z TOT
  35065   "RTN","RCD PRU",299,0 )
  35066    ;
  35067   "RTN","RCD PRU",300,0 )
  35068    ; Summari ze the Cod e level to tals
  35069   "RTN","RCD PRU",301,0 )
  35070    I ZSORT=" C" K OLD S  ZZ="",QQ= "" F  S ZZ =$O(@RARR@ ("ERA",ZZ) ) Q:ZZ=""   D
  35071   "RTN","RCD PRU",302,0 )
  35072    . S QQ="" ,(ZCT,ZPD, ZAD,ZTOT)= 0 F  S QQ= $O(@RARR@( "ERA",ZZ,Q Q)) Q:QQ=" "  D
  35073   "RTN","RCD PRU",303,0 )
  35074    .. S ZCT= ZCT+1
  35075   "RTN","RCD PRU",304,0 )
  35076    .. S ZPD= ZPD+$P(@RA RR@("ERA", ZZ,QQ,0),U ,5),ZTOT=Z TOT+@RARR@ ("00_ERA", QQ,.1),ZAD =ZAD+$$TAM T(QQ,RARR, ZZ),ZDC=$$ TCD(QQ,RAR R,ZZ)
  35077   "RTN","RCD PRU",305,0 )
  35078    . S @RARR @("SUMMARY ",ZZ)=ZAD_ U_ZPD_U_ZC T_U_ZDC_U_ ZTOT
  35079   "RTN","RCD PRU",306,0 )
  35080    ;
  35081   "RTN","RCD PRU",307,0 )
  35082    ; Summari ze the Pay er level t otals
  35083   "RTN","RCD PRU",308,0 )
  35084    I ZSORT=" P" K OLD S  ZZ="",QQ= "" F  S ZZ =$O(@RARR@ ("PAYR",ZZ )) Q:ZZ=""   D
  35085   "RTN","RCD PRU",309,0 )
  35086    . S QQ="" ,(ZCT,ZPD, ZAD,ZTOT)= 0 F  S QQ= $O(@RARR@( "PAYR",ZZ, QQ)) Q:QQ= ""  D
  35087   "RTN","RCD PRU",310,0 )
  35088    .. S ZCT= ZCT+1
  35089   "RTN","RCD PRU",311,0 )
  35090    .. S ZPD= ZPD+$P(@RA RR@("PAYR" ,ZZ,QQ,0), U,5),ZTOT= ZTOT+@RARR @("00_ERA" ,QQ,.1),ZA D=ZAD+$$TA MT(QQ,RARR ,"")
  35091   "RTN","RCD PRU",312,0 )
  35092    . S @RARR @("SUMMARY ",ZZ)=ZAD_ U_ZPD_U_ZC T_U_U_ZTOT
  35093   "RTN","RCD PRU",313,0 )
  35094    ;
  35095   "RTN","RCD PRU",314,0 )
  35096    ; Collect  and summa rize the G rand Total s.
  35097   "RTN","RCD PRU",315,0 )
  35098    S ZZ="",Q Q="" F  S  ZZ=$O(@RAR R@(SUBS,ZZ )) Q:ZZ=""   D 
  35099   "RTN","RCD PRU",316,0 )
  35100    . S XX=""  F  S XX=$ O(@RARR@(S UBS,ZZ,XX) ) Q:XX=""   S ZT=$G(@ RARR@("TOT ALS")),ZS= $G(@RARR@( "SUMMARY", ZZ)) D  S  @RARR@("ZZ _COUNTED", XX)=1
  35101   "RTN","RCD PRU",317,0 )
  35102    .. S ZN=$ G(@RARR@(S UBS,ZZ,XX, 0)),ZN("TB ILLED")=@R ARR@("00_E RA",XX,.1) ,TADJ=$$TA MT(XX,RARR ,"")
  35103   "RTN","RCD PRU",318,0 )
  35104    .. I $G(@ RARR@("ZZ_ COUNTED",X X))'=1 D
  35105   "RTN","RCD PRU",319,0 )
  35106    ... S @RA RR@("TOTAL S")=($P(ZT ,U,1)+TADJ )_U_($P(ZT ,U,2)+$P(Z N,U,5))_U_ ($P(ZT,U,3 )+1)_U_U_( $P(ZT,U,5) +ZN("TBILL ED"))
  35107   "RTN","RCD PRU",320,0 )
  35108    Q
  35109   "RTN","RCD PRU",321,0 )
  35110    ;
  35111   "RTN","RCD PRU",322,0 )
  35112   TAMT(ZIEN, XGBL,ZCODE ) ; Get Ad justment A mounts
  35113   "RTN","RCD PRU",323,0 )
  35114    N ZAMT,XD N,AA S ZAM T=0
  35115   "RTN","RCD PRU",324,0 )
  35116    ; ZCODE i f defined  is get the  Adjustmen t amounts  for just t his code
  35117   "RTN","RCD PRU",325,0 )
  35118    ; otherwi se sum the  adjustmen t amounts  for this E RA in ZIEN
  35119   "RTN","RCD PRU",326,0 )
  35120    D
  35121   "RTN","RCD PRU",327,0 )
  35122    . S AA=0. 1 F  S AA= $O(@XGBL@( "00_ERA",Z IEN,AA)) Q :AA=""  D
  35123   "RTN","RCD PRU",328,0 )
  35124    .. I $G(Z CODE)'=""  Q:$P($G(@X GBL@("00_E RA",ZIEN,A A)),U,1)'= ZCODE  ; Q uit if we  don't have  the right  code
  35125   "RTN","RCD PRU",329,0 )
  35126    .. ; Coll ect adjust ment amoun ts to retu rn for thi s ZIEN
  35127   "RTN","RCD PRU",330,0 )
  35128    .. S ZAMT =ZAMT+$P(@ XGBL@("00_ ERA",ZIEN, AA),U,2)
  35129   "RTN","RCD PRU",331,0 )
  35130    Q ZAMT
  35131   "RTN","RCD PRU",332,0 )
  35132    ;
  35133   "RTN","RCD PRU",333,0 )
  35134   TCD(ZIEN,X GBL,ZCODE)  ; Get PLB  Descripti on for Cod e & IEN gi ven
  35135   "RTN","RCD PRU",334,0 )
  35136    N RET,AA  S RET=""
  35137   "RTN","RCD PRU",335,0 )
  35138    Q:$G(ZCOD E)="" ""
  35139   "RTN","RCD PRU",336,0 )
  35140    S AA=0.1  F  S AA=$O (@XGBL@("0 0_ERA",ZIE N,AA)) Q:A A=""  D  Q :RET'=""
  35141   "RTN","RCD PRU",337,0 )
  35142    . Q:$P($G (@XGBL@("0 0_ERA",ZIE N,AA)),U,1 )'=ZCODE   ; Quit if  we don't h ave the ri ght code
  35143   "RTN","RCD PRU",338,0 )
  35144    . S RET=$ P(@XGBL@(" 00_ERA",ZI EN,AA),U,4 )
  35145   "RTN","RCD PRU",339,0 )
  35146    Q RET
  35147   "RTN","RCD PRU",340,0 )
  35148    ;
  35149   "RTN","RCD PRU",341,0 )
  35150    ; Moved f rom RCDPEM 2 because  of size is sues
  35151   "RTN","RCD PRU",342,0 )
  35152   UPDERA(DA, RECEPT,FOU ND) ;Mark  ERA as pos ted to pap er EOB
  35153   "RTN","RCD PRU",343,0 )
  35154    N Y,X,DR, DIE,%
  35155   "RTN","RCD PRU",344,0 )
  35156    D NOW^%DT C
  35157   "RTN","RCD PRU",345,0 )
  35158    S DIE="^R CY(344.4," ,FOUND=0
  35159   "RTN","RCD PRU",346,0 )
  35160    ;Update R eceipt #,  EFT Match  Status, De tail Post  Status and  Paper EOB
  35161   "RTN","RCD PRU",347,0 )
  35162    S DR=".08 ///"_RECEP T_";.09/// 2;.14///2; 20.03///1"
  35163   "RTN","RCD PRU",348,0 )
  35164    ;Update D ate/Time P osted and  User field s
  35165   "RTN","RCD PRU",349,0 )
  35166    S DR=DR_" ;7.01///"_ %_";7.02// /"_DUZ
  35167   "RTN","RCD PRU",350,0 )
  35168    D ^DIE
  35169   "RTN","RCD PRU",351,0 )
  35170    I '$D(Y)  D
  35171   "RTN","RCD PRU",352,0 )
  35172    .K DIR
  35173   "RTN","RCD PRU",353,0 )
  35174    .S DIR(0) ="EA"
  35175   "RTN","RCD PRU",354,0 )
  35176    .S DIR("A ",1)="ERA  HAS BEEN M ARKED AS P OSTED USIN G PAPER EO B"
  35177   "RTN","RCD PRU",355,0 )
  35178    .S DIR("A ")="Press  ENTER to c ontinue: "  W ! D ^DI R K DIR
  35179   "RTN","RCD PRU",356,0 )
  35180    .S FOUND= 1
  35181   "RTN","RCD PRU",357,0 )
  35182    E  W !,"U nable to u pdate ERA  for receip t "_RECEPT ,!
  35183   "RTN","RCD PRU",358,0 )
  35184    Q FOUND
  35185   "RTN","RCD PRU",359,0 )
  35186    ;
  35187   "RTN","RCD PRU",360,0 )
  35188    ; Get Rec iept Date  (moved fro m RCDPEM2
  35189   "RTN","RCD PRU",361,0 )
  35190   RCDATE(REC EPT) ;
  35191   "RTN","RCD PRU",362,0 )
  35192    N RCRECTD A
  35193   "RTN","RCD PRU",363,0 )
  35194    ;Get rece ipt IEN
  35195   "RTN","RCD PRU",364,0 )
  35196    S RCRECTD A=$O(^RCY( 344,"B",RE CEPT,0)) Q :'RCRECTDA  0
  35197   "RTN","RCD PRU",365,0 )
  35198    ;Return R eceipt dat e
  35199   "RTN","RCD PRU",366,0 )
  35200    Q $P($G(^ RCY(344,RC RECTDA,0)) ,U,3)
  35201   "RTN","RCD PRU",367,0 )
  35202    ;
  35203   "RTN","RCD PRU",368,0 )
  35204   AMT(RECEPT ) ;Total R eceipt amo unt
  35205   "RTN","RCD PRU",369,0 )
  35206    N RCRECTD A,RCTRAN,R CTOT
  35207   "RTN","RCD PRU",370,0 )
  35208    ;Get rece ipt IEN
  35209   "RTN","RCD PRU",371,0 )
  35210    S RCRECTD A=$O(^RCY( 344,"B",RE CEPT,0)) Q :'RCRECTDA  0
  35211   "RTN","RCD PRU",372,0 )
  35212    ;Total th e Receipt  transactio ns
  35213   "RTN","RCD PRU",373,0 )
  35214    S RCTRAN= 0,RCTOT=0
  35215   "RTN","RCD PRU",374,0 )
  35216    F  S RCTR AN=$O(^RCY (344,RCREC TDA,1,RCTR AN)) Q:'RC TRAN  D
  35217   "RTN","RCD PRU",375,0 )
  35218    .S RCTOT= RCTOT+$P($ G(^RCY(344 ,RCRECTDA, 1,RCTRAN,0 )),U,4)
  35219   "RTN","RCD PRU",376,0 )
  35220    Q RCTOT
  35221   "RTN","RCD PRU",377,0 )
  35222    ;
  35223   "RTN","RCD PRU",378,0 )
  35224    ; Moved f rom RCDPEM 2 for Manu al match b ecause RCD PEM2 was t oo big in  size
  35225   "RTN","RCD PRU",379,0 )
  35226    ; END, DT RNG, RCERA , RCMBG, S TART varia bles are n ewed and c leaned up  in RCDPEM2
  35227   "RTN","RCD PRU",380,0 )
  35228   ML0() ;
  35229   "RTN","RCD PRU",381,0 )
  35230   ML0A S RCE RA=$$SEL^R CDPEWL7()  ; Select E RA to use  from scree n
  35231   "RTN","RCD PRU",382,0 )
  35232    S RCMBG=V ALMBG ; Sa ve the lin e, we need  it when w e go back  to the wor klist.
  35233   "RTN","RCD PRU",383,0 )
  35234    I RCERA=0  Q 1
  35235   "RTN","RCD PRU",384,0 )
  35236    S RCERA(0 )=^RCY(344 .4,RCERA,0 ) ; Get th e zero nod e for this  ERA 
  35237   "RTN","RCD PRU",385,0 )
  35238    I ((+($P( RCERA(0),U ,9)))>0)!( $P(RCERA(0 ),U,8)'="" ) W !,"ERA  is alread y matched  please sel ect anothe r ERA...", ! G ML0A
  35239   "RTN","RCD PRU",386,0 )
  35240    S DIR("A" )="Select  EFT by dat e Range? ( Y/N) ",DIR (0)="YA",D IR("B")="N O" D ^DIR  K DIR
  35241   "RTN","RCD PRU",387,0 )
  35242    I $D(DUOU T)!$D(DTOU T) Q 1
  35243   "RTN","RCD PRU",388,0 )
  35244    I Y<1 G M LQ ; Go to  the EFT S election
  35245   "RTN","RCD PRU",389,0 )
  35246    S DTRNG=Y   ; flag i ndicating  date range  selected
  35247   "RTN","RCD PRU",390,0 )
  35248    K DIR S D IR("?")="E nter the e arliest da te for the  selection  range."
  35249   "RTN","RCD PRU",391,0 )
  35250    ; value i n DIR(0) f or %DT = A PE: ask da te, past a ssumed, ec ho answer
  35251   "RTN","RCD PRU",392,0 )
  35252    S DIR(0)= "DAO^:"_DT _":APE",DI R("A")="St art Date:  " D ^DIR K  DIR
  35253   "RTN","RCD PRU",393,0 )
  35254    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q 1
  35255   "RTN","RCD PRU",394,0 )
  35256    S START=Y  K DIR,X,Y
  35257   "RTN","RCD PRU",395,0 )
  35258    S DIR("?" )="Enter t he latest  date for t he selecti on range."
  35259   "RTN","RCD PRU",396,0 )
  35260    S DIR(0)= "DAO^"_STA RT_":"_DT_ ":APE",DIR ("A")="End  Date: ",D IR("B")=$$ FMTE^XLFDT (DT)
  35261   "RTN","RCD PRU",397,0 )
  35262    D ^DIR K  DIR
  35263   "RTN","RCD PRU",398,0 )
  35264    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q 1
  35265   "RTN","RCD PRU",399,0 )
  35266    S END=Y
  35267   "RTN","RCD PRU",400,0 )
  35268    ;
  35269   "RTN","RCD PRU",401,0 )
  35270   MLQ Q 0
  35271   "RTN","RCD PRU2")
  35272   0^32^B2126 6563
  35273   "RTN","RCD PRU2",1,0)
  35274   RCDPRU2 ;A ITC/CJE -  CARC REPOR T ON PAYER  OR CARC C ODE ;
  35275   "RTN","RCD PRU2",2,0)
  35276    ;;4.5;Acc ounts Rece ivable;**3 21**;;Buil d 46
  35277   "RTN","RCD PRU2",3,0)
  35278    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  35279   "RTN","RCD PRU2",4,0)
  35280    Q
  35281   "RTN","RCD PRU2",5,0)
  35282    ; PRCA*4. 5*321 - CA RC and Pay er report  utilities
  35283   "RTN","RCD PRU2",6,0)
  35284    ;
  35285   "RTN","RCD PRU2",7,0)
  35286    ; Moved f rom RCDPAR C to RCDPR U then to  RCDPRU2 -  PRCA*4.5*3 21
  35287   "RTN","RCD PRU2",8,0)
  35288   SUM(ARRAY, IEN,BILL,C ARC,PAYER, BAMT,PAMT, DESC,AAMT, SORT) ; EP
  35289   "RTN","RCD PRU2",9,0)
  35290    ; Count C laims and  summarize  for the re port
  35291   "RTN","RCD PRU2",10,0 )
  35292    ; IEN: IE N from 361 .1 file; B ILL: The K -Bill numb er; ITEM:  Top level  sort item  PAYER or C ARC to sum marize;
  35293   "RTN","RCD PRU2",11,0 )
  35294    ; BAMT: B illed Amou nt; PAMT:  Paid Amoun t ; AAMT:  Adjustment  Amount;
  35295   "RTN","RCD PRU2",12,0 )
  35296    ; LVL: se cond level  sort (CAR C/Payer) ;  SORT: "C"  is CARC o r "P" is P ayer first  level sor t,
  35297   "RTN","RCD PRU2",13,0 )
  35298    N ITEM,LV L
  35299   "RTN","RCD PRU2",14,0 )
  35300    I SORT="C " S ITEM=C ARC,LVL=PA YER
  35301   "RTN","RCD PRU2",15,0 )
  35302    E  S ITEM =PAYER,LVL =CARC
  35303   "RTN","RCD PRU2",16,0 )
  35304    ;
  35305   "RTN","RCD PRU2",17,0 )
  35306    D:$G(@ARR AY@("~~SUM ",ITEM,IEN ))'=1  ; I f we alrea dy counted  this clai m for CARC  or Payer  skip
  35307   "RTN","RCD PRU2",18,0 )
  35308    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM"),U ,1)=$P($G( @ARRAY@("R EPORT",ITE M,"~~SUM") ),U,1)+1 ;  Count cla ims
  35309   "RTN","RCD PRU2",19,0 )
  35310    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM"),U ,2)=$P($G( @ARRAY@("R EPORT",ITE M,"~~SUM") ),U,2)+BAM T ; Summar ize amount  billed
  35311   "RTN","RCD PRU2",20,0 )
  35312    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM"),U ,3)=$P($G( @ARRAY@("R EPORT",ITE M,"~~SUM") ),U,3)+PAM T ; Summar ize amount  paid
  35313   "RTN","RCD PRU2",21,0 )
  35314    ; Always  add in the  adjustmen t (this is  a differe nt adjustm ent each t ime proced ure is cal led)
  35315   "RTN","RCD PRU2",22,0 )
  35316    S $P(@ARR AY@("REPOR T",ITEM,"~ ~SUM"),U,4 )=$P($G(@A RRAY@("REP ORT",ITEM, "~~SUM")), U,4)+AAMT  ; Summariz e amount a djusted
  35317   "RTN","RCD PRU2",23,0 )
  35318    S:SORT="C " $P(@ARRA Y@("REPORT ",ITEM,"~~ SUM"),U,5) =$G(DESC)  ; CARC Des cription
  35319   "RTN","RCD PRU2",24,0 )
  35320    I (SORT=" C")&($G(LV L)'="") D: $G(@ARRAY@ ("~~SUM",I TEM,IEN))' =1
  35321   "RTN","RCD PRU2",25,0 )
  35322    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM",LV L),U,1)=$P ($G(@ARRAY @("REPORT" ,ITEM,"~~S UM",LVL)), U,1)+1 ; C ount claim s
  35323   "RTN","RCD PRU2",26,0 )
  35324    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM",LV L),U,2)=$P ($G(@ARRAY @("REPORT" ,ITEM,"~~S UM",LVL)), U,2)+BAMT  ; Summariz e amount b illed
  35325   "RTN","RCD PRU2",27,0 )
  35326    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM",LV L),U,3)=$P ($G(@ARRAY @("REPORT" ,ITEM,"~~S UM",LVL)), U,3)+PAMT  ; Summariz e amount p aid
  35327   "RTN","RCD PRU2",28,0 )
  35328    ;I $G(LVL )'="" D:$G (@ARRAY@(" ~~SUM",LVL ,IEN))'=1
  35329   "RTN","RCD PRU2",29,0 )
  35330    I (SORT=" P")&($G(LV L)'="") D: $G(@ARRAY@ ("~~SUM",I TEM,IEN,LV L))'=1
  35331   "RTN","RCD PRU2",30,0 )
  35332    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM",LV L),U,1)=$P ($G(@ARRAY @("REPORT" ,ITEM,"~~S UM",LVL)), U,1)+1 ; C ount claim s
  35333   "RTN","RCD PRU2",31,0 )
  35334    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM",LV L),U,2)=$P ($G(@ARRAY @("REPORT" ,ITEM,"~~S UM",LVL)), U,2)+BAMT  ; Summariz e amount b illed
  35335   "RTN","RCD PRU2",32,0 )
  35336    . S $P(@A RRAY@("REP ORT",ITEM, "~~SUM",LV L),U,3)=$P ($G(@ARRAY @("REPORT" ,ITEM,"~~S UM",LVL)), U,3)+PAMT  ; Summariz e amount p aid
  35337   "RTN","RCD PRU2",33,0 )
  35338    ; Always  add in the  adjustmen t (this is  a differe nt adjustm ent each t ime proced ure is cal led)
  35339   "RTN","RCD PRU2",34,0 )
  35340    S $P(@ARR AY@("REPOR T",ITEM,"~ ~SUM",LVL) ,U,4)=$P($ G(@ARRAY@( "REPORT",I TEM,"~~SUM ",LVL)),U, 4)+AAMT ;  Summarize  amount adj usted
  35341   "RTN","RCD PRU2",35,0 )
  35342    I SORT="P ",$G(LVL)' ="" S $P(@ ARRAY@("RE PORT",ITEM ,"~~SUM",L VL),U,5)=D ESC ; CARC  Descripti on
  35343   "RTN","RCD PRU2",36,0 )
  35344    ; Get gra nd totals  for report
  35345   "RTN","RCD PRU2",37,0 )
  35346    D:$G(@ARR AY@("~~SUM ",BILL))'= 1
  35347   "RTN","RCD PRU2",38,0 )
  35348    . S $P(@A RRAY@("~~S UM","CLAIM S"),U,1)=$ P($G(@ARRA Y@("~~SUM" ,"CLAIMS") ),U,1)+1
  35349   "RTN","RCD PRU2",39,0 )
  35350    . S $P(@A RRAY@("~~S UM","CLAIM S"),U,2)=$ P($G(@ARRA Y@("~~SUM" ,"CLAIMS") ),U,2)+BAM T
  35351   "RTN","RCD PRU2",40,0 )
  35352    . S $P(@A RRAY@("~~S UM","CLAIM S"),U,3)=$ P($G(@ARRA Y@("~~SUM" ,"CLAIMS") ),U,3)+PAM T
  35353   "RTN","RCD PRU2",41,0 )
  35354    ; May hav e more tha n one adju stment on  a bill
  35355   "RTN","RCD PRU2",42,0 )
  35356    I $G(@ARR AY@("~~SUM ",BILL,ITE M))'=1 S $ P(@ARRAY@( "~~SUM","C LAIMS"),U, 4)=$P($G(@ ARRAY@("~~ SUM","CLAI MS")),U,4) +AAMT ;W " BILL: ",BI LL," ITEM:  ",ITEM,"  Adj: ",AAM T,!
  35357   "RTN","RCD PRU2",43,0 )
  35358    ; Set mar kers so we  don't dou ble count  a claim
  35359   "RTN","RCD PRU2",44,0 )
  35360    S @ARRAY@ ("~~SUM",I TEM,BILL)= 1,@ARRAY@( "~~SUM",IT EM,IEN)=1, @ARRAY@("~ ~SUM",ITEM ,IEN,LVL)= 1,@ARRAY@( "~~SUM",BI LL)=1,@ARR AY@("~~SUM ",LVL,BILL )=1,@ARRAY @("~~SUM", LVL,IEN)=1
  35361   "RTN","RCD PRU2",45,0 )
  35362    Q
  35363   "RTN","RCD PRU2",46,0 )
  35364    ;
  35365   "RTN","RCD PRU2",47,0 )
  35366   PAYTIN(PY, L) ; EP
  35367   "RTN","RCD PRU2",48,0 )
  35368    ; Truncat e Payer/TI N string t o L charac ters for r eports
  35369   "RTN","RCD PRU2",49,0 )
  35370    ; Input:   PY = Paye r/TIN stri ng
  35371   "RTN","RCD PRU2",50,0 )
  35372    ;          L  = Maxi mum length  allowed
  35373   "RTN","RCD PRU2",51,0 )
  35374    ; Return:  Payer/TIN  string tr uncated to  length L
  35375   "RTN","RCD PRU2",52,0 )
  35376    N RETURN, XX,YY,ZZ
  35377   "RTN","RCD PRU2",53,0 )
  35378    S RETURN= PY
  35379   "RTN","RCD PRU2",54,0 )
  35380    I $L(PY)> L D
  35381   "RTN","RCD PRU2",55,0 )
  35382    . S ZZ=$L (PY,"/"),X X=$P(PY,"/ ",1,ZZ-1), YY=$P(PY," /",ZZ)
  35383   "RTN","RCD PRU2",56,0 )
  35384    . S XX=$E (XX,1,L-($ L(YY)+1)), RETURN=XX_ "/"_YY
  35385   "RTN","RCD PRU2",57,0 )
  35386    Q RETURN
  35387   "RTN","RCD PRU2",58,0 )
  35388    ;
  35389   "RTN","RCD PRU2",59,0 )
  35390   PAYTINS(PY ,RETURN) ;  Get all P AYER/TIN s trings for  the TIN i n PY
  35391   "RTN","RCD PRU2",60,0 )
  35392    ; Input:  PY String  with Payer  Name/TIN  in it
  35393   "RTN","RCD PRU2",61,0 )
  35394    ; Output:  RETURN pa ssed by re ference, a rray of Pa yer Name/T INS with s ame TIN as  input PY
  35395   "RTN","RCD PRU2",62,0 )
  35396    N COUNT,N AME,TIN,ZZ
  35397   "RTN","RCD PRU2",63,0 )
  35398    K RETURN
  35399   "RTN","RCD PRU2",64,0 )
  35400    S COUNT=0
  35401   "RTN","RCD PRU2",65,0 )
  35402    S TIN=$P( PY,"/",$L( PY,"/"))
  35403   "RTN","RCD PRU2",66,0 )
  35404    S ZZ="" F   S ZZ=$O( ^RCY(344.6 ,"C",TIN_"  ",ZZ)) Q: ZZ=""  D
  35405   "RTN","RCD PRU2",67,0 )
  35406    . S NAME= $$GET1^DIQ (344.6,ZZ_ ",",.01,"E ")
  35407   "RTN","RCD PRU2",68,0 )
  35408    . I NAME' ="" D  ;
  35409   "RTN","RCD PRU2",69,0 )
  35410    . . S COU NT=COUNT+1
  35411   "RTN","RCD PRU2",70,0 )
  35412    . . S RET URN(COUNT) =NAME_"/"_ TIN
  35413   "RTN","RCD PRU2",71,0 )
  35414    Q
  35415   "RTN","RCD PRU2",72,0 )
  35416    ;
  35417   "RTN","RCD PRU2",73,0 )
  35418   PAYLIST(AR RAY,TYPE,R ETURN) ; E xpand list  of payers  to includ e ones wit h the same  TIN
  35419   "RTN","RCD PRU2",74,0 )
  35420    ; Input:  ARRAY - ar ray of pay er names o r IENS
  35421   "RTN","RCD PRU2",75,0 )
  35422    ;         TYPE  - E= External ( Payer Name  array) or  I=Interna l (IEN arr ay)
  35423   "RTN","RCD PRU2",76,0 )
  35424    ; Output:  RETURN ar ray passed  by refere nce
  35425   "RTN","RCD PRU2",77,0 )
  35426    N KEY,ZZ
  35427   "RTN","RCD PRU2",78,0 )
  35428    S KEY=""
  35429   "RTN","RCD PRU2",79,0 )
  35430    F  S KEY= $O(ARRAY(K EY)) Q:KEY =""  D  ;
  35431   "RTN","RCD PRU2",80,0 )
  35432    . I TYPE= "I" D  ;
  35433   "RTN","RCD PRU2",81,0 )
  35434    . . D TIN LIST(KEY,. RETURN,TYP E)
  35435   "RTN","RCD PRU2",82,0 )
  35436    . I TYPE= "E" D  ;
  35437   "RTN","RCD PRU2",83,0 )
  35438    . S ZZ=""
  35439   "RTN","RCD PRU2",84,0 )
  35440    . F  S ZZ =$O(^RCY(3 44.6,"B",K EY,ZZ)) Q: ZZ=""  D   ;
  35441   "RTN","RCD PRU2",85,0 )
  35442    . . D TIN LIST(ZZ,.R ETURN,TYPE )
  35443   "RTN","RCD PRU2",86,0 )
  35444    Q
  35445   "RTN","RCD PRU2",87,0 )
  35446   TINLIST(PI EN,RETURN, TYPE) ; Gi ven a paye r IEN from  #344.6, g et list of  payers wi th the sam e TIN
  35447   "RTN","RCD PRU2",88,0 )
  35448    ; Input:  PIEN - Pay er IEN (#3 44.6)
  35449   "RTN","RCD PRU2",89,0 )
  35450    ;         ARRAY - ar ray of pay er names o r IENS
  35451   "RTN","RCD PRU2",90,0 )
  35452    ;         TYPE  - E= External ( Payer Name  array) or  I=Interna l (IEN arr ay)
  35453   "RTN","RCD PRU2",91,0 )
  35454    ; Output:  ARRAY pas sed by ref erence wit h modified  entries
  35455   "RTN","RCD PRU2",92,0 )
  35456    N TIN,PNA ME,ZZ
  35457   "RTN","RCD PRU2",93,0 )
  35458    S TIN=$$G ET1^DIQ(34 4.6,PIEN_" ,",.02,"E" )
  35459   "RTN","RCD PRU2",94,0 )
  35460    I TIN=""  Q
  35461   "RTN","RCD PRU2",95,0 )
  35462    S ZZ=""
  35463   "RTN","RCD PRU2",96,0 )
  35464    F  S ZZ=$ O(^RCY(344 .6,"C",TIN _" ",ZZ))  Q:ZZ=""  D
  35465   "RTN","RCD PRU2",97,0 )
  35466    . I TYPE= "E" D  ;
  35467   "RTN","RCD PRU2",98,0 )
  35468    . . S PNA ME=$$GET1^ DIQ(344.6, ZZ_",",.01 ,"E")
  35469   "RTN","RCD PRU2",99,0 )
  35470    . . I PNA ME'="" S R ETURN(PNAM E)=1
  35471   "RTN","RCD PRU2",100, 0)
  35472    . E  D
  35473   "RTN","RCD PRU2",101, 0)
  35474    . . S RET URN(ZZ)=1
  35475   "RTN","RCD PRU2",102, 0)
  35476    Q
  35477   "RTN","RCD PRU2",103, 0)
  35478    ;
  35479   "RTN","RCD PRU2",104, 0)
  35480   CHK(TYPE,I TEM,ARRAY)  ; Check t o see if t his ITEM i s included  for proce ssing
  35481   "RTN","RCD PRU2",105, 0)
  35482    ; If all  are includ ed no need  to check  further
  35483   "RTN","RCD PRU2",106, 0)
  35484    Q:$G(ARRA Y(TYPE))=" ALL" 1
  35485   "RTN","RCD PRU2",107, 0)
  35486    Q:$G(ITEM )="" 0
  35487   "RTN","RCD PRU2",108, 0)
  35488    Q:$G(ARRA Y(TYPE,ITE M))=1 1
  35489   "RTN","RCD PRU2",109, 0)
  35490    Q 0
  35491   "RTN","RCD PRU2",110, 0)
  35492    ;
  35493   "RTN","RCD PRU2",111, 0)
  35494    ;
  35495   "RTN","RCD PRU2",112, 0)
  35496   GPAYR(TIN)  ; First p ayer name  derived fr om TIN - P RCA*4.5*32 1
  35497   "RTN","RCD PRU2",113, 0)
  35498    ; Input:  TIN - Paye r ID
  35499   "RTN","RCD PRU2",114, 0)
  35500    ; Return:  The first  payer nam e related  to TIN
  35501   "RTN","RCD PRU2",115, 0)
  35502    ;          *Note mor e than one  entry in  344.6 may  have this  TIN but fo r sort by  name
  35503   "RTN","RCD PRU2",116, 0)
  35504    ;           purposes  we have t o select o ne of them .
  35505   "RTN","RCD PRU2",117, 0)
  35506    N RETURN, ZZ
  35507   "RTN","RCD PRU2",118, 0)
  35508    S ZZ=$O(^ RCY(344.6, "C",TIN_"  ",""))
  35509   "RTN","RCD PRU2",119, 0)
  35510    I ZZ Q $$ GET1^DIQ(3 44.6,ZZ_", ",.01,"E")
  35511   "RTN","RCD PRU2",120, 0)
  35512    Q ""
  35513   "RTN","RCD PTAR")
  35514   0^19^B1947 58258
  35515   "RTN","RCD PTAR",1,0)
  35516   RCDPTAR ;A LB/TJB - E FT TRANSAC TION AUDIT  REPORT ;1 /02/15
  35517   "RTN","RCD PTAR",2,0)
  35518    ;;4.5;Acc ounts Rece ivable;**3 03,321**;M ar 20, 199 5;Build 46
  35519   "RTN","RCD PTAR",3,0)
  35520    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  35521   "RTN","RCD PTAR",4,0)
  35522    ;
  35523   "RTN","RCD PTAR",5,0)
  35524    Q
  35525   "RTN","RCD PTAR",6,0)
  35526    ; PRCA*4. 5*303 - EF T TRANSACT ION AUDIT  REPORT
  35527   "RTN","RCD PTAR",7,0)
  35528    ;
  35529   "RTN","RCD PTAR",8,0)
  35530    ; Execute d by the o ption "EFT  Transacti on Audit R eport" fro m the "EDI  Lockbox R eports Men u"
  35531   "RTN","RCD PTAR",9,0)
  35532    ;
  35533   "RTN","RCD PTAR",10,0 )
  35534    ; DESCRIP TION: The  following  generates  a report t hat displa ys an audi t history  for an EFT
  35535   "RTN","RCD PTAR",11,0 )
  35536    ;
  35537   "RTN","RCD PTAR",12,0 )
  35538   EN ; Main  entry poin t for this  report
  35539   "RTN","RCD PTAR",13,0 )
  35540    ; Ask Sum mary or De tail outpu t
  35541   "RTN","RCD PTAR",14,0 )
  35542    ;
  35543   "RTN","RCD PTAR",15,0 )
  35544    N DIR,X,Y ,DUOUT,DTO UT,DIRUT,D IROUT,RCRE P
  35545   "RTN","RCD PTAR",16,0 )
  35546    W !
  35547   "RTN","RCD PTAR",17,0 )
  35548    S DIR(0)= "SOA^S:Sum mary Infor mation Onl y;D:Detail  Report"
  35549   "RTN","RCD PTAR",18,0 )
  35550    S DIR("A" )="(S)umma ry or (D)e tail Repor t format?  "
  35551   "RTN","RCD PTAR",19,0 )
  35552    S DIR("B" )="SUMMARY "
  35553   "RTN","RCD PTAR",20,0 )
  35554    D ^DIR
  35555   "RTN","RCD PTAR",21,0 )
  35556    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q
  35557   "RTN","RCD PTAR",22,0 )
  35558    S RCREP=Y
  35559   "RTN","RCD PTAR",23,0 )
  35560    ;
  35561   "RTN","RCD PTAR",24,0 )
  35562    I RCREP=" S" D SUM^R CDPTAR1
  35563   "RTN","RCD PTAR",25,0 )
  35564    I RCREP=" D" D DET
  35565   "RTN","RCD PTAR",26,0 )
  35566    Q
  35567   "RTN","RCD PTAR",27,0 )
  35568    ;
  35569   "RTN","RCD PTAR",28,0 )
  35570   DET ; Entr y point fo r detailed  report
  35571   "RTN","RCD PTAR",29,0 )
  35572    ; Input:  variable R CREP defin ed and equ al to "D"
  35573   "RTN","RCD PTAR",30,0 )
  35574    ; Output:  Written t o device
  35575   "RTN","RCD PTAR",31,0 )
  35576    ;
  35577   "RTN","RCD PTAR",32,0 )
  35578    N RCDATA, RCDET
  35579   "RTN","RCD PTAR",33,0 )
  35580    ;
  35581   "RTN","RCD PTAR",34,0 )
  35582   DET1 ; Pro mpt for us er selecti on criteri a
  35583   "RTN","RCD PTAR",35,0 )
  35584    K DIR
  35585   "RTN","RCD PTAR",36,0 )
  35586    S DIR(0)= "SO^N:Depo sit Number ;D:Deposit  Date;R:Re ceipt Numb er;T:Trace  Number"
  35587   "RTN","RCD PTAR",37,0 )
  35588    S DIR("PR E")="S:X?1 N X=$S(X=1 :""N"",X=2 :""d"",X=3 :""r"",X=4 :""t"",1:" "X"")"
  35589   "RTN","RCD PTAR",38,0 )
  35590    S DIR("L" ,1)="Searc h for EFT  Number by: "
  35591   "RTN","RCD PTAR",39,0 )
  35592    S DIR("L" ,2)=""
  35593   "RTN","RCD PTAR",40,0 )
  35594    S DIR("L" ,3)="  1.  Deposit (N )umber"
  35595   "RTN","RCD PTAR",41,0 )
  35596    S DIR("L" ,4)="  2.  Deposit (D )ate"
  35597   "RTN","RCD PTAR",42,0 )
  35598    S DIR("L" ,5)="  3.  (R)eceipt  #"
  35599   "RTN","RCD PTAR",43,0 )
  35600    S DIR("L" )="  4. (T )race #"
  35601   "RTN","RCD PTAR",44,0 )
  35602    S DIR("A" )="Search  for EFT by "
  35603   "RTN","RCD PTAR",45,0 )
  35604    D ^DIR
  35605   "RTN","RCD PTAR",46,0 )
  35606    I $D(DTOU T)!$D(DUOU T)!(Y="")  G DETQ
  35607   "RTN","RCD PTAR",47,0 )
  35608    S RCDET=Y
  35609   "RTN","RCD PTAR",48,0 )
  35610    ;
  35611   "RTN","RCD PTAR",49,0 )
  35612    ; Do look up of EFTs  based on  the user s election a bove
  35613   "RTN","RCD PTAR",50,0 )
  35614    S RCDATA= ""
  35615   "RTN","RCD PTAR",51,0 )
  35616    D @($S(RC DET="N":"D N",RCDET=" D":"DT",RC DET="R":"R C",1:"TR") _"(.RCDATA )")
  35617   "RTN","RCD PTAR",52,0 )
  35618    I RCDATA= -1 G DETQ
  35619   "RTN","RCD PTAR",53,0 )
  35620    I RCDATA= "" G DET1
  35621   "RTN","RCD PTAR",54,0 )
  35622    ;
  35623   "RTN","RCD PTAR",55,0 )
  35624     ; Prompt  for devic e
  35625   "RTN","RCD PTAR",56,0 )
  35626    N %ZIS,ZT SK,ZTRTN,Z TIO,ZTDESC ,ZTSAVE,PO P
  35627   "RTN","RCD PTAR",57,0 )
  35628    S %ZIS="Q M"
  35629   "RTN","RCD PTAR",58,0 )
  35630    D ^%ZIS
  35631   "RTN","RCD PTAR",59,0 )
  35632    I POP G D ETQ
  35633   "RTN","RCD PTAR",60,0 )
  35634    I $D(IO(" Q")) D  G  DETQ
  35635   "RTN","RCD PTAR",61,0 )
  35636    . S ZTRTN ="RUN^RCDP TAR(RCDATA )"
  35637   "RTN","RCD PTAR",62,0 )
  35638    . S ZTIO= ION
  35639   "RTN","RCD PTAR",63,0 )
  35640    . S ZTSAV E("*")=""
  35641   "RTN","RCD PTAR",64,0 )
  35642    . S ZTDES C="EFT TRA NSACTION S UMMARY REP ORT"
  35643   "RTN","RCD PTAR",65,0 )
  35644    . D ^%ZTL OAD
  35645   "RTN","RCD PTAR",66,0 )
  35646    . W !,$S( $D(ZTSK):" REQUEST QU EUED TASK= "_ZTSK,1:" REQUEST CA NCELLED")
  35647   "RTN","RCD PTAR",67,0 )
  35648    . D HOME^ %ZIS
  35649   "RTN","RCD PTAR",68,0 )
  35650    U IO
  35651   "RTN","RCD PTAR",69,0 )
  35652    ;
  35653   "RTN","RCD PTAR",70,0 )
  35654    D RUN(RCD ATA)
  35655   "RTN","RCD PTAR",71,0 )
  35656    Q
  35657   "RTN","RCD PTAR",72,0 )
  35658    ;
  35659   "RTN","RCD PTAR",73,0 )
  35660   DETQ ;
  35661   "RTN","RCD PTAR",74,0 )
  35662    Q
  35663   "RTN","RCD PTAR",75,0 )
  35664    ;
  35665   "RTN","RCD PTAR",76,0 )
  35666   RUN(RCDATA ) ; Compil e and outp ut the rep ort
  35667   "RTN","RCD PTAR",77,0 )
  35668    ; Input:  RCDATA - s ee subrout ine EFTDA  for delimi ted list o f fields
  35669   "RTN","RCD PTAR",78,0 )
  35670    ; Output:  none
  35671   "RTN","RCD PTAR",79,0 )
  35672    ;
  35673   "RTN","RCD PTAR",80,0 )
  35674    ; Compile  Data
  35675   "RTN","RCD PTAR",81,0 )
  35676    D COMPILE (RCDATA)
  35677   "RTN","RCD PTAR",82,0 )
  35678    ;
  35679   "RTN","RCD PTAR",83,0 )
  35680    ; Generat e Report
  35681   "RTN","RCD PTAR",84,0 )
  35682    D REPORT( RCDATA)
  35683   "RTN","RCD PTAR",85,0 )
  35684    ;
  35685   "RTN","RCD PTAR",86,0 )
  35686    K ^TMP("R CDPTAR",$J )
  35687   "RTN","RCD PTAR",87,0 )
  35688    Q
  35689   "RTN","RCD PTAR",88,0 )
  35690    ;
  35691   "RTN","RCD PTAR",89,0 )
  35692   DN(RCDATA)  ; Lookup  by Deposit  Number
  35693   "RTN","RCD PTAR",90,0 )
  35694    ; Input:  RCDATA - n ull on ent ry
  35695   "RTN","RCD PTAR",91,0 )
  35696    ; Output:  RCDATA pa ssed by re fence - se e subrouti ne EFTDA f or delimit ed list of  fields
  35697   "RTN","RCD PTAR",92,0 )
  35698    ; Note va riable RCD EFLUP is n eeded by L OOKUP^RCDP UDEP, whic h is calle d by the . 01 field
  35699   "RTN","RCD PTAR",93,0 )
  35700    ;
  35701   "RTN","RCD PTAR",94,0 )
  35702    N DIC,DTO UT,DUOUT,Y ,RCDEFLUP, LOCKIEN
  35703   "RTN","RCD PTAR",95,0 )
  35704    ;
  35705   "RTN","RCD PTAR",96,0 )
  35706    ; Lookup  Deposit Nu mber
  35707   "RTN","RCD PTAR",97,0 )
  35708    W !
  35709   "RTN","RCD PTAR",98,0 )
  35710    S DIC="^R CY(344.1," ,DIC(0)="Q EAMn",DIC( "A")="Sele ct DEPOSIT : ",DIC("W ")="D DICW ^RCDPUDEP"
  35711   "RTN","RCD PTAR",99,0 )
  35712    S RCDEFLU P=1
  35713   "RTN","RCD PTAR",100, 0)
  35714    D ^DIC
  35715   "RTN","RCD PTAR",101, 0)
  35716    I $G(DTOU T)!$G(DUOU T)!(Y=-1)  S RCDATA=- 1 Q
  35717   "RTN","RCD PTAR",102, 0)
  35718    ;
  35719   "RTN","RCD PTAR",103, 0)
  35720    S LOCKIEN =+$O(^RCY( 344.3,"ARD EP",+Y,"") )
  35721   "RTN","RCD PTAR",104, 0)
  35722    I 'LOCKIE N W !!,"EF T NOT FOUN D - please  check Dep osit" D PA USE Q
  35723   "RTN","RCD PTAR",105, 0)
  35724    ;
  35725   "RTN","RCD PTAR",106, 0)
  35726    ; Get EFT  pointer
  35727   "RTN","RCD PTAR",107, 0)
  35728    S RCDATA= $$EFT(LOCK IEN)
  35729   "RTN","RCD PTAR",108, 0)
  35730    Q
  35731   "RTN","RCD PTAR",109, 0)
  35732    ;
  35733   "RTN","RCD PTAR",110, 0)
  35734   DT(RCDATA)  ; Deposit  Date
  35735   "RTN","RCD PTAR",111, 0)
  35736    ; Input:  RCDATA - n ull on ent ry
  35737   "RTN","RCD PTAR",112, 0)
  35738    ; Output:  RCDATA pa ssed by re fence - se e subrouti ne EFTDA f or delimit ed list of  fields
  35739   "RTN","RCD PTAR",113, 0)
  35740    ;
  35741   "RTN","RCD PTAR",114, 0)
  35742    N CNT,DAT A,DEPIEN,D IR,DIROUT, DIRUT,DTOU T,DUOUT,IT EM,LINE,LI ST,RCDT,RC I,RCIEN,X, Y
  35743   "RTN","RCD PTAR",115, 0)
  35744    ;
  35745   "RTN","RCD PTAR",116, 0)
  35746   DT1 ; Ask  the user f or the Dep osit Date
  35747   "RTN","RCD PTAR",117, 0)
  35748    K DIR
  35749   "RTN","RCD PTAR",118, 0)
  35750    S DIR(0)= "DAO^:"_DT _":APE",DI R("B")="T"
  35751   "RTN","RCD PTAR",119, 0)
  35752    S DIR("A" )="Select  DEPOSIT DA TE: "
  35753   "RTN","RCD PTAR",120, 0)
  35754    D ^DIR
  35755   "RTN","RCD PTAR",121, 0)
  35756    I $D(DTOU T)!$D(DUOU T)!(Y="")  S RCDATA=- 1 Q
  35757   "RTN","RCD PTAR",122, 0)
  35758    S RCDT=Y
  35759   "RTN","RCD PTAR",123, 0)
  35760    ;
  35761   "RTN","RCD PTAR",124, 0)
  35762    ; Build L ist
  35763   "RTN","RCD PTAR",125, 0)
  35764    K LIST
  35765   "RTN","RCD PTAR",126, 0)
  35766    S RCI="", CNT=0 F  S  RCI=$O(^R CY(344.3," ADEP",RCDT ,RCI)) Q:R CI=""  D
  35767   "RTN","RCD PTAR",127, 0)
  35768    . S RCIEN ="" F  S R CIEN=$O(^R CY(344.3," ADEP",RCDT ,RCI,RCIEN )) Q:RCIEN =""  D
  35769   "RTN","RCD PTAR",128, 0)
  35770    .. S DEPI EN=$P($G(^ RCY(344.3, RCIEN,0)), U,3)
  35771   "RTN","RCD PTAR",129, 0)
  35772    .. I DEPI EN="" Q
  35773   "RTN","RCD PTAR",130, 0)
  35774    .. S DATA =$G(^RCY(3 44.1,DEPIE N,0))
  35775   "RTN","RCD PTAR",131, 0)
  35776    .. I DATA ="" Q
  35777   "RTN","RCD PTAR",132, 0)
  35778    .. S CNT= CNT+1
  35779   "RTN","RCD PTAR",133, 0)
  35780    .. ; Code  below is  similiar t o DICW^RCD PUDEP code
  35781   "RTN","RCD PTAR",134, 0)
  35782    .. S LINE =$J(CNT,3) _". "_$P(D ATA,U,1)
  35783   "RTN","RCD PTAR",135, 0)
  35784    .. S $E(L INE,19)="b y: "_$E($P ($G(^VA(20 0,+$P(DATA ,"^",6),0) ),"^"),1,1 5)
  35785   "RTN","RCD PTAR",136, 0)
  35786    .. I '$P( DATA,"^",7 ) S $P(DAT A,"^",7)=" ???????"
  35787   "RTN","RCD PTAR",137, 0)
  35788    .. S $E(L INE,39)="o n: "_$E($P (DATA,"^", 7),4,5)_"/ "_$E($P(DA TA,"^",7), 6,7)_"/"_$ E($P(DATA, "^",7),2,3 )
  35789   "RTN","RCD PTAR",138, 0)
  35790    .. S $E(L INE,52)="a mt: $"_$J( $P(DATA,"^ ",4),10,2)
  35791   "RTN","RCD PTAR",139, 0)
  35792    .. S $E(L INE,70)=$P ("N/A^OPEN ^DEPOSITED ^CONFIRMED ^PROCESSED ^VOID","^" ,+$P(DATA, "^",12)+1)
  35793   "RTN","RCD PTAR",140, 0)
  35794    .. S LIST (CNT)=RCIE N_"^"_$P(D ATA,U,1)_" ^"_LINE
  35795   "RTN","RCD PTAR",141, 0)
  35796    ;
  35797   "RTN","RCD PTAR",142, 0)
  35798    ; If no d eposits in  the LIST,  display a  message a nd try aga in
  35799   "RTN","RCD PTAR",143, 0)
  35800    I CNT=0 W  !,"Date " ,$$DATE^RC DPRU(RCDT) ," does no t have any  valid dep osits, ple ase try ag ain...",!  G DT1
  35801   "RTN","RCD PTAR",144, 0)
  35802    ;
  35803   "RTN","RCD PTAR",145, 0)
  35804    ; If only  one depos it in the  list, use  it
  35805   "RTN","RCD PTAR",146, 0)
  35806    I CNT=1 S  RCDATA=$$ EFT(+LIST( CNT)) Q
  35807   "RTN","RCD PTAR",147, 0)
  35808    ;
  35809   "RTN","RCD PTAR",148, 0)
  35810    ; Multipl e entries  found so p rompt for  the one th at is want ed
  35811   "RTN","RCD PTAR",149, 0)
  35812    W !!,"Dep osits on " ,$$DATE^RC DPRU(RCDT)
  35813   "RTN","RCD PTAR",150, 0)
  35814    K DIR,ITE M
  35815   "RTN","RCD PTAR",151, 0)
  35816    S DIR(0)= "SAO^"
  35817   "RTN","RCD PTAR",152, 0)
  35818    S DIR("A" )="Select  DEPOSIT: "
  35819   "RTN","RCD PTAR",153, 0)
  35820    S DIR("L" ,1)="  Cho ose from:"
  35821   "RTN","RCD PTAR",154, 0)
  35822    F LINE=1: 1:CNT D
  35823   "RTN","RCD PTAR",155, 0)
  35824    . S DATA= LIST(LINE) ,DIR(0)=DI R(0)_LINE_ ":"_$P(DAT A,U,2)_";"
  35825   "RTN","RCD PTAR",156, 0)
  35826    . S DIR(" L",LINE+1) =$P(DATA,U ,3),ITEM(L INE)=+DATA
  35827   "RTN","RCD PTAR",157, 0)
  35828    . W !,"   ",$P(DATA, U,3)
  35829   "RTN","RCD PTAR",158, 0)
  35830    S DIR(0)= $E(DIR(0), 1,$L(DIR(0 ))-1)
  35831   "RTN","RCD PTAR",159, 0)
  35832    S DIR("L" )=DIR("L", CNT+1) K D IR("L",CNT +1)
  35833   "RTN","RCD PTAR",160, 0)
  35834    W !
  35835   "RTN","RCD PTAR",161, 0)
  35836    D ^DIR
  35837   "RTN","RCD PTAR",162, 0)
  35838    I $D(DTOU T)!$D(DUOU T) S RCDAT A=-1 Q
  35839   "RTN","RCD PTAR",163, 0)
  35840    I Y="" G  DT1
  35841   "RTN","RCD PTAR",164, 0)
  35842    S RCDATA= $$EFT(ITEM (Y))
  35843   "RTN","RCD PTAR",165, 0)
  35844    Q
  35845   "RTN","RCD PTAR",166, 0)
  35846    ;
  35847   "RTN","RCD PTAR",167, 0)
  35848   RC(RCDATA)  ; Lookup  by Receipt  Number
  35849   "RTN","RCD PTAR",168, 0)
  35850    ; Input:  RCDATA - n ull on ent ry
  35851   "RTN","RCD PTAR",169, 0)
  35852    ; Output:  RCDATA pa ssed by re fence - se e subrouti ne EFTDA f or delimit ed list of  fields
  35853   "RTN","RCD PTAR",170, 0)
  35854    ;
  35855   "RTN","RCD PTAR",171, 0)
  35856    N DIC,D,D TOUT,DUOUT ,X,Y,RCIEN ,RCDTN,RCE D
  35857   "RTN","RCD PTAR",172, 0)
  35858    ;
  35859   "RTN","RCD PTAR",173, 0)
  35860    W !
  35861   "RTN","RCD PTAR",174, 0)
  35862    S DIC="^R CY(344,",D IC(0)="QEA Mn",DIC("A ")="Select  RECEIPT:  "
  35863   "RTN","RCD PTAR",175, 0)
  35864    S DIC("W" )="D DICW^ RCDPUREC"
  35865   "RTN","RCD PTAR",176, 0)
  35866    S DIC("S" )="I $$EDI LBEV^RCDPE U($P($G(^( 0)),U,4))"
  35867   "RTN","RCD PTAR",177, 0)
  35868    D ^DIC
  35869   "RTN","RCD PTAR",178, 0)
  35870    I $D(DTOU T)!$D(DUOU T)!(Y=-1)  S RCDATA=- 1 Q
  35871   "RTN","RCD PTAR",179, 0)
  35872    ;
  35873   "RTN","RCD PTAR",180, 0)
  35874    ; Check i f there is  a pointer  to the AR  Deposit
  35875   "RTN","RCD PTAR",181, 0)
  35876    S RCDATA= ""
  35877   "RTN","RCD PTAR",182, 0)
  35878    S RCIEN=$ P($G(^RCY( 344,+Y,0)) ,U,6)
  35879   "RTN","RCD PTAR",183, 0)
  35880    ;
  35881   "RTN","RCD PTAR",184, 0)
  35882    ; If ther e is, then  get the E FT via AR  Deposit an d EDI Lock Box files
  35883   "RTN","RCD PTAR",185, 0)
  35884    I RCIEN D
  35885   "RTN","RCD PTAR",186, 0)
  35886    . ; Get T icket Numb er
  35887   "RTN","RCD PTAR",187, 0)
  35888    . S RCDTN =$P($G(^RC Y(344.1,RC IEN,0)),U, 1)
  35889   "RTN","RCD PTAR",188, 0)
  35890    . I RCDTN ="" Q
  35891   "RTN","RCD PTAR",189, 0)
  35892    . ;
  35893   "RTN","RCD PTAR",190, 0)
  35894    . ; Get E DI Lockbox  Deposit F ile
  35895   "RTN","RCD PTAR",191, 0)
  35896    . S RCED= $O(^RCY(34 4.3,"C",RC DTN,""))
  35897   "RTN","RCD PTAR",192, 0)
  35898    . I RCED= "" Q
  35899   "RTN","RCD PTAR",193, 0)
  35900    . S RCDAT A=$$EFT(RC ED)
  35901   "RTN","RCD PTAR",194, 0)
  35902    ;
  35903   "RTN","RCD PTAR",195, 0)
  35904    ; If this  AR Deposi t record i s not foun d, check i f it is a  receipt on  the ERA
  35905   "RTN","RCD PTAR",196, 0)
  35906    I 'RCIEN  D
  35907   "RTN","RCD PTAR",197, 0)
  35908    . S ERAIE N=$O(^RCY( 344.4,"H", +Y,""))
  35909   "RTN","RCD PTAR",198, 0)
  35910    . I 'ERAI EN S ERAIE N=$O(^RCY( 344.4,"ARC T",+Y,""))
  35911   "RTN","RCD PTAR",199, 0)
  35912    . I 'ERAI EN Q
  35913   "RTN","RCD PTAR",200, 0)
  35914    . S EFTIE N=$O(^RCY( 344.31,"AE RA",ERAIEN ,""))
  35915   "RTN","RCD PTAR",201, 0)
  35916    . I EFTIE N S RCDATA =$$EFTDATA (EFTIEN)
  35917   "RTN","RCD PTAR",202, 0)
  35918    ;
  35919   "RTN","RCD PTAR",203, 0)
  35920    I RCDATA= "" W !!,"E FT NOT FOU ND - pleas e check Re ceipt" D P AUSE Q
  35921   "RTN","RCD PTAR",204, 0)
  35922    Q
  35923   "RTN","RCD PTAR",205, 0)
  35924    ;
  35925   "RTN","RCD PTAR",206, 0)
  35926   TR(RCDATA)  ; Lookup  by Trace N umber
  35927   "RTN","RCD PTAR",207, 0)
  35928    ; Input:  RCDATA - n ull on ent ry
  35929   "RTN","RCD PTAR",208, 0)
  35930    ; Output:  RCDATA pa ssed by re fence - se e subrouti ne EFTDA f or delimit ed list of  fields
  35931   "RTN","RCD PTAR",209, 0)
  35932    N DIC,D,Y ,X,DTOUT,D UOUT
  35933   "RTN","RCD PTAR",210, 0)
  35934    ;
  35935   "RTN","RCD PTAR",211, 0)
  35936    ; Use "F"  index in  EDI EFT De tail file
  35937   "RTN","RCD PTAR",212, 0)
  35938    W !
  35939   "RTN","RCD PTAR",213, 0)
  35940    S DIC="^R CY(344.31, ",DIC(0)=" QEASn",D=" F",DIC("A" )="Select  TRACE: "
  35941   "RTN","RCD PTAR",214, 0)
  35942    ; DIC("W" ) may need  to be fix ed if Trac e numbers  go over 32  character s. The fie lds
  35943   "RTN","RCD PTAR",215, 0)
  35944    ; display ed are the  EFT#, Ins urance com pany name,  amount an d Date Rec ieved.
  35945   "RTN","RCD PTAR",216, 0)
  35946    S DIC("W" )="D EN^DD IOL($J($P( ^(0),U,1), 7)_"" ""_$ $LJ^XLFSTR ($E($P(^(0 ),U,2),1,2 0),20)_$J( $P(^(0),U, 7),10)_""  ""_$$DATE^ RCDPRU($P( ^(0),U,13) ),,""?32"" )"
  35947   "RTN","RCD PTAR",217, 0)
  35948    D IX^DIC
  35949   "RTN","RCD PTAR",218, 0)
  35950    I $D(DTOU T)!$D(DUOU T)!(Y=-1)  S RCDATA=- 1 Q
  35951   "RTN","RCD PTAR",219, 0)
  35952    S RCDATA= $$EFTDATA( +Y)
  35953   "RTN","RCD PTAR",220, 0)
  35954    Q
  35955   "RTN","RCD PTAR",221, 0)
  35956    ;
  35957   "RTN","RCD PTAR",222, 0)
  35958   EFT(LOCKIE N) ; Selec t a single  EFT Numbe r
  35959   "RTN","RCD PTAR",223, 0)
  35960    ; Input:  LOCKIEN -  IEN for LO CKBOX DEPO SIT (#344. 3)
  35961   "RTN","RCD PTAR",224, 0)
  35962    ; Return:  LIST(Y) -  Delimiter  list of i nformation  as return ed by subo utine EFTD ATA
  35963   "RTN","RCD PTAR",225, 0)
  35964    ;
  35965   "RTN","RCD PTAR",226, 0)
  35966    I '$G(LOC KIEN) W !! ,"No EFT d etail for  this selec tion" D PA USE Q ""
  35967   "RTN","RCD PTAR",227, 0)
  35968    ;
  35969   "RTN","RCD PTAR",228, 0)
  35970    N EFTIEN, CNT,DATA,L IST,Y
  35971   "RTN","RCD PTAR",229, 0)
  35972    ;
  35973   "RTN","RCD PTAR",230, 0)
  35974    S EFTIEN= "",CNT=0
  35975   "RTN","RCD PTAR",231, 0)
  35976    F  S EFTI EN=$O(^RCY (344.31,"B ",LOCKIEN, EFTIEN)) Q :EFTIEN=""   D  ;
  35977   "RTN","RCD PTAR",232, 0)
  35978    . S DATA= $$EFTDATA( EFTIEN) I  DATA]"" S  CNT=CNT+1, LIST(CNT)= DATA
  35979   "RTN","RCD PTAR",233, 0)
  35980    ;
  35981   "RTN","RCD PTAR",234, 0)
  35982    I CNT=0 W  !!,"No EF T detail f or this se lection" D  PAUSE Q " "
  35983   "RTN","RCD PTAR",235, 0)
  35984    ;
  35985   "RTN","RCD PTAR",236, 0)
  35986    ; If only  one EFT,  select it  and quit
  35987   "RTN","RCD PTAR",237, 0)
  35988    I CNT=1 S  Y=1 G EFT 1
  35989   "RTN","RCD PTAR",238, 0)
  35990    ;
  35991   "RTN","RCD PTAR",239, 0)
  35992    ; Display  and the l et the use r select t he EFT
  35993   "RTN","RCD PTAR",240, 0)
  35994    N DIR,DIR UT,DIROUT, DTOUT,DUOU T,ROW,TRAN S,X
  35995   "RTN","RCD PTAR",241, 0)
  35996    S DIR(0)= "SO^"
  35997   "RTN","RCD PTAR",242, 0)
  35998    S DIR("A" )="Select  item from  list"
  35999   "RTN","RCD PTAR",243, 0)
  36000    S DIR("L" ,1)="Selec t single E FT:"
  36001   "RTN","RCD PTAR",244, 0)
  36002    F ROW=1:1 :CNT-1 D
  36003   "RTN","RCD PTAR",245, 0)
  36004    . S DATA= LIST(ROW), LOCKIEN=$P (DATA,U,2) ,EFTIEN=$P (DATA,U,3) ,TRANS=$$G ET1^DIQ(34 4.31,EFTIE N_",",.01)
  36005   "RTN","RCD PTAR",246, 0)
  36006    . S DIR(0 )=DIR(0)_R OW_":"_TRA NS_";"
  36007   "RTN","RCD PTAR",247, 0)
  36008    . S DIR(" L",(ROW+1) )=$J(ROW,3 )_". "_TRA NS_"    "_ $$DISPLAY( EFTIEN,LOC KIEN)
  36009   "RTN","RCD PTAR",248, 0)
  36010    S DATA=LI ST(CNT),LO CKIEN=$P(D ATA,U,2),E FTIEN=$P(D ATA,U,3),T RANS=$$GET 1^DIQ(344. 31,EFTIEN_ ",",.01)
  36011   "RTN","RCD PTAR",249, 0)
  36012    S DIR(0)= DIR(0)_CNT _":"_TRANS
  36013   "RTN","RCD PTAR",250, 0)
  36014    S DIR("L" )=$J(CNT,3 )_". "_TRA NS_"    "_ $$DISPLAY( EFTIEN,LOC KIEN)
  36015   "RTN","RCD PTAR",251, 0)
  36016    D ^DIR
  36017   "RTN","RCD PTAR",252, 0)
  36018    I $D(DTOU T)!$D(DUOU T)!(Y="")  Q -1
  36019   "RTN","RCD PTAR",253, 0)
  36020    ;
  36021   "RTN","RCD PTAR",254, 0)
  36022   EFT1 ;
  36023   "RTN","RCD PTAR",255, 0)
  36024    Q LIST(Y)
  36025   "RTN","RCD PTAR",256, 0)
  36026    ;
  36027   "RTN","RCD PTAR",257, 0)
  36028   EFTDATA(EF TIEN) ; Ge t associat ed records  for this  EFT
  36029   "RTN","RCD PTAR",258, 0)
  36030    ; Input:  EFTIEN - I EN for EFT  [344.31]
  36031   "RTN","RCD PTAR",259, 0)
  36032    ; Returns : A1^A2^A3 ^A4^45
  36033   "RTN","RCD PTAR",260, 0)
  36034    ;   where   A1=ERAIE N - IEN fo r ERA (#34 4.4)
  36035   "RTN","RCD PTAR",261, 0)
  36036    ;           A2=LOCKI EN - IEN f or LOCKBOX  DEPOSIT ( #344.3)
  36037   "RTN","RCD PTAR",262, 0)
  36038    ;           A3=EFTIE N - IEN fo r EFT (#34 4.31)
  36039   "RTN","RCD PTAR",263, 0)
  36040    ;           A4=DEPIE N - IEN fo r AR DEPOS IT (#344.1 )
  36041   "RTN","RCD PTAR",264, 0)
  36042    ;           A5=BATCH IEN - IEN  for AR BAT CH PAYMENT  (#344)
  36043   "RTN","RCD PTAR",265, 0)
  36044    ;
  36045   "RTN","RCD PTAR",266, 0)
  36046    I '$G(EFT IEN) Q ""
  36047   "RTN","RCD PTAR",267, 0)
  36048    ;
  36049   "RTN","RCD PTAR",268, 0)
  36050    N BATCHIE N,DEPIEN,E RAIEN,LOCK IEN                         ;PRC A*4.5*321  removed DE POSIT
  36051   "RTN","RCD PTAR",269, 0)
  36052    S (ERAIEN ,DEPIEN,BA TCHIEN)=""
  36053   "RTN","RCD PTAR",270, 0)
  36054    S ERAIEN= $$GET1^DIQ (344.31,EF TIEN,.1,"I ")               ;PRC A*4.5*321  use ^DIQ v s global a ccess
  36055   "RTN","RCD PTAR",271, 0)
  36056    S LOCKIEN =$$GET1^DI Q(344.31,E FTIEN,.01, "I")             ;PRC A*4.5*321
  36057   "RTN","RCD PTAR",272, 0)
  36058    I LOCKIEN  S DEPIEN= $$GET1^DIQ (344.3,LOC KIEN,.03," I")   ;PRC A*4.5*321  instead of  $O on B i ndex of 34 4.1
  36059   "RTN","RCD PTAR",273, 0)
  36060    I DEPIEN  S BATCHIEN =$O(^RCY(3 44,"AD",DE PIEN,""))
  36061   "RTN","RCD PTAR",274, 0)
  36062    Q ERAIEN_ U_LOCKIEN_ U_EFTIEN_U _DEPIEN_U_ BATCHIEN
  36063   "RTN","RCD PTAR",275, 0)
  36064    ;
  36065   "RTN","RCD PTAR",276, 0)
  36066   DISPLAY(EF TIEN,LOCKI EN) ; Disp lay EFT de tail durin g user sel ection pro cess
  36067   "RTN","RCD PTAR",277, 0)
  36068    ; Input:  EFTIEN - I EN for EFT  (#344.31)
  36069   "RTN","RCD PTAR",278, 0)
  36070    ;         LOCKIEN -  IEN for LO CKBOX DEPO SIT (#344. 3)
  36071   "RTN","RCD PTAR",279, 0)
  36072    ; Return:  X1_"    " _X2_"    " _X3_"    " _X4_"    " _X5
  36073   "RTN","RCD PTAR",280, 0)
  36074    ; where    X1=PAYER  NAME
  36075   "RTN","RCD PTAR",281, 0)
  36076    ;          X2=TRACE  NUMBER
  36077   "RTN","RCD PTAR",282, 0)
  36078    ;          X3=AMOUNT  OF PAYMEN T
  36079   "RTN","RCD PTAR",283, 0)
  36080    ;          X4=DEPOSI T NUMBER
  36081   "RTN","RCD PTAR",284, 0)
  36082    ;          X5=DEPOSI T DATE
  36083   "RTN","RCD PTAR",285, 0)
  36084    N X
  36085   "RTN","RCD PTAR",286, 0)
  36086    S EFTIEN= $G(EFTIEN)
  36087   "RTN","RCD PTAR",287, 0)
  36088    S LOCKIEN =$G(LOCKIE N)
  36089   "RTN","RCD PTAR",288, 0)
  36090    S X=$$GET 1^DIQ(344. 31,EFTIEN_ ",",.02)_"     "_$$GE T1^DIQ(344 .31,EFTIEN _",",.04)_ "    "
  36091   "RTN","RCD PTAR",289, 0)
  36092    S X=X_$$G ET1^DIQ(34 4.31,EFTIE N_",",.07) _"    "_$$ GET1^DIQ(3 44.3,LOCKI EN_",",.06 )_"    "
  36093   "RTN","RCD PTAR",290, 0)
  36094    S X=X_$$D ATE^RCDPRU ($$GET1^DI Q(344.3,LO CKIEN_",", .07,"I")," 2DZ")
  36095   "RTN","RCD PTAR",291, 0)
  36096    Q X
  36097   "RTN","RCD PTAR",292, 0)
  36098    ;
  36099   "RTN","RCD PTAR",293, 0)
  36100   COMPILE(RC DATA) ; Co mpile data  for displ ay
  36101   "RTN","RCD PTAR",294, 0)
  36102    ; Input:  RCDATA - s ee subrout ine EFTDA  for delimi ted list o f fields
  36103   "RTN","RCD PTAR",295, 0)
  36104    ; Output:  ^TMP("RCD PTAR",$J)
  36105   "RTN","RCD PTAR",296, 0)
  36106    ;
  36107   "RTN","RCD PTAR",297, 0)
  36108    I $G(RCDA TA)="" Q
  36109   "RTN","RCD PTAR",298, 0)
  36110    ;
  36111   "RTN","RCD PTAR",299, 0)
  36112    N BATCHIE N,DEPDATE, DEPIEN,EFT IEN,ERAIEN ,FILEDATE, FMSDOCNO,I ENS,LASTIE N,LINE,LOC KIEN
  36113   "RTN","RCD PTAR",300, 0)
  36114    N MATCHDA TE,MATCHIE N,PROCDATE ,STATUS,TR ANS
  36115   "RTN","RCD PTAR",301, 0)
  36116    K ^TMP("R CDPTAR",$J )
  36117   "RTN","RCD PTAR",302, 0)
  36118    ;
  36119   "RTN","RCD PTAR",303, 0)
  36120    ; Get Poi nters from  RCDATA
  36121   "RTN","RCD PTAR",304, 0)
  36122    S ERAIEN= $P(RCDATA, U,1),LOCKI EN=$P(RCDA TA,U,2),EF TIEN=$P(RC DATA,U,3)
  36123   "RTN","RCD PTAR",305, 0)
  36124    S DEPIEN= $P(RCDATA, U,4),BATCH IEN=$P(RCD ATA,U,5)
  36125   "RTN","RCD PTAR",306, 0)
  36126    ;
  36127   "RTN","RCD PTAR",307, 0)
  36128    ; Get Ini tal Creati on/Deposit  informati on
  36129   "RTN","RCD PTAR",308, 0)
  36130    K RCDATA
  36131   "RTN","RCD PTAR",309, 0)
  36132    I LOCKIEN  D
  36133   "RTN","RCD PTAR",310, 0)
  36134    . D GETS^ DIQ(344.3, LOCKIEN_", ",".02;.06 ;.08","IE" ,"RCDATA")
  36135   "RTN","RCD PTAR",311, 0)
  36136    . S FILED ATE=$G(RCD ATA(344.3, LOCKIEN_", ",.02,"I") )
  36137   "RTN","RCD PTAR",312, 0)
  36138    . I 'FILE DATE Q
  36139   "RTN","RCD PTAR",313, 0)
  36140    . S ^TMP( "RCDPTAR", $J,FILEDAT E,1)="DEP# :"_$G(RCDA TA(344.3,L OCKIEN_"," ,.06,"E")) _"  DEP AM T:"_$G(RCD ATA(344.3, LOCKIEN_", ",.08,"E") )_"^EFT ST ATUS:RECEI VED"
  36141   "RTN","RCD PTAR",314, 0)
  36142    ;
  36143   "RTN","RCD PTAR",315, 0)
  36144    ; Check i f posted t o revenue  code 8NZZ
  36145   "RTN","RCD PTAR",316, 0)
  36146    S TRANS=$ $GET1^DIQ( 344.31,EFT IEN_",",.1 4)
  36147   "RTN","RCD PTAR",317, 0)
  36148    I TRANS,$ D(^RCY(344 ,+BATCHIEN ,1,TRANS,0 )),LOCKIEN ,$D(RCDATA (344.3,LOC KIEN_","))  D
  36149   "RTN","RCD PTAR",318, 0)
  36150    . S DEPDA TE=$$GET1^ DIQ(344.1, DEPIEN_"," ,.07,"I")
  36151   "RTN","RCD PTAR",319, 0)
  36152    . I 'DEPD ATE Q
  36153   "RTN","RCD PTAR",320, 0)
  36154    . S ^TMP( "RCDPTAR", $J,DEPDATE ,2)="DEP#: "_$G(RCDAT A(344.3,LO CKIEN_",", .06,"E"))_ "  DEP AMT :"_$G(RCDA TA(344.3,L OCKIEN_"," ,.08,"E")) _"^DEP STA TUS:POSTED  TO 8NZZ"
  36155   "RTN","RCD PTAR",321, 0)
  36156    ;
  36157   "RTN","RCD PTAR",322, 0)
  36158    ; Get Mat ch Status  History in formation
  36159   "RTN","RCD PTAR",323, 0)
  36160    I EFTIEN  D
  36161   "RTN","RCD PTAR",324, 0)
  36162    . ; Get t he Last IE N of the m ultiple
  36163   "RTN","RCD PTAR",325, 0)
  36164    . S LASTI EN=$O(^RCY (344.31,EF TIEN,4,999 999),-1)
  36165   "RTN","RCD PTAR",326, 0)
  36166    . ; Loop  through hi story and  build data
  36167   "RTN","RCD PTAR",327, 0)
  36168    . S MATCH IEN=0 F  S  MATCHIEN= $O(^RCY(34 4.31,EFTIE N,4,MATCHI EN)) Q:'MA TCHIEN  D
  36169   "RTN","RCD PTAR",328, 0)
  36170    .. S IENS =MATCHIEN_ ","_EFTIEN _","
  36171   "RTN","RCD PTAR",329, 0)
  36172    .. D GETS ^DIQ(344.3 14,IENS,"* ","IE","RC DATA")
  36173   "RTN","RCD PTAR",330, 0)
  36174    .. S MATC HDATE=$G(R CDATA(344. 314,IENS,. 02,"I"))
  36175   "RTN","RCD PTAR",331, 0)
  36176    .. I MATC HDATE="" Q
  36177   "RTN","RCD PTAR",332, 0)
  36178    .. S STAT US=$G(RCDA TA(344.314 ,IENS,.01, "E"))
  36179   "RTN","RCD PTAR",333, 0)
  36180    .. I STAT US="MATCHE D WITH ERR ORS" S STA TUS="MATCH ED W/ERROR S"
  36181   "RTN","RCD PTAR",334, 0)
  36182    .. S LINE ="EFT STAT US:"_STATU S
  36183   "RTN","RCD PTAR",335, 0)
  36184    .. ; If t his is the  last reco rd and the  status is  matched,  add the ER A record t o the data
  36185   "RTN","RCD PTAR",336, 0)
  36186    .. I MATC HIEN=LASTI EN,STATUS= "MATCHED"! (STATUS="M ATCHED W/E RRORS"),$$ GET1^DIQ(3 44.31,EFTI EN_",",.1)  S LINE=LI NE_" ERA#: "_$$GET1^D IQ(344.31, EFTIEN_"," ,.1)
  36187   "RTN","RCD PTAR",337, 0)
  36188    .. S ^TMP ("RCDPTAR" ,$J,MATCHD ATE,3)=LIN E_"^BY "_$ E($G(RCDAT A(344.314, IENS,.03," E")),1,14) _" on "_$$ DATE^RCDPR U(MATCHDAT E,"2ZD")
  36189   "RTN","RCD PTAR",338, 0)
  36190    ;
  36191   "RTN","RCD PTAR",339, 0)
  36192    ; Get Rec eipt infor mation (EF T)
  36193   "RTN","RCD PTAR",340, 0)
  36194    I BATCHIE N D
  36195   "RTN","RCD PTAR",341, 0)
  36196    . S PROCD ATE=$$GET1 ^DIQ(344,B ATCHIEN_", ",.08,"I")
  36197   "RTN","RCD PTAR",342, 0)
  36198    . I 'PROC DATE Q
  36199   "RTN","RCD PTAR",343, 0)
  36200    . I $G(DE PDATE),PRO CDATE<DEPD ATE S PROC DATE=DEPDA TE     ;PR CA*4.5*321  add $G
  36201   "RTN","RCD PTAR",344, 0)
  36202    . S FMSDO CNO=$$FMSS TAT^RCDPUR EC(BATCHIE N)
  36203   "RTN","RCD PTAR",345, 0)
  36204    . S ^TMP( "RCDPTAR", $J,PROCDAT E,5)="DEP  RCPT#:"_$$ GET1^DIQ(3 44,BATCHIE N_",",.01, "E")_" ENT RY#:"_BATC HIEN_"^FMS  DOC#:"_$P (FMSDOCNO, U,1)_"^^DO C STATUS:" _$E($P(FMS DOCNO,U,2) ,1,18)
  36205   "RTN","RCD PTAR",346, 0)
  36206    ;
  36207   "RTN","RCD PTAR",347, 0)
  36208    ; Get Rep eipt infor mation (ER A)
  36209   "RTN","RCD PTAR",348, 0)
  36210    S BATCHIE N=$$GET1^D IQ(344.4,E RAIEN_",", .08,"I")
  36211   "RTN","RCD PTAR",349, 0)
  36212    I BATCHIE N D
  36213   "RTN","RCD PTAR",350, 0)
  36214    . S PROCD ATE=$$GET1 ^DIQ(344,B ATCHIEN_", ",.08,"I")
  36215   "RTN","RCD PTAR",351, 0)
  36216    . I $G(DE PDATE),PRO CDATE<DEPD ATE S PROC DATE=DEPDA TE     ; P RCA*4.5*32 1 add $G
  36217   "RTN","RCD PTAR",352, 0)
  36218    . I 'PROC DATE Q
  36219   "RTN","RCD PTAR",353, 0)
  36220    . S FMSDO CNO=$$FMSS TAT^RCDPUR EC(BATCHIE N)
  36221   "RTN","RCD PTAR",354, 0)
  36222    . ;S ^TMP ("RCDPTAR" ,$J,PROCDA TE,6)="RCP T#:"_$$GET 1^DIQ(344, BATCHIEN_" ,",.01,"E" )_" EFT DE TAIL#:"_EF TIEN_"^BY  "_$E($$GET 1^DIQ(344, BATCHIEN_" ,",.02,"E" ),1,14)_"  on "_$$DAT E^RCDPRU(P ROCDATE,"2 DZ")
  36223   "RTN","RCD PTAR",355, 0)
  36224    . S ^TMP( "RCDPTAR", $J,PROCDAT E,6)="RCPT #:"_$$GET1 ^DIQ(344,B ATCHIEN_", ",.01,"E") _"^BY "_$E ($$GET1^DI Q(344,BATC HIEN_",",. 02,"E"),1, 14)_" on " _$$DATE^RC DPRU(PROCD ATE,"2DZ")
  36225   "RTN","RCD PTAR",356, 0)
  36226    . S ^TMP( "RCDPTAR", $J,PROCDAT E,7)="FMS  DOC#:"_$P( FMSDOCNO,U ,1)_"^DOC  STATUS:"_$ E($P(FMSDO CNO,U,2),1 ,18)
  36227   "RTN","RCD PTAR",357, 0)
  36228    Q
  36229   "RTN","RCD PTAR",358, 0)
  36230    ;
  36231   "RTN","RCD PTAR",359, 0)
  36232   REPORT(RCD ATA) ; Pri nt out the  report
  36233   "RTN","RCD PTAR",360, 0)
  36234    ; Input:  RCDATA - s ee subrout ine EFTDA  about for  delimited  list of fi elds
  36235   "RTN","RCD PTAR",361, 0)
  36236    ; Output:  Write sta tements
  36237   "RTN","RCD PTAR",362, 0)
  36238    ;
  36239   "RTN","RCD PTAR",363, 0)
  36240    N CNT,DAT E,DATA,LIN ES,RCHR,RC NOW,RCPG,R CSCR
  36241   "RTN","RCD PTAR",364, 0)
  36242    ;
  36243   "RTN","RCD PTAR",365, 0)
  36244    ; Initial ize Report  Date, Pag e Number a nd String  of undersc ores
  36245   "RTN","RCD PTAR",366, 0)
  36246    S RCSCR=$ S($E($G(IO ST),1,2)=" C-":1,1:0)
  36247   "RTN","RCD PTAR",367, 0)
  36248    S RCNOW=$ $UP^XLFSTR ($$NOW^RCD PRU()),RCP G=0,RCHR=" ",$P(RCHR, "-",IOM+1) =""
  36249   "RTN","RCD PTAR",368, 0)
  36250    ;
  36251   "RTN","RCD PTAR",369, 0)
  36252    U IO
  36253   "RTN","RCD PTAR",370, 0)
  36254    D HEADER( RCNOW,.RCP G,RCHR,RCD ATA)
  36255   "RTN","RCD PTAR",371, 0)
  36256    I $G(RCDA TA)=""!'$D (^TMP("RCD PTAR",$J))  W !,"No d ata found"
  36257   "RTN","RCD PTAR",372, 0)
  36258    ;
  36259   "RTN","RCD PTAR",373, 0)
  36260    ; Display  the detai l
  36261   "RTN","RCD PTAR",374, 0)
  36262    S DATE=""  F  S DATE =$O(^TMP(" RCDPTAR",$ J,DATE)) Q :'DATE  D   I RCPG=0  Q
  36263   "RTN","RCD PTAR",375, 0)
  36264    . S CNT=0  F  S CNT= $O(^TMP("R CDPTAR",$J ,DATE,CNT) ) Q:'CNT   D  I RCPG= 0 Q
  36265   "RTN","RCD PTAR",376, 0)
  36266    .. S DATA =^TMP("RCD PTAR",$J,D ATE,CNT)
  36267   "RTN","RCD PTAR",377, 0)
  36268    .. S LINE S=1
  36269   "RTN","RCD PTAR",378, 0)
  36270    .. I $P(D ATA,U,3)]" "!($P(DATA ,U,4)]"")  S LINES=2
  36271   "RTN","RCD PTAR",379, 0)
  36272    .. I RCSC R S LINES= LINES+1
  36273   "RTN","RCD PTAR",380, 0)
  36274    .. D CHKP (RCNOW,.RC PG,RCHR,RC DATA,RCSCR ,LINES) I  RCPG=0 Q
  36275   "RTN","RCD PTAR",381, 0)
  36276    .. W !,$$ DATE^RCDPR U(DATE,"2D Z"),?10,$P (DATA,U,1) ,?51,$P(DA TA,U,2)
  36277   "RTN","RCD PTAR",382, 0)
  36278    .. I $P(D ATA,U,3)]" "!($P(DATA ,U,4)]"")  W !,?10,$P (DATA,U,3) ,?51,$P(DA TA,U,4)
  36279   "RTN","RCD PTAR",383, 0)
  36280    ;
  36281   "RTN","RCD PTAR",384, 0)
  36282    I 'RCSCR  W !,@IOF
  36283   "RTN","RCD PTAR",385, 0)
  36284    I $D(ZTQU EUED) S ZT REQ="@" Q
  36285   "RTN","RCD PTAR",386, 0)
  36286    D ^%ZISC
  36287   "RTN","RCD PTAR",387, 0)
  36288    ;
  36289   "RTN","RCD PTAR",388, 0)
  36290    I RCPG,RC SCR D PAUS E
  36291   "RTN","RCD PTAR",389, 0)
  36292    Q
  36293   "RTN","RCD PTAR",390, 0)
  36294    ;
  36295   "RTN","RCD PTAR",391, 0)
  36296   HEADER(RCN OW,RCPG,RC HR,RCDATA)  ; Print H eader Sect ion
  36297   "RTN","RCD PTAR",392, 0)
  36298    ; Input:  RCNOW - DA TE/TIME in  external  format
  36299   "RTN","RCD PTAR",393, 0)
  36300    ;         RCPG - Cur rent page  number
  36301   "RTN","RCD PTAR",394, 0)
  36302    ;         RCHR - Lin e of "-" t o margin w idth
  36303   "RTN","RCD PTAR",395, 0)
  36304    ;         RCDATA - S ee subrout ine EFTDA  about for  delimited  list of fi elds
  36305   "RTN","RCD PTAR",396, 0)
  36306    ; Output:  Write sta tements
  36307   "RTN","RCD PTAR",397, 0)
  36308    ;
  36309   "RTN","RCD PTAR",398, 0)
  36310    N EFTDATA ,LINE
  36311   "RTN","RCD PTAR",399, 0)
  36312    S EFTDATA =$G(^RCY(3 44.31,+$P( RCDATA,U,3 ),0))
  36313   "RTN","RCD PTAR",400, 0)
  36314    ;
  36315   "RTN","RCD PTAR",401, 0)
  36316    W @IOF
  36317   "RTN","RCD PTAR",402, 0)
  36318    S RCPG=RC PG+1
  36319   "RTN","RCD PTAR",403, 0)
  36320    W "EFT TR ANSACTION  AUDIT REPO RT"
  36321   "RTN","RCD PTAR",404, 0)
  36322    S LINE=RC NOW_"   PA GE: "_RCPG _" "
  36323   "RTN","RCD PTAR",405, 0)
  36324    W ?(IOM-$ L(LINE)),L INE
  36325   "RTN","RCD PTAR",406, 0)
  36326    ;
  36327   "RTN","RCD PTAR",407, 0)
  36328    W !,"EFT# : ",$$AGED (+$P(RCDAT A,U,3)),$P (EFTDATA,U ,1),?19,"D EPOSIT#: " ,$P($G(^RC Y(344.3,+$ P(RCDATA,U ,2),0)),U, 6),?42,"EF T TOTAL AM T: "_$P(EF TDATA,U,7)
  36329   "RTN","RCD PTAR",408, 0)
  36330    W !,"EFT  TRACE#: ", $P(EFTDATA ,U,4)
  36331   "RTN","RCD PTAR",409, 0)
  36332    W !,"DATE  RECEIVED:  ",$$DATE^ RCDPRU($P( EFTDATA,U, 12)),?26," PAYER/ID:  "_$P(EFTDA TA,U,2)_"/ "_$P(EFTDA TA,U,3)
  36333   "RTN","RCD PTAR",410, 0)
  36334    ;
  36335   "RTN","RCD PTAR",411, 0)
  36336    W !,"DATE ",?10,"ACT ION/DETAIL S",?51,"ST ATUS"
  36337   "RTN","RCD PTAR",412, 0)
  36338    W !,RCHR
  36339   "RTN","RCD PTAR",413, 0)
  36340    Q
  36341   "RTN","RCD PTAR",414, 0)
  36342    ;
  36343   "RTN","RCD PTAR",415, 0)
  36344   PAUSE() ;  Pause at e nd of each  page for  user input
  36345   "RTN","RCD PTAR",416, 0)
  36346    ; Input:  None
  36347   "RTN","RCD PTAR",417, 0)
  36348    ; Output:  User resp onse
  36349   "RTN","RCD PTAR",418, 0)
  36350    ;
  36351   "RTN","RCD PTAR",419, 0)
  36352    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  36353   "RTN","RCD PTAR",420, 0)
  36354    S DIR(0)= "E"
  36355   "RTN","RCD PTAR",421, 0)
  36356    D ^DIR
  36357   "RTN","RCD PTAR",422, 0)
  36358    Q Y
  36359   "RTN","RCD PTAR",423, 0)
  36360    ;
  36361   "RTN","RCD PTAR",424, 0)
  36362   CHKP(RCNOW ,RCPG,RCHR ,RCDATA,RC SCR,LINES)  ; Check i f we need  to do a pa ge break
  36363   "RTN","RCD PTAR",425, 0)
  36364    ; Input:  RCNOW - DA TE/TIME in  external  format
  36365   "RTN","RCD PTAR",426, 0)
  36366    ;         RCPG - Cur rent page  number
  36367   "RTN","RCD PTAR",427, 0)
  36368    ;         RCHR - Lin e of "-" t o margin w idth
  36369   "RTN","RCD PTAR",428, 0)
  36370    ;         RCDATA - S ee subrout ine EFTDA  about for  delimited  list of fi elds
  36371   "RTN","RCD PTAR",429, 0)
  36372    ;         RCSCR - 1  - Output i s going to  the users  screen, 0  - to prin ter
  36373   "RTN","RCD PTAR",430, 0)
  36374    ;         LINES - Cu rrent line  count
  36375   "RTN","RCD PTAR",431, 0)
  36376    ;
  36377   "RTN","RCD PTAR",432, 0)
  36378    I $Y'>(IO SL-LINES)  Q
  36379   "RTN","RCD PTAR",433, 0)
  36380    I RCSCR,' $$PAUSE S  RCPG=0 Q
  36381   "RTN","RCD PTAR",434, 0)
  36382    D HEADER( RCNOW,.RCP G,RCHR,RCD ATA)
  36383   "RTN","RCD PTAR",435, 0)
  36384    Q
  36385   "RTN","RCD PTAR",436, 0)
  36386    ;
  36387   "RTN","RCD PTAR",437, 0)
  36388   AGED(EFTIE N) ; Check  if EFT is  locked or  stale
  36389   "RTN","RCD PTAR",438, 0)
  36390    ; Input
  36391   "RTN","RCD PTAR",439, 0)
  36392    ;    EFTI EN: IEN of  EDI THIRD  PARTY EFT  DETAIL (# 344.31)
  36393   "RTN","RCD PTAR",440, 0)
  36394    ; Output
  36395   "RTN","RCD PTAR",441, 0)
  36396    ;    "*"  - Warning;  "**" - Er ror; Null  - Good
  36397   "RTN","RCD PTAR",442, 0)
  36398    N DAYSLIM T,RECVDT,T RARRY
  36399   "RTN","RCD PTAR",443, 0)
  36400    S RECVDT= $$GET1^DIQ (344.31,EF TIEN_",",. 13,"I")
  36401   "RTN","RCD PTAR",444, 0)
  36402    I RECVDT< $$CUTOFF^R CDPEWLP Q  ""  ; EFTs  2 months  older than  *298 inst allation d o not lock  the syste m
  36403   "RTN","RCD PTAR",445, 0)
  36404    S DAYSLIM T("M")=$$G ET1^DIQ(34 4.61,1,.06 ),DAYSLIMT ("P")=$$GE T1^DIQ(344 .61,1,.07)
  36405   "RTN","RCD PTAR",446, 0)
  36406    D CHKEFT^ RCDPEWLP(R ECVDT,EFTI EN,"B",.DA YSLIMT,.TR ARRY)
  36407   "RTN","RCD PTAR",447, 0)
  36408    I $D(TRAR RY("ERROR" )) Q "**"
  36409   "RTN","RCD PTAR",448, 0)
  36410    I $D(TRAR RY("WARNIN G")) Q "*"
  36411   "RTN","RCD PTAR",449, 0)
  36412    Q ""
  36413   "RTN","RCD PURE1")
  36414   0^33^B7313 3259
  36415   "RTN","RCD PURE1",1,0 )
  36416   RCDPURE1 ; WISC/RFJ -  Process a  Receipt ; Jun 06, 20 14@19:11:1 9
  36417   "RTN","RCD PURE1",2,0 )
  36418    ;;4.5;Acc ounts Rece ivable;**1 14,148,153 ,169,204,1 73,214,217 ,296,298,3 04,321**;M ar 20, 199 5;Build 46
  36419   "RTN","RCD PURE1",3,0 )
  36420    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  36421   "RTN","RCD PURE1",4,0 )
  36422    Q
  36423   "RTN","RCD PURE1",5,0 )
  36424    ;
  36425   "RTN","RCD PURE1",6,0 )
  36426    ;
  36427   "RTN","RCD PURE1",7,0 )
  36428   PROCESS(RC RECTDA,RCS CREEN) ;   process a  receipt, u pdate ar,  generate c r/tr docum ents to fm s
  36429   "RTN","RCD PURE1",8,0 )
  36430    ;  the re ceipt and  deposit mu st be lock ed before  calling th is label
  36431   "RTN","RCD PURE1",9,0 )
  36432    ;  if $g( rcscreen)  = 1 show m essages du ring proce ssing
  36433   "RTN","RCD PURE1",10, 0)
  36434    ;  if $g( rcscreen)  = 2 store  messages d uring proc essing
  36435   "RTN","RCD PURE1",11, 0)
  36436    ; 
  36437   "RTN","RCD PURE1",12, 0)
  36438    N RCPAYDA ,RCDPFPAY, RCERROR,RC MSG,RCEFT, RCERA,RCPA YDT0,RCPAY DT1,RCSUSP AR,RCI,RCJ ,RCCMTFLG
  36439   "RTN","RCD PURE1",13, 0)
  36440    K ^TMP($J ,"RCDPEMSG "),^TMP("R CDPE-RECEI PT-ERROR", $J)
  36441   "RTN","RCD PURE1",14, 0)
  36442    S RCCMTFL G=""
  36443   "RTN","RCD PURE1",15, 0)
  36444    ;
  36445   "RTN","RCD PURE1",16, 0)
  36446    ; === No  comments = ==  PRCA*4 .5*304
  36447   "RTN","RCD PURE1",17, 0)
  36448    ; If ther e are entr ies in sus pense with  no commen ts, AND, p osting man ually, not  through a uto-postin g, display  the list  of entries
  36449   "RTN","RCD PURE1",18, 0)
  36450    I RCSCREE N=1 D  Q:R CCMTFLG
  36451   "RTN","RCD PURE1",19, 0)
  36452    . S RCSUS PAR="",RCP AYDA=0
  36453   "RTN","RCD PURE1",20, 0)
  36454    . F  S RC PAYDA=$O(^ RCY(344,RC RECTDA,1,R CPAYDA)) Q :'RCPAYDA   D
  36455   "RTN","RCD PURE1",21, 0)
  36456    . . S RCP AYDT0=$G(^ RCY(344,RC RECTDA,1,R CPAYDA,0))
  36457   "RTN","RCD PURE1",22, 0)
  36458    . . S RCP AYDT1=$G(^ RCY(344,RC RECTDA,1,R CPAYDA,1))
  36459   "RTN","RCD PURE1",23, 0)
  36460    . . ; If  there is n o Bill lin ked, and t he pay amo unt is not  0 and the re is no c omment, ad d to the l ist
  36461   "RTN","RCD PURE1",24, 0)
  36462    . . I $P( RCPAYDT0,U ,9)="",($P (RCPAYDT0, U,4)'=0),( $P(RCPAYDT 1,U,2)="")  S RCSUSPA R(RCPAYDA) =""
  36463   "RTN","RCD PURE1",25, 0)
  36464    . ;
  36465   "RTN","RCD PURE1",26, 0)
  36466    . S RCI=" " I $O(RCS USPAR(RCI) ) D  Q
  36467   "RTN","RCD PURE1",27, 0)
  36468    . . I '$G (RCSCREEN)  Q
  36469   "RTN","RCD PURE1",28, 0)
  36470    . . S RCM SG="The fo llowing li ne items a re in susp ense: "
  36471   "RTN","RCD PURE1",29, 0)
  36472    . . S RCJ ="" F  S R CJ=$O(RCSU SPAR(RCJ))  Q:'RCJ  D
  36473   "RTN","RCD PURE1",30, 0)
  36474    . . . S R CMSG=RCMSG _RCJ_","
  36475   "RTN","RCD PURE1",31, 0)
  36476    . . S RCM SG=$E(RCMS G,1,$L(RCM SG)-1)
  36477   "RTN","RCD PURE1",32, 0)
  36478    . . D MSG (RCMSG,RCS CREEN,"!!" )
  36479   "RTN","RCD PURE1",33, 0)
  36480    . . S RCM SG="Please  add the a ppropriate  comment(s ) to these  line item s before r e-processi ng this re ceipt."
  36481   "RTN","RCD PURE1",34, 0)
  36482    . . D MSG (RCMSG,RCS CREEN,"!!" )
  36483   "RTN","RCD PURE1",35, 0)
  36484    . . S RCC MTFLG=1
  36485   "RTN","RCD PURE1",36, 0)
  36486    ;
  36487   "RTN","RCD PURE1",37, 0)
  36488    ;  first  mark the r eceipt as  processed/ closed to  prevent ch anging the
  36489   "RTN","RCD PURE1",38, 0)
  36490    ;  data i f the rece ipt does n ot fully p rocess.  t his will l ock the
  36491   "RTN","RCD PURE1",39, 0)
  36492    ;  cancel  payment,  edit payme nt, etc. o ptions.  o nce a rece ipt is
  36493   "RTN","RCD PURE1",40, 0)
  36494    ;  proces sed, even  partially,  it should  not be ch anged.
  36495   "RTN","RCD PURE1",41, 0)
  36496    D MARKPRO C^RCDPUREC (RCRECTDA, "")
  36497   "RTN","RCD PURE1",42, 0)
  36498    ;
  36499   "RTN","RCD PURE1",43, 0)
  36500    ; Special  processin g needed f or EFT-rel ated recei pts
  36501   "RTN","RCD PURE1",44, 0)
  36502    ; RCEFT =  1 if EFT  deposit, =  2 if rece ipt detail  transfer,  0 if no E FT
  36503   "RTN","RCD PURE1",45, 0)
  36504    S RCEFT=+ $$EDILB^RC DPEU(RCREC TDA)
  36505   "RTN","RCD PURE1",46, 0)
  36506    S RCERA=$ P($G(^RCY( 344,RCRECT DA,0)),U,1 8)
  36507   "RTN","RCD PURE1",47, 0)
  36508    ;
  36509   "RTN","RCD PURE1",48, 0)
  36510    ;  === no  payments  ===
  36511   "RTN","RCD PURE1",49, 0)
  36512    ;  if the re are no  payments f or the rec eipt, quit
  36513   "RTN","RCD PURE1",50, 0)
  36514    I '$O(^RC Y(344,RCRE CTDA,1,0))  D  Q
  36515   "RTN","RCD PURE1",51, 0)
  36516    . I $G(RC SCREEN) S  RCMSG="Rec eipt does  not have a ny payment s and has  been marke d as proce ssed/close d." D MSG( RCMSG,RCSC REEN,"!!")
  36517   "RTN","RCD PURE1",52, 0)
  36518    . S ^TMP( "RCDPE-REC EIPT-ERROR ",$J)=RCMS G  ;prca*4 .5*298  us ed by auto -post proc ess
  36519   "RTN","RCD PURE1",53, 0)
  36520    . I RCERA  D UPDERA( RCERA)
  36521   "RTN","RCD PURE1",54, 0)
  36522    ;
  36523   "RTN","RCD PURE1",55, 0)
  36524    ;  check  to see if  the paymen ts have do llar amoun ts
  36525   "RTN","RCD PURE1",56, 0)
  36526    S RCPAYDA =0 F  S RC PAYDA=$O(^ RCY(344,RC RECTDA,1,R CPAYDA)) Q :'RCPAYDA   I $P($G(^ (RCPAYDA,0 )),"^",4)  S RCDPFPAY =1 Q
  36527   "RTN","RCD PURE1",57, 0)
  36528    I '$G(RCD PFPAY) D   Q
  36529   "RTN","RCD PURE1",58, 0)
  36530    . I $G(RC SCREEN)  S  RCMSG="Re ceipt does  not have  any paymen ts and has  been mark ed as proc essed/clos ed." D MSG (RCMSG,RCS CREEN,"!!" )
  36531   "RTN","RCD PURE1",59, 0)
  36532    . S ^TMP( "RCDPE-REC EIPT-ERROR ",$J)=RCMS G  ;prca*4 .5*298  us ed by auto -post proc ess
  36533   "RTN","RCD PURE1",60, 0)
  36534    . I RCERA  D UPDERA( RCERA)
  36535   "RTN","RCD PURE1",61, 0)
  36536    ;
  36537   "RTN","RCD PURE1",62, 0)
  36538    ;  === up date AR ac counts ===
  36539   "RTN","RCD PURE1",63, 0)
  36540    I $G(RCSC REEN) S RC MSG="Updat ing AR acc ounts..."  D MSG(RCMS G,RCSCREEN ,"!!")
  36541   "RTN","RCD PURE1",64, 0)
  36542    ;
  36543   "RTN","RCD PURE1",65, 0)
  36544    ;  loop p ayments an d apply to  account i n AR
  36545   "RTN","RCD PURE1",66, 0)
  36546    S RCPAYDA =0 F  S RC PAYDA=$O(^ RCY(344,RC RECTDA,1,R CPAYDA)) Q :'RCPAYDA   D  I RCER ROR Q
  36547   "RTN","RCD PURE1",67, 0)
  36548    . S RCERR OR=$$PROCE SS^RCBEPAY (RCRECTDA, RCPAYDA)
  36549   "RTN","RCD PURE1",68, 0)
  36550    . S:RCERR OR ^TMP("R CDPE-RECEI PT-ERROR", $J)=RCERRO R  ;prca*4 .5*298  us ed by auto -post proc ess
  36551   "RTN","RCD PURE1",69, 0)
  36552    ;
  36553   "RTN","RCD PURE1",70, 0)
  36554    ;  an err or occurre d during p rocessing  a payment
  36555   "RTN","RCD PURE1",71, 0)
  36556    I $G(RCER ROR) D  Q
  36557   "RTN","RCD PURE1",72, 0)
  36558    .   I '$G (RCSCREEN)  Q
  36559   "RTN","RCD PURE1",73, 0)
  36560    .   S RCM SG="+----- ---------- ---------- ---------- ---------- ---------- ---------- ---------- --+" D MSG (RCMSG,RCS CREEN,"!!" )
  36561   "RTN","RCD PURE1",74, 0)
  36562    .   S RCM SG="|  An  ERROR has  occurred w hen proces sing payme nt "_RCPAY DA_" on re ceipt "_$P (^RCY(344, RCRECTDA,0 ),"^")_"." ,RCMSG=$E( RCMSG_$J(" ",77),1,77 )_"|" D MS G(RCMSG,RC SCREEN,"!" )
  36563   "RTN","RCD PURE1",75, 0)
  36564    .   S RCM SG="|  The  error mes sage retur ned during  processin g is:",RCM SG=$E(RCMS G_$J("",77 ),1,77)_"| " D MSG(RC MSG,RCSCRE EN,"!")
  36565   "RTN","RCD PURE1",76, 0)
  36566    .   S RCM SG="|"_$J( "",77)_"|"  D MSG(RCM SG,RCSCREE N,"!")
  36567   "RTN","RCD PURE1",77, 0)
  36568    .   S RCM SG=$E("|   "_$P(RCERR OR,"^",2)_ $J("",77), 1,77)_"|"  D MSG(RCMS G,RCSCREEN ,"!")
  36569   "RTN","RCD PURE1",78, 0)
  36570    .   S RCM SG="|"_$J( "",77)_"|"  D MSG(RCM SG,RCSCREE N,"!")
  36571   "RTN","RCD PURE1",79, 0)
  36572    .   S RCM SG=$E("|   You will n eed to cor rect the e rror befor e you can  completely  process t he"_$J("", 77),1,77)_ "|" D MSG( RCMSG,RCSC REEN,"!")
  36573   "RTN","RCD PURE1",80, 0)
  36574    .   S RCM SG=$E("|   receipt.   Once the r eceipt is  completely  processed , the FMS  "_$S(RCEFT '=2:"Cash  Receipt",1 :"'TR'")_$ J("",77),1 ,77)_"|" D  MSG(RCMSG ,RCSCREEN, "!")
  36575   "RTN","RCD PURE1",81, 0)
  36576    .   S RCM SG=$E("|   document w ill be gen erated."_$ J("",77),1 ,77)_"|" D  MSG(RCMSG ,RCSCREEN, "!")
  36577   "RTN","RCD PURE1",82, 0)
  36578    .   S RCM SG="+----- ---------- ---------- ---------- ---------- ---------- ---------- ---------- --+" D MSG (RCMSG,RCS CREEN,"!")
  36579   "RTN","RCD PURE1",83, 0)
  36580    ;
  36581   "RTN","RCD PURE1",84, 0)
  36582    ;  all pa yments pro cessed cor rectly
  36583   "RTN","RCD PURE1",85, 0)
  36584    I RCERA D  UPDERA(RC ERA)
  36585   "RTN","RCD PURE1",86, 0)
  36586    I $G(RCSC REEN) D MS G(" Done." ,RCSCREEN)
  36587   "RTN","RCD PURE1",87, 0)
  36588    ;
  36589   "RTN","RCD PURE1",88, 0)
  36590    ;  *296 -  no cr doc ument for  event type  'a' or 'p ' or 't'
  36591   "RTN","RCD PURE1",89, 0)
  36592    N RCDPETY  S RCDPETY =$P($G(^RC Y(344,RCRE CTDA,0))," ^",4)
  36593   "RTN","RCD PURE1",90, 0)
  36594    I (RCDPET Y=15)!(RCD PETY=16)!( RCDPETY=13 ) D 215 Q
  36595   "RTN","RCD PURE1",91, 0)
  36596    ;
  36597   "RTN","RCD PURE1",92, 0)
  36598    ;  if no  deposit ti cket and n ot related  to EFT or  is a HAC  payment, d o not send  to fms
  36599   "RTN","RCD PURE1",93, 0)
  36600    I '$P(^RC Y(344,RCRE CTDA,0),"^ ",6),$S('R CEFT:1,1:$ $HACEFT^RC DPEU(+$P(^ RCY(344,RC RECTDA,0), U,17))) D   Q
  36601   "RTN","RCD PURE1",94, 0)
  36602    . D 215
  36603   "RTN","RCD PURE1",95, 0)
  36604    . I $G(RC SCREEN) S  RCMSG="Rec eipt does  not have a  deposit t icket and  will NOT b e sent to  FMS." D MS G(RCMSG,RC SCREEN,"!! ")
  36605   "RTN","RCD PURE1",96, 0)
  36606    . S ^TMP( "RCDPE-REC EIPT-ERROR ",$J)=""   ;prca*4.5* 298  used  by auto-po st process
  36607   "RTN","RCD PURE1",97, 0)
  36608    ;
  36609   "RTN","RCD PURE1",98, 0)
  36610    ;  === se nd fms cas h receipt  document = ==
  36611   "RTN","RCD PURE1",99, 0)
  36612    N GECSDAT A,FMSDOCNO ,RESULT,RE FMS
  36613   "RTN","RCD PURE1",100 ,0)
  36614    ;  lookup  fms docum ent number  to see if  the recei pt has bee n
  36615   "RTN","RCD PURE1",101 ,0)
  36616    ;  sent t o fms (fie ld 200 in  file 344)
  36617   "RTN","RCD PURE1",102 ,0)
  36618    S FMSDOCN O=$P($G(^R CY(344,RCR ECTDA,2)), "^")
  36619   "RTN","RCD PURE1",103 ,0)
  36620    ;  if the re is an e ntry, find  the code  sheet in g cs to rebu ild
  36621   "RTN","RCD PURE1",104 ,0)
  36622    ;  gecsda ta will be  the ien f or file 21 00.1
  36623   "RTN","RCD PURE1",105 ,0)
  36624    I FMSDOCN O'="" S RE FMS=1 N DI Q2 D DATA^ GECSSGET(F MSDOCNO,0)
  36625   "RTN","RCD PURE1",106 ,0)
  36626    ;
  36627   "RTN","RCD PURE1",107 ,0)
  36628    I $G(RCSC REEN)&$G(G ECSDATA) S  RCMSG="Re -Transmitt ing CR doc ument to F MS... " D  MSG(RCMSG, RCSCREEN," !!")
  36629   "RTN","RCD PURE1",108 ,0)
  36630    I $G(RCSC REEN)&'$G( GECSDATA)  S RCMSG="T ransmittin g CR docum ent to FMS ... " D MS G(RCMSG,RC SCREEN,"!! ")
  36631   "RTN","RCD PURE1",109 ,0)
  36632    ;
  36633   "RTN","RCD PURE1",110 ,0)
  36634    ;  build  and send t he tr/cr d ocument to  fms
  36635   "RTN","RCD PURE1",111 ,0)
  36636    I RCEFT'= 2 D  ; Sen d CR doc
  36637   "RTN","RCD PURE1",112 ,0)
  36638    . S RESUL T=$$BUILDC R^RCXFMSCR (RCRECTDA, +$G(GECSDA TA),RCEFT)
  36639   "RTN","RCD PURE1",113 ,0)
  36640    E  D  ; S end TR doc
  36641   "RTN","RCD PURE1",114 ,0)
  36642    . S RESUL T=$$GETTR^ RCXFMST1(R CRECTDA,+$ G(GECSDATA ))
  36643   "RTN","RCD PURE1",115 ,0)
  36644    ;  error  in buildin g code she et
  36645   "RTN","RCD PURE1",116 ,0)
  36646    I 'RESULT  D:$G(RCSC REEN) MSG( "ERROR - " _$P(RESULT ,"^",2),RC SCREEN,"!! ") Q
  36647   "RTN","RCD PURE1",117 ,0)
  36648    ;
  36649   "RTN","RCD PURE1",118 ,0)
  36650    ;  no doc ument to s end
  36651   "RTN","RCD PURE1",119 ,0)
  36652    I $P(RESU LT,"^")=-1 ,$G(RCSCRE EN) S RCMS G="NOTE -  "_$P(RESUL T,"^",2) S  $P(RESULT ,"^",2)=""  D MSG(RCM SG,RCSCREE N,"!!") S  ^TMP("RCDP E-RECEIPT- ERROR",$J) =""
  36653   "RTN","RCD PURE1",120 ,0)
  36654    ;  docume nt built a nd sent
  36655   "RTN","RCD PURE1",121 ,0)
  36656    I $P(RESU LT,"^")=1, $G(RCSCREE N) D
  36657   "RTN","RCD PURE1",122 ,0)
  36658    . N Z,DIE ,DR,DA
  36659   "RTN","RCD PURE1",123 ,0)
  36660    . D MSG(" Done. FMS  document n umber "_$P (RESULT,"^ ",2),RCSCR EEN,"!!")
  36661   "RTN","RCD PURE1",124 ,0)
  36662    . I +$O(^ RCY(344.4, "ARCT",RCR ECTDA,0))  S DIE="^RC Y(344.4,", DR=".14/// /1",DA=+$O (^RCY(344. 4,"ARCT",R CRECTDA,0) ) D ^DIE
  36663   "RTN","RCD PURE1",125 ,0)
  36664    . I $P($G (^RCY(344, RCRECTDA,0 )),U,17) S  Z=$P($G(^ RCY(344.31 ,+$P(^RCY( 344,RCRECT DA,0),U,17 ),0)),U,15 ) I Z'=""  S DA=RCREC TDA,DIE="^ RCY(344,", DR=".16/// /"_Z D ^DI E
  36665   "RTN","RCD PURE1",126 ,0)
  36666    I $G(RCSC REEN) D
  36667   "RTN","RCD PURE1",127 ,0)
  36668    . N Y
  36669   "RTN","RCD PURE1",128 ,0)
  36670    . I '$G(R EFMS)&(DT> $$LDATE^RC RJR(DT)) S  Y=$E($$FP S^RCAMFN01 (DT,1),1,5 )_"01" D D D^%DT W !!  S RCMSG="    * * * *  Transmiss ion will b e held unt il "_Y_" *  * * *" D  MSG(RCMSG, RCSCREEN," !!")
  36671   "RTN","RCD PURE1",129 ,0)
  36672    ;
  36673   "RTN","RCD PURE1",130 ,0)
  36674    ;
  36675   "RTN","RCD PURE1",131 ,0)
  36676    ;  store  the fms do cument num ber (recei pt already  marked pr ocessed/
  36677   "RTN","RCD PURE1",132 ,0)
  36678    ;  closed  at the to p of the r outine jus t before p osting the  dollars.
  36679   "RTN","RCD PURE1",133 ,0)
  36680    D MARKPRO C^RCDPUREC (RCRECTDA, $P(RESULT, "^",2))
  36681   "RTN","RCD PURE1",134 ,0)
  36682    I RCEFT=2  D MSG("No  215 repor t generate d for this  receipt", RCSCREEN," !!") G Q21 5
  36683   "RTN","RCD PURE1",135 ,0)
  36684    ;
  36685   "RTN","RCD PURE1",136 ,0)
  36686    ;
  36687   "RTN","RCD PURE1",137 ,0)
  36688   215 ;  ===  print 215  report == =
  36689   "RTN","RCD PURE1",138 ,0)
  36690    I $G(RCSC REEN) D MS G("Queuing  215 repor t...",RCSC REEN,"!!")
  36691   "RTN","RCD PURE1",139 ,0)
  36692    N DEVICE
  36693   "RTN","RCD PURE1",140 ,0)
  36694    S DEVICE= $$OPTCK^RC DPRPL2("21 5REPORT",3 )
  36695   "RTN","RCD PURE1",141 ,0)
  36696    I DEVICE= "" D:$G(RC SCREEN) MS G(" Use Cu stomize Op tion to se t up the d efault pri nter.",RCS CREEN) Q
  36697   "RTN","RCD PURE1",142 ,0)
  36698    ;
  36699   "RTN","RCD PURE1",143 ,0)
  36700    S ZTIO=DE VICE,ZTDTH =$H,ZTRTN= "DQ^RCDPR2 15",ZTSAVE ("RECEIPDA ")=RCRECTD A,ZTSAVE(" RCTYPE")=" A"
  36701   "RTN","RCD PURE1",144 ,0)
  36702    D ^%ZTLOA D,^%ZISC
  36703   "RTN","RCD PURE1",145 ,0)
  36704   Q215 I $G( RCSCREEN)  D MSG(" Do ne.",RCSCR EEN)
  36705   "RTN","RCD PURE1",146 ,0)
  36706    Q
  36707   "RTN","RCD PURE1",147 ,0)
  36708    ;
  36709   "RTN","RCD PURE1",148 ,0)
  36710   UPDERA(RCE RA) ; Upda te detail  posted sta tus for ER A entry RC ERA
  36711   "RTN","RCD PURE1",149 ,0)
  36712    ;
  36713   "RTN","RCD PURE1",150 ,0)
  36714    N DA,DIE, DR
  36715   "RTN","RCD PURE1",151 ,0)
  36716    S DA=+$G( RCERA),DR= ".14////1" ,DIE="^RCY (344.4," D :DA ^DIE
  36717   "RTN","RCD PURE1",152 ,0)
  36718    Q
  36719   "RTN","RCD PURE1",153 ,0)
  36720    ;
  36721   "RTN","RCD PURE1",154 ,0)
  36722   MSG(RCMSG, RCSCREEN,P RELINE,POS TLINE) ; W rite messa ge or set  into msg a rray
  36723   "RTN","RCD PURE1",155 ,0)
  36724    ; RCMSG =  text to w rite  RCSC REEN = scr een flag
  36725   "RTN","RCD PURE1",156 ,0)
  36726    ; PRELINE  = the lin e feeds to  print bef ore the te xt
  36727   "RTN","RCD PURE1",157 ,0)
  36728    ; POSTLIN E = the li ne feeds t o print af ter the te xt
  36729   "RTN","RCD PURE1",158 ,0)
  36730    Q:'RCSCRE EN
  36731   "RTN","RCD PURE1",159 ,0)
  36732    N RCPRE,R CPOST,Z
  36733   "RTN","RCD PURE1",160 ,0)
  36734    S RCPRE=$ L($G(PRELI NE),"!")-1 ,RCPOST=$L ($G(POSTLI NE),"!")-1
  36735   "RTN","RCD PURE1",161 ,0)
  36736    I RCSCREE N=1 D  G M SGQ
  36737   "RTN","RCD PURE1",162 ,0)
  36738    . F Z=1:1 :RCPRE W !
  36739   "RTN","RCD PURE1",163 ,0)
  36740    . W RCMSG
  36741   "RTN","RCD PURE1",164 ,0)
  36742    . F Z=1:1 :RCPOST W  !
  36743   "RTN","RCD PURE1",165 ,0)
  36744    F Z=1:1:R CPRE S ^TM P($J,"RCDP EMSG",+$O( ^TMP("RCDP EMSG",""), -1)+1)=""
  36745   "RTN","RCD PURE1",166 ,0)
  36746    S ^TMP($J ,"RCDPEMSG ",+$O(^TMP ("RCDPEMSG ",""),-1)+ 1)=RCMSG
  36747   "RTN","RCD PURE1",167 ,0)
  36748    F Z=1:1:R CPOST S ^T MP($J,"RCD PEMSG",+$O (^TMP("RCD PEMSG","") ,-1)+1)=""
  36749   "RTN","RCD PURE1",168 ,0)
  36750   MSGQ Q
  36751   "RTN","RCD PURE1",169 ,0)
  36752    ;
  36753   "RTN","RCD PURE1",170 ,0)
  36754    ; PRCA*4. 5*298 upda ted EDIT4  removing D IPA
  36755   "RTN","RCD PURE1",171 ,0)
  36756   EDIT4(DA,D R,RCDR1,RC DR2,RCDR3)  ; Modify  DR string  for type o f payment  edit
  36757   "RTN","RCD PURE1",172 ,0)
  36758    ;   for E DI Lockbox
  36759   "RTN","RCD PURE1",173 ,0)
  36760    ; Input:  DA,DR   Ou tput: RCDR 1,RCDR2,RC DR3
  36761   "RTN","RCD PURE1",174 ,0)
  36762    ; If type  unchanged , or neith er old/new  are EDI L ockbox, no  chk neede d
  36763   "RTN","RCD PURE1",175 ,0)
  36764    ; If old  type is ED I Lockbox  and scratc h pad exis ts, no cha nge allowe d
  36765   "RTN","RCD PURE1",176 ,0)
  36766    ; If chan ged to EDI  Lockbox a nd detail  already ex ists, no c hg allowed  without U NMATCH EFT  key
  36767   "RTN","RCD PURE1",177 ,0)
  36768    ; If chan ged to EDI  Lockbox,  ask for re lated EFT
  36769   "RTN","RCD PURE1",178 ,0)
  36770    N RCDR,RC LST,RCM,RC M1,RCM2,RC M3,RCN4,RC NE,RCNO,RC O4,RCOE,RC P,RCSTRT,Z ,Z0
  36771   "RTN","RCD PURE1",179 ,0)
  36772    S (RCDR1, RCDR2,RCDR 3)=""
  36773   "RTN","RCD PURE1",180 ,0)
  36774    ;
  36775   "RTN","RCD PURE1",181 ,0)
  36776    S RCP=10  F Z=2:1 Q: DR'[("@"_R CP)&(DR'[( "@"_(RCP+1 )))&(DR'[( "@"_(RCP+2 )))&(DR'[( "@"_(RCP+3 )))&(DR'[( "@"_(RCP+4 )))  S RCP =RCP*Z
  36777   "RTN","RCD PURE1",182 ,0)
  36778    ;
  36779   "RTN","RCD PURE1",183 ,0)
  36780    S Z=$L(DR ,".04;"),R CSTRT=1,RC LST=Z
  36781   "RTN","RCD PURE1",184 ,0)
  36782    I Z>2 D   ; Find .04 , not n.04
  36783   "RTN","RCD PURE1",185 ,0)
  36784    . F  S Z0 =$P(DR,".0 4;",RCSTRT ) Q:Z0=""! '$E(Z0,$L( Z0))  S RC STRT=RCSTR T+1
  36785   "RTN","RCD PURE1",186 ,0)
  36786    ;
  36787   "RTN","RCD PURE1",187 ,0)
  36788    ; If unch anged/chan ged from/t o other th an EDI Loc kbox, jump  over edit s
  36789   "RTN","RCD PURE1",188 ,0)
  36790    S RCDR1=" S RCP="_RC P_" D SETV ^RCDPURE1; "_$P(DR,". 04;",1,RCS TRT)
  36791   "RTN","RCD PURE1",189 ,0)
  36792    S RCDR2=" @"_RCP_";. 04;S RCNO= 0,RCN4=X D  TYP^RCDPU REC(.Y);.1 7////^S X= RCNE;S Y=" "@"_(RCP+2 )_""""
  36793   "RTN","RCD PURE1",190 ,0)
  36794    ; Reset f ield .04 a nd .17 if  not a vali d type cha nge
  36795   "RTN","RCD PURE1",191 ,0)
  36796    S RCDR2=R CDR2_";@"_ (RCP+1)_"; .04////^S  X=RCO4;I R COE="""" S  Y=""@"_(R CP+3)_"""; "
  36797   "RTN","RCD PURE1",192 ,0)
  36798    S RCDR2=R CDR2_".17/ ///^S X=RC OE;@"_(RCP +3)_";"
  36799   "RTN","RCD PURE1",193 ,0)
  36800    ; PRCA*4. 5*321 Modi fied error  message l ogic in $S
  36801   "RTN","RCD PURE1",194 ,0)
  36802    S RCDR2=R CDR2_"W !, *7,$S(RCN4 =14&RCNO:R CM2,RCO4=1 4:RCM1,1:R CM),! S Y= ""@"_RCP_" "";@"_(RCP +2)
  36803   "RTN","RCD PURE1",195 ,0)
  36804    S RCDR3=$ P(DR,".04; ",RCSTRT+1 ,RCLST)
  36805   "RTN","RCD PURE1",196 ,0)
  36806    Q
  36807   "RTN","RCD PURE1",197 ,0)
  36808    ;
  36809   "RTN","RCD PURE1",198 ,0)
  36810    ; PRCA*4. 5*298 upda ted SETV r emoving DI PA, added  comments
  36811   "RTN","RCD PURE1",199 ,0)
  36812   SETV ; Set  up variab les needed  to edit c hange of r eceipt typ e, used in  DR string s to edit  AR BATCH P AYMENT (#3 44)
  36813   "RTN","RCD PURE1",200 ,0)
  36814    ; RCO4 =  existing ( #.04) TYPE  OF PAYMEN T value, R COE = exis ting (#.17 ) EFT RECO RD value
  36815   "RTN","RCD PURE1",201 ,0)
  36816    N X S X=$ G(^RCY(344 ,DA,0)),RC O4=$P(X,U, 4),RCOE=$P (X,U,17)
  36817   "RTN","RCD PURE1",202 ,0)
  36818    S RCM="RC DPEPP key  required f or this ac tion"                              ; PCRA*4 .5*321
  36819   "RTN","RCD PURE1",203 ,0)
  36820    S RCM1="R CDPEPP key  required  once detai l has been  loaded fr om the ERA " ; PCRA*4 .5*321
  36821   "RTN","RCD PURE1",204 ,0)
  36822    S RCM2="M ust have a n EFT for  an EDI Loc kbox payme nt type"
  36823   "RTN","RCD PURE1",205 ,0)
  36824    S RCM3="> >If receip t is for a n ERA and  a paper ch eck, selec t the ERA  now"
  36825   "RTN","RCD PURE1",206 ,0)
  36826    Q
  36827   "RTN","RCD PURE1",207 ,0)
  36828    ;
  36829   "RTN","RCD PURE1",208 ,0)
  36830   WL(DA) ; F unction re turns 0 if  the workl ist did no t create t he receipt
  36831   "RTN","RCD PURE1",209 ,0)
  36832    ;  or the  ien of th e worklist  entry if  it did (34 4.4 and 34 4.49 are D INUMED)
  36833   "RTN","RCD PURE1",210 ,0)
  36834    N Z
  36835   "RTN","RCD PURE1",211 ,0)
  36836    S Z=+$O(^ RCY(344.4, "AREC",DA, 0))
  36837   "RTN","RCD PURE1",212 ,0)
  36838    Q Z
  36839   "RTN","RCD PURE1",213 ,0)
  36840    ;
  36841   "RTN","RCD PURE1",214 ,0)
  36842   HAC(RC) ;  Returns 1  if the rec eipt in RC  is relate d to a HAC  EFT
  36843   "RTN","RCD PURE1",215 ,0)
  36844    N Z,HAC
  36845   "RTN","RCD PURE1",216 ,0)
  36846    S HAC=0
  36847   "RTN","RCD PURE1",217 ,0)
  36848    ; ERA rel ated to an  EFT detai l record
  36849   "RTN","RCD PURE1",218 ,0)
  36850    S Z=+$G(^ RCY(344.31 ,+$P($G(^R CY(344,RC, 0)),U,17), 0))
  36851   "RTN","RCD PURE1",219 ,0)
  36852    ; Deposit  # in EFT  transmissi on starts  with HAC
  36853   "RTN","RCD PURE1",220 ,0)
  36854    I Z S Z=$ P($G(^RCY( 344.3,+Z,0 )),U,6) I  $E(Z,1,3)= "HAC" S HA C=1
  36855   "RTN","RCD PURE1",221 ,0)
  36856    Q HAC
  36857   "RTN","RCD PURE1",222 ,0)
  36858    ;
  36859   "RTN","RCD PUREC")
  36860   0^22^B1463 54431
  36861   "RTN","RCD PUREC",1,0 )
  36862   RCDPUREC ; WISC/RFJ -  receipt u tilities ; Jun 06, 20 14@19:11:1 9
  36863   "RTN","RCD PUREC",2,0 )
  36864    ;;4.5;Acc ounts Rece ivable;**1 14,148,169 ,173,208,2 22,293,298 ,321**;Mar  20, 1995; Build 46
  36865   "RTN","RCD PUREC",3,0 )
  36866    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  36867   "RTN","RCD PUREC",4,0 )
  36868    Q
  36869   "RTN","RCD PUREC",5,0 )
  36870    ;
  36871   "RTN","RCD PUREC",6,0 )
  36872   ADDRECT(TR ANDATE,RCD EPTDA,PAYT YPDA) ;  a dd a recei pt
  36873   "RTN","RCD PUREC",7,0 )
  36874    ;
  36875   "RTN","RCD PUREC",8,0 )
  36876    ;  if dep osit or pa yment type  is missin g, do not  add the re ceipt
  36877   "RTN","RCD PUREC",9,0 )
  36878    I 'RCDEPT DA!('PAYTY PDA) Q 0
  36879   "RTN","RCD PUREC",10, 0)
  36880    ;
  36881   "RTN","RCD PUREC",11, 0)
  36882    N DA,DATA ,RCDPFLAG, RECEIPT,TY PE
  36883   "RTN","RCD PUREC",12, 0)
  36884    ;  if a r eceipt has  already b een added  for this t ransmissio n date
  36885   "RTN","RCD PUREC",13, 0)
  36886    ;  and de posit numb er, do not  add a new  one
  36887   "RTN","RCD PUREC",14, 0)
  36888    S DA=0 F   S DA=$O(^ RCY(344,"A D",+RCDEPT DA,DA)) Q: 'DA  S DAT A=$G(^RCY( 344,DA,0))  I $P($P(D ATA,"^",3) ,".")=TRAN DATE,$P(DA TA,"^",4)= PAYTYPDA S  RCDPFLAG= 1 Q
  36889   "RTN","RCD PUREC",15, 0)
  36890    I $G(RCDP FLAG) Q DA
  36891   "RTN","RCD PUREC",16, 0)
  36892    ;
  36893   "RTN","RCD PUREC",17, 0)
  36894    Q $$BLDRC PT(TRANDAT E,RCDEPTDA ,PAYTYPDA)
  36895   "RTN","RCD PUREC",18, 0)
  36896    ;
  36897   "RTN","RCD PUREC",19, 0)
  36898   BLDRCPT(TR ANDATE,RCD EPTDA,PAYT YPDA) ; fu nction, Bu ild a rece ipt with/w ithout dep osit
  36899   "RTN","RCD PUREC",20, 0)
  36900    ; LAYGO n ew entry t o AR BATCH  PAYMENT f ile (#344)
  36901   "RTN","RCD PUREC",21, 0)
  36902    ; returns  new IEN o n success,  else zero
  36903   "RTN","RCD PUREC",22, 0)
  36904    ;
  36905   "RTN","RCD PUREC",23, 0)
  36906    N GOTONE, RECEIPT,TY PE
  36907   "RTN","RCD PUREC",24, 0)
  36908    ; ATTMPT  - count of  attempts
  36909   "RTN","RCD PUREC",25, 0)
  36910    ; GOTONE  - new rece ipt # flag
  36911   "RTN","RCD PUREC",26, 0)
  36912    S GOTONE= 0
  36913   "RTN","RCD PUREC",27, 0)
  36914    ;  build  unique rec eipt numbe r for date
  36915   "RTN","RCD PUREC",28, 0)
  36916    S TYPE=$E ($G(^RC(34 1.1,PAYTYP DA,0))) I  TYPE="" S  TYPE="Z"   ; ^RC(341. 1,0) = AR  EVENT TYPE
  36917   "RTN","RCD PUREC",29, 0)
  36918    I TYPE="C ",$G(RCDEP TDA)["ERAC HK" S RCDE PTDA=+RCDE PTDA,TYPE= "E" ; ERA  plus paper  check EDI  Lockbox r eceipt
  36919   "RTN","RCD PUREC",30, 0)
  36920    ;
  36921   "RTN","RCD PUREC",31, 0)
  36922    ; -----
  36923   "RTN","RCD PUREC",32, 0)
  36924    ; PRCA*4. 5*298 - re moved test ing code t hat allowe d for dupl icate rece ipt number s in testi ng environ ments
  36925   "RTN","RCD PUREC",33, 0)
  36926    ;   code  for checki ng environ ment: S PR OD=$S($$PR OD^XUPROD( 1):"PROD", 1:"TEST")
  36927   "RTN","RCD PUREC",34, 0)
  36928    ;   The u ser would  be prompte d for a du plicate re ceipt numb er of from  1 to 12 c hars:
  36929   "RTN","RCD PUREC",35, 0)
  36930    ;             S DIR( 0)="FAO^1: 12",DIR("A ")="ENTER  A DUPLICAT E RECEIPT  #: "
  36931   "RTN","RCD PUREC",36, 0)
  36932    ;   if us er didn't  enter dupl icate rece ipt #, the y would be  asked if  they wante d a
  36933   "RTN","RCD PUREC",37, 0)
  36934    ;   dupli cate recei pt # for t esting. If  yes, the  code would  iterate:
  36935   "RTN","RCD PUREC",38, 0)
  36936    ;         ;.. F  S R ECEIPT=$O( ^PRCA(433, "AF",RECEI PT)) D  Q: DONE
  36937   "RTN","RCD PUREC",39, 0)
  36938    ;         ;... I REC EIPT="" W  !!,"NO MOR E DUPLICAT E RECEIPT  NUMBER SCE NARIOS FOU ND!",! S D ONE=1 H 2  Q
  36939   "RTN","RCD PUREC",40, 0)
  36940    ;         ;... I '$D (^RCY(344, "B",RECEIP T)) D
  36941   "RTN","RCD PUREC",41, 0)
  36942    ;         ;.... W !! ,"RECEIPT  #: "_RECEI PT_" WAS F OUND & WE  WILL ATTEM PT TO USE  IT.",! S D ONE=1 H 2
  36943   "RTN","RCD PUREC",42, 0)
  36944    ; the cod e was crea ting probl ems during  the queue d nightly  job in dev elopment e nvironment s
  36945   "RTN","RCD PUREC",43, 0)
  36946    ;      Ac counts Rec eivable Ni ghtly Proc ess Backgr ound Job [ PRCA NIGHT LY PROCESS ]
  36947   "RTN","RCD PUREC",44, 0)
  36948    ; -----
  36949   "RTN","RCD PUREC",45, 0)
  36950    ;
  36951   "RTN","RCD PUREC",46, 0)
  36952    ;lockbox  receipt in  the form  of L980901 A0, do not  include c entury
  36953   "RTN","RCD PUREC",47, 0)
  36954    F  D  Q:+ GOTONE&$L( RECEIPT)   ; must be  new and no n-null
  36955   "RTN","RCD PUREC",48, 0)
  36956    .;find a  unique rec eipt #
  36957   "RTN","RCD PUREC",49, 0)
  36958    .S RECEIP T=$$NEXT(T YPE_$E(TRA NDATE,2,7) )  ;get la st two dig its from 0 0 to ZZ 
  36959   "RTN","RCD PUREC",50, 0)
  36960    .I RECEIP T="" Q
  36961   "RTN","RCD PUREC",51, 0)
  36962    .I $D(^RC Y(344,"B", RECEIPT))  Q  ; AR BA TCH PAYMEN T file (#3 44), RECEI PT # field  (#.01)
  36963   "RTN","RCD PUREC",52, 0)
  36964    .I $D(^PR CA(433,"AF ",RECEIPT) ) Q  ; AR  TRANSACTIO N file (#4 33), RECEI PT # field  (#13)
  36965   "RTN","RCD PUREC",53, 0)
  36966    .S GOTONE =1
  36967   "RTN","RCD PUREC",54, 0)
  36968    ;
  36969   "RTN","RCD PUREC",55, 0)
  36970    ;
  36971   "RTN","RCD PUREC",56, 0)
  36972    L +^RCY(3 44,"B",REC EIPT):DILO CKTM E  Q  0 ; PRCA*4 .5*298, if  LOCK time out return  zero
  36973   "RTN","RCD PUREC",57, 0)
  36974    ;
  36975   "RTN","RCD PUREC",58, 0)
  36976    ; add ent ry to AR B ATCH PAYME NT file (# 344)
  36977   "RTN","RCD PUREC",59, 0)
  36978    N %,%DT,D 0,DA,DD,DI ,DIC,DIE,D LAYGO,DO,D Q,DR,X,Y
  36979   "RTN","RCD PUREC",60, 0)
  36980    S DIC="^R CY(344,",D IC(0)="L", DLAYGO=344
  36981   "RTN","RCD PUREC",61, 0)
  36982    ;  .02 =  opened by                    .03  = date op ened = tra nsmission  dt
  36983   "RTN","RCD PUREC",62, 0)
  36984    ;  .04 =  type of pa yment             .06  = deposit  ticket
  36985   "RTN","RCD PUREC",63, 0)
  36986    ;  .14 =  status (se t to 1:ope n)
  36987   "RTN","RCD PUREC",64, 0)
  36988    S DIC("DR ")=".02/// /"_DUZ_";. 03///"_TRA NDATE_";.0 4////"_PAY TYPDA_$S(R CDEPTDA:"; .06////"_R CDEPTDA,1: "")_";.14/ ///1;"
  36989   "RTN","RCD PUREC",65, 0)
  36990    S X=RECEI PT
  36991   "RTN","RCD PUREC",66, 0)
  36992    D FILE^DI CN
  36993   "RTN","RCD PUREC",67, 0)
  36994    L -^RCY(3 44,"B",REC EIPT)
  36995   "RTN","RCD PUREC",68, 0)
  36996    I Y>0 Q + Y  ; Y set  by DICN,  return new  IEN
  36997   "RTN","RCD PUREC",69, 0)
  36998    Q 0  ; en try not cr eated
  36999   "RTN","RCD PUREC",70, 0)
  37000    ;
  37001   "RTN","RCD PUREC",71, 0)
  37002    ;
  37003   "RTN","RCD PUREC",72, 0)
  37004   NEXT(RECEI PT) ; func tion, get  next 2 cha rs. in seq uence 00 t o ZZ for r eceipt
  37005   "RTN","RCD PUREC",73, 0)
  37006    ;
  37007   "RTN","RCD PUREC",74, 0)
  37008    ;  start  with 00
  37009   "RTN","RCD PUREC",75, 0)
  37010    I '$D(^RC Y(344,"B", RECEIPT_"0 0")),'$D(^ RCY(344,"B ",RECEIPT_ "00A")) Q  RECEIPT_"0 0"
  37011   "RTN","RCD PUREC",76, 0)
  37012    ;
  37013   "RTN","RCD PUREC",77, 0)
  37014    N DIGIT1, DIGIT2,LAS T
  37015   "RTN","RCD PUREC",78, 0)
  37016    ;  get th e last one  used and  increment  by 1
  37017   "RTN","RCD PUREC",79, 0)
  37018    S LAST=$O (^RCY(344, "B",RECEIP T_"ZZ"),-1 )  ;exampl e L2980901 ZZ
  37019   "RTN","RCD PUREC",80, 0)
  37020    S DIGIT1= $A($E(LAST ,8)),DIGIT 2=$A($E(LA ST,9))
  37021   "RTN","RCD PUREC",81, 0)
  37022    ;  increm ent the as cii value  of last di git
  37023   "RTN","RCD PUREC",82, 0)
  37024    S DIGIT2= DIGIT2+1
  37025   "RTN","RCD PUREC",83, 0)
  37026    ;  ascii  48=0, 57=9 , 65=A, 90 =Z
  37027   "RTN","RCD PUREC",84, 0)
  37028    I DIGIT2> 57,DIGIT2< 65 S DIGIT 2=65 ;an A
  37029   "RTN","RCD PUREC",85, 0)
  37030    ;  digit2  above a Z , set digi t2 to a 0  and increm ent digit  1
  37031   "RTN","RCD PUREC",86, 0)
  37032    I DIGIT2> 90 S DIGIT 2=48,DIGIT 1=DIGIT1+1
  37033   "RTN","RCD PUREC",87, 0)
  37034    I DIGIT1> 57,DIGIT1< 65 S DIGIT 1=65 ;an A
  37035   "RTN","RCD PUREC",88, 0)
  37036    ;  digit  1 is above  a Z, rese t and reus e the Z
  37037   "RTN","RCD PUREC",89, 0)
  37038    I DIGIT1> 90 S DIGIT 1=90,DIGIT 2=90
  37039   "RTN","RCD PUREC",90, 0)
  37040    ;
  37041   "RTN","RCD PUREC",91, 0)
  37042    ; If Rece ipt # alre ady on fil e get anot her one
  37043   "RTN","RCD PUREC",92, 0)
  37044    F  Q:'$D( ^RCY(344," B",RECEIPT _$C(DIGIT1 )_$C(DIGIT 2)))  D
  37045   "RTN","RCD PUREC",93, 0)
  37046    . S RECEI PT=$E(RECE IPT,1)_$E( 1000001+$E (RECEIPT,2 ,7),2,7)
  37047   "RTN","RCD PUREC",94, 0)
  37048    ;
  37049   "RTN","RCD PUREC",95, 0)
  37050    Q RECEIPT _$C(DIGIT1 )_$C(DIGIT 2)
  37051   "RTN","RCD PUREC",96, 0)
  37052    ;
  37053   "RTN","RCD PUREC",97, 0)
  37054    ;
  37055   "RTN","RCD PUREC",98, 0)
  37056   SELRECT(AD DNEW,RCDEP TDA) ;  se lect a rec eipt
  37057   "RTN","RCD PUREC",99, 0)
  37058    ;  if $g( addnew) al low adding  a new rec eipt
  37059   "RTN","RCD PUREC",100 ,0)
  37060    ;  if $g( rcdeptda)  allow sele ction of r eceipts fo r the depo sit only
  37061   "RTN","RCD PUREC",101 ,0)
  37062    ;  if $g( addnew) an d $g(rcdep tda) depos it number  auto set f or new rec eipt
  37063   "RTN","RCD PUREC",102 ,0)
  37064    ;  return s -1 for t imeout or  ^, 0 for n o selectio n, or ien  of receipt
  37065   "RTN","RCD PUREC",103 ,0)
  37066    N %,%Y,C, D0,DA,DI,D IC,DIE,DIK ,DG,DLAYGO ,DQ,DR,DTO UT,DUOUT,R CREFLUP,X, Y,RCDE,RCL B,RC1,RC2, RCREQ,RCY
  37067   "RTN","RCD PUREC",104 ,0)
  37068    S DIC="^R CY(344,",D IC(0)="QEA M",DIC("A" )="Select  RECEIPT: "
  37069   "RTN","RCD PUREC",105 ,0)
  37070    S DIC("W" )="D DICW^ RCDPUREC"
  37071   "RTN","RCD PUREC",106 ,0)
  37072    ;  set sc reen to se lect recei pts linked  to deposi t and to s creen out
  37073   "RTN","RCD PUREC",107 ,0)
  37074    ;  select ion of EDI  Lockbox-t ype receip ts unless  an EFT is  associated
  37075   "RTN","RCD PUREC",108 ,0)
  37076    ;  with t he deposit  and the r eceipt is  not associ ated with  an ERA
  37077   "RTN","RCD PUREC",109 ,0)
  37078    S RCDE=+$ O(^RCY(344 .3,"ARDEP" ,+$G(RCDEP TDA),0))
  37079   "RTN","RCD PUREC",110 ,0)
  37080    I $G(RCDE PTDA) D
  37081   "RTN","RCD PUREC",111 ,0)
  37082    .   S DIC ("S")="N Z  S Z=$G(^( 0)) I $S(' $$EDILBEV^ RCDPEU($P( Z,U,4)):'R CDE,1:RCDE &'$P(Z,U,1 8)),($P(Z, U,6)=""""! ($P(Z,U,6) =RCDEPTDA) )"
  37083   "RTN","RCD PUREC",112 ,0)
  37084    .   S DIC ("A")="Sel ect RECEIP T (for dep osit "_$P( ^RCY(344.1 ,RCDEPTDA, 0),"^")_") : "
  37085   "RTN","RCD PUREC",113 ,0)
  37086    ;  use sp ecial look up on inpu t
  37087   "RTN","RCD PUREC",114 ,0)
  37088    I '$G(RCD EPTDA) S R CREFLUP=1
  37089   "RTN","RCD PUREC",115 ,0)
  37090    ;  add ne w entries
  37091   "RTN","RCD PUREC",116 ,0)
  37092    S RC1="TY PE NOT VAL ID FOR THI S RECEIPT" ,RC2=">>AN  EFT REFER ENCE IS RE QUIRED"
  37093   "RTN","RCD PUREC",117 ,0)
  37094    I $G(ADDN EW) D
  37095   "RTN","RCD PUREC",118 ,0)
  37096    .   S DIC ("A")="Sel ect RECEIP T (or add  a new one) : "
  37097   "RTN","RCD PUREC",119 ,0)
  37098    .   S DIC (0)="QEALM ",DLAYGO=3 44
  37099   "RTN","RCD PUREC",120 ,0)
  37100    .   S DIC ("DR")="S  RCREQ=0;.0 2////"_DUZ _";.03///N OW;.14//// 1;@4;.04"_ $S(RCDE:"/ ///"_$$LBE VENT^RCDPE U(),1:"")
  37101   "RTN","RCD PUREC",121 ,0)
  37102    .   S DIC ("DR")=DIC ("DR")_";S  RCLB=$$ED ILBEV^RCDP EU(+X) S:' RCLB Y=""@ 6"";I $G(R CDEPTDA) S  Y=$S('RCD E:""@8"",1 :""@6"");W  !,RC2 S R CREQ=1;.17 ;S Y=""@99 """
  37103   "RTN","RCD PUREC",122 ,0)
  37104    .   S DIC ("DR")=DIC ("DR")_";@ 6;.06"_$S( $G(RCDEPTD A):"////"_ RCDEPTDA,1 :"")_";S:' RCDE Y=""@ 99"";.17// //"_+RCDE_ ";S Y=""@9 9"";@8;W * 7,!,RC1 S  Y=""@4"";@ 99"
  37105   "RTN","RCD PUREC",123 ,0)
  37106    .   S DIC ("DR")=DIC ("DR")_";"
  37107   "RTN","RCD PUREC",124 ,0)
  37108    D ^DIC
  37109   "RTN","RCD PUREC",125 ,0)
  37110    S RCY=Y
  37111   "RTN","RCD PUREC",126 ,0)
  37112    I RCY<0,' $G(DUOUT), '$G(DTOUT)  S RCY=0
  37113   "RTN","RCD PUREC",127 ,0)
  37114    I $P(RCY, U,3),$G(RC REQ) D
  37115   "RTN","RCD PUREC",128 ,0)
  37116    . I '$P($ G(^RCY(344 ,+RCY,0)), U,17) D  Q
  37117   "RTN","RCD PUREC",129 ,0)
  37118    .. W !,*7 ,"NO EFT R EFERENCED  - RECEIPT  NOT ADDED"
  37119   "RTN","RCD PUREC",130 ,0)
  37120    .. S DA=+ RCY,DIK="^ RCY(344,"  D ^DIK
  37121   "RTN","RCD PUREC",131 ,0)
  37122    .. S RCY= 0
  37123   "RTN","RCD PUREC",132 ,0)
  37124    . S DIE=" ^RCY(344.3 1,",DA=$P( ^RCY(344,+ RCY,0),U,1 7),DR=".08 ////2" D ^ DIE
  37125   "RTN","RCD PUREC",133 ,0)
  37126    Q +RCY
  37127   "RTN","RCD PUREC",134 ,0)
  37128    ;
  37129   "RTN","RCD PUREC",135 ,0)
  37130    ;
  37131   "RTN","RCD PUREC",136 ,0)
  37132   DICW ;  wr ite identi fier code  for receip t lookup
  37133   "RTN","RCD PUREC",137 ,0)
  37134    N DATA
  37135   "RTN","RCD PUREC",138 ,0)
  37136    S DATA=$G (^RCY(344, Y,0)) I DA TA="" Q
  37137   "RTN","RCD PUREC",139 ,0)
  37138    ;  opened  by
  37139   "RTN","RCD PUREC",140 ,0)
  37140    W ?13,"by : ",$E($P( $G(^VA(200 ,+$P(DATA, "^",2),0)) ,"^"),1,15 )
  37141   "RTN","RCD PUREC",141 ,0)
  37142    ;  date o pened
  37143   "RTN","RCD PUREC",142 ,0)
  37144    I '$P(DAT A,"^",3) S  $P(DATA," ^",3)="??? ????"
  37145   "RTN","RCD PUREC",143 ,0)
  37146    W ?35," o n: ",$E($P (DATA,"^", 3),4,5),"/ ",$E($P(DA TA,"^",3), 6,7),"/",$ E($P(DATA, "^",3),2,3 )
  37147   "RTN","RCD PUREC",144 ,0)
  37148    ;  type o f payment
  37149   "RTN","RCD PUREC",145 ,0)
  37150    W ?50," " ,$E($P($G( ^RC(341.1, +$P(DATA," ^",4),0)), "^"),1,18)
  37151   "RTN","RCD PUREC",146 ,0)
  37152    ;  status
  37153   "RTN","RCD PUREC",147 ,0)
  37154    W ?70," " ,$S($P(DAT A,"^",14): "OPEN",1:" CLOSED")
  37155   "RTN","RCD PUREC",148 ,0)
  37156    Q
  37157   "RTN","RCD PUREC",149 ,0)
  37158    ;
  37159   "RTN","RCD PUREC",150 ,0)
  37160    ;
  37161   "RTN","RCD PUREC",151 ,0)
  37162   LOOKUP ;   special lo okup on re ceipts, ca lled from  ^dd(344,.0 1,7.5)
  37163   "RTN","RCD PUREC",152 ,0)
  37164    ;  if rcr eflup flag  not set,  do not use  special l ookup
  37165   "RTN","RCD PUREC",153 ,0)
  37166    I '$D(RCR EFLUP) Q
  37167   "RTN","RCD PUREC",154 ,0)
  37168    ;  user e ntered O.?  for looku p on open  receipts
  37169   "RTN","RCD PUREC",155 ,0)
  37170    I X["O."! (X["o.") S  DIC("S")= "I $P(^(0) ,U,14)" S  X="?" Q
  37171   "RTN","RCD PUREC",156 ,0)
  37172    ;  user e ntered C.?  for looku p on close d receipts
  37173   "RTN","RCD PUREC",157 ,0)
  37174    I X["C."! (X["c.") S  DIC("S")= "I '$P(^(0 ),U,14)" S  X="?" Q
  37175   "RTN","RCD PUREC",158 ,0)
  37176    K DIC("S" )
  37177   "RTN","RCD PUREC",159 ,0)
  37178    Q
  37179   "RTN","RCD PUREC",160 ,0)
  37180    ;
  37181   "RTN","RCD PUREC",161 ,0)
  37182    ; PRCA*4. 5*298 - up dated logi c and comm ents in ED ITREC
  37183   "RTN","RCD PUREC",162 ,0)
  37184   EDITREC(DA ,DR) ;  ed it the rec eipt (DR =  string of  fields to  ask) in A R BATCH PA YMENT file  (#344)
  37185   "RTN","RCD PUREC",163 ,0)
  37186    ; RCBPYMN T - AR BAT CH PAYMENT  entry bef ore edit
  37187   "RTN","RCD PUREC",164 ,0)
  37188    N D,D0,DI ,DIC,DIE,D Q,EFTKEY,R CBPYMNT,RC DA,RCDR1,R CDR2,RCDR3 ,X,Y
  37189   "RTN","RCD PUREC",165 ,0)
  37190    S (DIC,DI E)="^RCY(3 44,",RCDA= DA
  37191   "RTN","RCD PUREC",166 ,0)
  37192    S EFTKEY= $$EFTKEY()  ; PRCA*4. 5*321 - Ch eck if use r has key  to unmatch  EFTs
  37193   "RTN","RCD PUREC",167 ,0)
  37194    I $G(DR)= "" N DR D
  37195   "RTN","RCD PUREC",168 ,0)
  37196    . S DR=". 01;.04;"_$ S($P($G(^R CY(344,RCD A,0)),U,17 ):"",1:"I  $P($G(^RCY (344,DA,0) ),U,17) S  Y=""@1001" ";.06;@100 1;")_"D LB T^RCDPUREC (.Y);.18;@ 99"
  37197   "RTN","RCD PUREC",169 ,0)
  37198    ;
  37199   "RTN","RCD PUREC",170 ,0)
  37200    I $G(DR)[ ".04;" D   ; Add a ch eck to DR  string for  type of p ayment edi t
  37201   "RTN","RCD PUREC",171 ,0)
  37202    .D EDIT4^ RCDPURE1(R CDA,DR,.RC DR1,.RCDR2 ,.RCDR3)   ; get new  DR strings  in RCDR1, RCDR2,RCDR 3
  37203   "RTN","RCD PUREC",172 ,0)
  37204    .S DR=$S( $E(RCDR1,$ L(RCDR1))' =";":RCDR1 ,1:$E(RCDR 1,1,$L(RCD R1)-1)),DR (1,344,1)= RCDR2,DR(1 ,344,2)=RC DR3
  37205   "RTN","RCD PUREC",173 ,0)
  37206    ;
  37207   "RTN","RCD PUREC",174 ,0)
  37208    M RCBPYMN T=^RCY(344 ,DA)  ; sa ve initial  values
  37209   "RTN","RCD PUREC",175 ,0)
  37210    ;
  37211   "RTN","RCD PUREC",176 ,0)
  37212    D ^DIE
  37213   "RTN","RCD PUREC",177 ,0)
  37214    ;
  37215   "RTN","RCD PUREC",178 ,0)
  37216    ; (#.04)  TYPE OF PA YMENT [4P: 341.1], (# .06) DEPOS IT TICKET  [6P:344.1] , (#.17) E FT RECORD  [17P:344.3 1]
  37217   "RTN","RCD PUREC",179 ,0)
  37218    ; Delete  deposit if  EDI Lockb ox event a nd EFT ref erenced
  37219   "RTN","RCD PUREC",180 ,0)
  37220    I $P($G(^ RCY(344,RC DA,0)),U,6 ),$P(^(0), U,17),$$ED ILBEV^RCDP EU(+$P(^(0 ),U,4)) S  DIE="^RCY( 344,",DR=" .06///@" D  ^DIE
  37221   "RTN","RCD PUREC",181 ,0)
  37222    Q:'$D(^RC Y(344,RCDA ,0))  ; en try should  still exi st
  37223   "RTN","RCD PUREC",182 ,0)
  37224    ;
  37225   "RTN","RCD PUREC",183 ,0)
  37226    ; check i f TYPE OF  PAYMENT (# .04) chang ed from CH ECK/MO PAY MENT to ED I LOCKBOX,  update EF T on RECEI PT
  37227   "RTN","RCD PUREC",184 ,0)
  37228    I $P(RCBP YMNT(0),U, 4)=4,$P(^R CY(344,RCD A,0),U,4)= 14,$G(RCNE ) D
  37229   "RTN","RCD PUREC",185 ,0)
  37230    .K DA,DR  S DA=RCDA, DIE="^RCY( 344,",DR=" .17////"_R CNE D ^DIE
  37231   "RTN","RCD PUREC",186 ,0)
  37232    .D EFTUPD (RCNE,2) ;  PRCA*4.5* 321 - Chan ge EFT sta tus to PAP ER EOB MAT CH, notify  user.
  37233   "RTN","RCD PUREC",187 ,0)
  37234    .D PAUSE
  37235   "RTN","RCD PUREC",188 ,0)
  37236    ;
  37237   "RTN","RCD PUREC",189 ,0)
  37238    ; check i f TYPE OF  PAYMENT (# .04) chang ed from ED I LOCKBOX  to CHECK/M O PAYMENT,  remove EF T from REC EIPT and
  37239   "RTN","RCD PUREC",190 ,0)
  37240    ; update  EDI THIRD  PARTY EFT  DETAIL sta tus to UNM ATCHED
  37241   "RTN","RCD PUREC",191 ,0)
  37242    I $P(RCBP YMNT(0),U, 4)=14,$P(^ RCY(344,RC DA,0),U,4) =4 D
  37243   "RTN","RCD PUREC",192 ,0)
  37244    .N DA,DR, DIE
  37245   "RTN","RCD PUREC",193 ,0)
  37246    .S DA=RCD A,DIE="^RC Y(344,",DR =".17////@ " D ^DIE
  37247   "RTN","RCD PUREC",194 ,0)
  37248    .D EFTUPD (+$P(RCBPY MNT(0),U,1 7),0) ; PR CA*4.5*321  call to c hange EFT  status and  notify us er.
  37249   "RTN","RCD PUREC",195 ,0)
  37250    .D PAUSE
  37251   "RTN","RCD PUREC",196 ,0)
  37252    ;
  37253   "RTN","RCD PUREC",197 ,0)
  37254    ; PRCA*4. 5*321 - St art change d block of  code
  37255   "RTN","RCD PUREC",198 ,0)
  37256    ; If this  was an ED I LOCKBOX  receipt wh ere the EF T was chan ged insert  new EFT
  37257   "RTN","RCD PUREC",199 ,0)
  37258    ; and upd ate origin al EDI THI RD PARTY E FT DETAIL  status to  UNMATCHED
  37259   "RTN","RCD PUREC",200 ,0)
  37260    I $P(RCBP YMNT(0),U, 4)=14,$P(^ RCY(344,RC DA,0),U,4) =14,$G(RCN E),$P(RCBP YMNT(0),U, 17)'=RCNE  D
  37261   "RTN","RCD PUREC",201 ,0)
  37262    .N DA,DR, DIE
  37263   "RTN","RCD PUREC",202 ,0)
  37264    .S DA=RCD A,DIE="^RC Y(344,",DR =".17////" _RCNE D ^D IE
  37265   "RTN","RCD PUREC",203 ,0)
  37266    .D EFTUPD (+$P(RCBPY MNT(0),U,1 7),0) ; Ch ange EFT s tatus to U NMATCHED,  notify use r.
  37267   "RTN","RCD PUREC",204 ,0)
  37268    .D EFTUPD (RCNE,2) ;  Change EF T status t o PAPER EO B MATCH, n otify user .
  37269   "RTN","RCD PUREC",205 ,0)
  37270    .D PAUSE
  37271   "RTN","RCD PUREC",206 ,0)
  37272    ; PRCA*4. 5*321 - En d of chang ed block o f code.
  37273   "RTN","RCD PUREC",207 ,0)
  37274    ;
  37275   "RTN","RCD PUREC",208 ,0)
  37276    D LASTEDI T(RCDA)  ;  update (# .11) LAST  EDITED BY  , (#.12) D ATE/TIME L AST EDIT
  37277   "RTN","RCD PUREC",209 ,0)
  37278    ;
  37279   "RTN","RCD PUREC",210 ,0)
  37280    Q
  37281   "RTN","RCD PUREC",211 ,0)
  37282    ;
  37283   "RTN","RCD PUREC",212 ,0)
  37284    ; PRCA*4. 5*298 - up dated comm ents in LB T
  37285   "RTN","RCD PUREC",213 ,0)
  37286   LBT(Y) ; D etermine i f Y should  be set to  @99 in DR  string to  skip fiel d #.18 ERA  REFERENCE
  37287   "RTN","RCD PUREC",214 ,0)
  37288    ; DR(1,34 4,2)="I $P ($G(^RCY(3 44,DA,0)), U,17) S Y= ""@1001""; .06;@1001; D LBT^RCDP UREC(.Y);. 18;@99"
  37289   "RTN","RCD PUREC",215 ,0)
  37290    ;  code b elow assum es DA,RCM3  are set
  37291   "RTN","RCD PUREC",216 ,0)
  37292    N Z,Z0
  37293   "RTN","RCD PUREC",217 ,0)
  37294    ; Z will  be true if  TYPE OF P AYMENT [4P :341.1] is  EDI LOCKB OX
  37295   "RTN","RCD PUREC",218 ,0)
  37296    S Z0=$G(^ RCY(344,DA ,0)),Z=($P (Z0,U,4)=$ $LBEVENT^R CDPEU())
  37297   "RTN","RCD PUREC",219 ,0)
  37298    ; (#.18)  ERA REFERE NCE [18P:3 44.4]
  37299   "RTN","RCD PUREC",220 ,0)
  37300    ; Don't a llow to ed it ERA ref erence if  worklist c reated it
  37301   "RTN","RCD PUREC",221 ,0)
  37302    ;  ^DD(34 4.49,.02,0 ) = "RECEI PT #^P344' ^RCY(344,^ 0;2^Q"
  37303   "RTN","RCD PUREC",222 ,0)
  37304    I $P($G(^ RCY(344.49 ,+$P(Z0,U, 18),0)),U, 2)=DA S Y= "@99" Q
  37305   "RTN","RCD PUREC",223 ,0)
  37306    ; only as k for ERA  if not EDI  lockbox a nd deposit  # exists
  37307   "RTN","RCD PUREC",224 ,0)
  37308    I $S(Z:1, 1:'$P($G(^ RCY(344,DA ,0)),U,6))  S Y="@99"  Q
  37309   "RTN","RCD PUREC",225 ,0)
  37310    W !,RCM3   ; RCM,RCM 1,RCM2,RCM 3 set in S ETV^RCDPUR E1
  37311   "RTN","RCD PUREC",226 ,0)
  37312    Q
  37313   "RTN","RCD PUREC",227 ,0)
  37314    ;
  37315   "RTN","RCD PUREC",228 ,0)
  37316    ; PRCA*4. 5*298 - up dated logi c and comm ents in TY P
  37317   "RTN","RCD PUREC",229 ,0)
  37318   TYP(Y) ; D etermine w here to ju mp to in t he 'type'  edit of
  37319   "RTN","RCD PUREC",230 ,0)
  37320    ; Y - pas sed by ref . from DR  string log ic
  37321   "RTN","RCD PUREC",231 ,0)
  37322    ; DR(1,34 4,1)="@20; .04;S RCNO =0,RCN4=X  D TYP^RCDP UREC(.Y);. 17////^S X =RCNE;S Y= ""@22"";@2 1;.04////^ S X=RCO4;I  RCOE=""""  S Y=""@23 "";.17//// ^S X=RCOE; @23;W !,*7 ,$S(RCO4=1 4:$S('RCNO :RCM1,1:RC M2),1:RCM)  S Y=""@20 "";@22"
  37323   "RTN","RCD PUREC",232 ,0)
  37324    ;  Assume s RCP,RCNO ,RCN4,RCO4 ,DA define d
  37325   "RTN","RCD PUREC",233 ,0)
  37326    N DIR,RCC HANGE,RCEF TSWP
  37327   "RTN","RCD PUREC",234 ,0)
  37328    S RCEFTSW P=EFTKEY&( (RCO4=14)& (RCN4=14))  ; PRCA*4. 5*321 - Al low edit o f matched  EFT with s ecurity ke y
  37329   "RTN","RCD PUREC",235 ,0)
  37330    I $S(RCEF TSWP:0,RCN 4=RCO4:1,( RCO4'=4)&( RCN4'=4)&( RCO4'=14)& (RCN4'=14) :1,1:0) S  Y=RCP+2 G  TYPQ
  37331   "RTN","RCD PUREC",236 ,0)
  37332    ; To get  here, the  type was c hanged and  it either  was 4 or  14 OR is n ow 4 or 14
  37333   "RTN","RCD PUREC",237 ,0)
  37334    ; Or per  PRCA*4.5*2 31 user ha s unmatch  key and ty pe is 14 ( EDI LOCKBO X) 
  37335   "RTN","RCD PUREC",238 ,0)
  37336    S RCCHANG E=(RCN4'=R CO4)
  37337   "RTN","RCD PUREC",239 ,0)
  37338    I RCCHANG E D  G:Y T YPQ
  37339   "RTN","RCD PUREC",240 ,0)
  37340    .; If rec eipt Statu s is OPEN,  EDI LOCKB OX can onl y be chang ed to CHEC K/MO PAYME NT and vic e-versa
  37341   "RTN","RCD PUREC",241 ,0)
  37342    .I $P(^RC Y(344,DA,0 ),"^",14), (RCO4=4&(R CN4'=14))! (RCO4=14&( RCN4'=4))  D  S Y=RCP  Q  ; PRCA *4.5*321
  37343   "RTN","RCD PUREC",242 ,0)
  37344    ..S $P(^R CY(344,DA, 0),"^",4)= RCO4
  37345   "RTN","RCD PUREC",243 ,0)
  37346    ..W !!,"T he Payment  Type can  only be ch anged to "
  37347   "RTN","RCD PUREC",244 ,0)
  37348    ..W $S(RC O4=4:$$GET 1^DIQ(341. 1,14,.01), 1:$$GET1^D IQ(341.1,4 ,.01)),$C( 7),!
  37349   "RTN","RCD PUREC",245 ,0)
  37350    .; Type c an't be ch anged if t he old typ e was EDI  Lockbox an d there is  an ERA de tail recor d
  37351   "RTN","RCD PUREC",246 ,0)
  37352    .; associ ated with  it. Unless  user has  the UNMATC H EFT key.
  37353   "RTN","RCD PUREC",247 ,0)
  37354    .I 'EFTKE Y,RCO4=14, $P($G(^RCY (344,DA,0) ),U,18) S  Y=RCP+1 Q   ; PRCA*4. 5*321
  37355   "RTN","RCD PUREC",248 ,0)
  37356    .; Type c an't be ch anged to E DI Lockbox  if receip t detail a lready exi sts. Unles s user has  the
  37357   "RTN","RCD PUREC",249 ,0)
  37358    .; UNMATC H EFT key.
  37359   "RTN","RCD PUREC",250 ,0)
  37360    .I 'EFTKE Y,RCN4=14, $O(^RCY(34 4,DA,1,0))  S Y=RCP+1  Q          ; PRCA*4. 5*321
  37361   "RTN","RCD PUREC",251 ,0)
  37362    .; If pay ment type  was EDI LO CKBOX and  is to be c hanged to  CHECK/MO P AYMENT (or  vice-vers a) confirm  with user
  37363   "RTN","RCD PUREC",252 ,0)
  37364    .I (RCO4= 14&(RCN4=4 ))!(RCO4=4 &(RCN4=14) ) D  Q
  37365   "RTN","RCD PUREC",253 ,0)
  37366    ..K DIR S  DIR(0)="Y "
  37367   "RTN","RCD PUREC",254 ,0)
  37368    ..S DIR(" A")="Are y ou sure yo u want to  change Pay ment Type  to "_$$GET 1^DIQ(341. 1,RCN4,.01 ),DIR("B") ="NO"
  37369   "RTN","RCD PUREC",255 ,0)
  37370    ..W ! D ^ DIR W !
  37371   "RTN","RCD PUREC",256 ,0)
  37372    ..I 'Y S  $P(^RCY(34 4,DA,0),"^ ",4)=RCO4, Y=RCP Q
  37373   "RTN","RCD PUREC",257 ,0)
  37374    ..S:Y Y=R CP+2 S:RCN 4=14 Y=0
  37375   "RTN","RCD PUREC",258 ,0)
  37376    ;
  37377   "RTN","RCD PUREC",259 ,0)
  37378    I RCN4'=1 4 S Y=RCP+ 2
  37379   "RTN","RCD PUREC",260 ,0)
  37380    ; fall th rough to T YPQ
  37381   "RTN","RCD PUREC",261 ,0)
  37382   TYPQ ;
  37383   "RTN","RCD PUREC",262 ,0)
  37384    ; If type  changed t o EDI LOCK BOX, must  have an EF T referenc e
  37385   "RTN","RCD PUREC",263 ,0)
  37386    I '$G(Y)  D
  37387   "RTN","RCD PUREC",264 ,0)
  37388    .; If ERA  is matche d to EFT,  don't allo w to edit  EFT unless  user has  key PRCA*4 .5*321
  37389   "RTN","RCD PUREC",265 ,0)
  37390    .I 'EFTKE Y,$P($G(^R CY(344,DA, 0)),U,17), $P($G(^(0) ),U,18),$D (^RCY(344. 31,"AERA", +$P($G(^RC Y(344,DA,0 )),U,18),+ $P($G(^RCY (344,DA,0) ),U,17)))  S Y=RCP+2  Q
  37391   "RTN","RCD PUREC",266 ,0)
  37392    .S RCNE=$ $ASK17(DA)  I 'RCNE S  RCNO=1,Y= RCP+1 Q
  37393   "RTN","RCD PUREC",267 ,0)
  37394    ;
  37395   "RTN","RCD PUREC",268 ,0)
  37396    I $G(Y) S  Y="@"_Y
  37397   "RTN","RCD PUREC",269 ,0)
  37398    Q
  37399   "RTN","RCD PUREC",270 ,0)
  37400    ;
  37401   "RTN","RCD PUREC",271 ,0)
  37402   LASTEDIT(D A) ;  set  when recei pt last ed it
  37403   "RTN","RCD PUREC",272 ,0)
  37404    N %DT,D,D 0,DI,DIC,D IE,DQ,DR,X ,Y
  37405   "RTN","RCD PUREC",273 ,0)
  37406    S (DIC,DI E)="^RCY(3 44,"
  37407   "RTN","RCD PUREC",274 ,0)
  37408    S DR=".11 ////"_DUZ_ ";.12///NO W;"
  37409   "RTN","RCD PUREC",275 ,0)
  37410    D ^DIE
  37411   "RTN","RCD PUREC",276 ,0)
  37412    Q
  37413   "RTN","RCD PUREC",277 ,0)
  37414    ;
  37415   "RTN","RCD PUREC",278 ,0)
  37416    ;
  37417   "RTN","RCD PUREC",279 ,0)
  37418   MARKPROC(D A,FMSDOCNO ) ;  mark  receipt as  processed , set rece ipt as clo sed,
  37419   "RTN","RCD PUREC",280 ,0)
  37420    ;  store  fms docume nt number  if passed
  37421   "RTN","RCD PUREC",281 ,0)
  37422    N %DT,D,D 0,DI,DIC,D IE,DQ,DR,X ,Y
  37423   "RTN","RCD PUREC",282 ,0)
  37424    S (DIC,DI E)="^RCY(3 44,"
  37425   "RTN","RCD PUREC",283 ,0)
  37426    S DR=".07 ////"_DUZ_ ";.08///NO W;.14////0 ;"
  37427   "RTN","RCD PUREC",284 ,0)
  37428    I $G(FMSD OCNO)'=""  S DR=DR_"2 00////"_FM SDOCNO_";"
  37429   "RTN","RCD PUREC",285 ,0)
  37430    D ^DIE
  37431   "RTN","RCD PUREC",286 ,0)
  37432    Q
  37433   "RTN","RCD PUREC",287 ,0)
  37434    ;
  37435   "RTN","RCD PUREC",288 ,0)
  37436   FMSSTAT(RC RECTDA) ;   return th e fms cr d ocument ^  status ^ i f sent bef ore lockbo x
  37437   "RTN","RCD PUREC",289 ,0)
  37438    N FMSDOCN O,PRELOCK, STATUS
  37439   "RTN","RCD PUREC",290 ,0)
  37440    ;  get th e fms docu ment from  the receip t
  37441   "RTN","RCD PUREC",291 ,0)
  37442    S FMSDOCN O=$P($G(^R CY(344,RCR ECTDA,2)), "^")
  37443   "RTN","RCD PUREC",292 ,0)
  37444    ;  if not  on receip t, it may  be earlier  than lock box and on  deposit
  37445   "RTN","RCD PUREC",293 ,0)
  37446    I FMSDOCN O="" S FMS DOCNO=$P($ G(^RCY(344 .1,+$P($G( ^RCY(344,R CRECTDA,0) ),"^",6),2 )),"^") I  FMSDOCNO'= "" S PRELO CK=1
  37447   "RTN","RCD PUREC",294 ,0)
  37448    S STATUS= $$STATUS^G ECSSGET(FM SDOCNO)
  37449   "RTN","RCD PUREC",295 ,0)
  37450    I STATUS= -1 S STATU S="NOT ENT ERED"
  37451   "RTN","RCD PUREC",296 ,0)
  37452    ;
  37453   "RTN","RCD PUREC",297 ,0)
  37454    ;  if the  cr docume nt is ente red, check  to see if  entered o n line
  37455   "RTN","RCD PUREC",298 ,0)
  37456    I FMSDOCN O'="",$P($ G(^RCY(344 ,RCRECTDA, 2)),"^",2)  S STATUS= "ON LINE E NTRY"
  37457   "RTN","RCD PUREC",299 ,0)
  37458    ;
  37459   "RTN","RCD PUREC",300 ,0)
  37460    ;  if the  cr docume nt is miss ing, set s tatus to n ot sent
  37461   "RTN","RCD PUREC",301 ,0)
  37462    I FMSDOCN O="" S FMS DOCNO="NOT  SENT"
  37463   "RTN","RCD PUREC",302 ,0)
  37464    ;
  37465   "RTN","RCD PUREC",303 ,0)
  37466    Q FMSDOCN O_"^"_STAT US_"^"_$G( PRELOCK)
  37467   "RTN","RCD PUREC",304 ,0)
  37468    ;
  37469   "RTN","RCD PUREC",305 ,0)
  37470    ; PRCA*4. 5*321 - Up dated for  UNMATCH ke y changes
  37471   "RTN","RCD PUREC",306 ,0)
  37472   ASK17(DA)  ; function , Ask, ret urn the EF T detail r ecord IEN  for a rece ipt
  37473   "RTN","RCD PUREC",307 ,0)
  37474    ; Input:  DA = the i en of the  RECEIPT (f ile 344)
  37475   "RTN","RCD PUREC",308 ,0)
  37476    ; Returns : IEN in E DI THIRD P ARTY EFT D ETAIL (#34 4.31) or z ero
  37477   "RTN","RCD PUREC",309 ,0)
  37478    N DIR,OLD EFT,RCARR, QUIT,X,Y
  37479   "RTN","RCD PUREC",310 ,0)
  37480    S OLDEFT= $P($G(^RCY (344,DA,0) ),U,17)
  37481   "RTN","RCD PUREC",311 ,0)
  37482    S QUIT=0
  37483   "RTN","RCD PUREC",312 ,0)
  37484    I OLDEFT  D  I QUIT  Q 0 ; Quit  here if u ser does n ot want to  change EF T
  37485   "RTN","RCD PUREC",313 ,0)
  37486    . N DIR,D UOUT,DTOUT ,X,Y
  37487   "RTN","RCD PUREC",314 ,0)
  37488    . D GETS^ DIQ(344.31 ,OLDEFT_", ",".01;.02 ;.04;.07", "","RCARR" )
  37489   "RTN","RCD PUREC",315 ,0)
  37490    . W !,"Ex isting EFT :  "_RCARR (344.31,OL DEFT_",",. 01)_"      "_RCARR(34 4.31,OLDEF T_",",.02)
  37491   "RTN","RCD PUREC",316 ,0)
  37492    . W "      "_RCARR(3 44.31,OLDE FT_",",.04 )_"     "_ RCARR(344. 31,OLDEFT_ ",",.07)
  37493   "RTN","RCD PUREC",317 ,0)
  37494    . W !
  37495   "RTN","RCD PUREC",318 ,0)
  37496    . S DIR(0 )="Y",DIR( "B")="NO"
  37497   "RTN","RCD PUREC",319 ,0)
  37498    . S DIR(" A")="Match  a differe nt EFT to  this recei pt"
  37499   "RTN","RCD PUREC",320 ,0)
  37500    . S DIR(" ?",1)="The  receipt i s currentl y matched  to the EFT  listed ab ove."
  37501   "RTN","RCD PUREC",321 ,0)
  37502    . S DIR(" ?",2)="If  you answer  'Y' or 'Y ES' you wi ll be prom pted for a  different  EFT"
  37503   "RTN","RCD PUREC",322 ,0)
  37504    . S DIR(" ?",3)="to  match with  this rece ipt."
  37505   "RTN","RCD PUREC",323 ,0)
  37506    . S DIR(" ?")="If yo u answer ' N' or 'NO' , no chang e will be  made."
  37507   "RTN","RCD PUREC",324 ,0)
  37508    . D ^DIR
  37509   "RTN","RCD PUREC",325 ,0)
  37510    . I $D(DU OUT)!$D(DT OUT)!('Y)  S QUIT=1
  37511   "RTN","RCD PUREC",326 ,0)
  37512    ;
  37513   "RTN","RCD PUREC",327 ,0)
  37514   G17 ; Repr ompt for n ew EFT if  null is en tered.
  37515   "RTN","RCD PUREC",328 ,0)
  37516    S DIR(0)= "344,.17A^ "
  37517   "RTN","RCD PUREC",329 ,0)
  37518    S DIR("?" ,1)="Selec t the EFT  that conta ined the d eposited m oney that  this recei pt details "
  37519   "RTN","RCD PUREC",330 ,0)
  37520    S DIR("?" ,2)="An EF T detail r ecord can  only be as sociated w ith one re ceipt"
  37521   "RTN","RCD PUREC",331 ,0)
  37522    S DIR("?" )="This is  required  if the typ e of payme nt is EDI  LOCKBOX."
  37523   "RTN","RCD PUREC",332 ,0)
  37524    S DIR("A" )="  NEW E FT DETAIL  RECORD: "
  37525   "RTN","RCD PUREC",333 ,0)
  37526    S DIR("B" )=""
  37527   "RTN","RCD PUREC",334 ,0)
  37528    D ^DIR K  DIR
  37529   "RTN","RCD PUREC",335 ,0)
  37530    I $D(DUOU T)!$D(DTOU T)!(Y<0) Q  0
  37531   "RTN","RCD PUREC",336 ,0)
  37532    I Y="" D   G G17
  37533   "RTN","RCD PUREC",337 ,0)
  37534    . W !,*7, "Must have  an EFT fo r an EDI L ockbox pay ment type"
  37535   "RTN","RCD PUREC",338 ,0)
  37536    Q +Y
  37537   "RTN","RCD PUREC",339 ,0)
  37538    ;
  37539   "RTN","RCD PUREC",340 ,0)
  37540   EFTKEY() ; Check if u ser has UN MATCH EFT  key
  37541   "RTN","RCD PUREC",341 ,0)
  37542    ; Input:  None
  37543   "RTN","RCD PUREC",342 ,0)
  37544    ; Returns ; 1 if use r owns key  RCDPEPP;  otherwise  0.
  37545   "RTN","RCD PUREC",343 ,0)
  37546    N MSG
  37547   "RTN","RCD PUREC",344 ,0)
  37548    D OWNSKEY ^XUSRB(.MS G,"RCDPEPP ",DUZ)
  37549   "RTN","RCD PUREC",345 ,0)
  37550    Q MSG(0)
  37551   "RTN","RCD PUREC",346 ,0)
  37552    ;
  37553   "RTN","RCD PUREC",347 ,0)
  37554   EFTUPD(DA, MATCH) ; U pdate EFT  record if  payment ty pe is chan ged
  37555   "RTN","RCD PUREC",348 ,0)
  37556    ; Input:  DA = Inter nal entry  number of  EFT record .
  37557   "RTN","RCD PUREC",349 ,0)
  37558    ;         MATCH = Ne w match st atus for t he EFT
  37559   "RTN","RCD PUREC",350 ,0)
  37560    ; Output:  Notificat ion to use r screen,  RCMSG.
  37561   "RTN","RCD PUREC",351 ,0)
  37562    N DIE,DIR ,DR,RCMSG, X,Y
  37563   "RTN","RCD PUREC",352 ,0)
  37564    S DIE="^R CY(344.31, "
  37565   "RTN","RCD PUREC",353 ,0)
  37566    I DA S DR =".08////" _MATCH D ^ DIE
  37567   "RTN","RCD PUREC",354 ,0)
  37568    S Y=$$GET 1^DIQ(344. 31,DA_",", .01,"I")
  37569   "RTN","RCD PUREC",355 ,0)
  37570    I Y D  ;
  37571   "RTN","RCD PUREC",356 ,0)
  37572    . S RCMSG ="EFT TRAN SACTION "_ Y_" update d to "_$$G ET1^DIQ(34 4.31,DA_", ",.08,"E")
  37573   "RTN","RCD PUREC",357 ,0)
  37574    E  S RCMS G="* EFT R ECORD not  found! *"
  37575   "RTN","RCD PUREC",358 ,0)
  37576    W !,"   " _RCMSG
  37577   "RTN","RCD PUREC",359 ,0)
  37578    Q
  37579   "RTN","RCD PUREC",360 ,0)
  37580   PAUSE ; Pa use screen  till user  hits ente r
  37581   "RTN","RCD PUREC",361 ,0)
  37582    ; Input:  None
  37583   "RTN","RCD PUREC",362 ,0)
  37584    ; output:  None
  37585   "RTN","RCD PUREC",363 ,0)
  37586    N DIR,X,Y
  37587   "RTN","RCD PUREC",364 ,0)
  37588    S DIR(0)= "EA",DIR(" A")="Press  return: "  D ^DIR
  37589   "RTN","RCD PUREC",365 ,0)
  37590    Q
  37591   "RTN","RCD PURED")
  37592   0^38^B7439 1782
  37593   "RTN","RCD PURED",1,0 )
  37594   RCDPURED ; WISC/RFJ -  File 344  receipt/pa yment dd c alls ;1 Ju n 99
  37595   "RTN","RCD PURED",2,0 )
  37596    ;;4.5;Acc ounts Rece ivable;**1 14,169,174 ,196,202,2 44,268,271 ,304,301,3 12,319,321 **;Mar 20,  1995;Buil d 46
  37597   "RTN","RCD PURED",3,0 )
  37598    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  37599   "RTN","RCD PURED",4,0 )
  37600    ;
  37601   "RTN","RCD PURED",5,0 )
  37602    ; Referen ce to $$RE C^IBRFN su pported by  DBIA 2031
  37603   "RTN","RCD PURED",6,0 )
  37604    ;
  37605   "RTN","RCD PURED",7,0 )
  37606    Q
  37607   "RTN","RCD PURED",8,0 )
  37608    ;
  37609   "RTN","RCD PURED",9,0 )
  37610    ;
  37611   "RTN","RCD PURED",10, 0)
  37612    ;  *****  dd referen ces from f ile 344 (r eceipts) * ****
  37613   "RTN","RCD PURED",11, 0)
  37614    ;
  37615   "RTN","RCD PURED",12, 0)
  37616    ;
  37617   "RTN","RCD PURED",13, 0)
  37618   DUPLCATE ;   called b y input tr ansform re ceipt numb er (.01)
  37619   "RTN","RCD PURED",14, 0)
  37620    ;  make s ure no dup licate rec eipt numbe rs
  37621   "RTN","RCD PURED",15, 0)
  37622    I $O(^RCY (344,"B",X ,"")) K X  W !,"This  is a dupli cate recei pt number. " Q
  37623   "RTN","RCD PURED",16, 0)
  37624    I $O(^PRC A(433,"AF" ,X,"")) K  X W !,"Thi s receipt  number has  already b een used a nd has bee n purged f rom the sy stem. " K  X
  37625   "RTN","RCD PURED",17, 0)
  37626    Q
  37627   "RTN","RCD PURED",18, 0)
  37628    ;
  37629   "RTN","RCD PURED",19, 0)
  37630    ;
  37631   "RTN","RCD PURED",20, 0)
  37632   PAYCOUNT(R CRECTDA) ;   called b y computed  field num ber of tra nsactions  (101)
  37633   "RTN","RCD PURED",21, 0)
  37634    ;  return  the count  of paymen ts for the  receipt
  37635   "RTN","RCD PURED",22, 0)
  37636    N COUNT,X
  37637   "RTN","RCD PURED",23, 0)
  37638    S COUNT=0
  37639   "RTN","RCD PURED",24, 0)
  37640    S X=0 F   S X=$O(^RC Y(344,+$G( RCRECTDA), 1,X)) Q:'X   S COUNT= COUNT+1
  37641   "RTN","RCD PURED",25, 0)
  37642    Q COUNT
  37643   "RTN","RCD PURED",26, 0)
  37644    ;
  37645   "RTN","RCD PURED",27, 0)
  37646    ;
  37647   "RTN","RCD PURED",28, 0)
  37648   PAYTOTAL(R CRECTDA) ;   called b y computed  field tot al amount  of receipt s (.15)
  37649   "RTN","RCD PURED",29, 0)
  37650    ;  return  the total  dollars f or payment s entered  for the re ceipt
  37651   "RTN","RCD PURED",30, 0)
  37652    N TOTAL,X ,RCERAIEN, RCRECIPT ; PRCA319 -  added RCER AIEN and R CRECIPT
  37653   "RTN","RCD PURED",31, 0)
  37654    S TOTAL=0
  37655   "RTN","RCD PURED",32, 0)
  37656    ;S X=0 F   S X=$O(^R CY(344,+$G (RCRECTDA) ,1,X)) Q:' X  S TOTAL =TOTAL+$P( $G(^(X,0)) ,"^",4)
  37657   "RTN","RCD PURED",33, 0)
  37658    ;PRCA319  replaced l ine above  with next  section:
  37659   "RTN","RCD PURED",34, 0)
  37660    S RCERAIE N=$P($G(^R CY(344,+$G (RCRECTDA) ,0)),U,18)
  37661   "RTN","RCD PURED",35, 0)
  37662    I '$D(^RC Y(344.4,+$ G(RCERAIEN ),1,"RECEI PT")) D  Q  TOTAL ;no t a multi  receipt ER
  37663   "RTN","RCD PURED",36, 0)
  37664    .S X=0 F   S X=$O(^R CY(344,+$G (RCRECTDA) ,1,X)) Q:' X  S TOTAL =TOTAL+$P( $G(^(X,0)) ,"^",4)
  37665   "RTN","RCD PURED",37, 0)
  37666    S RCRECIP T=0 F  S R CRECIPT=$O (^RCY(344. 4,+$G(RCER AIEN),1,"R ECEIPT",RC RECIPT)) Q :+RCRECIPT =0  D
  37667   "RTN","RCD PURED",38, 0)
  37668    . S X=0 F   S X=$O(^ RCY(344,+$ G(RCRECIPT ),1,X)) Q: 'X  S TOTA L=TOTAL+$P ($G(^RCY(3 44,+$G(RCR ECIPT),1,X ,0)),"^",4 )
  37669   "RTN","RCD PURED",39, 0)
  37670    ;PRCA319  end of add ed section
  37671   "RTN","RCD PURED",40, 0)
  37672    Q TOTAL
  37673   "RTN","RCD PURED",41, 0)
  37674    ;
  37675   "RTN","RCD PURED",42, 0)
  37676    ;
  37677   "RTN","RCD PURED",43, 0)
  37678    ;  *****  dd referen ces from s ub-file 34 4.01 (tran sactions)  *****
  37679   "RTN","RCD PURED",44, 0)
  37680    ;
  37681   "RTN","RCD PURED",45, 0)
  37682    ;
  37683   "RTN","RCD PURED",46, 0)
  37684   CHGAMT ;   called fro m the inpu t transfor m on the t ransaction  amount (. 04)
  37685   "RTN","RCD PURED",47, 0)
  37686    ;  field.   if the a mount is c hanged, th is will cr eate a new  cancelled
  37687   "RTN","RCD PURED",48, 0)
  37688    ;  transa ction show ing the or iginal amo unt before  the chang e.
  37689   "RTN","RCD PURED",49, 0)
  37690    Q:$G(CSNO PROC)  ; p rca*4.5*30 1 ; LEG
  37691   "RTN","RCD PURED",50, 0)
  37692    N ORIGDAT A,TRANDA
  37693   "RTN","RCD PURED",51, 0)
  37694    S ORIGDAT A=^RCY(344 ,DA(1),1,D A,0)
  37695   "RTN","RCD PURED",52, 0)
  37696    ;  no ori ginal paym ent amount
  37697   "RTN","RCD PURED",53, 0)
  37698    I '$P(ORI GDATA,"^", 4) Q
  37699   "RTN","RCD PURED",54, 0)
  37700    ;  paymen t amount d id not cha nge
  37701   "RTN","RCD PURED",55, 0)
  37702    I +$P(ORI GDATA,"^", 4)=+X Q
  37703   "RTN","RCD PURED",56, 0)
  37704    ;  paymen t amount i ncreased
  37705   "RTN","RCD PURED",57, 0)
  37706    I $P(ORIG DATA,"^",4 )<X Q
  37707   "RTN","RCD PURED",58, 0)
  37708    ;PRCA*4.5 *304 - sur press new  transactio n if from  Multiple s plit Link  Payment.
  37709   "RTN","RCD PURED",59, 0)
  37710    ;  undecl ared param eter RCSPR SS is defi ned (only  defined in  RCDPLPL4)
  37711   "RTN","RCD PURED",60, 0)
  37712    I $G(RCSP RSS) Q
  37713   "RTN","RCD PURED",61, 0)
  37714    ;  amount  was chang ed
  37715   "RTN","RCD PURED",62, 0)
  37716    ;  enter  a new tran saction
  37717   "RTN","RCD PURED",63, 0)
  37718    S TRANDA= $$ADDTRAN^ RCDPURET(D A(1))
  37719   "RTN","RCD PURED",64, 0)
  37720    I 'TRANDA  W !,"  Un able to ed it amount. " K X Q
  37721   "RTN","RCD PURED",65, 0)
  37722    ;  copy t he current  data for  the transa ction
  37723   "RTN","RCD PURED",66, 0)
  37724    ;  do not  use filem an, will o verwrite v ariables
  37725   "RTN","RCD PURED",67, 0)
  37726    ;  set th e cancel c omment (fi eld 1.01)
  37727   "RTN","RCD PURED",68, 0)
  37728    S $P(^RCY (344,DA(1) ,1,TRANDA, 1),"^")="A mount $"_$ P(ORIGDATA ,"^",4)_"  decreased  in origina l trans#"_ DA
  37729   "RTN","RCD PURED",69, 0)
  37730    ;  set th e payment  amount to  zero (for  cancelled)
  37731   "RTN","RCD PURED",70, 0)
  37732    S $P(ORIG DATA,"^",4 )=0
  37733   "RTN","RCD PURED",71, 0)
  37734    S $P(ORIG DATA,"^",1 4)=DUZ
  37735   "RTN","RCD PURED",72, 0)
  37736    S $P(^RCY (344,DA(1) ,1,TRANDA, 0),"^",2,9 9)=$P(ORIG DATA,"^",2 ,99)
  37737   "RTN","RCD PURED",73, 0)
  37738    Q
  37739   "RTN","RCD PURED",74, 0)
  37740    ;
  37741   "RTN","RCD PURED",75, 0)
  37742    ;
  37743   "RTN","RCD PURED",76, 0)
  37744   PAYCHK ;   called fro m the inpu t transfor m on the t ransaction  amount (. 04)
  37745   "RTN","RCD PURED",77, 0)
  37746    ;  field.   This wil l compare  the amount  paid with  the amoun t owed
  37747   "RTN","RCD PURED",78, 0)
  37748    ;  for a  bill.
  37749   "RTN","RCD PURED",79, 0)
  37750    Q:$G(CSNO PROC)  ; p rca*4.5*30 1 ; LEG
  37751   "RTN","RCD PURED",80, 0)
  37752    N ACCOUNT ,AMOUNT,OW ED
  37753   "RTN","RCD PURED",81, 0)
  37754    S ACCOUNT =$P($G(^RC Y(344,DA(1 ),1,DA,0)) ,"^",3)
  37755   "RTN","RCD PURED",82, 0)
  37756    ;  quit,  account no t a bill
  37757   "RTN","RCD PURED",83, 0)
  37758    I ACCOUNT '["PRCA(43 0," Q
  37759   "RTN","RCD PURED",84, 0)
  37760    ;  quit,  account is  a patient
  37761   "RTN","RCD PURED",85, 0)
  37762    I $P($G(^ RCD(340,+$ P($G(^PRCA (430,+ACCO UNT,0)),"^ ",9),0))," ^")[";DPT( " Q
  37763   "RTN","RCD PURED",86, 0)
  37764    ;  calcul ate amount  owed for  a bill
  37765   "RTN","RCD PURED",87, 0)
  37766    S OWED=$G (^PRCA(430 ,+ACCOUNT, 7))
  37767   "RTN","RCD PURED",88, 0)
  37768    S OWED=$P (OWED,"^") +$P(OWED," ^",2)+$P(O WED,"^",3) +$P(OWED," ^",4)+$P(O WED,"^",5)
  37769   "RTN","RCD PURED",89, 0)
  37770    ;  compar e amount p aid (in x)  with amou nt owed (i f not proc essed 0;7)
  37771   "RTN","RCD PURED",90, 0)
  37772    I X>OWED, '$P($G(^RC Y(344,DA(1 ),0)),"^", 7) W "  WA RNING: Pay ment amoun t greater  than amoun t of bill! "
  37773   "RTN","RCD PURED",91, 0)
  37774    ;  check  for other  bills
  37775   "RTN","RCD PURED",92, 0)
  37776    S AMOUNT= $$EOB^IBCN SBL2(+ACCO UNT,+$P($G (^PRCA(430 ,+ACCOUNT, 0)),"^",3) ,$$PAID^PR CAFN1(+ACC OUNT))
  37777   "RTN","RCD PURED",93, 0)
  37778    I AMOUNT  W !!,$P(AM OUNT,"^",2 )," may al so be bill able.",!
  37779   "RTN","RCD PURED",94, 0)
  37780    Q
  37781   "RTN","RCD PURED",95, 0)
  37782    ;
  37783   "RTN","RCD PURED",96, 0)
  37784    ;
  37785   "RTN","RCD PURED",97, 0)
  37786   PNORBILL ;   called b y the inpu t transfor m in recei pt file 34 4, transac tion
  37787   "RTN","RCD PURED",98, 0)
  37788    ;  multip le (field  1), patien t name or  bill numbe r (sub fie ld .09)
  37789   "RTN","RCD PURED",99, 0)
  37790    S CSNOPRO C=0 I $G(R CDCHKSW)=0 ,$G(HRCDCK SW) S RCDC HKSW=1 ; p rca*4.5*30 1 ; LEG
  37791   "RTN","RCD PURED",100 ,0)
  37792    I $L(X)>2 0!($L(X)<1 ) K X Q
  37793   "RTN","RCD PURED",101 ,0)
  37794    ;
  37795   "RTN","RCD PURED",102 ,0)
  37796    N DFN,RCB ILL,RCINPU T,RCOUTPUT ,Y,RCTYP,D IC,RCDISP, RCLKFLG,RC PAY,RCPMTT YP,RCMSG
  37797   "RTN","RCD PURED",103 ,0)
  37798    ;
  37799   "RTN","RCD PURED",104 ,0)
  37800    S RCINPUT =$TR(X,"ab cdefghijkl mnopqrstuv wxyz","ABC DEFGHIJKLM NOPQRSTUVW XYZ")
  37801   "RTN","RCD PURED",105 ,0)
  37802    ;  try an d lookup o n bill num ber
  37803   "RTN","RCD PURED",106 ,0)
  37804    I $G(RCDC HKSW),$G(R CRECTDA),$ G(RCTRANDA ) S RCPMTT YP=$P($G(^ RCY(344,RC RECTDA,1,R CTRANDA,0) ),"^",19)      ;prc*4 .5*301
  37805   "RTN","RCD PURED",107 ,0)
  37806    S X=$S($O (^PRCA(430 ,"B",RCINP UT,0)):$O( ^(0))_";PR CA(430,",$ O(^PRCA(43 0,"D",RCIN PUT,0)):$O (^(0))_";P RCA(430,", 1:RCINPUT)
  37807   "RTN","RCD PURED",108 ,0)
  37808    I X[";PRC A(430," D  DISPLAY(X)   ; PRCA*4 .5*301; LE G
  37809   "RTN","RCD PURED",109 ,0)
  37810    I '$G(RCD CHKSW),X[" ;PRCA(430, " I $D(^PR CA(430,"TC SP",+X)) D   Q  ; PRC A*4.5*301
  37811   "RTN","RCD PURED",110 ,0)
  37812    . W !," B ILL HAS BE EN REFERRE D TO CROSS -SERVICING .",!," NO  MANUAL PAY MENTS ARE  ALLOWED."
  37813   "RTN","RCD PURED",111 ,0)
  37814    . S X="^" ,CSNOPROC= 1
  37815   "RTN","RCD PURED",112 ,0)
  37816    ;prca*4.5 *301
  37817   "RTN","RCD PURED",113 ,0)
  37818    I $G(RCDC HKSW),$G(R CPMTTYP),X [";PRCA(43 0," D  Q:C SNOPROC=1
  37819   "RTN","RCD PURED",114 ,0)
  37820    . I RCPMT TYP=170,$D (^PRCA(430 ,"TCSP",+X )) Q
  37821   "RTN","RCD PURED",115 ,0)
  37822    . I RCPMT TYP=170,'$ D(^PRCA(43 0,"TCSP",+ X)) S RCMS G=1 D ERRM SG Q
  37823   "RTN","RCD PURED",116 ,0)
  37824    . I RCPMT TYP=168,$D (^PRCA(430 ,"TCSP",+X )) S RCMSG =3 D ERRMS G Q
  37825   "RTN","RCD PURED",117 ,0)
  37826    . I RCPMT TYP=169,$D (^PRCA(430 ,"TCSP",+X )) S RCMSG =2 D ERRMS G Q
  37827   "RTN","RCD PURED",118 ,0)
  37828    . I RCPMT TYP<168!(R CPMTTYP>17 0),$D(^PRC A(430,"TCS P",+X)) S  RCMSG=4 D  ERRMSG Q
  37829   "RTN","RCD PURED",119 ,0)
  37830    ;  bill n ot found,  try and lo okup on pa tient
  37831   "RTN","RCD PURED",120 ,0)
  37832    ;PRCA*4.5 *304 - Ech o info bac k to the u ser if not  surpresse d
  37833   "RTN","RCD PURED",121 ,0)
  37834    I X=RCINP UT S DIC=" ^DPT(",DIC (0)=$S($G( RCSPRSS):" M",1:"EM")  D ^DIC S  X=+Y_";DPT ("
  37835   "RTN","RCD PURED",122 ,0)
  37836    ;  new va lue in var iable X (o utput in X )
  37837   "RTN","RCD PURED",123 ,0)
  37838    ;
  37839   "RTN","RCD PURED",124 ,0)
  37840    ;PRCA*4.5 *304 - all ow EDI Loc kbox payme nt type to  look up b ills by EC ME and RX  #'s
  37841   "RTN","RCD PURED",125 ,0)
  37842    ;  patien t not foun d, type of  payment =  check/mo  or EDI LOC KBOX
  37843   "RTN","RCD PURED",126 ,0)
  37844    S RCPAY=$ P($G(^RCY( 344,DA(1), 0)),"^",4)
  37845   "RTN","RCD PURED",127 ,0)
  37846    S RCLKFLG =$S(RCPAY= 4:1,RCPAY= 14:1,1:0)
  37847   "RTN","RCD PURED",128 ,0)
  37848    I +$G(Y)< 0,RCLKFLG  D
  37849   "RTN","RCD PURED",129 ,0)
  37850    .   S (X, Y)=$$REC^I BRFN(RCINP UT,.RCTYP, .RCDISP),( RCBILL,X)= X_";PRCA(4 30,"    ;  DBIA 2031
  37851   "RTN","RCD PURED",130 ,0)
  37852    .   I Y>0  D
  37853   "RTN","RCD PURED",131 ,0)
  37854    .   .   N  DIR,DIQ2, DIRUT,DTOU T,DUOUT,RC PRM
  37855   "RTN","RCD PURED",132 ,0)
  37856    .   .   S  RCTYP=$G( RCTYP,1)
  37857   "RTN","RCD PURED",133 ,0)
  37858    .   .   S  RCPRM=$S( RCTYP=1:"T RICARE ref erence num ber",RCTYP =2:"ECME R x referenc e number", RCTYP=3:"p rescriptio n number", 1:"referen ce number" )
  37859   "RTN","RCD PURED",134 ,0)
  37860    .   .   S  DIR("A")= "Is this " _RCPRM_" -  "_$S($G(R CDISP)'="" :RCDISP,1: RCINPUT)
  37861   "RTN","RCD PURED",135 ,0)
  37862    .   .   S  DIR("B")= "No",DIR(" A",1)=" "
  37863   "RTN","RCD PURED",136 ,0)
  37864    .   .   S  DIR(0)="Y ^O" D ^DIR  S:'Y Y=-1
  37865   "RTN","RCD PURED",137 ,0)
  37866    .   .   I  Y'>0 Q
  37867   "RTN","RCD PURED",138 ,0)
  37868    .   .   I  '$G(RCSPR SS) W !!,$ P($G(^PRCA (430,+RCBI LL,0)),"^" )," "  ;PR CA*4.5*304
  37869   "RTN","RCD PURED",139 ,0)
  37870    .   .   D  DISPLAY(R CBILL)
  37871   "RTN","RCD PURED",140 ,0)
  37872    .   .   S  X=RCBILL
  37873   "RTN","RCD PURED",141 ,0)
  37874    ;  output  in variab le X
  37875   "RTN","RCD PURED",142 ,0)
  37876    ;
  37877   "RTN","RCD PURED",143 ,0)
  37878    I +$G(Y)< 0 K X Q
  37879   "RTN","RCD PURED",144 ,0)
  37880    ;
  37881   "RTN","RCD PURED",145 ,0)
  37882    S RCOUTPU T=X
  37883   "RTN","RCD PURED",146 ,0)
  37884    ;
  37885   "RTN","RCD PURED",147 ,0)
  37886    ;  patien t account,  show mess ages and q uit (outpu t still in  variable  X)
  37887   "RTN","RCD PURED",148 ,0)
  37888    I RCOUTPU T[";DPT("  D CHECKPAT (+RCOUTPUT ) Q
  37889   "RTN","RCD PURED",149 ,0)
  37890    ;
  37891   "RTN","RCD PURED",150 ,0)
  37892    ;  bill a ccount
  37893   "RTN","RCD PURED",151 ,0)
  37894    I $$IB^IB RUTL(+RCOU TPUT) W "  ... This b ill appear s to have  other pati ent bills  on 'hold'. "
  37895   "RTN","RCD PURED",152 ,0)
  37896    S X=$P($G (^RCD(340, +$P(^PRCA( 430,+RCOUT PUT,0),"^" ,9),0)),"^ ")
  37897   "RTN","RCD PURED",153 ,0)
  37898    I X[";DPT (" D CHECK PAT(+X)
  37899   "RTN","RCD PURED",154 ,0)
  37900    S X=RCOUT PUT
  37901   "RTN","RCD PURED",155 ,0)
  37902    Q
  37903   "RTN","RCD PURED",156 ,0)
  37904    ;
  37905   "RTN","RCD PURED",157 ,0)
  37906    ;
  37907   "RTN","RCD PURED",158 ,0)
  37908   CHECKPAT(D FN) ; chec k patient  for other  charges, e tc., show  message
  37909   "RTN","RCD PURED",159 ,0)
  37910    N RCLIST, RCNODE,RCT YPE,RCPSO, RCX,RCREF, RCTOTAL,RC COUNT
  37911   "RTN","RCD PURED",160 ,0)
  37912    N X,Y,DI   ; need to  protect F M within F M
  37913   "RTN","RCD PURED",161 ,0)
  37914    S (RCTOTA L,RCCOUNT) =0
  37915   "RTN","RCD PURED",162 ,0)
  37916    S X="IBAR XEU" X ^%Z OSF("TEST" )
  37917   "RTN","RCD PURED",163 ,0)
  37918    I $T S X= $$RXST^IBA RXEU(DFN,D T) I X D
  37919   "RTN","RCD PURED",164 ,0)
  37920    . W !?2," * Patient  is exempt  from RX Co pay: ",$P( X,"^",4),"  *"
  37921   "RTN","RCD PURED",165 ,0)
  37922    S RCLIST= "RCPSO52", RCNODE="0, 2,R,I"
  37923   "RTN","RCD PURED",166 ,0)
  37924    K ^TMP($J ,RCLIST,DF N)
  37925   "RTN","RCD PURED",167 ,0)
  37926    D RX^PSO5 2API(DFN,R CLIST,,,RC NODE,$$FMA DD^XLFDT(D T,-1))
  37927   "RTN","RCD PURED",168 ,0)
  37928    I $G(^TMP ($J,RCLIST ,DFN,0))<1  G CHECKQ
  37929   "RTN","RCD PURED",169 ,0)
  37930    S RCPSO=0  F  S RCPS O=$O(^TMP( $J,RCLIST, DFN,RCPSO) ) Q:'RCPSO   D
  37931   "RTN","RCD PURED",170 ,0)
  37932    . ; prote ct aginst  tier 0 dru gs
  37933   "RTN","RCD PURED",171 ,0)
  37934    . I $G(^T MP($J,RCLI ST,DFN,RCP SO,6)),$P( $$CPTIER^P SNAPIS("", DT,+^(6)), "^")=0 Q
  37935   "RTN","RCD PURED",172 ,0)
  37936    . ; origi nal fills
  37937   "RTN","RCD PURED",173 ,0)
  37938    . S RCTYP E=+$G(^TMP ($J,RCLIST ,DFN,RCPSO ,105)) Q:' RCTYPE
  37939   "RTN","RCD PURED",174 ,0)
  37940    . I +$G(^ TMP($J,RCL IST,DFN,RC PSO,22))=D T,$P($G(^( 11)),"^")= "W",'$G(^( 31)) D  Q
  37941   "RTN","RCD PURED",175 ,0)
  37942    .. S RCX= $G(^TMP($J ,RCLIST,DF N,RCPSO,8) )
  37943   "RTN","RCD PURED",176 ,0)
  37944    .. S RCX= RCX/30\1+$ S(RCX#30:1 ,1:0)
  37945   "RTN","RCD PURED",177 ,0)
  37946    .. S RCCO UNT=RCCOUN T+RCX
  37947   "RTN","RCD PURED",178 ,0)
  37948    .. S RCTO TAL=RCTOTA L+($$ARCOS T^IBAUTL(D FN,RCTYPE, RCPSO)*RCX )
  37949   "RTN","RCD PURED",179 ,0)
  37950    . ; refil ls
  37951   "RTN","RCD PURED",180 ,0)
  37952    . S RCREF =0 F  S RC REF=$O(^TM P($J,RCLIS T,DFN,RCPS O,"RF",RCR EF)) Q:'RC REF  I $P( $G(^TMP($J ,RCLIST,DF N,RCPSO,"R F",RCREF,. 01)),"^")= DT,$P($G(^ (2)),"^")= "W",'$G(^( 17)) D
  37953   "RTN","RCD PURED",181 ,0)
  37954    .. S RCX= $G(^TMP($J ,RCLIST,DF N,RCPSO,"R F",RCREF,1 .1))
  37955   "RTN","RCD PURED",182 ,0)
  37956    .. S RCX= RCX/30\1+$ S(RCX#30:1 ,1:0)
  37957   "RTN","RCD PURED",183 ,0)
  37958    .. S RCCO UNT=RCCOUN T+RCX
  37959   "RTN","RCD PURED",184 ,0)
  37960    .. S RCTO TAL=RCTOTA L+($$ARCOS T^IBAUTL(D FN,RCTYPE, RCPSO)*RCX )
  37961   "RTN","RCD PURED",185 ,0)
  37962    I RCTOTAL  D
  37963   "RTN","RCD PURED",186 ,0)
  37964    . W !?2," * This pat ient has " ,RCCOUNT," -30 day RX 's totalin g $",$FN(R CTOTAL,"," ,2)," that  are poten tially *"
  37965   "RTN","RCD PURED",187 ,0)
  37966    . W !?2," * billable . This rep resents an y Window R x's issued  today. *"
  37967   "RTN","RCD PURED",188 ,0)
  37968    ;
  37969   "RTN","RCD PURED",189 ,0)
  37970   CHECKQ ;
  37971   "RTN","RCD PURED",190 ,0)
  37972    K ^TMP($J ,RCLIST,DF N)
  37973   "RTN","RCD PURED",191 ,0)
  37974    Q
  37975   "RTN","RCD PURED",192 ,0)
  37976    ;
  37977   "RTN","RCD PURED",193 ,0)
  37978    ;
  37979   "RTN","RCD PURED",194 ,0)
  37980   DISPLAY(RC BILLDA) ;   display b ill
  37981   "RTN","RCD PURED",195 ,0)
  37982    N DATA
  37983   "RTN","RCD PURED",196 ,0)
  37984    S DATA=$P (^PRCA(430 ,+RCBILLDA ,0),"^",9)  W:DATA "   ",$$NAM^R CFN01(DATA )
  37985   "RTN","RCD PURED",197 ,0)
  37986    S DATA=$P (^PRCA(430 ,+RCBILLDA ,0),"^",8)  I DATA D
  37987   "RTN","RCD PURED",198 ,0)
  37988    .   W "    ",$P(^PRC A(430.3,DA TA,0),"^")
  37989   "RTN","RCD PURED",199 ,0)
  37990    .   I $P( ^PRCA(430. 3,DATA,0), "^",3)'=10 2,$P($G(^R CD(340,+$P (^PRCA(430 ,+RCBILLDA ,0),"^",9) ,0)),"^")' [";DPT(" W  !,"This b ill is not  in 'activ e' status. "
  37991   "RTN","RCD PURED",200 ,0)
  37992    S DATA=$G (^PRCA(430 ,+RCBILLDA ,7)) W "    $",$J($P( DATA,"^")+ $P(DATA,"^ ",2)+$P(DA TA,"^",3)+ $P(DATA,"^ ",4)+$P(DA TA,"^",5), 1,2)
  37993   "RTN","RCD PURED",201 ,0)
  37994    Q
  37995   "RTN","RCD PURED",202 ,0)
  37996    ;
  37997   "RTN","RCD PURED",203 ,0)
  37998   PAYDATE ;   called by  the input  transform  in receip t file 344 , transact ion
  37999   "RTN","RCD PURED",204 ,0)
  38000    ;  multip le (field  1), date o f payment  (sub field  .06)
  38001   "RTN","RCD PURED",205 ,0)
  38002    ;  date o f payment  not in fut ure or mor e than one  month ago
  38003   "RTN","RCD PURED",206 ,0)
  38004    N DAYSDIF F
  38005   "RTN","RCD PURED",207 ,0)
  38006    S DAYSDIF F=$$FMDIFF ^XLFDT(X,D T)
  38007   "RTN","RCD PURED",208 ,0)
  38008    I DAYSDIF F<-31!(DAY SDIFF>0) K  X
  38009   "RTN","RCD PURED",209 ,0)
  38010    Q
  38011   "RTN","RCD PURED",210 ,0)
  38012    ;
  38013   "RTN","RCD PURED",211 ,0)
  38014    ;
  38015   "RTN","RCD PURED",212 ,0)
  38016    ;  *****  dd referen ces from f ile 344.1  (deposits)  *****
  38017   "RTN","RCD PURED",213 ,0)
  38018    ;
  38019   "RTN","RCD PURED",214 ,0)
  38020    ;
  38021   "RTN","RCD PURED",215 ,0)
  38022   RECTOTAL(R CDEPTDA) ;   called f rom comput ed field T OTAL AMT O F RECEIPTS  (.18) in
  38023   "RTN","RCD PURED",216 ,0)
  38024    ;  deposi t file (34 4.1)
  38025   "RTN","RCD PURED",217 ,0)
  38026    ;  this r eturns the  total dol lars paid  for all re ceipts on  deposit ti cket
  38027   "RTN","RCD PURED",218 ,0)
  38028    N RCRECTD A,TOTAL
  38029   "RTN","RCD PURED",219 ,0)
  38030    S TOTAL=0
  38031   "RTN","RCD PURED",220 ,0)
  38032    S RCRECTD A=0 F  S R CRECTDA=$O (^RCY(344, "AD",+RCDE PTDA,RCREC TDA)) Q:'R CRECTDA  D
  38033   "RTN","RCD PURED",221 ,0)
  38034    .   S TOT AL=TOTAL+$ $PAYTOTAL( RCRECTDA)
  38035   "RTN","RCD PURED",222 ,0)
  38036    Q TOTAL
  38037   "RTN","RCD PURED",223 ,0)
  38038    ;
  38039   "RTN","RCD PURED",224 ,0)
  38040    ;
  38041   "RTN","RCD PURED",225 ,0)
  38042   RECCOUNT(R CDEPTDA) ;   called f rom comput ed field T OTAL RECEI PTS (100)  in deposit  file (344 .1)
  38043   "RTN","RCD PURED",226 ,0)
  38044    ;  this r eturns a c ount of th e number o f receipts  on a depo sit ticket
  38045   "RTN","RCD PURED",227 ,0)
  38046    N RCRECTD A,COUNT
  38047   "RTN","RCD PURED",228 ,0)
  38048    S COUNT=0
  38049   "RTN","RCD PURED",229 ,0)
  38050    S RCRECTD A=0 F  S R CRECTDA=$O (^RCY(344, "AD",+RCDE PTDA,RCREC TDA)) Q:'R CRECTDA  D
  38051   "RTN","RCD PURED",230 ,0)
  38052    .   S COU NT=COUNT+1
  38053   "RTN","RCD PURED",231 ,0)
  38054    Q COUNT
  38055   "RTN","RCD PURED",232 ,0)
  38056   HLP09 ; PR CA*4.5*321  - Add exe cutable he lp for fil e 4.01 fie ld .09
  38057   "RTN","RCD PURED",233 ,0)
  38058    W ?5,"To  enter a TR ICARE Auth orization  No, enter  'T.' follo wed by the  number."
  38059   "RTN","RCD PURED",234 ,0)
  38060    W !,?5,"T o enter an  ECME Rx R eference N umber, ent er 'E.' fo llowed by  the number ."
  38061   "RTN","RCD PURED",235 ,0)
  38062    W !,?5,"T o enter an  Prescript ion Number , enter 'R .' followe d by the n umber."
  38063   "RTN","RCD PURED",236 ,0)
  38064    Q
  38065   "RTN","RCD PURED",237 ,0)
  38066   ERRMSG ;pr nt error m essage and  set exit  variables       ;prca *4.5*301
  38067   "RTN","RCD PURED",238 ,0)
  38068    W !!,$P($ T(LINKMSG+ RCMSG),";" ,2),! S CS NOPROC=1,R CDCHKSW=0, HRCDCKSW=1  S X=0
  38069   "RTN","RCD PURED",239 ,0)
  38070    Q
  38071   "RTN","RCD PURED",240 ,0)
  38072   LINKMSG ;L inking err or message s      ;pr ca*4.5*301    
  38073   "RTN","RCD PURED",241 ,0)
  38074    ;** Linki ng Treasur y payment  (170) to a  non Cross -Servicing  bill not  allowed
  38075   "RTN","RCD PURED",242 ,0)
  38076    ;** Linki ng a TOP p ayment (16 9) to a Cr oss-Servic ing bill i s not allo wed
  38077   "RTN","RCD PURED",243 ,0)
  38078    ;** Linki ng a DMC p ayment (16 8) to a Cr oss-Servic ing bill i s not allo wed
  38079   "RTN","RCD PURED",244 ,0)
  38080    ;** Linki ng a MISC  payment to  a Cross-S ervicing b ill is not  allowed
  38081   "RTN","RCD PUT")
  38082   0^14^B2724 5872
  38083   "RTN","RCD PUT",1,0)
  38084   RCDPUT ;WA SH-ISC@ALT OONA,PA/RG Y/KML - UT ILITIES ;  5/6/11 12: 29pm
  38085   "RTN","RCD PUT",2,0)
  38086   V ;;4.5;Ac counts Rec eivable;** 69,90,106, 114,169,26 9,321**;Ma r 20, 1995 ;Build 46
  38087   "RTN","RCD PUT",3,0)
  38088    ;;Per VHA  Directive  10-93-142 , this rou tine shoul d not be m odified.
  38089   "RTN","RCD PUT",4,0)
  38090    Q
  38091   "RTN","RCD PUT",5,0)
  38092    ;
  38093   "RTN","RCD PUT",6,0)
  38094    ;
  38095   "RTN","RCD PUT",7,0)
  38096   RECEIPTS ;   check re ceipts
  38097   "RTN","RCD PUT",8,0)
  38098    N DATA,PA YDA,RCCOUN T,RCDATA0, RCDATE,RCR ECTDA,STAT US,TOTAL,X ,XCNP,XMDU Z,XMZ
  38099   "RTN","RCD PUT",9,0)
  38100    K ^TMP("R CDPUT",$J)
  38101   "RTN","RCD PUT",10,0)
  38102    ;  check  receipts w hich are 4  days old
  38103   "RTN","RCD PUT",11,0)
  38104    S RCDATE= $$FMADD^XL FDT(DT,-4)
  38105   "RTN","RCD PUT",12,0)
  38106    S RCCOUNT =7
  38107   "RTN","RCD PUT",13,0)
  38108    S RCRECTD A=0 F  S R CRECTDA=$O (^RCY(344, RCRECTDA))  Q:'RCRECT DA  D
  38109   "RTN","RCD PUT",14,0)
  38110    .   ;  if  no paymen ts, quit
  38111   "RTN","RCD PUT",15,0)
  38112    .   I '$O (^RCY(344, RCRECTDA,1 ,0)) Q
  38113   "RTN","RCD PUT",16,0)
  38114    .   ;
  38115   "RTN","RCD PUT",17,0)
  38116    .   S RCD ATA0=$G(^R CY(344,RCR ECTDA,0))
  38117   "RTN","RCD PUT",18,0)
  38118    .   ;
  38119   "RTN","RCD PUT",19,0)
  38120    .   ;  re ceipt is m arked as p rocessed
  38121   "RTN","RCD PUT",20,0)
  38122    .   I $P( RCDATA0,"^ ",8) D  Q
  38123   "RTN","RCD PUT",21,0)
  38124    .   .   ;   check th e last pay ment and s ee if it w as process ed
  38125   "RTN","RCD PUT",22,0)
  38126    .   .   ;   the last  payment m ust have a  paid amou nt and no  processed
  38127   "RTN","RCD PUT",23,0)
  38128    .   .   ;   amount A ND the pay ment did n ot go to s uspense.
  38129   "RTN","RCD PUT",24,0)
  38130    .   .   S  PAYDA=999 9999,TOTAL =0
  38131   "RTN","RCD PUT",25,0)
  38132    .   .   F   S PAYDA= $O(^RCY(34 4,RCRECTDA ,1,PAYDA), -1) Q:'PAY DA  S DATA =$G(^RCY(3 44,RCRECTD A,1,PAYDA, 0)),TOTAL= TOTAL+$P(D ATA,"^",4)  I $P(DATA ,"^",4),$P (DATA,"^", 3),$P($G(^ RCY(344,RC RECTDA,1,P AYDA,2))," ^",5)="" Q
  38133   "RTN","RCD PUT",26,0)
  38134    .   .   ;   no total  paid on t he receipt
  38135   "RTN","RCD PUT",27,0)
  38136    .   .   I  'TOTAL Q
  38137   "RTN","RCD PUT",28,0)
  38138    .   .   ;   found th e last pay ment and i t is not p rocessed
  38139   "RTN","RCD PUT",29,0)
  38140    .   .   I  PAYDA,'$P (^RCY(344, RCRECTDA,1 ,PAYDA,0), "^",5) D B UILDLN(RCD ATA0,"All  payments N OT complet ely proces sed.") Q
  38141   "RTN","RCD PUT",30,0)
  38142    .   .   ;
  38143   "RTN","RCD PUT",31,0)
  38144    .   .   ;   if no de posit tick et, receip t is proce ssed
  38145   "RTN","RCD PUT",32,0)
  38146    .   .   I  '$P(RCDAT A0,"^",6)  Q
  38147   "RTN","RCD PUT",33,0)
  38148    .   .   ;
  38149   "RTN","RCD PUT",34,0)
  38150    .   .   ;   receipts  is marked  as entere d on line
  38151   "RTN","RCD PUT",35,0)
  38152    .   .   I  $P($G(^RC Y(344,RCRE CTDA,2))," ^",2)=1 Q
  38153   "RTN","RCD PUT",36,0)
  38154    .   .   ;
  38155   "RTN","RCD PUT",37,0)
  38156    .   .   ;   fms docu ment has n ot been se nt
  38157   "RTN","RCD PUT",38,0)
  38158    .   .   I  $P($G(^RC Y(344,RCRE CTDA,2))," ^")="" D B UILDLN(RCD ATA0,"CR h as NOT bee n sent to  FMS.") Q
  38159   "RTN","RCD PUT",39,0)
  38160    .   .   ;
  38161   "RTN","RCD PUT",40,0)
  38162    .   .   ;   get the  status of  the fms co de sheet a nd see if  it is
  38163   "RTN","RCD PUT",41,0)
  38164    .   .   ;   accepted
  38165   "RTN","RCD PUT",42,0)
  38166    .   .   S  STATUS=$$ FMSSTAT^RC DPUREC(RCR ECTDA)
  38167   "RTN","RCD PUT",43,0)
  38168    .   .   ;   document  is accept ed or ente red on lin e
  38169   "RTN","RCD PUT",44,0)
  38170    .   .   I  $E($P(STA TUS,"^",2) )="A" Q
  38171   "RTN","RCD PUT",45,0)
  38172    .   .   I  $E($P(STA TUS,"^",2) )="O" Q
  38173   "RTN","RCD PUT",46,0)
  38174    .   .   ;   not been  more than  4 days
  38175   "RTN","RCD PUT",47,0)
  38176    .   .   I  $$FMDIFF^ XLFDT(DT,$ P(RCDATA0, "^",8))<4  Q
  38177   "RTN","RCD PUT",48,0)
  38178    .   .   D  BUILDLN(R CDATA0,"CR  NOT accep ted in FMS  ("_$P(STA TUS," ")_" ).")
  38179   "RTN","RCD PUT",49,0)
  38180    .   ;
  38181   "RTN","RCD PUT",50,0)
  38182    .   ;  re ceipt not  that old
  38183   "RTN","RCD PUT",51,0)
  38184    .   I $P( RCDATA0,"^ ",3)>RCDAT E Q
  38185   "RTN","RCD PUT",52,0)
  38186    .   ;
  38187   "RTN","RCD PUT",53,0)
  38188    .   ;  no t processe d in a tim ely manner
  38189   "RTN","RCD PUT",54,0)
  38190    .   D BUI LDLN(RCDAT A0,"NOT pr ocessed in  a timely  manner.")
  38191   "RTN","RCD PUT",55,0)
  38192    ;
  38193   "RTN","RCD PUT",56,0)
  38194    I '$O(^TM P("RCDPUT" ,$J,0)) Q
  38195   "RTN","RCD PUT",57,0)
  38196    ;
  38197   "RTN","RCD PUT",58,0)
  38198    ;  send m ail messag e
  38199   "RTN","RCD PUT",59,0)
  38200    S ^TMP("R CDPUT",$J, 1)="Sent t o: PRCA ER ROR mailgr oup"
  38201   "RTN","RCD PUT",60,0)
  38202    S ^TMP("R CDPUT",$J, 2)="          RCDP PA YMENTS mai lgroup"
  38203   "RTN","RCD PUT",61,0)
  38204    S ^TMP("R CDPUT",$J, 3)="          PRCAY P AYMENT SUP  security  key holder s"
  38205   "RTN","RCD PUT",62,0)
  38206    S ^TMP("R CDPUT",$J, 4)=" "
  38207   "RTN","RCD PUT",63,0)
  38208    S ^TMP("R CDPUT",$J, 5)="RECEIP T        O PENED   PR OCESS  WAR NING"
  38209   "RTN","RCD PUT",64,0)
  38210    S ^TMP("R CDPUT",$J, 6)="------ ---------- ---------- ---------- ---------- ---------- ---------- ---------- --"
  38211   "RTN","RCD PUT",65,0)
  38212    S XMY("G. PRCA ERROR ")=""
  38213   "RTN","RCD PUT",66,0)
  38214    S XMY("G. RCDP PAYME NTS")=""
  38215   "RTN","RCD PUT",67,0)
  38216    F X=0:0 S  X=$O(^XUS EC("PRCAY  PAYMENT SU P",X)) Q:' X  S XMY(X )=""
  38217   "RTN","RCD PUT",68,0)
  38218    S XMDUZ=" Accounts R eceivable  Package"
  38219   "RTN","RCD PUT",69,0)
  38220    S XMTEXT= "^TMP(""RC DPUT"",$J, "
  38221   "RTN","RCD PUT",70,0)
  38222    S XMSUB=" Error in A gent Cashi er Receipt (s)"
  38223   "RTN","RCD PUT",71,0)
  38224    D ^XMD
  38225   "RTN","RCD PUT",72,0)
  38226    K ^TMP("R CDPUT",$J)
  38227   "RTN","RCD PUT",73,0)
  38228    Q
  38229   "RTN","RCD PUT",74,0)
  38230    ;
  38231   "RTN","RCD PUT",75,0)
  38232    ;
  38233   "RTN","RCD PUT",76,0)
  38234   BUILDLN(RC DATA0,WARN ING) ;  bu ild line i n mail mes sage with  receipt da ta
  38235   "RTN","RCD PUT",77,0)
  38236    N DATA,DA TE
  38237   "RTN","RCD PUT",78,0)
  38238    S RCCOUNT =RCCOUNT+1
  38239   "RTN","RCD PUT",79,0)
  38240    S DATA=$E ($P(RCDATA 0,"^")_"            " ,1,11)_"   "
  38241   "RTN","RCD PUT",80,0)
  38242    S DATE=$P (RCDATA0," ^",3) I DA TE S DATE= $E(DATE,4, 5)_"/"_$E( DATE,6,7)_ "/"_$E(DAT E,2,3)
  38243   "RTN","RCD PUT",81,0)
  38244    S DATA=DA TA_$E(DATE _"         ",1,8)_"   "
  38245   "RTN","RCD PUT",82,0)
  38246    S DATE=$P (RCDATA0," ^",8) I DA TE S DATE= $E(DATE,4, 5)_"/"_$E( DATE,6,7)_ "/"_$E(DAT E,2,3)
  38247   "RTN","RCD PUT",83,0)
  38248    S DATA=DA TA_$E(DATE _"         ",1,8)_"   "
  38249   "RTN","RCD PUT",84,0)
  38250    S DATA=DA TA_WARNING
  38251   "RTN","RCD PUT",85,0)
  38252    S RCCOUNT =RCCOUNT+1
  38253   "RTN","RCD PUT",86,0)
  38254    S ^TMP("R CDPUT",$J, RCCOUNT)=D ATA
  38255   "RTN","RCD PUT",87,0)
  38256    Q
  38257   "RTN","RCD PUT",88,0)
  38258    ;
  38259   "RTN","RCD PUT",89,0)
  38260    ;
  38261   "RTN","RCD PUT",90,0)
  38262   PURGE ;  p urge recei pts and de posits
  38263   "RTN","RCD PUT",91,0)
  38264    N %,D0,D1 ,DA,DG,DIC ,DICR,DIG, DIH,DIK,DI U,DIV,DIW, RCDATE,RCD EPDA,RCREC TDA,X,Y
  38265   "RTN","RCD PUT",92,0)
  38266    ;
  38267   "RTN","RCD PUT",93,0)
  38268    ;  purge  receipts
  38269   "RTN","RCD PUT",94,0)
  38270    ; HIPAA 5 010 - reta in receipt s for 7 ye ar (84 mon ths)
  38271   "RTN","RCD PUT",95,0)
  38272    S RCDATE= $$FPS^RCAM FN01(DT,-8 4)
  38273   "RTN","RCD PUT",96,0)
  38274    S RCRECTD A=0 F  S R CRECTDA=$O (^RCY(344, RCRECTDA))  Q:'RCRECT DA  D
  38275   "RTN","RCD PUT",97,0)
  38276    .   ;  re ceipt not  processed,  do not pu rge
  38277   "RTN","RCD PUT",98,0)
  38278    .   I '$P (^RCY(344, RCRECTDA,0 ),"^",8) Q
  38279   "RTN","RCD PUT",99,0)
  38280    .   ;  re ceipt proc essed less  than 84 m onths ago,  do not pu rge
  38281   "RTN","RCD PUT",100,0 )
  38282    .   I $P( ^RCY(344,R CRECTDA,0) ,"^",8)>RC DATE Q
  38283   "RTN","RCD PUT",101,0 )
  38284    .   ;  pu rge receip t
  38285   "RTN","RCD PUT",102,0 )
  38286    .   L +^R CY(344,RCR ECTDA,0)
  38287   "RTN","RCD PUT",103,0 )
  38288    .   S DIK ="^RCY(344 ,",DA=RCRE CTDA D ^DI K
  38289   "RTN","RCD PUT",104,0 )
  38290    .   ;  pu rge any co mment hist ory - PRCA *4.5*321
  38291   "RTN","RCD PUT",105,0 )
  38292    .   D PUR GECH(RCREC TDA)
  38293   "RTN","RCD PUT",106,0 )
  38294    .   ;
  38295   "RTN","RCD PUT",107,0 )
  38296    .   L -^R CY(344,RCR ECTDA,0)
  38297   "RTN","RCD PUT",108,0 )
  38298    ;
  38299   "RTN","RCD PUT",109,0 )
  38300    ;  purge  deposits
  38301   "RTN","RCD PUT",110,0 )
  38302    ; ; HIPAA  5010 - re tain depos its for 7  year (84 m onths)
  38303   "RTN","RCD PUT",111,0 )
  38304    S RCDATE= $$FPS^RCAM FN01(DT,-8 4)
  38305   "RTN","RCD PUT",112,0 )
  38306    S RCDEPDA =0 F  S RC DEPDA=$O(^ RCY(344.1, RCDEPDA))  Q:'RCDEPDA   D
  38307   "RTN","RCD PUT",113,0 )
  38308    .   ;  if  receipts  are on dep osit, do n ot purge
  38309   "RTN","RCD PUT",114,0 )
  38310    .   I $O( ^RCY(344," AD",RCDEPD A,0)) Q
  38311   "RTN","RCD PUT",115,0 )
  38312    .   ;  de posit not  confirmed,  do not pu rge
  38313   "RTN","RCD PUT",116,0 )
  38314    .   I '$P (^RCY(344. 1,RCDEPDA, 0),"^",11)  Q
  38315   "RTN","RCD PUT",117,0 )
  38316    .   ;  de posit conf irmed less  than 84 m onths ago,  do not pu rge
  38317   "RTN","RCD PUT",118,0 )
  38318    .   I $P( ^RCY(344.1 ,RCDEPDA,0 ),"^",11)> RCDATE Q
  38319   "RTN","RCD PUT",119,0 )
  38320    .   ;  pu rge deposi t
  38321   "RTN","RCD PUT",120,0 )
  38322    .   L +^R CY(344.1,R CDEPDA,0)
  38323   "RTN","RCD PUT",121,0 )
  38324    .   S DIK ="^RCY(344 .1,",DA=RC DEPDA D ^D IK
  38325   "RTN","RCD PUT",122,0 )
  38326    .   L -^R CY(344.1,R CDEPDA,0)
  38327   "RTN","RCD PUT",123,0 )
  38328    Q
  38329   "RTN","RCD PUT",124,0 )
  38330    ;
  38331   "RTN","RCD PUT",125,0 )
  38332   PURGECH(RC DA) ; Purg e Comment  History -  PRCA*4.5*3 21
  38333   "RTN","RCD PUT",126,0 )
  38334    N DA,DIK, SUB
  38335   "RTN","RCD PUT",127,0 )
  38336    S SUB=0
  38337   "RTN","RCD PUT",128,0 )
  38338    F  S SUB= $O(^RCY(34 4.73,"B",R CDA,SUB))  Q:'SUB  D
  38339   "RTN","RCD PUT",129,0 )
  38340    .  ;Delet e Comment
  38341   "RTN","RCD PUT",130,0 )
  38342    .  S DIK= "^RCY(344. 73,",DA=SU B D ^DIK
  38343   "RTN","RCD PUT",131,0 )
  38344    Q
  38345   "RTN","RCD PUT",132,0 )
  38346    ;
  38347   "RTN","RCD PUT",133,0 )
  38348   MAN ;  Ent ry point f or nightly  process f or managin g receipts  and depos its
  38349   "RTN","RCD PUT",134,0 )
  38350    D PURGE
  38351   "RTN","RCD PUT",135,0 )
  38352    D RECEIPT S
  38353   "RTN","RCD PUT",136,0 )
  38354    Q
  38355   "RTN","RCP 321")
  38356   0^25^B2725 1682
  38357   "RTN","RCP 321",1,0)
  38358   RCP321 ;BI RM/EWL ALB /PJH - ePa yment Lock box Post-I nstallatio n Processi ng ;Dec 20 , 2014@14: 08:45
  38359   "RTN","RCP 321",2,0)
  38360    ;;4.5;Acc ounts Rece ivable;**3 21**;Jan 2 1, 2014;Bu ild 46
  38361   "RTN","RCP 321",3,0)
  38362    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  38363   "RTN","RCP 321",4,0)
  38364    Q
  38365   "RTN","RCP 321",5,0)
  38366    ;
  38367   "RTN","RCP 321",6,0)
  38368   POST() ; T ask jobs t o initiali ze RCDPE C OMMENT HIS TORY file  #344.73
  38369   "RTN","RCP 321",7,0)
  38370    ;
  38371   "RTN","RCP 321",8,0)
  38372    N DIK,ERR ,K34461,RC ENT,RCERR, RCINST,RCO UT,RCPAR,Z TDESC,ZTDT H,ZTIO,ZTR TN,ZTSK
  38373   "RTN","RCP 321",9,0)
  38374    ; set ^XT MP zero no de for 180  day reten tion
  38375   "RTN","RCP 321",10,0)
  38376    S ^XTMP($ T(+0),0)=$ $HTFM^XLFD T($H+180)_ U_DT_"^PRC A*4.5*321  post-insta llation"
  38377   "RTN","RCP 321",11,0)
  38378    D BMES^XP DUTL("Post -installat ion tasks  "_$$FMTE^X LFDT($$NOW ^XLFDT)) ;  add date/ time to lo g
  38379   "RTN","RCP 321",12,0)
  38380    D BMES^XP DUTL("Queu eing task  to initial ize RCDPE  COMMENT HI STORY file  #344.73")
  38381   "RTN","RCP 321",13,0)
  38382    S ZTRTN=" INIT1^"_$T (+0),ZTDES C="RCDPE C OMMENT HIS TORY (#344 .73) post- init work" ,ZTIO="",Z TDTH=$H
  38383   "RTN","RCP 321",14,0)
  38384    D ^%ZTLOA D
  38385   "RTN","RCP 321",15,0)
  38386    D MES^XPD UTL($S($G( ZTSK):"Tas k number " _ZTSK_" ha s been que ued.",1:"U nable to q ueue this  task."))
  38387   "RTN","RCP 321",16,0)
  38388    I $G(ZTSK ) D MES^XP DUTL("A Ma ilMan mess age will b e sent on  completion .")
  38389   "RTN","RCP 321",17,0)
  38390    ;
  38391   "RTN","RCP 321",18,0)
  38392    D BMES^XP DUTL("Dele ting old s tyle 'B' i ndex on fi le (#344.6 )")
  38393   "RTN","RCP 321",19,0)
  38394    D DELIX^D DMOD(344.6 ,.01,1,"K" )
  38395   "RTN","RCP 321",20,0)
  38396    D BMES^XP DUTL("Re-i ndexing PA YER NAME o n AUTO-PAY  EXCLUSION  file (#34 4.6)")
  38397   "RTN","RCP 321",21,0)
  38398    S DIK="^R CY(344.6," ,DIK(1)=". 01^B" D EN ALL^DIK
  38399   "RTN","RCP 321",22,0)
  38400    D BMES^XP DUTL("Re-i ndexing DA TE OPENED  on AR BATC H PAYMENTS  file (#34 4)")
  38401   "RTN","RCP 321",23,0)
  38402    S DIK="^R CY(344,",D IK(1)=".03 ^AO" D ENA LL^DIK
  38403   "RTN","RCP 321",24,0)
  38404    ;
  38405   "RTN","RCP 321",25,0)
  38406    ; RCDPE A UDIT mail  group upda te 
  38407   "RTN","RCP 321",26,0)
  38408    N RCAUD,R CRMEM,Z
  38409   "RTN","RCP 321",27,0)
  38410    D MES^XPD UTL("Updat ing RCDPE  AUDIT mail  group.")
  38411   "RTN","RCP 321",28,0)
  38412    ; Integra tion Agree ment 6814  for access  to ^XMB(3 .8
  38413   "RTN","RCP 321",29,0)
  38414    S RCAUD=$ $FIND1^DIC (3.8,"","M X","RCDPE  AUDIT","", "","ERR")  Q:'RCAUD
  38415   "RTN","RCP 321",30,0)
  38416    ; Delete  any REMOTE  MEMBER co ntaining t ext of VHA 835NOTIFY  (upper or  lower case )
  38417   "RTN","RCP 321",31,0)
  38418    S Z=0
  38419   "RTN","RCP 321",32,0)
  38420    F  S Z=$O (^XMB(3.8, RCAUD,6,Z) ) Q:'Z  D
  38421   "RTN","RCP 321",33,0)
  38422    . S RCRME M=$$GET1^D IQ(3.812,Z _","_RCAUD _",",.01)
  38423   "RTN","RCP 321",34,0)
  38424    . Q:$$UP^ XLFSTR(RCR MEM)'["VHA 835NOTIFY"
  38425   "RTN","RCP 321",35,0)
  38426    . N DA,DI K
  38427   "RTN","RCP 321",36,0)
  38428    . S DA(1) =RCAUD,DA= Z,DIK="^XM B(3.8,"_DA (1)_",6,"
  38429   "RTN","RCP 321",37,0)
  38430    . D ^DIK
  38431   "RTN","RCP 321",38,0)
  38432    . D MES^X PDUTL("Rem oved REMOT E MEMBER =  "_RCRMEM)
  38433   "RTN","RCP 321",39,0)
  38434    ;
  38435   "RTN","RCP 321",40,0)
  38436    ; If empt y populate  parameter  DAY TO SE ND WORKLOA D NOTIFICA TIONS with  SATURDAY
  38437   "RTN","RCP 321",41,0)
  38438    D:$$GET1^ DIQ(344.61 ,"1,",.1)= ""
  38439   "RTN","RCP 321",42,0)
  38440    .N DA,DIE ,DR
  38441   "RTN","RCP 321",43,0)
  38442    .S DIE="^ RCY(344.61 ,",DR=".1/ //SA;",DA= 1 D ^DIE
  38443   "RTN","RCP 321",44,0)
  38444    ;
  38445   "RTN","RCP 321",45,0)
  38446    ; Decreas e Medical  and Pharma cy EFT pre vent days  if they ex ceed the n ew maximum
  38447   "RTN","RCP 321",46,0)
  38448    S K34461= 0
  38449   "RTN","RCP 321",47,0)
  38450    F  S K344 61=$O(^RCY (344.61,K3 4461)) Q:' K34461  D
  38451   "RTN","RCP 321",48,0)
  38452    . N MEPRE V,RXPREV
  38453   "RTN","RCP 321",49,0)
  38454    . S MEPRE V=$$GET1^D IQ(344.61, K34461_"," ,.06,"I")
  38455   "RTN","RCP 321",50,0)
  38456    . I MEPRE V>60 D  ;
  38457   "RTN","RCP 321",51,0)
  38458    . . N FDA
  38459   "RTN","RCP 321",52,0)
  38460    . . S FDA (344.61,K3 4461_",",. 06)=60
  38461   "RTN","RCP 321",53,0)
  38462    . . D FIL E^DIE(""," FDA")
  38463   "RTN","RCP 321",54,0)
  38464    . ;
  38465   "RTN","RCP 321",55,0)
  38466    . S RXPRE V=$$GET1^D IQ(344.61, K34461_"," ,.07,"I")
  38467   "RTN","RCP 321",56,0)
  38468    . I RXPRE V>365 D  ;
  38469   "RTN","RCP 321",57,0)
  38470    . . N FDA
  38471   "RTN","RCP 321",58,0)
  38472    . . S FDA (344.61,K3 4461_",",. 07)=365
  38473   "RTN","RCP 321",59,0)
  38474    . . D FIL E^DIE(""," FDA")
  38475   "RTN","RCP 321",60,0)
  38476    ;
  38477   "RTN","RCP 321",61,0)
  38478   US795 ; Co nvert defa ult for ER A_CLAIM_TY PE in work list from  "B" to "A"
  38479   "RTN","RCP 321",62,0)
  38480    K ^TMP($J ,"RCP321")
  38481   "RTN","RCP 321",63,0)
  38482    S RCOUT=" ^TMP($J,"" RCP321"")"
  38483   "RTN","RCP 321",64,0)
  38484    S RCPAR=" RCDPE EDI  LOCKBOX WO RKLIST"
  38485   "RTN","RCP 321",65,0)
  38486    S RCINST= "ERA_CLAIM _TYPE"
  38487   "RTN","RCP 321",66,0)
  38488    D ENVAL^X PAR(.RCOUT ,RCPAR,RCI NST,.RCERR ,1) ; IA 2 992 PARAME TER DEFINI TION TOOLK IT
  38489   "RTN","RCP 321",67,0)
  38490    S RCENT=" "
  38491   "RTN","RCP 321",68,0)
  38492    F  S RCEN T=$O(^TMP( $J,"RCP321 ",RCENT))  Q:RCENT=""   D  ;
  38493   "RTN","RCP 321",69,0)
  38494    . I $G(^T MP($J,"RCP 321",RCENT ,RCINST))= "B" D  ;
  38495   "RTN","RCP 321",70,0)
  38496    . . D EN^ XPAR(RCENT ,RCPAR,RCI NST,"A",.R CERR) ; IA  2992 PARA METER DEFI NITION TOO LKIT
  38497   "RTN","RCP 321",71,0)
  38498    ;
  38499   "RTN","RCP 321",72,0)
  38500    Q
  38501   "RTN","RCP 321",73,0)
  38502    ;
  38503   "RTN","RCP 321",74,0)
  38504   INIT1 ;Bui ld 344.73
  38505   "RTN","RCP 321",75,0)
  38506    ; Clear a ny existin g history
  38507   "RTN","RCP 321",76,0)
  38508    D PURGE
  38509   "RTN","RCP 321",77,0)
  38510    ;
  38511   "RTN","RCP 321",78,0)
  38512    N COMMENT ,DATE,RCNO DE,RCBODY, RCSUBJ,RCT O,RCLINE,R CRCPT,RCSU SP,RCZR,US ER,XMINSTR
  38513   "RTN","RCP 321",79,0)
  38514    S RCNODE( "BEG")=$$N OW^XLFDT,R CNODE("CNT ")=0
  38515   "RTN","RCP 321",80,0)
  38516    S ^XTMP($ T(+0),"BEG IN")=RCNOD E("BEG")
  38517   "RTN","RCP 321",81,0)
  38518    ;Scan rec eipt file  for suspen se comment s
  38519   "RTN","RCP 321",82,0)
  38520    S RCRCPT= 0
  38521   "RTN","RCP 321",83,0)
  38522    F  S RCRC PT=$O(^RCY (344,RCRCP T)) Q:'RCR CPT  D
  38523   "RTN","RCP 321",84,0)
  38524    . S RCLIN E=0
  38525   "RTN","RCP 321",85,0)
  38526    . F  S RC LINE=$O(^R CY(344,RCR CPT,1,RCLI NE)) Q:'RC LINE  D
  38527   "RTN","RCP 321",86,0)
  38528    .. ; Chec k that lin e is still  in suspen se
  38529   "RTN","RCP 321",87,0)
  38530    .. S RCSU SP=$$GET1^ DIQ(344.01 ,RCLINE_", "_RCRCPT_" ,",3.01) Q :RCSUSP=""
  38531   "RTN","RCP 321",88,0)
  38532    .. ; Rece ipt line c omment
  38533   "RTN","RCP 321",89,0)
  38534    .. S COMM ENT=$$GET1 ^DIQ(344.0 1,RCLINE_" ,"_RCRCPT_ ",",1.02)  Q:$L(COMME NT)<3
  38535   "RTN","RCP 321",90,0)
  38536    .. ; Date  placed in to suspens e
  38537   "RTN","RCP 321",91,0)
  38538    .. S DATE =$$GET1^DI Q(344.01,R CLINE_","_ RCRCPT_"," ,3.02,"I")  Q:DATE=""
  38539   "RTN","RCP 321",92,0)
  38540    .. ; Plac ed into su spense by
  38541   "RTN","RCP 321",93,0)
  38542    .. S USER =$$GET1^DI Q(344.01,R CLINE_","_ RCRCPT_"," ,3.03,"I")  Q:USER=""
  38543   "RTN","RCP 321",94,0)
  38544    .. N FDA, ERR
  38545   "RTN","RCP 321",95,0)
  38546    .. S FDA( 344.73,"+1 ,",.01)=RC RCPT ;Rece ipt
  38547   "RTN","RCP 321",96,0)
  38548    .. S FDA( 344.73,"+1 ,",1)=RCLI NE  ;Scrat chpad or R eceipt Lin e Number
  38549   "RTN","RCP 321",97,0)
  38550    .. S FDA( 344.73,"+1 ,",2)=USER                ;User
  38551   "RTN","RCP 321",98,0)
  38552    .. S FDA( 344.73,"+1 ,",3)=DATE                ;Date/ time ;
  38553   "RTN","RCP 321",99,0)
  38554    .. S FDA( 344.73,"+1 ,",4)=COMM ENT            ;Comme nt ;file e ntry
  38555   "RTN","RCP 321",100,0 )
  38556    .. D UPDA TE^DIE(,"F DA","ERR")
  38557   "RTN","RCP 321",101,0 )
  38558    .. S RCNO DE("CNT")= RCNODE("CN T")+1
  38559   "RTN","RCP 321",102,0 )
  38560    ;
  38561   "RTN","RCP 321",103,0 )
  38562    S RCNODE( "END")=$$N OW^XLFDT
  38563   "RTN","RCP 321",104,0 )
  38564    S ^XTMP($ T(+0),"FIN ISHED")=RC NODE("END" )
  38565   "RTN","RCP 321",105,0 )
  38566    ; create  MailMan me ssage text
  38567   "RTN","RCP 321",106,0 )
  38568    S RCBODY( 0)=0
  38569   "RTN","RCP 321",107,0 )
  38570    D ADD2TXT (.RCBODY," Finished R CDPE COMME NT HISTORY  file #344 .73 initia lization t ask.")
  38571   "RTN","RCP 321",108,0 )
  38572    D ADD2TXT (.RCBODY,"  Process b egun: "_$$ FMTE^XLFDT (RCNODE("B EG")))
  38573   "RTN","RCP 321",109,0 )
  38574    D ADD2TXT (.RCBODY,"  Process e nded: "_$$ FMTE^XLFDT (RCNODE("E ND")))
  38575   "RTN","RCP 321",110,0 )
  38576    D ADD2TXT (.RCBODY,"  Comment c ount: "_$$ FMTE^XLFDT (RCNODE("C NT")))
  38577   "RTN","RCP 321",111,0 )
  38578    D ADD2TXT (.RCBODY," Report gen erated by  the "_$T(+ 0)_" post- initializa tion routi ne.")
  38579   "RTN","RCP 321",112,0 )
  38580    ;
  38581   "RTN","RCP 321",113,0 )
  38582    ; save Ma ilMan mess age text
  38583   "RTN","RCP 321",114,0 )
  38584    M ^XTMP($ T(+0),"MAI L MSG",$$N OW^XLFDT)= RCBODY
  38585   "RTN","RCP 321",115,0 )
  38586    ; send vi a MailMan
  38587   "RTN","RCP 321",116,0 )
  38588    S RCSUBJ= "PRCA*4.5* 321 Post I nstall Rou tine Compl eted"
  38589   "RTN","RCP 321",117,0 )
  38590    S RCTO(.5 )="",RCTO( DUZ)=""  ;  POSTMASTE R and user  who queue d it
  38591   "RTN","RCP 321",118,0 )
  38592    S RCTO("G .RCDPE PAY MENTS MGMT ")=""
  38593   "RTN","RCP 321",119,0 )
  38594    S XMINSTR ("FROM")=" POSTMASTER "
  38595   "RTN","RCP 321",120,0 )
  38596    ;
  38597   "RTN","RCP 321",121,0 )
  38598    D SENDMSG ^XMXAPI(DU Z,RCSUBJ," RCBODY",.R CTO,.XMINS TR,.RCZR)  ; send mes sage
  38599   "RTN","RCP 321",122,0 )
  38600    Q
  38601   "RTN","RCP 321",123,0 )
  38602    ;
  38603   "RTN","RCP 321",124,0 )
  38604   ADD2TXT(TX ARY,LN) ;  add LN to  TXARY for  MailMan Me ssage
  38605   "RTN","RCP 321",125,0 )
  38606    ; TXARY p assed by r ef.
  38607   "RTN","RCP 321",126,0 )
  38608    I $G(LN)' ="" S TXAR Y(0)=$G(TX ARY(0))+1, TXARY(TXAR Y(0),0)=LN
  38609   "RTN","RCP 321",127,0 )
  38610    Q
  38611   "RTN","RCP 321",128,0 )
  38612    ;
  38613   "RTN","RCP 321",129,0 )
  38614   PURGE ; Cl ear any ex isting his tory
  38615   "RTN","RCP 321",130,0 )
  38616    N DA,DIK, RCPURGE,SU B
  38617   "RTN","RCP 321",131,0 )
  38618    S SUB=0
  38619   "RTN","RCP 321",132,0 )
  38620    F  S SUB= $O(^RCY(34 4.73,SUB))  Q:'SUB  D
  38621   "RTN","RCP 321",133,0 )
  38622    .S DIK="^ RCY(344.73 ,",DA=SUB  D ^DIK
  38623   "RTN","RCP 321",134,0 )
  38624    K ^XTMP($ T(+0))
  38625   "RTN","RCP 321",135,0 )
  38626    Q
  38627   "SEC","^DI C",344.73, 344.73,0," AUDIT")
  38628   @
  38629   "SEC","^DI C",344.73, 344.73,0," DD")
  38630   @
  38631   "SEC","^DI C",344.73, 344.73,0," DEL")
  38632   @
  38633   "SEC","^DI C",344.73, 344.73,0," LAYGO")
  38634   @
  38635   "SEC","^DI C",344.73, 344.73,0," RD")
  38636   @
  38637   "SEC","^DI C",344.73, 344.73,0," WR")
  38638   @
  38639   "UP",344,3 44.01,-1)
  38640   344^1
  38641   "UP",344,3 44.01,0)
  38642   344.01
  38643   "UP",344.4 9,344.491, -1)
  38644   344.49^1
  38645   "UP",344.4 9,344.491, 0)
  38646   344.491
  38647   "VER")
  38648   8.0^22.2
  38649   "^DD",342, 342,7.07,0 )
  38650   AUTO-AUDIT  MEDICAL E DI BILLS^S ^0:No;1:Ye s;^7;7^Q
  38651   "^DD",342, 342,7.07,. 1)
  38652   ENABLE AUT O-AUDIT ME DICAL EDI  BILLS
  38653   "^DD",342, 342,7.07,3 )
  38654   Enter 1 to  allow Aut o-auditing  of Medica l EDI bill s, 0 to di sallow. 
  38655   "^DD",342, 342,7.07,2 1,0)
  38656   ^^2^2^3170 818^
  38657   "^DD",342, 342,7.07,2 1,1,0)
  38658   A Yes/No p rompt to a llow a sit e to audit  their Med ical EDI B ills durin g
  38659   "^DD",342, 342,7.07,2 1,2,0)
  38660   the AR Nig htly Proce ss.
  38661   "^DD",342, 342,7.07,2 3,0)
  38662   ^^2^2^3170 818^
  38663   "^DD",342, 342,7.07,2 3,1,0)
  38664   A Yes/No p rompt to a llow a sit e to audit  their Med ical EDI B ills durin g
  38665   "^DD",342, 342,7.07,2 3,2,0)
  38666   the AR Nig htly Proce ss [PRCA N IGHTLY PRO CESS].
  38667   "^DD",342, 342,7.07," DT")
  38668   3171011
  38669   "^DD",342, 342,7.08,0 )
  38670   AUTO-AUDIT  RX EDI BI LLS^S^0:No ;1:Yes;^7; 8^Q
  38671   "^DD",342, 342,7.08,. 1)
  38672   ENABLE AUT O-AUDIT RX  EDI BILLS
  38673   "^DD",342, 342,7.08,3 )
  38674   Enter 1 to  allow Aut o-auditing  of Pharma cy EDI bil ls, 0 to d isallow. 
  38675   "^DD",342, 342,7.08,2 1,0)
  38676   ^^2^2^3170 818^
  38677   "^DD",342, 342,7.08,2 1,1,0)
  38678   A Yes/No p rompt to s ee if the  site wishe s to audit  their Pha rmacy EDI
  38679   "^DD",342, 342,7.08,2 1,2,0)
  38680   Bills duri ng the AR  Nightly Pr ocess.
  38681   "^DD",342, 342,7.08,2 3,0)
  38682   ^^2^2^3170 818^
  38683   "^DD",342, 342,7.08,2 3,1,0)
  38684   A Yes/No p rompt to s ee if the  site wishe s to audit  their Pha rmacy EDI
  38685   "^DD",342, 342,7.08,2 3,2,0)
  38686   bills duri ng the AR  Nightly Pr ocess [PRC A NIGHTLY  PROCESS].
  38687   "^DD",342, 342,7.08," DT")
  38688   3171011
  38689   "^DD",344, 344,.03,0)
  38690   DATE OPENE D^D^^0;3^S  %DT="ETX"  D ^%DT S  X=Y K:Y<1  X
  38691   "^DD",344, 344,.03,1, 0)
  38692   ^.1
  38693   "^DD",344, 344,.03,1, 1,0)
  38694   344^AO
  38695   "^DD",344, 344,.03,1, 1,1)
  38696   S ^RCY(344 ,"AO",$E(X ,1,30),DA) =""
  38697   "^DD",344, 344,.03,1, 1,2)
  38698   K ^RCY(344 ,"AO",$E(X ,1,30),DA)
  38699   "^DD",344, 344,.03,1, 1,"%D",0)
  38700   ^^2^2^3170 914^
  38701   "^DD",344, 344,.03,1, 1,"%D",1,0 )
  38702   This cross  reference  by DATE O PENED was  added to s peed compi lation of 
  38703   "^DD",344, 344,.03,1, 1,"%D",2,0 )
  38704   the RCDP L IST OF REC EIPTS REPO RT which i s filtered  by this f ield.
  38705   "^DD",344, 344,.03,1, 1,"DT")
  38706   3170524
  38707   "^DD",344, 344,.03,21 ,0)
  38708   1^^1^1^299 0507^
  38709   "^DD",344, 344,.03,21 ,1,0)
  38710   This field  contains  the date/t ime the re ceipt was  created.
  38711   "^DD",344, 344,.03,"D T")
  38712   3170524
  38713   "^DD",344, 344.01,.09 ,0)
  38714   PATIENT NA ME OR BILL  NUMBER^FX O^^0;9^D P NORBILL^RC DPURED K:' $G(X) X
  38715   "^DD",344, 344.01,.09 ,.1)
  38716  
  38717   "^DD",344, 344.01,.09 ,1,0)
  38718   ^.1
  38719   "^DD",344, 344.01,.09 ,1,1,0)
  38720   ^^TRIGGER^ 344.01^.03
  38721   "^DD",344, 344.01,.09 ,1,1,1)
  38722   K DIV S DI V=X,D0=DA( 1),DIV(0)= D0,D1=DA,D IV(1)=D1 S  Y(1)=$S($ D(^RCY(344 ,D0,1,D1,0 )):^(0),1: "") S X=$P (Y(1),U,3) ,X=X S DIU =X K Y S X =DIV S X=D IV,X=X X ^ DD(344.01, .09,1,1,1. 4)
  38723   "^DD",344, 344.01,.09 ,1,1,1.4)
  38724   S DIH=$S($ D(^RCY(344 ,DIV(0),1, DIV(1),0)) :^(0),1:"" ),DIV=X S  $P(^(0),U, 3)=DIV,DIH =344.01,DI G=.03 D ^D ICR:$O(^DD (DIH,DIG,1 ,0))
  38725   "^DD",344, 344.01,.09 ,1,1,2)
  38726   K DIV S DI V=X,D0=DA( 1),DIV(0)= D0,D1=DA,D IV(1)=D1 S  Y(1)=$S($ D(^RCY(344 ,D0,1,D1,0 )):^(0),1: "") S X=$P (Y(1),U,3) ,X=X S DIU =X K Y S X ="" X ^DD( 344.01,.09 ,1,1,2.4)
  38727   "^DD",344, 344.01,.09 ,1,1,2.4)
  38728   S DIH=$S($ D(^RCY(344 ,DIV(0),1, DIV(1),0)) :^(0),1:"" ),DIV=X S  $P(^(0),U, 3)=DIV,DIH =344.01,DI G=.03 D ^D ICR:$O(^DD (DIH,DIG,1 ,0))
  38729   "^DD",344, 344.01,.09 ,1,1,3)
  38730   Needed to  set Accoun t field
  38731   "^DD",344, 344.01,.09 ,1,1,"%D", 0)
  38732   ^^5^5^2930 923^
  38733   "^DD",344, 344.01,.09 ,1,1,"%D", 1,0)
  38734   This field  allows a  customized  look-up t o the Pati ent file
  38735   "^DD",344, 344.01,.09 ,1,1,"%D", 2,0)
  38736   and Bill n umber file  when prom pting the  user for " PATIENT NA ME
  38737   "^DD",344, 344.01,.09 ,1,1,"%D", 3,0)
  38738   OR BILL NU MBER" duri ng payment  entry.  O nce the us er selects
  38739   "^DD",344, 344.01,.09 ,1,1,"%D", 4,0)
  38740   the Patien t or Bill  Number, th is data is  then move d to the
  38741   "^DD",344, 344.01,.09 ,1,1,"%D", 5,0)
  38742   "Account"  field for  VA FileMan  Compatibl ity for pr inting.
  38743   "^DD",344, 344.01,.09 ,1,1,"CREA TE VALUE")
  38744   INTERNAL(# .09)
  38745   "^DD",344, 344.01,.09 ,1,1,"DELE TE VALUE")
  38746   @
  38747   "^DD",344, 344.01,.09 ,1,1,"DT")
  38748   2920619
  38749   "^DD",344, 344.01,.09 ,1,1,"FIEL D")
  38750   ACCOUNT
  38751   "^DD",344, 344.01,.09 ,2)
  38752   S Y(0)=Y S  Y=$P(@("^ "_$P(Y,";" ,2)_+Y_",0 )"),"^")
  38753   "^DD",344, 344.01,.09 ,2.1)
  38754   S Y=$P(@(" ^"_$P(Y,"; ",2)_+Y_", 0)"),"^")
  38755   "^DD",344, 344.01,.09 ,3)
  38756   Enter one  of followi ng: Patien t Name, Bi ll No, TRI CARE Autho rization N o, ECME Rx  Reference  Number or  Prescript ion Number .
  38757   "^DD",344, 344.01,.09 ,4)
  38758   D HLP09^RC DPURED
  38759   "^DD",344, 344.01,.09 ,22)
  38760  
  38761   "^DD",344, 344.01,.09 ,"DT")
  38762   3170619
  38763   "^DD",344. 31,344.31, 3,0)
  38764   DEBIT/CRED IT FLAG^FJ 1^^0;16^K: $L(X)>1!($ L(X)<1)!'( X?1"D") X
  38765   "^DD",344. 31,344.31, 3,3)
  38766   Answer mus t be 1 cha racter in  length.
  38767   "^DD",344. 31,344.31, 3,21,0)
  38768   ^^2^2^3170 627^^
  38769   "^DD",344. 31,344.31, 3,21,1,0)
  38770   This field  contains  a "D" if t he EFT is  a debit EF T.  This f ield is
  38771   "^DD",344. 31,344.31, 3,21,2,0)
  38772   programmat ically gen erated and  should ne ver be upd ated by a  user.
  38773   "^DD",344. 31,344.31, 3,"DT")
  38774   3170627
  38775   "^DD",344. 49,344.491 ,.1,0)
  38776   RECEIPT LI NE COMMENT ^FJ60^^0;1 0^K:$L(X)> 60!($L(X)< 3) X
  38777   "^DD",344. 49,344.491 ,.1,3)
  38778   Answer mus t be 3-60  characters  in length .
  38779   "^DD",344. 49,344.491 ,.1,21,0)
  38780   ^^2^2^3030 429^
  38781   "^DD",344. 49,344.491 ,.1,21,1,0 )
  38782   This is th e text tha t will be  used to cr eate a bil l comment  for the
  38783   "^DD",344. 49,344.491 ,.1,21,2,0 )
  38784   bill refer enced by t his sequen ce.
  38785   "^DD",344. 49,344.491 ,.1,"DT")
  38786   3170512
  38787   "^DD",344. 6,344.6,.0 1,0)
  38788   PAYER NAME ^RF^^0;1^K :$L(X)>60! ($L(X)<3)! '(X'?1P.E)  X
  38789   "^DD",344. 6,344.6,.0 1,1,0)
  38790   ^.1^^0
  38791   "^DD",344. 6,344.6,.0 1,3)
  38792   Answer mus t be 3 to  60 charact ers. This  field shou ld only be  populated  programma tically.
  38793   "^DD",344. 6,344.6,.0 1,21,0)
  38794   ^.001^2^2^ 3140506^^^ ^
  38795   "^DD",344. 6,344.6,.0 1,21,1,0)
  38796   This is th e payer na me whose s ettings ar e defined  by this en try. This 
  38797   "^DD",344. 6,344.6,.0 1,21,2,0)
  38798   field is p rogrammati cally gene rated and  should nev er be upda ted by a u ser.
  38799   "^DD",344. 6,344.6,.0 1,"DT")
  38800   3170601
  38801   "^DD",344. 6,344.6,.0 9,0)
  38802   PHARMACY P AYER^S^1:Y es;0:No;^0 ;9^Q
  38803   "^DD",344. 6,344.6,.0 9,3)
  38804   Enter 'Yes ' to flag  this payer  as a phar macy payer .
  38805   "^DD",344. 6,344.6,.0 9,21,0)
  38806   ^^1^1^3170 828^
  38807   "^DD",344. 6,344.6,.0 9,21,1,0)
  38808   This field  is used t o flag a s pecified p ayer as a  pharmacy p ayer.
  38809   "^DD",344. 6,344.6,.0 9,"DT")
  38810   3170912
  38811   "^DD",344. 6,344.6,.1 ,0)
  38812   TRICARE PA YER^S^1:Ye s;0:No;^0; 10^Q
  38813   "^DD",344. 6,344.6,.1 ,3)
  38814   Enter 'Yes ' to flag  this payer  as a Tric are payer.
  38815   "^DD",344. 6,344.6,.1 ,21,0)
  38816   ^^1^1^3170 828^
  38817   "^DD",344. 6,344.6,.1 ,21,1,0)
  38818   This field  is used t o flag a s pecified p ayer as a  Tricare pa yer.
  38819   "^DD",344. 6,344.6,.1 ,"DT")
  38820   3170912
  38821   "^DD",344. 61,344.61, .06,0)
  38822   MEDICAL EF T POST PRE VENT DAYS^ NJ2,0^^0;6 ^K:+X'=X!( X>60)!(X<1 4)!(X?.E1" ."1.N) X
  38823   "^DD",344. 61,344.61, .06,.1)
  38824   NUMBER OF  DAYS (AGE)  OF UNPOST ED MEDICAL  EFTS TO P REVENT POS TING: 
  38825   "^DD",344. 61,344.61, .06,3)
  38826   Enter numb er of days  an EFT ca n age befo re prevent ing newer  EFTs (14-6 0).
  38827   "^DD",344. 61,344.61, .06,21,0)
  38828   ^^6^6^3170 912^
  38829   "^DD",344. 61,344.61, .06,21,1,0 )
  38830   The number  of calend ar days be yond which  un-posted  medical p ayments 
  38831   "^DD",344. 61,344.61, .06,21,2,0 )
  38832   (EFTs) wil l prevent  the user f rom postin g newer me dical EFTs  without 
  38833   "^DD",344. 61,344.61, .06,21,3,0 )
  38834   posting th e older pa yments fir st.
  38835   "^DD",344. 61,344.61, .06,21,4,0 )
  38836    
  38837   "^DD",344. 61,344.61, .06,21,5,0 )
  38838   A value of  21 is the  initial d efault.  T he user ca n reset th e value to  a 
  38839   "^DD",344. 61,344.61, .06,21,6,0 )
  38840   number fro m 14 to 60 , inclusiv e, but can not delete  the value .
  38841   "^DD",344. 61,344.61, .06,"DT")
  38842   3170926
  38843   "^DD",344. 61,344.61, .07,0)
  38844   PHARMACY E FT POST PR EVENT DAYS ^NJ3,0^^0; 7^K:+X'=X! (X>365)!(X <21)!(X?.E 1"."1.N) X
  38845   "^DD",344. 61,344.61, .07,.1)
  38846   NUMBER OF  DAYS (AGE)  OF UNPOST ED PHARMAC Y EFTS TO  PREVENT PO STING: 
  38847   "^DD",344. 61,344.61, .07,3)
  38848   Type a num ber betwee n 21 and 3 65, 0 deci mal digits .
  38849   "^DD",344. 61,344.61, .07,21,0)
  38850   ^^6^6^3170 912^
  38851   "^DD",344. 61,344.61, .07,21,1,0 )
  38852   The number  of calend ar days be yond which  unposted  pharmacy p ayments 
  38853   "^DD",344. 61,344.61, .07,21,2,0 )
  38854   (EFTs) wil l prevent  the user f rom postin g newer ph armacy EFT s without 
  38855   "^DD",344. 61,344.61, .07,21,3,0 )
  38856   posting th e older pa yments fir st.
  38857   "^DD",344. 61,344.61, .07,21,4,0 )
  38858    
  38859   "^DD",344. 61,344.61, .07,21,5,0 )
  38860   The user c an reset t he value t o a number  between 2 1 and 365,  inclusive ,
  38861   "^DD",344. 61,344.61, .07,21,6,0 )
  38862   but the us er cannot  delete the  value.
  38863   "^DD",344. 61,344.61, .07,"DT")
  38864   3170912
  38865   "^DD",344. 61,344.61, .1,0)
  38866   DAY FOR WO RKLOAD NOT IFICATIONS ^RS^MO:MON DAY;TU:TUE SDAY;WE:WE DNESDAY;TH :THURSDAY; FR:FRIDAY; SA:SATURDA Y;SU:SUNDA Y;^0;10^Q
  38867   "^DD",344. 61,344.61, .1,.1)
  38868   SELECT DAY  TO SEND W ORKLOAD NO TIFICATION
  38869   "^DD",344. 61,344.61, .1,3)
  38870   Select day  of week f or workloa d notifica tion bulle tins.
  38871   "^DD",344. 61,344.61, .1,21,0)
  38872   ^^2^2^3170 911^
  38873   "^DD",344. 61,344.61, .1,21,1,0)
  38874   This field  determine s on which  day of th e week tha t workload  notificat ion 
  38875   "^DD",344. 61,344.61, .1,21,2,0)
  38876   bulletins  are to be  sent to th e RCDPE AU DIT mail g roup.
  38877   "^DD",344. 61,344.61, .1,23,0)
  38878   ^^2^2^3170 911^
  38879   "^DD",344. 61,344.61, .1,23,1,0)
  38880   This field  is used i n the PRCA  nightly p rocess opt ion to tri gger workl oad 
  38881   "^DD",344. 61,344.61, .1,23,2,0)
  38882   notificati ons to the  RCDPE AUD IT mail gr oup.
  38883   "^DD",344. 61,344.61, .1,"DT")
  38884   3170915
  38885   "^DD",344. 73,344.73, 0)
  38886   FIELD^^4^5
  38887   "^DD",344. 73,344.73, 0,"DT")
  38888   3171016
  38889   "^DD",344. 73,344.73, 0,"IX","B" ,344.73,.0 1)
  38890  
  38891   "^DD",344. 73,344.73, 0,"NM","RC DPE COMMEN T HISTORY" )
  38892  
  38893   "^DD",344. 73,344.73, 0,"VRPK")
  38894   PRCA
  38895   "^DD",344. 73,344.73, .01,0)
  38896   RECEIPT #^ RP344'^RCY (344,^0;1^ Q
  38897   "^DD",344. 73,344.73, .01,1,0)
  38898   ^.1
  38899   "^DD",344. 73,344.73, .01,1,1,0)
  38900   344.73^B
  38901   "^DD",344. 73,344.73, .01,1,1,1)
  38902   S ^RCY(344 .73,"B",$E (X,1,30),D A)=""
  38903   "^DD",344. 73,344.73, .01,1,1,2)
  38904   K ^RCY(344 .73,"B",$E (X,1,30),D A)
  38905   "^DD",344. 73,344.73, .01,3)
  38906   Enter the  receipt nu mber.
  38907   "^DD",344. 73,344.73, .01,21,0)
  38908   ^^1^1^3170 516^
  38909   "^DD",344. 73,344.73, .01,21,1,0 )
  38910   This is th e receipt  number for  the comme nt.
  38911   "^DD",344. 73,344.73, .01,23,0)
  38912   ^^1^1^3170 516^
  38913   "^DD",344. 73,344.73, .01,23,1,0 )
  38914   This field  is a poin ter to the  AR BATCH  PAYMENT fi le #344.
  38915   "^DD",344. 73,344.73, .01,"DT")
  38916   3170526
  38917   "^DD",344. 73,344.73, 1,0)
  38918   LINE NUMBE R^RNJ4,0^^ 0;2^K:+X'= X!(X>9999) !(X<1)!(X? .E1"."1.N)  X
  38919   "^DD",344. 73,344.73, 1,3)
  38920   Type a num ber betwee n 1 and 99 99, 0 deci mal digits .
  38921   "^DD",344. 73,344.73, 1,21,0)
  38922   ^^2^2^3170 516^
  38923   "^DD",344. 73,344.73, 1,21,1,0)
  38924   This field  is the nu mber of th e receipt  line that  the commen t was ente red 
  38925   "^DD",344. 73,344.73, 1,21,2,0)
  38926   for.
  38927   "^DD",344. 73,344.73, 1,23,0)
  38928   ^^1^1^3170 516^
  38929   "^DD",344. 73,344.73, 1,23,1,0)
  38930   This is th e IEN of t he AR BATC H PAYMENT  #344.01 TR ANSACTION  sub-file.
  38931   "^DD",344. 73,344.73, 1,"DT")
  38932   3170526
  38933   "^DD",344. 73,344.73, 2,0)
  38934   USER^RP200 '^VA(200,^ 0;3^Q
  38935   "^DD",344. 73,344.73, 2,3)
  38936   Enter the  user who e ntered the  receipt l ine commen t.
  38937   "^DD",344. 73,344.73, 2,21,0)
  38938   ^^1^1^3170 516^
  38939   "^DD",344. 73,344.73, 2,21,1,0)
  38940   This is th e user who  entered t he comment  against t he receipt  line.
  38941   "^DD",344. 73,344.73, 2,23,0)
  38942   ^^1^1^3170 516^
  38943   "^DD",344. 73,344.73, 2,23,1,0)
  38944   This field  is a poin ter to the  NEW PERSO N file #20 0.
  38945   "^DD",344. 73,344.73, 2,"DT")
  38946   3170526
  38947   "^DD",344. 73,344.73, 3,0)
  38948   DATE/TIME  ENTERED^RD ^^0;4^S %D T="ESTR" D  ^%DT S X= Y K:X<1 X
  38949   "^DD",344. 73,344.73, 3,3)
  38950   Enter the  date and t ime the co mment was  entered.
  38951   "^DD",344. 73,344.73, 3,21,0)
  38952   ^^1^1^3170 516^
  38953   "^DD",344. 73,344.73, 3,21,1,0)
  38954   This is th e date/tim e the rece ipt line c omment was  entered.
  38955   "^DD",344. 73,344.73, 3,"DT")
  38956   3170526
  38957   "^DD",344. 73,344.73, 4,0)
  38958   RECEIPT CO MMENT^RFJ6 0X^^0;5^S  X=$$TRIM^X LFSTR(X) K :$L(X)>60! ($L(X)<1)  X
  38959   "^DD",344. 73,344.73, 4,3)
  38960   Answer mus t be 1-60  characters  in length .
  38961   "^DD",344. 73,344.73, 4,4)
  38962  
  38963   "^DD",344. 73,344.73, 4,21,0)
  38964   ^^1^1^3170 516^
  38965   "^DD",344. 73,344.73, 4,21,1,0)
  38966   This field  is the co mment ente red agains t the rece ipt line.
  38967   "^DD",344. 73,344.73, 4,23,0)
  38968   ^^2^2^3170 516^
  38969   "^DD",344. 73,344.73, 4,23,1,0)
  38970   This field  stores a  history of  comments  entered in to the rec eipt file 
  38971   "^DD",344. 73,344.73, 4,23,2,0)
  38972   #344.41 fi eld #1.02.
  38973   "^DD",344. 73,344.73, 4,"DT")
  38974   3170516
  38975   "^DIC",344 .73,344.73 ,0)
  38976   RCDPE COMM ENT HISTOR Y^344.73
  38977   "^DIC",344 .73,344.73 ,0,"GL")
  38978   ^RCY(344.7 3,
  38979   "^DIC",344 .73,344.73 ,"%",0)
  38980   ^1.005^^0
  38981   "^DIC",344 .73,344.73 ,"%D",0)
  38982   ^^1^1^3170 517^
  38983   "^DIC",344 .73,344.73 ,"%D",1,0)
  38984   This file  holds the  history of  receipt l ine commen ts.
  38985   "^DIC",344 .73,"B","R CDPE COMME NT HISTORY ",344.73)
  38986  
  38987   **END**
  38988   **END**