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