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

IBAUTL6.m

Go to the documentation of this file. 
  1. IBAUTL6 ;AAS/ALB-RX EXEMPTION UTILITY ROUTINE (CONT.);2-NOV-92
  1.  ;;2.0;INTEGRATED BILLING;**34,195,385**;21-MAR-94;Build 35
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. ADDP ; -- Add patient to file 354
  1.  ; -- Input    : dfn    =  entry in patient file
  1.  ;    returns  : ibadd  =  0 if not added, 1 if added
  1.  ;
  1.  N DINUM,DLAYGO,X
  1.  I '$D(DT) D DT^DICRW
  1.  S IBWHER=11,IBEXERR=""
  1.  S IBADD=0
  1.  I $S('$D(DFN):1,'$D(^IBA(354)):1,$D(^IBA(354,DFN)):1,1:0) G ADDPQ
  1.  K DO,DD,DIC,DR,DA,DIE S DIC="^IBA(354,",DIC(0)="L",DLAYGO=354
  1.  L +^IBA(354,DFN):15 I $T,'$D(^IBA(354,DFN)) S (DINUM,X)=DFN D FILE^DICN I +Y>0 S IBADD=1
  1.  I IBADD'=1 S IBEXERR=9
  1.  L -^IBA(354,DFN)
  1.  ;
  1. ADDPQ K DO,DD,DIC,DR,DIE,DA
  1.  Q
  1.  ;
  1. ADDEX(IBEXREA,IBDT,IBHOW,IBTYPE,IBOLDAUT) ; -- add entry to 354.1 and update
  1.  ;  -- this will become the active entry for this effective date
  1.  ;     other entries for this effective date should be cancelled
  1.  ;     prior to making this call
  1.  ;
  1.  ;  -- input      dfn  =  pt ien (required)
  1.  ;            ibexrea  =  pointer to exemption reason file (required)
  1.  ;               ibdt  =  internal form of effective date (required)
  1.  ;              ibhow  =  1=system added, 2=user override (optional) default =1
  1.  ;             ibtype  =  type of exemption (optional)  default =1 (copay)
  1.  ;           iboldaut  = date (optional)  if defined is the date of a previous exemption status (automatic) that needs to be inactivated
  1.  ;
  1.  ;  -- returns  ibadde = ibexrea^ibdt or null if not added
  1.  ;              iberr  = error if occurs else null
  1.  ;
  1.  L +^IBA(354,DFN):30 I '$T S IBEXERR=1 W:$D(IBTALK)&('$D(ZTQUEUED)) !,"ENTRY LOCKED" G ADDEXQ
  1. A1 I '$D(^IBA(354,DFN,0)) D ADDP G ADDEXQ:$G(IBEXERR)
  1.  ;
  1.  N IBDGMTA,IBDGMTP,IBDGMTF,IBVFAOK
  1.  I $D(DGMTA) S IBDGMTA=$G(DGMTA),IBDGMTP=$G(DGMTP),IBDGMTF=$G(DGMTINF)
  1.  N X,X1,X2,Y,IBCNT,DGMTA,DGMTP,DGMTINF
  1.  I $D(IBDGMTA) S DGMTA=$G(IBDGMTA),DGMTP=$G(IBDGMTP),DGMTINF=$G(IBDGMTF)
  1.  S IBWHER=12,IBEXERR="",IBADDE=""
  1.  ;
  1.  ;  - one last quick check
  1.  I IBDT'?7N S IBEXERR=3 G ADDEXQ
  1.  I DUZ,$G(^VA(200,+DUZ,0))="" S IBEXERR=8 G ADDEXQ
  1.  ; if DUZ=0, it will be considered as .5 (POSTMASTER) by the input template [IB NEW EXEMPTION]
  1.  ;
  1.  D BEFORE^IBARXEVT ;get prior exemption
  1.  ;
  1.  N IBSTAT,IBEXDA
  1.  S IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
  1.  S IBHOW=$S('$D(IBHOW):1,IBHOW="":1,IBHOW>2:1,IBHOW<1:1,1:IBHOW)
  1.  S IBTYPE=$S('$D(IBTYPE):1,IBTYPE="":1,1:IBTYPE)
  1.  ;I '$D(IBACTION) S IBACTION="ADD"
  1.  ;
  1.  ; -- inactivate a current autoexempt of no longer autoexempt
  1.  I $G(IBOLDAUT)?7N D INACT^IBAUTL7(IBOLDAUT) ;I '$D(ZTQUEUED),$D(IBTALK) W !,"Inactivating current non-income based exemption for patient"
  1.  ;
  1.  ; -- if forcing a new entry to correct problems
  1.  I $G(IBFORCE)?7N D INACT^IBAUTL7(IBFORCE)
  1.  ;
  1.  ; -- check for duplicate entry
  1.  I $G(IBOLDAUT)'?7N,$G(IBFORCE)'?7N,$$DUPL() W:'$D(ZTQUEUED)&($D(IBTALK)) !,"Exemption Attempting to Add is a duplicate, nothing added!",! G ADDEXQ
  1.  ;
  1.  ; -- inactivate previous active entries
  1.  D INACT^IBAUTL7(IBDT) I $G(IBEXERR) G ADDEXQ
  1.  ;
  1.  ; -- if no income data from conversion set date = start date
  1.  I $D(IBCONVER),$P($G(^IBE(354.2,+IBEXREA,0)),"^",5)=210 S IBDT=$$STDATE^IBARXEU
  1.  ;
  1.  ; -- add entry
  1.  S DIC="^IBA(354.1,",DIC(0)="L",X=IBDT K DO,DD D FILE^DICN
  1.  S (IBEXDA,DA)=+Y I Y<1 W:'$D(ZTQUEUED)&($D(IBTALK)) !,"Can't add entry to exemption file" S IBEXERR=4 G ADDEXQ
  1.  ;
  1.  ; -- edit new entry
  1.  S DIE="^IBA(354.1,",DR="[IB NEW EXEMPTION]" ; use compiled template
  1.  ;
  1.  ;DR=".02////"_DFN_";.03////"_IBTYPE_";.04////"_IBSTAT_";.05////"_IBEXREA_";.06////"_IBHOW_";.07////"_DUZ_";.08///NOW;.1////1;.11////"_$G(IBASIG)
  1.  ;
  1.  D ^DIE
  1.  I $D(Y) S IBEXERR=5 G ADDEXQ
  1.  S IBADDE=IBEXREA_"^"_IBDT
  1.  ;
  1.  ; -- VFA check
  1.  S IBVFAOK=$$VFAOK^IBARXEU($G(^IBA(354.1,DA,0)))
  1.  ;
  1.  ; -- clean up a bit
  1.  K DIC,DIE,DA,DR
  1.  ;
  1.  ; --if effective date is in last 365 days make current
  1.  I IBDT>$$MINUS^IBARXEU0(DT)!(IBVFAOK) D CURREX^IBAUTL7(IBSTAT,IBDT) I $G(IBEXERR) G ADDEXQ
  1.  ;
  1.  I '$D(ZTQUEUED),$G(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^"),"   ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
  1.  ; -- setup and call event driver
  1.  I '$D(IBCONVER) D  ;if not from conversion do following
  1.  .D AFTER^IBARXEVT
  1.  .S IBEVT=$$RXST^IBARXEU(DFN,$S(IBDT<$$STDATE^IBARXEU:$$STDATE^IBARXEU,1:IBDT))
  1.  .D ^IBARXEVT
  1.  .I IBSTAT D CANCEL^IBARXEU3 ;exempt patient cancel old charges
  1.  .D ^IBARXEB ; process bulletins and alerts
  1.  ;
  1. ADDEXQ ;
  1.  L -^IBA(354,DFN)
  1.  I $G(IBEXERR) D ^IBAERR
  1.  K DO,DD,DIC,DIE,DA,DR,IBEVT,IBEVTP,IBEVTA,IBASIG,IBARCAN
  1.  Q
  1.  ;
  1. DUPL() ; -- see if entry is a duplicate
  1.  N X,Y
  1.  S X=0
  1.  S Y=$$LST^IBARXEU0(DFN,IBDT)
  1.  I IBDT=+Y,+IBEXREA=+$P(Y,"^",5),IBTYPE=$P(Y,"^",3) S X=1
  1.  Q X