- PRPFOBR ;ALTOONA/CTB-OPTION TO RECALCULATE PATIENT BALANCES ;04/15/02
- V ;;3.0;PATIENT FUNDS;**6,13**;JUNE 1, 1989
- SE S %A="This option will recalculate the balances of a patient account",%A(1)="It should only be used after the account has be audited and it",%A(2)="has been determined that all transactions are valid."
- S %=2,U="^" W !,*7 S %A(3)="Do you really want to run this option",%B="" D ^PRPFYN G:%'=1 NA
- SE1 W !! S DIC="^PRPF(470,",DIC(0)="AEQMNZ" D ^DIC G:Y<0 OUT S (PF("PBAL"),PF("GBAL"),PF("BAL"))=0,DFN=+Y D CALC
- W !,?10,"BALANCE IN ACCOUNT",?50,"CORRECTED BALANCE" S X=$S($D(^PRPF(470,DFN,1)):^(1),1:"")
- W !,"TOTAL",?15,$J($P(X,U,4),8,2),?55,$J(PF("BAL"),8,2),!,"P/S",?15,$J($P(X,U,5),8,2),?55,$J(PF("PBAL"),8,2),!,"GRAT",?15,$J($P(X,U,6),8,2),?55,$J(PF("GBAL"),8,2)
- S %=2 W ! S %A="Are you ready to Post the corrected balances to the account",%B="" D ^PRPFYN G:%<0 NA I %'=1 D NA S DIC("A")="Select Next Patient: " G SE1
- S %A="ARE YOU SURE",%B="",%=2 D ^PRPFYN G:%<0 NA I %'=1 D NA S DIC("A")="Select Next Patient: " G SE1
- S $P(^PRPF(470,DFN,1),U,4,6)=PF("BAL")_U_PF("PBAL")_U_PF("GBAL") W " ---Done---" R X:2 D OUT
- W !! S DIC("A")="Select Next Patient: " G SE1
- CALC S (DA,PF("BAL"),PF("PBAL"),PF("GBAL"))=0 F N=0:0 S DA=$O(^PRPF(470,DFN,3,DA)) Q:'DA D CALC1
- Q
- CALC1 S X=^PRPF(470,DFN,3,DA,0) S PF("PBAL")=PF("PBAL")+$P(X,U,4),PF("GBAL")=PF("GBAL")+$P(X,U,5),PF("BAL")=PF("BAL")+$P(X,U,3),$P(^(0),U,6)=PF("BAL") Q
- TM S PRPFRNG="@",PRPFRNG2=""
- ALL ;;SCREEN ALL PATIENT FUND ACCOUNTS AND PRINT LIST OF OUT OF BALANCES
- K ^TMP("PRPFAH",$J)
- S X=" Hold on while I search the file . . .*" D MSG^PRPFQ
- S DFN=0,U="^" F I=1:1 S DFN=$O(^PRPF(470,DFN)) Q:DFN'=+DFN D CHECK
- I '$D(^TMP("PRPFAH",$J)) D NONE G OUT
- S DIC="^PRPF(470,",L=0,L(0)=1,BY="@73:99;S1,.01",BY(0)="^TMP(""PRPFAH"",$J,",FLDS="[PRPF OUT OF BALANCE]",FR=""_PRPFRNG_"",TO=""_PRPFRNG2_"" S IOP=$S($D(PRIOP):PRIOP,1:ION)
- S DIOEND="K ^TMP(""PRPFAH"") W !,""The information contained in this report is protected by the Privacy Act of 1974"""
- S:PRPFRNG="@" BY="@73,@73:99;S1,.01",FR="@,@",TO=","
- D EN1^DIP
- S ZTREQ="@"
- OUT K %,%W,C,DA,DFN,DIC,DIYS,K,N,PF,POP,PRPFRNG,PRPFRNG2,S,X,XBAL,XPBAL,XGBAL,X1,Y D DIKILL^PRPFQ,ZTKILL^PRPFQ
- Q
- NONE S IOP=ION W @IOF D NOW^PRPFQ W "PATIENT FUNDS OUT OF BALANCE REPORT",?50,%X,!!,"No Out of Balance Accounts Were Found While Running This Report" W:$E($G(IOST))="P" @IOF
- Q
- CHECK D CALC S X=PF("BAL")+PF("PBAL")+PF("GBAL"),X2=$S($D(^PRPF(470,DFN,1)):^(1),1:""),XBAL=$P(X2,U,4),XPBAL=$P(X2,U,5),XGBAL=$P(X2,U,6)
- S X1=XBAL+XPBAL+XGBAL
- I +X'=+X1 G SET
- I +PF("BAL")'=+XBAL G SET
- I +PF("PBAL")'=+XPBAL G SET
- I +PF("GBAL")'=+XGBAL G SET
- Q
- SET S ^TMP("PRPFAH",$J,DFN)=""
- Q
- NA W:(IOM-$X)<25 ! W " <No action taken>",*7 R X:3 W !! G OUT
- QUE ;QUEUE ALL^PRPFOBR TO RUN AS TASKMAN JOB
- W !,"This program will review all Patient Funds Accounts and print a",!,"report of all accounts which are out of balance in any way. ",!!
- W "Due to the length of time that this report may take, it is suggested that it,",!," be queued.",!!
- D SELRNG^PRPFQ
- I PRPFRNG="" D OUT QUIT
- I PRPFRNG="@" S PRPFRNG2=""
- E S PRPFRNG2=PRPFRNG
- S ZTSAVE("PRPFRNG")=PRPFRNG,ZTSAVE("PRPFRNG2")=PRPFRNG2
- S ZTRTN="ALL^PRPFOBR",ZTDESC=$P($T(ALL),";",3) D ^PRPFQ G OUT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFOBR 3301 printed Mar 13, 2025@21:06:39 Page 2
- PRPFOBR ;ALTOONA/CTB-OPTION TO RECALCULATE PATIENT BALANCES ;04/15/02
- V ;;3.0;PATIENT FUNDS;**6,13**;JUNE 1, 1989
- SE SET %A="This option will recalculate the balances of a patient account"
- SET %A(1)="It should only be used after the account has be audited and it"
- SET %A(2)="has been determined that all transactions are valid."
- +1 SET %=2
- SET U="^"
- WRITE !,*7
- SET %A(3)="Do you really want to run this option"
- SET %B=""
- DO ^PRPFYN
- if %'=1
- GOTO NA
- SE1 WRITE !!
- SET DIC="^PRPF(470,"
- SET DIC(0)="AEQMNZ"
- DO ^DIC
- if Y<0
- GOTO OUT
- SET (PF("PBAL"),PF("GBAL"),PF("BAL"))=0
- SET DFN=+Y
- DO CALC
- +1 WRITE !,?10,"BALANCE IN ACCOUNT",?50,"CORRECTED BALANCE"
- SET X=$SELECT($DATA(^PRPF(470,DFN,1)):^(1),1:"")
- +2 WRITE !,"TOTAL",?15,$JUSTIFY($PIECE(X,U,4),8,2),?55,$JUSTIFY(PF("BAL"),8,2),!,"P/S",?15,$JUSTIFY($PIECE(X,U,5),8,2),?55,$JUSTIFY(PF("PBAL"),8,2),!,"GRAT",?15,$JUSTIFY($PIECE(X,U,6),8,2),?55,$JUSTIFY(PF("GBAL"),8,2)
- +3 SET %=2
- WRITE !
- SET %A="Are you ready to Post the corrected balances to the account"
- SET %B=""
- DO ^PRPFYN
- if %<0
- GOTO NA
- IF %'=1
- DO NA
- SET DIC("A")="Select Next Patient: "
- GOTO SE1
- +4 SET %A="ARE YOU SURE"
- SET %B=""
- SET %=2
- DO ^PRPFYN
- if %<0
- GOTO NA
- IF %'=1
- DO NA
- SET DIC("A")="Select Next Patient: "
- GOTO SE1
- +5 SET $PIECE(^PRPF(470,DFN,1),U,4,6)=PF("BAL")_U_PF("PBAL")_U_PF("GBAL")
- WRITE " ---Done---"
- READ X:2
- DO OUT
- +6 WRITE !!
- SET DIC("A")="Select Next Patient: "
- GOTO SE1
- CALC SET (DA,PF("BAL"),PF("PBAL"),PF("GBAL"))=0
- FOR N=0:0
- SET DA=$ORDER(^PRPF(470,DFN,3,DA))
- if 'DA
- QUIT
- DO CALC1
- +1 QUIT
- CALC1 SET X=^PRPF(470,DFN,3,DA,0)
- SET PF("PBAL")=PF("PBAL")+$PIECE(X,U,4)
- SET PF("GBAL")=PF("GBAL")+$PIECE(X,U,5)
- SET PF("BAL")=PF("BAL")+$PIECE(X,U,3)
- SET $PIECE(^(0),U,6)=PF("BAL")
- QUIT
- TM SET PRPFRNG="@"
- SET PRPFRNG2=""
- ALL ;;SCREEN ALL PATIENT FUND ACCOUNTS AND PRINT LIST OF OUT OF BALANCES
- +1 KILL ^TMP("PRPFAH",$JOB)
- +2 SET X=" Hold on while I search the file . . .*"
- DO MSG^PRPFQ
- +3 SET DFN=0
- SET U="^"
- FOR I=1:1
- SET DFN=$ORDER(^PRPF(470,DFN))
- if DFN'=+DFN
- QUIT
- DO CHECK
- +4 IF '$DATA(^TMP("PRPFAH",$JOB))
- DO NONE
- GOTO OUT
- +5 SET DIC="^PRPF(470,"
- SET L=0
- SET L(0)=1
- SET BY="@73:99;S1,.01"
- SET BY(0)="^TMP(""PRPFAH"",$J,"
- SET FLDS="[PRPF OUT OF BALANCE]"
- SET FR=""_PRPFRNG_""
- SET TO=""_PRPFRNG2_""
- SET IOP=$SELECT($DATA(PRIOP):PRIOP,1:ION)
- +6 SET DIOEND="K ^TMP(""PRPFAH"") W !,""The information contained in this report is protected by the Privacy Act of 1974"""
- +7 if PRPFRNG="@"
- SET BY="@73,@73:99;S1,.01"
- SET FR="@,@"
- SET TO=","
- +8 DO EN1^DIP
- +9 SET ZTREQ="@"
- OUT KILL %,%W,C,DA,DFN,DIC,DIYS,K,N,PF,POP,PRPFRNG,PRPFRNG2,S,X,XBAL,XPBAL,XGBAL,X1,Y
- DO DIKILL^PRPFQ
- DO ZTKILL^PRPFQ
- +1 QUIT
- NONE SET IOP=ION
- WRITE @IOF
- DO NOW^PRPFQ
- WRITE "PATIENT FUNDS OUT OF BALANCE REPORT",?50,%X,!!,"No Out of Balance Accounts Were Found While Running This Report"
- if $EXTRACT($GET(IOST))="P"
- WRITE @IOF
- +1 QUIT
- CHECK DO CALC
- SET X=PF("BAL")+PF("PBAL")+PF("GBAL")
- SET X2=$SELECT($DATA(^PRPF(470,DFN,1)):^(1),1:"")
- SET XBAL=$PIECE(X2,U,4)
- SET XPBAL=$PIECE(X2,U,5)
- SET XGBAL=$PIECE(X2,U,6)
- +1 SET X1=XBAL+XPBAL+XGBAL
- +2 IF +X'=+X1
- GOTO SET
- +3 IF +PF("BAL")'=+XBAL
- GOTO SET
- +4 IF +PF("PBAL")'=+XPBAL
- GOTO SET
- +5 IF +PF("GBAL")'=+XGBAL
- GOTO SET
- +6 QUIT
- SET SET ^TMP("PRPFAH",$JOB,DFN)=""
- +1 QUIT
- NA if (IOM-$X)<25
- WRITE !
- WRITE " <No action taken>",*7
- READ X:3
- WRITE !!
- GOTO OUT
- QUE ;QUEUE ALL^PRPFOBR TO RUN AS TASKMAN JOB
- +1 WRITE !,"This program will review all Patient Funds Accounts and print a",!,"report of all accounts which are out of balance in any way. ",!!
- +2 WRITE "Due to the length of time that this report may take, it is suggested that it,",!," be queued.",!!
- +3 DO SELRNG^PRPFQ
- +4 IF PRPFRNG=""
- DO OUT
- QUIT
- +5 IF PRPFRNG="@"
- SET PRPFRNG2=""
- +6 IF '$TEST
- SET PRPFRNG2=PRPFRNG
- +7 SET ZTSAVE("PRPFRNG")=PRPFRNG
- SET ZTSAVE("PRPFRNG2")=PRPFRNG2
- +8 SET ZTRTN="ALL^PRPFOBR"
- SET ZTDESC=$PIECE($TEXT(ALL),";",3)
- DO ^PRPFQ
- GOTO OUT
