SDES2DISPRECALL ;ALB/BWF - DISPOSITION RECALL REQUEST; NOV 16,2023
;;5.3;Scheduling;**866**;Aug 13, 1993;Build 22
;;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,NOKEY,PROVIDER,NOKEY,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")
S NOKEY=$$KEY($G(SDINPUT("RECALL IEN")),PROVIDER,DELUSER)
I NOKEY D Q ;cannot move/delete if security key isn't present
.D ERRLOG^SDES2JSON(.ERRORS,NOKEY)
.S ERRORS("PtCSchReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS)
; 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 SDFDA
S SDFDA(403.5,$G(FILEDATA("RECALL IEN"))_",",2.5)=$G(FILEDATA("COMMENT"))
S SDFDA(403.5,$G(FILEDATA("RECALL IEN"))_",",100)=$G(EAS)
D FILE^DIE("","SDFDA")
K SDFDA
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
;
KEY(RECALLIEN,RRPROVIEN,DELUSER) ;check that user has the correct SECURITY KEY
;INPUT:
; RECALLIEN - ien of the entry in RECALL REMINDERS file (403.5)
; RRPROVIEN - ien of the entry in the RECALL REMINDERS PROVIDERS file 403.54
; DELUSER - user ien dispositioning the request
;RETURN
; 0=User has the correct SECURITY KEY
; "-1^<text>" = User does not have the correct SECURITY KEY
N KEY,RET,VALUE
S RET=135
I RRPROVIEN="" S RET=0
I RRPROVIEN'="" D
.S KEY=$$GET1^DIQ(409.54,RRPROVIEN,6,"I")
.I KEY="" S RET=0 Q
.S VALUE=$$LKUP^XPDKEY(KEY) N KY D OWNSKEY^XUSRB(.KY,VALUE,DELUSER)
.I $G(KY(0))'=0 S RET=0
Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2DISPRECALL 4327 printed Oct 16, 2024@18:54:15 Page 2
SDES2DISPRECALL ;ALB/BWF - DISPOSITION RECALL REQUEST; NOV 16,2023
+1 ;;5.3;Scheduling;**866**;Aug 13, 1993;Build 22
+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,NOKEY,PROVIDER,NOKEY,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 SET NOKEY=$$KEY($GET(SDINPUT("RECALL IEN")),PROVIDER,DELUSER)
+14 ;cannot move/delete if security key isn't present
IF NOKEY
Begin DoDot:1
+15 DO ERRLOG^SDES2JSON(.ERRORS,NOKEY)
+16 SET ERRORS("PtCSchReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS)
End DoDot:1
QUIT
+17 ; delete 403.5 entry
+18 DO DELETE(.ERRORS,.FILEDATA)
+19 IF $DATA(ERRORS)
SET ERRORS("PtCSchReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSONRETURN,.ERRORS)
QUIT
+20 SET RECALLRETURN("PtCSchReqDisposition","IEN")=$GET(SDINPUT("RECALL IEN"))
+21 DO BUILDJSON^SDES2JSON(.JSONRETURN,.RECALLRETURN)
+22 QUIT
+23 ;
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 SDFDA
+3 SET SDFDA(403.5,$GET(FILEDATA("RECALL IEN"))_",",2.5)=$GET(FILEDATA("COMMENT"))
+4 SET SDFDA(403.5,$GET(FILEDATA("RECALL IEN"))_",",100)=$GET(EAS)
+5 DO FILE^DIE("","SDFDA")
+6 KILL SDFDA
+7 QUIT
+8 ;
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 ;
KEY(RECALLIEN,RRPROVIEN,DELUSER) ;check that user has the correct SECURITY KEY
+1 ;INPUT:
+2 ; RECALLIEN - ien of the entry in RECALL REMINDERS file (403.5)
+3 ; RRPROVIEN - ien of the entry in the RECALL REMINDERS PROVIDERS file 403.54
+4 ; DELUSER - user ien dispositioning the request
+5 ;RETURN
+6 ; 0=User has the correct SECURITY KEY
+7 ; "-1^<text>" = User does not have the correct SECURITY KEY
+8 NEW KEY,RET,VALUE
+9 SET RET=135
+10 IF RRPROVIEN=""
SET RET=0
+11 IF RRPROVIEN'=""
Begin DoDot:1
+12 SET KEY=$$GET1^DIQ(409.54,RRPROVIEN,6,"I")
+13 IF KEY=""
SET RET=0
QUIT
+14 SET VALUE=$$LKUP^XPDKEY(KEY)
NEW KY
DO OWNSKEY^XUSRB(.KY,VALUE,DELUSER)
+15 IF $GET(KY(0))'=0
SET RET=0
End DoDot:1
+16 QUIT RET
