- 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 Jan 18, 2025@03:51:28 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