source: FOIAVistA/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSJZPR.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1BPSJZPR ;BHAM ISC/CMW/LJF - Process Incoming HL7 ZPR Message ;01-DEC-2003
2 ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Description:
6 ; Process incoming HL7 ZPR Messages
7 ; Update Payer Sheet File (9002313.92)
8 ;
9 Q
10 ;
11 ; Entry point
12EN(BPSJEN,BPSJSEG,BPSJROOT,BPSFILE) ;
13 ;
14 N BPRCODE,BPSF,BPSFDIC,BPSEGID,BPORDER,BPMODE,BPNOTES,BPSETID
15 N FLN,FLNSC,FLNPN,FLNSPEC
16 N DIE,DIC,DLAYGO,DR,DA,DINUM
17 N C,X,Y,NCNT,BPND
18 ;
19 I $G(BPSJEN),$G(BPSJROOT)]"",$G(BPSFILE)]"",$D(BPSJSEG)
20 E Q ; invalid info
21 ;
22 S BPRCODE=$$ZPR(),DIE=$G(BPSJROOT),C=","
23 ;
24 I BPRCODE,BPSEGID,BPORDER
25 E Q
26 ;
27 S BPSF=DIE_BPSJEN_C_BPSEGID_",0)"
28 I '$D(@BPSF) D
29 . S FLNSPEC=$$GET1^DID(BPSFILE,BPSEGID,"","SPECIFIER")
30 . S @BPSF=U_FLNSPEC_U_U
31 ;
32 S (X,DINUM)=BPORDER
33 S DA(1)=BPSJEN,DIC=DIE_BPSJEN_C_BPSEGID_C
34 S DIC(0)="L",(DIC("P"),DLAYGO)=FLN
35 D ^DIC
36 ;
37 S DA=+Y
38 S DIE=DIC
39 S DR=".02////"_BPRCODE_";.03////"_BPMODE
40 D ^DIE
41 ;
42 S BPSFDIC=DIC ; save dictionary ID
43 ; NOTES
44 I $D(BPSJSEG(8)) D
45 . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)"
46 . I '$D(@BPSF) S @BPSF=U_FLNPN_U_U
47 . S BPND="BPSJSEG(7,99)",NCNT=0
48 . F S BPND=$Q(@BPND) Q:BPND="" I $G(@BPND)]"" D
49 .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)"
50 .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=2,(NCNT,DA)=NCNT+1
51 .. K DR S DR=".01////"_@BPND
52 .. D ^DIE
53 K BPSJSEG(8) ; kill 8 so $Q of 7 won't find it
54 ;
55 ; Special Code
56 I $D(BPSJSEG(7)) D
57 . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)"
58 . I '$D(@BPSF) S @BPSF=U_FLNSC_U_U
59 . S BPND="BPSJSEG(6,99)",NCNT=0
60 . F S BPND=$Q(@BPND) Q:BPND="" I $G(@BPND)]"" D
61 .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)"
62 .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=1,(NCNT,DA)=NCNT+1
63 .. K DR S DR=".01////"_@BPND
64 .. D ^DIE
65 Q
66 ;
67ZPR() ; Validate Fields and Initialize ZPR variables
68 N RCODE,WDATA
69 ;
70 ; Reject reasons: 1=Missing ,2=Invalid
71 ;
72 S BPSETID=$G(BPSJSEG(2))
73 ;
74 S BPSEGID=$G(BPSJSEG(3))
75 I BPSEGID="" S BPSEGID=0 D
76 . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-1,"_BPSETID
77 E S BPSEGID=$G(ZPRS(BPSEGID)) D
78 . I 'BPSEGID S BPSEGID=0 D Q
79 .. S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-2,"_BPSETID
80 . ;
81 . S FLN=$P(BPSEGID,U,2)
82 . S FLNSC=$P(BPSEGID,U,3)
83 . S FLNPN=$P(BPSEGID,U,4)
84 . S BPSEGID=+BPSEGID
85 ;
86 S RCODE=$$GETPTR($G(BPSJSEG(4)))
87 I 'RCODE S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-2,"_BPSETID
88 I $G(BPSJSEG(4))="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-1,"_BPSETID
89 ;
90 S BPORDER=$G(BPSJSEG(5))
91 I BPORDER="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,4)="V634,"_BPSETID
92 ;
93 S BPMODE=$G(BPSJSEG(6))
94 ;
95 I BPMODE'="X",BPMODE'="S" D
96 . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,5)="V635,"_BPSETID
97 ;
98 I '$L($G(BPSJSEG(7))),$D(BPSJSEG(7))'>1 K BPSJSEG(7)
99 E D ;NOTES(.BPSJSEG(7))
100 . K WDATA M WDATA(7)=BPSJSEG(7) D NOTES(.WDATA)
101 . K BPSJSEG(7) M BPSJSEG(7)=WDATA K WDATA
102 ;
103 ; flag error if processing mode="X" and no special code
104 I BPMODE="X",'$D(BPSJSEG(7)) S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,6)="V636,"_BPSETID
105 ;
106 I '$L($G(BPSJSEG(8))),$D(BPSJSEG(8))'>1 K BPSJSEG(8)
107 E D ;NOTES(.BPSJSEG(8))
108 . K WDATA M WDATA(8)=BPSJSEG(8) D NOTES(.WDATA)
109 . K BPSJSEG(8) M BPSJSEG(8)=WDATA K WDATA
110 ;
111 Q RCODE
112 ;
113NOTES(ARRAYIN,TRCH) ; fProgrammer Notes - Special Code handler
114 ;
115 N II,ODAT,NODENM
116 N ISDATA,ISDATA1,ISDATA2,ISDATA3
117 ;
118 I '$D(TRCH) D ; apply standard Vista/Vitria "Free Text" de-encoding
119 . S TRCH("\F\")="|",TRCH("\R\")="~",TRCH("\E\")="\"
120 . S TRCH("\T\")="&",TRCH("\S\")="^"
121 . S TRCH("\.b")=1,TRCH("\.br\")=1
122 ;
123 S NODENM="ARRAYIN"
124 ;
125 S (ODAT,ISDATA1)=""
126 F S NODENM=$Q(@NODENM) Q:NODENM="" S ISDATA=@NODENM D
127 . ; clean up partial string if any
128 . I $L(ISDATA1) D I '$L(ISDATA) Q
129 .. S ISDATA1=ISDATA1_$E(ISDATA,1,10)
130 .. S ISDATA3=$$DECODE(ISDATA1,.TRCH,.ODAT,.ISDATA2)
131 .. S $E(ISDATA,1,10)=ISDATA2
132 . ;
133 . S ISDATA2=$$DECODE(ISDATA,.TRCH,.ODAT,.ISDATA1)
134 ;
135 S ODAT=ODAT_ISDATA1 D NWNODE(.ODAT) K ARRAYIN M ARRAYIN=ODAT
136 Q
137 ;
138NWNODE(FREERAY) ; build free text array
139 N CNT
140 S CNT=1+$O(FREERAY(""),-1),FREERAY(CNT)=FREERAY,FREERAY=""
141 Q
142 ;
143DECODE(INSTR,TCH,WDAT,INSTR1) ;
144 ; INSTR - Input string
145 ; TCH - translation array
146 ; WDAT - Output in a Vista compliant "Free Text" array
147 ; INSTR1 - Remainder of text when last or
148 ; second to last INSTR char = "\"
149 ;Development Note:
150 ;\.br\ - removed and new node created
151 ;\E\.br\E\ = \.br\ - (no further translation)
152 ;non-printable character translation not supported
153 ;Output Array nodes will contain no more than 200 characters each
154 ;
155 N II,CH
156 S INSTR1="",WDAT=$G(WDAT)
157 F II=1:1:$L(INSTR) S CH=$E(INSTR,II) D:CH="\" S WDAT=WDAT_CH I $L(WDAT)>199 D NWNODE(.WDAT)
158 . ;
159 . ; Partial TCH string, if \.br\ (CR-LF) translation allowed
160 . I $L($E(INSTR,II,II+2))<3,$G(TCH("\.br\")) D Q
161 .. S INSTR1=$E(INSTR,II,II+2),II=$L(INSTR),CH=""
162 . ;
163 . I '$D(TCH($E(INSTR,II,II+2))) Q ; not one we're interested in
164 . I +$G(TCH($E(INSTR,II,II+2))) D Q ; \.br\ to <CR-LF> conversion
165 .. I (II+4)>$L(INSTR) S INSTR1=$E(INSTR,II,$L(INSTR)),II=$L(INSTR),CH="" Q
166 .. I +$G(TCH($E(INSTR,II,II+4))) S II=II+4,CH="" D NWNODE(.WDAT)
167 . ;
168 . S CH=TCH($E(INSTR,II,II+2)),II=II+2 ; std conversion
169 Q WDAT ; Return top node of WDAT - for strings less than 200 characters
170 ;
171GETPTR(BPDAT) ; Get pointer into BPS NCPDP FIELD DEFS
172 N BPSFNM,BPSFNO,BPSIX,BPSIXALT,BPSFX,BPNAMIX,BPNUMIX,BPSFNOCK
173 ;
174 S BPSFNM=$P($G(BPDAT),"-",2),BPSFNO=+$G(BPDAT)
175 I BPSFNM]"",BPSFNO S (BPSIX,BPSIXALT)=0,BPSFX=BPSFNO_U_BPSFNM
176 E Q 0
177 S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,""))
178 S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,""))
179 ;
180 ;-if NAME and NUMBER point to the same IEN (but not 0)
181 I BPNAMIX,BPNUMIX=BPNAMIX Q BPNAMIX
182 ;
183 ;-else might be in another node of the "D" x-ref
184 I BPNAMIX,BPNUMIX F D Q:BPSIX Q:'BPNAMIX
185 . S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,BPNAMIX))
186 . I BPNUMIX=BPNAMIX S BPSIX=BPNAMIX
187 ;
188 ;-If not found, try "B" x-ref value
189 I 'BPSIX,BPNUMIX D
190 . I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX Q
191 . I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX Q
192 . ;
193 . ;-try additional "B" x-ref's for this NUMBER
194 . F D Q:BPSIX Q:'BPNUMIX
195 .. S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,BPNUMIX))
196 .. I BPNUMIX D
197 ... I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX
198 ... I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX
199 ;
200 ;-Last resort - go through all iens'
201 I 'BPSIX S BPNUMIX=0 F D Q:BPSIX Q:'BPNUMIX
202 . S BPNUMIX=$O(^BPSF(9002313.91,BPNUMIX))
203 . I BPNUMIX,+$G(^BPSF(9002313.91,BPNUMIX,0))[BPSFNO D
204 .. S BPSFNOCK=+$G(^BPSF(9002313.91,BPNUMIX,0))
205 .. ; Note: Special coding included for BPSFNO of 498 (498.nn)
206 .. I BPSFNOCK'=BPSFNO,$P(BPSFNOCK,".")'=498 Q
207 .. I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX
208 .. I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX
209 ;
210 Q BPSIX
211 ;
212INITZPRS(ZPRS) ;BPSEGID^FLN^FLNSC^FLNPN
213 S ZPRS(0)="100^9002313.9205^9002313.92051^9002313.92052"
214 S ZPRS(1)="110^9002313.9206^9002313.92061^9002313.92062"
215 S ZPRS(2)="140^9002313.9209^9002313.92091^9002313.92092"
216 S ZPRS(3)="150^9002313.921^9002313.9211^9002313.9212"
217 S ZPRS(4)="120^9002313.9207^9002313.92071^9002313.92072"
218 S ZPRS(5)="160^9002313.9213^9002313.92131^9002313.92132"
219 S ZPRS(6)="170^9002313.9214^9002313.92141^9002313.92142"
220 S ZPRS(7)="130^9002313.9208^9002313.92081^9002313.92082"
221 S ZPRS(8)="180^9002313.9215^9002313.92151^9002313.92152"
222 S ZPRS(9)="200^9002313.9217^9002313.92171^9002313.92172"
223 S ZPRS(10)="210^9002313.9218^9002313.92181^9002313.92182"
224 S ZPRS(11)="190^9002313.9216^9002313.92161^9002313.92162"
225 S ZPRS(12)="220^9002313.9219^9002313.92191^9002313.92192"
226 S ZPRS(13)="230^9002313.922^9002313.9221^9002313.9222"
227 Q
Note: See TracBrowser for help on using the repository browser.