IBCNBU1 ;ALB/ARH-Ins Buffer: Utilities ;1 Jun 97
;;2.0;INTEGRATED BILLING;**82,184,263,438,497**;21-MAR-94;Build 120
;;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,IB90 S IB0=$G(^IBA(355.33,IBBUFDA,0)) Q:IB0=""
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#
;
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,$E($P(IB90,U,3),1,19)
W !,?2,"Insurance: ",?15,$P($G(^IBA(355.33,+IBBUFDA,20)),U,1),?50,"Group #: ",?60,$E($P(IB90,U,2),1,19)
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
I IBX D
.; eIV real time inquiries temp. global
.K ^TMP("IBCNERTQ",$J,+IBBUFDA)
.S ^TMP("IBCNERTQ",$J,+IBBUFDA,"LOCK")=1
.Q
Q IBX
;
UNLOCK(IBBUFDA) ; unlock a Buffer entry
K ^TMP("IBCNERTQ",$J,+IBBUFDA,"LOCK")
I $G(^TMP("IBCNERTQ",$J,+IBBUFDA,"TRIGGER"))=1 D
.; eIV real time inquiry
.N TQIEN,RESPONSE,DIE,DA,DR,X,Y
.S RESPONSE=0
.; create an entry in eIV transmision queue
.S TQIEN=$$IBE^IBCNERTQ(+IBBUFDA)
.; Load and Send HL7 Message
.I TQIEN S RESPONSE=$$PROCSEND^IBCNERTQ(TQIEN)
.; set field 355.33/.16 (real time verification)
.S DIE="^IBA(355.33,",DA=+IBBUFDA,DR=".16////^S X=RESPONSE" D ^DIE
.K ^TMP("IBCNERTQ",$J,+IBBUFDA,"TRIGGER")
.Q
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBU1 6831 printed Oct 16, 2024@18:14:55 Page 2
IBCNBU1 ;ALB/ARH-Ins Buffer: Utilities ;1 Jun 97
+1 ;;2.0;INTEGRATED BILLING;**82,184,263,438,497**;21-MAR-94;Build 120
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
BUFFER(DFN) ; returns IFN of first buffer entry found for the patient, 0 otherwise
+1 QUIT +$ORDER(^IBA(355.33,"C",+$GET(DFN),0))
+2 ;
SELINS() ; user select an insurance company
+1 NEW IBX,DIE,DTOUT,DUOUT,DIC,X,Y
SET IBX=0
+2 SET DIC="^DIC(36,"
SET DIC(0)="AEQ"
SET DIC("A")="Select INSURANCE COMPANY: "
SET DIC("S")="I '$P(^(0),U,5)"
DO ^DIC
+3 IF +Y>0
SET IBX=Y
+4 QUIT IBX
+5 ;
SELGRP(IBINSDA) ; given a specific insurance company, allow user to choose a group/plan
+1 NEW IBX,DIE,DTOUT,DUOUT,DIC,X,Y,IBINSNM
SET IBX=0
+2 SET IBINSNM=$PIECE($GET(^DIC(36,+IBINSDA,0)),U,1)
+3 WRITE !,IBINSNM
+4 SET X=IBINSNM
SET DIC="^IBA(355.3,"
SET DIC(0)="EQ"
SET DIC("S")="I +^(0)="_+IBINSDA_"&('$P(^(0),U,11))"
DO ^DIC
+5 IF +Y>0
SET IBX=Y
+6 QUIT IBX
+7 ;
SELEXT(DFN) ; user select existing ins co, group, and if the patient is a member of the group also return the policy
+1 NEW IBX,IBINSDA,IBGRPDA,IBPOLDA
SET (IBINSDA,IBGRPDA,IBPOLDA)=""
+2 SET IBINSDA=$$SELINS()
SET IBX=+IBINSDA
+3 IF +IBINSDA
SET IBGRPDA=$$SELGRP(+IBINSDA)
IF +IBGRPDA
SET IBX=IBX_U_+IBGRPDA
+4 IF +IBGRPDA
IF +$GET(DFN)
SET IBPOLDA=$$PTGRP(DFN,IBINSDA,IBGRPDA)
IF +IBPOLDA
SET IBX=IBX_U_+IBPOLDA
+5 QUIT IBX
+6 ;
PTGRP(DFN,IBINSDA,IBGRPDA) ; return policy ifn if patient is a member of this group plan
+1 NEW IBX,IBY
SET IBX=0
SET DFN=+$GET(DFN)
SET IBINSDA=+$GET(IBINSDA)
SET IBGRPDA=+$GET(IBGRPDA)
+2 SET IBY=0
FOR
SET IBY=$ORDER(^DPT(DFN,.312,"B",IBINSDA,IBY))
if 'IBY
QUIT
IF +$PIECE($GET(^DPT(DFN,.312,IBY,0)),U,18)=IBGRPDA
SET IBX=IBY
+3 QUIT IBX
+4 ;
DISPBUF(IBBUFDA) ; display summary info on a buffer entry
+1 ;
+2 if '$GET(IBBUFDA)
QUIT
+3 NEW IB0,IB60,IB90
SET IB0=$GET(^IBA(355.33,IBBUFDA,0))
if IB0=""
QUIT
+4 ;WCJ;IB*2*497 used new fields for SUB ID and GROUP#
SET IB60=$GET(^IBA(355.33,IBBUFDA,60))
SET IB90=$GET(^IBA(355.33,IBBUFDA,90))
+5 ;
+6 WRITE !,"--------------------------------------------------------------------------------"
+7 WRITE !,?2,"Entered: ",?15,$$FMTE^XLFDT(+IB0,2),?50,"Source: ",?60,$$EXPAND^IBTRE(355.33,.03,$PIECE(IB0,U,3))
+8 WRITE !,?2,"Entered By: ",?15,$$EXPAND^IBTRE(355.33,.02,+$PIECE(IB0,U,2)),?50,"Verified: ",?60,$$FMTE^XLFDT($PIECE(IB0,U,10),2)
+9 IF +$PIECE(IB0,U,10)
WRITE !,?50,"Verif By: ",?60,$EXTRACT($$EXPAND^IBTRE(355.33,.11,$PIECE(IB0,U,11)),1,20)
+10 WRITE !!,?2,"Patient: ",?15,$$EXPAND^IBTRE(355.33,60.01,$PIECE(IB60,U,1)),?50,"Sub Id: ",?60,$EXTRACT($PIECE(IB90,U,3),1,19)
+11 WRITE !,?2,"Insurance: ",?15,$PIECE($GET(^IBA(355.33,+IBBUFDA,20)),U,1),?50,"Group #: ",?60,$EXTRACT($PIECE(IB90,U,2),1,19)
+12 WRITE !,?15,$PIECE($GET(^IBA(355.33,+IBBUFDA,21)),U,1)
+13 WRITE !,"--------------------------------------------------------------------------------"
+14 QUIT
+15 ;
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
+2 NEW IBX
SET IBX=0
+3 SET TO=$GET(TO,4)
+4 IF +$GET(IBBUFDA)
LOCK +^IBA(355.33,+IBBUFDA):TO
IF +$TEST
SET IBX=1
+5 IF 'IBX
IF +$GET(DISP)
WRITE !!,"Another user is currently editing/processing this entry, please try again later.",!
HANG TO
+6 IF IBX
Begin DoDot:1
+7 ; eIV real time inquiries temp. global
+8 KILL ^TMP("IBCNERTQ",$JOB,+IBBUFDA)
+9 SET ^TMP("IBCNERTQ",$JOB,+IBBUFDA,"LOCK")=1
+10 QUIT
End DoDot:1
+11 QUIT IBX
+12 ;
UNLOCK(IBBUFDA) ; unlock a Buffer entry
+1 KILL ^TMP("IBCNERTQ",$JOB,+IBBUFDA,"LOCK")
+2 IF $GET(^TMP("IBCNERTQ",$JOB,+IBBUFDA,"TRIGGER"))=1
Begin DoDot:1
+3 ; eIV real time inquiry
+4 NEW TQIEN,RESPONSE,DIE,DA,DR,X,Y
+5 SET RESPONSE=0
+6 ; create an entry in eIV transmision queue
+7 SET TQIEN=$$IBE^IBCNERTQ(+IBBUFDA)
+8 ; Load and Send HL7 Message
+9 IF TQIEN
SET RESPONSE=$$PROCSEND^IBCNERTQ(TQIEN)
+10 ; set field 355.33/.16 (real time verification)
+11 SET DIE="^IBA(355.33,"
SET DA=+IBBUFDA
SET DR=".16////^S X=RESPONSE"
DO ^DIE
+12 KILL ^TMP("IBCNERTQ",$JOB,+IBBUFDA,"TRIGGER")
+13 QUIT
End DoDot:1
+14 LOCK -^IBA(355.33,+IBBUFDA)
+15 QUIT
+16 ;
DICINS(INSNAME,IBSCACT,IBLISTN) ; user search/selection of existing Insurance Company Names, does not list duplicates, based on names and synonyms
+1 ;
+2 ; Input parameters
+3 ; INSNAME - user input; partial name match of insurance company
+4 ; IBSCACT - 0/1 flag indicating if inactive insurance companies
+5 ; should get screened out during the list building
+6 ; Default is 0 (no screen)
+7 ; IBLISTN - number of entries to display in the lister before
+8 ; giving the user a chance to select. Default is 4.
+9 ; Output
+10 ; returns Ins name, or -1 if ^, or 0 if none selected
+11 ;
+12 ; flag to screen out inactive ins
SET IBSCACT=$GET(IBSCACT,0)
+13 ; number of list entries before user selection
SET IBLISTN=$GET(IBLISTN,4)
+14 ;
+15 NEW IBX,IBINB,IBCX,IBSEL,IBXRF,IBNAME,IBSYNM,IBCNT,IBC1,IBINSIEN,IBLINE
+16 SET IBSEL=0
KILL ^TMP($JOB,"IBINSS"),^TMP($JOB,"IBINSSB")
IF INSNAME=""
GOTO DINSQ
+17 ;
+18 SET INSNAME=$$UP^XLFSTR(INSNAME)
SET IBX=$LENGTH(INSNAME)
SET IBINB=$EXTRACT(INSNAME,1,(IBX-1))_$CHAR($ASCII($EXTRACT(INSNAME,IBX))-1)_"~"
+19 ;
+20 FOR IBCX="C","B"
SET IBXRF=IBINB
Begin DoDot:1
+21 FOR
SET IBXRF=$ORDER(^DIC(36,IBCX,IBXRF))
if IBXRF=""!($EXTRACT(IBXRF,1,IBX)'=INSNAME)
QUIT
Begin DoDot:2
+22 SET IBINSIEN=0
+23 FOR
SET IBINSIEN=+$ORDER(^DIC(36,IBCX,IBXRF,IBINSIEN))
if 'IBINSIEN
QUIT
Begin DoDot:3
+24 ; bad xref entry?
IF '$DATA(^DIC(36,IBINSIEN,0))
QUIT
+25 ; inactive
IF IBSCACT
IF $PIECE($GET(^DIC(36,IBINSIEN,0)),U,5)
QUIT
+26 ; scheduled for deletion
IF IBSCACT
IF $PIECE($GET(^DIC(36,IBINSIEN,5)),U,1)
QUIT
+27 SET IBNAME=$PIECE($GET(^DIC(36,IBINSIEN,0)),U,1)
+28 IF IBNAME=""
QUIT
+29 IF $DATA(^TMP($JOB,"IBINSSB",IBNAME))
QUIT
+30 SET ^TMP($JOB,"IBINSSB",IBNAME)=$SELECT(IBNAME=IBXRF:"",1:IBXRF)
+31 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 SET IBCNT=0
SET IBX=""
FOR
SET IBX=$ORDER(^TMP($JOB,"IBINSSB",IBX))
if IBX=""
QUIT
SET IBCNT=IBCNT+1
SET ^TMP($JOB,"IBINSS",IBCNT)=IBX
+34 ;
+35 SET (IBCNT,IBC1)=0
FOR
SET IBCNT=$ORDER(^TMP($JOB,"IBINSS",IBCNT))
if 'IBCNT
QUIT
Begin DoDot:1
+36 SET IBNAME=^TMP($JOB,"IBINSS",IBCNT)
if IBNAME=""
QUIT
SET IBSYNM=$GET(^TMP($JOB,"IBINSSB",IBNAME))
+37 SET IBLINE=$JUSTIFY(IBCNT,7)_" "_$$FO^IBCNEUT1(IBNAME,40)_IBSYNM
+38 DO EN^DDIOL(IBLINE)
+39 SET IBC1=IBC1+1
IF '(IBCNT#IBLISTN)
SET IBSEL=$$DIR(IBC1)
+40 QUIT
End DoDot:1
IF +IBSEL
QUIT
+41 ;
+42 IF 'IBSEL
IF +(IBC1#IBLISTN)
SET IBSEL=$$DIR(IBC1)
+43 ;
+44 IF IBSEL>0
SET IBSEL=$GET(^TMP($JOB,"IBINSS",IBSEL))
+45 ;
DINSQ KILL ^TMP($JOB,"IBINSS"),^TMP($JOB,"IBCNSSB")
+1 QUIT IBSEL
+2 ;
DIR(MAX) ; DIR call for DICINS search for insurance company name
+1 NEW DIR,DIRUT,DTOUT,DUOUT,IBX,X,Y
SET IBX=0
SET DIR(0)="LOA^1:"_MAX_"^K:X'>0!(X>"_MAX_") X"
SET DIR("A")="CHOOSE 1-"_MAX_": "
+2 IF $GET(MAX)>0
DO ^DIR
KILL DIR
SET IBX=$SELECT($DATA(DTOUT)!$DATA(DUOUT):-1,+Y:+Y,1:0)
+3 QUIT IBX
+4 ;
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)
+2 NEW X,Y,IBX,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,D
SET IBX=0
+3 ;
+4 SET DIC("W")="W "" "",$P($G(^(20)),U,1),"" "",$P($G(^(21)),U,1)"
+5 SET DIC("S")="I $P(^(0),U,4)=""E""&('$P(^(0),U,10))"
if +$GET(IBDUZ)
SET DIC("S")=DIC("S")_"&(+$P(^(0),U,2)="_IBDUZ_")"
if +$GET(DFN)
SET DIC("S")=DIC("S")_"&(+$G(^(60))="_DFN_")"
+6 SET DIC="^IBA(355.33,"
SET DIC(0)="EM"
SET X=$$UP^XLFSTR($GET(INSNAME))
SET D="D"
DO IX^DIC
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
IF +Y>0
SET IBX=+Y
+7 QUIT IBX
