source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m@ 1211

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

revised back to 6/30/08 version

File size: 6.2 KB
Line 
1ORWPT3 ; VOE/GOW /REV - Patient Lookup Functions ;8/13/07 17:49
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 28
3 ; Copyright (C) 2007 WorldVistA
4 ;
5 ; This program is free software; you can redistribute it and/or modify
6 ; it under the terms of the GNU General Public License as published by
7 ; the Free Software Foundation; either version 2 of the License, or
8 ; (at your option) any later version.
9 ;
10 ; This program is distributed in the hope that it will be useful,
11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ; GNU General Public License for more details.
14 ;
15 ; You should have received a copy of the GNU General Public License
16 ; along with this program; if not, write to the Free Software
17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
19 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED WITH "OTHER" RADIOBUTTON LOOKUPS FOR DOB AND PHONE NO 11/14/06
20 ;
21 ; Ref. to ^UTILITY via IA 10061
22 ;
23 Q
24 ;
25 ;VWPT ENHANCEMENTS folow for "other" RADIO BUTTONlookup
26OTHER(LST,IDIN,OTHER) ; RADIO BUTTON Return a list of patients matching other ID identifier
27 N I,ID,IEN,ILENX,XREF,IDM1,ILEN1,ILNM1,ILENM1,IDD1,IPAST1,IDXX,IDSS,IDD2,LEN1,IFDN,IDX,IDS,DATEF,ILEN1,IPAST,ZVW,TEMP,IVAL,IVAR1,IFIND,IFDNS,IVAR,ARRAY,ERRARRAY,IENS
28 N IEN2,IENN,TAB,IX
29 N ILENP,X3,IEND,IDXS,IENNNN
30 N IDTMP,AJJTMP,AJJTMP1
31 I IDIN="" Q
32 S (I,IEN,IEND)=0
33 S ID=IDIN
34 S X=ID
35 S ILENX=$L(X)
36 ;REMOVES TABS
37 ;CHECK INPUT TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS
38 S TAB=$C(9)
39 S IX=$P(X,TAB,3) ; WAS 2ND POS
40 I IX'="" D
41 .S ILENP=$L(IX)
42 .S X=$E(IX,2,ILENP) ; JUMP OVER !
43 .S LST(1)=X_U_$P(^DPT(X,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_X_U_$$ID^DGLBPID(X) ; $$SSN^DPTLK1_U_IVAL ; RETURN OTHER AS 5TH PIECE
44 .;
45 .S IEND=1
46 E D
47 .;JUST UPPER CASE IT
48 .;UPPERCASE IT
49 .X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
50 I IEND=1 Q
51 S ID=X
52 ;OTHER IS FIELD NAME
53 ;GET THE FIELD NUMBER
54 S IFDN=0
55 S IFDN=$O(^DD(2,"B",OTHER,IFDN))
56 I IFDN="" Q
57 ;FOR NOW JUST USE ONE OF TWO CROSS-REFERENCES ,
58 ;ONE FOR DOB AS ADOB AND THE OTHER FOR PHONE # AS AZVWVOE
59 I OTHER="DATE OF BIRTH" S ICREF="ADOB"
60 I OTHER="PHONE NUMBER [RESIDENCE]" D
61 .S ICREF="AZVWVOE"
62 .S ID=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30)
63 I ICREF="AZVWVOE" I ILENX<7 Q
64 ;
65 ; NEW EDITS/GOW 8/12/07 BELOW. RADIO BUTTON HAS SLIGHTLY DIFFERENT FUNCTIONALITY THAN
66 ; WITH GENERIC MULTI-SOURCE LOOKUP. ALSO, CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER
67 ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM)
68 ; THE LOGIC ALLOWED A FUZZY MONTH ONLY LOOKUP FOR DOB AS A SPECIFIC DOB MAY NOT BE KNOWN ,OR REMEMBERED.
69 ; FOR FUZZY LOGIC REQUIRE 4 DIGIT YEAR ON DATE RANGE W/O SPECIFIC DAY(DATE) ENTERED
70 ; EXAMPLE, AS MONTH/YEAR ( IE, JUN 2005). NOW, MAKE CHANGE TO ALLOW THIS ONLY BY APHABETIC MONTH AND NUMERIC YEAR (2 OR 4 DIGIT) LOOKUP
71 ; THEN FOR SPECIFIC DOB LOOKUP WITH RADIO BUTTON SELECTION, WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56
72 ; FOR WHICH WAIT FOR SELECTION WILL OCCUR UNTIL AT A TRAILING 2 DIGIT YEAR IS INPUT WITH THE FORMER FORMATS ABOVE
73 S NOCONTIN=0
74 I ICREF="ADOB" D
75 .S NOCONTIN=1
76 .S IDTMP=$E($TR(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30)
77 .I IDTMP'=ID D
78 ..;ALPHABETIC FUZZY MONTH ALLOWED or a specific date for at least a 4 DIGIT year that must specified after a "," ( ie June 15,1968)
79 ..;OTHERWISE CHECK FOR TRAILING YEAR
80 ..S AJJTMP=$L($TR($P(ID,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE
81 ..S AJJTMP=$L($TR($P(ID," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr)
82 ..S AJJTMP=$L($TR($P(ID," ",2)," ")) I AJJTMP>3 S AJJTMP1=$TR(AJJTMP,",") I AJJTMP1=AJJTMP S NOCONTIN=0 Q ;CASE FOR FUZZY DATE ( MONTH followed by " " (space) and Year (4 digit yr)
83 .I IDTMP'=ID Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY
84 .S AJJTMP=$L($TR($P(ID,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT
85 .S AJJTMP=$L($TR($P(ID,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT
86 .S AJJTMP=$L($TR($P(ID,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT
87 I NOCONTIN=1 Q
88 ;END EDITS/GOW
89 ;
90 S IDX=ID
91 ;TO SEE blank char inserts
92 S ILENM1=$L(ID)-1
93 I ILENM1>0 D
94 .;S IDLC=$E(ID,1,ILENM1)
95 .S IDX=$E(ID,1,ILENM1) S IDXS=IDX
96 E D
97 .S IDX="" S IDXS=IDX
98 Q:ILENX<4 ;USE PHONE NUMBER LOOKUP XXX-
99 ;HOWEVER ID DATE OR DATE/TIME FIELD CONVERT ID TO
100 ;INTERNAL TIME
101 S DATEF=$P($G(^DD(2,IFDN,0)),"^",2)
102 I DATEF["D" D
103 .;NEW BELOW
104 .S X=ID D ^%DT S IDX=Y S IDS=Y
105 .I Y'=-1 D
106 . . S ILNM1=$L(IDX)-1
107 . . S IDX=$E(IDX,1,ILNM1)
108 . . ;W !,"IDX=",IDX,"IDS=",IDS
109 S IPAST=0
110 S IPAST1=0
111 S ILEN1=$L(ID)
112 F S IDX=$O(^DPT(ICREF,IDX)) Q:(IDX="")!(IPAST1=1) D
113 . S IEN=0
114 . ;EXTRA TO GET TRAILING SPACES
115 . I DATEF'["D" D
116 . . S IDD1=$E(IDX,1,ILEN1) I $L(IDD1)<ILEN1 Q
117 . F S IEN=$O(^DPT(ICREF,IDX,IEN)) Q:IEN="" D
118 . . S IPAST=0
119 . . ;W !,"IDX=",IDX," IDS=",IDS
120 . .I DATEF["D" D
121 . . .;CHECK FOR MONTH ONLY
122 . . .I $E(IDS,6,7)="00" D
123 . . . .S IDXX=$E(IDX,1,5) S IDSS=$E(IDS,1,5)
124 . . . .;W !,"IDXX=",IDXX," IDSS=",IDSS
125 . . . .I IDXX'=IDSS S IPAST=1
126 . . . .I IDXX>IDSS S IPAST1=1 Q
127 . . . .I IPAST=1 Q
128 . . .E D
129 . . . .;W !,"IDX=",IDX
130 . . . .I IDX'=IDS S IPAST=1
131 . . . .I IDX>IDS S IPAST1=1 Q
132 . . . .I IPAST=1 Q
133 . .E D
134 . . .S IDD1=$E(IDX,1,ILEN1) S IDD2=$E(ID,1,ILEN1)
135 . . .;W !,"IDD1=",IDD1 W !,"IDD2=",IDD2
136 . . .I $$ISNUM(IDD2)&$$ISNUM(IDD1) D
137 . . . .I IDD1'=IDD2 S IPAST=1
138 . . . .I IDD1>IDD2 S IPAST1=1 Q
139 . . . .I IPAST=1 Q
140 . . . .;
141 . . . .;
142 . . .E D
143 . . . .;
144 . . . .I IDD1'=IDD2 S IPAST=1
145 . . . .I IDD1]IDD2 S IPAST1=1 Q
146 . . . .I IPAST=1 Q
147 . .I IPAST=1 Q
148 . .I DATEF["D" D
149 . . .S Y=IDX S X=IDX D DD^%DT S IVAL=Y
150 . .E D
151 . . .S IVAL=IDX
152 . .S I=I+1
153 . .I $$SCREEN^DPTLK1(IEN) Q
154 . .;IVAL IS NOT HRN NOW
155 . .S LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_IVAL_TAB_"!"_IEN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(IEN) ; _U_IVAL ; RETURN OTHER AS 5TH PIECE
156 Q
157ISNUM(XA) ;
158 I XA=+XA Q 1
159 Q 0
Note: See TracBrowser for help on using the repository browser.