SDECAR ;ALB/SAT,MGD,KML,BLB,LAB - VISTA SCHEDULING RPCS ;Apr 21, 2023
;;5.3;Scheduling;**627,642,671,745,792,797,805,815,833,837,843**;Aug 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to OP^XQCHK in ICR #10078
Q
;
ARCLOSE(RET,INP) ;Appointment Request Close
;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP
; array. Allow EA as new disposition code.
;ARCLOSE(RET,S1,S2,S3,S4) external parameter tag in SDEC
; INP - Input parameters array
; INP(1) - Request ID - Pointer to SDEC APPT REQUEST file
; INP(2) - Disposition
; INP(3) - User Id - Pointer to NEW PERSON file
; INP(4) - Date Dispositioned in external form
N MI,ARDISP,ARDISPBY,ARDISPDT,ARFDA,ARIEN,ARMSG,ARRET,POP,XQOPT
S RET=$G(INP(1))_$C(30)
S POP=0
D OP^XQCHK
D:$P($G(XQOPT),U)'="SD RECEIVE OR" CHECKLOCK(.INP,.RET) Q:POP
;validate IEN
S ARIEN=$G(INP(1)) I ARIEN="" S RET="-1^Missing IEN"_$C(30,31) Q
;validate DISPOSITION
S ARDISP=$G(INP(2))
I ARDISP="" S RET="-1^Missing value for DISPOSITION"_$C(30,31) Q
;MC:MRTC PARENT CLOSED
; VSE-1220: Re-mapped the Dispositions to their corresponding pointer value
S:ARDISP="DEATH"!(ARDISP="D") ARDISP=1
S:ARDISP="REMOVED/NON-VA CARE"!(ARDISP="NC") ARDISP=2
S:ARDISP="REMOVED/SCHEDULED-ASSIGNED"!(ARDISP="SA") ARDISP=3
S:ARDISP="REMOVED/VA CONTRACT CARE"!(ARDISP="CC") ARDISP=4
S:ARDISP="REMOVED/NO LONGER NECESSARY"!(ARDISP="NN") ARDISP=5
S:ARDISP="ENTERED IN ERROR"!(ARDISP="ER") ARDISP=6
S:ARDISP="TRANSFERRED TO EWL"!(ARDISP="TR") ARDISP=7
S:ARDISP="CHANGED CLINIC"!(ARDISP="CL") ARDISP=8
S:ARDISP="MRTC PARENT CLOSED"!(ARDISP="MC") ARDISP=9
S:ARDISP="REMOVED/EXTERNAL APP"!(ARDISP="EA") ARDISP=10 ;* 745
S:ARDISP="FAILURE TO RESPOND" ARDISP=11
S:ARDISP="VET SELF-CANCEL" ARDISP=12
I '+ARDISP!((ARDISP<1)!(ARDISP>12)) D Q
.S RET="-1^Invalid value for DISPOSITION"_$C(30,31)
;validate DISPOSITIONED BY
S ARDISPBY=$G(INP(3),DUZ)
I '+ARDISPBY S ARDISPBY=$O(^VA(200,"B",ARDISPBY,0))
I '$D(^VA(200,+ARDISPBY,0)) S RET="-1^Invalid 'DISPOSITIONED BY' user"_$C(30,31) Q
;validate DATE DISPOSITIONED
S ARDISPDT=$G(INP(4),DT) I ARDISPDT'="" S %DT="" S X=ARDISPDT D ^%DT S ARDISPDT=Y
I Y=-1 S RET="-1^Invalid 'DATE DISPOSITIONED'"_$C(30,31) Q
S ARFDA=$NA(ARFDA($$FNUM,ARIEN_","))
S @ARFDA@(19)=ARDISPDT
S @ARFDA@(20)=ARDISPBY
S @ARFDA@(21)=ARDISP
S @ARFDA@(23)="C"
I $G(INP(5))'="" S @ARFDA@(22)=$$NETTOFM^SDECDATE($G(INP(5)),"N","N")
D UPDATE^DIE("","ARFDA","ARRET","ARMSG")
;
I $$GET1^DIQ(409.85,ARIEN,41,"I") D
.D UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,ARIEN,43.8,"I"),$$GET1^DIQ(409.85,ARIEN,.01,"I"))
;
I $D(ARMSG("DIERR")) D
. F MI=1:1:$G(ARMSG("DIERR")) S RET="-1^"_$G(ARMSG("DIERR",MI,"TEXT",1))_$C(30)
S RET=RET_$C(31)
I $D(ARMSG("DIERR")) Q
;SEND HL7 TO CPRS IF RTC REQUEST
I $P(^SDEC(409.85,ARIEN,0),U,5)="RTC" D
.I ARDISP=3 D ARDISP^SDECHL7(ARIEN,"")
.I ARDISP=9 D ARDISP^SDECHL7(ARIEN,"")
.I ARDISP'=3&(ARDISP'=9) D ARDISP^SDECHL7(ARIEN,1)
.I $D(^TMP($J,"REJECT",ARIEN)) D
..S RET="-2^"_^TMP(SDHL7IN("ORDER IEN"))
Q
;
AROPEN(RET,ARAPP,ARIEN,ARDDT) ;SET Appointment Request Open/re-open
;AROPEN(RET,ARAPP,ARIEN,ARDDT) external parameter tag in SDEC
;INPUT:
; ARAPP - (required if no ARIEN) Appointment ID pointer to SDEC APPOINTMENT file 409.84
; ARIEN - (required if no ARAPP) Request ID - Pointer to SDEC APPOINTMENT REQUEST file
; ARDDT - (optional) Desired Date of appointment in external format
N SDART,SDECI,SDQ,ARFDA,ARMSG,X,Y,%DT
S RET="^TMP(""SDECAR"","_$J_",""AROPEN"")"
K @RET
S (SDECI,SDQ)=0
S @RET@(SDECI)="T00030ERRORID^T00030ERRTEXT"_$C(30)
;validate ARAPP (required if ARIEN not passed it)
S ARAPP=$G(ARAPP)
I ARAPP'="" I $D(^SDEC(409.84,ARAPP,0)) D
.S SDART=$$GET1^DIQ(409.84,ARAPP_",",.22,"I")
.I $P(SDART,";",2)'="SDEC(409.85," S SDECI=SDECI+1 S @RET@(SDECI)="-1^Not a Requested appointment."_$C(30),SDQ=1 Q
.I $G(ARIEN)'="",ARIEN'=$P(SDART,";",1) S SDECI=SDECI+1 S @RET@(SDECI)="-1^Appointment Request does not match item passed in."_$C(30),SDQ=1 Q
.S ARIEN=$P(SDART,";",1)
G:SDQ ARX
;validate ARIEN
S ARIEN=$G(ARIEN)
I ARIEN="" S SDECI=SDECI+1 S @RET@(SDECI)="-1^Appointment Request ID or Appointment ID is required."_$C(30,31) Q
I '$D(^SDEC(409.85,ARIEN,0)) S SDECI=SDECI+1 S @RET@(SDECI)="-1^Invalid Appt Request ID."_$C(30,31) Q
;validate ARDDT
S ARDDT=$P($G(ARDDT),"@",1)
I $G(ARDDT)'="" S %DT="" S X=ARDDT D ^%DT I Y=-1 S SDECI=SDECI+1 S @RET@(SDECI)="-1^Invalid desired date of appointment."_$C(30,31) Q
S ARFDA=$NA(ARFDA(409.85,ARIEN_","))
S @ARFDA@(19)=""
S @ARFDA@(20)=""
S @ARFDA@(21)=""
S:ARDDT'="" @ARFDA@(22)=ARDDT
; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
N SDCANRSN,REOPENYN
S SDCANRSN=$$GET1^DIQ(409.84,ARAPP_",",.122,"I")
; 1 and null values re-open the appointment request
S REOPENYN=$$GET1^DIQ(409.2,SDCANRSN,5,"I")
I (REOPENYN="")!(REOPENYN=1) S @ARFDA@(23)="OPEN"
;I "^3^9^10^12^17^18^"'[(U_SDCANRSN_U) S @ARFDA@(23)="OPEN"
D UPDATE^DIE("E","ARFDA","ARRET","ARMSG")
;
I $$GET1^DIQ(409.85,ARIEN,41,"I") D
.D UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,ARIEN,43.8,"I"),$$GET1^DIQ(409.85,ARIEN,.01,"I"))
;
I $D(ARMSG("DIERR")) D
. F MI=1:1:$G(ARMSG("DIERR")) S SDECI=SDECI+1 S @RET@(SDECI)="-1^"_$G(ARMSG("DIERR",MI,"TEXT",1))_$C(30)
I '$D(ARMSG("DIERR")) S SDECI=SDECI+1 S @RET@(SDECI)="0^"_ARIEN_$C(30)
ARX S @RET@(SDECI)=@RET@(SDECI)_$C(31)
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
;
FNUM(RET) ;file number
S RET=409.85
Q RET
;
ARPCSET(SDECY,INP,ARIEN) ;SET update patient contacts in SDEC APPT REQUEST file
;ARSETPC(SDECY,INP,ARIEN) external parameter tag in SDEC
; INP = Patient Contacts separated by ::
; Each :: piece has the following ~~ pieces: (same as theyare passed into SDEC ARLSET)
; 1) = (required) DATE ENTERED external date/time
; 2) = (optional) PC ENTERED BY USER ID or NAME - Pointer to NEW PERSON file or NAME
; 4) = (optional) ACTION - valid values are:
; CALLED MESSAGE LEFT LETTER
; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
; 6) = NOT USED (optional) Comment 1-160 characters
; ARIEN = (required) pointer to SDEC APPT REQUEST file 409.85
N SDECI,SDTMP,ARMSG1
S SDECY="^TMP(""SDECAR"","_$J_",""ARSETPC"")"
K @SDECY
S SDECI=0
S @SDECY@(SDECI)="T00030RETURNCODE^T00030TEXT"_$C(30)
S ARIEN=$G(ARIEN)
I (ARIEN="")!('$D(^SDEC(409.85,ARIEN,0))) D ERR1^SDECERR(-1,"Invalid wait list ID "_ARIEN_".",SDECI,SDECY) Q
D AR23^SDECAR2(INP,ARIEN)
I $D(ARMSG1) D ERR1^SDECERR(-1,"Error storing patient contacts.",SDECI,SDECY) Q
S SDECI=SDECI+1 S @SDECY@(SDECI)="0^SUCCESS"_$C(30,31)
Q
;
ARDGET(SDECY) ;get values for disposition field of SDEC APPT REQUEST file
;ARDGET(SDECY) external parameter tag is in SDEC
;INPUT: none
;RETURN:
; Successful Return:
; Global array containing a list of the valid DISPOSITION values in which
; each array entry contains the disposition text.
; Caught Exception Return:
; A single entry in the Global Array in the format "-1^<error text>"
; "T00020RETURNCODE^T00100TEXT"
; Unexpected Exception Return:
; Handled by the RPC Broker.
; M errors are trapped by the use of M and Kernel error handling.
; The RPC execution stops and the RPC Broker sends the error generated
; text back to the client.
N SDI,SDX,SDXI,SDECI,DIERR,SDMSG
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
; data header
S @SDECY@(SDECI)="T00030TEXT"_$C(30)
S SDX=$$GET1^DID(409.85,21,"","POINTER","","MSG")
F SDI=1:1:$L(SDX,";") D
.S SDXI=$P(SDX,";",SDI)
.Q:SDXI=""
.S SDECI=SDECI+1 S @SDECY@(SDECI)=$P(SDXI,":",2)_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
;
ARMRTGET(SDECY,ARIEN) ;GET number of entries and values in MRTC CALC PREF DATES
;ARMRTGET(SDECY,ARIEN)
;INPUT:
; ARIEN - (required) pointer to SDEC APPT REQUEST file
;RETURN:
; 1st entry contains a count of the number of dates in MRTC CALC PREF DATES
; 2-n entry contains each date
N ARDATA,SDC,SDECI,SDI
S SDC=0
S SDECI=1 ;save position 1 for count in SDC
S SDECY="^TMP(""SDECAR"","_$J_",""ARMRTGET"")"
K @SDECY
; data header
S @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$C(30)
S ARIEN=$G(ARIEN)
I ARIEN="" S @SDECY@(1)="-1^SDEC APPT REQUEST id is required." Q
I '$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id." Q
D GETS^DIQ(409.85,+ARIEN,"43.5*","E","ARDATA")
S SDI=0 F S SDI=$O(ARDATA(409.851,SDI)) Q:SDI="" D
.S SDC=SDC+1
.S SDECI=SDECI+1 S @SDECY@(SDECI)=ARDATA(409.851,SDI,.01,"E")_$C(30)
S @SDECY@(1)=SDC_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
;
ARMULT(SDECY,ARIEN,MULT) ;SET MULT APPTS MADE multiple in SDEC APPT REQUEST file. All entries are removed and replaced by the values in MULT
;INPUT:
; ARIEN - (required) pointer to SDEC APPT REQUEST file (usualy a parent request)
; MULT - (optional) list of child pointers to SDEC APPOINTMENT and/or
; SDEC APPT REQUEST files separated by pipe
; each pipe piece contains the following ~ pieces:
; 1. (optional) Appointment Id pointer to SDEC APPOINTMENT
; file 409.84
; 2. (optional) Request Id pointer to SDEC APPT REQUEST
; file 409.85
;RETURN:
; ERRORCODE^MESSAGE
;
N MULT1,SDI
S SDECY="^TMP(""SDECAR"","_$J_",""ARMRTSET"")"
K @SDECY
; data header
S @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$C(30)
S ARIEN=$G(ARIEN)
I ARIEN="" S @SDECY@(1)="-1^SDEC APPT REQUEST id is required." Q
I '$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id." Q
S MULT=$G(MULT)
D MT1(ARIEN)
I MULT="" S @SDECY@(0)=@SDECY@(0)_$C(31) Q ;nothing to do
F SDI=1:1:$L(MULT,"|") D
.S MULT1=$TR($P(MULT,"|",SDI),"^","~")
.D AR433^SDECAR2(ARIEN,MULT1)
S @SDECY@(1)="0^SUCCESS"_$C(30,31)
Q
ARMRTSET(SDECY,ARIEN,MRTC) ;SET MRTC CALC PREF DATES dates - clears the multiple and sets the new ones that are passed into MRTC
;ARMRTSET(SDECY,ARIEN,MRTC)
;INPUT:
; ARIEN - (required) pointer to SDEC APPT REQUEST file
; MRTC - (optional) MRTC calculated preferred dates separated by pipe|:
; Each date can be in external format with no time.
;RETURN:
; ERRORCODE^MESSAGE
N SDI,MRTC1
S SDECY="^TMP(""SDECAR"","_$J_",""ARMRTSET"")"
K @SDECY
; data header
S @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$C(30)
S ARIEN=$G(ARIEN)
I ARIEN="" S @SDECY@(1)="-1^SDEC APPT REQUEST id is required." Q
I '$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id." Q
S MRTC=$G(MRTC)
I MRTC="" S @SDECY@(1)="0"_$C(30,31) Q ;not an error, just nothing to do
D MT(ARIEN)
D AR435^SDECAR2(MRTC,ARIEN)
S @SDECY@(1)="0"_$C(30,31)
Q
MT(ARIEN) ; clear out existing MRTC CALC PREF DATES
N DA,DIK,SDI
S SDI=0 F S SDI=$O(^SDEC(409.85,ARIEN,5,SDI)) Q:SDI'>0 D
.S DIK="^SDEC(409.85,"_ARIEN_",5,"
.S DA=SDI
.S DA(1)=ARIEN
.D ^DIK
Q
MT1(ARIEN) ; clear out existing MULT APPTS MADE
N DA,DIK,SDI
S SDI=0 F S SDI=$O(^SDEC(409.85,ARIEN,2,SDI)) Q:SDI'>0 D
.S DIK="^SDEC(409.85,"_ARIEN_",2,"
.S DA=SDI
.S DA(1)=ARIEN
.D ^DIK
Q
;
ARMRTC(RET,ARIEN) ;GET the number of MRTC appointments made for this request
;INPUT:
; ARIEN - (required) pointer to SDEC APPT REQUEST file 409.85
;RETURN
; Global array with 1 entry containing the count of appointments made under the COUNT header
N SDC,SDECI,SDI
S RET="^TMP(""SDECAR1"","_$J_",""ARMRTC"")"
K @RET
S (SDC,SDECI)=0
S ARIEN=$G(ARIEN)
I '$D(^SDEC(409.85,ARIEN,0)) S @RET@(1)="-1^Invalid ID"_$C(30,31) Q
S @RET@(SDECI)="T00030COUNT"_$C(30)
S @RET@(1)=$$MRTC(ARIEN)_$C(30,31)
Q
MRTC(ARIEN) ;
N SDC,SDI
S SDC=0
S SDI=0 F S SDI=$O(^SDEC(409.85,ARIEN,2,SDI)) Q:SDI'>0 D
.S SDC=SDC+1
Q SDC
;
ARAPPT(SDECY,SDAPPT) ;GET appointment request for given SDEC APPOINTMENT id
;INPUT:
; SDAPPT - (required) pointer to SDEC APPOINTMENT file 409.84
;RETURN
; Global array with 1 entry containing the REQUEST TYPE and IEN of the associated appointment separated by pipe |:
; 1. Request Type - A APPT
; C Consult
; E EWL
; R Recall
; 2. IEN - pointer to either the SDEC APPT REQUEST, REQUEST/CONSULTATION, SD WAIT LIST, or RECALL REMINDERS file
;
N SDECI,SDTYP,SDX,SDY
S SDECY="^TMP(""SDECAR"","_$J_",""ARAPPT"")"
K @SDECY
S SDECI=0
S @SDECY@(SDECI)="T00030SDAPTYP"_$C(30)
S SDAPPT=$G(SDAPPT)
I SDAPPT="" S @SDECY@(1)="-1^SDEC APPOINTMENT id is required."_$C(30,31) Q
I '$D(^SDEC(409.84,+SDAPPT,0)) S @SDECY@(1)="-1^Invalid SDEC APPOINTMENT ID."_$C(30,31) Q
S SDX=$$GET1^DIQ(409.84,SDAPPT_",",.22,"I")
S SDY=$P(SDX,";",2)
S SDTYP=$S(SDY="SDWL(409.3,":"E|",SDY="GMR(123,":"C|",SDY="SD(403.5,":"R|",SDY="SDEC(409.85,":"A|",1:"")_$P(SDX,";",1) ;appt request type
S SDECI=SDECI+1 S @SDECY@(SDECI)=SDTYP_$C(30,31)
Q
;
AUDITGET(SDECY,ARIEN) ;GET entries from VS AUDIT field of SDEC APPT REQUEST file 409.85
N ARDATA,SDECI,SDI,SDTMP,SDX
S SDECY="^TMP(""SDECAR"","_$J_",""AUDITGET"")"
K @SDECY
S SDECI=0
S SDTMP="T00030IEN^T00030ID^T00030DATE^T00030USERIEN^T00030USERNAME"
S SDTMP=SDTMP_"^T00030CLINIEN^T00030CLINNAME^T00030STOPIEN^T00030STOPNAME"
S @SDECY@(SDECI)=SDTMP_$C(30)
;validate ARIEN
S ARIEN=$G(ARIEN)
I '+$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id."_$C(30,31) Q
S SDI=0 F S SDI=$O(^SDEC(409.85,+ARIEN,6,SDI)) Q:SDI'>0 D
.K ARDATA
.D GETS^DIQ(409.8545,SDI_","_ARIEN_",","**","IE","ARDATA")
.S SDX="ARDATA(409.8545,"""_SDI_","_ARIEN_","")"
.S SDTMP=ARIEN_U_SDI_U_@SDX@(.01,"E")_U_@SDX@(1,"I")_U_@SDX@(1,"E")
.S SDTMP=SDTMP_U_@SDX@(2,"I")_U_@SDX@(2,"E")_U_@SDX@(3,"I")_U_@SDX@(3,"E")
.S SDECI=SDECI+1 S @SDECY@(SDECI)=SDTMP_$C(30)
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
;
CHECKLOCK(INP,RET) ;check lock
N REQTYP,RETURN
S RETURN=""
S REQTYP=$$GET1^DIQ(409.85,INP(1)_",",4,"I")
S DFN=$$GET1^DIQ(409.85,INP(1)_",",.01,"I")
S POP=$$ORDERLOCKCHECK^SDEC07C(REQTYP,INP(1),.RETURN,DFN)
S:POP RET="-1^RTC Order is locked by another user. Please try again later."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECAR 15028 printed Dec 13, 2024@02:51:42 Page 2
SDECAR ;ALB/SAT,MGD,KML,BLB,LAB - VISTA SCHEDULING RPCS ;Apr 21, 2023
+1 ;;5.3;Scheduling;**627,642,671,745,792,797,805,815,833,837,843**;Aug 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to OP^XQCHK in ICR #10078
+5 QUIT
+6 ;
ARCLOSE(RET,INP) ;Appointment Request Close
+1 ;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP
+2 ; array. Allow EA as new disposition code.
+3 ;ARCLOSE(RET,S1,S2,S3,S4) external parameter tag in SDEC
+4 ; INP - Input parameters array
+5 ; INP(1) - Request ID - Pointer to SDEC APPT REQUEST file
+6 ; INP(2) - Disposition
+7 ; INP(3) - User Id - Pointer to NEW PERSON file
+8 ; INP(4) - Date Dispositioned in external form
+9 NEW MI,ARDISP,ARDISPBY,ARDISPDT,ARFDA,ARIEN,ARMSG,ARRET,POP,XQOPT
+10 SET RET=$GET(INP(1))_$CHAR(30)
+11 SET POP=0
+12 DO OP^XQCHK
+13 if $PIECE($GET(XQOPT),U)'="SD RECEIVE OR"
DO CHECKLOCK(.INP,.RET)
if POP
QUIT
+14 ;validate IEN
+15 SET ARIEN=$GET(INP(1))
IF ARIEN=""
SET RET="-1^Missing IEN"_$CHAR(30,31)
QUIT
+16 ;validate DISPOSITION
+17 SET ARDISP=$GET(INP(2))
+18 IF ARDISP=""
SET RET="-1^Missing value for DISPOSITION"_$CHAR(30,31)
QUIT
+19 ;MC:MRTC PARENT CLOSED
+20 ; VSE-1220: Re-mapped the Dispositions to their corresponding pointer value
+21 if ARDISP="DEATH"!(ARDISP="D")
SET ARDISP=1
+22 if ARDISP="REMOVED/NON-VA CARE"!(ARDISP="NC")
SET ARDISP=2
+23 if ARDISP="REMOVED/SCHEDULED-ASSIGNED"!(ARDISP="SA")
SET ARDISP=3
+24 if ARDISP="REMOVED/VA CONTRACT CARE"!(ARDISP="CC")
SET ARDISP=4
+25 if ARDISP="REMOVED/NO LONGER NECESSARY"!(ARDISP="NN")
SET ARDISP=5
+26 if ARDISP="ENTERED IN ERROR"!(ARDISP="ER")
SET ARDISP=6
+27 if ARDISP="TRANSFERRED TO EWL"!(ARDISP="TR")
SET ARDISP=7
+28 if ARDISP="CHANGED CLINIC"!(ARDISP="CL")
SET ARDISP=8
+29 if ARDISP="MRTC PARENT CLOSED"!(ARDISP="MC")
SET ARDISP=9
+30 ;* 745
if ARDISP="REMOVED/EXTERNAL APP"!(ARDISP="EA")
SET ARDISP=10
+31 if ARDISP="FAILURE TO RESPOND"
SET ARDISP=11
+32 if ARDISP="VET SELF-CANCEL"
SET ARDISP=12
+33 IF '+ARDISP!((ARDISP<1)!(ARDISP>12))
Begin DoDot:1
+34 SET RET="-1^Invalid value for DISPOSITION"_$CHAR(30,31)
End DoDot:1
QUIT
+35 ;validate DISPOSITIONED BY
+36 SET ARDISPBY=$GET(INP(3),DUZ)
+37 IF '+ARDISPBY
SET ARDISPBY=$ORDER(^VA(200,"B",ARDISPBY,0))
+38 IF '$DATA(^VA(200,+ARDISPBY,0))
SET RET="-1^Invalid 'DISPOSITIONED BY' user"_$CHAR(30,31)
QUIT
+39 ;validate DATE DISPOSITIONED
+40 SET ARDISPDT=$GET(INP(4),DT)
IF ARDISPDT'=""
SET %DT=""
SET X=ARDISPDT
DO ^%DT
SET ARDISPDT=Y
+41 IF Y=-1
SET RET="-1^Invalid 'DATE DISPOSITIONED'"_$CHAR(30,31)
QUIT
+42 SET ARFDA=$NAME(ARFDA($$FNUM,ARIEN_","))
+43 SET @ARFDA@(19)=ARDISPDT
+44 SET @ARFDA@(20)=ARDISPBY
+45 SET @ARFDA@(21)=ARDISP
+46 SET @ARFDA@(23)="C"
+47 IF $GET(INP(5))'=""
SET @ARFDA@(22)=$$NETTOFM^SDECDATE($GET(INP(5)),"N","N")
+48 DO UPDATE^DIE("","ARFDA","ARRET","ARMSG")
+49 ;
+50 IF $$GET1^DIQ(409.85,ARIEN,41,"I")
Begin DoDot:1
+51 DO UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,ARIEN,43.8,"I"),$$GET1^DIQ(409.85,ARIEN,.01,"I"))
End DoDot:1
+52 ;
+53 IF $DATA(ARMSG("DIERR"))
Begin DoDot:1
+54 FOR MI=1:1:$GET(ARMSG("DIERR"))
SET RET="-1^"_$GET(ARMSG("DIERR",MI,"TEXT",1))_$CHAR(30)
End DoDot:1
+55 SET RET=RET_$CHAR(31)
+56 IF $DATA(ARMSG("DIERR"))
QUIT
+57 ;SEND HL7 TO CPRS IF RTC REQUEST
+58 IF $PIECE(^SDEC(409.85,ARIEN,0),U,5)="RTC"
Begin DoDot:1
+59 IF ARDISP=3
DO ARDISP^SDECHL7(ARIEN,"")
+60 IF ARDISP=9
DO ARDISP^SDECHL7(ARIEN,"")
+61 IF ARDISP'=3&(ARDISP'=9)
DO ARDISP^SDECHL7(ARIEN,1)
+62 IF $DATA(^TMP($JOB,"REJECT",ARIEN))
Begin DoDot:2
+63 SET RET="-2^"_^TMP(SDHL7IN("ORDER IEN"))
End DoDot:2
End DoDot:1
+64 QUIT
+65 ;
AROPEN(RET,ARAPP,ARIEN,ARDDT) ;SET Appointment Request Open/re-open
+1 ;AROPEN(RET,ARAPP,ARIEN,ARDDT) external parameter tag in SDEC
+2 ;INPUT:
+3 ; ARAPP - (required if no ARIEN) Appointment ID pointer to SDEC APPOINTMENT file 409.84
+4 ; ARIEN - (required if no ARAPP) Request ID - Pointer to SDEC APPOINTMENT REQUEST file
+5 ; ARDDT - (optional) Desired Date of appointment in external format
+6 NEW SDART,SDECI,SDQ,ARFDA,ARMSG,X,Y,%DT
+7 SET RET="^TMP(""SDECAR"","_$JOB_",""AROPEN"")"
+8 KILL @RET
+9 SET (SDECI,SDQ)=0
+10 SET @RET@(SDECI)="T00030ERRORID^T00030ERRTEXT"_$CHAR(30)
+11 ;validate ARAPP (required if ARIEN not passed it)
+12 SET ARAPP=$GET(ARAPP)
+13 IF ARAPP'=""
IF $DATA(^SDEC(409.84,ARAPP,0))
Begin DoDot:1
+14 SET SDART=$$GET1^DIQ(409.84,ARAPP_",",.22,"I")
+15 IF $PIECE(SDART,";",2)'="SDEC(409.85,"
SET SDECI=SDECI+1
SET @RET@(SDECI)="-1^Not a Requested appointment."_$CHAR(30)
SET SDQ=1
QUIT
+16 IF $GET(ARIEN)'=""
IF ARIEN'=$PIECE(SDART,";",1)
SET SDECI=SDECI+1
SET @RET@(SDECI)="-1^Appointment Request does not match item passed in."_$CHAR(30)
SET SDQ=1
QUIT
+17 SET ARIEN=$PIECE(SDART,";",1)
End DoDot:1
+18 if SDQ
GOTO ARX
+19 ;validate ARIEN
+20 SET ARIEN=$GET(ARIEN)
+21 IF ARIEN=""
SET SDECI=SDECI+1
SET @RET@(SDECI)="-1^Appointment Request ID or Appointment ID is required."_$CHAR(30,31)
QUIT
+22 IF '$DATA(^SDEC(409.85,ARIEN,0))
SET SDECI=SDECI+1
SET @RET@(SDECI)="-1^Invalid Appt Request ID."_$CHAR(30,31)
QUIT
+23 ;validate ARDDT
+24 SET ARDDT=$PIECE($GET(ARDDT),"@",1)
+25 IF $GET(ARDDT)'=""
SET %DT=""
SET X=ARDDT
DO ^%DT
IF Y=-1
SET SDECI=SDECI+1
SET @RET@(SDECI)="-1^Invalid desired date of appointment."_$CHAR(30,31)
QUIT
+26 SET ARFDA=$NAME(ARFDA(409.85,ARIEN_","))
+27 SET @ARFDA@(19)=""
+28 SET @ARFDA@(20)=""
+29 SET @ARFDA@(21)=""
+30 if ARDDT'=""
SET @ARFDA@(22)=ARDDT
+31 ; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
+32 NEW SDCANRSN,REOPENYN
+33 SET SDCANRSN=$$GET1^DIQ(409.84,ARAPP_",",.122,"I")
+34 ; 1 and null values re-open the appointment request
+35 SET REOPENYN=$$GET1^DIQ(409.2,SDCANRSN,5,"I")
+36 IF (REOPENYN="")!(REOPENYN=1)
SET @ARFDA@(23)="OPEN"
+37 ;I "^3^9^10^12^17^18^"'[(U_SDCANRSN_U) S @ARFDA@(23)="OPEN"
+38 DO UPDATE^DIE("E","ARFDA","ARRET","ARMSG")
+39 ;
+40 IF $$GET1^DIQ(409.85,ARIEN,41,"I")
Begin DoDot:1
+41 DO UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,ARIEN,43.8,"I"),$$GET1^DIQ(409.85,ARIEN,.01,"I"))
End DoDot:1
+42 ;
+43 IF $DATA(ARMSG("DIERR"))
Begin DoDot:1
+44 FOR MI=1:1:$GET(ARMSG("DIERR"))
SET SDECI=SDECI+1
SET @RET@(SDECI)="-1^"_$GET(ARMSG("DIERR",MI,"TEXT",1))_$CHAR(30)
End DoDot:1
+45 IF '$DATA(ARMSG("DIERR"))
SET SDECI=SDECI+1
SET @RET@(SDECI)="0^"_ARIEN_$CHAR(30)
ARX SET @RET@(SDECI)=@RET@(SDECI)_$CHAR(31)
+1 QUIT
+2 ;
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 ;
FNUM(RET) ;file number
+1 SET RET=409.85
+2 QUIT RET
+3 ;
ARPCSET(SDECY,INP,ARIEN) ;SET update patient contacts in SDEC APPT REQUEST file
+1 ;ARSETPC(SDECY,INP,ARIEN) external parameter tag in SDEC
+2 ; INP = Patient Contacts separated by ::
+3 ; Each :: piece has the following ~~ pieces: (same as theyare passed into SDEC ARLSET)
+4 ; 1) = (required) DATE ENTERED external date/time
+5 ; 2) = (optional) PC ENTERED BY USER ID or NAME - Pointer to NEW PERSON file or NAME
+6 ; 4) = (optional) ACTION - valid values are:
+7 ; CALLED MESSAGE LEFT LETTER
+8 ; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
+9 ; 6) = NOT USED (optional) Comment 1-160 characters
+10 ; ARIEN = (required) pointer to SDEC APPT REQUEST file 409.85
+11 NEW SDECI,SDTMP,ARMSG1
+12 SET SDECY="^TMP(""SDECAR"","_$JOB_",""ARSETPC"")"
+13 KILL @SDECY
+14 SET SDECI=0
+15 SET @SDECY@(SDECI)="T00030RETURNCODE^T00030TEXT"_$CHAR(30)
+16 SET ARIEN=$GET(ARIEN)
+17 IF (ARIEN="")!('$DATA(^SDEC(409.85,ARIEN,0)))
DO ERR1^SDECERR(-1,"Invalid wait list ID "_ARIEN_".",SDECI,SDECY)
QUIT
+18 DO AR23^SDECAR2(INP,ARIEN)
+19 IF $DATA(ARMSG1)
DO ERR1^SDECERR(-1,"Error storing patient contacts.",SDECI,SDECY)
QUIT
+20 SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^SUCCESS"_$CHAR(30,31)
+21 QUIT
+22 ;
ARDGET(SDECY) ;get values for disposition field of SDEC APPT REQUEST file
+1 ;ARDGET(SDECY) external parameter tag is in SDEC
+2 ;INPUT: none
+3 ;RETURN:
+4 ; Successful Return:
+5 ; Global array containing a list of the valid DISPOSITION values in which
+6 ; each array entry contains the disposition text.
+7 ; Caught Exception Return:
+8 ; A single entry in the Global Array in the format "-1^<error text>"
+9 ; "T00020RETURNCODE^T00100TEXT"
+10 ; Unexpected Exception Return:
+11 ; Handled by the RPC Broker.
+12 ; M errors are trapped by the use of M and Kernel error handling.
+13 ; The RPC execution stops and the RPC Broker sends the error generated
+14 ; text back to the client.
+15 NEW SDI,SDX,SDXI,SDECI,DIERR,SDMSG
+16 SET SDECI=0
+17 KILL ^TMP("SDEC",$JOB)
+18 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+19 ; data header
+20 SET @SDECY@(SDECI)="T00030TEXT"_$CHAR(30)
+21 SET SDX=$$GET1^DID(409.85,21,"","POINTER","","MSG")
+22 FOR SDI=1:1:$LENGTH(SDX,";")
Begin DoDot:1
+23 SET SDXI=$PIECE(SDX,";",SDI)
+24 if SDXI=""
QUIT
+25 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$PIECE(SDXI,":",2)_$CHAR(30)
End DoDot:1
+26 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+27 QUIT
+28 ;
ARMRTGET(SDECY,ARIEN) ;GET number of entries and values in MRTC CALC PREF DATES
+1 ;ARMRTGET(SDECY,ARIEN)
+2 ;INPUT:
+3 ; ARIEN - (required) pointer to SDEC APPT REQUEST file
+4 ;RETURN:
+5 ; 1st entry contains a count of the number of dates in MRTC CALC PREF DATES
+6 ; 2-n entry contains each date
+7 NEW ARDATA,SDC,SDECI,SDI
+8 SET SDC=0
+9 ;save position 1 for count in SDC
SET SDECI=1
+10 SET SDECY="^TMP(""SDECAR"","_$JOB_",""ARMRTGET"")"
+11 KILL @SDECY
+12 ; data header
+13 SET @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$CHAR(30)
+14 SET ARIEN=$GET(ARIEN)
+15 IF ARIEN=""
SET @SDECY@(1)="-1^SDEC APPT REQUEST id is required."
QUIT
+16 IF '$DATA(^SDEC(409.85,+ARIEN,0))
SET @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id."
QUIT
+17 DO GETS^DIQ(409.85,+ARIEN,"43.5*","E","ARDATA")
+18 SET SDI=0
FOR
SET SDI=$ORDER(ARDATA(409.851,SDI))
if SDI=""
QUIT
Begin DoDot:1
+19 SET SDC=SDC+1
+20 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=ARDATA(409.851,SDI,.01,"E")_$CHAR(30)
End DoDot:1
+21 SET @SDECY@(1)=SDC_$CHAR(30)
+22 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+23 QUIT
+24 ;
ARMULT(SDECY,ARIEN,MULT) ;SET MULT APPTS MADE multiple in SDEC APPT REQUEST file. All entries are removed and replaced by the values in MULT
+1 ;INPUT:
+2 ; ARIEN - (required) pointer to SDEC APPT REQUEST file (usualy a parent request)
+3 ; MULT - (optional) list of child pointers to SDEC APPOINTMENT and/or
+4 ; SDEC APPT REQUEST files separated by pipe
+5 ; each pipe piece contains the following ~ pieces:
+6 ; 1. (optional) Appointment Id pointer to SDEC APPOINTMENT
+7 ; file 409.84
+8 ; 2. (optional) Request Id pointer to SDEC APPT REQUEST
+9 ; file 409.85
+10 ;RETURN:
+11 ; ERRORCODE^MESSAGE
+12 ;
+13 NEW MULT1,SDI
+14 SET SDECY="^TMP(""SDECAR"","_$JOB_",""ARMRTSET"")"
+15 KILL @SDECY
+16 ; data header
+17 SET @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$CHAR(30)
+18 SET ARIEN=$GET(ARIEN)
+19 IF ARIEN=""
SET @SDECY@(1)="-1^SDEC APPT REQUEST id is required."
QUIT
+20 IF '$DATA(^SDEC(409.85,+ARIEN,0))
SET @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id."
QUIT
+21 SET MULT=$GET(MULT)
+22 DO MT1(ARIEN)
+23 ;nothing to do
IF MULT=""
SET @SDECY@(0)=@SDECY@(0)_$CHAR(31)
QUIT
+24 FOR SDI=1:1:$LENGTH(MULT,"|")
Begin DoDot:1
+25 SET MULT1=$TRANSLATE($PIECE(MULT,"|",SDI),"^","~")
+26 DO AR433^SDECAR2(ARIEN,MULT1)
End DoDot:1
+27 SET @SDECY@(1)="0^SUCCESS"_$CHAR(30,31)
+28 QUIT
ARMRTSET(SDECY,ARIEN,MRTC) ;SET MRTC CALC PREF DATES dates - clears the multiple and sets the new ones that are passed into MRTC
+1 ;ARMRTSET(SDECY,ARIEN,MRTC)
+2 ;INPUT:
+3 ; ARIEN - (required) pointer to SDEC APPT REQUEST file
+4 ; MRTC - (optional) MRTC calculated preferred dates separated by pipe|:
+5 ; Each date can be in external format with no time.
+6 ;RETURN:
+7 ; ERRORCODE^MESSAGE
+8 NEW SDI,MRTC1
+9 SET SDECY="^TMP(""SDECAR"","_$JOB_",""ARMRTSET"")"
+10 KILL @SDECY
+11 ; data header
+12 SET @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$CHAR(30)
+13 SET ARIEN=$GET(ARIEN)
+14 IF ARIEN=""
SET @SDECY@(1)="-1^SDEC APPT REQUEST id is required."
QUIT
+15 IF '$DATA(^SDEC(409.85,+ARIEN,0))
SET @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id."
QUIT
+16 SET MRTC=$GET(MRTC)
+17 ;not an error, just nothing to do
IF MRTC=""
SET @SDECY@(1)="0"_$CHAR(30,31)
QUIT
+18 DO MT(ARIEN)
+19 DO AR435^SDECAR2(MRTC,ARIEN)
+20 SET @SDECY@(1)="0"_$CHAR(30,31)
+21 QUIT
MT(ARIEN) ; clear out existing MRTC CALC PREF DATES
+1 NEW DA,DIK,SDI
+2 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.85,ARIEN,5,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+3 SET DIK="^SDEC(409.85,"_ARIEN_",5,"
+4 SET DA=SDI
+5 SET DA(1)=ARIEN
+6 DO ^DIK
End DoDot:1
+7 QUIT
MT1(ARIEN) ; clear out existing MULT APPTS MADE
+1 NEW DA,DIK,SDI
+2 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.85,ARIEN,2,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+3 SET DIK="^SDEC(409.85,"_ARIEN_",2,"
+4 SET DA=SDI
+5 SET DA(1)=ARIEN
+6 DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
ARMRTC(RET,ARIEN) ;GET the number of MRTC appointments made for this request
+1 ;INPUT:
+2 ; ARIEN - (required) pointer to SDEC APPT REQUEST file 409.85
+3 ;RETURN
+4 ; Global array with 1 entry containing the count of appointments made under the COUNT header
+5 NEW SDC,SDECI,SDI
+6 SET RET="^TMP(""SDECAR1"","_$JOB_",""ARMRTC"")"
+7 KILL @RET
+8 SET (SDC,SDECI)=0
+9 SET ARIEN=$GET(ARIEN)
+10 IF '$DATA(^SDEC(409.85,ARIEN,0))
SET @RET@(1)="-1^Invalid ID"_$CHAR(30,31)
QUIT
+11 SET @RET@(SDECI)="T00030COUNT"_$CHAR(30)
+12 SET @RET@(1)=$$MRTC(ARIEN)_$CHAR(30,31)
+13 QUIT
MRTC(ARIEN) ;
+1 NEW SDC,SDI
+2 SET SDC=0
+3 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.85,ARIEN,2,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 SET SDC=SDC+1
End DoDot:1
+5 QUIT SDC
+6 ;
ARAPPT(SDECY,SDAPPT) ;GET appointment request for given SDEC APPOINTMENT id
+1 ;INPUT:
+2 ; SDAPPT - (required) pointer to SDEC APPOINTMENT file 409.84
+3 ;RETURN
+4 ; Global array with 1 entry containing the REQUEST TYPE and IEN of the associated appointment separated by pipe |:
+5 ; 1. Request Type - A APPT
+6 ; C Consult
+7 ; E EWL
+8 ; R Recall
+9 ; 2. IEN - pointer to either the SDEC APPT REQUEST, REQUEST/CONSULTATION, SD WAIT LIST, or RECALL REMINDERS file
+10 ;
+11 NEW SDECI,SDTYP,SDX,SDY
+12 SET SDECY="^TMP(""SDECAR"","_$JOB_",""ARAPPT"")"
+13 KILL @SDECY
+14 SET SDECI=0
+15 SET @SDECY@(SDECI)="T00030SDAPTYP"_$CHAR(30)
+16 SET SDAPPT=$GET(SDAPPT)
+17 IF SDAPPT=""
SET @SDECY@(1)="-1^SDEC APPOINTMENT id is required."_$CHAR(30,31)
QUIT
+18 IF '$DATA(^SDEC(409.84,+SDAPPT,0))
SET @SDECY@(1)="-1^Invalid SDEC APPOINTMENT ID."_$CHAR(30,31)
QUIT
+19 SET SDX=$$GET1^DIQ(409.84,SDAPPT_",",.22,"I")
+20 SET SDY=$PIECE(SDX,";",2)
+21 ;appt request type
SET SDTYP=$SELECT(SDY="SDWL(409.3,":"E|",SDY="GMR(123,":"C|",SDY="SD(403.5,":"R|",SDY="SDEC(409.85,":"A|",1:"")_$PIECE(SDX,";",1)
+22 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=SDTYP_$CHAR(30,31)
+23 QUIT
+24 ;
AUDITGET(SDECY,ARIEN) ;GET entries from VS AUDIT field of SDEC APPT REQUEST file 409.85
+1 NEW ARDATA,SDECI,SDI,SDTMP,SDX
+2 SET SDECY="^TMP(""SDECAR"","_$JOB_",""AUDITGET"")"
+3 KILL @SDECY
+4 SET SDECI=0
+5 SET SDTMP="T00030IEN^T00030ID^T00030DATE^T00030USERIEN^T00030USERNAME"
+6 SET SDTMP=SDTMP_"^T00030CLINIEN^T00030CLINNAME^T00030STOPIEN^T00030STOPNAME"
+7 SET @SDECY@(SDECI)=SDTMP_$CHAR(30)
+8 ;validate ARIEN
+9 SET ARIEN=$GET(ARIEN)
+10 IF '+$DATA(^SDEC(409.85,+ARIEN,0))
SET @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id."_$CHAR(30,31)
QUIT
+11 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.85,+ARIEN,6,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+12 KILL ARDATA
+13 DO GETS^DIQ(409.8545,SDI_","_ARIEN_",","**","IE","ARDATA")
+14 SET SDX="ARDATA(409.8545,"""_SDI_","_ARIEN_","")"
+15 SET SDTMP=ARIEN_U_SDI_U_@SDX@(.01,"E")_U_@SDX@(1,"I")_U_@SDX@(1,"E")
+16 SET SDTMP=SDTMP_U_@SDX@(2,"I")_U_@SDX@(2,"E")_U_@SDX@(3,"I")_U_@SDX@(3,"E")
+17 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=SDTMP_$CHAR(30)
End DoDot:1
+18 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+19 QUIT
+20 ;
CHECKLOCK(INP,RET) ;check lock
+1 NEW REQTYP,RETURN
+2 SET RETURN=""
+3 SET REQTYP=$$GET1^DIQ(409.85,INP(1)_",",4,"I")
+4 SET DFN=$$GET1^DIQ(409.85,INP(1)_",",.01,"I")
+5 SET POP=$$ORDERLOCKCHECK^SDEC07C(REQTYP,INP(1),.RETURN,DFN)
+6 if POP
SET RET="-1^RTC Order is locked by another user. Please try again later."
+7 QUIT
