source: Scheduling/trunk/m/BSDX08.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.7 KB
Line 
1BSDX08 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 9/15/10 8:21pm
2 ;;1.4;BSDX;;Sep 07, 2010
3 ;
4 ;
5APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
6 ;Entry point for debugging
7 ;
8 ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
9 Q
10 ;
11APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
12 ;Called by BSDX CANCEL APPOINTMENT
13 ;Cancels appointment
14 ;BSDXAPTID is entry number in BSDX APPOINTMENT file
15 ;BSDXTYP is C for clinic-cancelled and PC for patient cancelled
16 ;BSDXCR is pointer to CANCELLATION REASON File (409.2)
17 ;BSDXNOT is user note
18 ;Returns error code in recordset field ERRORID
19 ;
20 ;
21 N BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXERR
22 N BSDXLOC,BSDXLEN,BSDXSCIEN
23 N BSDXNOEV
24 S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
25 ;
26 D ^XBKVAR S X="ETRAP^BSDX08",@^%ZOSF("TRAP")
27 S BSDXI=0
28 K ^BSDXTMP($J)
29 S BSDXY="^BSDXTMP("_$J_")"
30 S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30)
31 S BSDXI=BSDXI+1
32 TSTART
33 I '+BSDXAPTID D ERR(BSDXI,"BSDX08: Invalid Appointment ID") Q
34 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"BSDX08: Invalid Appointment ID") Q
35 ;
36 ;Delete APPOINTMENT entries
37 S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
38 S BSDXPATID=$P(BSDXNOD,U,5)
39 S BSDXSTART=$P(BSDXNOD,U)
40 ;
41 ;Lock BSDX node
42 L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later") TROLLBACK Q
43 ;
44 D BSDXCAN(BSDXAPTID)
45 ;
46 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
47 I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I +$G(BSDXZ) S BSDXERR=BSDXERR_$P(BSDXZ,U,2) D ERR(BSDXI,BSDXERR) Q
48 . S BSDXNOD=^BSDXRES(BSDXSC1,0)
49 . S BSDXLOC=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
50 . Q:'+BSDXLOC
51 . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ
52 . . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "
53 . . S BSDXZ=1
54 . . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 Q
55 . . N BSDX1
56 . . S BSDX1=0
57 . . F S BSDX1=$O(^BSDXRES(BSDXSC1,20,BSDX1)) Q:'+BSDX1 Q:BSDXZ=0 D
58 . . . Q:'$D(^BSDXRES(BSDXSC1,20,BSDX1,0))
59 . . . S BSDXLOC=$P(^BSDXRES(BSDXSC1,20,BSDX1,0),U)
60 . . . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) I +BSDXSCIEN S BSDXZ=0 Q
61 . S BSDXERR="BSDX08: CANCEL^BSDXAPI Returned "
62 . I BSDXLOC']"" S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q
63 . I '$D(^SC(BSDXLOC,0)) S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q
64 . S BSDXNOD=$G(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))
65 . I BSDXNOD="" S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q
66 . S BSDXLEN=$P(BSDXNOD,U,2)
67 . D APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART)
68 . Q:+$G(BSDXZ)
69 . D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
70 . ;L
71 ;
72 TCOMMIT
73 L -^BSDXAPPT(BSDXPATID)
74 S BSDXI=BSDXI+1
75 S ^BSDXTMP($J,BSDXI)=""_$C(30)
76 S BSDXI=BSDXI+1
77 S ^BSDXTMP($J,BSDXI)=$C(31)
78 Q
79 ;
80AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
81 ;See SDCNP0
82 S (SD,S)=BSDXSTART
83 S I=BSDXSCD
84 Q:'$D(^SC(I,"ST",SD\1,1))
85 S SL=^SC(I,"SL"),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
86 S SL=BSDXLEN
87 S S=^SC(I,"ST",SD\1,1),Y=SD#1-SB*100,ST=Y#1*SI\.6+(Y\1*SI),SS=SL*HSI/60
88 I Y'<1 F I=ST+ST:SDDIF S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y="" S S=$E(S,1,I)_Y_$E(S,I+2,999),SS=SS-1 Q:SS'>0
89 S ^SC(BSDXSCD,"ST",SD\1,1)=S
90 Q
91 ;
92APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD) ;
93 ;Cancel appointment for patient BSDXDFN in clinic BSDXSC1
94 ;at time BSDXSD
95 N BSDXC,%H
96 S BSDXC("PAT")=BSDXPATID
97 S BSDXC("CLN")=BSDXLOC
98 S BSDXC("TYP")=BSDXTYP
99 S BSDXC("ADT")=BSDXSD
100 S %H=$H D YMD^%DTC
101 S BSDXC("CDT")=X+%
102 S BSDXC("NOT")=BSDXNOT
103 S:'+$G(BSDXCR) BSDXCR=11 ;Other
104 S BSDXC("CR")=BSDXCR
105 S BSDXC("USR")=DUZ
106 ;
107 S BSDXZ=$$CANCEL^BSDXAPI(.BSDXC)
108 Q
109 ;
110BSDXCAN(BSDXAPTID) ;
111 ;Cancel BSDX APPOINTMENT entry
112 N %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG
113 S %DT="XT",X="NOW" D ^%DT ; X ^DD("DD")
114 S BSDXDATE=Y
115 S BSDXIENS=BSDXAPTID_","
116 S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
117 K BSDXMSG
118 D FILE^DIE("","BSDXFDA","BSDXMSG")
119 Q
120 ;
121CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event
122 ;when appointments cancelled via PIMS interface.
123 ;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients
124 N BSDXFOUND,BSDXRES
125 Q:+$G(BSDXNOEV)
126 Q:'+$G(BSDXSC)
127 S BSDXFOUND=0
128 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
129 I BSDXFOUND D CANEVT3(BSDXRES) Q
130 I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
131 I BSDXFOUND D CANEVT3(BSDXRES)
132 Q
133 ;
134CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;
135 ;Get appointment id in BSDXAPT
136 ;If found, call BSDXCAN(BSDXAPPT) and return 1
137 ;else return 0
138 N BSDXFOUND,BSDXAPPT
139 S BSDXFOUND=0
140 Q:'+BSDXRES BSDXFOUND
141 Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
142 S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
143 . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
144 . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
145 I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)
146 Q BSDXFOUND
147 ;
148CANEVT3(BSDXRES) ;
149 ;Call RaiseEvent to notify GUI clients
150 ;
151 N BSDXRESN
152 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
153 Q:BSDXRESN=""
154 S BSDXRESN=$P(BSDXRESN,"^")
155 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
156 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
157 Q
158 ;
159ERR(BSDXI,BSDXERR) ;Error processing
160 S BSDXI=BSDXI+1
161 S BSDXERR=$TR(BSDXERR,"^","~")
162 TROLLBACK
163 S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
164 S BSDXI=BSDXI+1
165 S ^BSDXTMP($J,BSDXI)=$C(31)
166 L
167 Q
168 ;
169ETRAP ;EP Error trap entry
170 D ^%ZTER
171 I '$D(BSDXI) N BSDXI S BSDXI=999999
172 S BSDXI=BSDXI+1
173 D ERR(BSDXI,"BSDX08 Error: "_$G(%ZTERROR))
174 Q
Note: See TracBrowser for help on using the repository browser.