source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNERP2.m@ 868

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

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1IBCNERP2 ;DAOU/BHS - IBCNE IIV RESPONSE REPORT COMPILE ;03-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184,271**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Input vars from IBCNERP1:
6 ; IBCNERTN="IBCNERP1"
7 ; IBCNESPC("BEGDT")=Start Dt for rpt
8 ; IBCNESPC("ENDDT")=End Dt for rpt
9 ; IBCNESPC("PYR")=Pyr IEN for rpt. If "", then show all.
10 ; IBCNESPC("PAT")=Pt IEN for rpt. If "", then show all.
11 ; IBCNESPC("TYPE")=A (All Responses) for date range OR M (Most Recent
12 ; Responses) for date range (by unique Pyr/Pt pair)
13 ; IBCNESPC("SORT")=1 (Pyr nm) OR 2 (Pt nm)
14 ; IBCNESPC("TRCN")=Trace #^IEN, if non-null, all other params are null
15 ; IBCNESPC("RFLAG")=Report Flag used to indicate which report is being
16 ; run. Response Report (0), Inactive Report (1), or Ambiguous
17 ; Report (2).
18 ; IBCNESPC("DTEXP")=Expiration date used in the inactive policy report
19 ;
20 ; Output vars used by IBCNERP3:
21 ; Structure of ^TMP based on IIV Response File (#365)
22 ; IBCNERTN="IBCNERP1"
23 ; SORT1=PyrNm (SORT=1) or PtNm(SORT=2)
24 ; SORT2=PtNm (SORT=1) or PyrNm (SORT=2)
25 ; ^TMP($J,IBCNERTN,SORT1,SORT2,CNT,0/1) based on ^IBCN(365,DA,0/1)
26 ; CNT=Seq ct
27 ; ^TMP($J,IBCNERTN,SORT1,SORT2,2,EBCT) based on ^IBCN(365,DA,2,EBCT,0)
28 ; EBCT = Elig/Benefit multiple field IEN (ptr to 365.02)
29 ; ^TMP($J,IBCNERTN,SORT1,SORT2,2,EBCT,NTCT) based on
30 ; ^IBCN(365,DA,2,EB,0,NT,0) Notes for EB seg
31 ; NTCT = Notes Ct may not equal Notes IEN (365.22) if ln must wrap
32 ; ^TMP($J,IBCNERTN,SORT1,SORT2,3,CNCT) based on ^IBCN(365,DA,3,CNCT,0)
33 ; CNCT = Contact Person multiple field IEN (ptr to 365.03)
34 ; ^TMP($J,IBCNERTN,SORT1,SORT2,4,CT) based on ^IBCN(365,DA,4)
35 ; CT=1 if len of text <=70, else ln is split
36 ; ^TMP($J,IBCNERTN,SORT1,SORT2,5,CT) based on # lns of comments reqd
37 ; CT=1 to display future retransmission date
38 ;
39 ; Must call at EN
40 Q
41 ;
42 ;
43EN(IBCNERTN,IBCNESPC) ; Entry
44 ; Init
45 N IBDT,IBBDT,IBPY,IBPYR,IBPT
46 N IBPAT,IBPTR,SORT1,SORT2,RPTDATA,IBTOT
47 N PYRIEN,PATIEN,IBTRC,IBTYP,IBCT,IBSRT,IBEXP,FRST,TQN,DONTINC,IPRF
48 ;
49 I '$D(ZTQUEUED),$G(IOST)["C-" W !!,"Compiling report data ..."
50 ;
51 ; Temp ct
52 S (IBTOT,IBCT)=0
53 ;
54 ; Kill scratch globals
55 K ^TMP($J,IBCNERTN),^TMP($J,IBCNERTN_"X")
56 ;
57 S IBTRC=$G(IBCNESPC("TRCN"))
58 ; Skip for TRACE#
59 I IBTRC'="" G TRCN
60 ;
61 S IBBDT=IBCNESPC("BEGDT")
62 S IBPY=$G(IBCNESPC("PYR"))
63 S IBPT=$G(IBCNESPC("PAT"))
64 S IBTYP=$G(IBCNESPC("TYPE"))
65 S IBSRT=$G(IBCNESPC("SORT"))
66 S IBEXP=$G(IBCNESPC("DTEXP"))
67 S IPRF=$G(IBCNESPC("RFLAG"))
68 ;
69 ; Loop thru the IIV Response File (#365) by Date/Time Response Rec X-Ref
70 ; S IBDT=$O(^IBCN(365,"AD",IBCNESPC("ENDDT")))
71 ; Initialize IBDT to end date
72 S IBDT=IBCNESPC("ENDDT")_".999999"
73 F S IBDT=$O(^IBCN(365,"AD",IBDT),-1) Q:IBDT=""!($P(IBDT,".",1)<IBBDT) D Q:$G(ZTSTOP)
74 . S PYRIEN=$S(IBPY="":0,1:$O(^IBCN(365,"AD",IBDT,IBPY),-1))
75 . F S PYRIEN=$O(^IBCN(365,"AD",IBDT,PYRIEN)) Q:'PYRIEN!((IBPY'="")&(PYRIEN'=IBPY)) D Q:$G(ZTSTOP)
76 .. I $D(ZTQUEUED),$$S^%ZTLOAD() S ZTSTOP=1 Q
77 .. ; Pyr nm from Pyr File (#365.12)
78 .. S IBPYR=$P($G(^IBE(365.12,PYRIEN,0)),U)
79 .. I IBPYR="" Q
80 .. S PATIEN=$S(IBPT="":0,1:$O(^IBCN(365,"AD",IBDT,PYRIEN,IBPT),-1))
81 .. F S PATIEN=$O(^IBCN(365,"AD",IBDT,PYRIEN,PATIEN)) Q:'PATIEN!((IBPT'="")&(PATIEN'=IBPT)) D Q:$G(ZTSTOP)
82 ... ; Pt nm from Pt File (#2)
83 ... S IBPAT=$P($G(^DPT(PATIEN,0)),U)
84 ... I IBPAT="" Q
85 ... S IBPTR=0
86 ... F S IBPTR=$O(^IBCN(365,"AD",IBDT,PYRIEN,PATIEN,IBPTR)) Q:'IBPTR D Q:$G(ZTSTOP)
87 .... S IBTOT=IBTOT+1
88 .... ; Since non-positive identifications are no longer placed in the
89 .... ; insurance buffer, two new reports were added to allow users to
90 .... ; view the responses. One report (IPFR=1) shows only responses
91 .... ; of inactive policies. The other (IPFR=2) shows ambiguous responses.
92 .... ; Any response that is not active nor inactive is considered
93 .... ; ambiguous for the purposes of this report.
94 .... I IPRF D Q:DONTINC
95 ..... N EBIC,NODE1,PCD
96 ..... S DONTINC=1
97 ..... S TQN=$P($G(^IBCN(365,IBPTR,0)),U,5) Q:TQN="" ; TQ ien (#365.1)
98 ..... S NODE1=$G(^IBCN(365,IBPTR,1))
99 ..... I $P($G(^IBCN(365.1,TQN,0)),U,11)="V" Q ; If verification quit
100 ..... I IPRF=1,($P(NODE1,U,12)="")!($P(NODE1,U,12)<$G(IBEXP)) Q
101 ..... S FRST=$O(^IBCN(365,IBPTR,2,0))
102 ..... I FRST="" Q
103 ..... S PCD=$P($G(^IBCN(365,IBPTR,2,FRST,0)),U,6)
104 ..... I PCD]"",PCD'="IIV Eligibility Determination" Q
105 ..... S EBIC=$$GET1^DIQ(365.02,FRST_","_IBPTR_",","ELIGIBILITY/BENEFIT INFO:CODE")
106 ..... I PCD]"",IPRF=1,EBIC'=6 Q
107 ..... I PCD]"",IPRF=2,EBIC=6!(EBIC=1) Q
108 ..... I $P(NODE1,U,14)]"" Q ; Error Condition
109 ..... I $P(NODE1,U,15)]"" Q ; Error Action
110 ..... I $P($G(^IBCN(365,IBPTR,4)),U)]"" Q ; Error Text
111 ..... S DONTINC=0
112 ....;
113 .... I $D(ZTQUEUED),IBTOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
114 .... ; Sort fields
115 .... S SORT1=$S(IBSRT=1:IBPYR,1:IBPAT)
116 .... S SORT2=$S(IBSRT=1:IBPAT,1:IBPYR)
117 .... ; Only check for Most Recent - Pyr/Pt pair
118 .... I IBTYP="M",$D(^TMP($J,IBCNERTN_"X",PYRIEN,PATIEN)) Q
119 .... ; Set temp ind.
120 .... I IBTYP="M" S ^TMP($J,IBCNERTN_"X",PYRIEN,PATIEN)=""
121 .... ; Update ct
122 .... S IBCT=IBCT+1
123 .... ; Sort data - build RPTDATA array
124 .... K RPTDATA
125 .... D GETDATA^IBCNERPE(IBPTR,.RPTDATA)
126 .... ; Merge data from RPTDATA to ^TMP
127 .... ;M ^TMP($J,IBCNERTN,SORT1,SORT2,IBCT)=RPTDATA
128 .... N %X,%Y
129 .... S %X="RPTDATA("
130 .... S %Y="^TMP($J,IBCNERTN,SORT1,SORT2,IBCT,"
131 .... I $D(RPTDATA)#10=1 S ^TMP($J,IBCNERTN,SORT1,SORT2,IBCT)=RPTDATA
132 .... D %XY^%RCR K %X,%Y
133 ;
134 ; Purge index of duplicate Pyr/Pt combos
135 K ^TMP($J,IBCNERTN_"X")
136 ;
137 G EXIT
138 ;
139TRCN ; Trace # proc.
140 S IBPTR=$P(IBTRC,U,2)
141 I IBPTR="" G EXIT
142 ; Sort the data - build RPTDATA array
143 KILL RPTDATA
144 D GETDATA^IBCNERPE(IBPTR,.RPTDATA)
145 ; Default sort - one record
146 ; Pyr nm from Pyr File (#365.12)
147 S PYRIEN=$P(RPTDATA(0),U,3)
148 I PYRIEN="" G EXIT
149 S SORT1=$P($G(^IBE(365.12,PYRIEN,0)),U,1)
150 I SORT1="" G EXIT
151 ; Pt nm from Pt File (#2)
152 S PATIEN=$P(RPTDATA(0),U,2)
153 I PATIEN="" G EXIT
154 S SORT2=$P($G(^DPT(PATIEN,0)),U,1)
155 I SORT2="" G EXIT
156 ; Merge data- RPTDATA to ^TMP
157 ;M ^TMP($J,IBCNERTN,SORT1,SORT2,1)=RPTDATA
158 N %X,%Y
159 S %X="RPTDATA("
160 S %Y="^TMP($J,IBCNERTN,SORT1,SORT2,1,"
161 I $D(RPTDATA)#10=1 S ^TMP($J,IBCNERTN,SORT1,SORT2,1)=RPTDATA
162 D %XY^%RCR K %X,%Y
163 ;
164EXIT ;
165 Q
166 ;
167X12(FILE,CODE,FLD) ; Output based on File # and X12 code
168 I $G(FILE)=""!($G(CODE)="") Q ""
169 ; Quit w/o label if not defined in File Def.
170 Q $$LBL(365.02,$G(FLD))_$P($G(^IBE(FILE,CODE,0)),U,2)
171 ;
172LBL(FILE,FLD) ; Determine label from File Def.
173 N IBLBL
174 ;
175 I $G(FILE)=""!($G(FLD)="") Q ""
176 S IBLBL=$$GET1^DID(FILE,FLD,"","TITLE")
177 Q $S(IBLBL'="":IBLBL_": ",1:"")
178 ;
Note: See TracBrowser for help on using the repository browser.