source: Scheduling/trunk/m/BSDX28.m@ 867

Last change on this file since 867 was 867, checked in by Sam Habiel, 14 years ago

Two updates: Search by Primary ID now enabled;
bug in make appointment code that causes storage of non-canonical
appointment times (3091103.0900 e.g. rather than 3091103.09). causes a
problem when retrieving appointments.
File size: 5.2 KB
Line 
1BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/10 3:55pm
2 ;;2.0;IHS WINDOWS SCHEDULING;;NOV 01, 2007
3 ;
4 ; HMW 3050721 Added test for inactivated record
5 ; SMH 3100714 add PID search, return PID instead of SSN
6 ; Change Error trap to new style.
7 ;
8PTLOOKRS(BSDXY,BSDXP,BSDXC) ;EP Patient Lookup
9 ;
10 ;Find up to BSDXC patients matching BSDXP*
11 ;Supports DOB Lookup, Primary Long ID lookup
12 ;
13 N $ET S $ET="G ERROR^BSDX28"
14 ; rm ctrl chars
15 S BSDXP=$TR(BSDXP,$C(13),"")
16 S BSDXP=$TR(BSDXP,$C(10),"")
17 S BSDXP=$TR(BSDXP,$C(9),"")
18 ; num of pts to find
19 S:BSDXC="" BSDXC=10
20 N BSDXHRN,BSDXZ,BSDXDLIM,BSDXRET,BSDXDPT,BSDXRET,BSDXIEN,BSDXFILE
21 N BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN
22 N BSDXTARG,BSDXMSG,BSDXRSLT
23 S BSDXDLIM="^"
24 S BSDXRET="T00030NAME^T00030HRN^T00030PID^D00030DOB^T00030IEN"_$C(30)
25 I '+$G(DUZ) S BSDXY=BSDXRET_$C(31) Q
26 I '$D(DUZ(2)) S BSDXY=BSDXRET_$C(31) Q
27
28PID ;PID Lookup
29 ; If this ID exists, go get it. If "UJOPID" index doesn't exist,
30 ; won't work anyways.
31 I $D(^DPT("UJOPID",BSDXP)) DO SET BSDXY=BSDXRET_$C(31) QUIT
32 . S BSDXIEN=$O(^DPT("UJOPID",BSDXP,""))
33 . Q:'$D(^DPT(BSDXIEN,0))
34 . S BSDXDPT=$G(^DPT(BSDXIEN,0))
35 . S BSDXZ=$P(BSDXDPT,U) ;NAME
36 . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
37 . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
38 . ; Inactivated Chart get an *
39 . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q
40 . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
41 . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
42 . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
43 . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
44 . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
45 . S BSDXRET=BSDXRET_BSDXZ_$C(30)
46 ;
47DOB ;DOB Lookup
48 I +DUZ(2),((BSDXP?1.2N1"/"1.2N1"/"1.4N)!(BSDXP?1.2N1" "1.2N1" "1.4N)!(BSDXP?1.2N1"-"1.2N1"-"1.4N)) D S BSDXY=BSDXRET_$C(31) Q
49 . S X=BSDXP S %DT="P" D ^%DT S BSDXP=Y Q:'+Y
50 . Q:'$D(^DPT("ADOB",BSDXP))
51 . S BSDXIEN=0 F S BSDXIEN=$O(^DPT("ADOB",BSDXP,BSDXIEN)) Q:'+BSDXIEN D
52 . . Q:'$D(^DPT(BSDXIEN,0))
53 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
54 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
55 . . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
56 . . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
57 . . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
58 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
59 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
60 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
61 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
62 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
63 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
64 . . Q
65 . Q
66 ;
67CHART
68 ;Chart# Lookup
69 I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
70 . S BSDXIEN=0 F S BSDXIEN=$O(^AUPNPAT("D",BSDXP,BSDXIEN)) Q:'+BSDXIEN I $D(^AUPNPAT("D",BSDXP,BSDXIEN,DUZ(2))) D Q
71 . . Q:'$D(^DPT(BSDXIEN,0))
72 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
73 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
74 . . S BSDXHRN=BSDXP ;CHART
75 . . I $D(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),$P(^(0),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
76 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
77 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
78 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
79 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
80 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
81 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
82 . . Q
83 . Q
84 ;
85SSN ;SSN Lookup
86 I (BSDXP?9N)!(BSDXP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
87 . S BSDXIEN=0 F S BSDXIEN=$O(^DPT("SSN",BSDXP,BSDXIEN)) Q:'+BSDXIEN D Q
88 . . Q:'$D(^DPT(BSDXIEN,0))
89 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
90 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
91 . . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
92 . . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
93 . . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
94 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
95 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
96 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
97 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
98 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
99 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
100 . . Q
101 . Q
102 ;
103 S BSDXFILE=9000001
104 S BSDXIENS=""
105 S BSDXFIELDS=".01"
106 S BSDXFLAGS="M"
107 S BSDXVALUE=BSDXP
108 S BSDXNUMBER=BSDXC
109 S BSDXINDEXES=""
110 S BSDXSCREEN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
111 S BSDXIDEN=""
112 S BSDXTARG="BSDXRSLT"
113 S BSDXMSG=""
114 D FIND^DIC(BSDXFILE,BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN,BSDXIDEN,BSDXTARG,BSDXMSG)
115 I '+$G(BSDXRSLT("DILIST",0)) S BSDXY=BSDXRET_$C(31) Q
116 N BSDXCNT S BSDXCNT=2
117 F BSDXX=1:1:$P(BSDXRSLT("DILIST",0),U) D
118 . S BSDXIEN=BSDXRSLT("DILIST",2,BSDXX)
119 . S BSDXZ=BSDXRSLT("DILIST","ID",BSDXX,.01) ;NAME
120 . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
121 . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
122 . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
123 . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
124 . S BSDXDPT=$G(^DPT(BSDXIEN,0))
125 . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
126 . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
127 . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
128 . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
129 . S $P(BSDXRET,$C(30),BSDXCNT)=BSDXZ
130 . S BSDXCNT=BSDXCNT+1
131 . Q
132 S BSDXY=BSDXRET_$C(30)_$C(31)
133 Q
134 ;
135ERROR ;
136 D ERR("RPMS Error")
137 Q
138 ;
139ERR(ERRNO) ;Error processing
140 S BSDXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30)_"^^^^"_$C(30)_$C(31)
141 Q
Note: See TracBrowser for help on using the repository browser.