BSDX07 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
;
APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXCR) ;EP
;Entry point for debugging
;
I +$G(^HWDEBUG("BREAK","APPADD")),+$G(^HWDEBUG("BREAK"))=DUZ D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)",$P(^HWDEBUG("BREAK"),U,2))
E G ENDBG
Q
;
APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXCR) ;EP
;Called by BSDX ADD NEW APPOINTMENT
;Add new appointment
;BSDXRES is ResourceName
;BSDXLEN is the appointment duration in minutes
;BSDXATID is used for 2 purposes:
; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
; if BSDXATID = a number, then it is the access type id (used for rebooking)
;
;Create entry in BSDX APPOINTMENT
;Returns recordset having fields
; AppointmentID and ErrorNumber
;
;Test lines:
ENDBG ;BSDX ADD NEW APPOINTMENT^12-28-2000@0900^12-28-2000@1000^370^2^PEDIATRICIAN,DEMO^EXAM^SCRATCH NOTE
;
N BSDXERR,BSDXIEN,BSDXDEP,BSDXI,BSDXJ,BSDXAPPTI,BSDXDJ,BSDXRESD,BSDXRNOD,BSDXSCD,BSDXC,BSDXERR,BSDXWKIN
N BSDXNOEV,BSDXDEV,BSDXDERR
S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
K ^BSDXTMP($J)
S X="ETRAP^BSDX07",@^%ZOSF("TRAP")
S BSDXERR=0
S BSDXI=0
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00020ERRORID"_$C(30)
S BSDXI=BSDXI+1
;
;Lock BSDX node
L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later") Q
;
TSTART
;Check input data for errors
S:BSDXSTART["@0000" BSDXSTART=$P(BSDXSTART,"@")
S:BSDXEND["@0000" BSDXEND=$P(BSDXEND,"@")
S %DT="T",X=BSDXSTART D ^%DT S BSDXSTART=Y
I BSDXSTART=-1 D ERR(BSDXI+1,"BSDX07 Error: Invalid Start Time") Q
S %DT="T",X=BSDXEND D ^%DT S BSDXEND=Y
I BSDXEND=-1 D ERR(BSDXI+1,"BSDX07 Error: Invalid End Time") Q
I $L(BSDXEND,".")=1 D ERR(BSDXI+1,"BSDX07 Error: Invalid End Time") Q
I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
I '+BSDXPATID,'$D(^DPT(BSDXPATID,0)) D ERR(BSDXI+1,"BSDX07 Error: Invalid Patient ID") Q
;Validate Resource entry
S BSDXERR=0 K BSDXRESD
I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI+1,"BSDX07 Error: Invalid Resource ID") Q
S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
S BSDXWKIN=0
I BSDXATID="WALKIN" S BSDXWKIN=1
I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
;
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID)
I 'BSDXAPPTID D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q
; call chart request - bwf 3/11/2010
S BSDXDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05) I BSDXDEV="" D ERR(BSDXI+1,"BSDX07 Error: No file room printer is defined for the chart request.") Q
I BSDXATID="WALKIN",$G(BSDXCR),$G(BSDXDEV)'="" S DGQUIET=1 D WISD^BSDROUT(BSDXPATID,$P(BSDXSTART,"."),"",BSDXDEV)
I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
;
;Create RPMS Appointment ;TODO: have this call APPRPMS^BSDX07
S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
;I BSDXRNOD="" D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry."),BSDXDEL(BSDXAPPTID) Q
I BSDXRNOD="" D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry.") Q
S BSDXSCD=$P(BSDXRNOD,U,4)
;I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR),BSDXDEL(BSDXAPPTID) Q
I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR) Q
. S BSDXC("PAT")=BSDXPATID
. S BSDXC("CLN")=BSDXSCD
. S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
. S:BSDXWKIN BSDXC("TYP")=4
. S BSDXC("ADT")=BSDXSTART
. S BSDXC("LEN")=BSDXLEN
. ;S BSDXC("OI")=$E($G(BSDXNOTE(.5)),1,150) ;File 44 has 150 character limit on OTHER field
. S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
. S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDAPI
. S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
. S BSDXC("RES")=BSDXRESD
. S BSDXC("USR")=DUZ
. S BSDXERR=$$MAKE^BSDAPI(.BSDXC)
. Q:BSDXERR
. D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
. ;L
. Q
;
;Update RPMS Clinic availability
;Return Recordset
TCOMMIT
L -^BSDXAPPT(BSDXPATID)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$G(BSDXDERR)_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
;Create RPMS Appointment
APPRPMS(BSDXLEN,BSDXNOTE,BSDXPATID,BSDXRESD,BSDXSTART,BSDXWKIN) ;
N BSDXC,BSDXRNOD,BSDXSCD
S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
I BSDXRNOD="" D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry.") Q
S BSDXSCD=$P(BSDXRNOD,U,4) ;hospital location
I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR) Q
. S BSDXC("PAT")=BSDXPATID
. S BSDXC("CLN")=BSDXSCD
. S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
. S:BSDXWKIN BSDXC("TYP")=4
. S BSDXC("ADT")=BSDXSTART
. S BSDXC("LEN")=BSDXLEN
. S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
. S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDAPI
. S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
. S BSDXC("RES")=BSDXRESD
. S BSDXC("USR")=DUZ
. S BSDXERR=$$MAKE^BSDAPI(.BSDXC)
. Q:BSDXERR
. D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
. ;L
. Q
Q +BSDXERR
;
BSDXDEL(BSDXAPPTID) ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
N DA,DIK
S DIK="^BSDXAPPT(",DA=BSDXAPPTID
D ^DIK
Q
;
STRIP(BSDXZ) ;Replace control characters with spaces
N BSDXI
F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
Q BSDXZ
;
BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY
;Returns ien in BSDXAPPT or 0 if failed
;Create entry in BSDX APPOINTMENT
N BSDXAPPTID
S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
;S BSDXFDA(9002018.4,"+1,",.09)=$G(DT) ;MJL 1/25/2007
S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
K BSDXIEN,BSDXMSG
D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
S BSDXAPPTID=+$G(BSDXIEN(1))
Q BSDXAPPTID
;
BSDXWP(BSDXAPPTID,BSDXNOTE) ;
;Add WP field
I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
I $D(BSDXNOTE(.5)) D
. D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
Q
;
ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP
;Called by BSDX ADD APPOINTMENT protocol
;BSDXSC=IEN of clinic in ^SC
;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
;
N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
Q:+$G(BSDXNOEV)
I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
Q:'+$G(BSDXRES)
S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
Q:BSDXNOD=""
S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
S BSDXWKIN=""
S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
S BSDXLEN=$P(BSDXNOD,U,2)
Q:'+BSDXLEN
S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
Q:'+BSDXAPPTID
S BSDXNOTE=$P(BSDXNOD,U,4)
I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
D ADDEVT3(BSDXRES)
Q
;
ADDEVT3(BSDXRES) ;
;Call RaiseEvent to notify GUI clients
N BSDXRESN
S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
Q:BSDXRESN=""
S BSDXRESN=$P(BSDXRESN,"^")
;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
Q
;
ERR(BSDXI,BSDXERR) ;Error processing
S BSDXI=BSDXI+1
S BSDXERR=$TR(BSDXERR,"^","~")
TROLLBACK
S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
L
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
I '$D(BSDXI) N BSDXI S BSDXI=999999
S BSDXI=BSDXI+1
D ERR(BSDXI,"BSDX07 Error: "_$G(%ZTERROR))
Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
F %=%:-1:281 S Y=%#4=1+1+Y
S Y=$E(X,6,7)+Y#7
Q
;
AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
;SEE SDM1
N Y,DFN
N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
S Y=BSDXSCD,DFN=BSDXPATID
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
;Determine maximum days for scheduling
S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
S SDDATE=BSDXSTART
S SDSDATE=SDDATE,SDDATE=SDDATE\1
1 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
S X2=SDEDT D C^%DTC S SDEDT=X
S Y=BSDXSTART
EN1 S (X,SD)=Y,SM=0 D DOW
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,".")
S S=BSDXLEN
;Check if BSDXLEN evenly divisible by appointment length
S RPMSL=$P(SL,U)
I BSDXLEN<RPMSL S BSDXLEN=RPMSL
I BSDXLEN#RPMSL'=0 D
. S BSDXINC=BSDXLEN\RPMSL
. S BSDXINC=BSDXINC+1
. S BSDXLEN=RPMSL*BSDXINC
S SL=S_U_$P(SL,U,2,99)
SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
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
;
SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
S SDNOT=1
S ABORT=0
F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT
. S ST=$E(S,I+1) S:ST="" ST=" "
. S Y=$E(STR,$F(STR,ST)-2)
. I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
. I Y="" S ABORT=1 Q
. 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
. Q
S ^SC(SC,"ST",$P(SD,"."),1)=S
L -^SC(SC,"ST",$P(SD,"."),1)
Q
;
APPOVB(BSDXY,SDCL,NSDT,BSDXRES) ; RPC - BSDX OVERBOOK - CHECK FOR OVERBOOK FOR GIVEN CLINIC, DATE, AND RESOURCE
; .BSDXY = returned pointer to OVERBOOK data
; SDCL = clinic code - pointer to Hospital Location file ^SC
; NSDT = date/time of new appointment
; BSDXRES = resource to check for overbook
G APPOVB^BSDX07A
;
ERROR ;
D ERR1("RPMS Error")
Q
;
ERR1(BSDXERR) ;Error processing
I +BSDXERR S BSDXERR=ERRNO+134234112 ;vbObjectError
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
BSDX07 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
+3 ;
APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXCR) ;EP
+1 ;Entry point for debugging
+2 ;
+3 IF +$GET(^HWDEBUG("BREAK","APPADD"))
IF +$GET(^HWDEBUG("BREAK"))=DUZ
DO DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)",$PIECE(^HWDEBUG("BREAK"),U,2))
+4 IF '$TEST
GOTO ENDBG
+5 QUIT
+6 ;
APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXCR) ;EP
+1 ;Called by BSDX ADD NEW APPOINTMENT
+2 ;Add new appointment
+3 ;BSDXRES is ResourceName
+4 ;BSDXLEN is the appointment duration in minutes
+5 ;BSDXATID is used for 2 purposes:
+6 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
+7 ; if BSDXATID = a number, then it is the access type id (used for rebooking)
+8 ;
+9 ;Create entry in BSDX APPOINTMENT
+10 ;Returns recordset having fields
+11 ; AppointmentID and ErrorNumber
+12 ;
+13 ;Test lines:
ENDBG ;BSDX ADD NEW APPOINTMENT^12-28-2000@0900^12-28-2000@1000^370^2^PEDIATRICIAN,DEMO^EXAM^SCRATCH NOTE
+1 ;
+2 NEW BSDXERR,BSDXIEN,BSDXDEP,BSDXI,BSDXJ,BSDXAPPTI,BSDXDJ,BSDXRESD,BSDXRNOD,BSDXSCD,BSDXC,BSDXERR,BSDXWKIN
+3 NEW BSDXNOEV,BSDXDEV,BSDXDERR
+4 ;Don't execute BSDX ADD APPOINTMENT protocol
SET BSDXNOEV=1
+5 KILL ^BSDXTMP($JOB)
+6 SET X="ETRAP^BSDX07"
SET @^%ZOSF("TRAP")
+7 SET BSDXERR=0
+8 SET BSDXI=0
+9 SET BSDXY="^BSDXTMP("_$JOB_")"
+10 SET ^BSDXTMP($JOB,BSDXI)="I00020APPOINTMENTID^T00020ERRORID"_$CHAR(30)
+11 SET BSDXI=BSDXI+1
+12 ;
+13 ;Lock BSDX node
+14 LOCK +^BSDXAPPT(BSDXPATID):5
IF '$TEST
DO ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later")
QUIT
+15 ;
+16 TSTART
+17 ;Check input data for errors
+18 IF BSDXSTART["@0000"
SET BSDXSTART=$PIECE(BSDXSTART,"@")
+19 IF BSDXEND["@0000"
SET BSDXEND=$PIECE(BSDXEND,"@")
+20 SET %DT="T"
SET X=BSDXSTART
DO ^%DT
SET BSDXSTART=Y
+21 IF BSDXSTART=-1
DO ERR(BSDXI+1,"BSDX07 Error: Invalid Start Time")
QUIT
+22 SET %DT="T"
SET X=BSDXEND
DO ^%DT
SET BSDXEND=Y
+23 IF BSDXEND=-1
DO ERR(BSDXI+1,"BSDX07 Error: Invalid End Time")
QUIT
+24 IF $LENGTH(BSDXEND,".")=1
DO ERR(BSDXI+1,"BSDX07 Error: Invalid End Time")
QUIT
+25 IF BSDXSTART>BSDXEND
SET BSDXTMP=BSDXEND
SET BSDXEND=BSDXSTART
SET BSDXSTART=BSDXTMP
+26 IF '+BSDXPATID
IF '$DATA(^DPT(BSDXPATID,0))
DO ERR(BSDXI+1,"BSDX07 Error: Invalid Patient ID")
QUIT
+27 ;Validate Resource entry
+28 SET BSDXERR=0
KILL BSDXRESD
+29 IF '$DATA(^BSDXRES("B",BSDXRES))
DO ERR(BSDXI+1,"BSDX07 Error: Invalid Resource ID")
QUIT
+30 SET BSDXRESD=$ORDER(^BSDXRES("B",BSDXRES,0))
+31 SET BSDXWKIN=0
+32 IF BSDXATID="WALKIN"
SET BSDXWKIN=1
+33 IF BSDXATID'?.N&(BSDXATID'="WALKIN")
SET BSDXATID=""
+34 ;
+35 SET BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID)
+36 IF 'BSDXAPPTID
DO ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.")
QUIT
+37 ; call chart request - bwf 3/11/2010
+38 SET BSDXDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05)
IF BSDXDEV=""
DO ERR(BSDXI+1,"BSDX07 Error: No file room printer is defined for the chart request.")
QUIT
+39 IF BSDXATID="WALKIN"
IF $GET(BSDXCR)
IF $GET(BSDXDEV)'=""
SET DGQUIET=1
DO WISD^BSDROUT(BSDXPATID,$PIECE(BSDXSTART,"."),"",BSDXDEV)
+40 IF BSDXNOTE]""
DO BSDXWP(BSDXAPPTID,BSDXNOTE)
+41 ;
+42 ;Create RPMS Appointment ;TODO: have this call APPRPMS^BSDX07
+43 SET BSDXRNOD=$GET(^BSDXRES(BSDXRESD,0))
+44 ;I BSDXRNOD="" D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry."),BSDXDEL(BSDXAPPTID) Q
+45 IF BSDXRNOD=""
DO ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry.")
QUIT
+46 SET BSDXSCD=$PIECE(BSDXRNOD,U,4)
+47 ;I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR),BSDXDEL(BSDXAPPTID) Q
+48 IF +BSDXSCD
IF $DATA(^SC(BSDXSCD,0))
Begin DoDot:1
+49 SET BSDXC("PAT")=BSDXPATID
+50 SET BSDXC("CLN")=BSDXSCD
+51 ;3 for scheduled appts, 4 for walkins
SET BSDXC("TYP")=3
+52 IF BSDXWKIN
SET BSDXC("TYP")=4
+53 SET BSDXC("ADT")=BSDXSTART
+54 SET BSDXC("LEN")=BSDXLEN
+55 ;S BSDXC("OI")=$E($G(BSDXNOTE(.5)),1,150) ;File 44 has 150 character limit on OTHER field
+56 ;File 44 has 150 character limit on OTHER field
SET BSDXC("OI")=$EXTRACT($GET(BSDXNOTE),1,150)
+57 ;No semicolons allowed by MAKE^BSDAPI
SET BSDXC("OI")=$TRANSLATE(BSDXC("OI"),";"," ")
+58 ;Strip control characters from note
SET BSDXC("OI")=$$STRIP(BSDXC("OI"))
+59 SET BSDXC("RES")=BSDXRESD
+60 SET BSDXC("USR")=DUZ
+61 SET BSDXERR=$$MAKE^BSDAPI(.BSDXC)
+62 IF BSDXERR
QUIT
+63 DO AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
+64 ;L
+65 QUIT
End DoDot:1
IF +BSDXERR
DO ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR)
QUIT
+66 ;
+67 ;Update RPMS Clinic availability
+68 ;Return Recordset
+69 TCOMMIT
+70 LOCK -^BSDXAPPT(BSDXPATID)
+71 SET BSDXI=BSDXI+1
+72 SET ^BSDXTMP($JOB,BSDXI)=BSDXAPPTID_"^"_$GET(BSDXDERR)_$CHAR(30)
+73 SET BSDXI=BSDXI+1
+74 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+75 QUIT
+76 ;
+77 ;Create RPMS Appointment
APPRPMS(BSDXLEN,BSDXNOTE,BSDXPATID,BSDXRESD,BSDXSTART,BSDXWKIN) ;
+1 NEW BSDXC,BSDXRNOD,BSDXSCD
+2 SET BSDXRNOD=$GET(^BSDXRES(BSDXRESD,0))
+3 IF BSDXRNOD=""
DO ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry.")
QUIT
+4 ;hospital location
SET BSDXSCD=$PIECE(BSDXRNOD,U,4)
+5 IF +BSDXSCD
IF $DATA(^SC(BSDXSCD,0))
Begin DoDot:1
+6 SET BSDXC("PAT")=BSDXPATID
+7 SET BSDXC("CLN")=BSDXSCD
+8 ;3 for scheduled appts, 4 for walkins
SET BSDXC("TYP")=3
+9 IF BSDXWKIN
SET BSDXC("TYP")=4
+10 SET BSDXC("ADT")=BSDXSTART
+11 SET BSDXC("LEN")=BSDXLEN
+12 ;File 44 has 150 character limit on OTHER field
SET BSDXC("OI")=$EXTRACT($GET(BSDXNOTE),1,150)
+13 ;No semicolons allowed by MAKE^BSDAPI
SET BSDXC("OI")=$TRANSLATE(BSDXC("OI"),";"," ")
+14 ;Strip control characters from note
SET BSDXC("OI")=$$STRIP(BSDXC("OI"))
+15 SET BSDXC("RES")=BSDXRESD
+16 SET BSDXC("USR")=DUZ
+17 SET BSDXERR=$$MAKE^BSDAPI(.BSDXC)
+18 IF BSDXERR
QUIT
+19 DO AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
+20 ;L
+21 QUIT
End DoDot:1
IF +BSDXERR
DO ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR)
QUIT
+22 QUIT +BSDXERR
+23 ;
BSDXDEL(BSDXAPPTID) ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
+1 NEW DA,DIK
+2 SET DIK="^BSDXAPPT("
SET DA=BSDXAPPTID
+3 DO ^DIK
+4 QUIT
+5 ;
STRIP(BSDXZ) ;Replace control characters with spaces
+1 NEW BSDXI
+2 FOR BSDXI=1:1:$LENGTH(BSDXZ)
IF (32>$ASCII($EXTRACT(BSDXZ,BSDXI)))
SET BSDXZ=$EXTRACT(BSDXZ,1,BSDXI-1)_" "_$EXTRACT(BSDXZ,BSDXI+1,999)
+3 QUIT BSDXZ
+4 ;
BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY
+1 ;Returns ien in BSDXAPPT or 0 if failed
+2 ;Create entry in BSDX APPOINTMENT
+3 NEW BSDXAPPTID
+4 SET BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
+5 SET BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
+6 SET BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
+7 SET BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
+8 SET BSDXFDA(9002018.4,"+1,",.08)=$GET(DUZ)
+9 ;S BSDXFDA(9002018.4,"+1,",.09)=$G(DT) ;MJL 1/25/2007
+10 SET BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
+11 IF BSDXATID="WALKIN"
SET BSDXFDA(9002018.4,"+1,",.13)="y"
+12 IF BSDXATID?.N
SET BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
+13 KILL BSDXIEN,BSDXMSG
+14 DO UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
+15 SET BSDXAPPTID=+$GET(BSDXIEN(1))
+16 QUIT BSDXAPPTID
+17 ;
BSDXWP(BSDXAPPTID,BSDXNOTE) ;
+1 ;Add WP field
+2 IF BSDXNOTE]""
SET BSDXNOTE(.5)=BSDXNOTE
SET BSDXNOTE=""
+3 IF $DATA(BSDXNOTE(0))
SET BSDXNOTE(.5)=BSDXNOTE(0)
KILL BSDXNOTE(0)
+4 IF $DATA(BSDXNOTE(.5))
Begin DoDot:1
+5 DO WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
End DoDot:1
+6 QUIT
+7 ;
ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP
+1 ;Called by BSDX ADD APPOINTMENT protocol
+2 ;BSDXSC=IEN of clinic in ^SC
+3 ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
+4 ;
+5 NEW BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
+6 IF +$GET(BSDXNOEV)
QUIT
+7 IF $DATA(^BSDXRES("ALOC",BSDXSC))
SET BSDXRES=$ORDER(^BSDXRES("ALOC",BSDXSC,0))
+8 IF '$TEST
IF $DATA(^BSDXRES("ASSOC",BSDXSC))
SET BSDXRES=$ORDER(^BSDXRES("ASSOC",BSDXSC,0))
+9 IF '+$GET(BSDXRES)
QUIT
+10 SET BSDXNOD=$GET(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
+11 IF BSDXNOD=""
QUIT
+12 SET BSDXNODP=$GET(^DPT(BSDXPATID,"S",BSDXSTART,0))
+13 SET BSDXWKIN=""
+14 ;Purpose of Visit field of DPT Appointment subfile
IF $PIECE(BSDXNODP,U,7)=4
SET BSDXWKIN="WALKIN"
+15 SET BSDXLEN=$PIECE(BSDXNOD,U,2)
+16 IF '+BSDXLEN
QUIT
+17 SET BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
+18 SET BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
+19 IF '+BSDXAPPTID
QUIT
+20 SET BSDXNOTE=$PIECE(BSDXNOD,U,4)
+21 IF BSDXNOTE]""
DO BSDXWP(BSDXAPPTID,BSDXNOTE)
+22 DO ADDEVT3(BSDXRES)
+23 QUIT
+24 ;
ADDEVT3(BSDXRES) ;
+1 ;Call RaiseEvent to notify GUI clients
+2 NEW BSDXRESN
+3 SET BSDXRESN=$GET(^BSDXRES(BSDXRES,0))
+4 IF BSDXRESN=""
QUIT
+5 SET BSDXRESN=$PIECE(BSDXRESN,"^")
+6 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
+7 DO EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
+8 QUIT
+9 ;
ERR(BSDXI,BSDXERR) ;Error processing
+1 SET BSDXI=BSDXI+1
+2 SET BSDXERR=$TRANSLATE(BSDXERR,"^","~")
+3 TROLLBACK
+4 SET ^BSDXTMP($JOB,BSDXI)="0^"_BSDXERR_$CHAR(30)
+5 SET BSDXI=BSDXI+1
+6 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+7 LOCK
+8 QUIT
+9 ;
ETRAP ;EP Error trap entry
+1 DO ^%ZTER
+2 IF '$DATA(BSDXI)
NEW BSDXI
SET BSDXI=999999
+3 SET BSDXI=BSDXI+1
+4 DO ERR(BSDXI,"BSDX07 Error: "_$GET(%ZTERROR))
+5 QUIT
+6 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
DOW SET %=$EXTRACT(X,1,3)
SET Y=$EXTRACT(X,4,5)
SET Y=Y>2&'(%#4)+$EXTRACT("144025036146",Y)
+1 FOR %=%:-1:281
SET Y=%#4=1+1+Y
+2 SET Y=$EXTRACT(X,6,7)+Y#7
+3 QUIT
+4 ;
AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
+1 ;SEE SDM1
+2 NEW Y,DFN
+3 NEW SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
+4 NEW X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
+5 SET Y=BSDXSCD
SET DFN=BSDXPATID
+6 SET SL=$GET(^SC(+Y,"SL"))
SET X=$PIECE(SL,U,3)
SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
SET SC=Y
SET SB=STARTDAY-1/100
SET X=$PIECE(SL,U,6)
SET HSI=$SELECT(X=1:X,X:X,1:4)
SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
KILL Y
+7 ;Determine maximum days for scheduling
+8 SET SDMAX(1)=$PIECE($GET(^SC(+SC,"SDP")),U,2)
IF 'SDMAX(1)
SET SDMAX(1)=365
+9 SET (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
+10 SET SDDATE=BSDXSTART
+11 SET SDSDATE=SDDATE
SET SDDATE=SDDATE\1
1 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
+1 IF $DATA(SDXXX)
QUIT
SET CCXN=0
KILL MXOK,COV,SDPROT
IF DFN<0
QUIT
SET SC=+SC
+2 SET X1=DT
SET SDEDT=365
IF $DATA(^SC(SC,"SDP"))
SET SDEDT=$PIECE(^SC(SC,"SDP"),"^",2)
+3 SET X2=SDEDT
DO C^%DTC
SET SDEDT=X
+4 SET Y=BSDXSTART
EN1 SET (X,SD)=Y
SET SM=0
DO DOW
S IF '$DATA(^SC(SC,"ST",$PIECE(SD,"."),1))
SET SS=+$ORDER(^SC(+SC,"T"_Y,SD))
IF SS'>0
QUIT
IF ^(SS,1)=""
QUIT
SET ^SC(+SC,"ST",$PIECE(SD,"."),1)=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(SD,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
SET ^(0)=$PIECE(SD,".")
+1 SET S=BSDXLEN
+2 ;Check if BSDXLEN evenly divisible by appointment length
+3 SET RPMSL=$PIECE(SL,U)
+4 IF BSDXLEN<RPMSL
SET BSDXLEN=RPMSL
+5 IF BSDXLEN#RPMSL'=0
Begin DoDot:1
+6 SET BSDXINC=BSDXLEN\RPMSL
+7 SET BSDXINC=BSDXINC+1
+8 SET BSDXLEN=RPMSL*BSDXINC
End DoDot:1
+9 SET SL=S_U_$PIECE(SL,U,2,99)
SC SET SDLOCK=$SELECT('$DATA(SDLOCK):1,1:SDLOCK+1)
IF SDLOCK>9
QUIT
+1 LOCK +^SC(SC,"ST",$PIECE(SD,"."),1):5
IF '$TEST
GOTO SC
+2 SET SDLOCK=0
SET S=^SC(SC,"ST",$PIECE(SD,"."),1)
+3 SET I=SD#1-SB*100
SET ST=I#1*SI\.6+($PIECE(I,".")*SI)
SET SS=SL*HSI/60*SDDIF+ST+ST
+4 IF (I<1!'$FIND(S,"["))&(S'["CAN")
LOCK -^SC(SC,"ST",$PIECE(SD,"."),1)
QUIT
+5 IF SM<7
SET %=$FIND(S,"[",SS-1)
IF '%!($PIECE(SL,"^",6)<3)
SET %=999
IF $FIND(S,"]",SS)'<%!(SDDIF=2&$EXTRACT(S,ST+ST+1,SS-1)["[")
SET SM=7
+6 ;
SP IF ST+ST>$LENGTH(S)
IF $LENGTH(S)<80
SET S=S_" "
GOTO SP
+1 SET SDNOT=1
+2 SET ABORT=0
+3 FOR I=ST+ST:SDDIF:SS-SDDIF
Begin DoDot:1
+4 SET ST=$EXTRACT(S,I+1)
IF ST=""
SET ST=" "
+5 SET Y=$EXTRACT(STR,$FIND(STR,ST)-2)
+6 IF S["CAN"!(ST="X"&($DATA(^SC(+SC,"ST",$PIECE(SD,"."),"CAN"))))
SET ABORT=1
QUIT
+7 IF Y=""
SET ABORT=1
QUIT
+8 IF Y'?1NL&(SM<6)
SET SM=6
SET ST=$EXTRACT(S,I+2,999)
IF ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I)_Y_ST
+9 QUIT
End DoDot:1
IF ABORT
QUIT
+10 SET ^SC(SC,"ST",$PIECE(SD,"."),1)=S
+11 LOCK -^SC(SC,"ST",$PIECE(SD,"."),1)
+12 QUIT
+13 ;
APPOVB(BSDXY,SDCL,NSDT,BSDXRES) ; RPC - BSDX OVERBOOK - CHECK FOR OVERBOOK FOR GIVEN CLINIC, DATE, AND RESOURCE
+1 ; .BSDXY = returned pointer to OVERBOOK data
+2 ; SDCL = clinic code - pointer to Hospital Location file ^SC
+3 ; NSDT = date/time of new appointment
+4 ; BSDXRES = resource to check for overbook
+5 GOTO APPOVB^BSDX07A
+6 ;
ERROR ;
+1 DO ERR1("RPMS Error")
+2 QUIT
+3 ;
ERR1(BSDXERR) ;Error processing
+1 ;vbObjectError
IF +BSDXERR
SET BSDXERR=ERRNO+134234112
+2 SET BSDXI=BSDXI+1
+3 SET ^BSDXTMP($JOB,BSDXI)=BSDXERR_$CHAR(30)
+4 SET BSDXI=BSDXI+1
+5 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+6 QUIT
