- 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 Mar 13, 2025@21:06:33 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
