source: FOIAVistA/trunk/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFBAL.m@ 1250

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