IBCNSA ;ALB/NLR - ANNUAL BENEFITS EDIT ; 21-MAY-1993
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; -- main entry point for IBCNS ANNUAL BENEFITS
K VALMQUIT,VALMEVL,XQORS,^TMP("XQORS",$J),DIC,%DT,IBCNS,IBCPOL,IBYR
S IBCHANGE="OKAY"
D EN^VALM("IBCNS ANNUAL BENEFITS")
Q
;
HDR(SCR) ; -- joint header logic
S Y=$E($E($P($G(^DIC(36,$P($G(^IBA(355.3,+IBCPOL,0)),U),0)),U),1,20)_" Ins. Co ",1,30)
I $G(IBPAT) S Y=Y_"Patient: "_$E($P(^DPT(DFN,0),"^"),1,20)
S VALMHDR(1)=SCR_" for: "_Y
S VALMHDR(2)=$S($G(IBPAT):" Policy: "_$E(IBCGN_" ",1,30)_" Ben Yr: "_IBYE,1:" Policy: "_$E(IBCGN_" ",1,30)_" Ben Yr: "_IBYE)
Q
;
INIT ; -- init variables and list array
K VALMQUIT,IBCAB,IBPAT
S VALMCNT=0,VALMBG=1
I $G(IBYR)'?7N K IBYR
I '$G(IBCPOL) D GETPOL Q:$D(VALMQUIT)
I '$G(IBYR) D GETYR Q:$D(VALMQUIT)
I '$D(IBCAB) S IBCAB=$$AB^IBCNSU(IBCPOL,IBYR)
S IBCABD=$G(^IBA(355.4,IBCAB,0))
S IBCABC=$G(^IBA(355.3,$P(IBCABD,U,2),0))
S IBCGN=$$GRP^IBCNS(IBCPOL)
K ^TMP("IBCNSA",$J)
D BLD
Q
BLD ; -- List builder
S VALMCNT=47
F I=1:1:56 D BLANK(.I)
D EN^IBCNSA0,EN^IBCNSA1
Q
;
GETPOL ;
I '$G(IBCNS) D INSCO^IBCNSC I '$G(IBCNS) S VALMQUIT="" G GETPOLQ
I '$G(IBCPOL) S IBCPOL=$$LK^IBCNSM31(IBCNS) ;D G:$D(VALMQUIT) GETPOLQ
;.S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U)=IBCNS"
;.D ^DIC K DIC
;.S IBCPOL=+Y
I $G(IBCPOL)<1 S VALMQUIT=""
GETPOLQ Q
;
GETYR ;
I '$G(IBCPOL) D GETPOL I $G(IBCPOL)<1 S VALMQUIT="" G GETYRQ
I '$G(IBYR) D GY1 G:$D(VALMQUIT) GETYRQ
GETYRQ Q
;
GY1 N %DT
S IBCNT=0
S IBDT="" F S IBDT=$O(^IBA(355.4,"APY",IBCPOL,IBDT)) Q:'IBDT S IBDA=0 F S IBDA=$O(^IBA(355.4,"APY",IBCPOL,IBDT,IBDA)) Q:'IBDA D
.S IBCNT=IBCNT+1
.W:IBCNT=1 !!,"Current benefit years on file:"
.W !?4,IBCNT,". ",?8,$$DAT1^IBOUTL(+$G(^IBA(355.4,IBDA,0)),2)
.Q
I 'IBCNT W !,"No Benefit Years Entered."
;
; -- get default date of most recent entry, change to positive value
;
S X=+$O(^IBA(355.4,"APY",IBCPOL,"")) I X S:X<0 X=-X S:X>0 DIC("B")=$$DAT1^IBOUTL(X)
S DIC="^IBA(355.4,",DIC(0)=$S($G(IBL):"AELQN",1:"AEQN"),DIC("A")="BENEFIT YEAR BEGINNING ON: "
S DIC("S")="I $P(^(0),U,2)=IBCPOL"
S DIC("W")=""
S DIC("DR")=".02////"_IBCPOL
S:$G(IBL) DLAYGO=355.4
D ^DIC K DIC
I +Y S IBYR=$P(Y,"^",2),IBCAB=+Y
;
I $G(IBYR)<1 S VALMQUIT=""
Q
;
GETYR2 ; -- get policy year from 355.4 from bu
I '$G(IBCPOL) D GETPOL I $G(IBCPOL)<1 S VALMQUIT="" G GETYR2Q
I '$G(IBYR) D G:$D(VALMQUIT) GETYR2Q
.N DIC,X,Y
.; -- get default date of most recent entry, change to positive value
.S IBEXP1="No Benefit Years Entered. You Must First Enter a Benefit Year for This Policy"
.S IBEXP2="No Benefit Years Entered Under Annual Benefits, Hence No Benefits Used to View."
.S X=+$O(^IBA(355.4,"APY",IBCPOL,"")) I 'X W !,$S('$G(IBVIEW):IBEXP1,1:IBEXP2) S VALMQUIT="" D PAUSE^VALM1 Q
.S:X<0 X=-X S:X>0 DIC("B")=$$FMTE^XLFDT(X,1)
.S DIC=355.4,DIC(0)="AEQN",DIC("A")="Select BENEFIT YEAR BEGINNING ON: "
.S DIC("S")="I $P(^(0),U,2)=IBCPOL"
.D ^DIC K DIC
.S IBYR=""
.I +Y S IBYR=$P(Y,"^",2)
I $G(IBYR)<1 S VALMQUIT=""
GETYR2Q Q
;
EXIT ;
K VALMQUIT,IBCHANGE,IBCAB,IBCABC,IBCABD,IBYR,IBCABD1,IBCABD2,IBCABD3,IBCABD4,IBCABD5
D CLEAN^VALM10
Q
BLANK(LINE) ; -- Build blank line
D SET^VALM10(.LINE,$J("",80))
Q
;
HELP ; -- Help Code
S X="?" D DISP^XQORM1 W !!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSA 3553 printed Nov 22, 2024@17:26:50 Page 2
IBCNSA ;ALB/NLR - ANNUAL BENEFITS EDIT ; 21-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 ;
EN ; -- main entry point for IBCNS ANNUAL BENEFITS
+1 KILL VALMQUIT,VALMEVL,XQORS,^TMP("XQORS",$JOB),DIC,%DT,IBCNS,IBCPOL,IBYR
+2 SET IBCHANGE="OKAY"
+3 DO EN^VALM("IBCNS ANNUAL BENEFITS")
+4 QUIT
+5 ;
HDR(SCR) ; -- joint header logic
+1 SET Y=$EXTRACT($EXTRACT($PIECE($GET(^DIC(36,$PIECE($GET(^IBA(355.3,+IBCPOL,0)),U),0)),U),1,20)_" Ins. Co ",1,30)
+2 IF $GET(IBPAT)
SET Y=Y_"Patient: "_$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,20)
+3 SET VALMHDR(1)=SCR_" for: "_Y
+4 SET VALMHDR(2)=$SELECT($GET(IBPAT):" Policy: "_$EXTRACT(IBCGN_" ",1,30)_" Ben Yr: "_IBYE,1:" Policy: "_$EXTRACT(IBCGN_" ",1,30)_" Ben Yr: "_IBYE)
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 KILL VALMQUIT,IBCAB,IBPAT
+2 SET VALMCNT=0
SET VALMBG=1
+3 IF $GET(IBYR)'?7N
KILL IBYR
+4 IF '$GET(IBCPOL)
DO GETPOL
if $DATA(VALMQUIT)
QUIT
+5 IF '$GET(IBYR)
DO GETYR
if $DATA(VALMQUIT)
QUIT
+6 IF '$DATA(IBCAB)
SET IBCAB=$$AB^IBCNSU(IBCPOL,IBYR)
+7 SET IBCABD=$GET(^IBA(355.4,IBCAB,0))
+8 SET IBCABC=$GET(^IBA(355.3,$PIECE(IBCABD,U,2),0))
+9 SET IBCGN=$$GRP^IBCNS(IBCPOL)
+10 KILL ^TMP("IBCNSA",$JOB)
+11 DO BLD
+12 QUIT
BLD ; -- List builder
+1 SET VALMCNT=47
+2 FOR I=1:1:56
DO BLANK(.I)
+3 DO EN^IBCNSA0
DO EN^IBCNSA1
+4 QUIT
+5 ;
GETPOL ;
+1 IF '$GET(IBCNS)
DO INSCO^IBCNSC
IF '$GET(IBCNS)
SET VALMQUIT=""
GOTO GETPOLQ
+2 ;D G:$D(VALMQUIT) GETPOLQ
IF '$GET(IBCPOL)
SET IBCPOL=$$LK^IBCNSM31(IBCNS)
+3 ;.S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U)=IBCNS"
+4 ;.D ^DIC K DIC
+5 ;.S IBCPOL=+Y
+6 IF $GET(IBCPOL)<1
SET VALMQUIT=""
GETPOLQ QUIT
+1 ;
GETYR ;
+1 IF '$GET(IBCPOL)
DO GETPOL
IF $GET(IBCPOL)<1
SET VALMQUIT=""
GOTO GETYRQ
+2 IF '$GET(IBYR)
DO GY1
if $DATA(VALMQUIT)
GOTO GETYRQ
GETYRQ QUIT
+1 ;
GY1 NEW %DT
+1 SET IBCNT=0
+2 SET IBDT=""
FOR
SET IBDT=$ORDER(^IBA(355.4,"APY",IBCPOL,IBDT))
if 'IBDT
QUIT
SET IBDA=0
FOR
SET IBDA=$ORDER(^IBA(355.4,"APY",IBCPOL,IBDT,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+3 SET IBCNT=IBCNT+1
+4 if IBCNT=1
WRITE !!,"Current benefit years on file:"
+5 WRITE !?4,IBCNT,". ",?8,$$DAT1^IBOUTL(+$GET(^IBA(355.4,IBDA,0)),2)
+6 QUIT
End DoDot:1
+7 IF 'IBCNT
WRITE !,"No Benefit Years Entered."
+8 ;
+9 ; -- get default date of most recent entry, change to positive value
+10 ;
+11 SET X=+$ORDER(^IBA(355.4,"APY",IBCPOL,""))
IF X
if X<0
SET X=-X
if X>0
SET DIC("B")=$$DAT1^IBOUTL(X)
+12 SET DIC="^IBA(355.4,"
SET DIC(0)=$SELECT($GET(IBL):"AELQN",1:"AEQN")
SET DIC("A")="BENEFIT YEAR BEGINNING ON: "
+13 SET DIC("S")="I $P(^(0),U,2)=IBCPOL"
+14 SET DIC("W")=""
+15 SET DIC("DR")=".02////"_IBCPOL
+16 if $GET(IBL)
SET DLAYGO=355.4
+17 DO ^DIC
KILL DIC
+18 IF +Y
SET IBYR=$PIECE(Y,"^",2)
SET IBCAB=+Y
+19 ;
+20 IF $GET(IBYR)<1
SET VALMQUIT=""
+21 QUIT
+22 ;
GETYR2 ; -- get policy year from 355.4 from bu
+1 IF '$GET(IBCPOL)
DO GETPOL
IF $GET(IBCPOL)<1
SET VALMQUIT=""
GOTO GETYR2Q
+2 IF '$GET(IBYR)
Begin DoDot:1
+3 NEW DIC,X,Y
+4 ; -- get default date of most recent entry, change to positive value
+5 SET IBEXP1="No Benefit Years Entered. You Must First Enter a Benefit Year for This Policy"
+6 SET IBEXP2="No Benefit Years Entered Under Annual Benefits, Hence No Benefits Used to View."
+7 SET X=+$ORDER(^IBA(355.4,"APY",IBCPOL,""))
IF 'X
WRITE !,$SELECT('$GET(IBVIEW):IBEXP1,1:IBEXP2)
SET VALMQUIT=""
DO PAUSE^VALM1
QUIT
+8 if X<0
SET X=-X
if X>0
SET DIC("B")=$$FMTE^XLFDT(X,1)
+9 SET DIC=355.4
SET DIC(0)="AEQN"
SET DIC("A")="Select BENEFIT YEAR BEGINNING ON: "
+10 SET DIC("S")="I $P(^(0),U,2)=IBCPOL"
+11 DO ^DIC
KILL DIC
+12 SET IBYR=""
+13 IF +Y
SET IBYR=$PIECE(Y,"^",2)
End DoDot:1
if $DATA(VALMQUIT)
GOTO GETYR2Q
+14 IF $GET(IBYR)<1
SET VALMQUIT=""
GETYR2Q QUIT
+1 ;
EXIT ;
+1 KILL VALMQUIT,IBCHANGE,IBCAB,IBCABC,IBCABD,IBYR,IBCABD1,IBCABD2,IBCABD3,IBCABD4,IBCABD5
+2 DO CLEAN^VALM10
+3 QUIT
BLANK(LINE) ; -- Build blank line
+1 DO SET^VALM10(.LINE,$JUSTIFY("",80))
+2 QUIT
+3 ;
HELP ; -- Help Code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
