SDEC02 ;ALB/SAT,PC,MGD - VISTA SCHEDULING RPCS ;Aug 25, 2020@21:11
;;5.3;Scheduling;**627,642,658,672,722,694,824**;Aug 13, 1993;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified
;
; Reference to ^DPT in ICR #10035
;
Q
;
CRSCHED(SDECY,SDECRES,SDECSTART,SDECEND,SDECWKIN,MAXREC,LASTSUB) ;Create Resource Appointment Schedule ;alb/sat 672
;CRSCHED(SDECY,SDECRES,SDECSTART,SDECEND,SDECWKIN) external parameter tag is in SDEC
;Create Resource Appointment Schedule recordset
;On error, returns 0 in APPOINTMENTID field and error text in NOTE field
;
;$O Thru ^SDEC(409.84,"ARSRC", RESOURCE, STARTTIME, APPTID)
;SDECRES - pipe | delimited list of resource names
;SDECSTART - Start date/time in external form
;SDECEND - End Date/time in external form
;SDECWKIN - Include Walk-ins 1=return walkins; 0=skip walk-ins
;9-27-2004 Added walkin to returned datatable
;TODO: Change SDECRES from names to IDs
;RETURN:
; Global Array in which each array entry contains data for the Resource Appointment Schedule separated by ^:
; 1. APPOINTMENTID
; 2. START_TIME
; 3. END_TIME
; 4. CHECKIN
; 5. AUXTIME
; 6. PATIENTID
; 7. PATIENTNAME
; 8. RESOURCENAME
; 9. NOSHOW
;10. HRN
;11. ACCESSTYPEID
;12. WALKIN
;13. CHECKOUT
;14. VPROVIDER
;15. CANCELLED
;16. NOTE
;17. DAPTDT
;18. APPTREQTYPE
;19. DIEDON
;20. EESTAT - Patient Status N=NEW E=ESTABLISHED
;21. MULT - data from MULT APPTS MADE field of SDEC APPT REQUEST separated by pipe ;alb/sat 642
; each pipe piece contains the following ~ pieces:
; 1. MULT APPTS MADE - pointer to SDEC APPOINTMENT
; 2. PARENT REQUEST - pointer to SDEC APPT REQUEST
;22. SDPARENT - PARENT REQUEST from SDEC APPT REQUEST. Pointer to SDEC APPT REQUEST. ;alb/sat 642
;23. RESOURCEID | STARTTIME | APPTID
;24. SSN
;25. DOB
;26. patient sensitive & record access checks
;27. APPTTYPE - APPOINTMENT TYPE (#.06)
;
N SDECERR,SDECIEN,SDECDEPD,SDECDEPN,SDECRESD,SDECI,SDECJ,SDECRESN,SDECS,SDECAD,SDECZ,SDECQ,SDECNOD,SDECTMP
N SDECPAT,SDECNOT,SDECZPCD,SDECPCD,SDDDT,SDAPTYP
N SDCNT,SDI ;alb/sat 672
N %DT,X,Y
K ^TMP("SDEC02",$JOB)
S SDECERR=""
S SDCNT=0 ;alb/sat 672
S SDECY="^TMP(""SDEC02"","_$JOB_")"
; 1 2 3 4 5 6
S SDECTMP="I00020APPOINTMENTID^D00030START_TIME^D00030END_TIME^D00030CHECKIN^D00030AUXTIME^I00020PATIENTID^"
; 7 8 9 10 11 12
S SDECTMP=SDECTMP_"T00030PATIENTNAME^T00030RESOURCENAME^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^"
; 13 14 15 16 17 18
S SDECTMP=SDECTMP_"D00030CHECKOUT^I00020VPROVIDER^T00020CANCELLED^T00250NOTE^T00030DAPTDT^T00030APPTREQTYPE^"
;alb/sat 642 added MULT and SDPARENT ;alb/sat 672 added SLAST,SSN,DOB,SENSITIVE
; 19 20 21 22 23 24 25 26 27
S SDECTMP=SDECTMP_"T00030DIEDON^T00030EESTAT^T00250MULT^T00030SDPARENT^T00050SDLAST^T00030SSN^T00030DOB^T00100SENSITIVE^T00030APPTTYP"
S ^TMP("SDEC02",$JOB,0)=SDECTMP_$CHAR(30)
;
;
; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
;
;S:SDECSTART["@0000" SDECSTART=$P(SDECSTART,"@")
;S:SDECEND["@0000" SDECEND=$P(SDECEND,"@")
;S %DT="T",X=SDECSTART D ^%DT S SDECSTART=Y
S SDECSTART=$$NETTOFM^SDECDATE(SDECSTART,"N") ;
I SDECSTART=-1 S ^TMP("SDEC02",$JOB,0)=^TMP("SDEC02",$JOB,0)_$CHAR(31) Q
; need to set the start date back to midnight if no time is sent to us from VSE
I $PIECE(SDECSTART,".",2)="" S SDECSTART=$$FMADD^XLFDT(SDECSTART,-1)_".24" ;pwc *694 1/13/2020
;S %DT="T",X=SDECEND D ^%DT S SDECEND=Y
S SDECEND=$$NETTOFM^SDECDATE(SDECEND,"Y") ;
I SDECEND=-1 S ^TMP("SDEC02",$JOB,0)=^TMP("SDEC02",$JOB,0)_$CHAR(31) Q
S MAXREC=$GET(MAXREC) S:'MAXREC MAXREC=9999999 ;alb/sat 672
S LASTSUB=$GET(LASTSUB) ;alb/sat 672
;
S SDECI=0
D STRES
;
S ^TMP("SDEC02",$JOB,SDECI)=^TMP("SDEC02",$JOB,SDECI)_$CHAR(31)
Q
;
STRES ;
S SDI=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1),1:1) ;alb/sat 672
N SDECRESA,SDECRSND,SDECRST,SDCL,NEWRES,SDRSLTS,SDECOVR ;*zeb+34 722 1/17/19 include appts for resources that share clinics
I SDECRES["|" D I 1
. S SDECRESA=SDECRES
E D
. S SDECRESA="|"_SDECRES_"|"
. I '+SDECRES Q:'$DATA(^SDEC(409.831,"B",SDECRES))
. I '+SDECRES S SDECRES=$ORDER(^SDEC(409.831,"B",SDECRES,0))
. S SDECRSND=$GET(^SDEC(409.831,SDECRES,0))
. S SDECRST=$PIECE($PIECE(SDECRSND,U,11),";",2)
. I SDECRST'="SC(" D Q
. . S SDECRESA=SDECRESA_"|"_SDECRES
. S SDCL=$PIECE(SDECRSND,U,4)
. S NEWRES=""
. F S NEWRES=$ORDER(^SDEC(409.831,"ALOC",SDCL,NEWRES)) Q:NEWRES="" D
. . Q:NEWRES=SDECRES
. . S SDECRESA=SDECRESA_"|"_NEWRES_U_$PIECE(^SDEC(409.831,SDECRES,0),U,1)
F SDECJ=1:1:$LENGTH(SDECRESA,"|") S SDECRESN=$PIECE(SDECRESA,"|",SDECJ) D
. Q:SDECRESN=""
. S SDECOVR=""
. I SDECRESN[U S SDECOVR=$PIECE(SDECRESN,U,2),SDECRESD=$PIECE(SDECRESN,U,1)
. E S SDECRESD=SDECRESN
. ;I +SDECRESN Q:'$D(^SDEC(409.831,+SDECRESN,0))
. ;I +SDECRESN S SDECRESD=SDECRESN
. ;I '+SDECRESN Q:'$D(^SDEC(409.831,"B",SDECRESN))
. ;I '+SDECRESN S SDECRESD=$O(^SDEC(409.831,"B",SDECRESN,0))
. ;Q:'+SDECRESD
. S SDECRESN=$PIECE($GET(^SDEC(409.831,SDECRESD,0)),U,1)
. ;Q:'$D(^SDEC(409.84,"ARSRC",SDECRESD))
. S SDECS=$SELECT($PIECE(LASTSUB,"|",2):$PIECE(LASTSUB,"|",2),1:SDECSTART)-.0001 ;alb/sat 672
. F S SDECS=$ORDER(^SDEC(409.84,"ARSRC",SDECRESD,SDECS)) Q:'+SDECS Q:SDECS>SDECEND D Q:SDCNT'<MAXREC ;alb/sat 672
. . S SDECAD=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0) ;alb/sat 672
. . S LASTSUB="" ;alb/sat 672
. . ;alb/sat 672
. . S:SDECOVR="" SDECOVR=SDECRESN ;*zeb+1 722 1/17/19 allow override of name for resources in same clinic
. . F S SDECAD=$ORDER(^SDEC(409.84,"ARSRC",SDECRESD,SDECS,SDECAD)) Q:'+SDECAD D:'$DATA(SDRSLTS(SDECAD)) STCOMM(SDECAD,SDECOVR,SDECRESD) S SDRSLTS(SDECAD)=1 Q:SDCNT'<MAXREC
Q
;
STCOMM(SDECAD,SDECRESN,SDRES) ;
;SDECAD is the sdec appointment IEN
N CHECKIN,SDECC,SDECCAN,SDECCO,SDECQ,SDECZ,SDECSUBC,SDECHRN,SDECPATD,SDECATID,SDECISWK
N DIEDON,SDECVPRV,REQFILE,REQIEN,REQTYPE
N SDDEMO,SDSENS,SDTMP ;alb/sat 672
S SDTMP="" ;alb/sat 672
Q:'$DATA(^SDEC(409.84,SDECAD,0))
S SDECNOD=^SDEC(409.84,SDECAD,0)
S SDECCAN=($PIECE(SDECNOD,U,12)]"") ;CANCELLED flag 1=cancelled; 0=not cancelled
S SDECISWK=0
S:$PIECE(SDECNOD,U,13)="y" SDECISWK=1
I +$GET(SDECWKIN) Q:SDECISWK ;Don't return walkins if appt is WALKIN and SDECWKIN is 1
S SDECCO=$TRANSLATE($$FMTE^XLFDT($PIECE(SDECNOD,U,14)),"@"," ") ;APPOINTMENT CHECKOUT TIME
S SDECVPRV=$PIECE(SDECNOD,U,16) ;POINTER TO V PROVIDER TABLE ^AUPNVPRV
S SDECZ=SDECAD_"^"
F SDECQ=1:1:4 D
. S Y=$PIECE(SDECNOD,U,SDECQ)
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
. ;
. ;X ^DD("DD") S Y=$TR(Y,"@"," ")
. S Y=$$FMTONET^SDECDATE(Y,"Y") ;
. S Y=$TRANSLATE(Y,"@"," ") ;remove the @ and replace with a space between date/time pwc *694 1/13/2020
. S SDECZ=SDECZ_Y_"^"
S SDECPATD=$PIECE(SDECNOD,U,5)
D PDEMO^SDECU3(.SDDEMO,SDECPATD)
I $PIECE(SDECZ,U,4)="" S CHECKIN=$$CHECKIN(SDRES,$PIECE(SDECNOD,U,1),SDECPATD,SDECAD) S:CHECKIN'="" $PIECE(SDECZ,U,4)=$PIECE(CHECKIN,U,1),$PIECE(SDECZ,U,5)=$PIECE(CHECKIN,U,2) ;if no checkin, check appointment checkin
S $PIECE(SDECZ,"^",6)=SDECPATD ;PATIENT ID
S SDECPAT=""
I SDECPATD]"",$DATA(^DPT(SDECPATD,0)) S SDECPAT=$PIECE(^DPT(SDECPATD,0),U)
S $PIECE(SDECZ,"^",7)=SDECPAT ;PATIENT NAME
S $PIECE(SDECZ,"^",8)=SDECRESN ;RESOURCENAME
S $PIECE(SDECZ,"^",9)=+$PIECE(SDECNOD,U,10) ;NOSHOW
S SDECHRN=""
I $DATA(DUZ(2)),DUZ(2)>0 S SDECHRN=$PIECE($GET(^AUPNPAT(SDECPATD,41,DUZ(2),0)),U,2) ;HRN
S $PIECE(SDECZ,"^",10)=SDECHRN
S SDECATID=$PIECE(SDECNOD,U,6)
S:'+SDECATID SDECATID=0 ;UNKNOWN TYPE
S $PIECE(SDECZ,"^",11)=SDECATID
S $PIECE(SDECZ,"^",12)=SDECISWK
S $PIECE(SDECZ,"^",13)=SDECCO ;CHECKOUT TIME
S $PIECE(SDECZ,"^",14)=SDECVPRV ;POINTER TO NEW PERSON
S $PIECE(SDECZ,"^",15)=SDECCAN ;CANCELLED
;NOTE [16]
S SDECNOT="",SDECQ=0 F S SDECQ=$ORDER(^SDEC(409.84,SDECAD,1,SDECQ)) Q:'+SDECQ D
. S SDECNOT=$GET(^SDEC(409.84,SDECAD,1,SDECQ,0))
. S:$EXTRACT(SDECNOT,$LENGTH(SDECNOT)-1,$LENGTH(SDECNOT))'=" " SDECNOT=SDECNOT_" "
. S SDTMP=SDTMP_$SELECT(SDTMP'="":" ",1:"")_$TRANSLATE(SDECNOT,"^"," ") ;alb/sat 672
. ;S SDECI=SDECI+1 ;alb/sat 672 - removed
. ;S ^TMP("SDEC02",$J,SDECI)=$TR(SDECNOT,"^"," ") ;alb/sat 658 ;alb/sat 672 - removed
;S ^TMP("SDEC02",$J,SDECI)=^TMP("SDEC02",$J,SDECI)_"^" ;alb/sat 672 - replaced
S $PIECE(SDECZ,"^",16)=SDTMP ;alb/sat 672
;additional data
;S SDECZ="" ;alb/sat 672 - removed
S $PIECE(SDECZ,"^",17)=$SELECT($PIECE(SDECNOD,U,20)'="":$$FMTE^XLFDT($PIECE(SDECNOD,U,20)),1:"") ;alb/sat 672
;appt request type
S SDAPTYP=$PIECE($GET(^SDEC(409.84,SDECAD,2)),U,1)
S:SDAPTYP'="" SDAPTYP=$SELECT($PIECE(SDAPTYP,";",2)["SDWL":"E",$PIECE(SDAPTYP,";",2)["GMR":"C",$PIECE(SDAPTYP,";",2)="SD(403.5,":"R",$PIECE(SDAPTYP,";",2)="SDEC(409.85,":"A",1:"")_"|"_$PIECE(SDAPTYP,";",1)
S $PIECE(SDECZ,"^",18)=SDAPTYP ;[18] ;alb/sat 672
S DIEDON="" D DIEDON^ORWPT(.DIEDON,SDECPATD)
S $PIECE(SDECZ,"^",19)=DIEDON ;[19] ;alb/sat 672
S $PIECE(SDECZ,"^",20)=$$GET1^DIQ(409.84,SDECAD_",",.23,"E") ;[20] ;alb/sat 672
I $PIECE(SDAPTYP,"|",1)="A" S $PIECE(SDECZ,"^",21)=$$MULT(SDAPTYP) ;[21] [22] alb/sat 642 ;alb/sat 672
I $PIECE(SDAPTYP,"|",1)="A" S $PIECE(SDECZ,"^",22)=$$GET1^DIQ(409.85,$PIECE(SDAPTYP,"|",2)_",",43.8,"I") ;[21] [22] alb/sat 642 ;alb/sat 672
S $PIECE(SDECZ,"^",24)=$GET(SDDEMO("SSN")) ;[24] ;alb/sat 672 - added
S $PIECE(SDECZ,"^",25)=$GET(SDDEMO("DOB")) ;[25] ;alb/sat 672 - added
S SDSENS=$$PTSEC^SDECUTL(SDECPATD) S $PIECE(SDECZ,"^",26)=SDSENS ;[26] ;alb/sat 672 - added
S REQTYPE=$$GET1^DIQ(409.84,SDECAD_",",.22,"I")
S REQIEN=$P(REQTYPE,";",1),REQFILE=$P(REQTYPE,";",2)
I REQFILE["123" S REQTYPE=$$GET1^DIQ(123,REQIEN_",",4,"E")
I REQFILE["409.85" S REQTYPE=$$GET1^DIQ(409.85,REQIEN_",",4,"E")
I REQFILE["403.5"!(REQFILE["409.3") S REQTYPE=""
S $PIECE(SDECZ,"^",27)=REQTYPE ; APPOINTMENT TYPE (#.06)
S SDCNT=SDCNT+1 I SDCNT'<MAXREC S $PIECE(SDECZ,"^",23)=SDECJ_"|"_SDECS_"|"_SDECAD ;[23] ;alb/sat 672 - last subscript on last rec
S SDECI=SDECI+1 S ^TMP("SDEC02",$JOB,SDECI)=SDECZ_$CHAR(30) ;alb/sat 672
Q
CHECKIN(SDRES,SDT,DFN,APPT) ;alb/sat 642 - if no checkin, check appointment checkin
; SDRES - resource id
; SDT - appointment date/time in external format
; DFN - patient ID
N CHECKIN,ENTERED,SDCL,SDFDA,SDI,SDNOD,Y
S (CHECKIN,ENTERED)=""
S SDCL=$$GET1^DIQ(409.831,SDRES_",",.04,"I")
S SDI=0 F S SDI=$ORDER(^SC(SDCL,"S",SDT,1,SDI)) Q:SDI'>0 D Q:CHECKIN'=""
.S SDNOD=$GET(^SC(SDCL,"S",SDT,1,SDI,0))
.Q:$PIECE(SDNOD,U,1)'=DFN
.I $DATA(^SC(SDCL,"S",SDT,1,SDI,"C")) D
..S CHECKIN=$PIECE($GET(^SC(SDCL,"S",SDT,1,SDI,"C")),U,1)
..S ENTERED=$PIECE($GET(^SC(SDCL,"S",SDT,1,SDI,"C")),U,5)
..S:CHECKIN'="" SDFDA(409.84,APPT_",",.03)=CHECKIN
..S:ENTERED'="" SDFDA(409.84,APPT_",",.04)=ENTERED
..D:$DATA(SDFDA) UPDATE^DIE("","SDFDA")
.. S Y=CHECKIN
.. ;
.. ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
.. ;
.. ;X ^DD("DD") S CHECKIN=$TR(Y,"@"," ")
.. S CHECKIN=$$FMTONET^SDECDATE(CHECKIN,"Y") ;
.. ;S Y=ENTERED
.. ;X ^DD("DD") S ENTERED=$TR(Y,"@"," ")
.. S ENTERED=$$FMTONET^SDECDATE(ENTERED,"Y") ;
Q CHECKIN_U_ENTERED
MULT(SDAPTYP) ;get data from MULT APPTS MADE field of SDEC APPT REQUEST file ;alb/sat 642
N ARIEN,SDI,MULT1,MULTL
S MULTL=""
S ARIEN=$PIECE(SDAPTYP,"|",2)
S SDI=0 F S SDI=$ORDER(^SDEC(409.85,ARIEN,2,SDI)) Q:SDI'>0 D
.S MULT1=$PIECE($GET(^SDEC(409.85,ARIEN,2,SDI,0)),"^",1)
.S MULTL=$SELECT(MULTL'="":MULTL_"|",1:"")_MULT1
Q MULTL
;
ERR(SDECI,SDECERR) ;Error processing
S SDECI=SDECI+1
S ^TMP("SDEC02",$JOB,SDECI)="0^^^^^^^^^^^"_SDECERR_$CHAR(30)
S SDECI=SDECI+1
S ^TMP("SDEC02",$JOB,SDECI)=$CHAR(31)
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
I '$DATA(SDECI) N SDECI S SDECI=999999
S SDECI=SDECI+1
D ERR(SDECI,"SDEC31 Error")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC02 12497 printed Apr 09, 2024@21:40:21 Page 2
SDEC02 ;ALB/SAT,PC,MGD - VISTA SCHEDULING RPCS ;Aug 25, 2020@21:11
+1 ;;5.3;Scheduling;**627,642,658,672,722,694,824**;Aug 13, 1993;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 ; Reference to ^DPT in ICR #10035
+5 ;
+6 QUIT
+7 ;
CRSCHED(SDECY,SDECRES,SDECSTART,SDECEND,SDECWKIN,MAXREC,LASTSUB) ;Create Resource Appointment Schedule ;alb/sat 672
+1 ;CRSCHED(SDECY,SDECRES,SDECSTART,SDECEND,SDECWKIN) external parameter tag is in SDEC
+2 ;Create Resource Appointment Schedule recordset
+3 ;On error, returns 0 in APPOINTMENTID field and error text in NOTE field
+4 ;
+5 ;$O Thru ^SDEC(409.84,"ARSRC", RESOURCE, STARTTIME, APPTID)
+6 ;SDECRES - pipe | delimited list of resource names
+7 ;SDECSTART - Start date/time in external form
+8 ;SDECEND - End Date/time in external form
+9 ;SDECWKIN - Include Walk-ins 1=return walkins; 0=skip walk-ins
+10 ;9-27-2004 Added walkin to returned datatable
+11 ;TODO: Change SDECRES from names to IDs
+12 ;RETURN:
+13 ; Global Array in which each array entry contains data for the Resource Appointment Schedule separated by ^:
+14 ; 1. APPOINTMENTID
+15 ; 2. START_TIME
+16 ; 3. END_TIME
+17 ; 4. CHECKIN
+18 ; 5. AUXTIME
+19 ; 6. PATIENTID
+20 ; 7. PATIENTNAME
+21 ; 8. RESOURCENAME
+22 ; 9. NOSHOW
+23 ;10. HRN
+24 ;11. ACCESSTYPEID
+25 ;12. WALKIN
+26 ;13. CHECKOUT
+27 ;14. VPROVIDER
+28 ;15. CANCELLED
+29 ;16. NOTE
+30 ;17. DAPTDT
+31 ;18. APPTREQTYPE
+32 ;19. DIEDON
+33 ;20. EESTAT - Patient Status N=NEW E=ESTABLISHED
+34 ;21. MULT - data from MULT APPTS MADE field of SDEC APPT REQUEST separated by pipe ;alb/sat 642
+35 ; each pipe piece contains the following ~ pieces:
+36 ; 1. MULT APPTS MADE - pointer to SDEC APPOINTMENT
+37 ; 2. PARENT REQUEST - pointer to SDEC APPT REQUEST
+38 ;22. SDPARENT - PARENT REQUEST from SDEC APPT REQUEST. Pointer to SDEC APPT REQUEST. ;alb/sat 642
+39 ;23. RESOURCEID | STARTTIME | APPTID
+40 ;24. SSN
+41 ;25. DOB
+42 ;26. patient sensitive & record access checks
+43 ;27. APPTTYPE - APPOINTMENT TYPE (#.06)
+44 ;
+45 NEW SDECERR,SDECIEN,SDECDEPD,SDECDEPN,SDECRESD,SDECI,SDECJ,SDECRESN,SDECS,SDECAD,SDECZ,SDECQ,SDECNOD,SDECTMP
+46 NEW SDECPAT,SDECNOT,SDECZPCD,SDECPCD,SDDDT,SDAPTYP
+47 ;alb/sat 672
NEW SDCNT,SDI
+48 NEW %DT,X,Y
+49 KILL ^TMP("SDEC02",$JOB)
+50 SET SDECERR=""
+51 ;alb/sat 672
SET SDCNT=0
+52 SET SDECY="^TMP(""SDEC02"","_$JOB_")"
+53 ; 1 2 3 4 5 6
+54 SET SDECTMP="I00020APPOINTMENTID^D00030START_TIME^D00030END_TIME^D00030CHECKIN^D00030AUXTIME^I00020PATIENTID^"
+55 ; 7 8 9 10 11 12
+56 SET SDECTMP=SDECTMP_"T00030PATIENTNAME^T00030RESOURCENAME^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^"
+57 ; 13 14 15 16 17 18
+58 SET SDECTMP=SDECTMP_"D00030CHECKOUT^I00020VPROVIDER^T00020CANCELLED^T00250NOTE^T00030DAPTDT^T00030APPTREQTYPE^"
+59 ;alb/sat 642 added MULT and SDPARENT ;alb/sat 672 added SLAST,SSN,DOB,SENSITIVE
+60 ; 19 20 21 22 23 24 25 26 27
+61 SET SDECTMP=SDECTMP_"T00030DIEDON^T00030EESTAT^T00250MULT^T00030SDPARENT^T00050SDLAST^T00030SSN^T00030DOB^T00100SENSITIVE^T00030APPTTYP"
+62 SET ^TMP("SDEC02",$JOB,0)=SDECTMP_$CHAR(30)
+63 ;
+64 ;
+65 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+66 ;
+67 ;S:SDECSTART["@0000" SDECSTART=$P(SDECSTART,"@")
+68 ;S:SDECEND["@0000" SDECEND=$P(SDECEND,"@")
+69 ;S %DT="T",X=SDECSTART D ^%DT S SDECSTART=Y
+70 ;
SET SDECSTART=$$NETTOFM^SDECDATE(SDECSTART,"N")
+71 IF SDECSTART=-1
SET ^TMP("SDEC02",$JOB,0)=^TMP("SDEC02",$JOB,0)_$CHAR(31)
QUIT
+72 ; need to set the start date back to midnight if no time is sent to us from VSE
+73 ;pwc *694 1/13/2020
IF $PIECE(SDECSTART,".",2)=""
SET SDECSTART=$$FMADD^XLFDT(SDECSTART,-1)_".24"
+74 ;S %DT="T",X=SDECEND D ^%DT S SDECEND=Y
+75 ;
SET SDECEND=$$NETTOFM^SDECDATE(SDECEND,"Y")
+76 IF SDECEND=-1
SET ^TMP("SDEC02",$JOB,0)=^TMP("SDEC02",$JOB,0)_$CHAR(31)
QUIT
+77 ;alb/sat 672
SET MAXREC=$GET(MAXREC)
if 'MAXREC
SET MAXREC=9999999
+78 ;alb/sat 672
SET LASTSUB=$GET(LASTSUB)
+79 ;
+80 SET SDECI=0
+81 DO STRES
+82 ;
+83 SET ^TMP("SDEC02",$JOB,SDECI)=^TMP("SDEC02",$JOB,SDECI)_$CHAR(31)
+84 QUIT
+85 ;
STRES ;
+1 ;alb/sat 672
SET SDI=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1),1:1)
+2 ;*zeb+34 722 1/17/19 include appts for resources that share clinics
NEW SDECRESA,SDECRSND,SDECRST,SDCL,NEWRES,SDRSLTS,SDECOVR
+3 IF SDECRES["|"
Begin DoDot:1
+4 SET SDECRESA=SDECRES
End DoDot:1
IF 1
+5 IF '$TEST
Begin DoDot:1
+6 SET SDECRESA="|"_SDECRES_"|"
+7 IF '+SDECRES
if '$DATA(^SDEC(409.831,"B",SDECRES))
QUIT
+8 IF '+SDECRES
SET SDECRES=$ORDER(^SDEC(409.831,"B",SDECRES,0))
+9 SET SDECRSND=$GET(^SDEC(409.831,SDECRES,0))
+10 SET SDECRST=$PIECE($PIECE(SDECRSND,U,11),";",2)
+11 IF SDECRST'="SC("
Begin DoDot:2
+12 SET SDECRESA=SDECRESA_"|"_SDECRES
End DoDot:2
QUIT
+13 SET SDCL=$PIECE(SDECRSND,U,4)
+14 SET NEWRES=""
+15 FOR
SET NEWRES=$ORDER(^SDEC(409.831,"ALOC",SDCL,NEWRES))
if NEWRES=""
QUIT
Begin DoDot:2
+16 if NEWRES=SDECRES
QUIT
+17 SET SDECRESA=SDECRESA_"|"_NEWRES_U_$PIECE(^SDEC(409.831,SDECRES,0),U,1)
End DoDot:2
End DoDot:1
+18 FOR SDECJ=1:1:$LENGTH(SDECRESA,"|")
SET SDECRESN=$PIECE(SDECRESA,"|",SDECJ)
Begin DoDot:1
+19 if SDECRESN=""
QUIT
+20 SET SDECOVR=""
+21 IF SDECRESN[U
SET SDECOVR=$PIECE(SDECRESN,U,2)
SET SDECRESD=$PIECE(SDECRESN,U,1)
+22 IF '$TEST
SET SDECRESD=SDECRESN
+23 ;I +SDECRESN Q:'$D(^SDEC(409.831,+SDECRESN,0))
+24 ;I +SDECRESN S SDECRESD=SDECRESN
+25 ;I '+SDECRESN Q:'$D(^SDEC(409.831,"B",SDECRESN))
+26 ;I '+SDECRESN S SDECRESD=$O(^SDEC(409.831,"B",SDECRESN,0))
+27 ;Q:'+SDECRESD
+28 SET SDECRESN=$PIECE($GET(^SDEC(409.831,SDECRESD,0)),U,1)
+29 ;Q:'$D(^SDEC(409.84,"ARSRC",SDECRESD))
+30 ;alb/sat 672
SET SDECS=$SELECT($PIECE(LASTSUB,"|",2):$PIECE(LASTSUB,"|",2),1:SDECSTART)-.0001
+31 ;alb/sat 672
FOR
SET SDECS=$ORDER(^SDEC(409.84,"ARSRC",SDECRESD,SDECS))
if '+SDECS
QUIT
if SDECS>SDECEND
QUIT
Begin DoDot:2
+32 ;alb/sat 672
SET SDECAD=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0)
+33 ;alb/sat 672
SET LASTSUB=""
+34 ;alb/sat 672
+35 ;*zeb+1 722 1/17/19 allow override of name for resources in same clinic
if SDECOVR=""
SET SDECOVR=SDECRESN
+36 FOR
SET SDECAD=$ORDER(^SDEC(409.84,"ARSRC",SDECRESD,SDECS,SDECAD))
if '+SDECAD
QUIT
if '$DATA(SDRSLTS(SDECAD))
DO STCOMM(SDECAD,SDECOVR,SDECRESD)
SET SDRSLTS(SDECAD)=1
if SDCNT'<MAXREC
QUIT
End DoDot:2
if SDCNT'<MAXREC
QUIT
End DoDot:1
+37 QUIT
+38 ;
STCOMM(SDECAD,SDECRESN,SDRES) ;
+1 ;SDECAD is the sdec appointment IEN
+2 NEW CHECKIN,SDECC,SDECCAN,SDECCO,SDECQ,SDECZ,SDECSUBC,SDECHRN,SDECPATD,SDECATID,SDECISWK
+3 NEW DIEDON,SDECVPRV,REQFILE,REQIEN,REQTYPE
+4 ;alb/sat 672
NEW SDDEMO,SDSENS,SDTMP
+5 ;alb/sat 672
SET SDTMP=""
+6 if '$DATA(^SDEC(409.84,SDECAD,0))
QUIT
+7 SET SDECNOD=^SDEC(409.84,SDECAD,0)
+8 ;CANCELLED flag 1=cancelled; 0=not cancelled
SET SDECCAN=($PIECE(SDECNOD,U,12)]"")
+9 SET SDECISWK=0
+10 if $PIECE(SDECNOD,U,13)="y"
SET SDECISWK=1
+11 ;Don't return walkins if appt is WALKIN and SDECWKIN is 1
IF +$GET(SDECWKIN)
if SDECISWK
QUIT
+12 ;APPOINTMENT CHECKOUT TIME
SET SDECCO=$TRANSLATE($$FMTE^XLFDT($PIECE(SDECNOD,U,14)),"@"," ")
+13 ;POINTER TO V PROVIDER TABLE ^AUPNVPRV
SET SDECVPRV=$PIECE(SDECNOD,U,16)
+14 SET SDECZ=SDECAD_"^"
+15 FOR SDECQ=1:1:4
Begin DoDot:1
+16 SET Y=$PIECE(SDECNOD,U,SDECQ)
+17 ;
+18 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+19 ;
+20 ;X ^DD("DD") S Y=$TR(Y,"@"," ")
+21 ;
SET Y=$$FMTONET^SDECDATE(Y,"Y")
+22 ;remove the @ and replace with a space between date/time pwc *694 1/13/2020
SET Y=$TRANSLATE(Y,"@"," ")
+23 SET SDECZ=SDECZ_Y_"^"
End DoDot:1
+24 SET SDECPATD=$PIECE(SDECNOD,U,5)
+25 DO PDEMO^SDECU3(.SDDEMO,SDECPATD)
+26 ;if no checkin, check appointment checkin
IF $PIECE(SDECZ,U,4)=""
SET CHECKIN=$$CHECKIN(SDRES,$PIECE(SDECNOD,U,1),SDECPATD,SDECAD)
if CHECKIN'=""
SET $PIECE(SDECZ,U,4)=$PIECE(CHECKIN,U,1)
SET $PIECE(SDECZ,U,5)=$PIECE(CHECKIN,U,2)
+27 ;PATIENT ID
SET $PIECE(SDECZ,"^",6)=SDECPATD
+28 SET SDECPAT=""
+29 IF SDECPATD]""
IF $DATA(^DPT(SDECPATD,0))
SET SDECPAT=$PIECE(^DPT(SDECPATD,0),U)
+30 ;PATIENT NAME
SET $PIECE(SDECZ,"^",7)=SDECPAT
+31 ;RESOURCENAME
SET $PIECE(SDECZ,"^",8)=SDECRESN
+32 ;NOSHOW
SET $PIECE(SDECZ,"^",9)=+$PIECE(SDECNOD,U,10)
+33 SET SDECHRN=""
+34 ;HRN
IF $DATA(DUZ(2))
IF DUZ(2)>0
SET SDECHRN=$PIECE($GET(^AUPNPAT(SDECPATD,41,DUZ(2),0)),U,2)
+35 SET $PIECE(SDECZ,"^",10)=SDECHRN
+36 SET SDECATID=$PIECE(SDECNOD,U,6)
+37 ;UNKNOWN TYPE
if '+SDECATID
SET SDECATID=0
+38 SET $PIECE(SDECZ,"^",11)=SDECATID
+39 SET $PIECE(SDECZ,"^",12)=SDECISWK
+40 ;CHECKOUT TIME
SET $PIECE(SDECZ,"^",13)=SDECCO
+41 ;POINTER TO NEW PERSON
SET $PIECE(SDECZ,"^",14)=SDECVPRV
+42 ;CANCELLED
SET $PIECE(SDECZ,"^",15)=SDECCAN
+43 ;NOTE [16]
+44 SET SDECNOT=""
SET SDECQ=0
FOR
SET SDECQ=$ORDER(^SDEC(409.84,SDECAD,1,SDECQ))
if '+SDECQ
QUIT
Begin DoDot:1
+45 SET SDECNOT=$GET(^SDEC(409.84,SDECAD,1,SDECQ,0))
+46 if $EXTRACT(SDECNOT,$LENGTH(SDECNOT)-1,$LENGTH(SDECNOT))'=" "
SET SDECNOT=SDECNOT_" "
+47 ;alb/sat 672
SET SDTMP=SDTMP_$SELECT(SDTMP'="":" ",1:"")_$TRANSLATE(SDECNOT,"^"," ")
+48 ;S SDECI=SDECI+1 ;alb/sat 672 - removed
+49 ;S ^TMP("SDEC02",$J,SDECI)=$TR(SDECNOT,"^"," ") ;alb/sat 658 ;alb/sat 672 - removed
End DoDot:1
+50 ;S ^TMP("SDEC02",$J,SDECI)=^TMP("SDEC02",$J,SDECI)_"^" ;alb/sat 672 - replaced
+51 ;alb/sat 672
SET $PIECE(SDECZ,"^",16)=SDTMP
+52 ;additional data
+53 ;S SDECZ="" ;alb/sat 672 - removed
+54 ;alb/sat 672
SET $PIECE(SDECZ,"^",17)=$SELECT($PIECE(SDECNOD,U,20)'="":$$FMTE^XLFDT($PIECE(SDECNOD,U,20)),1:"")
+55 ;appt request type
+56 SET SDAPTYP=$PIECE($GET(^SDEC(409.84,SDECAD,2)),U,1)
+57 if SDAPTYP'=""
SET SDAPTYP=$SELECT($PIECE(SDAPTYP,";",2)["SDWL":"E",$PIECE(SDAPTYP,";",2)["GMR":"C",$PIECE(SDAPTYP,";",2)="SD(403.5,":"R",$PIECE(SDAPTYP,";",2)="SDEC(409.85,":"A",1:"")_"|"_$PIECE(SDAPTYP,";",1)
+58 ;[18] ;alb/sat 672
SET $PIECE(SDECZ,"^",18)=SDAPTYP
+59 SET DIEDON=""
DO DIEDON^ORWPT(.DIEDON,SDECPATD)
+60 ;[19] ;alb/sat 672
SET $PIECE(SDECZ,"^",19)=DIEDON
+61 ;[20] ;alb/sat 672
SET $PIECE(SDECZ,"^",20)=$$GET1^DIQ(409.84,SDECAD_",",.23,"E")
+62 ;[21] [22] alb/sat 642 ;alb/sat 672
IF $PIECE(SDAPTYP,"|",1)="A"
SET $PIECE(SDECZ,"^",21)=$$MULT(SDAPTYP)
+63 ;[21] [22] alb/sat 642 ;alb/sat 672
IF $PIECE(SDAPTYP,"|",1)="A"
SET $PIECE(SDECZ,"^",22)=$$GET1^DIQ(409.85,$PIECE(SDAPTYP,"|",2)_",",43.8,"I")
+64 ;[24] ;alb/sat 672 - added
SET $PIECE(SDECZ,"^",24)=$GET(SDDEMO("SSN"))
+65 ;[25] ;alb/sat 672 - added
SET $PIECE(SDECZ,"^",25)=$GET(SDDEMO("DOB"))
+66 ;[26] ;alb/sat 672 - added
SET SDSENS=$$PTSEC^SDECUTL(SDECPATD)
SET $PIECE(SDECZ,"^",26)=SDSENS
+67 SET REQTYPE=$$GET1^DIQ(409.84,SDECAD_",",.22,"I")
+68 SET REQIEN=$PIECE(REQTYPE,";",1)
SET REQFILE=$PIECE(REQTYPE,";",2)
+69 IF REQFILE["123"
SET REQTYPE=$$GET1^DIQ(123,REQIEN_",",4,"E")
+70 IF REQFILE["409.85"
SET REQTYPE=$$GET1^DIQ(409.85,REQIEN_",",4,"E")
+71 IF REQFILE["403.5"!(REQFILE["409.3")
SET REQTYPE=""
+72 ; APPOINTMENT TYPE (#.06)
SET $PIECE(SDECZ,"^",27)=REQTYPE
+73 ;[23] ;alb/sat 672 - last subscript on last rec
SET SDCNT=SDCNT+1
IF SDCNT'<MAXREC
SET $PIECE(SDECZ,"^",23)=SDECJ_"|"_SDECS_"|"_SDECAD
+74 ;alb/sat 672
SET SDECI=SDECI+1
SET ^TMP("SDEC02",$JOB,SDECI)=SDECZ_$CHAR(30)
+75 QUIT
CHECKIN(SDRES,SDT,DFN,APPT) ;alb/sat 642 - if no checkin, check appointment checkin
+1 ; SDRES - resource id
+2 ; SDT - appointment date/time in external format
+3 ; DFN - patient ID
+4 NEW CHECKIN,ENTERED,SDCL,SDFDA,SDI,SDNOD,Y
+5 SET (CHECKIN,ENTERED)=""
+6 SET SDCL=$$GET1^DIQ(409.831,SDRES_",",.04,"I")
+7 SET SDI=0
FOR
SET SDI=$ORDER(^SC(SDCL,"S",SDT,1,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+8 SET SDNOD=$GET(^SC(SDCL,"S",SDT,1,SDI,0))
+9 if $PIECE(SDNOD,U,1)'=DFN
QUIT
+10 IF $DATA(^SC(SDCL,"S",SDT,1,SDI,"C"))
Begin DoDot:2
+11 SET CHECKIN=$PIECE($GET(^SC(SDCL,"S",SDT,1,SDI,"C")),U,1)
+12 SET ENTERED=$PIECE($GET(^SC(SDCL,"S",SDT,1,SDI,"C")),U,5)
+13 if CHECKIN'=""
SET SDFDA(409.84,APPT_",",.03)=CHECKIN
+14 if ENTERED'=""
SET SDFDA(409.84,APPT_",",.04)=ENTERED
+15 if $DATA(SDFDA)
DO UPDATE^DIE("","SDFDA")
+16 SET Y=CHECKIN
+17 ;
+18 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+19 ;
+20 ;X ^DD("DD") S CHECKIN=$TR(Y,"@"," ")
+21 ;
SET CHECKIN=$$FMTONET^SDECDATE(CHECKIN,"Y")
+22 ;S Y=ENTERED
+23 ;X ^DD("DD") S ENTERED=$TR(Y,"@"," ")
+24 ;
SET ENTERED=$$FMTONET^SDECDATE(ENTERED,"Y")
End DoDot:2
End DoDot:1
if CHECKIN'=""
QUIT
+25 QUIT CHECKIN_U_ENTERED
MULT(SDAPTYP) ;get data from MULT APPTS MADE field of SDEC APPT REQUEST file ;alb/sat 642
+1 NEW ARIEN,SDI,MULT1,MULTL
+2 SET MULTL=""
+3 SET ARIEN=$PIECE(SDAPTYP,"|",2)
+4 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.85,ARIEN,2,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+5 SET MULT1=$PIECE($GET(^SDEC(409.85,ARIEN,2,SDI,0)),"^",1)
+6 SET MULTL=$SELECT(MULTL'="":MULTL_"|",1:"")_MULT1
End DoDot:1
+7 QUIT MULTL
+8 ;
ERR(SDECI,SDECERR) ;Error processing
+1 SET SDECI=SDECI+1
+2 SET ^TMP("SDEC02",$JOB,SDECI)="0^^^^^^^^^^^"_SDECERR_$CHAR(30)
+3 SET SDECI=SDECI+1
+4 SET ^TMP("SDEC02",$JOB,SDECI)=$CHAR(31)
+5 QUIT
+6 ;
ETRAP ;EP Error trap entry
+1 DO ^%ZTER
+2 IF '$DATA(SDECI)
NEW SDECI
SET SDECI=999999
+3 SET SDECI=SDECI+1
+4 DO ERR(SDECI,"SDEC31 Error")
+5 QUIT
