- 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 Feb 19, 2025@00:18:08 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