PRPFBAL ;ALTOONA/CTB-PATIENT LOOKUP AND COMPUTE BALANCE ;08/29/02
V ;;3.0;PATIENT FUNDS;**6,8,13,14**;JUNE 1, 1989
EN S DIC(0)="ZAEQM",DIC=470 D ^DIC I +Y>0 S DFN=+Y,DFN(0)=Y(0),DFN(0,0)=Y(0,0),DFN(1)=$S($D(^PRPF(470,DFN,1)):^(1),1:"") D EN1 G EN
W:$D(IOF) @IOF K %,%W,%X,%Y,C,DFN,DIC,DIYS,POP,Y
OUT K %H,%I,%TG,D,D1,DG1,DGT,DGX,DIW,DIWT,DN,I,N,PFHI,PFLO,PFNORM,PRBAL,Q3,RES,TMP,TYPE,X,X2,Y,Z Q
EN1 D HILO S PRBAL("DEF")=$P(^DD(470,30.5,0),"^",5,99) S DFN(0)=^PRPF(470,DFN,0),DFN(1)=$S($D(^(1)):^(1),1:""),DFN(0,0)=$P(^DPT(DFN,0),"^") D EN^PRPFRES S PRBAL("SB")=$P(DFN(1),"^",4),PRBAL("PB")=$P(DFN(1),"^",5),PRBAL("GB")=$P(DFN(1),"^",6)
S RES=$P(DFN(0),U,3) S TYPE=$S(RES="R":"RESTRICTED",RES="L":"LIMITED UNRESTRICTED",RES="U":"UNRESTRICTED",1:"UNKNOWN")
A D ^PRPFDEF S D0=DFN X PRBAL("DEF") K D0 S PRBAL("DEF")=X
W:$D(IOF) @IOF W !,@PFHI,$P(DFN(0,0),"^"),@PFLO,?40 W "SSN: ",@PFHI S SSN=$P(^DPT(+DFN(0),0),"^",9)
W $E(SSN,1,3),@PFLO,"-",@PFHI,$E(SSN,4,5),@PFLO,"-",@PFHI,$E(SSN,6,9),?60,@PFLO,"CLAIM #: ",@PFHI,$S($D(^DPT(+DFN(0),.31)):$P(^(.31),"^",3),1:""),@PFLO K SSN
D DGINPW^PRPFU1 W @PFHI D DEAD^PRPFED W @PFLO,!
W ?18,"* * * ACCOUNT TYPE IS ",@PFHI,TYPE,@PFLO," * * *",!,"WARD: ",@PFHI,DFN(.1),@PFLO
I $D(^PRPF(470,DFN,12)) I (^PRPF(470,DFN,12))'="" W !,"STATION NAME: ",@PFHI,$$GET1^DIQ(4,(^PRPF(470,DFN,12)),.01),@PFLO
I $D(^PRPF(470,DFN,12)) I (^PRPF(470,DFN,12))="" W !,"STATION NAME:"
W:'$D(^PRPF(470,DFN,12)) !,"STATION NAME:"
I "UX"[RES G B
W !,"AUTH WD/MONTH: ",@PFHI S X=$P(DFN(1),U,7) D C W X,@PFLO,?39,"AUTH WD/WEEK: ",@PFHI S X=$P(DFN(1),U,8) D C W X,@PFLO,!,?7,"ACTUAL: ",@PFHI S X=$P(DFN(1),"^",11) D C W X,@PFLO,?45,"ACTUAL: ",@PFHI S X=$P(DFN(1),"^",12) D C W X
B W @PFLO S XI="",$P(XI,"*",80)="" W !,XI
W !,?10," TOTAL BALANCE: ",@PFHI S X=PRBAL("SB") D C W X,@PFLO,?45,"PRIVATE SOURCE: ",@PFHI S X=PRBAL("PB") D C W X,@PFLO,!,?16,"DEFERRED: ",@PFHI S X=PRBAL("DEF") D C W X,@PFLO,?49
W "GRATUITOUS: ",@PFHI S X=PRBAL("GB") D C W X,@PFLO,!!,"AVAILABLE FOR WITHDRAWAL: " S (PRBAL("PB"),X)=PRBAL("SB")-PRBAL("DEF") W @PFHI D C W X,@PFLO,!
W XI K XI
I +PRBAL("DEF")>0 W !,"DEFERRAL INFORMATION:",?30,"TRANSACTION",?50,"DEF DATE",?69,"AMOUNT" D DEF
GI ;PRINT GENERAL INFORMATION REMARKS
T2 W !,"GENERAL REMARKS/INFORMATION:"
K ^UTILITY($J,"W") ; <<< Added by REW in patch 8 since Eng. doesn't kill -- see NOIS CLE-1097-42161
W @PFHI S N=0,DIWF="W",DIWL=5,DIWR=IOM-10 F I=1:1 S N=$O(^PRPF(470,DFN,7,N)) Q:N="" S X=^(N,0) D ^DIWP
D ^DIWW K DIWF,DIWL,DIWR,X
W @PFNORM
T3 G:'$D(^XUSEC("PRPF CLERK",DUZ)) OUT W !,"SPECIAL REMARKS:"
W @PFHI S N=0,DIWF="W",DIWL=5,DIWR=IOM-10 F I=1:1 S N=$O(^PRPF(470,DFN,8,N)) Q:N="" S X=^(N,0) D ^DIWP
D ^DIWW
W !,"The information contained in this report is protected by the Privacy Act of 1974"
K DIWF,DIWL,DIWR,X W @PFNORM G OUT
DEF ;WRITES DEFERRAL INFORMATION
F I=0:0 S I=$O(^PRPF(470,DFN,4,I)) Q:I'=+I I $D(^(I,0)) S PRPF(1)=^PRPF(470,DFN,4,I,0) W !,?35,@PFHI,$P(PRPF(1),"^"),?49 S Y=$P(PRPF(1),"^",2) X ^DD("DD") W Y,?64 S X=$P(PRPF(1),"^",3) D C W X,@PFLO
K PRPF(1) Q
HILO S IOP=0 D ^%ZIS S (PFHI,PFLO,PFNORM)="*0" I ^%ZOSF("OS")'["M/11" Q
;HI/LO INTENSITY DISABLED FOR DSM DUE TO INAPPROPRIATE HANDLING OF COLUMN POSITIONING
S:$D(^%ZIS(2,IOST(0),7)) TMP=^(7),PFHI=$P(TMP,"^",1),PFLO=$P(TMP,"^",2),PFNORM=$P(TMP,"^",3) I PFHI=""!(PFLO="")!(PFNORM="") S (PFLO,PFHI,PFNORM)="*0"
Q
;
C S X2="2$"
S %D=X<0 S:%D X=-X S %=$S($D(X2):+X2,1:2),X=$J(X,1,%),%=$L(X)-3-$E(23456789,%)
F %=%:-3 Q:$E(X,%)="" S X=$E(X,1,%)_","_$E(X,%+1,99)
S:$D(X2) X=$E("$",X2["$")_X S X=$J($E("(",%D)_X_$E(" )",%D+1),12) K %,%D Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFBAL 3643 printed Dec 13, 2024@02:01:26 Page 2
PRPFBAL ;ALTOONA/CTB-PATIENT LOOKUP AND COMPUTE BALANCE ;08/29/02
V ;;3.0;PATIENT FUNDS;**6,8,13,14**;JUNE 1, 1989
EN SET DIC(0)="ZAEQM"
SET DIC=470
DO ^DIC
IF +Y>0
SET DFN=+Y
SET DFN(0)=Y(0)
SET DFN(0,0)=Y(0,0)
SET DFN(1)=$SELECT($DATA(^PRPF(470,DFN,1)):^(1),1:"")
DO EN1
GOTO EN
+1 if $DATA(IOF)
WRITE @IOF
KILL %,%W,%X,%Y,C,DFN,DIC,DIYS,POP,Y
OUT KILL %H,%I,%TG,D,D1,DG1,DGT,DGX,DIW,DIWT,DN,I,N,PFHI,PFLO,PFNORM,PRBAL,Q3,RES,TMP,TYPE,X,X2,Y,Z
QUIT
EN1 DO HILO
SET PRBAL("DEF")=$PIECE(^DD(470,30.5,0),"^",5,99)
SET DFN(0)=^PRPF(470,DFN,0)
SET DFN(1)=$SELECT($DATA(^(1)):^(1),1:"")
SET DFN(0,0)=$PIECE(^DPT(DFN,0),"^")
DO EN^PRPFRES
SET PRBAL("SB")=$PIECE(DFN(1),"^",4)
SET PRBAL("PB")=$PIECE(DFN(1),"^",5)
SET PRBAL("GB")=$PIECE(DFN(1),"^",6)
+1 SET RES=$PIECE(DFN(0),U,3)
SET TYPE=$SELECT(RES="R":"RESTRICTED",RES="L":"LIMITED UNRESTRICTED",RES="U":"UNRESTRICTED",1:"UNKNOWN")
A DO ^PRPFDEF
SET D0=DFN
XECUTE PRBAL("DEF")
KILL D0
SET PRBAL("DEF")=X
+1 if $DATA(IOF)
WRITE @IOF
WRITE !,@PFHI,$PIECE(DFN(0,0),"^"),@PFLO,?40
WRITE "SSN: ",@PFHI
SET SSN=$PIECE(^DPT(+DFN(0),0),"^",9)
+2 WRITE $EXTRACT(SSN,1,3),@PFLO,"-",@PFHI,$EXTRACT(SSN,4,5),@PFLO,"-",@PFHI,$EXTRACT(SSN,6,9),?60,@PFLO,"CLAIM #: ",@PFHI,$SELECT($DATA(^DPT(+DFN(0),.31)):$PIECE(^(.31),"^",3),1:""),@PFLO
KILL SSN
+3 DO DGINPW^PRPFU1
WRITE @PFHI
DO DEAD^PRPFED
WRITE @PFLO,!
+4 WRITE ?18,"* * * ACCOUNT TYPE IS ",@PFHI,TYPE,@PFLO," * * *",!,"WARD: ",@PFHI,DFN(.1),@PFLO
+5 IF $DATA(^PRPF(470,DFN,12))
IF (^PRPF(470,DFN,12))'=""
WRITE !,"STATION NAME: ",@PFHI,$$GET1^DIQ(4,(^PRPF(470,DFN,12)),.01),@PFLO
+6 IF $DATA(^PRPF(470,DFN,12))
IF (^PRPF(470,DFN,12))=""
WRITE !,"STATION NAME:"
+7 if '$DATA(^PRPF(470,DFN,12))
WRITE !,"STATION NAME:"
+8 IF "UX"[RES
GOTO B
+9 WRITE !,"AUTH WD/MONTH: ",@PFHI
SET X=$PIECE(DFN(1),U,7)
DO C
WRITE X,@PFLO,?39,"AUTH WD/WEEK: ",@PFHI
SET X=$PIECE(DFN(1),U,8)
DO C
WRITE X,@PFLO,!,?7,"ACTUAL: ",@PFHI
SET X=$PIECE(DFN(1),"^",11)
DO C
WRITE X,@PFLO,?45,"ACTUAL: ",@PFHI
SET X=$PIECE(DFN(1),"^",12)
DO C
WRITE X
B WRITE @PFLO
SET XI=""
SET $PIECE(XI,"*",80)=""
WRITE !,XI
+1 WRITE !,?10," TOTAL BALANCE: ",@PFHI
SET X=PRBAL("SB")
DO C
WRITE X,@PFLO,?45,"PRIVATE SOURCE: ",@PFHI
SET X=PRBAL("PB")
DO C
WRITE X,@PFLO,!,?16,"DEFERRED: ",@PFHI
SET X=PRBAL("DEF")
DO C
WRITE X,@PFLO,?49
+2 WRITE "GRATUITOUS: ",@PFHI
SET X=PRBAL("GB")
DO C
WRITE X,@PFLO,!!,"AVAILABLE FOR WITHDRAWAL: "
SET (PRBAL("PB"),X)=PRBAL("SB")-PRBAL("DEF")
WRITE @PFHI
DO C
WRITE X,@PFLO,!
+3 WRITE XI
KILL XI
+4 IF +PRBAL("DEF")>0
WRITE !,"DEFERRAL INFORMATION:",?30,"TRANSACTION",?50,"DEF DATE",?69,"AMOUNT"
DO DEF
GI ;PRINT GENERAL INFORMATION REMARKS
T2 WRITE !,"GENERAL REMARKS/INFORMATION:"
+1 ; <<< Added by REW in patch 8 since Eng. doesn't kill -- see NOIS CLE-1097-42161
KILL ^UTILITY($JOB,"W")
+2 WRITE @PFHI
SET N=0
SET DIWF="W"
SET DIWL=5
SET DIWR=IOM-10
FOR I=1:1
SET N=$ORDER(^PRPF(470,DFN,7,N))
if N=""
QUIT
SET X=^(N,0)
DO ^DIWP
+3 DO ^DIWW
KILL DIWF,DIWL,DIWR,X
+4 WRITE @PFNORM
T3 if '$DATA(^XUSEC("PRPF CLERK",DUZ))
GOTO OUT
WRITE !,"SPECIAL REMARKS:"
+1 WRITE @PFHI
SET N=0
SET DIWF="W"
SET DIWL=5
SET DIWR=IOM-10
FOR I=1:1
SET N=$ORDER(^PRPF(470,DFN,8,N))
if N=""
QUIT
SET X=^(N,0)
DO ^DIWP
+2 DO ^DIWW
+3 WRITE !,"The information contained in this report is protected by the Privacy Act of 1974"
+4 KILL DIWF,DIWL,DIWR,X
WRITE @PFNORM
GOTO OUT
DEF ;WRITES DEFERRAL INFORMATION
+1 FOR I=0:0
SET I=$ORDER(^PRPF(470,DFN,4,I))
if I'=+I
QUIT
IF $DATA(^(I,0))
SET PRPF(1)=^PRPF(470,DFN,4,I,0)
WRITE !,?35,@PFHI,$PIECE(PRPF(1),"^"),?49
SET Y=$PIECE(PRPF(1),"^",2)
XECUTE ^DD("DD")
WRITE Y,?64
SET X=$PIECE(PRPF(1),"^",3)
DO C
WRITE X,@PFLO
+2 KILL PRPF(1)
QUIT
HILO SET IOP=0
DO ^%ZIS
SET (PFHI,PFLO,PFNORM)="*0"
IF ^%ZOSF("OS")'["M/11"
QUIT
+1 ;HI/LO INTENSITY DISABLED FOR DSM DUE TO INAPPROPRIATE HANDLING OF COLUMN POSITIONING
+2 if $DATA(^%ZIS(2,IOST(0),7))
SET TMP=^(7)
SET PFHI=$PIECE(TMP,"^",1)
SET PFLO=$PIECE(TMP,"^",2)
SET PFNORM=$PIECE(TMP,"^",3)
IF PFHI=""!(PFLO="")!(PFNORM="")
SET (PFLO,PFHI,PFNORM)="*0"
+3 QUIT
+4 ;
C SET X2="2$"
+1 SET %D=X<0
if %D
SET X=-X
SET %=$SELECT($DATA(X2):+X2,1:2)
SET X=$JUSTIFY(X,1,%)
SET %=$LENGTH(X)-3-$EXTRACT(23456789,%)
+2 FOR %=%:-3
if $EXTRACT(X,%)=""
QUIT
SET X=$EXTRACT(X,1,%)_","_$EXTRACT(X,%+1,99)
+3 if $DATA(X2)
SET X=$EXTRACT("$",X2["$")_X
SET X=$JUSTIFY($EXTRACT("(",%D)_X_$EXTRACT(" )",%D+1),12)
KILL %,%D
QUIT
