SDRRISRU ;ALB/MAH,BWF,JAS - Recall Reminder Utilities ;NOV 25, 2024
;;5.3;Scheduling;**536,627,648,799,818,866,895**;Aug 13, 1993;Build 11
;;Per VHA Directive 6402, this routine should not be modified
;
OPENSLOT(SDRRIEN,SDRRST,SDRRND) ; Function returns the number of open (available)
; slots at the clinic during the time period.
; SDRRIEN - IEN of clinic in file #44
; SDRRST - (optional) start checking on this date (default=today)
; SDRRND - (optional) end of time period (default=last day of month)
N SDRRNOAV,SDRRTOT,SDRRHOL,SDRRT,SDRRTPT,SDRRTPDT,SDRRDT,SDRRDA
N SDRRFTR,CK,CLIN1,DA,DFN
I '$D(SDRRST) S SDRRST=DT
I '$D(SDRRND) D ; end of month
. S SDRRND=$E($$SCH^XLFDT("1M(L)",SDRRST),1,7)
. S SDRRND=$$FMADD^XLFDT(SDRRND,1)
. Q:$E(SDRRST,1,5)=$E(SDRRND,1,5)
. S SDRRND=$$FMADD^XLFDT($E(SDRRND,1,5)_"01",-1)
S SDRRST=$$FMADD^XLFDT(SDRRST,-1)
S SDRRNOAV=0
I '$O(^SC(SDRRIEN,"OST",SDRRST)),'$O(^SC(SDRRIEN,"ST",SDRRST,0)) D
. N SDRRI,SDRRDOW
. F SDRRI=0:1:6 S SDRRDOW=$O(^SC(SDRRIEN,"T"_SDRRI,SDRRST)) Q:SDRRDOW S:SDRRDOW SDRRNOAV=1
I SDRRNOAV Q 0 ; No future dates available
I '$D(SDRRYEAR) N SDRRYEAR D YEAR
S SDRRHOL=($P($G(^SC(SDRRIEN,"SL")),U,8)="Y")
S SDRRTOT=0,SDRRDT=SDRRST
F S SDRRDT=$O(SDRRYEAR(SDRRDT)) Q:SDRRDT>SDRRND!'SDRRDT D
. I 'SDRRHOL,$P(SDRRYEAR(SDRRDT),U,2) Q
. S SDRRTPDT=$G(^SC(SDRRIEN,"ST",SDRRDT,1)) ; Pattern
. I SDRRTPDT="" D Q:SDRRTPDT=""
. . S SDRRT="T"_+SDRRYEAR(SDRRDT)
. . S SDRRTPT=$O(^SC(SDRRIEN,SDRRT,SDRRDT)) Q:SDRRTPT=""
. . S SDRRTPDT=$G(^SC(SDRRIEN,SDRRT,SDRRTPT,1))
. S SDRRTOT=SDRRTOT+$$AVAIL(SDRRTPDT)
Q SDRRTOT
AVAIL(SDRRPAT) ; Given pattern, returns number of available slots.
; Check the pattern for available slots
; 0-9 and j-z = available slots where j=10, k=11...z=26
; $A(1)=49 $A(9)=57 $A("j")=106 $A("z")=122
N SDRRCNT,SDRRCHAR,I
S SDRRCNT=0
S SDRRPAT=$TR($E(SDRRPAT,6,$L(SDRRPAT)),"|[] ","")
F I=1:1:$L(SDRRPAT) S SDRRCHAR=$A(SDRRPAT,I) D
. I SDRRCHAR>48,SDRRCHAR<58 S SDRRCNT=SDRRCNT+$C(SDRRCHAR) Q
. I SDRRCHAR>105,SDRRCHAR<123 S SDRRCNT=SDRRCNT+SDRRCHAR-96
Q SDRRCNT
YEAR ; Set-up 1 year dates
; This array is used for available appointments
N SDRRI,SDRRDT
S SDRRDT=SDRRST
F SDRRI=1:1:365 D Q:SDRRDT=SDRRND
. S SDRRDT=$$FMADD^XLFDT(SDRRDT,1)
. S SDRRYEAR(SDRRDT)=$$DOW^XLFDT(SDRRDT,1)
. I $D(^HOLIDAY(SDRRDT)) S $P(SDRRYEAR(SDRRDT),U,2)=1
Q
DELETE ; This entry point is invoked by the new style xref A66201 on the .01 field of file 403.5
I $D(SDRRDA),$D(APPT),$D(CLIN1) D Q
.D DELAPPT(SDRRDA,APPT,CLIN1)
D DELUSER(DA)
Q
DELAPPT(SDRRIEN,APPT,CLIN1) ; Record deleted from Recall List because of appointment.
N SDRRFDA
S SDRRFDA(403.56,"+1,",101)=APPT ; appt date
S SDRRFDA(403.56,"+1,",102)=CLIN1 ; appt clinic
; SD*648 - Add delete info
S SDRRFDA(403.56,"+1,",201)=$E($$NOW^XLFDT(),1,12) ; delete date
S SDRRFDA(403.56,"+1,",202)=DUZ ; delete clerk
S:$G(SDRRFTR) SDRRFDA(403.56,"+1,",203)=SDRRFTR ; delete reason:
D DELSET(SDRRIEN,.SDRRFDA)
Q
DELUSER(SDRRIEN) ; Record deleted by a user.
N SDRRFDA
S SDRRFDA(403.56,"+1,",201)=$E($$NOW^XLFDT(),1,12) ; delete date
; DELUSER is defined by SDES2DISPRECALL to ensure the correct user is defined as the delete clerk
; This will not be new'ed or killed in this routine. DELUSER is newed in SDES2DISPRECALL,
; which is firing off this trigger cross reference.
S SDRRFDA(403.56,"+1,",202)=$S($G(DELUSER):$G(DELUSER),1:DUZ) ; delete clerk
S:$G(SDRRFTR) SDRRFDA(403.56,"+1,",203)=SDRRFTR ; delete reason:
D DELSET(SDRRIEN,.SDRRFDA)
Q
DELSET(SDRRIEN,SDRRFDA) ;
N SDRRREC,EAS,NEWIEN,APPTIEN,FDA,RREMIEN
S SDRRREC=$G(^SD(403.5,SDRRIEN,0))
S EAS=$G(^SD(403.5,SDRRIEN,1))
S SDRRFDA(403.56,"+1,",.01)=$P(SDRRREC,U,1) ; patient
S SDRRFDA(403.56,"+1,",2)=$P(SDRRREC,U,3) ; accession #
S SDRRFDA(403.56,"+1,",2.5)=$$CTRL^XMXUTIL1($P(SDRRREC,U,7)) ; comment
S SDRRFDA(403.56,"+1,",2.6)=$P(SDRRREC,U,8) ; fast / non-fast
S SDRRFDA(403.56,"+1,",3)=$P(SDRRREC,U,4) ; test/app.
S SDRRFDA(403.56,"+1,",4)=$P(SDRRREC,U,5) ; provider
S SDRRFDA(403.56,"+1,",4.5)=$P(SDRRREC,U,2) ; clinic
S SDRRFDA(403.56,"+1,",4.7)=$P(SDRRREC,U,9) ; length of appt.
S SDRRFDA(403.56,"+1,",5)=$P(SDRRREC,U,6) ; recall date
S SDRRFDA(403.56,"+1,",6)=$P(SDRRREC,U,10) ; date reminder sent
S SDRRFDA(403.56,"+1,",7)=$P(SDRRREC,U,11) ; user who entered recall
S SDRRFDA(403.56,"+1,",7.5)=$P(SDRRREC,U,14) ;DATE/TIME RECALL ADDED
S SDRRFDA(403.56,"+1,",100)=EAS ;EAS TRACKING NUMBER ADDED
D UPDATE^DIE("","SDRRFDA","NEWIEN")
S RREMIEN=$G(NEWIEN(1)) I 'RREMIEN Q
;
N CAFDA
S CAFDA(403.58,"+1,"_RREMIEN_",",.01)=$$NOW^XLFDT
S CAFDA(403.58,"+1,"_RREMIEN_",",1)=$P(SDRRREC,U,11)
S CAFDA(403.58,"+1,"_RREMIEN_",",2)=$$CTRL^XMXUTIL1($P(SDRRREC,U,7))
D UPDATE^DIE("","CAFDA") K CAFDA
;
S APPTIEN=$$GETAPPT(SDRRIEN) Q:'APPTIEN
S FDA(409.84,APPTIEN_",",5.1)=RREMIEN D FILE^DIE(,"FDA") K FDA
Q
GETAPPT(RECALLIEN) ;
N FILEROOT,FULLREF,APPTIEN,SDPATIEN,TRGTAPPT
S TRGTAPPT=""
S SDPATIEN=$$GET1^DIQ(403.5,RECALLIEN,.01,"I")
S FILEROOT=$$ROOT^DILFD(403.5)
S FULLREF=RECALLIEN_";"_$P(FILEROOT,U,2)
S APPTIEN=0 F S APPTIEN=$O(^SDEC(409.84,"CPAT",SDPATIEN,APPTIEN)) Q:'APPTIEN D
.I $$GET1^DIQ(409.84,APPTIEN,.22,"I")'=FULLREF Q
.S TRGTAPPT=APPTIEN
Q $G(TRGTAPPT)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRISRU 5357 printed Feb 19, 2025@00:27:18 Page 2
SDRRISRU ;ALB/MAH,BWF,JAS - Recall Reminder Utilities ;NOV 25, 2024
+1 ;;5.3;Scheduling;**536,627,648,799,818,866,895**;Aug 13, 1993;Build 11
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
OPENSLOT(SDRRIEN,SDRRST,SDRRND) ; Function returns the number of open (available)
+1 ; slots at the clinic during the time period.
+2 ; SDRRIEN - IEN of clinic in file #44
+3 ; SDRRST - (optional) start checking on this date (default=today)
+4 ; SDRRND - (optional) end of time period (default=last day of month)
+5 NEW SDRRNOAV,SDRRTOT,SDRRHOL,SDRRT,SDRRTPT,SDRRTPDT,SDRRDT,SDRRDA
+6 NEW SDRRFTR,CK,CLIN1,DA,DFN
+7 IF '$DATA(SDRRST)
SET SDRRST=DT
+8 ; end of month
IF '$DATA(SDRRND)
Begin DoDot:1
+9 SET SDRRND=$EXTRACT($$SCH^XLFDT("1M(L)",SDRRST),1,7)
+10 SET SDRRND=$$FMADD^XLFDT(SDRRND,1)
+11 if $EXTRACT(SDRRST,1,5)=$EXTRACT(SDRRND,1,5)
QUIT
+12 SET SDRRND=$$FMADD^XLFDT($EXTRACT(SDRRND,1,5)_"01",-1)
End DoDot:1
+13 SET SDRRST=$$FMADD^XLFDT(SDRRST,-1)
+14 SET SDRRNOAV=0
+15 IF '$ORDER(^SC(SDRRIEN,"OST",SDRRST))
IF '$ORDER(^SC(SDRRIEN,"ST",SDRRST,0))
Begin DoDot:1
+16 NEW SDRRI,SDRRDOW
+17 FOR SDRRI=0:1:6
SET SDRRDOW=$ORDER(^SC(SDRRIEN,"T"_SDRRI,SDRRST))
if SDRRDOW
QUIT
if SDRRDOW
SET SDRRNOAV=1
End DoDot:1
+18 ; No future dates available
IF SDRRNOAV
QUIT 0
+19 IF '$DATA(SDRRYEAR)
NEW SDRRYEAR
DO YEAR
+20 SET SDRRHOL=($PIECE($GET(^SC(SDRRIEN,"SL")),U,8)="Y")
+21 SET SDRRTOT=0
SET SDRRDT=SDRRST
+22 FOR
SET SDRRDT=$ORDER(SDRRYEAR(SDRRDT))
if SDRRDT>SDRRND!'SDRRDT
QUIT
Begin DoDot:1
+23 IF 'SDRRHOL
IF $PIECE(SDRRYEAR(SDRRDT),U,2)
QUIT
+24 ; Pattern
SET SDRRTPDT=$GET(^SC(SDRRIEN,"ST",SDRRDT,1))
+25 IF SDRRTPDT=""
Begin DoDot:2
+26 SET SDRRT="T"_+SDRRYEAR(SDRRDT)
+27 SET SDRRTPT=$ORDER(^SC(SDRRIEN,SDRRT,SDRRDT))
if SDRRTPT=""
QUIT
+28 SET SDRRTPDT=$GET(^SC(SDRRIEN,SDRRT,SDRRTPT,1))
End DoDot:2
if SDRRTPDT=""
QUIT
+29 SET SDRRTOT=SDRRTOT+$$AVAIL(SDRRTPDT)
End DoDot:1
+30 QUIT SDRRTOT
AVAIL(SDRRPAT) ; Given pattern, returns number of available slots.
+1 ; Check the pattern for available slots
+2 ; 0-9 and j-z = available slots where j=10, k=11...z=26
+3 ; $A(1)=49 $A(9)=57 $A("j")=106 $A("z")=122
+4 NEW SDRRCNT,SDRRCHAR,I
+5 SET SDRRCNT=0
+6 SET SDRRPAT=$TRANSLATE($EXTRACT(SDRRPAT,6,$LENGTH(SDRRPAT)),"|[] ","")
+7 FOR I=1:1:$LENGTH(SDRRPAT)
SET SDRRCHAR=$ASCII(SDRRPAT,I)
Begin DoDot:1
+8 IF SDRRCHAR>48
IF SDRRCHAR<58
SET SDRRCNT=SDRRCNT+$CHAR(SDRRCHAR)
QUIT
+9 IF SDRRCHAR>105
IF SDRRCHAR<123
SET SDRRCNT=SDRRCNT+SDRRCHAR-96
End DoDot:1
+10 QUIT SDRRCNT
YEAR ; Set-up 1 year dates
+1 ; This array is used for available appointments
+2 NEW SDRRI,SDRRDT
+3 SET SDRRDT=SDRRST
+4 FOR SDRRI=1:1:365
Begin DoDot:1
+5 SET SDRRDT=$$FMADD^XLFDT(SDRRDT,1)
+6 SET SDRRYEAR(SDRRDT)=$$DOW^XLFDT(SDRRDT,1)
+7 IF $DATA(^HOLIDAY(SDRRDT))
SET $PIECE(SDRRYEAR(SDRRDT),U,2)=1
End DoDot:1
if SDRRDT=SDRRND
QUIT
+8 QUIT
DELETE ; This entry point is invoked by the new style xref A66201 on the .01 field of file 403.5
+1 IF $DATA(SDRRDA)
IF $DATA(APPT)
IF $DATA(CLIN1)
Begin DoDot:1
+2 DO DELAPPT(SDRRDA,APPT,CLIN1)
End DoDot:1
QUIT
+3 DO DELUSER(DA)
+4 QUIT
DELAPPT(SDRRIEN,APPT,CLIN1) ; Record deleted from Recall List because of appointment.
+1 NEW SDRRFDA
+2 ; appt date
SET SDRRFDA(403.56,"+1,",101)=APPT
+3 ; appt clinic
SET SDRRFDA(403.56,"+1,",102)=CLIN1
+4 ; SD*648 - Add delete info
+5 ; delete date
SET SDRRFDA(403.56,"+1,",201)=$EXTRACT($$NOW^XLFDT(),1,12)
+6 ; delete clerk
SET SDRRFDA(403.56,"+1,",202)=DUZ
+7 ; delete reason:
if $GET(SDRRFTR)
SET SDRRFDA(403.56,"+1,",203)=SDRRFTR
+8 DO DELSET(SDRRIEN,.SDRRFDA)
+9 QUIT
DELUSER(SDRRIEN) ; Record deleted by a user.
+1 NEW SDRRFDA
+2 ; delete date
SET SDRRFDA(403.56,"+1,",201)=$EXTRACT($$NOW^XLFDT(),1,12)
+3 ; DELUSER is defined by SDES2DISPRECALL to ensure the correct user is defined as the delete clerk
+4 ; This will not be new'ed or killed in this routine. DELUSER is newed in SDES2DISPRECALL,
+5 ; which is firing off this trigger cross reference.
+6 ; delete clerk
SET SDRRFDA(403.56,"+1,",202)=$SELECT($GET(DELUSER):$GET(DELUSER),1:DUZ)
+7 ; delete reason:
if $GET(SDRRFTR)
SET SDRRFDA(403.56,"+1,",203)=SDRRFTR
+8 DO DELSET(SDRRIEN,.SDRRFDA)
+9 QUIT
DELSET(SDRRIEN,SDRRFDA) ;
+1 NEW SDRRREC,EAS,NEWIEN,APPTIEN,FDA,RREMIEN
+2 SET SDRRREC=$GET(^SD(403.5,SDRRIEN,0))
+3 SET EAS=$GET(^SD(403.5,SDRRIEN,1))
+4 ; patient
SET SDRRFDA(403.56,"+1,",.01)=$PIECE(SDRRREC,U,1)
+5 ; accession #
SET SDRRFDA(403.56,"+1,",2)=$PIECE(SDRRREC,U,3)
+6 ; comment
SET SDRRFDA(403.56,"+1,",2.5)=$$CTRL^XMXUTIL1($PIECE(SDRRREC,U,7))
+7 ; fast / non-fast
SET SDRRFDA(403.56,"+1,",2.6)=$PIECE(SDRRREC,U,8)
+8 ; test/app.
SET SDRRFDA(403.56,"+1,",3)=$PIECE(SDRRREC,U,4)
+9 ; provider
SET SDRRFDA(403.56,"+1,",4)=$PIECE(SDRRREC,U,5)
+10 ; clinic
SET SDRRFDA(403.56,"+1,",4.5)=$PIECE(SDRRREC,U,2)
+11 ; length of appt.
SET SDRRFDA(403.56,"+1,",4.7)=$PIECE(SDRRREC,U,9)
+12 ; recall date
SET SDRRFDA(403.56,"+1,",5)=$PIECE(SDRRREC,U,6)
+13 ; date reminder sent
SET SDRRFDA(403.56,"+1,",6)=$PIECE(SDRRREC,U,10)
+14 ; user who entered recall
SET SDRRFDA(403.56,"+1,",7)=$PIECE(SDRRREC,U,11)
+15 ;DATE/TIME RECALL ADDED
SET SDRRFDA(403.56,"+1,",7.5)=$PIECE(SDRRREC,U,14)
+16 ;EAS TRACKING NUMBER ADDED
SET SDRRFDA(403.56,"+1,",100)=EAS
+17 DO UPDATE^DIE("","SDRRFDA","NEWIEN")
+18 SET RREMIEN=$GET(NEWIEN(1))
IF 'RREMIEN
QUIT
+19 ;
+20 NEW CAFDA
+21 SET CAFDA(403.58,"+1,"_RREMIEN_",",.01)=$$NOW^XLFDT
+22 SET CAFDA(403.58,"+1,"_RREMIEN_",",1)=$PIECE(SDRRREC,U,11)
+23 SET CAFDA(403.58,"+1,"_RREMIEN_",",2)=$$CTRL^XMXUTIL1($PIECE(SDRRREC,U,7))
+24 DO UPDATE^DIE("","CAFDA")
KILL CAFDA
+25 ;
+26 SET APPTIEN=$$GETAPPT(SDRRIEN)
if 'APPTIEN
QUIT
+27 SET FDA(409.84,APPTIEN_",",5.1)=RREMIEN
DO FILE^DIE(,"FDA")
KILL FDA
+28 QUIT
GETAPPT(RECALLIEN) ;
+1 NEW FILEROOT,FULLREF,APPTIEN,SDPATIEN,TRGTAPPT
+2 SET TRGTAPPT=""
+3 SET SDPATIEN=$$GET1^DIQ(403.5,RECALLIEN,.01,"I")
+4 SET FILEROOT=$$ROOT^DILFD(403.5)
+5 SET FULLREF=RECALLIEN_";"_$PIECE(FILEROOT,U,2)
+6 SET APPTIEN=0
FOR
SET APPTIEN=$ORDER(^SDEC(409.84,"CPAT",SDPATIEN,APPTIEN))
if 'APPTIEN
QUIT
Begin DoDot:1
+7 IF $$GET1^DIQ(409.84,APPTIEN,.22,"I")'=FULLREF
QUIT
+8 SET TRGTAPPT=APPTIEN
End DoDot:1
+9 QUIT $GET(TRGTAPPT)
