SDRRCRR1 ;10N20/MAH;Recall Reminder list report; 11/8/2006
;;5.3;Scheduling;**536**;Aug 13, 1993;Build 53
EN2 ;BY Teams SELECTED Team
G:'$D(SDT) QUIT
N VAUTSTR,VAUTVB
S DIC="^SD(403.55,",VAUTVB="VAUTT",VAUTSTR="Team",VAUTNI="1"
S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB S (@VAUTVB,Y)=0
REDO1 N VAERR,VAI,VAUTNALL,VAUTX
W !,DIC("A") W:'$D(VAUTNALL) "ALL// " R X:DTIME G QUIT:(X="^")!'$T D:X["?" QQQ I X="" G:$D(VAUTNALL) QUIT S @VAUTVB=1 G TEAM
S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 REDO1 D SET
F VAI=1:0:19 W !,DIC("A") R X:DTIME G QUIT:(X="^")!'$T K Y Q:X="" D QQQ:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO1 S:'VAERR VAI=VAI+1
TEAM ;
I VAUTT=1 G ENTEAM
I VAUTT=0 G ONTEAM
Q
QQQ W !!,"Please select up to 20 Team that you would like to print" Q
ENTEAM 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="ENTEAM1^SDRRCRR1" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
ENTEAM1 ;ALL TEAMS
K ^TMP($J,"ENTEAM")
S (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT,DIV,DIV1,TEST)=""
S ZPR=0 F S ZPR=$O(^SD(403.5,"C",ZPR)) Q:ZPR="" 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 TEST=$P($G(^SD(403.5,D0,0)),U,5) S DIV=$P($G(^SD(403.54,TEST,0)),U,2)
.I DIV'="" S DIV1=$P($G(^SD(403.55,DIV,0)),"^",1)
.I DIV1="" S DIV1="Unknown"
.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 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,"ENTEAM",DIV1,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
.K CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
D PRT4^SDRRCRRP
D ^%ZISC
G QUIT
;THIS PART OF THE TEAMS IS OK
ONTEAM 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="ONTEAM1^SDRRCRR1" S ZTSAVE("*")="" D ^%ZTLOAD G QUIT
ONTEAM1 ;SELECTED TEAMS
K ^TMP($J,"ONTEAM")
S (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT,DIV,DIV1,TEST)=""
S TM=0
F S TM=$O(VAUTT(TM)) Q:TM="" S TEAM=$P(VAUTT(TM),"^",1) D
.S ZPR=0 F S ZPR=$O(^SD(403.5,"C",ZPR)) Q:ZPR="" 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 TEST=$P($G(^SD(403.5,D0,0)),U,5) S DIV=$P($G(^SD(403.54,TEST,0)),U,2)
..Q:DIV'=TEAM
..I DIV'="" S DIV1=$P($G(^SD(403.55,DIV,0)),"^",1)
..I DIV1="" S DIV1="Unknown"
..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 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,"ONTEAM",DIV1,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
..K CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
D PRT5^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,COMMENT,D0,DATE,DIC,DIV,DIV1,DTA,I,J,LN,MONTH,PAT1,PHONE,POP,PRO1,PRO2,SSN,TEAM,TEST,TM,USER1,X,YR,ZPR
K ZTDESC,ZTIO,ZTRTN,ZTSAVE,%DT,%ZIS,%,VAUTC,VAUTD,VA,VAUTNI,VAUTT,DFN,VAX,VAERR,VADM,VAPA
D KVAR^VADPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRCRR1 5314 printed Dec 13, 2024@03:00:39 Page 2
SDRRCRR1 ;10N20/MAH;Recall Reminder list report; 11/8/2006
+1 ;;5.3;Scheduling;**536**;Aug 13, 1993;Build 53
EN2 ;BY Teams SELECTED Team
+1 if '$DATA(SDT)
GOTO QUIT
+2 NEW VAUTSTR,VAUTVB
+3 SET DIC="^SD(403.55,"
SET VAUTVB="VAUTT"
SET VAUTSTR="Team"
SET VAUTNI="1"
+4 SET DIC(0)="EQMNZ"
SET DIC("A")="Select "_VAUTSTR_": "
KILL @VAUTVB
SET (@VAUTVB,Y)=0
REDO1 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 QQQ
IF X=""
if $DATA(VAUTNALL)
GOTO QUIT
SET @VAUTVB=1
GOTO TEAM
+2 SET DIC("A")="Select another "_VAUTSTR_": "
DO ^DIC
if Y'>0
GOTO REDO1
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 QQQ
if $EXTRACT(X)="-"
SET VAUTX=X
SET X=$EXTRACT(VAUTX,2,999)
DO ^DIC
IF Y>0
DO SET
if VAX
GOTO REDO1
if 'VAERR
SET VAI=VAI+1
TEAM ;
+1 IF VAUTT=1
GOTO ENTEAM
+2 IF VAUTT=0
GOTO ONTEAM
+3 QUIT
QQQ WRITE !!,"Please select up to 20 Team that you would like to print"
QUIT
ENTEAM 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="ENTEAM1^SDRRCRR1"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
ENTEAM1 ;ALL TEAMS
+1 KILL ^TMP($JOB,"ENTEAM")
+2 SET (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT,DIV,DIV1,TEST)=""
+3 SET ZPR=0
FOR
SET ZPR=$ORDER(^SD(403.5,"C",ZPR))
if ZPR=""
QUIT
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
+4 SET TEST=$PIECE($GET(^SD(403.5,D0,0)),U,5)
SET DIV=$PIECE($GET(^SD(403.54,TEST,0)),U,2)
+5 IF DIV'=""
SET DIV1=$PIECE($GET(^SD(403.55,DIV,0)),"^",1)
+6 IF DIV1=""
SET DIV1="Unknown"
+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)
SET DIV=CLINIC
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:2
+21 IF CDT1'=""
SET CDT=CDT1
End DoDot:2
+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,"ENTEAM",DIV1,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:1
+32 DO PRT4^SDRRCRRP
+33 DO ^%ZISC
+34 GOTO QUIT
+35 ;THIS PART OF THE TEAMS IS OK
ONTEAM 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="ONTEAM1^SDRRCRR1"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
GOTO QUIT
ONTEAM1 ;SELECTED TEAMS
+1 KILL ^TMP($JOB,"ONTEAM")
+2 SET (PRO,RDT,CDT,CDT1,PAT,PHONE,CLINIC,COMMENT,DIV,DIV1,TEST)=""
+3 SET TM=0
+4 FOR
SET TM=$ORDER(VAUTT(TM))
if TM=""
QUIT
SET TEAM=$PIECE(VAUTT(TM),"^",1)
Begin DoDot:1
+5 SET ZPR=0
FOR
SET ZPR=$ORDER(^SD(403.5,"C",ZPR))
if ZPR=""
QUIT
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
+6 SET TEST=$PIECE($GET(^SD(403.5,D0,0)),U,5)
SET DIV=$PIECE($GET(^SD(403.54,TEST,0)),U,2)
+7 if DIV'=TEAM
QUIT
+8 IF DIV'=""
SET DIV1=$PIECE($GET(^SD(403.55,DIV,0)),"^",1)
+9 IF DIV1=""
SET DIV1="Unknown"
+10 SET RDT=$PIECE($GET(DTA),"^",6)
if RDT=""
QUIT
+11 if RDT<SDT!(RDT>EDT)
QUIT
+12 SET MONTH=$EXTRACT(RDT,4,5)
SET YR=$EXTRACT(RDT,2,3)
+13 SET CLINIC=$PIECE($GET(DTA),"^",2)
SET DIV=CLINIC
IF CLINIC'=""
SET CLINIC=$$GET1^DIQ(44,CLINIC_",",.01)
+14 ;CLINIC
IF CLINIC=""
SET CLINIC="Unknown Clinic"
+15 ;RECALL DATE
SET Y=RDT
DO DD^%DT
SET DATE=Y
KILL Y
+16 SET PAT=$PIECE($GET(DTA),"^",1)
+17 if $$TESTPAT^VADPT(PAT)
QUIT
+18 SET DFN=PAT
+19 DO ADD^VADPT
DO DEM^VADPT
+20 SET LN=$EXTRACT(VADM(1),1)_$PIECE(VA("BID"),U)
+21 SET PAT1=$PIECE(VADM(1),U)
+22 SET (CDT,CDT1)=""
SET Y=$PIECE($GET(DTA),"^",10)
IF Y'=""
DO DD^%DT
SET CDT=Y
KILL Y
+23 SET Z=$PIECE($GET(DTA),"^",13)
IF Z'=""
SET CDT1="*"_CDT
KILL Z
Begin DoDot:3
+24 IF CDT1'=""
SET CDT=CDT1
End DoDot:3
+25 IF CDT=""
SET CDT="NotSent"
+26 SET PHONE=$PIECE(VAPA(8),U)
+27 ;phone
IF PHONE=""
SET PHONE="Unk. Phone"
+28 SET COMMENT=$PIECE($GET(DTA),"^",7)
+29 SET PRO=$PIECE($GET(DTA),"^",5)
IF PRO'=""
SET PRO1=$PIECE($GET(^SD(403.54,PRO,0)),"^",1)
SET PRO2=$$NAME^XUSER(PRO1,"F")
+30 IF PRO=""
SET PRO2="Unk. Provider"
+31 SET USER=$PIECE($GET(DTA),"^",11)
IF USER'=""
SET USER1=$$NAME^XUSER(USER)
+32 IF USER=""
SET USER1="Unk. User"
+33 SET ^TMP($JOB,"ONTEAM",DIV1,CLINIC,PRO2,MONTH,RDT,PAT1)=CLINIC_"^"_PRO2_"^"_DATE_"^"_CDT_"^"_PAT1_"^"_PHONE_"^"_COMMENT_"^"_USER1_"^"_LN
+34 KILL CLINIC,USER,PRO,PAT,RDT,CDT,CDT1
End DoDot:2
End DoDot:1
+35 DO PRT5^SDRRCRRP
+36 DO ^%ZISC
+37 GOTO QUIT
+38 ;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,COMMENT,D0,DATE,DIC,DIV,DIV1,DTA,I,J,LN,MONTH,PAT1,PHONE,POP,PRO1,PRO2,SSN,TEAM,TEST,TM,USER1,X,YR,ZPR
+1 KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE,%DT,%ZIS,%,VAUTC,VAUTD,VA,VAUTNI,VAUTT,DFN,VAX,VAERR,VADM,VAPA
+2 DO KVAR^VADPT
+3 QUIT
