SDECWL ;ALB/SAT,WTC,LAB - VISTA SCHEDULING RPCS ;Apr 10, 2020@15:22
;;5.3;Scheduling;**627,642,665,672,694,745,774**;Aug 13, 1993;Build 9
;
Q
;
; entry points for Clinical Scheduling/Wait List related Remote Procedures
APPTGET(RET,WLIEN) ; EP for SDEC WLGET remote procedure
S RET="I00020ERRORID^T00256ERRORTEXT"_$C(30)
S RET="-1^Not yet implemented"_$C(30,31)
Q
;------------------------------------------------
DEL(RET,INP) ;not used
S RET="I00020ERRORID^T00256ERRORTEXT"_$C(30)
S RET="-1^Not yet implemented"_$C(30,31)
Q
;
WLCLOSE(RET,INP) ;Waitlist Close
;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP array
;WLCLOSE(RET,SD1,SD2,SD3,SD4) external parameter tag is in SDEC
; INP - Input parameters array
; INP(1) - Waitlist ID - Pointer to SD WAIT LIST file
; INP(2) - Disposition
; INP(3) - User Id - Pointer to NEW PERSON file
; INP(4) - Date Dispositioned in external form
N MI,WLDISP,WLDISPBY,WLDISPDT,WLFDA,WLIEN,WLMSG,WLRET
S RET="I00020ERRORID^T00256ERRORTEXT"_$C(30)
;validate IEN
S WLIEN=$G(INP(1)) I WLIEN="" S RET=RET_"-1^Missing IEN"_$C(30,31) Q
;validate DISPOSITION
;*745 added Disposition of EA
S WLDISP=$G(INP(2))
I (WLDISP'="EA"),(WLDISP'="D"),(WLDISP'="NC"),(WLDISP'="SA"),(WLDISP'="CC"),(WLDISP'="NN"),(WLDISP'="ER"),(WLDISP'="TR"),(WLDISP'="CL") D
.S:WLDISP="DEATH" WLDISP="D"
.S:WLDISP="REMOVED/NON-VA CARE" WLDISP="NC"
.S:WLDISP="REMOVED/SCHEDULED-ASSIGNED" WLDISP="SA"
.S:WLDISP="REMOVED/VA CONTRACT CARE" WLDISP="CC"
.S:WLDISP="REMOVED/NO LONGER NECESSARY" WLDISP="NN"
.S:WLDISP="ENTERED IN ERROR" WLDISP="ER"
.S:WLDISP="TRANSFERRED" WLDISP="TR"
.S:WLDISP="CHANGED CLINIC" WLDISP="CL"
.S:WLDISP="REMOVED/EXTERNAL APP" WLDISP="EA" ;* 745
I WLDISP="" S RET=RET_"-1^Missing value for DISPOSITION"_$C(30,31) Q
I (WLDISP'="EA"),(WLDISP'="D"),(WLDISP'="NC"),(WLDISP'="SA"),(WLDISP'="CC"),(WLDISP'="NN"),(WLDISP'="ER"),(WLDISP'="TR"),(WLDISP'="CL") D
.S RET=RET_"-1^Invalid value for DISPOSITION"_$C(30,31) Q
;validate DISPOSITIONED BY
S WLDISPBY=$G(INP(3),DUZ)
I '+WLDISPBY S WLDISPBY=$O(^VA(200,"B",WLDISPBY,0))
I '+WLDISPBY S RET=RET_"-1^Invalid 'DISPOSITIONED BY' user"_$C(30,31) Q
;validate DATE DISPOSITIONED
S WLDISPDT=$G(INP(4),DT) ;I WLDISPDT'="" S %DT="" S X=WLDISPDT D ^%DT S WLDISPDT=Y
;
; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
;
S WLDISPDT=$$NETTOFM^SDECDATE(WLDISPDT,"N","N") I WLDISPDT=-1 S RET=RET_"-1^Invalid 'DATE DISPOSITIONED'"_$C(30,31) Q
;I Y=-1 S RET=RET_"-1^Invalid 'DATE DISPOSITIONED'"_$C(30,31) Q
S WLFDA=$NA(WLFDA($$FNUM,WLIEN_","))
S @WLFDA@(19)=WLDISPDT
S @WLFDA@(20)=WLDISPBY
S @WLFDA@(21)=WLDISP
S @WLFDA@(23)="C"
D UPDATE^DIE("","WLFDA","WLRET","WLMSG")
I $D(WLMSG("DIERR")) D
. F MI=1:1:$G(WLMSG("DIERR")) S RET=RET_"-1^"_$G(WLMSG("DIERR",MI,"TEXT",1))_$C(30)
S RET=RET_$C(31)
Q
;
WLOPEN(RET,WLAPP,WLIEN,WLDDT) ;SET Waitlist Open/re-open
;WLOPEN(RET,WLAPP,WLIEN,WLDDT) external parameter tag in SDEC
;INPUT:
; WLAPP - (required if no WLIEN) Appointment ID pointer to
; SDEC APPOINTMENT file 409.84
; WLIEN - (required if no WLAPP) Waitlist ID - Pointer to
; SD WAIT LIST file
; WLDDT - Desired Date of appointment in external format
S U="^"
N SDART,SDECI,SDQ,WLFDA,WLMSG,X,Y,%DT
I WLAPP="" S RET="-1^APPOINTMENT IEN REQUIRED" Q
I WLIEN="" S RET="-1^EWL ENTRY REQUIRED" Q
I WLDDT="" S RET="-1^PID REQUIRED" Q
S RET=""
;SD*5.3*774 Start new logic
Q:WLIEN=""
I $G(WLIEN)'="" D
.S DFN=$$GET1^DIQ(409.3,WLIEN_",",.01,"I")
.Q:DFN=""
.S INP(1)=""
.S INP(2)=DFN
.S INP(3)=$$GET1^DIQ(409.3,WLIEN_",",1,"E")
.S INP(4)=$$GET1^DIQ(409.3,WLIEN_",",2,"E")
.S INP(5)="APPT"
.S INP(6)=$$GET1^DIQ(409.3,WLIEN_",",13.2,"E")
.S INP(7)=$$GET1^DIQ(409.3,WLIEN_",",9,"E")
.S INP(8)=$$GET1^DIQ(409.3,WLIEN_",",10,"E")
.S INP(9)=$$GET1^DIQ(409.3,WLIEN_",",11,"E")
.S INP(10)=$$GET1^DIQ(409.3,WLIEN_",",12,"E")
.S INP(11)=WLDDT
.S INP(12)=$$GET1^DIQ(409.3,WLIEN_",",25)
.S INP(13)=$$GET1^DIQ(409.3,WLIEN_",",10.5,"E")
.S INP(14)=""
.S INP(15)=""
.S INP(16)=""
.S INP(17)=""
.S INP(18)=$$GET1^DIQ(409.3,WLIEN_",",15,"E")
.S INP(19)=$$GET1^DIQ(409.3,WLIEN_",",14)
.S RET1=""
.D ARSET^SDECAR2(.RET1,.INP)
.I RET'["-1" D
..S ARIEN=$P(RET1,$C(30),2)
..S ^SDEC(409.84,WLAPP,2)=+ARIEN_";SDEC(409.85,"
.Q
I $G(RET1)'="" S RET=RET1
Q
WLX S @RET@(SDECI)=@RET@(SDECI)_$C(31)
Q
;
FNUM(RET) ;file number
S RET=409.3
Q RET
;
CLINALL(RET,MAXREC,SDECP) ;Return the IEN and NAME for all entries in the SD WL CLINIC LOCATION file
;CLINALL(RET) external parameter tag is in SDEC
N CLINARR,CLINIEN,CLINNAME,COUNT,GLOREF,INACTIVE,LOCIEN,X
N CLINABR,SDCNT,SDECIEN,SDECNAM,SDF,SDMAX,SDTMP ;alb/sat 665
N SDARR1,SDREF,SDXT ;alb/sat 672
S SDF=""
S (SDCNT,SDMAX)=0 ;alb/sat 665
S RET="^TMP(""SDEC"","_$J_")"
K @RET
S @RET@(0)="T00020CLINIC_IEN^T00030CLINIC_NAME^T00020HOSPITAL_LOCATION_ID^T00030ABBR^T00030MORE"_$C(30)
S MAXREC=$G(MAXREC,50)
S SDECP=$G(SDECP)
;Search for entries using partial name
I SDECP'="" D
.;alb/sat 672 - begin modification; separate string and numeric lookup
.S (SDECNAM,SDXT)=$$GETSUB^SDECU(SDECP)
.;abbreviation as string
.S SDF="ABBRSTR" D
..S SDREF="C" D PART Q
.;abbreviation as numeric
.S SDF="ABBRNUM",SDECNAM=SDXT_" " D
..S SDREF="C" D PART Q
.;name as string
.S SDF="FULLSTR",SDECNAM=SDXT D
..S SDREF="B" D PART Q
.;name as numeric
.S SDF="FULLNUM",SDECNAM=SDXT_" " D
..S SDREF="B" D PART Q
.;alb/sat 672 - end modification; separate string and numeric lookup
;Search for all SD WL CLINIC LOCATION entries
I SDECP="" S CLINIEN=0 F S CLINIEN=$O(^SDWL(409.32,CLINIEN)) Q:'CLINIEN D PROCESS I SDCNT'<MAXREC S SDMAX=+$O(^SDWL(409.32,CLINIEN)) Q
;
S COUNT=0
S SDF=-1 F S SDF=$O(CLINARR(SDF)) Q:SDF="" D
.S CLINNAME="" F S CLINNAME=$O(CLINARR(SDF,CLINNAME)) Q:CLINNAME="" D
..S SDTMP=$P(CLINARR(SDF,CLINNAME),U)_U_CLINNAME_U_$P(CLINARR(SDF,CLINNAME),U,2)_U_$P(CLINARR(SDF,CLINNAME),U,3)_U_$S(+SDMAX:1,1:0)
..S COUNT=COUNT+1,@RET@(COUNT)=SDTMP_$C(30)
S @RET@(COUNT)=@RET@(COUNT)_$C(31)
Q
PART ;partial name lookup ;alb/sat 672
Q:SDREF=""
F S SDECNAM=$O(^SC(SDREF,SDECNAM)) Q:SDECNAM'[SDECP D I SDCNT'<MAXREC S SDECNAM=$O(^SC(SDREF,SDECNAM)) S SDMAX=$S(+SDMAX:1,SDECNAM[SDECP:1,1:0) Q ;alb/sat 658 - abbreviation lookup if characters length 7 or less
.S SDECIEN=0 F S SDECIEN=$O(^SC(SDREF,SDECNAM,SDECIEN)) Q:SDECIEN="" D I SDCNT'<MAXREC S SDMAX=$S(+SDMAX:+SDMAX,1:+$O(^SC(SDREF,SDECNAM,SDECIEN))) Q ;alb/sat 665 loop thru all entries
..S CLINIEN=0 F S CLINIEN=$O(^SDWL(409.32,"B",SDECIEN,CLINIEN)) Q:CLINIEN="" D PROCESS I SDCNT'<MAXREC S SDMAX=+$O(^SDWL(409.32,"B",SDECIEN,CLINIEN)) Q ;alb/sat 665 loop thru all entries
Q
PROCESS ;get 1 record ;alb/sat 665
N CLINABR,INACTIVE,LOCIEN
S INACTIVE=$$GET1^DIQ(409.32,CLINIEN_",",3,"I")
I (INACTIVE'="")&($P(INACTIVE,".",1)'>$P($$NOW^XLFDT,".",1)) Q
S LOCIEN=$P(^SDWL(409.32,CLINIEN,0),U)
S CLINNAME=$P($G(^SC(LOCIEN,0)),U)
S CLINABR=$P($G(^SC(LOCIEN,0)),U,2)
S:SDF["ABBR" CLINNAME=CLINABR_" "_CLINNAME
Q:$$GET1^DIQ(44,LOCIEN_",",50.01,"I")=1 ;OOS?
Q:$D(SDARR1(CLINIEN)) ;alb/sat 672 - checking for duplicates
S SDARR1(CLINIEN)="" ;alb/sat 672 - checking for duplicates
I CLINNAME'="" S CLINARR(SDF["FULL",CLINNAME)=CLINIEN_U_LOCIEN_U_CLINABR,SDCNT=SDCNT+1
Q
;
SVSPALL(RET) ;return IEN and NAME for all entries in the SD WL SERVICE/SPECIALTY file
;SVSPALL(RET) external parameter tag is in SDEC
N COUNT,GLOREF,CLSTPIEN,SVSPARR,SVSPIEN,SVSPNAME,X
S RET="^TMP(""SDEC"","_$J_")"
K @RET
S @RET@(0)="T00020SERVICESPECIALTY_IEN^T00030SERVICESPECIALTY_NAME"_$C(30)
S GLOREF=$NA(^SDWL(409.31))
; Search for all SD WL SERVICE/SPECIALTY entries
; Lookup the CLINIC STOP name
; Save the names in a local array so the return array will be sorted by Name
S SVSPIEN=0
F S SVSPIEN=$O(@GLOREF@(SVSPIEN)) Q:'SVSPIEN D
. S CLSTPIEN=$P(@GLOREF@(SVSPIEN,0),U)
. S SVSPNAME=$P($G(^DIC(40.7,CLSTPIEN,0)),U)
. I SVSPNAME'="" S SVSPARR(SVSPNAME)=SVSPIEN
S SVSPNAME="",COUNT=0
F S SVSPNAME=$O(SVSPARR(SVSPNAME)) Q:SVSPNAME="" D
. S COUNT=COUNT+1,@RET@(COUNT)=SVSPARR(SVSPNAME)_U_SVSPNAME_$C(30)
;S COUNT=COUNT+1,@RET@(COUNT)=$C(31)
S @RET@(COUNT)=@RET@(COUNT)_$C(31)
Q
;
APPTYPES(RET,DFN) ; EP for SDEC APPTYPES
;APPTYPES(RET,DFN) external parameter tag is in SDEC
; Return the different appointment types
N APTYDATA,APTYIEN,APTYINAC,APTYNAME,COUNT,GLOREF
N ISVET,PTYPE,SDEC,SDI
S PTYPE=""
S ISVET=1 ;0=not a vet; 1=is a vet
S RET=$NA(^TMP("SDEC",$J)),COUNT=0
K @RET
S @RET@(0)="T00020APPTTYPE_IEN^T00030APPTTYPE_NAME"_$C(30)
S DFN=$G(DFN) I DFN'="" S:'$D(^DPT(+DFN,0)) DFN=""
S GLOREF=$NA(^SD(409.1))
I '+DFN D
.S APTYNAME="" F S APTYNAME=$O(@GLOREF@("B",APTYNAME)) Q:APTYNAME="" D
..S APTYIEN=0 F S APTYIEN=$O(@GLOREF@("B",APTYNAME,APTYIEN)) Q:'APTYIEN D
...S APTYDATA=$G(@GLOREF@(APTYIEN,0))
...Q:$P(APTYDATA,U,3)
...S COUNT=COUNT+1,@RET@(COUNT)=APTYIEN_U_APTYNAME_$C(30)
;
I +DFN D
.N VAEL D ELIG^VADPT
.S SDEC=$S($D(^DIC(8,+VAEL(1),0)):$P(^(0),U,5),1:"")
.S APTYNAME="" F S APTYNAME=$O(@GLOREF@("B",APTYNAME)) Q:APTYNAME="" D
..S APTYIEN=0 F S APTYIEN=$O(@GLOREF@("B",APTYNAME,APTYIEN)) Q:'APTYIEN D
...S APTYDATA=$G(@GLOREF@(APTYIEN,0))
...Q:$P(APTYDATA,U,3)
...I $S(SDEC["Y":1,1:$P(APTYDATA,U,5)),$S('$P(APTYDATA,U,6):1,$D(VAEL(1,+$P(APTYDATA,U,6))):1,+VAEL(1)=$P(APTYDATA,U,6):1,1:0) D
....S COUNT=COUNT+1,@RET@(COUNT)=APTYIEN_U_APTYNAME_$C(30)
;
S @RET@(COUNT)=@RET@(COUNT)_$C(31)
Q
;
WLPCSET(SDECY,INP,WLIEN,SOURCE) ;SET update patient contacts in SD WAIT LIST file
;WLSETPC(SDECY,INP,WLIEN) external parameter tag in SDEC
; INP = Patient Contacts separated by ::
; Each :: piece has the following ~~ pieces: (same as they are passed into SDEC WLSET)
; 1) = (required) DATE ENTERED external date/time
; 2) = (optional) PC ENTERED BY USER ID or NAME - Pointer to NEW PERSON file or NAME
; 4) = (optional) ACTION - valid values are:
; CALLED
; MESSAGE LEFT
; LETTER
; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
; 6) = NOT USED (optional) Comment 1-160 characters
; WLIEN = (required) Wait List Id pointer to SDEC WAIT LIST file 409.3
;
N SDECI,SDTMP,WLMSG1
S SDECY="^TMP(""SDECWL"","_$J_",""WLSETPC"")"
K @SDECY
S SDECI=0
S @SDECY@(SDECI)="T00030RETURNCODE^T00030TEXT"_$C(30)
S WLIEN=$G(WLIEN)
I (WLIEN="")!('$D(^SDWL(409.3,WLIEN,0))) D ERR1^SDECERR(-1,"Invalid wait list ID "_WLIEN_".",SDECI,SDECY) Q
D WL23^SDECWL2(INP,WLIEN)
I $D(WLMSG1) D ERR1^SDECERR(-1,"Error storing patient contacts.",SDECI,SDECY) Q
S SDECI=SDECI+1 S @SDECY@(SDECI)="0^SUCCESS"_$C(30,31)
Q
;
AUDITGET(SDECY,WLIEN) ;GET entries from VS AUDIT field of SD WAIT LIST file 409.3
N WLDATA,SDECI,SDI,SDTMP,SDX
S SDECY="^TMP(""SDECWL"","_$J_",""AUDITGET"")"
K @SDECY
S SDECI=0
S SDTMP="T00030IEN^T00030ID^T00030DATE^T00030USERIEN^T00030USERNAME"
S SDTMP=SDTMP_"^T00030WLCINIEN^T00030WLCINNAME^T00030CLINIEN^T00030CLINNAME"
S SDTMP=SDTMP_"^T00030STOPIEN^T00030STOPNAME"
S @SDECY@(SDECI)=SDTMP_$C(30)
;validate WLIEN
S WLIEN=$G(WLIEN)
I '+$D(^SDWL(409.3,+WLIEN,0)) S @SDECY@(1)="-1^Invalid SD WAIT LIST id."_$C(30,31) Q
S SDI=0 F S SDI=$O(^SDWL(409.3,+WLIEN,6,SDI)) Q:SDI'>0 D
.K WLDATA
.D GETS^DIQ(409.345,SDI_","_WLIEN_",","**","IE","WLDATA")
.S SDX="WLDATA(409.345,"""_SDI_","_WLIEN_","")"
.S SDTMP=WLIEN_U_SDI_U_@SDX@(.01,"E")_U_@SDX@(1,"I")_U_@SDX@(1,"E")
.S SDTMP=SDTMP_U_@SDX@(2,"I")_U_@SDX@(2,"E")_U_@SDX@(3,"I")_U_@SDX@(3,"E")
.S SDTMP=SDTMP_U_@SDX@(4,"I")_U_@SDX@(4,"E")
.S SDECI=SDECI+1 S @SDECY@(SDECI)=SDTMP_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECWL 12165 printed Dec 13, 2024@02:52:59 Page 2
SDECWL ;ALB/SAT,WTC,LAB - VISTA SCHEDULING RPCS ;Apr 10, 2020@15:22
+1 ;;5.3;Scheduling;**627,642,665,672,694,745,774**;Aug 13, 1993;Build 9
+2 ;
+3 QUIT
+4 ;
+5 ; entry points for Clinical Scheduling/Wait List related Remote Procedures
APPTGET(RET,WLIEN) ; EP for SDEC WLGET remote procedure
+1 SET RET="I00020ERRORID^T00256ERRORTEXT"_$CHAR(30)
+2 SET RET="-1^Not yet implemented"_$CHAR(30,31)
+3 QUIT
+4 ;------------------------------------------------
DEL(RET,INP) ;not used
+1 SET RET="I00020ERRORID^T00256ERRORTEXT"_$CHAR(30)
+2 SET RET="-1^Not yet implemented"_$CHAR(30,31)
+3 QUIT
+4 ;
WLCLOSE(RET,INP) ;Waitlist Close
+1 ;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP array
+2 ;WLCLOSE(RET,SD1,SD2,SD3,SD4) external parameter tag is in SDEC
+3 ; INP - Input parameters array
+4 ; INP(1) - Waitlist ID - Pointer to SD WAIT LIST file
+5 ; INP(2) - Disposition
+6 ; INP(3) - User Id - Pointer to NEW PERSON file
+7 ; INP(4) - Date Dispositioned in external form
+8 NEW MI,WLDISP,WLDISPBY,WLDISPDT,WLFDA,WLIEN,WLMSG,WLRET
+9 SET RET="I00020ERRORID^T00256ERRORTEXT"_$CHAR(30)
+10 ;validate IEN
+11 SET WLIEN=$GET(INP(1))
IF WLIEN=""
SET RET=RET_"-1^Missing IEN"_$CHAR(30,31)
QUIT
+12 ;validate DISPOSITION
+13 ;*745 added Disposition of EA
+14 SET WLDISP=$GET(INP(2))
+15 IF (WLDISP'="EA")
IF (WLDISP'="D")
IF (WLDISP'="NC")
IF (WLDISP'="SA")
IF (WLDISP'="CC")
IF (WLDISP'="NN")
IF (WLDISP'="ER")
IF (WLDISP'="TR")
IF (WLDISP'="CL")
Begin DoDot:1
+16 if WLDISP="DEATH"
SET WLDISP="D"
+17 if WLDISP="REMOVED/NON-VA CARE"
SET WLDISP="NC"
+18 if WLDISP="REMOVED/SCHEDULED-ASSIGNED"
SET WLDISP="SA"
+19 if WLDISP="REMOVED/VA CONTRACT CARE"
SET WLDISP="CC"
+20 if WLDISP="REMOVED/NO LONGER NECESSARY"
SET WLDISP="NN"
+21 if WLDISP="ENTERED IN ERROR"
SET WLDISP="ER"
+22 if WLDISP="TRANSFERRED"
SET WLDISP="TR"
+23 if WLDISP="CHANGED CLINIC"
SET WLDISP="CL"
+24 ;* 745
if WLDISP="REMOVED/EXTERNAL APP"
SET WLDISP="EA"
End DoDot:1
+25 IF WLDISP=""
SET RET=RET_"-1^Missing value for DISPOSITION"_$CHAR(30,31)
QUIT
+26 IF (WLDISP'="EA")
IF (WLDISP'="D")
IF (WLDISP'="NC")
IF (WLDISP'="SA")
IF (WLDISP'="CC")
IF (WLDISP'="NN")
IF (WLDISP'="ER")
IF (WLDISP'="TR")
IF (WLDISP'="CL")
Begin DoDot:1
+27 SET RET=RET_"-1^Invalid value for DISPOSITION"_$CHAR(30,31)
QUIT
End DoDot:1
+28 ;validate DISPOSITIONED BY
+29 SET WLDISPBY=$GET(INP(3),DUZ)
+30 IF '+WLDISPBY
SET WLDISPBY=$ORDER(^VA(200,"B",WLDISPBY,0))
+31 IF '+WLDISPBY
SET RET=RET_"-1^Invalid 'DISPOSITIONED BY' user"_$CHAR(30,31)
QUIT
+32 ;validate DATE DISPOSITIONED
+33 ;I WLDISPDT'="" S %DT="" S X=WLDISPDT D ^%DT S WLDISPDT=Y
SET WLDISPDT=$GET(INP(4),DT)
+34 ;
+35 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+36 ;
+37 SET WLDISPDT=$$NETTOFM^SDECDATE(WLDISPDT,"N","N")
IF WLDISPDT=-1
SET RET=RET_"-1^Invalid 'DATE DISPOSITIONED'"_$CHAR(30,31)
QUIT
+38 ;I Y=-1 S RET=RET_"-1^Invalid 'DATE DISPOSITIONED'"_$C(30,31) Q
+39 SET WLFDA=$NAME(WLFDA($$FNUM,WLIEN_","))
+40 SET @WLFDA@(19)=WLDISPDT
+41 SET @WLFDA@(20)=WLDISPBY
+42 SET @WLFDA@(21)=WLDISP
+43 SET @WLFDA@(23)="C"
+44 DO UPDATE^DIE("","WLFDA","WLRET","WLMSG")
+45 IF $DATA(WLMSG("DIERR"))
Begin DoDot:1
+46 FOR MI=1:1:$GET(WLMSG("DIERR"))
SET RET=RET_"-1^"_$GET(WLMSG("DIERR",MI,"TEXT",1))_$CHAR(30)
End DoDot:1
+47 SET RET=RET_$CHAR(31)
+48 QUIT
+49 ;
WLOPEN(RET,WLAPP,WLIEN,WLDDT) ;SET Waitlist Open/re-open
+1 ;WLOPEN(RET,WLAPP,WLIEN,WLDDT) external parameter tag in SDEC
+2 ;INPUT:
+3 ; WLAPP - (required if no WLIEN) Appointment ID pointer to
+4 ; SDEC APPOINTMENT file 409.84
+5 ; WLIEN - (required if no WLAPP) Waitlist ID - Pointer to
+6 ; SD WAIT LIST file
+7 ; WLDDT - Desired Date of appointment in external format
+8 SET U="^"
+9 NEW SDART,SDECI,SDQ,WLFDA,WLMSG,X,Y,%DT
+10 IF WLAPP=""
SET RET="-1^APPOINTMENT IEN REQUIRED"
QUIT
+11 IF WLIEN=""
SET RET="-1^EWL ENTRY REQUIRED"
QUIT
+12 IF WLDDT=""
SET RET="-1^PID REQUIRED"
QUIT
+13 SET RET=""
+14 ;SD*5.3*774 Start new logic
+15 if WLIEN=""
QUIT
+16 IF $GET(WLIEN)'=""
Begin DoDot:1
+17 SET DFN=$$GET1^DIQ(409.3,WLIEN_",",.01,"I")
+18 if DFN=""
QUIT
+19 SET INP(1)=""
+20 SET INP(2)=DFN
+21 SET INP(3)=$$GET1^DIQ(409.3,WLIEN_",",1,"E")
+22 SET INP(4)=$$GET1^DIQ(409.3,WLIEN_",",2,"E")
+23 SET INP(5)="APPT"
+24 SET INP(6)=$$GET1^DIQ(409.3,WLIEN_",",13.2,"E")
+25 SET INP(7)=$$GET1^DIQ(409.3,WLIEN_",",9,"E")
+26 SET INP(8)=$$GET1^DIQ(409.3,WLIEN_",",10,"E")
+27 SET INP(9)=$$GET1^DIQ(409.3,WLIEN_",",11,"E")
+28 SET INP(10)=$$GET1^DIQ(409.3,WLIEN_",",12,"E")
+29 SET INP(11)=WLDDT
+30 SET INP(12)=$$GET1^DIQ(409.3,WLIEN_",",25)
+31 SET INP(13)=$$GET1^DIQ(409.3,WLIEN_",",10.5,"E")
+32 SET INP(14)=""
+33 SET INP(15)=""
+34 SET INP(16)=""
+35 SET INP(17)=""
+36 SET INP(18)=$$GET1^DIQ(409.3,WLIEN_",",15,"E")
+37 SET INP(19)=$$GET1^DIQ(409.3,WLIEN_",",14)
+38 SET RET1=""
+39 DO ARSET^SDECAR2(.RET1,.INP)
+40 IF RET'["-1"
Begin DoDot:2
+41 SET ARIEN=$PIECE(RET1,$CHAR(30),2)
+42 SET ^SDEC(409.84,WLAPP,2)=+ARIEN_";SDEC(409.85,"
End DoDot:2
+43 QUIT
End DoDot:1
+44 IF $GET(RET1)'=""
SET RET=RET1
+45 QUIT
WLX SET @RET@(SDECI)=@RET@(SDECI)_$CHAR(31)
+1 QUIT
+2 ;
FNUM(RET) ;file number
+1 SET RET=409.3
+2 QUIT RET
+3 ;
CLINALL(RET,MAXREC,SDECP) ;Return the IEN and NAME for all entries in the SD WL CLINIC LOCATION file
+1 ;CLINALL(RET) external parameter tag is in SDEC
+2 NEW CLINARR,CLINIEN,CLINNAME,COUNT,GLOREF,INACTIVE,LOCIEN,X
+3 ;alb/sat 665
NEW CLINABR,SDCNT,SDECIEN,SDECNAM,SDF,SDMAX,SDTMP
+4 ;alb/sat 672
NEW SDARR1,SDREF,SDXT
+5 SET SDF=""
+6 ;alb/sat 665
SET (SDCNT,SDMAX)=0
+7 SET RET="^TMP(""SDEC"","_$JOB_")"
+8 KILL @RET
+9 SET @RET@(0)="T00020CLINIC_IEN^T00030CLINIC_NAME^T00020HOSPITAL_LOCATION_ID^T00030ABBR^T00030MORE"_$CHAR(30)
+10 SET MAXREC=$GET(MAXREC,50)
+11 SET SDECP=$GET(SDECP)
+12 ;Search for entries using partial name
+13 IF SDECP'=""
Begin DoDot:1
+14 ;alb/sat 672 - begin modification; separate string and numeric lookup
+15 SET (SDECNAM,SDXT)=$$GETSUB^SDECU(SDECP)
+16 ;abbreviation as string
+17 SET SDF="ABBRSTR"
Begin DoDot:2
+18 SET SDREF="C"
DO PART
QUIT
End DoDot:2
+19 ;abbreviation as numeric
+20 SET SDF="ABBRNUM"
SET SDECNAM=SDXT_" "
Begin DoDot:2
+21 SET SDREF="C"
DO PART
QUIT
End DoDot:2
+22 ;name as string
+23 SET SDF="FULLSTR"
SET SDECNAM=SDXT
Begin DoDot:2
+24 SET SDREF="B"
DO PART
QUIT
End DoDot:2
+25 ;name as numeric
+26 SET SDF="FULLNUM"
SET SDECNAM=SDXT_" "
Begin DoDot:2
+27 SET SDREF="B"
DO PART
QUIT
End DoDot:2
+28 ;alb/sat 672 - end modification; separate string and numeric lookup
End DoDot:1
+29 ;Search for all SD WL CLINIC LOCATION entries
+30 IF SDECP=""
SET CLINIEN=0
FOR
SET CLINIEN=$ORDER(^SDWL(409.32,CLINIEN))
if 'CLINIEN
QUIT
DO PROCESS
IF SDCNT'<MAXREC
SET SDMAX=+$ORDER(^SDWL(409.32,CLINIEN))
QUIT
+31 ;
+32 SET COUNT=0
+33 SET SDF=-1
FOR
SET SDF=$ORDER(CLINARR(SDF))
if SDF=""
QUIT
Begin DoDot:1
+34 SET CLINNAME=""
FOR
SET CLINNAME=$ORDER(CLINARR(SDF,CLINNAME))
if CLINNAME=""
QUIT
Begin DoDot:2
+35 SET SDTMP=$PIECE(CLINARR(SDF,CLINNAME),U)_U_CLINNAME_U_$PIECE(CLINARR(SDF,CLINNAME),U,2)_U_$PIECE(CLINARR(SDF,CLINNAME),U,3)_U_$SELECT(+SDMAX:1,1:0)
+36 SET COUNT=COUNT+1
SET @RET@(COUNT)=SDTMP_$CHAR(30)
End DoDot:2
End DoDot:1
+37 SET @RET@(COUNT)=@RET@(COUNT)_$CHAR(31)
+38 QUIT
PART ;partial name lookup ;alb/sat 672
+1 if SDREF=""
QUIT
+2 ;alb/sat 658 - abbreviation lookup if characters length 7 or less
FOR
SET SDECNAM=$ORDER(^SC(SDREF,SDECNAM))
if SDECNAM'[SDECP
QUIT
Begin DoDot:1
+3 ;alb/sat 665 loop thru all entries
SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SC(SDREF,SDECNAM,SDECIEN))
if SDECIEN=""
QUIT
Begin DoDot:2
+4 ;alb/sat 665 loop thru all entries
SET CLINIEN=0
FOR
SET CLINIEN=$ORDER(^SDWL(409.32,"B",SDECIEN,CLINIEN))
if CLINIEN=""
QUIT
DO PROCESS
IF SDCNT'<MAXREC
SET SDMAX=+$ORDER(^SDWL(409.32,"B",SDECIEN,CLINIEN))
QUIT
End DoDot:2
IF SDCNT'<MAXREC
SET SDMAX=$SELECT(+SDMAX:+SDMAX,1:+$ORDER(^SC(SDREF,SDECNAM,SDECIEN)))
QUIT
End DoDot:1
IF SDCNT'<MAXREC
SET SDECNAM=$ORDER(^SC(SDREF,SDECNAM))
SET SDMAX=$SELECT(+SDMAX:1,SDECNAM[SDECP:1,1:0)
QUIT
+5 QUIT
PROCESS ;get 1 record ;alb/sat 665
+1 NEW CLINABR,INACTIVE,LOCIEN
+2 SET INACTIVE=$$GET1^DIQ(409.32,CLINIEN_",",3,"I")
+3 IF (INACTIVE'="")&($PIECE(INACTIVE,".",1)'>$PIECE($$NOW^XLFDT,".",1))
QUIT
+4 SET LOCIEN=$PIECE(^SDWL(409.32,CLINIEN,0),U)
+5 SET CLINNAME=$PIECE($GET(^SC(LOCIEN,0)),U)
+6 SET CLINABR=$PIECE($GET(^SC(LOCIEN,0)),U,2)
+7 if SDF["ABBR"
SET CLINNAME=CLINABR_" "_CLINNAME
+8 ;OOS?
if $$GET1^DIQ(44,LOCIEN_",",50.01,"I")=1
QUIT
+9 ;alb/sat 672 - checking for duplicates
if $DATA(SDARR1(CLINIEN))
QUIT
+10 ;alb/sat 672 - checking for duplicates
SET SDARR1(CLINIEN)=""
+11 IF CLINNAME'=""
SET CLINARR(SDF["FULL",CLINNAME)=CLINIEN_U_LOCIEN_U_CLINABR
SET SDCNT=SDCNT+1
+12 QUIT
+13 ;
SVSPALL(RET) ;return IEN and NAME for all entries in the SD WL SERVICE/SPECIALTY file
+1 ;SVSPALL(RET) external parameter tag is in SDEC
+2 NEW COUNT,GLOREF,CLSTPIEN,SVSPARR,SVSPIEN,SVSPNAME,X
+3 SET RET="^TMP(""SDEC"","_$JOB_")"
+4 KILL @RET
+5 SET @RET@(0)="T00020SERVICESPECIALTY_IEN^T00030SERVICESPECIALTY_NAME"_$CHAR(30)
+6 SET GLOREF=$NAME(^SDWL(409.31))
+7 ; Search for all SD WL SERVICE/SPECIALTY entries
+8 ; Lookup the CLINIC STOP name
+9 ; Save the names in a local array so the return array will be sorted by Name
+10 SET SVSPIEN=0
+11 FOR
SET SVSPIEN=$ORDER(@GLOREF@(SVSPIEN))
if 'SVSPIEN
QUIT
Begin DoDot:1
+12 SET CLSTPIEN=$PIECE(@GLOREF@(SVSPIEN,0),U)
+13 SET SVSPNAME=$PIECE($GET(^DIC(40.7,CLSTPIEN,0)),U)
+14 IF SVSPNAME'=""
SET SVSPARR(SVSPNAME)=SVSPIEN
End DoDot:1
+15 SET SVSPNAME=""
SET COUNT=0
+16 FOR
SET SVSPNAME=$ORDER(SVSPARR(SVSPNAME))
if SVSPNAME=""
QUIT
Begin DoDot:1
+17 SET COUNT=COUNT+1
SET @RET@(COUNT)=SVSPARR(SVSPNAME)_U_SVSPNAME_$CHAR(30)
End DoDot:1
+18 ;S COUNT=COUNT+1,@RET@(COUNT)=$C(31)
+19 SET @RET@(COUNT)=@RET@(COUNT)_$CHAR(31)
+20 QUIT
+21 ;
APPTYPES(RET,DFN) ; EP for SDEC APPTYPES
+1 ;APPTYPES(RET,DFN) external parameter tag is in SDEC
+2 ; Return the different appointment types
+3 NEW APTYDATA,APTYIEN,APTYINAC,APTYNAME,COUNT,GLOREF
+4 NEW ISVET,PTYPE,SDEC,SDI
+5 SET PTYPE=""
+6 ;0=not a vet; 1=is a vet
SET ISVET=1
+7 SET RET=$NAME(^TMP("SDEC",$JOB))
SET COUNT=0
+8 KILL @RET
+9 SET @RET@(0)="T00020APPTTYPE_IEN^T00030APPTTYPE_NAME"_$CHAR(30)
+10 SET DFN=$GET(DFN)
IF DFN'=""
if '$DATA(^DPT(+DFN,0))
SET DFN=""
+11 SET GLOREF=$NAME(^SD(409.1))
+12 IF '+DFN
Begin DoDot:1
+13 SET APTYNAME=""
FOR
SET APTYNAME=$ORDER(@GLOREF@("B",APTYNAME))
if APTYNAME=""
QUIT
Begin DoDot:2
+14 SET APTYIEN=0
FOR
SET APTYIEN=$ORDER(@GLOREF@("B",APTYNAME,APTYIEN))
if 'APTYIEN
QUIT
Begin DoDot:3
+15 SET APTYDATA=$GET(@GLOREF@(APTYIEN,0))
+16 if $PIECE(APTYDATA,U,3)
QUIT
+17 SET COUNT=COUNT+1
SET @RET@(COUNT)=APTYIEN_U_APTYNAME_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 IF +DFN
Begin DoDot:1
+20 NEW VAEL
DO ELIG^VADPT
+21 SET SDEC=$SELECT($DATA(^DIC(8,+VAEL(1),0)):$PIECE(^(0),U,5),1:"")
+22 SET APTYNAME=""
FOR
SET APTYNAME=$ORDER(@GLOREF@("B",APTYNAME))
if APTYNAME=""
QUIT
Begin DoDot:2
+23 SET APTYIEN=0
FOR
SET APTYIEN=$ORDER(@GLOREF@("B",APTYNAME,APTYIEN))
if 'APTYIEN
QUIT
Begin DoDot:3
+24 SET APTYDATA=$GET(@GLOREF@(APTYIEN,0))
+25 if $PIECE(APTYDATA,U,3)
QUIT
+26 IF $SELECT(SDEC["Y":1,1:$PIECE(APTYDATA,U,5))
IF $SELECT('$PIECE(APTYDATA,U,6):1,$DATA(VAEL(1,+$PIECE(APTYDATA,U,6))):1,+VAEL(1)=$PIECE(APTYDATA,U,6):1,1:0)
Begin DoDot:4
+27 SET COUNT=COUNT+1
SET @RET@(COUNT)=APTYIEN_U_APTYNAME_$CHAR(30)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;
+29 SET @RET@(COUNT)=@RET@(COUNT)_$CHAR(31)
+30 QUIT
+31 ;
WLPCSET(SDECY,INP,WLIEN,SOURCE) ;SET update patient contacts in SD WAIT LIST file
+1 ;WLSETPC(SDECY,INP,WLIEN) external parameter tag in SDEC
+2 ; INP = Patient Contacts separated by ::
+3 ; Each :: piece has the following ~~ pieces: (same as they are passed into SDEC WLSET)
+4 ; 1) = (required) DATE ENTERED external date/time
+5 ; 2) = (optional) PC ENTERED BY USER ID or NAME - Pointer to NEW PERSON file or NAME
+6 ; 4) = (optional) ACTION - valid values are:
+7 ; CALLED
+8 ; MESSAGE LEFT
+9 ; LETTER
+10 ; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
+11 ; 6) = NOT USED (optional) Comment 1-160 characters
+12 ; WLIEN = (required) Wait List Id pointer to SDEC WAIT LIST file 409.3
+13 ;
+14 NEW SDECI,SDTMP,WLMSG1
+15 SET SDECY="^TMP(""SDECWL"","_$JOB_",""WLSETPC"")"
+16 KILL @SDECY
+17 SET SDECI=0
+18 SET @SDECY@(SDECI)="T00030RETURNCODE^T00030TEXT"_$CHAR(30)
+19 SET WLIEN=$GET(WLIEN)
+20 IF (WLIEN="")!('$DATA(^SDWL(409.3,WLIEN,0)))
DO ERR1^SDECERR(-1,"Invalid wait list ID "_WLIEN_".",SDECI,SDECY)
QUIT
+21 DO WL23^SDECWL2(INP,WLIEN)
+22 IF $DATA(WLMSG1)
DO ERR1^SDECERR(-1,"Error storing patient contacts.",SDECI,SDECY)
QUIT
+23 SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^SUCCESS"_$CHAR(30,31)
+24 QUIT
+25 ;
AUDITGET(SDECY,WLIEN) ;GET entries from VS AUDIT field of SD WAIT LIST file 409.3
+1 NEW WLDATA,SDECI,SDI,SDTMP,SDX
+2 SET SDECY="^TMP(""SDECWL"","_$JOB_",""AUDITGET"")"
+3 KILL @SDECY
+4 SET SDECI=0
+5 SET SDTMP="T00030IEN^T00030ID^T00030DATE^T00030USERIEN^T00030USERNAME"
+6 SET SDTMP=SDTMP_"^T00030WLCINIEN^T00030WLCINNAME^T00030CLINIEN^T00030CLINNAME"
+7 SET SDTMP=SDTMP_"^T00030STOPIEN^T00030STOPNAME"
+8 SET @SDECY@(SDECI)=SDTMP_$CHAR(30)
+9 ;validate WLIEN
+10 SET WLIEN=$GET(WLIEN)
+11 IF '+$DATA(^SDWL(409.3,+WLIEN,0))
SET @SDECY@(1)="-1^Invalid SD WAIT LIST id."_$CHAR(30,31)
QUIT
+12 SET SDI=0
FOR
SET SDI=$ORDER(^SDWL(409.3,+WLIEN,6,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+13 KILL WLDATA
+14 DO GETS^DIQ(409.345,SDI_","_WLIEN_",","**","IE","WLDATA")
+15 SET SDX="WLDATA(409.345,"""_SDI_","_WLIEN_","")"
+16 SET SDTMP=WLIEN_U_SDI_U_@SDX@(.01,"E")_U_@SDX@(1,"I")_U_@SDX@(1,"E")
+17 SET SDTMP=SDTMP_U_@SDX@(2,"I")_U_@SDX@(2,"E")_U_@SDX@(3,"I")_U_@SDX@(3,"E")
+18 SET SDTMP=SDTMP_U_@SDX@(4,"I")_U_@SDX@(4,"E")
+19 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=SDTMP_$CHAR(30)
End DoDot:1
+20 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+21 QUIT
