72 lines
3.6 KiB
Mathematica
72 lines
3.6 KiB
Mathematica
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
|