PRPFMIN ;ALTOONA/CTB-CREATE MIN/MAS SEARCH LISTS ;4/15/02
V ;;3.0;PATIENT FUNDS;**6,8,13**;JUNE 1, 1989
D SELRNG^PRPFQ
I PRPFRNG="" D OUT QUIT
I PRPFRNG="@" S PRPFRNG2=""
E S PRPFRNG2=PRPFRNG
S ZTSAVE("PRPFRNG")=PRPFRNG,ZTSAVE("PRPFRNG2")=PRPFRNG2
S ZTRTN="DQ^PRPFMIN",ZTDESC=$P($T(DQ),";",3) D ^PRPFQ
K %X,DFN,DG1,DGT,DGX Q
DQ ;MIN/MAX PATIENT FUNDS REPORT
S PRIOP=ION
K ^TMP("PRPFAF",$J)
K ^TMP("PRPFAG",$J)
S DA=0 S X="I'm now beginning to search the file." D MSG^PRPFQ
F I=1:1 S DA=$O(^PRPF(470,DA)) Q:'DA D CK I I#25=0,'$D(ZTQUEUED) W "."
I '$D(^TMP("PRPFAF",$J)),'$D(^TMP("PRPFAG",$J)) D NONE QUIT
S IOP=PRIOP,DIC="^PRPF(470,",L=0,L(0)=1,BY="@73:99;S1,.01",BY(0)="^TMP(""PRPFAF"",$J,",FLDS="[PRPF MIN/MAX1]",FR=""_PRPFRNG_"",TO=""_PRPFRNG2_""
S DIOEND="K ^TMP(""PRPFAF"") W !,""The information contained in this report is protected by the Privacy Act of 1974""" D:'$D(ZTQUEUED) WAIT^PRPFYN
S:PRPFRNG="@" BY="@73,@73:99;S1,.01",FR="@,@",TO=","
W !,"" D EN1^DIP I '$D(ZTQUEUED) D ENCON^PRPFQ
S IOP=PRIOP,DIC="^PRPF(470,",L=0,L(0)=1,BY="@73:99;S1,.01",BY(0)="^TMP(""PRPFAG"",$J,",FLDS="[PRPF MIN/MAX2]",FR=""_PRPFRNG_"",TO=""_PRPFRNG2_""
S DIOEND="K ^TMP(""PRPFAG"") W !,""The information contained in this report is protected by the Privacy Act of 1974""" D:'$D(ZTQUEUED) WAIT^PRPFYN
S:PRPFRNG="@" BY="@73,@73:99;S1,.01",FR="@,@",TO=","
W !,"" D EN1^DIP I '$D(ZTQUEUED) D ENCON^PRPFQ
OUT K DIJ,DP,DQTIME,IOX,IOY,MAX1,MAX2,MIN1,MIN2,PRPFQ,PRPFRNG,PRPFRNG2,PRIOP,SBAL,PRIOP,DIOEND
S ZTREQ="@"
QUIT
NONE S IOP=ION W @IOF D NOW^PRPFQ W "PATIENT FUNDS MIN/MAX REPORT",?50,%X,!!,"No matches were found while running this report." W:$E($G(IOST))="P" @IOF
Q
CK ;CHECKS BALANCES
Q:'+$D(^PRPF(470,DA,2)) S A=^(2),MIN1=+$P(A,U),MAX1=+$P(A,U,2),MIN2=+$P(A,U,3),MAX2=+$P(A,U,4),SBAL=$S($D(^(1)):$P(^(1),U,4),1:0)
Q:$P(^PRPF(470,DA,0),U,2)="I" ; <<<< by REW in patch 8 to suppress inactives
I MIN1=0!(MAX1=0) G CK1
I MIN1<MAX1 I SBAL>MAX1!(SBAL<MIN1) S ^TMP("PRPFAF",$J,DA)=""
CK1 I MIN2=0!(MAX2=0) Q
I MIN2<MAX2,SBAL>MAX2!(SBAL<MIN2) S ^TMP("PRPFAG",$J,DA)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFMIN 2124 printed Nov 22, 2024@17:11:52 Page 2
PRPFMIN ;ALTOONA/CTB-CREATE MIN/MAS SEARCH LISTS ;4/15/02
V ;;3.0;PATIENT FUNDS;**6,8,13**;JUNE 1, 1989
+1 DO SELRNG^PRPFQ
+2 IF PRPFRNG=""
DO OUT
QUIT
+3 IF PRPFRNG="@"
SET PRPFRNG2=""
+4 IF '$TEST
SET PRPFRNG2=PRPFRNG
+5 SET ZTSAVE("PRPFRNG")=PRPFRNG
SET ZTSAVE("PRPFRNG2")=PRPFRNG2
+6 SET ZTRTN="DQ^PRPFMIN"
SET ZTDESC=$PIECE($TEXT(DQ),";",3)
DO ^PRPFQ
+7 KILL %X,DFN,DG1,DGT,DGX
QUIT
DQ ;MIN/MAX PATIENT FUNDS REPORT
+1 SET PRIOP=ION
+2 KILL ^TMP("PRPFAF",$JOB)
+3 KILL ^TMP("PRPFAG",$JOB)
+4 SET DA=0
SET X="I'm now beginning to search the file."
DO MSG^PRPFQ
+5 FOR I=1:1
SET DA=$ORDER(^PRPF(470,DA))
if 'DA
QUIT
DO CK
IF I#25=0
IF '$DATA(ZTQUEUED)
WRITE "."
+6 IF '$DATA(^TMP("PRPFAF",$JOB))
IF '$DATA(^TMP("PRPFAG",$JOB))
DO NONE
QUIT
+7 SET IOP=PRIOP
SET DIC="^PRPF(470,"
SET L=0
SET L(0)=1
SET BY="@73:99;S1,.01"
SET BY(0)="^TMP(""PRPFAF"",$J,"
SET FLDS="[PRPF MIN/MAX1]"
SET FR=""_PRPFRNG_""
SET TO=""_PRPFRNG2_""
+8 SET DIOEND="K ^TMP(""PRPFAF"") W !,""The information contained in this report is protected by the Privacy Act of 1974"""
if '$DATA(ZTQUEUED)
DO WAIT^PRPFYN
+9 if PRPFRNG="@"
SET BY="@73,@73:99;S1,.01"
SET FR="@,@"
SET TO=","
+10 WRITE !,""
DO EN1^DIP
IF '$DATA(ZTQUEUED)
DO ENCON^PRPFQ
+11 SET IOP=PRIOP
SET DIC="^PRPF(470,"
SET L=0
SET L(0)=1
SET BY="@73:99;S1,.01"
SET BY(0)="^TMP(""PRPFAG"",$J,"
SET FLDS="[PRPF MIN/MAX2]"
SET FR=""_PRPFRNG_""
SET TO=""_PRPFRNG2_""
+12 SET DIOEND="K ^TMP(""PRPFAG"") W !,""The information contained in this report is protected by the Privacy Act of 1974"""
if '$DATA(ZTQUEUED)
DO WAIT^PRPFYN
+13 if PRPFRNG="@"
SET BY="@73,@73:99;S1,.01"
SET FR="@,@"
SET TO=","
+14 WRITE !,""
DO EN1^DIP
IF '$DATA(ZTQUEUED)
DO ENCON^PRPFQ
OUT KILL DIJ,DP,DQTIME,IOX,IOY,MAX1,MAX2,MIN1,MIN2,PRPFQ,PRPFRNG,PRPFRNG2,PRIOP,SBAL,PRIOP,DIOEND
+1 SET ZTREQ="@"
+2 QUIT
NONE SET IOP=ION
WRITE @IOF
DO NOW^PRPFQ
WRITE "PATIENT FUNDS MIN/MAX REPORT",?50,%X,!!,"No matches were found while running this report."
if $EXTRACT($GET(IOST))="P"
WRITE @IOF
+1 QUIT
CK ;CHECKS BALANCES
+1 if '+$DATA(^PRPF(470,DA,2))
QUIT
SET A=^(2)
SET MIN1=+$PIECE(A,U)
SET MAX1=+$PIECE(A,U,2)
SET MIN2=+$PIECE(A,U,3)
SET MAX2=+$PIECE(A,U,4)
SET SBAL=$SELECT($DATA(^(1)):$PIECE(^(1),U,4),1:0)
+2 ; <<<< by REW in patch 8 to suppress inactives
if $PIECE(^PRPF(470,DA,0),U,2)="I"
QUIT
+3 IF MIN1=0!(MAX1=0)
GOTO CK1
+4 IF MIN1<MAX1
IF SBAL>MAX1!(SBAL<MIN1)
SET ^TMP("PRPFAF",$JOB,DA)=""
CK1 IF MIN2=0!(MAX2=0)
QUIT
+1 IF MIN2<MAX2
IF SBAL>MAX2!(SBAL<MIN2)
SET ^TMP("PRPFAG",$JOB,DA)=""
+2 QUIT
