SDEC50 ;ALB/SAT/JSM,TAW,LAB,BLB - VISTA SCHEDULING RPCS ;FEB 14,2022@12:15
;;5.3;Scheduling;**627,658,665,672,722,723,737,694,745,790,792,803,809**;Aug 13, 1993;Build 10
;;Per VHA Directive 2004-038, this routine should not be modified
;
; ICR
; ---
; 723 - #42 Ward location
; 2437 - #405 patient movement
; 4837 - #123 Request/Consultation
; 7025 - #43 MAS parameters
; 7030 - #2 patient appointment data
Q
;
FAPPTGET(SDECY,DFN,SDBEG,SDEND,SDANC) ; GET Future appointments for given patient and date range
;FAPPTGET(SDECY,DFN,SDBEG,SDEND,SDANC) external parameter tag is in SDEC
;INPUT:
; DFN = (required) Patient ID - Pointer to the PATIENT file 2 (lookup by name is not accurate if duplicates)
; SDBEG = (required) Begin of date range to search for appointments in external format
; SDEND = (required) End of date range to search for appointments in external format
; SDANC = (optional) ancillary flag 0=all appointments; 1=only ancillary appointments
;RETURN:
; Successful Return:
; Global Array in which each array entry contains Appointment Data from the PATIENT file
; Data is separated by ^:
; 1. DFN
; 2. CLINIC_IEN - Clinic IEN
; 3. CLINIC_NAME - Clinic Name
; 4. APPT_DATE - Appointment Date in external format
; 5. STATUS - Status text
; 6. ANCTXT - Ancillary Text
; 7. SDLNK - Pointer found in REQUEST file node 2(#123,#409.84,#403.5 or #409.3) pwc 745
; 8. Appointment request IEN
; 9. Appointment type IEN
; 10. Appointment type Name
; 11. Cancel/noshow date
;"T00020DFN^T00020CLINIC_IEN^T00030CLINIC_NAME^T00020APPT_DATE^T00020STATUS^T00100ANCTXT^T00030SDLNK^T00030IEN^T00030APPTYPE_IEN^T00030APPTYPE_NAME^T00030CANDATE" ;sat 658 IEN ;sat 672 APPTYPE ;pwc/lab 745 SDLNK/CANDATE
; Caught Exception Return:
; Unexpected Exception Return:
; Handled by the RPC Broker.
; M errors are trapped by the use of M and Kernel error handling.
; The RPC execution stops and the RPC Broker sends the error generated text back to the client.
;
N IEN,SDANCT,SDCL,SDCLN,SDCONS,SDATA,SDDT,SDST,SDT,X,Y,%DT,SDSTDT,SDSTSTR ;745 lab
N SDTMP,SDTYP,SDTYPN,SDNOD,SDRES,SDNOD2,SDLNK,PRECHINSTEP,TIMEZONE ;alb/sat 672 ;*zeb 723 5/2/19
S SDECI=0
K ^TMP("SDEC50",$J)
S SDECY="^TMP(""SDEC50"","_$J_")"
; data header
S SDTMP="T00020DFN^T00020CLINIC_IEN^T00030CLINIC_NAME^T00020APPT_DATE^T00020STATUS^T00100ANCTXT"
S SDTMP=SDTMP_"^T00030SDLNK^T00030IEN^T00030APPTYPE_IEN^T00030APPTYPE_NAME^T00030CANDATE^T00030PRECKNCOMPLETE^T00030TIMEZONE" ;sat 658 IEN ;sat 672 APPTYPE ;pwc/lab 745 SDLNK/CANDATE
S @SDECY@(0)=SDTMP_$C(30)
;validate Patient (required)
I '+DFN D ERR1^SDECERR(-1,"Invalid Patient ID.",.SDECI,SDECY) Q
I '$D(^DPT(DFN,0)) D ERR1^SDECERR(-1,"Invalid Patient ID.",.SDECI,SDECY) Q
;validate begin date/time (required)
S:$G(SDBEG)="" SDBEG=$P($$NOW^XLFDT,".",1)
;Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
S SDBEG=$$NETTOFM^SDECDATE(SDBEG,"N","N")
I SDBEG=-1 D ERR1^SDECERR(-1,"Invalid Begin Time.",.SDECI,SDECY) Q
;validate end date/time (required)
S:$G(SDEND)="" SDEND=1000000
S SDEND=$$NETTOFM^SDECDATE(SDEND,"N","N")
I SDEND=-1 D ERR1^SDECERR(-1,"Invalid End Time.",.SDECI,SDECY) Q
;validate ancillary flag (optional)
S SDANC=$G(SDANC)
S:SDANC'=1 SDANC=0
;*zeb 722 1/9/19 begin new loop over appts instead of pt
S SDT=SDBEG
F S SDT=$O(^SDEC(409.84,"APTDT",DFN,SDT)) Q:SDT="" Q:$P(SDT,".",1)>SDEND D
. S IEN=""
. F S IEN=$O(^SDEC(409.84,"APTDT",DFN,SDT,IEN)) Q:IEN="" D
.. S SDNOD=$G(^SDEC(409.84,IEN,0))
.. Q:SDNOD="" ;appointment data missing
.. S SDATA=$G(^DPT(DFN,"S",SDT,0))
.. S SDANCT=$$ANC^SDAM1() ;assumes SDATA ;ancillary
.. I SDANC Q:SDANCT=""
.. ;return appointment data
.. S SDRES=$P(SDNOD,U,7)
.. S SDCL="",SDCLN="*CORRUPT DATA" ;*zeb+8 723 5/2/19 support appointments with no resource
.. I SDRES]"" S SDCL=$$GET1^DIQ(409.831,SDRES_",",.04,"I") S SDCLN=$$GET1^DIQ(409.831,SDRES_",",.04) ;clinic IEN/clinic name
.. S SDDT=$$GET1^DIQ(409.84,IEN_",",.01,"I") ;appointment start date/time ;used GET1 instead of ^DD("DD") because GUI needs leading zeroes
.. ; Change date/time conversion so midnight is handled properly. 694 wtc/pwc 1/7/2020
.. S SDDT=$$FMTONET^SDECDATE(SDDT,"N")
.. S SDSTSTR=$$APPTSTS(IEN,SDNOD,SDCL) ;current status ;745 lab
.. S SDST=$P(SDSTSTR,"^",1) ;745 lab
.. S SDSTDT=$$FMTONET^SDECDATE($P(SDSTSTR,"^",2),"Y") ;745 lab
.. S SDTYP=$P(SDNOD,U,6) ;appt type id
.. I SDTYP S SDTYPN=$P($G(^SD(409.1,SDTYP,0)),U,1) ;appt type name
.. E S SDTYPN="REGULAR",SDTYP=$O(^SD(409.1,"B",SDTYPN,0)) ; 737 WTC 11/19/2019
.. S SDNOD2=$G(^SDEC(409.84,IEN,2)),SDLNK=""
.. S SDLNK=$S(SDNOD2="":"",1:$P(SDNOD2,U,1)) ;pwc *745 ptr link files
.. S PRECHINSTEP=$$LASTCKNSTEP^SDESCKNSTEP(IEN)
.. S TIMEZONE=$$TIMEZONEDATA^SDESUTIL(SDCL),TIMEZONE=$P($G(TIMEZONE),U)
.. S SDECI=SDECI+1 S @SDECY@(SDECI)=DFN_U_SDCL_U_SDCLN_U_SDDT_U_SDST_U_SDANCT_U_SDLNK_U_IEN_U_SDTYP_U_SDTYPN_U_SDSTDT_U_PRECHINSTEP_U_TIMEZONE_$C(30) ; pwc/lab *745 SDLNK/SDSTDT
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
;
;*zeb+tag 722 2/19/19 added to get appointment status for pending appointments from appointment file
APPTSTS(APPTIEN,APPTNOD,CLINIEN) ;Get current status for an entry in the SDEC APPOINTMENT file in the style of STATUS^SDAM1
;APPTIEN (R)- IEN of entry in the SDEC APPOINTMENT file (#409.84)
;APPTNOD (O)- 0 node of appointment entry (will be read if not passed in)
;CLINIEN (O)- IEN of entry in the HOSPITAL LOCATION file (#44); non-count will not be checked via clinic if not passed in (can check via OE)
N STS,OEIEN,DFN,SDT,VAINDT,VADMVT,CHKIO,RET,OESTS,CXLRSN,CXLRSNTP,CXLSTS,STSDT ;wtc 8/27/19;745
I $G(APPTNOD)="" S APPTNOD=$G(^SDEC(409.84,APPTIEN,0))
S SDT=$P(APPTNOD,U,1)
S DFN=$P(APPTNOD,U,5)
S OEIEN=$P($G(^DPT(DFN,"S",SDT,0)),U,20)
S CHKIO=""
;set initial status value ; non-count clinic?
S STS=$P(APPTNOD,U,17)
S STSDT=$P(APPTNOD,U,12) ;745
I STS]"" S STS=$P($P($P(^DD(409.84,.17,0),"^",3),STS_":",2),";",1) I 1 ;name for status code
E I CLINIEN]"" S:$P($G(^SC(CLINIEN,0)),U,17)="Y" STS="NON-COUNT" ;check for non-count clinic ;*zeb+1 723 5/2/19 don't crash if resource/clinic not available
I CLINIEN'="",STS="NO ACTION TAKEN",OEIEN'="" S STS="" ; wtc 723 8/20/2019
;no show?
I $P(APPTNOD,U,10)=1 D
. I STSDT]"" D Q ;handle cancel after no-show -- appt sts doesn't get updated with cxl but pt status does; 745 STSDT
. . S CXLRSN=$P(APPTNOD,U,22)
. . ; Line below revised to use appointment status (field .17) to calculate status when reason is missing (e.g., SDCANCEL). wtc 694 7/12/2019
. . I CXLRSN="" S STS=$S($P(APPTNOD,U,17)="C":"CANCELLED BY CLINIC",$P(APPTNOD,U,17)="PC":"CANCELLED BY PATIENT",1:"CANCELLED") Q
. . S CXLRSNTP=$P($G(^SD(409.2,CXLRSN,0)),U,2)
. . I CXLRSNTP="C" S STS="CANCELLED BY CLINIC" Q
. . I CXLRSNTP="P" S STS="CANCELLED BY PATIENT" Q
. . S CXLSTS=$$GET1^DIQ(2.98,SDT_","_DFN_",",100)
. . I CXLSTS["CANCELLED" S STS=CXLSTS Q
. . S STS="CANCELLED BY CLINIC" ;default to clinic if information is lost
. S STS="NO-SHOW",STSDT=$P(APPTNOD,U,23) ;745 lab STSDT
; WTC 722 3/22/19
I STS=""!($P(APPTNOD,U,17)="I"),$$INP^SDAM2(DFN,SDT)="I" S STS=$S($P(APPTNOD,U,12)="":"INPATIENT",$P($G(^DPT(DFN,"S",SDT,0)),U,2)="PC":"CANCELLED BY PATIENT",1:"CANCELLED BY CLINIC") ; WTC 722 3/27/2019
N SDNEXTIEN
S SDNEXTIEN=$O(^SDEC(409.84,"APTDT",DFN,SDT,APPTIEN))
I +$G(SDNEXTIEN),($P(APPTNOD,U,17)="I"),($P(APPTNOD,U,12)'="") S STS="INPATIENT/CANCELLED"
Q:STS="INPATIENT/CANCELLED" STS
S VAINDT=SDT D ADM^VADPT2 ;ADM^VADPT2 assumes VAINDT and returns in VADMVT
I STS["INPATIENT",$S('VADMVT:1,'$P(^DG(43,1,0),U,21):0,1:$P($G(^DIC(42,+$P($G(^DGPM(VADMVT,0)),U,6),0)),U,3)="D") S STS=""
; -- determine ci/co indicator
S CHKIO=$S($P(APPTNOD,U,14)]"":"CHECKED OUT",$P(APPTNOD,U,3)]"":"CHECKED IN",SDT>(DT+.2400):"FUTURE",1:"NO ACTION TAKEN") ;DT is a FileMan-assumable variable with the current date
; Look for check-in time in the Location file (#44) if check-in/out indicator is NO ACTION TAKEN. Needed 'cause VPS does not update Appointment file. wtc 10/31/2019 737
I CHKIO="NO ACTION TAKEN",CLINIEN'="" D ;
. N SDECD2 S SDECD2=$$FIND^SDAM2(DFN,SDT,CLINIEN) I SDECD2,$P($G(^SC(CLINIEN,"S",SDT,1,SDECD2,"C")),U,1)'="" S CHKIO="CHECKED IN" ;
S:STS="" STS=CHKIO
;If NO ACTION TAKEN, If cancelled in Patient(by SDCANCEL), wtc 11/4/2019 737
I STS'["CANCELLED" D ;
. I $P($G(^DPT(DFN,"S",SDT,0)),U,1)'=CLINIEN Q ;If appointment does not match, leave status alone.
. S STS=$S($P($G(^DPT(DFN,"S",SDT,0)),U,2)="PC":"CANCELLED BY PATIENT",$P($G(^DPT(DFN,"S",SDT,0)),U,2)="C":"CANCELLED BY CLINIC",1:STS) ;
;
I (STS="NO ACTION TAKEN"),($P(SDT,".")=DT),(CHKIO'["CHECKED") S CHKIO="TODAY"
; -- determine print status
I STS["CANCELLED" Q STS_"^"_STSDT ;745 lab include stsdt
S RET=$S(STS=CHKIO!(CHKIO=""):STS,1:"")
I RET="" D
. I STS["INPATIENT",$P(SDT,".",1)>DT S RET=$P(STS," ",1)_"/FUTURE" Q ; WTC 3/26/19 722
. I (STS["INPATIENT"),(CLINIEN]""),($P($G(^SC(CLINIEN,0)),U,17)'="Y"),OEIEN="" S RET=$P(STS," ",1)_"/ACT REQ" Q ; wtc 3/22/19 722 no outpatient encounter for inpatient
. I (STS["INPATIENT"),(CLINIEN]""),($P($G(^SC(CLINIEN,0)),U,17)'="Y"),($P($G(^SCE(OEIEN,0)),U,7)="") S RET=$P(STS," ",1)_"/ACT REQ" Q
. I (STS="NO ACTION TAKEN"),((CHKIO="CHECKED OUT")!(CHKIO="CHECKED IN")) S RET="ACT REQ/"_CHKIO D Q
. . I (OEIEN),($P($G(^SCE(OEIEN,0)),U,7)) S RET="CHECKED OUT" ; wtc 722 8/27/19 changed P to RET to match code in SDAM1, where the code originally came from.
. I ((STS="NO-SHOW")!(STS="NON-COUNT")) S RET=STS Q:CHKIO="NO ACTION TAKEN"
. S RET=STS_"/"_CHKIO
I STS["INPATIENT",((CHKIO="")!(CHKIO="NO ACTION TAKEN")) D
. I SDT>(DT+.2359) S RET=$P(STS," ")_"/FUTURE" Q
. S RET=$P(STS," ")_"/NO ACT TAKN"
I STS["INPATIENT" Q RET
I STS["NO-SHOW" Q RET_"^"_STSDT ;745
I ($G(OEIEN)),($D(^SCE(OEIEN,0))) D
. S OESTS=$P($G(^SCE(OEIEN,0)),U,12)
. S:OESTS]"" OESTS=$P($G(^SD(409.63,OESTS,0)),U,1)
. I $G(OESTS)="NON-COUNT" D Q
. . I $P(APPTNOD,U,14) S RET="NON-COUNT/CHECKED OUT" Q
. . I $P(APPTNOD,U,3) S RET="NON-COUNT/CHECKED IN"
. I $G(OESTS)="CHECKED OUT" S RET="CHECKED OUT" Q
. I $P(APPTNOD,U,14) S RET="ACT REQ/CHECKED OUT" D Q
. . I ($G(OESTS)=""),($P($G(^SCE(OEIEN,0)),U,7)) S RET="CHECKED OUT"
. I $P(APPTNOD,U,3) S RET="ACT REQ/CHECKED IN"
Q RET
;
GETIEN(DFN,SDCLN,SDDT) ;get SDEC APPOINTMENT id
N SDF,SDI,SDNOD,SDR
Q:$G(DFN)="" ""
Q:$G(SDCLN)="" ""
Q:$G(SDDT)="" ""
S (SDF,SDI)=0 F S SDI=$O(^SDEC(409.84,"CPAT",DFN,SDI)) Q:SDI="" D Q:SDF=1
.S SDNOD=$G(^SDEC(409.84,SDI,0))
.Q:SDNOD=""
.S SDR=$$GETRES^SDECUTL(SDCLN)
.I $P(SDNOD,U,1)=SDDT,$P(SDNOD,U,7)=SDR S SDF=1
Q $S(SDI'="":SDI,1:"")
;
CONS(SDCL,DFN,SDDT) ;check for consult in file 44
;SDCL = (required) clinic IEN
;DFN = (required) patient IEN
;SDDT = (required) appointment time in FM format
N CONS,CSTAT,SDI,SDJ
S CONS=""
S SDI=0 F S SDI=$O(^SC(SDCL,"S",SDDT,1,SDI)) Q:SDI'>0 D Q:CONS'=""
.I $P($G(^SC(SDCL,"S",SDDT,1,SDI,0)),U,1)=DFN D
..S CONS=$G(^SC(SDCL,"S",SDDT,1,SDI,"CONS"))
..I +CONS D
...S CSTAT=$P($G(^GMR(123,CONS,0)),U,12)
...S:(CSTAT=1!(CSTAT=2)!(CSTAT=13)) CONS=""
Q CONS
;
PCSTGET(SDECY,DFN,SDCL,SDBEG,SDEND) ;GET patient clinic status for a clinic for a given time frame - has the patient been seen by the given Clinic in the past 24 months
;PCSTGET(SDECY,DFN,SDCL,SDBEG,SDEND) external parameter tag is in SDEC
;INPUT:
;DFN = (required) Patient ID - Pointer to the PATIENT file 2 (lookup by name is not accurate if duplicates)
;SDCL = (required) Clinic code - Pointer to HOSPITAL LOCATION file
;SDBEG = (optional) Begin date in external format; defaults to 730 days previous (24 months)
;SDEND = (optional) End date in external format; defaults to today
;RETURN:
; Successful Return:
; a single entry in the global array indicating that patient has or has not been seen.
; "T00020RETURNCODE^T00100TEXT"
; Caught Exception Return:
; A single entry in the Global Array in the format "-1^<error text>"
; "T00020RETURNCODE^T00100TEXT"
; Unexpected Exception Return:
; Handled by the RPC Broker.
; M errors are trapped by the use of M and Kernel error handling.
; The RPC execution stops and the RPC Broker sends the error generated
; text back to the client.
N SDASD,SDECI,SDS,STOP,SDYN,SDSCL
;N SDSNOD,SDSD,SDSTP,SDT,SDVSP,SDWL,SDYN alb/jsm 658 commented out since variables not used here
N X,Y,%DT,APIEN
S SDECI=0
S SDECY="^TMP(""SDEC50"","_$J_",""PCSTGET"")"
K @SDECY
; data header
S @SDECY@(0)="T00020RETURNCODE^T00100TEXT"_$C(30)
;check for valid Patient
I '+DFN D ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY) Q
I '$D(^DPT(DFN,0)) D ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY) Q
;check for valid Clinic
I '+SDCL D ERR1^SDECERR(-1,"Invalid Clinic ID.",SDECI,SDECY) Q
I '$D(^SC(SDCL,0)) D ERR1^SDECERR(-1,"Invalid Clinic ID.",SDECI,SDECY) Q
;check times
I $G(SDBEG)'="" S %DT="" S X=$P(SDBEG,"@",1) D ^%DT S SDBEG=Y I Y=-1 S SDBEG=""
S:$G(SDBEG)="" SDBEG=$P($$FMADD^XLFDT($$NOW^XLFDT,-1095),".",1)
I $G(SDEND)'="" S %DT="" S X=$P(SDEND,"@",1) D ^%DT S SDEND=Y I Y=-1 S SDEND="" ;alb/sat 665 - remove Q
S:$G(SDEND)="" SDEND=$P($$NOW^XLFDT,".",1)
S STOP=$$CLSTOP(SDCL) ;get stop code number alb/jsm 658 updated to use new CLSTOP call
I '+STOP D ERR1^SDECERR(-1,"Clinic "_$P($G(^SC(+$G(SDCL),0)),U,1)_" does not have a STOP CODE NUMBER defined.",SDECI,SDECY) Q
S SDYN="NO"
D CHKPT
S SDECI=SDECI+1 S @SDECY@(SDECI)="0^"_SDYN_$C(30,31)
Q
;
CLSTOP(CLINIC) ;Return clinic stop code for clinic
Q:$G(CLINIC)="" 0 ;Verify clinic is passed in
Q $P($G(^SC(CLINIC,0)),U,7) ;Return the stop code for the clinic
;
CHKPT ;alb/jsm 658 added to be used by PCSTGET and PCST2GET
N SDSCO
S SDS=0 F S SDS=$O(^DPT(DFN,"S",SDS)) Q:SDS="" D Q:SDYN="YES" ;alb/sat 665 - start with SDS=0 instead of ""
.S SDSCL=$P($G(^DPT(DFN,"S",SDS,0)),U,1)
.I $$CLSTOP(SDSCL)=STOP D
..S APIEN=$$FIND^SDAM2(DFN,SDS,SDSCL)
..Q:APIEN=""
..S SDSCO=$P($P($G(^SC(SDSCL,"S",SDS,1,+APIEN,"C")),U,3),".",1)
..S:(SDSCO'="")&(SDSCO'<SDBEG)&(SDSCO'>SDEND) SDYN="YES"
Q
;
PCST2GET(SDECY,DFN,STOP,SDBEG,SDEND) ;GET patient clinic status for a service/specialty (clinic stop) for a given time frame - has the patient been seen any clinics with the given service/specialty (clinic stop) in the past 24 months
;PCST2GET(SDECY,DFN,STOP,SDBEG,SDEND) external parameter tag is in SDEC
;INPUT:
; DFN = (required) Patient ID - Pointer to the PATIENT file 2 (lookup by name is not accurate if duplicates)
; STOP = (required) CLINIC STOP or Service/Specialty name - NAME from the SD WL SERVICE/SPECIALTY file - looks for 1st active
; OR - Pointer to the CLINIC STOP file
; SDBEG = (optional) Begin date in external format; defaults to 730 days previous (24 months)
; SDEND = (optional) End date in external format; defaults to today
;RETURN:
; Successful Return:
; a single entry in the global array indicating that patient has or has not been seen.
; "T00020RETURNCODE^T00100TEXT"
; Caught Exception Return:
; A single entry in the Global Array in the format "-1^<error text>"
; "T00020RETURNCODE^T00100TEXT"
; Unexpected Exception Return:
; Handled by the RPC Broker.
; M errors are trapped by the use of M and Kernel error handling.
; The RPC execution stops and the RPC Broker sends the error generated
; text back to the client.
N SDASD,SDF,SDSCN,SDECI,SDSNOD,SDSD,SDSTP,SDT,SDVSP,SDWL,SDYN
N H,WLSRVSP,X,Y,%DT
S WLSRVSP=""
S (SDF,SDECI,SDSCN)=0
S SDECY="^TMP(""SDEC50"","_$J_",""PCST2GET"")"
K @SDECY
;data header
S @SDECY@(0)="T00020RETURNCODE^T00100TEXT"_$C(30)
;check for valid Patient
I '+DFN D ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY) Q
I '$D(^DPT(DFN,0)) D ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY) Q
;check for valid Service/Specialty
S STOP=$G(STOP)
I +STOP,'$D(^DIC(40.7,STOP,0)) D ERR1^SDECERR(-1,"Invalid stop code.",SDECI,SDECY) Q
I +STOP S SDSCN=$$GET1^DIQ(40.7,STOP_",",.01) S SDF=1
I 'SDF,'+STOP D
.S H="" F S H=$O(^DIC(40.7,"B",STOP,H)) Q:H="" D Q:+STOP
..I $P(^DIC(40.7,H,0),U,3)'="",$P(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT() Q
..S STOP=H
I '+STOP D ERR1^SDECERR(-1,"Invalid Stop code.",SDECI,SDECY) Q
;check times
I $G(SDBEG)'="" S %DT="" S X=$P(SDBEG,"@",1) D ^%DT S SDBEG=Y I Y=-1 S SDBEG=""
S:$G(SDBEG)="" SDBEG=$P($$FMADD^XLFDT($$NOW^XLFDT,-730),".",1)
I $G(SDEND)'="" S %DT="" S X=$P(SDEND,"@",1) D ^%DT S SDEND=Y I Y=-1 S SDEND="" Q
S:$G(SDEND)="" SDEND=$P($$NOW^XLFDT,".",1)
S SDYN="NO"
D CHKPT
S SDECI=SDECI+1 S @SDECY@(SDECI)="0^"_SDYN_$C(30,31)
Q
;
LOOK ;
;look in PATIENT Appointments
I SDYN'="YES" D
.S SDS="" F S SDS=$O(^DPT(DFN,"S",SDS)) Q:SDS="" D Q:SDYN="YES"
..S SDSD=$$GET1^DIQ(2.98,SDS_","_DFN_",",.001,"I")
..I (SDSD'<SDBEG)&(SDSD'>SDEND) D
...I $P($G(^DPT(DFN,"S",SDS,0)),U,1)=SDCL D
....S APIEN=$$FIND^SDAM2(DFN,SDS,SDCL)
....I APIEN'="",$G(^SC(SDCL,"S",SDS,1,APIEN,"C"))'="" S SDYN="YES"
;look in HOSPITAL LOCATION
I SDYN'="YES" D
.S SDS=SDBEG F S SDS=$O(^SC(SDCL,"S",SDS)) Q:SDS'>0 Q:SDS>SDEND D Q:SDYN="YES"
..S APIEN=$$FIND^SDAM2(DFN,SDS,SDCL)
..Q:APIEN=""
..S:$P($G(^SC(SDCL,"S",SDS,1,APIEN,"C")),U,1)'="" SDYN="YES"
Q
;
LOOKWL ;
;look in SD WAIT LIST file for STOP stop code
S SDWL="" F S SDWL=$O(^SDWL(409.3,"B",DFN,SDWL)) Q:SDWL="" D Q:SDYN="YES"
.S SDSD=$P($G(^SDWL(409.3,SDWL,0)),U,23)
.I (SDSD'<SDBEG)&(SDSD'>SDEND) D
..S SDSTP=$P($G(^SDWL(409.3,SDWL,"SDAPT")),U,4)
..I SDSTP=STOP S SDYN="YES"
.Q:SDYN="YES"
Q
;
PCSGET(SDECY,SDSVSP,SDCL) ;GET clinics for a service/specialty (clinic stop) ;alb/sat 658 add SDCL
;PCSGET(SDECY,SDSVSP) external parameter tag is in SDEC
;INPUT:
; SDSVSP = (required) Service/Specialty name - NAME from the SD WL SERVICE/SPECIALTY file - looks for 1st active
; OR - Pointer to the SD WL SERVICE/SPECIALTY file
;RETURN:
; Successful Return:
; global array containing Clinic IEN and Name of matching Hospital Locations
; CLINSTOP - pointer to CLINIC STOP file 40.7
; CLINIEN - pointer to the HOSPITAL LOCATION file 44
; CLINNAME - NAME from the HOSPITAL LOCATION file
; Caught Exception Return:
; A single entry in the Global Array in the format "-1^<error text>"
; "T00020RETURNCODE^T00100TEXT"
; Unexpected Exception Return:
; Handled by the RPC Broker.
; M errors are trapped by the use of M and Kernel error handling.
; The RPC execution stops and the RPC Broker sends the error generated
; text back to the client.
;
N SDASD,SDSCN,SDECI,SDSNOD,SDSD,SDSTP,SDT,SDVSP,SDWL
N H,WLSRVSP,X,Y
S WLSRVSP=""
S (SDECI,SDSCN)=0
S SDECY="^TMP(""SDEC50"","_$J_",""PCSGET"")"
K @SDECY
;data header
S @SDECY@(0)="T00030CLINSTOP^T00030CLINIEN^T00030CLINNAME"_$C(30)
;check clinic ;alb/sat 658
S SDCL=$G(SDCL)
I SDCL'="",$D(^SC(SDCL,0)) D
.S SDSVSP=$$GET1^DIQ(44,SDCL_",",8,"I")
;check for valid Service/Specialty
S SDSVSP=$G(SDSVSP)
I SDSVSP="" D ERR1^SDECERR(-1,"Service/Specialty ID required",SDECI,SDECY) Q
I '+SDSVSP D
.S H=0 F S H=$O(^DIC(40.7,"B",SDSVSP,H)) Q:H="" D Q:SDSCN'=0
..I $P(^DIC(40.7,H,0),U,3)'="",$P(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT() Q
..S SDSCN=H
I '+SDSCN D ERR1^SDECERR(-1,"Invalid Service/Specialty.",SDECI,SDECY) Q
S SDCL=0 F S SDCL=$O(^SC(SDCL)) Q:SDCL'>0 D
.S SDCLN=$P($G(^SC(SDCL,0)),U,7)
.I $$GET1^DIQ(44,SDCL_",",2505,)'="",$$GET1^DIQ(44,SDCL_",",2506)="" Q ;only active
.I SDCLN=SDSCN S SDECI=SDECI+1 S @SDECY@(SDECI)=SDSCN_U_SDCL_U_$P($G(^SC(SDCL,0)),U,1)_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC50 19932 printed Nov 22, 2024@18:00:41 Page 2
SDEC50 ;ALB/SAT/JSM,TAW,LAB,BLB - VISTA SCHEDULING RPCS ;FEB 14,2022@12:15
+1 ;;5.3;Scheduling;**627,658,665,672,722,723,737,694,745,790,792,803,809**;Aug 13, 1993;Build 10
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 ; ICR
+5 ; ---
+6 ; 723 - #42 Ward location
+7 ; 2437 - #405 patient movement
+8 ; 4837 - #123 Request/Consultation
+9 ; 7025 - #43 MAS parameters
+10 ; 7030 - #2 patient appointment data
+11 QUIT
+12 ;
FAPPTGET(SDECY,DFN,SDBEG,SDEND,SDANC) ; GET Future appointments for given patient and date range
+1 ;FAPPTGET(SDECY,DFN,SDBEG,SDEND,SDANC) external parameter tag is in SDEC
+2 ;INPUT:
+3 ; DFN = (required) Patient ID - Pointer to the PATIENT file 2 (lookup by name is not accurate if duplicates)
+4 ; SDBEG = (required) Begin of date range to search for appointments in external format
+5 ; SDEND = (required) End of date range to search for appointments in external format
+6 ; SDANC = (optional) ancillary flag 0=all appointments; 1=only ancillary appointments
+7 ;RETURN:
+8 ; Successful Return:
+9 ; Global Array in which each array entry contains Appointment Data from the PATIENT file
+10 ; Data is separated by ^:
+11 ; 1. DFN
+12 ; 2. CLINIC_IEN - Clinic IEN
+13 ; 3. CLINIC_NAME - Clinic Name
+14 ; 4. APPT_DATE - Appointment Date in external format
+15 ; 5. STATUS - Status text
+16 ; 6. ANCTXT - Ancillary Text
+17 ; 7. SDLNK - Pointer found in REQUEST file node 2(#123,#409.84,#403.5 or #409.3) pwc 745
+18 ; 8. Appointment request IEN
+19 ; 9. Appointment type IEN
+20 ; 10. Appointment type Name
+21 ; 11. Cancel/noshow date
+22 ;"T00020DFN^T00020CLINIC_IEN^T00030CLINIC_NAME^T00020APPT_DATE^T00020STATUS^T00100ANCTXT^T00030SDLNK^T00030IEN^T00030APPTYPE_IEN^T00030APPTYPE_NAME^T00030CANDATE" ;sat 658 IEN ;sat 672 APPTYPE ;pwc/lab 745 SDLNK/CANDATE
+23 ; Caught Exception Return:
+24 ; Unexpected Exception Return:
+25 ; Handled by the RPC Broker.
+26 ; M errors are trapped by the use of M and Kernel error handling.
+27 ; The RPC execution stops and the RPC Broker sends the error generated text back to the client.
+28 ;
+29 ;745 lab
NEW IEN,SDANCT,SDCL,SDCLN,SDCONS,SDATA,SDDT,SDST,SDT,X,Y,%DT,SDSTDT,SDSTSTR
+30 ;alb/sat 672 ;*zeb 723 5/2/19
NEW SDTMP,SDTYP,SDTYPN,SDNOD,SDRES,SDNOD2,SDLNK,PRECHINSTEP,TIMEZONE
+31 SET SDECI=0
+32 KILL ^TMP("SDEC50",$JOB)
+33 SET SDECY="^TMP(""SDEC50"","_$JOB_")"
+34 ; data header
+35 SET SDTMP="T00020DFN^T00020CLINIC_IEN^T00030CLINIC_NAME^T00020APPT_DATE^T00020STATUS^T00100ANCTXT"
+36 ;sat 658 IEN ;sat 672 APPTYPE ;pwc/lab 745 SDLNK/CANDATE
SET SDTMP=SDTMP_"^T00030SDLNK^T00030IEN^T00030APPTYPE_IEN^T00030APPTYPE_NAME^T00030CANDATE^T00030PRECKNCOMPLETE^T00030TIMEZONE"
+37 SET @SDECY@(0)=SDTMP_$CHAR(30)
+38 ;validate Patient (required)
+39 IF '+DFN
DO ERR1^SDECERR(-1,"Invalid Patient ID.",.SDECI,SDECY)
QUIT
+40 IF '$DATA(^DPT(DFN,0))
DO ERR1^SDECERR(-1,"Invalid Patient ID.",.SDECI,SDECY)
QUIT
+41 ;validate begin date/time (required)
+42 if $GET(SDBEG)=""
SET SDBEG=$PIECE($$NOW^XLFDT,".",1)
+43 ;Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+44 SET SDBEG=$$NETTOFM^SDECDATE(SDBEG,"N","N")
+45 IF SDBEG=-1
DO ERR1^SDECERR(-1,"Invalid Begin Time.",.SDECI,SDECY)
QUIT
+46 ;validate end date/time (required)
+47 if $GET(SDEND)=""
SET SDEND=1000000
+48 SET SDEND=$$NETTOFM^SDECDATE(SDEND,"N","N")
+49 IF SDEND=-1
DO ERR1^SDECERR(-1,"Invalid End Time.",.SDECI,SDECY)
QUIT
+50 ;validate ancillary flag (optional)
+51 SET SDANC=$GET(SDANC)
+52 if SDANC'=1
SET SDANC=0
+53 ;*zeb 722 1/9/19 begin new loop over appts instead of pt
+54 SET SDT=SDBEG
+55 FOR
SET SDT=$ORDER(^SDEC(409.84,"APTDT",DFN,SDT))
if SDT=""
QUIT
if $PIECE(SDT,".",1)>SDEND
QUIT
Begin DoDot:1
+56 SET IEN=""
+57 FOR
SET IEN=$ORDER(^SDEC(409.84,"APTDT",DFN,SDT,IEN))
if IEN=""
QUIT
Begin DoDot:2
+58 SET SDNOD=$GET(^SDEC(409.84,IEN,0))
+59 ;appointment data missing
if SDNOD=""
QUIT
+60 SET SDATA=$GET(^DPT(DFN,"S",SDT,0))
+61 ;assumes SDATA ;ancillary
SET SDANCT=$$ANC^SDAM1()
+62 IF SDANC
if SDANCT=""
QUIT
+63 ;return appointment data
+64 SET SDRES=$PIECE(SDNOD,U,7)
+65 ;*zeb+8 723 5/2/19 support appointments with no resource
SET SDCL=""
SET SDCLN="*CORRUPT DATA"
+66 ;clinic IEN/clinic name
IF SDRES]""
SET SDCL=$$GET1^DIQ(409.831,SDRES_",",.04,"I")
SET SDCLN=$$GET1^DIQ(409.831,SDRES_",",.04)
+67 ;appointment start date/time ;used GET1 instead of ^DD("DD") because GUI needs leading zeroes
SET SDDT=$$GET1^DIQ(409.84,IEN_",",.01,"I")
+68 ; Change date/time conversion so midnight is handled properly. 694 wtc/pwc 1/7/2020
+69 SET SDDT=$$FMTONET^SDECDATE(SDDT,"N")
+70 ;current status ;745 lab
SET SDSTSTR=$$APPTSTS(IEN,SDNOD,SDCL)
+71 ;745 lab
SET SDST=$PIECE(SDSTSTR,"^",1)
+72 ;745 lab
SET SDSTDT=$$FMTONET^SDECDATE($PIECE(SDSTSTR,"^",2),"Y")
+73 ;appt type id
SET SDTYP=$PIECE(SDNOD,U,6)
+74 ;appt type name
IF SDTYP
SET SDTYPN=$PIECE($GET(^SD(409.1,SDTYP,0)),U,1)
+75 ; 737 WTC 11/19/2019
IF '$TEST
SET SDTYPN="REGULAR"
SET SDTYP=$ORDER(^SD(409.1,"B",SDTYPN,0))
+76 SET SDNOD2=$GET(^SDEC(409.84,IEN,2))
SET SDLNK=""
+77 ;pwc *745 ptr link files
SET SDLNK=$SELECT(SDNOD2="":"",1:$PIECE(SDNOD2,U,1))
+78 SET PRECHINSTEP=$$LASTCKNSTEP^SDESCKNSTEP(IEN)
+79 SET TIMEZONE=$$TIMEZONEDATA^SDESUTIL(SDCL)
SET TIMEZONE=$PIECE($GET(TIMEZONE),U)
+80 ; pwc/lab *745 SDLNK/SDSTDT
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=DFN_U_SDCL_U_SDCLN_U_SDDT_U_SDST_U_SDANCT_U_SDLNK_U_IEN_U_SDTYP_U_SDTYPN_U_SDSTDT_U_PRECHINSTEP_U_TIMEZONE_$CHAR(30)
End DoDot:2
End DoDot:1
+81 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+82 QUIT
+83 ;
+84 ;*zeb+tag 722 2/19/19 added to get appointment status for pending appointments from appointment file
APPTSTS(APPTIEN,APPTNOD,CLINIEN) ;Get current status for an entry in the SDEC APPOINTMENT file in the style of STATUS^SDAM1
+1 ;APPTIEN (R)- IEN of entry in the SDEC APPOINTMENT file (#409.84)
+2 ;APPTNOD (O)- 0 node of appointment entry (will be read if not passed in)
+3 ;CLINIEN (O)- IEN of entry in the HOSPITAL LOCATION file (#44); non-count will not be checked via clinic if not passed in (can check via OE)
+4 ;wtc 8/27/19;745
NEW STS,OEIEN,DFN,SDT,VAINDT,VADMVT,CHKIO,RET,OESTS,CXLRSN,CXLRSNTP,CXLSTS,STSDT
+5 IF $GET(APPTNOD)=""
SET APPTNOD=$GET(^SDEC(409.84,APPTIEN,0))
+6 SET SDT=$PIECE(APPTNOD,U,1)
+7 SET DFN=$PIECE(APPTNOD,U,5)
+8 SET OEIEN=$PIECE($GET(^DPT(DFN,"S",SDT,0)),U,20)
+9 SET CHKIO=""
+10 ;set initial status value ; non-count clinic?
+11 SET STS=$PIECE(APPTNOD,U,17)
+12 ;745
SET STSDT=$PIECE(APPTNOD,U,12)
+13 ;name for status code
IF STS]""
SET STS=$PIECE($PIECE($PIECE(^DD(409.84,.17,0),"^",3),STS_":",2),";",1)
IF 1
+14 ;check for non-count clinic ;*zeb+1 723 5/2/19 don't crash if resource/clinic not available
IF '$TEST
IF CLINIEN]""
if $PIECE($GET(^SC(CLINIEN,0)),U,17)="Y"
SET STS="NON-COUNT"
+15 ; wtc 723 8/20/2019
IF CLINIEN'=""
IF STS="NO ACTION TAKEN"
IF OEIEN'=""
SET STS=""
+16 ;no show?
+17 IF $PIECE(APPTNOD,U,10)=1
Begin DoDot:1
+18 ;handle cancel after no-show -- appt sts doesn't get updated with cxl but pt status does; 745 STSDT
IF STSDT]""
Begin DoDot:2
+19 SET CXLRSN=$PIECE(APPTNOD,U,22)
+20 ; Line below revised to use appointment status (field .17) to calculate status when reason is missing (e.g., SDCANCEL). wtc 694 7/12/2019
+21 IF CXLRSN=""
SET STS=$SELECT($PIECE(APPTNOD,U,17)="C":"CANCELLED BY CLINIC",$PIECE(APPTNOD,U,17)="PC":"CANCELLED BY PATIENT",1:"CANCELLED")
QUIT
+22 SET CXLRSNTP=$PIECE($GET(^SD(409.2,CXLRSN,0)),U,2)
+23 IF CXLRSNTP="C"
SET STS="CANCELLED BY CLINIC"
QUIT
+24 IF CXLRSNTP="P"
SET STS="CANCELLED BY PATIENT"
QUIT
+25 SET CXLSTS=$$GET1^DIQ(2.98,SDT_","_DFN_",",100)
+26 IF CXLSTS["CANCELLED"
SET STS=CXLSTS
QUIT
+27 ;default to clinic if information is lost
SET STS="CANCELLED BY CLINIC"
End DoDot:2
QUIT
+28 ;745 lab STSDT
SET STS="NO-SHOW"
SET STSDT=$PIECE(APPTNOD,U,23)
End DoDot:1
+29 ; WTC 722 3/22/19
+30 ; WTC 722 3/27/2019
IF STS=""!($PIECE(APPTNOD,U,17)="I")
IF $$INP^SDAM2(DFN,SDT)="I"
SET STS=$SELECT($PIECE(APPTNOD,U,12)="":"INPATIENT",$PIECE($GET(^DPT(DFN,"S",SDT,0)),U,2)="PC":"CANCELLED BY PATIENT",1:"CANCELLED BY CLINIC")
+31 NEW SDNEXTIEN
+32 SET SDNEXTIEN=$ORDER(^SDEC(409.84,"APTDT",DFN,SDT,APPTIEN))
+33 IF +$GET(SDNEXTIEN)
IF ($PIECE(APPTNOD,U,17)="I")
IF ($PIECE(APPTNOD,U,12)'="")
SET STS="INPATIENT/CANCELLED"
+34 if STS="INPATIENT/CANCELLED"
QUIT STS
+35 ;ADM^VADPT2 assumes VAINDT and returns in VADMVT
SET VAINDT=SDT
DO ADM^VADPT2
+36 IF STS["INPATIENT"
IF $SELECT('VADMVT:1,'$PIECE(^DG(43,1,0),U,21):0,1:$PIECE($GET(^DIC(42,+$PIECE($GET(^DGPM(VADMVT,0)),U,6),0)),U,3)="D")
SET STS=""
+37 ; -- determine ci/co indicator
+38 ;DT is a FileMan-assumable variable with the current date
SET CHKIO=$SELECT($PIECE(APPTNOD,U,14)]"":"CHECKED OUT",$PIECE(APPTNOD,U,3)]"":"CHECKED IN",SDT>(DT+.2400):"FUTURE",1:"NO ACTION TAKEN")
+39 ; Look for check-in time in the Location file (#44) if check-in/out indicator is NO ACTION TAKEN. Needed 'cause VPS does not update Appointment file. wtc 10/31/2019 737
+40 ;
IF CHKIO="NO ACTION TAKEN"
IF CLINIEN'=""
Begin DoDot:1
+41 ;
NEW SDECD2
SET SDECD2=$$FIND^SDAM2(DFN,SDT,CLINIEN)
IF SDECD2
IF $PIECE($GET(^SC(CLINIEN,"S",SDT,1,SDECD2,"C")),U,1)'=""
SET CHKIO="CHECKED IN"
End DoDot:1
+42 if STS=""
SET STS=CHKIO
+43 ;If NO ACTION TAKEN, If cancelled in Patient(by SDCANCEL), wtc 11/4/2019 737
+44 ;
IF STS'["CANCELLED"
Begin DoDot:1
+45 ;If appointment does not match, leave status alone.
IF $PIECE($GET(^DPT(DFN,"S",SDT,0)),U,1)'=CLINIEN
QUIT
+46 ;
SET STS=$SELECT($PIECE($GET(^DPT(DFN,"S",SDT,0)),U,2)="PC":"CANCELLED BY PATIENT",$PIECE($GET(^DPT(DFN,"S",SDT,0)),U,2)="C":"CANCELLED BY CLINIC",1:STS)
End DoDot:1
+47 ;
+48 IF (STS="NO ACTION TAKEN")
IF ($PIECE(SDT,".")=DT)
IF (CHKIO'["CHECKED")
SET CHKIO="TODAY"
+49 ; -- determine print status
+50 ;745 lab include stsdt
IF STS["CANCELLED"
QUIT STS_"^"_STSDT
+51 SET RET=$SELECT(STS=CHKIO!(CHKIO=""):STS,1:"")
+52 IF RET=""
Begin DoDot:1
+53 ; WTC 3/26/19 722
IF STS["INPATIENT"
IF $PIECE(SDT,".",1)>DT
SET RET=$PIECE(STS," ",1)_"/FUTURE"
QUIT
+54 ; wtc 3/22/19 722 no outpatient encounter for inpatient
IF (STS["INPATIENT")
IF (CLINIEN]"")
IF ($PIECE($GET(^SC(CLINIEN,0)),U,17)'="Y")
IF OEIEN=""
SET RET=$PIECE(STS," ",1)_"/ACT REQ"
QUIT
+55 IF (STS["INPATIENT")
IF (CLINIEN]"")
IF ($PIECE($GET(^SC(CLINIEN,0)),U,17)'="Y")
IF ($PIECE($GET(^SCE(OEIEN,0)),U,7)="")
SET RET=$PIECE(STS," ",1)_"/ACT REQ"
QUIT
+56 IF (STS="NO ACTION TAKEN")
IF ((CHKIO="CHECKED OUT")!(CHKIO="CHECKED IN"))
SET RET="ACT REQ/"_CHKIO
Begin DoDot:2
+57 ; wtc 722 8/27/19 changed P to RET to match code in SDAM1, where the code originally came from.
IF (OEIEN)
IF ($PIECE($GET(^SCE(OEIEN,0)),U,7))
SET RET="CHECKED OUT"
End DoDot:2
QUIT
+58 IF ((STS="NO-SHOW")!(STS="NON-COUNT"))
SET RET=STS
if CHKIO="NO ACTION TAKEN"
QUIT
+59 SET RET=STS_"/"_CHKIO
End DoDot:1
+60 IF STS["INPATIENT"
IF ((CHKIO="")!(CHKIO="NO ACTION TAKEN"))
Begin DoDot:1
+61 IF SDT>(DT+.2359)
SET RET=$PIECE(STS," ")_"/FUTURE"
QUIT
+62 SET RET=$PIECE(STS," ")_"/NO ACT TAKN"
End DoDot:1
+63 IF STS["INPATIENT"
QUIT RET
+64 ;745
IF STS["NO-SHOW"
QUIT RET_"^"_STSDT
+65 IF ($GET(OEIEN))
IF ($DATA(^SCE(OEIEN,0)))
Begin DoDot:1
+66 SET OESTS=$PIECE($GET(^SCE(OEIEN,0)),U,12)
+67 if OESTS]""
SET OESTS=$PIECE($GET(^SD(409.63,OESTS,0)),U,1)
+68 IF $GET(OESTS)="NON-COUNT"
Begin DoDot:2
+69 IF $PIECE(APPTNOD,U,14)
SET RET="NON-COUNT/CHECKED OUT"
QUIT
+70 IF $PIECE(APPTNOD,U,3)
SET RET="NON-COUNT/CHECKED IN"
End DoDot:2
QUIT
+71 IF $GET(OESTS)="CHECKED OUT"
SET RET="CHECKED OUT"
QUIT
+72 IF $PIECE(APPTNOD,U,14)
SET RET="ACT REQ/CHECKED OUT"
Begin DoDot:2
+73 IF ($GET(OESTS)="")
IF ($PIECE($GET(^SCE(OEIEN,0)),U,7))
SET RET="CHECKED OUT"
End DoDot:2
QUIT
+74 IF $PIECE(APPTNOD,U,3)
SET RET="ACT REQ/CHECKED IN"
End DoDot:1
+75 QUIT RET
+76 ;
GETIEN(DFN,SDCLN,SDDT) ;get SDEC APPOINTMENT id
+1 NEW SDF,SDI,SDNOD,SDR
+2 if $GET(DFN)=""
QUIT ""
+3 if $GET(SDCLN)=""
QUIT ""
+4 if $GET(SDDT)=""
QUIT ""
+5 SET (SDF,SDI)=0
FOR
SET SDI=$ORDER(^SDEC(409.84,"CPAT",DFN,SDI))
if SDI=""
QUIT
Begin DoDot:1
+6 SET SDNOD=$GET(^SDEC(409.84,SDI,0))
+7 if SDNOD=""
QUIT
+8 SET SDR=$$GETRES^SDECUTL(SDCLN)
+9 IF $PIECE(SDNOD,U,1)=SDDT
IF $PIECE(SDNOD,U,7)=SDR
SET SDF=1
End DoDot:1
if SDF=1
QUIT
+10 QUIT $SELECT(SDI'="":SDI,1:"")
+11 ;
CONS(SDCL,DFN,SDDT) ;check for consult in file 44
+1 ;SDCL = (required) clinic IEN
+2 ;DFN = (required) patient IEN
+3 ;SDDT = (required) appointment time in FM format
+4 NEW CONS,CSTAT,SDI,SDJ
+5 SET CONS=""
+6 SET SDI=0
FOR
SET SDI=$ORDER(^SC(SDCL,"S",SDDT,1,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^SC(SDCL,"S",SDDT,1,SDI,0)),U,1)=DFN
Begin DoDot:2
+8 SET CONS=$GET(^SC(SDCL,"S",SDDT,1,SDI,"CONS"))
+9 IF +CONS
Begin DoDot:3
+10 SET CSTAT=$PIECE($GET(^GMR(123,CONS,0)),U,12)
+11 if (CSTAT=1!(CSTAT=2)!(CSTAT=13))
SET CONS=""
End DoDot:3
End DoDot:2
End DoDot:1
if CONS'=""
QUIT
+12 QUIT CONS
+13 ;
PCSTGET(SDECY,DFN,SDCL,SDBEG,SDEND) ;GET patient clinic status for a clinic for a given time frame - has the patient been seen by the given Clinic in the past 24 months
+1 ;PCSTGET(SDECY,DFN,SDCL,SDBEG,SDEND) external parameter tag is in SDEC
+2 ;INPUT:
+3 ;DFN = (required) Patient ID - Pointer to the PATIENT file 2 (lookup by name is not accurate if duplicates)
+4 ;SDCL = (required) Clinic code - Pointer to HOSPITAL LOCATION file
+5 ;SDBEG = (optional) Begin date in external format; defaults to 730 days previous (24 months)
+6 ;SDEND = (optional) End date in external format; defaults to today
+7 ;RETURN:
+8 ; Successful Return:
+9 ; a single entry in the global array indicating that patient has or has not been seen.
+10 ; "T00020RETURNCODE^T00100TEXT"
+11 ; Caught Exception Return:
+12 ; A single entry in the Global Array in the format "-1^<error text>"
+13 ; "T00020RETURNCODE^T00100TEXT"
+14 ; Unexpected Exception Return:
+15 ; Handled by the RPC Broker.
+16 ; M errors are trapped by the use of M and Kernel error handling.
+17 ; The RPC execution stops and the RPC Broker sends the error generated
+18 ; text back to the client.
+19 NEW SDASD,SDECI,SDS,STOP,SDYN,SDSCL
+20 ;N SDSNOD,SDSD,SDSTP,SDT,SDVSP,SDWL,SDYN alb/jsm 658 commented out since variables not used here
+21 NEW X,Y,%DT,APIEN
+22 SET SDECI=0
+23 SET SDECY="^TMP(""SDEC50"","_$JOB_",""PCSTGET"")"
+24 KILL @SDECY
+25 ; data header
+26 SET @SDECY@(0)="T00020RETURNCODE^T00100TEXT"_$CHAR(30)
+27 ;check for valid Patient
+28 IF '+DFN
DO ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY)
QUIT
+29 IF '$DATA(^DPT(DFN,0))
DO ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY)
QUIT
+30 ;check for valid Clinic
+31 IF '+SDCL
DO ERR1^SDECERR(-1,"Invalid Clinic ID.",SDECI,SDECY)
QUIT
+32 IF '$DATA(^SC(SDCL,0))
DO ERR1^SDECERR(-1,"Invalid Clinic ID.",SDECI,SDECY)
QUIT
+33 ;check times
+34 IF $GET(SDBEG)'=""
SET %DT=""
SET X=$PIECE(SDBEG,"@",1)
DO ^%DT
SET SDBEG=Y
IF Y=-1
SET SDBEG=""
+35 if $GET(SDBEG)=""
SET SDBEG=$PIECE($$FMADD^XLFDT($$NOW^XLFDT,-1095),".",1)
+36 ;alb/sat 665 - remove Q
IF $GET(SDEND)'=""
SET %DT=""
SET X=$PIECE(SDEND,"@",1)
DO ^%DT
SET SDEND=Y
IF Y=-1
SET SDEND=""
+37 if $GET(SDEND)=""
SET SDEND=$PIECE($$NOW^XLFDT,".",1)
+38 ;get stop code number alb/jsm 658 updated to use new CLSTOP call
SET STOP=$$CLSTOP(SDCL)
+39 IF '+STOP
DO ERR1^SDECERR(-1,"Clinic "_$PIECE($GET(^SC(+$GET(SDCL),0)),U,1)_" does not have a STOP CODE NUMBER defined.",SDECI,SDECY)
QUIT
+40 SET SDYN="NO"
+41 DO CHKPT
+42 SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^"_SDYN_$CHAR(30,31)
+43 QUIT
+44 ;
CLSTOP(CLINIC) ;Return clinic stop code for clinic
+1 ;Verify clinic is passed in
if $GET(CLINIC)=""
QUIT 0
+2 ;Return the stop code for the clinic
QUIT $PIECE($GET(^SC(CLINIC,0)),U,7)
+3 ;
CHKPT ;alb/jsm 658 added to be used by PCSTGET and PCST2GET
+1 NEW SDSCO
+2 ;alb/sat 665 - start with SDS=0 instead of ""
SET SDS=0
FOR
SET SDS=$ORDER(^DPT(DFN,"S",SDS))
if SDS=""
QUIT
Begin DoDot:1
+3 SET SDSCL=$PIECE($GET(^DPT(DFN,"S",SDS,0)),U,1)
+4 IF $$CLSTOP(SDSCL)=STOP
Begin DoDot:2
+5 SET APIEN=$$FIND^SDAM2(DFN,SDS,SDSCL)
+6 if APIEN=""
QUIT
+7 SET SDSCO=$PIECE($PIECE($GET(^SC(SDSCL,"S",SDS,1,+APIEN,"C")),U,3),".",1)
+8 if (SDSCO'="")&(SDSCO'<SDBEG)&(SDSCO'>SDEND)
SET SDYN="YES"
End DoDot:2
End DoDot:1
if SDYN="YES"
QUIT
+9 QUIT
+10 ;
PCST2GET(SDECY,DFN,STOP,SDBEG,SDEND) ;GET patient clinic status for a service/specialty (clinic stop) for a given time frame - has the patient been seen any clinics with the given service/specialty (clinic stop) in the past 24 months
+1 ;PCST2GET(SDECY,DFN,STOP,SDBEG,SDEND) external parameter tag is in SDEC
+2 ;INPUT:
+3 ; DFN = (required) Patient ID - Pointer to the PATIENT file 2 (lookup by name is not accurate if duplicates)
+4 ; STOP = (required) CLINIC STOP or Service/Specialty name - NAME from the SD WL SERVICE/SPECIALTY file - looks for 1st active
+5 ; OR - Pointer to the CLINIC STOP file
+6 ; SDBEG = (optional) Begin date in external format; defaults to 730 days previous (24 months)
+7 ; SDEND = (optional) End date in external format; defaults to today
+8 ;RETURN:
+9 ; Successful Return:
+10 ; a single entry in the global array indicating that patient has or has not been seen.
+11 ; "T00020RETURNCODE^T00100TEXT"
+12 ; Caught Exception Return:
+13 ; A single entry in the Global Array in the format "-1^<error text>"
+14 ; "T00020RETURNCODE^T00100TEXT"
+15 ; Unexpected Exception Return:
+16 ; Handled by the RPC Broker.
+17 ; M errors are trapped by the use of M and Kernel error handling.
+18 ; The RPC execution stops and the RPC Broker sends the error generated
+19 ; text back to the client.
+20 NEW SDASD,SDF,SDSCN,SDECI,SDSNOD,SDSD,SDSTP,SDT,SDVSP,SDWL,SDYN
+21 NEW H,WLSRVSP,X,Y,%DT
+22 SET WLSRVSP=""
+23 SET (SDF,SDECI,SDSCN)=0
+24 SET SDECY="^TMP(""SDEC50"","_$JOB_",""PCST2GET"")"
+25 KILL @SDECY
+26 ;data header
+27 SET @SDECY@(0)="T00020RETURNCODE^T00100TEXT"_$CHAR(30)
+28 ;check for valid Patient
+29 IF '+DFN
DO ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY)
QUIT
+30 IF '$DATA(^DPT(DFN,0))
DO ERR1^SDECERR(-1,"Invalid Patient ID.",SDECI,SDECY)
QUIT
+31 ;check for valid Service/Specialty
+32 SET STOP=$GET(STOP)
+33 IF +STOP
IF '$DATA(^DIC(40.7,STOP,0))
DO ERR1^SDECERR(-1,"Invalid stop code.",SDECI,SDECY)
QUIT
+34 IF +STOP
SET SDSCN=$$GET1^DIQ(40.7,STOP_",",.01)
SET SDF=1
+35 IF 'SDF
IF '+STOP
Begin DoDot:1
+36 SET H=""
FOR
SET H=$ORDER(^DIC(40.7,"B",STOP,H))
if H=""
QUIT
Begin DoDot:2
+37 IF $PIECE(^DIC(40.7,H,0),U,3)'=""
IF $PIECE(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT()
QUIT
+38 SET STOP=H
End DoDot:2
if +STOP
QUIT
End DoDot:1
+39 IF '+STOP
DO ERR1^SDECERR(-1,"Invalid Stop code.",SDECI,SDECY)
QUIT
+40 ;check times
+41 IF $GET(SDBEG)'=""
SET %DT=""
SET X=$PIECE(SDBEG,"@",1)
DO ^%DT
SET SDBEG=Y
IF Y=-1
SET SDBEG=""
+42 if $GET(SDBEG)=""
SET SDBEG=$PIECE($$FMADD^XLFDT($$NOW^XLFDT,-730),".",1)
+43 IF $GET(SDEND)'=""
SET %DT=""
SET X=$PIECE(SDEND,"@",1)
DO ^%DT
SET SDEND=Y
IF Y=-1
SET SDEND=""
QUIT
+44 if $GET(SDEND)=""
SET SDEND=$PIECE($$NOW^XLFDT,".",1)
+45 SET SDYN="NO"
+46 DO CHKPT
+47 SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^"_SDYN_$CHAR(30,31)
+48 QUIT
+49 ;
LOOK ;
+1 ;look in PATIENT Appointments
+2 IF SDYN'="YES"
Begin DoDot:1
+3 SET SDS=""
FOR
SET SDS=$ORDER(^DPT(DFN,"S",SDS))
if SDS=""
QUIT
Begin DoDot:2
+4 SET SDSD=$$GET1^DIQ(2.98,SDS_","_DFN_",",.001,"I")
+5 IF (SDSD'<SDBEG)&(SDSD'>SDEND)
Begin DoDot:3
+6 IF $PIECE($GET(^DPT(DFN,"S",SDS,0)),U,1)=SDCL
Begin DoDot:4
+7 SET APIEN=$$FIND^SDAM2(DFN,SDS,SDCL)
+8 IF APIEN'=""
IF $GET(^SC(SDCL,"S",SDS,1,APIEN,"C"))'=""
SET SDYN="YES"
End DoDot:4
End DoDot:3
End DoDot:2
if SDYN="YES"
QUIT
End DoDot:1
+9 ;look in HOSPITAL LOCATION
+10 IF SDYN'="YES"
Begin DoDot:1
+11 SET SDS=SDBEG
FOR
SET SDS=$ORDER(^SC(SDCL,"S",SDS))
if SDS'>0
QUIT
if SDS>SDEND
QUIT
Begin DoDot:2
+12 SET APIEN=$$FIND^SDAM2(DFN,SDS,SDCL)
+13 if APIEN=""
QUIT
+14 if $PIECE($GET(^SC(SDCL,"S",SDS,1,APIEN,"C")),U,1)'=""
SET SDYN="YES"
End DoDot:2
if SDYN="YES"
QUIT
End DoDot:1
+15 QUIT
+16 ;
LOOKWL ;
+1 ;look in SD WAIT LIST file for STOP stop code
+2 SET SDWL=""
FOR
SET SDWL=$ORDER(^SDWL(409.3,"B",DFN,SDWL))
if SDWL=""
QUIT
Begin DoDot:1
+3 SET SDSD=$PIECE($GET(^SDWL(409.3,SDWL,0)),U,23)
+4 IF (SDSD'<SDBEG)&(SDSD'>SDEND)
Begin DoDot:2
+5 SET SDSTP=$PIECE($GET(^SDWL(409.3,SDWL,"SDAPT")),U,4)
+6 IF SDSTP=STOP
SET SDYN="YES"
End DoDot:2
+7 if SDYN="YES"
QUIT
End DoDot:1
if SDYN="YES"
QUIT
+8 QUIT
+9 ;
PCSGET(SDECY,SDSVSP,SDCL) ;GET clinics for a service/specialty (clinic stop) ;alb/sat 658 add SDCL
+1 ;PCSGET(SDECY,SDSVSP) external parameter tag is in SDEC
+2 ;INPUT:
+3 ; SDSVSP = (required) Service/Specialty name - NAME from the SD WL SERVICE/SPECIALTY file - looks for 1st active
+4 ; OR - Pointer to the SD WL SERVICE/SPECIALTY file
+5 ;RETURN:
+6 ; Successful Return:
+7 ; global array containing Clinic IEN and Name of matching Hospital Locations
+8 ; CLINSTOP - pointer to CLINIC STOP file 40.7
+9 ; CLINIEN - pointer to the HOSPITAL LOCATION file 44
+10 ; CLINNAME - NAME from the HOSPITAL LOCATION file
+11 ; Caught Exception Return:
+12 ; A single entry in the Global Array in the format "-1^<error text>"
+13 ; "T00020RETURNCODE^T00100TEXT"
+14 ; Unexpected Exception Return:
+15 ; Handled by the RPC Broker.
+16 ; M errors are trapped by the use of M and Kernel error handling.
+17 ; The RPC execution stops and the RPC Broker sends the error generated
+18 ; text back to the client.
+19 ;
+20 NEW SDASD,SDSCN,SDECI,SDSNOD,SDSD,SDSTP,SDT,SDVSP,SDWL
+21 NEW H,WLSRVSP,X,Y
+22 SET WLSRVSP=""
+23 SET (SDECI,SDSCN)=0
+24 SET SDECY="^TMP(""SDEC50"","_$JOB_",""PCSGET"")"
+25 KILL @SDECY
+26 ;data header
+27 SET @SDECY@(0)="T00030CLINSTOP^T00030CLINIEN^T00030CLINNAME"_$CHAR(30)
+28 ;check clinic ;alb/sat 658
+29 SET SDCL=$GET(SDCL)
+30 IF SDCL'=""
IF $DATA(^SC(SDCL,0))
Begin DoDot:1
+31 SET SDSVSP=$$GET1^DIQ(44,SDCL_",",8,"I")
End DoDot:1
+32 ;check for valid Service/Specialty
+33 SET SDSVSP=$GET(SDSVSP)
+34 IF SDSVSP=""
DO ERR1^SDECERR(-1,"Service/Specialty ID required",SDECI,SDECY)
QUIT
+35 IF '+SDSVSP
Begin DoDot:1
+36 SET H=0
FOR
SET H=$ORDER(^DIC(40.7,"B",SDSVSP,H))
if H=""
QUIT
Begin DoDot:2
+37 IF $PIECE(^DIC(40.7,H,0),U,3)'=""
IF $PIECE(^DIC(40.7,H,0),U,3)<$$NOW^XLFDT()
QUIT
+38 SET SDSCN=H
End DoDot:2
if SDSCN'=0
QUIT
End DoDot:1
+39 IF '+SDSCN
DO ERR1^SDECERR(-1,"Invalid Service/Specialty.",SDECI,SDECY)
QUIT
+40 SET SDCL=0
FOR
SET SDCL=$ORDER(^SC(SDCL))
if SDCL'>0
QUIT
Begin DoDot:1
+41 SET SDCLN=$PIECE($GET(^SC(SDCL,0)),U,7)
+42 ;only active
IF $$GET1^DIQ(44,SDCL_",",2505,)'=""
IF $$GET1^DIQ(44,SDCL_",",2506)=""
QUIT
+43 IF SDCLN=SDSCN
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=SDSCN_U_SDCL_U_$PIECE($GET(^SC(SDCL,0)),U,1)_$CHAR(30)
End DoDot:1
+44 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+45 QUIT
