SDES2DISPRECALL ;ALB/BWF,JAS,JHC - DISPOSITION RECALL REQUEST; OCT 30, 2025
;;5.3;Scheduling;**866,895,922**;Aug 13, 1993;Build 7
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
;
; RPC: SDES2 DISPOSITION RECALL REQ
;
; SDCONTEXT INPUT
;
;S SDCONTEXT("ACHERON AUDIT ID") = Up to 40 Character unique ID number. Ex: 11d9dcc6-c6a2-4785-8031-8261576fca37
;S SDCONTEXT("USER DUZ") = The DUZ of the user taking action in the calling application.
;S SDCONTEXT("USER SECID") = The SECID of the user taking action in the calling application.
;S SDCONTEXT("PATIENT DFN") = The DFN/IEN of the target patient from the calling application.
;S SDCONTEXT("PATIENT ICN") = The ICN of the target patient from the calling application.
;
; INPUT FORMAT
;
;S SDINPUT("RECALL IEN")=RECALL IEN REQUIRED
;S SDINPUT("DELETE REASON")=DELETE REASON From 403.56, 203 OPTIONAL
; Can be the number or name
; '1' FOR FAILURE TO RESPOND
; '2' FOR MOVED
; '3' FOR DECEASED
; '4' FOR DOESN'T WANT VA SERVICES
; '5' FOR RECEIVED CARE AT ANOTHER VA
; '6' FOR OTHER
; '7' FOR APPT SCHEDULED
; '8' FOR VET SELF-CANCEL
;
;S SDINPUT("COMMENT")=FREE TEXT (1-80) OPTIONAL
;
DISPRECALL(JSONRETURN,SDCONTEXT,SDINPUT) ; add a disposition and delete an entry from the RECALL REMINDERS file (403.5)
N ERRORS,FILEDATA,PROVIDER,RECALLRETURN,DELUSER
; validate context
D VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
I $D(ERRORS) S ERRORS("PtCSchReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS) Q
S DELUSER=$S($G(SDCONTEXT("USER DUZ"))'="":SDCONTEXT("USER DUZ"),1:DUZ)
M FILEDATA=SDINPUT
; validate SDINPUT
D VALIDATE(.ERRORS,.SDINPUT,.FILEDATA)
I $D(ERRORS) S ERRORS("PtCSchReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS) Q
; edit the comment and eas fields in 403.5
D EDIT(.FILEDATA,$G(SDCONTEXT("ACHERON AUDIT ID")))
S PROVIDER=$$GET1^DIQ(403.5,$G(SDINPUT("RECALL IEN")),4,"I")
; delete 403.5 entry
D DELETE(.ERRORS,.FILEDATA)
I $D(ERRORS) S ERRORS("PtCSchReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS) Q
S RECALLRETURN("PtCSchReqDisposition","IEN")=$G(SDINPUT("RECALL IEN"))
D BUILDJSON^SDES2JSON(.JSONRETURN,.RECALLRETURN)
Q
;
VALIDATE(ERRORS,SDINPUT,FILEDATA) ;
N VALRETURN
D VALFILEIEN^SDES2VALUTIL(.VALRETURN,.ERRORS,403.5,$G(SDINPUT("RECALL IEN")),1,,16,17)
; validate disposition (optional)
D VALFIELD^SDES2VALUTIL(.VALRETURN,.ERRORS,403.56,203,$G(SDINPUT("DELETE REASON")),,,,535)
I VALRETURN S FILEDATA("DELETE REASON")=$G(VALRETURN(403.56,203,"I"))
;validate comment
D VALFIELD^SDES2VALUTIL(.VALRETURN,.ERRORS,403.5,2.5,$G(SDINPUT("COMMENT")),,,,443)
Q
;
EDIT(FILEDATA,EAS) ;
;replace existing comment and EAS tracking number before calling move/delete
N LASTNOTE,SDFDA
S LASTNOTE=$$GET1^DIQ(403.5,$G(FILEDATA("RECALL IEN"))_",",2.5,"E")
S SDFDA(403.5,$G(FILEDATA("RECALL IEN"))_",",2.5)=$$CTRL^XMXUTIL1($G(FILEDATA("COMMENT")))
S SDFDA(403.5,$G(FILEDATA("RECALL IEN"))_",",100)=$G(EAS)
D FILE^DIE("","SDFDA")
K SDFDA
; 403.57 COMMENT AUDIT multiple
N LASTLENGTH,NEWLENGTH,NEWNOTE
S LASTLENGTH=$L(LASTNOTE),NEWLENGTH=$L($G(FILEDATA("COMMENT")))
S NEWNOTE=$E($G(FILEDATA("COMMENT")),(LASTLENGTH+1),NEWLENGTH)
S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
S CAFDA(403.57,"+1,"_$G(FILEDATA("RECALL IEN"))_",",.01)=$$NOW^XLFDT
S CAFDA(403.57,"+1,"_$G(FILEDATA("RECALL IEN"))_",",1)=DELUSER
S CAFDA(403.57,"+1,"_$G(FILEDATA("RECALL IEN"))_",",2)=NEWNOTE
D UPDATE^DIE("","CAFDA") K CAFDA
Q
;
DELETE(ERRORS,FILEDATA) ;delete and move entry to RECALL REMINDERS REMOVED file (403.56)
N SDFDA,SDMSG,SDRRFTR
S SDRRFTR=$G(FILEDATA("DELETE REASON"))
S SDFDA(403.5,$G(FILEDATA("RECALL IEN"))_",",.01)="@"
D FILE^DIE("","SDFDA","SDMSG")
I $D(SDMSG) D ERRLOG^SDESJSON(.ERRORS,136,"for IEN "_$G(SDINPUT("RECALL IEN")))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2DISPRECALL 4024 printed Jan 29, 2026@15:52:46 Page 2
SDES2DISPRECALL ;ALB/BWF,JAS,JHC - DISPOSITION RECALL REQUEST; OCT 30, 2025
+1 ;;5.3;Scheduling;**866,895,922**;Aug 13, 1993;Build 7
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ;
+7 ; RPC: SDES2 DISPOSITION RECALL REQ
+8 ;
+9 ; SDCONTEXT INPUT
+10 ;
+11 ;S SDCONTEXT("ACHERON AUDIT ID") = Up to 40 Character unique ID number. Ex: 11d9dcc6-c6a2-4785-8031-8261576fca37
+12 ;S SDCONTEXT("USER DUZ") = The DUZ of the user taking action in the calling application.
+13 ;S SDCONTEXT("USER SECID") = The SECID of the user taking action in the calling application.
+14 ;S SDCONTEXT("PATIENT DFN") = The DFN/IEN of the target patient from the calling application.
+15 ;S SDCONTEXT("PATIENT ICN") = The ICN of the target patient from the calling application.
+16 ;
+17 ; INPUT FORMAT
+18 ;
+19 ;S SDINPUT("RECALL IEN")=RECALL IEN REQUIRED
+20 ;S SDINPUT("DELETE REASON")=DELETE REASON From 403.56, 203 OPTIONAL
+21 ; Can be the number or name
+22 ; '1' FOR FAILURE TO RESPOND
+23 ; '2' FOR MOVED
+24 ; '3' FOR DECEASED
+25 ; '4' FOR DOESN'T WANT VA SERVICES
+26 ; '5' FOR RECEIVED CARE AT ANOTHER VA
+27 ; '6' FOR OTHER
+28 ; '7' FOR APPT SCHEDULED
+29 ; '8' FOR VET SELF-CANCEL
+30 ;
+31 ;S SDINPUT("COMMENT")=FREE TEXT (1-80) OPTIONAL
+32 ;
DISPRECALL(JSONRETURN,SDCONTEXT,SDINPUT) ; add a disposition and delete an entry from the RECALL REMINDERS file (403.5)
+1 NEW ERRORS,FILEDATA,PROVIDER,RECALLRETURN,DELUSER
+2 ; validate context
+3 DO VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
+4 IF $DATA(ERRORS)
SET ERRORS("PtCSchReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS)
QUIT
+5 SET DELUSER=$SELECT($GET(SDCONTEXT("USER DUZ"))'="":SDCONTEXT("USER DUZ"),1:DUZ)
+6 MERGE FILEDATA=SDINPUT
+7 ; validate SDINPUT
+8 DO VALIDATE(.ERRORS,.SDINPUT,.FILEDATA)
+9 IF $DATA(ERRORS)
SET ERRORS("PtCSchReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS)
QUIT
+10 ; edit the comment and eas fields in 403.5
+11 DO EDIT(.FILEDATA,$GET(SDCONTEXT("ACHERON AUDIT ID")))
+12 SET PROVIDER=$$GET1^DIQ(403.5,$GET(SDINPUT("RECALL IEN")),4,"I")
+13 ; delete 403.5 entry
+14 DO DELETE(.ERRORS,.FILEDATA)
+15 IF $DATA(ERRORS)
SET ERRORS("PtCSchReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS)
QUIT
+16 SET RECALLRETURN("PtCSchReqDisposition","IEN")=$GET(SDINPUT("RECALL IEN"))
+17 DO BUILDJSON^SDES2JSON(.JSONRETURN,.RECALLRETURN)
+18 QUIT
+19 ;
VALIDATE(ERRORS,SDINPUT,FILEDATA) ;
+1 NEW VALRETURN
+2 DO VALFILEIEN^SDES2VALUTIL(.VALRETURN,.ERRORS,403.5,$GET(SDINPUT("RECALL IEN")),1,,16,17)
+3 ; validate disposition (optional)
+4 DO VALFIELD^SDES2VALUTIL(.VALRETURN,.ERRORS,403.56,203,$GET(SDINPUT("DELETE REASON")),,,,535)
+5 IF VALRETURN
SET FILEDATA("DELETE REASON")=$GET(VALRETURN(403.56,203,"I"))
+6 ;validate comment
+7 DO VALFIELD^SDES2VALUTIL(.VALRETURN,.ERRORS,403.5,2.5,$GET(SDINPUT("COMMENT")),,,,443)
+8 QUIT
+9 ;
EDIT(FILEDATA,EAS) ;
+1 ;replace existing comment and EAS tracking number before calling move/delete
+2 NEW LASTNOTE,SDFDA
+3 SET LASTNOTE=$$GET1^DIQ(403.5,$GET(FILEDATA("RECALL IEN"))_",",2.5,"E")
+4 SET SDFDA(403.5,$GET(FILEDATA("RECALL IEN"))_",",2.5)=$$CTRL^XMXUTIL1($GET(FILEDATA("COMMENT")))
+5 SET SDFDA(403.5,$GET(FILEDATA("RECALL IEN"))_",",100)=$GET(EAS)
+6 DO FILE^DIE("","SDFDA")
+7 KILL SDFDA
+8 ; 403.57 COMMENT AUDIT multiple
+9 NEW LASTLENGTH,NEWLENGTH,NEWNOTE
+10 SET LASTLENGTH=$LENGTH(LASTNOTE)
SET NEWLENGTH=$LENGTH($GET(FILEDATA("COMMENT")))
+11 SET NEWNOTE=$EXTRACT($GET(FILEDATA("COMMENT")),(LASTLENGTH+1),NEWLENGTH)
+12 if $EXTRACT(NEWNOTE,1,1)=" "
SET NEWNOTE=$EXTRACT(NEWNOTE,2,$LENGTH(NEWNOTE))
+13 SET CAFDA(403.57,"+1,"_$GET(FILEDATA("RECALL IEN"))_",",.01)=$$NOW^XLFDT
+14 SET CAFDA(403.57,"+1,"_$GET(FILEDATA("RECALL IEN"))_",",1)=DELUSER
+15 SET CAFDA(403.57,"+1,"_$GET(FILEDATA("RECALL IEN"))_",",2)=NEWNOTE
+16 DO UPDATE^DIE("","CAFDA")
KILL CAFDA
+17 QUIT
+18 ;
DELETE(ERRORS,FILEDATA) ;delete and move entry to RECALL REMINDERS REMOVED file (403.56)
+1 NEW SDFDA,SDMSG,SDRRFTR
+2 SET SDRRFTR=$GET(FILEDATA("DELETE REASON"))
+3 SET SDFDA(403.5,$GET(FILEDATA("RECALL IEN"))_",",.01)="@"
+4 DO FILE^DIE("","SDFDA","SDMSG")
+5 IF $DATA(SDMSG)
DO ERRLOG^SDESJSON(.ERRORS,136,"for IEN "_$GET(SDINPUT("RECALL IEN")))
+6 QUIT
+7 ;
