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

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1IBCNSU4 ;ALB/CPM - SPONSOR UTILITIES ; 21-JAN-97
2 ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5GET(DFN,ARR) ; Retrieve sponsor relationships for a patient.
6 ; Input: DFN -- Pointer to the patient in file #2
7 ; Output: ARR -- Passed by reference:
8 ;
9 ; ARR = #, where # is the number of relationships
10 ;
11 ; ARR(#,"REL")=1^2^3^4^5, where
12 ; 1 => sponsor name
13 ; 2 => family prefix
14 ; 3 => type (tricare/champva)
15 ; 4 => effective date (fm format)
16 ; 5 => expiration date (fm format)
17 ; 6 => pointer to the relationship in file #355.81
18 ;
19 ; ARR(#,"SPON")=1^2^3^4^5^6, where
20 ; 1 => sponsor name
21 ; 2 => sponsor dob (external format)
22 ; 3 => sponsor ssn (external format [dashes])
23 ; 4 => military status (active duty/retired)
24 ; 5 => branch (expanded from file #23)
25 ; 6 => rank
26 ;
27 N BRAN,REL,SPON,STAT,X,X1,XSPON,Y,Y1
28 K ARR S ARR=0
29 I '$G(DFN) G GETQ
30 ;
31 ; - look at all of the patient's sponsor relationships
32 S X=0 F S X=$O(^IBA(355.81,"B",DFN,X)) Q:'X D
33 .S REL=$G(^IBA(355.81,X,0)) Q:'REL
34 .S SPON=$G(^IBA(355.8,+$P(REL,"^",2),0)) Q:'SPON
35 .I $L(REL,"^")<6 S REL=REL_"^^^^^^^"
36 .;
37 .; - if the sponsor is a patient, gather attributes from file #2
38 .I $P(SPON,"^")["DPT" D
39 ..S X1=$G(^DPT(+SPON,0))
40 ..S Y=$P(X1,"^",3) X ^DD("DD")
41 ..S XSPON=$P(X1,"^")_"^"_Y_"^"_$$SSN($P(X1,"^",9))
42 .;
43 .; - if the sponsor is not a patient, go to file #355.82
44 .E D
45 ..S XSPON=$G(^IBA(355.82,+SPON,0)) S:$L(XSPON,"^")<3 XSPON=XSPON_"^^"
46 ..S Y=$P(XSPON,"^",2) I Y X ^DD("DD") S $P(XSPON,"^",2)=Y
47 ..S Y=$P(XSPON,"^",3) I Y S $P(XSPON,"^",3)=$$SSN(Y)
48 .;
49 .;
50 .; - build sponsor relation array
51 .S $P(REL,"^",4)=$S($P(REL,"^",4)="T":"TRICARE",$P(REL,"^",4)="C":"CHAMPVA",1:"")
52 .S ARR=ARR+1,ARR(ARR,"REL")=$P(XSPON,"^")_"^"_$P(REL,"^",3,6)_"^"_X
53 .;
54 .; - build sponsor array
55 .S STAT=$S($P(SPON,"^",2)="A":"ACTIVE DUTY",$P(SPON,"^",2)="R":"RETIRED",1:"")
56 .S BRAN=$P($G(^DIC(23,+$P(SPON,"^",3),0)),"^")
57 .S ARR(ARR,"SPON")=$P(XSPON,"^",1,3)_"^"_STAT_"^"_BRAN_"^"_$P(SPON,"^",4)
58 ;
59GETQ Q
60 ;
61 ;
62SSN(X) ; Strip dashes from SSN and add them back in.
63 S:$G(X)'="" X=$TR(X,"-","")
64 Q $S($G(X)="":"",1:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,13))
Note: See TracBrowser for help on using the repository browser.