source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBU1.m@ 1800

IBCNBU1 ;ALB/ARH-Ins Buffer: Utilities ;1 Jun 97

 ;;2.0;INTEGRATED BILLING;**82,184,263**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

BUFFER(DFN) ; returns IFN of first buffer entry found for the patient, 0 otherwise

 Q +$O(^IBA(355.33,"C",+$G(DFN),0))

 ;

SELINS() ; user select an insurance company

 N IBX,DIE,DTOUT,DUOUT,DIC,X,Y S IBX=0

 S DIC="^DIC(36,",DIC(0)="AEQ",DIC("A")="Select INSURANCE COMPANY: ",DIC("S")="I '$P(^(0),U,5)" D ^DIC

 I +Y>0 S IBX=Y

 Q IBX

 ;

SELGRP(IBINSDA) ; given a specific insurance company, allow user to choose a group/plan

 N IBX,DIE,DTOUT,DUOUT,DIC,X,Y,IBINSNM S IBX=0

 S IBINSNM=$P($G(^DIC(36,+IBINSDA,0)),U,1)

 W !,IBINSNM

 S X=IBINSNM,DIC="^IBA(355.3,",DIC(0)="EQ",DIC("S")="I +^(0)="_+IBINSDA_"&('$P(^(0),U,11))" D ^DIC

 I +Y>0 S IBX=Y

 Q IBX

 ;

SELEXT(DFN) ; user select existing ins co, group, and if the patient is a member of the group also return the policy

 N IBX,IBINSDA,IBGRPDA,IBPOLDA S (IBINSDA,IBGRPDA,IBPOLDA)=""

 S IBINSDA=$$SELINS() S IBX=+IBINSDA

 I +IBINSDA S IBGRPDA=$$SELGRP(+IBINSDA) I +IBGRPDA S IBX=IBX_U_+IBGRPDA

 I +IBGRPDA,+$G(DFN) S IBPOLDA=$$PTGRP(DFN,IBINSDA,IBGRPDA) I +IBPOLDA S IBX=IBX_U_+IBPOLDA

 Q IBX

 ;

PTGRP(DFN,IBINSDA,IBGRPDA) ; return policy ifn if patient is a member of this group plan

 N IBX,IBY S IBX=0,DFN=+$G(DFN),IBINSDA=+$G(IBINSDA),IBGRPDA=+$G(IBGRPDA)

 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

 Q IBX

 ;

DISPBUF(IBBUFDA) ; display summary info on a buffer entry

 ;

 Q:'$G(IBBUFDA)

 N IB0,IB60 S IB0=$G(^IBA(355.33,IBBUFDA,0)) Q:IB0=""  S IB60=$G(^IBA(355.33,IBBUFDA,60))

 ;

 W !,"--------------------------------------------------------------------------------"

 W !,?2,"Entered: ",?15,$$FMTE^XLFDT(+IB0,2),?50,"Source: ",?60,$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3))

 W !,?2,"Entered By: ",?15,$$EXPAND^IBTRE(355.33,.02,+$P(IB0,U,2)),?50,"Verified: ",?60,$$FMTE^XLFDT($P(IB0,U,10),2)

 I +$P(IB0,U,10) W !,?50,"Verif By: ",?60,$E($$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)),1,20)

 W !!,?2,"Patient: ",?15,$$EXPAND^IBTRE(355.33,60.01,$P(IB60,U,1)),?50,"Sub Id: ",?60,$P(IB60,U,4)

 W !,?2,"Insurance: ",?15,$P($G(^IBA(355.33,+IBBUFDA,20)),U,1),?50,"Group #: ",?60,$P($G(^IBA(355.33,+IBBUFDA,40)),U,3)

 W !,?15,$P($G(^IBA(355.33,+IBBUFDA,21)),U,1)

 W !,"--------------------------------------------------------------------------------"

 Q

 ;

LOCK(IBBUFDA,DISP,TO) ; return true if able to lock the buffer entry, if not an DISP is true then will display a message

 ; TO - lock attempt time out & hang time in seconds, default to 4

 N IBX S IBX=0

 S TO=$G(TO,4)

 I +$G(IBBUFDA) L +^IBA(355.33,+IBBUFDA):TO I +$T S IBX=1

 I 'IBX,+$G(DISP) W !!,"Another user is currently editing/processing this entry, please try again later.",! H TO

 Q IBX

 ;

UNLOCK(IBBUFDA) ; unlock a Buffer entry

 L -^IBA(355.33,+IBBUFDA)

 Q

 ;

DICINS(INSNAME,IBSCACT,IBLISTN) ; user search/selection of existing Insurance Company Names, does not list duplicates, based on names and synonyms

 ;

 ; Input parameters

 ;    INSNAME - user input; partial name match of insurance company

 ;    IBSCACT - 0/1 flag indicating if inactive insurance companies

 ;              should get screened out during the list building

 ;              Default is 0 (no screen)

 ;    IBLISTN - number of entries to display in the lister before

 ;              giving the user a chance to select. Default is 4.

 ; Output

 ;    returns Ins name, or -1 if ^, or 0 if none selected

 ;

 S IBSCACT=$G(IBSCACT,0)  ; flag to screen out inactive ins

 S IBLISTN=$G(IBLISTN,4)  ; number of list entries before user selection

 ;

 N IBX,IBINB,IBCX,IBSEL,IBXRF,IBNAME,IBSYNM,IBCNT,IBC1,IBINSIEN,IBLINE

 S IBSEL=0 K ^TMP($J,"IBINSS"),^TMP($J,"IBINSSB") I INSNAME="" G DINSQ

 ;

 S INSNAME=$$UP^XLFSTR(INSNAME),IBX=$L(INSNAME),IBINB=$E(INSNAME,1,(IBX-1))_$C($A($E(INSNAME,IBX))-1)_"~"

 ;

 F IBCX="C","B" S IBXRF=IBINB D

 . F  S IBXRF=$O(^DIC(36,IBCX,IBXRF)) Q:IBXRF=""!($E(IBXRF,1,IBX)'=INSNAME)  D

 .. S IBINSIEN=0

 .. F  S IBINSIEN=+$O(^DIC(36,IBCX,IBXRF,IBINSIEN)) Q:'IBINSIEN  D

 ... I '$D(^DIC(36,IBINSIEN,0)) Q  ; bad xref entry?

 ... I IBSCACT,$P($G(^DIC(36,IBINSIEN,0)),U,5) Q   ; inactive

 ... I IBSCACT,$P($G(^DIC(36,IBINSIEN,5)),U,1) Q   ; scheduled for deletion

 ... S IBNAME=$P($G(^DIC(36,IBINSIEN,0)),U,1)

 ... I IBNAME="" Q

 ... I $D(^TMP($J,"IBINSSB",IBNAME)) Q

 ... S ^TMP($J,"IBINSSB",IBNAME)=$S(IBNAME=IBXRF:"",1:IBXRF)

 ... Q

 ;

 S IBCNT=0,IBX="" F  S IBX=$O(^TMP($J,"IBINSSB",IBX)) Q:IBX=""  S IBCNT=IBCNT+1,^TMP($J,"IBINSS",IBCNT)=IBX

 ;

 S (IBCNT,IBC1)=0 F  S IBCNT=$O(^TMP($J,"IBINSS",IBCNT)) Q:'IBCNT  D  I +IBSEL Q

 . S IBNAME=^TMP($J,"IBINSS",IBCNT) Q:IBNAME=""  S IBSYNM=$G(^TMP($J,"IBINSSB",IBNAME))

 . S IBLINE=$J(IBCNT,7)_"   "_$$FO^IBCNEUT1(IBNAME,40)_IBSYNM

 . DO EN^DDIOL(IBLINE)

 . S IBC1=IBC1+1 I '(IBCNT#IBLISTN) S IBSEL=$$DIR(IBC1)

 . Q

 ;

 I 'IBSEL,+(IBC1#IBLISTN) S IBSEL=$$DIR(IBC1)

 ;

 I IBSEL>0 S IBSEL=$G(^TMP($J,"IBINSS",IBSEL))

 ;

DINSQ K ^TMP($J,"IBINSS"),^TMP($J,"IBCNSSB")

 Q IBSEL

 ;

DIR(MAX) ; DIR call for DICINS search for insurance company name

 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_": "

 I $G(MAX)>0 D ^DIR K DIR S IBX=$S($D(DTOUT)!$D(DUOUT):-1,+Y:+Y,1:0)

 Q IBX

 ;

DICBUF(INSNAME,DFN,IBDUZ) ; display list of editable buffer entries based on insurance name, may specify patient and/or enterer

 ; (non-MCCR people: only the person that created an entry should be able to edit it, everyone else should create new ones)

 N X,Y,IBX,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,D S IBX=0

 ;

 S DIC("W")="W ""   "",$P($G(^(20)),U,1),""   "",$P($G(^(21)),U,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_")"

 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

 Q IBX