SDRRTSK ;10N20/MAH - RECALL LETTER PRINT TASK ;09/05/17
;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
;THIS ROUTINE WILL PRINT LETTER FOR SELECTED METHOD OF PRINTING
;WILL LOOK AT CLINIC RECALL LOCATION
;
; SD*654
; - fixes incomplete Canadian address.
; - changes word 'card' to 'letter' in the message.
;
DATE ;lOOKS TO SEE HOW MANY DAYS IN ADVANCE TO PRINT LETTER
Q:'$D(^SD(403.53,0))
S CRP=0
F S CRP=$O(^SD(403.53,CRP)) Q:'CRP D
.S TYPE=$P($G(^SD(403.53,CRP,0)),"^",2)
.Q:TYPE["C"
.S DATE=$P($G(^SD(403.53,CRP,0)),"^",4) Q:DATE="" ;IF NOT SET ROUTINE WILL QUIT
.S X="T+"_DATE D ^%DT S (ZSDT,ZEDT)=Y K Y
.S (PRT,TEAM)=0
.F S TEAM=$O(^SD(403.55,"C",CRP,TEAM)) Q:TEAM="" S PRT=$P($G(^SD(403.55,TEAM,0)),"^",3) D
..Q:PRT=""
..S DA=PRT
..S DIC="^%ZIS(1,",DR=".01;1;3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1
..N IOP S IOP=$G(DPTR("3.5",DA,".01","I")) D ^%ZIS
..S PROV=0 F S PROV=$O(^SD(403.54,"C",TEAM,PROV)) Q:PROV="" D
...S (MESSAGE,D0,LETTER)=0 F S D0=$O(^SD(403.5,"C",PROV,D0)) Q:D0="" S (CLINIC,FAIL)=0 S CLINIC=$P($G(^SD(403.5,D0,0)),"^",2) D
....; SD*579 - Kill x-refs and quit if entry not exist
....I '$D(^SD(403.5,D0)) D KXREF Q
....S DTA=$G(^SD(403.5,D0,0))
....I CLINIC="" 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 ZDIV=CLINIC S LETTER=0,LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))
....S TIME=""
....I $P($G(^SD(403.5,D0,0)),"^",9)>45 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)<ZSDT!($P(DTA,U,6)>ZEDT)
....Q:$P(DTA,U,6)>ZEDT ;alb/sat 643
....Q:$P(DTA,U,10)'="" ;alb/sat 643
....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
....N CHECK
....I $$BADADR^DGUTL3(DFN) S CHECK=1 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D
.....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
.....Q
....;ADDED THE DATE INFORMATION
....I '$D(CHECK) S $P(^SD(403.5,D0,0),"^",10)=DT ;NEW CODE
....Q:$D(CHECK)
....U IO
....; 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 problem
....S PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
....W !?20,PNAME
....D ADDR ; SD*654 fix incomplete addr
....I LETTER=0 W !!!!!,?25,MESSAGE
....I TIME'="" W !!!!?2,"**"_TIME
....I LAB'="" W !!!!!,?2,"*"_LAB
....W !!!
....S:'$D(MESSAGE) LETTER=$O(^SD(403.52,"B",CLINIC,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)
..D ^%ZISC
K DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
K MESSAGE,LETTER,PRNDT,LAST4,PNAME
QUIT K DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,LAB,STATE
K LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,PROV,TEAM,CRP,DATE,TYPE,SDRR,DPT,VA
D KVAR^VADPT
Q
;
KXREF ; SD*579 - If entry not exist, kill all the x-refs.
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[HSDRRTSK 5229 printed Dec 13, 2024@03:00:59 Page 2
SDRRTSK ;10N20/MAH - RECALL LETTER PRINT TASK ;09/05/17
+1 ;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
+2 ;THIS ROUTINE WILL PRINT LETTER FOR SELECTED METHOD OF PRINTING
+3 ;WILL LOOK AT CLINIC RECALL LOCATION
+4 ;
+5 ; SD*654
+6 ; - fixes incomplete Canadian address.
+7 ; - changes word 'card' to 'letter' in the message.
+8 ;
DATE ;lOOKS TO SEE HOW MANY DAYS IN ADVANCE TO PRINT LETTER
+1 if '$DATA(^SD(403.53,0))
QUIT
+2 SET CRP=0
+3 FOR
SET CRP=$ORDER(^SD(403.53,CRP))
if 'CRP
QUIT
Begin DoDot:1
+4 SET TYPE=$PIECE($GET(^SD(403.53,CRP,0)),"^",2)
+5 if TYPE["C"
QUIT
+6 ;IF NOT SET ROUTINE WILL QUIT
SET DATE=$PIECE($GET(^SD(403.53,CRP,0)),"^",4)
if DATE=""
QUIT
+7 SET X="T+"_DATE
DO ^%DT
SET (ZSDT,ZEDT)=Y
KILL Y
+8 SET (PRT,TEAM)=0
+9 FOR
SET TEAM=$ORDER(^SD(403.55,"C",CRP,TEAM))
if TEAM=""
QUIT
SET PRT=$PIECE($GET(^SD(403.55,TEAM,0)),"^",3)
Begin DoDot:2
+10 if PRT=""
QUIT
+11 SET DA=PRT
+12 SET DIC="^%ZIS(1,"
SET DR=".01;1;3"
SET DIQ="DPTR"
SET DIQ(0)="I"
DO EN^DIQ1
+13 NEW IOP
SET IOP=$GET(DPTR("3.5",DA,".01","I"))
DO ^%ZIS
+14 SET PROV=0
FOR
SET PROV=$ORDER(^SD(403.54,"C",TEAM,PROV))
if PROV=""
QUIT
Begin DoDot:3
+15 SET (MESSAGE,D0,LETTER)=0
FOR
SET D0=$ORDER(^SD(403.5,"C",PROV,D0))
if D0=""
QUIT
SET (CLINIC,FAIL)=0
SET CLINIC=$PIECE($GET(^SD(403.5,D0,0)),"^",2)
Begin DoDot:4
+16 ; SD*579 - Kill x-refs and quit if entry not exist
+17 IF '$DATA(^SD(403.5,D0))
DO KXREF
QUIT
+18 SET DTA=$GET(^SD(403.5,D0,0))
+19 IF CLINIC=""
SET MESSAGE="***NO CLINIC ON FILE**"
+20 IF CLINIC'=""
IF '$DATA(^SD(403.52,"B",CLINIC))
SET MESSAGE="***NO CLINIC LETTER ON FILE**"
SET FAIL=1
+21 IF CLINIC'=""
IF (FAIL=0)
SET ZDIV=CLINIC
SET LETTER=0
SET LETTER=$ORDER(^SD(403.52,"B",CLINIC,LETTER))
+22 SET TIME=""
+23 IF $PIECE($GET(^SD(403.5,D0,0)),"^",9)>45
SET TIME=$PIECE($GET(^SD(403.5,D0,0)),"^",9)
SET TIME="**"_TIME_"**"
+24 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 a
ppointment is made",1:"")
+25 SET DFN=+DTA
+26 ;Q:$P(DTA,U,6)<ZSDT!($P(DTA,U,6)>ZEDT)
+27 ;alb/sat 643
if $PIECE(DTA,U,6)>ZEDT
QUIT
+28 ;alb/sat 643
if $PIECE(DTA,U,10)'=""
QUIT
+29 if $$TESTPAT^VADPT(DFN)
QUIT
+30 DO ADD^VADPT
DO DEM^VADPT
+31 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+32 SET PN=$PIECE(VADM(1),U)
+33 IF $GET(VADM(6),U)'=""
QUIT
+34 NEW CHECK
+35 IF $$BADADR^DGUTL3(DFN)
SET CHECK=1
SET XMSUB="Bad Address for Recall Reminder Patient"
SET XMTEXT="SDRR("
Begin DoDot:5
+36 SET XMY("G.SDRR BAD ADDRESS")=""
SET XMDUZ=.5
+37 SET SDRR(1)="Bad Address - letter will not be printed for:"_" "_PN_" "_VA("BID")
+38 DO ^XMD
+39 KILL XMY,XMSUB,XMTEXT,XMDUZ
+40 QUIT
End DoDot:5
+41 ;ADDED THE DATE INFORMATION
+42 ;NEW CODE
IF '$DATA(CHECK)
SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
+43 if $DATA(CHECK)
QUIT
+44 USE IO
+45 ; SD*579 - Add date printed and last 4
+46 SET PRNDT=$TRANSLATE($$FMTE^XLFDT(DT,"5DF")," ","0")
+47 SET LAST4=$EXTRACT($PIECE(VA("BID"),U),1,4)
+48 WRITE @IOF
+49 WRITE !,?65,PRNDT
+50 WRITE !,?65,$EXTRACT(PN,1)_LAST4
+51 FOR L=1:1:9
WRITE !
+52 ; SD*579 - Fix suffix problem
+53 SET PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
+54 WRITE !?20,PNAME
+55 ; SD*654 fix incomplete addr
DO ADDR
+56 IF LETTER=0
WRITE !!!!!,?25,MESSAGE
+57 IF TIME'=""
WRITE !!!!?2,"**"_TIME
+58 IF LAB'=""
WRITE !!!!!,?2,"*"_LAB
+59 WRITE !!!
+60 if '$DATA(MESSAGE)
SET LETTER=$ORDER(^SD(403.52,"B",CLINIC,LETTER))
+61 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)
End DoDot:4
End DoDot:3
+62 DO ^%ZISC
End DoDot:2
End DoDot:1
+63 KILL DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
+64 KILL MESSAGE,LETTER,PRNDT,LAST4,PNAME
QUIT KILL DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,LAB,STATE
+1 KILL LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,PROV,TEAM,CRP,DATE,TYPE,SDRR,DPT,VA
+2 DO KVAR^VADPT
+3 QUIT
+4 ;
KXREF ; SD*579 - If entry not exist, kill all the x-refs.
+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
