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

IB20P385.m

Go to the documentation of this file. 
  1. IB20P385 ;OAK/ELZ - POST INIT ROUTINE FOR IB*2*385 ;5/15/2013
  1.  ;;2.0;INTEGRATED BILLING;**385**;21-MAR-94;Build 35
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. ENV ;
  1.  ; need to make sure we can find the CD entry for 354.1 before we can
  1.  ; install.
  1.  N DIC,X,Y
  1.  S DIC="^IBE(354.2,",DIC(0)="",X="CATASTROPHICALLY DISABLED" D ^DIC
  1.  I Y<1 W !,"CATASTROPHICALLY DISABLED entry in file 354.1 not found!!" S XPDQUIT=2
  1.  Q
  1.  ;
  1. POST ;
  1.  N IBA
  1.  I $$INSTALDT^XPDUTL("IB*2.0*385") D MES("--> Patch previously installed, not running post-init again",1) Q
  1.  D MES("--> Starting post-install",1)
  1.  D CDFIX ; correct file 354.1 code field for CD patients
  1.  ;D KIDSVFA ; clean up records since VFA start date and cancel charges
  1.  D MES("--> Post-install complete",1)
  1.  ;
  1.  Q
  1.  ;
  1. CDFIX ; - need to find the CD entry in file 354.1 and update the code so it is
  1.  ; a 2 digit code, going to use 70 since IB ignores that code if passed
  1.  ; in by the DG package
  1.  N DIC,X,Y,IBFDA
  1.  D MES("--> Updating 354.2 CATASTROPHICALLY DISABLED entry",1)
  1.  S DIC="^IBE(354.2,",DIC(0)="",X="CATASTROPHICALLY DISABLED" D ^DIC
  1.  I Y<1 D MES("*** Cannot find CATASTROPHICALLY DISABLED ***") Q
  1.  S IBFDA(354.2,+Y_",",.05)=70 D FILE^DIE(,"IBFDA")
  1.  D MES("     - CATASTROPHICALLY DISABLED entry updated")
  1.  Q
  1.  ;
  1. KIDSVFA ; - entry for KIDS doing the VFA clean-up to know to output status bar
  1.  N IBKIDS
  1.  S IBKIDS=1
  1.  ;
  1. VFA ; - clean up since VFA is effective in the past
  1.  N IBCT,IBDT,IBE,IBOK,IBUP,IBZ354,DFN,DA,DR,DIE,IBDATE,IBFDA
  1.  ;
  1.  D MES("--> Cleaning up Patient Exemptions started",1)
  1.  ;
  1.  S IBCT=0
  1.  ;
  1.  S IBE=$O(^IBE(354.2,"B","NO INCOME DATA",0))
  1.  I 'IBE S IBA(1)="***Cannot find Exemption Reason NO INCOME DATA***",IBA(2)="---------- Post install aborded!!! ----------" D MES(.IBA) Q
  1.  ;
  1.  ; -- already running, if not setup xtmp
  1.  I $D(^XTMP("IB20P385",0)) S IBA(1)="Post-install may have already run or may be running now",IBA(2)="Quiting this post-install..." D MES(.IBA) Q
  1.  S ^XTMP("IB20P385",0)=$$FMADD^XLFDT(DT,30)_"^"_DT
  1.  ;
  1.  ; -- setup status bar every 5%
  1.  S XPDIDTOT=$P(^IBA(354,0),"^",4),IBUP=$P(XPDIDTOT/20,".")
  1.  ;
  1.  ; -- go through 354 to find NO INCOME records since 1/1/13
  1.  S DFN=+$G(^XTMP("IB20P385","DFN")) F  S DFN=$O(^IBA(354,DFN)) Q:'DFN  D
  1.  . ;
  1.  . ; -- update status bar
  1.  . S IBCT=IBCT+1 I '(IBCT#IBUP) X $S(IBKIDS:"D UPDATE^XPDID(IBCT)",1:"W "".""")
  1.  . ;
  1.  . S IBZ354=^IBA(354,DFN,0)
  1.  . ;
  1.  . ; quit if not a NO INCOME record active after 1/1/13
  1.  . I $P(IBZ354,"^",3)<3130101!($P(IBZ354,"^",5)'=IBE) D DFN(DFN) Q
  1.  . ;
  1.  . ; look at previously active records to see if they were VFA-OK
  1.  . S IBDT=$$LST^IBARXEU0(DFN,$P(IBZ354,"^",3)),IBOK=0
  1.  . F  S IBDT=$$LST^IBARXEU0(DFN,$$FMADD^XLFDT(+IBDT,-1)) S IBOK=$$VFAOK^IBARXEU(IBDT) Q:IBDT<3120101!(IBOK&($P(IBDT,"^",5)'=IBE))
  1.  . I 'IBOK!($P(IBDT,"^",5)=IBE) D DFN(DFN) Q
  1.  . ;
  1.  . ; set 354 to OK values
  1.  . D UP354(DFN,+IBDT,$P(IBDT,"^",4),$P(IBDT,"^",5))
  1.  . ;
  1.  . ; clean up 354.1 entries
  1.  . S IBDATE=-IBDT F  S IBDATE=$O(^IBA(354.1,"AIVDT",1,DFN,IBDATE),-1) Q:'IBDATE  D
  1.  .. S DA=$O(^IBA(354.1,"AIVDT",1,DFN,IBDATE,0))
  1.  .. S DIE="^IBA(354.1,",DR=".1////0" D ^DIE
  1.  . ;
  1.  . ; cancel copay bills if exempt
  1.  . I '$P(IBDT,"^",4) D DFN(DFN) Q
  1.  . D CANCEL(DFN,IBDT)
  1.  . ;
  1.  . D DFN(DFN)
  1.  ;
  1.  D MES("--> Cleaning up Patient Exemptions completed",1)
  1.  ;
  1.  Q
  1. CANCEL(DFN,IBXX) ; cancel charges from date of last active exemption
  1.  N IBBDT,IBEDT,X,Y,IBDATE,IBFOUND,IBNN,IBPARNT,IBPARDT,IBPARNT1,IBLAST
  1.  N IBCRES,IBND,IBDUZ,IBATYP,IBSEQNO,IBIL,IBUNIT,IBCHRG,IBN,IBFAC,DA,DIE
  1.  N DR,IBYCHK,DLAYGO,IBSITE,IBNOW,IBAFY,ERR,IBWHER,IBARCAN
  1.  ;
  1.  S IBBDT=$S(IBXX<3130101:3130101,1:+IBXX)
  1.  S IBEDT=DT
  1.  ;
  1.  ; - quit if there are no charges to cancel
  1.  S X=$O(^IB("APTDT",DFN,(IBBDT-.01))) I 'X!(X>(IBEDT+.9)) G CANCELQ
  1.  ;
  1.  ; - cancel the charges in billing
  1.  S Y=1 D ARPARM^IBAUTL I Y<0 G CANCELQ
  1.  ;
  1.  S IBDATE=IBBDT-.0001,IBFOUND=0
  1.  F  S IBDATE=$O(^IB("APTDT",DFN,IBDATE)) Q:'IBDATE!((IBEDT+.9)<IBDATE)  D
  1.  . S IBNN=0 F  S IBNN=$O(^IB("APTDT",DFN,IBDATE,IBNN)) Q:'IBNN  D BILL^IBARXEU3
  1.  ;
  1.  ; - cancel bills in AR, if at least one charge was cancelled
  1.  I IBFOUND S IBARCAN=1 D ARCAN^IBARXEU4(DFN,$P(IBXX,"^",4),IBBDT,IBEDT)
  1.  ;
  1. CANCELQ Q
  1.  ;
  1. MES(X,T) ; - display message
  1.  X $S($G(T):"D BMES^XPDUTL(.X)",1:"D MES^XPDUTL(.X)")
  1.  K X
  1.  Q
  1.  ;
  1. RESTART ; - unadvertised entry to restart process from last XTMP patient
  1.  N IBKIDS
  1.  S IBKIDS=0
  1.  K ^XTMP("IB20P385",0)
  1.  D VFA
  1.  Q
  1.  ;
  1. DFN(DFN) ; saves DFN into XTMP
  1.  S ^XTMP("IB20P385","DFN")=DFN
  1.  Q
  1.  ;
  1. UP354(DA,IBDT,IBSTAT,IBEXREA) ; -- calling out separate to update 354
  1.  N DIE,DR
  1.  S DIE="^IBA(354,"
  1.  S DR="[IB CURRENT STATUS]"
  1.  D ^DIE
  1.  Q