Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGLBPID.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGLBPID.m
r613 r623 1 DGLBPID 2 ;;5.3;Registration;**634**;Aug 13, 1993;Build 30 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 ID(DFN) 23 24 25 26 27 28 29 30 31 32 33 34 HRN(DFN) 35 36 37 38 39 GOTIDQ(DFN) 40 41 42 43 44 45 46 REQID(DFN) 47 48 49 50 51 52 53 54 55 IDCAP() 56 57 58 59 60 61 62 63 64 LONGID 65 66 67 68 69 70 71 SHORTID 72 73 74 75 76 77 78 IHSID 79 80 81 82 83 84 85 86 87 88 89 90 DFNID 91 92 93 94 95 96 97 98 99 100 101 SSNID 102 103 104 105 106 107 GETALL 108 109 110 111 112 113 ENALL 114 115 116 1 DGLBPID ;DJW,TOAD; Health Record Number Identifier ;5/1/07 20:26 2 ;;5.3;Registration;**634**;Aug 13, 1993;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 Q 20 ; 21 ; 22 ID(DFN) ;GFT/VW IA 10035 23 N ID S ID=$P($G(^DPT(DFN,.36)),U,3) ;PRIMARY LONG ID 24 I ID="" S ID=$$HRN(DFN) 25 I ID="" S ID=$P($G(^DPT(DFN,0)),U,9) I ID]"" S ID=$E(ID,1,3)_"-"_$E(ID,4,5)_"-"_$E(ID,6,99) 26 I ID="" D 27 .N I F I=0:0 S I=$O(^AUPNPAT(DFN,41,I)) Q:'I I $P($G(^(I,0)),U,5)="" S ID=$P($G(^(0)),U,2) I ID]"" S ID=ID_" ("_$P($G(^DIC(4,I,0)),U,5)_")" Q 28 I ID="" S ID="`"_DFN 29 Q ID 30 ; 31 ; 32 ; 33 ; 34 HRN(DFN) ;LOOKUP HEALTH RECORD NUMBER 35 I '$G(DUZ(2)) Q "" 36 Q $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) 37 ; 38 ; 39 GOTIDQ(DFN) ;Do we have the needed number for this guy? 40 N T S T=$$REQID(DFN) 41 I T="SSN" Q $P(^DPT(DFN,0),U,9)]"" 42 I T="HRN" Q:'$G(DUZ(2)) 0 Q $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)]"" 43 Q 1 44 ; 45 ; 46 REQID(DFN) ;WHICH IDENTIFICATION FORMAT IS REQUIRED? 47 N TYPE S TYPE="" 48 D:$G(DFN) 49 .S TYPE=+$G(^DPT(DFN,.361)) I TYPE S TYPE=$P($G(^DIC(8,TYPE,0)),U,9) ;try PRIMARY ELIGIBILITY CODE 50 .I TYPE="" S TYPE=+$G(^DPT(DFN,"TYPE")) I TYPE S TYPE=+$G(^DG(391,TYPE,8.2)) ;try patient TYPE 51 I 'TYPE S TYPE=$G(DUZ("AG")),TYPE=$S(TYPE="V":1,1:2) ;or just assume it's HRN if not VA 52 Q $P("SSN^HRN",U,TYPE) 53 ; 54 ; 55 IDCAP() ;Returns 3 characters: " ID" or "SSN" 56 I $G(DUZ("AG"))="E" Q " ID" 57 Q "SSN" 58 ; 59 ; 60 ; 61 ; 62 ; 63 ; 64 LONGID ;Called by ^DIC(8.2,2,"LONG") (assumes DA(1) is DFN!) 65 N INSTITU,DFN,DFNID,SSNID,IHSID D GETALL 66 S X=$S($G(IHSID("L"))'?."-":IHSID("L"),$G(SSNID("L"))'?."-":SSNID("L"),$G(DFNID("L"))'?."-":DFNID("L"),1:"") 67 ;I X="" W 1/0 ;some LONGID must exist for a patient, else ERROR! 68 Q 69 ; 70 ; 71 SHORTID ;Called by ^DIC(8.2,2,"SHORT") (assumes DA(1) is DFN!) 72 N INSTITU,DFN,DFNID,SSNID,IHSID D GETALL 73 S X=$S($G(IHSID("S"))'?."-":IHSID("S"),$G(SSNID("S"))'?."-":SSNID("S"),$G(DFNID("S"))'?."-":DFNID("S"),1:"") 74 ;I X="" W 1/0 ;some SHORTID must exist for a patient, else ERROR! 75 Q 76 ; 77 ; 78 IHSID ; 79 ;given INSTITU (current institution #) 80 ;get HEALTH RECORD NUMBER (Multiple 4101, 9000001.41) associated 81 ;with the institution 82 S IHSID=$P($G(^AUPNPAT(DFN,41,+INSTITU,0)),"^",2) 83 I IHSID'="" D 84 . S IHSID("L")=IHSID ; $J(IHSID,12) ; if we want to zero pad then $TR($J(IHSID("L"),12)," ",0) 85 . S IHSID("S")=$TR(IHSID("L"),$TR(IHSID("L"),9876543210)) 86 . S IHSID("S")=$TR($J(IHSID("S"),4)," ",0) 87 . S IHSID("S")=$E(IHSID("S"),$L(IHSID("S"))-3,$L(IHSID("S"))) 88 ;now return Health Record Number 89 Q 90 DFNID S DFN=DA(1) ; IEN in patient file, with default institution from 91 ;kernel system parameters file as prefix. 92 ;8989.3,217 DEFAULT INSTITUTION of #8989.3 -- KERNEL SYSTEM PARAMETERS FILE 93 S INSTITU=$P($G(^XTV(8989.3,1,"XUS")),U,17) 94 ;150.9 VISIT TRACKING PARAMETERS :: DEFAULT INSTITUTION: 95 I INSTITU="",$P($G(^DIC(150.9,1,0)),U,4)'="" S INSTITU=$P(^(0),U,4) 96 ; if we have a medical record number in IHS PATIENT, for this 97 I INSTITU'="",$P($G(^DIC(4,+INSTITU,99)),U)'="" S INSTITU("STA#")=$P(^(99),U) 98 ; now put INSTITUtion STATION NUMBER as prefix to DFN as "DFNID" 99 S DFNID("S")="`"_DFN,DFNID("L")=999_"-`"_DFN S:$D(INSTITU("STA#"))#2 DFNID("L")=INSTITU("STA#")_"-`"_DFN 100 Q 101 SSNID ; 102 ;code scarfed from ^DIC(8.2,1,"LONG") - retrieving the SSN 103 N X 104 S SSNID("L")="" I $D(DFN),$D(^DPT(DFN,0)) S X=$P(^(0),U,9),SSNID("L")=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10) 105 S SSNID("S")=$P(SSNID("L"),"-",3) 106 Q 107 GETALL ; 108 ;Utility Subroutine to Getall the variables 109 D DFNID,IHSID,SSNID 110 ;K DFNID,SSNID ; kill because HRN is "required" 111 Q 112 ; 113 ENALL ;RE-INDEX PHONE NUMBER (KIDS POST-INSTALL DG*5.3*634) 114 K ^DPT("AZVWVOE") 115 N DIK S DIK="^DPT(",DIK(1)=".131^251000" D ENALL^DIK 116 Q
Note:
See TracChangeset
for help on using the changeset viewer.
