source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCTOPS.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1RCTOPS ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY (SERVER) ;10/24/96 3:21 PM
2V ;;4.5;Accounts Receivable;**141,229**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;Program to process server messages from DMC
5 ;1) Will automatically delete TOP flags from local system for
6 ; those patients submitted to TOP that are rejected by TOP, Austin
7 ; or DMC
8 ;2) Will adjust TOP amount if update rejected
9 ;
10READ ;READS MESSAGE INTO TEMPORARY GLOBAL
11 K ^TMP("RCTOPS",$J) S XMA=0
12READ1 X XMREC I $D(XMER) G PROC:XMER<0
13 S XMA=XMA+1
14 S ^TMP("RCTOPS",$J,"READ",XMA)=XMRG
15 G READ1
16PROC N DEBTOR,TIN,LN,I,REC,NAME,TYPE,CNTR,BILL,ACTION,ECODE,ECODE1,AMOUNT
17 N LDOC,REC1,XMDUZ,XMSUB,XMY,XMTEXT,SEQ,TSEQ,MTYPE,FILE
18 K XMPOS,XMA,XMER,XMREC,XMRG
19 S (LDOC,LN)=0
20 F S LN=$O(^TMP("RCTOPS",$J,"READ",LN)) Q:LN="" S REC=$G(^(LN)) Q:$E(REC,1,4)="NNNN" D
21 .I $E(REC,1,4)="2TPA" Q
22 .I REC[U S TSEQ=$P(REC,U),SEQ=$P(REC,U,2),MTYPE=$P(REC,U,3),MTYPE=$S(MTYPE["AUST":"(AAC)",MTYPE["TREAS":"(TREASURY)",1:"(DMC)") Q
23 .I $L(REC)=250 D LDOC Q
24 .S DEBTOR=+$E(REC,21,34),TYPE=$E(REC,36),ACTION=$E(REC,35),TIN=""
25 .S ECODE=$E(REC,202,221)
26 .S:TYPE=1 TIN=$E(REC,37,45),AMOUNT=$E(REC,135,144)_"."_$E(REC,145,146)
27 .I TIN="" S TIN=$P($G(^RCD(340,DEBTOR,4)),U) I TIN="" D
28 ..S FILE=$$FILE^RCTOPD(^RCD(340,DEBTOR,0))
29 ..S TIN=$$TAXID^RCTOP1(DEBTOR,FILE)
30 ..Q
31 .K NAME S DIC=340,DR=.01,DA=DEBTOR,DIQ="NAME",DIQ(0)="E" D EN^DIQ1
32 .;
33 .; If DEBTOR is not in VistA - Ignore
34 .Q:'$D(NAME) ;PRCA*4.5*229
35 .;
36 .S NAME=NAME(340,DEBTOR,.01,"E"),NAME=$$LJ^XLFSTR(NAME,30)
37 .S ECODE1=$E(ECODE,1,2)
38 .F I=3:2 Q:$E(ECODE,I)'?1N S ECODE1=ECODE1_","_$E(ECODE,I,I+1)
39SETLN .S ^TMP("RCTOPS",$J,"BUILD",NAME,TYPE)=NAME_" "_TIN_" "_TYPE_" "_ACTION_" "_ECODE1
40 .I TYPE=1 D
41 ..I ACTION="A" D Q
42 ...K ^RCD(340,DEBTOR,4),^(5),^(6),^RCD(340,"TOP",DEBTOR)
43 ...S BILL=0
44 ...F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL="" K ^PRCA(430,BILL,14)
45 ...Q
46 ..Q:'$D(^RCD(340,"TOP",DEBTOR))
47 ..S:ACTION="I" $P(^(4),U,3)=$P(^RCD(340,DEBTOR,4),U,3)-AMOUNT
48 ..S:ACTION="S" $P(^(4),U,3)=$P(^RCD(340,DEBTOR,4),U,3)+AMOUNT
49 ..Q
50 .Q
51 ;
52MSG ;Send list of rejected documents
53 G MSG1:LDOC
54 S ^TMP("RCTOPS",$J,"REC",1)="The following TOP transmissions have been rejected"
55 S ^TMP("RCTOPS",$J,"REC",2)=""
56 S ^TMP("RCTOPS",$J,"REC",3)="NAME TIN TYPE ACTION ERROR CODES"
57 S ^TMP("RCTOPS",$J,"REC",4)="" G SEND
58MSG1 S ^TMP("RCTOPS",$J,"REC",1)="The following debtors were unable to have TOP letters sent:"
59 S ^TMP("RCTOPS",$J,"REC",2)=""
60 S ^TMP("RCTOPS",$J,"REC",3)="NAME TIN ERROR CODES"
61 S ^TMP("RCTOPS",$J,"REC",4)=""
62SEND D ALPHA
63 S XMSUB="TOP REJECTS"_MTYPE_" SEQ: "_SEQ_" OF "_TSEQ
64 S XMY("G.TOP")="",XMDUZ="AR PACKAGE",XMTEXT="^TMP(""RCTOPS"","_$J_",""REC"","
65 D ^XMD
66 ;
67CLEANUP ; This cleans up the ^TMP global.
68 K ^TMP("RCTOPS",$J)
69 Q
70LDOC ;Process debtor not receiving TOP letters
71 S:'LDOC LDOC=1
72 S LN=$O(^TMP("RCTOPS",$J,"READ",LN)) S REC1=^(LN)
73 S TIN=$E(REC,1,9),DEBTOR=+$E(REC1,104,113),ECODE=$E(REC1,115,134)
74 K NAME S DIC=340,DR=.01,DA=DEBTOR,DIQ="NAME",DIQ(0)="E" D EN^DIQ1
75 S NAME=NAME(340,DEBTOR,.01,"E"),NAME=$$LJ^XLFSTR(NAME,40)
76 S ECODE1=$E(ECODE,1,2)
77 F I=3:2 Q:$E(ECODE,I)=" " S ECODE1=ECODE1_","_$E(ECODE,I,I+1)
78 S ^TMP("RCTOPS",$J,"BUILD",NAME,LN)=NAME_" "_TIN_" "_ECODE1
79 Q
80ALPHA ;loads alphabetical listings into "REC"
81 S NAME="",CNTR=4
82 F S NAME=$O(^TMP("RCTOPS",$J,"BUILD",NAME)) Q:NAME="" S I=0 D
83 .F S I=$O(^TMP("RCTOPS",$J,"BUILD",NAME,I)) Q:I'?1N.N S REC=^(I) D
84 ..S CNTR=CNTR+1,^TMP("RCTOPS",$J,"REC",CNTR)=REC
85 ..Q
86 .Q
87 Q
Note: See TracBrowser for help on using the repository browser.