- SDRRISRL ;10N20/MAH;Recall Reminder Open Slots Report;01/18/2008
- ;;5.3;Scheduling;**536**;Aug 13, 1993;Build 53
- ; Option: SDRR RECALL LIST
- EN ;
- N SDRRST,SDRRND,SDRRSTX,SDRRNDX,SDRRBRK,SDRRABORT,DIRUT,I,ZTSAVE,XMDUZ,XMSUB,ZTQUEUED,ZTSK
- N SDRRDIV,ZTDESC
- S SDRRABORT=0
- W !!,"Select a time period and a set of clinics, and I'll tell you all the"
- W !,"patients who are on the Recall List for that time period at those clinics."
- W !,"For each month, I'll also tell you how many slots are available in each clinic.",!
- W !,"First select the Recall Date range."
- S SDRRST=$E(DT,1,5)_"01" ; 1st of this month
- I $E(DT,4,5)>27 S SDRRST=$E($$FMADD^XLFDT(SDRRST,31),1,5)_"01" ; 1st of next month
- S SDRRND=$E($$SCH^XLFDT("3M",SDRRST),1,7) ; 3 months later
- D DRANGE^SDRRUTL(.SDRRST,.SDRRND,.SDRRSTX,.SDRRNDX,.SDRRABORT,SDRRST,$$FMADD^XLFDT(DT,366),1) Q:SDRRABORT
- K ^TMP("SDRR",$J)
- D ASKDIV^SDRRPXC(.SDRRDIV) Q:'SDRRDIV
- D ASKCLIN^SDRRPXC(.SDRRDIV,SDRRST,SDRRND) Q:'$D(^TMP("SDRR",$J))
- W !
- N DIR,X,Y
- S DIR(0)="Y"
- S DIR("A")="Page break on clinic"
- S DIR("B")="Yes"
- D ^DIR Q:$D(DIRUT)
- S SDRRBRK=Y ; Page break on Clinic
- S XMSUB="Future Recall Slots, "_$S(SDRRST=SDRRND:SDRRSTX,1:SDRRSTX_"-"_SDRRNDX)
- F I="SDRRDIV","SDRRDIV(","SDRRST","SDRRSTX","SDRRND","SDRRNDX","SDRRBRK","^TMP(""SDRR"",$J," S ZTSAVE(I)=""
- D EN^XUTMDEVQ("CONTROL^SDRRISRL",XMSUB,.ZTSAVE,,1)
- I '$D(ZTQUEUED),$D(ZTSK) W !,"Request queued. (Task: ",ZTSK,")"
- Q
- CONTROL ;
- N SDRRIA,SDRRCLIST
- S SDRRIA=$E($G(IOST),1,2)="C-"
- D CLINLIST^SDRRISB(.SDRRCLIST)
- D GATHER
- D PRINT
- K ^TMP("SDRR",$J)
- Q
- GATHER ; Gather Patient from Recall List
- N SDRRDT,SDRRIEN,SDRRDFN,SDRRREC,SDRRDFN0,SDRRCLIN,SDRRCLERK,SDRRSDT,SDRRPHONE,DFN,VA,VADM,VAPA,Z
- S SDRRND=SDRRND+.9999
- S SDRRDT=SDRRST-.1
- S SDRRIEN="" ; "D" xref is on the RECALL DATE field
- F S SDRRDT=$O(^SD(403.5,"D",SDRRDT)) Q:SDRRDT>SDRRND!'SDRRDT D
- . F S SDRRIEN=$O(^SD(403.5,"D",SDRRDT,SDRRIEN)) Q:'SDRRIEN D
- . . S SDRRREC=$G(^SD(403.5,SDRRIEN,0))
- . . S SDRRCLIN=+$P(SDRRREC,U,2)
- . . Q:'$D(SDRRCLIST(SDRRCLIN)) ; Must be clinic we want
- . . S SDRRDFN=+SDRRREC
- . . Q:$$TESTPAT^VADPT(SDRRDFN) ; Test patient
- . . S SDRRSDT=$P(SDRRREC,U,10) ; Reminder sent date
- . . S SDRRCLERK=+$P(SDRRREC,U,11) ; Clerk who entered the recall
- . . S Z=$P(SDRRREC,U,13) I Z'="" S Z="*"
- . . S DFN=SDRRDFN
- . . D ADD^VADPT,DEM^VADPT
- . . S ^TMP("SDRR",$J,"PRT",SDRRCLIST(SDRRCLIN)_U_SDRRCLIN,SDRRDT,$P(VADM(1),U)_U_SDRRDFN)=$P(VA("BID"),U)_U_$P(VAPA(8),U)_U_SDRRCLERK_U_SDRRSDT_U_Z
- D KVAR^VADPT
- Q
- PRINT ;
- N SDRRTODAY,SDRRCLIN,SDRRCLSAV,SDRRDT,SDRRDTSAV,SDRRREC,SDRRPAGE,SDRRABORT,SDRRDR,SDRRRP
- N SDRRCLERK,SDRRPAT,SDRRSSN,SDRRCNT,SDRRDTX,SDRRPHONE,SDRRSDT,SDRRMDT,SDRRMDTX
- N SDRRPROV
- S SDRRMDT=$$FMADD^XLFDT(DT,1) ; earliest date to look for slot availability
- S SDRRMDTX=$$FMTE^XLFDT(SDRRMDT,"2Z")
- S (SDRRABORT,SDRRPAGE,SDRRCNT)=0
- I SDRRIA W @IOF
- S SDRRTODAY=$$FMTE^XLFDT(DT)
- S SDRRDR=$$CJ^XLFSTR(ZTDESC,IOM-1)
- S $E(SDRRDR,1,$L(SDRRTODAY))=SDRRTODAY
- S SDRRDR=$E(SDRRDR,1,IOM-8)_"Page"
- D HEADER
- I '$D(^TMP("SDRR",$J,"PRT")) W !,"No Recalls found for this date range." Q
- S (SDRRCLIN,SDRRDT,SDRRPAT)=""
- S SDRRCLSAV=SDRRCLIN
- F S SDRRCLIN=$O(^TMP("SDRR",$J,"PRT",SDRRCLIN)) Q:SDRRCLIN="" D Q:SDRRABORT
- . I SDRRCLSAV'="",SDRRBRK!($Y+5+SDRRIA>IOSL) D Q:SDRRABORT
- . . I SDRRIA D PAGE^XMXUTIL(.SDRRABORT) Q:SDRRABORT
- . . W @IOF D HEADER
- . S SDRRCLSAV=SDRRCLIN
- . S SDRRPROV=$$PRDEF^SDCO31($P(SDRRCLIN,U,2))
- . I SDRRPROV="" S SDRRPROV="(No Default Provider)"
- . W !!,$$CJ^XLFSTR(" "_$P(SDRRCLIN,U)_" "_SDRRPROV_" ",79,"-")
- . S SDRRDTSAV=SDRRDT
- . F S SDRRDT=$O(^TMP("SDRR",$J,"PRT",SDRRCLIN,SDRRDT)) Q:'SDRRDT D Q:SDRRABORT
- . . S SDRRDTX=$$FMTE^XLFDT(SDRRDT,"2Z")
- . . I SDRRDTSAV'=$E(SDRRDT,1,5) D Q:SDRRABORT
- . . . I SDRRDTSAV D SUBTOT
- . . . S SDRRCNT=0
- . . . S SDRRDTSAV=$E(SDRRDT,1,5)
- . . . I $Y+2+SDRRIA>IOSL D Q:SDRRABORT
- . . . . I SDRRIA D PAGE^XMXUTIL(.SDRRABORT) Q:SDRRABORT
- . . . . W @IOF D HEADER
- . . . W !
- . . F S SDRRPAT=$O(^TMP("SDRR",$J,"PRT",SDRRCLIN,SDRRDT,SDRRPAT)) Q:SDRRPAT="" S SDRRREC=^(SDRRPAT) D Q:SDRRABORT
- . . . S SDRRCNT=SDRRCNT+1
- . . . S SDRRSSN=$E(SDRRREC,1,4)
- . . . S SDRRPHONE=$P(SDRRREC,U,2)
- . . . S SDRRCLERK=$P(SDRRREC,U,3) S SDRRCLERK=$$NAME^XUSER(SDRRCLERK,"F")
- . . . S SDRRSDT=$P(SDRRREC,U,4)
- . . . S SDRRRP=$P(SDRRREC,U,5)
- . . . I $Y+2+SDRRIA>IOSL D Q:SDRRABORT
- . . . . I SDRRIA D PAGE^XMXUTIL(.SDRRABORT) Q:SDRRABORT
- . . . . W @IOF D HEADER
- . . . W !,SDRRDTX,?10,SDRRRP_$$FMTE^XLFDT(SDRRSDT,"2Z"),?20,$E($P(SDRRPAT,U),1,17),?38,SDRRSSN,?43,SDRRPHONE,?64,$E(SDRRCLERK,1,15)
- . Q:SDRRABORT
- . D SUBTOT
- Q:SDRRABORT
- I SDRRIA D WAIT^XMXUTIL
- Q
- S SDRRPAGE=SDRRPAGE+1
- W SDRRDR,$J(SDRRPAGE,3)
- W !!,?10,"Reminder",?64,"Recall"
- W !,"Recall",?10,"Sent",?20,"Patient",?38,"SSN",?43,"Home Phone",?64,"Entered by"
- Q
- SUBTOT ;
- I $Y+3+SDRRIA>IOSL D Q:SDRRABORT
- . I SDRRIA D PAGE^XMXUTIL(.SDRRABORT) Q:SDRRABORT
- . W @IOF D HEADER
- W !!,$$FMTE^XLFDT(SDRRDTSAV_"00",1)," Patient Recalls: ",SDRRCNT,", Available Slots: ",$$OPENSLOT^SDRRISRU($P(SDRRCLIN,U,2),$S(SDRRDTSAV=$E(SDRRMDT,1,5):SDRRMDT,1:SDRRDTSAV_"01"))
- I SDRRDTSAV=$E(SDRRMDT,1,5) W " (",SDRRMDTX," through EOM)"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRISRL 5298 printed Feb 19, 2025@00:27:17 Page 2
- SDRRISRL ;10N20/MAH;Recall Reminder Open Slots Report;01/18/2008
- +1 ;;5.3;Scheduling;**536**;Aug 13, 1993;Build 53
- +2 ; Option: SDRR RECALL LIST
- EN ;
- +1 NEW SDRRST,SDRRND,SDRRSTX,SDRRNDX,SDRRBRK,SDRRABORT,DIRUT,I,ZTSAVE,XMDUZ,XMSUB,ZTQUEUED,ZTSK
- +2 NEW SDRRDIV,ZTDESC
- +3 SET SDRRABORT=0
- +4 WRITE !!,"Select a time period and a set of clinics, and I'll tell you all the"
- +5 WRITE !,"patients who are on the Recall List for that time period at those clinics."
- +6 WRITE !,"For each month, I'll also tell you how many slots are available in each clinic.",!
- +7 WRITE !,"First select the Recall Date range."
- +8 ; 1st of this month
- SET SDRRST=$EXTRACT(DT,1,5)_"01"
- +9 ; 1st of next month
- IF $EXTRACT(DT,4,5)>27
- SET SDRRST=$EXTRACT($$FMADD^XLFDT(SDRRST,31),1,5)_"01"
- +10 ; 3 months later
- SET SDRRND=$EXTRACT($$SCH^XLFDT("3M",SDRRST),1,7)
- +11 DO DRANGE^SDRRUTL(.SDRRST,.SDRRND,.SDRRSTX,.SDRRNDX,.SDRRABORT,SDRRST,$$FMADD^XLFDT(DT,366),1)
- if SDRRABORT
- QUIT
- +12 KILL ^TMP("SDRR",$JOB)
- +13 DO ASKDIV^SDRRPXC(.SDRRDIV)
- if 'SDRRDIV
- QUIT
- +14 DO ASKCLIN^SDRRPXC(.SDRRDIV,SDRRST,SDRRND)
- if '$DATA(^TMP("SDRR",$JOB))
- QUIT
- +15 WRITE !
- +16 NEW DIR,X,Y
- +17 SET DIR(0)="Y"
- +18 SET DIR("A")="Page break on clinic"
- +19 SET DIR("B")="Yes"
- +20 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +21 ; Page break on Clinic
- SET SDRRBRK=Y
- +22 SET XMSUB="Future Recall Slots, "_$SELECT(SDRRST=SDRRND:SDRRSTX,1:SDRRSTX_"-"_SDRRNDX)
- +23 FOR I="SDRRDIV","SDRRDIV(","SDRRST","SDRRSTX","SDRRND","SDRRNDX","SDRRBRK","^TMP(""SDRR"",$J,"
- SET ZTSAVE(I)=""
- +24 DO EN^XUTMDEVQ("CONTROL^SDRRISRL",XMSUB,.ZTSAVE,,1)
- +25 IF '$DATA(ZTQUEUED)
- IF $DATA(ZTSK)
- WRITE !,"Request queued. (Task: ",ZTSK,")"
- +26 QUIT
- CONTROL ;
- +1 NEW SDRRIA,SDRRCLIST
- +2 SET SDRRIA=$EXTRACT($GET(IOST),1,2)="C-"
- +3 DO CLINLIST^SDRRISB(.SDRRCLIST)
- +4 DO GATHER
- +5 DO PRINT
- +6 KILL ^TMP("SDRR",$JOB)
- +7 QUIT
- GATHER ; Gather Patient from Recall List
- +1 NEW SDRRDT,SDRRIEN,SDRRDFN,SDRRREC,SDRRDFN0,SDRRCLIN,SDRRCLERK,SDRRSDT,SDRRPHONE,DFN,VA,VADM,VAPA,Z
- +2 SET SDRRND=SDRRND+.9999
- +3 SET SDRRDT=SDRRST-.1
- +4 ; "D" xref is on the RECALL DATE field
- SET SDRRIEN=""
- +5 FOR
- SET SDRRDT=$ORDER(^SD(403.5,"D",SDRRDT))
- if SDRRDT>SDRRND!'SDRRDT
- QUIT
- Begin DoDot:1
- +6 FOR
- SET SDRRIEN=$ORDER(^SD(403.5,"D",SDRRDT,SDRRIEN))
- if 'SDRRIEN
- QUIT
- Begin DoDot:2
- +7 SET SDRRREC=$GET(^SD(403.5,SDRRIEN,0))
- +8 SET SDRRCLIN=+$PIECE(SDRRREC,U,2)
- +9 ; Must be clinic we want
- if '$DATA(SDRRCLIST(SDRRCLIN))
- QUIT
- +10 SET SDRRDFN=+SDRRREC
- +11 ; Test patient
- if $$TESTPAT^VADPT(SDRRDFN)
- QUIT
- +12 ; Reminder sent date
- SET SDRRSDT=$PIECE(SDRRREC,U,10)
- +13 ; Clerk who entered the recall
- SET SDRRCLERK=+$PIECE(SDRRREC,U,11)
- +14 SET Z=$PIECE(SDRRREC,U,13)
- IF Z'=""
- SET Z="*"
- +15 SET DFN=SDRRDFN
- +16 DO ADD^VADPT
- DO DEM^VADPT
- +17 SET ^TMP("SDRR",$JOB,"PRT",SDRRCLIST(SDRRCLIN)_U_SDRRCLIN,SDRRDT,$PIECE(VADM(1),U)_U_SDRRDFN)=$PIECE(VA("BID"),U)_U_$PIECE(VAPA(8),U)_U_SDRRCLERK_U_SDRRSDT_U_Z
- End DoDot:2
- End DoDot:1
- +18 DO KVAR^VADPT
- +19 QUIT
- PRINT ;
- +1 NEW SDRRTODAY,SDRRCLIN,SDRRCLSAV,SDRRDT,SDRRDTSAV,SDRRREC,SDRRPAGE,SDRRABORT,SDRRDR,SDRRRP
- +2 NEW SDRRCLERK,SDRRPAT,SDRRSSN,SDRRCNT,SDRRDTX,SDRRPHONE,SDRRSDT,SDRRMDT,SDRRMDTX
- +3 NEW SDRRPROV
- +4 ; earliest date to look for slot availability
- SET SDRRMDT=$$FMADD^XLFDT(DT,1)
- +5 SET SDRRMDTX=$$FMTE^XLFDT(SDRRMDT,"2Z")
- +6 SET (SDRRABORT,SDRRPAGE,SDRRCNT)=0
- +7 IF SDRRIA
- WRITE @IOF
- +8 SET SDRRTODAY=$$FMTE^XLFDT(DT)
- +9 SET SDRRDR=$$CJ^XLFSTR(ZTDESC,IOM-1)
- +10 SET $EXTRACT(SDRRDR,1,$LENGTH(SDRRTODAY))=SDRRTODAY
- +11 SET SDRRDR=$EXTRACT(SDRRDR,1,IOM-8)_"Page"
- +12 DO HEADER
- +13 IF '$DATA(^TMP("SDRR",$JOB,"PRT"))
- WRITE !,"No Recalls found for this date range."
- QUIT
- +14 SET (SDRRCLIN,SDRRDT,SDRRPAT)=""
- +15 SET SDRRCLSAV=SDRRCLIN
- +16 FOR
- SET SDRRCLIN=$ORDER(^TMP("SDRR",$JOB,"PRT",SDRRCLIN))
- if SDRRCLIN=""
- QUIT
- Begin DoDot:1
- +17 IF SDRRCLSAV'=""
- IF SDRRBRK!($Y+5+SDRRIA>IOSL)
- Begin DoDot:2
- +18 IF SDRRIA
- DO PAGE^XMXUTIL(.SDRRABORT)
- if SDRRABORT
- QUIT
- +19 WRITE @IOF
- DO HEADER
- End DoDot:2
- if SDRRABORT
- QUIT
- +20 SET SDRRCLSAV=SDRRCLIN
- +21 SET SDRRPROV=$$PRDEF^SDCO31($PIECE(SDRRCLIN,U,2))
- +22 IF SDRRPROV=""
- SET SDRRPROV="(No Default Provider)"
- +23 WRITE !!,$$CJ^XLFSTR(" "_$PIECE(SDRRCLIN,U)_" "_SDRRPROV_" ",79,"-")
- +24 SET SDRRDTSAV=SDRRDT
- +25 FOR
- SET SDRRDT=$ORDER(^TMP("SDRR",$JOB,"PRT",SDRRCLIN,SDRRDT))
- if 'SDRRDT
- QUIT
- Begin DoDot:2
- +26 SET SDRRDTX=$$FMTE^XLFDT(SDRRDT,"2Z")
- +27 IF SDRRDTSAV'=$EXTRACT(SDRRDT,1,5)
- Begin DoDot:3
- +28 IF SDRRDTSAV
- DO SUBTOT
- +29 SET SDRRCNT=0
- +30 SET SDRRDTSAV=$EXTRACT(SDRRDT,1,5)
- +31 IF $Y+2+SDRRIA>IOSL
- Begin DoDot:4
- +32 IF SDRRIA
- DO PAGE^XMXUTIL(.SDRRABORT)
- if SDRRABORT
- QUIT
- +33 WRITE @IOF
- DO HEADER
- End DoDot:4
- if SDRRABORT
- QUIT
- +34 WRITE !
- End DoDot:3
- if SDRRABORT
- QUIT
- +35 FOR
- SET SDRRPAT=$ORDER(^TMP("SDRR",$JOB,"PRT",SDRRCLIN,SDRRDT,SDRRPAT))
- if SDRRPAT=""
- QUIT
- SET SDRRREC=^(SDRRPAT)
- Begin DoDot:3
- +36 SET SDRRCNT=SDRRCNT+1
- +37 SET SDRRSSN=$EXTRACT(SDRRREC,1,4)
- +38 SET SDRRPHONE=$PIECE(SDRRREC,U,2)
- +39 SET SDRRCLERK=$PIECE(SDRRREC,U,3)
- SET SDRRCLERK=$$NAME^XUSER(SDRRCLERK,"F")
- +40 SET SDRRSDT=$PIECE(SDRRREC,U,4)
- +41 SET SDRRRP=$PIECE(SDRRREC,U,5)
- +42 IF $Y+2+SDRRIA>IOSL
- Begin DoDot:4
- +43 IF SDRRIA
- DO PAGE^XMXUTIL(.SDRRABORT)
- if SDRRABORT
- QUIT
- +44 WRITE @IOF
- DO HEADER
- End DoDot:4
- if SDRRABORT
- QUIT
- +45 WRITE !,SDRRDTX,?10,SDRRRP_$$FMTE^XLFDT(SDRRSDT,"2Z"),?20,$EXTRACT($PIECE(SDRRPAT,U),1,17),?38,SDRRSSN,?43,SDRRPHONE,?64,$EXTRACT(SDRRCLERK,1,15)
- End DoDot:3
- if SDRRABORT
- QUIT
- End DoDot:2
- if SDRRABORT
- QUIT
- +46 if SDRRABORT
- QUIT
- +47 DO SUBTOT
- End DoDot:1
- if SDRRABORT
- QUIT
- +48 if SDRRABORT
- QUIT
- +49 IF SDRRIA
- DO WAIT^XMXUTIL
- +50 QUIT
- +1 SET SDRRPAGE=SDRRPAGE+1
- +2 WRITE SDRRDR,$JUSTIFY(SDRRPAGE,3)
- +3 WRITE !!,?10,"Reminder",?64,"Recall"
- +4 WRITE !,"Recall",?10,"Sent",?20,"Patient",?38,"SSN",?43,"Home Phone",?64,"Entered by"
- +5 QUIT
- SUBTOT ;
- +1 IF $Y+3+SDRRIA>IOSL
- Begin DoDot:1
- +2 IF SDRRIA
- DO PAGE^XMXUTIL(.SDRRABORT)
- if SDRRABORT
- QUIT
- +3 WRITE @IOF
- DO HEADER
- End DoDot:1
- if SDRRABORT
- QUIT
- +4 WRITE !!,$$FMTE^XLFDT(SDRRDTSAV_"00",1)," Patient Recalls: ",SDRRCNT,", Available Slots: ",$$OPENSLOT^SDRRISRU($PIECE(SDRRCLIN,U,2),$SELECT(SDRRDTSAV=$EXTRACT(SDRRMDT,1,5):SDRRMDT,1:SDRRDTSAV_"01"))
- +5 IF SDRRDTSAV=$EXTRACT(SDRRMDT,1,5)
- WRITE " (",SDRRMDTX," through EOM)"
- +6 QUIT
