Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRPFRES

PRPFRES.m

Go to the documentation of this file.
  1. PRPFRES ;ALTOONA/CTB-POST RESTRICTION INFO TO PATIENT FILE ;4/20/02
  1. V ;;3.0;PATIENT FUNDS;**6,13**;JUNE 1, 1989
  1. ;REQUIRES FOLLOWING VARIABLES
  1. ; PRPFDATE=TRANSACTION DATE
  1. ; DFN(0)=ZEROTH NODE OF PATIENT FUNDS PATIENT
  1. ; DFN(1)="1" NODE OF PATIENT FUNDS PATIENT
  1. ; AMT=AMOUNT TO BE POSTED TO RESTRICTIONS
  1. ;UPDATES ^PRPF(470) AND RESETS DFN(0) AND (1)
  1. WK ;DETERMINE WEEK NUMBER SINCE 4 JAN 87
  1. D CURWK
  1. S X2=2870104,X1=PRPFDATE D ^%DTC S POSTWK=X\7+1
  1. I POSTWK<CURWK G MO
  1. I POSTWK>CURWK S:'$D(^PRPF(470,DFN,11,0)) ^(0)="^470.072A^^" S X=^(0),$P(X,"^",3)=POSTWK,$P(X,"^",4)=$P(X,"^",4)+1,^(0)=X S:'$D(^(POSTWK,0)) ^(0)=POSTWK_"^0" S $P(^(0),"^",2)=$P(^(0),"^",2)-AMT G MO
  1. S $P(DFN(1),"^",12)=$P(DFN(1),"^",12)-AMT
  1. MO ;POST TO CURRENT MONTH
  1. S POSTMO=$E(PRPFDATE,1,5)_"00" Q:POSTMO<CURMO
  1. I POSTMO>CURMO S:'$D(^PRPF(470,DFN,10,0)) ^(0)="^470.071DA^^" S X=^(0),$P(X,"^",3)=POSTMO,$P(X,"^",4)=$P(X,"^",4)+1,^(0)=X S:'$D(^(POSTMO,0)) ^(0)=POSTMO_"^0" S $P(^(0),"^",2)=$P(^(0),"^",2)-AMT Q
  1. S $P(DFN(1),"^",11)=$P(DFN(1),"^",11)-AMT
  1. G OUT
  1. CURWK ;GET CURRENT WEEK NUMBER CLEAR FIELDS
  1. I '$D(DT) D NOW^PRPFQ S DT=X
  1. S X2=2870104,X1=DT D ^%DTC S CURWK=X\7+1
  1. I $P(DFN(1),"^",10)'=CURWK S $P(DFN(1),"^",10)=CURWK,$P(DFN(1),"^",12)=0
  1. F I=0:0 S I=$O(^PRPF(470,DFN,11,I)) Q:I="" Q:I>CURWK I I<CURWK K ^PRPF(470,DFN,11,I) S X=^PRPF(470,DFN,11,0),$P(X,"^",3)=$O(^(0)),$P(X,"^",4)=$P(X,"^",4)-1,^(0)=X
  1. I $D(^PRPF(470,DFN,11,CURWK,0)) S $P(DFN(1),"^",12)=$P(^(0),"^",2) K ^PRPF(470,DFN,11,CURWK) S X=^PRPF(470,DFN,11,0),$P(X,"^",3)=$O(^(0)),$P(X,"^",4)=$P(X,"^",4)-1,^(0)=X
  1. CURMO ;GET CURRENT MONTH CLEAR FIELDS
  1. S CURMO=$E(DT,1,5)_"00" I $P(DFN(1),"^",9)'=CURMO S $P(DFN(1),"^",9)=CURMO,$P(DFN(1),"^",11)=0
  1. F I=0:0 S I=$O(^PRPF(470,DFN,10,I)) Q:I="" Q:I>CURWK I I<CURWK K ^PRPF(470,DFN,10,I) S X=^PRPF(470,DFN,10,0),$P(X,"^",3)=$O(^(0)),$P(X,"^",4)=$P(X,"^",4)-1,^(0)=X
  1. I $D(^PRPF(470,DFN,10,CURMO,0)) S $P(DFN(1),"^",11)=$P(^(0),"^",2) K ^PRPF(470,DFN,10,CURMO) S X=^PRPF(470,DFN,10,0),$P(X,"^",3)=$O(^(0)),$P(X,"^",4)=$P(X,"^",4)-1,^(0)=X
  1. Q
  1. EN ;ENTRY POINT TO UPDATE CURRENT WEEK AND MONTH
  1. D CURWK,OUT Q
  1. ;
  1. OUT ;RESET PATIENT NODES
  1. F I=0,1 S ^PRPF(470,DFN,I)=DFN(I)
  1. K CURMO,CURWK,POSTMO,POSTWK,X1,X2,PRPFDATE Q
  1. QUIT
  1. IG ;REPORT OF NEGATIVE BALANCE AND RESTRICTIONS FOR IG
  1. D SELRNG^PRPFQ
  1. I PRPFRNG="" K PRPFRNG QUIT
  1. I PRPFRNG="@" S PRPFRNG2=""
  1. E S PRPFRNG2=PRPFRNG
  1. S ZTSAVE("PRPFRNG")=PRPFRNG,ZTSAVE("PRPFRNG2")=PRPFRNG2
  1. S ZTRTN="DQ^PRPFRES",ZTDESC=$P($T(DQ),";",3) D ^PRPFQ
  1. K %X,DFN,DG1,DGT,DGX,PRPFRNG,PRPFRNG2 Q
  1. TM S PRPFRNG="@",PRPFRNG2=""
  1. DQ ;MISC NEGATIVE BALANCES
  1. N PRIOP,DA
  1. S PRIOP=ION
  1. K ^TMP("PRPFRES",$J)
  1. S DA=0 S X="I'm now beginning to search the file." D MSG^PRPFQ
  1. F D Q:'DA W:'$D(ZTQUEUED) "."
  1. . F XX=1:1:25 S DA=$O(^PRPF(470,DA)) Q:'DA D CK(DA)
  1. . QUIT
  1. I '$D(^TMP("PRPFRES",$J)) K ^TMP("PRPFRES",$J) D NONE QUIT
  1. S IOP=PRIOP,DIC="^PRPF(470,",L=0,L(0)=1,BY="@73:99;S1,.01",BY(0)="^TMP(""PRPFRES"",$J,",FLDS="[PRPF NEGATIVE BALANCES]",FR=""_PRPFRNG_"",TO=""_PRPFRNG2_""
  1. S DIOEND="K ^TMP(""PRPFRES"") W !,""The information contained in this report is protected by the Privacy Act of 1974""" D:'$D(ZTQUEUED) WAIT^PRPFYN
  1. S:PRPFRNG="@" BY="@73,@73:99;S1,.01",FR="@,@",TO=","
  1. W !,"" D EN1^DIP I '$D(ZTQUEUED) D ENCON^PRPFQ
  1. QUIT
  1. NONE S IOP=ION W @IOF D NOW^PRPFQ W "PATIENT FUNDS NEGATIVE BALANCE REPORT",?50,%X,!!,"No accounts with negative balances were found while running this report." W:$E($G(IOST))="P" @IOF
  1. Q
  1. CK(DFN) ;
  1. S DFN(0)=$G(^PRPF(470,DFN,0))
  1. S DFN(1)=$G(^PRPF(470,DFN,1))
  1. D EN
  1. I $P(DFN(1),"^",4)<0 D ADD QUIT
  1. I $P(DFN(1),"^",11)<0 D ADD QUIT
  1. I $P(DFN(1),"^",12)<0 D ADD QUIT
  1. QUIT
  1. ADD S ^TMP("PRPFRES",$J,DFN)="" QUIT