IBCNSA.m

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

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