PRPFTAT ;ALTOONA/CTB REVIEW STATUS ON ALL PATIENT FUNDS ACCOUNTS ;4/25/97 8:29 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
UPDAT W !,"This routine will insert the Active/Inactive indicator into the file for",!,"each patient based upon the following:",!!?5,"Balance not zero - ACTIVE"
W !?5,"Zero Balance - Last Transaction less than 30 days - ACTIVE"
W !?5,"Zero Balance - Last Transaction more than 30 days - INACTIVE"
W !?5,"Zero Balance - No Transactions - INACTIVE"
W !!,"The system will automatically convert the status to ACTIVE when any transaction",!,"is entered into the account."
W " Finally, this program will print a report showing all accounts on which the STATUS was changed.",! S %A="ARE YOU READY TO CONTINUE",%B="",%=1 D ^PRPFYN
I %=1 S ZTRTN="ALL^PRPFTAT",ZTDESC=$P($T(ALL),";",3) D ^PRPFQ
OUT K %,%X,BAL,DA,DATE,DFN,DG1,DGT,DGX,DIJ,DP,IOY,NEW,OLD,TDATE,X,Y,ZTQUEUED Q
ALL ;;UPDATE THE 'ACTIVE'/'INACTIVE' STATUS OF ALL ACCOUNTS
I $D(ZTQUEUED) S ZTREQ="@"
E D WAIT^PRPFYN
S %DT="",X="T-30" D ^%DT S TDATE=Y K %DT,%H,%I,^PRPF(470,"AJ","Y") F DA=0:0 S DA=$O(^PRPF(470,DA)) Q:'DA S OLD="" S:$D(^(DA,0)) OLD=$P(^(0),"^",2) D CHECK
I '$D(^TMP("PRPFAJ",$J)) W @IOF,!,"PATIENT FUNDS CHANGE IN ACCOUNT STATUS LISTING" S Y=DT D D^PRPFU1 W ?$X+10,Y,!!,"No change required in any account." W:$D(ZTSK) @IOF Q
S IOP=$S($D(PRIOP):PRIOP,1:ION),DIC="^PRPF(470,",L=0,L(0)=1,BY=".01",(FR,TO)="",BY(0)="^TMP(""PRPFAJ"",$J,",FLDS="[PRPF NEW ACCOUNT STATUS]",DIOEND="K ^TMP(""PRPFAJ"",$J)"
D EN1^DIP
D DIKILL^PRPFQ Q
CHECK ;THIS LINE CHECKS THE CURRENT STATUS OF THE ACCOUNT AND UPDATES THE
;STATUS WHEN NECESSARY
Q:'$D(^PRPF(470,DA,0)) S DATE=$P(^PRPF(470,DA,0),"^",11),BAL=0 S:$D(^(1)) BAL=$P(^(1),"^",4)
I +BAL'=0 Q:OLD="A" S NEW="A" G CR
I DATE<TDATE Q:OLD="I" S NEW="I" G CR
Q:OLD="A" S NEW="A" G CR
Q
CR S ^TMP("PRPFAJ",$J,DA)="",$P(^PRPF(470,DA,0),"^",2)=NEW,^PRPF(470,"AC",NEW,DA)="" K:OLD'="" ^PRPF(470,"AC",OLD,DA) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFTAT 1986 printed Oct 16, 2024@18:02:49 Page 2
PRPFTAT ;ALTOONA/CTB REVIEW STATUS ON ALL PATIENT FUNDS ACCOUNTS ;4/25/97 8:29 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
UPDAT WRITE !,"This routine will insert the Active/Inactive indicator into the file for",!,"each patient based upon the following:",!!?5,"Balance not zero - ACTIVE"
+1 WRITE !?5,"Zero Balance - Last Transaction less than 30 days - ACTIVE"
+2 WRITE !?5,"Zero Balance - Last Transaction more than 30 days - INACTIVE"
+3 WRITE !?5,"Zero Balance - No Transactions - INACTIVE"
+4 WRITE !!,"The system will automatically convert the status to ACTIVE when any transaction",!,"is entered into the account."
+5 WRITE " Finally, this program will print a report showing all accounts on which the STATUS was changed.",!
SET %A="ARE YOU READY TO CONTINUE"
SET %B=""
SET %=1
DO ^PRPFYN
+6 IF %=1
SET ZTRTN="ALL^PRPFTAT"
SET ZTDESC=$PIECE($TEXT(ALL),";",3)
DO ^PRPFQ
OUT KILL %,%X,BAL,DA,DATE,DFN,DG1,DGT,DGX,DIJ,DP,IOY,NEW,OLD,TDATE,X,Y,ZTQUEUED
QUIT
ALL ;;UPDATE THE 'ACTIVE'/'INACTIVE' STATUS OF ALL ACCOUNTS
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
DO WAIT^PRPFYN
+3 SET %DT=""
SET X="T-30"
DO ^%DT
SET TDATE=Y
KILL %DT,%H,%I,^PRPF(470,"AJ","Y")
FOR DA=0:0
SET DA=$ORDER(^PRPF(470,DA))
if 'DA
QUIT
SET OLD=""
if $DATA(^(DA,0))
SET OLD=$PIECE(^(0),"^",2)
DO CHECK
+4 IF '$DATA(^TMP("PRPFAJ",$JOB))
WRITE @IOF,!,"PATIENT FUNDS CHANGE IN ACCOUNT STATUS LISTING"
SET Y=DT
DO D^PRPFU1
WRITE ?$X+10,Y,!!,"No change required in any account."
if $DATA(ZTSK)
WRITE @IOF
QUIT
+5 SET IOP=$SELECT($DATA(PRIOP):PRIOP,1:ION)
SET DIC="^PRPF(470,"
SET L=0
SET L(0)=1
SET BY=".01"
SET (FR,TO)=""
SET BY(0)="^TMP(""PRPFAJ"",$J,"
SET FLDS="[PRPF NEW ACCOUNT STATUS]"
SET DIOEND="K ^TMP(""PRPFAJ"",$J)"
+6 DO EN1^DIP
+7 DO DIKILL^PRPFQ
QUIT
CHECK ;THIS LINE CHECKS THE CURRENT STATUS OF THE ACCOUNT AND UPDATES THE
+1 ;STATUS WHEN NECESSARY
+2 if '$DATA(^PRPF(470,DA,0))
QUIT
SET DATE=$PIECE(^PRPF(470,DA,0),"^",11)
SET BAL=0
if $DATA(^(1))
SET BAL=$PIECE(^(1),"^",4)
+3 IF +BAL'=0
if OLD="A"
QUIT
SET NEW="A"
GOTO CR
+4 IF DATE<TDATE
if OLD="I"
QUIT
SET NEW="I"
GOTO CR
+5 if OLD="A"
QUIT
SET NEW="A"
GOTO CR
+6 QUIT
CR SET ^TMP("PRPFAJ",$JOB,DA)=""
SET $PIECE(^PRPF(470,DA,0),"^",2)=NEW
SET ^PRPF(470,"AC",NEW,DA)=""
if OLD'=""
KILL ^PRPF(470,"AC",OLD,DA)
QUIT
