1 | PRPFRES ;ALTOONA/CTB-POST RESTRICTION INFO TO PATIENT FILE ;4/20/02
|
---|
2 | V ;;3.0;PATIENT FUNDS;**6,13**;JUNE 1, 1989
|
---|
3 | ;REQUIRES FOLLOWING VARIABLES
|
---|
4 | ; PRPFDATE=TRANSACTION DATE
|
---|
5 | ; DFN(0)=ZEROTH NODE OF PATIENT FUNDS PATIENT
|
---|
6 | ; DFN(1)="1" NODE OF PATIENT FUNDS PATIENT
|
---|
7 | ; AMT=AMOUNT TO BE POSTED TO RESTRICTIONS
|
---|
8 | ;UPDATES ^PRPF(470) AND RESETS DFN(0) AND (1)
|
---|
9 | WK ;DETERMINE WEEK NUMBER SINCE 4 JAN 87
|
---|
10 | D CURWK
|
---|
11 | S X2=2870104,X1=PRPFDATE D ^%DTC S POSTWK=X\7+1
|
---|
12 | I POSTWK<CURWK G MO
|
---|
13 | 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
|
---|
14 | S $P(DFN(1),"^",12)=$P(DFN(1),"^",12)-AMT
|
---|
15 | MO ;POST TO CURRENT MONTH
|
---|
16 | S POSTMO=$E(PRPFDATE,1,5)_"00" Q:POSTMO<CURMO
|
---|
17 | 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
|
---|
18 | S $P(DFN(1),"^",11)=$P(DFN(1),"^",11)-AMT
|
---|
19 | G OUT
|
---|
20 | CURWK ;GET CURRENT WEEK NUMBER CLEAR FIELDS
|
---|
21 | I '$D(DT) D NOW^PRPFQ S DT=X
|
---|
22 | S X2=2870104,X1=DT D ^%DTC S CURWK=X\7+1
|
---|
23 | I $P(DFN(1),"^",10)'=CURWK S $P(DFN(1),"^",10)=CURWK,$P(DFN(1),"^",12)=0
|
---|
24 | 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
|
---|
25 | 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
|
---|
26 | CURMO ;GET CURRENT MONTH CLEAR FIELDS
|
---|
27 | S CURMO=$E(DT,1,5)_"00" I $P(DFN(1),"^",9)'=CURMO S $P(DFN(1),"^",9)=CURMO,$P(DFN(1),"^",11)=0
|
---|
28 | 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
|
---|
29 | 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
|
---|
30 | Q
|
---|
31 | EN ;ENTRY POINT TO UPDATE CURRENT WEEK AND MONTH
|
---|
32 | D CURWK,OUT Q
|
---|
33 | ;
|
---|
34 | OUT ;RESET PATIENT NODES
|
---|
35 | F I=0,1 S ^PRPF(470,DFN,I)=DFN(I)
|
---|
36 | K CURMO,CURWK,POSTMO,POSTWK,X1,X2,PRPFDATE Q
|
---|
37 | QUIT
|
---|
38 | IG ;REPORT OF NEGATIVE BALANCE AND RESTRICTIONS FOR IG
|
---|
39 | D SELRNG^PRPFQ
|
---|
40 | I PRPFRNG="" K PRPFRNG QUIT
|
---|
41 | I PRPFRNG="@" S PRPFRNG2=""
|
---|
42 | E S PRPFRNG2=PRPFRNG
|
---|
43 | S ZTSAVE("PRPFRNG")=PRPFRNG,ZTSAVE("PRPFRNG2")=PRPFRNG2
|
---|
44 | S ZTRTN="DQ^PRPFRES",ZTDESC=$P($T(DQ),";",3) D ^PRPFQ
|
---|
45 | K %X,DFN,DG1,DGT,DGX,PRPFRNG,PRPFRNG2 Q
|
---|
46 | TM S PRPFRNG="@",PRPFRNG2=""
|
---|
47 | DQ ;MISC NEGATIVE BALANCES
|
---|
48 | N PRIOP,DA
|
---|
49 | S PRIOP=ION
|
---|
50 | K ^TMP("PRPFRES",$J)
|
---|
51 | S DA=0 S X="I'm now beginning to search the file." D MSG^PRPFQ
|
---|
52 | F D Q:'DA W:'$D(ZTQUEUED) "."
|
---|
53 | . F XX=1:1:25 S DA=$O(^PRPF(470,DA)) Q:'DA D CK(DA)
|
---|
54 | . QUIT
|
---|
55 | I '$D(^TMP("PRPFRES",$J)) K ^TMP("PRPFRES",$J) D NONE QUIT
|
---|
56 | 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_""
|
---|
57 | 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
|
---|
58 | S:PRPFRNG="@" BY="@73,@73:99;S1,.01",FR="@,@",TO=","
|
---|
59 | W !,"" D EN1^DIP I '$D(ZTQUEUED) D ENCON^PRPFQ
|
---|
60 | QUIT
|
---|
61 | 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
|
---|
62 | Q
|
---|
63 | CK(DFN) ;
|
---|
64 | S DFN(0)=$G(^PRPF(470,DFN,0))
|
---|
65 | S DFN(1)=$G(^PRPF(470,DFN,1))
|
---|
66 | D EN
|
---|
67 | I $P(DFN(1),"^",4)<0 D ADD QUIT
|
---|
68 | I $P(DFN(1),"^",11)<0 D ADD QUIT
|
---|
69 | I $P(DFN(1),"^",12)<0 D ADD QUIT
|
---|
70 | QUIT
|
---|
71 | ADD S ^TMP("PRPFRES",$J,DFN)="" QUIT
|
---|