source: Scheduling/trunk/m/BSDX02.m@ 806

Last change on this file since 806 was 614, checked in by Sam Habiel, 15 years ago

Initial committ of scheduling package
File size: 3.5 KB
RevLine 
[614]1BSDX02 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
2 ;;2.0;IHS WINDOWS SCHEDULING;;NOV 01, 2007
3 ;
4 ;
5CRSCHD(BSDXY,BSDXRES,BSDXSTART,BSDXEND) ;EP
6 ;Entry point for debugging
7 ;
8 ;D DEBUG^%Serenji("CRSCH^BSDX02(.BSDXY,BSDXRES,BSDXSTART,BSDXEND)")
9 Q
10 ;
11CRSCH(BSDXY,BSDXRES,BSDXSTART,BSDXEND,BSDXWKIN) ;
12 ;Called by BSDX CREATE APPT SCHEDULE
13 ;Create Resource Appointment Schedule recordset
14 ;On error, returns 0 in APPOINTMENTID field and error text in NOTE field
15 ;
16 ;$O Thru ^BSDXAPPT("ARSRC", RESOURCE, STARTTIME, APPTID)
17 ;BMXRES is a | delimited list of resource names
18 ;BSDXWKIN - If 1, then return walkins, otherwise skip them
19 ;9-27-2004 Added walkin to returned datatable
20 ;TODO: Change BSDXRES from names to IDs
21 ;
22 N BSDXERR,BSDXIEN,BSDXDEPD,BSDXDEPN,BSDXRESD,BSDXI,BSDXJ,BSDXRESN,BSDXS,BSDXAD,BSDXZ,BSDXQ,BSDXNOD
23 N BSDXPAT,BSDXNOT,BSDXZPCD,BSDXPCD
24 K ^BSDXTMP($J)
25 S BSDXERR=""
26 S BSDXY="^BSDXTMP("_$J_")"
27 S ^BSDXTMP($J,0)="I00020APPOINTMENTID^D00030START_TIME^D00030END_TIME^D00030CHECKIN^D00030AUXTIME^I00020PATIENTID^T00030PATIENTNAME^T00030RESOURCENAME^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^T00250NOTE"_$C(30)
28 D ^XBKVAR S X="ETRAP^BSDX02",@^%ZOSF("TRAP")
29 ;
30 S:BSDXSTART["@0000" BSDXSTART=$P(BSDXSTART,"@")
31 S:BSDXEND["@0000" BSDXEND=$P(BSDXEND,"@")
32 S %DT="T",X=BSDXSTART D ^%DT S BSDXSTART=Y
33 I BSDXSTART=-1 S ^BSDXTMP($J,1)=$C(31) Q
34 S %DT="T",X=BSDXEND D ^%DT S BSDXEND=Y
35 I BSDXEND=-1 S ^BSDXTMP($J,1)=$C(31) Q
36 ;
37 S BSDXI=0
38 D STRES
39 ;
40 S BSDXI=BSDXI+1
41 S ^BSDXTMP($J,BSDXI)=$C(31)
42 Q
43 ;
44STRES ;
45 F BSDXJ=1:1:$L(BSDXRES,"|") S BSDXRESN=$P(BSDXRES,"|",BSDXJ) D
46 . Q:BSDXRESN=""
47 . Q:'$D(^BSDXRES("B",BSDXRESN))
48 . S BSDXRESD=$O(^BSDXRES("B",BSDXRESN,0))
49 . Q:'+BSDXRESD
50 . Q:'$D(^BSDXAPPT("ARSRC",BSDXRESD))
51 . S BSDXS=BSDXSTART-.0001
52 . F S BSDXS=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS)) Q:'+BSDXS Q:BSDXS>BSDXEND D
53 . . S BSDXAD=0 F S BSDXAD=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS,BSDXAD)) Q:'+BSDXAD D STCOMM(BSDXAD,BSDXRESN)
54 Q
55 ;
56STCOMM(BSDXAD,BSDXRESN) ;
57 ;BSDXAD is the appointment IEN
58 N BSDXC,BSDXQ,BSDXZ,BSDXSUBC,BSDXHRN,BSDXPATD,BSDXATID,BSDXISWK
59 Q:'$D(^BSDXAPPT(BSDXAD,0))
60 S BSDXNOD=^BSDXAPPT(BSDXAD,0)
61 Q:$P(BSDXNOD,U,12)]"" ;CANCELLED
62 S BSDXISWK=0
63 S:$P(BSDXNOD,U,13)="y" BSDXISWK=1
64 I +$G(BSDXWKIN) Q:BSDXISWK ;Don't return walkins if appt is WALKIN and BSDXWKIN is 1
65 S BSDXZ=BSDXAD_"^"
66 F BSDXQ=1:1:4 D
67 . S Y=$P(BSDXNOD,U,BSDXQ)
68 . X ^DD("DD") S Y=$TR(Y,"@"," ")
69 . S BSDXZ=BSDXZ_Y_"^"
70 S BSDXPATD=$P(BSDXNOD,U,5)
71 S BSDXZ=BSDXZ_BSDXPATD_"^" ;PATIENT ID
72 S BSDXPAT=""
73 I BSDXPATD]"",$D(^DPT(BSDXPATD,0)) S BSDXPAT=$P(^DPT(BSDXPATD,0),U)
74 S BSDXZ=BSDXZ_BSDXPAT_"^" ;PATIENT NAME
75 S BSDXZ=BSDXZ_BSDXRESN_"^" ;RESOURCENAME
76 S BSDXZ=BSDXZ_+$P(BSDXNOD,U,10)_"^" ;NOSHOW
77 S BSDXHRN=""
78 I $D(DUZ(2)),DUZ(2)>0 S BSDXHRN=$P($G(^AUPNPAT(BSDXPATD,41,DUZ(2),0)),U,2) ;HRN
79 S BSDXZ=BSDXZ_BSDXHRN_"^"
80 S BSDXATID=$P(BSDXNOD,U,6)
81 S:'+BSDXATID BSDXATID=0 ;UNKNOWN TYPE
82 S BSDXZ=BSDXZ_BSDXATID_"^"_BSDXISWK_"^"
83 S BSDXI=BSDXI+1
84 S ^BSDXTMP($J,BSDXI)=BSDXZ
85 ;NOTE
86 S BSDXNOT="",BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXAD,1,BSDXQ)) Q:'+BSDXQ D
87 . S BSDXNOT=$G(^BSDXAPPT(BSDXAD,1,BSDXQ,0))
88 . S:$E(BSDXNOT,$L(BSDXNOT)-1,$L(BSDXNOT))'=" " BSDXNOT=BSDXNOT_" "
89 . S BSDXI=BSDXI+1
90 . S ^BSDXTMP($J,BSDXI)=BSDXNOT
91 S BSDXI=BSDXI+1
92 S ^BSDXTMP($J,BSDXI)=$C(30)
93 Q
94 ;
95ERR(BSDXI,BSDXERR) ;Error processing
96 S BSDXI=BSDXI+1
97 S ^BSDXTMP($J,BSDXI)="0^^^^^^^^^^^"_BSDXERR_$C(30)
98 S BSDXI=BSDXI+1
99 S ^BSDXTMP($J,BSDXI)=$C(31)
100 Q
101 ;
102ETRAP ;EP Error trap entry
103 D ^%ZTER
104 I '$D(BSDXI) N BSDXI S BSDXI=999999
105 S BSDXI=BSDXI+1
106 D ERR(BSDXI,"BSDX31 Error: "_$G(%ZTERROR))
107 Q
Note: See TracBrowser for help on using the repository browser.