SDES2ARCLOSE ;ALB/ANU,BLB,LAB,TJB,LAB - SDES2 DISPOSITION APPT REQ; MAR 19,2026
;;5.3;Scheduling;**866,873,875,909,929,940**;Aug 13, 1993;Build 5
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to DUZ^XUP is supported by IA #7487
;
Q
; INPUT
;
; SDCONTEXT("ACHERON AUDIT ID") = Up to 40 Character unique ID number. Ex: 11d9dcc6-c6a2-4785-8031-8261576fca37
; SDCONTEXT("USER DUZ") = The DUZ of the user taking action in the calling application.
; SDCONTEXT("USER SECID") = The SECID of the user taking action in the calling application.
; SDCONTEXT("PATIENT DFN") = The DFN/IEN of the target patient from the calling application.
; SDCONTEXT("PATIENT ICN") = The ICN of the target patient from the calling application.
; SDINPUT("REQUEST ID") = IEN, Pointer to SDEC APPT REQUEST file.
; SDINPUT("DISP") = Disposition.
; SDINPUT("DISPDT") = Date Dispositioned in external form (e.g.,CCYY-MM-DD)
; SDINPUT("PCMT") = (optional) patient-entered comments from VAOS
;
DISPOSITION(JSON,SDCONTEXT,SDINPUT) ; Disposition an Appointment Request
N SDERRORS,SDRETURN,ARIEN,DISP,DISPDT,PCMT,PARAMETERS
;
; Validate SDCONTEXT
;
D VALCONTEXT^SDES2VALCONTEXT(.SDERRORS,.SDCONTEXT)
I $D(SDERRORS) S SDERRORS("ApptReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSON,.SDERRORS) Q
I $G(SDCONTEXT("USER DUZ"))'="" N DUZ D DUZ^XUP(SDCONTEXT("USER DUZ"))
; Validate PARAMS
S PARAMETERS=$$VALPARAMS(.SDINPUT,.SDERRORS)
I $D(SDERRORS) S SDERRORS("ApptReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSON,.SDERRORS) Q
;
S ARIEN=$P(PARAMETERS,"^"),DISP=$P(PARAMETERS,"^",2),DISPDT=$P(PARAMETERS,"^",3),PCMT=$P(PARAMETERS,"^",4)
D DISP(.SDRETURN,ARIEN,DISP,DISPDT,PCMT,SDCONTEXT("ACHERON AUDIT ID"),.SDERRORS)
;
I $D(SDERRORS) S SDERRORS("ApptReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSON,.SDERRORS) Q
;
I '$D(SDRETURN) S SDRETURN("ApptReqDisposition",1)=""
D BUILDJSON^SDES2JSON(.JSON,.SDRETURN)
Q
;
VALPARAMS(PARAMS,SDERRORS) ; Validate
N ARIEN,DISP,DISPDT,PCMT
;
; Validate Request ID
S ARIEN=$G(PARAMS("REQUEST ID"))
I $G(ARIEN)="" D ERRLOG^SDESJSON(.SDERRORS,3)
I $G(ARIEN)'="",'$D(^SDEC(409.85,ARIEN)) D ERRLOG^SDESJSON(.SDERRORS,4)
;
; Validate Disposition
S DISP=$G(PARAMS("DISP"))
I $G(DISP)="" D ERRLOG^SDESJSON(.SDERRORS,42)
Q:$D(SDERRORS) ""
; Re-mapped the Dispositions to their corresponding pointer value
S:(+DISP=0) DISP=$O(^SDEC(409.853,"B",DISP,""))
D:$$GET1^DIQ(409.853,DISP,.01)="" ERRLOG^SDESJSON(.SDERRORS,43)
;
; Validate DATE DISPOSITIONED
S DISPDT=$G(PARAMS("DISPDT"))
I $G(DISPDT)'="" S DISPDT=$$ISOTFM^SDAMUTDT(DISPDT) D
.I DISPDT=-1 D ERRLOG^SDESJSON(.SDERRORS,55)
I $G(DISPDT)="" D ERRLOG^SDESJSON(.SDERRORS,56)
;
; validate Patient-Entered comments
S PCMT=$G(PARAMS("PCMT"))
S PCMT=$TR($G(PCMT),"^"," ")
;
; validate request is not already dispositioned
;lab removing until ISS is ready I $$GET1^DIQ(409.85,ARIEN,21,"I")'="" D ERRLOG^SDESJSON(.SDERRORS,52,"Request is already dispositioned :"_$$GET1^DIQ(409.85,ARIEN,21,"E")_".")
Q:$D(SDERRORS) 0
Q ARIEN_"^"_DISP_"^"_DISPDT_"^"_PCMT
;
DISP(SDRETURN,ARIEN,DISP,DISPDT,PCMT,AUDITID,SDERRORS) ;Disposition an appt req
N ARFDA,ARRET,ARMSG,X,MI,%DT,SDERR,PARENTIEN,SDHL7IN,Y
S SDERR=0
S ARFDA=$NA(ARFDA(409.85,ARIEN_","))
S @ARFDA@(19)=DISPDT
S @ARFDA@(20)=DUZ
S @ARFDA@(21)=DISP
S @ARFDA@(23)="C"
S @ARFDA@(100)=AUDITID
D UPDATE^DIE("","ARFDA","ARRET","ARMSG")
I '$D(ARMSG) D
.S SDRETURN("ApptReqDisposition","FilingSuccess")=1
I $D(ARMSG("DIERR")) D
.S SDERR=1
.F MI=1:1:$G(ARMSG("DIERR")) D ERRLOG^SDESJSON(.SDERRORS,47,$G(ARMSG("DIERR",MI,"TEXT",1)))
I '$G(SDERR)&($$GET1^DIQ(409.85,ARIEN,41,"I")=1) D
. S PARENTIEN=$$GET1^DIQ(409.85,ARIEN,43.8,"I")
. I PARENTIEN D
. . D REMOVEMRTCINFO^SDES2MRTCUTIL(PARENTIEN,ARIEN,.SDERRORS)
. . D UPDATEPARENT^SDES2MRTCUTIL(PARENTIEN,DISP,DISPDT,AUDITID,.SDERRORS)
I '$G(SDERR) D EDITPCMT(ARIEN,PCMT)
;
;SEND HL7 TO CPRS IF RTC REQUEST
;
I '$G(SDERR),$P(^SDEC(409.85,ARIEN,0),U,5)="RTC" D
.I DISP=3!(DISP=9) D ARDISP^SDECHL7(ARIEN,"")
.I DISP'=3&(DISP'=9) D ARDISP^SDECHL7(ARIEN,1)
.I $D(^TMP($J,"REJECT",ARIEN)) D
..S SDERR=1,X=$G(^TMP(SDHL7IN("ORDER IEN")))
..D ERRLOG^SDESJSON(.SDRETURN,47,X)
Q
;
EDITPCMT(ARIEN,COMMENTSFLD60) ; update word processing PATIENT COMMENTS (409.855,60)
; ARIEN - (required) IEN to entry in 409.85
; COMMENTSFLD60 - (optional) VAOS related patient-entered comments
N SDFDA,PCMTSARRAY
S COMMENTSFLD60=$G(COMMENTSFLD60)
D WP^SDECUTL(.PCMTSARRAY,COMMENTSFLD60)
D WP^DIE(409.85,ARIEN_",",60,"","PCMTSARRAY")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2ARCLOSE 4674 printed May 25, 2026@12:57:40 Page 2
SDES2ARCLOSE ;ALB/ANU,BLB,LAB,TJB,LAB - SDES2 DISPOSITION APPT REQ; MAR 19,2026
+1 ;;5.3;Scheduling;**866,873,875,909,929,940**;Aug 13, 1993;Build 5
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to DUZ^XUP is supported by IA #7487
+5 ;
+6 QUIT
+7 ; INPUT
+8 ;
+9 ; SDCONTEXT("ACHERON AUDIT ID") = Up to 40 Character unique ID number. Ex: 11d9dcc6-c6a2-4785-8031-8261576fca37
+10 ; SDCONTEXT("USER DUZ") = The DUZ of the user taking action in the calling application.
+11 ; SDCONTEXT("USER SECID") = The SECID of the user taking action in the calling application.
+12 ; SDCONTEXT("PATIENT DFN") = The DFN/IEN of the target patient from the calling application.
+13 ; SDCONTEXT("PATIENT ICN") = The ICN of the target patient from the calling application.
+14 ; SDINPUT("REQUEST ID") = IEN, Pointer to SDEC APPT REQUEST file.
+15 ; SDINPUT("DISP") = Disposition.
+16 ; SDINPUT("DISPDT") = Date Dispositioned in external form (e.g.,CCYY-MM-DD)
+17 ; SDINPUT("PCMT") = (optional) patient-entered comments from VAOS
+18 ;
DISPOSITION(JSON,SDCONTEXT,SDINPUT) ; Disposition an Appointment Request
+1 NEW SDERRORS,SDRETURN,ARIEN,DISP,DISPDT,PCMT,PARAMETERS
+2 ;
+3 ; Validate SDCONTEXT
+4 ;
+5 DO VALCONTEXT^SDES2VALCONTEXT(.SDERRORS,.SDCONTEXT)
+6 IF $DATA(SDERRORS)
SET SDERRORS("ApptReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSON,.SDERRORS)
QUIT
+7 IF $GET(SDCONTEXT("USER DUZ"))'=""
NEW DUZ
DO DUZ^XUP(SDCONTEXT("USER DUZ"))
+8 ; Validate PARAMS
+9 SET PARAMETERS=$$VALPARAMS(.SDINPUT,.SDERRORS)
+10 IF $DATA(SDERRORS)
SET SDERRORS("ApptReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSON,.SDERRORS)
QUIT
+11 ;
+12 SET ARIEN=$PIECE(PARAMETERS,"^")
SET DISP=$PIECE(PARAMETERS,"^",2)
SET DISPDT=$PIECE(PARAMETERS,"^",3)
SET PCMT=$PIECE(PARAMETERS,"^",4)
+13 DO DISP(.SDRETURN,ARIEN,DISP,DISPDT,PCMT,SDCONTEXT("ACHERON AUDIT ID"),.SDERRORS)
+14 ;
+15 IF $DATA(SDERRORS)
SET SDERRORS("ApptReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSON,.SDERRORS)
QUIT
+16 ;
+17 IF '$DATA(SDRETURN)
SET SDRETURN("ApptReqDisposition",1)=""
+18 DO BUILDJSON^SDES2JSON(.JSON,.SDRETURN)
+19 QUIT
+20 ;
VALPARAMS(PARAMS,SDERRORS) ; Validate
+1 NEW ARIEN,DISP,DISPDT,PCMT
+2 ;
+3 ; Validate Request ID
+4 SET ARIEN=$GET(PARAMS("REQUEST ID"))
+5 IF $GET(ARIEN)=""
DO ERRLOG^SDESJSON(.SDERRORS,3)
+6 IF $GET(ARIEN)'=""
IF '$DATA(^SDEC(409.85,ARIEN))
DO ERRLOG^SDESJSON(.SDERRORS,4)
+7 ;
+8 ; Validate Disposition
+9 SET DISP=$GET(PARAMS("DISP"))
+10 IF $GET(DISP)=""
DO ERRLOG^SDESJSON(.SDERRORS,42)
+11 if $DATA(SDERRORS)
QUIT ""
+12 ; Re-mapped the Dispositions to their corresponding pointer value
+13 if (+DISP=0)
SET DISP=$ORDER(^SDEC(409.853,"B",DISP,""))
+14 if $$GET1^DIQ(409.853,DISP,.01)=""
DO ERRLOG^SDESJSON(.SDERRORS,43)
+15 ;
+16 ; Validate DATE DISPOSITIONED
+17 SET DISPDT=$GET(PARAMS("DISPDT"))
+18 IF $GET(DISPDT)'=""
SET DISPDT=$$ISOTFM^SDAMUTDT(DISPDT)
Begin DoDot:1
+19 IF DISPDT=-1
DO ERRLOG^SDESJSON(.SDERRORS,55)
End DoDot:1
+20 IF $GET(DISPDT)=""
DO ERRLOG^SDESJSON(.SDERRORS,56)
+21 ;
+22 ; validate Patient-Entered comments
+23 SET PCMT=$GET(PARAMS("PCMT"))
+24 SET PCMT=$TRANSLATE($GET(PCMT),"^"," ")
+25 ;
+26 ; validate request is not already dispositioned
+27 ;lab removing until ISS is ready I $$GET1^DIQ(409.85,ARIEN,21,"I")'="" D ERRLOG^SDESJSON(.SDERRORS,52,"Request is already dispositioned :"_$$GET1^DIQ(409.85,ARIEN,21,"E")_".")
+28 if $DATA(SDERRORS)
QUIT 0
+29 QUIT ARIEN_"^"_DISP_"^"_DISPDT_"^"_PCMT
+30 ;
DISP(SDRETURN,ARIEN,DISP,DISPDT,PCMT,AUDITID,SDERRORS) ;Disposition an appt req
+1 NEW ARFDA,ARRET,ARMSG,X,MI,%DT,SDERR,PARENTIEN,SDHL7IN,Y
+2 SET SDERR=0
+3 SET ARFDA=$NAME(ARFDA(409.85,ARIEN_","))
+4 SET @ARFDA@(19)=DISPDT
+5 SET @ARFDA@(20)=DUZ
+6 SET @ARFDA@(21)=DISP
+7 SET @ARFDA@(23)="C"
+8 SET @ARFDA@(100)=AUDITID
+9 DO UPDATE^DIE("","ARFDA","ARRET","ARMSG")
+10 IF '$DATA(ARMSG)
Begin DoDot:1
+11 SET SDRETURN("ApptReqDisposition","FilingSuccess")=1
End DoDot:1
+12 IF $DATA(ARMSG("DIERR"))
Begin DoDot:1
+13 SET SDERR=1
+14 FOR MI=1:1:$GET(ARMSG("DIERR"))
DO ERRLOG^SDESJSON(.SDERRORS,47,$GET(ARMSG("DIERR",MI,"TEXT",1)))
End DoDot:1
+15 IF '$GET(SDERR)&($$GET1^DIQ(409.85,ARIEN,41,"I")=1)
Begin DoDot:1
+16 SET PARENTIEN=$$GET1^DIQ(409.85,ARIEN,43.8,"I")
+17 IF PARENTIEN
Begin DoDot:2
+18 DO REMOVEMRTCINFO^SDES2MRTCUTIL(PARENTIEN,ARIEN,.SDERRORS)
+19 DO UPDATEPARENT^SDES2MRTCUTIL(PARENTIEN,DISP,DISPDT,AUDITID,.SDERRORS)
End DoDot:2
End DoDot:1
+20 IF '$GET(SDERR)
DO EDITPCMT(ARIEN,PCMT)
+21 ;
+22 ;SEND HL7 TO CPRS IF RTC REQUEST
+23 ;
+24 IF '$GET(SDERR)
IF $PIECE(^SDEC(409.85,ARIEN,0),U,5)="RTC"
Begin DoDot:1
+25 IF DISP=3!(DISP=9)
DO ARDISP^SDECHL7(ARIEN,"")
+26 IF DISP'=3&(DISP'=9)
DO ARDISP^SDECHL7(ARIEN,1)
+27 IF $DATA(^TMP($JOB,"REJECT",ARIEN))
Begin DoDot:2
+28 SET SDERR=1
SET X=$GET(^TMP(SDHL7IN("ORDER IEN")))
+29 DO ERRLOG^SDESJSON(.SDRETURN,47,X)
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
EDITPCMT(ARIEN,COMMENTSFLD60) ; update word processing PATIENT COMMENTS (409.855,60)
+1 ; ARIEN - (required) IEN to entry in 409.85
+2 ; COMMENTSFLD60 - (optional) VAOS related patient-entered comments
+3 NEW SDFDA,PCMTSARRAY
+4 SET COMMENTSFLD60=$GET(COMMENTSFLD60)
+5 DO WP^SDECUTL(.PCMTSARRAY,COMMENTSFLD60)
+6 DO WP^DIE(409.85,ARIEN_",",60,"","PCMTSARRAY")
+7 QUIT
+8 ;
