SDEC26 ;ALB/SAT,JAS,LAB/JAS - VISTA SCHEDULING RPCS ; NOV 22, 2024
;;5.3;Scheduling;**627,658,722,831,893,895**;Aug 13, 1993;Build 11
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
EDITAPPT(SDECY,SDECAPTID,SDECNOTE,SDECLEN) ;Edit appointment (only 'note text' and appointment length can be edited)
;EDITAPPT(SDECY,SDECAPTID,SDECNOTE,SDECLEN) external parameter tag is in SDEC
; SDECAPTID - Appointment ID - Pointer to SDEC APPOINTMENT
; SDECNOTE - Note
; SDECLEN - no longer allowed If there is a change in the length of appointment, this is the new value (in minutes) for length
;
N SDECAP,SDECCL,SDECNEND,SDECNOD,SDECOLEN,SDECPAT,SDECPATID,SDECRES,SDECSTART
N DIK,DA,INP,SDECID,SDECI,SDECZ,SDECIENS,SDECEND
;
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,SDECI)="T00020ERRORID"_$C(30)
S SDECI=SDECI+1
;validate SDEC appointment pointer
I '+SDECAPTID D ERR(SDECI,"SDEC26: Invalid Appointment ID") Q
I '$D(^SDEC(409.84,SDECAPTID,0)) D ERR(SDECI,"SDEC26: Invalid Appointment ID") Q
;alb/sat 658 begin
N SDID,SDNOD,SDRET,SDTYP ;check if request is open
S SDNOD=$G(^SDEC(409.84,SDECAPTID,0))
I $P(SDNOD,U,23)="",$P(SDNOD,U,12)="" D
.S SDTYP=$P($G(^SDEC(409.84,SDECAPTID,2)),U,1)
.Q:SDTYP=""
.S SDID=$P(SDTYP,";",1)
.S SDTYP=$S($P(SDTYP,";",2)="SDWL(409.3,":1,$P(SDTYP,";",2)="SDEC(409.85,":2,1:0)
.I SDTYP=2,$$GET1^DIQ(409.85,SDID_",",23,"I")="O" D
..S INP(1)=SDID
..S INP(2)="SA"
..S INP(4)=$P(SDNOD,U,9) ;date appt made
..D ARCLOSE1^SDEC(.SDRET,.INP)
.I SDTYP=1,$$GET1^DIQ(409.3,SDID_",",23,"I")="O" D
..S INP(1)=SDID
..S INP(2)="SA"
..S INP(4)=$P(SDNOD,U,9) ;date appt made
..D WLCLOSE1^SDEC(.SDRET,.INP)
..;end check if request is open
S SDECNOTE=$G(SDECNOTE) S:SDECNOTE'="" SDECNOTE=$E(SDECNOTE,1,150),SDECNOTE=$TR(SDECNOTE,"^"," ") ;alb/sat 658 - only use 1st 150 characters
D:SDECNOTE'="" SETNOTE(SDECAPTID,SDECNOTE)
;alb/sat 658 end
;
;Edit appointment length - no longer permitted.
N POP
S POP=0
I $G(SDECLEN),$G(SDECLEN)>0 D
. I $G(SDECLEN)'=$$GET1^DIQ(409.84,SDECAPTID_",",.18,"I") D
. . D ERR(SDECI,"SDEC26: Appointment Length cannot be modified. Cancel appointment and recreate.")
. . S POP=1
Q:POP
;
;Return Recordset
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)="-1"_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
SETNOTE(APID,NOTE) ;set note to SDEC APPOINTMENT and file 44-APPOINTMENT-OTHER alb/sat 658
N DFN,DIC,DA,FDA,IENS,X,Y,DLAYGO,DD,DO,DINUM
N SDCL,SDID,SDRES,SDRTYP,SDT
S NOTE=$G(NOTE)
Q:NOTE=""
S:NOTE'="" NOTE=$E(NOTE,1,150)
S DFN=$$GET1^DIQ(409.84,APID_",",.05,"I")
S SDRES=$$GET1^DIQ(409.84,APID_",",.07,"I")
Q:SDRES=""
S SDRTYP=$$GET1^DIQ(409.831,SDRES_",",.012,"I")
Q:$P(SDRTYP,";",2)'="SC("
S SDCL=$P(SDRTYP,";",1)
S SDT=$$GET1^DIQ(409.84,APID_",",.01,"I")
S SDID=0 F S SDID=$O(^SC(SDCL,"S",SDT,1,SDID)) Q:SDID="" Q:(($P($G(^SC(SDCL,"S",SDT,1,SDID,0)),U,9)'="C")&(+$G(^SC(SDCL,"S",SDT,1,SDID,0))=DFN)) ;*zeb 722 2/21/19 skip cancelled appts
Q:SDID=""
S IENS=SDID_","_SDT_","_SDCL_","
;
N APPTREF,NOTEINFO,ERR,INDEX,LASTLENGTH,LASTNOTE,NEWLENGTH,NEWNOTE
D GETS^DIQ(409.84,APID_",","1","E","NOTEINFO","ERR")
S (INDEX,LASTLENGTH)=0,LASTNOTE=""
S APPTREF=$O(NOTEINFO(409.84,""),-1)
F S INDEX=$O(NOTEINFO(409.84,APPTREF,1,INDEX)) Q:'INDEX D
. S LASTLENGTH=LASTLENGTH+$L(NOTEINFO(409.84,APPTREF,1,INDEX))
. S LASTNOTE=LASTNOTE_NOTEINFO(409.84,APPTREF,1,INDEX)
S NEWNOTE=NOTE
S:NEWNOTE[LASTNOTE NEWNOTE=$E(NOTE,(LASTLENGTH+1),($L(NOTE)))
S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
S NEWNOTE=$$CTRL^XMXUTIL1(NEWNOTE)
;
S NOTE=$$CTRL^XMXUTIL1(NOTE)
S FDA(44.003,IENS,3)=NOTE
D UPDATE^DIE("","FDA")
D SDECWP^SDEC07(APID,NOTE)
;
; 409.84 NOTE AUDIT multiple
I $L(NOTE) D
. N NAFDA
. S NAFDA(409.847,"+1,"_APID_",",.01)=$$NOW^XLFDT
. S NAFDA(409.847,"+1,"_APID_",",1)=DUZ
. S NAFDA(409.847,"+1,"_APID_",",2)=NEWNOTE
. D UPDATE^DIE("","NAFDA") K NAFDA
Q
;
;
ERR(SDECI,SDECERR) ;Error processing
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=SDECERR_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
I '$D(SDECI) N SDECI S SDECI=999999
S SDECI=SDECI+1
D ERR(SDECI,"SDEC26 Error")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC26 4352 printed Sep 23, 2025@20:26:46 Page 2
SDEC26 ;ALB/SAT,JAS,LAB/JAS - VISTA SCHEDULING RPCS ; NOV 22, 2024
+1 ;;5.3;Scheduling;**627,658,722,831,893,895**;Aug 13, 1993;Build 11
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
EDITAPPT(SDECY,SDECAPTID,SDECNOTE,SDECLEN) ;Edit appointment (only 'note text' and appointment length can be edited)
+1 ;EDITAPPT(SDECY,SDECAPTID,SDECNOTE,SDECLEN) external parameter tag is in SDEC
+2 ; SDECAPTID - Appointment ID - Pointer to SDEC APPOINTMENT
+3 ; SDECNOTE - Note
+4 ; SDECLEN - no longer allowed If there is a change in the length of appointment, this is the new value (in minutes) for length
+5 ;
+6 NEW SDECAP,SDECCL,SDECNEND,SDECNOD,SDECOLEN,SDECPAT,SDECPATID,SDECRES,SDECSTART
+7 NEW DIK,DA,INP,SDECID,SDECI,SDECZ,SDECIENS,SDECEND
+8 ;
+9 SET SDECI=0
+10 KILL ^TMP("SDEC",$JOB)
+11 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+12 SET ^TMP("SDEC",$JOB,SDECI)="T00020ERRORID"_$CHAR(30)
+13 SET SDECI=SDECI+1
+14 ;validate SDEC appointment pointer
+15 IF '+SDECAPTID
DO ERR(SDECI,"SDEC26: Invalid Appointment ID")
QUIT
+16 IF '$DATA(^SDEC(409.84,SDECAPTID,0))
DO ERR(SDECI,"SDEC26: Invalid Appointment ID")
QUIT
+17 ;alb/sat 658 begin
+18 ;check if request is open
NEW SDID,SDNOD,SDRET,SDTYP
+19 SET SDNOD=$GET(^SDEC(409.84,SDECAPTID,0))
+20 IF $PIECE(SDNOD,U,23)=""
IF $PIECE(SDNOD,U,12)=""
Begin DoDot:1
+21 SET SDTYP=$PIECE($GET(^SDEC(409.84,SDECAPTID,2)),U,1)
+22 if SDTYP=""
QUIT
+23 SET SDID=$PIECE(SDTYP,";",1)
+24 SET SDTYP=$SELECT($PIECE(SDTYP,";",2)="SDWL(409.3,":1,$PIECE(SDTYP,";",2)="SDEC(409.85,":2,1:0)
+25 IF SDTYP=2
IF $$GET1^DIQ(409.85,SDID_",",23,"I")="O"
Begin DoDot:2
+26 SET INP(1)=SDID
+27 SET INP(2)="SA"
+28 ;date appt made
SET INP(4)=$PIECE(SDNOD,U,9)
+29 DO ARCLOSE1^SDEC(.SDRET,.INP)
End DoDot:2
+30 IF SDTYP=1
IF $$GET1^DIQ(409.3,SDID_",",23,"I")="O"
Begin DoDot:2
+31 SET INP(1)=SDID
+32 SET INP(2)="SA"
+33 ;date appt made
SET INP(4)=$PIECE(SDNOD,U,9)
+34 DO WLCLOSE1^SDEC(.SDRET,.INP)
+35 ;end check if request is open
End DoDot:2
End DoDot:1
+36 ;alb/sat 658 - only use 1st 150 characters
SET SDECNOTE=$GET(SDECNOTE)
if SDECNOTE'=""
SET SDECNOTE=$EXTRACT(SDECNOTE,1,150)
SET SDECNOTE=$TRANSLATE(SDECNOTE,"^"," ")
+37 if SDECNOTE'=""
DO SETNOTE(SDECAPTID,SDECNOTE)
+38 ;alb/sat 658 end
+39 ;
+40 ;Edit appointment length - no longer permitted.
+41 NEW POP
+42 SET POP=0
+43 IF $GET(SDECLEN)
IF $GET(SDECLEN)>0
Begin DoDot:1
+44 IF $GET(SDECLEN)'=$$GET1^DIQ(409.84,SDECAPTID_",",.18,"I")
Begin DoDot:2
+45 DO ERR(SDECI,"SDEC26: Appointment Length cannot be modified. Cancel appointment and recreate.")
+46 SET POP=1
End DoDot:2
End DoDot:1
+47 if POP
QUIT
+48 ;
+49 ;Return Recordset
+50 SET SDECI=SDECI+1
+51 SET ^TMP("SDEC",$JOB,SDECI)="-1"_$CHAR(30)
+52 SET SDECI=SDECI+1
+53 SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+54 QUIT
SETNOTE(APID,NOTE) ;set note to SDEC APPOINTMENT and file 44-APPOINTMENT-OTHER alb/sat 658
+1 NEW DFN,DIC,DA,FDA,IENS,X,Y,DLAYGO,DD,DO,DINUM
+2 NEW SDCL,SDID,SDRES,SDRTYP,SDT
+3 SET NOTE=$GET(NOTE)
+4 if NOTE=""
QUIT
+5 if NOTE'=""
SET NOTE=$EXTRACT(NOTE,1,150)
+6 SET DFN=$$GET1^DIQ(409.84,APID_",",.05,"I")
+7 SET SDRES=$$GET1^DIQ(409.84,APID_",",.07,"I")
+8 if SDRES=""
QUIT
+9 SET SDRTYP=$$GET1^DIQ(409.831,SDRES_",",.012,"I")
+10 if $PIECE(SDRTYP,";",2)'="SC("
QUIT
+11 SET SDCL=$PIECE(SDRTYP,";",1)
+12 SET SDT=$$GET1^DIQ(409.84,APID_",",.01,"I")
+13 ;*zeb 722 2/21/19 skip cancelled appts
SET SDID=0
FOR
SET SDID=$ORDER(^SC(SDCL,"S",SDT,1,SDID))
if SDID=""
QUIT
if (($PIECE($GET(^SC(SDCL,"S",SDT,1,SDID,0)),U,9)'="C")&(+$GET(^SC(SDCL,"S",SDT,1,SDID,0))=DFN))
QUIT
+14 if SDID=""
QUIT
+15 SET IENS=SDID_","_SDT_","_SDCL_","
+16 ;
+17 NEW APPTREF,NOTEINFO,ERR,INDEX,LASTLENGTH,LASTNOTE,NEWLENGTH,NEWNOTE
+18 DO GETS^DIQ(409.84,APID_",","1","E","NOTEINFO","ERR")
+19 SET (INDEX,LASTLENGTH)=0
SET LASTNOTE=""
+20 SET APPTREF=$ORDER(NOTEINFO(409.84,""),-1)
+21 FOR
SET INDEX=$ORDER(NOTEINFO(409.84,APPTREF,1,INDEX))
if 'INDEX
QUIT
Begin DoDot:1
+22 SET LASTLENGTH=LASTLENGTH+$LENGTH(NOTEINFO(409.84,APPTREF,1,INDEX))
+23 SET LASTNOTE=LASTNOTE_NOTEINFO(409.84,APPTREF,1,INDEX)
End DoDot:1
+24 SET NEWNOTE=NOTE
+25 if NEWNOTE[LASTNOTE
SET NEWNOTE=$EXTRACT(NOTE,(LASTLENGTH+1),($LENGTH(NOTE)))
+26 if $EXTRACT(NEWNOTE,1,1)=" "
SET NEWNOTE=$EXTRACT(NEWNOTE,2,$LENGTH(NEWNOTE))
+27 SET NEWNOTE=$$CTRL^XMXUTIL1(NEWNOTE)
+28 ;
+29 SET NOTE=$$CTRL^XMXUTIL1(NOTE)
+30 SET FDA(44.003,IENS,3)=NOTE
+31 DO UPDATE^DIE("","FDA")
+32 DO SDECWP^SDEC07(APID,NOTE)
+33 ;
+34 ; 409.84 NOTE AUDIT multiple
+35 IF $LENGTH(NOTE)
Begin DoDot:1
+36 NEW NAFDA
+37 SET NAFDA(409.847,"+1,"_APID_",",.01)=$$NOW^XLFDT
+38 SET NAFDA(409.847,"+1,"_APID_",",1)=DUZ
+39 SET NAFDA(409.847,"+1,"_APID_",",2)=NEWNOTE
+40 DO UPDATE^DIE("","NAFDA")
KILL NAFDA
End DoDot:1
+41 QUIT
+42 ;
+43 ;
ERR(SDECI,SDECERR) ;Error processing
+1 SET SDECI=SDECI+1
+2 SET ^TMP("SDEC",$JOB,SDECI)=SDECERR_$CHAR(30)
+3 SET SDECI=SDECI+1
+4 SET ^TMP("SDEC",$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,"SDEC26 Error")
+5 QUIT
