DGBTRDV ;ALB/BLD,KAR - Beneficiary Travel information VIA RDV ;1/16/19 14:05
;;1.0;Beneficiary Travel;**20,35**;September 25, 2001;Build 18
;Per VA Directive 6402, this routine should not be modified.
;
; This routine is used to exchange insurance information between
; facilities.
;
;COPIED FROM IBCNRDV **************
;
Q
;
OPT(DFN,DGBTDTI) ; Menu option entry point.
; information about from the remote treating facilities.
N DIC,X,Y,DTOUT,DUOUT,%,%Y,DGBTIEN,VADM,DGBTIBB,DGBTD,DGBTIBI,DGBTICN,DGBTIBRZ,DGBTDGBTIBY,DGBTZ,DGBTWAIT,DGBTIBI
N DO,DGBTYPE,DGBTIB1,DGBTRPC,DGBTR,RET,DGBTHDL
;
K ^TMP("DGBTRDV"),^TMP("BARRY")
;
S (RDVMSG,DGBTYPE)=0 ;this tell's the system not to run in back ground. it has to be a foreground job
; prompt for patient
;
BACKGND ; background/tasked entry point
; DGBTYPE is being used as a flag to indicate this is running in background
; DGBTRDV is array of treating facilities
; look up treating facilities
K DGBTRDV S DGBTRDV=$$TFL(DFN,.DGBTRDV)
I DGBTRDV<1,$D(DGBTYPE) S RDVMSG=1 W !!,"This patient has no remote treating facilities to query." Q
I DGBTRDV<1 Q
;
; get ICN
; DGBTICN - is the patients ICN
S DGBTICN=$$ICN(DFN) I 'DGBTICN,'$D(DGBTYPE) S RDVMSG=1 W !!,"No ICN for this patient" Q
I 'DGBTICN Q
;
; sent off the remote queries and get back handles
; DGBTRPC is name of RPC in file 8994
; DGBTIEN is IEN of the treating facilities array
; DGBTRET - the array that contains the return data
;
S DGBTRPC="DGBT CLAIM DEDUCTIBLE PAID"
S DGBTIEN=0 F S DGBTIEN=$O(DGBTRDV(DGBTIEN)) Q:DGBTIEN<1 D
.D SEND(.DGBTRET,DGBTIEN,DGBTICN,DGBTRPC,DGBTDTI)
.X $S(DGBTRET(0)'="":"S $P(DGBTRDV(DGBTIEN),U,5)=DGBTRET(0)",1:"W:'$D(DGBTYPE) !,""No handle returned for "",$P(DGBTRDV(DGBTIEN),U,2) K DGBTRDV(DGBTIEN)")
;
; no handles returned
I $D(DGBTRDV)<9,$D(DGBTYPE) S RDVMSG=1 W !!,"Unable to perform any remote queries.",! Q
I $D(DGBTRDV)<9 Q
;
; go through every DGBTRDV()
S DGBTIBRZ="|",DGBTIEN=0
F S DGBTIEN=$O(DGBTRDV(DGBTIEN)) Q:DGBTIEN<1!($D(DGBTRDV)<9) D
.;
.; do I have a return data.
.F DGBTWAIT=1:1:30 W:$D(DGBTYPE) "." H 1 D CHECK(.DGBTR,$P(DGBTRDV(DGBTIEN),"^",5)) I $G(DGBTR(0))["Done" Q
.I $G(DGBTR(0))'["Done" S:$D(DGBTYPE) RDVMSG=1 W:$D(DGBTYPE) !!,"Unable to communicate with ",$P(DGBTRDV(DGBTIEN),U,2) Q
.D RETURN(.DGBTR,$P(DGBTRDV(DGBTIEN),"^",5))
.;
.; no data returned or error message
.S DGBTIBRZ=$S(-1=+$G(DGBTR):DGBTR,$G(DGBTR(0))="":$G(DGBTR(1)),1:$G(DGBTR(0)))
.;
.; no info to proceed
.I DGBTIBRZ<1 S RDVMSG=1 W:'$D(DGBTYPE) !,"Response from ",$P(DGBTRDV(DGBTX),U,2),!,$P(DGBTIBRZ,"^",2) K DGBTRDV(DGBTIEN) Q
.I DGBTIBRZ<1 K DGBTRDV(DGBTIEN) Q
.;
;
Q
;
RPC(DGBTRET,DGBTICN,DGBTDTI) ; RPC entry for Beneficiary Travel Claims for a given month
N DFN K DGBTRET ;KAR 07/08/18 Removed output parameter from input
S ^TMP("FROM CHEY246",$H)=""
S DFN=$$DFN(DGBTICN) I 'DFN S DGBTRET="-1^ICN Not found" Q
S DGBTRET(0)=$$WAIV^DGBTRDVW(DFN,DGBTDTI)
I $G(DGBTRET(0))="" S DGBTRDV="-1^No BT Claims on File" Q
; set up return format
;
Q
;
SEND(DGBTRET,DGBTIEN,DGBTICN,DGBTRPC,DGBTDTI) ; called to send off queries
D EN1^XWB2HL7(.DGBTRET,DGBTIEN,DGBTRPC,"",DGBTICN,DGBTDTI)
Q
;
CHECK(DGBTRET,DGBTHDL) ; called to check the return status of an RPC
D RPCCHK^XWB2HL7(.DGBTRET,DGBTHDL)
Q
;
RETURN(DGBTRTN,DGBTHDL) ; called to get the return data and clear the broker
N I,DGBTZ
D RTNDATA^XWBDRPC(.DGBTRET,DGBTHDL),CLEAR^XWBDRPC(.DGBTZ,DGBTHDL)
F I=1:1:$L(DGBTRET(0),"^") S $P(RETURN,"^",I)=$P(RETURN,"^",I)+$P(DGBTRET(0),"^",I)
Q
;
;****************************************************************************
;***** the following tags are from DGBTRDV1 ***********
;
TFL(DFN,DGBTIBT) ; returns treating facility list (pass IBT by reference)
; supported references ia #2990 and #10112, value returned is count
; needed to N Y because VAFCTFU1 will kill it
N DGBTIBC,DGBTIBZ,DGBTIBS,DGBTIBFT
;
D TFL^VAFCTFU1(.DGBTIBZ,DFN) Q:-$G(DGBTIBZ(1))=1 0
S DGBTIBS=+$P($$SITE,"^",3),(DGBTIBZ,DGBTIBC)=0
; Return only remote facilities of certain types:
F S DGBTIBZ=$O(DGBTIBZ(DGBTIBZ)) Q:DGBTIBZ<1 D
.I $P(DGBTIBZ(DGBTIBZ),"^",3)="" Q
.I $E($P(DGBTIBZ(DGBTIBZ),"^",3),1,5)'=$E(DGBTDT,1,5) Q
.I +DGBTIBZ(DGBTIBZ)>0,+DGBTIBZ(DGBTIBZ)'=DGBTIBS S DGBTIBT(+DGBTIBZ(DGBTIBZ))=DGBTIBZ(DGBTIBZ),DGBTIBC=DGBTIBC+1
Q DGBTIBC
;
SITE() ; returns site number and info
Q $$SITE^VASITE
;
;
ICN(DFN) ; returns icn for dfn ia #2701 and #2702
N DGBTIBICN
I '$L($T(GETICN^MPIF001)) Q 0 ; mpi not installed
S DGBTIBICN=$$MPINODE^MPIFAPI(+DFN) Q:$P(DGBTIBICN,"^",4) 0 ; local icn
S DGBTIBICN=$$GETICN^MPIF001(+DFN)
Q $S(DGBTIBICN>0:DGBTIBICN,1:0)
;
DFN(DGBTIBICN) ; returns dfn for icn ia #2701
N DFN ; check to see if mpi software installed
S DFN=$S($L($T(GETDFN^MPIF001)):+$$GETDFN^MPIF001(+DGBTIBICN),1:0)
Q $S(DFN>0:DFN,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTRDV 4985 printed Nov 22, 2024@16:51:16 Page 2
DGBTRDV ;ALB/BLD,KAR - Beneficiary Travel information VIA RDV ;1/16/19 14:05
+1 ;;1.0;Beneficiary Travel;**20,35**;September 25, 2001;Build 18
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine is used to exchange insurance information between
+5 ; facilities.
+6 ;
+7 ;COPIED FROM IBCNRDV **************
+8 ;
+9 QUIT
+10 ;
OPT(DFN,DGBTDTI) ; Menu option entry point.
+1 ; information about from the remote treating facilities.
+2 NEW DIC,X,Y,DTOUT,DUOUT,%,%Y,DGBTIEN,VADM,DGBTIBB,DGBTD,DGBTIBI,DGBTICN,DGBTIBRZ,DGBTDGBTIBY,DGBTZ,DGBTWAIT,DGBTIBI
+3 NEW DO,DGBTYPE,DGBTIB1,DGBTRPC,DGBTR,RET,DGBTHDL
+4 ;
+5 KILL ^TMP("DGBTRDV"),^TMP("BARRY")
+6 ;
+7 ;this tell's the system not to run in back ground. it has to be a foreground job
SET (RDVMSG,DGBTYPE)=0
+8 ; prompt for patient
+9 ;
BACKGND ; background/tasked entry point
+1 ; DGBTYPE is being used as a flag to indicate this is running in background
+2 ; DGBTRDV is array of treating facilities
+3 ; look up treating facilities
+4 KILL DGBTRDV
SET DGBTRDV=$$TFL(DFN,.DGBTRDV)
+5 IF DGBTRDV<1
IF $DATA(DGBTYPE)
SET RDVMSG=1
WRITE !!,"This patient has no remote treating facilities to query."
QUIT
+6 IF DGBTRDV<1
QUIT
+7 ;
+8 ; get ICN
+9 ; DGBTICN - is the patients ICN
+10 SET DGBTICN=$$ICN(DFN)
IF 'DGBTICN
IF '$DATA(DGBTYPE)
SET RDVMSG=1
WRITE !!,"No ICN for this patient"
QUIT
+11 IF 'DGBTICN
QUIT
+12 ;
+13 ; sent off the remote queries and get back handles
+14 ; DGBTRPC is name of RPC in file 8994
+15 ; DGBTIEN is IEN of the treating facilities array
+16 ; DGBTRET - the array that contains the return data
+17 ;
+18 SET DGBTRPC="DGBT CLAIM DEDUCTIBLE PAID"
+19 SET DGBTIEN=0
FOR
SET DGBTIEN=$ORDER(DGBTRDV(DGBTIEN))
if DGBTIEN<1
QUIT
Begin DoDot:1
+20 DO SEND(.DGBTRET,DGBTIEN,DGBTICN,DGBTRPC,DGBTDTI)
+21 XECUTE $SELECT(DGBTRET(0)'="":"S $P(DGBTRDV(DGBTIEN),U,5)=DGBTRET(0)",1:"W:'$D(DGBTYPE) !,""No handle returned for "",$P(DGBTRDV(DGBTIEN),U,2) K DGBTRDV(DGBTIEN)")
End DoDot:1
+22 ;
+23 ; no handles returned
+24 IF $DATA(DGBTRDV)<9
IF $DATA(DGBTYPE)
SET RDVMSG=1
WRITE !!,"Unable to perform any remote queries.",!
QUIT
+25 IF $DATA(DGBTRDV)<9
QUIT
+26 ;
+27 ; go through every DGBTRDV()
+28 SET DGBTIBRZ="|"
SET DGBTIEN=0
+29 FOR
SET DGBTIEN=$ORDER(DGBTRDV(DGBTIEN))
if DGBTIEN<1!($DATA(DGBTRDV)<9)
QUIT
Begin DoDot:1
+30 ;
+31 ; do I have a return data.
+32 FOR DGBTWAIT=1:1:30
if $DATA(DGBTYPE)
WRITE "."
HANG 1
DO CHECK(.DGBTR,$PIECE(DGBTRDV(DGBTIEN),"^",5))
IF $GET(DGBTR(0))["Done"
QUIT
+33 IF $GET(DGBTR(0))'["Done"
if $DATA(DGBTYPE)
SET RDVMSG=1
if $DATA(DGBTYPE)
WRITE !!,"Unable to communicate with ",$PIECE(DGBTRDV(DGBTIEN),U,2)
QUIT
+34 DO RETURN(.DGBTR,$PIECE(DGBTRDV(DGBTIEN),"^",5))
+35 ;
+36 ; no data returned or error message
+37 SET DGBTIBRZ=$SELECT(-1=+$GET(DGBTR):DGBTR,$GET(DGBTR(0))="":$GET(DGBTR(1)),1:$GET(DGBTR(0)))
+38 ;
+39 ; no info to proceed
+40 IF DGBTIBRZ<1
SET RDVMSG=1
if '$DATA(DGBTYPE)
WRITE !,"Response from ",$PIECE(DGBTRDV(DGBTX),U,2),!,$PIECE(DGBTIBRZ,"^",2)
KILL DGBTRDV(DGBTIEN)
QUIT
+41 IF DGBTIBRZ<1
KILL DGBTRDV(DGBTIEN)
QUIT
+42 ;
End DoDot:1
+43 ;
+44 QUIT
+45 ;
RPC(DGBTRET,DGBTICN,DGBTDTI) ; RPC entry for Beneficiary Travel Claims for a given month
+1 ;KAR 07/08/18 Removed output parameter from input
NEW DFN
KILL DGBTRET
+2 SET ^TMP("FROM CHEY246",$HOROLOG)=""
+3 SET DFN=$$DFN(DGBTICN)
IF 'DFN
SET DGBTRET="-1^ICN Not found"
QUIT
+4 SET DGBTRET(0)=$$WAIV^DGBTRDVW(DFN,DGBTDTI)
+5 IF $GET(DGBTRET(0))=""
SET DGBTRDV="-1^No BT Claims on File"
QUIT
+6 ; set up return format
+7 ;
+8 QUIT
+9 ;
SEND(DGBTRET,DGBTIEN,DGBTICN,DGBTRPC,DGBTDTI) ; called to send off queries
+1 DO EN1^XWB2HL7(.DGBTRET,DGBTIEN,DGBTRPC,"",DGBTICN,DGBTDTI)
+2 QUIT
+3 ;
CHECK(DGBTRET,DGBTHDL) ; called to check the return status of an RPC
+1 DO RPCCHK^XWB2HL7(.DGBTRET,DGBTHDL)
+2 QUIT
+3 ;
RETURN(DGBTRTN,DGBTHDL) ; called to get the return data and clear the broker
+1 NEW I,DGBTZ
+2 DO RTNDATA^XWBDRPC(.DGBTRET,DGBTHDL)
DO CLEAR^XWBDRPC(.DGBTZ,DGBTHDL)
+3 FOR I=1:1:$LENGTH(DGBTRET(0),"^")
SET $PIECE(RETURN,"^",I)=$PIECE(RETURN,"^",I)+$PIECE(DGBTRET(0),"^",I)
+4 QUIT
+5 ;
+6 ;****************************************************************************
+7 ;***** the following tags are from DGBTRDV1 ***********
+8 ;
TFL(DFN,DGBTIBT) ; returns treating facility list (pass IBT by reference)
+1 ; supported references ia #2990 and #10112, value returned is count
+2 ; needed to N Y because VAFCTFU1 will kill it
+3 NEW DGBTIBC,DGBTIBZ,DGBTIBS,DGBTIBFT
+4 ;
+5 DO TFL^VAFCTFU1(.DGBTIBZ,DFN)
if -$GET(DGBTIBZ(1))=1
QUIT 0
+6 SET DGBTIBS=+$PIECE($$SITE,"^",3)
SET (DGBTIBZ,DGBTIBC)=0
+7 ; Return only remote facilities of certain types:
+8 FOR
SET DGBTIBZ=$ORDER(DGBTIBZ(DGBTIBZ))
if DGBTIBZ<1
QUIT
Begin DoDot:1
+9 IF $PIECE(DGBTIBZ(DGBTIBZ),"^",3)=""
QUIT
+10 IF $EXTRACT($PIECE(DGBTIBZ(DGBTIBZ),"^",3),1,5)'=$EXTRACT(DGBTDT,1,5)
QUIT
+11 IF +DGBTIBZ(DGBTIBZ)>0
IF +DGBTIBZ(DGBTIBZ)'=DGBTIBS
SET DGBTIBT(+DGBTIBZ(DGBTIBZ))=DGBTIBZ(DGBTIBZ)
SET DGBTIBC=DGBTIBC+1
End DoDot:1
+12 QUIT DGBTIBC
+13 ;
SITE() ; returns site number and info
+1 QUIT $$SITE^VASITE
+2 ;
+3 ;
ICN(DFN) ; returns icn for dfn ia #2701 and #2702
+1 NEW DGBTIBICN
+2 ; mpi not installed
IF '$LENGTH($TEXT(GETICN^MPIF001))
QUIT 0
+3 ; local icn
SET DGBTIBICN=$$MPINODE^MPIFAPI(+DFN)
if $PIECE(DGBTIBICN,"^",4)
QUIT 0
+4 SET DGBTIBICN=$$GETICN^MPIF001(+DFN)
+5 QUIT $SELECT(DGBTIBICN>0:DGBTIBICN,1:0)
+6 ;
DFN(DGBTIBICN) ; returns dfn for icn ia #2701
+1 ; check to see if mpi software installed
NEW DFN
+2 SET DFN=$SELECT($LENGTH($TEXT(GETDFN^MPIF001)):+$$GETDFN^MPIF001(+DGBTIBICN),1:0)
+3 QUIT $SELECT(DFN>0:DFN,1:0)
+4 ;
