PRPFPOST ;ALTOONA/CTB TRANSFER TEMPORARY TRANSACTION TO MASTER FILE ;11/22/96 4:41 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
ASK ;ASK PERMISSION TO POST DATA TO RECORD
S PRPFTYPE=$S($D(^%ZIS("TYPE-AHEAD",$I)):^($I),1:"") I PRPFTYPE="" X ^%ZOSF("NO-TYPE-AHEAD")
;TYPE AHEAD DISALLOWED AT THIS POINT TO PREVENT INADVERTENT POSTING TO THE CARD.
D DEAD^PRPFED
S %A="Is it OK to Post this data to the Permanent Files",%B="Answering 'YES' will cause the data which you have entered to be",%B(1)="transferred into the Permanent Master File and the Patient Card.",%=1
D ^PRPFYN I PRPFTYPE="" X ^%ZOSF("TYPE-AHEAD") K PRPFTYPE
I %=-1 S X=" <Action Terminated - No posting has occurred.>*" D MSG^PRPFU1 G OUT1
I %=2,$D(PRPFMUL) S X=" <Nothing Posted>*" D MSG^PRPFU1 G OUT1
I %=2 S %A="Do you wish to edit the transaction",%B="" D ^PRPFYN G:%'=1 OUT S %=3 Q
D ESIG^PRPFSIG(DUZ,.%) I %'>0 S X=" <Action Terminated>*" D MSG^PRPFU1 G OUT1
D WAIT^PRPFYN
NOASK I '$D(DT) D NOW^%DTC S DT=X K %,%H,%I,X
D:'$D(PRPF("NAME")) DUZ^PRPFSITE S TRDA(0)=^PRPFT(470.5,TRDA,0)
S %=1 F I=4,5,7,8,9,10,11 I $P(TRDA(0),"^",I)="" S X="Data is missing, Unable to post. Please reenter transaction.*" D MSG^PRPFU1 S %=-1 G OUT
I $P(TRDA(0),"^",12)+$P(TRDA(0),"^",13)'=+$P(TRDA(0),"^",4) S X="Transaction out of balance. Please reenter transaction.*" D MSG^PRPFU1 S %=-1 G OUT
SOURCE ;COMPUTE PS AND GRAT AMTS
S DFN(1)=$S($D(^PRPF(470,DFN,1)):^(1),1:""),PB=$P(DFN(1),"^",5),GB=$P(DFN(1),"^",6),SB=$P(DFN(1),"^",4)
S SOURCE=$P(TRDA(0),"^",10),GAMT=$P(TRDA(0),"^",13),PAMT=$P(TRDA(0),"^",12),AMT=$P(TRDA(0),"^",4)
I PAMT'=0 S PB=PB+PAMT I PB<0,SB+AMT'<0 S GB=GB+PB,GAMT=GAMT+PB,PAMT=PAMT-PB,PB=0 G TOT
I GAMT'=0 S GB=GB+GAMT I GB<0,SB+AMT'<0 S PB=PB+GB,PAMT=PAMT+GB,GAMT=GAMT-GB,GB=0
TOT I +AMT'=(PAMT+GAMT) W !,"Transaction out of balance. Private Source and Gratuitous Amounts do not equal",!,"the Transaction amount.",*7 G OUT
S SB=SB+AMT I +PAMT'=0,+GAMT'=0 S $P(TRDA(0),"^",10)="B"
I +PAMT=0,+GAMT'=0 S $P(TRDA(0),"^",10)="G"
I +PAMT'=0,+GAMT=0 S $P(TRDA(0),"^",10)="P"
S $P(TRDA(0),"^",12)=PAMT,$P(TRDA(0),"^",13)=GAMT,$P(TRDA(0),"^",14)=PRPF("PER")
S MADA(0)=TRDA(0)
K DEFDATE I $P(MADA(0),"^",21)>0 S DEFDATE=$P(MADA(0),"^",21)
S $P(MADA(0),"^",2)=DFN,$P(MADA(0),"^",12,13)=PAMT_"^"_GAMT,$P(MADA(0),"^",6)=DT,$P(PATRDA(0),"^",2,6)=$P(MADA(0),"^",5)_"^"_AMT_"^"_PAMT_"^"_GAMT_"^"_SB
MASTER ;CREATE ENTRY IN MASTER FILE
L +^PRPF(470.3,470.1) I '$D(^PRPF(470.3,470.1,0)) S ^(0)=470.1,$P(^PRPF(470.3,0),"^",3,4)="470.1^1",^PRPF(470.3,"B",470.1,470.1)=""
S X=$P(^PRPF(470.3,470.1,0),"^",2)+1,$P(^(0),"^",2)=X,(PRPFX,X)=X_"M" G:$D(^PRPF(470.1,"B",X)) MASTER L -^PRPF(470.3,470.1)
S DLAYGO=470.1,DIC="^PRPF(470.1,",DIC(0)="ML" D ^DIC G:Y<0 OUT G:$P(Y,"^",3)'=1 MASTER S MADA=+Y
PAT ;CREATE NEW TRANSACTION IN PATIENT FILE
S X=PRPFX K PRPFX
S:'$D(^PRPF(470,DFN,3,0)) ^(0)="^470.01A^^"
S DA(1)=DFN
S DLAYGO=470,DIC="^PRPF(470,"_DFN_",3,",DIC(0)="ML" D ^DIC G:Y<1 OUT S PATRDA=+Y,PATRID=$P(Y,"^",2)
S $P(MADA(0),"^",2,3)=DFN_"^"_PATRDA
S $P(^PRPF(470,DFN,1),"^",4,6)=SB_"^"_PB_"^"_GB,$P(^(3,PATRDA,0),"^",2)=$P(PATRDA(0),"^",2,99),$P(^PRPF(470.1,MADA,0),"^",2)=$P(MADA(0),"^",2,21)
S $P(^PRPF(470,DFN,0),"^",2)="A",$P(^(0),"^",11)=$P(MADA(0),"^",5),^PRPF(470,DFN,3,"AC",$P(MADA(0),"^",5),PATRDA)="",^PRPF(470,"AC","A",DFN)="" K ^PRPF(470,"AC","I",DFN)
D ENCODE^PRPFSIG1(MADA,DUZ,.Y)
DEF ;CREATE DEFERRAL ENTRY
I $D(DEFDATE),+DEFDATE>DT D EN1^PRPFDEF
RES ;POST RESTRICTIONS
I $P(TRDA(0),"^",22)["Y" S PRPFDATE=$P(MADA(0),"^",5),DFN(0)=^PRPF(470,DFN,0),DFN(1)=^(1) D ^PRPFRES
XREF ;CREATE CROSS REFERENCES FOR MASTER FILE
S X=$P(MADA(0),"^",6) I X]"" S ^PRPF(470.1,"AC",X,MADA)=""
S X=$P(MADA(0),"^",5) I X]"" S ^PRPF(470.1,"AD",X,MADA)=""
;POST BULLETINS
I $D(PRPFBUL("OVERDRAW")) D OVERDRAW^PRPFBUL(DFN,$P(MADA(0),"^",1))
I $D(PRPFBUL("RESTRICTION")) D RESTRICT^PRPFBUL(DFN,$P(MADA(0),"^",1))
I $D(PRPFBUL("DEFERRAL")) D DEFER^PRPFBUL(DFN,$P(MADA(0),"^",1))
K AMT,C,C1,COUNT,D0,D1,DA,DFN(0),DFN(1),DIC,DIE,DLAYGO,DQ,DR,GAMT,GB,I,MADA,P,PAMT,PATRDA,PATRID,PB,PRBAL,RES,SB,TYPE,TYPEX,X,Y,ZX,PRPFBUL
S X=" ---DONE---",%=1 G MSG^PRPFU1
OUT1 I $D(PRPFMUL) S %=0 Q
OUT I $D(TRDA),TRDA>0 S DA=TRDA,DIK="^PRPFT(470.5," D ^DIK K DIK S %=-1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFPOST 4307 printed Nov 22, 2024@17:12 Page 2
PRPFPOST ;ALTOONA/CTB TRANSFER TEMPORARY TRANSACTION TO MASTER FILE ;11/22/96 4:41 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
ASK ;ASK PERMISSION TO POST DATA TO RECORD
+1 SET PRPFTYPE=$SELECT($DATA(^%ZIS("TYPE-AHEAD",$IO)):^($IO),1:"")
IF PRPFTYPE=""
XECUTE ^%ZOSF("NO-TYPE-AHEAD")
+2 ;TYPE AHEAD DISALLOWED AT THIS POINT TO PREVENT INADVERTENT POSTING TO THE CARD.
+3 DO DEAD^PRPFED
+4 SET %A="Is it OK to Post this data to the Permanent Files"
SET %B="Answering 'YES' will cause the data which you have entered to be"
SET %B(1)="transferred into the Permanent Master File and the Patient Card."
SET %=1
+5 DO ^PRPFYN
IF PRPFTYPE=""
XECUTE ^%ZOSF("TYPE-AHEAD")
KILL PRPFTYPE
+6 IF %=-1
SET X=" <Action Terminated - No posting has occurred.>*"
DO MSG^PRPFU1
GOTO OUT1
+7 IF %=2
IF $DATA(PRPFMUL)
SET X=" <Nothing Posted>*"
DO MSG^PRPFU1
GOTO OUT1
+8 IF %=2
SET %A="Do you wish to edit the transaction"
SET %B=""
DO ^PRPFYN
if %'=1
GOTO OUT
SET %=3
QUIT
+9 DO ESIG^PRPFSIG(DUZ,.%)
IF %'>0
SET X=" <Action Terminated>*"
DO MSG^PRPFU1
GOTO OUT1
+10 DO WAIT^PRPFYN
NOASK IF '$DATA(DT)
DO NOW^%DTC
SET DT=X
KILL %,%H,%I,X
+1 if '$DATA(PRPF("NAME"))
DO DUZ^PRPFSITE
SET TRDA(0)=^PRPFT(470.5,TRDA,0)
+2 SET %=1
FOR I=4,5,7,8,9,10,11
IF $PIECE(TRDA(0),"^",I)=""
SET X="Data is missing, Unable to post. Please reenter transaction.*"
DO MSG^PRPFU1
SET %=-1
GOTO OUT
+3 IF $PIECE(TRDA(0),"^",12)+$PIECE(TRDA(0),"^",13)'=+$PIECE(TRDA(0),"^",4)
SET X="Transaction out of balance. Please reenter transaction.*"
DO MSG^PRPFU1
SET %=-1
GOTO OUT
SOURCE ;COMPUTE PS AND GRAT AMTS
+1 SET DFN(1)=$SELECT($DATA(^PRPF(470,DFN,1)):^(1),1:"")
SET PB=$PIECE(DFN(1),"^",5)
SET GB=$PIECE(DFN(1),"^",6)
SET SB=$PIECE(DFN(1),"^",4)
+2 SET SOURCE=$PIECE(TRDA(0),"^",10)
SET GAMT=$PIECE(TRDA(0),"^",13)
SET PAMT=$PIECE(TRDA(0),"^",12)
SET AMT=$PIECE(TRDA(0),"^",4)
+3 IF PAMT'=0
SET PB=PB+PAMT
IF PB<0
IF SB+AMT'<0
SET GB=GB+PB
SET GAMT=GAMT+PB
SET PAMT=PAMT-PB
SET PB=0
GOTO TOT
+4 IF GAMT'=0
SET GB=GB+GAMT
IF GB<0
IF SB+AMT'<0
SET PB=PB+GB
SET PAMT=PAMT+GB
SET GAMT=GAMT-GB
SET GB=0
TOT IF +AMT'=(PAMT+GAMT)
WRITE !,"Transaction out of balance. Private Source and Gratuitous Amounts do not equal",!,"the Transaction amount.",*7
GOTO OUT
+1 SET SB=SB+AMT
IF +PAMT'=0
IF +GAMT'=0
SET $PIECE(TRDA(0),"^",10)="B"
+2 IF +PAMT=0
IF +GAMT'=0
SET $PIECE(TRDA(0),"^",10)="G"
+3 IF +PAMT'=0
IF +GAMT=0
SET $PIECE(TRDA(0),"^",10)="P"
+4 SET $PIECE(TRDA(0),"^",12)=PAMT
SET $PIECE(TRDA(0),"^",13)=GAMT
SET $PIECE(TRDA(0),"^",14)=PRPF("PER")
+5 SET MADA(0)=TRDA(0)
+6 KILL DEFDATE
IF $PIECE(MADA(0),"^",21)>0
SET DEFDATE=$PIECE(MADA(0),"^",21)
+7 SET $PIECE(MADA(0),"^",2)=DFN
SET $PIECE(MADA(0),"^",12,13)=PAMT_"^"_GAMT
SET $PIECE(MADA(0),"^",6)=DT
SET $PIECE(PATRDA(0),"^",2,6)=$PIECE(MADA(0),"^",5)_"^"_AMT_"^"_PAMT_"^"_GAMT_"^"_SB
MASTER ;CREATE ENTRY IN MASTER FILE
+1 LOCK +^PRPF(470.3,470.1)
IF '$DATA(^PRPF(470.3,470.1,0))
SET ^(0)=470.1
SET $PIECE(^PRPF(470.3,0),"^",3,4)="470.1^1"
SET ^PRPF(470.3,"B",470.1,470.1)=""
+2 SET X=$PIECE(^PRPF(470.3,470.1,0),"^",2)+1
SET $PIECE(^(0),"^",2)=X
SET (PRPFX,X)=X_"M"
if $DATA(^PRPF(470.1,"B",X))
GOTO MASTER
LOCK -^PRPF(470.3,470.1)
+3 SET DLAYGO=470.1
SET DIC="^PRPF(470.1,"
SET DIC(0)="ML"
DO ^DIC
if Y<0
GOTO OUT
if $PIECE(Y,"^",3)'=1
GOTO MASTER
SET MADA=+Y
PAT ;CREATE NEW TRANSACTION IN PATIENT FILE
+1 SET X=PRPFX
KILL PRPFX
+2 if '$DATA(^PRPF(470,DFN,3,0))
SET ^(0)="^470.01A^^"
+3 SET DA(1)=DFN
+4 SET DLAYGO=470
SET DIC="^PRPF(470,"_DFN_",3,"
SET DIC(0)="ML"
DO ^DIC
if Y<1
GOTO OUT
SET PATRDA=+Y
SET PATRID=$PIECE(Y,"^",2)
+5 SET $PIECE(MADA(0),"^",2,3)=DFN_"^"_PATRDA
+6 SET $PIECE(^PRPF(470,DFN,1),"^",4,6)=SB_"^"_PB_"^"_GB
SET $PIECE(^(3,PATRDA,0),"^",2)=$PIECE(PATRDA(0),"^",2,99)
SET $PIECE(^PRPF(470.1,MADA,0),"^",2)=$PIECE(MADA(0),"^",2,21)
+7 SET $PIECE(^PRPF(470,DFN,0),"^",2)="A"
SET $PIECE(^(0),"^",11)=$PIECE(MADA(0),"^",5)
SET ^PRPF(470,DFN,3,"AC",$PIECE(MADA(0),"^",5),PATRDA)=""
SET ^PRPF(470,"AC","A",DFN)=""
KILL ^PRPF(470,"AC","I",DFN)
+8 DO ENCODE^PRPFSIG1(MADA,DUZ,.Y)
DEF ;CREATE DEFERRAL ENTRY
+1 IF $DATA(DEFDATE)
IF +DEFDATE>DT
DO EN1^PRPFDEF
RES ;POST RESTRICTIONS
+1 IF $PIECE(TRDA(0),"^",22)["Y"
SET PRPFDATE=$PIECE(MADA(0),"^",5)
SET DFN(0)=^PRPF(470,DFN,0)
SET DFN(1)=^(1)
DO ^PRPFRES
XREF ;CREATE CROSS REFERENCES FOR MASTER FILE
+1 SET X=$PIECE(MADA(0),"^",6)
IF X]""
SET ^PRPF(470.1,"AC",X,MADA)=""
+2 SET X=$PIECE(MADA(0),"^",5)
IF X]""
SET ^PRPF(470.1,"AD",X,MADA)=""
+3 ;POST BULLETINS
+4 IF $DATA(PRPFBUL("OVERDRAW"))
DO OVERDRAW^PRPFBUL(DFN,$PIECE(MADA(0),"^",1))
+5 IF $DATA(PRPFBUL("RESTRICTION"))
DO RESTRICT^PRPFBUL(DFN,$PIECE(MADA(0),"^",1))
+6 IF $DATA(PRPFBUL("DEFERRAL"))
DO DEFER^PRPFBUL(DFN,$PIECE(MADA(0),"^",1))
+7 KILL AMT,C,C1,COUNT,D0,D1,DA,DFN(0),DFN(1),DIC,DIE,DLAYGO,DQ,DR,GAMT,GB,I,MADA,P,PAMT,PATRDA,PATRID,PB,PRBAL,RES,SB,TYPE,TYPEX,X,Y,ZX,PRPFBUL
+8 SET X=" ---DONE---"
SET %=1
GOTO MSG^PRPFU1
OUT1 IF $DATA(PRPFMUL)
SET %=0
QUIT
OUT IF $DATA(TRDA)
IF TRDA>0
SET DA=TRDA
SET DIK="^PRPFT(470.5,"
DO ^DIK
KILL DIK
SET %=-1
QUIT
