source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRC2.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 2.8 KB
Line 
1IBTRC2 ;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 356.2 DD ; 22-JULY-91
2 ;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6DD(IBX,IBDA) ; - called from input transform for field 1.05
7 ; -- input ibx = x from input transform
8 ; ibda = internal entry in 356.2
9 ; -- output returns x=internal entry in 2.3121 (ins. Mult.) if valid
10 ;
11 N DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN,DA,DR,DIC,DIE
12 D VAR
13 S X=$$SEL^IBCNS2(IBX,DFN,DT,ACTIVE)
14 I +X<1 K X
15DDQ Q
16 ;
17VAR S DFN=$P(^IBT(356.2,IBDA,0),"^",5)
18 I DFN="" S DFN=$P($G(^IBT(356,+$P(^IBT(356.2,IBDA,0),"^",2),0)),"^",2)
19 S ACTIVE=2,INSDT=DT
20 Q
21 ;
22SEL(IBX,DFN,INSDT,ACTIVE) ; -- Select insurance policy
23 ; -- Input IBX = x from input transform
24 ; DFN = patient
25 ; INSDT = (optional) Active date of ins. (default = dt)
26 ; ACTIVE = (optional) 1 if want active (default)
27 ; = 2 if want all ins returned
28 ;
29 ; -- Output = pointer to 36 ^ pointer to 2.3121 ^ pointer to 355.3
30 ;
31 N I,J,Y,DA,DE,DQ,DR,DIC,DIE,DIR,DIV,IBSEL,IBDD,IBD
32 S IBSEL=1,Y=""
33 I '$G(ACTIVE) S ACTIVE=2
34 S:'$G(INSDT) INSDT=DT
35 I '$G(DFN) G SELQ
36 D BLD
37 ;
38 ; -- call DIC to choose from list
39 S X=IBX
40 S DIC="^DPT("_DFN_",.312,",DIC(0)="EQMN"
41 S DIC("S")="I $D(IBDD(+Y))"
42 S DIC("W")="W $P(^DIC(36,+^(0),0),U)_"" Group: ""_$$GRP^IBCNS($P(^DPT(DFN,.312,+Y,0),U,18))"
43 D ^DIC
44SELQ Q +Y
45 ;
46BLD K IBD,IBDD
47 S (IBDD,IBCDFN)=0 F S IBCDFN=$O(^DPT(+DFN,.312,IBCDFN)) Q:'IBCDFN I $D(^DPT(DFN,.312,+IBCDFN,0)) D CHK(IBCDFN,ACTIVE,INSDT)
48 Q
49 ;
50CHK(IBCDFN,ACTIVE,INSDT) ; -- see if active
51 N X,X1
52 S X=$G(^DPT(DFN,.312,IBCDFN,0))
53 S IBDD(IBCDFN)=+X_"^"_IBCDFN_"^"_$P(X,"^",18)
54 I ACTIVE=2 G CHKQ
55 S X1=$G(^DIC(36,+X,0)) I X1="" G CQ ;ins co entry doesn't exist
56 I $P(X,"^",8) G:INSDT<$P(X,"^",8) CQ ;effective date later than care
57 I $P(X,"^",4) G:INSDT>$P(X,"^",4) CQ ;care after expiration date
58 I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CQ ;plan is inactive
59 G:$P(X1,"^",5) CQ ; ;ins company inactive
60 G:$P(X1,"^",2)="N" CQ ; ;ins company will not reimburse
61 G CHKQ
62CQ K IBDD(IBCDFN)
63CHKQ S:$D(IBDD(IBCDFN)) IBDD=IBDD+1,IBD(IBDD)=IBCDFN
64 Q
65 ;
66 ;
67DDHELP(IBDA) ; -- Executable help
68 ; -- write out list to choose from
69 N DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN,I,IBINS
70 D VAR,BLD
71 ;
72 I $G(IBDD)=0 W !,"No Insurance Policies to Select From" G DDHQ
73 ;
74 I '$D(IOM) D HOME^%ZIS
75 W ! D HDR^IBCNS
76 S I=0 F S I=$O(IBD(I)) Q:'I D
77 .S IBINS=$G(^DPT(DFN,.312,$G(IBD(I)),0))
78 .D D1^IBCNS
79DDHQ Q
80 ;
81TRANS(IBDA,Y) ; -- output transform
82 N DFN,INSDT,ACTIVE,IBDD,IBD,IBCDFN
83 D VAR
84 S Y=$P($G(^DIC(36,+$P($G(^DPT(DFN,.312,+$G(Y),0)),U),0)),U)
85 Q Y
86 ;
87INSCO(IBDA,IBCDFN) ; -- return pointer value of 36 from pt. file
88 N DFN,INSDT,ACTIVE,IBDD,IBD
89 D VAR
90 S Y=+$G(^DPT(DFN,.312,IBCDFN,0))
91 Q Y_$S(Y>0:"^"_$P($G(^DIC(36,+Y,0)),"^"),1:"")
Note: See TracBrowser for help on using the repository browser.