- 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 Feb 19, 2025@00:17:07 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
