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

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

initial load of WorldVistAEHR
File size: 7.1 KB
RevLine 
[613]1IBCNEHLQ ;DAOU/ALA - HL7 RQI Message ;17-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184,271,300,361**;21-MAR-94;Build 9
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This routine builds an IIV Verification (RQI^I01) or
7 ; Identification (RQI^I03) request
8 ;
9 ;**Modified by Date Reason
10 ; DAOU/BHS 10/04/2002 Implementing Transmit SSN logic
11 ; DAOU/DB 03/19/2004 Stripped dashes from SSN (PID, GT1)
12 ;
13EN ; Entry Point
14 ; Variables
15 ; HLFS = Field Separator
16 ; DFN = Patient IEN
17 ; PAYR = Payer IEN
18 ; BUFF = Buffer IEN
19 ; FRDT = Freshness Date
20 ;
21PID ; Patient Identification Segment
22 NEW VAERR,VAFSTR,VADM,VA,ICN,SNDSSN,NM,I
23 S SNDSSN=$$SNDSSN^IBCNEUT5(PAYR,"IIV")
24 D DEM^VADPT
25 S VAFSTR=",1,7,8,11,"
26 S PID=$$EN^VAFHLPID(DFN,VAFSTR,1)
27 ; Encode special characters into Name and address pieces
28 ; **NOTE: If $$EN^VAFHLPID should, in the future, return more than 11 pieces than the lines below may
29 ; need to be modified as they currently expect 11 pieces to be returned.
30 S DFN=$G(DFN) I DFN]"" D
31 . S NM("FILE")=2,NM("IENS")=DFN,NM("FIELD")=.01
32 . S NM=$$HLNAME^XLFNAME(.NM,"",$E(HLECH)),NM=$S(NM]"":NM,1:HLQ)
33 . S I=$L(NM,"|"),NM=$$ENCHL7(NM),$P(PID,"|",6,5+I)=NM
34 S $P(PID,"|",12,99)=$$ENCHL7($P(PID,"|",12,99))
35 ;
36 S ICN=$P($G(^DPT(DFN,"MPI")),U,1)
37 S $P(PID,HLFS,4)=ICN_HLECH_HLECH_HLECH_"USVHA"_HLECH_"NI"_HLECH
38 I DFN S $P(PID,HLFS,4)=$P(PID,HLFS,4)_"~"_DFN_HLECH_HLECH_HLECH_"USVHA"_HLECH_"PI"_HLECH_$P($$SITE^VASITE,U,3)_HLECH
39 I SNDSSN S $P(PID,HLFS,4)=$P(PID,HLFS,4)_"~"_$TR(VA("PID"),"-")_HLECH_HLECH_HLECH_"USSSA"_HLECH_"SS"_HLECH_"USSSA"
40 S FRDT=$$HLDATE^HLFNC($G(FRDT))
41 S $P(PID,HLFS,34)=FRDT
42 Q
43 ;
44GT1 ; Guarantor Segment
45 NEW WHO,NM,IDOB,ISSN,ISEX,SEX,RLIEN,PER,PLIEN,RDATA,IBSDATA,IBADDR
46 NEW SNDSSN
47 ;
48 S SNDSSN=$$SNDSSN^IBCNEUT5(PAYR,"IIV")
49 ;
50 S GT1=""
51 I $G(QUERY)="I" Q
52 ;
53 ; If the data was extracted from Buffer get specifics from Buffer file
54 I EXT=1 D
55 . S WHO=$P($G(^IBA(355.33,BUFF,60)),U,5)
56 . I WHO="v"!(WHO="") Q
57 . S NM=$P($G(^IBA(355.33,BUFF,60)),U,7),NM=$$NAME^IBCNEHLU(NM)
58 . S NM=$$HLNAME^HLFNC(NM,HLECH)
59 . S NM=$$ENCHL7(NM)
60 . S $P(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
61 . S IDOB=$P($G(^IBA(355.33,BUFF,60)),U,8),IDOB=$$HLDATE^HLFNC(IDOB)
62 . S $P(GT1,HLFS,8)=IDOB
63 . S $P(GT1,HLFS,2)=$$ENCHL7($G(SUBID))_HLECH_HLECH_HLECH_HLECH_"HC"
64 . I SNDSSN S $P(GT1,HLFS,12)=$TR($P($G(^IBA(355.33,BUFF,60)),U,9),"-")
65 ;
66 ; If the data was extracted from non-Buffer, check Patient file
67 I EXT'=1 D
68 . I IRIEN="" Q
69 . S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6)
70 . I WHO="v"!(WHO="") Q
71 . S NM=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17)
72 . S NM=$$HLNAME^HLFNC(NM,HLECH)
73 . S NM=$$ENCHL7(NM)
74 . S $P(GT1,HLFS,3)=NM_HLECH_HLECH_HLECH
75 . S IDOB=$P($G(^DPT(DFN,.312,IRIEN,3)),U,1),IDOB=$$HLDATE^HLFNC(IDOB)
76 . S $P(GT1,HLFS,8)=IDOB
77 . S $P(GT1,HLFS,2)=$$ENCHL7($G(SUBID))_HLECH_HLECH_HLECH_HLECH_"HC"
78 . ;
79 . S IBSDATA=$G(^DPT(DFN,.312,IRIEN,3))
80 . ;
81 . S ISSN=$P(IBSDATA,U,5)
82 . I SNDSSN S $P(GT1,HLFS,12)=$TR(ISSN,"-")
83 . ;
84 . S IBADDR=$$HLADDR^HLFNC($P(IBSDATA,U,6,7),$P(IBSDATA,U,8,12))
85 . S $P(GT1,HLFS,5)=$$ENCHL7(IBADDR)
86 . ;
87 . D CHK
88 . I $P(GT1,HLFS,8)=""&(IDOB'="") S $P(GT1,HLFS,8)=$$HLDATE^HLFNC(IDOB)
89 . I $P(GT1,HLFS,9)=""&(ISEX'="") S $P(GT1,HLFS,9)=ISEX
90 . I SNDSSN,$P(GT1,HLFS,12)=""&(ISSN'="") S $P(GT1,HLFS,12)=$TR(ISSN,"-")
91 . I $P(GT1,HLFS,9)="",WHO="s" D
92 .. S SEX=$P($G(^DPT(DFN,.312,IRIEN,3)),U,12) ; get policy holder sex
93 .. I SEX="" S SEX=$P(^DPT(DFN,0),U,2),SEX=$S(SEX="M":"F",1:"M") ; if null, use alternative method
94 .. S $P(GT1,HLFS,9)=SEX
95 ;
96 I GT1="" Q
97 S $P(GT1,HLFS,1)=1
98 S GT1="GT1"_HLFS_GT1
99 Q
100 ;
101IN1 ; Insurance Segment
102 NEW EFFDT,EXPDT,WHO,ADMN,ADMDT,IENS
103 S IN1="",SRVDT=$$HLDATE^HLFNC(SRVDT)
104 ;
105 ; If the data was extracted from Buffer get specifics from Buffer file
106 I EXT=1 D
107 . S $P(IN1,HLFS,2)=$$ENCHL7($G(SUBID))
108 . I PAYR'=$$FIND1^DIC(365.12,"","X","~NO PAYER") D
109 .. S $P(IN1,HLFS,3)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,2))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH
110 .. S $P(IN1,HLFS,4)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,1))
111 . S $P(IN1,HLFS,8)=$$ENCHL7($P($G(^IBA(355.33,BUFF,40)),U,3))
112 . S $P(IN1,HLFS,9)=$$ENCHL7($P($G(^IBA(355.33,BUFF,40)),U,2))
113 . S EFFDT=$P($G(^IBA(355.33,BUFF,60)),U,2),EFFDT=$$HLDATE^HLFNC(EFFDT)
114 . S EXPDT=$P($G(^IBA(355.33,BUFF,60)),U,3),EXPDT=$$HLDATE^HLFNC(EXPDT)
115 . S $P(IN1,HLFS,12)=EFFDT
116 . S $P(IN1,HLFS,13)=EXPDT
117 . S WHO=$P($G(^IBA(355.33,BUFF,60)),U,5)
118 . S $P(IN1,HLFS,17)=$S(WHO="v":18,WHO="":18,WHO="s":"01",1:34)
119 ;
120 ; If the data was extracted from non-Buffer, check Patient file
121 I EXT'=1 D
122 . I IRIEN="" Q
123 . I $G(SUBID)'=$P($G(^DPT(DFN,.312,IRIEN,0)),U,2) Q
124 . S EFFDT=$P($G(^DPT(DFN,.312,IRIEN,0)),U,8),EFFDT=$$HLDATE^HLFNC(EFFDT)
125 . S EXPDT=$P($G(^DPT(DFN,.312,IRIEN,0)),U,4),EXPDT=$$HLDATE^HLFNC(EXPDT)
126 . S $P(IN1,HLFS,12)=EFFDT
127 . S $P(IN1,HLFS,13)=EXPDT
128 . S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6) I WHO="" Q
129 . S $P(IN1,HLFS,17)=$S(WHO="v":18,WHO="":18,WHO="s":"01",1:34)
130 . S IENS=IRIEN_","_DFN_","
131 . S $P(IN1,HLFS,8)=$$ENCHL7($$GET1^DIQ(2.312,IENS,21,"E"))
132 . S $P(IN1,HLFS,9)=$$ENCHL7($$GET1^DIQ(2.312,IENS,20,"E"))
133 ;
134 ; If it's an inquire with 'No Payer', don't send payer info
135 I PAYR'=$$FIND1^DIC(365.12,"","X","~NO PAYER") D
136 . S $P(IN1,HLFS,3)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,2))_HLECH_HLECH_HLECH_"USVHA"_HLECH_"VP"_HLECH
137 . S $P(IN1,HLFS,4)=$$ENCHL7($P(^IBE(365.12,PAYR,0),U,1))
138 . S $P(IN1,HLFS,2)=$$ENCHL7($G(SUBID))
139 ;
140 I IN1="" Q
141 ;
142 I $G(QUERY)="I",$P(IN1,HLFS,17)'=18 S $P(IN1,HLFS,17)=18
143 I $P(IN1,HLFS,17)="" S $P(IN1,HLFS,17)=18
144 ;
145 ; Set the admission date if patient currently admitted
146 S ADMN=$P($G(^DPT(DFN,.105)),U,1) I ADMN'="" D
147 . S ADMDT=$P(^DGPM(ADMN,0),U,1),ADMDT=$$HLDATE^HLFNC(ADMDT)
148 . S $P(IN1,HLFS,24)=ADMDT
149 ;
150 ; Set the service date
151 S $P(IN1,HLFS,26)=SRVDT
152 S $P(IN1,HLFS,1)=1
153 S IN1="IN1"_HLFS_IN1
154 Q
155 ;
156CHK ; Check for spouse or other information in the Patient Relation File
157 ; DGREL = Relationship (1=Self, 2=Spouse, 3-34,99=Other)
158 NEW IEN,QFL
159 S IEN="",RLIEN="",ISEX="",QFL=0
160 F S IEN=$O(^DGPR(408.12,"B",DFN,IEN)) Q:IEN="" D Q:QFL
161 . S DGREL=$P($G(^DGPR(408.12,IEN,0)),U,2)
162 . ;
163 . ; If person is veteran, quit
164 . I DGREL=1 Q
165 . ;
166 . ; If person is spouse, pick that record and quit
167 . I WHO="s",DGREL=2 S RLIEN=IEN,QFL=1 Q
168 . ;
169 . ; Otherwise it should be an 'other' dependent
170 . S RLIEN=IEN
171 ;
172 I RLIEN="" Q
173 ;
174 ; Check for Sex, SSN, DOB in INCOME PERSON File
175 S PER=$P(^DGPR(408.12,RLIEN,0),U,3)
176 I PER'["DGPR(408.13" Q
177 S PLIEN=$P(PER,";",1)
178 I PLIEN="" Q
179 S RDATA=$G(^DGPR(408.13,PLIEN,0))
180 S ISEX=$P(RDATA,U,2),IDOB=$P(RDATA,U,3),ISSN=$P(RDATA,U,9)
181 I $P(RDATA,U,4)'="" D
182 . NEW DFN
183 . S DFN=$P(RDATA,U,4),ISEX=$P(^DPT(DFN,0),U,2),IDOB=$P(^DPT(DFN,0),U,3)
184 . S ISSN=$P(^DPT(DFN,0),U,9)
185 Q
186 ;
187ENCHL7(STR) ; Encode HL7 escape seqs in data fields
188 ;
189 ; Input:
190 ; STR = Field data possible containing HL7 encoding chars
191 ;
192 ; Output Values
193 ; Fn returns string w/converted escape seqs
194 ;
195 N CHR,NEW,RPLC,CNT,LOOP
196 ;
197 ; Replace "\" "&" "~" "|" with \F\ \R\ \E\ \T\ respectively
198 F CHR="\","&","~","|" S CNT=$L(STR,CHR) I CNT>1 D
199 . S NEW=$P(STR,CHR)
200 . S RPLC="\"_$TR(CHR,"|~\&","FRET")_"\"
201 . F LOOP=2:1:CNT S NEW=NEW_RPLC_$P(STR,CHR,LOOP)
202 . S STR=NEW
203 ;
204 Q STR
Note: See TracBrowser for help on using the repository browser.