IBNCPIV ;ALB/ESG - Manual Rx Eligibility Verification ;23-SEP-2010
;;2.0;INTEGRATED BILLING;**435,452**;21-MAR-94;Build 26
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to EN^BPSNCPD9 supported by IA# 5576
; Reference to PID^VADPT6 supported by IA# 10062
; Reference to DT^DICRW supported by IA# 10005
;
Q
;
EN ; -- main entry point for IBNCPDP INS ELIG VER INQ
N IBNCPIVD,DFN
D DT^DICRW
S IBNCPIVD=DT ; first time in compile Active Rx ins as of today
D EN^VALM("IBNCPDP INS ELIG VER INQ")
Q
;
HDR ; -- header code
N VA,NAME
D PID^VADPT6
S NAME=$P($G(^DPT($G(DFN),0)),U,1)
S VALMHDR(1)="Perform Rx Eligibility Insurance Inquiry"
S VALMHDR(2)=" Patient: "_$E(NAME,1,20)_" ("_$E(NAME)_$G(VA("BID"))_")"
S VALMHDR(3)=" Showing: All Insurance Policies on File"
I $G(IBNCPIVD) S VALMHDR(3)=" Showing: Active Rx Policies as of Effective Date "_$$FMTE^XLFDT(IBNCPIVD,"2Z")
S VALMHDR(4)=" "
I +$$BUFFER^IBCNBU1($G(DFN)) S VALMHDR(4)=" Buffer: *** Patient has Insurance Buffer Records ***"
Q
;
INIT ; Build the list of valid insurance policies
D INIT^IBCNSM4
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBNSM",$J),^TMP("IBNSMDX",$J)
D CLEAN^VALM10
Q
;
SEND ; send the ELIG inquiry
N VALMY,IBDATA,IBRES,IBX,IBY,IBPPOL,INSIEN,INSNM,GENERR,IBPL,IBCDFN,EPHPLAN,IBSTL,LIST,G,IBSTA,TXT,DEFDT
N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,DIC,LOCKFLG,IBREL,IBPER
D FULL^VALM1
D EN^VALM2($G(XQORNOD(0)),"S") ; user selection - 1 entry from the list
I '$D(VALMY) G SENDX
S IBX=$O(VALMY(0)) I 'IBX G SENDX
S IBPPOL=$G(^TMP("IBNSMDX",$J,+$O(^TMP("IBNSM",$J,"IDX",IBX,0))))
I IBPPOL="" W !!,$T(+0)_" - System error - policy data not found!" D PAUSE^VALM1 G SENDX
S INSIEN=+$P(IBPPOL,U,5) ; file 36 ien
S INSNM=$P($G(^DIC(36,INSIEN,0)),U,1) ; ins company name
S GENERR="Unable to submit Eligibility Verification Inquiry to "_INSNM_"."
S IBPL=+$P(IBPPOL,U,22) ; plan file 355.3 ien
I 'IBPL W !!,GENERR,!,"This policy has no plan." D PAUSE^VALM1 G SENDX
S IBDATA("PLAN")=IBPL ; plan file 355.3 ien
S IBCDFN=+$P(IBPPOL,U,4) ; subfile 2.312 ien
;
; lock check
L +^IBDPTL(DFN,IBCDFN):$G(DILOCKTM,3)
E W !!,GENERR,!,"Another user is currently processing the same patient and policy!" D PAUSE^VALM1 G SENDX
S LOCKFLG=1
;
S EPHPLAN=+$P($G(^IBA(355.3,IBPL,6)),U,1) ; epharmacy plan ien
I 'EPHPLAN W !!,GENERR,!,"This policy's plan is not linked with an ePharmacy plan." D PAUSE^VALM1 G SENDX
;
; scan for any other errors and display them all
K IBY D STCHK^IBCNRU1(EPHPLAN,.IBY,1)
I $E($G(IBY(1)))'="A" D G SENDX
. S IBSTL=$G(IBY(6)) ; list of error msg code#'s
. K LIST
. D STATAR^IBCNRU1(.LIST) ; build the list of error messages
. W !!,GENERR
. F G=1:1:$L(IBSTL,",") S IBSTA=+$P(IBSTL,",",G),TXT=$G(LIST(IBSTA)) I TXT'="" W !,TXT
. D PAUSE^VALM1
. Q
;
; Ask for Effective Date for the ELIG transmission
S DEFDT=$G(IBNCPIVD)
I 'DEFDT S DEFDT=DT ; default date
S DIR(0)="D"
S DIR("A")="Effective Date"
S DIR("?")="Enter the Date for which to perform the Eligibility Verification check."
S DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z")
W ! D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!('Y) G SENDX
;
; check for pharmacy coverage as of this date
I '$$PLCOV^IBCNSU3(IBPL,Y,3) W !!,GENERR,!,"This policy has no Active Pharmacy Coverage on this date." D PAUSE^VALM1 G SENDX
S IBDATA("DOS")=Y
;
; Ask for Relationship Code
S IBREL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),U,16) ; pt. relationship to insured (2.312,16)
I IBREL'<4 S IBREL=4
S DIC=9002313.19
S DIC(0)="AEQZ"
S DIC("A")="Relationship Code: "
S DIC("B")=IBREL
W ! D ^DIC K DIC
I $D(DTOUT)!$D(DUOUT)!(Y'>0) G SENDX
S IBDATA("REL CODE")=$P(Y,U,2)
;
; Ask for Person Code
S IBPER=IBDATA("REL CODE")
S IBPER=$S(IBPER:0_IBPER,1:"01") ; base the default value on the selected relationship code
S DIR(0)="FO^1:3"
S DIR("A")="Person Code"
S DIR("?",1)="Enter the Specific Person Code Assigned to the Patient by the Payer."
S DIR("?",2)="This is a code assigned to a specific person within a family."
S DIR("?",3)=" "
S DIR("?",4)="Enrollment Standard Examples"
S DIR("?",5)="----------------------------"
S DIR("?",6)="001=Cardholder"
S DIR("?",7)="002=Spouse"
S DIR("?")="003-999=Dependents and Others (including second spouses, etc.)"
S DIR("B")=IBPER
W ! D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) G SENDX
S IBDATA("PERSON CODE")=Y
;
; call BPS to send the elig transaction
S IBRES=$$EN^BPSNCPD9(DFN,.IBDATA)
;
; success!
I +IBRES W !!,"Eligibility Verification Inquiry sent to "_INSNM_".",!,$P(IBRES,U,2) D PAUSE^VALM1 G SENDX
;
; error
W !!,"Failure to submit Eligibility Verification Inquiry to "_INSNM_"."
W !,$P(IBRES,U,2)
D PAUSE^VALM1
;
SENDX ;
I $G(LOCKFLG) L -^IBDPTL(DFN,IBCDFN) ; unlock
S VALMBCK="R"
Q
;
CP ; Change Patient
N VALMQUIT,IBDFN
D FULL^VALM1
S IBDFN=$G(DFN)
W ! D PAT^IBCNSM
I $D(VALMQUIT) S DFN=IBDFN
I IBDFN=$G(DFN) G CPX ; no changes
K VALMHDR
D INIT
CPX ;
S VALMBCK="R"
Q
;
CHGD ; change the date for the screen display
N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,ORIG,DEFDT
S (ORIG,DEFDT)=$G(IBNCPIVD) ; save the original value coming in
I 'DEFDT S DEFDT=DT ; always have a default date
D FULL^VALM1
S DIR(0)="D"
S DIR("A")="Enter the Effective Date"
S DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z")
S DIR("?",1)="Please enter the effective date to be used in order to look-up active"
S DIR("?",2)="pharmacy insurance policies as of this effective date. The effective"
S DIR("?",3)="date used for the current screen display is found in the header of"
S DIR("?")="this screen unless ALL insurance policies are displayed."
W ! D ^DIR K DIR
I Y S IBNCPIVD=Y
I ORIG=$G(IBNCPIVD) G CHGDX ; no changes to date
K VALMHDR
D INIT
CHGDX ;
S VALMBCK="R"
Q
;
TOGGLE ; toggle the display between all ins policies and Rx only policies
;
N CASE,TEXT,PROMPT,X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
D FULL^VALM1
;
I $G(IBNCPIVD) D
. S CASE=1
. S TEXT="The screen is now showing Active Rx Insurance as of "_$$FMTE^XLFDT(IBNCPIVD,"2Z")_"."
. S PROMPT="Do you want to display ALL insurance on file"
. Q
;
I '$G(IBNCPIVD) D
. S CASE=2
. S TEXT="The screen is now showing ALL insurance on file."
. S PROMPT="Do you want to display only Active Rx Insurance"
. Q
;
S DIR(0)="Y"
S DIR("A")=PROMPT
S DIR("A",1)=TEXT
S DIR("B")="YES"
W ! D ^DIR K DIR
I 'Y G TOGGX ; user said NO, no changes so get out
;
I CASE=1 K IBNCPIVD,VALMHDR D INIT G TOGGX ; change to ALL insurance/rebuild list
;
D CHGD ; change to Active Rx only ins/get effective date & rebuild list
;
TOGGX ;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPIV 6945 printed Apr 09, 2024@21:07:24 Page 2
IBNCPIV ;ALB/ESG - Manual Rx Eligibility Verification ;23-SEP-2010
+1 ;;2.0;INTEGRATED BILLING;**435,452**;21-MAR-94;Build 26
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to EN^BPSNCPD9 supported by IA# 5576
+5 ; Reference to PID^VADPT6 supported by IA# 10062
+6 ; Reference to DT^DICRW supported by IA# 10005
+7 ;
+8 QUIT
+9 ;
EN ; -- main entry point for IBNCPDP INS ELIG VER INQ
+1 NEW IBNCPIVD,DFN
+2 DO DT^DICRW
+3 ; first time in compile Active Rx ins as of today
SET IBNCPIVD=DT
+4 DO EN^VALM("IBNCPDP INS ELIG VER INQ")
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW VA,NAME
+2 DO PID^VADPT6
+3 SET NAME=$PIECE($GET(^DPT($GET(DFN),0)),U,1)
+4 SET VALMHDR(1)="Perform Rx Eligibility Insurance Inquiry"
+5 SET VALMHDR(2)=" Patient: "_$EXTRACT(NAME,1,20)_" ("_$EXTRACT(NAME)_$GET(VA("BID"))_")"
+6 SET VALMHDR(3)=" Showing: All Insurance Policies on File"
+7 IF $GET(IBNCPIVD)
SET VALMHDR(3)=" Showing: Active Rx Policies as of Effective Date "_$$FMTE^XLFDT(IBNCPIVD,"2Z")
+8 SET VALMHDR(4)=" "
+9 IF +$$BUFFER^IBCNBU1($GET(DFN))
SET VALMHDR(4)=" Buffer: *** Patient has Insurance Buffer Records ***"
+10 QUIT
+11 ;
INIT ; Build the list of valid insurance policies
+1 DO INIT^IBCNSM4
+2 QUIT
+3 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBNSM",$JOB),^TMP("IBNSMDX",$JOB)
+2 DO CLEAN^VALM10
+3 QUIT
+4 ;
SEND ; send the ELIG inquiry
+1 NEW VALMY,IBDATA,IBRES,IBX,IBY,IBPPOL,INSIEN,INSNM,GENERR,IBPL,IBCDFN,EPHPLAN,IBSTL,LIST,G,IBSTA,TXT,DEFDT
+2 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,DIC,LOCKFLG,IBREL,IBPER
+3 DO FULL^VALM1
+4 ; user selection - 1 entry from the list
DO EN^VALM2($GET(XQORNOD(0)),"S")
+5 IF '$DATA(VALMY)
GOTO SENDX
+6 SET IBX=$ORDER(VALMY(0))
IF 'IBX
GOTO SENDX
+7 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,+$ORDER(^TMP("IBNSM",$JOB,"IDX",IBX,0))))
+8 IF IBPPOL=""
WRITE !!,$TEXT(+0)_" - System error - policy data not found!"
DO PAUSE^VALM1
GOTO SENDX
+9 ; file 36 ien
SET INSIEN=+$PIECE(IBPPOL,U,5)
+10 ; ins company name
SET INSNM=$PIECE($GET(^DIC(36,INSIEN,0)),U,1)
+11 SET GENERR="Unable to submit Eligibility Verification Inquiry to "_INSNM_"."
+12 ; plan file 355.3 ien
SET IBPL=+$PIECE(IBPPOL,U,22)
+13 IF 'IBPL
WRITE !!,GENERR,!,"This policy has no plan."
DO PAUSE^VALM1
GOTO SENDX
+14 ; plan file 355.3 ien
SET IBDATA("PLAN")=IBPL
+15 ; subfile 2.312 ien
SET IBCDFN=+$PIECE(IBPPOL,U,4)
+16 ;
+17 ; lock check
+18 LOCK +^IBDPTL(DFN,IBCDFN):$GET(DILOCKTM,3)
+19 IF '$TEST
WRITE !!,GENERR,!,"Another user is currently processing the same patient and policy!"
DO PAUSE^VALM1
GOTO SENDX
+20 SET LOCKFLG=1
+21 ;
+22 ; epharmacy plan ien
SET EPHPLAN=+$PIECE($GET(^IBA(355.3,IBPL,6)),U,1)
+23 IF 'EPHPLAN
WRITE !!,GENERR,!,"This policy's plan is not linked with an ePharmacy plan."
DO PAUSE^VALM1
GOTO SENDX
+24 ;
+25 ; scan for any other errors and display them all
+26 KILL IBY
DO STCHK^IBCNRU1(EPHPLAN,.IBY,1)
+27 IF $EXTRACT($GET(IBY(1)))'="A"
Begin DoDot:1
+28 ; list of error msg code#'s
SET IBSTL=$GET(IBY(6))
+29 KILL LIST
+30 ; build the list of error messages
DO STATAR^IBCNRU1(.LIST)
+31 WRITE !!,GENERR
+32 FOR G=1:1:$LENGTH(IBSTL,",")
SET IBSTA=+$PIECE(IBSTL,",",G)
SET TXT=$GET(LIST(IBSTA))
IF TXT'=""
WRITE !,TXT
+33 DO PAUSE^VALM1
+34 QUIT
End DoDot:1
GOTO SENDX
+35 ;
+36 ; Ask for Effective Date for the ELIG transmission
+37 SET DEFDT=$GET(IBNCPIVD)
+38 ; default date
IF 'DEFDT
SET DEFDT=DT
+39 SET DIR(0)="D"
+40 SET DIR("A")="Effective Date"
+41 SET DIR("?")="Enter the Date for which to perform the Eligibility Verification check."
+42 SET DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z")
+43 WRITE !
DO ^DIR
KILL DIR
+44 IF $DATA(DTOUT)!$DATA(DUOUT)!('Y)
GOTO SENDX
+45 ;
+46 ; check for pharmacy coverage as of this date
+47 IF '$$PLCOV^IBCNSU3(IBPL,Y,3)
WRITE !!,GENERR,!,"This policy has no Active Pharmacy Coverage on this date."
DO PAUSE^VALM1
GOTO SENDX
+48 SET IBDATA("DOS")=Y
+49 ;
+50 ; Ask for Relationship Code
+51 ; pt. relationship to insured (2.312,16)
SET IBREL=+$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),U,16)
+52 IF IBREL'<4
SET IBREL=4
+53 SET DIC=9002313.19
+54 SET DIC(0)="AEQZ"
+55 SET DIC("A")="Relationship Code: "
+56 SET DIC("B")=IBREL
+57 WRITE !
DO ^DIC
KILL DIC
+58 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y'>0)
GOTO SENDX
+59 SET IBDATA("REL CODE")=$PIECE(Y,U,2)
+60 ;
+61 ; Ask for Person Code
+62 SET IBPER=IBDATA("REL CODE")
+63 ; base the default value on the selected relationship code
SET IBPER=$SELECT(IBPER:0_IBPER,1:"01")
+64 SET DIR(0)="FO^1:3"
+65 SET DIR("A")="Person Code"
+66 SET DIR("?",1)="Enter the Specific Person Code Assigned to the Patient by the Payer."
+67 SET DIR("?",2)="This is a code assigned to a specific person within a family."
+68 SET DIR("?",3)=" "
+69 SET DIR("?",4)="Enrollment Standard Examples"
+70 SET DIR("?",5)="----------------------------"
+71 SET DIR("?",6)="001=Cardholder"
+72 SET DIR("?",7)="002=Spouse"
+73 SET DIR("?")="003-999=Dependents and Others (including second spouses, etc.)"
+74 SET DIR("B")=IBPER
+75 WRITE !
DO ^DIR
KILL DIR
+76 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO SENDX
+77 SET IBDATA("PERSON CODE")=Y
+78 ;
+79 ; call BPS to send the elig transaction
+80 SET IBRES=$$EN^BPSNCPD9(DFN,.IBDATA)
+81 ;
+82 ; success!
+83 IF +IBRES
WRITE !!,"Eligibility Verification Inquiry sent to "_INSNM_".",!,$PIECE(IBRES,U,2)
DO PAUSE^VALM1
GOTO SENDX
+84 ;
+85 ; error
+86 WRITE !!,"Failure to submit Eligibility Verification Inquiry to "_INSNM_"."
+87 WRITE !,$PIECE(IBRES,U,2)
+88 DO PAUSE^VALM1
+89 ;
SENDX ;
+1 ; unlock
IF $GET(LOCKFLG)
LOCK -^IBDPTL(DFN,IBCDFN)
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
CP ; Change Patient
+1 NEW VALMQUIT,IBDFN
+2 DO FULL^VALM1
+3 SET IBDFN=$GET(DFN)
+4 WRITE !
DO PAT^IBCNSM
+5 IF $DATA(VALMQUIT)
SET DFN=IBDFN
+6 ; no changes
IF IBDFN=$GET(DFN)
GOTO CPX
+7 KILL VALMHDR
+8 DO INIT
CPX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
CHGD ; change the date for the screen display
+1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,ORIG,DEFDT
+2 ; save the original value coming in
SET (ORIG,DEFDT)=$GET(IBNCPIVD)
+3 ; always have a default date
IF 'DEFDT
SET DEFDT=DT
+4 DO FULL^VALM1
+5 SET DIR(0)="D"
+6 SET DIR("A")="Enter the Effective Date"
+7 SET DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z")
+8 SET DIR("?",1)="Please enter the effective date to be used in order to look-up active"
+9 SET DIR("?",2)="pharmacy insurance policies as of this effective date. The effective"
+10 SET DIR("?",3)="date used for the current screen display is found in the header of"
+11 SET DIR("?")="this screen unless ALL insurance policies are displayed."
+12 WRITE !
DO ^DIR
KILL DIR
+13 IF Y
SET IBNCPIVD=Y
+14 ; no changes to date
IF ORIG=$GET(IBNCPIVD)
GOTO CHGDX
+15 KILL VALMHDR
+16 DO INIT
CHGDX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
TOGGLE ; toggle the display between all ins policies and Rx only policies
+1 ;
+2 NEW CASE,TEXT,PROMPT,X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+3 DO FULL^VALM1
+4 ;
+5 IF $GET(IBNCPIVD)
Begin DoDot:1
+6 SET CASE=1
+7 SET TEXT="The screen is now showing Active Rx Insurance as of "_$$FMTE^XLFDT(IBNCPIVD,"2Z")_"."
+8 SET PROMPT="Do you want to display ALL insurance on file"
+9 QUIT
End DoDot:1
+10 ;
+11 IF '$GET(IBNCPIVD)
Begin DoDot:1
+12 SET CASE=2
+13 SET TEXT="The screen is now showing ALL insurance on file."
+14 SET PROMPT="Do you want to display only Active Rx Insurance"
+15 QUIT
End DoDot:1
+16 ;
+17 SET DIR(0)="Y"
+18 SET DIR("A")=PROMPT
+19 SET DIR("A",1)=TEXT
+20 SET DIR("B")="YES"
+21 WRITE !
DO ^DIR
KILL DIR
+22 ; user said NO, no changes so get out
IF 'Y
GOTO TOGGX
+23 ;
+24 ; change to ALL insurance/rebuild list
IF CASE=1
KILL IBNCPIVD,VALMHDR
DO INIT
GOTO TOGGX
+25 ;
+26 ; change to Active Rx only ins/get effective date & rebuild list
DO CHGD
+27 ;
TOGGX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
