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 ---[H[J[2J[HSDRRRECL 13715 printed Dec 13, 2024@03:00:53 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))
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 ma
de",1:"")
+11 SET DFN=+DTA
+12 ;SD*561 check selected date range
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:3
+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:3
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:2
End DoDot:1
+29 DO ^%ZISC
GOTO QUIT
+30 ;done and tested
EN4 ;PRINT LETTER FOR ONE PATIENT
+1 KILL X
WRITE !
SET DIC="^SD(403.5,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Patient: "
DO ^DIC
SET D0=+Y
KILL DIC
if Y<0
GOTO QUIT
+2 SET DIC="^SC("
SET DIC(0)="AEQMZ"
DO ^DIC
if Y<0
QUIT
SET DIV=+Y
KILL DIC
if Y<0
GOTO QUIT
+3 IF '$DATA(^SD(403.52,"B",DIV))
WRITE !,?5,"**NO RECALL LETTER ON FILE**"
GOTO QUIT
+4 IF '$DATA(^SD(403.5,"E",DIV,D0))
WRITE *7,!!,?5,"**This patient does not have a recall reminder for the selected clinic**",!!
GOTO QUIT
+5 ;
+6 ; SD*654 - Check if it needs to quit before prompting for device
+7 SET DFN=+$GET(^SD(403.5,D0,0))
+8 DO DEM^VADPT
+9 SET PN=$PIECE(VADM(1),U)
+10 ; SD*654 - add missing var DFN
+11 ; - quit updating date and printing ltr if bad addr
+12 SET CHECK=$$BADADR^DGUTL3(DFN)
IF CHECK>0
SET XMSUB="Bad Address for Recall Reminder Patient"
SET XMTEXT="SDRR("
Begin DoDot:1
+13 SET XMY("G.SDRR BAD ADDRESS")=""
SET XMDUZ=.5
+14 SET SDRR(1)="Bad Address - letter will not be printed for:"_" "_PN_" "_VA("BID")
+15 DO ^XMD
+16 KILL XMY,SMSUB,XMTEXT,XMDUZ
End DoDot:1
WRITE !!,?5,"**This patient has been flagged with a Bad Address Indicator.**",!!
GOTO QUIT
+17 ; quit if DoD
+18 IF $GET(VADM(6),U)'=""
WRITE !!,?5,VADM(7),!!
GOTO QUIT
+19 ; quit if test pat
+20 IF $$TESTPAT^VADPT(DFN)
WRITE !!,?5,"**You may have selected a test patient.**",!!
GOTO QUIT
+21 ; SD*654 - End
+22 ;
+23 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDESC="Print Recall Letters for a Patient"
SET ZTRTN="DQD3^SDRRRECL"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DQD3 KILL ^TMP($JOB)
+1 SET DTA=$GET(^SD(403.5,D0,0))
if DTA]""
Begin DoDot:1
+2 ; SD*569 - Quit if patient's clinic does not match the selected hospital location.
+3 IF $PIECE(DTA,"^",2)'=DIV
QUIT
+4 SET TIME=""
+5 IF $PIECE(^SD(403.5,D0,0),"^",9)>30
SET TIME=$PIECE(^SD(403.5,D0,0),"^",9)
SET TIME="**"_TIME_"**"
+6 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:""
)
+7 SET DFN=+DTA
+8 DO ADD^VADPT
+9 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+10 ;ADDED THE DATE INFORMATION
+11 ; SD*654 - do not update date if letter printed to a computer screen.
+12 IF $EXTRACT(IOST,1,2)'="C-"
SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
+13 DO PR
End DoDot:1
+14 DO ^%ZISC
GOTO QUIT
EN5 ;Print LETTERS for Nonresponsive
+1 SET TEAM=""
+2 SET DIC="^SD(403.55,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Clinic Recall Team: "
DO ^DIC
SET TEAM=+Y
KILL DIC
if TEAM<0
GOTO QUIT
+3 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDESC="Print Recall Letters for Nonresponsive"
SET ZTRTN="DQD5^SDRRRECL"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DQD5 NEW CHKDATE
+1 ;SD*5.3*561 remove extraneous write command following $O on next line
+2 SET PR=0
SET CHKDATE=5
FOR
SET PR=$ORDER(^SD(403.54,"C",TEAM,PR))
if 'PR
QUIT
Begin DoDot:1
+3 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:2
+4 ; SD*579 - If entry not exist, kill x-refs and quit
+5 IF '$DATA(^SD(403.5,D0))
DO KXREF
QUIT
+6 IF $PIECE($GET(^SD(403.5,D0,0)),"^",10)=""
QUIT
+7 ; SD*569 - Prevent from printing more than ONE second letter.
+8 IF $PIECE($GET(^SD(403.5,D0,0)),"^",13)'=""
QUIT
+9 SET RDATE=$PIECE($GET(^SD(403.5,D0,0)),"^",6)
SET CHECK=$$FMDIFF^XLFDT(RDATE,DT)
IF CHECK>CHKDATE
KILL RDATE
QUIT
+10 SET DTA=$GET(^SD(403.5,D0,0))
+11 IF CLINIC=""
SET FAIL=1
SET MESSAGE="***NO CLINIC ON FILE**"
+12 IF CLINIC'=""
IF '$DATA(^SD(403.52,"B",CLINIC))
SET MESSAGE="***NO CLINIC LETTER ON FILE**"
SET FAIL=1
+13 IF CLINIC'=""
IF (FAIL=0)
SET DIV=CLINIC
SET LETTER=0
SET LETTER=$ORDER(^SD(403.52,"B",CLINIC,LETTER))
+14 SET TIME=""
+15 IF $PIECE(^SD(403.5,D0,0),"^",9)>30
SET TIME=$PIECE(^SD(403.5,D0,0),"^",9)
SET TIME="**"_TIME_"**"
+16 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 ma
de",1:"")
+17 SET DFN=+DTA
+18 if $$TESTPAT^VADPT(DFN)
QUIT
+19 DO ADD^VADPT
DO DEM^VADPT
+20 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+21 SET PN=$PIECE(VADM(1),U)
+22 IF $GET(VADM(6),U)'=""
QUIT
+23 ; SD*654 - add missing var DFN
+24 ; - quit updating date and printing ltr if bad addr
+25 SET CHECK=$$BADADR^DGUTL3(DFN)
IF CHECK>0
SET XMSUB="Bad Address for Recall Reminder Patient"
SET XMTEXT="SDRR("
Begin DoDot:3
+26 SET XMY("G.SDRR BAD ADDRESS")=""
SET XMDUZ=.5
+27 SET SDRR(1)="Bad Address - letter will not be printed for:"_" "_PN_" "_VA("BID")
+28 DO ^XMD
+29 KILL XMY,XMSUB,XMTEXT,XMDUZ
End DoDot:3
QUIT
+30 ;ADDED THE DATE INFORMATION
+31 ; SD*654 - do not update date if letter printed to a computer screen.
+32 IF $EXTRACT(IOST,1,2)'="C-"
SET $PIECE(^SD(403.5,D0,0),"^",13)=DT
+33 DO PR
End DoDot:2
End DoDot:1
+34 DO ^%ZISC
GOTO QUIT
+35 QUIT
+36 ;
KXREF ; SD*579 - kill x-refs if entry not exist
+1 SET STR="BCDE"
+2 FOR I=1:1:$LENGTH(STR)
Begin DoDot:1
+3 SET X=$EXTRACT(STR,I,I)
+4 SET N3=0
FOR
SET N3=$ORDER(^SD(403.5,X,N3))
if N3'>0
QUIT
Begin DoDot:2
+5 SET N4=0
FOR
SET N4=$ORDER(^SD(403.5,X,N3,N4))
if N4'>0
QUIT
Begin DoDot:3
+6 IF N4=D0
KILL ^SD(403.5,X,N3,N4)
End DoDot:3
End DoDot:2
End DoDot:1
+7 KILL I,STR,X,N3,N4
+8 QUIT
+9 ;
ADDR ; SD*654 - Patient address
+1 ; Change state to abbr.
+2 NEW SDRRIENS,SDRRX
+3 IF $DATA(VAPA(5))
SET SDRRIENS=+VAPA(5)_","
SET SDRRX=$$GET1^DIQ(5,SDRRIENS,1)
SET $PIECE(VAPA(5),U,2)=SDRRX
+4 IF $DATA(VAPA(17))
SET SDRRIENS=+VAPA(17)_","
SET SDRRX=$$GET1^DIQ(5,SDRRIENS,1)
SET $PIECE(VAPA(17),U,2)=SDRRX
+5 KILL SDRRIENS,SDRRX
+6 ;
+7 NEW SDRRACT1,SDRRACT2,LL
+8 ; Check Confidential Address Indicator (0=Inactive,1=Active)
+9 SET SDRRACT1=VAPA(12)
SET SDRRACT2=$PIECE($GET(VAPA(22,2)),U,3)
+10 ; If Confidential address is not active, print regular address
+11 IF ($GET(SDRRACT1)=0)!($GET(SDRRACT2)'="Y")
Begin DoDot:1
+12 FOR LL=1:1:3
if VAPA(LL)]""
WRITE !,?20,VAPA(LL)
+13 ; If country is blank, display as USA
+14 IF (VAPA(25)="")!($PIECE(VAPA(25),U,2)="UNITED STATES")
Begin DoDot:2
+15 ; Display city, state, zip
+16 WRITE !?20,VAPA(4)_" "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(11),U,2)
End DoDot:2
+17 IF '$TEST
Begin DoDot:2
+18 ; Display city, province, postal code
+19 WRITE !?20,VAPA(4)_" "_VAPA(23)_" "_VAPA(24)
End DoDot:2
+20 ; Display country
+21 if ($PIECE(VAPA(25),U,2)'="UNITED STATES")
WRITE !,?20,$PIECE(VAPA(25),U,2)
End DoDot:1
+22 ; If Confidential address is active, print confidential address
+23 IF $GET(SDRRACT1)=1
IF $GET(SDRRACT2)="Y"
Begin DoDot:1
+24 ;*685
FOR LL=13:1:15
if VAPA(LL)]""
WRITE !,?20,VAPA(LL)
+25 IF (VAPA(28)="")!($PIECE(VAPA(28),"^",2)="UNITED STATES")
Begin DoDot:2
+26 WRITE !,?20,VAPA(16)_" "_$PIECE(VAPA(17),U,2)_" "_$PIECE(VAPA(18),U,2)
End DoDot:2
+27 IF '$TEST
Begin DoDot:2
+28 WRITE !,?20,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
End DoDot:2
+29 IF ($PIECE(VAPA(28),"^",2)'="UNITED STATES")
WRITE !?20,$PIECE(VAPA(28),U,2)
End DoDot:1
+30 QUIT
