Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDEC26

SDEC26.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. Q
  1. ;
  1. 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
  1. ; SDECAPTID - Appointment ID - Pointer to SDEC APPOINTMENT
  1. ; SDECNOTE - Note
  1. ; SDECLEN - no longer allowed If there is a change in the length of appointment, this is the new value (in minutes) for length
  1. ;
  1. N SDECAP,SDECCL,SDECNEND,SDECNOD,SDECOLEN,SDECPAT,SDECPATID,SDECRES,SDECSTART
  1. N DIK,DA,INP,SDECID,SDECI,SDECZ,SDECIENS,SDECEND
  1. ;
  1. S SDECI=0
  1. K ^TMP("SDEC",$J)
  1. S SDECY="^TMP(""SDEC"","_$J_")"
  1. S ^TMP("SDEC",$J,SDECI)="T00020ERRORID"_$C(30)
  1. S SDECI=SDECI+1
  1. ;validate SDEC appointment pointer
  1. I '+SDECAPTID D ERR(SDECI,"SDEC26: Invalid Appointment ID") Q
  1. I '$D(^SDEC(409.84,SDECAPTID,0)) D ERR(SDECI,"SDEC26: Invalid Appointment ID") Q
  1. ;alb/sat 658 begin
  1. N SDID,SDNOD,SDRET,SDTYP ;check if request is open
  1. S SDNOD=$G(^SDEC(409.84,SDECAPTID,0))
  1. I $P(SDNOD,U,23)="",$P(SDNOD,U,12)="" D
  1. .S SDTYP=$P($G(^SDEC(409.84,SDECAPTID,2)),U,1)
  1. .Q:SDTYP=""
  1. .S SDID=$P(SDTYP,";",1)
  1. .S SDTYP=$S($P(SDTYP,";",2)="SDWL(409.3,":1,$P(SDTYP,";",2)="SDEC(409.85,":2,1:0)
  1. .I SDTYP=2,$$GET1^DIQ(409.85,SDID_",",23,"I")="O" D
  1. ..S INP(1)=SDID
  1. ..S INP(2)="SA"
  1. ..S INP(4)=$P(SDNOD,U,9) ;date appt made
  1. ..D ARCLOSE1^SDEC(.SDRET,.INP)
  1. .I SDTYP=1,$$GET1^DIQ(409.3,SDID_",",23,"I")="O" D
  1. ..S INP(1)=SDID
  1. ..S INP(2)="SA"
  1. ..S INP(4)=$P(SDNOD,U,9) ;date appt made
  1. ..D WLCLOSE1^SDEC(.SDRET,.INP)
  1. ..;end check if request is open
  1. S SDECNOTE=$G(SDECNOTE) S:SDECNOTE'="" SDECNOTE=$E(SDECNOTE,1,150),SDECNOTE=$TR(SDECNOTE,"^"," ") ;alb/sat 658 - only use 1st 150 characters
  1. D:SDECNOTE'="" SETNOTE(SDECAPTID,SDECNOTE)
  1. ;alb/sat 658 end
  1. ;
  1. ;Edit appointment length - no longer permitted.
  1. N POP
  1. S POP=0
  1. I $G(SDECLEN),$G(SDECLEN)>0 D
  1. . I $G(SDECLEN)'=$$GET1^DIQ(409.84,SDECAPTID_",",.18,"I") D
  1. . . D ERR(SDECI,"SDEC26: Appointment Length cannot be modified. Cancel appointment and recreate.")
  1. . . S POP=1
  1. Q:POP
  1. ;
  1. ;Return Recordset
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)="-1"_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=$C(31)
  1. Q
  1. SETNOTE(APID,NOTE) ;set note to SDEC APPOINTMENT and file 44-APPOINTMENT-OTHER alb/sat 658
  1. N DFN,DIC,DA,FDA,IENS,X,Y,DLAYGO,DD,DO,DINUM
  1. N SDCL,SDID,SDRES,SDRTYP,SDT
  1. S NOTE=$G(NOTE)
  1. Q:NOTE=""
  1. S:NOTE'="" NOTE=$E(NOTE,1,150)
  1. S DFN=$$GET1^DIQ(409.84,APID_",",.05,"I")
  1. S SDRES=$$GET1^DIQ(409.84,APID_",",.07,"I")
  1. Q:SDRES=""
  1. S SDRTYP=$$GET1^DIQ(409.831,SDRES_",",.012,"I")
  1. Q:$P(SDRTYP,";",2)'="SC("
  1. S SDCL=$P(SDRTYP,";",1)
  1. S SDT=$$GET1^DIQ(409.84,APID_",",.01,"I")
  1. 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
  1. Q:SDID=""
  1. S IENS=SDID_","_SDT_","_SDCL_","
  1. ;
  1. N APPTREF,NOTEINFO,ERR,INDEX,LASTLENGTH,LASTNOTE,NEWLENGTH,NEWNOTE
  1. D GETS^DIQ(409.84,APID_",","1","E","NOTEINFO","ERR")
  1. S (INDEX,LASTLENGTH)=0,LASTNOTE=""
  1. S APPTREF=$O(NOTEINFO(409.84,""),-1)
  1. F S INDEX=$O(NOTEINFO(409.84,APPTREF,1,INDEX)) Q:'INDEX D
  1. . S LASTLENGTH=LASTLENGTH+$L(NOTEINFO(409.84,APPTREF,1,INDEX))
  1. . S LASTNOTE=LASTNOTE_NOTEINFO(409.84,APPTREF,1,INDEX)
  1. S NEWNOTE=NOTE
  1. S:NEWNOTE[LASTNOTE NEWNOTE=$E(NOTE,(LASTLENGTH+1),($L(NOTE)))
  1. S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
  1. S NEWNOTE=$$CTRL^XMXUTIL1(NEWNOTE)
  1. ;
  1. S NOTE=$$CTRL^XMXUTIL1(NOTE)
  1. S FDA(44.003,IENS,3)=NOTE
  1. D UPDATE^DIE("","FDA")
  1. D SDECWP^SDEC07(APID,NOTE)
  1. ;
  1. ; 409.84 NOTE AUDIT multiple
  1. I $L(NOTE) D
  1. . N NAFDA
  1. . S NAFDA(409.847,"+1,"_APID_",",.01)=$$NOW^XLFDT
  1. . S NAFDA(409.847,"+1,"_APID_",",1)=DUZ
  1. . S NAFDA(409.847,"+1,"_APID_",",2)=NEWNOTE
  1. . D UPDATE^DIE("","NAFDA") K NAFDA
  1. Q
  1. ;
  1. ;
  1. ERR(SDECI,SDECERR) ;Error processing
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=SDECERR_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=$C(31)
  1. Q
  1. ;
  1. ETRAP ;EP Error trap entry
  1. D ^%ZTER
  1. I '$D(SDECI) N SDECI S SDECI=999999
  1. S SDECI=SDECI+1
  1. D ERR(SDECI,"SDEC26 Error")
  1. Q