Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDESARCLOSE

SDESARCLOSE.m

Go to the documentation of this file.
SDESARCLOSE ;ALB/BLB,KML,MGD,DJS - VISTA SCHEDULING RPCS ;Sep 05, 2022
 ;;5.3;Scheduling;**794,799,805,809,815,818,819,820,825**;Aug 13, 1993;Build 2
 ;;Per VHA Directive 6402, this routine should not be modified
 ; Reference to ^DPT(DFN,0) in ICR #10035
 ;
DISPOSITION(RETURN,ARIEN,DISP,DISPBY,DISPDT,EASTRCKNGNMBR,PCMT) ;Disposition an appt req
 ;Input
 ;     IEN - Request ID - Pointer to SDEC APPT REQUEST file
 ;     DISP - Disposition
 ;     DISPBY - User Id - Pointer to NEW PERSON file
 ;     DISPDT - Date Dispositioned in external form (e.g.,CCYY-MM-DD)
 ;     EASTRCKNGNMBR - (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
 ;     PCMT - (optional) patient-entered comments from VAOS
 N SDAPTREQ,POP,ARFDA,ARRET,ARMSG,X,MI,%DT
 I $G(ARIEN)="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,3)
 I $G(ARIEN)'="",'$D(^SDEC(409.85,ARIEN)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,4)
 I $G(DISP)="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,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
 ..S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,43)
 ;validate DISPOSITIONED BY
 I $G(DISPBY)="" D
 .S DISPBY=$S(+$G(DUZ):DUZ,1:$$FIND1^DIC(200,"","X","SDESOITEAS,SRV","B"))
 .I $G(DISPBY)="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,269)   ;VSE-3761 new error message
 I $G(DISPBY)'="",'$D(^VA(200,+DISPBY,0)) S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,268)   ;VSE-3761 new error message
 ;validate DATE DISPOSITIONED
 I $G(DISPDT)'="" S DISPDT=$$ISOTFM^SDAMUTDT(DISPDT) D  ;VSE-2396
 .I DISPDT=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,55)
 I $G(DISPDT)="" S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,56)
 ;validate EAS Tracking Number
 S EASTRCKNGNMBR=$TR($G(EASTRCKNGNMBR),"^"," ")
 I $L(EASTRCKNGNMBR) S EASTRCKNGNMBR=$$EASVALIDATE^SDESUTIL(EASTRCKNGNMBR)
 I EASTRCKNGNMBR=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPTREQ,142)
 ; validate Patient-Entered comments
 S PCMT=$TR($G(PCMT),"^"," ")
 I $G(POP) S SDAPTREQ("ApptReqDisposition",1)=""
 ;
 I '$G(POP) D
 .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)=EASTRCKNGNMBR
 .D UPDATE^DIE("","ARFDA","ARRET","ARMSG")
 .I '$D(ARMSG) D
 ..S SDAPTREQ("ApptReqDisposition","FilingSuccess")=1
 .I $D(ARMSG("DIERR")) D
 ..S POP=1
 ..F MI=1:1:$G(ARMSG("DIERR")) D ERRLOG^SDESJSON(.SDAPTREQ,47,$G(ARMSG("DIERR",MI,"TEXT",1)))
 .;SEND HL7 TO CPRS IF RTC REQUEST
 .I '$G(POP),$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 POP=1,X=$G(^TMP(SDHL7IN("ORDER IEN")))
 ...D ERRLOG^SDESJSON(.SDAPTREQ,47,X)
 .I '$G(POP) D EDITPCMT(ARIEN,PCMT)
 D BUILDER
 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
 ;
BUILDER ;Convert data to JSON
 N JSONERR
 S JSONERR=""
 D ENCODE^SDESJSON(.SDAPTREQ,.RETURN,.JSONERR)
 Q