source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSDEM2.m@ 1769

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1GMTSDEM2 ; SLC/DLT,KER - Demographics (cont) ; 12/11/2002 [9/16/03 7:29am]
2 ;;2.7;Health Summary;**56,58,60,62**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10061 OAD^VADPT
6 ; DBIA 10061 DEM^VADPT
7 ; DBIA 951 ^IBE(355.1
8 ; DBIA 794 ^DIC(36
9 ; DBIA 2056 $$GET1^DIQ (file #36, and #355.1)
10 ; DBIA 10145 ALL^IBCNS1
11 ; DBIA 10104 $$UP^XLFSTR
12 ;
13NOKC ; Next of Kin Component
14 N GMTSNOK S GMTSNOK="" D NOK Q
15NOK ; Next of Kin
16 Q:$D(GMTSQIT) N %,%H,STR,STR1,STR2,NOKTYPE,ADR,VAERR,VAOA K VAOA("A") D OAD^VADPT
17 I $L($G(VAOA(9))) D
18 . ; Primary Next of Kin
19 . S NOKTYPE="Primary" D DNOK
20 . S VAOA("A")=3 D OAD^VADPT
21 . I $L($G(VAOA(9))) D
22 . . ; Secondary Next of Kin
23 . . K GMTSNOK S NOKTYPE="Secondary" D DNOK
24 Q
25DNOK ; Display Next of Kin
26 D:'$D(GMTSNOK) WRT^GMTSDEM("",,,,0) Q:$D(GMTSQIT)
27 S STR1=$$UP^XLFSTR(VAOA(9)),STR2=$S('$L(VAOA(10)):"<not given>",1:$$UP^XLFSTR(VAOA(10)))
28 D WRT^GMTSDEM(($G(NOKTYPE)_" NOK"),STR1,"Relation",STR2,1) Q:$D(GMTSQIT)
29 S ADR=$G(VAOA(1)) K VAOA(1) I '$L(ADR) S ADR=$G(VAOA(2)) K VAOA(2) I '$L(ADR) S ADR=$G(VAOA(3)) K VAOA(3)
30 S STR=$S('$L(ADR):"<street address not available>",1:$$UP^XLFSTR(ADR))
31 K:STR="<street address not available>" VAOA(1),VAOA(2),VAOA(3)
32 D WRT^GMTSDEM("",STR,"Phone",VAOA(8),1) Q:$D(GMTSQIT)
33 S ADR=$G(VAOA(2)) K VAOA(2) I '$L(ADR) S ADR=$G(VAOA(3)) K VAOA(3)
34 S STR=$$UP^XLFSTR(ADR) D:$L(STR) WRT^GMTSDEM("",STR,,,1) Q:$D(GMTSQIT)
35 S ADR=$G(VAOA(3))
36 S STR=$$UP^XLFSTR(ADR) D:$L(STR) WRT^GMTSDEM("",STR,,,1) Q:$D(GMTSQIT)
37 I VAOA(4)'="" D
38 . S STR=$$UP^XLFSTR(VAOA(4)) S:VAOA(5) STR=STR_", "_$$UP^XLFSTR($P(VAOA(5),U,2)) S:VAOA(6) STR=STR_" "_$$UP^XLFSTR(VAOA(6))
39 . D WRT^GMTSDEM("",STR,,,1) Q:$D(GMTSQIT)
40 Q
41 ;
42INS ; Insurance Info
43 N I,INSURE,GMTSX,IEN,VAL,CLAIM,COMPANY,TYPE,COB,SUBSCRIB,GROUP,HOLDER,EFFECT,EXPIRE
44 D ALL^IBCNS1(DFN,"INSURE") Q:$O(INSURE(0))=""
45 S I=0 F S I=$O(INSURE(I)) Q:'I D Q:$D(GMTSQIT)
46 . S (COMPANY,TYPE,GROUP,HOLDER,EFFECT,EXPIRE)=""
47 . S GMTSX=INSURE(I,0),IEN=+GMTSX
48 . ; Insurance Company
49 . S COMPANY=$$GET1^DIQ(36,(+IEN_","),.01) Q:'$L(COMPANY)
50 . S CLAIM=INSURE(I,355.3)
51 . ; Policy Type
52 . S IEN=$P(CLAIM,"^",9)
53 . S TYPE="" I IEN]"" D
54 . . S TYPE=$$GET1^DIQ(355.1,(+IEN_","),.01) S TYPE=$$ABR(TYPE)
55 . ; Group Number
56 . S GROUP=$P(CLAIM,"^",4)
57 . S GMTSX=INSURE(I,0),VAL=$P(GMTSX,"^",6)
58 . ; Insurance Policy Holder
59 . S HOLDER=$S(VAL="v":"SELF",VAL="s":"SPOUSE",1:"OTHER")
60 . ; Insurance Effect Date
61 . S EFFECT=$P(GMTSX,"^",8)
62 . ; Insurance Expiration Date
63 . S EXPIRE=$P(GMTSX,"^",4)
64 . ; Subscriber ID
65 . S SUBSCRIB=$P($G(INSURE(I,0)),"^",2)
66 . ; Coordination of Benefits
67 . S COB=+($P($G(INSURE(I,0)),"^",20))
68 . S COB=$S(COB=1:"PRIMARY",COB=2:"SECONDARY",COB=3:"TERTIARY",1:"UNKNOWN")
69 . Q:$D(GMTSQIT) D WRT^GMTSDEM("",,,,0) Q:$D(GMTSQIT)
70 . D WRT^GMTSDEM("Insurance Company",$E(COMPANY,1,27),"Holder",HOLDER,1) Q:$D(GMTSQIT)
71 . I $L(TYPE)!($L(EFFECT)) D WRT^GMTSDEM("Policy Type",$E(TYPE,1,28),"Effective",$$EDT^GMTSU(EFFECT),1) Q:$D(GMTSQIT)
72 . I $L(GROUP)!($L(EXPIRE)) D WRT^GMTSDEM("Group #",$E(GROUP,1,28),"Expires",$$EDT^GMTSU(EXPIRE),1) Q:$D(GMTSQIT)
73 . I $L(SUBSCRIB)!($L(COB)) D WRT^GMTSDEM("Subscriber ID",$E(SUBSCRIB,1,28),"Coord. of Benefits",COB,1) Q:$D(GMTSQIT)
74 Q
75 ;
76RACE ; Race and Ethnicity
77 N GMTS D ER(+($G(DFN)),.GMTS) I $L($G(GMTS(2)))!($L($G(GMTS(6)))) D Q
78 . N GMTSD,GMTSI,GMTSC
79 . S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(6)),"^",GMTSI)) D Q:$D(GMTSQIT)
80 . . S GMTSD=$P($G(GMTS(6)),"^",GMTSI),GMTSC=GMTSC+1
81 . . D:+GMTSC=1 WRT^GMTSDEM("Ethnicity",GMTSD,"",,1) Q:$D(GMTSQIT)
82 . . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
83 . Q:$D(GMTSQIT)
84 . S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(2)),"^",GMTSI)) D Q:$D(GMTSQIT)
85 . . S GMTSD=$P($G(GMTS(2)),"^",GMTSI),GMTSC=GMTSC+1
86 . . D:+GMTSC=1 WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
87 . . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
88 I '$L($G(GMTS(2)))&('$L($G(GMTS(6)))) D Q
89 . N GMTSD,GMTSI,GMTSC S GMTSD=$G(GMTS(.06)) D WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
90 Q
91RE ; Race and Ethnicity Component
92 N GMTS D ER(+($G(DFN)),.GMTS) I $L($G(GMTS(2)))!($L($G(GMTS(6)))) D Q
93 . N GMTSD,GMTSI,GMTSC
94 . S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(6)),"^",GMTSI)) D Q:$D(GMTSQIT)
95 . . S GMTSD=$P($G(GMTS(6)),"^",GMTSI),GMTSC=GMTSC+1
96 . . D:+GMTSC=1 WRT^GMTSDEM("Ethnicity",GMTSD,"",,1) Q:$D(GMTSQIT)
97 . . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
98 . Q:$D(GMTSQIT)
99 . S (GMTSI,GMTSC)=0 F GMTSI=1:1 Q:'$L($P($G(GMTS(2)),"^",GMTSI)) D Q:$D(GMTSQIT)
100 . . S GMTSD=$P($G(GMTS(2)),"^",GMTSI),GMTSC=GMTSC+1
101 . . D:+GMTSC=1 WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
102 . . D:+GMTSC>1 WRT^GMTSDEM("",GMTSD,"",,1) Q:$D(GMTSQIT)
103 I '$L($G(GMTS(2)))&('$L($G(GMTS(6)))) D Q
104 . N GMTSD,GMTSI,GMTSC S GMTSD=$G(GMTS(.06)) D WRT^GMTSDEM("Race",GMTSD,"",,1) Q:$D(GMTSQIT)
105 Q
106ER(DFN,GMTS) ; Get Ethnicity and Race
107 N VADM,VA,VAERR,GMTSD,GMTSI,GMTSC,X,Y S DFN=+($G(DFN)) Q:+DFN=0
108 D DEM^VADPT S GMTSD=$P($G(VADM(8)),"^",2),GMTS(.06)=GMTSD,GMTS("OLD")=GMTSD
109 S GMTSI=0 F S GMTSI=$O(VADM(11,GMTSI)) Q:+GMTSI=0 D
110 . S GMTSD=$P($G(VADM(11,GMTSI)),"^",2) S:$L(GMTSD) GMTS(6)=$G(GMTS(6))_"^"_GMTSD
111 S GMTSD=$G(GMTS(6)) F Q:$E(GMTSD,1)'="^" S GMTSD=$E(GMTSD,2,$L(GMTSD))
112 S GMTS(6)=GMTSD S GMTSI=0 F S GMTSI=$O(VADM(12,GMTSI)) Q:+GMTSI=0 D
113 . S GMTSD=$P($G(VADM(12,GMTSI)),"^",2) S:$L(GMTSD) GMTS(2)=$G(GMTS(2))_"^"_GMTSD
114 S GMTSD=$G(GMTS(2)) F Q:$E(GMTSD,1)'="^" S GMTSD=$E(GMTSD,2,$L(GMTSD))
115 S GMTS(2)=GMTSD,GMTSD=$G(GMTS(6))_"^^"_$G(GMTS(2)) F Q:$E(GMTSD,1)'="^" S GMTSD=$E(GMTSD,2,$L(GMTSD))
116 S GMTS("NEW")=GMTSD,GMTS(.06)=$G(GMTS(.06)),GMTS(2)=$G(GMTS(2)),GMTS(6)=$G(GMTS(6))
117 Q
118 ;
119ABR(X) ; Abbreviations
120 S X=$$UP^XLFSTR($G(X)) N TM,AB,SID S TM="PROCEDURES",AB="PROC" S:X[TM X=$$SW(X,TM,AB)
121 S TM="SUPPLEMENTAL",AB="SUP" S:X[TM X=$$SW(X,TM,AB) S TM="ORGANIZATION",AB="ORG" S:X[TM X=$$SW(X,TM,AB) S TM="ORIGIZ",AB="ORG" S:X[TM X=$$SW(X,TM,AB)
122 S TM="ORGANIZ",AB="ORG" S:X[TM X=$$SW(X,TM,AB) S TM="MAINTENANCE",AB="MAINT" S:X[TM X=$$SW(X,TM,AB) S TM="PROVIDER",AB="PROV" S:X[TM X=$$SW(X,TM,AB)
123 S TM="INDIVIDUAL",AB="INDIVID" S:X[TM X=$$SW(X,TM,AB) S TM="ASSOCATION",AB="ASSOC" S:X[TM X=$$SW(X,TM,AB) S TM="ASSOCIATION",AB="ASSOC" S:X[TM X=$$SW(X,TM,AB)
124 S TM="PRACT",AB="PRACT" S:X[TM X=$$SW(X,TM,AB) S TM="INSURANCE",AB="INS" S:X[TM X=$$SW(X,TM,AB) S TM="ETC.",AB="ETC" S:X[TM X=$$SW(X,TM,AB)
125 S TM="(ONLY)",AB="" S:X[TM X=$$SW(X,TM,AB) S TM="PROTECTION",AB="PROT" S:X[TM X=$$SW(X,TM,AB) S TM="PRACTICE",AB="PRACT" S:X[TM X=$$SW(X,TM,AB)
126 Q X
127SW(X,Y,Z) ; Swap Abbreviation with Term
128 N TM,AB
129 S X=$G(X),TM=$$TRIM($G(Y)),AB=$$TRIM($G(Z)) Q:X="" "" Q:TM="" X Q:TM=AB X
130 F Q:X'[TM S X=$P(X,TM,1)_AB_$P(X,TM,2)
131 Q X
132TRIM(X) ; Trim Spaces
133 S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
134 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
135 F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
136 Q X
Note: See TracBrowser for help on using the repository browser.