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 Dec 13, 2024@02:01:57 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
