- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT3.m
r613 r623 1 ORWPT3 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 OTHER(LST,IDIN,OTHER) 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 ISNUM(XA) 158 159 1 ORWPT3 ; 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 26 OTHER(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 157 ISNUM(XA) ; 158 I XA=+XA Q 1 159 Q 0
Note:
See TracChangeset
for help on using the changeset viewer.
