SDRRCRR ;10N20/MAH;clinic recall list report; 11/8/2006
;;5.3;Scheduling;**536**;Aug 13, 1993;Build 53
STR K DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT,Q,X
S DIR(0)="SO^1:All Clinics;2:Selected Clinics;3:Selected Team"
W ! S DIR("A")="Please select what type of Clinic Recall List you are looking for"
D ^DIR G:$D(DUOUT)!($D(DTOUT)!($D(DIRUT))) QUIT S Q=Y
I Q=1 K DIR D DATE,EN G QUIT
I Q=2 K DIR D DATE,EN1 G QUIT
I Q=3 K DIR D DATE G EN2^SDRRCRR1
DATE ;SETS UP TO FROM DATE AND WILL GROUP BY MONTH IF SELECTED MULTIPLE MONTHS
S %DT="AEX",%DT("A")="Start with Recall Date First: " D ^%DT G:Y<0 STR S SDT=Y K Y
S %DT("A")="Recall Date Lasted: " D ^%DT I Y<SDT W $C(7)," Can't be before Recall Date First - Try Again" G DATE
Q:Y<0 S EDT=Y K Y
Q
EN ;all clinics by division
Q:'$D(SDT)
W ! S SDEND=1 D ASK2^SDDIV G:Y<0 QUIT
I VAUTD=1 G ENDIV
I VAUTD=0 G ONDIV
Q
ENDIV ;
W !!,"***This report requires 132 columns",!! S %ZIS="QM" D ^%ZIS G:POP QUIT
I $D(IO("Q")) S ZTDESC="Print Recall List for Division",ZTRTN="EDIV^SDRRCRR" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
EDIV K ^TMP($J,"ENDIV")
S (PRO,PRO1,PRO2,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
S ZPR=0 F S ZPR=$O(^SD(403.5,"C",ZPR)) Q:ZPR="" S DIV=$P($G(^SD(403.54,ZPR,0)),"^",3) S D0=0 F S D0=$O(^SD(403.5,"C",ZPR,D0)) Q:D0="" S DTA=$G(^SD(403.5,D0,0)) D:DTA]""
.S RDT=$P($G(DTA),"^",6) Q:RDT=""
.Q:RDT<SDT!(RDT>EDT)
.S MONTH=$E(RDT,4,5),YR=$E(RDT,2,3)
.S CLINIC=$P($G(DTA),"^",2) I CLINIC'="" S CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
.I CLINIC="" S CLINIC="Unknown Clinic" ;CLINIC
.S Y=RDT D DD^%DT S DATE=Y K Y ;RECALL DATE
.S PAT=$P($G(DTA),"^",1)
.Q:$$TESTPAT^VADPT(PAT)
.S DFN=PAT
.D ADD^VADPT,DEM^VADPT
.S LN=$E(VADM(1),1)_$P(VA("BID"),U)
.S PAT1=$P(VADM(1),U)
.S (CDT,CDT1)="",Y=$P($G(DTA),"^",10) I Y'="" D DD^%DT S CDT=Y K Y D
..S Z=$P($G(DTA),"^",13) I Z'=""
..S CDT1="*"_CDT K Z
..I CDT1'="" S CDT=CDT1
.I CDT="" S CDT="NotSent"
.S PHONE=$P(VAPA(8),U)
.I PHONE="" S PHONE="Unk. Phone" ;phone
.S COMMENT=$P($G(DTA),"^",7)
.S PRO=$P($G(DTA),"^",5) I PRO'="" S PRO1=$P($G(^SD(403.54,PRO,0)),"^",1)
.I PRO1'="" S PRO2=$$NAME^XUSER(PRO1,"F")
.I PRO="" S PRO2="Unk. Provider"
.S USER=$P($G(DTA),"^",11) I USER'="" S USER1=$$NAME^XUSER(USER)
.I USER="" S USER1="Unk. User"
.S ^TMP($J,"ENDIV",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
.K CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
D PRT1^SDRRCRRP
D ^%ZISC
G QUIT
ONDIV ;
W !!,"***This report requires 132 columns",!! S %ZIS="QM" D ^%ZIS G:POP QUIT
I $D(IO("Q")) S ZTIO=ION,ZTDESC="Print Recall List for Division",ZTRTN="ONDIV1^SDRRCRR" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
ONDIV1 ;
K ^TMP($J,"ONDIV")
U IO
S (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
S DIV=0
F S DIV=$O(VAUTD(DIV)) Q:DIV="" D
.S ZPR=0 F S ZPR=$O(^SD(403.5,"C",ZPR)) Q:ZPR="" I $P($G(^SD(403.54,ZPR,0)),"^",3)=DIV S D0=0 F S D0=$O(^SD(403.5,"C",ZPR,D0)) Q:D0="" S DTA=$G(^SD(403.5,D0,0)) D:DTA]""
..S RDT=$P($G(DTA),"^",6) Q:RDT=""
..Q:RDT<SDT!(RDT>EDT)
..S MONTH=$E(RDT,4,5),YR=$E(RDT,2,3)
..S CLINIC=$P($G(DTA),"^",2) I CLINIC'="" S CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
..I CLINIC="" S CLINIC="Unknown Clinic" ;CLINIC
..S Y=RDT D DD^%DT S DATE=Y K Y ;RECALL DATE
..S PAT=$P($G(DTA),"^",1)
..Q:$$TESTPAT^VADPT(PAT)
..S DFN=PAT
..D ADD^VADPT,DEM^VADPT
..S LN=$E(VADM(1),1)_$P(VA("BID"),U)
..S PAT1=$P(VADM(1),U)
..S (CDT,CDT1)="",Y=$P($G(DTA),"^",10) I Y'="" D DD^%DT S CDT=Y K Y
..S Z=$P($G(DTA),"^",13) I Z'="" S CDT1="*"_CDT K Z D
...I CDT1'="" S CDT=CDT1
.. I CDT="" S CDT="NotSent"
..S PHONE=$P(VAPA(8),U)
..I PHONE="" S PHONE="Unk. Phone" ;phone
..S COMMENT=$P($G(DTA),"^",7)
..S PRO=$P($G(DTA),"^",5) I PRO'="" S PRO1=$P($G(^SD(403.54,PRO,0)),"^",1),PRO2=$$NAME^XUSER(PRO1,"F")
..I PRO="" S PRO2="Unk. Provider"
..S USER=$P($G(DTA),"^",11) I USER'="" S USER1=$$NAME^XUSER(USER)
..I USER="" S USER1="Unk. User"
..S ^TMP($J,"ONDIV",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
..K CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
D PRT^SDRRCRRP
D ^%ZISC
G QUIT
EN1 ;BY CLINIC SELECTED CLINIC
Q:'$D(SDT)
N VAUTSTR,VAUTVB
S DIC="^SC(",VAUTVB="VAUTC",VAUTSTR="clinic",VAUTNI="1" ;G FIRST^VAUTOMA
S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB S (@VAUTVB,Y)=0
REDO N VAERR,VAI,VAUTNALL,VAUTX
W !,DIC("A") W:'$D(VAUTNALL) "ALL// " R X:DTIME G QUIT:(X="^")!'$T D:X["?" QQ I X="" G:$D(VAUTNALL) QUIT S @VAUTVB=1 G CLIN
S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 REDO D SET
F VAI=1:0:19 W !,DIC("A") R X:DTIME G QUIT:(X="^")!'$T K Y Q:X="" D QQ:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1
CLIN ;
I VAUTC=1 G ENCLIN
I VAUTC=0 G ONCLIN
Q
QQ W !!,"Please select up to 20 clinics that you would like to print"
Q
ONCLIN W !!,"***This report requires 132 columns",!! S %ZIS="QM" D ^%ZIS G:POP QUIT
I $D(IO("Q")) S ZTIO=ION,ZTDESC="Print Recall List for Clinics",ZTRTN="ONCLIN1^SDRRCRR" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
ONCLIN1 ;
K ^TMP($J,"ONCLIN")
S (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
S DIV=0
F S DIV=$O(VAUTC(DIV)) Q:DIV="" S ZPR=$P(VAUTC(DIV),"^",1) D
.S D0=0 F S D0=$O(^SD(403.5,"E",ZPR,D0)) Q:D0="" S DTA=$G(^SD(403.5,D0,0)) D:DTA]""
..S RDT=$P($G(DTA),"^",6) Q:RDT=""
..Q:RDT<SDT!(RDT>EDT)
..S MONTH=$E(RDT,4,5),YR=$E(RDT,2,3)
..S CLINIC=$P($G(DTA),"^",2) Q:CLINIC'=ZPR I CLINIC'="" S CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
..I CLINIC="" S CLINIC="Unknown Clinic" ;CLINIC
..S Y=RDT D DD^%DT S DATE=Y K Y ;RECALL DATE
..S PAT=$P($G(DTA),"^",1)
..Q:$$TESTPAT^VADPT(PAT)
..S DFN=PAT
..D ADD^VADPT,DEM^VADPT
..S LN=$E(VADM(1),1)_$P(VA("BID"),U)
..S PAT1=$P(VADM(1),U)
..S CDT="",Y=$P($G(DTA),"^",10) I Y'="" D DD^%DT S CDT=Y K Y
..S Z=$P($G(DTA),"^",13) I Z'="" S CDT1="*"_CDT K Z D
...I CDT1'="" S CDT=CDT1
..I CDT="" S CDT="NotSent"
..S PHONE=$P(VAPA(8),U)
..I PHONE="" S PHONE="Unk. Phone" ;phone
..S COMMENT=$P($G(DTA),"^",7)
..S PRO=$P($G(DTA),"^",5) I PRO'="" S PRO1=$P($G(^SD(403.54,PRO,0)),"^",1),PRO2=$$NAME^XUSER(PRO1,"F")
..I PRO="" S PRO2="Unk. Provider"
..S USER=$P($G(DTA),"^",11) I USER'="" S USER1=$$NAME^XUSER(USER)
..I USER="" S USER1="Unk. User"
..S ^TMP($J,"ONCLIN",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
..K CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
D PRT2^SDRRCRRP
D ^%ZISC
G QUIT
;by division works fine
ENCLIN W !!,"***This report requires 132 columns",!! S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D ^%ZIS G:POP QUIT S ZTIO=ION,ZTDESC="Print Recall List for Clinics",ZTRTN="ENCLIN1^SDRRCRR" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
ENCLIN1 ;
K ^TMP($J,"ENCLIN")
S (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
S ZPR=0 F S ZPR=$O(^SD(403.5,"E",ZPR)) Q:ZPR="" S D0=0 F S D0=$O(^SD(403.5,"E",ZPR,D0)) Q:D0="" S DTA=$G(^SD(403.5,D0,0)) D:DTA]""
.S RDT=$P($G(DTA),"^",6) Q:RDT=""
.Q:RDT<SDT!(RDT>EDT)
.S MONTH=$E(RDT,4,5),YR=$E(RDT,2,3)
.S CLINIC=$P($G(DTA),"^",2),DIV=CLINIC I CLINIC'="" S CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
.I DIV="" S DIV="Unknown"
.I CLINIC="" S CLINIC="Unknown Clinic" ;CLINIC
.S Y=RDT D DD^%DT S DATE=Y K Y ;RECALL DATE
.S PAT=$P($G(DTA),"^",1)
.Q:$$TESTPAT^VADPT(PAT)
.S DFN=PAT
.D ADD^VADPT,DEM^VADPT
.S LN=$E(VADM(1),1)_$P(VA("BID"),U)
.S PAT1=$P(VADM(1),U)
.S (CDT,CDT1)="",Y=$P($G(DTA),"^",10) I Y'="" D DD^%DT S CDT=Y K Y
.S Z=$P($G(DTA),"^",13) I Z'="" S CDT1="*"_CDT K Z D
..I CDT1'="" S CDT=CDT1
.I CDT="" S CDT="NotSent"
.S PHONE=$P(VAPA(8),U)
.I PHONE="" S PHONE="Unk. Phone" ;phone
.S COMMENT=$P($G(DTA),"^",7)
.S PRO=$P($G(DTA),"^",5) I PRO'="" S PRO1=$P($G(^SD(403.54,PRO,0)),"^",1),PRO2=$$NAME^XUSER(PRO1,"F")
.I PRO="" S PRO2="Unk. Provider"
.S USER=$P($G(DTA),"^",11) I USER'="" S USER1=$$NAME^XUSER(USER)
.I USER="" S USER1="Unk. User"
.S ^TMP($J,"ENCLIN",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
.K CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
D PRT3^SDRRCRRP
D ^%ZISC
G QUIT
;BY CLINICS WORK FINE
SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q
S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,". Try again." S VAERR=1
I VAUTNI=1 S @VAUTVB@($P(Y(0),U))=+Y Q
I VAUTNI=3 S @VAUTVB@($P(Y(0,0),U))=+Y Q
S @VAUTVB@(+Y)=$P(Y(0),U) Q
QUIT K DIR,Y,SDT,EDT,X,D0,COMMENT,DATE,DIC,I,DTA,DIV,J,LN,MONTH,PAT1,PHONE,POP,PRO1,PRO2,Q,SDEND,SSN,USER1,%,VAUTC,VAUTD,VA,YR,ZPR,VAUTNI
K ZTDESC,ZTIO,ZTRTN,ZTSAVE,%DT,%ZIS,DFN,VAX,VADM,VAPA
D KVAR^VADPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRCRR 9027 printed Nov 22, 2024@18:10:30 Page 2
SDRRCRR ;10N20/MAH;clinic recall list report; 11/8/2006
+1 ;;5.3;Scheduling;**536**;Aug 13, 1993;Build 53
STR KILL DIR,Y,DTOUT,DIROUT,DIRUT,DUOUT,Q,X
+1 SET DIR(0)="SO^1:All Clinics;2:Selected Clinics;3:Selected Team"
+2 WRITE !
SET DIR("A")="Please select what type of Clinic Recall List you are looking for"
+3 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT)!($DATA(DIRUT)))
GOTO QUIT
SET Q=Y
+4 IF Q=1
KILL DIR
DO DATE
DO EN
GOTO QUIT
+5 IF Q=2
KILL DIR
DO DATE
DO EN1
GOTO QUIT
+6 IF Q=3
KILL DIR
DO DATE
GOTO EN2^SDRRCRR1
DATE ;SETS UP TO FROM DATE AND WILL GROUP BY MONTH IF SELECTED MULTIPLE MONTHS
+1 SET %DT="AEX"
SET %DT("A")="Start with Recall Date First: "
DO ^%DT
if Y<0
GOTO STR
SET SDT=Y
KILL Y
+2 SET %DT("A")="Recall Date Lasted: "
DO ^%DT
IF Y<SDT
WRITE $CHAR(7)," Can't be before Recall Date First - Try Again"
GOTO DATE
+3 if Y<0
QUIT
SET EDT=Y
KILL Y
+4 QUIT
EN ;all clinics by division
+1 if '$DATA(SDT)
QUIT
+2 WRITE !
SET SDEND=1
DO ASK2^SDDIV
if Y<0
GOTO QUIT
+3 IF VAUTD=1
GOTO ENDIV
+4 IF VAUTD=0
GOTO ONDIV
+5 QUIT
ENDIV ;
+1 WRITE !!,"***This report requires 132 columns",!!
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
+2 IF $DATA(IO("Q"))
SET ZTDESC="Print Recall List for Division"
SET ZTRTN="EDIV^SDRRCRR"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
EDIV KILL ^TMP($JOB,"ENDIV")
+1 SET (PRO,PRO1,PRO2,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
+2 SET ZPR=0
FOR
SET ZPR=$ORDER(^SD(403.5,"C",ZPR))
if ZPR=""
QUIT
SET DIV=$PIECE($GET(^SD(403.54,ZPR,0)),"^",3)
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",ZPR,D0))
if D0=""
QUIT
SET DTA=$GET(^SD(403.5,D0,0))
if DTA]""
Begin DoDot:1
+3 SET RDT=$PIECE($GET(DTA),"^",6)
if RDT=""
QUIT
+4 if RDT<SDT!(RDT>EDT)
QUIT
+5 SET MONTH=$EXTRACT(RDT,4,5)
SET YR=$EXTRACT(RDT,2,3)
+6 SET CLINIC=$PIECE($GET(DTA),"^",2)
IF CLINIC'=""
SET CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
+7 ;CLINIC
IF CLINIC=""
SET CLINIC="Unknown Clinic"
+8 ;RECALL DATE
SET Y=RDT
DO DD^%DT
SET DATE=Y
KILL Y
+9 SET PAT=$PIECE($GET(DTA),"^",1)
+10 if $$TESTPAT^VADPT(PAT)
QUIT
+11 SET DFN=PAT
+12 DO ADD^VADPT
DO DEM^VADPT
+13 SET LN=$EXTRACT(VADM(1),1)_$PIECE(VA("BID"),U)
+14 SET PAT1=$PIECE(VADM(1),U)
+15 SET (CDT,CDT1)=""
SET Y=$PIECE($GET(DTA),"^",10)
IF Y'=""
DO DD^%DT
SET CDT=Y
KILL Y
Begin DoDot:2
+16 SET Z=$PIECE($GET(DTA),"^",13)
IF Z'=""
+17 SET CDT1="*"_CDT
KILL Z
+18 IF CDT1'=""
SET CDT=CDT1
End DoDot:2
+19 IF CDT=""
SET CDT="NotSent"
+20 SET PHONE=$PIECE(VAPA(8),U)
+21 ;phone
IF PHONE=""
SET PHONE="Unk. Phone"
+22 SET COMMENT=$PIECE($GET(DTA),"^",7)
+23 SET PRO=$PIECE($GET(DTA),"^",5)
IF PRO'=""
SET PRO1=$PIECE($GET(^SD(403.54,PRO,0)),"^",1)
+24 IF PRO1'=""
SET PRO2=$$NAME^XUSER(PRO1,"F")
+25 IF PRO=""
SET PRO2="Unk. Provider"
+26 SET USER=$PIECE($GET(DTA),"^",11)
IF USER'=""
SET USER1=$$NAME^XUSER(USER)
+27 IF USER=""
SET USER1="Unk. User"
+28 SET ^TMP($JOB,"ENDIV",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
+29 KILL CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
End DoDot:1
+30 DO PRT1^SDRRCRRP
+31 DO ^%ZISC
+32 GOTO QUIT
ONDIV ;
+1 WRITE !!,"***This report requires 132 columns",!!
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
+2 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTDESC="Print Recall List for Division"
SET ZTRTN="ONDIV1^SDRRCRR"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
ONDIV1 ;
+1 KILL ^TMP($JOB,"ONDIV")
+2 USE IO
+3 SET (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
+4 SET DIV=0
+5 FOR
SET DIV=$ORDER(VAUTD(DIV))
if DIV=""
QUIT
Begin DoDot:1
+6 SET ZPR=0
FOR
SET ZPR=$ORDER(^SD(403.5,"C",ZPR))
if ZPR=""
QUIT
IF $PIECE($GET(^SD(403.54,ZPR,0)),"^",3)=DIV
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"C",ZPR,D0))
if D0=""
QUIT
SET DTA=$GET(^SD(403.5,D0,0))
if DTA]""
Begin DoDot:2
+7 SET RDT=$PIECE($GET(DTA),"^",6)
if RDT=""
QUIT
+8 if RDT<SDT!(RDT>EDT)
QUIT
+9 SET MONTH=$EXTRACT(RDT,4,5)
SET YR=$EXTRACT(RDT,2,3)
+10 SET CLINIC=$PIECE($GET(DTA),"^",2)
IF CLINIC'=""
SET CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
+11 ;CLINIC
IF CLINIC=""
SET CLINIC="Unknown Clinic"
+12 ;RECALL DATE
SET Y=RDT
DO DD^%DT
SET DATE=Y
KILL Y
+13 SET PAT=$PIECE($GET(DTA),"^",1)
+14 if $$TESTPAT^VADPT(PAT)
QUIT
+15 SET DFN=PAT
+16 DO ADD^VADPT
DO DEM^VADPT
+17 SET LN=$EXTRACT(VADM(1),1)_$PIECE(VA("BID"),U)
+18 SET PAT1=$PIECE(VADM(1),U)
+19 SET (CDT,CDT1)=""
SET Y=$PIECE($GET(DTA),"^",10)
IF Y'=""
DO DD^%DT
SET CDT=Y
KILL Y
+20 SET Z=$PIECE($GET(DTA),"^",13)
IF Z'=""
SET CDT1="*"_CDT
KILL Z
Begin DoDot:3
+21 IF CDT1'=""
SET CDT=CDT1
End DoDot:3
+22 IF CDT=""
SET CDT="NotSent"
+23 SET PHONE=$PIECE(VAPA(8),U)
+24 ;phone
IF PHONE=""
SET PHONE="Unk. Phone"
+25 SET COMMENT=$PIECE($GET(DTA),"^",7)
+26 SET PRO=$PIECE($GET(DTA),"^",5)
IF PRO'=""
SET PRO1=$PIECE($GET(^SD(403.54,PRO,0)),"^",1)
SET PRO2=$$NAME^XUSER(PRO1,"F")
+27 IF PRO=""
SET PRO2="Unk. Provider"
+28 SET USER=$PIECE($GET(DTA),"^",11)
IF USER'=""
SET USER1=$$NAME^XUSER(USER)
+29 IF USER=""
SET USER1="Unk. User"
+30 SET ^TMP($JOB,"ONDIV",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
+31 KILL CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
End DoDot:2
End DoDot:1
+32 DO PRT^SDRRCRRP
+33 DO ^%ZISC
+34 GOTO QUIT
EN1 ;BY CLINIC SELECTED CLINIC
+1 if '$DATA(SDT)
QUIT
+2 NEW VAUTSTR,VAUTVB
+3 ;G FIRST^VAUTOMA
SET DIC="^SC("
SET VAUTVB="VAUTC"
SET VAUTSTR="clinic"
SET VAUTNI="1"
+4 SET DIC(0)="EQMNZ"
SET DIC("A")="Select "_VAUTSTR_": "
KILL @VAUTVB
SET (@VAUTVB,Y)=0
REDO NEW VAERR,VAI,VAUTNALL,VAUTX
+1 WRITE !,DIC("A")
if '$DATA(VAUTNALL)
WRITE "ALL// "
READ X:DTIME
if (X="^")!'$TEST
GOTO QUIT
if X["?"
DO QQ
IF X=""
if $DATA(VAUTNALL)
GOTO QUIT
SET @VAUTVB=1
GOTO CLIN
+2 SET DIC("A")="Select another "_VAUTSTR_": "
DO ^DIC
if Y'>0
GOTO REDO
DO SET
+3 FOR VAI=1:0:19
WRITE !,DIC("A")
READ X:DTIME
if (X="^")!'$TEST
GOTO QUIT
KILL Y
if X=""
QUIT
if X["?"
DO QQ
if $EXTRACT(X)="-"
SET VAUTX=X
SET X=$EXTRACT(VAUTX,2,999)
DO ^DIC
IF Y>0
DO SET
if VAX
GOTO REDO
if 'VAERR
SET VAI=VAI+1
CLIN ;
+1 IF VAUTC=1
GOTO ENCLIN
+2 IF VAUTC=0
GOTO ONCLIN
+3 QUIT
QQ WRITE !!,"Please select up to 20 clinics that you would like to print"
+1 QUIT
ONCLIN WRITE !!,"***This report requires 132 columns",!!
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO QUIT
+1 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTDESC="Print Recall List for Clinics"
SET ZTRTN="ONCLIN1^SDRRCRR"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
ONCLIN1 ;
+1 KILL ^TMP($JOB,"ONCLIN")
+2 SET (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
+3 SET DIV=0
+4 FOR
SET DIV=$ORDER(VAUTC(DIV))
if DIV=""
QUIT
SET ZPR=$PIECE(VAUTC(DIV),"^",1)
Begin DoDot:1
+5 SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"E",ZPR,D0))
if D0=""
QUIT
SET DTA=$GET(^SD(403.5,D0,0))
if DTA]""
Begin DoDot:2
+6 SET RDT=$PIECE($GET(DTA),"^",6)
if RDT=""
QUIT
+7 if RDT<SDT!(RDT>EDT)
QUIT
+8 SET MONTH=$EXTRACT(RDT,4,5)
SET YR=$EXTRACT(RDT,2,3)
+9 SET CLINIC=$PIECE($GET(DTA),"^",2)
if CLINIC'=ZPR
QUIT
IF CLINIC'=""
SET CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
+10 ;CLINIC
IF CLINIC=""
SET CLINIC="Unknown Clinic"
+11 ;RECALL DATE
SET Y=RDT
DO DD^%DT
SET DATE=Y
KILL Y
+12 SET PAT=$PIECE($GET(DTA),"^",1)
+13 if $$TESTPAT^VADPT(PAT)
QUIT
+14 SET DFN=PAT
+15 DO ADD^VADPT
DO DEM^VADPT
+16 SET LN=$EXTRACT(VADM(1),1)_$PIECE(VA("BID"),U)
+17 SET PAT1=$PIECE(VADM(1),U)
+18 SET CDT=""
SET Y=$PIECE($GET(DTA),"^",10)
IF Y'=""
DO DD^%DT
SET CDT=Y
KILL Y
+19 SET Z=$PIECE($GET(DTA),"^",13)
IF Z'=""
SET CDT1="*"_CDT
KILL Z
Begin DoDot:3
+20 IF CDT1'=""
SET CDT=CDT1
End DoDot:3
+21 IF CDT=""
SET CDT="NotSent"
+22 SET PHONE=$PIECE(VAPA(8),U)
+23 ;phone
IF PHONE=""
SET PHONE="Unk. Phone"
+24 SET COMMENT=$PIECE($GET(DTA),"^",7)
+25 SET PRO=$PIECE($GET(DTA),"^",5)
IF PRO'=""
SET PRO1=$PIECE($GET(^SD(403.54,PRO,0)),"^",1)
SET PRO2=$$NAME^XUSER(PRO1,"F")
+26 IF PRO=""
SET PRO2="Unk. Provider"
+27 SET USER=$PIECE($GET(DTA),"^",11)
IF USER'=""
SET USER1=$$NAME^XUSER(USER)
+28 IF USER=""
SET USER1="Unk. User"
+29 SET ^TMP($JOB,"ONCLIN",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
+30 KILL CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
End DoDot:2
End DoDot:1
+31 DO PRT2^SDRRCRRP
+32 DO ^%ZISC
+33 GOTO QUIT
+34 ;by division works fine
ENCLIN WRITE !!,"***This report requires 132 columns",!!
SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+1 IF $DATA(IO("Q"))
DO ^%ZIS
if POP
GOTO QUIT
SET ZTIO=ION
SET ZTDESC="Print Recall List for Clinics"
SET ZTRTN="ENCLIN1^SDRRCRR"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
ENCLIN1 ;
+1 KILL ^TMP($JOB,"ENCLIN")
+2 SET (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT)=""
+3 SET ZPR=0
FOR
SET ZPR=$ORDER(^SD(403.5,"E",ZPR))
if ZPR=""
QUIT
SET D0=0
FOR
SET D0=$ORDER(^SD(403.5,"E",ZPR,D0))
if D0=""
QUIT
SET DTA=$GET(^SD(403.5,D0,0))
if DTA]""
Begin DoDot:1
+4 SET RDT=$PIECE($GET(DTA),"^",6)
if RDT=""
QUIT
+5 if RDT<SDT!(RDT>EDT)
QUIT
+6 SET MONTH=$EXTRACT(RDT,4,5)
SET YR=$EXTRACT(RDT,2,3)
+7 SET CLINIC=$PIECE($GET(DTA),"^",2)
SET DIV=CLINIC
IF CLINIC'=""
SET CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
+8 IF DIV=""
SET DIV="Unknown"
+9 ;CLINIC
IF CLINIC=""
SET CLINIC="Unknown Clinic"
+10 ;RECALL DATE
SET Y=RDT
DO DD^%DT
SET DATE=Y
KILL Y
+11 SET PAT=$PIECE($GET(DTA),"^",1)
+12 if $$TESTPAT^VADPT(PAT)
QUIT
+13 SET DFN=PAT
+14 DO ADD^VADPT
DO DEM^VADPT
+15 SET LN=$EXTRACT(VADM(1),1)_$PIECE(VA("BID"),U)
+16 SET PAT1=$PIECE(VADM(1),U)
+17 SET (CDT,CDT1)=""
SET Y=$PIECE($GET(DTA),"^",10)
IF Y'=""
DO DD^%DT
SET CDT=Y
KILL Y
+18 SET Z=$PIECE($GET(DTA),"^",13)
IF Z'=""
SET CDT1="*"_CDT
KILL Z
Begin DoDot:2
+19 IF CDT1'=""
SET CDT=CDT1
End DoDot:2
+20 IF CDT=""
SET CDT="NotSent"
+21 SET PHONE=$PIECE(VAPA(8),U)
+22 ;phone
IF PHONE=""
SET PHONE="Unk. Phone"
+23 SET COMMENT=$PIECE($GET(DTA),"^",7)
+24 SET PRO=$PIECE($GET(DTA),"^",5)
IF PRO'=""
SET PRO1=$PIECE($GET(^SD(403.54,PRO,0)),"^",1)
SET PRO2=$$NAME^XUSER(PRO1,"F")
+25 IF PRO=""
SET PRO2="Unk. Provider"
+26 SET USER=$PIECE($GET(DTA),"^",11)
IF USER'=""
SET USER1=$$NAME^XUSER(USER)
+27 IF USER=""
SET USER1="Unk. User"
+28 SET ^TMP($JOB,"ENCLIN",DIV,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
+29 KILL CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
End DoDot:1
+30 DO PRT3^SDRRCRRP
+31 DO ^%ZISC
+32 GOTO QUIT
+33 ;BY CLINICS WORK FINE
SET SET VAX=0
IF $DATA(VAUTX)
SET J=$SELECT(VAUTNI=2:+Y,1:$PIECE(Y(0),"^"))
KILL VAUTX
SET VAERR=$SELECT($DATA(@VAUTVB@(J)):0,1:1)
WRITE $SELECT('VAERR:"...removed from list...",1:"...not on list...can't remove")
if VAERR
QUIT
SET VAI=VAI-1
KILL @VAUTVB@(J)
if $ORDER(@VAUTVB@(0))']""
SET VAX=1
QUIT
+1 SET VAERR=0
IF $SELECT($DATA(@VAUTVB@($PIECE(Y(0),U))):1,$DATA(@VAUTVB@(+Y)):1,1:0)
WRITE !?3,*7,"You have already selected that ",VAUTSTR,". Try again."
SET VAERR=1
+2 IF VAUTNI=1
SET @VAUTVB@($PIECE(Y(0),U))=+Y
QUIT
+3 IF VAUTNI=3
SET @VAUTVB@($PIECE(Y(0,0),U))=+Y
QUIT
+4 SET @VAUTVB@(+Y)=$PIECE(Y(0),U)
QUIT
QUIT KILL DIR,Y,SDT,EDT,X,D0,COMMENT,DATE,DIC,I,DTA,DIV,J,LN,MONTH,PAT1,PHONE,POP,PRO1,PRO2,Q,SDEND,SSN,USER1,%,VAUTC,VAUTD,VA,YR,ZPR,VAUTNI
+1 KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE,%DT,%ZIS,DFN,VAX,VADM,VAPA
+2 DO KVAR^VADPT
+3 QUIT
