BSDX25 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
;
CHECKIND(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG,BSDXCR) ;EP
;Entry point for debugging
;
;I +$G(^BSDXDBUG("BREAK","CHECKIN")),+$G(^BSDXDBUG("BREAK"))=DUZ D DEBUG^%Serenji("CHECKIN^BSDX25(.BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)",$P(^BSDXDBUG("BREAK"),U,2))
;E G ENDBG
Q
;
CHECKIN(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG,BSDXCR,BSDXPCC,BSDXWHF) ;EP Check in appointment
;
; INPUT: BSDXAPTID - Appointment ID
; BSDXCDT - Check-in date/time. ("@" - indicates delete check-in)
; BSDXCC -
; BSDXPRV -
; BSDXROU - Print Routing Slip flag
; BSDXVCL -
; BSDXVFM -
; BSDXOG -
; BSDXCR - Generate Chart request upon check-in? (1-Yes, otherwise no)
; BSDXPCC - ien of PWH Type in HEALTH SUMMARY PWH TYPE file ^APCHPWHT
; BSDXWHF - Print Patient Wellness Handout flag
;
ENDBG ;
N BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXIENS,BSDXVEN
N BSDXNOEV,BSDXCAN,EMSG
S EMSG=""
S BSDXNOEV=1 ;Don't execute protocol
S BSDXCAN=0
;
D ^XBKVAR S X="ERROR^BSDX25",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="T00020ERRORID^T00150MESSAGE"_$C(30)
I '+BSDXAPTID D ERR("Invalid Appointment ID") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR("Invalid Appointment ID") Q
;
S:BSDXCDT="@" BSDXCAN=1
S:BSDXCDT["@0000" BSDXCDT=$P(BSDXCDT,"@")
S %DT="T",X=BSDXCDT D ^%DT S BSDXCDT=Y
I '$G(BSDXCAN),BSDXCDT=-1 D ERR(70) Q
I BSDXCDT>$$NOW^XLFDT S BSDXCDT=$$NOW^XLFDT
S BSDXCDT=$P(BSDXCDT,".",1)_"."_$E($P(BSDXCDT,".",2),1,4)
S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
S DFN=$P(BSDXNOD,U,5)
S BSDXPATID=$P(BSDXNOD,U,5)
S BSDXSTART=$P(BSDXNOD,U)
;
S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
;if resourceId is not null AND there is a valid resource record
I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I +$G(BSDXZ) D ERR($P(BSDXZ,U,2)) Q
. S BSDXNOD=^BSDXRES(BSDXSC1,0)
. S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
. ;Hospital Location is required for CHECKIN
. I 'BSDXSC1]"",'$D(^SC(+BSDXSC1,0)) D ERR("RPMS Clinic not defined for this Resource: "_$P(BSDXNOD,U,1)_" ("_BSDXSC1_")") Q
. ;Checkin BSDX APPOINTMENT entry
. D BSDXCHK(BSDXAPTID,$S(BSDXCAN:"",1:BSDXCDT)) ; sets field .03 (Checkin), in file 9002018.4
. ;Process cancel checkin
. I $G(BSDXCAN) D CANCHKIN(BSDXPATID,BSDXSC1,BSDXSTART) Q
. D APCHK(.BSDXZ,BSDXSC1,BSDXPATID,BSDXCDT,BSDXSTART,BSDXCC,BSDXPRV,BSDXVCL,BSDXVFM,BSDXOG)
. I $G(BSDXPRV) S DIE="^BSDXAPPT(",DA=BSDXAPTID,DR=".16///"_BSDXPRV D ^DIE
. ;S DGQUIET=1
. I $G(BSDXROU)="true" D WISD^BSDX42(DFN,$P(BSDXCDT,"."),"SD",,,.EMSG) ;print routing slip
. I $G(BSDXPCC)'="" D WISD^BSDX43(DFN,$P(BSDXCDT,"."),"SD",BSDXPCC,.EMSG) ;print PCC health summary
. I $G(BSDXWHF)="true" D WISDW^BSDX42(DFN,$P(BSDXCDT,"."),.EMSG) ;print patient wellness handout
. I $G(BSDXCR),$$GET1^DIQ(9002018.4,BSDXAPTID,.13)="YES" D
. . S BSDXDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05) I BSDXDEV="" D ERR("Chart request failed - No default file room printer found.") Q
. . S DGQUIET=1 D WISD^BSDROUT(BSDXPATID,$P(BSDXSTART,"."),"",BSDXDEV)
;
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)="0^"_$S(EMSG'="":EMSG,1:"")_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
BSDXCHK(BSDXAPTID,BSDXCDT) ;
;
S BSDXIENS=BSDXAPTID_","
S BSDXFDA(9002018.4,BSDXIENS,.03)=BSDXCDT
D FILE^DIE("","BSDXFDA","BSDXMSG")
Q
;
APCHK(BSDXZ,BSDXSC1,BSDXDFN,BSDXCDT,BSDXSTART,BSDXCC,BSDXPRV,BSDXVCL,BSDXVFM,BSDXOG) ;
;Checkin appointment for patient BSDXDFN in clinic BSDXSC1
;at time BSDXSD
N BSDXC,BSDXOUT,IEN
; BSDR("PAT") = ien of patient in file 2
; BSDR("CLN") = ien of clinic in file 44
; BSDR("ADT") = appt date/time
; BSDR("CDT") = checkin date/time
; BSDR("USR") = checkin user
S BSDXC("PAT")=BSDXDFN
;S BSDXC("CLN")=BSDXSC1
S BSDXC("HOS LOC")=BSDXSC1
;S BSDXC("CC")=BSDXCC
S BSDXC("CLINIC CODE")=$G(BSDXCC)
;S BSDXC("PRV")=$G(BSDXPRV)
S BSDXC("PROVIDER")=$G(BSDXPRV)
;S BSDXC("ADT")=BSDXSTART
S BSDXC("APPT DATE")=BSDXSTART
S BSDXC("CDT")=BSDXCDT
S BSDXC("USR")=DUZ
;find IEN in ^SC multiple or null
S APTN=$$FIND^SDAM2(BSDXC("PAT"),BSDXC("APPT DATE"),BSDXC("HOS LOC"))
;
;Required by NEW API:
S BSDXC("TIME RANGE")=-1
S BSDXC("VISIT DATE")=BSDXCDT ;IHS/HMW **1** 20060419
S BSDXC("SITE")=$G(DUZ(2))
S BSDXC("VISIT TYPE")=$$GET1^DIQ(9001001.2,BSDXC("SITE"),.11,"I")
I BSDXC("VISIT TYPE")="" S BSDXC("VISIT TYPE")=$$GET1^DIQ(9001000,BSDXC("SITE"),.04,"I")
I BSDXC("VISIT TYPE")="" S BSDXC("VISIT TYPE")="I"
S BSDXC("SRV CAT")=$$GET1^DIQ(9001001.2,BSDXC("SITE"),.12,"I")
I BSDXC("SRV CAT")="" S BSDXC("SRV CAT")="A"
;TELL LINDA ABOUT THESE 2 -- SAME VARIABLES WITH DIFFERENT NAMES
S BSDXC("CLN")=BSDXC("HOS LOC")
S BSDXC("ADT")=BSDXC("APPT DATE")
;
;Set up BSDXVEN array containing VEN EHP CLINIC, VEN EHP FORM, OUTGUIDE FLAG
;These values come from input param
S BSDXVEN("CLINIC")=$G(BSDXVCL)
S BSDXVEN("FORM")=$G(BSDXVFM)
S BSDXVEN("OUTGUIDE")=$G(BSDXOG)
;
S BSDXC("APCDAPPT")=$S($P(^DPT(BSDXC("PAT"),"S",BSDXC("APPT DATE"),0),U,7)=3:"A",$P(^DPT(BSDXC("PAT"),"S",BSDXC("APPT DATE"),0),U,7)=4:"W",1:"U") ;walk-in vs appt
I "CT"[BSDXC("SRV CAT") K BSDXC("APCDAPPT") ;not needed for phone calls & chart reviews
S BSDXC("APCDOPT")=$O(^DIC(19,"B","SD IHS PCC LINK",0))
S IEN=$$SCIEN^BSDU2(BSDXC("PAT"),BSDXC("HOS LOC"),BSDXC("APPT DATE")) ;find appt
; set checkin
K DIE,DA,DR
S DIE="^SC("_BSDXC("HOS LOC")_",""S"","_BSDXC("APPT DATE")_",1,"
S DA(2)=BSDXC("HOS LOC"),DA(1)=BSDXC("APPT DATE"),DA=IEN
S DR="309///"_BSDXC("VISIT DATE")_";302///`"_BSDXC("USR")_";305///"_$$NOW^XLFDT
D ^DIE
I $$GET1^DIQ(9009017.2,+BSDXC("HOS LOC"),.09)'="YES" Q ;don't create visit
S BSDXC("CALLER")="BSD CHECKIN"
D GETVISIT^BSDAPI4(.BSDXC,.BSDXOUT) ;call to check for existing visit and checkin appt; checkin appt should create visit if needed
;if we came back with at least 1 existing visit, we are done; otherwise we need to create a visit.
I 'BSDXOUT(0) D
. S BSDXC("FORCE ADD")=1
. D GETVISIT^BSDAPI4(.BSDXC,.BSDXOUT)
;
; add provider to visit
I $G(BSDXC("PROVIDER")) D
. N BSDXVSTR,BSDXIEN
. S BSDXIEN=$O(BSDXOUT(0))
. S BSDXVSTR=$$VIS2VSTR^BEHOENCX(BSDXC("PAT"),BSDXIEN)
. D UPDPRV^BEHOENCX(,BSDXC("PAT"),BSDXVSTR,BSDXC("PROVIDER"))
Q
;
CANCHKIN(DFN,SDCL,SDT) ; Logic to cancel a checkin if the checkin date/time is passed in as '@'
; input: DFN := ifn of patient
; SDCL := clinic#
; SDT := appt d/t
;
N SDDA
S SDDA=$$FIND(DFN,SDT,SDCL)
;I 'SDDA D ERR("BSDX25: Could not locate appointment in database or appointment is cancelled.") Q
I 'SDDA D ERR("Could not locate appointment in database or appointment is cancelled.") Q
N SDATA,SDCIHDL,X S SDATA=SDDA_U_DFN_U_SDT_U_SDCL,SDCIHDL=$$HANDLE^SDAMEVT(1)
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
S FDA(44.003,SDDA_","_SDT_","_SDCL_",",309)="" D FILE^DIE(,"FDA","ERR")
D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
D CHKEVTD(DFN,SDT,SDCL)
K FDA,ERR
Q
;
FIND(DFN,SDT,SDCL) ; -- return appt ifn for pat
; input: DFN := ifn of pat.
; SDT := appt d/t
; SDCL := ifn of clinic
; output: [returned] := ifn if pat has appt on date/time
;
N Y
S Y=0 F S Y=$O(^SC(SDCL,"S",SDT,1,Y)) Q:'Y I $D(^(Y,0)),DFN=+^(0),$D(^DPT(+DFN,"S",SDT,0)),$$VALID(DFN,SDCL,SDT,Y) Q
Q Y
;
VALID(DFN,SDCL,SDT,SDDA) ; -- return valid appt.
; **NOTE: For speed consideration the ^SC and ^DPT nodes must be
; check to see they exist prior to calling this entry point.
; input: DFN := ifn of pat.
; SDT := appt d/t
; SDCL := ifn of clinic
; SDDA := ifn of appt
; output: [returned] := 1 for valid appt., 0 for not valid
Q $S($P(^SC(SDCL,"S",SDT,1,SDDA,0),U,9)'="C":1,$P(^DPT(DFN,"S",SDT,0),U,2)["C":1,1:0)
;
CHKEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CHECKIN APPOINTMENT event
;when appointments CHECKIN via PIMS interface.
;Propagates CHECKIN to BSDXAPPT and raises refresh event to running GUI clients
;
Q:+$G(BSDXNOEV)
Q:'+$G(BSDXSC)
N BSDXSTAT,BSDXFOUND,BSDXRES
S BSDXSTAT=""
S:$G(SDATA("AFTER","STATUS"))["CHECKED IN" BSDXSTAT=$P(SDATA("AFTER","STATUS"),"^",4)
S BSDXFOUND=0
I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
I BSDXFOUND D CHKEVT3(BSDXRES) Q
I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
I BSDXFOUND D CHKEVT3(BSDXRES)
Q
;
CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ;
;Get appointment id in BSDXAPT
;If found, call BSDXNOS(BSDXAPPT) and return 1
;else return 0
N BSDXFOUND,BSDXAPPT
S BSDXFOUND=0
Q:'+$G(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 BSDXCHK(BSDXAPPT,BSDXSTAT)
Q BSDXFOUND
;
CHKEVT3(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
;
CHKEVTD(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CHECKIN APPOINTMENT event
;when an appointment CHECKIN is deleted via.
;Deletes CHECKIN to and raises refresh event to running GUI clients
;
;
Q:+$G(BSDXNOEV)
Q:'+$G(BSDXSC)
N BSDXSTAT,BSDXFOUND,BSDXRES
S BSDXSTAT=""
S:$G(SDATA("AFTER","STATUS"))'="CHECKED IN" BSDXSTAT=$P(SDATA("AFTER","STATUS"),"^",4)
I BSDXSTAT="" S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
I BSDXRES D CHKEVT3(BSDXRES) Q
S BSDXFOUND=0
;
;I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
;I BSDXFOUND D CHKEVT3(BSDXRES) Q
;I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
;I BSDXFOUND D CHKEVT3(BSDXRES)
Q
;
;CHECK OUT APPOINTMENT - RPC
CHECKOUT(BSDXY,DFN,SDT,SDCODT,BSDXAPTID,VPRV) ;EP Check Out appointment
; Returns BSDXY
; Input -- DFN Patient file IEN
; SDT Appointment Date/Time in FM format
; SDCODT Date/Time of Check Out FM FORMAT [REQUIRED]
; BSDXAPTID - Appointment ID
; VPRV - V Provider
; called by BSDX CHECKOUT APPOINTMENT remote procedure
;SETUP ERROR TRACKING
D ^XBKVAR S X="ERROR^BSDX25",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
I '+BSDXAPTID D ERR("Invalid Appointment ID.") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR("Invalid Appointment ID.") Q
;INITIALIZE VARIABLES
S %DT="T"
S X=SDT
D ^%DT ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
S SDT=Y
S X=SDCODT
D ^%DT ; GET FM FORMAT FOR CHECKOUT DATE/TIME
;ChecOut time cannot be in the future
S SDCODT=Y
I SDCODT>$$HTFM^XLFDT($H) D ERR("Check Out time cannot be in the future.") Q
;
;appointment record
S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
;make sure CHECKOUT time is after CHECKIN time
I SDCODT<=$P(BSDXNOD,U,3) D ERR("Check Out time must be at least 1 minute after the Check In time of "_$TR($$FMTE^XLFDT($P(BSDXNOD,U,3)),"@"," ")_".") Q
;Hospital Location of RESOURCE
S BSDXRES=$P(BSDXNOD,U,7) ;RESOURCEID
S BSDXNOD=^BSDXRES(BSDXRES,0)
S SDCL=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
;
S SDDA=0
S SDASK=0
S SDCOALBF=""
S SDCOACT="CO"
S SDLNE=""
S SDQUIET=1
K APIERR
S APIERR=0
D CO^BSDX25A(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOACT,SDLNE,.SDCOALBF,BSDXAPTID,SDQUIET,VPRV,.APIERR) ;Appt Check Out
;ERROR(S) FOUND
I APIERR>0 D
. S CNT=""
. F S CNT=$O(APIERR(CNT),1,ERR) Q:CNT="" S BSDXI=BSDXI+1 D ERR(ERR)
;NO ERROR
I APIERR<1 D
. S BSDXI=BSDXI+1
. S ^BSDXTMP($J,BSDXI)="0"_$C(30)
. S BSDXI=BSDXI+1
. S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
;CHECK OUT APPOINTMENT - RPC
CANCKOUT(BSDXY,BSDXAPTID) ;EP Check Out appointment
; Returns BSDXY
; Input -- BSDXAPTID - Appointment ID
; called by BSDX CANCEL CHECKOUT APPT remote procedure
;SETUP ERROR TRACKING
D ^XBKVAR S X="ERROR^BSDX25",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
I '+BSDXAPTID D ERR("Invalid Appointment ID.") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR("Invalid Appointment ID.") Q
S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
S APS=$P(BSDXNOD,U,19)
S DFN=$P(BSDXNOD,U,5)
S SDT=$P(BSDXNOD,U)
S RES=$P(BSDXNOD,U,7)
S SDCL=$P(^BSDXRES(RES,0),U,4)
I $P(BSDXNOD,U,14)="" D ERR("Appointment is not Checked Out.") Q
; ^BSDXAPPT: update piece 8: Data Entry Clerk; clear piece 14: CHECKOUT;
S DIE="^BSDXAPPT("
S DA=BSDXAPTID
S DR=".14////@;.08///"_DUZ
D ^DIE
; ^SC file 44: clear piece C;3: CHECKED OUT; clear piece C;4: CHECK OUT USER; clear C;6: CHECK OUT ENTERED
S DIE="^SC("_SDCL_",""S"","_SDT_",1,"
S DA(2)=SDCL,DA(1)=SDT,(DA,SDN)=$$SCIEN^BSDU2(DFN,SDCL,SDT)
S DR="303///@;304///@;306///@"
D ^DIE
; ^AUPNVSIT file 9000010: clear piece 18: CHECK OUT DATE&TIME
S SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
S SDV=$$GET1^DIQ(409.68,SDOE,.05,"I")
I +SDV D
. S DIE="^AUPNVSIT(",DA=SDV
. S DR=".18///@"
. D ^DIE S AUPNVSIT=SDV D MOD^AUPNVSIT
; ^SCE file 409.68: Set piece 12 back to CHECKED IN, pointer to APPOINTMENT STATUS file 409.63; clear piece 7: CHECK OUT PROCESS COMPLETION
I +APS D
. S DIE=409.68,DA=SDOE,DR=".07///@;.12///"_APS
. D ^DIE
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)="0"_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
ERROR ;
D ERR("RPMS Error")
Q
;
ERR(ERRNO) ;Error processing
I +ERRNO S BSDXERR=ERRNO+134234112 ;vbObjectError
E S BSDXERR=ERRNO
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
BSDX25 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
+3 ;
CHECKIND(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG,BSDXCR) ;EP
+1 ;Entry point for debugging
+2 ;
+3 ;I +$G(^BSDXDBUG("BREAK","CHECKIN")),+$G(^BSDXDBUG("BREAK"))=DUZ D DEBUG^%Serenji("CHECKIN^BSDX25(.BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)",$P(^BSDXDBUG("BREAK"),U,2))
+4 ;E G ENDBG
+5 QUIT
+6 ;
CHECKIN(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG,BSDXCR,BSDXPCC,BSDXWHF) ;EP Check in appointment
+1 ;
+2 ; INPUT: BSDXAPTID - Appointment ID
+3 ; BSDXCDT - Check-in date/time. ("@" - indicates delete check-in)
+4 ; BSDXCC -
+5 ; BSDXPRV -
+6 ; BSDXROU - Print Routing Slip flag
+7 ; BSDXVCL -
+8 ; BSDXVFM -
+9 ; BSDXOG -
+10 ; BSDXCR - Generate Chart request upon check-in? (1-Yes, otherwise no)
+11 ; BSDXPCC - ien of PWH Type in HEALTH SUMMARY PWH TYPE file ^APCHPWHT
+12 ; BSDXWHF - Print Patient Wellness Handout flag
+13 ;
ENDBG ;
+1 NEW BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXIENS,BSDXVEN
+2 NEW BSDXNOEV,BSDXCAN,EMSG
+3 SET EMSG=""
+4 ;Don't execute protocol
SET BSDXNOEV=1
+5 SET BSDXCAN=0
+6 ;
+7 DO ^XBKVAR
SET X="ERROR^BSDX25"
SET @^%ZOSF("TRAP")
+8 SET BSDXI=0
+9 KILL ^BSDXTMP($JOB)
+10 SET BSDXY="^BSDXTMP("_$JOB_")"
+11 SET ^BSDXTMP($JOB,0)="T00020ERRORID^T00150MESSAGE"_$CHAR(30)
+12 IF '+BSDXAPTID
DO ERR("Invalid Appointment ID")
QUIT
+13 IF '$DATA(^BSDXAPPT(BSDXAPTID,0))
DO ERR("Invalid Appointment ID")
QUIT
+14 ;
+15 IF BSDXCDT="@"
SET BSDXCAN=1
+16 IF BSDXCDT["@0000"
SET BSDXCDT=$PIECE(BSDXCDT,"@")
+17 SET %DT="T"
SET X=BSDXCDT
DO ^%DT
SET BSDXCDT=Y
+18 IF '$GET(BSDXCAN)
IF BSDXCDT=-1
DO ERR(70)
QUIT
+19 IF BSDXCDT>$$NOW^XLFDT
SET BSDXCDT=$$NOW^XLFDT
+20 SET BSDXCDT=$PIECE(BSDXCDT,".",1)_"."_$EXTRACT($PIECE(BSDXCDT,".",2),1,4)
+21 SET BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
+22 SET DFN=$PIECE(BSDXNOD,U,5)
+23 SET BSDXPATID=$PIECE(BSDXNOD,U,5)
+24 SET BSDXSTART=$PIECE(BSDXNOD,U)
+25 ;
+26 ;RESOURCEID
SET BSDXSC1=$PIECE(BSDXNOD,U,7)
+27 ;if resourceId is not null AND there is a valid resource record
+28 IF BSDXSC1]""
IF $DATA(^BSDXRES(BSDXSC1,0))
Begin DoDot:1
+29 SET BSDXNOD=^BSDXRES(BSDXSC1,0)
+30 ;HOSPITAL LOCATION
SET BSDXSC1=$PIECE(BSDXNOD,U,4)
+31 ;Hospital Location is required for CHECKIN
+32 IF 'BSDXSC1]""
IF '$DATA(^SC(+BSDXSC1,0))
DO ERR("RPMS Clinic not defined for this Resource: "_$PIECE(BSDXNOD,U,1)_" ("_BSDXSC1_")")
QUIT
+33 ;Checkin BSDX APPOINTMENT entry
+34 ; sets field .03 (Checkin), in file 9002018.4
DO BSDXCHK(BSDXAPTID,$SELECT(BSDXCAN:"",1:BSDXCDT))
+35 ;Process cancel checkin
+36 IF $GET(BSDXCAN)
DO CANCHKIN(BSDXPATID,BSDXSC1,BSDXSTART)
QUIT
+37 DO APCHK(.BSDXZ,BSDXSC1,BSDXPATID,BSDXCDT,BSDXSTART,BSDXCC,BSDXPRV,BSDXVCL,BSDXVFM,BSDXOG)
+38 IF $GET(BSDXPRV)
SET DIE="^BSDXAPPT("
SET DA=BSDXAPTID
SET DR=".16///"_BSDXPRV
DO ^DIE
+39 ;S DGQUIET=1
+40 ;print routing slip
IF $GET(BSDXROU)="true"
DO WISD^BSDX42(DFN,$PIECE(BSDXCDT,"."),"SD",,,.EMSG)
+41 ;print PCC health summary
IF $GET(BSDXPCC)'=""
DO WISD^BSDX43(DFN,$PIECE(BSDXCDT,"."),"SD",BSDXPCC,.EMSG)
+42 ;print patient wellness handout
IF $GET(BSDXWHF)="true"
DO WISDW^BSDX42(DFN,$PIECE(BSDXCDT,"."),.EMSG)
+43 IF $GET(BSDXCR)
IF $$GET1^DIQ(9002018.4,BSDXAPTID,.13)="YES"
Begin DoDot:2
+44 SET BSDXDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05)
IF BSDXDEV=""
DO ERR("Chart request failed - No default file room printer found.")
QUIT
+45 SET DGQUIET=1
DO WISD^BSDROUT(BSDXPATID,$PIECE(BSDXSTART,"."),"",BSDXDEV)
End DoDot:2
End DoDot:1
IF +$GET(BSDXZ)
DO ERR($PIECE(BSDXZ,U,2))
QUIT
+46 ;
+47 SET BSDXI=BSDXI+1
+48 SET ^BSDXTMP($JOB,BSDXI)="0^"_$SELECT(EMSG'="":EMSG,1:"")_$CHAR(30)
+49 SET BSDXI=BSDXI+1
+50 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+51 QUIT
+52 ;
BSDXCHK(BSDXAPTID,BSDXCDT) ;
+1 ;
+2 SET BSDXIENS=BSDXAPTID_","
+3 SET BSDXFDA(9002018.4,BSDXIENS,.03)=BSDXCDT
+4 DO FILE^DIE("","BSDXFDA","BSDXMSG")
+5 QUIT
+6 ;
APCHK(BSDXZ,BSDXSC1,BSDXDFN,BSDXCDT,BSDXSTART,BSDXCC,BSDXPRV,BSDXVCL,BSDXVFM,BSDXOG) ;
+1 ;Checkin appointment for patient BSDXDFN in clinic BSDXSC1
+2 ;at time BSDXSD
+3 NEW BSDXC,BSDXOUT,IEN
+4 ; BSDR("PAT") = ien of patient in file 2
+5 ; BSDR("CLN") = ien of clinic in file 44
+6 ; BSDR("ADT") = appt date/time
+7 ; BSDR("CDT") = checkin date/time
+8 ; BSDR("USR") = checkin user
+9 SET BSDXC("PAT")=BSDXDFN
+10 ;S BSDXC("CLN")=BSDXSC1
+11 SET BSDXC("HOS LOC")=BSDXSC1
+12 ;S BSDXC("CC")=BSDXCC
+13 SET BSDXC("CLINIC CODE")=$GET(BSDXCC)
+14 ;S BSDXC("PRV")=$G(BSDXPRV)
+15 SET BSDXC("PROVIDER")=$GET(BSDXPRV)
+16 ;S BSDXC("ADT")=BSDXSTART
+17 SET BSDXC("APPT DATE")=BSDXSTART
+18 SET BSDXC("CDT")=BSDXCDT
+19 SET BSDXC("USR")=DUZ
+20 ;find IEN in ^SC multiple or null
+21 SET APTN=$$FIND^SDAM2(BSDXC("PAT"),BSDXC("APPT DATE"),BSDXC("HOS LOC"))
+22 ;
+23 ;Required by NEW API:
+24 SET BSDXC("TIME RANGE")=-1
+25 ;IHS/HMW **1** 20060419
SET BSDXC("VISIT DATE")=BSDXCDT
+26 SET BSDXC("SITE")=$GET(DUZ(2))
+27 SET BSDXC("VISIT TYPE")=$$GET1^DIQ(9001001.2,BSDXC("SITE"),.11,"I")
+28 IF BSDXC("VISIT TYPE")=""
SET BSDXC("VISIT TYPE")=$$GET1^DIQ(9001000,BSDXC("SITE"),.04,"I")
+29 IF BSDXC("VISIT TYPE")=""
SET BSDXC("VISIT TYPE")="I"
+30 SET BSDXC("SRV CAT")=$$GET1^DIQ(9001001.2,BSDXC("SITE"),.12,"I")
+31 IF BSDXC("SRV CAT")=""
SET BSDXC("SRV CAT")="A"
+32 ;TELL LINDA ABOUT THESE 2 -- SAME VARIABLES WITH DIFFERENT NAMES
+33 SET BSDXC("CLN")=BSDXC("HOS LOC")
+34 SET BSDXC("ADT")=BSDXC("APPT DATE")
+35 ;
+36 ;Set up BSDXVEN array containing VEN EHP CLINIC, VEN EHP FORM, OUTGUIDE FLAG
+37 ;These values come from input param
+38 SET BSDXVEN("CLINIC")=$GET(BSDXVCL)
+39 SET BSDXVEN("FORM")=$GET(BSDXVFM)
+40 SET BSDXVEN("OUTGUIDE")=$GET(BSDXOG)
+41 ;
+42 ;walk-in vs appt
SET BSDXC("APCDAPPT")=$SELECT($PIECE(^DPT(BSDXC("PAT"),"S",BSDXC("APPT DATE"),0),U,7)=3:"A",$PIECE(^DPT(BSDXC("PAT"),"S",BSDXC("APPT DATE"),0),U,7)=4:"W",1:"U")
+43 ;not needed for phone calls & chart reviews
IF "CT"[BSDXC("SRV CAT")
KILL BSDXC("APCDAPPT")
+44 SET BSDXC("APCDOPT")=$ORDER(^DIC(19,"B","SD IHS PCC LINK",0))
+45 ;find appt
SET IEN=$$SCIEN^BSDU2(BSDXC("PAT"),BSDXC("HOS LOC"),BSDXC("APPT DATE"))
+46 ; set checkin
+47 KILL DIE,DA,DR
+48 SET DIE="^SC("_BSDXC("HOS LOC")_",""S"","_BSDXC("APPT DATE")_",1,"
+49 SET DA(2)=BSDXC("HOS LOC")
SET DA(1)=BSDXC("APPT DATE")
SET DA=IEN
+50 SET DR="309///"_BSDXC("VISIT DATE")_";302///`"_BSDXC("USR")_";305///"_$$NOW^XLFDT
+51 DO ^DIE
+52 ;don't create visit
IF $$GET1^DIQ(9009017.2,+BSDXC("HOS LOC"),.09)'="YES"
QUIT
+53 SET BSDXC("CALLER")="BSD CHECKIN"
+54 ;call to check for existing visit and checkin appt; checkin appt should create visit if needed
DO GETVISIT^BSDAPI4(.BSDXC,.BSDXOUT)
+55 ;if we came back with at least 1 existing visit, we are done; otherwise we need to create a visit.
+56 IF 'BSDXOUT(0)
Begin DoDot:1
+57 SET BSDXC("FORCE ADD")=1
+58 DO GETVISIT^BSDAPI4(.BSDXC,.BSDXOUT)
End DoDot:1
+59 ;
+60 ; add provider to visit
+61 IF $GET(BSDXC("PROVIDER"))
Begin DoDot:1
+62 NEW BSDXVSTR,BSDXIEN
+63 SET BSDXIEN=$ORDER(BSDXOUT(0))
+64 SET BSDXVSTR=$$VIS2VSTR^BEHOENCX(BSDXC("PAT"),BSDXIEN)
+65 DO UPDPRV^BEHOENCX(,BSDXC("PAT"),BSDXVSTR,BSDXC("PROVIDER"))
End DoDot:1
+66 QUIT
+67 ;
CANCHKIN(DFN,SDCL,SDT) ; Logic to cancel a checkin if the checkin date/time is passed in as '@'
+1 ; input: DFN := ifn of patient
+2 ; SDCL := clinic#
+3 ; SDT := appt d/t
+4 ;
+5 NEW SDDA
+6 SET SDDA=$$FIND(DFN,SDT,SDCL)
+7 ;I 'SDDA D ERR("BSDX25: Could not locate appointment in database or appointment is cancelled.") Q
+8 IF 'SDDA
DO ERR("Could not locate appointment in database or appointment is cancelled.")
QUIT
+9 NEW SDATA,SDCIHDL,X
SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
SET SDCIHDL=$$HANDLE^SDAMEVT(1)
+10 DO BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
+11 SET FDA(44.003,SDDA_","_SDT_","_SDCL_",",309)=""
DO FILE^DIE(,"FDA","ERR")
+12 DO AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
+13 DO CHKEVTD(DFN,SDT,SDCL)
+14 KILL FDA,ERR
+15 QUIT
+16 ;
FIND(DFN,SDT,SDCL) ; -- return appt ifn for pat
+1 ; input: DFN := ifn of pat.
+2 ; SDT := appt d/t
+3 ; SDCL := ifn of clinic
+4 ; output: [returned] := ifn if pat has appt on date/time
+5 ;
+6 NEW Y
+7 SET Y=0
FOR
SET Y=$ORDER(^SC(SDCL,"S",SDT,1,Y))
IF 'Y
QUIT
IF $DATA(^(Y,0))
IF DFN=+^(0)
IF $DATA(^DPT(+DFN,"S",SDT,0))
IF $$VALID(DFN,SDCL,SDT,Y)
QUIT
+8 QUIT Y
+9 ;
VALID(DFN,SDCL,SDT,SDDA) ; -- return valid appt.
+1 ; **NOTE: For speed consideration the ^SC and ^DPT nodes must be
+2 ; check to see they exist prior to calling this entry point.
+3 ; input: DFN := ifn of pat.
+4 ; SDT := appt d/t
+5 ; SDCL := ifn of clinic
+6 ; SDDA := ifn of appt
+7 ; output: [returned] := 1 for valid appt., 0 for not valid
+8 QUIT $SELECT($PIECE(^SC(SDCL,"S",SDT,1,SDDA,0),U,9)'="C":1,$PIECE(^DPT(DFN,"S",SDT,0),U,2)["C":1,1:0)
+9 ;
CHKEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CHECKIN APPOINTMENT event
+1 ;when appointments CHECKIN via PIMS interface.
+2 ;Propagates CHECKIN to BSDXAPPT and raises refresh event to running GUI clients
+3 ;
+4 IF +$GET(BSDXNOEV)
QUIT
+5 IF '+$GET(BSDXSC)
QUIT
+6 NEW BSDXSTAT,BSDXFOUND,BSDXRES
+7 SET BSDXSTAT=""
+8 IF $GET(SDATA("AFTER","STATUS"))["CHECKED IN"
SET BSDXSTAT=$PIECE(SDATA("AFTER","STATUS"),"^",4)
+9 SET BSDXFOUND=0
+10 IF $DATA(^BSDXRES("ALOC",BSDXSC))
SET BSDXRES=$ORDER(^BSDXRES("ALOC",BSDXSC,0))
SET BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
+11 IF BSDXFOUND
DO CHKEVT3(BSDXRES)
QUIT
+12 IF $DATA(^BXDXRES("ASSOC",BSDXSC))
SET BSDXRES=$ORDER(^BSDXRES("ASSOC",BSDXSC,0))
SET BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
+13 IF BSDXFOUND
DO CHKEVT3(BSDXRES)
+14 QUIT
+15 ;
CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ;
+1 ;Get appointment id in BSDXAPT
+2 ;If found, call BSDXNOS(BSDXAPPT) and return 1
+3 ;else return 0
+4 NEW BSDXFOUND,BSDXAPPT
+5 SET BSDXFOUND=0
+6 IF '+$GET(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 BSDXCHK(BSDXAPPT,BSDXSTAT)
+12 QUIT BSDXFOUND
+13 ;
CHKEVT3(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 ;
CHKEVTD(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CHECKIN APPOINTMENT event
+1 ;when an appointment CHECKIN is deleted via.
+2 ;Deletes CHECKIN to and raises refresh event to running GUI clients
+3 ;
+4 ;
+5 IF +$GET(BSDXNOEV)
QUIT
+6 IF '+$GET(BSDXSC)
QUIT
+7 NEW BSDXSTAT,BSDXFOUND,BSDXRES
+8 SET BSDXSTAT=""
+9 IF $GET(SDATA("AFTER","STATUS"))'="CHECKED IN"
SET BSDXSTAT=$PIECE(SDATA("AFTER","STATUS"),"^",4)
+10 IF BSDXSTAT=""
SET BSDXRES=$ORDER(^BSDXRES("ALOC",BSDXSC,0))
+11 IF BSDXRES
DO CHKEVT3(BSDXRES)
QUIT
+12 SET BSDXFOUND=0
+13 ;
+14 ;I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
+15 ;I BSDXFOUND D CHKEVT3(BSDXRES) Q
+16 ;I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
+17 ;I BSDXFOUND D CHKEVT3(BSDXRES)
+18 QUIT
+19 ;
+20 ;CHECK OUT APPOINTMENT - RPC
CHECKOUT(BSDXY,DFN,SDT,SDCODT,BSDXAPTID,VPRV) ;EP Check Out appointment
+1 ; Returns BSDXY
+2 ; Input -- DFN Patient file IEN
+3 ; SDT Appointment Date/Time in FM format
+4 ; SDCODT Date/Time of Check Out FM FORMAT [REQUIRED]
+5 ; BSDXAPTID - Appointment ID
+6 ; VPRV - V Provider
+7 ; called by BSDX CHECKOUT APPOINTMENT remote procedure
+8 ;SETUP ERROR TRACKING
+9 DO ^XBKVAR
SET X="ERROR^BSDX25"
SET @^%ZOSF("TRAP")
+10 SET BSDXI=0
+11 KILL ^BSDXTMP($JOB)
+12 SET BSDXY="^BSDXTMP("_$JOB_")"
+13 SET ^BSDXTMP($JOB,0)="T00020ERRORID"_$CHAR(30)
+14 IF '+BSDXAPTID
DO ERR("Invalid Appointment ID.")
QUIT
+15 IF '$DATA(^BSDXAPPT(BSDXAPTID,0))
DO ERR("Invalid Appointment ID.")
QUIT
+16 ;INITIALIZE VARIABLES
+17 SET %DT="T"
+18 SET X=SDT
+19 ; GET FM FORMAT FOR APPOINTMENT DATE/TIME
DO ^%DT
+20 SET SDT=Y
+21 SET X=SDCODT
+22 ; GET FM FORMAT FOR CHECKOUT DATE/TIME
DO ^%DT
+23 ;ChecOut time cannot be in the future
+24 SET SDCODT=Y
+25 IF SDCODT>$$HTFM^XLFDT($HOROLOG)
DO ERR("Check Out time cannot be in the future.")
QUIT
+26 ;
+27 ;appointment record
+28 SET BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
+29 ;make sure CHECKOUT time is after CHECKIN time
+30 IF SDCODT<=$PIECE(BSDXNOD,U,3)
DO ERR("Check Out time must be at least 1 minute after the Check In time of "_$TRANSLATE($$FMTE^XLFDT($PIECE(BSDXNOD,U,3)),"@"," ")_".")
QUIT
+31 ;Hospital Location of RESOURCE
+32 ;RESOURCEID
SET BSDXRES=$PIECE(BSDXNOD,U,7)
+33 SET BSDXNOD=^BSDXRES(BSDXRES,0)
+34 ;HOSPITAL LOCATION
SET SDCL=$PIECE(BSDXNOD,U,4)
+35 ;
+36 SET SDDA=0
+37 SET SDASK=0
+38 SET SDCOALBF=""
+39 SET SDCOACT="CO"
+40 SET SDLNE=""
+41 SET SDQUIET=1
+42 KILL APIERR
+43 SET APIERR=0
+44 ;Appt Check Out
DO CO^BSDX25A(DFN,SDT,SDCL,SDDA,SDASK,SDCODT,SDCOACT,SDLNE,.SDCOALBF,BSDXAPTID,SDQUIET,VPRV,.APIERR)
+45 ;ERROR(S) FOUND
+46 IF APIERR>0
Begin DoDot:1
+47 SET CNT=""
+48 FOR
SET CNT=$ORDER(APIERR(CNT),1,ERR)
IF CNT=""
QUIT
SET BSDXI=BSDXI+1
DO ERR(ERR)
End DoDot:1
+49 ;NO ERROR
+50 IF APIERR<1
Begin DoDot:1
+51 SET BSDXI=BSDXI+1
+52 SET ^BSDXTMP($JOB,BSDXI)="0"_$CHAR(30)
+53 SET BSDXI=BSDXI+1
+54 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
End DoDot:1
+55 QUIT
+56 ;
+57 ;CHECK OUT APPOINTMENT - RPC
CANCKOUT(BSDXY,BSDXAPTID) ;EP Check Out appointment
+1 ; Returns BSDXY
+2 ; Input -- BSDXAPTID - Appointment ID
+3 ; called by BSDX CANCEL CHECKOUT APPT remote procedure
+4 ;SETUP ERROR TRACKING
+5 DO ^XBKVAR
SET X="ERROR^BSDX25"
SET @^%ZOSF("TRAP")
+6 SET BSDXI=0
+7 KILL ^BSDXTMP($JOB)
+8 SET BSDXY="^BSDXTMP("_$JOB_")"
+9 SET ^BSDXTMP($JOB,0)="T00020ERRORID"_$CHAR(30)
+10 IF '+BSDXAPTID
DO ERR("Invalid Appointment ID.")
QUIT
+11 IF '$DATA(^BSDXAPPT(BSDXAPTID,0))
DO ERR("Invalid Appointment ID.")
QUIT
+12 SET BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
+13 SET APS=$PIECE(BSDXNOD,U,19)
+14 SET DFN=$PIECE(BSDXNOD,U,5)
+15 SET SDT=$PIECE(BSDXNOD,U)
+16 SET RES=$PIECE(BSDXNOD,U,7)
+17 SET SDCL=$PIECE(^BSDXRES(RES,0),U,4)
+18 IF $PIECE(BSDXNOD,U,14)=""
DO ERR("Appointment is not Checked Out.")
QUIT
+19 ; ^BSDXAPPT: update piece 8: Data Entry Clerk; clear piece 14: CHECKOUT;
+20 SET DIE="^BSDXAPPT("
+21 SET DA=BSDXAPTID
+22 SET DR=".14////@;.08///"_DUZ
+23 DO ^DIE
+24 ; ^SC file 44: clear piece C;3: CHECKED OUT; clear piece C;4: CHECK OUT USER; clear C;6: CHECK OUT ENTERED
+25 SET DIE="^SC("_SDCL_",""S"","_SDT_",1,"
+26 SET DA(2)=SDCL
SET DA(1)=SDT
SET (DA,SDN)=$$SCIEN^BSDU2(DFN,SDCL,SDT)
+27 SET DR="303///@;304///@;306///@"
+28 DO ^DIE
+29 ; ^AUPNVSIT file 9000010: clear piece 18: CHECK OUT DATE&TIME
+30 SET SDOE=$$GETAPT^SDVSIT2(DFN,SDT,SDCL)
+31 SET SDV=$$GET1^DIQ(409.68,SDOE,.05,"I")
+32 IF +SDV
Begin DoDot:1
+33 SET DIE="^AUPNVSIT("
SET DA=SDV
+34 SET DR=".18///@"
+35 DO ^DIE
SET AUPNVSIT=SDV
DO MOD^AUPNVSIT
End DoDot:1
+36 ; ^SCE file 409.68: Set piece 12 back to CHECKED IN, pointer to APPOINTMENT STATUS file 409.63; clear piece 7: CHECK OUT PROCESS COMPLETION
+37 IF +APS
Begin DoDot:1
+38 SET DIE=409.68
SET DA=SDOE
SET DR=".07///@;.12///"_APS
+39 DO ^DIE
End DoDot:1
+40 SET BSDXI=BSDXI+1
+41 SET ^BSDXTMP($JOB,BSDXI)="0"_$CHAR(30)
+42 SET BSDXI=BSDXI+1
+43 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+44 QUIT
+45 ;
ERROR ;
+1 DO ERR("RPMS Error")
+2 QUIT
+3 ;
ERR(ERRNO) ;Error processing
+1 ;vbObjectError
IF +ERRNO
SET BSDXERR=ERRNO+134234112
+2 IF '$TEST
SET BSDXERR=ERRNO
+3 SET BSDXI=BSDXI+1
+4 SET ^BSDXTMP($JOB,BSDXI)=BSDXERR_$CHAR(30)
+5 SET BSDXI=BSDXI+1
+6 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+7 QUIT
