IBCNSA2 ;ALB/NLR - ANNUAL BENEFITS EDIT, DIE CALLS ; 28-MAY-1993
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
ED(IBT) ;
D FULL^VALM1 W !!
D SAVEAB
L +^IBA(355.4,+IBCAB):5 I '$T D LOCKED^IBTRCD1 G EDQ
S DIE="^IBA(355.4,",DA=IBCAB
S DR=IBT
D ^DIE K DIE,DIC,DA,DR
D COMP
I IBDIF=1 D EDUP
D EXIT
L -^IBA(355.4,+IBCAB)
EDQ Q
;
SAVEAB ;
K ^TMP($J,"IBAB")
S ^TMP($J,"IBAB",355.4,IBCAB,0)=$G(^IBA(355.4,IBCAB,0))
S ^TMP($J,"IBAB",355.4,IBCAB,1)=$G(^IBA(355.4,IBCAB,1))
S ^TMP($J,"IBAB",355.4,IBCAB,2)=$G(^IBA(355.4,IBCAB,2))
S ^TMP($J,"IBAB",355.4,IBCAB,3)=$G(^IBA(355.4,IBCAB,3))
S ^TMP($J,"IBAB",355.4,IBCAB,4)=$G(^IBA(355.4,IBCAB,4))
S ^TMP($J,"IBAB",355.4,IBCAB,5)=$G(^IBA(355.4,IBCAB,5))
Q
COMP ;
S IBDIF=0
I $G(^IBA(355.4,IBCAB,0))'=^TMP($J,"IBAB",355.4,IBCAB,0) S IBDIF=1 Q
I $G(^IBA(355.4,IBCAB,1))'=^TMP($J,"IBAB",355.4,IBCAB,1) S IBDIF=1 Q
I $G(^IBA(355.4,IBCAB,2))'=^TMP($J,"IBAB",355.4,IBCAB,2) S IBDIF=1 Q
I $G(^IBA(355.4,IBCAB,3))'=^TMP($J,"IBAB",355.4,IBCAB,3) S IBDIF=1 Q
I $G(^IBA(355.4,IBCAB,4))'=^TMP($J,"IBAB",355.4,IBCAB,4) S IBDIF=1 Q
I $G(^IBA(355.4,IBCAB,5))'=^TMP($J,"IBAB",355.4,IBCAB,5) S IBDIF=1 Q
Q
EDUP ; -- enter date and user if editing has taken place
S DIE="^IBA(355.4,",DA=IBCAB
S DR="1.05///NOW;1.06////"_DUZ
D ^DIE K DIE,DIC,DA,DR
Q
CY ;
D FULL^VALM1 W !!
S IBYR1=IBYR K IBYR D INIT^IBCNSA
I $D(VALMQUIT) S IBYR=IBYR1 K VALMQUIT D EXITRP
I IBYR=IBYR1 D
.K IBYR1,VALMQUIT D EXITRP
E D EXIT
Q
;
;
EXIT D HDR^IBCNSA("Annual Benefits"),BLD^IBCNSA
EXITRP K VALMQUIT S VALMBCK="R"
Q
;
DATECHK ; -- called from input transform from annual benefits (355.4,.01)
; make sure benefit years do not overlap
; kills x if not okay
;
Q:'$D(X)
N BEFORE,AFTER,MINUS,PLUS,ZZ
S MINUS=X-10000
S PLUS=X+10000
I '$G(IBCPOL) S IBCPOL=$P($G(^IBA(355.4,$G(DA),0)),"^",2)
Q:'IBCPOL
;
; -- find most recent entry
S ZZ=-$O(^IBA(355.4,"APY",IBCPOL,""))
I 'ZZ Q ;if not prior entires quit.
;
; -- if x>most recent entry
I X>ZZ K:X<(ZZ+10000) X Q
;
Q:'$D(X)
;
; -- find policy date prior to (before or less than) x
S BEFORE=-$O(^IBA(355.4,"APY",+IBCPOL,-X))
S AFTER=-$O(^IBA(355.4,"APY",+IBCPOL,-PLUS))
;
I 'BEFORE D Q
.I AFTER=X Q
.I AFTER,AFTER>X K X
.Q
;
; -- if it exists,not exactly one year,if within one year of prior year
I BEFORE D Q
.I BEFORE=MINUS Q
.I BEFORE>MINUS K X Q
.I X=AFTER Q
.I AFTER>X K X
.Q
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSA2 2574 printed Dec 13, 2024@02:16:49 Page 2
IBCNSA2 ;ALB/NLR - ANNUAL BENEFITS EDIT, DIE CALLS ; 28-MAY-1993
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
ED(IBT) ;
+1 DO FULL^VALM1
WRITE !!
+2 DO SAVEAB
+3 LOCK +^IBA(355.4,+IBCAB):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDQ
+4 SET DIE="^IBA(355.4,"
SET DA=IBCAB
+5 SET DR=IBT
+6 DO ^DIE
KILL DIE,DIC,DA,DR
+7 DO COMP
+8 IF IBDIF=1
DO EDUP
+9 DO EXIT
+10 LOCK -^IBA(355.4,+IBCAB)
EDQ QUIT
+1 ;
SAVEAB ;
+1 KILL ^TMP($JOB,"IBAB")
+2 SET ^TMP($JOB,"IBAB",355.4,IBCAB,0)=$GET(^IBA(355.4,IBCAB,0))
+3 SET ^TMP($JOB,"IBAB",355.4,IBCAB,1)=$GET(^IBA(355.4,IBCAB,1))
+4 SET ^TMP($JOB,"IBAB",355.4,IBCAB,2)=$GET(^IBA(355.4,IBCAB,2))
+5 SET ^TMP($JOB,"IBAB",355.4,IBCAB,3)=$GET(^IBA(355.4,IBCAB,3))
+6 SET ^TMP($JOB,"IBAB",355.4,IBCAB,4)=$GET(^IBA(355.4,IBCAB,4))
+7 SET ^TMP($JOB,"IBAB",355.4,IBCAB,5)=$GET(^IBA(355.4,IBCAB,5))
+8 QUIT
COMP ;
+1 SET IBDIF=0
+2 IF $GET(^IBA(355.4,IBCAB,0))'=^TMP($JOB,"IBAB",355.4,IBCAB,0)
SET IBDIF=1
QUIT
+3 IF $GET(^IBA(355.4,IBCAB,1))'=^TMP($JOB,"IBAB",355.4,IBCAB,1)
SET IBDIF=1
QUIT
+4 IF $GET(^IBA(355.4,IBCAB,2))'=^TMP($JOB,"IBAB",355.4,IBCAB,2)
SET IBDIF=1
QUIT
+5 IF $GET(^IBA(355.4,IBCAB,3))'=^TMP($JOB,"IBAB",355.4,IBCAB,3)
SET IBDIF=1
QUIT
+6 IF $GET(^IBA(355.4,IBCAB,4))'=^TMP($JOB,"IBAB",355.4,IBCAB,4)
SET IBDIF=1
QUIT
+7 IF $GET(^IBA(355.4,IBCAB,5))'=^TMP($JOB,"IBAB",355.4,IBCAB,5)
SET IBDIF=1
QUIT
+8 QUIT
EDUP ; -- enter date and user if editing has taken place
+1 SET DIE="^IBA(355.4,"
SET DA=IBCAB
+2 SET DR="1.05///NOW;1.06////"_DUZ
+3 DO ^DIE
KILL DIE,DIC,DA,DR
+4 QUIT
CY ;
+1 DO FULL^VALM1
WRITE !!
+2 SET IBYR1=IBYR
KILL IBYR
DO INIT^IBCNSA
+3 IF $DATA(VALMQUIT)
SET IBYR=IBYR1
KILL VALMQUIT
DO EXITRP
+4 IF IBYR=IBYR1
Begin DoDot:1
+5 KILL IBYR1,VALMQUIT
DO EXITRP
End DoDot:1
+6 IF '$TEST
DO EXIT
+7 QUIT
+8 ;
+9 ;
EXIT DO HDR^IBCNSA("Annual Benefits")
DO BLD^IBCNSA
EXITRP KILL VALMQUIT
SET VALMBCK="R"
+1 QUIT
+2 ;
DATECHK ; -- called from input transform from annual benefits (355.4,.01)
+1 ; make sure benefit years do not overlap
+2 ; kills x if not okay
+3 ;
+4 if '$DATA(X)
QUIT
+5 NEW BEFORE,AFTER,MINUS,PLUS,ZZ
+6 SET MINUS=X-10000
+7 SET PLUS=X+10000
+8 IF '$GET(IBCPOL)
SET IBCPOL=$PIECE($GET(^IBA(355.4,$GET(DA),0)),"^",2)
+9 if 'IBCPOL
QUIT
+10 ;
+11 ; -- find most recent entry
+12 SET ZZ=-$ORDER(^IBA(355.4,"APY",IBCPOL,""))
+13 ;if not prior entires quit.
IF 'ZZ
QUIT
+14 ;
+15 ; -- if x>most recent entry
+16 IF X>ZZ
if X<(ZZ+10000)
KILL X
QUIT
+17 ;
+18 if '$DATA(X)
QUIT
+19 ;
+20 ; -- find policy date prior to (before or less than) x
+21 SET BEFORE=-$ORDER(^IBA(355.4,"APY",+IBCPOL,-X))
+22 SET AFTER=-$ORDER(^IBA(355.4,"APY",+IBCPOL,-PLUS))
+23 ;
+24 IF 'BEFORE
Begin DoDot:1
+25 IF AFTER=X
QUIT
+26 IF AFTER
IF AFTER>X
KILL X
+27 QUIT
End DoDot:1
QUIT
+28 ;
+29 ; -- if it exists,not exactly one year,if within one year of prior year
+30 IF BEFORE
Begin DoDot:1
+31 IF BEFORE=MINUS
QUIT
+32 IF BEFORE>MINUS
KILL X
QUIT
+33 IF X=AFTER
QUIT
+34 IF AFTER>X
KILL X
+35 QUIT
End DoDot:1
QUIT
+36 ;
+37 QUIT
