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

IBCNSA2.m

Go to the documentation of this file.
  1. IBCNSA2 ;ALB/NLR - ANNUAL BENEFITS EDIT, DIE CALLS ; 28-MAY-1993
  1. ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ED(IBT) ;
  1. D FULL^VALM1 W !!
  1. D SAVEAB
  1. L +^IBA(355.4,+IBCAB):5 I '$T D LOCKED^IBTRCD1 G EDQ
  1. S DIE="^IBA(355.4,",DA=IBCAB
  1. S DR=IBT
  1. D ^DIE K DIE,DIC,DA,DR
  1. D COMP
  1. I IBDIF=1 D EDUP
  1. D EXIT
  1. L -^IBA(355.4,+IBCAB)
  1. EDQ Q
  1. ;
  1. SAVEAB ;
  1. K ^TMP($J,"IBAB")
  1. S ^TMP($J,"IBAB",355.4,IBCAB,0)=$G(^IBA(355.4,IBCAB,0))
  1. S ^TMP($J,"IBAB",355.4,IBCAB,1)=$G(^IBA(355.4,IBCAB,1))
  1. S ^TMP($J,"IBAB",355.4,IBCAB,2)=$G(^IBA(355.4,IBCAB,2))
  1. S ^TMP($J,"IBAB",355.4,IBCAB,3)=$G(^IBA(355.4,IBCAB,3))
  1. S ^TMP($J,"IBAB",355.4,IBCAB,4)=$G(^IBA(355.4,IBCAB,4))
  1. S ^TMP($J,"IBAB",355.4,IBCAB,5)=$G(^IBA(355.4,IBCAB,5))
  1. Q
  1. COMP ;
  1. S IBDIF=0
  1. I $G(^IBA(355.4,IBCAB,0))'=^TMP($J,"IBAB",355.4,IBCAB,0) S IBDIF=1 Q
  1. I $G(^IBA(355.4,IBCAB,1))'=^TMP($J,"IBAB",355.4,IBCAB,1) S IBDIF=1 Q
  1. I $G(^IBA(355.4,IBCAB,2))'=^TMP($J,"IBAB",355.4,IBCAB,2) S IBDIF=1 Q
  1. I $G(^IBA(355.4,IBCAB,3))'=^TMP($J,"IBAB",355.4,IBCAB,3) S IBDIF=1 Q
  1. I $G(^IBA(355.4,IBCAB,4))'=^TMP($J,"IBAB",355.4,IBCAB,4) S IBDIF=1 Q
  1. I $G(^IBA(355.4,IBCAB,5))'=^TMP($J,"IBAB",355.4,IBCAB,5) S IBDIF=1 Q
  1. Q
  1. EDUP ; -- enter date and user if editing has taken place
  1. S DIE="^IBA(355.4,",DA=IBCAB
  1. S DR="1.05///NOW;1.06////"_DUZ
  1. D ^DIE K DIE,DIC,DA,DR
  1. Q
  1. CY ;
  1. D FULL^VALM1 W !!
  1. S IBYR1=IBYR K IBYR D INIT^IBCNSA
  1. I $D(VALMQUIT) S IBYR=IBYR1 K VALMQUIT D EXITRP
  1. I IBYR=IBYR1 D
  1. .K IBYR1,VALMQUIT D EXITRP
  1. E D EXIT
  1. Q
  1. ;
  1. ;
  1. EXIT D HDR^IBCNSA("Annual Benefits"),BLD^IBCNSA
  1. EXITRP K VALMQUIT S VALMBCK="R"
  1. Q
  1. ;
  1. DATECHK ; -- called from input transform from annual benefits (355.4,.01)
  1. ; make sure benefit years do not overlap
  1. ; kills x if not okay
  1. ;
  1. Q:'$D(X)
  1. N BEFORE,AFTER,MINUS,PLUS,ZZ
  1. S MINUS=X-10000
  1. S PLUS=X+10000
  1. I '$G(IBCPOL) S IBCPOL=$P($G(^IBA(355.4,$G(DA),0)),"^",2)
  1. Q:'IBCPOL
  1. ;
  1. ; -- find most recent entry
  1. S ZZ=-$O(^IBA(355.4,"APY",IBCPOL,""))
  1. I 'ZZ Q ;if not prior entires quit.
  1. ;
  1. ; -- if x>most recent entry
  1. I X>ZZ K:X<(ZZ+10000) X Q
  1. ;
  1. Q:'$D(X)
  1. ;
  1. ; -- find policy date prior to (before or less than) x
  1. S BEFORE=-$O(^IBA(355.4,"APY",+IBCPOL,-X))
  1. S AFTER=-$O(^IBA(355.4,"APY",+IBCPOL,-PLUS))
  1. ;
  1. I 'BEFORE D Q
  1. .I AFTER=X Q
  1. .I AFTER,AFTER>X K X
  1. .Q
  1. ;
  1. ; -- if it exists,not exactly one year,if within one year of prior year
  1. I BEFORE D Q
  1. .I BEFORE=MINUS Q
  1. .I BEFORE>MINUS K X Q
  1. .I X=AFTER Q
  1. .I AFTER>X K X
  1. .Q
  1. ;
  1. Q