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

IBCNBU1.m

Go to the documentation of this file.
  1. IBCNBU1 ;ALB/ARH-Ins Buffer: Utilities ;1 Jun 97
  1. ;;2.0;INTEGRATED BILLING;**82,184,263,438,497**;21-MAR-94;Build 120
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. BUFFER(DFN) ; returns IFN of first buffer entry found for the patient, 0 otherwise
  1. Q +$O(^IBA(355.33,"C",+$G(DFN),0))
  1. ;
  1. SELINS() ; user select an insurance company
  1. N IBX,DIE,DTOUT,DUOUT,DIC,X,Y S IBX=0
  1. S DIC="^DIC(36,",DIC(0)="AEQ",DIC("A")="Select INSURANCE COMPANY: ",DIC("S")="I '$P(^(0),U,5)" D ^DIC
  1. I +Y>0 S IBX=Y
  1. Q IBX
  1. ;
  1. SELGRP(IBINSDA) ; given a specific insurance company, allow user to choose a group/plan
  1. N IBX,DIE,DTOUT,DUOUT,DIC,X,Y,IBINSNM S IBX=0
  1. S IBINSNM=$P($G(^DIC(36,+IBINSDA,0)),U,1)
  1. W !,IBINSNM
  1. S X=IBINSNM,DIC="^IBA(355.3,",DIC(0)="EQ",DIC("S")="I +^(0)="_+IBINSDA_"&('$P(^(0),U,11))" D ^DIC
  1. I +Y>0 S IBX=Y
  1. Q IBX
  1. ;
  1. SELEXT(DFN) ; user select existing ins co, group, and if the patient is a member of the group also return the policy
  1. N IBX,IBINSDA,IBGRPDA,IBPOLDA S (IBINSDA,IBGRPDA,IBPOLDA)=""
  1. S IBINSDA=$$SELINS() S IBX=+IBINSDA
  1. I +IBINSDA S IBGRPDA=$$SELGRP(+IBINSDA) I +IBGRPDA S IBX=IBX_U_+IBGRPDA
  1. I +IBGRPDA,+$G(DFN) S IBPOLDA=$$PTGRP(DFN,IBINSDA,IBGRPDA) I +IBPOLDA S IBX=IBX_U_+IBPOLDA
  1. Q IBX
  1. ;
  1. PTGRP(DFN,IBINSDA,IBGRPDA) ; return policy ifn if patient is a member of this group plan
  1. N IBX,IBY S IBX=0,DFN=+$G(DFN),IBINSDA=+$G(IBINSDA),IBGRPDA=+$G(IBGRPDA)
  1. S IBY=0 F S IBY=$O(^DPT(DFN,.312,"B",IBINSDA,IBY)) Q:'IBY I +$P($G(^DPT(DFN,.312,IBY,0)),U,18)=IBGRPDA S IBX=IBY
  1. Q IBX
  1. ;
  1. DISPBUF(IBBUFDA) ; display summary info on a buffer entry
  1. ;
  1. Q:'$G(IBBUFDA)
  1. N IB0,IB60,IB90 S IB0=$G(^IBA(355.33,IBBUFDA,0)) Q:IB0=""
  1. S IB60=$G(^IBA(355.33,IBBUFDA,60)),IB90=$G(^IBA(355.33,IBBUFDA,90)) ;WCJ;IB*2*497 used new fields for SUB ID and GROUP#
  1. ;
  1. W !,"--------------------------------------------------------------------------------"
  1. W !,?2,"Entered: ",?15,$$FMTE^XLFDT(+IB0,2),?50,"Source: ",?60,$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3))
  1. W !,?2,"Entered By: ",?15,$$EXPAND^IBTRE(355.33,.02,+$P(IB0,U,2)),?50,"Verified: ",?60,$$FMTE^XLFDT($P(IB0,U,10),2)
  1. I +$P(IB0,U,10) W !,?50,"Verif By: ",?60,$E($$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)),1,20)
  1. W !!,?2,"Patient: ",?15,$$EXPAND^IBTRE(355.33,60.01,$P(IB60,U,1)),?50,"Sub Id: ",?60,$E($P(IB90,U,3),1,19)
  1. W !,?2,"Insurance: ",?15,$P($G(^IBA(355.33,+IBBUFDA,20)),U,1),?50,"Group #: ",?60,$E($P(IB90,U,2),1,19)
  1. W !,?15,$P($G(^IBA(355.33,+IBBUFDA,21)),U,1)
  1. W !,"--------------------------------------------------------------------------------"
  1. Q
  1. ;
  1. LOCK(IBBUFDA,DISP,TO) ; return true if able to lock the buffer entry, if not an DISP is true then will display a message
  1. ; TO - lock attempt time out & hang time in seconds, default to 4
  1. N IBX S IBX=0
  1. S TO=$G(TO,4)
  1. I +$G(IBBUFDA) L +^IBA(355.33,+IBBUFDA):TO I +$T S IBX=1
  1. I 'IBX,+$G(DISP) W !!,"Another user is currently editing/processing this entry, please try again later.",! H TO
  1. I IBX D
  1. .; eIV real time inquiries temp. global
  1. .K ^TMP("IBCNERTQ",$J,+IBBUFDA)
  1. .S ^TMP("IBCNERTQ",$J,+IBBUFDA,"LOCK")=1
  1. .Q
  1. Q IBX
  1. ;
  1. UNLOCK(IBBUFDA) ; unlock a Buffer entry
  1. K ^TMP("IBCNERTQ",$J,+IBBUFDA,"LOCK")
  1. I $G(^TMP("IBCNERTQ",$J,+IBBUFDA,"TRIGGER"))=1 D
  1. .; eIV real time inquiry
  1. .N TQIEN,RESPONSE,DIE,DA,DR,X,Y
  1. .S RESPONSE=0
  1. .; create an entry in eIV transmision queue
  1. .S TQIEN=$$IBE^IBCNERTQ(+IBBUFDA)
  1. .; Load and Send HL7 Message
  1. .I TQIEN S RESPONSE=$$PROCSEND^IBCNERTQ(TQIEN)
  1. .; set field 355.33/.16 (real time verification)
  1. .S DIE="^IBA(355.33,",DA=+IBBUFDA,DR=".16////^S X=RESPONSE" D ^DIE
  1. .K ^TMP("IBCNERTQ",$J,+IBBUFDA,"TRIGGER")
  1. .Q
  1. L -^IBA(355.33,+IBBUFDA)
  1. Q
  1. ;
  1. DICINS(INSNAME,IBSCACT,IBLISTN) ; user search/selection of existing Insurance Company Names, does not list duplicates, based on names and synonyms
  1. ;
  1. ; Input parameters
  1. ; INSNAME - user input; partial name match of insurance company
  1. ; IBSCACT - 0/1 flag indicating if inactive insurance companies
  1. ; should get screened out during the list building
  1. ; Default is 0 (no screen)
  1. ; IBLISTN - number of entries to display in the lister before
  1. ; giving the user a chance to select. Default is 4.
  1. ; Output
  1. ; returns Ins name, or -1 if ^, or 0 if none selected
  1. ;
  1. S IBSCACT=$G(IBSCACT,0) ; flag to screen out inactive ins
  1. S IBLISTN=$G(IBLISTN,4) ; number of list entries before user selection
  1. ;
  1. N IBX,IBINB,IBCX,IBSEL,IBXRF,IBNAME,IBSYNM,IBCNT,IBC1,IBINSIEN,IBLINE
  1. S IBSEL=0 K ^TMP($J,"IBINSS"),^TMP($J,"IBINSSB") I INSNAME="" G DINSQ
  1. ;
  1. S INSNAME=$$UP^XLFSTR(INSNAME),IBX=$L(INSNAME),IBINB=$E(INSNAME,1,(IBX-1))_$C($A($E(INSNAME,IBX))-1)_"~"
  1. ;
  1. F IBCX="C","B" S IBXRF=IBINB D
  1. . F S IBXRF=$O(^DIC(36,IBCX,IBXRF)) Q:IBXRF=""!($E(IBXRF,1,IBX)'=INSNAME) D
  1. .. S IBINSIEN=0
  1. .. F S IBINSIEN=+$O(^DIC(36,IBCX,IBXRF,IBINSIEN)) Q:'IBINSIEN D
  1. ... I '$D(^DIC(36,IBINSIEN,0)) Q ; bad xref entry?
  1. ... I IBSCACT,$P($G(^DIC(36,IBINSIEN,0)),U,5) Q ; inactive
  1. ... I IBSCACT,$P($G(^DIC(36,IBINSIEN,5)),U,1) Q ; scheduled for deletion
  1. ... S IBNAME=$P($G(^DIC(36,IBINSIEN,0)),U,1)
  1. ... I IBNAME="" Q
  1. ... I $D(^TMP($J,"IBINSSB",IBNAME)) Q
  1. ... S ^TMP($J,"IBINSSB",IBNAME)=$S(IBNAME=IBXRF:"",1:IBXRF)
  1. ... Q
  1. ;
  1. S IBCNT=0,IBX="" F S IBX=$O(^TMP($J,"IBINSSB",IBX)) Q:IBX="" S IBCNT=IBCNT+1,^TMP($J,"IBINSS",IBCNT)=IBX
  1. ;
  1. S (IBCNT,IBC1)=0 F S IBCNT=$O(^TMP($J,"IBINSS",IBCNT)) Q:'IBCNT D I +IBSEL Q
  1. . S IBNAME=^TMP($J,"IBINSS",IBCNT) Q:IBNAME="" S IBSYNM=$G(^TMP($J,"IBINSSB",IBNAME))
  1. . S IBLINE=$J(IBCNT,7)_" "_$$FO^IBCNEUT1(IBNAME,40)_IBSYNM
  1. . DO EN^DDIOL(IBLINE)
  1. . S IBC1=IBC1+1 I '(IBCNT#IBLISTN) S IBSEL=$$DIR(IBC1)
  1. . Q
  1. ;
  1. I 'IBSEL,+(IBC1#IBLISTN) S IBSEL=$$DIR(IBC1)
  1. ;
  1. I IBSEL>0 S IBSEL=$G(^TMP($J,"IBINSS",IBSEL))
  1. ;
  1. DINSQ K ^TMP($J,"IBINSS"),^TMP($J,"IBCNSSB")
  1. Q IBSEL
  1. ;
  1. DIR(MAX) ; DIR call for DICINS search for insurance company name
  1. N DIR,DIRUT,DTOUT,DUOUT,IBX,X,Y S IBX=0,DIR(0)="LOA^1:"_MAX_"^K:X'>0!(X>"_MAX_") X",DIR("A")="CHOOSE 1-"_MAX_": "
  1. I $G(MAX)>0 D ^DIR K DIR S IBX=$S($D(DTOUT)!$D(DUOUT):-1,+Y:+Y,1:0)
  1. Q IBX
  1. ;
  1. DICBUF(INSNAME,DFN,IBDUZ) ; display list of editable buffer entries based on insurance name, may specify patient and/or enterer
  1. ; (non-MCCR people: only the person that created an entry should be able to edit it, everyone else should create new ones)
  1. N X,Y,IBX,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,D S IBX=0
  1. ;
  1. S DIC("W")="W "" "",$P($G(^(20)),U,1),"" "",$P($G(^(21)),U,1)"
  1. S DIC("S")="I $P(^(0),U,4)=""E""&('$P(^(0),U,10))" S:+$G(IBDUZ) DIC("S")=DIC("S")_"&(+$P(^(0),U,2)="_IBDUZ_")" S:+$G(DFN) DIC("S")=DIC("S")_"&(+$G(^(60))="_DFN_")"
  1. S DIC="^IBA(355.33,",DIC(0)="EM",X=$$UP^XLFSTR($G(INSNAME)),D="D" D IX^DIC I '$D(DTOUT),'$D(DUOUT),+Y>0 S IBX=+Y
  1. Q IBX