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

Last change on this file since 1475 was 1472, checked in by Sam Habiel, 12 years ago

Updated version number on all routines to be 1.7T1.
Minor fixes here and there for XINDEX errors.
File size: 5.7 KB
Line 
1BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 10:57am
2 ;;1.7T1;BSDX;;Jul 06, 2012;Build 18
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 ;Chart# Lookup
79 I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
80 . S BSDXIEN=0 F S BSDXIEN=$O(^AUPNPAT("D",BSDXP,BSDXIEN)) Q:'+BSDXIEN I $D(^AUPNPAT("D",BSDXP,BSDXIEN,DUZ(2))) D Q
81 . . Q:'$D(^DPT(BSDXIEN,0))
82 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
83 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
84 . . S BSDXHRN=BSDXP ;CHART
85 . . I $D(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),$P(^(0),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
86 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
87 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
88 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
89 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
90 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
91 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
92 . . Q
93 . Q
94 ;
95SSN ;SSN Lookup
96 I (BSDXP?9N)!(BSDXP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
97 . S BSDXIEN=0 F S BSDXIEN=$O(^DPT("SSN",BSDXP,BSDXIEN)) Q:'+BSDXIEN D Q
98 . . Q:'$D(^DPT(BSDXIEN,0))
99 . . S BSDXDPT=$G(^DPT(BSDXIEN,0))
100 . . S BSDXZ=$P(BSDXDPT,U) ;NAME
101 . . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
102 . . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
103 . . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
104 . . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
105 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
106 . . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
107 . . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
108 . . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
109 . . S BSDXRET=BSDXRET_BSDXZ_$C(30)
110 . . Q
111 . Q
112 ;
113 S BSDXFILE=9000001
114 S BSDXIENS=""
115 S BSDXFIELDS=".01"
116 S BSDXFLAGS="M"
117 S BSDXVALUE=BSDXP
118 S BSDXNUMBER=BSDXC
119 S BSDXINDEXES=""
120 S BSDXSCREEN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
121 S BSDXIDEN=""
122 S BSDXTARG="BSDXRSLT"
123 S BSDXMSG=""
124 D FIND^DIC(BSDXFILE,BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN,BSDXIDEN,BSDXTARG,BSDXMSG)
125 I '+$G(BSDXRSLT("DILIST",0)) S BSDXY=BSDXRET_$C(31) Q
126 N BSDXCNT S BSDXCNT=2
127 F BSDXX=1:1:$P(BSDXRSLT("DILIST",0),U) D
128 . S BSDXIEN=BSDXRSLT("DILIST",2,BSDXX)
129 . S BSDXZ=BSDXRSLT("DILIST","ID",BSDXX,.01) ;NAME
130 . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
131 . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
132 . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
133 . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
134 . S BSDXDPT=$G(^DPT(BSDXIEN,0))
135 . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
136 . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
137 . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
138 . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
139 . S $P(BSDXRET,$C(30),BSDXCNT)=BSDXZ
140 . S BSDXCNT=BSDXCNT+1
141 . Q
142 S BSDXY=BSDXRET_$C(30)_$C(31)
143 Q
144 ;
145ERROR ;
146 D ERR("RPMS Error")
147 Q
148 ;
149ERR(ERRNO) ;Error processing
150 S BSDXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30)_"^^^^"_$C(30)_$C(31)
151 Q
Note: See TracBrowser for help on using the repository browser.