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

IBNCPIV.m

Go to the documentation of this file. 
  1. IBNCPIV ;ALB/ESG - Manual Rx Eligibility Verification ;23-SEP-2010
  1.  ;;2.0;INTEGRATED BILLING;**435,452**;21-MAR-94;Build 26
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; Reference to EN^BPSNCPD9 supported by IA# 5576
  1.  ; Reference to PID^VADPT6 supported by IA# 10062
  1.  ; Reference to DT^DICRW supported by IA# 10005
  1.  ;
  1.  Q
  1.  ;
  1. EN ; -- main entry point for IBNCPDP INS ELIG VER INQ
  1.  N IBNCPIVD,DFN
  1.  D DT^DICRW
  1.  S IBNCPIVD=DT      ; first time in compile Active Rx ins as of today
  1.  D EN^VALM("IBNCPDP INS ELIG VER INQ")
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  N VA,NAME
  1.  D PID^VADPT6
  1.  S NAME=$P($G(^DPT($G(DFN),0)),U,1)
  1.  S VALMHDR(1)="Perform Rx Eligibility Insurance Inquiry"
  1.  S VALMHDR(2)="   Patient: "_$E(NAME,1,20)_"  ("_$E(NAME)_$G(VA("BID"))_")"
  1.  S VALMHDR(3)="   Showing: All Insurance Policies on File"
  1.  I $G(IBNCPIVD) S VALMHDR(3)="   Showing: Active Rx Policies as of Effective Date "_$$FMTE^XLFDT(IBNCPIVD,"2Z")
  1.  S VALMHDR(4)=" "
  1.  I +$$BUFFER^IBCNBU1($G(DFN)) S VALMHDR(4)="    Buffer: *** Patient has Insurance Buffer Records ***"
  1.  Q
  1.  ;
  1. INIT ; Build the list of valid insurance policies
  1.  D INIT^IBCNSM4
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("IBNSM",$J),^TMP("IBNSMDX",$J)
  1.  D CLEAN^VALM10
  1.  Q
  1.  ;
  1. SEND ; send the ELIG inquiry
  1.  N VALMY,IBDATA,IBRES,IBX,IBY,IBPPOL,INSIEN,INSNM,GENERR,IBPL,IBCDFN,EPHPLAN,IBSTL,LIST,G,IBSTA,TXT,DEFDT
  1.  N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,DIC,LOCKFLG,IBREL,IBPER
  1.  D FULL^VALM1
  1.  D EN^VALM2($G(XQORNOD(0)),"S")    ; user selection - 1 entry from the list
  1.  I '$D(VALMY) G SENDX
  1.  S IBX=$O(VALMY(0)) I 'IBX G SENDX
  1.  S IBPPOL=$G(^TMP("IBNSMDX",$J,+$O(^TMP("IBNSM",$J,"IDX",IBX,0))))
  1.  I IBPPOL="" W !!,$T(+0)_" - System error - policy data not found!" D PAUSE^VALM1 G SENDX
  1.  S INSIEN=+$P(IBPPOL,U,5)                ; file 36 ien
  1.  S INSNM=$P($G(^DIC(36,INSIEN,0)),U,1)   ; ins company name
  1.  S GENERR="Unable to submit Eligibility Verification Inquiry to "_INSNM_"."
  1.  S IBPL=+$P(IBPPOL,U,22)                 ; plan file 355.3 ien
  1.  I 'IBPL W !!,GENERR,!,"This policy has no plan." D PAUSE^VALM1 G SENDX
  1.  S IBDATA("PLAN")=IBPL                   ; plan file 355.3 ien
  1.  S IBCDFN=+$P(IBPPOL,U,4)                ; subfile 2.312 ien
  1.  ;
  1.  ; lock check
  1.  L +^IBDPTL(DFN,IBCDFN):$G(DILOCKTM,3)
  1.  E  W !!,GENERR,!,"Another user is currently processing the same patient and policy!" D PAUSE^VALM1 G SENDX
  1.  S LOCKFLG=1
  1.  ;
  1.  S EPHPLAN=+$P($G(^IBA(355.3,IBPL,6)),U,1)   ; epharmacy plan ien
  1.  I 'EPHPLAN W !!,GENERR,!,"This policy's plan is not linked with an ePharmacy plan." D PAUSE^VALM1 G SENDX
  1.  ;
  1.  ; scan for any other errors and display them all
  1.  K IBY D STCHK^IBCNRU1(EPHPLAN,.IBY,1)
  1.  I $E($G(IBY(1)))'="A" D  G SENDX
  1.  . S IBSTL=$G(IBY(6))         ; list of error msg code#'s
  1.  . K LIST
  1.  . D STATAR^IBCNRU1(.LIST)    ; build the list of error messages
  1.  . W !!,GENERR
  1.  . F G=1:1:$L(IBSTL,",") S IBSTA=+$P(IBSTL,",",G),TXT=$G(LIST(IBSTA)) I TXT'="" W !,TXT
  1.  . D PAUSE^VALM1
  1.  . Q
  1.  ;
  1.  ; Ask for Effective Date for the ELIG transmission
  1.  S DEFDT=$G(IBNCPIVD)
  1.  I 'DEFDT S DEFDT=DT   ; default date
  1.  S DIR(0)="D"
  1.  S DIR("A")="Effective Date"
  1.  S DIR("?")="Enter the Date for which to perform the Eligibility Verification check."
  1.  S DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z")
  1.  W ! D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT)!('Y) G SENDX
  1.  ;
  1.  ; check for pharmacy coverage as of this date
  1.  I '$$PLCOV^IBCNSU3(IBPL,Y,3) W !!,GENERR,!,"This policy has no Active Pharmacy Coverage on this date." D PAUSE^VALM1 G SENDX
  1.  S IBDATA("DOS")=Y
  1.  ;
  1.  ; Ask for Relationship Code
  1.  S IBREL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),U,16)    ; pt. relationship to insured (2.312,16)
  1.  I IBREL'<4 S IBREL=4
  1.  S DIC=9002313.19
  1.  S DIC(0)="AEQZ"
  1.  S DIC("A")="Relationship Code: "
  1.  S DIC("B")=IBREL
  1.  W ! D ^DIC K DIC
  1.  I $D(DTOUT)!$D(DUOUT)!(Y'>0) G SENDX
  1.  S IBDATA("REL CODE")=$P(Y,U,2)
  1.  ;
  1.  ; Ask for Person Code
  1.  S IBPER=IBDATA("REL CODE")
  1.  S IBPER=$S(IBPER:0_IBPER,1:"01")    ; base the default value on the selected relationship code
  1.  S DIR(0)="FO^1:3"
  1.  S DIR("A")="Person Code"
  1.  S DIR("?",1)="Enter the Specific Person Code Assigned to the Patient by the Payer."
  1.  S DIR("?",2)="This is a code assigned to a specific person within a family."
  1.  S DIR("?",3)=" "
  1.  S DIR("?",4)="Enrollment Standard Examples"
  1.  S DIR("?",5)="----------------------------"
  1.  S DIR("?",6)="001=Cardholder"
  1.  S DIR("?",7)="002=Spouse"
  1.  S DIR("?")="003-999=Dependents and Others (including second spouses, etc.)"
  1.  S DIR("B")=IBPER
  1.  W ! D ^DIR K DIR
  1.  I $D(DTOUT)!$D(DUOUT) G SENDX
  1.  S IBDATA("PERSON CODE")=Y
  1.  ;
  1.  ; call BPS to send the elig transaction
  1.  S IBRES=$$EN^BPSNCPD9(DFN,.IBDATA)
  1.  ;
  1.  ; success!
  1.  I +IBRES W !!,"Eligibility Verification Inquiry sent to "_INSNM_".",!,$P(IBRES,U,2) D PAUSE^VALM1 G SENDX
  1.  ;
  1.  ; error
  1.  W !!,"Failure to submit Eligibility Verification Inquiry to "_INSNM_"."
  1.  W !,$P(IBRES,U,2)
  1.  D PAUSE^VALM1
  1.  ;
  1. SENDX ;
  1.  I $G(LOCKFLG) L -^IBDPTL(DFN,IBCDFN)    ; unlock
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. CP ; Change Patient
  1.  N VALMQUIT,IBDFN
  1.  D FULL^VALM1
  1.  S IBDFN=$G(DFN)
  1.  W ! D PAT^IBCNSM
  1.  I $D(VALMQUIT) S DFN=IBDFN
  1.  I IBDFN=$G(DFN) G CPX   ; no changes
  1.  K VALMHDR
  1.  D INIT
  1. CPX ;
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. CHGD ; change the date for the screen display
  1.  N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT,ORIG,DEFDT
  1.  S (ORIG,DEFDT)=$G(IBNCPIVD)     ; save the original value coming in
  1.  I 'DEFDT S DEFDT=DT             ; always have a default date
  1.  D FULL^VALM1
  1.  S DIR(0)="D"
  1.  S DIR("A")="Enter the Effective Date"
  1.  S DIR("B")=$$FMTE^XLFDT(DEFDT,"2Z")
  1.  S DIR("?",1)="Please enter the effective date to be used in order to look-up active"
  1.  S DIR("?",2)="pharmacy insurance policies as of this effective date.  The effective"
  1.  S DIR("?",3)="date used for the current screen display is found in the header of"
  1.  S DIR("?")="this screen unless ALL insurance policies are displayed."
  1.  W ! D ^DIR K DIR
  1.  I Y S IBNCPIVD=Y
  1.  I ORIG=$G(IBNCPIVD) G CHGDX   ; no changes to date
  1.  K VALMHDR
  1.  D INIT
  1. CHGDX ;
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. TOGGLE ; toggle the display between all ins policies and Rx only policies
  1.  ;
  1.  N CASE,TEXT,PROMPT,X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
  1.  D FULL^VALM1
  1.  ;
  1.  I $G(IBNCPIVD) D
  1.  . S CASE=1
  1.  . S TEXT="The screen is now showing Active Rx Insurance as of "_$$FMTE^XLFDT(IBNCPIVD,"2Z")_"."
  1.  . S PROMPT="Do you want to display ALL insurance on file"
  1.  . Q
  1.  ;
  1.  I '$G(IBNCPIVD) D
  1.  . S CASE=2
  1.  . S TEXT="The screen is now showing ALL insurance on file."
  1.  . S PROMPT="Do you want to display only Active Rx Insurance"
  1.  . Q
  1.  ;
  1.  S DIR(0)="Y"
  1.  S DIR("A")=PROMPT
  1.  S DIR("A",1)=TEXT
  1.  S DIR("B")="YES"
  1.  W ! D ^DIR K DIR
  1.  I 'Y G TOGGX        ; user said NO, no changes so get out
  1.  ;
  1.  I CASE=1 K IBNCPIVD,VALMHDR D INIT G TOGGX     ; change to ALL insurance/rebuild list
  1.  ;
  1.  D CHGD    ; change to Active Rx only ins/get effective date & rebuild list
  1.  ;
  1. TOGGX ;
  1.  S VALMBCK="R"
  1.  Q
  1.  ;