Changeset 1041
- Timestamp:
- Dec 12, 2010, 11:11:57 AM (13 years ago)
- Location:
- Scheduling/trunk/m
- Files:
-
- 37 edited
-
BSDX01.m (modified) (1 diff)
-
BSDX02.m (modified) (1 diff)
-
BSDX03.m (modified) (1 diff)
-
BSDX04.m (modified) (1 diff)
-
BSDX05.m (modified) (1 diff)
-
BSDX06.m (modified) (1 diff)
-
BSDX07.m (modified) (1 diff)
-
BSDX08.m (modified) (6 diffs)
-
BSDX09.m (modified) (2 diffs)
-
BSDX11.m (modified) (1 diff)
-
BSDX12.m (modified) (1 diff)
-
BSDX13.m (modified) (3 diffs)
-
BSDX14.m (modified) (1 diff)
-
BSDX15.m (modified) (1 diff)
-
BSDX16.m (modified) (1 diff)
-
BSDX17.m (modified) (1 diff)
-
BSDX18.m (modified) (1 diff)
-
BSDX19.m (modified) (1 diff)
-
BSDX20.m (modified) (1 diff)
-
BSDX21.m (modified) (1 diff)
-
BSDX22.m (modified) (1 diff)
-
BSDX23.m (modified) (1 diff)
-
BSDX24.m (modified) (1 diff)
-
BSDX25.m (modified) (1 diff)
-
BSDX26.m (modified) (1 diff)
-
BSDX27.m (modified) (1 diff)
-
BSDX28.m (modified) (1 diff)
-
BSDX29.m (modified) (7 diffs)
-
BSDX2E.m (modified) (1 diff)
-
BSDX30.m (modified) (1 diff)
-
BSDX31.m (modified) (1 diff)
-
BSDX32.m (modified) (1 diff)
-
BSDX33.m (modified) (1 diff)
-
BSDX34.m (modified) (1 diff)
-
BSDX35.m (modified) (1 diff)
-
BSDXAPI.m (modified) (3 diffs)
-
BSDXGPRV.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
Scheduling/trunk/m/BSDX01.m
r968 r1041 1 1 BSDX01 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 9/29/10 10:20am 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 SUINFOD(BSDXY,BSDXDUZ) ;EP Debugging entry point -
Scheduling/trunk/m/BSDX02.m
r968 r1041 1 1 BSDX02 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:25pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; Change Log -
Scheduling/trunk/m/BSDX03.m
r968 r1041 1 1 BSDX03 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX04.m
r968 r1041 1 1 BSDX04 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 7/15/10 12:44pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; Change Log: 4 4 ; July 11 2010: Pass BSDXSTART and END as FM dates rather than US formatted dates -
Scheduling/trunk/m/BSDX05.m
r968 r1041 1 BSDX05 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:51pm2 ;;1.41;BSDX;;Sep 29, 20103 ;1 BSDX05 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 5:36pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 ; 4 4 ; Change Log: 5 5 ; UJO/SMH - July 11 2010: pass FM Dates for Start and End rather than US Dates 6 ; 7 APBLKOV(BSDXY,BSDXSTART,BSDXEND,BSDXRES) ;EP 8 ;Called by BSDX APPT BLOCKS OVERLAP 9 ; July 11 2010 - pass FM Dates for Start and End rather than US Dates 10 ;(Duplicates old qryAppointmentBlocksOverlapB) 11 ;BSDXRES is resource name 12 ; 13 ;Test lines: 14 ;D APBLKOV^BSDX05(.RES,"11-8-2000","11-8-2004","WHITT") ZW RES 15 ;BSDX APPT BLOCKS OVERLAP^11-8-2000^11-8-2004^WHITT 16 ;S ^HW("BSDXD05")=BSDXSTART_U_BSDXEND_U_BSDXRES 17 ; 18 N BSDXERR,BSDXIEN,BSDXDEP,BSDXBS,BSDXI,BSDXNEND,BSDXNSTART,BSDXPEND,BSDXRESD,BSDXRESN,BSDXS,BSDXAD,BSDXNOD 19 K ^BSDXTMP($J) 20 S BSDXERR="" 21 S BSDXY="^BSDXTMP("_$J_")" 22 S ^BSDXTMP($J,0)="D00030START_TIME^D00030END_TIME"_$C(30) 23 D 24 . S BSDXBS=0 25 . S BSDXEND=BSDXEND+.9999 ;Go to end of day 26 . S BSDXRESN=BSDXRES 27 . Q:BSDXRESN="" 28 . Q:'$D(^BSDXRES("B",BSDXRESN)) 29 . S BSDXRESD=$O(^BSDXRES("B",BSDXRESN,0)) 30 . Q:'+BSDXRESD 31 . Q:'$D(^BSDXAPPT("ARSRC",BSDXRESD)) 32 . D STRES(BSDXRESD,BSDXSTART,BSDXEND) 33 . Q 34 ; 35 S BSDXI=$G(BSDXI)+1 36 S ^BSDXTMP($J,BSDXI)=$C(31) 37 Q 38 ; 39 STRES(BSDXRESD,BSDXSTART,BSDXEND) ; 40 ;$O THRU "ARSRC" XREF OF ^BSDXAPPT 41 ;Start at the beginning of the day -- appts can't overlap days 42 S BSDXS=$P(BSDXSTART,"."),BSDXS=BSDXS-.0001 43 S BSDXI=0 44 F S BSDXS=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS)) Q:'+BSDXS Q:BSDXS>BSDXEND D 45 . S BSDXAD=0 F S BSDXAD=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS,BSDXAD)) Q:'+BSDXAD D STCOMM(BSDXAD) ;BSDXAD Is the AppointmentID 46 . Q 47 Q 48 ; 49 STCOMM(BSDXAD) ; 50 S BSDXNEND=0,BSDXNSTART=0,BSDXPEND=0 51 Q:'$D(^BSDXAPPT(BSDXAD,0)) 52 S BSDXNOD=^BSDXAPPT(BSDXAD,0) 53 Q:$P(BSDXNOD,U,10)=1 ;NO-SHOW Flag 54 Q:$P(BSDXNOD,U,12)]"" ;CANCELLED APPT 55 Q:$P(BSDXNOD,U,13)="y" ;WALKIN 56 S BSDXNSTART=$P(BSDXNOD,U) 57 S BSDXNEND=$P(BSDXNOD,U,2) 58 I BSDXNEND'>BSDXSTART Q ;End is less than start 59 S Y=BSDXNSTART X ^DD("DD") S BSDXNSTART=$TR(Y,"@"," ") 60 S Y=BSDXNEND X ^DD("DD") S BSDXNEND=$TR(Y,"@"," ") 61 S BSDXI=BSDXI+1 62 S ^BSDXTMP($J,BSDXI)=BSDXNSTART_U_BSDXNEND_$C(30) 63 Q 6 ; UJO/SMH - Dec 8 2010: In STCOMM, the logic was that an appointment 7 ; that was a walk-in didn't count towards slot calculations. 8 ; I checked PIMS, and Walk-ins do indeed count towards slot calculations. 9 ; Therefore, I commented this line out: 10 ; ;Q:$P(BSDXNOD,U,13)="y" ;WALKIN 11 ; 12 APBLKOV(BSDXY,BSDXSTART,BSDXEND,BSDXRES) ;EP 13 ;Called by BSDX APPT BLOCKS OVERLAP 14 ; July 11 2010 - pass FM Dates for Start and End rather than US Dates 15 ;(Duplicates old qryAppointmentBlocksOverlapB) 16 ;BSDXRES is resource name 17 ; 18 ;Test lines: 19 ;D APBLKOV^BSDX05(.RES,"11-8-2000","11-8-2004","WHITT") ZW RES 20 ;BSDX APPT BLOCKS OVERLAP^11-8-2000^11-8-2004^WHITT 21 ;S ^HW("BSDXD05")=BSDXSTART_U_BSDXEND_U_BSDXRES 22 ; 23 N BSDXERR,BSDXIEN,BSDXDEP,BSDXBS,BSDXI,BSDXNEND,BSDXNSTART,BSDXPEND,BSDXRESD,BSDXRESN,BSDXS,BSDXAD,BSDXNOD 24 K ^BSDXTMP($J) 25 S BSDXERR="" 26 S BSDXY="^BSDXTMP("_$J_")" 27 S ^BSDXTMP($J,0)="D00030START_TIME^D00030END_TIME"_$C(30) 28 D 29 . S BSDXBS=0 30 . S BSDXEND=BSDXEND+.9999 ;Go to end of day 31 . S BSDXRESN=BSDXRES 32 . Q:BSDXRESN="" 33 . Q:'$D(^BSDXRES("B",BSDXRESN)) 34 . S BSDXRESD=$O(^BSDXRES("B",BSDXRESN,0)) 35 . Q:'+BSDXRESD 36 . Q:'$D(^BSDXAPPT("ARSRC",BSDXRESD)) 37 . D STRES(BSDXRESD,BSDXSTART,BSDXEND) 38 . Q 39 ; 40 S BSDXI=$G(BSDXI)+1 41 S ^BSDXTMP($J,BSDXI)=$C(31) 42 Q 43 ; 44 STRES(BSDXRESD,BSDXSTART,BSDXEND) ; 45 ;$O THRU "ARSRC" XREF OF ^BSDXAPPT 46 ;Start at the beginning of the day -- appts can't overlap days 47 S BSDXS=$P(BSDXSTART,"."),BSDXS=BSDXS-.0001 48 S BSDXI=0 49 F S BSDXS=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS)) Q:'+BSDXS Q:BSDXS>BSDXEND D 50 . S BSDXAD=0 F S BSDXAD=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS,BSDXAD)) Q:'+BSDXAD D STCOMM(BSDXAD) ;BSDXAD Is the AppointmentID 51 . Q 52 Q 53 ; 54 STCOMM(BSDXAD) ; 55 S BSDXNEND=0,BSDXNSTART=0,BSDXPEND=0 56 Q:'$D(^BSDXAPPT(BSDXAD,0)) 57 S BSDXNOD=^BSDXAPPT(BSDXAD,0) 58 Q:$P(BSDXNOD,U,10)=1 ;NO-SHOW Flag 59 Q:$P(BSDXNOD,U,12)]"" ;CANCELLED APPT 60 ; Q:$P(BSDXNOD,U,13)="y" ;WALKIN -- new in V 1.42. See top comments. 61 S BSDXNSTART=$P(BSDXNOD,U) 62 S BSDXNEND=$P(BSDXNOD,U,2) 63 I BSDXNEND'>BSDXSTART Q ;End is less than start 64 S Y=BSDXNSTART X ^DD("DD") S BSDXNSTART=$TR(Y,"@"," ") 65 S Y=BSDXNEND X ^DD("DD") S BSDXNEND=$TR(Y,"@"," ") 66 S BSDXI=BSDXI+1 67 S ^BSDXTMP($J,BSDXI)=BSDXNSTART_U_BSDXNEND_$C(30) 68 Q -
Scheduling/trunk/m/BSDX06.m
r968 r1041 1 1 BSDX06 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 4:51pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; Change Log: 4 4 ; UJO/SMH: July 15 2010: Change in BSDXSTART and BSDXEND: get -
Scheduling/trunk/m/BSDX07.m
r998 r1041 1 BSDX07 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 10/31/10 9:38am2 ;;1.42;BSDX;;Sep 29, 20103 ;4 ; Change Log:5 ; UJO/SMH6 ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US.7 8 9 ; v1.42 Oct 30 2010 - Extensive refactoring.10 11 12 13 14 15 16 ; -5: BSDXPATID is not numeric17 18 19 20 21 22 23 24 APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP25 ;Entry point for debugging26 D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")27 Q28 ;29 UT 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 1 BSDX07 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:31pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 ; 4 ; Change Log: 5 ; UJO/SMH 6 ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US. 7 ; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments 8 ; thanks to Rick Marshall and Zach Gonzalez at Oroville. 9 ; v1.42 Oct 30 2010 - Extensive refactoring. 10 ; 11 ; Error Reference: 12 ; -1: Patient Record is locked. This means something is wrong!!!! 13 ; -2: Start Time is not a valid Fileman date 14 ; -3: End Time is not a valid Fileman date 15 ; -4: End Time does not have time inside of it. 16 ; -5: BSDXPATID is not numeric 17 ; -6: Patient Does not exist in ^DPT 18 ; -7: Resource Name does not exist in B index of BSDX RESOURCE 19 ; -8: Resouce doesn't exist in ^BSDXRES 20 ; -9: Couldn't add appointment to BSDX APPOINTMENT 21 ; -10: Couldn't add appointment to files 2 and/or 44 22 ; -100: Mumps Error 23 24 APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP 25 ;Entry point for debugging 26 D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)") 27 Q 28 ; 29 UT ; Unit Tests 30 N ZZZ 31 ; Test for bad start date 32 D APPADD(.ZZZ,2100123,3100123.3,2,"Dr Office",30,"Sam's Note",1) 33 I +$P(^BSDXTMP($J,1),U,2)'=-2 W "Error in -2",! 34 ; Test for bad end date 35 D APPADD(.ZZZ,3100123,2100123.3,2,"Dr Office",30,"Sam's Note",1) 36 I +$P(^BSDXTMP($J,1),U,2)'=-3 W "Error in -3",! 37 ; Test for end date without time 38 D APPADD(.ZZZ,3100123.1,3100123,2,"Dr Office",30,"Sam's Note",1) 39 I +$P(^BSDXTMP($J,1),U,2)'=-4 W "Error in -4",! 40 ; Test for mumps error 41 S bsdxdie=1 42 D APPADD(.ZZZ,3100123.09,3100123.093,2,"Dr Office",30,"Sam's Note",1) 43 I +$P(^BSDXTMP($J,1),U,2)'=-100 W "Error in -100: M Error",! 44 K bsdxdie 45 ; Test for TRESTART 46 s bsdxrestart=1 47 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1) 48 I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",! 49 k bsdxrestart 50 ; Test for non-numeric patient 51 D APPADD(.ZZZ,3100123.09,3100123.093,"CAT,DOG","Dr Office",30,"Sam's Note",1) 52 I +$P(^BSDXTMP($J,1),U,2)'=-5 W "Error in -5",! 53 ; Test for a non-existent patient 54 D APPADD(.ZZZ,3100123.09,3100123.093,8989898989,"Dr Office",30,"Sam's Note",1) 55 I +$P(^BSDXTMP($J,1),U,2)'=-6 W "Error in -6",! 56 ; Test for a non-existent resource name 57 D APPADD(.ZZZ,3100123.09,3100123.093,3,"lkajsflkjsadf",30,"Sam's Note",1) 58 I +$P(^BSDXTMP($J,1),U,2)'=-7 W "Error in -7",! 59 ; Test for corrupted resource 60 ; Can't test for -8 since it requires DB corruption 61 ; Test for inability to add appointment to BSDX Appointment 62 ; Also requires something wrong in the DB 63 ; Test for inability to add appointment to 2,44 64 ; Test by creating a duplicate appointment 65 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1) 66 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1) 67 I +$P(^BSDXTMP($J,1),U,2)'=-10 W "Error in -10",! 68 ; Test for normality: 69 D APPADD(.ZZZ,3110123.09,3110123.093,3,"Dr Office",30,"Sam's Note",1) 70 ; Does Appt exist? 71 N APPID S APPID=+$P(^BSDXTMP($J,1),U) 72 I 'APPID W "Error Making Appt-1" QUIT 73 I +^BSDXAPPT(APPID,0)'=3110123.09 W "Error Making Appt-2" 74 I '$D(^DPT(3,"S",3110123.09)) W "Error Making Appt-3" 75 I '$D(^SC(2,"S",3110123.09)) W "Error Making Appt-4" 76 QUIT 77 ; 78 78 APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP 79 ;Called by RPC: BSDX ADD NEW APPOINTMENT80 ;81 82 83 84 85 86 ;Paramters:87 88 89 90 91 92 ;BSDXLEN is the appointment duration in minutes93 94 ;BSDXATID is used for 2 purposes:95 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.96 ; if BSDXATID = a number, then it is the access type id (used for rebooking)97 ;98 ;Return:99 100 ; AppointmentID and ErrorNumber101 ;102 ;Test lines:103 104 105 106 S BSDXY=$NA(^BSDXTMP($J))107 108 109 N $ET S $ET="G ETRAP^BSDX07"110 ; Counter111 N BSDXI S BSDXI=0112 ; Lock BSDX node, only to synchronize access to the globals.113 114 115 116 ; Header Node117 S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00020ERRORID"_$C(30)118 119 120 121 122 123 N BSDXNOEV124 S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol125 ;126 127 128 ;129 130 131 132 133 134 135 136 137 ; If C# sends the dates with extra zeros, remove them138 S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND139 ; Are the dates valid? Must be FM Dates > than 2010140 141 142 143 I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q144 ; If the Start Date is greater than the end date, swap dates145 146 147 148 ; Check if the patient exists:149 150 151 152 153 ;154 155 I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q156 N BSDXRESD ; Resource IEN157 S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))158 N BSDXRNOD ; Resouce zero node159 160 I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q161 ;162 163 164 I BSDXATID="WALKIN" S BSDXWKIN=1165 166 I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""167 ;168 169 N BSDXAPPTID170 171 I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q172 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)173 ;174 ; Then Create Subfiles in 2/44 Appointment175 N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4) ; Hosp Location IEN176 177 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: ~MAKE^BSDAPI returned error code: "_BSDXERR) Q178 . N BSDXC179 180 . S BSDXC("CLN")=BSDXSCD181 . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins182 . S:BSDXWKIN BSDXC("TYP")=4183 . S BSDXC("ADT")=BSDXSTART184 . S BSDXC("LEN")=BSDXLEN185 . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field186 . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI187 . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note188 . S BSDXC("USR")=DUZ189 . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)190 . Q:BSDXERR191 . ;Update RPMS Clinic availability192 . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)193 . Q194 ;195 ;Return Recordset196 TCOMMIT197 L -^BSDXAPPT(BSDXPATID)198 S BSDXI=BSDXI+1199 S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)200 S BSDXI=BSDXI+1201 S ^BSDXTMP($J,BSDXI)=$C(31)202 Q79 ;Called by RPC: BSDX ADD NEW APPOINTMENT 80 ; 81 ;Add new appointment to 3 files 82 ; - BSDX APPOINTMENT 83 ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic 84 ; - Patient Appointment Subfile if Resource is linked to clinic 85 ; 86 ;Paramters: 87 ;BSDXY: Global Return (RPC must be set to Global Array) 88 ;BSDXSTART: FM Start Date 89 ;BSDXEND: FM End Date 90 ;BSDXPATID: Patient DFN 91 ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN) 92 ;BSDXLEN is the appointment duration in minutes 93 ;BSDXNOTE is the Appiontment Note 94 ;BSDXATID is used for 2 purposes: 95 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt. 96 ; if BSDXATID = a number, then it is the access type id (used for rebooking) 97 ; 98 ;Return: 99 ; ADO.net Recordset having fields: 100 ; AppointmentID and ErrorNumber 101 ; 102 ;Test lines: 103 ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN 104 ; 105 ; Return Array; set Return and clear array 106 S BSDXY=$NA(^BSDXTMP($J)) 107 K ^BSDXTMP($J) 108 ; $ET 109 N $ET S $ET="G ETRAP^BSDX07" 110 ; Counter 111 N BSDXI S BSDXI=0 112 ; Lock BSDX node, only to synchronize access to the globals. 113 ; It's not expected that the error will ever happen as no filing 114 ; is supposed to take 5 seconds. 115 L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q 116 ; Header Node 117 S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30) 118 ;Restartable Transaction; restore paramters when starting. 119 ; (Params restored are what's passed here + BSDXI) 120 TSTART (BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXI):T="BSDX ADD NEW APPOINTMENT^BSDX07" 121 ; 122 ; Turn off SDAM APPT PROTOCOL BSDX Entries 123 N BSDXNOEV 124 S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol 125 ; 126 ; Set Error Message to be empty 127 N BSDXERR S BSDXERR=0 128 ; 129 ;;;test for error inside transaction. See if %ZTER works 130 I $G(bsdxdie) S X=1/0 131 ;;;test 132 ;;;test for TRESTART 133 I $G(bsdxrestart) K bsdxrestart TRESTART 134 ;;;test 135 ; 136 ; -- Start and End Date Processing -- 137 ; If C# sends the dates with extra zeros, remove them 138 S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND 139 ; Are the dates valid? Must be FM Dates > than 2010 140 I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q 141 I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q 142 ; If Ending date doesn't have a time, this is an error 143 I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q 144 ; If the Start Date is greater than the end date, swap dates 145 N BSDXTMP 146 I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP 147 ; 148 ; Check if the patient exists: 149 ; - DFN valid number? 150 ; - Valid Patient in file 2? 151 I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q 152 I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q 153 ; 154 ;Validate Resource entry 155 I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q 156 N BSDXRESD ; Resource IEN 157 S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0)) 158 N BSDXRNOD ; Resouce zero node 159 S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0)) 160 I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q 161 ; 162 ; Walk-in (Unscheduled) Appointment? 163 N BSDXWKIN S BSDXWKIN=0 164 I BSDXATID="WALKIN" S BSDXWKIN=1 165 ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number 166 I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID="" 167 ; 168 ; Done with all checks, let's make appointment in BSDX APPOINTMENT 169 N BSDXAPPTID 170 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) 171 I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q 172 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) 173 ; 174 ; Then Create Subfiles in 2/44 Appointment 175 N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4) ; Hosp Location IEN 176 ; Only if we have a valid Hosp Loc can we make an appointment 177 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: ~MAKE^BSDAPI returned error code: "_BSDXERR) Q 178 . N BSDXC 179 . S BSDXC("PAT")=BSDXPATID 180 . S BSDXC("CLN")=BSDXSCD 181 . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins 182 . S:BSDXWKIN BSDXC("TYP")=4 183 . S BSDXC("ADT")=BSDXSTART 184 . S BSDXC("LEN")=BSDXLEN 185 . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field 186 . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI 187 . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note 188 . S BSDXC("USR")=DUZ 189 . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC) 190 . Q:BSDXERR 191 . ;Update RPMS Clinic availability 192 . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) 193 . Q 194 ; 195 ;Return Recordset 196 TCOMMIT 197 L -^BSDXAPPT(BSDXPATID) 198 S BSDXI=BSDXI+1 199 S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30) 200 S BSDXI=BSDXI+1 201 S ^BSDXTMP($J,BSDXI)=$C(31) 202 Q 203 203 BSDXDEL(BSDXAPPTID) ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN 204 N DA,DIK205 S DIK="^BSDXAPPT(",DA=BSDXAPPTID206 D ^DIK207 Q208 ;209 STRIP(BSDXZ) ;Replace control characters with spaces210 N BSDXI211 F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)212 Q BSDXZ213 ;214 BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY215 ;Returns ien in BSDXAPPT or 0 if failed216 ;Create entry in BSDX APPOINTMENT217 N BSDXAPPTID218 S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART219 S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND220 S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID221 S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD222 S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)223 S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT224 S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"225 S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID226 N BSDXIEN,BSDXMSG227 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")228 S BSDXAPPTID=+$G(BSDXIEN(1))229 Q BSDXAPPTID230 ;204 N DA,DIK 205 S DIK="^BSDXAPPT(",DA=BSDXAPPTID 206 D ^DIK 207 Q 208 ; 209 STRIP(BSDXZ) ;Replace control characters with spaces 210 N BSDXI 211 F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999) 212 Q BSDXZ 213 ; 214 BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY 215 ;Returns ien in BSDXAPPT or 0 if failed 216 ;Create entry in BSDX APPOINTMENT 217 N BSDXAPPTID 218 S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART 219 S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND 220 S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID 221 S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD 222 S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ) 223 S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT 224 S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y" 225 S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID 226 N BSDXIEN,BSDXMSG 227 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG") 228 S BSDXAPPTID=+$G(BSDXIEN(1)) 229 Q BSDXAPPTID 230 ; 231 231 BSDXWP(BSDXAPPTID,BSDXNOTE) ; 232 ;Add WP field233 I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""234 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)235 I $D(BSDXNOTE(.5)) D236 . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")237 Q238 ;232 ;Add WP field 233 I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE="" 234 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0) 235 I $D(BSDXNOTE(.5)) D 236 . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG") 237 Q 238 ; 239 239 ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP 240 ;Called by BSDX ADD APPOINTMENT protocol241 ;BSDXSC=IEN of clinic in ^SC242 ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note243 ;244 N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES245 Q:+$G(BSDXNOEV)246 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))247 E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))248 Q:'+$G(BSDXRES)249 S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))250 Q:BSDXNOD=""251 S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))252 S BSDXWKIN=""253 S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile254 S BSDXLEN=$P(BSDXNOD,U,2)255 Q:'+BSDXLEN256 S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)257 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)258 Q:'+BSDXAPPTID259 S BSDXNOTE=$P(BSDXNOD,U,4)260 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)261 D ADDEVT3(BSDXRES)262 Q263 ;264 ADDEVT3(BSDXRES) ;265 ;Call RaiseEvent to notify GUI clients266 N BSDXRESN267 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))268 Q:BSDXRESN=""269 S BSDXRESN=$P(BSDXRESN,"^")270 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")271 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)272 Q273 ;274 ERR(BSDXI,BSDXERR) ;Error processing275 S BSDXI=BSDXI+1276 S BSDXERR=$TR(BSDXERR,"^","~")277 I $TL>0 TROLLBACK278 S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)279 S BSDXI=BSDXI+1280 S ^BSDXTMP($J,BSDXI)=$C(31)281 L -^BSDXAPPT(BSDXPATID)282 Q283 ;284 ETRAP ;EP Error trap entry285 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap286 287 288 289 290 ; Log error message and send to client291 292 D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))293 Q294 ;240 ;Called by BSDX ADD APPOINTMENT protocol 241 ;BSDXSC=IEN of clinic in ^SC 242 ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note 243 ; 244 N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES 245 Q:+$G(BSDXNOEV) 246 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) 247 E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) 248 Q:'+$G(BSDXRES) 249 S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0)) 250 Q:BSDXNOD="" 251 S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0)) 252 S BSDXWKIN="" 253 S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile 254 S BSDXLEN=$P(BSDXNOD,U,2) 255 Q:'+BSDXLEN 256 S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0) 257 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN) 258 Q:'+BSDXAPPTID 259 S BSDXNOTE=$P(BSDXNOD,U,4) 260 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) 261 D ADDEVT3(BSDXRES) 262 Q 263 ; 264 ADDEVT3(BSDXRES) ; 265 ;Call RaiseEvent to notify GUI clients 266 N BSDXRESN 267 S BSDXRESN=$G(^BSDXRES(BSDXRES,0)) 268 Q:BSDXRESN="" 269 S BSDXRESN=$P(BSDXRESN,"^") 270 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","") 271 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN) 272 Q 273 ; 274 ERR(BSDXI,BSDXERR) ;Error processing 275 S BSDXI=BSDXI+1 276 S BSDXERR=$TR(BSDXERR,"^","~") 277 I $TL>0 TROLLBACK 278 S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30) 279 S BSDXI=BSDXI+1 280 S ^BSDXTMP($J,BSDXI)=$C(31) 281 L -^BSDXAPPT(BSDXPATID) 282 Q 283 ; 284 ETRAP ;EP Error trap entry 285 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 286 ; Rollback, otherwise ^XTER will be empty from future rollback 287 I $TL>0 TROLLBACK 288 D ^%ZTER 289 S $EC="" ; Clear Error 290 ; Log error message and send to client 291 I '$D(BSDXI) N BSDXI S BSDXI=0 292 D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE)) 293 Q 294 ; 295 295 DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR 296 ;296 ; 297 297 DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y) 298 F %=%:-1:281 S Y=%#4=1+1+Y299 S Y=$E(X,6,7)+Y#7300 Q301 ;302 AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability303 ;SEE SDM1304 N Y,DFN305 N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG306 N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I307 S Y=BSDXSCD,DFN=BSDXPATID308 S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,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 Y309 ;Determine maximum days for scheduling310 S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365311 S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))312 S SDDATE=BSDXSTART313 S SDSDATE=SDDATE,SDDATE=SDDATE\1314 1 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC315 Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC316 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)317 S X2=SDEDT D C^%DTC S SDEDT=X318 S Y=BSDXSTART298 F %=%:-1:281 S Y=%#4=1+1+Y 299 S Y=$E(X,6,7)+Y#7 300 Q 301 ; 302 AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability 303 ;SEE SDM1 304 N Y,DFN 305 N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG 306 N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I 307 S Y=BSDXSCD,DFN=BSDXPATID 308 S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,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 309 ;Determine maximum days for scheduling 310 S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365 311 S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1)) 312 S SDDATE=BSDXSTART 313 S SDSDATE=SDDATE,SDDATE=SDDATE\1 314 1 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC 315 Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC 316 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2) 317 S X2=SDEDT D C^%DTC S SDEDT=X 318 S Y=BSDXSTART 319 319 EN1 S (X,SD)=Y,SM=0 D DOW 320 S I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) Q:SS'>0 Q:^(SS,1)="" S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".")321 S S=BSDXLEN322 ;Check if BSDXLEN evenly divisible by appointment length323 S RPMSL=$P(SL,U)324 I BSDXLEN<RPMSL S BSDXLEN=RPMSL325 I BSDXLEN#RPMSL'=0 D326 . S BSDXINC=BSDXLEN\RPMSL327 . S BSDXINC=BSDXINC+1328 . S BSDXLEN=RPMSL*BSDXINC329 S SL=S_U_$P(SL,U,2,99)330 SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9331 L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC332 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)333 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST334 I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q335 I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7336 ;337 SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP338 S SDNOT=1339 S ABORT=0340 F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT341 . S ST=$E(S,I+1) S:ST="" ST=" "342 . S Y=$E(STR,$F(STR,ST)-2)343 . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q344 . I Y="" S ABORT=1 Q345 . S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) S:ST="" ST=" " S S=$E(S,1,I)_Y_ST346 . Q347 S ^SC(SC,"ST",$P(SD,"."),1)=S348 L -^SC(SC,"ST",$P(SD,"."),1)349 Q320 S I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) Q:SS'>0 Q:^(SS,1)="" S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".") 321 S S=BSDXLEN 322 ;Check if BSDXLEN evenly divisible by appointment length 323 S RPMSL=$P(SL,U) 324 I BSDXLEN<RPMSL S BSDXLEN=RPMSL 325 I BSDXLEN#RPMSL'=0 D 326 . S BSDXINC=BSDXLEN\RPMSL 327 . S BSDXINC=BSDXINC+1 328 . S BSDXLEN=RPMSL*BSDXINC 329 S SL=S_U_$P(SL,U,2,99) 330 SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9 331 L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC 332 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1) 333 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST 334 I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q 335 I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7 336 ; 337 SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP 338 S SDNOT=1 339 S ABORT=0 340 F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT 341 . S ST=$E(S,I+1) S:ST="" ST=" " 342 . S Y=$E(STR,$F(STR,ST)-2) 343 . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q 344 . I Y="" S ABORT=1 Q 345 . S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) S:ST="" ST=" " S S=$E(S,1,I)_Y_ST 346 . Q 347 S ^SC(SC,"ST",$P(SD,"."),1)=S 348 L -^SC(SC,"ST",$P(SD,"."),1) 349 Q -
Scheduling/trunk/m/BSDX08.m
r1007 r1041 1 BSDX08 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 1 1/16/10 7:12am2 ;;1.42;BSDX;; Sep 29, 20103 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 1 BSDX08 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:35pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 ; 4 ; Original by HMW. New Written by Sam Habiel. Licensed under LGPL. 5 ; 6 ; Change History 7 ; 3101022 UJO/SMH v1.42 8 ; - Transaction now restartable. Thanks to 9 ; --> Zach Gonzalez and Rick Marshall for fix. 10 ; - Extra TROLLBACK in Lock Statement when lock fails. 11 ; --> Removed--Rollback is already in ERR tag. 12 ; - Added new statements to old SD code in AVUPDT to obviate 13 ; --> need to restore variables in transaction 14 ; - Refactored this chunk of code. Don't really know whether it 15 ; --> worked in the first place. Waiting for bug report to know. 16 ; - Refactored all of APPDEL. 17 ; 18 ; Error Reference: 19 ; -1~BSDX08: Appt record is locked. Please contact technical support. 20 ; -2~BSDX08: Invalid Appointment ID 21 21 ; -3~BSDX08: Invalid Appointment ID 22 23 24 25 26 27 28 22 ; -4~BSDX08: Cancelled appointment does not have a Resouce ID 23 ; -5~BSDX08: Resouce ID does not exist in BSDX RESOURCE 24 ; -6~BSDX08: Invalid Hosp Location stored in Database 25 ; -7~BSDX08: Patient does not have an appointment in PIMS Clinic 26 ; -8^BSDX08: Unable to find associated PIMS appointment for this patient 27 ; -9^BSDX08: BSDXAPI returned an error: (error) 28 ; -100~BSDX08 Error: (Mumps Error) 29 29 ; 30 30 APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP … … 33 33 Q 34 34 ; 35 UT 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 UTL(APPID) 77 35 UT ; Unit Tests 36 ; Test 1: Make normal appointment and cancel it. See if every thing works 37 N ZZZ 38 D APPADD^BSDX07(.ZZZ,3110123.2,3110123.3,4,"Dr Office",10,"Sam's Note",1) 39 S APPID=+$P(^BSDXTMP($J,1),U) 40 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note") 41 I $P(^BSDXAPPT(APPID,0),U,12)'>0 W "Error in Cancellation-1" 42 I $O(^SC(2,"S",3110123.2,1,0))]"" W "Error in Cancellation-2" 43 I $P(^DPT(4,"S",3110123.2,0),U,2)'="PC" W "Error in Cancellation-3" 44 I ^DPT(4,"S",3110123.2,"R")'="Sam's Cancel Note" W "Error in Cancellation-4" 45 ; 46 ; Test 2: Check for -1 47 ; Make appt 48 D APPADD^BSDX07(.ZZZ,3110125.2,3110125.3,4,"Dr Office",10,"Sam's Note",1) 49 ; Lock the node in another job 50 S APPID=+$P(^BSDXTMP($J,1),U) 51 ; W "Lock ^BSDXAPPT("_APPID_") in another session. You have 10 seconds." H 10 52 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note") 53 ; 54 ; Test 3: Check for -100 55 S bsdxdie=1 56 D APPADD^BSDX07(.ZZZ,3110126.2,3110126.3,4,"Dr Office",10,"Sam's Note",1) 57 S APPID=+$P(^BSDXTMP($J,1),U) 58 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons") 59 I $P(^BSDXTMP($J,1),"~")'=-100 W "Error in -100",! 60 K bsdxdie 61 ; 62 ; Test 4: Restartable transaction 63 S bsdxrestart=1 64 D APPADD^BSDX07(.ZZZ,3110128.2,3110128.3,4,"Dr Office",10,"Sam's Note",1) 65 S APPID=+$P(^BSDXTMP($J,1),U) 66 D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons") 67 I $P(^DPT(4,"S",3110128.2,0),U,2)'="PC" W "Error in Restartable Transaction",! 68 ; 69 ; Test 5: for invalid Appointment ID (-2 and -3) 70 D APPDEL^BSDX08(.ZZZ,0,"PC",1,"Reasons") 71 I $P(^BSDXTMP($J,1),"~")'=-2 W "Error in -2",! 72 D APPDEL^BSDX08(.ZZZ,999999,"PC",1,"Reasons") 73 I $P(^BSDXTMP($J,1),"~")'=-3 W "Error in -3",! 74 QUIT 75 ; Lock the node in another job for testing. 76 UTL(APPID) L +^BSDXAPPT(APPID) HANG 10 QUIT 77 ; 78 78 APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP 79 79 ;Called by RPC: BSDX CANCEL APPOINTMENT 80 80 ;Cancels existing appointment in BSDX APPOINTMENT and 44/2 subfiles 81 81 ;Input Parameters: 82 82 ; - BSDXAPTID is entry number in BSDX APPOINTMENT file 83 83 ; - BSDXTYP is C for clinic-cancelled and PC for patient cancelled … … 85 85 ; - BSDXNOT is user note 86 86 ; 87 88 89 ; 90 87 ; Returns error code in recordset field ERRORID. Zero is success. 88 ; Returns Global Array. Must use this type in RPC. 89 ; 90 ; Return Array: set Return and clear array 91 91 S BSDXY=$NA(^BSDXTMP($J)) 92 93 ; 94 95 96 97 98 99 ; 100 92 K ^BSDXTMP($J) 93 ; 94 ; Set min DUZ vars if they don't exist 95 D ^XBKVAR 96 ; 97 ; $ET 98 N $ET S $ET="G ETRAP^BSDX08" 99 ; 100 ; Counter 101 101 N BSDXI S BSDXI=0 102 103 S ^BSDXTMP($J,BSDXI)="T00 030ERRORID"_$C(30)104 ; 105 106 107 108 109 ; 110 111 112 113 ; 114 102 ; Header Node 103 S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30) 104 ; 105 ; Lock BSDX node, only to synchronize access to the globals. 106 ; It's not expected that the error will ever happen as no filing 107 ; is supposed to take 5 seconds. 108 L +^BSDXAPPT(BSDXAPTID):5 I '$T D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q 109 ; 110 ;Restartable Transaction; restore paramters when starting. 111 ; (Params restored are what's passed here + BSDXI) 112 TSTART (BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT,BSDXI):T="BSDX CANCEL APPOINTEMENT^BSDX08" 113 ; 114 ; Turn off SDAM APPT PROTOCOL BSDX Entries 115 115 N BSDXNOEV 116 116 S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol 117 117 ; 118 119 120 121 122 123 124 125 126 118 ;;;test for error inside transaction. See if %ZTER works 119 I $G(bsdxdie) S X=1/0 120 ;;;test 121 ;;;test for TRESTART 122 I $G(bsdxrestart) K bsdxrestart TRESTART 123 ;;;test 124 ; 125 ; Check appointment ID and whether it exists 126 I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q 127 127 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q 128 128 ; 129 129 ; Start Processing: 130 130 ; First, add cancellation date to appt entry in BSDX APPOINTMENT 131 131 N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; BSDX Appt Node 132 132 N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; Patient ID … … 134 134 D BSDXCAN(BSDXAPTID) ; Add a cancellation date in BSDX APPOINTMENT 135 135 ; 136 136 ; Second, cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability 137 137 N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID 138 138 ; If the resouce id doesn't exist... 139 139 I BSDXSC1="" D ERR(BSDXI,"-4~BSDX08: Cancelled appointment does not have a Resouce ID") QUIT 140 140 I '$D(^BSDXRES(BSDXSC1,0)) D ERR(BSDXI,"-5~BSDX08: Resouce ID does not exist in BSDX RESOURCE") QUIT 141 141 ; Get zero node of resouce 142 143 142 S BSDXNOD=^BSDXRES(BSDXSC1,0) 143 ; Get Hosp location 144 144 N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4) 145 146 147 148 145 ; Error indicator for Hosp Location filing for getting out of routine 146 N BSDXERR S BSDXERR=0 147 ; Only file in 2/44 if there is an associated hospital location 148 I BSDXLOC D QUIT:BSDXERR 149 149 . I '$D(^SC(BSDXLOC,0)) S BSDXERR=1 D ERR(BSDXI,"-6~BSDX08: Invalid Hosp Location stored in Database") QUIT 150 151 150 . ; Get the IEN of the appointment in the "S" node of ^SC 151 . N BSDXSCIEN 152 152 . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) 153 153 . I BSDXSCIEN="" S BSDXERR=1 D ERR(BSDXI,"-7~BSDX08: Patient does not have an appointment in PIMS Clinic") QUIT 154 154 . ; Get the appointment node 155 155 . S BSDXNOD=$G(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0)) 156 156 . I BSDXNOD="" S BSDXERR=1 D ERR(BSDXI,"-8^BSDX08: Unable to find associated PIMS appointment for this patient") QUIT 157 157 . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2) 158 158 . ; Cancel through BSDXAPI 159 160 161 159 . N BSDXZ 160 . D APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART) 161 . I +BSDXZ>0 S BSDXERR=1 D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXZ,U,2)) QUIT 162 162 . ; Update Legacy PIMS clinic Availability 163 163 . D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN) … … 174 174 ;See SDCNP0 175 175 N SD,S ; Start Date 176 177 176 S (SD,S)=BSDXSTART 177 N I ; Clinic IEN in 44 178 178 S I=BSDXSCD 179 179 ; if day has no schedule in legacy PIMS, forget about this update. 180 180 Q:'$D(^SC(I,"ST",SD\1,1)) 181 181 N SL ; Clinic characteristics node (length of appt, when appts start etc) 182 182 S SL=^SC(I,"SL") 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 183 N X ; Hour Clinic Display Begins 184 S X=$P(SL,U,3) 185 N STARTDAY ; When does the day start? 186 S STARTDAY=$S($L(X):X,1:8) ; If defined, use it; otherwise, 8am 187 N SB ; ?? Who knows? Day Start - 1 divided by 100. 188 S SB=STARTDAY-1/100 189 S X=$P(SL,U,6) ; Now X is Display increments per hour 190 N HSI ; Slots per hour, try 1 191 S HSI=$S(X:X,1:4) ; if defined, use it; otherwise, 4 192 N SI ; Slots per hour, try 2 193 S SI=$S(X="":4,X<3:4,X:X,1:4) ; If slots "", or less than 3, then 4 194 N STR ; ?? 195 S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz" 196 N SDDIF ; Slots per hour diff?? 197 S SDDIF=$S(HSI<3:8/HSI,1:2) 198 198 S SL=BSDXLEN ; Dammit, reusing variable; SL now Appt Length from GUI 199 199 S S=^SC(I,"ST",SD\1,1) ; reusing var again; S now Day Pattern from PIMS 200 201 202 203 204 205 206 207 200 N Y ; Hours since start of Date 201 S Y=SD#1-SB*100 ;SD#1=FM Time portion; -SB minus start of day; conv to hrs 202 N ST ; ?? 203 ; Y#1 -> Minutes; *SI -> * Slots per hour; \.6 trunc min to hour 204 ; Y\1 -> Hours since start of day; * SI: * slots 205 S ST=Y#1*SI\.6+(Y\1*SI) 206 N SS ; how many slots are supposed to be taken by appointment 207 S SS=SL*HSI/60 ; (nb: try SL: 30 min; HSI: 4 slots) 208 208 N I 209 210 211 212 213 214 215 209 I Y'<1 D ; If Hours since start of Date is greater than 1 210 . ; loop through pattern. Tired of documenting. 211 . F I=ST+ST:SDDIF D Q:Y="" Q:SS'>0 212 . . S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y="" 213 . . S S=$E(S,1,I)_Y_$E(S,I+2,999) 214 . . S SS=SS-1 215 . . Q:SS'>0 216 216 S ^SC(BSDXSCD,"ST",SD\1,1)=S ; new pattern; global set 217 217 Q … … 296 296 ETRAP ;EP Error trap entry 297 297 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 298 299 300 301 298 ; Rollback, otherwise ^XTER will be empty from future rollback 299 I $TL>0 TROLLBACK 300 D ^%ZTER 301 S $EC="" ; Clear Error 302 302 ; Log error message and send to client 303 303 I '$D(BSDXI) N BSDXI S BSDXI=0 304 304 D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE)) 305 305 QUIT 306 307 308 309 306 ; 307 ;;;NB: This is code that is unused in both original and port. 308 ; ; If not appt in the "S" node is found in ^SC then check associated RPMS Clinic Multiple 309 ; I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ 310 310 ; . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. " 311 311 ; . S BSDXZ=1 312 312 ; . ; Check if there are associated RPMS clinics. (not currently used) Does the multiple exist? No, then quit 313 313 ; . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 QUIT 314 314 ; . ; Loop through the multiple. Get Location and then the ^SC "S" node IEN. 315 315 ; . N BSDX1 S BSDX1=0 316 316 ; . F S BSDX1=$O(^BSDXRES(BSDXSC1,20,BSDX1)) Q:'+BSDX1 Q:BSDXZ=0 D -
Scheduling/trunk/m/BSDX09.m
r984 r1041 1 1 BSDX09 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 10/20/10 4:16pm 2 ;;1.4 1;BSDX;;Sep07, 2010;Build 72 ;;1.42;BSDX;;Dec 07, 2010;Build 7 3 3 ; 4 4 ; Change Log: … … 11 11 ; UJO/TH - v 1.3 on 3100715 - Change SSN to PID and get PID field instead 12 12 ; 13 14 13 ; UJO/TH - v 1.42 on 3101020 - Add Sex field. 14 ; 15 15 GETREGA(BSDXRET,BSDXPAT) ;EP 16 16 ; -
Scheduling/trunk/m/BSDX11.m
r968 r1041 1 1 BSDX11 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ENV0100 ;EP Version 1.0 Environment check -
Scheduling/trunk/m/BSDX12.m
r968 r1041 1 1 BSDX12 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:14pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; Change Log: -
Scheduling/trunk/m/BSDX13.m
r968 r1041 1 BSDX13 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:17pm2 ;;1.4 1;BSDX;;Sep 29, 20101 BSDX13 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 6:05pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; Change Log: … … 31 31 ; S %DT="X" D ^%DT 32 32 ; I Y=-1 D ERR(0,"AVDELDT-BSDX13: Invalid End Date") Q 33 S BSDXEND=$P( Y,".")_".99999"33 S BSDXEND=$P(BSDXEND,".")_".99999" 34 34 I '+BSDXRESD D ERR(0,"AVDELDT-BSDX13: Invalid Resource ID") Q 35 35 ; … … 46 46 I '+$G(BSDXI) N BSDXI S BSDXI=999999 47 47 S BSDXI=BSDXI+1 48 D ERR(0,"BSDX13 M Error: <"_$G(%ZTER ROR)_">")48 D ERR(0,"BSDX13 M Error: <"_$G(%ZTERZE)_">") 49 49 Q 50 50 ; -
Scheduling/trunk/m/BSDX14.m
r968 r1041 1 1 BSDX14 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX15.m
r968 r1041 1 1 BSDX15 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX16.m
r968 r1041 1 1 BSDX16 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX17.m
r968 r1041 1 1 BSDX17 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX18.m
r968 r1041 1 1 BSDX18 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX19.m
r968 r1041 1 1 BSDX19 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX20.m
r968 r1041 1 1 BSDX20 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX21.m
r968 r1041 1 1 BSDX21 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/21/10 9:42pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX22.m
r968 r1041 1 1 BSDX22 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX23.m
r968 r1041 1 1 BSDX23 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX24.m
r968 r1041 1 1 BSDX24 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX25.m
r968 r1041 1 1 BSDX25 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX26.m
r1036 r1041 1 BSDX26 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 3:08am2 ;;1.42;BSDX;;Sep 29, 20103 4 5 6 7 8 9 10 11 12 13 EDITAPTD(BSDXY,BSDXAPTID,BSDXNOTE) 14 15 16 17 18 UT 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 EDITAPT(BSDXY,BSDXAPTID,BSDXNOTE) 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30)78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 ERR(BSDXI,BSDXERR) 117 118 119 120 121 122 123 124 125 ETRAP 126 127 128 129 130 131 132 1 BSDX26 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:38pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 ; Change History: 4 ; 3101023 - UJO/SMH - Addition of restartable transaction; relocation of tx. 5 ; --> Thanks to Zach Gonzalez and Rick Marshall 6 ; 3101205 - UJO/SMH - Extensive refactoring. 7 ; 8 ; Error Reference: 9 ; -1: Appt ID is not a number 10 ; -2: Appt IEN is not in ^BSDXAPPT 11 ; -3: FM Failure to file WP field in ^BSDXAPPT 12 ; 13 EDITAPTD(BSDXY,BSDXAPTID,BSDXNOTE) ;EP 14 ;Entry point for debugging 15 ; 16 D DEBUG^%Serenji("EDITAPT^BSDX26(.BSDXY,BSDXAPTID,BSDXNOTE)") 17 Q 18 UT ; Unit Tests 19 ; Test 1: Make sure this damn thing works 20 N ZZZ 21 N %H S %H=$H 22 N NOTE S NOTE="New Note "_%H 23 D EDITAPT(.ZZZ,188,NOTE) 24 I ^BSDXAPPT(188,1,1,0)'=NOTE W "ERROR",! B 25 ; Test 2: Test Errors -1 and -2 26 N ZZZ 27 N NOTE S NOTE="Nothing important" 28 D EDITAPT(.ZZZ,"BLAHBLAH",NOTE) 29 I +^BSDXTMP($J,1)'=-1 W "ERROR IN -1",! B 30 D EDITAPT(.ZZZ,298734322,NOTE) 31 I +^BSDXTMP($J,1)'=-2 W "ERROR IN -2",! B 32 ; Test 4: M Error 33 N bsdxdie S bsdxdie=1 34 D EDITAPT(.ZZZ,188,NOTE) 35 I +^BSDXTMP($J,1)'=-100 W "ERROR IN -100",! B 36 k bsdxdie 37 ; Test 5: Trestart 38 N bsdxrestart S bsdxrestart=1 39 N %H S %H=$H 40 N NOTE S NOTE="New Note "_%H 41 D EDITAPT(.ZZZ,188,NOTE) 42 I ^BSDXAPPT(188,1,1,0)'=NOTE W "ERROR in TRESTART",! B 43 ; Test 6: for Hosp Location Update 44 N DATE S DATE=$$NOW^XLFDT() 45 S DATE=$E(DATE,1,12) ; Just get minutes b/c of HL file input transform 46 D APPADD^BSDX07(.ZZZ,DATE,DATE+.001,3,"Dr Office",30,"Old Note",1) 47 N APPID S APPID=+$P(^BSDXTMP($J,1),U) 48 D EDITAPT(.ZZZ,APPID,"New Note") 49 I ^BSDXAPPT(APTID,1,1,0)'="New Note" W "Error in HL Section",! B 50 I $P(^SC(2,"S",DATE,1,1,0),U,4)'="New Note" W "Error in HL Section",! B 51 QUIT 52 ; 53 EDITAPT(BSDXY,BSDXAPTID,BSDXNOTE) ;EP Edit appointment (only note text can be edited) 54 ; Called by RPC: BSDX EDIT APPOINTMENT 55 ; 56 ; Edits Appointment Text in BSDX APPOINTMENT file & Hosp Location (44) file 57 ; 58 ; Parameters: 59 ; - BSDXY: Global Return (RPC must be set to Global Array) 60 ; - BSDXAPTID: Appointment IEN in BSDX APPOINTMENT 61 ; - BSDXNOTE: New note 62 ; 63 ; Return: 64 ; ADO.net Recordset having 1 field: ERRORID 65 ; If Okay: -1; otherwise, positive integer with message 66 ; 67 ; Return Array; set Return and clear array 68 S BSDXY=$NA(^BSDXTMP($J)) 69 K ^BSDXTMP($J) 70 ; ET 71 N $ET S $ET="G ETRAP^BSDX26" 72 ; Set up basic DUZ variables 73 D ^XBKVAR 74 ; Counter 75 N BSDXI S BSDXI=0 76 ; Header Node 77 S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30) 78 ; Restartable txn for GT.M. Restored vars are Params + BSDXI. 79 TSTART (BSDXY,BSDXAPTID,BSDXNOTE,BSDXI):T="BSDX EDIT APPOINTMENT^BSDX26" 80 ; 81 ;;;test for error inside transaction. See if %ZTER works 82 I $G(bsdxdie) S X=1/0 83 ;;;test 84 ;;;test for TRESTART 85 I $G(bsdxrestart) K bsdxrestart TRESTART 86 ;;;test 87 ; 88 ; Validate Appointment ID 89 I '+BSDXAPTID D ERR(BSDXI,"-1~BSDX26: Invalid Appointment ID") QUIT 90 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-2~BSDX26: Invalid Appointment ID") QUIT 91 ; Put the WP in decendant fields from the root to file as a WP field 92 S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE="" 93 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0) 94 N BSDXMSG ; Message in case of error in filing. 95 I $D(BSDXNOTE(.5)) D 96 . D WP^DIE(9002018.4,BSDXAPTID_",",1,"","BSDXNOTE","BSDXMSG") 97 I $D(BSDXMSG) D ERR(BSDXI,"-3~BSDX26: Fileman failure to file data into 9002018.4") QUIT 98 ; 99 ; Now file in file 44: 100 N PTIEN S PTIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".05","I") ; Patient IEN 101 N HLIEN S HLIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".07:.04","I") ; HL Location IEN pointed to by Resource ID 102 N DATE S DATE=+^BSDXAPPT(BSDXAPTID,0) ; Date of APPT 103 N BSDXRES S BSDXRES=0 ; Result 104 ; Update Note only if we have a linked hospital location. 105 I HLIEN S BSDXRES=$$UPDATENOTE^BSDXAPI(PTIEN,HLIEN,DATE,BSDXNOTE(.5)) 106 ; If we get an error (denoted by -1 in BSDXRES), return error to client 107 I BSDXRES<0 D ERR(BSDXI,"-4~BSDX26: BSDXAPI reports an error: "_BSDXRES) QUIT 108 ;Return Recordset 109 TCOMMIT 110 S BSDXI=BSDXI+1 111 S ^BSDXTMP($J,BSDXI)="-1"_$C(30) 112 S BSDXI=BSDXI+1 113 S ^BSDXTMP($J,BSDXI)=$C(31) 114 QUIT 115 ; 116 ERR(BSDXI,BSDXERR) ;Error processing 117 S BSDXI=BSDXI+1 118 S BSDXERR=$TR(BSDXERR,"^","~") 119 I $TL>0 TROLLBACK 120 S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30) 121 S BSDXI=BSDXI+1 122 S ^BSDXTMP($J,BSDXI)=$C(31) 123 QUIT 124 ; 125 ETRAP ;EP Error trap entry 126 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 127 I $TL>0 TROLLBACK 128 D ^%ZTER 129 S $EC="" 130 I '$D(BSDXI) N BSDXI S BSDXI=0 131 D ERR(BSDXI,"-100~BSDX26 Error: "_$G(%ZTERZE)) 132 Q -
Scheduling/trunk/m/BSDX27.m
r968 r1041 1 BSDX27 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:22pm2 ;;1.41;BSDX;;Sep 29, 20101 BSDX27 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 4:52pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; Change Log: July 15, 2010 5 ; UJO/SMH - i18n: FM Dates passed into routine for Clinic Letters - CLDISP tag 6 ; 7 ; 8 Q 9 ; 10 PADISPD(BSDXY,BSDXPAT) ;EP 11 ;Entry point for debugging 12 ; 13 ;D DEBUG^%Serenji("PADISP^BSDX27(.BSDXY,BSDXPAT)") 14 Q 15 ; 16 PADISP(BSDXY,BSDXPAT) ;EP 17 ;Return recordset of patient appointments used in listing 18 ;a patient's appointments and generating patient letters. 19 ;Called by rpc BSDX PATIENT APPT DISPLAY 20 ; 21 N BSDXI,BSDXIEN,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCNID,BSDXCNOD,BSDXMADE,BSDXCLRK,BSDXNOT,BSDXQ 22 N BSDXSTRT 23 N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON 24 S BSDXY="^BSDXTMP("_$J_")" 25 S BSDXI=0 26 S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus" 27 S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30) 28 S X="ERROR^BSDX27",@^%ZOSF("TRAP") 29 ;Get patient info 30 ; 31 I '+BSDXPAT S ^BSDXTMP($J,1)=$C(31) Q 32 I '$D(^DPT(+BSDXPAT,0)) S ^BSDXTMP($J,1)=$C(31) Q 33 S BSDXNOD=$$PATINFO(BSDXPAT) 34 S BSDXNAM=$P(BSDXNOD,U) ;NAME 35 S BSDXSEX=$P(BSDXNOD,U,2) ;SEX 36 S BSDXDOB=$P(BSDXNOD,U,3) ;DOB 37 S BSDXHRN=$P(BSDXNOD,U,4) ;Health Record Number for location DUZ(2) 38 S BSDXSTRE=$P(BSDXNOD,U,5) ;Street 39 S BSDXCITY=$P(BSDXNOD,U,6) ;City 40 S BSDXST=$P(BSDXNOD,U,7) ;State 41 S BSDXZIP=$P(BSDXNOD,U,8) ;zip 42 S BSDXPHON=$P(BSDXNOD,U,9) ;homephone 43 ; 44 ;Organize ^DPT(BSDXPAT,"S," nodes 45 ; into BSDXDPT(CLINIC,DATE) 46 ; 47 I $D(^DPT(BSDXPAT,"S")) S BSDXDT=0 F S BSDXDT=$O(^DPT(BSDXPAT,"S",BSDXDT)) Q:'+BSDXDT D 48 . S BSDXNOD=$G(^DPT(BSDXPAT,"S",BSDXDT,0)) 49 . S BSDXCID=$P(BSDXNOD,U) 50 . Q:'+BSDXCID 51 . Q:'$D(^SC(BSDXCID,0)) 52 . S BSDXDPT(BSDXCID,BSDXDT)=BSDXNOD 53 ; 54 ;$O Through ^BSDX("CPAT", 55 S BSDXIEN=0 56 I $D(^BSDXAPPT("CPAT",BSDXPAT)) F S BSDXIEN=$O(^BSDXAPPT("CPAT",BSDXPAT,BSDXIEN)) Q:'BSDXIEN D 57 . N BSDXNOD,BSDXAPT,BSDXCID,BSDXCNOD,BSDXCLN,BSDX44,BSDXDNOD,BSDXSTAT,BSDX,BSDXTYPE,BSDXLIN 58 . S BSDXNOD=$G(^BSDXAPPT(BSDXIEN,0)) 59 . Q:BSDXNOD="" 60 . Q:$P(BSDXNOD,U,12)]"" ;CANCELLED 61 . S Y=$P(BSDXNOD,U) 62 . Q:'+Y 63 . X ^DD("DD") S Y=$TR(Y,"@"," ") 64 . S BSDXAPT=Y ;Appointment date time 65 . S BSDXCLRK=$P(BSDXNOD,U,8) ;Appointment made by 66 . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U) 67 . S Y=$P(BSDXNOD,U,9) ;Date Appointment Made 68 . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ") 69 . S BSDXMADE=Y 70 . ;NOTE 71 . S BSDXNOT="" 72 . I $D(^BSDXAPPT(BSDXIEN,1,0)) S BSDXNOT="",BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXIEN,1,BSDXQ)) Q:'+BSDXQ D 73 . . S BSDXLIN=$G(^BSDXAPPT(BSDXIEN,1,BSDXQ,0)) 74 . . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" " 75 . . S BSDXNOT=BSDXNOT_BSDXLIN 76 . ;Resource 77 . S BSDXCID=$P(BSDXNOD,U,7) ;IEN of BSDX RESOURCE 78 . Q:'+BSDXCID 79 . Q:'$D(^BSDXRES(BSDXCID,0)) 80 . S BSDXCNOD=$G(^BSDXRES(BSDXCID,0)) ;BSDX RESOURCE node 81 . Q:BSDXCNOD="" 82 . S BSDXCLN=$P(BSDXCNOD,U) ;Text name of BSDX Resource 83 . S BSDX44=$P(BSDXCNOD,U,4) ;File 44 pointer 84 . ;If appt entry in ^DPT(PAT,"S" exists for this clinic, get the TYPE/STATUS info from 85 . ;the BSDXDPT array and delete the BSDXDPT node 86 . S BSDXTYPE="" 87 . I +BSDX44,$D(BSDXDPT(BSDX44,$P(BSDXNOD,U))) D ;BSDXNOD is the BSDX APPOINTMENT node 88 . . S BSDXDNOD=BSDXDPT(BSDX44,$P(BSDXNOD,U)) ;BSDXDNOD is a copy of the ^DPT(PAT,"S" node 89 . . S BSDXTYPE=$$STATUS(BSDXPAT,$P(BSDXNOD,U),BSDXDNOD) ;IHS/OIT/HMW 20050208 Added 90 . . K BSDXDPT(BSDX44,$P(BSDXNOD,U)) 91 . S BSDXI=BSDXI+1 92 . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30) 93 . Q 94 ; 95 ;Go through remaining BSDXDPT( entries 96 I $D(BSDXDPT) S BSDX44=0 D 97 . F S BSDX44=$O(BSDXDPT(BSDX44)) Q:'+BSDX44 S BSDXDT=0 D 98 . . F S BSDXDT=$O(BSDXDPT(BSDX44,BSDXDT)) Q:'+BSDXDT D 99 . . . S BSDXDNOD=BSDXDPT(BSDX44,BSDXDT) 100 . . . S Y=BSDXDT 101 . . . Q:'+Y 102 . . . X ^DD("DD") S Y=$TR(Y,"@"," ") 103 . . . S BSDXAPT=Y 104 . . . S BSDXTYPE=$$STATUS(BSDXPAT,BSDXDT,BSDXDNOD) ;IHS/OIT/HMW 20050208 Added 105 . . . S BSDXCLN=$P($G(^SC(BSDX44,0)),U) 106 . . . S BSDXCLRK=$P(BSDXDNOD,U,18) 107 . . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U) 108 . . . S Y=$P(BSDXDNOD,U,19) 109 . . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ") 110 . . . S BSDXMADE=Y 111 . . . S BSDXNOT="" 112 . . . S BSDXI=BSDXI+1 113 . . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30) 114 . . . K BSDXDPT(BSDX44,BSDXDT) 115 ; 116 S BSDXI=BSDXI+1 117 S ^BSDXTMP($J,BSDXI)=$C(31) 118 Q 119 ; 120 STATUS(PAT,DATE,NODE) ; returns appt status 121 ;IHS/OIT/HMW 20050208 Added from BSDDPA 122 NEW TYP 123 S TYP=$$APPTYP^BSDXAPI(PAT,DATE) ;sched vs. walkin 124 I $P(NODE,U,2)["C" Q TYP_" - CANCELLED" 125 I $P(NODE,U,2)'="NT",$P(NODE,U,2)["N" Q TYP_" - NO SHOW" 126 I $$CO^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED OUT" 127 I $$CI^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED IN" 128 Q TYP 129 ; 130 ERROR ; 131 D ERR(BSDXI,"RPMS Error") 132 Q 133 ; 134 ERR(BSDXI,ERRNO,MSG) ;Error processing 135 S:'$D(BSDXI) BSDXI=999 136 I +ERRNO S BSDXERR=ERRNO+134234112 ;vbObjectError 137 E S BSDXERR=ERRNO 138 S BSDXI=BSDXI+1 139 S ^BSDXTMP($J,BSDXI)=MSG_"^^^^^^^^^^^^^^^"_$C(30) 140 S BSDXI=BSDXI+1 141 S ^BSDXTMP($J,BSDXI)=$C(31) 142 Q 143 PATINFO(BSDXPAT) ;EP 144 ;Intrisic Function returns NAME^SEX^DOB^HRN^STREET^CITY^STATE^ZIP^PHONE for patient ien BSDXPAT 145 ;DOB is in external format 146 ;HRN depends on existence of DUZ(2) 147 ; 148 N BSDXNOD,BSDXNAM,BSDXSEX,BSDXDOB,BSDXHRN,BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON 149 S BSDXNOD=^DPT(+BSDXPAT,0) 150 S BSDXNAM=$P(BSDXNOD,U) ;NAME 151 S BSDXSEX=$P(BSDXNOD,U,2) 152 S BSDXSEX=$S(BSDXSEX="F":"FEMALE",BSDXSEX="M":"MALE",1:"") 153 S Y=$P(BSDXNOD,U,3) I Y]"" X ^DD("DD") S Y=$TR(Y,"@"," ") 154 S BSDXDOB=Y ;DOB 155 S BSDXHRN="" 156 I $D(DUZ(2)) I DUZ(2)>0 S BSDXHRN=$P($G(^AUPNPAT(BSDXPAT,41,DUZ(2),0)),U,2) ;HRN 157 ; 158 S BSDXNOD=$G(^DPT(+BSDXPAT,.11)) 159 S (BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP)="" 160 I BSDXNOD]"" D 161 . S BSDXSTRT=$E($P(BSDXNOD,U),1,50) ;STREET 162 . S BSDXCITY=$P(BSDXNOD,U,4) ;CITY 163 . S BSDXST=$P(BSDXNOD,U,5) ;STATE 164 . I +BSDXST,$D(^DIC(5,+BSDXST,0)) S BSDXST=$P(^DIC(5,+BSDXST,0),U,2) 165 . S BSDXZIP=$P(BSDXNOD,U,6) ;ZIP 166 ; 167 S BSDXNOD=$G(^DPT(+BSDXPAT,.13)) ;PHONE 168 S BSDXPHON=$P(BSDXNOD,U) 169 ; 170 Q BSDXNAM_U_BSDXSEX_U_BSDXDOB_U_BSDXHRN_U_BSDXSTRT_U_BSDXCITY_U_BSDXST_U_BSDXZIP_U_BSDXPHON 171 ; 5 ; UJO/SMH - i18n: FM Dates passed into routine for Clinic Letters - CLDISP ta 6 ; v 1.42 - 3101208 - SMH 7 ; - Added check to skip cancelled appointments. Check was forgotten 8 ; in original code. 9 ; . N BSDXFLAGS S BSDXFLAGS=$P(BSDXNOD,U,2) ; No show and Cancel Flags 10 ; . Q:BSDXFLAGS["C" ; if appt is cancelled, quit 11 ; 12 Q 13 ; 14 PADISPD(BSDXY,BSDXPAT) ;EP 15 ;Entry point for debugging 16 ; 17 ;D DEBUG^%Serenji("PADISP^BSDX27(.BSDXY,BSDXPAT)") 18 Q 19 ; 20 PADISP(BSDXY,BSDXPAT) ;EP 21 ;Return recordset of patient appointments used in listing 22 ;a patient's appointments and generating patient letters. 23 ;Called by rpc BSDX PATIENT APPT DISPLAY 24 ; 25 ; Sam's Notes: 26 ; Relatively complex algorithm. 27 ; 1. First, loop through ^DPT(DA,"S", and get all appointments. 28 ; Exclude cancelled appts. Store in BSDXDPT array. 29 ; 2. Go through ^BSDXAPPT("CPAT", (patient index) . 30 ; Get the info from there and compar with BSDXDPT array. If 31 ; they are the same, get all info, and rm entry from BSDXDPT array. 32 ; 3. If there are any remaining entries in BSDXDPT (PIMS leftovers), 33 ; Get the data from file 2 and 44. 34 ; 35 N BSDXI,BSDXIEN,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCNID,BSDXCNOD,BSDXMADE,BSDXCLRK,BSDXNOT,BSDXQ 36 N BSDXSTRT 37 N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON 38 S BSDXY="^BSDXTMP("_$J_")" 39 S BSDXI=0 40 S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus" 41 S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30) 42 S X="ERROR^BSDX27",@^%ZOSF("TRAP") 43 ;Get patient info 44 ; 45 I '+BSDXPAT S ^BSDXTMP($J,1)=$C(31) Q 46 I '$D(^DPT(+BSDXPAT,0)) S ^BSDXTMP($J,1)=$C(31) Q 47 S BSDXNOD=$$PATINFO(BSDXPAT) 48 S BSDXNAM=$P(BSDXNOD,U) ;NAME 49 S BSDXSEX=$P(BSDXNOD,U,2) ;SEX 50 S BSDXDOB=$P(BSDXNOD,U,3) ;DOB 51 S BSDXHRN=$P(BSDXNOD,U,4) ;Health Record Number for location DUZ(2) 52 S BSDXSTRE=$P(BSDXNOD,U,5) ;Street 53 S BSDXCITY=$P(BSDXNOD,U,6) ;City 54 S BSDXST=$P(BSDXNOD,U,7) ;State 55 S BSDXZIP=$P(BSDXNOD,U,8) ;zip 56 S BSDXPHON=$P(BSDXNOD,U,9) ;homephone 57 ; 58 ;Organize ^DPT(BSDXPAT,"S," nodes 59 ; into BSDXDPT(CLINIC,DATE) 60 ; 61 I $D(^DPT(BSDXPAT,"S")) S BSDXDT=0 F S BSDXDT=$O(^DPT(BSDXPAT,"S",BSDXDT)) Q:'+BSDXDT D 62 . S BSDXNOD=$G(^DPT(BSDXPAT,"S",BSDXDT,0)) 63 . S BSDXCID=$P(BSDXNOD,U) 64 . Q:'+BSDXCID 65 . Q:'$D(^SC(BSDXCID,0)) 66 . N BSDXFLAGS S BSDXFLAGS=$P(BSDXNOD,U,2) ; No show and Cancel Flags 67 . Q:BSDXFLAGS["C" ; if appt is cancelled, quit 68 . S BSDXDPT(BSDXCID,BSDXDT)=BSDXNOD 69 ; 70 ;$O Through ^BSDX("CPAT", 71 S BSDXIEN=0 72 I $D(^BSDXAPPT("CPAT",BSDXPAT)) F S BSDXIEN=$O(^BSDXAPPT("CPAT",BSDXPAT,BSDXIEN)) Q:'BSDXIEN D 73 . N BSDXNOD,BSDXAPT,BSDXCID,BSDXCNOD,BSDXCLN,BSDX44,BSDXDNOD,BSDXSTAT,BSDX,BSDXTYPE,BSDXLIN 74 . S BSDXNOD=$G(^BSDXAPPT(BSDXIEN,0)) 75 . Q:BSDXNOD="" 76 . Q:$P(BSDXNOD,U,12)]"" ;CANCELLED 77 . S Y=$P(BSDXNOD,U) 78 . Q:'+Y 79 . X ^DD("DD") S Y=$TR(Y,"@"," ") 80 . S BSDXAPT=Y ;Appointment date time 81 . S BSDXCLRK=$P(BSDXNOD,U,8) ;Appointment made by 82 . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U) 83 . S Y=$P(BSDXNOD,U,9) ;Date Appointment Made 84 . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ") 85 . S BSDXMADE=Y 86 . ;NOTE 87 . S BSDXNOT="" 88 . I $D(^BSDXAPPT(BSDXIEN,1,0)) S BSDXNOT="",BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXIEN,1,BSDXQ)) Q:'+BSDXQ D 89 . . S BSDXLIN=$G(^BSDXAPPT(BSDXIEN,1,BSDXQ,0)) 90 . . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" " 91 . . S BSDXNOT=BSDXNOT_BSDXLIN 92 . ;Resource 93 . S BSDXCID=$P(BSDXNOD,U,7) ;IEN of BSDX RESOURCE 94 . Q:'+BSDXCID 95 . Q:'$D(^BSDXRES(BSDXCID,0)) 96 . S BSDXCNOD=$G(^BSDXRES(BSDXCID,0)) ;BSDX RESOURCE node 97 . Q:BSDXCNOD="" 98 . S BSDXCLN=$P(BSDXCNOD,U) ;Text name of BSDX Resource 99 . S BSDX44=$P(BSDXCNOD,U,4) ;File 44 pointer 100 . ;If appt entry in ^DPT(PAT,"S" exists for this clinic, get the TYPE/STATUS info from 101 . ;the BSDXDPT array and delete the BSDXDPT node 102 . S BSDXTYPE="" 103 . I +BSDX44,$D(BSDXDPT(BSDX44,$P(BSDXNOD,U))) D ;BSDXNOD is the BSDX APPOINTMENT node 104 . . S BSDXDNOD=BSDXDPT(BSDX44,$P(BSDXNOD,U)) ;BSDXDNOD is a copy of the ^DPT(PAT,"S" node 105 . . S BSDXTYPE=$$STATUS(BSDXPAT,$P(BSDXNOD,U),BSDXDNOD) ;IHS/OIT/HMW 20050208 Added 106 . . K BSDXDPT(BSDX44,$P(BSDXNOD,U)) 107 . S BSDXI=BSDXI+1 108 . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30) 109 . Q 110 ; 111 ;Go through remaining BSDXDPT( entries 112 I $D(BSDXDPT) S BSDX44=0 D 113 . F S BSDX44=$O(BSDXDPT(BSDX44)) Q:'+BSDX44 S BSDXDT=0 D 114 . . F S BSDXDT=$O(BSDXDPT(BSDX44,BSDXDT)) Q:'+BSDXDT D 115 . . . S BSDXDNOD=BSDXDPT(BSDX44,BSDXDT) 116 . . . S Y=BSDXDT 117 . . . Q:'+Y 118 . . . X ^DD("DD") S Y=$TR(Y,"@"," ") 119 . . . S BSDXAPT=Y 120 . . . S BSDXTYPE=$$STATUS(BSDXPAT,BSDXDT,BSDXDNOD) ;IHS/OIT/HMW 20050208 Added 121 . . . S BSDXCLN=$P($G(^SC(BSDX44,0)),U) 122 . . . S BSDXCLRK=$P(BSDXDNOD,U,18) 123 . . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U) 124 . . . S Y=$P(BSDXDNOD,U,19) 125 . . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ") 126 . . . S BSDXMADE=Y 127 . . . S BSDXNOT="" 128 . . . S BSDXI=BSDXI+1 129 . . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30) 130 . . . K BSDXDPT(BSDX44,BSDXDT) 131 ; 132 S BSDXI=BSDXI+1 133 S ^BSDXTMP($J,BSDXI)=$C(31) 134 Q 135 ; 136 STATUS(PAT,DATE,NODE) ; returns appt status 137 ;IHS/OIT/HMW 20050208 Added from BSDDPA 138 NEW TYP 139 S TYP=$$APPTYP^BSDXAPI(PAT,DATE) ;sched vs. walkin 140 I $P(NODE,U,2)["C" Q TYP_" - CANCELLED" 141 I $P(NODE,U,2)'="NT",$P(NODE,U,2)["N" Q TYP_" - NO SHOW" 142 I $$CO^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED OUT" 143 I $$CI^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED IN" 144 Q TYP 145 ; 146 ERROR ; 147 D ERR(BSDXI,"RPMS Error") 148 Q 149 ; 150 ERR(BSDXI,ERRNO,MSG) ;Error processing 151 S:'$D(BSDXI) BSDXI=999 152 I +ERRNO S BSDXERR=ERRNO+134234112 ;vbObjectError 153 E S BSDXERR=ERRNO 154 S BSDXI=BSDXI+1 155 S ^BSDXTMP($J,BSDXI)=MSG_"^^^^^^^^^^^^^^^"_$C(30) 156 S BSDXI=BSDXI+1 157 S ^BSDXTMP($J,BSDXI)=$C(31) 158 Q 159 PATINFO(BSDXPAT) ;EP 160 ;Intrisic Function returns NAME^SEX^DOB^HRN^STREET^CITY^STATE^ZIP^PHONE for patient ien BSDXPAT 161 ;DOB is in external format 162 ;HRN depends on existence of DUZ(2) 163 ; 164 N BSDXNOD,BSDXNAM,BSDXSEX,BSDXDOB,BSDXHRN,BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON 165 S BSDXNOD=^DPT(+BSDXPAT,0) 166 S BSDXNAM=$P(BSDXNOD,U) ;NAME 167 S BSDXSEX=$P(BSDXNOD,U,2) 168 S BSDXSEX=$S(BSDXSEX="F":"FEMALE",BSDXSEX="M":"MALE",1:"") 169 S Y=$P(BSDXNOD,U,3) I Y]"" X ^DD("DD") S Y=$TR(Y,"@"," ") 170 S BSDXDOB=Y ;DOB 171 S BSDXHRN="" 172 I $D(DUZ(2)) I DUZ(2)>0 S BSDXHRN=$P($G(^AUPNPAT(BSDXPAT,41,DUZ(2),0)),U,2) ;HRN 173 ; 174 S BSDXNOD=$G(^DPT(+BSDXPAT,.11)) 175 S (BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP)="" 176 I BSDXNOD]"" D 177 . S BSDXSTRT=$E($P(BSDXNOD,U),1,50) ;STREET 178 . S BSDXCITY=$P(BSDXNOD,U,4) ;CITY 179 . S BSDXST=$P(BSDXNOD,U,5) ;STATE 180 . I +BSDXST,$D(^DIC(5,+BSDXST,0)) S BSDXST=$P(^DIC(5,+BSDXST,0),U,2) 181 . S BSDXZIP=$P(BSDXNOD,U,6) ;ZIP 182 ; 183 S BSDXNOD=$G(^DPT(+BSDXPAT,.13)) ;PHONE 184 S BSDXPHON=$P(BSDXNOD,U) 185 ; 186 Q BSDXNAM_U_BSDXSEX_U_BSDXDOB_U_BSDXHRN_U_BSDXSTRT_U_BSDXCITY_U_BSDXST_U_BSDXZIP_U_BSDXPHON 187 ; 172 188 CLDISPD(BSDXY,BSDXCLST,BSDXBEG,BSDXEND) ;EP 173 ;Entry point for debugging174 ;175 ;D DEBUG^%Serenji("CLDISP^BSDX27(.BSDXY,BSDXCLST,BSDXBEG,BSDXEND)")176 Q177 ;178 CLDISP(BSDXY,BSDXCLST,BSDXBEG,BSDXEND) ;EP179 ;180 ;Return recordset of patient appointments181 ;between dates BSDXBEG and BSDXEND for each clinic in BSDXCLST.182 ;Used in listing a patient's appointments and generating patient letters.183 ;BSDXCLST is a |-delimited list of BSDX RESOURCE iens. (The last |-piece is null, so discard it.)184 ;BSDXBEG and BSDXEND are in external date form.185 ;Called by BSDX CLINIC LETTERS186 ;187 ; July 10, 2010 -- to support i18n, we pass dates from client in188 ; locale-neutral Fileman format. No need to convert it.189 N BSDXI,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCID,BSDXCNOD,BSDXDT190 N BSDXJ,BSDXAID,BSDXPAT,BSDXPNOD,BSDXCLN,BSDXCLRK,BSDXMADE,BSDXNOT,BSDXLIN191 N BSDXSTRT192 N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON193 S BSDXY="^BSDXTMP("_$J_")"194 K ^BSDXTMP($J)195 S BSDXI=0196 S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus"197 S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30)198 S X="ERROR^BSDX27",@^%ZOSF("TRAP")199 ;200 ;Convert beginning and ending dates201 ;202 S BSDXBEG=BSDXBEG-1,BSDXBEG=BSDXBEG_".9999"203 S BSDXEND=BSDXEND_".9999"204 I BSDXCLST="" D ERR(BSDXI,0,"Routine: BSDX27, Error: Null clinic list") Q205 ;206 ;For each clinic in BSDXCLST $O through ^BSDXAPPT("ARSRC",ResourceIEN,FMDate,ApptIEN)207 ;208 F BSDXJ=1:1:$L(BSDXCLST,"|")-1 S BSDXCID=$P(BSDXCLST,"|",BSDXJ) D209 . S BSDXCLN=$G(^BSDXRES(BSDXCID,0)) S BSDXCLN=$P(BSDXCLN,U) Q:BSDXCLN=""210 . S BSDXSTRT=BSDXBEG F S BSDXSTRT=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT)) Q:'+BSDXSTRT Q:BSDXSTRT>BSDXEND D211 . . S BSDXAID=0 F S BSDXAID=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT,BSDXAID)) Q:'+BSDXAID D212 . . . S BSDXNOD=$G(^BSDXAPPT(BSDXAID,0))213 . . . Q:BSDXNOD=""214 . . . Q:$P(BSDXNOD,U,12)]"" ;CANCELLED215 . . . Q:$P(BSDXNOD,U,13)="y" ;WALKIN216 . . . S Y=$P(BSDXNOD,U)217 . . . Q:'+Y218 . . . X ^DD("DD") S Y=$TR(Y,"@"," ")219 . . . S BSDXAPT=Y ;Appointment date time220 . . . ;221 . . . ;NOTE222 . . . S BSDXNOT=""223 . . . I $D(^BSDXAPPT(BSDXAID,1,0)) S BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXAID,1,BSDXQ)) Q:'+BSDXQ D224 . . . . S BSDXLIN=$G(^BSDXAPPT(BSDXAID,1,BSDXQ,0))225 . . . . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" "226 . . . . S BSDXNOT=BSDXNOT_BSDXLIN227 . . . ;228 . . . S BSDXPAT=$P(BSDXNOD,U,5)229 . . . S BSDXPNOD=$$PATINFO(BSDXPAT)230 . . . S BSDXNAM=$P(BSDXPNOD,U) ;NAME231 . . . S BSDXSEX=$P(BSDXPNOD,U,2) ;SEX232 . . . S BSDXDOB=$P(BSDXPNOD,U,3) ;DOB233 . . . S BSDXHRN=$P(BSDXPNOD,U,4) ;Health Record Number for location DUZ(2)234 . . . S BSDXSTRE=$P(BSDXPNOD,U,5) ;Street235 . . . S BSDXCITY=$P(BSDXPNOD,U,6) ;City236 . . . S BSDXST=$P(BSDXPNOD,U,7) ;State237 . . . S BSDXZIP=$P(BSDXPNOD,U,8) ;zip238 . . . S BSDXPHON=$P(BSDXPNOD,U,9) ;homephone239 . . . S BSDXTYPE="" ;Type/status doesn't exist for BSDX APPT clinics and it's not needed for clinic letters240 . . . S BSDXCLRK=$P(BSDXNOD,U,8)241 . . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U)242 . . . S Y=$P(BSDXNOD,U,9)243 . . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ")244 . . . S BSDXMADE=Y245 . . . S BSDXI=BSDXI+1246 . . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30)247 ;248 S BSDXI=BSDXI+1249 S ^BSDXTMP($J,BSDXI)=$C(31)250 Q189 ;Entry point for debugging 190 ; 191 ;D DEBUG^%Serenji("CLDISP^BSDX27(.BSDXY,BSDXCLST,BSDXBEG,BSDXEND)") 192 Q 193 ; 194 CLDISP(BSDXY,BSDXCLST,BSDXBEG,BSDXEND) ;EP 195 ; 196 ;Return recordset of patient appointments 197 ;between dates BSDXBEG and BSDXEND for each clinic in BSDXCLST. 198 ;Used in listing a patient's appointments and generating patient letters. 199 ;BSDXCLST is a |-delimited list of BSDX RESOURCE iens. (The last |-piece is null, so discard it.) 200 ;BSDXBEG and BSDXEND are in external date form. 201 ;Called by BSDX CLINIC LETTERS 202 ; 203 ; July 10, 2010 -- to support i18n, we pass dates from client in 204 ; locale-neutral Fileman format. No need to convert it. 205 N BSDXI,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCID,BSDXCNOD,BSDXDT 206 N BSDXJ,BSDXAID,BSDXPAT,BSDXPNOD,BSDXCLN,BSDXCLRK,BSDXMADE,BSDXNOT,BSDXLIN 207 N BSDXSTRT 208 N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON 209 S BSDXY="^BSDXTMP("_$J_")" 210 K ^BSDXTMP($J) 211 S BSDXI=0 212 S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus" 213 S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30) 214 S X="ERROR^BSDX27",@^%ZOSF("TRAP") 215 ; 216 ;Convert beginning and ending dates 217 ; 218 S BSDXBEG=BSDXBEG-1,BSDXBEG=BSDXBEG_".9999" 219 S BSDXEND=BSDXEND_".9999" 220 I BSDXCLST="" D ERR(BSDXI,0,"Routine: BSDX27, Error: Null clinic list") Q 221 ; 222 ;For each clinic in BSDXCLST $O through ^BSDXAPPT("ARSRC",ResourceIEN,FMDate,ApptIEN) 223 ; 224 F BSDXJ=1:1:$L(BSDXCLST,"|")-1 S BSDXCID=$P(BSDXCLST,"|",BSDXJ) D 225 . S BSDXCLN=$G(^BSDXRES(BSDXCID,0)) S BSDXCLN=$P(BSDXCLN,U) Q:BSDXCLN="" 226 . S BSDXSTRT=BSDXBEG F S BSDXSTRT=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT)) Q:'+BSDXSTRT Q:BSDXSTRT>BSDXEND D 227 . . S BSDXAID=0 F S BSDXAID=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT,BSDXAID)) Q:'+BSDXAID D 228 . . . S BSDXNOD=$G(^BSDXAPPT(BSDXAID,0)) 229 . . . Q:BSDXNOD="" 230 . . . Q:$P(BSDXNOD,U,12)]"" ;CANCELLED 231 . . . Q:$P(BSDXNOD,U,13)="y" ;WALKIN 232 . . . S Y=$P(BSDXNOD,U) 233 . . . Q:'+Y 234 . . . X ^DD("DD") S Y=$TR(Y,"@"," ") 235 . . . S BSDXAPT=Y ;Appointment date time 236 . . . ; 237 . . . ;NOTE 238 . . . S BSDXNOT="" 239 . . . I $D(^BSDXAPPT(BSDXAID,1,0)) S BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXAID,1,BSDXQ)) Q:'+BSDXQ D 240 . . . . S BSDXLIN=$G(^BSDXAPPT(BSDXAID,1,BSDXQ,0)) 241 . . . . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" " 242 . . . . S BSDXNOT=BSDXNOT_BSDXLIN 243 . . . ; 244 . . . S BSDXPAT=$P(BSDXNOD,U,5) 245 . . . S BSDXPNOD=$$PATINFO(BSDXPAT) 246 . . . S BSDXNAM=$P(BSDXPNOD,U) ;NAME 247 . . . S BSDXSEX=$P(BSDXPNOD,U,2) ;SEX 248 . . . S BSDXDOB=$P(BSDXPNOD,U,3) ;DOB 249 . . . S BSDXHRN=$P(BSDXPNOD,U,4) ;Health Record Number for location DUZ(2) 250 . . . S BSDXSTRE=$P(BSDXPNOD,U,5) ;Street 251 . . . S BSDXCITY=$P(BSDXPNOD,U,6) ;City 252 . . . S BSDXST=$P(BSDXPNOD,U,7) ;State 253 . . . S BSDXZIP=$P(BSDXPNOD,U,8) ;zip 254 . . . S BSDXPHON=$P(BSDXPNOD,U,9) ;homephone 255 . . . S BSDXTYPE="" ;Type/status doesn't exist for BSDX APPT clinics and it's not needed for clinic letters 256 . . . S BSDXCLRK=$P(BSDXNOD,U,8) 257 . . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U) 258 . . . S Y=$P(BSDXNOD,U,9) 259 . . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ") 260 . . . S BSDXMADE=Y 261 . . . S BSDXI=BSDXI+1 262 . . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30) 263 ; 264 S BSDXI=BSDXI+1 265 S ^BSDXTMP($J,BSDXI)=$C(31) 266 Q -
Scheduling/trunk/m/BSDX28.m
r968 r1041 1 1 BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:30pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; Change Log: -
Scheduling/trunk/m/BSDX29.m
r1036 r1041 1 BSDX29 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 6:05am2 ;;1.42;BSDX;; Sep 29, 20101 BSDX29 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:39pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; Change Log: 5 5 ; v1.3 by WV/SMH on 3100713 6 6 ; - Beginning and Ending dates passed as FM Dates 7 8 9 10 7 ; v1.42 by WV/SMH on 3101023 8 ; - Transaction moved; now restartable too. 9 ; --> Thanks to Zach Gonzalez and Rick Marshall. 10 ; - Refactoring of major portions of routine 11 11 ; 12 12 BSDXCPD(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND) ;EP … … 19 19 ;Copy appointments from HOSPITAL LOCATION entry BSDX44 to BSDX RESOURCE entry BSDXRES 20 20 ;Beginning with appointments on day BSDXBEG and ending on BSDXEND, inclusive 21 22 ; 23 24 25 26 27 28 29 21 ;Called by RPC: BSDX COPY APPOINTMENTS 22 ; 23 ; Parameters: 24 ; - BSDXY: Global Return 25 ; - BSDXRES: BSDX RESOURCE to copy appointments to 26 ; - BSDX44: Hospital Location IEN to copy appointments from 27 ; - BSDXBEG: Beginning Date in FM Format 28 ; - BSDXEND: End Date in FM Format 29 ; 30 30 ;Returns ADO Recordset containing TASK_NUMBER and ERRORID 31 31 ; 32 32 ; Return Array 33 33 S BSDXY=$NA(^BSDXTMP($J)) 34 35 36 34 K ^BSDXTMP($J) 35 ; $ET 36 N $ET S $ET="G ETRAP^BSDX29" 37 37 ; Counter 38 39 40 S ^BSDXTMP($J,0)="T00010TASK_NUMBER^T00 020ERRORID"_$C(30)41 ; 42 43 38 N BSDXI S BSDXI=0 39 ; Header Node 40 S ^BSDXTMP($J,0)="T00010TASK_NUMBER^T00100ERRORID"_$C(30) 41 ; 42 ; Make dates inclusive; add 1 to FM dates 43 S BSDXBEG=BSDXBEG-1 44 44 S BSDXEND=BSDXEND+1 45 45 ; 46 47 46 ; Taskman variables 47 N ZTSK,ZTRTN,ZTDTH,ZTDESC,ZTSAVE 48 48 ; Task Load 49 49 S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS" … … 61 61 ; 62 62 ZTM ;EP - Taskman entry point 63 64 63 ; Variables set up in ZTSAVE above 64 ; 65 65 Q:'$D(ZTSK) 66 67 66 ; $ET 67 N $ET S $ET="G ZTMERR^BSDX29" 68 68 ; Txn 69 69 TSTART (BSDXBEG,BSDXEND,BSDX44,BSDXRES):T="BSDX COPY APPOINTMENT^BSDX29" 70 70 ;$O through ^SC(BSDX44,"S", 71 71 N BSDXCNT S BSDXCNT=0 ; Count of Copied Appointments 72 72 N BSDXQUIT S BSDXQUIT=0 ; Quit Flag to be retrieved from an external proc 73 73 ; Set Count 74 74 S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT 75 75 ; Loop through dates here. 76 77 78 79 76 F S BSDXBEG=$O(^SC(BSDX44,"S",BSDXBEG)) Q:'+BSDXBEG Q:BSDXBEG>BSDXEND Q:BSDXQUIT D 77 . ; Loop through Entries in each date in the subsubfile. 78 . ; Quit if we are at the end or if a remote process requests a quit. 79 . N BSDXIEN S BSDXIEN=0 80 80 . F S BSDXIEN=$O(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN)) Q:'+BSDXIEN Q:BSDXQUIT D 81 81 . . N BSDXNOD S BSDXNOD=$G(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN,0)) ; Node … … 83 83 . . N BSDXCAN S BSDXCAN=$P(BSDXNOD,U,9) ; Cancel flag 84 84 . . Q:BSDXCAN="C" ; Quit if appt cancelled 85 86 85 . . N BSDXPAT S BSDXPAT=$P(BSDXNOD,U) ; Patient 86 . . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2) ;duration in minutes 87 87 . . N BSDXCLRK S BSDXCLRK=$P(BSDXNOD,U,6) ;appt made by (clerk) 88 88 . . N BSDXMADE S BSDXMADE=$P(BSDXNOD,U,7) ;date appt made … … 100 100 ZTMERR ; For now, error from TM is only in trap; not returned to client. 101 101 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 102 103 102 ; Rollback before logging the error 103 I $TL>0 TROLLBACK 104 104 D ^%ZTER 105 105 S $EC="" ; Clear Error 106 106 QUIT 107 107 ; … … 148 148 ERR(BSDXI,BSDXCNT,BSDXERR) ;Error processing 149 149 S BSDXI=BSDXI+1 150 150 S BSDXERR=$TR(BSDXERR,"^","~") 151 151 S ^BSDXTMP($J,BSDXI)=BSDXCNT_"^"_BSDXERR_$C(30) 152 152 S BSDXI=BSDXI+1 … … 156 156 ETRAP ;EP Error trap entry 157 157 ; No Txn here. So don't rollback anything 158 159 160 158 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 159 D ^%ZTER 160 S $EC="" ; Clear error 161 161 I '$D(BSDXI) N BSDXI S BSDXI=0 162 162 D ERR(BSDXI,$G(BSDXCNT),"~100~BSDX29, Error: "_$G(%ZTERZE)) -
Scheduling/trunk/m/BSDX2E.m
r968 r1041 1 1 BSDX2E ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [7/18/10 4:30pm] 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 S LINE="",$P(LINE,"*",81)="" -
Scheduling/trunk/m/BSDX30.m
r968 r1041 1 1 BSDX30 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [ 09/12/2007 1:54 PM ] 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX31.m
r1036 r1041 1 BSDX31 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 8:25am 2 ;;1.42;BSDX;;Sep 29, 2010 3 ; Change Log: 4 ; v1.42 Oct 23 2010 WV/SMH 5 ; - Change transaction to restartable. Thanks to Zach Gonzalez 6 ; --> and Rick Marshall for their help. 7 ; v1.42 Dec 6 2010: Extensive refactoring 8 ; 9 ; Error Reference: 10 ; -1: zero or null Appt ID 11 ; -2: Invalid APPT ID (doesn't exist in ^BSDXAPPT) 12 ; -3: No-show flag is invalid 13 ; -100: M Error 14 ; 15 ; 16 NOSHOWD(BSDXY,BSDXAPTID,BSDXNS) ;EP 17 ;Entry point for debugging 18 ; 19 D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)") 20 Q 21 ; 22 UT ; Unit Tests 23 ; Test 1: Sanity Check 24 N ZZZ ; Garbage return variable 25 N DATE S DATE=$$NOW^XLFDT() 26 S DATE=$E(DATE,1,12) ; Just get minutes b/c of HL file input transform 27 D APPADD^BSDX07(.ZZZ,DATE,DATE+.0001,3,"Dr Office",30,"Old Note",1) 28 N APPID S APPID=+$P(^BSDXTMP($J,1),U) 29 D NOSHOW(.ZZZ,APPID,1) 30 I $P(^BSDXAPPT(APPID,0),U,10)'=1 W "ERROR T1",! B 31 I $P(^DPT(3,"S",DATE,0),U,2)'="N" W "ERROR T1",! B 32 ; Test 2: Undo noshow 33 D NOSHOW(.ZZZ,APPID,0) 34 I $P(^BSDXAPPT(APPID,0),U,10)'="0" W "ERROR T2",! B 35 I $P(^DPT(3,"S",DATE,0),U,2)'="" W "ERROR T2",! B 36 ; Test 3: -1 37 D NOSHOW(.ZZZ,"",0) 38 I $P(^BSDXTMP($J,1),U)'=-1 W "ERROR T3",! B 39 ; Test 4: -2 40 D NOSHOW(.ZZZ,2938748233,0) 41 I $P(^BSDXTMP($J,1),U)'=-2 W "ERROR T4",! B 42 QUIT 43 NOSHOW(BSDXY,BSDXAPTID,BSDXNS) ;EP - No show a patient 44 ; Called by RPC: BSDX NOSHOW 45 ; Sets appointment noshow flag in BSDX APPOINTMENT file and "S" node in File 2 46 ; 47 ; Parameters: 48 ; BSDXY: Global Return 49 ; BSDXAPTID is entry number in BSDX APPOINTMENT file 50 ; BSDXNS = 1: NOSHOW, 0: CANCEL NOSHO 51 ; 52 ; Returns ADO.net record set with fields 53 ; - ERRORID; ERRORTEXT 54 ; ERRORID of 1 is okay 55 ; Anything else is an error. 56 ; 57 ; Return Array; set and clear 58 S BSDXY=$NA(^BSDXTMP($J)) 59 K ^BSDXTMP($J) 60 ; $ET 61 N $ET S $ET="G ETRAP^BSDX31" 62 ; Basline vars 63 D ^XBKVAR ; Set up baseline variables (DUZ, DUZ(2)) if they don't exist 64 ; Counter 65 N BSDXI S BSDXI=0 66 ; Header Node 67 S ^BSDXTMP($J,BSDXI)="I00020ERRORID^T00030ERRORTEXT"_$C(30) 68 ; Begin transaction 69 TSTART (BSDXI,BSDXY,BSDXAPTID,BSDXNS):T="BSDX NOSHOW CANCEL^BSDX29" 70 ; Turn off SDAM APPT PROTOCOL BSDX Entries 71 N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol 72 ; Appointment ID check 73 I '+BSDXAPTID D ERR(-1,"BSDX31: Invalid Appointment ID") Q 74 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(-2,"BSDX31: Invalid Appointment ID") Q 75 ; Noshow value check - Must be 1 or 0 76 S BSDXNS=+BSDXNS 77 I BSDXNS'=1&(BSDXNS'=0) D ERR(-3,"BSDX31: Invalid No Show value") Q 78 ; Get Some data 79 N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; Node 80 N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN 81 N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Date/Time 82 ; Edit BSDX APPOINTMENT entry 83 N BSDXMSG ; 84 D BSDXNOS(BSDXAPTID,BSDXNS,.BSDXMSG) ;Edit BSDX APPOINTMENT entry NOSHOW field 85 I $D(BSDXMSG("DIERR")) S BSDXMSG=$G(BSDXMSG("DIERR",1,"TEXT",1)) D ERR(-4,"BSDX31: "_BSDXMSG) Q 86 ; Edit File 2 "S" node entry 87 N BSDXZ,BSDXERR ; Error variables to control looping 88 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID 89 ; If Resource ID exists, and HL exists (means that Resource is linked), No show in File 2 90 I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I $G(BSDXZ)]"" S BSDXERR="BSDX31: APNOSHO Returned: "_BSDXZ D ERR(-5,BSDXERR) Q 91 . S BSDXNOD=^BSDXRES(BSDXSC1,0) 92 . S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION 93 . I BSDXSC1]"",$D(^SC(BSDXSC1,0)) D APNOSHO(.BSDXZ,BSDXSC1,BSDXPATID,BSDXSTART,BSDXNS) 94 ; 95 TCOMMIT 96 S BSDXI=BSDXI+1 97 S ^BSDXTMP($J,BSDXI)="1^"_$C(30) ; 1 means everything okay 98 S BSDXI=BSDXI+1 99 S ^BSDXTMP($J,BSDXI)=$C(31) 100 QUIT 101 ; 102 APNOSHO(BSDXZ,BSDXSC1,BSDXDFN,BSDXSD,BSDXNS) ; 103 ; update file 2 info 104 ;Set noshow for patient BSDXDFN in clinic BSDXSC1 105 ;at time BSDXSD 106 N BSDXC,%H,BSDXCDT,BSDXIEN 107 N BSDXIENS,BSDXFDA,BSDXMSG 108 S %H=$H D YMD^%DTC 109 S BSDXCDT=X+% 110 ; 111 S BSDXIENS=BSDXSD_","_BSDXDFN_"," 112 I +BSDXNS D 113 . S BSDXFDA(2.98,BSDXIENS,3)="N" 114 . S BSDXFDA(2.98,BSDXIENS,14)=DUZ 115 . S BSDXFDA(2.98,BSDXIENS,15)=BSDXCDT 116 E D 117 . S BSDXFDA(2.98,BSDXIENS,3)="" 118 . S BSDXFDA(2.98,BSDXIENS,14)="" 119 . S BSDXFDA(2.98,BSDXIENS,15)="" 120 K BSDXIEN 121 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG") 122 S BSDXZ=$G(BSDXMSG("DIERR",1,"TEXT",1)) 123 Q 124 ; 125 BSDXNOS(BSDXAPTID,BSDXNS,BSDXMSG) ; 126 ; 127 N BSDXFDA,BSDXIENS 128 S BSDXIENS=BSDXAPTID_"," 129 S BSDXFDA(9002018.4,BSDXIENS,.1)=BSDXNS ;NOSHOW 130 D FILE^DIE("","BSDXFDA","BSDXMSG") 131 QUIT 132 ; 133 NOSEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX NOSHOW APPOINTMENT event 134 ;when appointments NOSHOW via PIMS interface. 135 ;Propagates NOSHOW to BSDXAPPT and raises refresh event to running GUI clients 136 ; 137 Q:+$G(BSDXNOEV) 138 Q:'+$G(BSDXSC) 139 Q:$G(SDATA("AFTER","STATUS"))["AUTO RE-BOOK" 140 N BSDXSTAT,BSDXFOUND,BSDXRES 141 S BSDXSTAT=1 142 S:$G(SDATA("BEFORE","STATUS"))["NO-SHOW" BSDXSTAT=0 143 S BSDXFOUND=0 144 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) 145 I BSDXFOUND D NOSEVT3(BSDXRES) Q 146 I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) 147 I BSDXFOUND D NOSEVT3(BSDXRES) 148 Q 149 ; 150 NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ; 151 ;Get appointment id in BSDXAPT 152 ;If found, call BSDXNOS(BSDXAPPT) and return 1 153 ;else return 0 154 N BSDXFOUND,BSDXAPPT 155 S BSDXFOUND=0 156 Q:'+$G(BSDXRES) BSDXFOUND 157 Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND 158 S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND 159 . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD="" 160 . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q 161 I BSDXFOUND,+$G(BSDXAPPT) D BSDXNOS(BSDXAPPT,BSDXSTAT) 162 Q BSDXFOUND 163 ; 164 NOSEVT3(BSDXRES) ; 165 ;Call RaiseEvent to notify GUI clients 166 ; 167 N BSDXRESN 168 S BSDXRESN=$G(^BSDXRES(BSDXRES,0)) 169 Q:BSDXRESN="" 170 S BSDXRESN=$P(BSDXRESN,"^") 171 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN) 172 Q 173 ; 174 ; 175 ERR(BSDXERID,ERRTXT) ;Error processing 176 S BSDXI=BSDXI+1 177 TROLLBACK 178 S ^BSDXTMP($J,BSDXI)=BSDXERID_"^"_ERRTXT_$C(30) 179 S BSDXI=BSDXI+1 180 S ^BSDXTMP($J,BSDXI)=$C(31) 181 Q 182 ; 183 ETRAP ;EP Error trap entry 184 D ^%ZTER 185 I '$D(BSDXI) N BSDXI S BSDXI=999999 186 S BSDXI=BSDXI+1 187 D ERR(0,"BSDX31 Error: "_$G(%ZTERROR)) 188 Q 189 ; 190 IMHERE(BSDXRES) ;EP 191 ;Entry point for BSDX IM HERE remote procedure 192 S BSDXRES=1 193 Q 194 ; 1 BSDX31 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:39pm 2 ;;1.42;BSDX;;Dec 07, 2010 3 ; Change Log: 4 ; v1.42 Oct 23 2010 WV/SMH 5 ; - Change transaction to restartable. Thanks to Zach Gonzalez 6 ; --> and Rick Marshall for their help. 7 ; v1.42 Dec 6 2010: Extensive refactoring 8 ; 9 ; Error Reference: 10 ; -1: zero or null Appt ID 11 ; -2: Invalid APPT ID (doesn't exist in ^BSDXAPPT) 12 ; -3: No-show flag is invalid 13 ; -4: Filing of No-show in ^BSDXAPPT failed 14 ; -5: Filing of No-show in ^DPT failed (BSDXAPI error) 15 ; -100: M Error 16 ; 17 ; 18 NOSHOWD(BSDXY,BSDXAPTID,BSDXNS) ;EP 19 ;Entry point for debugging 20 ; 21 D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)") 22 Q 23 ; 24 UT ; Unit Tests 25 ; Test 1: Sanity Check 26 N ZZZ ; Garbage return variable 27 N DATE S DATE=$$NOW^XLFDT() 28 S DATE=$E(DATE,1,12) ; Just get minutes b/c of HL file input transform 29 D APPADD^BSDX07(.ZZZ,DATE,DATE+.0001,3,"Dr Office",30,"Old Note",1) 30 N APPID S APPID=+$P(^BSDXTMP($J,1),U) 31 D NOSHOW(.ZZZ,APPID,1) 32 I $P(^BSDXAPPT(APPID,0),U,10)'=1 W "ERROR T1",! B 33 I $P(^DPT(3,"S",DATE,0),U,2)'="N" W "ERROR T1",! B 34 ; Test 2: Undo noshow 35 D NOSHOW(.ZZZ,APPID,0) 36 I $P(^BSDXAPPT(APPID,0),U,10)'="0" W "ERROR T2",! B 37 I $P(^DPT(3,"S",DATE,0),U,2)'="" W "ERROR T2",! B 38 ; Test 3: -1 39 D NOSHOW(.ZZZ,"",0) 40 I $P(^BSDXTMP($J,1),U)'=-1 W "ERROR T3",! B 41 ; Test 4: -2 42 D NOSHOW(.ZZZ,2938748233,0) 43 I $P(^BSDXTMP($J,1),U)'=-2 W "ERROR T4",! B 44 ; Test 5: -3 45 D NOSHOW(.ZZZ,APPID,3) 46 I $P(^BSDXTMP($J,1),U)'=-3 W "ERROR T5",! B 47 ; Test 6: Mumps error (-100) 48 s bsdxdie=1 49 D NOSHOW(.ZZZ,APPID,1) 50 I $P(^BSDXTMP($J,1),U)'=-100 W "ERROR T6",! B 51 k bsdxdie 52 ; Test 7: Restartable transaction 53 s bsdxrestart=1 54 D NOSHOW(.ZZZ,APPID,1) 55 I $P(^BSDXAPPT(APPID,0),U,10)'=1 W "ERROR T7",! B 56 QUIT 57 NOSHOW(BSDXY,BSDXAPTID,BSDXNS) ;EP - No show a patient 58 ; Called by RPC: BSDX NOSHOW 59 ; Sets appointment noshow flag in BSDX APPOINTMENT file and "S" node in File 2 60 ; 61 ; Parameters: 62 ; BSDXY: Global Return 63 ; BSDXAPTID is entry number in BSDX APPOINTMENT file 64 ; BSDXNS = 1: NOSHOW, 0: CANCEL NOSHO 65 ; 66 ; Returns ADO.net record set with fields 67 ; - ERRORID; ERRORTEXT 68 ; ERRORID of 1 is okay 69 ; Anything else is an error. 70 ; 71 ; Return Array; set and clear 72 S BSDXY=$NA(^BSDXTMP($J)) 73 K ^BSDXTMP($J) 74 ; $ET 75 N $ET S $ET="G ETRAP^BSDX31" 76 ; Basline vars 77 D ^XBKVAR ; Set up baseline variables (DUZ, DUZ(2)) if they don't exist 78 ; Counter 79 N BSDXI S BSDXI=0 80 ; Header Node 81 S ^BSDXTMP($J,BSDXI)="I00100ERRORID^T00030ERRORTEXT"_$C(30) 82 ; Begin transaction 83 TSTART (BSDXI,BSDXY,BSDXAPTID,BSDXNS):T="BSDX NOSHOW CANCEL^BSDX29" 84 ;;;test for error inside transaction. See if %ZTER works 85 I $G(bsdxdie) S X=1/0 86 ;;;TEST 87 ;;;test for TRESTART 88 I $G(bsdxrestart) K bsdxrestart TRESTART 89 ;;;test 90 ; Turn off SDAM APPT PROTOCOL BSDX Entries 91 N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol 92 ; Appointment ID check 93 I '+BSDXAPTID D ERR(-1,"BSDX31: Invalid Appointment ID") Q 94 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(-2,"BSDX31: Invalid Appointment ID") Q 95 ; Noshow value check - Must be 1 or 0 96 S BSDXNS=+BSDXNS 97 I BSDXNS'=1&(BSDXNS'=0) D ERR(-3,"BSDX31: Invalid No Show value") Q 98 ; Get Some data 99 N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; Node 100 N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN 101 N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Date/Time 102 ; Edit BSDX APPOINTMENT entry 103 N BSDXMSG ; 104 D BSDXNOS(BSDXAPTID,BSDXNS,.BSDXMSG) ;Edit BSDX APPOINTMENT entry NOSHOW field 105 I $D(BSDXMSG("DIERR")) S BSDXMSG=$G(BSDXMSG("DIERR",1,"TEXT",1)) D ERR(-4,"BSDX31: "_BSDXMSG) Q 106 ; Edit File 2 "S" node entry 107 N BSDXZ,BSDXERR ; Error variables to control looping 108 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID 109 ; If Resource ID exists, and HL exists (means that Resource is linked), No show in File 2 110 I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I $G(BSDXZ)]"" S BSDXERR="BSDX31: APNOSHO Returned: "_BSDXZ D ERR(-5,BSDXERR) Q 111 . S BSDXNOD=^BSDXRES(BSDXSC1,0) 112 . S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION 113 . I BSDXSC1]"",$D(^SC(BSDXSC1,0)) D APNOSHO(.BSDXZ,BSDXSC1,BSDXPATID,BSDXSTART,BSDXNS) 114 ; 115 TCOMMIT 116 S BSDXI=BSDXI+1 117 S ^BSDXTMP($J,BSDXI)="1^"_$C(30) ; 1 means everything okay 118 S BSDXI=BSDXI+1 119 S ^BSDXTMP($J,BSDXI)=$C(31) 120 QUIT 121 ; 122 APNOSHO(BSDXZ,BSDXSC1,BSDXDFN,BSDXSD,BSDXNS) ; 123 ; update file 2 info 124 ;Set noshow for patient BSDXDFN in clinic BSDXSC1 125 ;at time BSDXSD 126 N BSDXC,%H,BSDXCDT,BSDXIEN 127 N BSDXIENS,BSDXFDA,BSDXMSG 128 S %H=$H D YMD^%DTC 129 S BSDXCDT=X+% 130 ; 131 S BSDXIENS=BSDXSD_","_BSDXDFN_"," 132 I +BSDXNS D 133 . S BSDXFDA(2.98,BSDXIENS,3)="N" 134 . S BSDXFDA(2.98,BSDXIENS,14)=DUZ 135 . S BSDXFDA(2.98,BSDXIENS,15)=BSDXCDT 136 E D 137 . S BSDXFDA(2.98,BSDXIENS,3)="" 138 . S BSDXFDA(2.98,BSDXIENS,14)="" 139 . S BSDXFDA(2.98,BSDXIENS,15)="" 140 K BSDXIEN 141 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG") 142 S BSDXZ=$G(BSDXMSG("DIERR",1,"TEXT",1)) 143 Q 144 ; 145 BSDXNOS(BSDXAPTID,BSDXNS,BSDXMSG) ; 146 ; 147 N BSDXFDA,BSDXIENS 148 S BSDXIENS=BSDXAPTID_"," 149 S BSDXFDA(9002018.4,BSDXIENS,.1)=BSDXNS ;NOSHOW 150 D FILE^DIE("","BSDXFDA","BSDXMSG") 151 QUIT 152 ; 153 NOSEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX NOSHOW APPOINTMENT event 154 ;when appointments NOSHOW via PIMS interface. 155 ;Propagates NOSHOW to BSDXAPPT and raises refresh event to running GUI clients 156 ; 157 Q:+$G(BSDXNOEV) 158 Q:'+$G(BSDXSC) 159 Q:$G(SDATA("AFTER","STATUS"))["AUTO RE-BOOK" 160 N BSDXSTAT,BSDXFOUND,BSDXRES 161 S BSDXSTAT=1 162 S:$G(SDATA("BEFORE","STATUS"))["NO-SHOW" BSDXSTAT=0 163 S BSDXFOUND=0 164 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) 165 I BSDXFOUND D NOSEVT3(BSDXRES) Q 166 I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) 167 I BSDXFOUND D NOSEVT3(BSDXRES) 168 Q 169 ; 170 NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ; 171 ;Get appointment id in BSDXAPT 172 ;If found, call BSDXNOS(BSDXAPPT) and return 1 173 ;else return 0 174 N BSDXFOUND,BSDXAPPT 175 S BSDXFOUND=0 176 Q:'+$G(BSDXRES) BSDXFOUND 177 Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND 178 S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND 179 . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD="" 180 . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q 181 I BSDXFOUND,+$G(BSDXAPPT) D BSDXNOS(BSDXAPPT,BSDXSTAT) 182 Q BSDXFOUND 183 ; 184 NOSEVT3(BSDXRES) ; 185 ;Call RaiseEvent to notify GUI clients 186 ; 187 N BSDXRESN 188 S BSDXRESN=$G(^BSDXRES(BSDXRES,0)) 189 Q:BSDXRESN="" 190 S BSDXRESN=$P(BSDXRESN,"^") 191 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN) 192 Q 193 ; 194 ; 195 ERR(BSDXERID,ERRTXT) ;Error processing 196 S BSDXI=BSDXI+1 197 S ERRTXT=$TR(ERRTXT,"^","~") 198 I $TL>0 TROLLBACK 199 S ^BSDXTMP($J,BSDXI)=BSDXERID_"^"_ERRTXT_$C(30) 200 S BSDXI=BSDXI+1 201 S ^BSDXTMP($J,BSDXI)=$C(31) 202 QUIT 203 ; 204 ETRAP ;EP Error trap entry 205 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 206 ; Rollback, otherwise ^XTER will be empty from future rollback 207 I $TL>0 TROLLBACK 208 D ^%ZTER 209 S $EC="" ; Clear Error 210 ; Send to client 211 I '$D(BSDXI) N BSDXI S BSDXI=0 212 D ERR(-100,"BSDX31 Error: "_$G(%ZTERZE)) 213 QUIT 214 ; 215 IMHERE(BSDXRES) ;EP 216 ;Entry point for BSDX IM HERE remote procedure 217 S BSDXRES=1 218 Q 219 ; -
Scheduling/trunk/m/BSDX32.m
r968 r1041 1 1 BSDX32 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 9/29/10 10:21am 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDX33.m
r968 r1041 1 1 BSDX33 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:33pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; Mods by WV/STAR 4 4 ; -
Scheduling/trunk/m/BSDX34.m
r968 r1041 1 1 BSDX34 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:37pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; Change Log: -
Scheduling/trunk/m/BSDX35.m
r968 r1041 1 1 BSDX35 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ; -
Scheduling/trunk/m/BSDXAPI.m
r1035 r1041 1 BSDXAPI ; IHS/ANMC/LJF - SCHEDULING APIs ; 12/6/10 6:01am2 ;;1.42;BSDX;; Sep 29, 2010;Build 71 BSDXAPI ; IHS/ANMC/LJF - SCHEDULING APIs ; 12/6/10 5:50pm 2 ;;1.42;BSDX;;Dec 07, 2010;Build 7 3 3 ;Orignal routine is BSDAPI by IHS/LJF, HMW, and MAW 4 4 ;local mods (many) by WV/SMH 5 5 ;Move to BSDX namespace as BSDXAPI from BSDAPI by WV/SMH 6 6 ; Change History: 7 ; 2010-11-5: 7 8 ; - Fixed errors having to do uncanceling patient appointments if it was a patient cancelled appointment. 8 9 ; - Use new style Fileman API for storing appointments in file 44 in $$MAKE due to problems with legacy API. 9 ; 2010-11-12: 10 ; - Changed ="C" to ["C" in SCIEN. Cancelled appointments can be "PC" as well. 11 ; 2010-12-5 12 ; Added an entry point to update the patient note in file 44. 13 ; 2010-12-6 14 ; MAKE1 incorrectly put info field in BSDR("INFO") rather than BSDR("OI") 10 ; 2010-11-12: 11 ; - Changed ="C" to ["C" in SCIEN. Cancelled appointments can be "PC" as well. 12 ; 2010-12-5 13 ; Added an entry point to update the patient note in file 44. 14 ; 2010-12-6 15 ; MAKE1 incorrectly put info field in BSDR("INFO") rather than BSDR("OI") 16 ; 2010-12-8 17 ; Removed restriction on max appt length. Even though this restriction 18 ; exists in fileman (120 minutes), PIMS ignores it. Therefore, I 19 ; will ignore it here too. 15 20 ; 16 21 MAKE1(DFN,CLIN,TYP,DATE,LEN,INFO) ; Simplified PEP w/ parameters for $$MAKE - making appointment … … 51 56 I $G(BSDR("ADT"))'?7N1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT")) 52 57 ; 53 I ($G(BSDR("LEN"))<5)!($G(BSDR("LEN"))>240) Q 1_U_"Appt Length error: "_$G(BSDR("LEN"))58 ;I ($G(BSDR("LEN"))<5)!($G(BSDR("LEN"))>240) Q 1_U_"Appt Length error: "_$G(BSDR("LEN")) ; v 1.42 - no check on length is done anymore. see top comments for details. 54 59 I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Made Appt Error: "_$G(BSDR("USR")) 55 60 I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)'["C" Q 1_U_"Patient "_BSDR("PAT")_" already has appt at "_BSDR("ADT") … … 280 285 Q $S(X:1,1:0) 281 286 ; 282 UPDATENOTE(PAT,CLINIC,DATE,NOTE) 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 287 UPDATENOTE(PAT,CLINIC,DATE,NOTE) ; PEP; Update Note in ^SC for patient's appointment @ DATE 288 ; PAT = DFN 289 ; CLINIC = SC IEN 290 ; DATE = FM Date/Time of Appointment 291 ; 292 ; Returns: 293 ; 0 if okay 294 ; -1 if failure 295 N SCIEN S SCIEN=$$SCIEN(PAT,CLINIC,DATE) ; ien of appt in ^SC 296 I SCIEN<1 QUIT 0 ; Appt cancelled; cancelled appts rm'ed from file 44 297 N BSDXIENS S BSDXIENS=SCIEN_","_DATE_","_CLINIC_"," 298 S BSDXFDA(44.003,BSDXIENS,3)=$E(NOTE,1,150) 299 N BSDXERR 300 D FILE^DIE("","BSDXFDA","BSDXERR") 301 I $D(BSDXERR) QUIT "-1~Can't file for Pat "_PAT_" in Clinic "_CLINIC_" at "_DATE_". Fileman reported an error: "_BSDXERR("DIERR",1,"TEXT",1) 302 QUIT 0 -
Scheduling/trunk/m/BSDXGPRV.m
r1005 r1041 1 1 BSDXGPRV ; WV/SMH - WINDOWS SCHEDULING RPCS ; 11/2/10 4:27pm 2 ;;1.4 1;BSDX;;Sep 29, 20102 ;;1.42;BSDX;;Dec 07, 2010 3 3 ; 4 4 ;
Note:
See TracChangeset
for help on using the changeset viewer.
