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

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1PRPFRES ;ALTOONA/CTB-POST RESTRICTION INFO TO PATIENT FILE ;4/20/02
2V ;;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)
9WK ;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
15MO ;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
20CURWK ;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
26CURMO ;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
31EN ;ENTRY POINT TO UPDATE CURRENT WEEK AND MONTH
32 D CURWK,OUT Q
33 ;
34OUT ;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
38IG ;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
46TM S PRPFRNG="@",PRPFRNG2=""
47DQ ;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
61NONE 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
63CK(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
71ADD S ^TMP("PRPFRES",$J,DFN)="" QUIT
Note: See TracBrowser for help on using the repository browser.