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

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

Changes to BSDX01 to prevent Scheduled,dc'ed,completed radiology appointments from being cancelled. Updated files to T2.
File size: 5.7 KB
Line 
1BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:25am
2 ;;1.6T2;BSDX;;May 16, 2011
3 ; Licensed under LGPL
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
30DFN ;If DFN is passed as `nnnn, just return that patient
31 I $E(BSDXP)="`" DO SET BSDXY=BSDXRET_$C(31) QUIT
32 . N BSDXIEN S BSDXIEN=$E(BSDXP,2,99)
33 . I BSDXIEN'=+BSDXIEN QUIT ; BSDXIEN must be numeric
34 . N NAME S NAME=$P(^DPT(BSDXIEN,0),U)
35 . N HRN S HRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2)
36 . N PID S PID=$P(^DPT(BSDXIEN,.36),U,3)
37 . N DOB S DOB=$$FMTE^XLFDT($P(^DPT(BSDXIEN,0),U,3))
38 . S BSDXRET=BSDXRET_NAME_U_HRN_U_PID_U_DOB_U_BSDXIEN_$C(30)
39PID ;PID Lookup
40 ; If this ID exists, go get it. If "UJOPID" index doesn't exist,
41 ; won't work anyways.
42 I $D(^DPT("UJOPID",BSDXP)) DO SET BSDXY=BSDXRET_$C(31) QUIT
43 . S BSDXIEN=$O(^DPT("UJOPID",BSDXP,""))
44 . Q:'$D(^DPT(BSDXIEN,0))
45 . S BSDXDPT=$G(^DPT(BSDXIEN,0))
46 . S BSDXZ=$P(BSDXDPT,U) ;NAME
47 . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
48 . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
49 . ; Inactivated Chart get an *
50 . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q
51 . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
52 . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
53 . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
54 . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
55 . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
56 . S BSDXRET=BSDXRET_BSDXZ_$C(30)
57 ;
58DOB ;DOB Lookup
59 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
60 . S X=BSDXP S %DT="P" D ^%DT S BSDXP=Y Q:'+Y
61 . Q:'$D(^DPT("ADOB",BSDXP))
62 . S BSDXIEN=0 F S BSDXIEN=$O(^DPT("ADOB",BSDXP,BSDXIEN)) Q:'+BSDXIEN D
63 . . Q:'$D(^DPT(BSDXIEN,0))
64 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
65 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
66 . . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
67 . . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
68 . . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
69 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
70 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
71 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
72 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
73 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
74 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
75 . . Q
76 . Q
77 ;
78CHART
79 ;Chart# Lookup
80 I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
81 . S BSDXIEN=0 F S BSDXIEN=$O(^AUPNPAT("D",BSDXP,BSDXIEN)) Q:'+BSDXIEN I $D(^AUPNPAT("D",BSDXP,BSDXIEN,DUZ(2))) D Q
82 . . Q:'$D(^DPT(BSDXIEN,0))
83 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
84 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
85 . . S BSDXHRN=BSDXP ;CHART
86 . . I $D(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),$P(^(0),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
87 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
88 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
89 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
90 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
91 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
92 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
93 . . Q
94 . Q
95 ;
96SSN ;SSN Lookup
97 I (BSDXP?9N)!(BSDXP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
98 . S BSDXIEN=0 F S BSDXIEN=$O(^DPT("SSN",BSDXP,BSDXIEN)) Q:'+BSDXIEN D Q
99 . . Q:'$D(^DPT(BSDXIEN,0))
100 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
101 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
102 . . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
103 . . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
104 . . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
105 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
106 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
107 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
108 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
109 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
110 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
111 . . Q
112 . Q
113 ;
114 S BSDXFILE=9000001
115 S BSDXIENS=""
116 S BSDXFIELDS=".01"
117 S BSDXFLAGS="M"
118 S BSDXVALUE=BSDXP
119 S BSDXNUMBER=BSDXC
120 S BSDXINDEXES=""
121 S BSDXSCREEN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
122 S BSDXIDEN=""
123 S BSDXTARG="BSDXRSLT"
124 S BSDXMSG=""
125 D FIND^DIC(BSDXFILE,BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN,BSDXIDEN,BSDXTARG,BSDXMSG)
126 I '+$G(BSDXRSLT("DILIST",0)) S BSDXY=BSDXRET_$C(31) Q
127 N BSDXCNT S BSDXCNT=2
128 F BSDXX=1:1:$P(BSDXRSLT("DILIST",0),U) D
129 . S BSDXIEN=BSDXRSLT("DILIST",2,BSDXX)
130 . S BSDXZ=BSDXRSLT("DILIST","ID",BSDXX,.01) ;NAME
131 . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
132 . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
133 . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
134 . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
135 . S BSDXDPT=$G(^DPT(BSDXIEN,0))
136 . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
137 . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
138 . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
139 . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
140 . S $P(BSDXRET,$C(30),BSDXCNT)=BSDXZ
141 . S BSDXCNT=BSDXCNT+1
142 . Q
143 S BSDXY=BSDXRET_$C(30)_$C(31)
144 Q
145 ;
146ERROR ;
147 D ERR("RPMS Error")
148 Q
149 ;
150ERR(ERRNO) ;Error processing
151 S BSDXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30)_"^^^^"_$C(30)_$C(31)
152 Q
Note: See TracBrowser for help on using the repository browser.