source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1DPTLK1 ;ALB/RMO,EG - MAS Patient Look-up Check Cross-References ; 08/15/2006
2 ;;5.3;Registration;**32,50,197,249,317,391,244,532,574,620,641,680,538,657**;Aug 13, 1993;Build 19
3FIND ;Cross reference patient lookup
4 ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
5 ; by patch DG*5.3*244
6 ;
7 N DDCOMA,DPTXOLD,DPTOUT,DPTOVAL,DGLASTLK
8 S DGLASTLK=1
9 S (DPTXOLD,DPTX)=$$UCASE(DPTX)
10 I DPTX?1A.E1","1.A.E S DPTXOLD=DPTX,DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$L($P(DPTX,",",2))_")="""_$TR($P(DPTX,",",2),"""")_"""",DPTX=$P(DPTX,",")
11 K DPTREFS S DPTREFS=$S(DIC(0)'["M":"B,NOP",DPTX?1A1N.N:$S($L(DPTX)<6:"BS5,CN,RM",1:"CN,RM"),DPTX?4N!(DPTX?4N1A):"BS,SSN,CN,RM",DPTX?9N.E:"SSN,CN,RM",1:"")
12 S:DPTREFS="" DPTREFS=$S(DPTX?1N.N:$S($L(DPTX)<5:"CN,RM,BS,SSN",1:"CN,RM,SSN"),DPTX?1N.E:"CN,RM",1:"B,NOP,CN,RM") S:$D(DPTIX) DPTREFS=DPTIX_","_DPTREFS
13 ;Use cross reference passed to LIST^DPTLK1 by Person Service Lookup (DPTPSREF) if defined.
14 I $G(DPTPSREF)'="" S DPTREFS=DPTPSREF
15 S DPTBEG=1,(DPTDFN,DPTNUM,DPTOUT)=0
16 F DPTLP=1:1 S DPTREF=$P(DPTREFS,",",DPTLP) Q:DPTREF=""!(DPTDFN) D Q:DPTDFN!DPTOUT
17 .S DPTVAL=DPTX
18 .I DPTREF="NOP",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^XLFNAME7(DPTVAL,2,30,1,0,,1) Q:'$L(DPTVAL)
19 .D LOOK(DPTVAL)
20 .I DPTREF="B",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^XLFNAME7(DPTX,2,30,1,0,,1) D:DPTVAL'=DPTX LOOK(DPTVAL)
21 .Q
22SET I 'DPTDFN S:DPTCNT=1&($D(DPTIFNS(DPTCNT))) DPTDFN=+DPTIFNS(DPTCNT) S DPT("NOPRT^")="" D PRTDPT:'DPTDFN&(DPTCNT>DPTNUM)&(DIC(0)["E") K DPT("NOPRT^") I 'DPTDFN,$D(DPTSEL),DPTSEL="" S DPTX="",DPTDFN=-1
23 I DPTDFN'>0,$L($G(DPTXOLD)) I DPTX=$P(DPTXOLD,",") S DPTX=DPTXOLD
24 I DPTDFN>0,$D(DPTXOLD) S DPTX=DPTXOLD
25 ; one last stab at lookup - DG*641
26 I '$G(DPTCNT),DPTX[",",DGLASTLK=1,'$G(DPTNOFZY) D
27 .S DPTX=$$FORMAT^XLFNAME7(DPTX,2,30,1)
28 .S DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$L($P(DPTX,",",2))_")="""_$TR($P(DPTX,",",2),"""")_""""
29 .S DPTX=$P(DPTX,",")
30 .S DGLASTLK=0
31 .S DPTREFS="B,NOP,CN,RM"
32 .;Person Service Lookup does not allow lookup by RM cross reference
33 .;PSL release 4 does not allow lookup by ward (CN) cross reference
34 .I $G(DPTPSREF)'="" S DPTREFS="B,NOP"
35 .F DPTLP=1:1 S DPTREF=$P(DPTREFS,",",DPTLP) Q:DPTREF=""!(DPTDFN) D Q:DPTDFN!DPTOUT
36 ..S DPTVAL=DPTX
37 ..D LOOK(DPTVAL)
38 I DGLASTLK=0,$G(DPTCNT) S DGLASTLK=1 G SET
39 I DGLASTLK=0,'$G(DPTCNT),$L($G(DPTXOLD)) S DPTX=DPTXOLD
40 ; end of DG*641 change
41 ;
42Q K DPTBEG,DPTIFN,DPTIFNS,DPTLP,DPTLP1,DPTNUM,DPTREF,DPTREFS,DPTVAL
43 K DPTOVAL,DPTOUT,DPTXOLD,^TMP("DPTLK",$J)
44 Q
45 ;
46LOOK(DPTVAL) ;Look for x-ref matches
47 ;Input: DPTVAL=lookup seed value
48 I $L(DPTVAL),$D(^DPT(DPTREF,DPTVAL)) D CHKIFN Q:DPTDFN!DPTOUT
49 I $L(DPTVAL),'($D(^DPT(DPTREF,DPTVAL))&(DIC(0)["O"))&(DIC(0)'["X") D CHKVAL
50 Q
51 ;
52CHKVAL S DPTOVAL=DPTVAL
53 N DPTSEED S DPTSEED=DPTVAL
54 I DPTREF="SSN",(DPTVAL?9N1"p") D Q
55 .S DPTVAL=$E(DPTVAL,1,9)_"P" D CHKIFN
56 .Q
57 I DPTREF="SSN",(DPTVAL?2.9N) D Q
58 .S DPTVAL=$E(DPTVAL_"0000000",1,9)
59 .D CV1(DPTVAL),CHKIFN
60 .S DPTVAL=DPTVAL_"P" D CV1(DPTVAL),CHKIFN
61 .Q
62 D CV1(DPTVAL)
63 I DPTREF="CN"!(DPTREF="RM"),DPTVAL'["E",DPTVAL=+DPTVAL,'$D(^DPT(DPTREF,DPTVAL)) D Q
64 .S DPTVAL=$O(^DPT(DPTREF,DPTVAL_" "),-1)
65 .D CV1(DPTVAL)
66 .Q
67 Q
68 ;
69CV1(DPTVAL) ;Look for input value matches
70 I $L(DPTVAL) F DPTLP1=0:0 S DPTVAL=$O(^DPT(DPTREF,DPTVAL)) Q:DPTVAL=""!(DPTDFN)!($P(DPTVAL,DPTSEED)'="") D CHKIFN
71 Q
72 ;
73CHKIFN F DPTIFN=0:0 S DPTIFN=$O(^DPT(DPTREF,DPTVAL,DPTIFN)) Q:'DPTIFN!(DPTDFN)!DPTOUT S Y=DPTIFN D SETDPT I $S<DPTSZ F I=1:1:DPTNUM-7 S J=$S($D(DPTIFNS(I)):+DPTIFNS(I),1:0) K DPTIFNS(I),DPTS(J) S DPTBEG=I
74 Q
75 ;
76SETDPT Q:($D(DPTS(Y))&($G(DPTREF)'="B"))!'$D(^DPT(Y,0))
77 ; screen out MERGED FROM records - DG/574
78 Q:$D(^DPT(Y,-9))
79 N DPTNVAL I '$D(DPTOVAL) N DPTOVAL S DPTOVAL=DPTX
80 I 1 S X=DPTOVAL X:$D(DIC("S")) DIC("S") Q:'$T X:($D(DO("SCR"))) DO("SCR") Q:'$T X:$D(DDCOMA) DDCOMA Q:'$T
81 K:$G(DPTCNT)<1 ^TMP("DPTLK",$J)
82 S DPTS(Y)=$S('$D(DPTREF):$P(^DPT(Y,0),U),1:$P(^DPT(Y,0),U))_U_$S($D(DPTVAL):$E(DPTVAL,($L(DPTOVAL)+1),$L(DPTVAL)),1:"")
83 S DPTNVAL=$P(^DPT(Y,0),U)_U_$S($G(DPTREF)="NOP":$P(^DPT(Y,0),U),$D(DPTVAL):DPTVAL,1:"")
84 Q:$D(^TMP("DPTLK",$J,Y,DPTNVAL))
85 S DPTCNT=DPTCNT+1,^TMP("DPTLK",$J,Y,DPTNVAL)="",DPTIFNS(DPTCNT)=Y_U_DPTNVAL
86 I $D(DPTLARR) D Q
87 .I DPTLMAX,DPTCNT>DPTLMAX D Q
88 ..S @DPTLARR@(DPTCNT)="ADDITIONAL MATCHES FOUND BUT NOT RETURNED"
89 ..S DPTOUT=1
90 ..Q
91 .S @DPTLARR@(DPTCNT)=DPTIFNS(DPTCNT)_U_$$SSN(Y)_U_$$DOB(Y)
92 .Q
93 I '(DPTCNT#5),DIC(0)["E" D PRTDPT
94 Q
95 ;
96PRTDPT I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY S X=0 X ^%ZOSF("RM")
97 N DPTP1,DPTP2
98 F DPTNUM=DPTNUM+1:1:DPTCNT Q:DPTOUT S DPTIFN=+DPTIFNS(DPTNUM) D
99 .W:'$D(DDS) !
100 .S DPTP2=$P(DPTIFNS(DPTNUM),U,3)
101 .S DPTP1=$P(DPTIFNS(DPTNUM),U,2)
102 .W ?3,DPTNUM,?$X+(4-$L(DPTNUM))
103 .; write the xref value
104 .W DPTP2_" "
105 .; write patient name if diff than xref value
106 .I DPTP1'=DPTP2 W DPTP1
107 .S Y=DPTIFN X:$D(^DPT(DPTIFN,0)) "N DDS X DIC(""W"")" I $D(DDS) S DY=DY+1,DX=0 X DDXY S $X=0
108 I '$D(DPT("NOPRT^")) W:'$D(DDS) ! W "ENTER '^' TO STOP, OR "
109 W:'$D(DDS) ! W "CHOOSE ",DPTBEG,"-",DPTNUM,": " R X:DTIME S DPTSEL=X D Q:DPTSEL=""!$D(DTOUT)!$D(DUOUT)
110 .S:'$T DPTSEL=$S($D(DPTOVAL):DPTOVAL,$D(DPTVAL):DPTVAL,$D(DPTX):DPTX,$D(DPTXOLD):DPTXOLD,1:""),(DPTOUT,DTOUT)=1
111 .S:X="^" (DPTOUT,DUOUT)=1
112 S DPTDFN=$S(DPTSEL'?.ANP!($L(DPTSEL)>30):-1,'$D(DPTIFNS(DPTSEL)):-1,$D(DPTS(+DPTIFNS(DPTSEL))):+DPTIFNS(DPTSEL),1:-1),DPTX=$S(DPTDFN<0:DPTSEL,1:DPTX)
113 S:DPTDFN=-1 DPTXOLD=DPTSEL
114 Q
115 ;
116LIST(DPTX,DPTLMAX,DPTLARR) ;Silent lookup list
117 ;Input: DPTX=lookup value (name, SSN, room, ward, DFN or
118 ; "space_return").
119 ; DPTLMAX=maximum number of matches to return (optional), this
120 ; parameter has no effect if DFN or "space_return"
121 ; lookup methods are used.
122 ; DPTLARR=name of array to return list of matches, this should
123 ; be a global if DPTLMAX is a large value or unspecified
124 ; This array is returned in the format:
125 ; @DPTLARR@(n)=DFN^patient_name^xref_lookup_match_value^
126 ; SSN^Date_of_Birth
127 ; If more matches exist than the maximum to be returned
128 ; as specified by DPTLMAX, the @DPTLARR@(DPTLMAX+1) node
129 ; will be defined = "ADDITIONAL MATCHES FOUND BUT NOT
130 ; RETURNED".
131 ; The calling program has the responsibility to kill
132 ; @DPTLARR prior to calling this entry point.
133 ;Output: number of matches and array named by DPTLARR.
134 ;
135 N X,Y,DPTCNT,DIC,DPTSZ,DPTDFN,DPTIFNS,DPTS
136 S DPTCNT=0,DIC(0)="M",DPTSZ=1000 S:$G(DPTLMAX)<1 DPTLMAX=0
137 ;Check for "space_return" or DFN lookup
138 I DPTX=" "!($E(DPTX)="`") D Q DPTCNT
139 .I DPTX=" " S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)
140 .I $E(DPTX)="`" S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1)
141 .Q:Y<1 Q:'$D(^DPT(Y,0)) D SETDPT S DPTCNT=1
142 .Q
143 D FIND
144 Q $S(DPTLMAX&(DPTCNT>DPTLMAX):DPTLMAX,1:DPTCNT)
145 ;
146UCASE(DGX) ;Uppercase lookup value
147 ;Input: DGX=lookup value
148 ;Output: transformed DGX
149 N DGI,DGY,DGZ S DGZ=DGX,DGX=""
150 F DGI=1:1:$L(DGZ) S DGY=$E(DGZ,DGI) D
151 .S:DGY?1L DGY=$C($A(DGY)-32)
152 .S DGX=DGX_DGY
153 Q DGX
154 ;
155SSN(DFN) ;do not show ssn identifier for patient
156 ; input DFN = ien in file #2 [required]
157 ; output SSN = nnnnnnnnn
158 ;
159 N SSN
160 S SSN="",DFN=+DFN
161 I DFN>0 D
162 .I $$SCREEN(DFN) S SSN="*SENSITIVE*" Q
163 .S SSN=$P($G(^DPT(DFN,0)),U,9)
164 .; DG*5.3*657 BAJ 11/20 2005
165 .; display Pseudo SSN alert on list
166 .I SSN?9N1"P" S SSN=SSN_" **Pseudo SSN**"
167 .Q
168 Q SSN
169 ;
170DOB(DFN,DGYR) ;do not show dob identifier for patient
171 ; input DFN = ien in file #2 [required]
172 ; DGYR = 0/1 [optional]
173 ; where 0 returns 4-digit year (default)
174 ; 1 returns 2-digit year
175 ; 2 returns File manager date
176 ; output DOB = mm/dd/yyyy (default)
177 ; = mm/dd/yy, if DGYR=1
178 ; = yyymmdd, if DGYR=2
179 N B,DOB,YEAR
180 S DOB="",DFN=+DFN,DGYR=+$G(DGYR)
181 I DFN>0 D
182 .I $$SCREEN(DFN) S DOB="*SENSITIVE*" Q
183 .S B=$P($G(^DPT(DFN,0)),U,3)
184 .I DGYR'=2 D Q
185 ..S YEAR=$S(DGYR=1:"2D",1:"5D")
186 ..S DOB=$$FMTE^XLFDT(B,YEAR)
187 .S DOB=B
188 Q DOB
189 ;
190SCREEN(DFN) ;Screening logic for SSN & DOB
191 ;Input : DFN - Pointer to PATIENT file (#2)
192 ;Output : 1 - Apply screen
193 ; 0 - Don't apply screen
194 ;Notes : Screen applied if patient is sensitive or an employee
195 ;
196 N DGTIME,DGT,DGA1,DG1,DGXFR0
197 ;Inpatient check - no longer used (kept for future reference)
198 ;D H^DGUTL S DGT=DGTIME D ^DGPMSTAT I DG1 Q 0
199 ;Sensitive - screen
200 I $P($G(^DGSL(38.1,DFN,0)),"^",2) Q 1
201 ;Employee - screen
202 I $$EMPL^DGSEC4(DFN) Q 1
203 ;Don't screen
204 Q 0
Note: See TracBrowser for help on using the repository browser.