SDES2ARCLOSE ;ALB/ANU/BLB - SDES2 DISPOSITION APPT REQ; DEC 06, 2023@02:00
;;5.3;Scheduling;**866,873**;Aug 13, 1993;Build 10
;;Per VHA Directive 6402, this routine should not be modified
;
;
;
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 ERRORS,SDRETURN,ARIEN,DISP,DISPBY,DISPDT,PCMT,PARAMETERS
;
; Validate SDCONTEXT
;
D VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
I $D(ERRORS) S ERRORS("ApptReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSON,.ERRORS) Q
; Validate PARAMS
S PARAMETERS=$$VALPARAMS(.SDINPUT,.ERRORS)
I $D(ERRORS) S ERRORS("ApptReqDisposition",1)="" D BUILDJSON^SDES2JSON(.JSON,.ERRORS) Q
;
S DISPBY=$S(+$G(SDCONTEXT("USER DUZ")):+SDCONTEXT("USER DUZ"),1:$G(DUZ))
S ARIEN=$P(PARAMETERS,"^"),DISP=$P(PARAMETERS,"^",2),DISPDT=$P(PARAMETERS,"^",3),PCMT=$P(PARAMETERS,"^",4)
D DISP(.SDRETURN,ARIEN,DISP,DISPBY,DISPDT,PCMT,SDCONTEXT("ACHERON AUDIT ID"))
;
I $$GET1^DIQ(409.85,$G(SDINPUT("REQUEST ID")),43.8,"I") D
.D UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,$G(SDINPUT("REQUEST ID")),43.8,"I"),$$GET1^DIQ(409.85,$G(SDINPUT("REQUEST ID")),.01,"I"))
;
I '$D(SDRETURN) S SDRETURN("ApptReqDisposition",1)=""
D BUILDJSON^SDES2JSON(.JSON,.SDRETURN)
Q
;
VALPARAMS(PARAMS,SDERRORS) ; Validate
N ARIEN,DISP,DISPBY,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)
; Re-mapped the Dispositions to their corresponding pointer value
I $G(DISP)'="" D
.S:DISP="DEATH" DISP=1
.S:DISP="REMOVED/NON-VA CARE" DISP=2
.S:DISP="REMOVED/SCHEDULED-ASSIGNED" DISP=3
.S:DISP="REMOVED/VA CONTRACT CARE" DISP=4
.S:DISP="REMOVED/NO LONGER NECESSARY" DISP=5
.S:DISP="ENTERED IN ERROR" DISP=6
.S:DISP="TRANSFERRED TO EWL" DISP=7
.S:DISP="CHANGED CLINIC" DISP=8
.S:DISP="MRTC PARENT CLOSED" DISP=9
.S:DISP="REMOVED/EXTERNAL APP" DISP=10 ;* 745
.S:DISP="FAILURE TO RESPOND" DISP=11
.S:DISP="VET SELF-CANCEL" DISP=12
I $G(DISP)'="" D
.I '+DISP!((DISP<1)!(DISP>12)) D
..D 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),"^"," ")
;
Q:$D(SDERRORS) 0
Q ARIEN_"^"_DISP_"^"_DISPDT_"^"_PCMT
;
DISP(SDRETURN,ARIEN,DISP,DISPBY,DISPDT,PCMT,AUDITID) ;Disposition an appt req
N ARFDA,ARRET,ARMSG,X,MI,%DT,SDERR
S SDERR=0
S ARFDA=$NA(ARFDA(409.85,ARIEN_","))
S @ARFDA@(19)=DISPDT
S @ARFDA@(20)=DISPBY
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(.SDRETURN,47,$G(ARMSG("DIERR",MI,"TEXT",1)))
;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)
I '$G(SDERR) D EDITPCMT(ARIEN,PCMT)
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
;
UPDATEMRTCSEQNUM(PARENTREQUESTIEN,DFN) ;
N COUNT,REQUESTIEN,IENS,NEXTSEQUENCENUM,CHILD,LASTCHILD,FDA,ERR
S REQUESTIEN=0,COUNT=0,LASTCHILD=""
F S REQUESTIEN=$O(^SDEC(409.85,"B",DFN,REQUESTIEN)) Q:'REQUESTIEN D
.I $$GET1^DIQ(409.85,REQUESTIEN,43.8,"I")=PARENTREQUESTIEN D
..I $$GET1^DIQ(409.85,REQUESTIEN,23,"I")="C",'$$GET1^DIQ(409.85,REQUESTIEN,13,"I") Q
..S COUNT=COUNT+1
..S CHILD(REQUESTIEN)=COUNT
;
S REQUESTIEN=0
F S REQUESTIEN=$O(CHILD(REQUESTIEN)) Q:'REQUESTIEN D
.S FDA(409.85,REQUESTIEN_",",43.1)=$G(CHILD(REQUESTIEN))
.D FILE^DIE(,"FDA","ERR") ;K FDA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2ARCLOSE 5223 printed Apr 09, 2024@21:59:18 Page 2
SDES2ARCLOSE ;ALB/ANU/BLB - SDES2 DISPOSITION APPT REQ; DEC 06, 2023@02:00
+1 ;;5.3;Scheduling;**866,873**;Aug 13, 1993;Build 10
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ;
+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 ERRORS,SDRETURN,ARIEN,DISP,DISPBY,DISPDT,PCMT,PARAMETERS
+2 ;
+3 ; Validate SDCONTEXT
+4 ;
+5 DO VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
+6 IF $DATA(ERRORS)
SET ERRORS("ApptReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSON,.ERRORS)
QUIT
+7 ; Validate PARAMS
+8 SET PARAMETERS=$$VALPARAMS(.SDINPUT,.ERRORS)
+9 IF $DATA(ERRORS)
SET ERRORS("ApptReqDisposition",1)=""
DO BUILDJSON^SDES2JSON(.JSON,.ERRORS)
QUIT
+10 ;
+11 SET DISPBY=$SELECT(+$GET(SDCONTEXT("USER DUZ")):+SDCONTEXT("USER DUZ"),1:$GET(DUZ))
+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,DISPBY,DISPDT,PCMT,SDCONTEXT("ACHERON AUDIT ID"))
+14 ;
+15 IF $$GET1^DIQ(409.85,$GET(SDINPUT("REQUEST ID")),43.8,"I")
Begin DoDot:1
+16 DO UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,$GET(SDINPUT("REQUEST ID")),43.8,"I"),$$GET1^DIQ(409.85,$GET(SDINPUT("REQUEST ID")),.01,"I"))
End DoDot:1
+17 ;
+18 IF '$DATA(SDRETURN)
SET SDRETURN("ApptReqDisposition",1)=""
+19 DO BUILDJSON^SDES2JSON(.JSON,.SDRETURN)
+20 QUIT
+21 ;
VALPARAMS(PARAMS,SDERRORS) ; Validate
+1 NEW ARIEN,DISP,DISPBY,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 ; Re-mapped the Dispositions to their corresponding pointer value
+12 IF $GET(DISP)'=""
Begin DoDot:1
+13 if DISP="DEATH"
SET DISP=1
+14 if DISP="REMOVED/NON-VA CARE"
SET DISP=2
+15 if DISP="REMOVED/SCHEDULED-ASSIGNED"
SET DISP=3
+16 if DISP="REMOVED/VA CONTRACT CARE"
SET DISP=4
+17 if DISP="REMOVED/NO LONGER NECESSARY"
SET DISP=5
+18 if DISP="ENTERED IN ERROR"
SET DISP=6
+19 if DISP="TRANSFERRED TO EWL"
SET DISP=7
+20 if DISP="CHANGED CLINIC"
SET DISP=8
+21 if DISP="MRTC PARENT CLOSED"
SET DISP=9
+22 ;* 745
if DISP="REMOVED/EXTERNAL APP"
SET DISP=10
+23 if DISP="FAILURE TO RESPOND"
SET DISP=11
+24 if DISP="VET SELF-CANCEL"
SET DISP=12
End DoDot:1
+25 IF $GET(DISP)'=""
Begin DoDot:1
+26 IF '+DISP!((DISP<1)!(DISP>12))
Begin DoDot:2
+27 DO ERRLOG^SDESJSON(.SDERRORS,43)
End DoDot:2
End DoDot:1
+28 ;
+29 ; Validate DATE DISPOSITIONED
+30 SET DISPDT=$GET(PARAMS("DISPDT"))
+31 IF $GET(DISPDT)'=""
SET DISPDT=$$ISOTFM^SDAMUTDT(DISPDT)
Begin DoDot:1
+32 IF DISPDT=-1
DO ERRLOG^SDESJSON(.SDERRORS,55)
End DoDot:1
+33 IF $GET(DISPDT)=""
DO ERRLOG^SDESJSON(.SDERRORS,56)
+34 ;
+35 ; validate Patient-Entered comments
+36 SET PCMT=$GET(PARAMS("PCMT"))
+37 SET PCMT=$TRANSLATE($GET(PCMT),"^"," ")
+38 ;
+39 if $DATA(SDERRORS)
QUIT 0
+40 QUIT ARIEN_"^"_DISP_"^"_DISPDT_"^"_PCMT
+41 ;
DISP(SDRETURN,ARIEN,DISP,DISPBY,DISPDT,PCMT,AUDITID) ;Disposition an appt req
+1 NEW ARFDA,ARRET,ARMSG,X,MI,%DT,SDERR
+2 SET SDERR=0
+3 SET ARFDA=$NAME(ARFDA(409.85,ARIEN_","))
+4 SET @ARFDA@(19)=DISPDT
+5 SET @ARFDA@(20)=DISPBY
+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(.SDRETURN,47,$GET(ARMSG("DIERR",MI,"TEXT",1)))
End DoDot:1
+15 ;SEND HL7 TO CPRS IF RTC REQUEST
+16 IF '$GET(SDERR)
IF $PIECE(^SDEC(409.85,ARIEN,0),U,5)="RTC"
Begin DoDot:1
+17 IF DISP=3!(DISP=9)
DO ARDISP^SDECHL7(ARIEN,"")
+18 IF DISP'=3&(DISP'=9)
DO ARDISP^SDECHL7(ARIEN,1)
+19 IF $DATA(^TMP($JOB,"REJECT",ARIEN))
Begin DoDot:2
+20 SET SDERR=1
SET X=$GET(^TMP(SDHL7IN("ORDER IEN")))
+21 DO ERRLOG^SDESJSON(.SDRETURN,47,X)
End DoDot:2
End DoDot:1
+22 IF '$GET(SDERR)
DO EDITPCMT(ARIEN,PCMT)
+23 QUIT
+24 ;
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 ;
UPDATEMRTCSEQNUM(PARENTREQUESTIEN,DFN) ;
+1 NEW COUNT,REQUESTIEN,IENS,NEXTSEQUENCENUM,CHILD,LASTCHILD,FDA,ERR
+2 SET REQUESTIEN=0
SET COUNT=0
SET LASTCHILD=""
+3 FOR
SET REQUESTIEN=$ORDER(^SDEC(409.85,"B",DFN,REQUESTIEN))
if 'REQUESTIEN
QUIT
Begin DoDot:1
+4 IF $$GET1^DIQ(409.85,REQUESTIEN,43.8,"I")=PARENTREQUESTIEN
Begin DoDot:2
+5 IF $$GET1^DIQ(409.85,REQUESTIEN,23,"I")="C"
IF '$$GET1^DIQ(409.85,REQUESTIEN,13,"I")
QUIT
+6 SET COUNT=COUNT+1
+7 SET CHILD(REQUESTIEN)=COUNT
End DoDot:2
End DoDot:1
+8 ;
+9 SET REQUESTIEN=0
+10 FOR
SET REQUESTIEN=$ORDER(CHILD(REQUESTIEN))
if 'REQUESTIEN
QUIT
Begin DoDot:1
+11 SET FDA(409.85,REQUESTIEN_",",43.1)=$GET(CHILD(REQUESTIEN))
+12 ;K FDA
DO FILE^DIE(,"FDA","ERR")
End DoDot:1
+13 QUIT
+14 ;
