source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNPAT3.m@ 634

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

initial load of WorldVistAEHR
File size: 4.2 KB
Line 
1AUPNPAT3 ; IHS/CMI/LAB - PATIENT RELATED FUNCTIONS ; 2/8/05 3:59pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
3 ;
4 ;IHS/CMI/LAB - patch 2 Y2K
5 ;IHS/CMI/LAB - patch 8 DOD check in AGE subroutine
6 Q
7 ;
8AGE(DFN,D,F) ;EP - Given DFN, return Age.
9 I '$G(DFN) Q -1
10 I '$D(^DPT(DFN,0)) Q -1
11 I $$DOB^AUPNPAT(DFN,"")<0 Q -1
12 ;S:$G(D)="" D=DT ;IHS/CMI/LAB - added DOD check patch 8
13 S:$G(D)="" D=$S(+$$DOD^AUPNPAT3(DFN):$$DOD^AUPNPAT3(DFN),1:DT)
14 S:$G(F)="" F="Y"
15 NEW %
16 S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
17 S %1=%\365.25
18 I F="Y" Q %1
19 Q $S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS")
20 ;
21BEN(DFN,F) ;EP - returns classification/beneficiary in F format
22 ;F="E":name of beneficiary type, F="I":ien of beneficiary type, F="C":code of beneficiary type
23 I '$G(DFN) Q -1
24 I '$D(^AUPNPAT(DFN,11)) Q -1
25 I $P(^AUPNPAT(DFN,11),"^",11)="" Q ""
26 I '$D(^AUTTBEN($P(^AUPNPAT(DFN,11),"^",11))) Q -1
27 S F=$G(F)
28 Q $S(F="I":$P(^AUPNPAT(DFN,11),"^",11),F="E":$P(^AUTTBEN($P(^AUPNPAT(DFN,11),"^",11),0),"^"),1:$P(^AUTTBEN($P(^AUPNPAT(DFN,11),"^",11),0),"^",2))
29 ;
30CDEATH(DFN,F) ;EP - returns Cause of Death in F format
31 ;F="E":ICD narrative, F="I":ien of icd code, F="C":icd code
32 I '$G(DFN) Q ""
33 I '$D(^AUPNPAT(DFN)) Q ""
34 I '$P($G(^AUPNPAT(DFN,11)),"^",14) Q ""
35 I '$D(^ICD9($P(^AUPNPAT(DFN,11),"^",14))) Q ""
36 S F=$G(F)
37 Q $S(F="I":$P(^AUPNPAT(DFN,11),"^",14),F="E":$P(^ICD9($P(^AUPNPAT(DFN,11),"^",14),0),"^",3),1:$P(^ICD9($P(^AUPNPAT(DFN,11),"^",14),0),"^"))
38 ;
39COMMRES(DFN,F) ;EP - Given DFN, return comm of res in F format
40 ;F="E":community name, F="I":community ien, F="C":community STCTYCOM code
41 I '$G(DFN) Q -1
42 I '$D(^AUPNPAT(DFN,11)) Q -1
43 I $P(^AUPNPAT(DFN,11),"^",17)="" Q ""
44 I '$D(^AUTTCOM($P(^AUPNPAT(DFN,11),"^",17))) Q -1
45 S F=$G(F)
46 Q $S(F="I":$P(^AUPNPAT(DFN,11),"^",17),F="E":$P(^AUTTCOM($P(^AUPNPAT(DFN,11),"^",17),0),"^"),1:$P(^AUTTCOM($P(^AUPNPAT(DFN,11),"^",17),0),"^",8))
47 ;
48DOB(DFN,F) ;EP - Given DFN, return Date of Birth according to F.
49 ; If F="E" produce the External form, else FM format.
50 I '$G(DFN) Q -1
51 I '$D(^DPT(DFN,0)) Q -1
52 S F=$G(F)
53 ;beginning Y2K mods - change 2 parameter is FMTE call to 5
54 ;Q $S(F="E":$$FMTE^XLFDT($P(^DPT(DFN,0),"^",3)),F="S":$$FMTE^XLFDT($P(^DPT(DFN,0),"^",3),2),1:$P(^DPT(DFN,0),"^",3)) ;Y2000 IHS/CMI/LAB - commented out
55 Q $S(F="E":$$FMTE^XLFDT($P(^DPT(DFN,0),"^",3)),F="S":$$FMTE^XLFDT($P(^DPT(DFN,0),"^",3),5),1:$P(^DPT(DFN,0),"^",3)) ;Y2000 IHS/CMI/LAB
56 ;end Y2K mods
57 ;
58DOD(DFN,F) ;EP - Given DFN, return Date of Death according to F.
59 ; If F="E" produce the External form, else FM format.
60 I '$G(DFN) Q -1
61 I '$D(^DPT(DFN,0)) Q -1
62 S F=$G(F)
63 Q $S(F="E":$$FMTE^XLFDT($P($G(^DPT(DFN,.35)),"^")),1:$P($G(^DPT(DFN,.35)),"^"))
64 ;
65ELIGSTAT(DFN,F) ;EP - returns eligibility status in F format
66 ;F="E":eligibility type (name), F="I":internal set of codes
67 ;Begin new code DAOU/JLG 2/8/05
68 ;Not valid for VO EHR
69 I $G(DUZ("AG"))="E" Q -1
70 ;End new code.
71 I '$G(DFN) Q -1
72 I '$D(^AUPNPAT(DFN,11)) Q -1
73 S F=$G(F)
74 ;Line commented out to prevent XINDEX error DAOU/JLG 2/8/05
75 ;Q $S(F="E":$$EXTSET^XBFUNC(9000001,1112,$P(^AUPNPAT(DFN,11),"^",12)),1:$P(^AUPNPAT(DFN,11),"^",12))
76 Q -1 ;Line added to prevent error DAOU/JLG 2/8/05
77 ;
78HRN(DFN,L,F) ;EP - return HRN at L location
79 ;L must be ien of location of encounter
80 ;F is optional. If F=2 hrn will be prefixed with site abbreviation
81 I '$G(DFN) Q -1
82 I '$D(^AUPNPAT(DFN)) Q -1
83 I '$G(L) Q -1
84 I $G(F)=2,'$D(^AUTTLOC(L,0)) Q -1
85 Q $S($D(^AUPNPAT(DFN,41,L,0)):$S($G(F)=2:$P(^AUTTLOC(L,0),"^",7)_" ",1:"")_$P(^AUPNPAT(DFN,41,L,0),"^",2),1:"")
86 Q $P($G(^AUPNPAT(DFN,41,L,0)),"^",2)
87 ;
88SEX(DFN) ;EP - Given DFN, return Sex.
89 I '$G(DFN) Q -1
90 I '$D(^DPT(DFN,0)) Q -1
91 Q $P(^DPT(DFN,0),"^",2)
92 ;
93SSN(DFN) ;EP - Given DFN, return SSN.
94 I '$G(DFN) Q -1
95 I '$D(^DPT(DFN,0)) Q -1
96 Q $P(^DPT(DFN,0),"^",9)
97 ;
98TRIBE(DFN,F) ;EP - Given DFN, return Tribe in F format
99 ;If F="E", name of tribe returned, if F="I", internal ien of tribe
100 ;returned, if F="C", tribe code returned
101 I '$G(DFN) Q -1
102 I '$D(^AUPNPAT(DFN,11)) Q -1
103 I $P(^AUPNPAT(DFN,11),"^",8)="" Q ""
104 I '$D(^AUTTTRI($P(^AUPNPAT(DFN,11),"^",8))) Q -1
105 S F=$G(F)
106 Q $S(F="I":$P(^AUPNPAT(DFN,11),"^",8),F="E":$P(^AUTTTRI($P(^AUPNPAT(DFN,11),"^",8),0),"^"),1:$P(^AUTTTRI($P(^AUPNPAT(DFN,11),"^",8),0),"^",2))
107 ;
Note: See TracBrowser for help on using the repository browser.