Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDX25

BSDX25.m

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