- SDEC52A ;ALB/SAT,PC,LAB,KML,JAS - VISTA SCHEDULING RPCS ;NOV 25, 2024
- ;;5.3;Scheduling;**627,658,694,745,774,799,815,895**;Aug 13, 1993;Build 11
- ;;Per VHA Directive 6402, this routine should not be modified
- ;
- Q
- ;
- RECSET(SDECY,INP) ; SET/EDIT an entry to the RECALL REMINDERS file 403.5
- ;SD*5.3*745 replace external 'INP...' due to XINDEX issue. Parameters are then rolled into the INP array
- ;RECSET(SDECY,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15) external parameter tag is in SDEC
- ;INPUT:
- ; INP - Input array
- ; INP(1) - (optional) IEN pointer to RECALL REMINDERS
- ; a new entry will be added if null
- ; INP(2) - (required) DFN Pointer to PATIENT file
- ; INP(3) - (optional) Accession # (free-text 1-25 characters)
- ; INP(4) - (optional) COMMENT (free-text 1-80 characters)
- ; INP(5) - (optional) FAST/NON-FASTING valid values:
- ; FASTING
- ; NON-FASTING
- ; INP(6) - (required) Test/App pointer to RECALL REMINDERS APPT TYPE file 403.51
- ; INP(7) - (required) Provider - Pointer to RECALL REMINDERS PROVIDERS file 403.54
- ; INP(8) - (required) Clinic pointer to HOSPITAL LOCATION file
- ; INP(9) - (optional) Length of Appointment numeric between 10 and 120
- ; INP(10) - (required) Recall Date in external format (no time)
- ; INP(11)- (optional) Recall Date (Per patient) in external format (no time)
- ; INP(12)- (optional) Date Reminder Sent in external format (no time)
- ; INP(13)- (optional) User Who Entered Recall pointer to NEW PERSON file; default to current user
- ; INP(14)- (optional) Second Print Date in external format (no time)
- ; INP(15)- (optional) DATE/TIME Recall Added in external format
- ; INP(16)- (optional) EAS Tracking Number
- ;RETURN:
- ; Successful Return:
- ; Single Value return in the format "0^<Recall Reminders ien>"
- ; 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 APPTLEN,CLINIEN,DATE1,DATE,DATE2,DATE3,DAPTDT,DFN,FASTING,ORGDT
- N PROVIEN,RECALLIEN,RRAPPTYP,RRNOD,RRPROVIEN,EAS
- N SDCOMM,SDFDA,SDIEN,SDMSG,SDRET
- N LASTNOTE,X,Y,%DT
- K ^TMP("SDEC52",$J,"RECSET")
- ; data header
- S SDECY="I00020ERRORID^T00030ERRORTEXT"_$C(30)
- ;
- ;check IEN of RECALL REMINDERS if passed in (optional)
- S RECALLIEN=$G(INP(1))
- I RECALLIEN'="" I '$D(^SD(403.5,+RECALLIEN)) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS id."_$C(30,31) Q
- I RECALLIEN'="" S RRNOD=$G(^SD(403.5,+RECALLIEN,0))
- I RECALLIEN="" S RECALLIEN="+1"
- S LASTNOTE=$S(RECALLIEN="+1":"",1:$$GET1^DIQ(403.5,RECALLIEN_",",2.5,"I"))
- ;
- ;check provider (required)
- S RRPROVIEN=$G(INP(7))
- I +RRPROVIEN I '$D(^SD(403.54,+RRPROVIEN)) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS PROVIDERS id."_$C(30,31) Q
- I '+RRPROVIEN,RECALLIEN="+1" S SDECY=SDECY_"-1^RECALL REMINDERS PROVIDERS id is required."_$C(30,31) Q
- ;check that user has the correct security key
- S SDRET=$$KEY(RRPROVIEN) I SDRET S SDECY=SDECY_SDRET_$C(30,31) Q
- ;check for valid Patient (required)
- S DFN=$G(INP(2))
- I +DFN I '$D(^DPT(+DFN,0)) S SDECY=SDECY_"-1^Invalid Patient ID."_$C(30,31) Q
- I '+DFN,RECALLIEN="+1" S SDECY=SDECY_"-1^Patient ID is required."_$C(30,31) Q
- ;check Test/App pointer (required)
- S RRAPPTYP=$G(INP(6))
- I +RRAPPTYP I '$D(^SD(403.51,+RRAPPTYP)) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS APPT TYPE id."_$C(30,31) Q
- I '+RRAPPTYP,RECALLIEN="+1" S SDECY=SDECY_"-1^RECALL REMINDERS APPT TYPE is required."_$C(30,31) Q
- ;check Clinic (required)
- S CLINIEN=$G(INP(8))
- I +CLINIEN I '$D(^SC(+CLINIEN)) S SDECY=SDECY_"-1^Invalid Clinic id."_$C(30,31) Q
- I '+CLINIEN,RECALLIEN="+1" S SDECY=SDECY_"-1^Clinic ID is required."_$C(30,31) Q
- ;check Recall Date (required)
- S DATE=$G(INP(10))
- ;
- ; Change date/time conversion so midnight is handled properly.
- ;
- S DATE=$$NETTOFM^SDECDATE(DATE,"N","N") I DATE=-1 S SDECY=SDECY_"-1^Invalid Recall Date."_$C(30,31) Q
- I DATE="",RECALLIEN="+1" S SDECY=SDECY_"-1^Recall Date is required."_$C(30,31) Q
- ;
- ;check FAST/NON-FASTING (optional)
- S FASTING=$G(INP(5))
- 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:"")
- S INP(5)=FASTING
- ;check Length of Appointment (optional)
- S APPTLEN=$G(INP(9))
- I APPTLEN'="" I APPTLEN<10,APPTLEN>120 S APPTLEN=""
- ;check Recall Date (per Patient) (optional)
- S DATE1=$G(INP(11))
- ;
- ; Change date/time conversion so midnight is handled properly.
- ;
- S DATE1=$$NETTOFM^SDECDATE(DATE1,"N","N") I DATE1=-1 S DATE1="" ;
- ;check date reminder sent (optional)
- S DAPTDT=$G(INP(12))
- ;
- ; Change date/time conversion so midnight is handled properly.
- ;
- S DAPTDT=$$NETTOFM^SDECDATE(DAPTDT,"N","N") I DAPTDT=-1 S DAPTDT="" ; changed ORGDT to DAPTDT
- ;check User Who Entered Recall (optional) default to current
- S PROVIEN=$G(INP(13))
- I (PROVIEN="")!('$D(^VA(200,+PROVIEN))) S PROVIEN=DUZ
- ;check Second Print date (optional)
- S DATE2=$G(INP(14))
- ;
- ; Change date/time conversion so midnight is handled properly.
- ;
- I DATE2'="" S DATE2=$$NETTOFM^SDECDATE(DATE2,"N","N") I DATE2=-1 S DATE2="" ;
- ;check DATE/TIME RECALL ADDED (optional)
- S DATE3=$G(INP(15))
- ;
- ; Change date/time conversion so midnight is handled properly.
- ;
- ;set EAS Tracking Number
- S EAS=$G(INP(16))
- I DATE3'="" S DATE3=$$NETTOFM^SDECDATE(DATE3,"N","N") I DATE3=-1 S DATE3="" ; changed TIME requirement to NO in call to NETTOFM^SDECDATE
- I DATE3'="",$G(RRNOD)'="",$P(RRNOD,U,14)'="" S DATE3="" ;only add DATE/TIME RECALL ADDED if it is not already there
- ;check comment
- S (INP(4),SDCOMM)=$TR($G(INP(4)),"^"," ")
- S SDCOMM=$$CTRL^XMXUTIL1(SDCOMM)
- ;
- S SDFDA=$NA(SDFDA(403.5,RECALLIEN_","))
- S @SDFDA@(.01)=DFN
- S:$G(INP(3))'="" @SDFDA@(2)=$E(INP(3),1,25)
- S:SDCOMM'="" @SDFDA@(2.5)=$E(SDCOMM,1,80) ;use SDCOMM instead of INP(4)
- S:$G(FASTING)'="" @SDFDA@(2.6)=FASTING
- S @SDFDA@(3)=RRAPPTYP
- S @SDFDA@(4)=RRPROVIEN
- S @SDFDA@(4.5)=CLINIEN
- S:APPTLEN'="" @SDFDA@(4.7)=APPTLEN
- S @SDFDA@(5)=DATE
- S:DATE1'="" @SDFDA@(5.5)=DATE1
- S:DAPTDT'="" @SDFDA@(6)=DAPTDT
- S @SDFDA@(7)=PROVIEN
- S:DATE3'="" @SDFDA@(7.5)=DATE3
- S:DATE2'="" @SDFDA@(8)=DATE2
- S @SDFDA@(100)=EAS
- D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
- S:RECALLIEN="+1" RECALLIEN=SDIEN(1)
- I $D(SDMSG) S SDECY=SDECY_"-1^Error updating RECALL REMINDERS file"_$C(30,31) Q
- I '$D(SDMSG) S SDECY=SDECY_"0^"_$S(RECALLIEN'="":RECALLIEN,1:SDIEN(1))_$C(30,31)
- ;
- ; 403.57 COMMENT AUDIT multiple
- N LASTLENGTH,NEWLENGTH,NEWNOTE
- S LASTLENGTH=$L(LASTNOTE),NEWLENGTH=$L(SDCOMM)
- S NEWNOTE=SDCOMM
- S:NEWNOTE[LASTNOTE NEWNOTE=$E(SDCOMM,(LASTLENGTH+1),NEWLENGTH)
- S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
- I $L($G(NEWNOTE)) D
- .S CAFDA(403.57,"+1,"_RECALLIEN_",",.01)=$$NOW^XLFDT
- .S CAFDA(403.57,"+1,"_RECALLIEN_",",1)=DUZ
- .S CAFDA(403.57,"+1,"_RECALLIEN_",",2)=NEWNOTE
- .D UPDATE^DIE("","CAFDA") K CAFDA
- Q
- ;
- RECDSET(SDECY,RECALLIEN,SDRRFTR,SDCOMM) ; DELETE an entry to the RECALL REMINDERS file 403.5
- ;RECDSET(SDECY,RECALLIEN,SDRRFTR,SDCOMM) external parameter tag is in SDEC
- ;INPUT:
- ; INP - Input array
- ; RECALLIEN - (required) IEN pointer to RECALL REMINDERS
- ; SDRRFTR - (optional) Recall Disposition used to populate the
- ; DELETE REASON field in the RECALL REMINDERS
- ; REMOVED file 403.56 when an entry is removed
- ; from RECALL REMINDERS file. Valid Values are:
- ; FAILURE TO RESPOND
- ; MOVED
- ; DECEASED
- ; DOESN'T WANT VA SERVICES
- ; RECEIVED CARE AT ANOTHER VA
- ; OTHER
- ; APPT SCHEDULED
- ; VET SELF-CANCEL
- ; SDCOMM - (optional) Text to replace the text in the COMMENT
- ; Field 2.5 in RECALL REMINDERS prior to the
- ; delete which moves the data including this
- ; comment to RECALL REMINDERS REMOVED
- ;RETURN:
- ; Successful Return:
- ; Single Value return in the format "0^<Recall Reminders ien>"
- ; Caught Exception Return:
- ; Single Value return in the format "-1^<error text>"
- ; "T00020ERRORID^T00100ERRORTEXT"
- ; 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 APPTLEN,CAFDA,DATE1,DATE,DATE2,DAPTDT,DFN,FASTING,LASTNOTE,PROVIEN,RRAPPTYP,SDFDA,SDIEN,SDMSG,SDRET
- ; data header
- S SDECY="I00020ERRORID^T00030ERRORTEXT"_$C(30)
- ;
- ;check IEN of RECALL REMINDERS (required)
- I (RECALLIEN="")!('$D(^SD(403.5,+RECALLIEN))) S SDECY=SDECY_"-1^Invalid RECALL REMINDERS id."_$C(30,31) Q
- ;check disposition (optional)
- S SDRRFTR=$G(SDRRFTR)
- I SDRRFTR'="" D
- .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:"")
- I SDRRFTR="" K SDRRFTR
- ;
- ;check provider (required)
- S RRPROVIEN=$P($G(^SD(403.5,+RECALLIEN,0)),U,5)
- 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
- ;
- ;verify comment (optional)
- S SDCOMM=$$CTRL^XMXUTIL1($G(SDCOMM))
- I SDCOMM'="" D ;replace existing comment before calling move/delete
- .K SDFDA,CAFDA
- .S LASTNOTE=$$GET1^DIQ(403.5,RECALLIEN_",",2.5,"I")
- .S SDFDA(403.5,RECALLIEN_",",2.5)=$E(SDCOMM,1,80)
- .D UPDATE^DIE("","SDFDA")
- .; 403.57 COMMENT AUDIT multiple
- .N LASTLENGTH,NEWLENGTH,NEWNOTE
- .S LASTLENGTH=$L(LASTNOTE),NEWLENGTH=$L(SDCOMM)
- .S NEWNOTE=SDCOMM
- .S:NEWNOTE[LASTNOTE NEWNOTE=$E(SDCOMM,(LASTLENGTH+1),NEWLENGTH)
- .S:$E(NEWNOTE,1,1)=" " NEWNOTE=$E(NEWNOTE,2,$L(NEWNOTE))
- .S CAFDA(403.57,"+1,"_RECALLIEN_",",.01)=$$NOW^XLFDT
- .S CAFDA(403.57,"+1,"_RECALLIEN_",",1)=DUZ
- .S CAFDA(403.57,"+1,"_RECALLIEN_",",2)=NEWNOTE
- .D UPDATE^DIE("","CAFDA") K CAFDA
- ;
- ;
- S SDRET=$$RECSETD(RECALLIEN,RRPROVIEN)
- S SDECY=SDECY_SDRET_$C(30,31)
- Q
- ;
- RECSETD(RECALLIEN,RRPROVIEN) ;delete entry
- ;INPUT
- ; RECALLIEN - Pointer to RECALL REMINDERS file
- ; RRPROVIEN
- ;RETURN
- ; "0^<TEXT>" = delete successful
- ; "-1^<TEXT>" = delete unsuccessful
- N RET,SDFDA,SDIEN,SDMSG
- S RET=$$KEY(RECALLIEN,RRPROVIEN)
- Q:RET RET
- S SDFDA=$NA(SDFDA(403.5,RECALLIEN_","))
- S @SDFDA@(.01)="@"
- D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
- I $D(SDMSG) S RET="-1^Error deleting RECALL REMINDERS file"_$C(30,31)
- I '$D(SDMSG) S RET="0^"_RECALLIEN
- Q RET
- ;
- KEY(RECALLIEN,RRPROVIEN) ;check that user has the correct SECURITY KEY
- ;INPUT:
- ; RRPROVIEN - Pointer to RECALL REMINDERS PROVIDERS file 403.54
- ;RETURN
- ; 0=User has the correct SECURITY KEY
- ; "-1^<text>" = User does not have the correct SECURITY KEY
- N KEY,KY,RET,SDPRV,SDFLAG
- 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."
- S (SDPRV,KEY,SDFLAG)="" S SDPRV=$P($G(^SD(403.5,+RECALLIEN,0)),U,5) D
- .I SDPRV="" S RET=0
- .I SDPRV'="" S KEY=$P($G(^SD(403.54,SDPRV,0)),U,7) D
- ..I KEY="" S RET=0 Q
- ..N VALUE
- ..S VALUE=$$LKUP^XPDKEY(KEY) K KY D OWNSKEY^XUSRB(.KY,VALUE,DUZ) ;ICR 1367 and ICR 3277
- ..I $G(KY(0))'=0 S RET=0
- Q RET
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC52A 12018 printed Feb 19, 2025@00:17:12 Page 2
- 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
- +2 ;;Per VHA Directive 6402, this routine should not be modified
- +3 ;
- +4 QUIT
- +5 ;
- 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
- +2 ;RECSET(SDECY,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,S12,S13,S14,S15) external parameter tag is in SDEC
- +3 ;INPUT:
- +4 ; INP - Input array
- +5 ; INP(1) - (optional) IEN pointer to RECALL REMINDERS
- +6 ; a new entry will be added if null
- +7 ; INP(2) - (required) DFN Pointer to PATIENT file
- +8 ; INP(3) - (optional) Accession # (free-text 1-25 characters)
- +9 ; INP(4) - (optional) COMMENT (free-text 1-80 characters)
- +10 ; INP(5) - (optional) FAST/NON-FASTING valid values:
- +11 ; FASTING
- +12 ; NON-FASTING
- +13 ; INP(6) - (required) Test/App pointer to RECALL REMINDERS APPT TYPE file 403.51
- +14 ; INP(7) - (required) Provider - Pointer to RECALL REMINDERS PROVIDERS file 403.54
- +15 ; INP(8) - (required) Clinic pointer to HOSPITAL LOCATION file
- +16 ; INP(9) - (optional) Length of Appointment numeric between 10 and 120
- +17 ; INP(10) - (required) Recall Date in external format (no time)
- +18 ; INP(11)- (optional) Recall Date (Per patient) in external format (no time)
- +19 ; INP(12)- (optional) Date Reminder Sent in external format (no time)
- +20 ; INP(13)- (optional) User Who Entered Recall pointer to NEW PERSON file; default to current user
- +21 ; INP(14)- (optional) Second Print Date in external format (no time)
- +22 ; INP(15)- (optional) DATE/TIME Recall Added in external format
- +23 ; INP(16)- (optional) EAS Tracking Number
- +24 ;RETURN:
- +25 ; Successful Return:
- +26 ; Single Value return in the format "0^<Recall Reminders ien>"
- +27 ; Caught Exception Return:
- +28 ; A single entry in the Global Array in the format "-1^<error text>"
- +29 ; "T00020RETURNCODE^T00100TEXT"
- +30 ; Unexpected Exception Return:
- +31 ; Handled by the RPC Broker.
- +32 ; M errors are trapped by the use of M and Kernel error handling.
- +33 ; The RPC execution stops and the RPC Broker sends the error generated
- +34 ; text back to the client.
- +35 ;
- +36 NEW APPTLEN,CLINIEN,DATE1,DATE,DATE2,DATE3,DAPTDT,DFN,FASTING,ORGDT
- +37 NEW PROVIEN,RECALLIEN,RRAPPTYP,RRNOD,RRPROVIEN,EAS
- +38 NEW SDCOMM,SDFDA,SDIEN,SDMSG,SDRET
- +39 NEW LASTNOTE,X,Y,%DT
- +40 KILL ^TMP("SDEC52",$JOB,"RECSET")
- +41 ; data header
- +42 SET SDECY="I00020ERRORID^T00030ERRORTEXT"_$CHAR(30)
- +43 ;
- +44 ;check IEN of RECALL REMINDERS if passed in (optional)
- +45 SET RECALLIEN=$GET(INP(1))
- +46 IF RECALLIEN'=""
- IF '$DATA(^SD(403.5,+RECALLIEN))
- SET SDECY=SDECY_"-1^Invalid RECALL REMINDERS id."_$CHAR(30,31)
- QUIT
- +47 IF RECALLIEN'=""
- SET RRNOD=$GET(^SD(403.5,+RECALLIEN,0))
- +48 IF RECALLIEN=""
- SET RECALLIEN="+1"
- +49 SET LASTNOTE=$SELECT(RECALLIEN="+1":"",1:$$GET1^DIQ(403.5,RECALLIEN_",",2.5,"I"))
- +50 ;
- +51 ;check provider (required)
- +52 SET RRPROVIEN=$GET(INP(7))
- +53 IF +RRPROVIEN
- IF '$DATA(^SD(403.54,+RRPROVIEN))
- SET SDECY=SDECY_"-1^Invalid RECALL REMINDERS PROVIDERS id."_$CHAR(30,31)
- QUIT
- +54 IF '+RRPROVIEN
- IF RECALLIEN="+1"
- SET SDECY=SDECY_"-1^RECALL REMINDERS PROVIDERS id is required."_$CHAR(30,31)
- QUIT
- +55 ;check that user has the correct security key
- +56 SET SDRET=$$KEY(RRPROVIEN)
- IF SDRET
- SET SDECY=SDECY_SDRET_$CHAR(30,31)
- QUIT
- +57 ;check for valid Patient (required)
- +58 SET DFN=$GET(INP(2))
- +59 IF +DFN
- IF '$DATA(^DPT(+DFN,0))
- SET SDECY=SDECY_"-1^Invalid Patient ID."_$CHAR(30,31)
- QUIT
- +60 IF '+DFN
- IF RECALLIEN="+1"
- SET SDECY=SDECY_"-1^Patient ID is required."_$CHAR(30,31)
- QUIT
- +61 ;check Test/App pointer (required)
- +62 SET RRAPPTYP=$GET(INP(6))
- +63 IF +RRAPPTYP
- IF '$DATA(^SD(403.51,+RRAPPTYP))
- SET SDECY=SDECY_"-1^Invalid RECALL REMINDERS APPT TYPE id."_$CHAR(30,31)
- QUIT
- +64 IF '+RRAPPTYP
- IF RECALLIEN="+1"
- SET SDECY=SDECY_"-1^RECALL REMINDERS APPT TYPE is required."_$CHAR(30,31)
- QUIT
- +65 ;check Clinic (required)
- +66 SET CLINIEN=$GET(INP(8))
- +67 IF +CLINIEN
- IF '$DATA(^SC(+CLINIEN))
- SET SDECY=SDECY_"-1^Invalid Clinic id."_$CHAR(30,31)
- QUIT
- +68 IF '+CLINIEN
- IF RECALLIEN="+1"
- SET SDECY=SDECY_"-1^Clinic ID is required."_$CHAR(30,31)
- QUIT
- +69 ;check Recall Date (required)
- +70 SET DATE=$GET(INP(10))
- +71 ;
- +72 ; Change date/time conversion so midnight is handled properly.
- +73 ;
- +74 SET DATE=$$NETTOFM^SDECDATE(DATE,"N","N")
- IF DATE=-1
- SET SDECY=SDECY_"-1^Invalid Recall Date."_$CHAR(30,31)
- QUIT
- +75 IF DATE=""
- IF RECALLIEN="+1"
- SET SDECY=SDECY_"-1^Recall Date is required."_$CHAR(30,31)
- QUIT
- +76 ;
- +77 ;check FAST/NON-FASTING (optional)
- +78 SET FASTING=$GET(INP(5))
- +79 IF FASTING'=""
- SET FASTING=$SELECT($$UP^XLFSTR(FASTING)="FASTING":"f",$$UP^XLFSTR(FASTING)="NON-FASTING":"n",$$UP^XLFSTR(FASTING)="F":"f",$$UP^XLFSTR(FASTING)="N":"n",FASTING="@":"@",1:"")
- +80 SET INP(5)=FASTING
- +81 ;check Length of Appointment (optional)
- +82 SET APPTLEN=$GET(INP(9))
- +83 IF APPTLEN'=""
- IF APPTLEN<10
- IF APPTLEN>120
- SET APPTLEN=""
- +84 ;check Recall Date (per Patient) (optional)
- +85 SET DATE1=$GET(INP(11))
- +86 ;
- +87 ; Change date/time conversion so midnight is handled properly.
- +88 ;
- +89 ;
- SET DATE1=$$NETTOFM^SDECDATE(DATE1,"N","N")
- IF DATE1=-1
- SET DATE1=""
- +90 ;check date reminder sent (optional)
- +91 SET DAPTDT=$GET(INP(12))
- +92 ;
- +93 ; Change date/time conversion so midnight is handled properly.
- +94 ;
- +95 ; changed ORGDT to DAPTDT
- SET DAPTDT=$$NETTOFM^SDECDATE(DAPTDT,"N","N")
- IF DAPTDT=-1
- SET DAPTDT=""
- +96 ;check User Who Entered Recall (optional) default to current
- +97 SET PROVIEN=$GET(INP(13))
- +98 IF (PROVIEN="")!('$DATA(^VA(200,+PROVIEN)))
- SET PROVIEN=DUZ
- +99 ;check Second Print date (optional)
- +100 SET DATE2=$GET(INP(14))
- +101 ;
- +102 ; Change date/time conversion so midnight is handled properly.
- +103 ;
- +104 ;
- IF DATE2'=""
- SET DATE2=$$NETTOFM^SDECDATE(DATE2,"N","N")
- IF DATE2=-1
- SET DATE2=""
- +105 ;check DATE/TIME RECALL ADDED (optional)
- +106 SET DATE3=$GET(INP(15))
- +107 ;
- +108 ; Change date/time conversion so midnight is handled properly.
- +109 ;
- +110 ;set EAS Tracking Number
- +111 SET EAS=$GET(INP(16))
- +112 ; changed TIME requirement to NO in call to NETTOFM^SDECDATE
- IF DATE3'=""
- SET DATE3=$$NETTOFM^SDECDATE(DATE3,"N","N")
- IF DATE3=-1
- SET DATE3=""
- +113 ;only add DATE/TIME RECALL ADDED if it is not already there
- IF DATE3'=""
- IF $GET(RRNOD)'=""
- IF $PIECE(RRNOD,U,14)'=""
- SET DATE3=""
- +114 ;check comment
- +115 SET (INP(4),SDCOMM)=$TRANSLATE($GET(INP(4)),"^"," ")
- +116 SET SDCOMM=$$CTRL^XMXUTIL1(SDCOMM)
- +117 ;
- +118 SET SDFDA=$NAME(SDFDA(403.5,RECALLIEN_","))
- +119 SET @SDFDA@(.01)=DFN
- +120 if $GET(INP(3))'=""
- SET @SDFDA@(2)=$EXTRACT(INP(3),1,25)
- +121 ;use SDCOMM instead of INP(4)
- if SDCOMM'=""
- SET @SDFDA@(2.5)=$EXTRACT(SDCOMM,1,80)
- +122 if $GET(FASTING)'=""
- SET @SDFDA@(2.6)=FASTING
- +123 SET @SDFDA@(3)=RRAPPTYP
- +124 SET @SDFDA@(4)=RRPROVIEN
- +125 SET @SDFDA@(4.5)=CLINIEN
- +126 if APPTLEN'=""
- SET @SDFDA@(4.7)=APPTLEN
- +127 SET @SDFDA@(5)=DATE
- +128 if DATE1'=""
- SET @SDFDA@(5.5)=DATE1
- +129 if DAPTDT'=""
- SET @SDFDA@(6)=DAPTDT
- +130 SET @SDFDA@(7)=PROVIEN
- +131 if DATE3'=""
- SET @SDFDA@(7.5)=DATE3
- +132 if DATE2'=""
- SET @SDFDA@(8)=DATE2
- +133 SET @SDFDA@(100)=EAS
- +134 DO UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
- +135 if RECALLIEN="+1"
- SET RECALLIEN=SDIEN(1)
- +136 IF $DATA(SDMSG)
- SET SDECY=SDECY_"-1^Error updating RECALL REMINDERS file"_$CHAR(30,31)
- QUIT
- +137 IF '$DATA(SDMSG)
- SET SDECY=SDECY_"0^"_$SELECT(RECALLIEN'="":RECALLIEN,1:SDIEN(1))_$CHAR(30,31)
- +138 ;
- +139 ; 403.57 COMMENT AUDIT multiple
- +140 NEW LASTLENGTH,NEWLENGTH,NEWNOTE
- +141 SET LASTLENGTH=$LENGTH(LASTNOTE)
- SET NEWLENGTH=$LENGTH(SDCOMM)
- +142 SET NEWNOTE=SDCOMM
- +143 if NEWNOTE[LASTNOTE
- SET NEWNOTE=$EXTRACT(SDCOMM,(LASTLENGTH+1),NEWLENGTH)
- +144 if $EXTRACT(NEWNOTE,1,1)=" "
- SET NEWNOTE=$EXTRACT(NEWNOTE,2,$LENGTH(NEWNOTE))
- +145 IF $LENGTH($GET(NEWNOTE))
- Begin DoDot:1
- +146 SET CAFDA(403.57,"+1,"_RECALLIEN_",",.01)=$$NOW^XLFDT
- +147 SET CAFDA(403.57,"+1,"_RECALLIEN_",",1)=DUZ
- +148 SET CAFDA(403.57,"+1,"_RECALLIEN_",",2)=NEWNOTE
- +149 DO UPDATE^DIE("","CAFDA")
- KILL CAFDA
- End DoDot:1
- +150 QUIT
- +151 ;
- 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
- +2 ;INPUT:
- +3 ; INP - Input array
- +4 ; RECALLIEN - (required) IEN pointer to RECALL REMINDERS
- +5 ; SDRRFTR - (optional) Recall Disposition used to populate the
- +6 ; DELETE REASON field in the RECALL REMINDERS
- +7 ; REMOVED file 403.56 when an entry is removed
- +8 ; from RECALL REMINDERS file. Valid Values are:
- +9 ; FAILURE TO RESPOND
- +10 ; MOVED
- +11 ; DECEASED
- +12 ; DOESN'T WANT VA SERVICES
- +13 ; RECEIVED CARE AT ANOTHER VA
- +14 ; OTHER
- +15 ; APPT SCHEDULED
- +16 ; VET SELF-CANCEL
- +17 ; SDCOMM - (optional) Text to replace the text in the COMMENT
- +18 ; Field 2.5 in RECALL REMINDERS prior to the
- +19 ; delete which moves the data including this
- +20 ; comment to RECALL REMINDERS REMOVED
- +21 ;RETURN:
- +22 ; Successful Return:
- +23 ; Single Value return in the format "0^<Recall Reminders ien>"
- +24 ; Caught Exception Return:
- +25 ; Single Value return in the format "-1^<error text>"
- +26 ; "T00020ERRORID^T00100ERRORTEXT"
- +27 ; Unexpected Exception Return:
- +28 ; Handled by the RPC Broker.
- +29 ; M errors are trapped by the use of M and Kernel error handling.
- +30 ; The RPC execution stops and the RPC Broker sends the error generated
- +31 ; text back to the client.
- +32 ;
- +33 NEW APPTLEN,CAFDA,DATE1,DATE,DATE2,DAPTDT,DFN,FASTING,LASTNOTE,PROVIEN,RRAPPTYP,SDFDA,SDIEN,SDMSG,SDRET
- +34 ; data header
- +35 SET SDECY="I00020ERRORID^T00030ERRORTEXT"_$CHAR(30)
- +36 ;
- +37 ;check IEN of RECALL REMINDERS (required)
- +38 IF (RECALLIEN="")!('$DATA(^SD(403.5,+RECALLIEN)))
- SET SDECY=SDECY_"-1^Invalid RECALL REMINDERS id."_$CHAR(30,31)
- QUIT
- +39 ;check disposition (optional)
- +40 SET SDRRFTR=$GET(SDRRFTR)
- +41 IF SDRRFTR'=""
- Begin DoDot:1
- +42 SET SDRRFTR=$SELECT(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:"")
- End DoDot:1
- +43 IF SDRRFTR=""
- KILL SDRRFTR
- +44 ;
- +45 ;check provider (required)
- +46 SET RRPROVIEN=$PIECE($GET(^SD(403.5,+RECALLIEN,0)),U,5)
- +47 IF '$DATA(^SD(403.54,+RRPROVIEN))
- SET SDECY=SDECY_"-1^Invalid RECALL REMINDERS PROVIDERS defined in RECALL REMINDERS file for id "_RECALLIEN_"."_$CHAR(30,31)
- QUIT
- +48 ;
- +49 ;verify comment (optional)
- +50 SET SDCOMM=$$CTRL^XMXUTIL1($GET(SDCOMM))
- +51 ;replace existing comment before calling move/delete
- IF SDCOMM'=""
- Begin DoDot:1
- +52 KILL SDFDA,CAFDA
- +53 SET LASTNOTE=$$GET1^DIQ(403.5,RECALLIEN_",",2.5,"I")
- +54 SET SDFDA(403.5,RECALLIEN_",",2.5)=$EXTRACT(SDCOMM,1,80)
- +55 DO UPDATE^DIE("","SDFDA")
- +56 ; 403.57 COMMENT AUDIT multiple
- +57 NEW LASTLENGTH,NEWLENGTH,NEWNOTE
- +58 SET LASTLENGTH=$LENGTH(LASTNOTE)
- SET NEWLENGTH=$LENGTH(SDCOMM)
- +59 SET NEWNOTE=SDCOMM
- +60 if NEWNOTE[LASTNOTE
- SET NEWNOTE=$EXTRACT(SDCOMM,(LASTLENGTH+1),NEWLENGTH)
- +61 if $EXTRACT(NEWNOTE,1,1)=" "
- SET NEWNOTE=$EXTRACT(NEWNOTE,2,$LENGTH(NEWNOTE))
- +62 SET CAFDA(403.57,"+1,"_RECALLIEN_",",.01)=$$NOW^XLFDT
- +63 SET CAFDA(403.57,"+1,"_RECALLIEN_",",1)=DUZ
- +64 SET CAFDA(403.57,"+1,"_RECALLIEN_",",2)=NEWNOTE
- +65 DO UPDATE^DIE("","CAFDA")
- KILL CAFDA
- End DoDot:1
- +66 ;
- +67 ;
- +68 SET SDRET=$$RECSETD(RECALLIEN,RRPROVIEN)
- +69 SET SDECY=SDECY_SDRET_$CHAR(30,31)
- +70 QUIT
- +71 ;
- RECSETD(RECALLIEN,RRPROVIEN) ;delete entry
- +1 ;INPUT
- +2 ; RECALLIEN - Pointer to RECALL REMINDERS file
- +3 ; RRPROVIEN
- +4 ;RETURN
- +5 ; "0^<TEXT>" = delete successful
- +6 ; "-1^<TEXT>" = delete unsuccessful
- +7 NEW RET,SDFDA,SDIEN,SDMSG
- +8 SET RET=$$KEY(RECALLIEN,RRPROVIEN)
- +9 if RET
- QUIT RET
- +10 SET SDFDA=$NAME(SDFDA(403.5,RECALLIEN_","))
- +11 SET @SDFDA@(.01)="@"
- +12 DO UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
- +13 IF $DATA(SDMSG)
- SET RET="-1^Error deleting RECALL REMINDERS file"_$CHAR(30,31)
- +14 IF '$DATA(SDMSG)
- SET RET="0^"_RECALLIEN
- +15 QUIT RET
- +16 ;
- KEY(RECALLIEN,RRPROVIEN) ;check that user has the correct SECURITY KEY
- +1 ;INPUT:
- +2 ; RRPROVIEN - Pointer to RECALL REMINDERS PROVIDERS file 403.54
- +3 ;RETURN
- +4 ; 0=User has the correct SECURITY KEY
- +5 ; "-1^<text>" = User does not have the correct SECURITY KEY
- +6 NEW KEY,KY,RET,SDPRV,SDFLAG
- +7 SET RET="-1^THE PROVIDER ASSIGNED TO THIS RECALL REMINDER IS ASSIGNED A SECURITY KEY WHICH YOU DO NOT HAVE. PLEASE CONTACT YOUR RECALL COORDINATOR."
- +8 SET (SDPRV,KEY,SDFLAG)=""
- SET SDPRV=$PIECE($GET(^SD(403.5,+RECALLIEN,0)),U,5)
- Begin DoDot:1
- +9 IF SDPRV=""
- SET RET=0
- +10 IF SDPRV'=""
- SET KEY=$PIECE($GET(^SD(403.54,SDPRV,0)),U,7)
- Begin DoDot:2
- +11 IF KEY=""
- SET RET=0
- QUIT
- +12 NEW VALUE
- +13 ;ICR 1367 and ICR 3277
- SET VALUE=$$LKUP^XPDKEY(KEY)
- KILL KY
- DO OWNSKEY^XUSRB(.KY,VALUE,DUZ)
- +14 IF $GET(KY(0))'=0
- SET RET=0
- End DoDot:2
- End DoDot:1
- +15 QUIT RET