source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNERPE.m@ 1582

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

initial load of WorldVistAEHR
File size: 8.8 KB
Line 
1IBCNERPE ;DAOU/BHS - IBCNE IIV RESPONSE REPORT (cont'd);03-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**271,300**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Must call at tag
6 Q
7 ;
8 ; This tag is only called from IBCNERP2
9 ;
10GETDATA(IEN,RPTDATA) ; Retrieve response data
11 ; Init
12 N EBCT,NOTECT,EBPTR,PC,CNCT,CNPTR,NWNTCT,IBNOTES,IBERR
13 N %,DIW,DIWI,DIWT,DIWTC,DIWX,DN,I,Z,ERRTEXT,II,FUTDT,TQIEN
14 N FRST,IIVSTR,IIVSTAT
15 ;
16 ; Insured Info from IIV Response #365
17 S RPTDATA(0)=$G(^IBCN(365,IEN,0)),TQIEN=$P(RPTDATA(0),U,5)
18 ; Trans dates to ext format
19 S $P(RPTDATA(0),U,7)=$$FMTE^XLFDT($P(RPTDATA(0),U,7)\1,"5Z")
20 S RPTDATA(1)=$G(^IBCN(365,IEN,1))
21 ; Trans ext values for SET of CODES values
22 S $P(RPTDATA(1),U,8)=$$GET1^DIQ(365,IEN_",",1.08,"E") ; Whose Ins
23 S $P(RPTDATA(1),U,9)=$$GET1^DIQ(365,IEN_",",1.09,"E") ; Pt Rel to Sub
24 S $P(RPTDATA(1),U,13)=$$GET1^DIQ(365,IEN_",",1.13,"E") ; COB
25 ; Trans err actions/codes to ext
26 S $P(RPTDATA(1),U,14)=$$X12^IBCNERP2(365.017,$P(RPTDATA(1),U,14))
27 S $P(RPTDATA(1),U,15)=$$X12^IBCNERP2(365.018,$P(RPTDATA(1),U,15))
28 ; Trans dates to ext format - check format
29 F PC=2,9:1:12,16,17,19 S $P(RPTDATA(1),U,PC)=$$FMTE^XLFDT($P(RPTDATA(1),U,PC),"5Z")
30 ;
31 ; Loop thru mult Elig/Ben segs
32 S EBCT=0,IIVSTAT=""
33 ; Check to see if the IIV STATUS flag was passed
34 ; If so, set IIVSTAT to its value and update RPTDATA
35 S FRST=$O(^IBCN(365,IEN,2,0))
36 I FRST D
37 . S IIVSTR=$G(^IBCN(365,IEN,2,FRST,0))
38 . I $P(IIVSTR,U,6)="IIV Eligibility Determination" D
39 .. S EBCT=FRST,IIVSTAT=$P(IIVSTR,U)
40 .. ; Convert IEN to X12 code
41 .. S IIVSTAT=$$GET1^DIQ(365.02,EBCT_","_IEN_",","ELIGIBILITY/BENEFIT INFO:CODE")
42 .. S IIVSTAT=$S(IIVSTAT=1:"Active",IIVSTAT=6:"Inactive",1:"U")
43 .. S RPTDATA(2,0)=IIVSTAT,RPTDATA(2,EBCT)=""
44 ; Error action/condition shd be flagged as Undetermined - no EC flg sent
45 I IIVSTAT="",$P(RPTDATA(1),U,14)]""!($P(RPTDATA(1),U,15)]"") S (IIVSTAT,RPTDATA(2,0))="U"
46 F S EBCT=$O(^IBCN(365,IEN,2,EBCT)) Q:'EBCT D
47 . S RPTDATA(2,EBCT)=$G(^IBCN(365,IEN,2,EBCT,0))
48 . ; Elig/Ben Info (ptr to EB01 table)
49 . S $P(RPTDATA(2,EBCT),U,2)=$$X12^IBCNERP2(365.011,$P(RPTDATA(2,EBCT),U,2))
50 . ; Cov Lvl Code (ptr to EB02 table)
51 . S $P(RPTDATA(2,EBCT),U,3)=$$X12^IBCNERP2(365.012,$P(RPTDATA(2,EBCT),U,3))
52 . ; Svc Type Code (ptr to EB03 table)
53 . S $P(RPTDATA(2,EBCT),U,4)=$$X12^IBCNERP2(365.013,$P(RPTDATA(2,EBCT),U,4))
54 . ; Ins Type Code (ptr to EB04 table)
55 . S $P(RPTDATA(2,EBCT),U,5)=$$X12^IBCNERP2(365.014,$P(RPTDATA(2,EBCT),U,5))
56 . ; Plan Cov Desc - free text
57 . ; Time Pd Qual (ptr to EB06 table)
58 . S $P(RPTDATA(2,EBCT),U,7)=$$X12^IBCNERP2(365.015,$P(RPTDATA(2,EBCT),U,7))
59 . ; Monetary Amt
60 . I $P(RPTDATA(2,EBCT),U,8)'="" S $P(RPTDATA(2,EBCT),U,8)="$"_$FN(+$P(RPTDATA(2,EBCT),U,8),",",2)
61 . ; Percent
62 . I $P(RPTDATA(2,EBCT),U,9)'="" S $P(RPTDATA(2,EBCT),U,9)=$S($P(RPTDATA(2,EBCT),U,9)<1:$P(RPTDATA(2,EBCT),U,9)*100,1:$P(RPTDATA(2,EBCT),U,9))_"%"
63 . ; Qty Qual (ptr to EB09)
64 . S $P(RPTDATA(2,EBCT),U,10)=$$X12^IBCNERP2(365.016,$P(RPTDATA(2,EBCT),U,10))
65 . ; Qty
66 . I $P(RPTDATA(2,EBCT),U,11)'="" S $P(RPTDATA(2,EBCT),U,10)=$P(RPTDATA(2,EBCT),U,11)_" "_$P(RPTDATA(2,EBCT),U,10),$P(RPTDATA(2,EBCT),U,11)=""
67 . ; Auth/Cert Ind (Y/N/U)
68 . I $P(RPTDATA(2,EBCT),U,12)'="" S $P(RPTDATA(2,EBCT),U,12)=$$GET1^DIQ(365.02,EBCT_","_IEN_",",.12,"E")
69 . ; In-Plan Network Ind (Y/N/U)
70 . I $P(RPTDATA(2,EBCT),U,13)'="" S $P(RPTDATA(2,EBCT),U,13)=$$GET1^DIQ(365.02,EBCT_","_IEN_",",.13,"E")
71 . ; Loop thru Notes (wp) - format to 70 chars
72 . S (NOTECT,NWNTCT)=0
73 . F S NOTECT=$O(^IBCN(365,IEN,2,EBCT,2,NOTECT)) Q:'NOTECT D
74 . . D FSTRNG^IBJU1($G(^IBCN(365,IEN,2,EBCT,2,NOTECT,0)),70,.IBNOTES)
75 . . ; Loop thru text (70 chars wide)
76 . . S II=0
77 . . F S II=$O(IBNOTES(II)) Q:'II I $G(IBNOTES(II))'="" D
78 . . . S NWNTCT=NWNTCT+1
79 . . . S RPTDATA(2,EBCT,NWNTCT)=$G(IBNOTES(II))
80 ;
81 ; Loop thru mult Contact segs
82 S CNCT=0
83 F S CNCT=$O(^IBCN(365,IEN,3,CNCT)) Q:'CNCT D
84 . S RPTDATA(3,CNCT)=$G(^IBCN(365,IEN,3,CNCT,0))
85 . ; Disp. blank if NOT SPECIFIED
86 . I $P(RPTDATA(3,CNCT),U)="NOT SPECIFIED" S $P(RPTDATA(3,CNCT),U)=""
87 . ; Comm Qual #1-3
88 . F II=1:1:3 D
89 . . S CNPTR=$$X12^IBCNERP2(365.021,$P(RPTDATA(3,CNCT),U,II*2))
90 . . I CNPTR'="" S $P(RPTDATA(3,CNCT),U,II*2)=CNPTR_": "_$P(RPTDATA(3,CNCT),U,II*2+1),$P(RPTDATA(3,CNCT),U,II*2+1)=""
91 ;
92 ; Error Txt
93 S ERRTEXT=$G(^IBCN(365,IEN,4))
94 ; Error text shd be flagged as Undetermined - no EC flg sent
95 I IIVSTAT="" S (IIVSTAT,RPTDATA(2,0))="U"
96 I ERRTEXT="" G FUTDT
97 D FSTRNG^IBJU1(ERRTEXT,60,.IBERR)
98 ; Loop thru text (60 chars)
99 S II=0
100 F S II=$O(IBERR(II)) Q:'II I $G(IBERR(II))'="" D
101 . S RPTDATA(4,II)=$G(IBERR(II))
102FUTDT I TQIEN D ; If there is a future date, display it
103 . S FUTDT=$P($G(^IBCN(365.1,TQIEN,0)),U,9) Q:FUTDT=""
104 . S II=$O(RPTDATA(5,""),-1)+1
105 . S RPTDATA(5,II)=" ",II=II+1
106 . S RPTDATA(5,II)="Inquiry will be automatically resubmitted on "_$$FMTE^XLFDT(FUTDT,"5Z")_"."
107 ;
108GETDATX ; GETDATA exit point
109 Q
110 ;
111 ; This tag is only called from IBCNERP3
112 ;
113DATA(DISPDATA) ; Build disp lines
114 N LCT,EBCT,CT,SEGCT,ITEM,CT2,NTCT,CNCT,ERCT,RPTDATA
115 ; Merge into local array
116 ;M RPTDATA=^TMP($J,RTN,SORT1,SORT2,CNT)
117 N %X,%Y
118 S %X="^TMP($J,RTN,SORT1,SORT2,CNT,"
119 S %Y="RPTDATA("
120 I $D(^TMP($J,RTN,SORT1,SORT2,CNT))#10=1 S RPTDATA=^TMP($J,RTN,SORT1,SORT2,CNT)
121 D %XY^%RCR K %X,%Y
122 ; Build
123 S LCT=1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.01),17,"R")_$P(RPTDATA(1),U,1)
124 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.05),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,5),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.02),22,"R")_$P(RPTDATA(1),U,2)
125 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.03),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,3),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.04),22,"R")_$P(RPTDATA(1),U,4)
126 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.06),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,6),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.07),22,"R")_$P(RPTDATA(1),U,7)
127 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.08),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,8),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.09),22,"R")_$P(RPTDATA(1),U,9)
128 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.18),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,18),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.13),22,"R")_$P(RPTDATA(1),U,13)
129 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.1),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,10),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.16),22,"R")_$P(RPTDATA(1),U,16)
130 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.11),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,11),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.17),22,"R")_$P(RPTDATA(1),U,17)
131 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.12),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,12),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.19),22,"R")_$P(RPTDATA(1),U,19)
132 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,.07),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(0),U,7),20)_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,.09),22,"R")_$P(RPTDATA(0),U,9)
133 S LCT=LCT+1,DISPDATA(LCT)=$$FO^IBCNEUT1($$LBL^IBCNERP2(365,1.2),17,"R")_$$FO^IBCNEUT1($P(RPTDATA(1),U,20),20)
134 S LCT=LCT+1
135 ; Elig/Ben - added sorted EB notes to DISPDATA and update LCT (line ct)
136 D EBDISP^IBCNERPA(.RPTDATA,.DISPDATA,.LCT)
137 ;
138 ; Contacts
139CONT S CNCT=+$O(RPTDATA(3,""),-1) I 'CNCT G ERR
140 S DISPDATA(LCT)="",LCT=LCT+1,DISPDATA(LCT)="Contact Information:",LCT=LCT+1
141 ; Build
142 F CT=1:1:CNCT D
143 . S DISPDATA(LCT)="",LCT=LCT+1,DISPDATA(LCT)=" "
144 . S SEGCT=$L(RPTDATA(3,CT),U)
145 . F CT2=1:1:SEGCT S ITEM=$P(RPTDATA(3,CT),U,CT2) I $L(ITEM)>0 D
146 . . I $L(ITEM)+$L(DISPDATA(LCT))>74 S LCT=LCT+1,DISPDATA(LCT)=" "_ITEM Q
147 . . I DISPDATA(LCT)'=" " S DISPDATA(LCT)=DISPDATA(LCT)_", "_ITEM Q
148 . . S DISPDATA(LCT)=" "_ITEM
149 . S LCT=LCT+1
150 ; Err Info
151ERR I $P(RPTDATA(1),U,14)="",$P(RPTDATA(1),U,15)="",'$O(RPTDATA(4,""),-1) G DATAX
152 S DISPDATA(LCT)="",LCT=LCT+1
153 S DISPDATA(LCT)="Error Information:",LCT=LCT+1
154 S DISPDATA(LCT)="",LCT=LCT+1
155 I $P(RPTDATA(1),U,14)'="" D
156 . ; Split text, if necessary
157 . N IBERR,IBTOT,IBCT
158 . D FSTRNG^IBJU1($P(RPTDATA(1),U,14),60,.IBERR)
159 . S IBTOT=$O(IBERR(""),-1)
160 . F IBCT=1:1:IBTOT S DISPDATA(LCT)=" "_$$FO^IBCNEUT1($S(IBCT=1:$$LBL^IBCNERP2(365,1.14),1:" "),17,"R")_$G(IBERR(IBCT)),LCT=LCT+1
161 I $P(RPTDATA(1),U,15)'="" D
162 . ; Split text, if necessary
163 . N IBERR,IBTOT,IBCT
164 . D FSTRNG^IBJU1($P(RPTDATA(1),U,15),60,.IBERR)
165 . S IBTOT=$O(IBERR(""),-1)
166 . F IBCT=1:1:IBTOT S DISPDATA(LCT)=" "_$$FO^IBCNEUT1($S(IBCT=1:$$LBL^IBCNERP2(365,1.15),1:" "),17,"R")_$G(IBERR(IBCT)),LCT=LCT+1
167 ; Disp Err Txt
168 F CT=1:1:+$O(RPTDATA(4,""),-1) D
169 . I CT=1 S DISPDATA(LCT)=" "_$$FO^IBCNEUT1($$LBL^IBCNERP2(365,4.01),17,"R")_$G(RPTDATA(4,CT)),LCT=LCT+1 Q
170 . S DISPDATA(LCT)=" "_$$FO^IBCNEUT1("",17,"R")_$G(RPTDATA(4,CT)),LCT=LCT+1
171DATAX ;
172 ; Disp Future Date and Misc. Comments
173 I $O(RPTDATA(5,0))'="" D
174 . F CT=1:1:+$O(RPTDATA(5,""),-1) D
175 .. S DISPDATA(LCT)=" "_$$FO^IBCNEUT1("",7,"R")_$G(RPTDATA(5,CT)),LCT=LCT+1
176 ;
177 Q
Note: See TracBrowser for help on using the repository browser.