source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPETR.m@ 642

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1RCDPETR ;ALB/TMK - EOB TRANSFER IN/TRANSFER OUT REPORTS ;04-NOV-02
2 ;;4.5;Accounts Receivable;**173**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; IA for read access to ^IBM(361.1 = 4051
5 Q
6 ;
7RPT ; Transfer In/Out Report
8 N DIR,X,Y,POP,RCRPT,RCDT1,RCDT2,ZTRTN,ZTSK,ZTDESC,%ZIS
9 S DIR(0)="SBO^I:TRANSFER IN REPORT;O:TRANSFER OUT REPORT;B:BOTH REPORTS",DIR("A")="SELECT REPORT" D ^DIR K DIR
10 I $D(DTOUT)!$D(DUOUT)!(Y="") G RPTQ
11 S RCRPT=Y
12 S DIR("?")="ENTER THE EARLIEST TRANSFERRED FROM/TO DATE TO INCLUDE ON THE REPORT"
13 S DIR(0)="DAO^:"_DT_":APE",DIR("A")="START DATE: " D ^DIR K DIR
14 I $D(DTOUT)!$D(DUOUT)!(Y="") G RPTQ
15 S RCDT1=Y
16 S DIR("?")="ENTER THE LATEST TRANSFERRED FROM/TO DATE TO INCLUDE ON THE REPORT"
17 S DIR(0)="DAO^"_RCDT1_":"_DT_":APE",DIR("A")="END DATE: " D ^DIR K DIR
18 I $D(DTOUT)!$D(DUOUT)!(Y="") G RPTQ
19 S RCDT2=Y
20 ; Ask device
21 S %ZIS="QM" D ^%ZIS G:POP RPTQ
22 I $D(IO("Q")) D G RPTQ
23 . S ZTRTN="EN^RCDPETR("_RCRPT_","_RCDT1_","_RCDT2_")",ZTDESC="AR - EDI LOCKBOX TRANSFERRED EEOB REPORT"
24 . D ^%ZTLOAD
25 . W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
26 . K ZTSK,IO("Q") D HOME^%ZIS
27 U IO
28 D EN(RCRPT,RCDT1,RCDT2)
29RPTQ Q
30 ;
31EN(RCRPT,RCDT1,RCDT2) ; Entry point for queued job
32 N Q,Z,Z0,Z1,Z2,ZCT,RCSTOP,RCPG,RCDAT,RCDAT1,RCCT,RCACC,RCNOT,RCRCV,RCNRCV
33 K ^TMP($J,"RCDPE_TROUT"),^("RCDPE_TRIN")
34 S (RCSTOP,ZCT)=0
35 I RCRPT="O"!(RCRPT="B") D ; Transfer out
36 . S Z=RCDT1-.0001
37 . F S Z=$O(^RCY(344.4,"ATOUT",Z)) Q:'Z!RCSTOP S Z0=0 F S Z0=$O(^RCY(344.4,"ATOUT",Z,Z0)) Q:'Z0!(Z0>RCDT2)!RCSTOP S Z1=0 F S Z1=$O(^RCY(344.4,"ATOUT",Z,Z0,Z1)) Q:'Z1 D Q:RCSTOP
38 .. Q:$$STOP(.ZCT,.RCSTOP,0)
39 .. ; EOB transferred out was found in date range
40 .. S ^TMP($J,"RCDPE_TROUT",Z,Z0,Z1)=$G(^RCY(344.4,Z0,1,Z1,0))
41 .. ; sbscrpts are: date,ien file 344.4,ien file 344.41
42 ;
43 I 'RCSTOP,(RCRPT="I"!(RCRPT="B")) D ; Transfer in
44 . S Z=RCDT1-.0001 ; Look for accepted ones
45 . F S Z=$O(^IBM(361.1,"ATIN",Z)) Q:'Z!(Z>RCDT2)!RCSTOP S Z0="" F S Z0=$O(^IBM(361.1,"ATIN",Z,Z0)) Q:Z0=""!RCSTOP S Z1=0 F S Z1=$O(^IBM(361.1,"ATIN",Z,Z0,Z1)) Q:'Z1 D Q:RCSTOP ; IA 4051
46 .. ; EOB transfer in/accepted was found in date range
47 .. Q:$$STOP(.ZCT,.RCSTOP,0)
48 .. S ^TMP($J,"RCDPE_TRIN",Z,361.1,Z0,Z1)=$G(^IBM(361.1,Z1,0)) ; IA 4051
49 .. ;sbscrpts are: date,file,transferred from name,ien file 361.1
50 .. S ^TMP($J,"RCDPE_TRIN",Z,361.1,Z0,Z1,7)=$G(^IBM(361.1,Z1,7)) ; IA 4051
51 .. S ^TMP($J,"RCDPE_TRIN",Z,361.1,Z0,Z1,1)=$G(^IBM(361.1,Z1,1)) ; IA 4051
52 . Q:RCSTOP
53 . S Z=RCDT1-.0001 ; Look for pending accept ones
54 . F S Z=$O(^RCY(344.5,"ATIN",Z)) Q:Z'!(Z>RCDT2)!RCSTOP S Z0="" F S Z0=$O(^RCY(344.5,"ATIN",Z,Z0)) Q:Z0=""!RCSTOP S Z1=0 F S Z1=$O(^RCY(344.5,"ATIN",Z,Z0,Z1)) Q:'Z1 D Q:RCSTOP
55 .. ; EOB transfer in/pending acceptance was found in date range
56 .. S ^TMP($J,"RCDPE_TRIN",Z,344.5,Z0,Z1)=$G(^RCY(344.5,Z1,0))
57 .. ;sbscrpts are: date,file,transferred from name,ien file 344.5
58 ;
59 G:RCSTOP ENQ
60 S (RCPG,RCCT,Z,RCACC,RCNOT,RCRCV,RCNRCV)=0
61 F S Z=$O(^TMP($J,"RCDPE_TROUT",Z)) Q:'Z!RCSTOP S Z0="" F S Z0=$O(^TMP($J,"RCDPE_TROUT",Z,Z0)) Q:Z0=""!RCSTOP S Z1=0 F S Z1=$O(^TMP($J,"RCDPE_TROUT",Z,Z0,Z1)) Q:'Z1 S RCDAT=$G(^(Z1)) D Q:RCSTOP
62 . I 'RCPG!(($Y+5)>IOSL) D HDR(.RCCT,.RCPG,.RCSTOP,1,RCDT1,RCDT2) Q:RCSTOP
63 . S Q=$$SETSTR^VALM1($P(RCDAT,U,5),"",1,11)
64 . S Q=$$SETSTR^VALM1($$FMTE^XLFDT($P(RCDAT,U,12),"2D"),Q,14,8)
65 . S Q=$$SETSTR^VALM1($P($G(^DIC(4,+$P(RCDAT,U,11),0)),U),Q,24,20)
66 . S Q=$$SETSTR^VALM1($$FMTE^XLFDT($P($G(^RCY(344.4,+Z0,0)),U,4),"2D"),Q,46,8)
67 . S Q=$$SETSTR^VALM1($J(+$P(RCDAT,U,3),"",2),Q,56,12)
68 . S Q=$$SETSTR^VALM1($S('$P(RCDAT,U,16):"NOT REC'D",$P(RCDAT,U,10)="":"REC'D",$P(RCDAT,U,10)=0:"NOT ACCPTD",1:"ACCPTD"),Q,70,10)
69 . I '$P(RCDAT,U,16) S RCNRCV=RCNRCV+1
70 . I $P(RCDAT,U,16)=1,$P(RCDAT,U,10)="" S RCRCV=RCRCV+1
71 . I $P(RCDAT,U,10) S RCACC=RCACC+1
72 . I $P(RCDAT,U,10)=0 S RCNOT=RCNOT+1
73 . D SETLINE(Q,.RCCT)
74 ;
75 G:RCSTOP ENQ
76 ;
77 I RCRPT="B"!(RCRPT="O") D
78 . I '$O(^TMP($J,"RCDPE_TROUT",0)) D Q
79 .. D HDR(.RCCT,.RCPG,.RCSTOP,1,RCDT1,RCDT2) Q:RCSTOP
80 .. D SETLINE("** THERE WERE NO EEOBs TRANSFERRED OUT WITHIN THE DATE RANGE SELECTED",.RCCT)
81 . I ($Y+5)>IOSL D HDR(.RCCT,.RCPG,.RCSTOP,1,RCDT1,RCDT2) Q:RCSTOP
82 . D SETLINE(" ",.RCCT)
83 . D SETLINE(" TOTAL # EEOBs NOT CONFIRMED AS 'RECEIVED' BY OTHER SITES: "_RCNRCV,.RCCT)
84 . D SETLINE(" TOTAL # EEOBs STILL JUST 'RECEIVED' BY OTHER SITES: "_RCRCV,.RCCT)
85 . D SETLINE(" TOTAL # EEOBs ACCEPTED BY OTHER SITES: "_RCACC,.RCCT)
86 . D SETLINE(" TOTAL # EEOBs NOT ACCEPTED BY OTHER SITES: "_RCNOT,.RCCT)
87 ;
88 G:RCSTOP ENQ
89 ;
90 I RCPG D ASK()
91 S (RCACC,RCNOT,RCPG)=0
92 S Z=0 F S Z=$O(^TMP($J,"RCDPE_TRIN",Z)) Q:'Z S Z0=0 F S Z0=$O(^TMP($J,"RCDPE_TRIN",Z,Z0)) Q:'Z0 S Z1="" F S Z1=$O(^TMP($J,"RCDPE_TRIN",Z,Z0,Z1)) Q:Z1="" S Z2=0 F S Z2=$O(^TMP($J,"RCDPE_TRIN",Z,Z0,Z1,Z2)) Q:'Z2 D
93 . S RCDAT=$G(^TMP($J,"RCDPE_TRIN",Z,Z0,Z1,Z2))
94 . I Z0=361.1 S RCDAT(7)=$G(^TMP($J,"RCDPE_TRIN",Z,Z0,Z1,Z2,7)),RCDAT(1)=$G(^(1))
95 . I 'RCPG!(($Y+5)>IOSL) D HDR(.RCCT,.RCPG,.RCSTOP,0,RCDT1,RCDT2) Q:RCSTOP
96 . I Z0=361.1 D
97 .. S Q=$$SETSTR^VALM1($$BN1^PRCAFN(+RCDAT),"",1,11)
98 .. S Q=$$SETSTR^VALM1($$FMTE^XLFDT($P(RCDAT,U,5),"2D"),Q,14,8)
99 .. S Q=$$SETSTR^VALM1($P(RCDAT(7),U),Q,24,20)
100 .. S Q=$$SETSTR^VALM1($$FMTE^XLFDT($P(RCDAT,U,6),"2D"),Q,46,8)
101 .. S Q=$$SETSTR^VALM1($J(+$P(RCDAT(1),U),"",2),Q,56,12)
102 .. S Q=$$SETSTR^VALM1("ACCEPTED",Q,70,10)
103 .. S RCACC=RCACC+1
104 . E D
105 .. D RAWBILL(Z2,.RCDAT1)
106 .. S RCDAT1=+$O(RCDAT1(0)),RCDAT1=$G(RCDAT1(RCDAT1))
107 .. S Q=$$SETSTR^VALM1($P(RCDAT1,U),"",1,11)
108 .. S Q=$$SETSTR^VALM1($$FMTE^XLFDT($P(RCDAT,U,3),"2D"),Q,14,8)
109 .. S Q=$$SETSTR^VALM1($P(RCDAT,U,12),Q,24,20)
110 .. S Q=$$SETSTR^VALM1($S($G(RCDAT1(0)):$E(RCDAT1(0),5,6)_"/"_$E(RCDAT1(0),7,8)_"/"_$E(RCDAT1(0),3,4),1:""),Q,46,8)
111 .. S Q=$$SETSTR^VALM1($J(+$P(RCDAT1,U,2),"",2),Q,56,12)
112 .. S Q=$$SETSTR^VALM1("PENDING",Q,70,10)
113 .. S RCNOT=RCNOT+1
114 . D SETLINE(Q,.RCCT)
115 ;
116 G:RCSTOP ENQ
117 ;
118 I RCRPT="B"!(RCRPT="I") D
119 . I '$O(^TMP($J,"RCDPE_TRIN",0)) D Q
120 .. D HDR(.RCCT,.RCPG,.RCSTOP,0,RCDT1,RCDT2) Q:RCSTOP
121 .. D SETLINE("** THERE WERE NO EEOBs TRANSFERRED 'IN' WITHIN THE DATE RANGE SELECTED",.RCCT)
122 . I ($Y+5)>IOSL D HDR(.RCCT,.RCPG,.RCSTOP,0,RCDT1,RCDT2) Q:RCSTOP
123 . D SETLINE(" ",.RCCT)
124 . D SETLINE(" TOTAL # EEOBs YOU ACCEPTED: "_RCACC,.RCCT)
125 . D SETLINE(" TOTAL # EEOBs STILL PENDING: "_RCNOT,.RCCT)
126 ;
127ENQ I '$D(ZTQUEUED) D ^%ZISC I 'RCSTOP,RCPG D ASK()
128 I $D(ZTQUEUED) S ZTREQ="@"
129 K ^TMP($J,"RCDPE_TROUT"),^("RCDPE_TRIN")
130 Q
131 ;
132HDR(RCCT,RCPG,RCSTOP,RCINOUT,RCDT1,RCDT2) ;Prints report heading
133 ; Function returns RCPG = current page # and RCCT = running line count
134 ; and RCSTOP = 1 if user aborted print
135 ; Parameters must be passed by reference
136 N Z,Z0
137 I RCPG!($E(IOST,1,2)="C-") D
138 . I RCPG&($E(IOST,1,2)="C-") D ASK(.RCSTOP) Q:RCSTOP
139 . W @IOF,*13 ; Write form feed
140 S RCPG=RCPG+1
141 S Z0="EDI LOCKBOX EEOBs TRANSFERRED "_$S(RCINOUT=1:"OUT",1:"IN")_" REPORT"
142 S Z=$$SETSTR^VALM1($J("",80-$L(Z0)\2)_Z0,"",1,79)
143 S Z=$$SETSTR^VALM1("Page: "_RCPG,Z,70,10)
144 D SETLINE(Z,.RCCT)
145 S Z0="RUN DATE: "_$$FMTE^XLFDT(DT,2),Z0=$J("",80-$L(Z0)\2)_Z0
146 S Z=$$SETSTR^VALM1(Z0,"",1,79)
147 D SETLINE(Z,.RCCT)
148 D SETLINE(" ",.RCCT)
149 D SETLINE("DATE RANGE SELECTED: "_$$FMTE^XLFDT(RCDT1,2)_"-"_$$FMTE^XLFDT(RCDT2,2),.RCCT)
150 D SETLINE(" ",.RCCT)
151 S Z=$$SETSTR^VALM1($E("BILL #"_$J("",13),1,13)_"TRANS DT"_$J("",2)_$E("TRANS "_$S(RCINOUT=1:"TO",1:"FROM")_$J("",21),1,21)_"EEOB DATE"_$J("",2)_$E("AMT PAID"_$J("",14),1,14)_"STATUS","",1,80)
152 D SETLINE(Z,.RCCT)
153 D SETLINE($TR($J("",IOM-1)," ","="),.RCCT)
154 I $$STOP(99,.RCSTOP,0)
155 Q
156 ;
157SETLINE(Z,RCCT) ; Writes line
158 ; Z = txt to output
159 ; RCCT = line counter
160 S RCCT=RCCT+1
161 W !,Z
162 Q
163 ;
164ASK(RCSTOP) ; Ask to continue
165 ; If passed by reference ,RCSTOP is returned as 1 if print is aborted
166 I $E(IOST,1,2)'["C-" Q
167 N DIR,DIROUT,DIRUT,DTOUT,DUOUT
168 S DIR(0)="E" W ! D ^DIR
169 I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q
170 Q
171 ;
172STOP(CT,RCSTOP,RCPG) ; Function returns 1 if queued job/user requested forced exit
173 ; Function returns CT if passed by ref to only check every 100 records
174 S CT=CT+1
175 I (CT#100) Q 0
176 I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !,"***TASK STOPPED BY USER***" Q 1
177 Q 0
178 ;
179RAWBILL(RC3445,RCDAT) ; Returns bill specific data for entry in file 344.5
180 ; RC3445 = Ien file 344.5
181 ; FUNCTION RETURNS RCDAT(SEQ #)=Bill #^amt pd^EOB date (pass by ref)
182 N DAT,Z,Z0,RCT
183 S (RCT,Z)=0 F S Z=$O(^RCY(344.5,RC3445,2,Z)) Q:'Z S Z0=$G(^(Z,0)) D
184 . I +Z0=835 S RCDAT(0)=$P(Z0,U,3) Q
185 . I +Z0=10 S RCT=RCT+1,RCDAT(RCT)=$P(Z0,U,2)_U_$J($P(Z0,U,11)/100,"",2)
186 Q
187 ;
Note: See TracBrowser for help on using the repository browser.