SDRRRECL.m

SDRRRECL ;10N20/MAH - Recall Reminder Manual Printing;09/20/2004

 ;;5.3;Scheduling;**536,561,569,579,654,685**;Aug 13, 1993;Build 3

 ;;This routine is called from SDRRLRP 

 ;;If the site has set TYPE OF NOTIFICATION to LETTER this routine

 ;;will run.

 ;

 ; SD*654

 ; - do not update date if letter printed to a computer screen.

 ; - adds missing var DFN when calling $$BADADR^DGUTL3 and

 ;   quits updating date and printing ltr if bad addr.

 ; - changes word 'card' to 'letter' in the message.

 ; - fixes incomplete Canadian address.

 ;

 K TYPE

MEN ;SET UP WHAT ARE THEY WOULD LIKE TO PRINT FOR LETTERS

 K DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT

 S DIR(0)="SO^1:Print Letters by Clinic;2:Print Letters by Provider;3:Print Letters by Team;4:Print a Letter by Patient;5:Print Letters for Nonresponsive Patients"

 W ! S DIR("A")="Please select what you are looking for"

 D ^DIR G:$D(DUOUT)!($D(DTOUT)!($D(DIRUT))) QUIT S Q=Y

 I Q=1 G EN

 I Q=2 G EN1

 I Q=3 G EN3

 I Q=4 G EN4

 I Q=5 G EN5

 Q

EN ;PRINT BY CLINIC

 S DIC="^SC(",DIC(0)="AEQMZ" D ^DIC Q:Y<0  S DIV=+Y G:Y<0 QUIT

 I '$D(^SD(403.52,"B",DIV)) W !,?5,"**NO RECALL LETTER ON FILE**" G QUIT

 D SELDT G:Y<0 QUIT  ;SD*561 quit if no date range entered

 S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Letters by Clinic",ZTRTN="DQD^SDRRRECL" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT

DQD K ^TMP($J)

 U IO S D0=0 F  S D0=$O(^SD(403.5,"E",DIV,D0)) Q:D0=""  S DTA=$G(^SD(403.5,D0,0)) D:DTA]""

 .S TIME=""

 .I $P(^SD(403.5,D0,0),"^",9)>30 S TIME=$P(^SD(403.5,D0,0),"^",9) S TIME="**"_TIME_"**"

 .S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$P(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",1:"")

 .S DFN=+DTA

 .Q:$P(DTA,U,6)<SDT!($P(DTA,U,6)>EDT)

 .Q:$$TESTPAT^VADPT(DFN)

 .D ADD^VADPT,DEM^VADPT

 .S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)

 .S PN=$P(VADM(1),U)

 .I $G(VADM(6),U)'="" Q

 .; SD*654 - add missing var DFN

 .;        - quit updating date and printing ltr if bad addr

 .S CHECK=$$BADADR^DGUTL3(DFN) I CHECK>0 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D  Q

 ..S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5

 ..S SDRR(1)="Bad Address - letter will not be printed for:"_"   "_PN_"   "_VA("BID")

 ..D ^XMD

 ..K XMY,XMSUB,XMTEXT,XMDUZ

 .;ADDED THE DATE INFORMATION

 .; SD*654 - do not update date if displaying to a computer screen.

 .I $E(IOST,1,2)'="C-" S $P(^SD(403.5,D0,0),"^",10)=DT

 .D PR

 D ^%ZISC G QUIT

 ;;done and tested

QUIT K ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,DIV,EDT,PR,SDT,FAST,TIME,ACC

 K LINE,LETTER,MESSAGE,TEST,DOD,CLINIC,FAIL,TEAM,LAB,SDRR,Q,%DT,%ZIS,CHECK,VA,ZTDESC,ZTIO,ZTRTN,ZTSAVE,STATE Q

 D KVAR^VADPT

 Q

SELDT S %DT="AEX",%DT("A")="Start with RECALL DATE: " D ^%DT Q:Y<0  S SDT=Y,%DT("A")="End with RECALL DATE: " D ^%DT I Y<SDT W $C(7),"  ??" G SELDT

 S EDT=Y Q

PR S LETTER=0

 ; SD*579 - Add date printed and last 4

 S PRNDT=$TR($$FMTE^XLFDT(DT,"5DF")," ","0")

 S LAST4=$E($P(VA("BID"),U),1,4)

 W @IOF

 W !,?65,PRNDT

 W !,?65,$E(PN,1)_LAST4

 F L=1:1:9 W !

 ;

 ; SD*579 - Fix suffix listed problem

 S PNAME=$$NAMEFMT^XLFNAME(PN,"G","")

 W !?20,PNAME

 D ADDR

 I $D(MESSAGE) W !!!!!,?25,MESSAGE

 ; SD*569 - Adjust the tab starting position

 I TIME'="" W !!!!?2,TIME

 I LAB'="" W !!!!!,?2,"*"_LAB

 W !!!

 S:'$D(MESSAGE) LETTER=$O(^SD(403.52,"B",DIV,LETTER))

 I LETTER>0 S LINE=0 F  S LINE=$O(^SD(403.52,LETTER,1,LINE)) Q:'LINE  W !,?2,$P(^SD(403.52,LETTER,1,LINE,0),"^",1)

 K MESSAGE,PRNDT,LAST4,PNAME

 Q

EN1 ;print letters by provider

 S DIC="^SD(403.54,",DIC(0)="AEQMZ",DIC("A")="Select Provider: " D ^DIC G:Y<0 QUIT S PR=+Y

 D SELDT G:Y<0 QUIT  ;SD*5.3*561 quit if no date range entered

 S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Letters by Provider",ZTRTN="DQD1^SDRRRECL" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT

DQD1 K ^TMP($J)

 U IO S D0=0 F  S D0=$O(^SD(403.5,"C",PR,D0)) Q:D0=""  S (CLINIC,FAIL)=0 S CLINIC=$P($G(^SD(403.5,D0,0)),"^",2) D

 .; SD*579 - If entry not exist, kill x-refs and quit.

 .I '$D(^SD(403.5,D0)) D KXREF Q

 .S DTA=$G(^SD(403.5,D0,0))

 .I CLINIC="" S FAIL=1 S MESSAGE="***NO CLINIC ON FILE**"

 .I CLINIC'=""  I '$D(^SD(403.52,"B",CLINIC))  S MESSAGE="***NO CLINIC LETTER ON FILE**" S FAIL=1

 .I CLINIC'="",(FAIL=0) S DIV=CLINIC S LETTER=0,LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))

 .S TIME=""

 .I $P($G(^SD(403.5,D0,0)),"^",9)>30 S TIME=$P($G(^SD(403.5,D0,0)),"^",9) S TIME="**"_TIME_"**"

 .S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$P(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",1:"")

 .S DFN=+DTA

 .Q:$P(DTA,U,6)<SDT!($P(DTA,U,6)>EDT)

 .Q:$$TESTPAT^VADPT(DFN)

 .D ADD^VADPT,DEM^VADPT

 .S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)

 .S PN=$P(VADM(1),U)

 .I $G(VADM(6),U)'="" Q

 .; SD*654 - add missing var DFN

 .;        - quit updating date and printing ltr if bad addr

 .S CHECK=$$BADADR^DGUTL3(DFN) I CHECK>0 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D  Q

 ..S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5

 ..S SDRR(1)="Bad Address - letter will not be printed for:"_"   "_PN_"   "_VA("BID")

 ..D ^XMD

 ..K XMY,XMSUB,XMTEXT,XMDUZ

 .;ADDED THE DATE INFORMATION

 .; SD*654 - do not update date if letter printed to a computer screen.

 .I $E(IOST,1,2)'="C-" S $P(^SD(403.5,D0,0),"^",10)=DT

 .D PR

 D ^%ZISC G QUIT

EN3 ;PRINT LETTER FOR A TEAM

 W ! S DIC="^SD(403.55,",DIC(0)="AEQMZ",DIC("A")="Select Clinic Recall Team: " D ^DIC S TEAM=+Y K DIC G:Y<0 QUIT

 D SELDT G:Y<0 QUIT  ;SD*561 quit if no date range entered

 S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Letters for a Team",ZTRTN="DQD4^SDRRRECL" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT

DQD4 S PR=0 F  S PR=$O(^SD(403.54,"C",TEAM,PR)) Q:'PR  S D0=0 D

 .F  S D0=$O(^SD(403.5,"C",PR,D0)) Q:D0=""  S (CLINIC,FAIL)=0 S CLINIC=$P($G(^SD(403.5,D0,0)),"^",2) D

 ..; SD*579 - If entry not exist, kill x-refs and quit.

 ..I '$D(^SD(403.5,D0)) D KXREF Q

 ..S DTA=$G(^SD(403.5,D0,0))

 ..I CLINIC="" S FAIL=1 S MESSAGE="***NO CLINIC ON FILE**"

 ..I CLINIC'=""  I '$D(^SD(403.52,"B",CLINIC))  S MESSAGE="***NO CLINIC LETTER ON FILE**" S FAIL=1

 ..I CLINIC'="",(FAIL=0) S DIV=CLINIC S LETTER=0,LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))

 ..S TIME=""

 ..I $P($G(^SD(403.5,D0,0)),"^",9)>30 S TIME=$P($G(^SD(403.5,D0,0)),"^",9) S TIME="**"_TIME_"**"

 ..S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$P(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",1:"")

 ..S DFN=+DTA

 ..Q:$P(DTA,U,6)<SDT!($P(DTA,U,6)>EDT)  ;SD*561 check selected date range

 ..Q:$$TESTPAT^VADPT(DFN)

 ..D ADD^VADPT,DEM^VADPT

 ..S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)

 ..S PN=$P(VADM(1),U)

 ..I $G(VADM(6),U)'="" Q

 ..; SD*654 - add missing var DFN

 ..;        - quit updating date and printing ltr if bad addr

 ..S CHECK=$$BADADR^DGUTL3(DFN) I CHECK>0 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D  Q

 ...S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5

 ...S SDRR(1)="Bad Address - letter will not be printed for:"_"   "_PN_"   "_VA("BID")

 ...D ^XMD

 ...K XMY,XMSUB,XMTEXT,XMDUZ

 ..;ADDED THE DATE INFORMATION

 ..; SD*654 - do not update date if letter printed to a computer screen.

 ..I $E(IOST,1,2)'="C-" S $P(^SD(403.5,D0,0),"^",10)=DT

 ..D PR

 D ^%ZISC G QUIT

 ;done and tested

EN4 ;PRINT LETTER FOR ONE PATIENT

 K X W ! S DIC="^SD(403.5,",DIC(0)="AEQMZ",DIC("A")="Select Patient: " D ^DIC S D0=+Y K DIC G:Y<0 QUIT

 S DIC="^SC(",DIC(0)="AEQMZ" D ^DIC Q:Y<0  S DIV=+Y K DIC G:Y<0 QUIT

 I '$D(^SD(403.52,"B",DIV)) W !,?5,"**NO RECALL LETTER ON FILE**" G QUIT

 I '$D(^SD(403.5,"E",DIV,D0)) W *7,!!,?5,"**This patient does not have a recall reminder for the selected clinic**",!! G QUIT

 ;

 ; SD*654 - Check if it needs to quit before prompting for device

 S DFN=+$G(^SD(403.5,D0,0))

 D DEM^VADPT

 S PN=$P(VADM(1),U)

 ; SD*654 - add missing var DFN

 ;        - quit updating date and printing ltr if bad addr

 S CHECK=$$BADADR^DGUTL3(DFN) I CHECK>0 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D  W !!,?5,"**This patient has been flagged with a Bad Address Indicator.**",!! G QUIT

 . S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5

 . S SDRR(1)="Bad Address - letter will not be printed for:"_"   "_PN_" "_VA("BID")

 . D ^XMD

 . K XMY,SMSUB,XMTEXT,XMDUZ

 ; quit if DoD

 I $G(VADM(6),U)'="" W !!,?5,VADM(7),!! G QUIT

 ; quit if test pat

 I $$TESTPAT^VADPT(DFN) W !!,?5,"**You may have selected a test patient.**",!! G QUIT

 ; SD*654 - End

 ;

 S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Letters for a Patient",ZTRTN="DQD3^SDRRRECL" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT

DQD3 K ^TMP($J)

 S DTA=$G(^SD(403.5,D0,0)) D:DTA]""

 .; SD*569 - Quit if patient's clinic does not match the selected hospital location.

 .I $P(DTA,"^",2)'=DIV Q

 .S TIME=""

 .I $P(^SD(403.5,D0,0),"^",9)>30 S TIME=$P(^SD(403.5,D0,0),"^",9) S TIME="**"_TIME_"**"

 .S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$P(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",1:"")

 .S DFN=+DTA

 .D ADD^VADPT

 .S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)

 .;ADDED THE DATE INFORMATION

 .; SD*654 - do not update date if letter printed to a computer screen.

 .I $E(IOST,1,2)'="C-" S $P(^SD(403.5,D0,0),"^",10)=DT

 .D PR

 D ^%ZISC G QUIT

EN5 ;Print LETTERS for Nonresponsive

 S TEAM=""

 S DIC="^SD(403.55,",DIC(0)="AEQMZ",DIC("A")="Select Clinic Recall Team: " D ^DIC S TEAM=+Y K DIC G:TEAM<0 QUIT

 S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Letters for Nonresponsive",ZTRTN="DQD5^SDRRRECL" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT

DQD5 N CHKDATE

 ;SD*5.3*561 remove extraneous write command following $O on next line

 S PR=0,CHKDATE=5 F  S PR=$O(^SD(403.54,"C",TEAM,PR)) Q:'PR  D

 .S D0=0 F  S D0=$O(^SD(403.5,"C",PR,D0)) Q:'D0  S (CLINIC,FAIL)=0 S CLINIC=$P($G(^SD(403.5,D0,0)),"^",2) D

 ..; SD*579 - If entry not exist, kill x-refs and quit

 ..I '$D(^SD(403.5,D0)) D KXREF Q

 ..I $P($G(^SD(403.5,D0,0)),"^",10)="" QUIT

 ..; SD*569 - Prevent from printing more than ONE second letter.

 ..I $P($G(^SD(403.5,D0,0)),"^",13)'="" QUIT

 ..S RDATE=$P($G(^SD(403.5,D0,0)),"^",6) S CHECK=$$FMDIFF^XLFDT(RDATE,DT) I CHECK>CHKDATE K RDATE QUIT

 ..S DTA=$G(^SD(403.5,D0,0))

 ..I CLINIC="" S FAIL=1 S MESSAGE="***NO CLINIC ON FILE**"

 ..I CLINIC'=""  I '$D(^SD(403.52,"B",CLINIC))  S MESSAGE="***NO CLINIC LETTER ON FILE**" S FAIL=1

 ..I CLINIC'="",(FAIL=0) S DIV=CLINIC S LETTER=0,LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))

 ..S TIME=""

 ..I $P(^SD(403.5,D0,0),"^",9)>30 S TIME=$P(^SD(403.5,D0,0),"^",9) S TIME="**"_TIME_"**"

 ..S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$P(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",1:"")

 ..S DFN=+DTA

 ..Q:$$TESTPAT^VADPT(DFN)

 ..D ADD^VADPT,DEM^VADPT

 ..S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)

 ..S PN=$P(VADM(1),U)

 ..I $G(VADM(6),U)'="" Q

 ..; SD*654 - add missing var DFN

 ..;        - quit updating date and printing ltr if bad addr

 ..S CHECK=$$BADADR^DGUTL3(DFN) I CHECK>0 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D  Q

 ...S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5

 ...S SDRR(1)="Bad Address - letter will not be printed for:"_"   "_PN_"   "_VA("BID")

 ...D ^XMD

 ...K XMY,XMSUB,XMTEXT,XMDUZ

 ..;ADDED THE DATE INFORMATION

 ..; SD*654 - do not update date if letter printed to a computer screen.

 ..I $E(IOST,1,2)'="C-" S $P(^SD(403.5,D0,0),"^",13)=DT

 ..D PR

 D ^%ZISC G QUIT

 Q

 ;

KXREF ; SD*579 - kill x-refs if entry not exist

 S STR="BCDE"

 F I=1:1:$L(STR) D

 .S X=$E(STR,I,I)

 .S N3=0 F  S N3=$O(^SD(403.5,X,N3)) Q:N3'>0  D

 ..S N4=0 F  S N4=$O(^SD(403.5,X,N3,N4)) Q:N4'>0  D

 ...I N4=D0 K ^SD(403.5,X,N3,N4)

 K I,STR,X,N3,N4

 Q

 ;

ADDR ; SD*654 - Patient address

 ; Change state to abbr.

 N SDRRIENS,SDRRX

 I $D(VAPA(5)) S SDRRIENS=+VAPA(5)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(5),U,2)=SDRRX

 I $D(VAPA(17)) S SDRRIENS=+VAPA(17)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(17),U,2)=SDRRX

 K SDRRIENS,SDRRX

 ;

 N SDRRACT1,SDRRACT2,LL

 ; Check Confidential Address Indicator (0=Inactive,1=Active)

 S SDRRACT1=VAPA(12),SDRRACT2=$P($G(VAPA(22,2)),U,3)

 ; If Confidential address is not active, print regular address

 I ($G(SDRRACT1)=0)!($G(SDRRACT2)'="Y") D

 . F LL=1:1:3 W:VAPA(LL)]"" !,?20,VAPA(LL)

 . ; If country is blank, display as USA

 . I (VAPA(25)="")!($P(VAPA(25),U,2)="UNITED STATES") D

 . . ; Display city, state, zip

 . . W !?20,VAPA(4)_" "_$P(VAPA(5),U,2)_"  "_$P(VAPA(11),U,2)

 . E  D

 . . ; Display city, province, postal code

 . . W !?20,VAPA(4)_" "_VAPA(23)_"  "_VAPA(24)

 . ; Display country

 . W:($P(VAPA(25),U,2)'="UNITED STATES") !,?20,$P(VAPA(25),U,2)

 ; If Confidential address is active, print confidential address

 I $G(SDRRACT1)=1,$G(SDRRACT2)="Y" D

 . F LL=13:1:15 W:VAPA(LL)]"" !,?20,VAPA(LL)  ;*685

 . I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D

 . . W !,?20,VAPA(16)_" "_$P(VAPA(17),U,2)_"  "_$P(VAPA(18),U,2)

 . E  D

 . . W !,?20,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)

 . I ($P(VAPA(28),"^",2)'="UNITED STATES") W !?20,$P(VAPA(28),U,2)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SDRRRECL   13715     printed  Apr 23, 2025@19:15:31                                                                                                                                                                                                   Page 2

SDRRRECL  ;10N20/MAH - Recall Reminder Manual Printing;09/20/2004

 +1       ;;5.3;Scheduling;**536,561,569,579,654,685**;Aug 13, 1993;Build 3

 +2       ;;This routine is called from SDRRLRP 

 +3       ;;If the site has set TYPE OF NOTIFICATION to LETTER this routine

 +4       ;;will run.

 +5       ;

 +6       ; SD*654

 +7       ; - do not update date if letter printed to a computer screen.

 +8       ; - adds missing var DFN when calling $$BADADR^DGUTL3 and

 +9       ;   quits updating date and printing ltr if bad addr.

 +10      ; - changes word 'card' to 'letter' in the message.

 +11      ; - fixes incomplete Canadian address.

 +12      ;

 +13       KILL TYPE

MEN       ;SET UP WHAT ARE THEY WOULD LIKE TO PRINT FOR LETTERS

 +1        KILL DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT

 +2        SET DIR(0)="SO^1:Print Letters by Clinic;2:Print Letters by Provider;3:Print Letters by Team;4:Print a Letter by Patient;5:Print Letters for Nonresponsive Patients"

 +3        WRITE !

           SET DIR("A")="Please select what you are looking for"

 +4        DO ^DIR

           if $DATA(DUOUT)!($DATA(DTOUT)!($DATA(DIRUT)))

               GOTO QUIT

           SET Q=Y

 +5        IF Q=1

               GOTO EN

 +6        IF Q=2

               GOTO EN1

 +7        IF Q=3

               GOTO EN3

 +8        IF Q=4

               GOTO EN4

 +9        IF Q=5

               GOTO EN5

 +10       QUIT 

EN        ;PRINT BY CLINIC

 +1        SET DIC="^SC("

           SET DIC(0)="AEQMZ"

           DO ^DIC

           if Y<0

               QUIT 

           SET DIV=+Y

           if Y<0

               GOTO QUIT

 +2        IF '$DATA(^SD(403.52,"B",DIV))

               WRITE !,?5,"**NO RECALL LETTER ON FILE**"

               GOTO QUIT

 +3       ;SD*561 quit if no date range entered

           DO SELDT

           if Y<0

               GOTO QUIT

 +4        SET %ZIS="QM"

           DO ^%ZIS

           if POP

               GOTO QUIT

           IF $DATA(IO("Q"))

               SET ZTDESC="Print Recall Letters by Clinic"

               SET ZTRTN="DQD^SDRRRECL"

               SET ZTSAVE("*")=""

               DO ^%ZTLOAD

               GOTO QUIT

DQD        KILL ^TMP($JOB)

 +1        USE IO

           SET D0=0

           FOR 

               SET D0=$ORDER(^SD(403.5,"E",DIV,D0))

               if D0=""

                   QUIT 

               SET DTA=$GET(^SD(403.5,D0,0))

               if DTA]""

                   Begin DoDot:1

 +2                    SET TIME=""

 +3                    IF $PIECE(^SD(403.5,D0,0),"^",9)>30

                           SET TIME=$PIECE(^SD(403.5,D0,0),"^",9)

                           SET TIME="**"_TIME_"**"

 +4                    SET LAB=$SELECT($PIECE($GET(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$PIECE(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",

1:"")

 +5                    SET DFN=+DTA

 +6                    if $PIECE(DTA,U,6)<SDT!($PIECE(DTA,U,6)>EDT)

                           QUIT 

 +7                    if $$TESTPAT^VADPT(DFN)

                           QUIT 

 +8                    DO ADD^VADPT

                       DO DEM^VADPT

 +9                    SET STATE=$PIECE(VAPA(5),"^",1)

                       SET STATE=$$GET1^DIQ(5,STATE_",",1)

 +10                   SET PN=$PIECE(VADM(1),U)

 +11                   IF $GET(VADM(6),U)'=""

                           QUIT 

 +12      ; SD*654 - add missing var DFN

 +13      ;        - quit updating date and printing ltr if bad addr

 +14                   SET CHECK=$$BADADR^DGUTL3(DFN)

                       IF CHECK>0

                           SET XMSUB="Bad Address for Recall Reminder Patient"

                           SET XMTEXT="SDRR("

                           Begin DoDot:2

 +15                           SET XMY("G.SDRR BAD ADDRESS")=""

                               SET XMDUZ=.5

 +16                           SET SDRR(1)="Bad Address - letter will not be printed for:"_"   "_PN_"   "_VA("BID")

 +17                           DO ^XMD

 +18                           KILL XMY,XMSUB,XMTEXT,XMDUZ

                           End DoDot:2

                           QUIT 

 +19      ;ADDED THE DATE INFORMATION

 +20      ; SD*654 - do not update date if displaying to a computer screen.

 +21                   IF $EXTRACT(IOST,1,2)'="C-"

                           SET $PIECE(^SD(403.5,D0,0),"^",10)=DT

 +22                   DO PR

                   End DoDot:1

 +23       DO ^%ZISC

           GOTO QUIT

 +24      ;;done and tested

QUIT       KILL ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,DIV,EDT,PR,SDT,FAST,TIME,ACC

 +1        KILL LINE,LETTER,MESSAGE,TEST,DOD,CLINIC,FAIL,TEAM,LAB,SDRR,Q,%DT,%ZIS,CHECK,VA,ZTDESC,ZTIO,ZTRTN,ZTSAVE,STATE

           QUIT 

 +2        DO KVAR^VADPT

 +3        QUIT 

SELDT      SET %DT="AEX"

           SET %DT("A")="Start with RECALL DATE: "

           DO ^%DT

           if Y<0

               QUIT 

           SET SDT=Y

           SET %DT("A")="End with RECALL DATE: "

           DO ^%DT

           IF Y<SDT

               WRITE $CHAR(7),"  ??"

               GOTO SELDT

 +1        SET EDT=Y

           QUIT 

PR         SET LETTER=0

 +1       ; SD*579 - Add date printed and last 4

 +2        SET PRNDT=$TRANSLATE($$FMTE^XLFDT(DT,"5DF")," ","0")

 +3        SET LAST4=$EXTRACT($PIECE(VA("BID"),U),1,4)

 +4        WRITE @IOF

 +5        WRITE !,?65,PRNDT

 +6        WRITE !,?65,$EXTRACT(PN,1)_LAST4

 +7        FOR L=1:1:9

               WRITE !

 +8       ;

 +9       ; SD*579 - Fix suffix listed problem

 +10       SET PNAME=$$NAMEFMT^XLFNAME(PN,"G","")

 +11       WRITE !?20,PNAME

 +12       DO ADDR

 +13       IF $DATA(MESSAGE)

               WRITE !!!!!,?25,MESSAGE

 +14      ; SD*569 - Adjust the tab starting position

 +15       IF TIME'=""

               WRITE !!!!?2,TIME

 +16       IF LAB'=""

               WRITE !!!!!,?2,"*"_LAB

 +17       WRITE !!!

 +18       if '$DATA(MESSAGE)

               SET LETTER=$ORDER(^SD(403.52,"B",DIV,LETTER))

 +19       IF LETTER>0

               SET LINE=0

               FOR 

                   SET LINE=$ORDER(^SD(403.52,LETTER,1,LINE))

                   if 'LINE

                       QUIT 

                   WRITE !,?2,$PIECE(^SD(403.52,LETTER,1,LINE,0),"^",1)

 +20       KILL MESSAGE,PRNDT,LAST4,PNAME

 +21       QUIT 

EN1       ;print letters by provider

 +1        SET DIC="^SD(403.54,"

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select Provider: "

           DO ^DIC

           if Y<0

               GOTO QUIT

           SET PR=+Y

 +2       ;SD*5.3*561 quit if no date range entered

           DO SELDT

           if Y<0

               GOTO QUIT

 +3        SET %ZIS="QM"

           DO ^%ZIS

           if POP

               GOTO QUIT

           IF $DATA(IO("Q"))

               SET ZTDESC="Print Recall Letters by Provider"

               SET ZTRTN="DQD1^SDRRRECL"

               SET ZTSAVE("*")=""

               DO ^%ZTLOAD

               GOTO QUIT

DQD1       KILL ^TMP($JOB)

 +1        USE IO

           SET D0=0

           FOR 

               SET D0=$ORDER(^SD(403.5,"C",PR,D0))

               if D0=""

                   QUIT 

               SET (CLINIC,FAIL)=0

               SET CLINIC=$PIECE($GET(^SD(403.5,D0,0)),"^",2)

               Begin DoDot:1

 +2       ; SD*579 - If entry not exist, kill x-refs and quit.

 +3                IF '$DATA(^SD(403.5,D0))

                       DO KXREF

                       QUIT 

 +4                SET DTA=$GET(^SD(403.5,D0,0))

 +5                IF CLINIC=""

                       SET FAIL=1

                       SET MESSAGE="***NO CLINIC ON FILE**"

 +6                IF CLINIC'=""

                       IF '$DATA(^SD(403.52,"B",CLINIC))

                           SET MESSAGE="***NO CLINIC LETTER ON FILE**"

                           SET FAIL=1

 +7                IF CLINIC'=""

                       IF (FAIL=0)

                           SET DIV=CLINIC

                           SET LETTER=0

                           SET LETTER=$ORDER(^SD(403.52,"B",CLINIC,LETTER))

 +8                SET TIME=""

 +9                IF $PIECE($GET(^SD(403.5,D0,0)),"^",9)>30

                       SET TIME=$PIECE($GET(^SD(403.5,D0,0)),"^",9)

                       SET TIME="**"_TIME_"**"

 +10               SET LAB=$SELECT($PIECE($GET(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$PIECE(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",1:""

)

 +11               SET DFN=+DTA

 +12               if $PIECE(DTA,U,6)<SDT!($PIECE(DTA,U,6)>EDT)

                       QUIT 

 +13               if $$TESTPAT^VADPT(DFN)

                       QUIT 

 +14               DO ADD^VADPT

                   DO DEM^VADPT

 +15               SET STATE=$PIECE(VAPA(5),"^",1)

                   SET STATE=$$GET1^DIQ(5,STATE_",",1)

 +16               SET PN=$PIECE(VADM(1),U)

 +17               IF $GET(VADM(6),U)'=""

                       QUIT 

 +18      ; SD*654 - add missing var DFN

 +19      ;        - quit updating date and printing ltr if bad addr

 +20               SET CHECK=$$BADADR^DGUTL3(DFN)

                   IF CHECK>0

                       SET XMSUB="Bad Address for Recall Reminder Patient"

                       SET XMTEXT="SDRR("

                       Begin DoDot:2

 +21                       SET XMY("G.SDRR BAD ADDRESS")=""

                           SET XMDUZ=.5

 +22                       SET SDRR(1)="Bad Address - letter will not be printed for:"_"   "_PN_"   "_VA("BID")

 +23                       DO ^XMD

 +24                       KILL XMY,XMSUB,XMTEXT,XMDUZ

                       End DoDot:2

                       QUIT 

 +25      ;ADDED THE DATE INFORMATION

 +26      ; SD*654 - do not update date if letter printed to a computer screen.

 +27               IF $EXTRACT(IOST,1,2)'="C-"

                       SET $PIECE(^SD(403.5,D0,0),"^",10)=DT

 +28               DO PR

               End DoDot:1

 +29       DO ^%ZISC

           GOTO QUIT

EN3       ;PRINT LETTER FOR A TEAM

 +1        WRITE !

           SET DIC="^SD(403.55,"

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select Clinic Recall Team: "

           DO ^DIC

           SET TEAM=+Y

           KILL DIC

           if Y<0

               GOTO QUIT

 +2       ;SD*561 quit if no date range entered

           DO SELDT

           if Y<0

               GOTO QUIT

 +3        SET %ZIS="QM"

           DO ^%ZIS

           if POP

               GOTO QUIT

           IF $DATA(IO("Q"))

               SET ZTDESC="Print Recall Letters for a Team"

               SET ZTRTN="DQD4^SDRRRECL"

               SET ZTSAVE("*")=""

               DO ^%ZTLOAD

               GOTO QUIT

DQD4       SET PR=0

           FOR 

               SET PR=$ORDER(^SD(403.54,"C",TEAM,PR))

               if 'PR

                   QUIT 

               SET D0=0

               Begin DoDot:1

 +1                FOR 

                       SET D0=$ORDER(^SD(403.5,"C",PR,D0))

                       if D0=""

                           QUIT 

                       SET (CLINIC,FAIL)=0

                       SET CLINIC=$PIECE($GET(^SD(403.5,D0,0)),"^",2)

                       Begin DoDot:2

 +2       ; SD*579 - If entry not exist, kill x-refs and quit.

 +3                        IF '$DATA(^SD(403.5,D0))