DVBHQD1 ;ISC-ALBANY/PKE/PHH- HINQ receiver ; 5/15/06 10:58am
;;4.0;HINQ;**3,12,16,22,23,32,34,40,46,49,57,56**; 03/25/92
;
S:'$D(DTIME) DTIME=300 S DVBTIME=DTIME
EN S:$G(IO(0))="" IO(0)=$I S (C,DVBTSK,DVBABORT)=0,DVBXM=1,DTIME=30 U IO(0)
;
SEL S (DVBRTC,DVBTRY)=1,DVBNRT="Y"
R !!," Select Input: (P)atient File, or (D)irect P//",X:DTIME I '$T!(X["^") G HINQ
I "Pp"[$E(X) S DVBPRGM="TM^DVBHIQD" G ASK
I "Dd"[$E(X_1) S DVBPRGM="EN^DVBHQDE" G ASK
I X["?" D HP^DVBHQAT G SEL
G SEL
ASK S:$G(IO(0))="" IO(0)=$I W ! S Y=0,DVBIO=IO D @DVBPRGM
ASK1 I Y'<0,$D(DVBP),$L(DVBP)=4 S IO=DVBIO D STUFF^DVBHQAT:$D(DFN),MES
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
S IO=DVBIO U IO(0) K DVBP S DVBABORT=0
I '$D(Y) G ASK
I Y>0 G ASK
;
HINQ U IO(0) W !!,"Do you wish to continue" S %=2 D YN^DICN G:'% HINQ I %=1 W ! G EN
EX S DTIME=$S($D(DVBTIME):DVBTIME,1:300)
Q
MES ;
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)
K E H 1 S DVBEND="NNNN" S:'$D(DVBXM) DVBXM=0 S:'$D(C) C=0
;
TOTIMS S TRY=0,CN=$F(DVBZ,"/CN",24),DVBZ0=DVBZ
I $S('$D(DFN):1,DFN:0,1:1) S CN=0 D SEND^DVBHQD2,KTO^DVBHQD2 Q
I 'CN D CNLKUP^DVBHQAT
DO D SEND^DVBHQD2 I TRY DO I TRY H 1 D SEND^DVBHQD2
.I CN,'TRY S DVBZ0=$E(DVBZ,1,23)_$E(DVBZ,24,CN-3)_$E(DVBZ,CN+9,999) Q
.I CN,TRY S DVBZ1=$E(DVBZ,1,23)_$E(DVBZ,CN-2,999) Q
.I 'CN S DVBZ0=DVBZ,TRY=0 Q
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
G KTO^DVBHQD2
;
;z1 is first x(),z9 is last x()
OK ;I 'DVBTSK DO
;. 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))," "
;. W !?9,LX,! K LX H 3 U IO
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)
I $G(X(Z1))["HINQ" S X(Z1)="HINQ"_$P(X(Z1),"HINQ",2)
E K X(Z1) DO
. S Z1=$O(X(0)) I Z1="" S Z1=0,X(0)=""
. I $G(X(Z1))["HINQ" S X(Z1)="HINQ"_$P(X(Z1),"HINQ",2)
I $L(X(Z1))>25 S DVBLEN=+$E(X(Z1),22,25)
I $L(X(Z1))'>25 D
. I $D(X(Z1+1)) DO
. . S DVBLEN=+$E($E(X(Z1),1,99)_$E(X(Z1+1),1,30),22,25)
. I '$D(X(Z1+1)) D
. . S DVBLEN=$L(X(Z1)) ;DVB*4*49 - error response may be < 25 chars
I '$D(DVBLEN) S DVBABORT=DVBABORT+1 U IO(0) W:'DVBTSK !,"Missing string" U IO Q
;
I $D(F3) S DVBLEN=DVBLEN-F3 K F3
I "456789ABCDUVWNMXYZ"'[$E(X(Z1),5) S DVBLEN=DVBLEN-2
;
S (Z,Z9,F2)=0 F S Z=$O(X(Z)) Q:'Z S Z9=Z,F2=F2+$L(X(Z))
;
I DVBLEN'=F2,X(Z9)[$C(10) S DVBABORT=DVBABORT+1 U IO(0) W:'DVBTSK !,"Missing character" S DVBMISS="" Q
I $E(X(Z1),5)'=2 S F2=F2+1
;
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
;trim,e will pack back to x(1)
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
;
S DVBABORT=DVBABORT+1 Q:$E(X(1),1,4)'="HINQ"
I $E(X(1),5)="A" U IO(0) W:'DVBTSK !,"VBA File not Available" U IO H 2 D ALL QUIT
;
I DVBTSK,"69XY"[$E($E(X(1),5)_1) S DVBBADP="" D ALL QUIT
I 'Z9 Q
;
ALL 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)
E I DVBXM D K DVBTX Q
. N DVBQT
. D RS,A^DVBHIQR
. I $G(DFN)>1,('DVBTSK),($E(X(1),5)=2),('$D(DVBERCS)) D CHKID I DVBQT D Q
. . N DVBTMP1,DVBTMP2
. . S DVBTMP1=$G(DVBNOALR)
. . S DVBTMP2=$G(DVBJ2)
. . S DVBNOALR=";4///c;5////"_DUZ_";6///N",DVBJ2=1
. . D FILE^DVBHQUP
. . S DVBNOALR=DVBTMP1
. . S DVBJ2=DVBTMP2
. D RECMAL^DVBHQD2
. D IALERT^DVBHT2,EN^DVBHIQM H 1 D WRT
I DVBABORT=3!($D(DVBBADP)) S DFN=0
Q
; do all if no error or retrying
ALLM I "BC"'[$E($E(X(1),5)_1) D ALL Q
I CN,'TRY S TRY=1 D:DVBXM DCN Q
I 'CN D ALL Q
S X(1)=X(1)_"[TRY]1" D ALL Q
;
DCN S:$G(IO(0))="" IO(0)=$I U IO(0) W !,"..Name, SSN didn't work ....retrying using Claim Number",! U IO Q
;
RS Q:'$D(DFN) Q:'DFN Q:'$D(^DVB(395.5,DFN,0)) S DVBDFN=DFN,DVBCS=0
F DVBSZ=0:0 S DVBSZ=$O(X(DVBSZ)) D SC^DVBHQST Q:'DVBSZ D ST^DVBHQDB
K DVBSZ,DVBDFN Q
;
TRIM Q:F1=999
I '$D(F1) S F1=$F(X(Z9),DVBEND)
I $E(X(Z9),F1-F4)=$C(10) S F1=F1-1
S X(Z9)=$E(X(Z9),1,F1-F4)
K F1 Q
;
WRT S:$G(IO(0))="" IO(0)=$I S DVBJIO=IO(0)
WRT1 S:$G(DVBJIO)="" DVBJIO=$I S:'$D(DVBIOSL) DVBIOSL=IOSL S:'$D(DVBIOST) DVBIOST=IOST S:'$D(DVBIOF) DVBIOF=IOF
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
Q:X="^" K DVBJIO D SROLL^DVBHQD2 Q
;
CH S F1=0
I X(W)=$C(10)_"NNNN" K X(W) S F1=999 Q
I $L(X(W))>4!($L(X(W))<1) Q
F A=$L(X(W)):-1:1 Q:$E(X(W),A)'="N"
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)
Q
CHKID ;checks 4 critical identifier fields
;fields are name, DOB, SSN and sex.
;DVBQT 0 to continue, 1 to stop processing
N DA,DIC,DIQ,DIR,DR,X,Y
N DVBBIRTH,DVBCNT,DVBNAM,DVBNM,DVBSEX,DVBSOCL,DVBSSN
N DVBDIQ
S DVBCNT=0
S DVBQT=0
S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="DVBDIQ("
S DR=".01;.02;.03;.09"
D EN^DIQ1
S DVBNAM=$S($D(DVBADR(1)):DVBADR(1),$D(DVBNAME):$E(DVBNAME,1,30),1:"")
S DVBSEX=""
I $D(DVBVET),$P(DVBVET,U)="A" S DVBSEX=$S($P(DVBVET,U,3)="M":"MALE",$P(DVBVET,U,3)="F":"FEMALE",1:"")
I '$D(DVBVET),($D(DVBBIR)) S DVBSEX=$S($P(DVBBIR,U,25)="M":"MALE",$P(DVBBIR,U,25)="F":"FEMALE",1:"")
S DVBSOCL=""
I $D(DVBREF),($P(DVBREF,U)?9N) S DVBSOCL=$P(DVBREF,U)
I $P($G(DVBREF),U)'?9N I $D(DVBSSN),(DVBSSN?9N) S DVBSOCL=DVBSSN
S DVBBIRTH=""
;change date of birth to match the Patient file ext value (DVBBIRTH)
I $D(DVBDOB),(DVBDOB?8N) S DVBBIRTH=$E(DVBDOB,1,2)_"/"_$E(DVBDOB,3,4)_"/"_$E(DVBDOB,5,8)
;change ext Patient file value for name to HINQ name format
I '$$NAME(DVBDIQ(2,DFN,.01,"E")) S DVBCNT=DVBCNT+1
I $G(DVBSEX)'=$G(DVBDIQ(2,DFN,.02,"E")) S DVBCNT=DVBCNT+1
I $G(DVBBIRTH)'=$G(DVBDIQ(2,DFN,.03,"E")) S DVBCNT=DVBCNT+1
I $G(DVBSOCL)'=$G(DVBDIQ(2,DFN,.09,"E")) S DVBCNT=DVBCNT+1
I DVBCNT>0 D WARN
Q
WARN ;warns user if there are any discrepancies between HINQ and VistA for
;4 critical identifier fields - name, DOB, SSN and sex.
N DIRUT,DUOUT
U IO(0)
H 1
D TEXT
D DISPL
S DVBQT=1
N DIR
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"
W !!
S DIR("A",1)="Check displayed data before proceeding."
S DIR("A",2)=""
S DIR("A",3)="Choose one of the following:"
S DIR("A",4)=" 1. Update this record."
S DIR("A",5)=" 2. Take no action at this time."
S DIR("A",6)=" 3. Delete this record from the SUSPENSE file."
S DIR("A",7)=""
S DIR("?")=" Select 1 - 3"
S DIR("?",1)=" If you want to continue processing this HINQ enter 1."
S DIR("?",3)=" If you cannot process this patient data at this time enter 2."
S DIR("?",2)=" If the HINQ data is for the wrong patient, enter 3."
S DIR("B")=2
D ^DIR
W !!
I Y=1 S DVBQT=0 Q ;update
I Y=2 Q ;ignore
I Y="^"!($G(DIRUT)=1)!($G(DUOUT)=1) S DVBOUT="^" Q ;"^" out of option
N DA,DIK ;delete
S DA=DFN
S DIK="^DVB(395.5,"
D ^DIK
Q
TEXT ;warning text
W @IOF
W !!!!
W ?2,"*********************************************************************"
W !?2,"* NOTE: IDENTIFYING DATA FROM HINQ AND VISTA DOES NOT MATCH *"
W !?2,"* PATIENT FROM HINQ RESPONSE MAY NOT BE THE PATIENT REQUESTED *"
W !?2,"*********************************************************************"
Q
DISPL ;display ID data
W !!?17,"Patient File data",?45,"HINQ Data"
W !?17,"-----------------",?45,"---------"
W !?11,"Name: "_$G(DVBDIQ(2,DFN,.01,"E")),?45,$G(DVBNAM)
W !?12,"Sex: "_$G(DVBDIQ(2,DFN,.02,"E")),?45,$G(DVBSEX)
W !?2,"Date of Birth: "_$G(DVBDIQ(2,DFN,.03,"E")),?45,$G(DVBBIRTH)
W !?12,"SSN: "_$G(DVBDIQ(2,DFN,.09,"E")),?45,$G(DVBSOCL)
Q
NAME(DVBNM) ;set local variables to hold the VistA and HINQ formats of the
;patient name so they can be compared, DVB*4*56
;first check for the HINQ name on the first address line
N DVBARR,DVBHFRST,DVBHLST,DVBHMID,DVBOK,DVBSTUB,DVBVFRST,DVBVLST,DVBVMID
S (DVBARR,DVBOK,DVBSTUB)=0
;set variable with HINQ name parts
I $G(DVBADR(1))]"" D
. S DVBARR=1
. S DVBHFRST=$P(DVBADR(1)," ") ;first name
. S DVBHMID=$P(DVBADR(1)," ",2) ;middle name, if there is one
. S DVBHLST=$P(DVBADR(1)," ",3) ;last name, if there was a middle name
;then check for the HINQ 7 character name stub
I DVBARR=0,($G(DVBNAME)]"") S DVBSTUB=1
;get VistA name parts
N DVBREST
S DVBVLST=$P(DVBNM,",")
S DVBREST=$P(DVBNM,",",2,3)
S DVBVFRST=$P(DVBREST," ")
S DVBVMID=$P(DVBREST," ",2)
;now compare
I DVBARR=1 D Q DVBOK
. N DVBOK1,DVBOK2,DVBOK3
. S (DVBOK1,DVBOK2,DVBOK3)=0
. ;if name is long, HINQ first name may have been truncated to 1 char
. I $L(DVBHFRST)=1 S DVBVFRST=$E(DVBVFRST)
. ;if last name is > 16 chars, it may be truncated
. I $L(DVBVLST)>16 S DVBVLST=$E(DVBVLST,1,$L(DVBHLST))
. ;if name is long, HINQ middle name may have been truncated to 1 char
. ;but, if there is no HINQ middle name, do not try to compare
. I $G(DVBHMID)']"" S DVBOK3=1
. I DVBOK3=0 D
. . I $L(DVBHMID)=1 S DVBVMID=$E(DVBVMID)
. . I DVBVMID=DVBHMID S DVBOK3=1
. I DVBVFRST=DVBHFRST S DVBOK1=1
. I DVBVLST=DVBHLST S DVBOK2=1
. I DVBOK1=1,(DVBOK2=1),(DVBOK3=1) S DVBOK=1 Q
;if the first line of the address array is not populated, compare
;DVBNAME which is a HINQ stub name to the equivalent patient file stub
I DVBARR=0,(DVBSTUB=1) D
. N DVBVSTUB
. I DVBVMID']"" S DVBVMID=" "
. S DVBVSTUB=$E(DVBVFRST)_$E(DVBVMID)_$E(DVBVLST,1,5)
. I DVBVSTUB=DVBNAME S DVBOK=1
Q DVBOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQD1 9917 printed Dec 13, 2024@01:58:34 Page 2
DVBHQD1 ;ISC-ALBANY/PKE/PHH- HINQ receiver ; 5/15/06 10:58am
+1 ;;4.0;HINQ;**3,12,16,22,23,32,34,40,46,49,57,56**; 03/25/92
+2 ;
+3 if '$DATA(DTIME)
SET DTIME=300
SET DVBTIME=DTIME
EN if $GET(IO(0))=""
SET IO(0)=$IO
SET (C,DVBTSK,DVBABORT)=0
SET DVBXM=1
SET DTIME=30
USE IO(0)
+1 ;
SEL SET (DVBRTC,DVBTRY)=1
SET DVBNRT="Y"
+1 READ !!," Select Input: (P)atient File, or (D)irect P//",X:DTIME
IF '$TEST!(X["^")
GOTO HINQ
+2 IF "Pp"[$EXTRACT(X)
SET DVBPRGM="TM^DVBHIQD"
GOTO ASK
+3 IF "Dd"[$EXTRACT(X_1)
SET DVBPRGM="EN^DVBHQDE"
GOTO ASK
+4 IF X["?"
DO HP^DVBHQAT
GOTO SEL
+5 GOTO SEL
ASK if $GET(IO(0))=""
SET IO(0)=$IO
WRITE !
SET Y=0
SET DVBIO=IO
DO @DVBPRGM
ASK1 IF Y'<0
IF $DATA(DVBP)
IF $LENGTH(DVBP)=4
SET IO=DVBIO
if $DATA(DFN)
DO STUFF^DVBHQAT
DO MES
+1 IF $DATA(DVBMISS)
KILL DVBMISS
if DVBTRY>3
DO RETRY^DVBHQD2
if DVBNRT="N"
GOTO LOAD2^DVBHQD2
IF DVBTRY<4&(DVBRTC<4)
SET DVBTRY=DVBTRY+1
USE IO(0)
WRITE ?35,"Retrying Request."
GOTO ASK1
+2 SET IO=DVBIO
USE IO(0)
KILL DVBP
SET DVBABORT=0
+3 IF '$DATA(Y)
GOTO ASK
+4 IF Y>0
GOTO ASK
+5 ;
HINQ USE IO(0)
WRITE !!,"Do you wish to continue"
SET %=2
DO YN^DICN
if '%
GOTO HINQ
IF %=1
WRITE !
GOTO EN
EX SET DTIME=$SELECT($DATA(DVBTIME):DVBTIME,1:300)
+1 QUIT
MES ;
+1 if $GET(IO(0))=""
SET IO(0)=$IO
SET E=$LENGTH(DVBZ)
IF '$DATA(DVBDXX)
IF ($EXTRACT(DVBZ,E-7,E-4)'=DVBNUM)
SET DVBZ=$EXTRACT(DVBZ,1,E-4)_DVBNUM_$EXTRACT(DVBZ,E-3,999)
+2 KILL E
HANG 1
SET DVBEND="NNNN"
if '$DATA(DVBXM)
SET DVBXM=0
if '$DATA(C)
SET C=0
+3 ;
TOTIMS SET TRY=0
SET CN=$FIND(DVBZ,"/CN",24)
SET DVBZ0=DVBZ
+1 IF $SELECT('$DATA(DFN):1,DFN:0,1:1)
SET CN=0
DO SEND^DVBHQD2
DO KTO^DVBHQD2
QUIT
+2 IF 'CN
DO CNLKUP^DVBHQAT
+3 Begin DoDot:1
+4 IF CN
IF 'TRY
SET DVBZ0=$EXTRACT(DVBZ,1,23)_$EXTRACT(DVBZ,24,CN-3)_$EXTRACT(DVBZ,CN+9,999)
QUIT
+5 IF CN
IF TRY
SET DVBZ1=$EXTRACT(DVBZ,1,23)_$EXTRACT(DVBZ,CN-2,999)
QUIT
+6 IF 'CN
SET DVBZ0=DVBZ
SET TRY=0
QUIT
End DoDot:1
DO SEND^DVBHQD2
IF TRY
Begin DoDot:1
End DoDot:1
IF TRY
HANG 1
DO SEND^DVBHQD2
+7 IF $DATA(DVBMISS)&($DATA(DVBPRGM))
IF (DVBPRGM["TM")
KILL DVBMISS
if DVBTRY>3
DO RETRY^DVBHQD2
if DVBNRT="N"
GOTO LOAD^DVBHQD2
IF DVBTRY<4&(DVBRTC<4)
SET DVBTRY=DVBTRY+1
USE IO(0)
WRITE ?35,"Retrying Request."
GOTO MES
+8 GOTO KTO^DVBHQD2
+9 ;
+10 ;z1 is first x(),z9 is last x()
OK ;I 'DVBTSK DO
+1 ;. 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))," "
+2 ;. W !?9,LX,! K LX H 3 U IO
+3 if $GET(IO(0))=""
SET IO(0)=$IO
SET Z1=$ORDER(X(0))
FOR
if $EXTRACT(X(Z1))'=$CHAR(10)
QUIT
SET X(Z1)=$EXTRACT(X(Z1),2,999)
+4 IF $GET(X(Z1))["HINQ"
SET X(Z1)="HINQ"_$PIECE(X(Z1),"HINQ",2)
+5 IF '$TEST
KILL X(Z1)
Begin DoDot:1
+6 SET Z1=$ORDER(X(0))
IF Z1=""
SET Z1=0
SET X(0)=""
+7 IF $GET(X(Z1))["HINQ"
SET X(Z1)="HINQ"_$PIECE(X(Z1),"HINQ",2)
End DoDot:1
+8 IF $LENGTH(X(Z1))>25
SET DVBLEN=+$EXTRACT(X(Z1),22,25)
+9 IF $LENGTH(X(Z1))'>25
Begin DoDot:1
+10 IF $DATA(X(Z1+1))
Begin DoDot:2
+11 SET DVBLEN=+$EXTRACT($EXTRACT(X(Z1),1,99)_$EXTRACT(X(Z1+1),1,30),22,25)
End DoDot:2
+12 IF '$DATA(X(Z1+1))
Begin DoDot:2
+13 ;DVB*4*49 - error response may be < 25 chars
SET DVBLEN=$LENGTH(X(Z1))
End DoDot:2
End DoDot:1
+14 IF '$DATA(DVBLEN)
SET DVBABORT=DVBABORT+1
USE IO(0)
if 'DVBTSK
WRITE !,"Missing string"
USE IO
QUIT
+15 ;
+16 IF $DATA(F3)
SET DVBLEN=DVBLEN-F3
KILL F3
+17 IF "456789ABCDUVWNMXYZ"'[$EXTRACT(X(Z1),5)
SET DVBLEN=DVBLEN-2
+18 ;
+19 SET (Z,Z9,F2)=0
FOR
SET Z=$ORDER(X(Z))
if 'Z
QUIT
SET Z9=Z
SET F2=F2+$LENGTH(X(Z))
+20 ;
+21 IF DVBLEN'=F2
IF X(Z9)[$CHAR(10)
SET DVBABORT=DVBABORT+1
USE IO(0)
if 'DVBTSK
WRITE !,"Missing character"
SET DVBMISS=""
QUIT
+22 IF $EXTRACT(X(Z1),5)'=2
SET F2=F2+1
+23 ;
+24 IF DVBLEN'=F2-1
IF X(Z9)'[$CHAR(10)
IF $SELECT('$DATA(X(Z9-1)):1,1:$SELECT(X(Z9-1)'[$CHAR(10):1,1:0))
SET DVBABORT=DVBABORT+1
USE IO(0)
if 'DVBTSK
WRITE !,"Missing character"
SET DVBMISS=""
QUIT
+25 ;trim,e will pack back to x(1)
+26 IF Z9
if $DATA(X)
SET DVBSOX=X
DO TRIM
DO E^DVBHQAT
if $DATA(DVBSOX)
SET X=DVBSOX
KILL DVBSOX
IF $EXTRACT(X(1),1,4)["HINQ"
IF "AXY69"'[$EXTRACT($EXTRACT(X(1),5)_1)
DO ALLM
QUIT
+27 ;
+28 SET DVBABORT=DVBABORT+1
if $EXTRACT(X(1),1,4)'="HINQ"
QUIT
+29 IF $EXTRACT(X(1),5)="A"
USE IO(0)
if 'DVBTSK
WRITE !,"VBA File not Available"
USE IO
HANG 2
DO ALL
QUIT
+30 ;
+31 IF DVBTSK
IF "69XY"[$EXTRACT($EXTRACT(X(1),5)_1)
SET DVBBADP=""
DO ALL
QUIT
+32 IF 'Z9
QUIT
+33 ;
ALL IF 'DVBXM
IF $DATA(DFN)
IF +DFN
if C
KILL ^TMP("DVBHINQ",$JOB,DFN)
SET Z=0
FOR
SET Z=$ORDER(X(Z))
if 'Z
QUIT
SET ^TMP("DVBHINQ",$JOB,DFN,Z)=X(Z)
+1 IF '$TEST
IF DVBXM
Begin DoDot:1
+2 NEW DVBQT
+3 DO RS
DO A^DVBHIQR
+4 IF $GET(DFN)>1
IF ('DVBTSK)
IF ($EXTRACT(X(1),5)=2)
IF ('$DATA(DVBERCS))
DO CHKID
IF DVBQT
Begin DoDot:2
+5 NEW DVBTMP1,DVBTMP2
+6 SET DVBTMP1=$GET(DVBNOALR)
+7 SET DVBTMP2=$GET(DVBJ2)
+8 SET DVBNOALR=";4///c;5////"_DUZ_";6///N"
SET DVBJ2=1
+9 DO FILE^DVBHQUP
+10 SET DVBNOALR=DVBTMP1
+11 SET DVBJ2=DVBTMP2
End DoDot:2
QUIT
+12 DO RECMAL^DVBHQD2
+13 DO IALERT^DVBHT2
DO EN^DVBHIQM
HANG 1
DO WRT
End DoDot:1
KILL DVBTX
QUIT
+14 IF DVBABORT=3!($DATA(DVBBADP))
SET DFN=0
+15 QUIT
+16 ; do all if no error or retrying
ALLM IF "BC"'[$EXTRACT($EXTRACT(X(1),5)_1)
DO ALL
QUIT
+1 IF CN
IF 'TRY
SET TRY=1
if DVBXM
DO DCN
QUIT
+2 IF 'CN
DO ALL
QUIT
+3 SET X(1)=X(1)_"[TRY]1"
DO ALL
QUIT
+4 ;
DCN if $GET(IO(0))=""
SET IO(0)=$IO
USE IO(0)
WRITE !,"..Name, SSN didn't work ....retrying using Claim Number",!
USE IO
QUIT
+1 ;
RS if '$DATA(DFN)
QUIT
if 'DFN
QUIT
if '$DATA(^DVB(395.5,DFN,0))
QUIT
SET DVBDFN=DFN
SET DVBCS=0
+1 FOR DVBSZ=0:0
SET DVBSZ=$ORDER(X(DVBSZ))
DO SC^DVBHQST
if 'DVBSZ
QUIT
DO ST^DVBHQDB
+2 KILL DVBSZ,DVBDFN
QUIT
+3 ;
TRIM if F1=999
QUIT
+1 IF '$DATA(F1)
SET F1=$FIND(X(Z9),DVBEND)
+2 IF $EXTRACT(X(Z9),F1-F4)=$CHAR(10)
SET F1=F1-1
+3 SET X(Z9)=$EXTRACT(X(Z9),1,F1-F4)
+4 KILL F1
QUIT
+5 ;
WRT if $GET(IO(0))=""
SET IO(0)=$IO
SET DVBJIO=IO(0)
WRT1 if $GET(DVBJIO)=""
SET DVBJIO=$IO
if '$DATA(DVBIOSL)
SET DVBIOSL=IOSL
if '$DATA(DVBIOST)
SET DVBIOST=IOST
if '$DATA(DVBIOF)
SET DVBIOF=IOF
+1 SET X=""
USE DVBJIO
WRITE !!!
DO CODE^DVBHQUS
WRITE !!
SET Y0=$Y
FOR Z=0:0
SET Z=$ORDER(^TMP($JOB,Z))
if 'Z
QUIT
IF $DATA(^(Z,0))
WRITE ^(0),!
if $Y-Y0>(DVBIOSL-4)
DO SROLL^DVBHQD2
if X="^"
QUIT
if $Y<Y0
DO ABS^DVBHQD2
+2 if X="^"
QUIT
KILL DVBJIO
DO SROLL^DVBHQD2
QUIT
+3 ;
CH SET F1=0
+1 IF X(W)=$CHAR(10)_"NNNN"
KILL X(W)
SET F1=999
QUIT
+2 IF $LENGTH(X(W))>4!($LENGTH(X(W))<1)
QUIT
+3 FOR A=$LENGTH(X(W)):-1:1
if $EXTRACT(X(W),A)'="N"
QUIT
+4 IF A=1
IF $EXTRACT(X(W),A)="N"
SET F1=$LENGTH(X(W-1))+1
SET F3=$LENGTH(X(W))
SET F4=5-$LENGTH(X(W))
KILL X(W)
+5 QUIT
CHKID ;checks 4 critical identifier fields
+1 ;fields are name, DOB, SSN and sex.
+2 ;DVBQT 0 to continue, 1 to stop processing
+3 NEW DA,DIC,DIQ,DIR,DR,X,Y
+4 NEW DVBBIRTH,DVBCNT,DVBNAM,DVBNM,DVBSEX,DVBSOCL,DVBSSN
+5 NEW DVBDIQ
+6 SET DVBCNT=0
+7 SET DVBQT=0
+8 SET DIC="^DPT("
SET DA=DFN
SET DIQ(0)="E"
SET DIQ="DVBDIQ("
+9 SET DR=".01;.02;.03;.09"
+10 DO EN^DIQ1
+11 SET DVBNAM=$SELECT($DATA(DVBADR(1)):DVBADR(1),$DATA(DVBNAME):$EXTRACT(DVBNAME,1,30),1:"")
+12 SET DVBSEX=""
+13 IF $DATA(DVBVET)
IF $PIECE(DVBVET,U)="A"
SET DVBSEX=$SELECT($PIECE(DVBVET,U,3)="M":"MALE",$PIECE(DVBVET,U,3)="F":"FEMALE",1:"")
+14 IF '$DATA(DVBVET)
IF ($DATA(DVBBIR))
SET DVBSEX=$SELECT($PIECE(DVBBIR,U,25)="M":"MALE",$PIECE(DVBBIR,U,25)="F":"FEMALE",1:"")
+15 SET DVBSOCL=""
+16 IF $DATA(DVBREF)
IF ($PIECE(DVBREF,U)?9N)
SET DVBSOCL=$PIECE(DVBREF,U)
+17 IF $PIECE($GET(DVBREF),U)'?9N
IF $DATA(DVBSSN)
IF (DVBSSN?9N)
SET DVBSOCL=DVBSSN
+18 SET DVBBIRTH=""
+19 ;change date of birth to match the Patient file ext value (DVBBIRTH)
+20 IF $DATA(DVBDOB)
IF (DVBDOB?8N)
SET DVBBIRTH=$EXTRACT(DVBDOB,1,2)_"/"_$EXTRACT(DVBDOB,3,4)_"/"_$EXTRACT(DVBDOB,5,8)
+21 ;change ext Patient file value for name to HINQ name format
+22 IF '$$NAME(DVBDIQ(2,DFN,.01,"E"))
SET DVBCNT=DVBCNT+1
+23 IF $GET(DVBSEX)'=$GET(DVBDIQ(2,DFN,.02,"E"))
SET DVBCNT=DVBCNT+1
+24 IF $GET(DVBBIRTH)'=$GET(DVBDIQ(2,DFN,.03,"E"))
SET DVBCNT=DVBCNT+1
+25 IF $GET(DVBSOCL)'=$GET(DVBDIQ(2,DFN,.09,"E"))
SET DVBCNT=DVBCNT+1
+26 IF DVBCNT>0
DO WARN
+27 QUIT
WARN ;warns user if there are any discrepancies between HINQ and VistA for
+1 ;4 critical identifier fields - name, DOB, SSN and sex.
+2 NEW DIRUT,DUOUT
+3 USE IO(0)
+4 HANG 1
+5 DO TEXT
+6 DO DISPL
+7 SET DVBQT=1
+8 NEW DIR
+9 SET DIR(0)="N^1:3:0"
SET DIR("A")="Do you want to process the HINQ on "_DVBDIQ(2,DFN,.01,"E")_"? "
SET DIR("B")="NO"
+10 WRITE !!
+11 SET DIR("A",1)="Check displayed data before proceeding."
+12 SET DIR("A",2)=""
+13 SET DIR("A",3)="Choose one of the following:"
+14 SET DIR("A",4)=" 1. Update this record."
+15 SET DIR("A",5)=" 2. Take no action at this time."
+16 SET DIR("A",6)=" 3. Delete this record from the SUSPENSE file."
+17 SET DIR("A",7)=""
+18 SET DIR("?")=" Select 1 - 3"
+19 SET DIR("?",1)=" If you want to continue processing this HINQ enter 1."
+20 SET DIR("?",3)=" If you cannot process this patient data at this time enter 2."
+21 SET DIR("?",2)=" If the HINQ data is for the wrong patient, enter 3."
+22 SET DIR("B")=2
+23 DO ^DIR
+24 WRITE !!
+25 ;update
IF Y=1
SET DVBQT=0
QUIT
+26 ;ignore
IF Y=2
QUIT
+27 ;"^" out of option
IF Y="^"!($GET(DIRUT)=1)!($GET(DUOUT)=1)
SET DVBOUT="^"
QUIT
+28 ;delete
NEW DA,DIK
+29 SET DA=DFN
+30 SET DIK="^DVB(395.5,"
+31 DO ^DIK
+32 QUIT
TEXT ;warning text
+1 WRITE @IOF
+2 WRITE !!!!
+3 WRITE ?2,"*********************************************************************"
+4 WRITE !?2,"* NOTE: IDENTIFYING DATA FROM HINQ AND VISTA DOES NOT MATCH *"
+5 WRITE !?2,"* PATIENT FROM HINQ RESPONSE MAY NOT BE THE PATIENT REQUESTED *"
+6 WRITE !?2,"*********************************************************************"
+7 QUIT
DISPL ;display ID data
+1 WRITE !!?17,"Patient File data",?45,"HINQ Data"
+2 WRITE !?17,"-----------------",?45,"---------"
+3 WRITE !?11,"Name: "_$GET(DVBDIQ(2,DFN,.01,"E")),?45,$GET(DVBNAM)
+4 WRITE !?12,"Sex: "_$GET(DVBDIQ(2,DFN,.02,"E")),?45,$GET(DVBSEX)
+5 WRITE !?2,"Date of Birth: "_$GET(DVBDIQ(2,DFN,.03,"E")),?45,$GET(DVBBIRTH)
+6 WRITE !?12,"SSN: "_$GET(DVBDIQ(2,DFN,.09,"E")),?45,$GET(DVBSOCL)
+7 QUIT
NAME(DVBNM) ;set local variables to hold the VistA and HINQ formats of the
+1 ;patient name so they can be compared, DVB*4*56
+2 ;first check for the HINQ name on the first address line
+3 NEW DVBARR,DVBHFRST,DVBHLST,DVBHMID,DVBOK,DVBSTUB,DVBVFRST,DVBVLST,DVBVMID
+4 SET (DVBARR,DVBOK,DVBSTUB)=0
+5 ;set variable with HINQ name parts
+6 IF $GET(DVBADR(1))]""
Begin DoDot:1
+7 SET DVBARR=1
+8 ;first name
SET DVBHFRST=$PIECE(DVBADR(1)," ")
+9 ;middle name, if there is one
SET DVBHMID=$PIECE(DVBADR(1)," ",2)
+10 ;last name, if there was a middle name
SET DVBHLST=$PIECE(DVBADR(1)," ",3)
End DoDot:1
+11 ;then check for the HINQ 7 character name stub
+12 IF DVBARR=0
IF ($GET(DVBNAME)]"")
SET DVBSTUB=1
+13 ;get VistA name parts
+14 NEW DVBREST
+15 SET DVBVLST=$PIECE(DVBNM,",")
+16 SET DVBREST=$PIECE(DVBNM,",",2,3)
+17 SET DVBVFRST=$PIECE(DVBREST," ")
+18 SET DVBVMID=$PIECE(DVBREST," ",2)
+19 ;now compare
+20 IF DVBARR=1
Begin DoDot:1
+21 NEW DVBOK1,DVBOK2,DVBOK3
+22 SET (DVBOK1,DVBOK2,DVBOK3)=0
+23 ;if name is long, HINQ first name may have been truncated to 1 char
+24 IF $LENGTH(DVBHFRST)=1
SET DVBVFRST=$EXTRACT(DVBVFRST)
+25 ;if last name is > 16 chars, it may be truncated
+26 IF $LENGTH(DVBVLST)>16
SET DVBVLST=$EXTRACT(DVBVLST,1,$LENGTH(DVBHLST))
+27 ;if name is long, HINQ middle name may have been truncated to 1 char
+28 ;but, if there is no HINQ middle name, do not try to compare
+29 IF $GET(DVBHMID)']""
SET DVBOK3=1
+30 IF DVBOK3=0
Begin DoDot:2
+31 IF $LENGTH(DVBHMID)=1
SET DVBVMID=$EXTRACT(DVBVMID)
+32 IF DVBVMID=DVBHMID
SET DVBOK3=1
End DoDot:2
+33 IF DVBVFRST=DVBHFRST
SET DVBOK1=1
+34 IF DVBVLST=DVBHLST
SET DVBOK2=1
+35 IF DVBOK1=1
IF (DVBOK2=1)
IF (DVBOK3=1)
SET DVBOK=1
QUIT
End DoDot:1
QUIT DVBOK
+36 ;if the first line of the address array is not populated, compare
+37 ;DVBNAME which is a HINQ stub name to the equivalent patient file stub
+38 IF DVBARR=0
IF (DVBSTUB=1)
Begin DoDot:1
+39 NEW DVBVSTUB
+40 IF DVBVMID']""
SET DVBVMID=" "
+41 SET DVBVSTUB=$EXTRACT(DVBVFRST)_$EXTRACT(DVBVMID)_$EXTRACT(DVBVLST,1,5)
+42 IF DVBVSTUB=DVBNAME
SET DVBOK=1
End DoDot:1
+43 QUIT DVBOK
