BSDX08.m

BSDX08 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 ;

 ;

APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP

 ;Entry point for debugging

 ;

 ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")

 Q

 ;

APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)        ;EP

 ;Called by BSDX CANCEL APPOINTMENT

 ;Cancels appointment

 ;BSDXAPTID is entry number in BSDX APPOINTMENT file

 ;BSDXTYP is C for clinic-cancelled and PC for patient cancelled

 ;BSDXCR is pointer to CANCELLATION REASON File (409.2)

 ;BSDXNOT is user note

 ;Returns error code in recordset field ERRORID

 ;

 N BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXERR

 N BSDXLOC,BSDXLEN,BSDXSCIEN

 N BSDXNOEV

 S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol

 ;

 D ^XBKVAR S X="ETRAP^BSDX08",@^%ZOSF("TRAP")

 S BSDXI=0

 K ^BSDXTMP($J)

 S BSDXY="^BSDXTMP("_$J_")"

 S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30)

 S BSDXI=BSDXI+1

 TSTART

 I '+BSDXAPTID D ERR(BSDXI,"BSDX08: Invalid Appointment ID") Q

 I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"BSDX08: Invalid Appointment ID") Q

 ;

 ;Delete APPOINTMENT entries

 S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)

 S BSDXPATID=$P(BSDXNOD,U,5)

 S BSDXSTART=$P(BSDXNOD,U)

 ;

 ;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") TROLLBACK  Q

 ;cancel BSDX APPOINTMENT record

 D BSDXCAN(BSDXAPTID)

 ;

 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID

 I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D  I +$G(BSDXZ) S BSDXERR=BSDXERR_$P(BSDXZ,U,2) D ERR(BSDXI,BSDXERR) Q

 . S BSDXNOD=^BSDXRES(BSDXSC1,0)

 . S BSDXLOC=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION

 . Q:'+BSDXLOC

 . S BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART) I BSDXSCIEN="" D  I 'BSDXZ Q  ;Q:BSDXZ

 . . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "

 . . S BSDXZ=1

 . . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 Q

 . . N BSDX1

 . . S BSDX1=0

 . . F  S BSDX1=$O(^BSDXRES(BSDXSC1,20,BSDX1)) Q:'+BSDX1  Q:BSDXZ=0  D

 . . . Q:'$D(^BSDXRES(BSDXSC1,20,BSDX1,0))

 . . . S BSDXLOC=$P(^BSDXRES(BSDXSC1,20,BSDX1,0),U)

 . . . S BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART) I +BSDXSCIEN S BSDXZ=0 Q

 . S BSDXERR="BSDX08: CANCEL^BSDAPI Returned "

 . I BSDXLOC']"" S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q

 . I '$D(^SC(BSDXLOC,0)) S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q

 . S BSDXNOD=$G(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))

 . I BSDXNOD="" S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q

 . S BSDXLEN=$P(BSDXNOD,U,2)

 . D APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXAPTID,BSDXLEN)

 . Q:+$G(BSDXZ)

 . D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)

 . ;L

 ;

 TCOMMIT

 L -^BSDXAPPT(BSDXPATID)

 S BSDXI=BSDXI+1

 S ^BSDXTMP($J,BSDXI)=""_$C(30)

 S BSDXI=BSDXI+1

 S ^BSDXTMP($J,BSDXI)=$C(31)

 Q

 ;

AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability

 ;See SDCNP0

 S (SD,S)=BSDXSTART

 S I=BSDXSCD

 Q:'$D(^SC(I,"ST",SD\1,1))

 S SL=^SC(I,"SL"),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y

 S SL=BSDXLEN

 S S=^SC(I,"ST",SD\1,1),Y=SD#1-SB*100,ST=Y#1*SI\.6+(Y\1*SI),SS=SL*HSI/60

 I Y'<1 F I=ST+ST:SDDIF S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y=""  S S=$E(S,1,I)_Y_$E(S,I+2,999),SS=SS-1 Q:SS'>0

 S ^SC(BSDXSCD,"ST",SD\1,1)=S

 Q

 ;

APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD,BSDXAPTID,BSDXLEN)         ;

 ;Cancel appointment for patient BSDXDFN in clinic BSDXSC1

 ;at time BSDXSD

 N BSDXPNOD,BSDXC,DA,DIE,DPTST,DR,%H

 ;save data in case of uncancel (status & appt length)

 S BSDXPNOD=^DPT(BSDXPATID,"S",BSDXSD,0)

 S DPTST=$P(BSDXPNOD,U,2)

 S DIE=9002018.4

 S DA=BSDXAPTID

 S DR=".17///"_DPTST_";"_".18///"_BSDXLEN

 D ^DIE

 S BSDXC("PAT")=BSDXDFN

 S BSDXC("CLN")=BSDXLOC

 S BSDXC("TYP")=BSDXTYP

 S BSDXC("ADT")=BSDXSD

 S %H=$H D YMD^%DTC

 S BSDXC("CDT")=X+%

 S BSDXC("NOT")=BSDXNOT

 S:'+$G(BSDXCR) BSDXCR=14 ;UNKNOWN REASON

 S BSDXC("CR")=BSDXCR

 S BSDXC("USR")=DUZ

 ;

 S BSDXZ=$$CANCEL(.BSDXC)

 Q

 ;

BSDXCAN(BSDXAPTID) ;

 ;Cancel BSDX APPOINTMENT entry

 N %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG

 S %DT="XT",X="NOW" D ^%DT ; X ^DD("DD")

 S BSDXDATE=Y

 S BSDXIENS=BSDXAPTID_","

 S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE

 K BSDXMSG

 D FILE^DIE("","BSDXFDA","BSDXMSG")

 Q

 ;

CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event

 ;when appointments cancelled via PIMS interface.

 ;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients

 N BSDXFOUND,BSDXRES

 Q:+$G(BSDXNOEV)

 Q:'+$G(BSDXSC)

 S BSDXFOUND=0

 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)

 I BSDXFOUND D CANEVT3(BSDXRES) Q

 I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)

 I BSDXFOUND D CANEVT3(BSDXRES)

 Q

 ;

CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;

 ;Get appointment id in BSDXAPT

 ;If found, call BSDXCAN(BSDXAPPT) and return 1

 ;else return 0

 N BSDXFOUND,BSDXAPPT

 S BSDXFOUND=0

 Q:'+BSDXRES BSDXFOUND

 Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND

 S BSDXAPPT=0 F  S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT  D  Q:BSDXFOUND

 . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""

 . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q

 I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)

 Q BSDXFOUND

 ;

CANEVT3(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

 ;

CANCEL(BSDR) ;EP; called to cancel appt

 ;

 ; Make call using: S ERR=$$CANCEL^BSDAPI(.ARRAY)

 ;

 ; Input Array -

 ; BSDR("PAT") = ien of patient in file 2

 ; BSDR("CLN") = ien of clinic in file 44

 ; BSDR("TYP") = C for canceled by clinic; PC for patient canceled

 ; BSDR("ADT") = appointment date and time

 ; BSDR("CDT") = cancel date and time

 ; BSDR("USR") = user who canceled appt

 ; BSDR("CR")  = cancel reason - pointer to file 409.2

 ; BSDR("NOT") = cancel remarks - optional notes to 160 characters

 ;

 ;Output: error status and message

 ;   = 0 or null:  everything okay

 ;   = 1^message:  error and reason

 ;

 I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))

 I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))

 I ($G(BSDR("TYP"))'="C"),($G(BSDR("TYP"))'="PC") Q 1_U_"Cancel Status error: "_$G(BSDR("TYP"))

 I $G(BSDR("ADT")) S BSDR("ADT")=+$E(BSDR("ADT"),1,12)  ;remove seconds

 I $G(BSDR("ADT"))'?7N1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))

 I $G(BSDR("CDT")) S BSDR("CDT")=+$E(BSDR("CDT"),1,12)  ;remove seconds

 I $G(BSDR("CDT"))'?7N1".".4N Q 1_U_"Cancel Date/Time error: "_$G(BSDR("CDT"))

 I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Canceled Appt Error: "_$G(BSDR("USR"))

 I '$D(^SD(409.2,+$G(BSDR("CR")))) Q 1_U_"Cancel Reason error: "_$G(BSDR("CR"))

 ;

 NEW IEN,DIE,DA,DR

 S IEN=$$SCIEN^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))

 I 'IEN Q 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")

 ;

 I $$CI^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) Q 1_U_"Patient already checked in; cannot cancel until checkin deleted: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")

 ;

 ; remember before status

 NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL

 S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN

 S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL

 D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)

 ;

 ; get user who made appt and date appt made from ^SC

 ;    because data in ^SC will be deleted

 NEW USER,DATE

 S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)

 S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)

 ;

 ; update file 2 info

 NEW DIE,DA,DR

 S DIE="^DPT("_DFN_",""S"",",DA(1)=DFN,DA=SDT

 S DR="3///"_BSDR("TYP")_";14///`"_BSDR("USR")_";15///"_BSDR("CDT")_";16///`"_BSDR("CR")_";19///`"_USER_";20///"_DATE

 S:$G(BSDR("NOT"))]"" DR=DR_";17///"_$E(BSDR("NOT"),1,160)

 D ^DIE

 ;

 ; delete data in ^SC

 NEW DIK,DA

 S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"

 S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN

 D ^DIK

 Q 0

 ;

APPUDEL(BSDXY,BSDXAPTID) ;EP  Undo Cancel

 ;called by BSDX UNCANCEL APPT

 ; BSDXAPTID = ien of appointment in BSDX APPOINTMENT (^BSDXAPPT) file 9002018.4

 N BSDXDAM,BSDXDEC,BSDXI,BSDXNOD,BSDXPATID,BSDXSTART

 S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol

 ;

 D ^XBKVAR S X="ETRAP^BSDX08",@^%ZOSF("TRAP")

 S BSDXI=0

 K ^BSDXTMP($J)

 S BSDXY="^BSDXTMP("_$J_")"

 S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30)

 TSTART

 I '+BSDXAPTID TROLLBACK  D ERR(BSDXI+1,"Invalid Appointment ID.") Q

 I '$D(^BSDXAPPT(BSDXAPTID,0)) TROLLBACK  D ERR(BSDXI+1,"Invalid Appointment ID") Q

 ;Make sure appointment is cancelled

 I $$GET1^DIQ(9002018.4,BSDXAPTID_",",.12)="" TROLLBACK  D ERR(BSDXI+1,"Appointment is not Cancelled.") Q

 ;appts cancelled by patient cannot be uncancelled.

 S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)

 I $P(^DPT($P(BSDXNOD,U,5),"S",$P(BSDXNOD,U,1),0),U,2)="PC" TROLLBACK  D ERR(BSDXI+1,"Cancelled by patient appointment can not be uncancelled.") Q

 ;get appointment data

 S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)

 S BSDXDAM=$P(BSDXNOD,U,9)                  ;date appt made

 S BSDXDEC=$P(BSDXNOD,U,8)                  ;data entry clerk

 S BSDXLEN=$P(BSDXNOD,U,18)                 ;length of appt in minutes

 S BSDXNOTE=$G(^BSDXAPPT(BSDXAPTID,1,1,0))  ;note from BSDX APPOINTMENT

 S BSDXPATID=$P(BSDXNOD,U,5)                ;pointer to VA PATIENT file 2

 S BSDXSC1=$P($G(BSDXNOD),U,7)              ;resource

 S BSDXSTART=$P(BSDXNOD,U)                  ;appt start time

 S BSDXWKIN=$P($G(BSDXNOD),U,13)            ;walkin

 ;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") TROLLBACK  Q

 ;uncancel BSDX APPOINTMENT

 D BSDXUCAN(BSDXAPTID)

 I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D  I +$G(BSDXZ) S BSDXERR=BSDXERR_$P(BSDXZ,U,2) D ERR(BSDXI,BSDXERR) Q

 . S BSDXNOD=^BSDXRES(BSDXSC1,0)

 . S BSDXLOC=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION

 . Q:'+BSDXLOC

 . ;uncancel patient appointment and re-instate clinic appointment

 . S BSDXZ=""

 . D APUCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXDAM,BSDXDEC,BSDXLEN,BSDXNOTE,BSDXSC1,BSDXWKIN)

 TCOMMIT

 L -^BSDXAPPT(BSDXPATID)

 S BSDXI=BSDXI+1

 S ^BSDXTMP($J,BSDXI)=""_$C(30)

 S BSDXI=BSDXI+1

 S ^BSDXTMP($J,BSDXI)=$C(31)

 Q

 ;

BSDXUCAN(BSDXAPTID) ;called internally to update BSDX APPOINTMENT by clearing cancel date/time

 S BSDXIENS=BSDXAPTID_","

 S BSDXFDA(9002018.4,BSDXIENS,.12)=""

 K BSDXMSG

 D FILE^DIE("","BSDXFDA","BSDXMSG")

 Q

 ;

APUCAN(BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXDAM,BSDXDEC,BSDXLEN,BSDXNOTE,BSDXRES,BSDXWKIN)         ;

 ;unCancel appointment for patient BSDXDFN in clinic BSDXSC1

 ;  BSDXLOC   = pointer to hospital location ^SC file 44

 ;  BSDXPATID = pointer to VA Patient ^DPT file 2

 ;  BSDXSTART = Appointment time

 ;  BSDXDAM   = Date appointment made in FM format

 ;  BSDXDEC   = Data entry clerk - pointer to NEW PERSON file 200

 N BSDXC,%H

 S BSDXC("PAT")=BSDXPATID

 S BSDXC("CLN")=BSDXLOC

 S BSDXC("ADT")=BSDXSTART

 S BSDXC("NOTE")=BSDXNOTE  ;user note

 S BSDXC("RES")=BSDXRES

 S BSDXC("USR")=DUZ

 S BSDXC("LEN")=BSDXLEN

 S BSDXC("WKIN")=BSDXWKIN

 ;

 S BSDXZ=$$UNCANCEL(.BSDXC)

 Q

 ;

UNCANCEL(BSDR) ;PEP; called to ucancel appt

 ;

 ; Make call using: S ERR=$$UNCANCEL(.ARRAY)

 ;

 ; Input Array -

 ; BSDR("PAT") = ien of patient in file 2

 ; BSDR("CLN") = ien of clinic in file 44

 ; BSDR("ADT") = appointment date and time

 ; BSDR("USR") = user who uncanceled appt

 ; BSDR("NOTE") = appointment note from BSDX APPOINTMENT

 ; BSDR("LEN") = appt length in minutes (numeric)

 ; BSDR("RES") = resource

 ; BSDR("WKIN")= walkin

 ;

 ;Output: error status and message

 ;   = 0 or null:  everything okay

 ;   = 1^message:  error and reason

 ;

 N DPTNOD,DPTNODR

 I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))

 I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))

 I $G(BSDR("ADT")) S BSDR("ADT")=+$E(BSDR("ADT"),1,12)  ;remove seconds

 I $G(BSDR("ADT"))'?7N1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))

 I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Canceled Appt Error: "_$G(BSDR("USR"))

 ;

 S BSDXERR=$$APPRPMS^BSDX07(BSDR("LEN"),BSDR("NOTE"),BSDR("PAT"),BSDR("RES"),BSDR("ADT"),BSDR("WKIN"))

 Q BSDXERR

 ;

ERR(BSDXI,BSDXERR) ;Error processing

 S BSDXI=BSDXI+1

 S BSDXERR=$TR(BSDXERR,"^","~")

 TROLLBACK

 S ^BSDXTMP($J,BSDXI)=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,"BSDX08 Error: "_$G(%ZTERROR))

 Q

BSDX08    ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 +1       ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 +2       ;

 +3       ;

APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP

 +1       ;Entry point for debugging

 +2       ;

 +3       ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")

 +4        QUIT 

 +5       ;

APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP

 +1       ;Called by BSDX CANCEL APPOINTMENT

 +2       ;Cancels appointment

 +3       ;BSDXAPTID is entry number in BSDX APPOINTMENT file

 +4       ;BSDXTYP is C for clinic-cancelled and PC for patient cancelled

 +5       ;BSDXCR is pointer to CANCELLATION REASON File (409.2)

 +6       ;BSDXNOT is user note

 +7       ;Returns error code in recordset field ERRORID

 +8       ;

 +9        NEW BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXERR

 +10       NEW BSDXLOC,BSDXLEN,BSDXSCIEN

 +11       NEW BSDXNOEV

 +12      ;Don't execute BSDX CANCEL APPOINTMENT protocol

           SET BSDXNOEV=1

 +13      ;

 +14       DO ^XBKVAR

           SET X="ETRAP^BSDX08"

           SET @^%ZOSF("TRAP")

 +15       SET BSDXI=0

 +16       KILL ^BSDXTMP($JOB)

 +17       SET BSDXY="^BSDXTMP("_$JOB_")"

 +18       SET ^BSDXTMP($JOB,BSDXI)="T00020ERRORID"_$CHAR(30)

 +19       SET BSDXI=BSDXI+1

 +20       TSTART 

 +21       IF '+BSDXAPTID

               DO ERR(BSDXI,"BSDX08: Invalid Appointment ID")

               QUIT 

 +22       IF '$DATA(^BSDXAPPT(BSDXAPTID,0))

               DO ERR(BSDXI,"BSDX08: Invalid Appointment ID")

               QUIT 

 +23      ;

 +24      ;Delete APPOINTMENT entries

 +25       SET BSDXNOD=^BSDXAPPT(BSDXAPTID,0)

 +26       SET BSDXPATID=$PIECE(BSDXNOD,U,5)

 +27       SET BSDXSTART=$PIECE(BSDXNOD,U)

 +28      ;

 +29      ;Lock BSDX node

 +30       LOCK +^BSDXAPPT(BSDXPATID):5

           IF '$TEST

               DO ERR(BSDXI+1,"Another user is working with this patient's record.  Please try again later")

               TROLLBACK 

               QUIT 

 +31      ;cancel BSDX APPOINTMENT record

 +32       DO BSDXCAN(BSDXAPTID)

 +33      ;

 +34      ;RESOURCEID

           SET BSDXSC1=$PIECE(BSDXNOD,U,7)

 +35       IF BSDXSC1]""

               IF $DATA(^BSDXRES(BSDXSC1,0))

                   Begin DoDot:1

 +36                   SET BSDXNOD=^BSDXRES(BSDXSC1,0)

 +37      ;HOSPITAL LOCATION

                       SET BSDXLOC=$PIECE(BSDXNOD,U,4)

 +38                   IF '+BSDXLOC

                           QUIT 

 +39      ;Q:BSDXZ

                       SET BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART)

                       IF BSDXSCIEN=""

                           Begin DoDot:2

 +40                           SET BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "

 +41                           SET BSDXZ=1

 +42                           IF '$DATA(^BSDXRES(BSDXSC1,20))

                                   SET BSDXZ=0

                                   QUIT 

 +43                           NEW BSDX1

 +44                           SET BSDX1=0

 +45                           FOR 

                                   SET BSDX1=$ORDER(^BSDXRES(BSDXSC1,20,BSDX1))

                                   IF '+BSDX1

                                       QUIT 

                                   IF BSDXZ=0

                                       QUIT 

                                   Begin DoDot:3

 +46                                   IF '$DATA(^BSDXRES(BSDXSC1,20,BSDX1,0))

                                           QUIT 

 +47                                   SET BSDXLOC=$PIECE(^BSDXRES(BSDXSC1,20,BSDX1,0),U)

 +48                                   SET BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART)

                                       IF +BSDXSCIEN

                                           SET BSDXZ=0

                                           QUIT 

                                   End DoDot:3

                           End DoDot:2

                           IF 'BSDXZ

                               QUIT 

 +49                   SET BSDXERR="BSDX08: CANCEL^BSDAPI Returned "

 +50                   IF BSDXLOC']""

                           SET BSDXZ="0^Unable to find associated RPMS appointment for this patient."

                           QUIT 

 +51                   IF '$DATA(^SC(BSDXLOC,0))

                           SET BSDXZ="0^Unable to find associated RPMS appointment for this patient."

                           QUIT 

 +52                   SET BSDXNOD=$GET(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))

 +53                   IF BSDXNOD=""

                           SET BSDXZ="0^Unable to find associated RPMS appointment for this patient."

                           QUIT 

 +54                   SET BSDXLEN=$PIECE(BSDXNOD,U,2)

 +55                   DO APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXAPTID,BSDXLEN)

 +56                   IF +$GET(BSDXZ)

                           QUIT 

 +57                   DO AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)

 +58      ;L

                   End DoDot:1

                   IF +$GET(BSDXZ)

                       SET BSDXERR=BSDXERR_$PIECE(BSDXZ,U,2)

                       DO ERR(BSDXI,BSDXERR)

                       QUIT 

 +59      ;

 +60       TCOMMIT 

 +61       LOCK -^BSDXAPPT(BSDXPATID)

 +62       SET BSDXI=BSDXI+1

 +63       SET ^BSDXTMP($JOB,BSDXI)=""_$CHAR(30)

 +64       SET BSDXI=BSDXI+1

 +65       SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)

 +66       QUIT 

 +67      ;

AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability

 +1       ;See SDCNP0

 +2        SET (SD,S)=BSDXSTART

 +3        SET I=BSDXSCD

 +4        IF '$DATA(^SC(I,"ST",SD\1,1))

               QUIT 

 +5        SET SL=^SC(I,"SL")

           SET X=$PIECE(SL,U,3)

           SET STARTDAY=$SELECT($LENGTH(X):X,1:8)

           SET SB=STARTDAY-1/100

           SET X=$PIECE(SL,U,6)

           SET HSI=$SELECT(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

 +6        SET SL=BSDXLEN

 +7        SET S=^SC(I,"ST",SD\1,1)

           SET Y=SD#1-SB*100

           SET ST=Y#1*SI\.6+(Y\1*SI)

           SET SS=SL*HSI/60

 +8        IF Y'<1

               FOR I=ST+ST:SDDIF

                   SET Y=$EXTRACT(STR,$FIND(STR,$EXTRACT(S,I+1)))

                   IF Y=""

                       QUIT 

                   SET S=$EXTRACT(S,1,I)_Y_$EXTRACT(S,I+2,999)

                   SET SS=SS-1

                   IF SS'>0

                       QUIT 

 +9        SET ^SC(BSDXSCD,"ST",SD\1,1)=S

 +10       QUIT 

 +11      ;

APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD,BSDXAPTID,BSDXLEN) ;

 +1       ;Cancel appointment for patient BSDXDFN in clinic BSDXSC1

 +2       ;at time BSDXSD

 +3        NEW BSDXPNOD,BSDXC,DA,DIE,DPTST,DR,%H

 +4       ;save data in case of uncancel (status & appt length)

 +5        SET BSDXPNOD=^DPT(BSDXPATID,"S",BSDXSD,0)

 +6        SET DPTST=$PIECE(BSDXPNOD,U,2)

 +7        SET DIE=9002018.4

 +8        SET DA=BSDXAPTID

 +9        SET DR=".17///"_DPTST_";"_".18///"_BSDXLEN

 +10       DO ^DIE

 +11       SET BSDXC("PAT")=BSDXDFN

 +12       SET BSDXC("CLN")=BSDXLOC

 +13       SET BSDXC("TYP")=BSDXTYP

 +14       SET BSDXC("ADT")=BSDXSD

 +15       SET %H=$HOROLOG

           DO YMD^%DTC

 +16       SET BSDXC("CDT")=X+%

 +17       SET BSDXC("NOT")=BSDXNOT

 +18      ;UNKNOWN REASON

           IF '+$GET(BSDXCR)

               SET BSDXCR=14

 +19       SET BSDXC("CR")=BSDXCR

 +20       SET BSDXC("USR")=DUZ

 +21      ;

 +22       SET BSDXZ=$$CANCEL(.BSDXC)

 +23       QUIT 

 +24      ;

BSDXCAN(BSDXAPTID) ;

 +1       ;Cancel BSDX APPOINTMENT entry

 +2        NEW %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG

 +3       ; X ^DD("DD")

           SET %DT="XT"

           SET X="NOW"

           DO ^%DT

 +4        SET BSDXDATE=Y

 +5        SET BSDXIENS=BSDXAPTID_","

 +6        SET BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE

 +7        KILL BSDXMSG

 +8        DO FILE^DIE("","BSDXFDA","BSDXMSG")

 +9        QUIT 

 +10      ;

CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event

 +1       ;when appointments cancelled via PIMS interface.

 +2       ;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients

 +3        NEW BSDXFOUND,BSDXRES

 +4        IF +$GET(BSDXNOEV)

               QUIT 

 +5        IF '+$GET(BSDXSC)

               QUIT 

 +6        SET BSDXFOUND=0

 +7        IF $DATA(^BSDXRES("ALOC",BSDXSC))

               SET BSDXRES=$ORDER(^BSDXRES("ALOC",BSDXSC,0))

               SET BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)

 +8        IF BSDXFOUND

               DO CANEVT3(BSDXRES)

               QUIT 

 +9        IF $DATA(^BXDXRES("ASSOC",BSDXSC))

               SET BSDXRES=$ORDER(^BSDXRES("ASSOC",BSDXSC,0))

               SET BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)

 +10       IF BSDXFOUND

               DO CANEVT3(BSDXRES)

 +11       QUIT 

 +12      ;

CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;

 +1       ;Get appointment id in BSDXAPT

 +2       ;If found, call BSDXCAN(BSDXAPPT) and return 1

 +3       ;else return 0

 +4        NEW BSDXFOUND,BSDXAPPT

 +5        SET BSDXFOUND=0

 +6        IF '+BSDXRES

               QUIT BSDXFOUND

 +7        IF '$DATA(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART))

               QUIT BSDXFOUND

 +8        SET BSDXAPPT=0

           FOR 

               SET BSDXAPPT=$ORDER(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT))

               IF '+BSDXAPPT

                   QUIT 

               Begin DoDot:1

 +9                SET BSDXNOD=$GET(^BSDXAPPT(BSDXAPPT,0))

                   IF BSDXNOD=""

                       QUIT 

 +10               IF $PIECE(BSDXNOD,U,5)=BSDXPAT

                       IF $PIECE(BSDXNOD,U,12)=""

                           SET BSDXFOUND=1

                           QUIT 

               End DoDot:1

               IF BSDXFOUND

                   QUIT 

 +11       IF BSDXFOUND

               IF +$GET(BSDXAPPT)

                   DO BSDXCAN(BSDXAPPT)

 +12       QUIT BSDXFOUND

 +13      ;

CANEVT3(BSDXRES) ;

 +1       ;Call RaiseEvent to notify GUI clients

 +2       ;

 +3        NEW BSDXRESN

 +4        SET BSDXRESN=$GET(^BSDXRES(BSDXRES,0))

 +5        IF BSDXRESN=""

               QUIT 

 +6        SET BSDXRESN=$PIECE(BSDXRESN,"^")

 +7       ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")

 +8        DO EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)

 +9        QUIT 

 +10      ;

CANCEL(BSDR) ;EP; called to cancel appt

 +1       ;

 +2       ; Make call using: S ERR=$$CANCEL^BSDAPI(.ARRAY)

 +3       ;

 +4       ; Input Array -

 +5       ; BSDR("PAT") = ien of patient in file 2

 +6       ; BSDR("CLN") = ien of clinic in file 44

 +7       ; BSDR("TYP") = C for canceled by clinic; PC for patient canceled

 +8       ; BSDR("ADT") = appointment date and time

 +9       ; BSDR("CDT") = cancel date and time

 +10      ; BSDR("USR") = user who canceled appt

 +11      ; BSDR("CR")  = cancel reason - pointer to file 409.2

 +12      ; BSDR("NOT") = cancel remarks - optional notes to 160 characters

 +13      ;

 +14      ;Output: error status and message

 +15      ;   = 0 or null:  everything okay

 +16      ;   = 1^message:  error and reason

 +17      ;

 +18       IF '$DATA(^DPT(+$GET(BSDR("PAT")),0))

               QUIT 1_U_"Patient not on file: "_$GET(BSDR("PAT"))

 +19       IF '$DATA(^SC(+$GET(BSDR("CLN")),0))

               QUIT 1_U_"Clinic not on file: "_$GET(BSDR("CLN"))

 +20       IF ($GET(BSDR("TYP"))'="C")

               IF ($GET(BSDR("TYP"))'="PC")

                   QUIT 1_U_"Cancel Status error: "_$GET(BSDR("TYP"))

 +21      ;remove seconds

           IF $GET(BSDR("ADT"))

               SET BSDR("ADT")=+$EXTRACT(BSDR("ADT"),1,12)

 +22       IF $GET(BSDR("ADT"))'?7N1".".4N

               QUIT 1_U_"Appt Date/Time error: "_$GET(BSDR("ADT"))

 +23      ;remove seconds

           IF $GET(BSDR("CDT"))

               SET BSDR("CDT")=+$EXTRACT(BSDR("CDT"),1,12)

 +24       IF $GET(BSDR("CDT"))'?7N1".".4N

               QUIT 1_U_"Cancel Date/Time error: "_$GET(BSDR("CDT"))

 +25       IF '$DATA(^VA(200,+$GET(BSDR("USR")),0))

               QUIT 1_U_"User Who Canceled Appt Error: "_$GET(BSDR("USR"))

 +26       IF '$DATA(^SD(409.2,+$GET(BSDR("CR"))))

               QUIT 1_U_"Cancel Reason error: "_$GET(BSDR("CR"))

 +27      ;

 +28       NEW IEN,DIE,DA,DR

 +29       SET IEN=$$SCIEN^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))

 +30       IF 'IEN

               QUIT 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")

 +31      ;

 +32       IF $$CI^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN)

               QUIT 1_U_"Patient already checked in; cannot cancel until checkin deleted: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")

 +33      ;