SDRRRECP ;10N20/MAH - Recall Reminder Manual Printing;09/20/2004
;;5.3;Scheduling;**536,569,579,654,685**;Aug 13, 1993;Build 3
;;This routine is called from SDRRLRP
;;If the site has set TYPE OF NOTIFICATION to CARDS this routine
;;will run.
;
; SD*654
; - do not update date if card printed to a computer screen.
; - adds missing var DFN when calling $$BARADR^DGUTL3 and
; quits printing if bad addr.
; - fixes incomplete Canadian address
;
K TYPE
MEN ;SET UP WHAT ARE THEY WOULD LIKE TO PRINT FOR CARDS
K DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT
S DIR(0)="SO^1:Print Cards by Division;2:Print Cards by Clinic;3:Print Cards by Provider;4:Print Cards by Team;5:Print a Card by Patient;6:Print Cards 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 EN3
I Q=2 G EN
I Q=3 G EN2
I Q=4 G EN1
I Q=5 G EN4
I Q=6 G EN5
Q
;ALLK Q,Y,DIR
EN3 ;PRINT BY DIVISION
S DIC="^DG(40.8,",DIC(0)="AEQMZ" D ^DIC G:Y<0 QUIT S DIV=+Y D SELDT G:Y<0 QUIT
S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDSC="Print Recall Cards by Division",ZTRTN="DQD1^SDRRRECP" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
DQD1 K ^TMP($J)
S PR=0 F S PR=$O(^SD(403.5,"C",PR)) Q:PR="" I $P($G(^SD(403.54,PR,0)),"^",3)=DIV S D0=0 F S D0=$O(^SD(403.5,"C",PR,D0)) Q:D0="" S DTA=$G(^SD(403.5,D0,0)) D:DTA]""
.S TIME=""
.I $P(^SD(403.5,D0,0),"^",9)["60" S TIME=$P(^SD(403.5,D0,0),"^",9) S TIME="**"_TIME_"**"
.S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
.S DFN=+DTA
.Q:$$TESTPAT^VADPT(DFN)
.D ADD^VADPT,DEM^VADPT
.S PN=$P(VADM(1),U)
.S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)
.I $G(VADM(6),U)'="" Q
.Q:$P(DTA,"^",6)<SDT!($P(DTA,"^",6)>EDT)
.; SD*654 - add missing var DFN
.; - quit updating date and printing card 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- card 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 card 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
EN ;PRINT BY CLINIC
S DIC="^SC(",DIC(0)="AEQMZ" D ^DIC Q:Y<0 S DIV=+Y D SELDT G:Y<0 QUIT
S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Cards by Clinic",ZTRTN="DQD^SDRRRECP" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
DQD K ^TMP($J)
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)["60" S TIME=$P(^SD(403.5,D0,0),"^",9) S TIME="**"_TIME_"**"
.S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",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
.Q:$P(DTA,"^",6)<SDT!($P(DTA,"^",6)>EDT)
.; SD*654 - add missing var DFN
.; - quit updating date and printing card 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- card 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 card 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
QUIT K ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,DIV,EDT,PR,SDT,TIME,LAB,Y,STATE,PNAME
K DATE,DOD,X,Q,%DT,%ZIS,SDRR,VA,CHECK,ZTDESC,ZTDSC,ZTEAM,ZTIO,ZTRTN,ZTSAVE
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 W @IOF F L=1:1:7 W !
S PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
W !?20,PNAME
D ADDR
I TIME'="" W !!?45,TIME
I LAB'="" W !!?45,LAB
Q
EN1 ;PRINT BY TEAM
S DIC="^SD(403.55,",DIC(0)="AEQMZ",DIC("A")="Select Clinic Team: " D ^DIC Q:Y<0 S ZTEAM=+Y D SELDT G:Y<0 QUIT
S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Cards by Team",ZTRTN="DQT^SDRRRECP" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
DQT K ^TMP($J)
S PR=0 F S PR=$O(^SD(403.5,"C",PR)) Q:PR="" I $P($G(^SD(403.54,PR,0)),U,2)=+ZTEAM S D0=0 F S D0=$O(^SD(403.5,"C",PR,D0)) Q:D0="" S DTA=$G(^SD(403.5,D0,0)) D:DTA]""
.S TIME=""
.I $P(^SD(403.5,D0,0),"^",9)["60" S TIME=$P(^SD(403.5,D0,0),"^",9) S TIME="**"_TIME_"**"
.S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
.S DFN=+DTA
.Q:$$TESTPAT^VADPT(DFN)
.D ADD^VADPT,DEM^VADPT
.S PN=$P(VADM(1),U)
.S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)
.I $G(VADM(6),U)'="" Q
.Q:$P(DTA,"^",6)<SDT!($P(DTA,"^",6)>EDT)
.; SD*654 - add missing var DFN
.; - quit updating date and printing card 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- card will not be printed for:"_" "_PN_" "_VA("BID")
..D ^XMD
..K XMY,XMSUB,XMTEXT,XMDUZ
..;D ^%ZISC G QUIT
.;ADDED THE DATE INFORMATION
.; SD*654 - do not update date if card 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
EN2 ;PRINT BY PROV
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
S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Cards by Prov",ZTRTN="DQP^SDRRRECP" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
DQP K ^TMP($J)
S D0=0 F S D0=$O(^SD(403.5,"C",PR,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":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",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
.Q:$P(DTA,"^",6)<SDT!($P(DTA,"^",6)>EDT)
.; SD*654 - add missing var DFN
.; - quit updating date and printing card 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- card 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 card 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
EN4 ;PRINT BY Patient
W ! S DIC="^SD(403.5,",DIC(0)="AEQMZ",DIC("A")="Select Patient: " D ^DIC G:Y<0 QUIT S D0=+Y
;
; SD*654 - Check if it needs to quit before prompting for device
S DFN=+$G(^SD(403.5,D0,0))
I $$TESTPAT^VADPT(DFN) W !!,?5,"**You may have selected a test patient.**",!! G QUIT ; quit if test pat
D DEM^VADPT
S PN=$P(VADM(1),U)
; SD*654 - add missing var DFN
; - quit updating date and printing card 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 - card will not be printed for:"_" "_PN_" "_VA("BID")
. D ^XMD
. K XMY,XMSUB,XMTEXT,XMDUZ
I $G(VADM(6),U)'="" W !!,?5,VADM(7),!! G QUIT ; quit if DoD
; SD*654 - end
;
S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Recall Cards by Prov",ZTRTN="DPP^SDRRRECP" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
DPP K ^TMP($J)
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":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
.S DFN=+DTA
.D ADD^VADPT,DEM^VADPT
.S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)
.S PN=$P(VADM(1),U)
.;ADDED THE DATE INFORMATION
.; SD*654 - do not update date if card 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 BY NONRESPONSIVE PATIENTS
S DIC="^SD(403.55,",DIC(0)="AEQMZ",DIC("A")="Select Clinic Team: " D ^DIC S ZTEAM=+Y G:Y<0 QUIT
S %ZIS="QM" D ^%ZIS G:POP QUIT I $D(IO("Q")) S ZTDESC="Print Nonresponsive Recall Cards by Team",ZTRTN="DQDD^SDRRRECP" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
DQDD K ^TMP($J)
N CHKDATE
S PR=0 F S PR=$O(^SD(403.5,"C",PR)) Q:PR="" I $P($G(^SD(403.54,PR,0)),U,2)=+ZTEAM S D0=0 F S D0=$O(^SD(403.5,"C",PR,D0)) Q:D0="" S DTA=$G(^SD(403.5,D0,0)) D:DTA]""
.I $P($G(^SD(403.5,D0,0)),"^",10)="" QUIT
.; SD*569 - Prevent from printing more than ONE second card
.I $P($G(^SD(403.5,D0,0)),"^",13)'="" QUIT
.S CHKDATE=5 S RDATE=$P($G(^SD(403.5,D0,0)),"^",6) S CHECK=$$FMDIFF^XLFDT(RDATE,DT) I CHECK>CHKDATE K RDATE QUIT
.S TIME=""
.I $P(^SD(403.5,D0,0),"^",9)["60" S TIME=$P(^SD(403.5,D0,0),"^",9) S TIME="**"_TIME_"**"
.S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",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 card 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- card 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 card 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
;
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[HSDRRRECP 11658 printed Dec 13, 2024@03:00:54 Page 2
SDRRRECP ;10N20/MAH - Recall Reminder Manual Printing;09/20/2004
+1 ;;5.3;Scheduling;**536,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 CARDS this routine
+4 ;;will run.
+5 ;
+6 ; SD*654
+7 ; - do not update date if card printed to a computer screen.
+8 ; - adds missing var DFN when calling $$BARADR^DGUTL3 and
+9 ; quits printing if bad addr.
+10 ; - fixes incomplete Canadian address
+11 ;
+12 KILL TYPE
MEN ;SET UP WHAT ARE THEY WOULD LIKE TO PRINT FOR CARDS
+1 KILL DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT
+2 SET DIR(0)="SO^1:Print Cards by Division;2:Print Cards by Clinic;3:Print Cards by Provider;4:Print Cards by Team;5:Print a Card by Patient;6:Print Cards 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 EN3
+6 IF Q=2
GOTO EN
+7 IF Q=3
GOTO EN2
+8 IF Q=4
GOTO EN1
+9 IF Q=5
GOTO EN4
+10 IF Q=6
GOTO EN5
+11 QUIT
+12 ;ALLK Q,Y,DIR
EN3 ;PRINT BY DIVISION
+1 SET DIC="^DG(40.8,"
SET DIC(0)="AEQMZ"
DO ^DIC
if Y<0
GOTO QUIT
SET DIV=+Y
DO SELDT
if Y<0
GOTO QUIT
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDSC="Print Recall Cards by Division"
SET ZTRTN="DQD1^SDRRRECP"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DQD1 KILL ^TMP($JOB)
+1 SET PR=0
FOR
SET PR=$ORDER(^SD(403.5,"C",PR))
if PR=""
QUIT
IF $PIECE($GET(^SD(403.54,PR,0)),"^",3)=DIV
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",PR,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)["60"
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":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
+5 SET DFN=+DTA
+6 if $$TESTPAT^VADPT(DFN)
QUIT
+7 DO ADD^VADPT
DO DEM^VADPT
+8 SET PN=$PIECE(VADM(1),U)
+9 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+10 IF $GET(VADM(6),U)'=""
QUIT
+11 if $PIECE(DTA,"^",6)<SDT!($PIECE(DTA,"^",6)>EDT)
QUIT
+12 ; SD*654 - add missing var DFN
+13 ; - quit updating date and printing card 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- card 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 card printed 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
EN ;PRINT BY CLINIC
+1 SET DIC="^SC("
SET DIC(0)="AEQMZ"
DO ^DIC
if Y<0
QUIT
SET DIV=+Y
DO SELDT
if Y<0
GOTO QUIT
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDESC="Print Recall Cards by Clinic"
SET ZTRTN="DQD^SDRRRECP"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DQD KILL ^TMP($JOB)
+1 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)["60"
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":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
+5 SET DFN=+DTA
+6 if $$TESTPAT^VADPT(DFN)
QUIT
+7 DO ADD^VADPT
DO DEM^VADPT
+8 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+9 SET PN=$PIECE(VADM(1),U)
+10 IF $GET(VADM(6),U)'=""
QUIT
+11 if $PIECE(DTA,"^",6)<SDT!($PIECE(DTA,"^",6)>EDT)
QUIT
+12 ; SD*654 - add missing var DFN
+13 ; - quit updating date and printing card 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- card 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 card printed 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
QUIT KILL ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,DIV,EDT,PR,SDT,TIME,LAB,Y,STATE,PNAME
+1 KILL DATE,DOD,X,Q,%DT,%ZIS,SDRR,VA,CHECK,ZTDESC,ZTDSC,ZTEAM,ZTIO,ZTRTN,ZTSAVE
+2 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 WRITE @IOF
FOR L=1:1:7
WRITE !
+1 SET PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
+2 WRITE !?20,PNAME
+3 DO ADDR
+4 IF TIME'=""
WRITE !!?45,TIME
+5 IF LAB'=""
WRITE !!?45,LAB
+6 QUIT
EN1 ;PRINT BY TEAM
+1 SET DIC="^SD(403.55,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Clinic Team: "
DO ^DIC
if Y<0
QUIT
SET ZTEAM=+Y
DO SELDT
if Y<0
GOTO QUIT
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDESC="Print Recall Cards by Team"
SET ZTRTN="DQT^SDRRRECP"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DQT KILL ^TMP($JOB)
+1 SET PR=0
FOR
SET PR=$ORDER(^SD(403.5,"C",PR))
if PR=""
QUIT
IF $PIECE($GET(^SD(403.54,PR,0)),U,2)=+ZTEAM
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",PR,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)["60"
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":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
+5 SET DFN=+DTA
+6 if $$TESTPAT^VADPT(DFN)
QUIT
+7 DO ADD^VADPT
DO DEM^VADPT
+8 SET PN=$PIECE(VADM(1),U)
+9 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+10 IF $GET(VADM(6),U)'=""
QUIT
+11 if $PIECE(DTA,"^",6)<SDT!($PIECE(DTA,"^",6)>EDT)
QUIT
+12 ; SD*654 - add missing var DFN
+13 ; - quit updating date and printing card 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- card will not be printed for:"_" "_PN_" "_VA("BID")
+17 DO ^XMD
+18 KILL XMY,XMSUB,XMTEXT,XMDUZ
+19 ;D ^%ZISC G QUIT
End DoDot:2
QUIT
+20 ;ADDED THE DATE INFORMATION
+21 ; SD*654 - do not update date if card printed to a computer screen.
+22 IF $EXTRACT(IOST,1,2)'="C-"
SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
+23 DO PR
End DoDot:1
+24 DO ^%ZISC
GOTO QUIT
EN2 ;PRINT BY PROV
+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
DO SELDT
if Y<0
GOTO QUIT
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDESC="Print Recall Cards by Prov"
SET ZTRTN="DQP^SDRRRECP"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DQP KILL ^TMP($JOB)
+1 SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",PR,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":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
+5 SET DFN=+DTA
+6 if $$TESTPAT^VADPT(DFN)
QUIT
+7 DO ADD^VADPT
DO DEM^VADPT
+8 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+9 SET PN=$PIECE(VADM(1),U)
+10 IF $GET(VADM(6),U)'=""
QUIT
+11 if $PIECE(DTA,"^",6)<SDT!($PIECE(DTA,"^",6)>EDT)
QUIT
+12 ; SD*654 - add missing var DFN
+13 ; - quit updating date and printing card 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- card 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 card printed 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
EN4 ;PRINT BY Patient
+1 WRITE !
SET DIC="^SD(403.5,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Patient: "
DO ^DIC
if Y<0
GOTO QUIT
SET D0=+Y
+2 ;
+3 ; SD*654 - Check if it needs to quit before prompting for device
+4 SET DFN=+$GET(^SD(403.5,D0,0))
+5 ; quit if test pat
IF $$TESTPAT^VADPT(DFN)
WRITE !!,?5,"**You may have selected a test patient.**",!!
GOTO QUIT
+6 DO DEM^VADPT
+7 SET PN=$PIECE(VADM(1),U)
+8 ; SD*654 - add missing var DFN
+9 ; - quit updating date and printing card if bad addr
+10 SET CHECK=$$BADADR^DGUTL3(DFN)
IF CHECK>0
SET XMSUB="Bad Address for Recall Reminder Patient"
SET XMTEXT="SDRR("
Begin DoDot:1
+11 SET XMY("G.SDRR BAD ADDRESS")=""
SET XMDUZ=.5
+12 SET SDRR(1)="Bad Address - card will not be printed for:"_" "_PN_" "_VA("BID")
+13 DO ^XMD
+14 KILL XMY,XMSUB,XMTEXT,XMDUZ
End DoDot:1
WRITE !!,?5,"**This patient has been flagged with a Bad Address Indicator.**",!!
GOTO QUIT
+15 ; quit if DoD
IF $GET(VADM(6),U)'=""
WRITE !!,?5,VADM(7),!!
GOTO QUIT
+16 ; SD*654 - end
+17 ;
+18 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDESC="Print Recall Cards by Prov"
SET ZTRTN="DPP^SDRRRECP"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DPP KILL ^TMP($JOB)
+1 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":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
+5 SET DFN=+DTA
+6 DO ADD^VADPT
DO DEM^VADPT
+7 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+8 SET PN=$PIECE(VADM(1),U)
+9 ;ADDED THE DATE INFORMATION
+10 ; SD*654 - do not update date if card printed to a computer screen.
+11 IF $EXTRACT(IOST,1,2)'="C-"
SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
+12 DO PR
End DoDot:1
+13 DO ^%ZISC
GOTO QUIT
EN5 ;PRINT BY NONRESPONSIVE PATIENTS
+1 SET DIC="^SD(403.55,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select Clinic Team: "
DO ^DIC
SET ZTEAM=+Y
if Y<0
GOTO QUIT
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
IF $DATA(IO("Q"))
SET ZTDESC="Print Nonresponsive Recall Cards by Team"
SET ZTRTN="DQDD^SDRRRECP"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
DQDD KILL ^TMP($JOB)
+1 NEW CHKDATE
+2 SET PR=0
FOR
SET PR=$ORDER(^SD(403.5,"C",PR))
if PR=""
QUIT
IF $PIECE($GET(^SD(403.54,PR,0)),U,2)=+ZTEAM
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",PR,D0))
if D0=""
QUIT
SET DTA=$GET(^SD(403.5,D0,0))
if DTA]""
Begin DoDot:1
+3 IF $PIECE($GET(^SD(403.5,D0,0)),"^",10)=""
QUIT
+4 ; SD*569 - Prevent from printing more than ONE second card
+5 IF $PIECE($GET(^SD(403.5,D0,0)),"^",13)'=""
QUIT
+6 SET CHKDATE=5
SET RDATE=$PIECE($GET(^SD(403.5,D0,0)),"^",6)
SET CHECK=$$FMDIFF^XLFDT(RDATE,DT)
IF CHECK>CHKDATE
KILL RDATE
QUIT
+7 SET TIME=""
+8 IF $PIECE(^SD(403.5,D0,0),"^",9)["60"
SET TIME=$PIECE(^SD(403.5,D0,0),"^",9)
SET TIME="**"_TIME_"**"
+9 SET LAB=$SELECT($PIECE($GET(^SD(403.5,D0,0)),"^",8)="f":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
+10 SET DFN=+DTA
+11 if $$TESTPAT^VADPT(DFN)
QUIT
+12 DO ADD^VADPT
DO DEM^VADPT
+13 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+14 SET PN=$PIECE(VADM(1),U)
+15 IF $GET(VADM(6),U)'=""
QUIT
+16 ; SD*654 - add missing var DFN
+17 ; - quit updating date and printing card if bad addr
+18 SET CHECK=$$BADADR^DGUTL3(DFN)
IF CHECK>0
SET XMSUB="Bad Address for Recall Reminder Patient"
SET XMTEXT="SDRR("
Begin DoDot:2
+19 SET XMY("G.SDRR BAD ADDRESS")=""
SET XMDUZ=.5
+20 SET SDRR(1)="Bad Address- card will not be printed for:"_" "_PN_" "_VA("BID")
+21 DO ^XMD
+22 KILL XMY,XMSUB,XMTEXT,XMDUZ
End DoDot:2
QUIT
+23 ;ADDED THE DATE INFORMATION
+24 ; SD*654 - do not update date if card printed to a computer screen.
+25 IF $EXTRACT(IOST,1,2)'="C-"
SET $PIECE(^SD(403.5,D0,0),"^",13)=DT
+26 DO PR
End DoDot:1
+27 DO ^%ZISC
GOTO QUIT
+28 QUIT
+29 ;
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
