source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDEM.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1PXRMPDEM ; SLC/PKR - Computed findings for patient demographics. ;07/21/2006
2 ;;2.0;CLINICAL REMINDERS;**5,4**;Feb 04, 2005;Build 21
3 ;
4 ;======================================================
5AGE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for returning a patient's
6 ;age
7 S DATE=$$NOW^PXRMDATE,TEST=1
8 I $D(PXRMPDEM) D Q
9 . S VALUE=PXRMPDEM("AGE")
10 . I +PXRMPDEM("DOD")=0 S VALUE("DECEASED")=0 Q
11 . I +PXRMPDEM("DOD")>0 S VALUE("DECEASED")=1,TEXT="Patient is deceased"
12 I '$D(PXRMPDEM) D
13 . N DOB,DOD
14 .;DBIA #10035
15 . S DOB=$P(^DPT(DFN,0),U,3)
16 . S DOD=$P($G(^DPT(DFN,.35)),U,1)
17 . S VALUE=$$AGE^PXRMAGE(DOB,DOD,$$NOW^PXRMDATE)
18 . I +DOD=0 S VALUE("DECEASED")=0 Q
19 . I +DOD>0 S VALUE("DECEASED")=1,TEXT="Patient is deceased"
20 Q
21 ;
22 ;======================================================
23DISCHDT(DFN,TEST,DATE,VALUE,TEXT) ;This computed finding will return
24 ;the most recent service separation date.
25 N CNT,IRW,VAROOT
26 S VAROOT="IRW"
27 D SVC^VADPT
28 S VALUE=$P($G(IRW(6,5)),U)
29 I VALUE="" S TEST=0 D KVA^VADPT Q
30 S DATE=VALUE,TEST=1
31 S TEXT="Last Service Separation date: "_$$EDATE^PXRMDATE(VALUE)_" Branch of Service: "_$P($G(IRW(6,1)),U,2)
32 D KVA^VADPT
33 Q
34 ;
35 ;======================================================
36DOB(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for a patient's
37 ;date of birth.
38 I $D(PXRMPDEM) S VALUE=PXRMPDEM("DOB")
39 ;DBIA #10035 DATE OF BIRTH is a required field.
40 I '$D(PXRMPDEM) S VALUE=$P(^DPT(DFN,0),U,3)
41 S TEST=$S(VALUE<$$NOW^PXRMDATE:1,1:0)
42 I TEST S DATE=VALUE,TEXT=$$EDATE^PXRMDATE(VALUE)
43 Q
44 ;
45 ;======================================================
46DOD(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for a patient's
47 ;date of death.
48 I $D(PXRMPDEM) S VALUE=+PXRMPDEM("DOD")
49 ;DBIA #10035
50 I '$D(PXRMPDEM) S VALUE=+$P($G(^DPT(DFN,.35)),U,1)
51 S TEST=$S(VALUE=0:0,VALUE>$$NOW^PXRMDATE:0,1:1)
52 I TEST S DATE=VALUE,TEXT=$$EDATE^PXRMDATE(VALUE)
53 Q
54 ;
55 ;======================================================
56ETHNY(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding for
57 ;a patient's ethnicity.
58 N CNT,CNT1,VADM
59 D DEM^VADPT
60 I $D(VADM(11))'=11 S NFOUND=0 D KVA^VADPT Q
61 S NGET=$S(NGET<0:-NGET,1:NGET)
62 S (CNT,CNT1)=0
63 F S CNT=$O(VADM(11,CNT)) Q:(CNT="")!(CNT1=NGET) D
64 . S CNT1=CNT1+1,TEST(CNT1)=1,DATE(CNT1)=$$NOW^PXRMDATE
65 . S TEXT(CNT1)="",VALUE(CNT1,"VALUE")=$P($G(VADM(11,CNT)),U,2)
66 S NFOUND=CNT1
67 D KVA^VADPT
68 Q
69 ;
70 ;======================================================
71HDISCH(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
72 ;a list of a patient's discharge dates from PTF.
73 ;References to ^DGPT covered by DBIA #1372.
74 N DAS,DDATE,DDATEL,DONE,FEEBASIS,IEN,IND,INCEN,INFEE,NF,SDIR,TEMP,TYPE
75 S TEMP=$$UP^XLFSTR(TEST)
76 S TEMP=$P(TEMP,"IN:",2)
77 S INFEE=$S(TEMP["FEE":1,1:0)
78 S INCEN=$S(TEMP["CEN":1,1:0)
79 S IEN="",NFOUND=0
80 F S IEN=$O(^DGPT("B",DFN,IEN)) Q:IEN="" D
81 . S DDATE=+$P($G(^DGPT(IEN,70)),U,1)
82 . I DDATE>0,DDATE'<BDT,DDATE'>EDT S NFOUND=NFOUND+1,DDATEL(DDATE,NFOUND)=^DGPT(IEN,0)
83 I NFOUND=0 Q
84 S SDIR=$S(NGET<0:1,1:-1)
85 S NGET=$S(NGET<0:-NGET,1:NGET)
86 S (DONE,NF)=0
87 S DDATE=""
88 F IND=1:1:NFOUND Q:DONE D
89 . S DDATE=$O(DDATEL(DDATE),SDIR)
90 . I DDATE="" S DONE=1 Q
91 . S IEN=0
92 . F S IEN=$O(DDATEL(DDATE,IEN)) Q:(IEN="")!(DONE) D
93 .. S FEEBASIS=$P(DDATEL(DDATE,IEN),U,4)
94 .. I FEEBASIS=1,'INFEE Q
95 ..;Type 1 is PTF, Type 2 is Census
96 .. S TYPE=$P(DDATEL(DDATE,IEN),U,11)
97 .. I TYPE=2,'INCEN Q
98 .. S NF=NF+1
99 .. S TEST(NF)=1,(DATE(NF),VALUE(NF))=DDATE
100 .. I FEEBASIS=1 S TEXT(NF)="Fee basis"
101 .. I TYPE=2 S TEXT(NF)="Census"
102 .. I NF=NGET S DONE=1
103 S NFOUND=NF
104 Q
105 ;
106 ;======================================================
107NEWRACE(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,VALUE,TEXT) ;Computed finding
108 ;for returning a patient's multi-valued race.
109 N CNT,CNT1,IND,VADM
110 D DEM^VADPT
111 I $D(VADM(12))'=11 S NFOUND=0 D KVA^VADPT Q
112 S NGET=$S(NGET<0:-NGET,1:NGET)
113 S (CNT,CNT1)=0
114 F S CNT=$O(VADM(12,CNT)) Q:(CNT="")!(CNT1=NGET) D
115 . S CNT1=CNT1+1,TEST(CNT1)=1,DATE(CNT1)=$$NOW^PXRMDATE
116 . S TEXT(CNT1)="",VALUE(CNT1,"VALUE")=$P($G(VADM(12,CNT)),U,2)
117 F CNT=1:1:CNT1 F IND=1:1:CNT1 S VALUE(CNT,"RACE",IND)=VALUE(IND,"VALUE")
118 S NFOUND=CNT1
119 D KVA^VADPT
120 Q
121 ;
122 ;======================================================
123PATTYPE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding to return the patient
124 ;type
125 N VAEL
126 S VALUE=""
127 S DATE=$$NOW^PXRMDATE
128 D ELIG^VADPT
129 S TEST=$S($G(VAEL(6))'="":1,1:0)
130 S VALUE=$P(VAEL(6),U,2)
131 D KVA^VADPT
132 Q
133 ;======================================================
134RACE(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking a patient's race.
135 N RACE
136 S DATE=$$NOW^PXRMDATE
137 ;DBIA #10035
138 S RACE=$P($G(^DPT(DFN,0)),U,6)
139 I RACE="" S TEST=0,VALUE="" Q
140 Q
141 ;
142 ;======================================================
143SEX(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for returning a patient's
144 ;sex.
145 S DATE=$$NOW^PXRMDATE,TEST=1
146 I $D(PXRMPDEM) S VALUE=PXRMPDEM("SEX") Q
147 ;DBIA #10035 SEX is a required field.
148 I '$D(PXRMPDEM) S VALUE=$P(^DPT(DFN,0),U,2)
149 Q
150 ;
151 ;======================================================
152VETERAN(DFN,TEST,DATE,VALUE,TEXT) ;Computed finding for checking if a
153 ;patient is a veteran.
154 N VAEL
155 S DATE=$$NOW^PXRMDATE
156 D ELIG^VADPT
157 S TEST=VAEL(4)
158 S VALUE=""
159 D KVA^VADPT
160 Q
161 ;
Note: See TracBrowser for help on using the repository browser.