- PRPFTRCK ;ALTOONA/CTB MODIFIED INPUT TRANS FOR PATIENT FUNDS SYSTEM ;11/22/96 4:47 PM
- V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
- ; USED TO CHECK THE TRANSACTION AMOUNT
- I X=""!(X["^") K X Q
- S:X["$" X=$P(X,"$",2) I X'?."-".N.1".".2N K X Q
- W " $ ",$J(X,0,2)
- I X>100000!(X<-100000) S %=1,%A="Are you sure about this amount",%B="" D ^PRPFYN G:%<0 DELETE I %=2 K X Q
- I '$D(DEP) K X Q
- S:DEP="W" X=-X S X1=X D ^PRPFDEF S D0(1)=D0,D0=+DFN X $P(^DD(470,30.5,0),"^",5,99) S D0=D0(1) K D0(1) S PRBAL("DEF")=X,PRBAL("SB")=$P(DFN(1),"^",4)
- I -X1'<0,PRBAL("SB")<-X1 W !,"The balance of $ ",$J(PRBAL("SB"),0,2)," is not sufficient to complete this transaction. " G OVRDRW
- I -X1'<0,(PRBAL("SB")-PRBAL("DEF"))<-X1 W *7,!,"Because of a deferred item in this account, the available balance is",!,"insufficient to fund this withdrawal.",! D OVRDEF I X="K",$D(PRPF("KILL")) Q
- S DFN(1)=^PRPF(470,DFN,1) I DEP="W",$P(DFN(1),"^",7)>0,$P(DFN(1),"^",7)-$P(DFN(1),"^",11)<-X1 S PRPFW="MONTHLY" D WARN K PRPFW I %'=1 G DELETE
- I DEP="W",$P(DFN(1),"^",8)>0,$P(DFN(1),"^",8)-$P(DFN(1),"^",12)<-X1 S PRPFW="WEEKLY" D WARN K PRPFW I %'=1 G DELETE
- A1 S X=X1 Q
- DELETE S X="K",PRPF("KILL")="" Q
- OVRDRW ;CHECK FOR AUTHORIZATION TO OVERDRAW
- G:'$D(^XUSEC("PRPF OVERDRAW",DUZ)) DELETE
- S %A="Processing of this transaction will cause this patient's account",%A(1)="to be overdrawn. You will be assuming PERSONAL responsibility",%A(2)="for this action."
- S %A(3)="DO YOU WISH TO OVERDRAW THIS ACCOUNT",%B="",%=2 D ^PRPFYN I %'=1 G DELETE
- W !,*7 K % S %A="Are you sure you wish to OVERDRAW this account",%B="" D ^PRPFYN G:%'=1 DELETE
- W *7,!,"* * * ACCOUNT OVERDRAWN * * *"
- S PRPFBUL("OVERDRAW")=""
- G A1
- WARN S %A="** WARNING, Posting this amount will exceed the "_PRPFW_" withdrawal limitation **",%A(1)="Is is OK to exceed the "_PRPFW_" limitation",%B="",%=2 D ^PRPFYN
- S:%=1 PRPFBUL("RESTRICTION")=""
- Q
- OVRDEF ;OVERRIDE DEFERRAL
- I $D(^XUSEC("PRPF DEFERRAL OVERRIDE")),'$D(^XUSEC("PRPF DEFERRAL OVERRIDE",DUZ)) G DELETE
- S %A="When overriding a deferral date, you are assuming PERSONAL responsibility for a",%A(1)="loss of funds, should one occur as a result of this action."
- S %A(2)="DO YOU WISH TO OVERRIDE",%B="" S %=2 D ^PRPFYN G:%'=1 DELETE
- I -X1'<0,(PRBAL("SB")-PRBAL("DEF"))<-X1 W ! S %A="ARE YOU SURE THAT YOU WANT TO OVERRIDE",%B="",%=2 D ^PRPFYN G:%'=1 DELETE
- S PRPFBUL("DEFERRAL")=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFTRCK 2413 printed Mar 13, 2025@21:06:52 Page 2
- PRPFTRCK ;ALTOONA/CTB MODIFIED INPUT TRANS FOR PATIENT FUNDS SYSTEM ;11/22/96 4:47 PM
- V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
- +1 ; USED TO CHECK THE TRANSACTION AMOUNT
- +2 IF X=""!(X["^")
- KILL X
- QUIT
- +3 if X["$"
- SET X=$PIECE(X,"$",2)
- IF X'?."-".N.1".".2N
- KILL X
- QUIT
- +4 WRITE " $ ",$JUSTIFY(X,0,2)
- +5 IF X>100000!(X<-100000)
- SET %=1
- SET %A="Are you sure about this amount"
- SET %B=""
- DO ^PRPFYN
- if %<0
- GOTO DELETE
- IF %=2
- KILL X
- QUIT
- +6 IF '$DATA(DEP)
- KILL X
- QUIT
- +7 if DEP="W"
- SET X=-X
- SET X1=X
- DO ^PRPFDEF
- SET D0(1)=D0
- SET D0=+DFN
- XECUTE $PIECE(^DD(470,30.5,0),"^",5,99)
- SET D0=D0(1)
- KILL D0(1)
- SET PRBAL("DEF")=X
- SET PRBAL("SB")=$PIECE(DFN(1),"^",4)
- +8 IF -X1'<0
- IF PRBAL("SB")<-X1
- WRITE !,"The balance of $ ",$JUSTIFY(PRBAL("SB"),0,2)," is not sufficient to complete this transaction. "
- GOTO OVRDRW
- +9 IF -X1'<0
- IF (PRBAL("SB")-PRBAL("DEF"))<-X1
- WRITE *7,!,"Because of a deferred item in this account, the available balance is",!,"insufficient to fund this withdrawal.",!
- DO OVRDEF
- IF X="K"
- IF $DATA(PRPF("KILL"))
- QUIT
- +10 SET DFN(1)=^PRPF(470,DFN,1)
- IF DEP="W"
- IF $PIECE(DFN(1),"^",7)>0
- IF $PIECE(DFN(1),"^",7)-$PIECE(DFN(1),"^",11)<-X1
- SET PRPFW="MONTHLY"
- DO WARN
- KILL PRPFW
- IF %'=1
- GOTO DELETE
- +11 IF DEP="W"
- IF $PIECE(DFN(1),"^",8)>0
- IF $PIECE(DFN(1),"^",8)-$PIECE(DFN(1),"^",12)<-X1
- SET PRPFW="WEEKLY"
- DO WARN
- KILL PRPFW
- IF %'=1
- GOTO DELETE
- A1 SET X=X1
- QUIT
- DELETE SET X="K"
- SET PRPF("KILL")=""
- QUIT
- OVRDRW ;CHECK FOR AUTHORIZATION TO OVERDRAW
- +1 if '$DATA(^XUSEC("PRPF OVERDRAW",DUZ))
- GOTO DELETE
- +2 SET %A="Processing of this transaction will cause this patient's account"
- SET %A(1)="to be overdrawn. You will be assuming PERSONAL responsibility"
- SET %A(2)="for this action."
- +3 SET %A(3)="DO YOU WISH TO OVERDRAW THIS ACCOUNT"
- SET %B=""
- SET %=2
- DO ^PRPFYN
- IF %'=1
- GOTO DELETE
- +4 WRITE !,*7
- KILL %
- SET %A="Are you sure you wish to OVERDRAW this account"
- SET %B=""
- DO ^PRPFYN
- if %'=1
- GOTO DELETE
- +5 WRITE *7,!,"* * * ACCOUNT OVERDRAWN * * *"
- +6 SET PRPFBUL("OVERDRAW")=""
- +7 GOTO A1
- WARN SET %A="** WARNING, Posting this amount will exceed the "_PRPFW_" withdrawal limitation **"
- SET %A(1)="Is is OK to exceed the "_PRPFW_" limitation"
- SET %B=""
- SET %=2
- DO ^PRPFYN
- +1 if %=1
- SET PRPFBUL("RESTRICTION")=""
- +2 QUIT
- OVRDEF ;OVERRIDE DEFERRAL
- +1 IF $DATA(^XUSEC("PRPF DEFERRAL OVERRIDE"))
- IF '$DATA(^XUSEC("PRPF DEFERRAL OVERRIDE",DUZ))
- GOTO DELETE
- +2 SET %A="When overriding a deferral date, you are assuming PERSONAL responsibility for a"
- SET %A(1)="loss of funds, should one occur as a result of this action."
- +3 SET %A(2)="DO YOU WISH TO OVERRIDE"
- SET %B=""
- SET %=2
- DO ^PRPFYN
- if %'=1
- GOTO DELETE
- +4 IF -X1'<0
- IF (PRBAL("SB")-PRBAL("DEF"))<-X1
- WRITE !
- SET %A="ARE YOU SURE THAT YOU WANT TO OVERRIDE"
- SET %B=""
- SET %=2
- DO ^PRPFYN
- if %'=1
- GOTO DELETE
- +5 SET PRPFBUL("DEFERRAL")=""
- +6 QUIT
