source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSA.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1IBCNSA ;ALB/NLR - ANNUAL BENEFITS EDIT ; 21-MAY-1993
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; -- main entry point for IBCNS ANNUAL BENEFITS
6 K VALMQUIT,VALMEVL,XQORS,^TMP("XQORS",$J),DIC,%DT,IBCNS,IBCPOL,IBYR
7 S IBCHANGE="OKAY"
8 D EN^VALM("IBCNS ANNUAL BENEFITS")
9 Q
10 ;
11HDR(SCR) ; -- joint header logic
12 S Y=$E($E($P($G(^DIC(36,$P($G(^IBA(355.3,+IBCPOL,0)),U),0)),U),1,20)_" Ins. Co ",1,30)
13 I $G(IBPAT) S Y=Y_"Patient: "_$E($P(^DPT(DFN,0),"^"),1,20)
14 S VALMHDR(1)=SCR_" for: "_Y
15 S VALMHDR(2)=$S($G(IBPAT):" Policy: "_$E(IBCGN_" ",1,30)_" Ben Yr: "_IBYE,1:" Policy: "_$E(IBCGN_" ",1,30)_" Ben Yr: "_IBYE)
16 Q
17 ;
18INIT ; -- init variables and list array
19 K VALMQUIT,IBCAB,IBPAT
20 S VALMCNT=0,VALMBG=1
21 I $G(IBYR)'?7N K IBYR
22 I '$G(IBCPOL) D GETPOL Q:$D(VALMQUIT)
23 I '$G(IBYR) D GETYR Q:$D(VALMQUIT)
24 I '$D(IBCAB) S IBCAB=$$AB^IBCNSU(IBCPOL,IBYR)
25 S IBCABD=$G(^IBA(355.4,IBCAB,0))
26 S IBCABC=$G(^IBA(355.3,$P(IBCABD,U,2),0))
27 S IBCGN=$$GRP^IBCNS(IBCPOL)
28 K ^TMP("IBCNSA",$J)
29 D BLD
30 Q
31BLD ; -- List builder
32 S VALMCNT=47
33 F I=1:1:56 D BLANK(.I)
34 D EN^IBCNSA0,EN^IBCNSA1
35 Q
36 ;
37GETPOL ;
38 I '$G(IBCNS) D INSCO^IBCNSC I '$G(IBCNS) S VALMQUIT="" G GETPOLQ
39 I '$G(IBCPOL) S IBCPOL=$$LK^IBCNSM31(IBCNS) ;D G:$D(VALMQUIT) GETPOLQ
40 ;.S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U)=IBCNS"
41 ;.D ^DIC K DIC
42 ;.S IBCPOL=+Y
43 I $G(IBCPOL)<1 S VALMQUIT=""
44GETPOLQ Q
45 ;
46GETYR ;
47 I '$G(IBCPOL) D GETPOL I $G(IBCPOL)<1 S VALMQUIT="" G GETYRQ
48 I '$G(IBYR) D GY1 G:$D(VALMQUIT) GETYRQ
49GETYRQ Q
50 ;
51GY1 N %DT
52 S IBCNT=0
53 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
54 .S IBCNT=IBCNT+1
55 .W:IBCNT=1 !!,"Current benefit years on file:"
56 .W !?4,IBCNT,". ",?8,$$DAT1^IBOUTL(+$G(^IBA(355.4,IBDA,0)),2)
57 .Q
58 I 'IBCNT W !,"No Benefit Years Entered."
59 ;
60 ; -- get default date of most recent entry, change to positive value
61 ;
62 S X=+$O(^IBA(355.4,"APY",IBCPOL,"")) I X S:X<0 X=-X S:X>0 DIC("B")=$$DAT1^IBOUTL(X)
63 S DIC="^IBA(355.4,",DIC(0)=$S($G(IBL):"AELQN",1:"AEQN"),DIC("A")="BENEFIT YEAR BEGINNING ON: "
64 S DIC("S")="I $P(^(0),U,2)=IBCPOL"
65 S DIC("W")=""
66 S DIC("DR")=".02////"_IBCPOL
67 S:$G(IBL) DLAYGO=355.4
68 D ^DIC K DIC
69 I +Y S IBYR=$P(Y,"^",2),IBCAB=+Y
70 ;
71 I $G(IBYR)<1 S VALMQUIT=""
72 Q
73 ;
74GETYR2 ; -- get policy year from 355.4 from bu
75 I '$G(IBCPOL) D GETPOL I $G(IBCPOL)<1 S VALMQUIT="" G GETYR2Q
76 I '$G(IBYR) D G:$D(VALMQUIT) GETYR2Q
77 .N DIC,X,Y
78 .; -- get default date of most recent entry, change to positive value
79 .S IBEXP1="No Benefit Years Entered. You Must First Enter a Benefit Year for This Policy"
80 .S IBEXP2="No Benefit Years Entered Under Annual Benefits, Hence No Benefits Used to View."
81 .S X=+$O(^IBA(355.4,"APY",IBCPOL,"")) I 'X W !,$S('$G(IBVIEW):IBEXP1,1:IBEXP2) S VALMQUIT="" D PAUSE^VALM1 Q
82 .S:X<0 X=-X S:X>0 DIC("B")=$$FMTE^XLFDT(X,1)
83 .S DIC=355.4,DIC(0)="AEQN",DIC("A")="Select BENEFIT YEAR BEGINNING ON: "
84 .S DIC("S")="I $P(^(0),U,2)=IBCPOL"
85 .D ^DIC K DIC
86 .S IBYR=""
87 .I +Y S IBYR=$P(Y,"^",2)
88 I $G(IBYR)<1 S VALMQUIT=""
89GETYR2Q Q
90 ;
91EXIT ;
92 K VALMQUIT,IBCHANGE,IBCAB,IBCABC,IBCABD,IBYR,IBCABD1,IBCABD2,IBCABD3,IBCABD4,IBCABD5
93 D CLEAN^VALM10
94 Q
95BLANK(LINE) ; -- Build blank line
96 D SET^VALM10(.LINE,$J("",80))
97 Q
98 ;
99HELP ; -- Help Code
100 S X="?" D DISP^XQORM1 W !!
101 Q
Note: See TracBrowser for help on using the repository browser.