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

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

Change version to 1.4 on all routines
BSDX08 has fix for drag and drop because it referenced a non existent cancellation reason
File size: 5.3 KB
Line 
1BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:30pm
2 ;;1.4;BSDX;;Sep 07, 2010
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.