source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF78.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: 2.0 KB
Line 
1IBCEF78 ;ALB/WCJ - Provider ID functions ;13 May 2007
2 ;;2.0;INTEGRATED BILLING;**371**;21-MAR-94;Build 57
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;;
5 G AWAY
6AWAY Q
7 ;
8PAYERIDS(IBXIEN,IBRET) ; This function returns all the PAYER IDS for the current and other insurance(s)
9 ;
10 D PRIPAYID(IBXIEN,.IBRET)
11 D SECPAYID(IBXIEN,.IBRET)
12 Q
13 ;
14PRIPAYID(IBXIEN,IBXRET) ; Primary Payer IDs
15 ; Incoming:
16 ; IBXIEN = IEN for File # 399
17 ; IBXRET = Return Array for Qualifiers and IDs
18 ;
19 ; Outgoing
20 ; IBXRET("CI_PID",1)=QUAL^ID
21 ; IBXRET("OI_PID",#)=QUAL^ID
22 ;
23 N RET,I
24 S RET=$$PAYERID^IBCEF2(IBXIEN)
25 I RET]"" S IBXRET("CI_PID",1)="PI"_U_RET
26 ;
27 D OTHINSID^IBCEF72(IBXIEN,.RET)
28 F I=1,2 I $G(RET(I))]"" S IBXRET("OI_PID",I)="PI"_U_RET(I)
29 Q
30 ;
31 ;
32SECPAYID(IBXIEN,IBXRET) ; This returns all of the secondary payer IDs from file #36
33 ; for the insurance companies on a given claim
34 ;
35 ; Incoming:
36 ; IBXIEN = IEN for File # 399
37 ; IBXRET = Return Array for Qualifiers and IDs
38 ;
39 ; Outgoing
40 ; IBXRET("CI_PSIDS",1)=QUAL^ID^QUAL^ID
41 ; IBXRET("OI_PSIDS",#)=QUAL^ID^QUAL^ID
42 ;
43 N Z,C,IBZ,Z0,FT
44 F Z=1:1:3 S IBZ(Z)=$$POLICY^IBCEF(IBXIEN,1,Z)
45 S Z0=0,C=$$COBN^IBCEF(IBXIEN),FT=$$FT^IBCEF(IBXIEN)
46 F Z=1:1:3 S:C'=Z Z0=Z0+1 S IBXRET($S(C=Z:"CI_PSIDS",1:"OI_PSIDS"),$S(C=Z:1,1:Z0))=$$SPIDS(+IBZ(Z),FT)
47 Q
48 ;
49SPIDS(INS,FT) ;
50 ; FT = FORM TYPE (2 PROFESSIONAL 3 INSTITUTIONAL)
51 ; INS = INSURANCE COMPANY (FILE #36) IEN
52 ; Returns String (^ delimited)
53 ; [1] = QUAL 1
54 ; [2] = PAYER ID 1
55 ; [3] = QUAL 2
56 ; [4] = PAYER ID 2
57 Q:'+INS ""
58 ;
59 N DATA,PCE
60 S DATA=$S(FT=3:$P($G(^DIC(36,+INS,6)),U,1,4),FT=2:$P($G(^DIC(36,+INS,6)),U,5,8),1:"")
61 ;
62 ; Check for dangling IDs/Qualifiers
63 F PCE=1,3 D
64 . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
65 . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
66 ;
67 ; fill in the gap if there is one
68 I $P(DATA,U,1)="",$P(DATA,U,3)'="" D
69 . S $P(DATA,U,1)=$P(DATA,U,3)
70 . S $P(DATA,U,2)=$P(DATA,U,4)
71 . S ($P(DATA,U,3),$P(DATA,U,4))=""
72 ;
73 Q DATA
74 ;
75CLEANUP(IBRET) ;
76 K IBRET("CI_PID"),IBRET("OI_PID"),IBRET("CI_PSIDS"),IBRET("OI_PSIDS")
77 Q
78 ;
Note: See TracBrowser for help on using the repository browser.