source: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCCPCML.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1RCCPCML ;WASH-ISC@ALTOONA,PA/LDB-Send CCPC transmission ;12/19/96 4:16 PM
2V ;;4.5;Accounts Receivable;**34,80,93,118,133,140,160,165,187,195,206,223**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4TRAN ;called from RCCPC TRANSMIT option to interactively allow transmission of CCPC mesages
5 N %DT,DTOUT,SDT,X,Y,ZTRTN,ZTSAVE,ZTDESC,ZTIO
6 I '$D(^XUSEC("RCCPC TRANSMIT",DUZ)) W *7,*7,!,"You do not have access to do this." Q
7 S %DT="AEXP"
8 S %DT("A")="Enter statement date as it will appear on these statements: "
9 S SDT=$O(^RCPS(349.2,0)) I 'SDT W !,"You need to build the CCPC file." Q
10 S SDT=$P($P($G(^RCPS(349.2,SDT,0)),"^",10),".") I 'SDT W !,"Your CCPC statement file (349.2) is corrupted. Please rebuild it." Q
11 S SDT=$E(SDT,1,5)_$$STDY^RCCPCFN
12 S %DT("B")=$$FMTE^XLFDT(SDT)
13 D ^%DT Q:(X="^")!($D(DTOUT))!(Y=-1)
14 S SDT=$E(Y,1,5)_$$STDY^RCCPCFN,SDT=$$STDT^RCCPCFN(SDT)
15 S ZTSAVE("SDT")="",ZTRTN="RETRAN^RCCPCML",ZTIO="",ZTDESC="Re-transmit CCPC patient statements -user activated"
16 D ^%ZTLOAD
17 Q
18 ;
19EN ;called from background job
20 N DA,DIK,LPRINT
21 S SDT=$$STDT^RCCPCFN("")
22RETRAN N DA,DIK,ERROR,RCT,X
23 S (ERROR,X)=0 F S X=$O(^RCPS(349.2,X)) Q:'X I $G(^(X,6)) S ERROR=1,NM=0 D ERROR Q
24 I $G(ERROR) D EXIT Q
25 K ^TMP($J)
26 S X=0 F S X=$O(^RCT(349,"B",X)) Q:X="" I $P(X,".")="PS" S DA=$O(^RCT(349,"B",X,0)),DIK="^RCT(349," D ^DIK
27 F X="PA","IS","IT" S RCT=$O(^RCT(349.1,"B",X,0)) I RCT K ^RCT(349.1,+RCT,4)
28 N %,ADD,AMT,ERROR,L,LN,M,MSG,MCT,MPT1,MTOT,NM,P,PD,PD0,PSN,PT,PT0,PHCT,RCM,RTY,TAMT,TMSG,SZ
29 D DT^DICRW
30 S (ERROR,RTY)=0
31 S X=$O(^RCT(349.1,"B","PS",0))
32 I X,$P($G(^RCT(349.1,+X,0)),"^",3) S X=$P($G(^RCT(349.1,+X,3)),"^",3)
33 I X']"" S ERROR=6,NM=0 D ERROR,EXIT Q
34 D PHCT I 'PHCT S ERROR=1,NM=0 D ERROR,EXIT Q
35 S MTOT=$O(^TMP($J,"MCT",""),-1)
36 S MCT=0 F S MCT=$O(^TMP($J,"MCT",MCT)) Q:'MCT D PS
37EXIT D ERRML^RCCPCML1
38 K SDT,^TMP($J)
39 Q
40 ;
41F349 ;Get PS segment entry
42 N DA,D0,DIC,DLAYGO,X
43 S ERROR=0 K DD,DO S DIC="^RCT(349,",DIC(0)="L",DLAYGO=349,X="PS."_$TR($$FMTE^XLFDT(DT,"2D"),"/",".")_"."_RCM D FILE^DICN
44 I Y<0 S RTY=RTY+1 G F349:RTY<4 S ERROR=2,NM=0 D ERROR Q
45 S PSN=+Y
46 Q
47 ;
48PS ;Build PS,PH,PD segments and messages
49 S PSN=$O(^TMP($J,"MCT",MCT,0))
50 S $P(^RCT(349,+PSN,0),"^",3,10)=MCT_"^"_MTOT_"^"_$$SITE^RCMSITE()_"^"_$$FP^RCCPCFN_"^"_+^TMP($J,"MCT",MCT)_"^"_$P(^TMP($J,"MCT",MCT),"^",2)_"^"_SDT_"^"_$$STM^RCCPCFN
51 S LN=+PSN,^TMP($J,"MSG",LN)=$P($G(^RCT(349,+PSN,0)),"^",2,10)_"^|"
52 S MPT1=$P(^TMP($J,"MCT",MCT),"^",3)
53 S PT=$S(MCT=1:0,1:$P(^TMP($J,"MCT",MCT-1),"^",3))
54 F S PT=$O(^RCPS(349.2,PT)) Q:PT=$O(^RCPS(349.2,+($P(^TMP($J,"MCT",MCT),"^",3)))) D
55 .Q:$D(^TMP($J,"ERRPT",+PT))
56 .S PT0=^RCPS(349.2,+PT,0)
57 .S LN=LN+1 S ^TMP($J,"MSG",LN)="PH^"_$$SITE^RCMSITE_$$KEY^RCCPCFN(+PT)_"^"_$$NM^RCCPCFN(+PT)_"^"
58 .S ADD=$G(^RCPS(349.2,+PT,1))
59 .;
60 .;Remove special characters causing problems (WIM-0402-20728)
61 .I ADD["~" S ADD=$TR(ADD,"~","") ;Remove tilde
62 .I ADD["|" S ADD=$TR(ADD,"|","") ;Remove the pipe symbol
63 .;
64 .;Debtor needs large print (font) IF LPRINT=1
65 .S LPRINT=$G(^RCPS(349.2,+PT,7)) S:LPRINT="" LPRINT=0
66 .;
67 .F P=1:1:7 S $P(^TMP($J,"MSG",LN),"^",P+5)=$S($P(ADD,"^",P)]"":$P(ADD,"^",P),1:"")
68 .S ^TMP($J,"MSG",LN)=^TMP($J,"MSG",LN)_"^"
69 .S LN=LN+1
70 .F X=4:1:8 S $P(AMT,"^",X-3)=$$HEX^RCCPCFN($P(PT0,"^",X))
71 .;S ^TMP($J,"MSG",LN)=AMT_"^"_$G(^RCPS(349.2,+PT,3))_"^"_$G(^RCPS(349.2,+PT,4))_"^"_$P(^RCPS(349.2,+PT,2,0),"^",4)_"^|"
72 .S ^TMP($J,"MSG",LN)=AMT_"^"_$G(^RCPS(349.2,+PT,3))_"^"_$G(^RCPS(349.2,+PT,4))_"^"_$O(^RCPS(349.2,+PT,2,""),-1)
73 .S LN=LN+1 I $P($G(^RCD(340,+PT,0)),";") S ^TMP($J,"MSG",LN)="^"_$$SITE^RCMSITE_$$RJ^XLFSTR($TR($P(^RCD(340,+PT,0),";"),".",""),13,0)
74 .S ^TMP($J,"MSG",LN)=$G(^TMP($J,"MSG",LN))_"^"_LPRINT_"^|"
75 .S $P(^RCPS(349.2,+PT,0),"^",11)=+PSN
76 .S PD=0 F S PD=$O(^RCPS(349.2,+PT,2,PD)) Q:'PD I $D(^(PD,0)) S PD0=^(0) D
77 ..S AMT(0)=$$HEX^RCCPCFN($P(PD0,"^",3))
78 ..S LN=LN+1,^TMP($J,"MSG",LN)="PD^"_$$DAT^RCCPCFN(+PD0)_"^"_$P(PD0,"^",2)_"^"_AMT(0)_"^"_$P(PD0,"^",4)_"^|"
79 S LN=LN+1,^TMP($J,"MSG",LN)="~"
80 ;
81MAIL ;set up mail message
82 N L,XMDUZ,XMSUB,XMY,XMZ,Z
83 S XMSUB=$$SITE^RCMSITE()_" CCPC TRANSMISSION "_SDT
84 S XMDUZ="AR PACKAGE"
85 I $O(^XMB(3.8,"B","RCCPC STATEMENTS","")),$P($G(^RC(342,1,0)),"^",12) S XMY("G.RCCPC STATEMENTS")=""
86 S X=$O(^RCT(349.1,"B","PS",0))
87 I X,$P($G(^RCT(349.1,+X,0)),"^",3) S X=$P($G(^RCT(349.1,+X,3)),"^")_"@"_$P($G(^RCT(349.1,+X,3)),"^",3) S:$P(X,"@",2)]"" XMY(X)=""
88 I $P(X,"@",2)']"" D Q
89 .S ERROR=6,NM=0 D ERROR
90 S XMDUZ="AR PACKAGE"
91 D XMZ^XMA2
92 I XMZ<1 S RTY=RTY+1 G MAIL:RTY<4 S ERROR=5,NM=0 D ERROR Q
93 S $P(^RCT(349,+PSN,0),"^",11,12)=DT_"^"_XMZ
94 S (L,L(1))=0 F S L(1)=$O(^TMP($J,"MSG",L(1))) Q:'L(1) S L=L+1,^XMB(3.9,+XMZ,2,L,0)=^TMP($J,"MSG",L(1))
95 ;S L=$O(^TMP($J,"MSG",""),-1)
96 S ^XMB(3.9,XMZ,2,0)="^3.92A^"_L_"^"_L_"^"_DT
97 D ENT1^XMD
98 D NOW^%DTC
99 S $P(^RCT(349,+PSN,0),"^",11,12)=%_"^"_XMZ
100 K ^TMP($J,"MSG")
101 ;D KILL^XM
102 Q
103 ;
104PHCT ;PH count
105 S (ERROR,PT,PHCT,TAMT,SZ)=0,RCM=1
106 F S PT=$O(^RCPS(349.2,PT)) Q:'PT S ERROR=0 D I ERROR,(ERROR<3) Q
107 .S SZ(1)=0 D ERRCHK Q:ERROR
108 .S PT0=^RCPS(349.2,+PT,0)
109 .S PHCT=PHCT+1
110 .S SZ=550+SZ,SZ(1)=550
111 .S:$G(^RCPS(349.2,+PT,1))]"" SZ=SZ+$L(^(1)),SZ(1)=SZ(1)+$L(^(1))
112 .S:$G(^RCPS(349.2,+PT,3))]"" SZ=SZ+$L(^(3))+1,SZ(1)=SZ(1)+$L(^(3))+1
113 .S:$G(^RCPS(349.2,+PT,4))]"" SZ=SZ+$L(^(4))+1,SZ(1)=SZ(1)+$L(^(4))+1
114 .S X=0 F S X=$O(^RCPS(349.2,+PT,2,X)) Q:'X I $D(^(X,0)) S SZ=$L(^(0))+SZ,SZ(1)=SZ(1)+$L(^(0))
115 .S TAMT=TAMT+$P(^RCPS(349.2,+PT,0),"^",8)
116 .I SZ>27000 D
117 ..S RTY=0 D F349 Q:ERROR
118 ..S TAMT=TAMT-$P(PT0,"^",8)
119 ..S TAMT=$$HEX^RCCPCFN(TAMT)
120 ..S ^TMP($J,"MCT",RCM)=(PHCT-1)_"^"_TAMT_"^"_$O(^RCPS(349.2,PT),-1)_"^"_(SZ-SZ(1))
121 ..S ^TMP($J,"MCT",RCM,+PSN)=""
122 ..S RCM=RCM+1,PHCT=1
123 ..S SZ=SZ(1)
124 ..S TAMT=$P(PT0,"^",8)
125 I 'PT,$O(^RCPS(349.2,0)) D
126 .S RTY=0 D F349 Q:ERROR S ^TMP($J,"MCT",RCM)=PHCT_"^"_$$HEX^RCCPCFN(TAMT)_"^"_$O(^RCPS(349.2,PT),-1)
127 .S ^TMP($J,"MCT",RCM,+PSN)=""
128 Q
129 ;
130ERROR ;ERROR FILE
131 I NM=0 S ^TMP($J,"ERROR",ERROR,NM)="" Q
132 S ^TMP($J,"ERROR",ERROR,NM,$$SSN^RCFN01(+PT))=""
133 Q
134 ;
135ERRCHK ;Error check
136 I '$D(^RCPS(349.2,+PT,0)) S ERROR=1,NM=0 D ERROR Q
137 S PT(1)=PT,PT=$O(^RCPS(349.2,0)) I '$P(^RCPS(349.2,PT,0),"^",18) S ERROR=1,NM=0 D ERROR S PT=PT(1) Q
138 S PT=PT(1)
139 I $$KEY^RCCPCFN(+PT)']"" S ERROR=4,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
140 I '$D(^RCPS(349.2,"AKEY",$$KEY^RCCPCFN(+PT))) S ERROR=4,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
141 S ADD=$G(^RCPS(349.2,+PT,1))
142 F P=1:1:7 S ADD(P)=$S($P(ADD,"^",P)]"":$P(ADD,"^",P),1:"")
143 I ADD(1)="",ADD(2)="",ADD(3)="",ADD(4)="",ADD(5)="",ADD(6)="" S ERROR=8,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
144 I ADD(1)="",(ADD(2)=""),(ADD(3)=""),(ADD(6)="") S ERROR=8,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
145 I ADD(4)=""!(ADD(5)="")!(ADD(6)="") S ERROR=8,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)=""
146 F ADD=1:1:6 I ADD(ADD)'?.ANP S ERROR=10,NM=$$NAM^RCFN01(+PT),^TMP($J,"ERRPT",+PT)="" D ERROR Q
147 I $P($G(^RCD(340,+PT,1)),"^",9) S ^TMP($J,"ERRPT",+PT)="",ERROR=9,NM=$$NAM^RCFN01(+PT) D ERROR
148 Q
Note: See TracBrowser for help on using the repository browser.