IBCNEQU ;DAOU/BHS - eIV REQUEST ELECTRONIC INSURANCE INQUIRY ; 24-JUN-2002
;;2.0;INTEGRATED BILLING;**184,271,416,438,497,582,601,631,668,702,732,737**;21-MAR-94;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
; eIV - Insurance Verification Interface
;
; Must call from EN
;
; IB*737/TAZ - Remove References to ~NO PAYER
Q
;
EN ; Entry pt
; Init vars
N DFN,X,POP,IBFASTXT,VALMCNT,VALMBG,VALMHDR,VALMBCK,IDUZ
;
EN1 I $G(IBFASTXT) G ENX
S DFN=$$PAT I 'DFN G ENX
D EN^VALM("IBCNE REQUEST INS INQUIRY LIST")
G EN1
;
ENX ; EN exit pt
Q
;
INIT ; -- set up initial variables
S VALMCNT=0,VALMBG=1,IDUZ=DUZ
K ^TMP("IBCNEQU",$J),^TMP("IBCNEQUX",$J),^TMP("IBCNEQUDTS",$J)
D HDR
D BLD(DFN)
;
INITX ; INIT exit pt
Q
;
HDR ; -- screen header for initial screen
N VA,VAERR,%DT,II
D PID^VADPT
S VALMHDR(1)="Request Electronic Insurance Inquiry for Patient: "_$E($P($G(^DPT(DFN,0)),U),1,20)_" "_$E($G(^(0)),1)_VA("BID")
S VALMHDR(2)=" "
S VALMHDR(3)=" "
S II=1
I +$$BUFFER^IBCNBU1(DFN) S II=II+1,VALMHDR(II)="*** Patient has Insurance Buffer Records"
I $P($G(^DPT(DFN,.35)),U)'="" S II=II+1,VALMHDR(II)="*** Date of Death: "_$$FMTE^XLFDT($P($G(^DPT(DFN,.35)),U)\1,"5Z")
Q
;
HELP ; -- help code
D FULL^VALM1
W @IOF
W !,"When requesting an Electronic Insurance Inquiry..." ; IB*2*601/DM
W !,"This screen lists all eligible (non-Medicaid) Insurance policies for the"
W !,"patient. Selecting an entry here creates an Insurance Buffer entry with Source"
W !,"'eIV' and Override Freshness Flag 'Yes'. Setting this flag is designed to force"
W !,"the eIV extract to attempt to create an insurance inquiry based on this entry."
W !!,"Entries with an asterisk (*) preceding the Insurance Co name already exist in"
W !,"the Insurance Buffer with the exact same name, the exact same Group Number,"
W !,"and the Override Freshness Flag set to 'Yes'."
; IB*2*601/DM
W !!,"When requesting a MBI lookup..."
W !,"Policies will be listed as described above for electronic insurance inquiry;"
W !,"however, no special 'checks' will be made. The MBI request will be initiated "
W !,"immediately, regardless of policies above and resulting buffer entry will have"
W !,"source 'Medicare'."
; IB*2*702/TAZ - Added following lines
W !!,"When initiating an EICD Request..."
W !,"An EICD request will be initiated if the following conditions are met:"
W !," - The patient does not have active insurance on file."
W !," - The patient does not have an eligibility exclusion."
W !," - There have been no other recent EICD requests."
W !
;
S VALMBCK="R"
Q
;
EXIT ; -- exit code
K ^TMP("IBCNEQU",$J),^TMP("IBCNEQUX",$J)
Q
;
PAT() ; Prompt user to select a patient
; Init vars
N DIC,X,Y,DISYS,%H,%I,DUOUT,DTOUT
;
W !
; Exclude non-Veterans
S DIC(0)="AEQMN"
S DIC("S")="I $G(^(""VET""))=""Y"",('$P($G(^(0)),U,21))",DIC="^DPT("
D ^DIC
I $D(DUOUT)!$D(DTOUT)!(Y<1) Q ""
;
Q +Y
;
BLD(DFN) ; Build list of all insurance for patient
N IBCT,IBINS,IBDATA0,IBDATA1,IBDATA2,II,STR,IBINSIEN,IBINAME,IBHOLD
N VNODT,X,POP,IBBUF,IBBUFNM,IBIEN,IBBUFDT,TMPNM,GRPNUM,SFANAME
;
K ^TMP("IBCNEQU",$J),^TMP("IBCNEQUX",$J)
;
S (IBCT,VALMCNT)=0
;
; Determine if buffer entries exist for this DFN and build array by name
S IBIEN=0
F S IBIEN=$O(^IBA(355.33,"C",DFN,IBIEN)) Q:'IBIEN D
. S IBBUFDT=$G(^IBA(355.33,IBIEN,0))
. ; Include E status only
. I $P(IBBUFDT,U,4)'="E" Q
. S IBBUFNM=$$TRIM^XLFSTR($P($G(^IBA(355.33,IBIEN,20)),U))
. I IBBUFNM="" Q
. ;S GRPNUM=$$TRIM^XLFSTR($P($G(^IBA(355.33,IBIEN,40)),U,3))
. S GRPNUM=$$TRIM^XLFSTR($P($G(^IBA(355.33,IBIEN,90)),U,2)) ; ib*2*497 get group number from it's new location
. S IBBUF(IBBUFNM," "_GRPNUM)=""
. Q
;
; Populate IBINS array with Patient Insurance records
D ALL^IBCNS1(DFN,"IBINS")
I $G(IBINS(0)) S II=0 F S II=$O(IBINS(II)) Q:'II D
. S IBDATA0=$G(IBINS(II,0))
. S IBDATA1=$G(IBINS(II,1))
. S IBDATA2=$G(^IBA(355.3,+$P(IBDATA0,U,18),0))
. S GRPNUM=$$TRIM^XLFSTR($P($G(^IBA(355.3,+$P(IBDATA0,U,18),2)),U,2)) ; ib*2*497 get group number from it's new location
. ;S GRPNUM=$$TRIM^XLFSTR($P(GRPNUM,U,2))
. ;S GRPNUM=$$TRIM^XLFSTR($P(IBDATA2,U,4))
. S IBINSIEN=+$P(IBDATA0,U)
. Q:'IBINSIEN!'$D(^DIC(36,IBINSIEN,0))
. S IBINAME=$P($G(^DIC(36,IBINSIEN,0)),U)
. S TMPNM=$$TRIM^XLFSTR(IBINAME)
. ; Filter Ins Co's by name - currently filter Medicaid
. I $$EXCLUDE^IBCNEUT4(TMPNM) Q
. S IBCT=IBCT+1
. S STR=""
. S STR=$$SETFLD^VALM1(IBCT,STR,"NUMBER")
. ; Update IBINAME if found in buffer already
. S IBINAME=$S($D(IBBUF(TMPNM," "_GRPNUM)):"*",1:"")_IBINAME
. S STR=$$SETFLD^VALM1(IBINAME,STR,"NAME")
. S STR=$$SETFLD^VALM1($E($P(IBDATA0,U,2),1,14),STR,"POLICY")
. S IBHOLD=$P(IBDATA0,U,6),STR=$$SETFLD^VALM1($S(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"UNKNOWN"),STR,"HOLDER")
. S STR=$$SETFLD^VALM1($E($$GRP^IBCNS($P(IBDATA0,U,18)),1,10),STR,"GROUP")
. S STR=$$SETFLD^VALM1($$FMTE^XLFDT($P(IBDATA0,U,8),"5Z"),STR,"EFFDT")
. S STR=$$SETFLD^VALM1($$FMTE^XLFDT($P(IBDATA0,U,4),"5Z"),STR,"EXPIRE")
. S STR=$$SETFLD^VALM1($E($P($G(^IBE(355.1,+$P(IBDATA2,U,9),0)),U),1,8),STR,"TYPE")
. S STR=$$SETFLD^VALM1($P($G(^IBE(355.1,+$P(IBDATA2,U,9),0)),U),STR,"TYPEPOL")
. S STR=$$SETFLD^VALM1($E($P($G(^VA(200,+$P(IBDATA1,U,4),0)),U),1,15),STR,"VERIFIED BY")
. S STR=$$SETFLD^VALM1($$FMTE^XLFDT($P(IBDATA1,U,3),"5Z"),STR,"VERIFIED ON")
. S STR=$$SETFLD^VALM1($$YN($P(IBDATA2,U,6)),STR,"PRECERT")
. S STR=$$SETFLD^VALM1($$YN($P(IBDATA2,U,5)),STR,"UR")
. S STR=$$SETFLD^VALM1($$YN($P(IBDATA0,U,20)),STR,"COB")
. D SET(STR)
. Q
;
I 'IBCT D
. S VALMCNT=VALMCNT+1
. S ^TMP("IBCNEQU",$J,VALMCNT,0)=" "
. S VALMCNT=VALMCNT+1
. S ^TMP("IBCNEQU",$J,VALMCNT,0)=" No eligible insurance policies found."
. Q
;
S VNODT=$P($G(^IBA(354,DFN,60)),U,1) I VNODT D
. S VALMCNT=VALMCNT+1
. S ^TMP("IBCNEQU",$J,VALMCNT,0)=" "
. S VALMCNT=VALMCNT+1
. S ^TMP("IBCNEQU",$J,VALMCNT,0)=" Verification of No Coverage "_$$FMTE^XLFDT(VNODT,"5Z")_"."
. Q
;
BLDX ; BLD exit pt
Q
;
SET(LINE) ; -- set arrays
; LINE - line of text to display
S VALMCNT=VALMCNT+1
S ^TMP("IBCNEQU",$J,VALMCNT,0)=LINE
S ^TMP("IBCNEQU",$J,"IDX",VALMCNT,IBCT)=""
S ^TMP("IBCNEQUX",$J,IBCT)=VALMCNT_U_DFN_U_II_U_IBINAME_U_IBDATA0
S ^TMP("IBCNEQUX",$J)=$G(^TMP("IBCNEQUX",$J))+1
Q
;
YN(X) ; -- convert 1 or 0 to yes/no/unknown
Q $S(X=0:"NO",X=1:"YES",1:"UNK")
;
SELECT ; User selects insurance from list to be reconfirmed
N IBDATA,IBDPT,IBDA,DIR,X,Y,D0,DG,DIC,DISYS,DIW,IENS,IBELIGDT,IBERROR,IBIEN,IBSYM
;
D FULL^VALM1
S VALMBCK="R"
;
I '$O(^TMP("IBCNEQUX",$J,0)) D G SELECTX
. W !!,"No Insurance policies to select."
. S DIR(0)="E" D ^DIR K DIR
. Q
;
S (IBDPT,IBDA,IBERROR)=""
S IBDATA=$$SEL()
S IBDPT=+$P(IBDATA,U) ; Patient DFN
S IBDA=+$P(IBDATA,U,2) ; 2.312 ptr
I +IBDPT,+IBDA D
. S IBIEN=+$P(IBDATA,U,4) ; Ins Co IEN (#36)
. S IBSYM=$P($$INSERROR^IBCNEUT3("I",IBIEN),"^",1)
. S ^TMP("IBCNEQUDTS",$J)=1
. D PT^IBCNEBF(IBDPT,IBDA,IBSYM,1,1,.IBERROR)
. ; Check for errors
. I $G(IBERROR)'="" W !!,"Insurance Buffer entry could not be created due to error! Please try again.",!
. I $G(IBERROR)="" W !!,"Insurance Buffer entry created!",!
. S DIR(0)="E" D ^DIR K DIR
. K ^TMP("IBCNEQUDTS",$J)
;
SELECTX ;
S VALMBCK="R"
Q
;
SEL() ; User selects insurance from list
N IBSELN,DIR,X,Y,DIRUT,DUOUT
;
S IBSELN=""
; Select entry to reconfirm
S DIR(0)="NO^1:"_$G(^TMP("IBCNEQUX",$J))_":0"
S DIR("A")="Select entry to request electronic inquiry"
S DIR("?",1)=" Select an entry to initiate an insurance inquiry."
S DIR("?",2)=" If entry contains an Insurance Co name, an Insurance"
S DIR("?",3)=" Buffer entry will be created for nightly batch extract."
S DIR("?")=" "
D ^DIR K DIR
I $D(DIRUT)!$D(DUOUT)!(Y<1) G SELX
S IBSELN=$O(^TMP("IBCNEQU",$J,"IDX",Y,0))
I IBSELN S IBSELN=$P($G(^TMP("IBCNEQUX",$J,IBSELN)),U,2,99)
I $E($P(IBSELN,U,3))="*" W ! D S IBSELN="" G SELX
.S DIR(0)="EA"
.S DIR("A",1)=""
.S DIR("A",2)="Selected policy has an existing buffer entry."
.S DIR("A",3)="You must first process the existing buffer entry."
.S DIR("A")="Press RETURN to continue " D ^DIR K DIR W !
.Q
;
; Get service type code
D STC
I X="^" S IBSELN="" G SELX ; '^' entered thus backup a level & re-ask Insurance question
; Get eligibility date
S IBELIGDT=$$ELIGDT() I 'IBELIGDT S IBSELN="" G SELX
W !
S DIR(0)="Y"
S DIR("A")="Are you sure you want to request an insurance inquiry"
S DIR("B")="NO"
S DIR("?",1)=" If yes, a request will be created for the nightly batch."
D ^DIR K DIR
I $D(DIRUT)!$D(DUOUT)!('Y) S IBSELN=""
;
SELX Q IBSELN
;
STC ; Ask for service type code to send
; IB*582/HN - Modified Default Service Type Code to pull from the MCCF Billing Parameters File (350.9,60.01)
N DIR,X,Y
; IBEISTC used as STC variable
S IBEISTC=""
S DIR(0)="PAO^365.013:EMZ",DIR("A")="Enter Service Type Code: "
S DIR("B")=$$GET1^DIQ(350.9,1_",",60.01,"E")
S DIR("??")="^D HELPSTC2^IBCNEQU"
STCEN ; Intital and re-enterant tag upon error
D ^DIR Q:X="^"
; Check to verify code is active, if not, display error and ask again
I $P($G(Y(0)),U,3)'="" W !,"Code selected is not an active code - please select another code.",! G STCEN
; If valid STC entered, set IBEISTC to be STC IEN. If no code entered, default to service code 30
;S IBEISTC=$S(+Y>0:$P(Y,U,1),1:$O(^IBE(365.013,"B",30,"")))
; If valid STC entered, set IBEISTC to be STCIEN.
S IBEISTC=$P(Y,U,1)
Q
;
FASTEXIT ; Sets flag to indicate a quick exit from the option
N DIR,DIRUT,X,Y
S VALMBCK="Q"
D FULL^VALM1
S DIR(0)="Y",DIR("A")="Exit option entirely",DIR("B")="NO"
D ^DIR
I +Y S IBFASTXT=1
Q
;
HELPSTC2 ; Text to display in response to '??' entry
N DIR
D FULL^VALM1
W @IOF
;IB*732/DTG start - change help text to reflect code is dictionary driven
W !,"Enter the single SERVICE TYPE CODE to be sent with inquiry or press"
W !,"'ENTER' to send default service type code. The default service type"
W !,"code may auto-update. All other service types will not auto-update."
;IB*732/DTG end - change help text to reflect code is dictionary driven
Q
;
ELIGDT() ; Prompt user for eligibility date
N DIR,X,Y,DIRUT,DUOUT,STARTDT,ENDDT,ELIGDT
S ELIGDT=""
D DT^DILF(,"T-12M",.STARTDT) ; start date within the last 12 months
; allow end date up to the end of the current month
S ENDDT=$$SCH^XLFDT("1M(L@1A)",DT)\1 ; ICR#10103 this call returns the last day of the current month at 1 AM. If not time was sent, it would actually return the next to last day at 2400 hours.
S DIR(0)="DA^"_STARTDT_":"_ENDDT_":"_"EX",DIR("A")="Enter Eligibility Date: ",DIR("B")="TODAY"
S DIR("?",1)="Select an eligibility date to be sent in the inquiry."
S DIR("?")="Date must be within the last 12 months or up to the end of the current month."
D ^DIR
I $D(DIRUT)!$D(DUOUT)!('Y) G ELIGDTX
S ELIGDT=Y
ELIGDTX ;
Q ELIGDT
;
MBIREQ ; User requested a MBI lookup request
;/vd-IB*2*668 - Added the variable APIEN
N APIEN,DIR,X,Y,DIRUT,DUOUT
N IBMBIPYR,IBBUF,IBFDA
;
D FULL^VALM1
S VALMBCK="R"
K DIR
;
; see if the MBI PAYER site parameter has been populated
S IBMBIPYR=+$$GET1^DIQ(350.9,"1,","MBI PAYER","I")
I 'IBMBIPYR D G MBIREQX
. W !!," The required MBI Payer site parameter is not populated; try again later",!
. S DIR(0)="E" D ^DIR K DIR
;
S APIEN=$$PYRAPP^IBCNEUT5("EIV",IBMBIPYR) ;/vd-IB*2*668
;/vd-IB*2*668 - Replaced the following 2 lines of code to remove a hardcoded value.
;I '($$GET1^DIQ(365.121,"1,"_IBMBIPYR_",",.02,"I")) D G MBIREQX
;. W !!," The MBI Payer is not nationally active; try again later",!
I '($$GET1^DIQ(365.121,APIEN_","_IBMBIPYR_",",.02,"I")) D G MBIREQX
. W !!," The MBI Payer is not NATIONALLY Enabled; try again later",!
. S DIR(0)="E" D ^DIR K DIR
;
;/vd-IB*2*668 - Replaced the following 2 lines of code to remove a hardcoded value.
;I '($$GET1^DIQ(365.121,"1,"_IBMBIPYR_",",.03,"I")) D G MBIREQX
;. W !!," The MBI Payer LOCAL ACTIVE field is set to 'NO'; it must be 'YES' to proceed",!
I '($$GET1^DIQ(365.121,APIEN_","_IBMBIPYR_",",.03,"I")) D G MBIREQX
. W !!," The MBI Payer is not LOCALLY Enabled; try again later",!
. S DIR(0)="E" D ^DIR K DIR
;
D DEM^VADPT ; ; ICR#10061
I ($P(VADM(2),U)="")!($P(VADM(3),U)="") D G MBIREQX
. W !!," SSN and DOB are required fields, they must be populated in order to proceed",!
. S DIR(0)="E" D ^DIR K DIR
;
S DIR(0)="Y"
S DIR("A")="Are you sure you want to request this Patient's Medicare Beneficiary ID"
S DIR("B")="YES"
S DIR("?",1)=" If yes, a MBI request will be initiated immediately."
S DIR("?")=" If no, the MBI request will be cancelled."
D ^DIR K DIR
I $D(DIRUT)!$D(DUOUT)!('Y) G MBIREQX
;
;write a buffer entry
;the real time process will set the patient relationship to self automatically
;patient fields, name, dob and ssn will be populated automatically
K IBBUF
S IBBUF(.02)=DUZ ; Entered By
S IBBUF(.12)=$P($$PAYER^IBCNEUT4(IBMBIPYR),U) ; Buffer Symbol
S IBBUF(20.01)=$$GET1^DIQ(350.9,"1,","MBI PAYER","E")
S IBBUF(60.01)=DFN ; Patient IEN
S IBBUF(90.03)="MBIrequest" ; MBI placeholder for subscriber ID
S IBBUF(91.01)=VADM(1) ; patient (subscriber) name
; the following call in-turn, calls EDITSTF^IBCNBES which will make sure to file subscriber ID last, automatically
S IBFDA=$$ADDSTF^IBCNBES($$FIND1^DIC(355.12,,,"MEDICARE","C"),DFN,.IBBUF)
;
W !!,"The MBI request was successful, check the buffer for results.",!
S DIR(0)="E" D ^DIR K DIR
S VALMBCK="Q"
Q
MBIREQX ;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEQU 13875 printed Apr 09, 2024@21:37:38 Page 2
IBCNEQU ;DAOU/BHS - eIV REQUEST ELECTRONIC INSURANCE INQUIRY ; 24-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,416,438,497,582,601,631,668,702,732,737**;21-MAR-94;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; eIV - Insurance Verification Interface
+5 ;
+6 ; Must call from EN
+7 ;
+8 ; IB*737/TAZ - Remove References to ~NO PAYER
+9 QUIT
+10 ;
EN ; Entry pt
+1 ; Init vars
+2 NEW DFN,X,POP,IBFASTXT,VALMCNT,VALMBG,VALMHDR,VALMBCK,IDUZ
+3 ;
EN1 IF $GET(IBFASTXT)
GOTO ENX
+1 SET DFN=$$PAT
IF 'DFN
GOTO ENX
+2 DO EN^VALM("IBCNE REQUEST INS INQUIRY LIST")
+3 GOTO EN1
+4 ;
ENX ; EN exit pt
+1 QUIT
+2 ;
INIT ; -- set up initial variables
+1 SET VALMCNT=0
SET VALMBG=1
SET IDUZ=DUZ
+2 KILL ^TMP("IBCNEQU",$JOB),^TMP("IBCNEQUX",$JOB),^TMP("IBCNEQUDTS",$JOB)
+3 DO HDR
+4 DO BLD(DFN)
+5 ;
INITX ; INIT exit pt
+1 QUIT
+2 ;
HDR ; -- screen header for initial screen
+1 NEW VA,VAERR,%DT,II
+2 DO PID^VADPT
+3 SET VALMHDR(1)="Request Electronic Insurance Inquiry for Patient: "_$EXTRACT($PIECE($GET(^DPT(DFN,0)),U),1,20)_" "_$EXTRACT($GET(^(0)),1)_VA("BID")
+4 SET VALMHDR(2)=" "
+5 SET VALMHDR(3)=" "
+6 SET II=1
+7 IF +$$BUFFER^IBCNBU1(DFN)
SET II=II+1
SET VALMHDR(II)="*** Patient has Insurance Buffer Records"
+8 IF $PIECE($GET(^DPT(DFN,.35)),U)'=""
SET II=II+1
SET VALMHDR(II)="*** Date of Death: "_$$FMTE^XLFDT($PIECE($GET(^DPT(DFN,.35)),U)\1,"5Z")
+9 QUIT
+10 ;
HELP ; -- help code
+1 DO FULL^VALM1
+2 WRITE @IOF
+3 ; IB*2*601/DM
WRITE !,"When requesting an Electronic Insurance Inquiry..."
+4 WRITE !,"This screen lists all eligible (non-Medicaid) Insurance policies for the"
+5 WRITE !,"patient. Selecting an entry here creates an Insurance Buffer entry with Source"
+6 WRITE !,"'eIV' and Override Freshness Flag 'Yes'. Setting this flag is designed to force"
+7 WRITE !,"the eIV extract to attempt to create an insurance inquiry based on this entry."
+8 WRITE !!,"Entries with an asterisk (*) preceding the Insurance Co name already exist in"
+9 WRITE !,"the Insurance Buffer with the exact same name, the exact same Group Number,"
+10 WRITE !,"and the Override Freshness Flag set to 'Yes'."
+11 ; IB*2*601/DM
+12 WRITE !!,"When requesting a MBI lookup..."
+13 WRITE !,"Policies will be listed as described above for electronic insurance inquiry;"
+14 WRITE !,"however, no special 'checks' will be made. The MBI request will be initiated "
+15 WRITE !,"immediately, regardless of policies above and resulting buffer entry will have"
+16 WRITE !,"source 'Medicare'."
+17 ; IB*2*702/TAZ - Added following lines
+18 WRITE !!,"When initiating an EICD Request..."
+19 WRITE !,"An EICD request will be initiated if the following conditions are met:"
+20 WRITE !," - The patient does not have active insurance on file."
+21 WRITE !," - The patient does not have an eligibility exclusion."
+22 WRITE !," - There have been no other recent EICD requests."
+23 WRITE !
+24 ;
+25 SET VALMBCK="R"
+26 QUIT
+27 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBCNEQU",$JOB),^TMP("IBCNEQUX",$JOB)
+2 QUIT
+3 ;
PAT() ; Prompt user to select a patient
+1 ; Init vars
+2 NEW DIC,X,Y,DISYS,%H,%I,DUOUT,DTOUT
+3 ;
+4 WRITE !
+5 ; Exclude non-Veterans
+6 SET DIC(0)="AEQMN"
+7 SET DIC("S")="I $G(^(""VET""))=""Y"",('$P($G(^(0)),U,21))"
SET DIC="^DPT("
+8 DO ^DIC
+9 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y<1)
QUIT ""
+10 ;
+11 QUIT +Y
+12 ;
BLD(DFN) ; Build list of all insurance for patient
+1 NEW IBCT,IBINS,IBDATA0,IBDATA1,IBDATA2,II,STR,IBINSIEN,IBINAME,IBHOLD
+2 NEW VNODT,X,POP,IBBUF,IBBUFNM,IBIEN,IBBUFDT,TMPNM,GRPNUM,SFANAME
+3 ;
+4 KILL ^TMP("IBCNEQU",$JOB),^TMP("IBCNEQUX",$JOB)
+5 ;
+6 SET (IBCT,VALMCNT)=0
+7 ;
+8 ; Determine if buffer entries exist for this DFN and build array by name
+9 SET IBIEN=0
+10 FOR
SET IBIEN=$ORDER(^IBA(355.33,"C",DFN,IBIEN))
if 'IBIEN
QUIT
Begin DoDot:1
+11 SET IBBUFDT=$GET(^IBA(355.33,IBIEN,0))
+12 ; Include E status only
+13 IF $PIECE(IBBUFDT,U,4)'="E"
QUIT
+14 SET IBBUFNM=$$TRIM^XLFSTR($PIECE($GET(^IBA(355.33,IBIEN,20)),U))
+15 IF IBBUFNM=""
QUIT
+16 ;S GRPNUM=$$TRIM^XLFSTR($P($G(^IBA(355.33,IBIEN,40)),U,3))
+17 ; ib*2*497 get group number from it's new location
SET GRPNUM=$$TRIM^XLFSTR($PIECE($GET(^IBA(355.33,IBIEN,90)),U,2))
+18 SET IBBUF(IBBUFNM," "_GRPNUM)=""
+19 QUIT
End DoDot:1
+20 ;
+21 ; Populate IBINS array with Patient Insurance records
+22 DO ALL^IBCNS1(DFN,"IBINS")
+23 IF $GET(IBINS(0))
SET II=0
FOR
SET II=$ORDER(IBINS(II))
if 'II
QUIT
Begin DoDot:1
+24 SET IBDATA0=$GET(IBINS(II,0))
+25 SET IBDATA1=$GET(IBINS(II,1))
+26 SET IBDATA2=$GET(^IBA(355.3,+$PIECE(IBDATA0,U,18),0))
+27 ; ib*2*497 get group number from it's new location
SET GRPNUM=$$TRIM^XLFSTR($PIECE($GET(^IBA(355.3,+$PIECE(IBDATA0,U,18),2)),U,2))
+28 ;S GRPNUM=$$TRIM^XLFSTR($P(GRPNUM,U,2))
+29 ;S GRPNUM=$$TRIM^XLFSTR($P(IBDATA2,U,4))
+30 SET IBINSIEN=+$PIECE(IBDATA0,U)
+31 if 'IBINSIEN!'$DATA(^DIC(36,IBINSIEN,0))
QUIT
+32 SET IBINAME=$PIECE($GET(^DIC(36,IBINSIEN,0)),U)
+33 SET TMPNM=$$TRIM^XLFSTR(IBINAME)
+34 ; Filter Ins Co's by name - currently filter Medicaid
+35 IF $$EXCLUDE^IBCNEUT4(TMPNM)
QUIT
+36 SET IBCT=IBCT+1
+37 SET STR=""
+38 SET STR=$$SETFLD^VALM1(IBCT,STR,"NUMBER")
+39 ; Update IBINAME if found in buffer already
+40 SET IBINAME=$SELECT($DATA(IBBUF(TMPNM," "_GRPNUM)):"*",1:"")_IBINAME
+41 SET STR=$$SETFLD^VALM1(IBINAME,STR,"NAME")
+42 SET STR=$$SETFLD^VALM1($EXTRACT($PIECE(IBDATA0,U,2),1,14),STR,"POLICY")
+43 SET IBHOLD=$PIECE(IBDATA0,U,6)
SET STR=$$SETFLD^VALM1($SELECT(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"UNKNOWN"),STR,"HOLDER")
+44 SET STR=$$SETFLD^VALM1($EXTRACT($$GRP^IBCNS($PIECE(IBDATA0,U,18)),1,10),STR,"GROUP")
+45 SET STR=$$SETFLD^VALM1($$FMTE^XLFDT($PIECE(IBDATA0,U,8),"5Z"),STR,"EFFDT")
+46 SET STR=$$SETFLD^VALM1($$FMTE^XLFDT($PIECE(IBDATA0,U,4),"5Z"),STR,"EXPIRE")
+47 SET STR=$$SETFLD^VALM1($EXTRACT($PIECE($GET(^IBE(355.1,+$PIECE(IBDATA2,U,9),0)),U),1,8),STR,"TYPE")
+48 SET STR=$$SETFLD^VALM1($PIECE($GET(^IBE(355.1,+$PIECE(IBDATA2,U,9),0)),U),STR,"TYPEPOL")
+49 SET STR=$$SETFLD^VALM1($EXTRACT($PIECE($GET(^VA(200,+$PIECE(IBDATA1,U,4),0)),U),1,15),STR,"VERIFIED BY")
+50 SET STR=$$SETFLD^VALM1($$FMTE^XLFDT($PIECE(IBDATA1,U,3),"5Z"),STR,"VERIFIED ON")
+51 SET STR=$$SETFLD^VALM1($$YN($PIECE(IBDATA2,U,6)),STR,"PRECERT")
+52 SET STR=$$SETFLD^VALM1($$YN($PIECE(IBDATA2,U,5)),STR,"UR")
+53 SET STR=$$SETFLD^VALM1($$YN($PIECE(IBDATA0,U,20)),STR,"COB")
+54 DO SET(STR)
+55 QUIT
End DoDot:1
+56 ;
+57 IF 'IBCT
Begin DoDot:1
+58 SET VALMCNT=VALMCNT+1
+59 SET ^TMP("IBCNEQU",$JOB,VALMCNT,0)=" "
+60 SET VALMCNT=VALMCNT+1
+61 SET ^TMP("IBCNEQU",$JOB,VALMCNT,0)=" No eligible insurance policies found."
+62 QUIT
End DoDot:1
+63 ;
+64 SET VNODT=$PIECE($GET(^IBA(354,DFN,60)),U,1)
IF VNODT
Begin DoDot:1
+65 SET VALMCNT=VALMCNT+1
+66 SET ^TMP("IBCNEQU",$JOB,VALMCNT,0)=" "
+67 SET VALMCNT=VALMCNT+1
+68 SET ^TMP("IBCNEQU",$JOB,VALMCNT,0)=" Verification of No Coverage "_$$FMTE^XLFDT(VNODT,"5Z")_"."
+69 QUIT
End DoDot:1
+70 ;
BLDX ; BLD exit pt
+1 QUIT
+2 ;
SET(LINE) ; -- set arrays
+1 ; LINE - line of text to display
+2 SET VALMCNT=VALMCNT+1
+3 SET ^TMP("IBCNEQU",$JOB,VALMCNT,0)=LINE
+4 SET ^TMP("IBCNEQU",$JOB,"IDX",VALMCNT,IBCT)=""
+5 SET ^TMP("IBCNEQUX",$JOB,IBCT)=VALMCNT_U_DFN_U_II_U_IBINAME_U_IBDATA0
+6 SET ^TMP("IBCNEQUX",$JOB)=$GET(^TMP("IBCNEQUX",$JOB))+1
+7 QUIT
+8 ;
YN(X) ; -- convert 1 or 0 to yes/no/unknown
+1 QUIT $SELECT(X=0:"NO",X=1:"YES",1:"UNK")
+2 ;
SELECT ; User selects insurance from list to be reconfirmed
+1 NEW IBDATA,IBDPT,IBDA,DIR,X,Y,D0,DG,DIC,DISYS,DIW,IENS,IBELIGDT,IBERROR,IBIEN,IBSYM
+2 ;
+3 DO FULL^VALM1
+4 SET VALMBCK="R"
+5 ;
+6 IF '$ORDER(^TMP("IBCNEQUX",$JOB,0))
Begin DoDot:1
+7 WRITE !!,"No Insurance policies to select."
+8 SET DIR(0)="E"
DO ^DIR
KILL DIR
+9 QUIT
End DoDot:1
GOTO SELECTX
+10 ;
+11 SET (IBDPT,IBDA,IBERROR)=""
+12 SET IBDATA=$$SEL()
+13 ; Patient DFN
SET IBDPT=+$PIECE(IBDATA,U)
+14 ; 2.312 ptr
SET IBDA=+$PIECE(IBDATA,U,2)
+15 IF +IBDPT
IF +IBDA
Begin DoDot:1
+16 ; Ins Co IEN (#36)
SET IBIEN=+$PIECE(IBDATA,U,4)
+17 SET IBSYM=$PIECE($$INSERROR^IBCNEUT3("I",IBIEN),"^",1)
+18 SET ^TMP("IBCNEQUDTS",$JOB)=1
+19 DO PT^IBCNEBF(IBDPT,IBDA,IBSYM,1,1,.IBERROR)
+20 ; Check for errors
+21 IF $GET(IBERROR)'=""
WRITE !!,"Insurance Buffer entry could not be created due to error! Please try again.",!
+22 IF $GET(IBERROR)=""
WRITE !!,"Insurance Buffer entry created!",!
+23 SET DIR(0)="E"
DO ^DIR
KILL DIR
+24 KILL ^TMP("IBCNEQUDTS",$JOB)
End DoDot:1
+25 ;
SELECTX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
SEL() ; User selects insurance from list
+1 NEW IBSELN,DIR,X,Y,DIRUT,DUOUT
+2 ;
+3 SET IBSELN=""
+4 ; Select entry to reconfirm
+5 SET DIR(0)="NO^1:"_$GET(^TMP("IBCNEQUX",$JOB))_":0"
+6 SET DIR("A")="Select entry to request electronic inquiry"
+7 SET DIR("?",1)=" Select an entry to initiate an insurance inquiry."
+8 SET DIR("?",2)=" If entry contains an Insurance Co name, an Insurance"
+9 SET DIR("?",3)=" Buffer entry will be created for nightly batch extract."
+10 SET DIR("?")=" "
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)!$DATA(DUOUT)!(Y<1)
GOTO SELX
+13 SET IBSELN=$ORDER(^TMP("IBCNEQU",$JOB,"IDX",Y,0))
+14 IF IBSELN
SET IBSELN=$PIECE($GET(^TMP("IBCNEQUX",$JOB,IBSELN)),U,2,99)
+15 IF $EXTRACT($PIECE(IBSELN,U,3))="*"
WRITE !
Begin DoDot:1
+16 SET DIR(0)="EA"
+17 SET DIR("A",1)=""
+18 SET DIR("A",2)="Selected policy has an existing buffer entry."
+19 SET DIR("A",3)="You must first process the existing buffer entry."
+20 SET DIR("A")="Press RETURN to continue "
DO ^DIR
KILL DIR
WRITE !
+21 QUIT
End DoDot:1
SET IBSELN=""
GOTO SELX
+22 ;
+23 ; Get service type code
+24 DO STC
+25 ; '^' entered thus backup a level & re-ask Insurance question
IF X="^"
SET IBSELN=""
GOTO SELX
+26 ; Get eligibility date
+27 SET IBELIGDT=$$ELIGDT()
IF 'IBELIGDT
SET IBSELN=""
GOTO SELX
+28 WRITE !
+29 SET DIR(0)="Y"
+30 SET DIR("A")="Are you sure you want to request an insurance inquiry"
+31 SET DIR("B")="NO"
+32 SET DIR("?",1)=" If yes, a request will be created for the nightly batch."
+33 DO ^DIR
KILL DIR
+34 IF $DATA(DIRUT)!$DATA(DUOUT)!('Y)
SET IBSELN=""
+35 ;
SELX QUIT IBSELN
+1 ;
STC ; Ask for service type code to send
+1 ; IB*582/HN - Modified Default Service Type Code to pull from the MCCF Billing Parameters File (350.9,60.01)
+2 NEW DIR,X,Y
+3 ; IBEISTC used as STC variable
+4 SET IBEISTC=""
+5 SET DIR(0)="PAO^365.013:EMZ"
SET DIR("A")="Enter Service Type Code: "
+6 SET DIR("B")=$$GET1^DIQ(350.9,1_",",60.01,"E")
+7 SET DIR("??")="^D HELPSTC2^IBCNEQU"
STCEN ; Intital and re-enterant tag upon error
+1 DO ^DIR
if X="^"
QUIT
+2 ; Check to verify code is active, if not, display error and ask again
+3 IF $PIECE($GET(Y(0)),U,3)'=""
WRITE !,"Code selected is not an active code - please select another code.",!
GOTO STCEN
+4 ; If valid STC entered, set IBEISTC to be STC IEN. If no code entered, default to service code 30
+5 ;S IBEISTC=$S(+Y>0:$P(Y,U,1),1:$O(^IBE(365.013,"B",30,"")))
+6 ; If valid STC entered, set IBEISTC to be STCIEN.
+7 SET IBEISTC=$PIECE(Y,U,1)
+8 QUIT
+9 ;
FASTEXIT ; Sets flag to indicate a quick exit from the option
+1 NEW DIR,DIRUT,X,Y
+2 SET VALMBCK="Q"
+3 DO FULL^VALM1
+4 SET DIR(0)="Y"
SET DIR("A")="Exit option entirely"
SET DIR("B")="NO"
+5 DO ^DIR
+6 IF +Y
SET IBFASTXT=1
+7 QUIT
+8 ;
HELPSTC2 ; Text to display in response to '??' entry
+1 NEW DIR
+2 DO FULL^VALM1
+3 WRITE @IOF
+4 ;IB*732/DTG start - change help text to reflect code is dictionary driven
+5 WRITE !,"Enter the single SERVICE TYPE CODE to be sent with inquiry or press"
+6 WRITE !,"'ENTER' to send default service type code. The default service type"
+7 WRITE !,"code may auto-update. All other service types will not auto-update."
+8 ;IB*732/DTG end - change help text to reflect code is dictionary driven
+9 QUIT
+10 ;
ELIGDT() ; Prompt user for eligibility date
+1 NEW DIR,X,Y,DIRUT,DUOUT,STARTDT,ENDDT,ELIGDT
+2 SET ELIGDT=""
+3 ; start date within the last 12 months
DO DT^DILF(,"T-12M",.STARTDT)
+4 ; allow end date up to the end of the current month
+5 ; ICR#10103 this call returns the last day of the current month at 1 AM. If not time was sent, it would actually return the next to last day at 2400 hours.
SET ENDDT=$$SCH^XLFDT("1M(L@1A)",DT)\1
+6 SET DIR(0)="DA^"_STARTDT_":"_ENDDT_":"_"EX"
SET DIR("A")="Enter Eligibility Date: "
SET DIR("B")="TODAY"
+7 SET DIR("?",1)="Select an eligibility date to be sent in the inquiry."
+8 SET DIR("?")="Date must be within the last 12 months or up to the end of the current month."
+9 DO ^DIR
+10 IF $DATA(DIRUT)!$DATA(DUOUT)!('Y)
GOTO ELIGDTX
+11 SET ELIGDT=Y
ELIGDTX ;
+1 QUIT ELIGDT
+2 ;
MBIREQ ; User requested a MBI lookup request
+1 ;/vd-IB*2*668 - Added the variable APIEN
+2 NEW APIEN,DIR,X,Y,DIRUT,DUOUT
+3 NEW IBMBIPYR,IBBUF,IBFDA
+4 ;
+5 DO FULL^VALM1
+6 SET VALMBCK="R"
+7 KILL DIR
+8 ;
+9 ; see if the MBI PAYER site parameter has been populated
+10 SET IBMBIPYR=+$$GET1^DIQ(350.9,"1,","MBI PAYER","I")
+11 IF 'IBMBIPYR
Begin DoDot:1
+12 WRITE !!," The required MBI Payer site parameter is not populated; try again later",!
+13 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO MBIREQX
+14 ;
+15 ;/vd-IB*2*668
SET APIEN=$$PYRAPP^IBCNEUT5("EIV",IBMBIPYR)
+16 ;/vd-IB*2*668 - Replaced the following 2 lines of code to remove a hardcoded value.
+17 ;I '($$GET1^DIQ(365.121,"1,"_IBMBIPYR_",",.02,"I")) D G MBIREQX
+18 ;. W !!," The MBI Payer is not nationally active; try again later",!
+19 IF '($$GET1^DIQ(365.121,APIEN_","_IBMBIPYR_",",.02,"I"))
Begin DoDot:1
+20 WRITE !!," The MBI Payer is not NATIONALLY Enabled; try again later",!
+21 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO MBIREQX
+22 ;
+23 ;/vd-IB*2*668 - Replaced the following 2 lines of code to remove a hardcoded value.
+24 ;I '($$GET1^DIQ(365.121,"1,"_IBMBIPYR_",",.03,"I")) D G MBIREQX
+25 ;. W !!," The MBI Payer LOCAL ACTIVE field is set to 'NO'; it must be 'YES' to proceed",!
+26 IF '($$GET1^DIQ(365.121,APIEN_","_IBMBIPYR_",",.03,"I"))
Begin DoDot:1
+27 WRITE !!," The MBI Payer is not LOCALLY Enabled; try again later",!
+28 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO MBIREQX
+29 ;
+30 ; ; ICR#10061
DO DEM^VADPT
+31 IF ($PIECE(VADM(2),U)="")!($PIECE(VADM(3),U)="")
Begin DoDot:1
+32 WRITE !!," SSN and DOB are required fields, they must be populated in order to proceed",!
+33 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
GOTO MBIREQX
+34 ;
+35 SET DIR(0)="Y"
+36 SET DIR("A")="Are you sure you want to request this Patient's Medicare Beneficiary ID"
+37 SET DIR("B")="YES"
+38 SET DIR("?",1)=" If yes, a MBI request will be initiated immediately."
+39 SET DIR("?")=" If no, the MBI request will be cancelled."
+40 DO ^DIR
KILL DIR
+41 IF $DATA(DIRUT)!$DATA(DUOUT)!('Y)
GOTO MBIREQX
+42 ;
+43 ;write a buffer entry
+44 ;the real time process will set the patient relationship to self automatically
+45 ;patient fields, name, dob and ssn will be populated automatically
+46 KILL IBBUF
+47 ; Entered By
SET IBBUF(.02)=DUZ
+48 ; Buffer Symbol
SET IBBUF(.12)=$PIECE($$PAYER^IBCNEUT4(IBMBIPYR),U)
+49 SET IBBUF(20.01)=$$GET1^DIQ(350.9,"1,","MBI PAYER","E")
+50 ; Patient IEN
SET IBBUF(60.01)=DFN
+51 ; MBI placeholder for subscriber ID
SET IBBUF(90.03)="MBIrequest"
+52 ; patient (subscriber) name
SET IBBUF(91.01)=VADM(1)
+53 ; the following call in-turn, calls EDITSTF^IBCNBES which will make sure to file subscriber ID last, automatically
+54 SET IBFDA=$$ADDSTF^IBCNBES($$FIND1^DIC(355.12,,,"MEDICARE","C"),DFN,.IBBUF)
+55 ;
+56 WRITE !!,"The MBI request was successful, check the buffer for results.",!
+57 SET DIR(0)="E"
DO ^DIR
KILL DIR
+58 SET VALMBCK="Q"
+59 QUIT
MBIREQX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
