PRPFED1 ;ALTOONA/CTB CONTINUATION OF EDIT ROUTINE ;11/22/96 4:38 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
BCF ;ENTER BALANCE CARRIED FORWARD
D GETPAT^PRPFED G:'%PRPF OUT I $D(^PRPF(470,DFN,3,0)),$O(^(0))'="" D W1 G BCF
D GETTRANS^PRPFED G:'%PRPF OUT
BCF1 S DIE=DIC,DR="[PRPF TEMP BCF AMTS]" D ^DIE G:$D(Y) OUT S TRDA(0)=^PRPFT(470.5,DA,0),PRTOT=$P(TRDA(0),"^",18),PRPVT=$P(TRDA(0),"^",19),PRGRAT=$P(TRDA(0),"^",20)
I +PRTOT'=(PRPVT+PRGRAT) W !,"Total of Gratuitous and Private Source must equal Total",*7,! G BCF1
S $P(TRDA(0),"^",4,16)=PRTOT_U_DT_"^^BALCARFWD^D^3^B^^"_PRPVT_U_PRGRAT_U_DUZ_"^^Balance Carried Forward" S DIC=470.2,DIC(0)="MN",X="BALCARFWD" D ^DIC I Y>0 S $P(TRDA(0),"^",11)=+Y,^PRPFT(470.5,DA,0)=TRDA(0)
S Y=DFN,Y(0)=DFN(0) D ^PRPFPOST I %=1 W !! D OUT S DIC("A")="Select Next Patient: " G BCF
S X=" <Option Terminated, No Posting Has Occurred>*" D MSG^PRPFU1 R X:3
OUT K:$D(DFN) ^PRPF(470,DFN,9) K %,%PRPF,%W,%X,%Y,C,COUNT,D,D0,DA,DFN,DI,DIC,DIE,DIYS,DLAYGO,DQ,DR,I,K,P,POP,PRGRAT,PRPF,PRPVT,PRTOT,S,SOURCE,TRDA,X,Y Q
W1 W !,*7,"This option may not be used when a patient already has transactions",!,"entered for his account." R X:4 D OUT Q
D GETTRANS^PRPFED G:'%PRPF OUT S SINGLE=1 D BCF1,EN1^PRPFBAL,OUT K SINGLE Q
FORMS ;ADD/EDIT FORMS FILE
S DIC=470.2,DIC(0)="AEMNZL",DLAYGO=470.2 D ^DIC G:Y<0 OUT S DA=+Y,DR="[PRPF FORMS EDIT]" D ^DIE G FORMS
RCODE ;ENTER/EDIT REMARKS CODE FILE
S DIC=470.6,DIC(0)="AEMNL",DLAYGO=470.6 D ^DIC K DIC G:Y<0 OUT S DIE="^PRPF(470.6,",DA=+Y,DR=".01;1" D ^DIE W ! G RCODE
REM ;INPUT TRANSFORM FOR 'FULL REMARK' FIELD OF FILE 470.5
G REM1:X'["," S ZX=$P(X,",",2,99),X=$P(X,","),DIC=470.6,DIC(0)="ZMN" D ^DIC I Y<0 S:ZX]"" X=ZX K ZX G RE2
S X=$P(Y(0),"^",2)_$S(ZX]"":" "_ZX,1:"") K ZX G RE2
REM1 S DIC=470.6,DIC(0)="ZMN" D ^DIC G:Y<0 RE2
S X=$P(Y(0),"^",2)
RE2 I $L(X)>50 W ?$X+5,"EXCEEDS 50 CHARACTERS, PLEASE REENTER" K X Q
W ?$X+8,X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFED1 1928 printed Dec 13, 2024@02:01:42 Page 2
PRPFED1 ;ALTOONA/CTB CONTINUATION OF EDIT ROUTINE ;11/22/96 4:38 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
BCF ;ENTER BALANCE CARRIED FORWARD
+1 DO GETPAT^PRPFED
if '%PRPF
GOTO OUT
IF $DATA(^PRPF(470,DFN,3,0))
IF $ORDER(^(0))'=""
DO W1
GOTO BCF
+2 DO GETTRANS^PRPFED
if '%PRPF
GOTO OUT
BCF1 SET DIE=DIC
SET DR="[PRPF TEMP BCF AMTS]"
DO ^DIE
if $DATA(Y)
GOTO OUT
SET TRDA(0)=^PRPFT(470.5,DA,0)
SET PRTOT=$PIECE(TRDA(0),"^",18)
SET PRPVT=$PIECE(TRDA(0),"^",19)
SET PRGRAT=$PIECE(TRDA(0),"^",20)
+1 IF +PRTOT'=(PRPVT+PRGRAT)
WRITE !,"Total of Gratuitous and Private Source must equal Total",*7,!
GOTO BCF1
+2 SET $PIECE(TRDA(0),"^",4,16)=PRTOT_U_DT_"^^BALCARFWD^D^3^B^^"_PRPVT_U_PRGRAT_U_DUZ_"^^Balance Carried Forward"
SET DIC=470.2
SET DIC(0)="MN"
SET X="BALCARFWD"
DO ^DIC
IF Y>0
SET $PIECE(TRDA(0),"^",11)=+Y
SET ^PRPFT(470.5,DA,0)=TRDA(0)
+3 SET Y=DFN
SET Y(0)=DFN(0)
DO ^PRPFPOST
IF %=1
WRITE !!
DO OUT
SET DIC("A")="Select Next Patient: "
GOTO BCF
+4 SET X=" <Option Terminated, No Posting Has Occurred>*"
DO MSG^PRPFU1
READ X:3
OUT if $DATA(DFN)
KILL ^PRPF(470,DFN,9)
KILL %,%PRPF,%W,%X,%Y,C,COUNT,D,D0,DA,DFN,DI,DIC,DIE,DIYS,DLAYGO,DQ,DR,I,K,P,POP,PRGRAT,PRPF,PRPVT,PRTOT,S,SOURCE,TRDA,X,Y
QUIT
W1 WRITE !,*7,"This option may not be used when a patient already has transactions",!,"entered for his account."
READ X:4
DO OUT
QUIT
+1 DO GETTRANS^PRPFED
if '%PRPF
GOTO OUT
SET SINGLE=1
DO BCF1
DO EN1^PRPFBAL
DO OUT
KILL SINGLE
QUIT
FORMS ;ADD/EDIT FORMS FILE
+1 SET DIC=470.2
SET DIC(0)="AEMNZL"
SET DLAYGO=470.2
DO ^DIC
if Y<0
GOTO OUT
SET DA=+Y
SET DR="[PRPF FORMS EDIT]"
DO ^DIE
GOTO FORMS
RCODE ;ENTER/EDIT REMARKS CODE FILE
+1 SET DIC=470.6
SET DIC(0)="AEMNL"
SET DLAYGO=470.6
DO ^DIC
KILL DIC
if Y<0
GOTO OUT
SET DIE="^PRPF(470.6,"
SET DA=+Y
SET DR=".01;1"
DO ^DIE
WRITE !
GOTO RCODE
REM ;INPUT TRANSFORM FOR 'FULL REMARK' FIELD OF FILE 470.5
+1 if X'[","
GOTO REM1
SET ZX=$PIECE(X,",",2,99)
SET X=$PIECE(X,",")
SET DIC=470.6
SET DIC(0)="ZMN"
DO ^DIC
IF Y<0
if ZX]""
SET X=ZX
KILL ZX
GOTO RE2
+2 SET X=$PIECE(Y(0),"^",2)_$SELECT(ZX]"":" "_ZX,1:"")
KILL ZX
GOTO RE2
REM1 SET DIC=470.6
SET DIC(0)="ZMN"
DO ^DIC
if Y<0
GOTO RE2
+1 SET X=$PIECE(Y(0),"^",2)
RE2 IF $LENGTH(X)>50
WRITE ?$X+5,"EXCEEDS 50 CHARACTERS, PLEASE REENTER"
KILL X
QUIT
+1 WRITE ?$X+8,X
QUIT
