SDRRTSK1 ;10N20/MAH - Recall Reminder-Clinic Print Task ;09/07/17
;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
;;This routine is called from SDRR TASK JOB CARD
;;and will be called if PARAM IS cards
;
; SD*654
; - fixes incomplete Canadian address.
;
START 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["L"
.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 D0=0 F S D0=$O(^SD(403.5,"C",PROV,D0)) Q:D0="" 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))
....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":"**FL",$P(^SD(403.5,D0,0),"^",8)="n":"**NFL",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- card 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
....Q:$D(CHECK)
....U IO
....W @IOF F L=1:1:7 W !
....S PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
....W !?20,PNAME
....D ADDR ; SD*654 fix incomplete addr
....I TIME'="" W !!?45,TIME
....I LAB'="" W !,?45,LAB
..D ^%ZISC
K DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
QUIT K DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,TYPE,PTN,CRP,STATE,PNAME
K LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,DPT,LAB,SDRR,VA,LAB,DPT,SDRR,VA
D KVAR^VADPT
Q
;
KXREF ; SD*579 - If entry does 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[HSDRRTSK1 4164 printed Apr 09, 2024@21:41:40 Page 2
SDRRTSK1 ;10N20/MAH - Recall Reminder-Clinic Print Task ;09/07/17
+1 ;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
+2 ;;This routine is called from SDRR TASK JOB CARD
+3 ;;and will be called if PARAM IS cards
+4 ;
+5 ; SD*654
+6 ; - fixes incomplete Canadian address.
+7 ;
START if '$DATA(^SD(403.53,0))
QUIT
+1 SET CRP=0
+2 FOR
SET CRP=$ORDER(^SD(403.53,CRP))
if 'CRP
QUIT
Begin DoDot:1
+3 SET TYPE=$PIECE($GET(^SD(403.53,CRP,0)),"^",2)
+4 if TYPE["L"
QUIT
+5 ;IF NOT SET ROUTINE WILL QUIT
SET DATE=$PIECE($GET(^SD(403.53,CRP,0)),"^",4)
if DATE=""
QUIT
+6 SET X="T+"_DATE
DO ^%DT
SET (ZSDT,ZEDT)=Y
KILL Y
+7 SET (PRT,TEAM)=0
+8 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
+9 if PRT=""
QUIT
+10 SET DA=PRT
+11 SET DIC="^%ZIS(1,"
SET DR=".01;1;3"
SET DIQ="DPTR"
SET DIQ(0)="I"
DO EN^DIQ1
+12 NEW IOP
SET IOP=$GET(DPTR("3.5",DA,".01","I"))
DO ^%ZIS
+13 SET PROV=0
FOR
SET PROV=$ORDER(^SD(403.54,"C",TEAM,PROV))
if PROV=""
QUIT
Begin DoDot:3
+14 SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",PROV,D0))
if D0=""
QUIT
Begin DoDot:4
+15 ; SD*579 - if entry not exist, kill x-refs and quit
+16 IF '$DATA(^SD(403.5,D0))
DO KXREF
QUIT
+17 SET DTA=$GET(^SD(403.5,D0,0))
+18 SET TIME=""
+19 IF $PIECE($GET(^SD(403.5,D0,0)),"^",9)>45
SET TIME=$PIECE($GET(^SD(403.5,D0,0)),"^",9)
SET TIME="**"_TIME_"**"
+20 SET LAB=$SELECT($PIECE($GET(^SD(403.5,D0,0)),"^",8)="f":"**FL",$PIECE(^SD(403.5,D0,0),"^",8)="n":"**NFL",1:"")
+21 SET DFN=+DTA
+22 ;Q:$P(DTA,U,6)<ZSDT!($P(DTA,U,6)>ZEDT)
+23 ;alb/sat 643
if $PIECE(DTA,U,6)>ZEDT
QUIT
+24 ;alb/sat 643
if $PIECE(DTA,U,10)'=""
QUIT
+25 if $$TESTPAT^VADPT(DFN)
QUIT
+26 DO ADD^VADPT
DO DEM^VADPT
+27 SET STATE=$PIECE(VAPA(5),"^",1)
SET STATE=$$GET1^DIQ(5,STATE_",",1)
+28 SET PN=$PIECE(VADM(1),U)
+29 IF $GET(VADM(6),U)'=""
QUIT
+30 NEW CHECK
+31 IF $$BADADR^DGUTL3(DFN)
SET CHECK=1
SET XMSUB="Bad Address for Recall Reminder Patient"
SET XMTEXT="SDRR("
Begin DoDot:5
+32 SET XMY("G.SDRR BAD ADDRESS")=""
SET XMDUZ=.5
+33 SET SDRR(1)="Bad Address- card will not be printed for:"_" "_PN_" "_VA("BID")
+34 DO ^XMD
+35 KILL XMY,XMSUB,XMTEXT,XMDUZ
+36 QUIT
+37 ;ADDED THE DATE INFORMATION
End DoDot:5
+38 IF '$DATA(CHECK)
SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
+39 if $DATA(CHECK)
QUIT
+40 USE IO
+41 WRITE @IOF
FOR L=1:1:7
WRITE !
+42 SET PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
+43 WRITE !?20,PNAME
+44 ; SD*654 fix incomplete addr
DO ADDR
+45 IF TIME'=""
WRITE !!?45,TIME
+46 IF LAB'=""
WRITE !,?45,LAB
End DoDot:4
End DoDot:3
+47 DO ^%ZISC
End DoDot:2
End DoDot:1
+48 KILL DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
QUIT KILL DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,TYPE,PTN,CRP,STATE,PNAME
+1 KILL LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,DPT,LAB,SDRR,VA,LAB,DPT,SDRR,VA
+2 DO KVAR^VADPT
+3 QUIT
+4 ;
KXREF ; SD*579 - If entry does 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
