- SDRRCRR1 ;10N20/MAH;Recall Reminder list report; 11/8/2006
- ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- 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
- SDRRCRR1 ;10N20/MAH;Recall Reminder list report; 11/8/2006
- +1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
- 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
