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

SDEC52A.m

Go to the documentation of this file.
  1. SDEC52A ;ALB/SAT,PC,LAB,KML,JAS - VISTA SCHEDULING RPCS ;NOV 25, 2024
  1. ;;5.3;Scheduling;**627,658,694,745,774,799,815,895**;Aug 13, 1993;Build 11
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. Q
  1. ;
  1. RECSET(SDECY,INP) ; SET/EDIT an entry to the RECALL REMINDERS file 403.5
  1. ;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP array
  1. ;RECSET(SDECY,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15) external parameter tag is in SDEC
  1. ;INPUT:
  1. ; INP - Input array
  1. ; INP(1) - (optional) IEN pointer to RECALL REMINDERS
  1. ; a new entry will be added if null
  1. ; INP(2) - (required) DFN Pointer to PATIENT file
  1. ; INP(3) - (optional) Accession # (free-text 1-25 characters)
  1. ; INP(4) - (optional) COMMENT (free-text 1-80 characters)
  1. ; INP(5) - (optional) FAST/NON-FASTING valid values:
  1. ; FASTING
  1. ; NON-FASTING
  1. ; INP(6) - (required) Test/App pointer to RECALL REMINDERS APPT TYPE file 403.51
  1. ; INP(7) - (required) Provider - Pointer to RECALL REMINDERS PROVIDERS file 403.54
  1. ; INP(8) - (required) Clinic pointer to HOSPITAL LOCATION file
  1. ; INP(9) - (optional) Length of Appointment numeric between 10 and 120
  1. ; INP(10) - (required) Recall Date in external format (no time)
  1. ; INP(11)- (optional) Recall Date (Per patient) in external format (no time)
  1. ; INP(12)- (optional) Date Reminder Sent in external format (no time)
  1. ; INP(13)- (optional) User Who Entered Recall pointer to NEW PERSON file; default to current user
  1. ; INP(14)- (optional) Second Print Date in external format (no time)
  1. ; INP(15)- (optional) DATE/TIME Recall Added in external format
  1. ; INP(16)- (optional) EAS Tracking Number
  1. ;RETURN:
  1. ; Successful Return:
  1. ; Single Value return in the format "0^<Recall Reminders ien>"
  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. ;
  1. N APPTLEN,CLINIEN,DATE1,DATE,DATE2,DATE3,DAPTDT,DFN,FASTING,ORGDT
  1. N PROVIEN,RECALLIEN,RRAPPTYP,RRNOD,RRPROVIEN,EAS
  1. N SDCOMM,SDFDA,SDIEN,SDMSG,SDRET
  1. N LASTNOTE,X,Y,%DT
  1. K ^TMP("SDEC52",$J,"RECSET")
  1. ; data header
  1. S SDECY="I00020ERRORID^T00030ERRORTEXT"_$C(30)
  1. ;
  1. ;check IEN of RECALL REMINDERS if passed in (optional)
  1. S RECALLIEN=$G(INP(1))
  1. I RECALLIEN'="" I '$D(^SD(403.5,+RECALLIEN)) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS id."_$C(30,31) Q
  1. I RECALLIEN'="" S RRNOD=$G(^SD(403.5,+RECALLIEN,0))
  1. I RECALLIEN="" S RECALLIEN="+1"
  1. S LASTNOTE=$S(RECALLIEN="+1":"",1:$$GET1^DIQ(403.5,RECALLIEN_",",2.5,"I"))
  1. ;
  1. ;check provider (required)
  1. S RRPROVIEN=$G(INP(7))
  1. I +RRPROVIEN I '$D(^SD(403.54,+RRPROVIEN)) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS PROVIDERS id."_$C(30,31) Q
  1. I '+RRPROVIEN,RECALLIEN="+1" S SDECY=SDECY_"-1^RECALL REMINDERS PROVIDERS id is required."_$C(30,31) Q
  1. ;check that user has the correct security key
  1. S SDRET=$$KEY(RRPROVIEN) I SDRET S SDECY=SDECY_SDRET_$C(30,31) Q
  1. ;check for valid Patient (required)
  1. S DFN=$G(INP(2))
  1. I +DFN I '$D(^DPT(+DFN,0)) S SDECY=SDECY_"-1^Invalid Patient ID."_$C(30,31) Q
  1. I '+DFN,RECALLIEN="+1" S SDECY=SDECY_"-1^Patient ID is required."_$C(30,31) Q
  1. ;check Test/App pointer (required)
  1. S RRAPPTYP=$G(INP(6))
  1. I +RRAPPTYP I '$D(^SD(403.51,+RRAPPTYP)) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS APPT TYPE id."_$C(30,31) Q
  1. I '+RRAPPTYP,RECALLIEN="+1" S SDECY=SDECY_"-1^RECALL REMINDERS APPT TYPE is required."_$C(30,31) Q
  1. ;check Clinic (required)
  1. S CLINIEN=$G(INP(8))
  1. I +CLINIEN I '$D(^SC(+CLINIEN)) S SDECY=SDECY_"-1^Invalid Clinic id."_$C(30,31) Q
  1. I '+CLINIEN,RECALLIEN="+1" S SDECY=SDECY_"-1^Clinic ID is required."_$C(30,31) Q
  1. ;check Recall Date (required)
  1. S DATE=$G(INP(10))
  1. ;
  1. ; Change date/time conversion so midnight is handled properly.
  1. ;
  1. S DATE=$$NETTOFM^SDECDATE(DATE,"N","N") I DATE=-1 S SDECY=SDECY_"-1^Invalid Recall Date."_$C(30,31) Q
  1. I DATE="",RECALLIEN="+1" S SDECY=SDECY_"-1^Recall Date is required."_$C(30,31) Q
  1. ;
  1. ;check FAST/NON-FASTING (optional)
  1. S FASTING=$G(INP(5))
  1. I FASTING'="" S FASTING=$S($$UP^XLFSTR(FASTING)="FASTING":"f",$$UP^XLFSTR(FASTING)="NON-FASTING":"n",$$UP^XLFSTR(FASTING)="F":"f",$$UP^XLFSTR(FASTING)="N":"n",FASTING="@":"@",1:"")
  1. S INP(5)=FASTING
  1. ;check Length of Appointment (optional)
  1. S APPTLEN=$G(INP(9))
  1. I APPTLEN'="" I APPTLEN<10,APPTLEN>120 S APPTLEN=""
  1. ;check Recall Date (per Patient) (optional)
  1. S DATE1=$G(INP(11))
  1. ;
  1. ; Change date/time conversion so midnight is handled properly.
  1. ;
  1. S DATE1=$$NETTOFM^SDECDATE(DATE1,"N","N") I DATE1=-1 S DATE1="" ;
  1. ;check date reminder sent (optional)
  1. S DAPTDT=$G(INP(12))
  1. ;
  1. ; Change date/time conversion so midnight is handled properly.
  1. ;
  1. S DAPTDT=$$NETTOFM^SDECDATE(DAPTDT,"N","N") I DAPTDT=-1 S DAPTDT="" ; changed ORGDT to DAPTDT
  1. ;check User Who Entered Recall (optional) default to current
  1. S PROVIEN=$G(INP(13))
  1. I (PROVIEN="")!('$D(^VA(200,+PROVIEN))) S PROVIEN=DUZ
  1. ;check Second Print date (optional)
  1. S DATE2=$G(INP(14))
  1. ;
  1. ; Change date/time conversion so midnight is handled properly.
  1. ;
  1. I DATE2'="" S DATE2=$$NETTOFM^SDECDATE(DATE2,"N","N") I DATE2=-1 S DATE2="" ;
  1. ;check DATE/TIME RECALL ADDED (optional)
  1. S DATE3=$G(INP(15))
  1. ;
  1. ; Change date/time conversion so midnight is handled properly.
  1. ;
  1. ;set EAS Tracking Number
  1. S EAS=$G(INP(16))
  1. I DATE3'="" S DATE3=$$NETTOFM^SDECDATE(DATE3,"N","N") I DATE3=-1 S DATE3="" ; changed TIME requirement to NO in call to NETTOFM^SDECDATE
  1. I DATE3'="",$G(RRNOD)'="",$P(RRNOD,U,14)'="" S DATE3="" ;only add DATE/TIME RECALL ADDED if it is not already there
  1. ;check comment
  1. S (INP(4),SDCOMM)=$TR($G(INP(4)),"^"," ")
  1. S SDCOMM=$$CTRL^XMXUTIL1(SDCOMM)
  1. ;
  1. S SDFDA=$NA(SDFDA(403.5,RECALLIEN_","))
  1. S @SDFDA@(.01)=DFN
  1. S:$G(INP(3))'="" @SDFDA@(2)=$E(INP(3),1,25)
  1. S:SDCOMM'="" @SDFDA@(2.5)=$E(SDCOMM,1,80) ;use SDCOMM instead of INP(4)
  1. S:$G(FASTING)'="" @SDFDA@(2.6)=FASTING
  1. S @SDFDA@(3)=RRAPPTYP
  1. S @SDFDA@(4)=RRPROVIEN
  1. S @SDFDA@(4.5)=CLINIEN
  1. S:APPTLEN'="" @SDFDA@(4.7)=APPTLEN
  1. S @SDFDA@(5)=DATE
  1. S:DATE1'="" @SDFDA@(5.5)=DATE1
  1. S:DAPTDT'="" @SDFDA@(6)=DAPTDT
  1. S @SDFDA@(7)=PROVIEN
  1. S:DATE3'="" @SDFDA@(7.5)=DATE3
  1. S:DATE2'="" @SDFDA@(8)=DATE2
  1. S @SDFDA@(100)=EAS
  1. D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
  1. S:RECALLIEN="+1" RECALLIEN=SDIEN(1)
  1. I $D(SDMSG) S SDECY=SDECY_"-1^Error updating RECALL REMINDERS file"_$C(30,31) Q
  1. I '$D(SDMSG) S SDECY=SDECY_"0^"_$S(RECALLIEN'="":RECALLIEN,1:SDIEN(1))_$C(30,31)
  1. ;
  1. ; 403.57 COMMENT AUDIT multiple
  1. N LASTLENGTH,NEWLENGTH,NEWNOTE
  1. S LASTLENGTH=$L(LASTNOTE),NEWLENGTH=$L(SDCOMM)
  1. S NEWNOTE=SDCOMM
  1. S:NEWNOTE[LASTNOTE NEWNOTE=$E(SDCOMM,(LASTLENGTH+1),NEWLENGTH)
  1. S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
  1. I $L($G(NEWNOTE)) D
  1. .S CAFDA(403.57,"+1,"_RECALLIEN_",",.01)=$$NOW^XLFDT
  1. .S CAFDA(403.57,"+1,"_RECALLIEN_",",1)=DUZ
  1. .S CAFDA(403.57,"+1,"_RECALLIEN_",",2)=NEWNOTE
  1. .D UPDATE^DIE("","CAFDA") K CAFDA
  1. Q
  1. ;
  1. RECDSET(SDECY,RECALLIEN,SDRRFTR,SDCOMM) ; DELETE an entry to the RECALL REMINDERS file 403.5
  1. ;RECDSET(SDECY,RECALLIEN,SDRRFTR,SDCOMM) external parameter tag is in SDEC
  1. ;INPUT:
  1. ; INP - Input array
  1. ; RECALLIEN - (required) IEN pointer to RECALL REMINDERS
  1. ; SDRRFTR - (optional) Recall Disposition used to populate the
  1. ; DELETE REASON field in the RECALL REMINDERS
  1. ; REMOVED file 403.56 when an entry is removed
  1. ; from RECALL REMINDERS file. Valid Values are:
  1. ; FAILURE TO RESPOND
  1. ; MOVED
  1. ; DECEASED
  1. ; DOESN'T WANT VA SERVICES
  1. ; RECEIVED CARE AT ANOTHER VA
  1. ; OTHER
  1. ; APPT SCHEDULED
  1. ; VET SELF-CANCEL
  1. ; SDCOMM - (optional) Text to replace the text in the COMMENT
  1. ; Field 2.5 in RECALL REMINDERS prior to the
  1. ; delete which moves the data including this
  1. ; comment to RECALL REMINDERS REMOVED
  1. ;RETURN:
  1. ; Successful Return:
  1. ; Single Value return in the format "0^<Recall Reminders ien>"
  1. ; Caught Exception Return:
  1. ; Single Value return in the format "-1^<error text>"
  1. ; "T00020ERRORID^T00100ERRORTEXT"
  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. ;
  1. N APPTLEN,CAFDA,DATE1,DATE,DATE2,DAPTDT,DFN,FASTING,LASTNOTE,PROVIEN,RRAPPTYP,SDFDA,SDIEN,SDMSG,SDRET
  1. ; data header
  1. S SDECY="I00020ERRORID^T00030ERRORTEXT"_$C(30)
  1. ;
  1. ;check IEN of RECALL REMINDERS (required)
  1. I (RECALLIEN="")!('$D(^SD(403.5,+RECALLIEN))) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS id."_$C(30,31) Q
  1. ;check disposition (optional)
  1. S SDRRFTR=$G(SDRRFTR)
  1. I SDRRFTR'="" D
  1. .S SDRRFTR=$S(SDRRFTR="FAILURE TO RESPOND":1,SDRRFTR="MOVED":2,SDRRFTR="DECEASED":3,SDRRFTR="DOESN'T WANT VA SERVICES":4,SDRRFTR="RECEIVED CARE AT ANOTHER VA":5,SDRRFTR="OTHER":6,SDRRFTR="APPT SCHEDULED":7,SDRRFTR="VET SELF-CANCEL":8,1:"")
  1. I SDRRFTR="" K SDRRFTR
  1. ;
  1. ;check provider (required)
  1. S RRPROVIEN=$P($G(^SD(403.5,+RECALLIEN,0)),U,5)
  1. I '$D(^SD(403.54,+RRPROVIEN)) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS PROVIDERS defined in RECALL REMINDERS file for id "_RECALLIEN_"."_$C(30,31) Q
  1. ;
  1. ;verify comment (optional)
  1. S SDCOMM=$$CTRL^XMXUTIL1($G(SDCOMM))
  1. I SDCOMM'="" D ;replace existing comment before calling move/delete
  1. .K SDFDA,CAFDA
  1. .S LASTNOTE=$$GET1^DIQ(403.5,RECALLIEN_",",2.5,"I")
  1. .S SDFDA(403.5,RECALLIEN_",",2.5)=$E(SDCOMM,1,80)
  1. .D UPDATE^DIE("","SDFDA")
  1. .; 403.57 COMMENT AUDIT multiple
  1. .N LASTLENGTH,NEWLENGTH,NEWNOTE
  1. .S LASTLENGTH=$L(LASTNOTE),NEWLENGTH=$L(SDCOMM)
  1. .S NEWNOTE=SDCOMM
  1. .S:NEWNOTE[LASTNOTE NEWNOTE=$E(SDCOMM,(LASTLENGTH+1),NEWLENGTH)
  1. .S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
  1. .S CAFDA(403.57,"+1,"_RECALLIEN_",",.01)=$$NOW^XLFDT
  1. .S CAFDA(403.57,"+1,"_RECALLIEN_",",1)=DUZ
  1. .S CAFDA(403.57,"+1,"_RECALLIEN_",",2)=NEWNOTE
  1. .D UPDATE^DIE("","CAFDA") K CAFDA
  1. ;
  1. ;
  1. S SDRET=$$RECSETD(RECALLIEN,RRPROVIEN)
  1. S SDECY=SDECY_SDRET_$C(30,31)
  1. Q
  1. ;
  1. RECSETD(RECALLIEN,RRPROVIEN) ;delete entry
  1. ;INPUT
  1. ; RECALLIEN - Pointer to RECALL REMINDERS file
  1. ; RRPROVIEN
  1. ;RETURN
  1. ; "0^<TEXT>" = delete successful
  1. ; "-1^<TEXT>" = delete unsuccessful
  1. N RET,SDFDA,SDIEN,SDMSG
  1. S RET=$$KEY(RECALLIEN,RRPROVIEN)
  1. Q:RET RET
  1. S SDFDA=$NA(SDFDA(403.5,RECALLIEN_","))
  1. S @SDFDA@(.01)="@"
  1. D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
  1. I $D(SDMSG) S RET="-1^Error deleting RECALL REMINDERS file"_$C(30,31)
  1. I '$D(SDMSG) S RET="0^"_RECALLIEN
  1. Q RET
  1. ;
  1. KEY(RECALLIEN,RRPROVIEN) ;check that user has the correct SECURITY KEY
  1. ;INPUT:
  1. ; RRPROVIEN - Pointer to RECALL REMINDERS PROVIDERS file 403.54
  1. ;RETURN
  1. ; 0=User has the correct SECURITY KEY
  1. ; "-1^<text>" = User does not have the correct SECURITY KEY
  1. N KEY,KY,RET,SDPRV,SDFLAG
  1. S RET="-1^THE PROVIDER ASSIGNED TO THIS RECALL REMINDER IS ASSIGNED A SECURITY KEY WHICH YOU DO NOT HAVE. PLEASE CONTACT YOUR RECALL COORDINATOR."
  1. S (SDPRV,KEY,SDFLAG)="" S SDPRV=$P($G(^SD(403.5,+RECALLIEN,0)),U,5) D
  1. .I SDPRV="" S RET=0
  1. .I SDPRV'="" S KEY=$P($G(^SD(403.54,SDPRV,0)),U,7) D
  1. ..I KEY="" S RET=0 Q
  1. ..N VALUE
  1. ..S VALUE=$$LKUP^XPDKEY(KEY) K KY D OWNSKEY^XUSRB(.KY,VALUE,DUZ) ;ICR 1367 and ICR 3277
  1. ..I $G(KY(0))'=0 S RET=0
  1. Q RET