- 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 Apr 23, 2025@18:16:21 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
