source: FOIAVistA/trunk/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFRES.m@ 897

PRPFRES ;ALTOONA/CTB-POST RESTRICTION INFO TO PATIENT FILE ;4/20/02
V ;;3.0;PATIENT FUNDS;**6,13**;JUNE 1, 1989
 ;REQUIRES FOLLOWING VARIABLES
 ;  PRPFDATE=TRANSACTION DATE
 ;  DFN(0)=ZEROTH NODE OF PATIENT FUNDS PATIENT
 ;  DFN(1)="1" NODE OF PATIENT FUNDS PATIENT
 ;  AMT=AMOUNT TO BE POSTED TO RESTRICTIONS
 ;UPDATES ^PRPF(470) AND RESETS DFN(0) AND (1)
WK ;DETERMINE WEEK NUMBER SINCE 4 JAN 87
 D CURWK
 S X2=2870104,X1=PRPFDATE D ^%DTC S POSTWK=X\7+1
 I POSTWK<CURWK G MO
 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
 S $P(DFN(1),"^",12)=$P(DFN(1),"^",12)-AMT
MO ;POST TO CURRENT MONTH
 S POSTMO=$E(PRPFDATE,1,5)_"00" Q:POSTMO<CURMO
 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
 S $P(DFN(1),"^",11)=$P(DFN(1),"^",11)-AMT
 G OUT
CURWK ;GET CURRENT WEEK NUMBER  CLEAR FIELDS
 I '$D(DT) D NOW^PRPFQ S DT=X
 S X2=2870104,X1=DT D ^%DTC S CURWK=X\7+1
 I $P(DFN(1),"^",10)'=CURWK S $P(DFN(1),"^",10)=CURWK,$P(DFN(1),"^",12)=0
 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
 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
CURMO ;GET CURRENT MONTH  CLEAR FIELDS
 S CURMO=$E(DT,1,5)_"00" I $P(DFN(1),"^",9)'=CURMO S $P(DFN(1),"^",9)=CURMO,$P(DFN(1),"^",11)=0
 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
 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
 Q
EN ;ENTRY POINT TO UPDATE CURRENT WEEK AND MONTH
 D CURWK,OUT Q
 ;
OUT ;RESET PATIENT NODES
 F I=0,1 S ^PRPF(470,DFN,I)=DFN(I)
 K CURMO,CURWK,POSTMO,POSTWK,X1,X2,PRPFDATE Q
 QUIT
IG ;REPORT OF NEGATIVE BALANCE AND RESTRICTIONS FOR IG
 D SELRNG^PRPFQ
 I PRPFRNG="" K PRPFRNG QUIT
 I PRPFRNG="@" S PRPFRNG2=""
 E  S PRPFRNG2=PRPFRNG
 S ZTSAVE("PRPFRNG")=PRPFRNG,ZTSAVE("PRPFRNG2")=PRPFRNG2
 S ZTRTN="DQ^PRPFRES",ZTDESC=$P($T(DQ),";",3) D ^PRPFQ
 K %X,DFN,DG1,DGT,DGX,PRPFRNG,PRPFRNG2 Q
TM S PRPFRNG="@",PRPFRNG2=""
DQ ;MISC NEGATIVE BALANCES
 N PRIOP,DA
 S PRIOP=ION
 K ^TMP("PRPFRES",$J)
 S DA=0 S X="I'm now beginning to search the file." D MSG^PRPFQ
 F  D  Q:'DA  W:'$D(ZTQUEUED) "."
 . F XX=1:1:25 S DA=$O(^PRPF(470,DA)) Q:'DA  D CK(DA)
 . QUIT
 I '$D(^TMP("PRPFRES",$J)) K ^TMP("PRPFRES",$J) D NONE QUIT
 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_""
 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
 S:PRPFRNG="@" BY="@73,@73:99;S1,.01",FR="@,@",TO=","
 W !,"" D EN1^DIP I '$D(ZTQUEUED) D ENCON^PRPFQ
 QUIT
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
 Q
CK(DFN) ;
 S DFN(0)=$G(^PRPF(470,DFN,0))
 S DFN(1)=$G(^PRPF(470,DFN,1))
 D EN
 I $P(DFN(1),"^",4)<0 D ADD QUIT
 I $P(DFN(1),"^",11)<0 D ADD QUIT
 I $P(DFN(1),"^",12)<0 D ADD QUIT
 QUIT
ADD S ^TMP("PRPFRES",$J,DFN)="" QUIT