- 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 Feb 18, 2025@23:34:04 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