source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK6.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: 4.1 KB
Line 
1DPTLK6 ;BAY/JAT,EG - Patient lookup RPCs for patient safety issue ; 11 Aug 2005 8:33 AM
2 ;;5.3;Registration;**265,276,277,675**;Aug 13, 1993
3GUIBS5(GUIDATA,DFN) ; RPC checks if other patients on "BS5" xref
4 ; with same last name
5 ; returns: 1 or 0 (or -1 if bad dfn or no zero node)
6 ; if 1, returns text to be displayed
7 ; return type: array
8 ; parameter: ien of Patient file
9 K GUIDATA
10 I '$G(DFN) S GUIDATA(1)=-1 Q
11 I '$D(^DPT(DFN,0)) S GUIDATA(1)=-1 Q
12 I '$$BS5^DPTLK5(DFN) S GUIDATA(1)=0 Q
13 S GUIDATA(1)=1
14 N DPT0,DPTNME,DPTSSN
15 S DPT0=$G(^DPT(DFN,0))
16 S DPTNME=$P($P(DPT0,U),",")
17 S DPTSSN=$E($P(DPT0,U,9),6,9)
18 S GUIDATA(2)="There is more than one patient whose last name is "_DPTNME
19 S GUIDATA(3)="and whose social security number ends with "_DPTSSN
20 S GUIDATA(4)="Are you sure you wish to continue?"
21 Q
22 ;
23GUIBS5A(GUIDATA,DFN) ; RPC checks if other patients on "BS5" xref
24 ; with same last name
25 ; returns 1 or 0 in 1st string (or -1 if bad DFN or no zero node)
26 ; if 1 returns array nodes where
27 ; text is preceeded by 0 (0^<text>)
28 ; and patient data is preceeded by 1 (1^DFN^patient name^DOB^SSN)
29 ; return type: global array
30 ; parameter: ien of Patient file
31 K GUIDATA
32 I '$G(DFN) S GUIDATA(1)=-1 Q
33 I '$D(^DPT(DFN,0)) S GUIDATA(1)=-1 Q
34 I '$$BS5^DPTLK5(DFN) S GUIDATA(1)=0 Q
35 K ^TMP("DPTLK6",$J)
36 S ^TMP("DPTLK6",$J,1)=1
37 N DPT0,DPTNME,DPTSSN,DPTBS5,DPTLAST,DPTIEN,DPTCNT,DPTDOB,DPTSSN1
38 S DPT0=^DPT(DFN,0)
39 S DPTNME=$E(DPT0,1),DPTSSN=$E($P(DPT0,U,9),6,9)
40 S DPTBS5=DPTNME_DPTSSN
41 S DPTLAST=$P($P(DPT0,U),",")
42 S ^TMP("DPTLK6",$J,2)="0^There is more than one patient whose last name is "_DPTLAST
43 S ^TMP("DPTLK6",$J,3)="0^and whose social security number ends with "_DPTSSN
44 S DPTCNT=3
45 S DPTIEN=0
46 F S DPTIEN=$O(^DPT("BS5",DPTBS5,DPTIEN)) Q:'DPTIEN D
47 .S DPT0=$G(^DPT(DPTIEN,0)),DPTNME=$P($P(DPT0,U),",")
48 .Q:DPTNME'=DPTLAST
49 .S DPTNME=$P(DPT0,U)
50 .I $T(DOB^DPTLK1)'="" S DPTDOB=$$DOB^DPTLK1(DPTIEN,2),DPTSSN1=$$SSN^DPTLK1(DPTIEN)
51 .E S DPTDOB=$P(DPT0,U,3),DPTSSN1=$P(DPT0,U,9)
52 .S DPTCNT=DPTCNT+1
53 .S ^TMP("DPTLK6",$J,DPTCNT)="1"_U_DPTIEN_U_DPTNME_U_DPTDOB_U_DPTSSN1
54 S DPTCNT=DPTCNT+1
55 S ^TMP("DPTLK6",$J,DPTCNT)="0^Are you sure you wish to continue?"
56 M GUIDATA=^TMP("DPTLK6",$J)
57 K ^TMP("DPTLK6",$J)
58 Q
59 ;
60GUIDMT(GUIDATA,DUZ2) ; RPC checks if the 'Display Means Test Required'
61 ; message is to be displayed for the Division user is in
62 ; returns 1 or 0 in 1st string (or -1 if bad DUZ(2))
63 ; if 1, returns text to be displayed in 2nd and 3rd string (if any)
64 ; return type: array
65 ; parameter: Institution file pointer for user (optional)
66 K GUIDATA
67 I '$G(DUZ2) S DUZ2=DUZ(2)
68 I '$G(DUZ2) S GUIDATA(1)=-1 Q
69 N DPTDIV,DPTDIVMT S DPTDIV=0
70 S DPTDIV=$O(^DG(40.8,"AD",DUZ2,DPTDIV))
71 I '$G(DPTDIV) S GUIDATA(1)=-1 Q
72 S GUIDATA(1)=0
73 S DPTDIVMT=$G(^DG(40.8,DPTDIV,"MT"))
74 I $P(DPTDIVMT,U,3)="Y" S GUIDATA(1)=1,GUIDATA(2)="MEANS TEST REQUIRED",GUIDATA(3)=$P(DPTDIVMT,U,2)
75 Q
76 ;
77GUIMT(GUIDATA,DFN) ; RPC checks if Means Test is required for this patient
78 ; returns 1 or 0 (or -1 if bad DFN)
79 ; return type: single value
80 ; parameter: ien of Patient file
81 K GUIDATA
82 I '$G(DFN) S GUIDATA=-1 Q
83 N Y,DGREQF,DGMTLST
84 S GUIDATA=0
85 S DGMTLST=$$CMTS^DGMTU(DFN)
86 I $P(DGMTLST,U,4)'="R" Q
87 S GUIDATA=1
88 Q
89 ;
90GUIMTD(GUIDATA,DFN,DUZ2) ; RPC checks if Means Test is required for this
91 ; patient and if 'Means Test Required' message is to be
92 ; displayed for the Division user is in
93 ; returns 1 or 0 in 1st string (or -1 if bad parameters)
94 ; if 1, returns text to be displayed in 2nd and 3rd string (if any)
95 ; return type: array
96 ; parameters: ien of Patient file, Institution file pointer for user
97 ; (optional)
98 K GUIDATA
99 I '$G(DUZ2) S DUZ2=DUZ(2)
100 I '$G(DFN)!('$G(DUZ2)) S GUIDATA(1)=-1 Q
101 N DPTDIV,DPTDIVMT S DPTDIV=0
102 S DPTDIV=$O(^DG(40.8,"AD",DUZ2,DPTDIV))
103 I '$G(DPTDIV) S GUIDATA(1)=-1 Q
104 N Y,DGREQF,DGMTLST
105 S GUIDATA(1)=0
106 S DGMTLST=$$CMTS^DGMTU(DFN)
107 ;only display division message if means test is required
108 I '$$MFLG^DGMTU(DGMTLST) Q
109 S DPTDIVMT=$G(^DG(40.8,DPTDIV,"MT"))
110 I $P(DPTDIVMT,U,3)="Y" S GUIDATA(1)=1,GUIDATA(2)="MEANS TEST REQUIRED",GUIDATA(3)=$P(DPTDIVMT,U,2)
111 Q
112 ;
Note: See TracBrowser for help on using the repository browser.