- 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 Jan 18, 2025@03:02:38 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