source: Scheduling/branches/Radiology-Support/m/BSDX28.m@ 1154

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

BSDX32: Hospital Location has extra column IS_RADIOLOGY_LOCATION to link if that HL is tied to the Radiology Package
BDDX01: GETRADEX: Get Radiology Exams for a Patient in a specific HL;
BSDX01: SCHRAEX: Schedule Radiology Exam
BSDX01: HOLDRAEX: Hold Radiology Exam
BSDX02: Added Radiology Exam Field, to retrieve Radiology Exam associated with appt
BSDX07: Support for adding Radiology Exams to Appointment. BSDX APPOINTMENT file now has a Radiology Exam that points to file 75.1 (RAD/NUC MED ORDERS)
BSDX28: Added support for searching by DFN from Scheduling GUI by accent grave notation.
File size: 5.7 KB
RevLine 
[1141]1BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/10/11 2:34pm
[1116]2 ;;1.5V3;BSDX;;Mar 16, 2011
[883]3 ;
[888]4 ; Change Log:
[867]5 ; HMW 3050721 Added test for inactivated record
[888]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.
[614]10 ;
11PTLOOKRS(BSDXY,BSDXP,BSDXC) ;EP Patient Lookup
12 ;
13 ;Find up to BSDXC patients matching BSDXP*
[867]14 ;Supports DOB Lookup, Primary Long ID lookup
[614]15 ;
[867]16 N $ET S $ET="G ERROR^BSDX28"
[888]17 ; rm ctrl chars
[614]18 S BSDXP=$TR(BSDXP,$C(13),"")
19 S BSDXP=$TR(BSDXP,$C(10),"")
20 S BSDXP=$TR(BSDXP,$C(9),"")
[888]21 ; num of pts to find
[614]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="^"
[867]27 S BSDXRET="T00030NAME^T00030HRN^T00030PID^D00030DOB^T00030IEN"_$C(30)
[614]28 I '+$G(DUZ) S BSDXY=BSDXRET_$C(31) Q
29 I '$D(DUZ(2)) S BSDXY=BSDXRET_$C(31) Q
[1141]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)
[888]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)
[614]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
[888]70 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
[614]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 ;
[888]78CHART
79 ;Chart# Lookup
[614]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
[888]88 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
[614]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
[888]95 ;
[867]96SSN ;SSN Lookup
[614]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
[888]106 . . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
[614]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))
[888]136 . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
[614]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.