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

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

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