PRPFDAY ;ALTOONA/CTB BALANCE ON SPECIFIED DAY ;3/7/97 2:44 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1,1989
N NAME,Y,DATE
S DIC=470,DIC(0)="AEMNZ" D ^DIC Q:Y<0 S DA=+Y
S NAME=$P(Y(0),"^")
S %DT="A",%DT("A")="Select Ending Date: " D ^%DT S DATE=+Y
S X=$$ONE(DA,DATE)
W !!,NAME," ",$P(X,"^",1)," ",$P(X,"^",2)," ",$P(X,"^",3)
QUIT
HDR N PDATE
D NOW^%DTC S PDATE=$$DATE^PRPFU1(%)
W !,"Patient Funds Balances as of "_$$DATE^PRPFU1(DATE),?(IOM-($L(PDATE)+1)),PDATE
W !!,?35,"LAST",?50,"COMPUTED",?65,"STORED"
W !,"PATIENT NAME",?35,"TRANSACTION",?50,"BALANCE",?65,"BAL"
W ! F I=1:1:IOM-2 W "-"
W !
QUIT
LOOP ;;LOOP THROUGH ALL PATIENTS FOR BALANCE IN ACCOUNTS ON SPECIFIED DATE
S %DT="AQX",%DT("A")="Select Ending Date: " D ^%DT Q:Y<0 S DATE=+Y
S ZTDESC="BALANCE IN ACCOUNTS",ZTSAVE("DATE")=DATE,ZTRTN="L1^PRPFDAY" D ^PRPFQ
QUIT
L1 N TBAL,LTBAL,LINE,DAX,BALANCE,LASTBAL,LASTDATE
S TBAL=0,LTBAL=0
;LOOP TO CREATE ALPHABETICAL ORDER
K ^TMP($J,"PRPFDAY")
D HDR S LINE=0
S DA=0 F S DA=$O(^PRPF(470,DA)) Q:'DA D
. S X=$$ONE(DA,DATE)
. I +$P(X,"^",2)=0,+$P(X,"^",3)=0 QUIT
. S LASTDATE=$$DATE^PRPFU1($P(X,"^",1)),BALANCE=$P(X,"^",2),LASTBAL=$P(X,"^",3)
. S ^TMP($J,"PRPFDAY",$P(^DPT(DA,0),"^",1),DA)=LASTDATE_U_BALANCE_U_LASTBAL
.QUIT
S NAME="" F S NAME=$O(^TMP($J,"PRPFDAY",NAME)) Q:NAME="" S DA=0 F S DA=$O(^(NAME,DA)) Q:'DA D
. S X=^(DA)
. S LASTDATE=$P(X,"^",1),BALANCE=$P(X,"^",2),LASTBAL=$P(X,"^",3)
. W !,NAME,?35,LASTDATE,?50,$J(BALANCE,10,2),?65,$J(LASTBAL,10,2) I BALANCE'=LASTBAL W " ***" S LINE=LINE+1 I LINE>(IOSL-10) W @IOF D HDR S LINE=0
. S TBAL=TBAL+BALANCE,LTBAL=LTBAL+LASTBAL
. QUIT
W !!,?50,$J(TBAL,10,2),?65,$J(LTBAL,10,2)
QUIT
ONE(DA,DATE) ;;EXTRINSIC FUNCTION RETURNS THE BALANCE IN THE ACCOUNT OF PATIENT (DA) AS OF 2359 HOURS ON THE DATE SPECIFIED (DATE)
;;ASSUMES DA AND DATE ARE VALID
N X,TRDATE,TRAMT,TRBAL,LASTDATE,N,BALANCE
S DATE=$P(DATE,".",1)_"."_2399
S BALANCE=0,LASTBAL=0
S N=0,LASTDATE="" F S N=$O(^PRPF(470,DA,3,N)) Q:'N D
. S X=$G(^(N,0)),TRDATE=$P(X,"^",2),TRAMT=$P(X,"^",3),TRBAL=$P(X,"^",6)
. Q:TRDATE>DATE
. S BALANCE=BALANCE+TRAMT
. I LASTDATE'>TRDATE S LASTDATE=TRDATE,LASTBAL=TRBAL
. QUIT
QUIT LASTDATE_U_BALANCE_U_LASTBAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFDAY 2265 printed Nov 22, 2024@17:11:37 Page 2
PRPFDAY ;ALTOONA/CTB BALANCE ON SPECIFIED DAY ;3/7/97 2:44 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1,1989
+1 NEW NAME,Y,DATE
+2 SET DIC=470
SET DIC(0)="AEMNZ"
DO ^DIC
if Y<0
QUIT
SET DA=+Y
+3 SET NAME=$PIECE(Y(0),"^")
+4 SET %DT="A"
SET %DT("A")="Select Ending Date: "
DO ^%DT
SET DATE=+Y
+5 SET X=$$ONE(DA,DATE)
+6 WRITE !!,NAME," ",$PIECE(X,"^",1)," ",$PIECE(X,"^",2)," ",$PIECE(X,"^",3)
+7 QUIT
HDR NEW PDATE
+1 DO NOW^%DTC
SET PDATE=$$DATE^PRPFU1(%)
+2 WRITE !,"Patient Funds Balances as of "_$$DATE^PRPFU1(DATE),?(IOM-($LENGTH(PDATE)+1)),PDATE
+3 WRITE !!,?35,"LAST",?50,"COMPUTED",?65,"STORED"
+4 WRITE !,"PATIENT NAME",?35,"TRANSACTION",?50,"BALANCE",?65,"BAL"
+5 WRITE !
FOR I=1:1:IOM-2
WRITE "-"
+6 WRITE !
+7 QUIT
LOOP ;;LOOP THROUGH ALL PATIENTS FOR BALANCE IN ACCOUNTS ON SPECIFIED DATE
+1 SET %DT="AQX"
SET %DT("A")="Select Ending Date: "
DO ^%DT
if Y<0
QUIT
SET DATE=+Y
+2 SET ZTDESC="BALANCE IN ACCOUNTS"
SET ZTSAVE("DATE")=DATE
SET ZTRTN="L1^PRPFDAY"
DO ^PRPFQ
+3 QUIT
L1 NEW TBAL,LTBAL,LINE,DAX,BALANCE,LASTBAL,LASTDATE
+1 SET TBAL=0
SET LTBAL=0
+2 ;LOOP TO CREATE ALPHABETICAL ORDER
+3 KILL ^TMP($JOB,"PRPFDAY")
+4 DO HDR
SET LINE=0
+5 SET DA=0
FOR
SET DA=$ORDER(^PRPF(470,DA))
if 'DA
QUIT
Begin DoDot:1
+6 SET X=$$ONE(DA,DATE)
+7 IF +$PIECE(X,"^",2)=0
IF +$PIECE(X,"^",3)=0
QUIT
+8 SET LASTDATE=$$DATE^PRPFU1($PIECE(X,"^",1))
SET BALANCE=$PIECE(X,"^",2)
SET LASTBAL=$PIECE(X,"^",3)
+9 SET ^TMP($JOB,"PRPFDAY",$PIECE(^DPT(DA,0),"^",1),DA)=LASTDATE_U_BALANCE_U_LASTBAL
+10 QUIT
End DoDot:1
+11 SET NAME=""
FOR
SET NAME=$ORDER(^TMP($JOB,"PRPFDAY",NAME))
if NAME=""
QUIT
SET DA=0
FOR
SET DA=$ORDER(^(NAME,DA))
if 'DA
QUIT
Begin DoDot:1
+12 SET X=^(DA)
+13 SET LASTDATE=$PIECE(X,"^",1)
SET BALANCE=$PIECE(X,"^",2)
SET LASTBAL=$PIECE(X,"^",3)
+14 WRITE !,NAME,?35,LASTDATE,?50,$JUSTIFY(BALANCE,10,2),?65,$JUSTIFY(LASTBAL,10,2)
IF BALANCE'=LASTBAL
WRITE " ***"
SET LINE=LINE+1
IF LINE>(IOSL-10)
WRITE @IOF
DO HDR
SET LINE=0
+15 SET TBAL=TBAL+BALANCE
SET LTBAL=LTBAL+LASTBAL
+16 QUIT
End DoDot:1
+17 WRITE !!,?50,$JUSTIFY(TBAL,10,2),?65,$JUSTIFY(LTBAL,10,2)
+18 QUIT
ONE(DA,DATE) ;;EXTRINSIC FUNCTION RETURNS THE BALANCE IN THE ACCOUNT OF PATIENT (DA) AS OF 2359 HOURS ON THE DATE SPECIFIED (DATE)
+1 ;;ASSUMES DA AND DATE ARE VALID
+2 NEW X,TRDATE,TRAMT,TRBAL,LASTDATE,N,BALANCE
+3 SET DATE=$PIECE(DATE,".",1)_"."_2399
+4 SET BALANCE=0
SET LASTBAL=0
+5 SET N=0
SET LASTDATE=""
FOR
SET N=$ORDER(^PRPF(470,DA,3,N))
if 'N
QUIT
Begin DoDot:1
+6 SET X=$GET(^(N,0))
SET TRDATE=$PIECE(X,"^",2)
SET TRAMT=$PIECE(X,"^",3)
SET TRBAL=$PIECE(X,"^",6)
+7 if TRDATE>DATE
QUIT
+8 SET BALANCE=BALANCE+TRAMT
+9 IF LASTDATE'>TRDATE
SET LASTDATE=TRDATE
SET LASTBAL=TRBAL
+10 QUIT
End DoDot:1
+11 QUIT LASTDATE_U_BALANCE_U_LASTBAL
