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

SDECAR.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. ; Reference to OP^XQCHK in ICR #10078
  1. Q
  1. ;
  1. 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
  1. ; array. Allow EA as new disposition code.
  1. ;ARCLOSE(RET,S1,S2,S3,S4) external parameter tag in SDEC
  1. ; INP - Input parameters array
  1. ; INP(1) - Request ID - Pointer to SDEC APPT REQUEST file
  1. ; INP(2) - Disposition
  1. ; INP(3) - User Id - Pointer to NEW PERSON file
  1. ; INP(4) - Date Dispositioned in external form
  1. N MI,ARDISP,ARDISPBY,ARDISPDT,ARFDA,ARIEN,ARMSG,ARRET,POP,XQOPT
  1. S RET=$G(INP(1))_$C(30)
  1. S POP=0
  1. D OP^XQCHK
  1. D:$P($G(XQOPT),U)'="SD RECEIVE OR" CHECKLOCK(.INP,.RET) Q:POP
  1. ;validate IEN
  1. S ARIEN=$G(INP(1)) I ARIEN="" S RET="-1^Missing IEN"_$C(30,31) Q
  1. ;validate DISPOSITION
  1. S ARDISP=$G(INP(2))
  1. I ARDISP="" S RET="-1^Missing value for DISPOSITION"_$C(30,31) Q
  1. ;MC:MRTC PARENT CLOSED
  1. ; VSE-1220: Re-mapped the Dispositions to their corresponding pointer value
  1. S:ARDISP="DEATH"!(ARDISP="D") ARDISP=1
  1. S:ARDISP="REMOVED/NON-VA CARE"!(ARDISP="NC") ARDISP=2
  1. S:ARDISP="REMOVED/SCHEDULED-ASSIGNED"!(ARDISP="SA") ARDISP=3
  1. S:ARDISP="REMOVED/VA CONTRACT CARE"!(ARDISP="CC") ARDISP=4
  1. S:ARDISP="REMOVED/NO LONGER NECESSARY"!(ARDISP="NN") ARDISP=5
  1. S:ARDISP="ENTERED IN ERROR"!(ARDISP="ER") ARDISP=6
  1. S:ARDISP="TRANSFERRED TO EWL"!(ARDISP="TR") ARDISP=7
  1. S:ARDISP="CHANGED CLINIC"!(ARDISP="CL") ARDISP=8
  1. S:ARDISP="MRTC PARENT CLOSED"!(ARDISP="MC") ARDISP=9
  1. S:ARDISP="REMOVED/EXTERNAL APP"!(ARDISP="EA") ARDISP=10 ;* 745
  1. S:ARDISP="FAILURE TO RESPOND" ARDISP=11
  1. S:ARDISP="VET SELF-CANCEL" ARDISP=12
  1. I '+ARDISP!((ARDISP<1)!(ARDISP>12)) D Q
  1. .S RET="-1^Invalid value for DISPOSITION"_$C(30,31)
  1. ;validate DISPOSITIONED BY
  1. S ARDISPBY=$G(INP(3),DUZ)
  1. I '+ARDISPBY S ARDISPBY=$O(^VA(200,"B",ARDISPBY,0))
  1. I '$D(^VA(200,+ARDISPBY,0)) S RET="-1^Invalid 'DISPOSITIONED BY' user"_$C(30,31) Q
  1. ;validate DATE DISPOSITIONED
  1. S ARDISPDT=$G(INP(4),DT) I ARDISPDT'="" S %DT="" S X=ARDISPDT D ^%DT S ARDISPDT=Y
  1. I Y=-1 S RET="-1^Invalid 'DATE DISPOSITIONED'"_$C(30,31) Q
  1. S ARFDA=$NA(ARFDA($$FNUM,ARIEN_","))
  1. S @ARFDA@(19)=ARDISPDT
  1. S @ARFDA@(20)=ARDISPBY
  1. S @ARFDA@(21)=ARDISP
  1. S @ARFDA@(23)="C"
  1. I $G(INP(5))'="" S @ARFDA@(22)=$$NETTOFM^SDECDATE($G(INP(5)),"N","N")
  1. D UPDATE^DIE("","ARFDA","ARRET","ARMSG")
  1. ;
  1. I $$GET1^DIQ(409.85,ARIEN,41,"I") D
  1. .D UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,ARIEN,43.8,"I"),$$GET1^DIQ(409.85,ARIEN,.01,"I"))
  1. ;
  1. I $D(ARMSG("DIERR")) D
  1. . F MI=1:1:$G(ARMSG("DIERR")) S RET="-1^"_$G(ARMSG("DIERR",MI,"TEXT",1))_$C(30)
  1. S RET=RET_$C(31)
  1. I $D(ARMSG("DIERR")) Q
  1. ;SEND HL7 TO CPRS IF RTC REQUEST
  1. I $P(^SDEC(409.85,ARIEN,0),U,5)="RTC" D
  1. .I ARDISP=3 D ARDISP^SDECHL7(ARIEN,"")
  1. .I ARDISP=9 D ARDISP^SDECHL7(ARIEN,"")
  1. .I ARDISP'=3&(ARDISP'=9) D ARDISP^SDECHL7(ARIEN,1)
  1. .I $D(^TMP($J,"REJECT",ARIEN)) D
  1. ..S RET="-2^"_^TMP(SDHL7IN("ORDER IEN"))
  1. Q
  1. ;
  1. AROPEN(RET,ARAPP,ARIEN,ARDDT) ;SET Appointment Request Open/re-open
  1. ;AROPEN(RET,ARAPP,ARIEN,ARDDT) external parameter tag in SDEC
  1. ;INPUT:
  1. ; ARAPP - (required if no ARIEN) Appointment ID pointer to SDEC APPOINTMENT file 409.84
  1. ; ARIEN - (required if no ARAPP) Request ID - Pointer to SDEC APPOINTMENT REQUEST file
  1. ; ARDDT - (optional) Desired Date of appointment in external format
  1. N SDART,SDECI,SDQ,ARFDA,ARMSG,X,Y,%DT
  1. S RET="^TMP(""SDECAR"","_$J_",""AROPEN"")"
  1. K @RET
  1. S (SDECI,SDQ)=0
  1. S @RET@(SDECI)="T00030ERRORID^T00030ERRTEXT"_$C(30)
  1. ;validate ARAPP (required if ARIEN not passed it)
  1. S ARAPP=$G(ARAPP)
  1. I ARAPP'="" I $D(^SDEC(409.84,ARAPP,0)) D
  1. .S SDART=$$GET1^DIQ(409.84,ARAPP_",",.22,"I")
  1. .I $P(SDART,";",2)'="SDEC(409.85," S SDECI=SDECI+1 S @RET@(SDECI)="-1^Not a Requested appointment."_$C(30),SDQ=1 Q
  1. .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
  1. .S ARIEN=$P(SDART,";",1)
  1. G:SDQ ARX
  1. ;validate ARIEN
  1. S ARIEN=$G(ARIEN)
  1. I ARIEN="" S SDECI=SDECI+1 S @RET@(SDECI)="-1^Appointment Request ID or Appointment ID is required."_$C(30,31) Q
  1. I '$D(^SDEC(409.85,ARIEN,0)) S SDECI=SDECI+1 S @RET@(SDECI)="-1^Invalid Appt Request ID."_$C(30,31) Q
  1. ;validate ARDDT
  1. S ARDDT=$P($G(ARDDT),"@",1)
  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
  1. S ARFDA=$NA(ARFDA(409.85,ARIEN_","))
  1. S @ARFDA@(19)=""
  1. S @ARFDA@(20)=""
  1. S @ARFDA@(21)=""
  1. S:ARDDT'="" @ARFDA@(22)=ARDDT
  1. ; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
  1. N SDCANRSN,REOPENYN
  1. S SDCANRSN=$$GET1^DIQ(409.84,ARAPP_",",.122,"I")
  1. ; 1 and null values re-open the appointment request
  1. S REOPENYN=$$GET1^DIQ(409.2,SDCANRSN,5,"I")
  1. I (REOPENYN="")!(REOPENYN=1) S @ARFDA@(23)="OPEN"
  1. ;I "^3^9^10^12^17^18^"'[(U_SDCANRSN_U) S @ARFDA@(23)="OPEN"
  1. D UPDATE^DIE("E","ARFDA","ARRET","ARMSG")
  1. ;
  1. I $$GET1^DIQ(409.85,ARIEN,41,"I") D
  1. .D UPDATEMRTCSEQNUM($$GET1^DIQ(409.85,ARIEN,43.8,"I"),$$GET1^DIQ(409.85,ARIEN,.01,"I"))
  1. ;
  1. I $D(ARMSG("DIERR")) D
  1. . F MI=1:1:$G(ARMSG("DIERR")) S SDECI=SDECI+1 S @RET@(SDECI)="-1^"_$G(ARMSG("DIERR",MI,"TEXT",1))_$C(30)
  1. I '$D(ARMSG("DIERR")) S SDECI=SDECI+1 S @RET@(SDECI)="0^"_ARIEN_$C(30)
  1. ARX S @RET@(SDECI)=@RET@(SDECI)_$C(31)
  1. Q
  1. ;
  1. UPDATEMRTCSEQNUM(PARENTREQUESTIEN,DFN) ;
  1. N COUNT,REQUESTIEN,IENS,NEXTSEQUENCENUM,CHILD,LASTCHILD,FDA,ERR
  1. S REQUESTIEN=0,COUNT=0,LASTCHILD=""
  1. F S REQUESTIEN=$O(^SDEC(409.85,"B",DFN,REQUESTIEN)) Q:'REQUESTIEN D
  1. .I $$GET1^DIQ(409.85,REQUESTIEN,43.8,"I")=PARENTREQUESTIEN D
  1. ..I $$GET1^DIQ(409.85,REQUESTIEN,23,"I")="C",'$$GET1^DIQ(409.85,REQUESTIEN,13,"I") Q
  1. ..S COUNT=COUNT+1
  1. ..S CHILD(REQUESTIEN)=COUNT
  1. ;
  1. S REQUESTIEN=0
  1. F S REQUESTIEN=$O(CHILD(REQUESTIEN)) Q:'REQUESTIEN D
  1. .S FDA(409.85,REQUESTIEN_",",43.1)=$G(CHILD(REQUESTIEN))
  1. .D FILE^DIE(,"FDA","ERR") ;K FDA
  1. Q
  1. ;
  1. FNUM(RET) ;file number
  1. S RET=409.85
  1. Q RET
  1. ;
  1. ARPCSET(SDECY,INP,ARIEN) ;SET update patient contacts in SDEC APPT REQUEST file
  1. ;ARSETPC(SDECY,INP,ARIEN) external parameter tag in SDEC
  1. ; INP = Patient Contacts separated by ::
  1. ; Each :: piece has the following ~~ pieces: (same as theyare passed into SDEC ARLSET)
  1. ; 1) = (required) DATE ENTERED external date/time
  1. ; 2) = (optional) PC ENTERED BY USER ID or NAME - Pointer to NEW PERSON file or NAME
  1. ; 4) = (optional) ACTION - valid values are:
  1. ; CALLED MESSAGE LEFT LETTER
  1. ; 5) = (optional) PATIENT PHONE Free-Text 4-20 characters
  1. ; 6) = NOT USED (optional) Comment 1-160 characters
  1. ; ARIEN = (required) pointer to SDEC APPT REQUEST file 409.85
  1. N SDECI,SDTMP,ARMSG1
  1. S SDECY="^TMP(""SDECAR"","_$J_",""ARSETPC"")"
  1. K @SDECY
  1. S SDECI=0
  1. S @SDECY@(SDECI)="T00030RETURNCODE^T00030TEXT"_$C(30)
  1. S ARIEN=$G(ARIEN)
  1. I (ARIEN="")!('$D(^SDEC(409.85,ARIEN,0))) D ERR1^SDECERR(-1,"Invalid wait list ID "_ARIEN_".",SDECI,SDECY) Q
  1. D AR23^SDECAR2(INP,ARIEN)
  1. I $D(ARMSG1) D ERR1^SDECERR(-1,"Error storing patient contacts.",SDECI,SDECY) Q
  1. S SDECI=SDECI+1 S @SDECY@(SDECI)="0^SUCCESS"_$C(30,31)
  1. Q
  1. ;
  1. ARDGET(SDECY) ;get values for disposition field of SDEC APPT REQUEST file
  1. ;ARDGET(SDECY) external parameter tag is in SDEC
  1. ;INPUT: none
  1. ;RETURN:
  1. ; Successful Return:
  1. ; Global array containing a list of the valid DISPOSITION values in which
  1. ; each array entry contains the disposition text.
  1. ; Caught Exception Return:
  1. ; A single entry in the Global Array in the format "-1^<error text>"
  1. ; "T00020RETURNCODE^T00100TEXT"
  1. ; Unexpected Exception Return:
  1. ; Handled by the RPC Broker.
  1. ; M errors are trapped by the use of M and Kernel error handling.
  1. ; The RPC execution stops and the RPC Broker sends the error generated
  1. ; text back to the client.
  1. N SDI,SDX,SDXI,SDECI,DIERR,SDMSG
  1. S SDECI=0
  1. K ^TMP("SDEC",$J)
  1. S SDECY="^TMP(""SDEC"","_$J_")"
  1. ; data header
  1. S @SDECY@(SDECI)="T00030TEXT"_$C(30)
  1. S SDX=$$GET1^DID(409.85,21,"","POINTER","","MSG")
  1. F SDI=1:1:$L(SDX,";") D
  1. .S SDXI=$P(SDX,";",SDI)
  1. .Q:SDXI=""
  1. .S SDECI=SDECI+1 S @SDECY@(SDECI)=$P(SDXI,":",2)_$C(30)
  1. S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
  1. Q
  1. ;
  1. ARMRTGET(SDECY,ARIEN) ;GET number of entries and values in MRTC CALC PREF DATES
  1. ;ARMRTGET(SDECY,ARIEN)
  1. ;INPUT:
  1. ; ARIEN - (required) pointer to SDEC APPT REQUEST file
  1. ;RETURN:
  1. ; 1st entry contains a count of the number of dates in MRTC CALC PREF DATES
  1. ; 2-n entry contains each date
  1. N ARDATA,SDC,SDECI,SDI
  1. S SDC=0
  1. S SDECI=1 ;save position 1 for count in SDC
  1. S SDECY="^TMP(""SDECAR"","_$J_",""ARMRTGET"")"
  1. K @SDECY
  1. ; data header
  1. S @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$C(30)
  1. S ARIEN=$G(ARIEN)
  1. I ARIEN="" S @SDECY@(1)="-1^SDEC APPT REQUEST id is required." Q
  1. I '$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id." Q
  1. D GETS^DIQ(409.85,+ARIEN,"43.5*","E","ARDATA")
  1. S SDI=0 F S SDI=$O(ARDATA(409.851,SDI)) Q:SDI="" D
  1. .S SDC=SDC+1
  1. .S SDECI=SDECI+1 S @SDECY@(SDECI)=ARDATA(409.851,SDI,.01,"E")_$C(30)
  1. S @SDECY@(1)=SDC_$C(30)
  1. S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
  1. Q
  1. ;
  1. 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:
  1. ; ARIEN - (required) pointer to SDEC APPT REQUEST file (usualy a parent request)
  1. ; MULT - (optional) list of child pointers to SDEC APPOINTMENT and/or
  1. ; SDEC APPT REQUEST files separated by pipe
  1. ; each pipe piece contains the following ~ pieces:
  1. ; 1. (optional) Appointment Id pointer to SDEC APPOINTMENT
  1. ; file 409.84
  1. ; 2. (optional) Request Id pointer to SDEC APPT REQUEST
  1. ; file 409.85
  1. ;RETURN:
  1. ; ERRORCODE^MESSAGE
  1. ;
  1. N MULT1,SDI
  1. S SDECY="^TMP(""SDECAR"","_$J_",""ARMRTSET"")"
  1. K @SDECY
  1. ; data header
  1. S @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$C(30)
  1. S ARIEN=$G(ARIEN)
  1. I ARIEN="" S @SDECY@(1)="-1^SDEC APPT REQUEST id is required." Q
  1. I '$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id." Q
  1. S MULT=$G(MULT)
  1. D MT1(ARIEN)
  1. I MULT="" S @SDECY@(0)=@SDECY@(0)_$C(31) Q ;nothing to do
  1. F SDI=1:1:$L(MULT,"|") D
  1. .S MULT1=$TR($P(MULT,"|",SDI),"^","~")
  1. .D AR433^SDECAR2(ARIEN,MULT1)
  1. S @SDECY@(1)="0^SUCCESS"_$C(30,31)
  1. Q
  1. 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)
  1. ;INPUT:
  1. ; ARIEN - (required) pointer to SDEC APPT REQUEST file
  1. ; MRTC - (optional) MRTC calculated preferred dates separated by pipe|:
  1. ; Each date can be in external format with no time.
  1. ;RETURN:
  1. ; ERRORCODE^MESSAGE
  1. N SDI,MRTC1
  1. S SDECY="^TMP(""SDECAR"","_$J_",""ARMRTSET"")"
  1. K @SDECY
  1. ; data header
  1. S @SDECY@(0)="T00030ERRORCODE^T00030MESSAGE"_$C(30)
  1. S ARIEN=$G(ARIEN)
  1. I ARIEN="" S @SDECY@(1)="-1^SDEC APPT REQUEST id is required." Q
  1. I '$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id." Q
  1. S MRTC=$G(MRTC)
  1. I MRTC="" S @SDECY@(1)="0"_$C(30,31) Q ;not an error, just nothing to do
  1. D MT(ARIEN)
  1. D AR435^SDECAR2(MRTC,ARIEN)
  1. S @SDECY@(1)="0"_$C(30,31)
  1. Q
  1. MT(ARIEN) ; clear out existing MRTC CALC PREF DATES
  1. N DA,DIK,SDI
  1. S SDI=0 F S SDI=$O(^SDEC(409.85,ARIEN,5,SDI)) Q:SDI'>0 D
  1. .S DIK="^SDEC(409.85,"_ARIEN_",5,"
  1. .S DA=SDI
  1. .S DA(1)=ARIEN
  1. .D ^DIK
  1. Q
  1. MT1(ARIEN) ; clear out existing MULT APPTS MADE
  1. N DA,DIK,SDI
  1. S SDI=0 F S SDI=$O(^SDEC(409.85,ARIEN,2,SDI)) Q:SDI'>0 D
  1. .S DIK="^SDEC(409.85,"_ARIEN_",2,"
  1. .S DA=SDI
  1. .S DA(1)=ARIEN
  1. .D ^DIK
  1. Q
  1. ;
  1. ARMRTC(RET,ARIEN) ;GET the number of MRTC appointments made for this request
  1. ;INPUT:
  1. ; ARIEN - (required) pointer to SDEC APPT REQUEST file 409.85
  1. ;RETURN
  1. ; Global array with 1 entry containing the count of appointments made under the COUNT header
  1. N SDC,SDECI,SDI
  1. S RET="^TMP(""SDECAR1"","_$J_",""ARMRTC"")"
  1. K @RET
  1. S (SDC,SDECI)=0
  1. S ARIEN=$G(ARIEN)
  1. I '$D(^SDEC(409.85,ARIEN,0)) S @RET@(1)="-1^Invalid ID"_$C(30,31) Q
  1. S @RET@(SDECI)="T00030COUNT"_$C(30)
  1. S @RET@(1)=$$MRTC(ARIEN)_$C(30,31)
  1. Q
  1. MRTC(ARIEN) ;
  1. N SDC,SDI
  1. S SDC=0
  1. S SDI=0 F S SDI=$O(^SDEC(409.85,ARIEN,2,SDI)) Q:SDI'>0 D
  1. .S SDC=SDC+1
  1. Q SDC
  1. ;
  1. ARAPPT(SDECY,SDAPPT) ;GET appointment request for given SDEC APPOINTMENT id
  1. ;INPUT:
  1. ; SDAPPT - (required) pointer to SDEC APPOINTMENT file 409.84
  1. ;RETURN
  1. ; Global array with 1 entry containing the REQUEST TYPE and IEN of the associated appointment separated by pipe |:
  1. ; 1. Request Type - A APPT
  1. ; C Consult
  1. ; E EWL
  1. ; R Recall
  1. ; 2. IEN - pointer to either the SDEC APPT REQUEST, REQUEST/CONSULTATION, SD WAIT LIST, or RECALL REMINDERS file
  1. ;
  1. N SDECI,SDTYP,SDX,SDY
  1. S SDECY="^TMP(""SDECAR"","_$J_",""ARAPPT"")"
  1. K @SDECY
  1. S SDECI=0
  1. S @SDECY@(SDECI)="T00030SDAPTYP"_$C(30)
  1. S SDAPPT=$G(SDAPPT)
  1. I SDAPPT="" S @SDECY@(1)="-1^SDEC APPOINTMENT id is required."_$C(30,31) Q
  1. I '$D(^SDEC(409.84,+SDAPPT,0)) S @SDECY@(1)="-1^Invalid SDEC APPOINTMENT ID."_$C(30,31) Q
  1. S SDX=$$GET1^DIQ(409.84,SDAPPT_",",.22,"I")
  1. S SDY=$P(SDX,";",2)
  1. 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
  1. S SDECI=SDECI+1 S @SDECY@(SDECI)=SDTYP_$C(30,31)
  1. Q
  1. ;
  1. AUDITGET(SDECY,ARIEN) ;GET entries from VS AUDIT field of SDEC APPT REQUEST file 409.85
  1. N ARDATA,SDECI,SDI,SDTMP,SDX
  1. S SDECY="^TMP(""SDECAR"","_$J_",""AUDITGET"")"
  1. K @SDECY
  1. S SDECI=0
  1. S SDTMP="T00030IEN^T00030ID^T00030DATE^T00030USERIEN^T00030USERNAME"
  1. S SDTMP=SDTMP_"^T00030CLINIEN^T00030CLINNAME^T00030STOPIEN^T00030STOPNAME"
  1. S @SDECY@(SDECI)=SDTMP_$C(30)
  1. ;validate ARIEN
  1. S ARIEN=$G(ARIEN)
  1. I '+$D(^SDEC(409.85,+ARIEN,0)) S @SDECY@(1)="-1^Invalid SDEC APPT REQUEST id."_$C(30,31) Q
  1. S SDI=0 F S SDI=$O(^SDEC(409.85,+ARIEN,6,SDI)) Q:SDI'>0 D
  1. .K ARDATA
  1. .D GETS^DIQ(409.8545,SDI_","_ARIEN_",","**","IE","ARDATA")
  1. .S SDX="ARDATA(409.8545,"""_SDI_","_ARIEN_","")"
  1. .S SDTMP=ARIEN_U_SDI_U_@SDX@(.01,"E")_U_@SDX@(1,"I")_U_@SDX@(1,"E")
  1. .S SDTMP=SDTMP_U_@SDX@(2,"I")_U_@SDX@(2,"E")_U_@SDX@(3,"I")_U_@SDX@(3,"E")
  1. .S SDECI=SDECI+1 S @SDECY@(SDECI)=SDTMP_$C(30)
  1. S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
  1. Q
  1. ;
  1. CHECKLOCK(INP,RET) ;check lock
  1. N REQTYP,RETURN
  1. S RETURN=""
  1. S REQTYP=$$GET1^DIQ(409.85,INP(1)_",",4,"I")
  1. S DFN=$$GET1^DIQ(409.85,INP(1)_",",.01,"I")
  1. S POP=$$ORDERLOCKCHECK^SDEC07C(REQTYP,INP(1),.RETURN,DFN)
  1. S:POP RET="-1^RTC Order is locked by another user. Please try again later."
  1. Q