- 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 Feb 18, 2025@23:43:12 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