source: WorldVistAEHR/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHQD1.m@ 1724

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1DVBHQD1 ;ISC-ALBANY/PKE/PHH- HINQ receiver ; 5/15/06 10:58am
2 ;;4.0;HINQ;**3,12,16,22,23,32,34,40,46,49,57,56**; 03/25/92
3 ;
4 S:'$D(DTIME) DTIME=300 S DVBTIME=DTIME
5EN S:$G(IO(0))="" IO(0)=$I S (C,DVBTSK,DVBABORT)=0,DVBXM=1,DTIME=30 U IO(0)
6 ;
7SEL S (DVBRTC,DVBTRY)=1,DVBNRT="Y"
8 R !!," Select Input: (P)atient File, or (D)irect P//",X:DTIME I '$T!(X["^") G HINQ
9 I "Pp"[$E(X) S DVBPRGM="TM^DVBHIQD" G ASK
10 I "Dd"[$E(X_1) S DVBPRGM="EN^DVBHQDE" G ASK
11 I X["?" D HP^DVBHQAT G SEL
12 G SEL
13ASK S:$G(IO(0))="" IO(0)=$I W ! S Y=0,DVBIO=IO D @DVBPRGM
14ASK1 I Y'<0,$D(DVBP),$L(DVBP)=4 S IO=DVBIO D STUFF^DVBHQAT:$D(DFN),MES
15 I $D(DVBMISS) K DVBMISS D:DVBTRY>3 RETRY^DVBHQD2 G:DVBNRT="N" LOAD2^DVBHQD2 I DVBTRY<4&(DVBRTC<4) S DVBTRY=DVBTRY+1 U IO(0) W ?35,"Retrying Request." G ASK1
16 S IO=DVBIO U IO(0) K DVBP S DVBABORT=0
17 I '$D(Y) G ASK
18 I Y>0 G ASK
19 ;
20HINQ U IO(0) W !!,"Do you wish to continue" S %=2 D YN^DICN G:'% HINQ I %=1 W ! G EN
21EX S DTIME=$S($D(DVBTIME):DVBTIME,1:300)
22 Q
23MES ;
24 S:$G(IO(0))="" IO(0)=$I S E=$L(DVBZ) I '$D(DVBDXX),($E(DVBZ,E-7,E-4)'=DVBNUM) S DVBZ=$E(DVBZ,1,E-4)_DVBNUM_$E(DVBZ,E-3,999)
25 K E H 1 S DVBEND="NNNN" S:'$D(DVBXM) DVBXM=0 S:'$D(C) C=0
26 ;
27TOTIMS S TRY=0,CN=$F(DVBZ,"/CN",24),DVBZ0=DVBZ
28 I $S('$D(DFN):1,DFN:0,1:1) S CN=0 D SEND^DVBHQD2,KTO^DVBHQD2 Q
29 I 'CN D CNLKUP^DVBHQAT
30 DO D SEND^DVBHQD2 I TRY DO I TRY H 1 D SEND^DVBHQD2
31 .I CN,'TRY S DVBZ0=$E(DVBZ,1,23)_$E(DVBZ,24,CN-3)_$E(DVBZ,CN+9,999) Q
32 .I CN,TRY S DVBZ1=$E(DVBZ,1,23)_$E(DVBZ,CN-2,999) Q
33 .I 'CN S DVBZ0=DVBZ,TRY=0 Q
34 I $D(DVBMISS)&($D(DVBPRGM)) I (DVBPRGM["TM") K DVBMISS D:DVBTRY>3 RETRY^DVBHQD2 G:DVBNRT="N" LOAD^DVBHQD2 I DVBTRY<4&(DVBRTC<4) S DVBTRY=DVBTRY+1 U IO(0) W ?35,"Retrying Request." G MES
35 G KTO^DVBHQD2
36 ;
37 ;z1 is first x(),z9 is last x()
38OK ;I 'DVBTSK DO
39 ;. U IO(0) W !!?3 S Z1=0 F S Z1=$O(X(Z1)) Q:'Z1 S LX=$G(LX)+$L(X(Z1)) W Z1," ",$L(X(Z1))," "
40 ;. W !?9,LX,! K LX H 3 U IO
41 S:$G(IO(0))="" IO(0)=$I S Z1=$O(X(0)) F Q:$E(X(Z1))'=$C(10) S X(Z1)=$E(X(Z1),2,999)
42 I $G(X(Z1))["HINQ" S X(Z1)="HINQ"_$P(X(Z1),"HINQ",2)
43 E K X(Z1) DO
44 . S Z1=$O(X(0)) I Z1="" S Z1=0,X(0)=""
45 . I $G(X(Z1))["HINQ" S X(Z1)="HINQ"_$P(X(Z1),"HINQ",2)
46 I $L(X(Z1))>25 S DVBLEN=+$E(X(Z1),22,25)
47 I $L(X(Z1))'>25 D
48 . I $D(X(Z1+1)) DO
49 . . S DVBLEN=+$E($E(X(Z1),1,99)_$E(X(Z1+1),1,30),22,25)
50 . I '$D(X(Z1+1)) D
51 . . S DVBLEN=$L(X(Z1)) ;DVB*4*49 - error response may be < 25 chars
52 I '$D(DVBLEN) S DVBABORT=DVBABORT+1 U IO(0) W:'DVBTSK !,"Missing string" U IO Q
53 ;
54 I $D(F3) S DVBLEN=DVBLEN-F3 K F3
55 I "456789ABCDUVWNMXYZ"'[$E(X(Z1),5) S DVBLEN=DVBLEN-2
56 ;
57 S (Z,Z9,F2)=0 F S Z=$O(X(Z)) Q:'Z S Z9=Z,F2=F2+$L(X(Z))
58 ;
59 I DVBLEN'=F2,X(Z9)[$C(10) S DVBABORT=DVBABORT+1 U IO(0) W:'DVBTSK !,"Missing character" S DVBMISS="" Q
60 I $E(X(Z1),5)'=2 S F2=F2+1
61 ;
62 I DVBLEN'=F2-1,X(Z9)'[$C(10),$S('$D(X(Z9-1)):1,1:$S(X(Z9-1)'[$C(10):1,1:0)) S DVBABORT=DVBABORT+1 U IO(0) W:'DVBTSK !,"Missing character" S DVBMISS="" Q
63 ;trim,e will pack back to x(1)
64 I Z9 S:$D(X) DVBSOX=X D TRIM,E^DVBHQAT S:$D(DVBSOX) X=DVBSOX K DVBSOX I $E(X(1),1,4)["HINQ","AXY69"'[$E($E(X(1),5)_1) D ALLM Q
65 ;
66 S DVBABORT=DVBABORT+1 Q:$E(X(1),1,4)'="HINQ"
67 I $E(X(1),5)="A" U IO(0) W:'DVBTSK !,"VBA File not Available" U IO H 2 D ALL QUIT
68 ;
69 I DVBTSK,"69XY"[$E($E(X(1),5)_1) S DVBBADP="" D ALL QUIT
70 I 'Z9 Q
71 ;
72ALL I 'DVBXM,$D(DFN),+DFN K:C ^TMP("DVBHINQ",$J,DFN) S Z=0 F S Z=$O(X(Z)) Q:'Z S ^TMP("DVBHINQ",$J,DFN,Z)=X(Z)
73 E I DVBXM D K DVBTX Q
74 . N DVBQT
75 . D RS,A^DVBHIQR
76 . I $G(DFN)>1,('DVBTSK),($E(X(1),5)=2),('$D(DVBERCS)) D CHKID I DVBQT D Q
77 . . N DVBTMP1,DVBTMP2
78 . . S DVBTMP1=$G(DVBNOALR)
79 . . S DVBTMP2=$G(DVBJ2)
80 . . S DVBNOALR=";4///c;5////"_DUZ_";6///N",DVBJ2=1
81 . . D FILE^DVBHQUP
82 . . S DVBNOALR=DVBTMP1
83 . . S DVBJ2=DVBTMP2
84 . D RECMAL^DVBHQD2
85 . D IALERT^DVBHT2,EN^DVBHIQM H 1 D WRT
86 I DVBABORT=3!($D(DVBBADP)) S DFN=0
87 Q
88 ; do all if no error or retrying
89ALLM I "BC"'[$E($E(X(1),5)_1) D ALL Q
90 I CN,'TRY S TRY=1 D:DVBXM DCN Q
91 I 'CN D ALL Q
92 S X(1)=X(1)_"[TRY]1" D ALL Q
93 ;
94DCN S:$G(IO(0))="" IO(0)=$I U IO(0) W !,"..Name, SSN didn't work ....retrying using Claim Number",! U IO Q
95 ;
96RS Q:'$D(DFN) Q:'DFN Q:'$D(^DVB(395.5,DFN,0)) S DVBDFN=DFN,DVBCS=0
97 F DVBSZ=0:0 S DVBSZ=$O(X(DVBSZ)) D SC^DVBHQST Q:'DVBSZ D ST^DVBHQDB
98 K DVBSZ,DVBDFN Q
99 ;
100TRIM Q:F1=999
101 I '$D(F1) S F1=$F(X(Z9),DVBEND)
102 I $E(X(Z9),F1-F4)=$C(10) S F1=F1-1
103 S X(Z9)=$E(X(Z9),1,F1-F4)
104 K F1 Q
105 ;
106WRT S:$G(IO(0))="" IO(0)=$I S DVBJIO=IO(0)
107WRT1 S:$G(DVBJIO)="" DVBJIO=$I S:'$D(DVBIOSL) DVBIOSL=IOSL S:'$D(DVBIOST) DVBIOST=IOST S:'$D(DVBIOF) DVBIOF=IOF
108 S X="" U DVBJIO W !!! D CODE^DVBHQUS W !! S Y0=$Y F Z=0:0 S Z=$O(^TMP($J,Z)) Q:'Z I $D(^(Z,0)) W ^(0),! D:$Y-Y0>(DVBIOSL-4) SROLL^DVBHQD2 Q:X="^" D:$Y<Y0 ABS^DVBHQD2
109 Q:X="^" K DVBJIO D SROLL^DVBHQD2 Q
110 ;
111CH S F1=0
112 I X(W)=$C(10)_"NNNN" K X(W) S F1=999 Q
113 I $L(X(W))>4!($L(X(W))<1) Q
114 F A=$L(X(W)):-1:1 Q:$E(X(W),A)'="N"
115 I A=1,$E(X(W),A)="N" S F1=$L(X(W-1))+1,F3=$L(X(W)),F4=5-$L(X(W)) K X(W)
116 Q
117CHKID ;checks 4 critical identifier fields
118 ;fields are name, DOB, SSN and sex.
119 ;DVBQT 0 to continue, 1 to stop processing
120 N DA,DIC,DIQ,DIR,DR,X,Y
121 N DVBBIRTH,DVBCNT,DVBNAM,DVBNM,DVBSEX,DVBSOCL,DVBSSN
122 N DVBDIQ
123 S DVBCNT=0
124 S DVBQT=0
125 S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="DVBDIQ("
126 S DR=".01;.02;.03;.09"
127 D EN^DIQ1
128 S DVBNAM=$S($D(DVBADR(1)):DVBADR(1),$D(DVBNAME):$E(DVBNAME,1,30),1:"")
129 S DVBSEX=""
130 I $D(DVBVET),$P(DVBVET,U)="A" S DVBSEX=$S($P(DVBVET,U,3)="M":"MALE",$P(DVBVET,U,3)="F":"FEMALE",1:"")
131 I '$D(DVBVET),($D(DVBBIR)) S DVBSEX=$S($P(DVBBIR,U,25)="M":"MALE",$P(DVBBIR,U,25)="F":"FEMALE",1:"")
132 S DVBSOCL=""
133 I $D(DVBREF),($P(DVBREF,U)?9N) S DVBSOCL=$P(DVBREF,U)
134 I $P($G(DVBREF),U)'?9N I $D(DVBSSN),(DVBSSN?9N) S DVBSOCL=DVBSSN
135 S DVBBIRTH=""
136 ;change date of birth to match the Patient file ext value (DVBBIRTH)
137 I $D(DVBDOB),(DVBDOB?8N) S DVBBIRTH=$E(DVBDOB,1,2)_"/"_$E(DVBDOB,3,4)_"/"_$E(DVBDOB,5,8)
138 ;change ext Patient file value for name to HINQ name format
139 I '$$NAME(DVBDIQ(2,DFN,.01,"E")) S DVBCNT=DVBCNT+1
140 I $G(DVBSEX)'=$G(DVBDIQ(2,DFN,.02,"E")) S DVBCNT=DVBCNT+1
141 I $G(DVBBIRTH)'=$G(DVBDIQ(2,DFN,.03,"E")) S DVBCNT=DVBCNT+1
142 I $G(DVBSOCL)'=$G(DVBDIQ(2,DFN,.09,"E")) S DVBCNT=DVBCNT+1
143 I DVBCNT>0 D WARN
144 Q
145WARN ;warns user if there are any discrepancies between HINQ and VistA for
146 ;4 critical identifier fields - name, DOB, SSN and sex.
147 N DIRUT,DUOUT
148 U IO(0)
149 H 1
150 D TEXT
151 D DISPL
152 S DVBQT=1
153 N DIR
154 S DIR(0)="N^1:3:0",DIR("A")="Do you want to process the HINQ on "_DVBDIQ(2,DFN,.01,"E")_"? ",DIR("B")="NO"
155 W !!
156 S DIR("A",1)="Check displayed data before proceeding."
157 S DIR("A",2)=""
158 S DIR("A",3)="Choose one of the following:"
159 S DIR("A",4)=" 1. Update this record."
160 S DIR("A",5)=" 2. Take no action at this time."
161 S DIR("A",6)=" 3. Delete this record from the SUSPENSE file."
162 S DIR("A",7)=""
163 S DIR("?")=" Select 1 - 3"
164 S DIR("?",1)=" If you want to continue processing this HINQ enter 1."
165 S DIR("?",3)=" If you cannot process this patient data at this time enter 2."
166 S DIR("?",2)=" If the HINQ data is for the wrong patient, enter 3."
167 S DIR("B")=2
168 D ^DIR
169 W !!
170 I Y=1 S DVBQT=0 Q ;update
171 I Y=2 Q ;ignore
172 I Y="^"!($G(DIRUT)=1)!($G(DUOUT)=1) S DVBOUT="^" Q ;"^" out of option
173 N DA,DIK ;delete
174 S DA=DFN
175 S DIK="^DVB(395.5,"
176 D ^DIK
177 Q
178TEXT ;warning text
179 W @IOF
180 W !!!!
181 W ?2,"*********************************************************************"
182 W !?2,"* NOTE: IDENTIFYING DATA FROM HINQ AND VISTA DOES NOT MATCH *"
183 W !?2,"* PATIENT FROM HINQ RESPONSE MAY NOT BE THE PATIENT REQUESTED *"
184 W !?2,"*********************************************************************"
185 Q
186DISPL ;display ID data
187 W !!?17,"Patient File data",?45,"HINQ Data"
188 W !?17,"-----------------",?45,"---------"
189 W !?11,"Name: "_$G(DVBDIQ(2,DFN,.01,"E")),?45,$G(DVBNAM)
190 W !?12,"Sex: "_$G(DVBDIQ(2,DFN,.02,"E")),?45,$G(DVBSEX)
191 W !?2,"Date of Birth: "_$G(DVBDIQ(2,DFN,.03,"E")),?45,$G(DVBBIRTH)
192 W !?12,"SSN: "_$G(DVBDIQ(2,DFN,.09,"E")),?45,$G(DVBSOCL)
193 Q
194NAME(DVBNM) ;set local variables to hold the VistA and HINQ formats of the
195 ;patient name so they can be compared, DVB*4*56
196 ;first check for the HINQ name on the first address line
197 N DVBARR,DVBHFRST,DVBHLST,DVBHMID,DVBOK,DVBSTUB,DVBVFRST,DVBVLST,DVBVMID
198 S (DVBARR,DVBOK,DVBSTUB)=0
199 ;set variable with HINQ name parts
200 I $G(DVBADR(1))]"" D
201 . S DVBARR=1
202 . S DVBHFRST=$P(DVBADR(1)," ") ;first name
203 . S DVBHMID=$P(DVBADR(1)," ",2) ;middle name, if there is one
204 . S DVBHLST=$P(DVBADR(1)," ",3) ;last name, if there was a middle name
205 ;then check for the HINQ 7 character name stub
206 I DVBARR=0,($G(DVBNAME)]"") S DVBSTUB=1
207 ;get VistA name parts
208 N DVBREST
209 S DVBVLST=$P(DVBNM,",")
210 S DVBREST=$P(DVBNM,",",2,3)
211 S DVBVFRST=$P(DVBREST," ")
212 S DVBVMID=$P(DVBREST," ",2)
213 ;now compare
214 I DVBARR=1 D Q DVBOK
215 . N DVBOK1,DVBOK2,DVBOK3
216 . S (DVBOK1,DVBOK2,DVBOK3)=0
217 . ;if name is long, HINQ first name may have been truncated to 1 char
218 . I $L(DVBHFRST)=1 S DVBVFRST=$E(DVBVFRST)
219 . ;if last name is > 16 chars, it may be truncated
220 . I $L(DVBVLST)>16 S DVBVLST=$E(DVBVLST,1,$L(DVBHLST))
221 . ;if name is long, HINQ middle name may have been truncated to 1 char
222 . ;but, if there is no HINQ middle name, do not try to compare
223 . I $G(DVBHMID)']"" S DVBOK3=1
224 . I DVBOK3=0 D
225 . . I $L(DVBHMID)=1 S DVBVMID=$E(DVBVMID)
226 . . I DVBVMID=DVBHMID S DVBOK3=1
227 . I DVBVFRST=DVBHFRST S DVBOK1=1
228 . I DVBVLST=DVBHLST S DVBOK2=1
229 . I DVBOK1=1,(DVBOK2=1),(DVBOK3=1) S DVBOK=1 Q
230 ;if the first line of the address array is not populated, compare
231 ;DVBNAME which is a HINQ stub name to the equivalent patient file stub
232 I DVBARR=0,(DVBSTUB=1) D
233 . N DVBVSTUB
234 . I DVBVMID']"" S DVBVMID=" "
235 . S DVBVSTUB=$E(DVBVFRST)_$E(DVBVMID)_$E(DVBVLST,1,5)
236 . I DVBVSTUB=DVBNAME S DVBOK=1
237 Q DVBOK
Note: See TracBrowser for help on using the repository browser.