IBARXMU ;LL/ELZ-PHARMACY COPAY CAP UTILITIES ;17-NOV-2000
;;2.0;INTEGRATED BILLING;**150,158,156,178,186,676,717**;21-MAR-94;Build 1
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
PRIORITY(DFN) ; returns the patient's priority level, ia #2918 for DGENA
Q +$$PRIORITY^DGENA(DFN)
;
FAC(X) ; returns facility information ia #2171
Q $$NNT^XUAF4(X)
;
SITE() ; returns site number and info
Q $$SITE^VASITE
;
TFL(DFN,IBT,CCR) ; 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
;676/BL; As part of patch IB*2.0*676 a new parameter is being added to this call
;CCR will specify in this call if the array returned will contain Sites that have
;been converted to Cerner or not. The DEFAULT will be to return Converted sites and
;not return Cerner.
; CCR=0 - Remove Converted sites Remove Cerner site in list
; CCR=1 - Remove Converted sites, Leave Cerner site
; CCR=2 - Leave Converted sites, Leave Cerner site
; CCR=3 (Default)- Leave Converted sites, Remove Cerner site in list
;
N IBC,IBZ,IBS,IBFT,Y,CON,IBA
S:$G(CCR)="" CCR=3 ;Cerner Check, default
;
D TFL^VAFCTFU1(.IBZ,DFN) Q:-$G(IBZ(1))=1 0
S IBS=+$P($$SITE,"^",3),(IBZ,IBC)=0
;
;676;BL; The VAFCTFU1 and VAFCTFU2 utilities must be reconciled this utility will remove any site
;not returned in the VAFCTFU2 utility. VAFCTFU2 is no considered the source of truth
S IBZ=$$TFL^IBARXCFL(.IBZ,DFN,CCR) ;IBZ is changed to contain only the sites in VAFCTFU2
Q:IBZ=0 0
;
S IBFT="^VAMC^M&ROC^RO-OC^"
S IBZ=0,IBC=0
F S IBZ=$O(IBZ(IBZ)) Q:IBZ<1 I +IBZ(IBZ)>0,+IBZ(IBZ)'=IBS,IBFT[("^"_$P(IBZ(IBZ),U,5)_"^") S IBT(+IBZ(IBZ))=IBZ(IBZ),IBC=IBC+1
Q IBC
;
ADD(X) ; adds patient to 354.7
N DO,DIC,DINUM,DA,Y
Q:$G(^IBAM(354.7,X,0))
L +^IBAM(354.7,X):10 I '$T S Y="-1^IB319" Q
S DIC="^IBAM(354.7,",DIC(0)="",DINUM=X D FILE^DICN
L -^IBAM(354.7,X)
Q
QUERY(DFN,IBM,IBF,IBD) ; looks up copay billing info from remote facility
; IBM is the month and year for the query
; IBF is the remote facility to query
; IBD is the place where to return (pass by ref)
; ia #3144
N IBICN,Y,DA,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT,PHONE,RPCIEN,IO,IOBS,IOCPU,IOF,IOHG,IOM,ION,IOPAR,IOUPAR,IOS,IOSL,IOST,IOT,IOXY,POP
D
. S IBICN=$$ICN(DFN) Q:'IBICN
. D DIRECT^XWB2HL7(.IBD,IBF,"IBARXM QUERY ONLY","",IBICN,IBM)
Q
;
UQUERY(DFN,IBM,IBF,IBD) ; looks up copay billing info from remote facility
; this is just like the QUERY tag except it is only for background
; info only and user information is not logged into the remote site's
; new person file.
; IBM is the month and year for the query
; IBF is the remote facility to query
; IBD is the place where to return (pass by ref)
; ia #3144
N IBICN,Y,DA,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT,PHONE,RPCIEN,IO,IOBS,IOCPU,IOF,IOHG,IOM,ION,IOPAR,IOUPAR,IOS,IOSL,IOST,IOT,IOXY,POP
D
. S IBICN=$$ICN(DFN) Q:'IBICN
. D DIRECT^XWB2HL7(.IBD,IBF,"IBARXM QUERY SUPPRESS USER","",IBICN,IBM)
Q
;
SEND(DFN,IBF,IBD) ; notifies a remote facility of new or updated data
; IBF is the remote facility to query
; IBD is the data to send
; return is accepted or not
; ia #3144
N IBR,IBICN,IBH,IBC,IBZ,Y,DA,DIC,HLECH,HLFS,HLHDR,HLN,HLQ,HLSAN,HLTYPE,HLX,PTR,ROUTINE,ZMID,%
;
D
. I DUZ=.5 N DUZ S DUZ=$P(IBD,"^",16),DUZ(2)=+$$SITE
. S IBICN=$$ICN(DFN) I 'IBICN S IBR="-1^No ICN for patient" Q
. ;
. D SENDF(.IBD)
. D EN1^XWB2HL7(.IBH,IBF,"IBARXM TRANS DATA","",IBICN,IBD)
. I $G(IBH(0))="" S IBR="-1^No handle returned from RPC" Q
. ; wait a second then start looking for Done flag.
. H 1
. F IBC=1:1:10 D RPCCHK^XWB2HL7(.IBR,IBH(0)) Q:$G(IBR(0))["Done" H 2
. ; if done get data.
. I $G(IBR(0))["Done" D
.. K IBR
.. D RTNDATA^XWBDRPC(.IBR,IBH(0)),CLEAR^XWBDRPC(.IBZ,IBH(0))
;
Q $S(-1=+$G(IBR):IBR,$G(IBR(0))="":$G(IBR(1)),1:$G(IBR(0)))
;
DFN(IBICN) ; returns dfn for icn ia #2701
N DFN ; check to see if mpi software installed
S DFN=$S($L($T(GETDFN^MPIF001)):+$$GETDFN^MPIF001(+IBICN),1:0)
Q $S(DFN>0:DFN,1:0)
;
ICN(DFN) ; returns icn for dfn ia #2701 and #2702
N IBICN
I '$L($T(GETICN^MPIF001)) Q 0 ; mpi not installed
S IBICN=$$MPINODE^MPIFAPI(+DFN) Q:$P(IBICN,"^",4) 0 ; local icn
S IBICN=$$GETICN^MPIF001(+DFN)
Q $S(IBICN>0:IBICN,1:0)
;
SENDF(IBD) ; formats data for sending 354.71 data
; call with raw data from 354.71 by ref to reformat it for transmission
S $P(IBD,"^",4,5)=U_$S($P(IBD,"^",5)="P"!($P(IBD,"^",5)="C"):"C",1:"X")
S:$P(IBD,"^",10) $P(IBD,"^",10)=$P(^IBAM(354.71,$P(IBD,"^",10),0),"^")
S $P(IBD,"^",13)=$P($$FAC($P(IBD,"^",13)),"^",2)
S IBD=$P(IBD,"^",1,13)
Q
;
EFDT(X,Y) ; sets in Y the effective date to be used for updates
N Z S Z=$P($G(^IBAM(354.71,+$P($G(^IB(+X,0)),"^",19),0)),"^",3)
S:Z Y(X)=Z
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMU 5021 printed Dec 13, 2024@02:07:40 Page 2
IBARXMU ;LL/ELZ-PHARMACY COPAY CAP UTILITIES ;17-NOV-2000
+1 ;;2.0;INTEGRATED BILLING;**150,158,156,178,186,676,717**;21-MAR-94;Build 1
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
PRIORITY(DFN) ; returns the patient's priority level, ia #2918 for DGENA
+1 QUIT +$$PRIORITY^DGENA(DFN)
+2 ;
FAC(X) ; returns facility information ia #2171
+1 QUIT $$NNT^XUAF4(X)
+2 ;
SITE() ; returns site number and info
+1 QUIT $$SITE^VASITE
+2 ;
TFL(DFN,IBT,CCR) ; 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 ;676/BL; As part of patch IB*2.0*676 a new parameter is being added to this call
+4 ;CCR will specify in this call if the array returned will contain Sites that have
+5 ;been converted to Cerner or not. The DEFAULT will be to return Converted sites and
+6 ;not return Cerner.
+7 ; CCR=0 - Remove Converted sites Remove Cerner site in list
+8 ; CCR=1 - Remove Converted sites, Leave Cerner site
+9 ; CCR=2 - Leave Converted sites, Leave Cerner site
+10 ; CCR=3 (Default)- Leave Converted sites, Remove Cerner site in list
+11 ;
+12 NEW IBC,IBZ,IBS,IBFT,Y,CON,IBA
+13 ;Cerner Check, default
if $GET(CCR)=""
SET CCR=3
+14 ;
+15 DO TFL^VAFCTFU1(.IBZ,DFN)
if -$GET(IBZ(1))=1
QUIT 0
+16 SET IBS=+$PIECE($$SITE,"^",3)
SET (IBZ,IBC)=0
+17 ;
+18 ;676;BL; The VAFCTFU1 and VAFCTFU2 utilities must be reconciled this utility will remove any site
+19 ;not returned in the VAFCTFU2 utility. VAFCTFU2 is no considered the source of truth
+20 ;IBZ is changed to contain only the sites in VAFCTFU2
SET IBZ=$$TFL^IBARXCFL(.IBZ,DFN,CCR)
+21 if IBZ=0
QUIT 0
+22 ;
+23 SET IBFT="^VAMC^M&ROC^RO-OC^"
+24 SET IBZ=0
SET IBC=0
+25 FOR
SET IBZ=$ORDER(IBZ(IBZ))
if IBZ<1
QUIT
IF +IBZ(IBZ)>0
IF +IBZ(IBZ)'=IBS
IF IBFT[("^"_$PIECE(IBZ(IBZ),U,5)_"^")
SET IBT(+IBZ(IBZ))=IBZ(IBZ)
SET IBC=IBC+1
+26 QUIT IBC
+27 ;
ADD(X) ; adds patient to 354.7
+1 NEW DO,DIC,DINUM,DA,Y
+2 if $GET(^IBAM(354.7,X,0))
QUIT
+3 LOCK +^IBAM(354.7,X):10
IF '$TEST
SET Y="-1^IB319"
QUIT
+4 SET DIC="^IBAM(354.7,"
SET DIC(0)=""
SET DINUM=X
DO FILE^DICN
+5 LOCK -^IBAM(354.7,X)
+6 QUIT
QUERY(DFN,IBM,IBF,IBD) ; looks up copay billing info from remote facility
+1 ; IBM is the month and year for the query
+2 ; IBF is the remote facility to query
+3 ; IBD is the place where to return (pass by ref)
+4 ; ia #3144
+5 NEW IBICN,Y,DA,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT,PHONE,RPCIEN,IO,IOBS,IOCPU,IOF,IOHG,IOM,ION,IOPAR,IOUPAR,IOS,IOSL,IOST,IOT,IOXY,POP
+6 Begin DoDot:1
+7 SET IBICN=$$ICN(DFN)
if 'IBICN
QUIT
+8 DO DIRECT^XWB2HL7(.IBD,IBF,"IBARXM QUERY ONLY","",IBICN,IBM)
End DoDot:1
+9 QUIT
+10 ;
UQUERY(DFN,IBM,IBF,IBD) ; looks up copay billing info from remote facility
+1 ; this is just like the QUERY tag except it is only for background
+2 ; info only and user information is not logged into the remote site's
+3 ; new person file.
+4 ; IBM is the month and year for the query
+5 ; IBF is the remote facility to query
+6 ; IBD is the place where to return (pass by ref)
+7 ; ia #3144
+8 NEW IBICN,Y,DA,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT,PHONE,RPCIEN,IO,IOBS,IOCPU,IOF,IOHG,IOM,ION,IOPAR,IOUPAR,IOS,IOSL,IOST,IOT,IOXY,POP
+9 Begin DoDot:1
+10 SET IBICN=$$ICN(DFN)
if 'IBICN
QUIT
+11 DO DIRECT^XWB2HL7(.IBD,IBF,"IBARXM QUERY SUPPRESS USER","",IBICN,IBM)
End DoDot:1
+12 QUIT
+13 ;
SEND(DFN,IBF,IBD) ; notifies a remote facility of new or updated data
+1 ; IBF is the remote facility to query
+2 ; IBD is the data to send
+3 ; return is accepted or not
+4 ; ia #3144
+5 NEW IBR,IBICN,IBH,IBC,IBZ,Y,DA,DIC,HLECH,HLFS,HLHDR,HLN,HLQ,HLSAN,HLTYPE,HLX,PTR,ROUTINE,ZMID,%
+6 ;
+7 Begin DoDot:1
+8 IF DUZ=.5
NEW DUZ
SET DUZ=$PIECE(IBD,"^",16)
SET DUZ(2)=+$$SITE
+9 SET IBICN=$$ICN(DFN)
IF 'IBICN
SET IBR="-1^No ICN for patient"
QUIT
+10 ;
+11 DO SENDF(.IBD)
+12 DO EN1^XWB2HL7(.IBH,IBF,"IBARXM TRANS DATA","",IBICN,IBD)
+13 IF $GET(IBH(0))=""
SET IBR="-1^No handle returned from RPC"
QUIT
+14 ; wait a second then start looking for Done flag.
+15 HANG 1
+16 FOR IBC=1:1:10
DO RPCCHK^XWB2HL7(.IBR,IBH(0))
if $GET(IBR(0))["Done"
QUIT
HANG 2
+17 ; if done get data.
+18 IF $GET(IBR(0))["Done"
Begin DoDot:2
+19 KILL IBR
+20 DO RTNDATA^XWBDRPC(.IBR,IBH(0))
DO CLEAR^XWBDRPC(.IBZ,IBH(0))
End DoDot:2
End DoDot:1
+21 ;
+22 QUIT $SELECT(-1=+$GET(IBR):IBR,$GET(IBR(0))="":$GET(IBR(1)),1:$GET(IBR(0)))
+23 ;
DFN(IBICN) ; 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(+IBICN),1:0)
+3 QUIT $SELECT(DFN>0:DFN,1:0)
+4 ;
ICN(DFN) ; returns icn for dfn ia #2701 and #2702
+1 NEW IBICN
+2 ; mpi not installed
IF '$LENGTH($TEXT(GETICN^MPIF001))
QUIT 0
+3 ; local icn
SET IBICN=$$MPINODE^MPIFAPI(+DFN)
if $PIECE(IBICN,"^",4)
QUIT 0
+4 SET IBICN=$$GETICN^MPIF001(+DFN)
+5 QUIT $SELECT(IBICN>0:IBICN,1:0)
+6 ;
SENDF(IBD) ; formats data for sending 354.71 data
+1 ; call with raw data from 354.71 by ref to reformat it for transmission
+2 SET $PIECE(IBD,"^",4,5)=U_$SELECT($PIECE(IBD,"^",5)="P"!($PIECE(IBD,"^",5)="C"):"C",1:"X")
+3 if $PIECE(IBD,"^",10)
SET $PIECE(IBD,"^",10)=$PIECE(^IBAM(354.71,$PIECE(IBD,"^",10),0),"^")
+4 SET $PIECE(IBD,"^",13)=$PIECE($$FAC($PIECE(IBD,"^",13)),"^",2)
+5 SET IBD=$PIECE(IBD,"^",1,13)
+6 QUIT
+7 ;
EFDT(X,Y) ; sets in Y the effective date to be used for updates
+1 NEW Z
SET Z=$PIECE($GET(^IBAM(354.71,+$PIECE($GET(^IB(+X,0)),"^",19),0)),"^",3)
+2 if Z
SET Y(X)=Z
+3 QUIT
