Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXMU

IBARXMU.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. PRIORITY(DFN) ; returns the patient's priority level, ia #2918 for DGENA
  1. Q +$$PRIORITY^DGENA(DFN)
  1. ;
  1. FAC(X) ; returns facility information ia #2171
  1. Q $$NNT^XUAF4(X)
  1. ;
  1. SITE() ; returns site number and info
  1. Q $$SITE^VASITE
  1. ;
  1. TFL(DFN,IBT,CCR) ; returns treating facility list (pass IBT by reference)
  1. ; supported references ia #2990 and #10112, value returned is count
  1. ; needed to N Y because VAFCTFU1 will kill it
  1. ;676/BL; As part of patch IB*2.0*676 a new parameter is being added to this call
  1. ;CCR will specify in this call if the array returned will contain Sites that have
  1. ;been converted to Cerner or not. The DEFAULT will be to return Converted sites and
  1. ;not return Cerner.
  1. ; CCR=0 - Remove Converted sites Remove Cerner site in list
  1. ; CCR=1 - Remove Converted sites, Leave Cerner site
  1. ; CCR=2 - Leave Converted sites, Leave Cerner site
  1. ; CCR=3 (Default)- Leave Converted sites, Remove Cerner site in list
  1. ;
  1. N IBC,IBZ,IBS,IBFT,Y,CON,IBA
  1. S:$G(CCR)="" CCR=3 ;Cerner Check, default
  1. ;
  1. D TFL^VAFCTFU1(.IBZ,DFN) Q:-$G(IBZ(1))=1 0
  1. S IBS=+$P($$SITE,"^",3),(IBZ,IBC)=0
  1. ;
  1. ;676;BL; The VAFCTFU1 and VAFCTFU2 utilities must be reconciled this utility will remove any site
  1. ;not returned in the VAFCTFU2 utility. VAFCTFU2 is no considered the source of truth
  1. S IBZ=$$TFL^IBARXCFL(.IBZ,DFN,CCR) ;IBZ is changed to contain only the sites in VAFCTFU2
  1. Q:IBZ=0 0
  1. ;
  1. S IBFT="^VAMC^M&ROC^RO-OC^"
  1. S IBZ=0,IBC=0
  1. 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
  1. Q IBC
  1. ;
  1. ADD(X) ; adds patient to 354.7
  1. N DO,DIC,DINUM,DA,Y
  1. Q:$G(^IBAM(354.7,X,0))
  1. L +^IBAM(354.7,X):10 I '$T S Y="-1^IB319" Q
  1. S DIC="^IBAM(354.7,",DIC(0)="",DINUM=X D FILE^DICN
  1. L -^IBAM(354.7,X)
  1. Q
  1. QUERY(DFN,IBM,IBF,IBD) ; looks up copay billing info from remote facility
  1. ; IBM is the month and year for the query
  1. ; IBF is the remote facility to query
  1. ; IBD is the place where to return (pass by ref)
  1. ; ia #3144
  1. 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
  1. D
  1. . S IBICN=$$ICN(DFN) Q:'IBICN
  1. . D DIRECT^XWB2HL7(.IBD,IBF,"IBARXM QUERY ONLY","",IBICN,IBM)
  1. Q
  1. ;
  1. 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
  1. ; info only and user information is not logged into the remote site's
  1. ; new person file.
  1. ; IBM is the month and year for the query
  1. ; IBF is the remote facility to query
  1. ; IBD is the place where to return (pass by ref)
  1. ; ia #3144
  1. 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
  1. D
  1. . S IBICN=$$ICN(DFN) Q:'IBICN
  1. . D DIRECT^XWB2HL7(.IBD,IBF,"IBARXM QUERY SUPPRESS USER","",IBICN,IBM)
  1. Q
  1. ;
  1. SEND(DFN,IBF,IBD) ; notifies a remote facility of new or updated data
  1. ; IBF is the remote facility to query
  1. ; IBD is the data to send
  1. ; return is accepted or not
  1. ; ia #3144
  1. N IBR,IBICN,IBH,IBC,IBZ,Y,DA,DIC,HLECH,HLFS,HLHDR,HLN,HLQ,HLSAN,HLTYPE,HLX,PTR,ROUTINE,ZMID,%
  1. ;
  1. D
  1. . I DUZ=.5 N DUZ S DUZ=$P(IBD,"^",16),DUZ(2)=+$$SITE
  1. . S IBICN=$$ICN(DFN) I 'IBICN S IBR="-1^No ICN for patient" Q
  1. . ;
  1. . D SENDF(.IBD)
  1. . D EN1^XWB2HL7(.IBH,IBF,"IBARXM TRANS DATA","",IBICN,IBD)
  1. . I $G(IBH(0))="" S IBR="-1^No handle returned from RPC" Q
  1. . ; wait a second then start looking for Done flag.
  1. . H 1
  1. . F IBC=1:1:10 D RPCCHK^XWB2HL7(.IBR,IBH(0)) Q:$G(IBR(0))["Done" H 2
  1. . ; if done get data.
  1. . I $G(IBR(0))["Done" D
  1. .. K IBR
  1. .. D RTNDATA^XWBDRPC(.IBR,IBH(0)),CLEAR^XWBDRPC(.IBZ,IBH(0))
  1. ;
  1. Q $S(-1=+$G(IBR):IBR,$G(IBR(0))="":$G(IBR(1)),1:$G(IBR(0)))
  1. ;
  1. DFN(IBICN) ; returns dfn for icn ia #2701
  1. N DFN ; check to see if mpi software installed
  1. S DFN=$S($L($T(GETDFN^MPIF001)):+$$GETDFN^MPIF001(+IBICN),1:0)
  1. Q $S(DFN>0:DFN,1:0)
  1. ;
  1. ICN(DFN) ; returns icn for dfn ia #2701 and #2702
  1. N IBICN
  1. I '$L($T(GETICN^MPIF001)) Q 0 ; mpi not installed
  1. S IBICN=$$MPINODE^MPIFAPI(+DFN) Q:$P(IBICN,"^",4) 0 ; local icn
  1. S IBICN=$$GETICN^MPIF001(+DFN)
  1. Q $S(IBICN>0:IBICN,1:0)
  1. ;
  1. SENDF(IBD) ; formats data for sending 354.71 data
  1. ; call with raw data from 354.71 by ref to reformat it for transmission
  1. S $P(IBD,"^",4,5)=U_$S($P(IBD,"^",5)="P"!($P(IBD,"^",5)="C"):"C",1:"X")
  1. S:$P(IBD,"^",10) $P(IBD,"^",10)=$P(^IBAM(354.71,$P(IBD,"^",10),0),"^")
  1. S $P(IBD,"^",13)=$P($$FAC($P(IBD,"^",13)),"^",2)
  1. S IBD=$P(IBD,"^",1,13)
  1. Q
  1. ;
  1. EFDT(X,Y) ; sets in Y the effective date to be used for updates
  1. N Z S Z=$P($G(^IBAM(354.71,+$P($G(^IB(+X,0)),"^",19),0)),"^",3)
  1. S:Z Y(X)=Z
  1. Q