- PRPFDEF ;CTB/ALTOONA PATIENT FUNDS DEFERRED CREDIT ;2/25/97 1:44 PM
- V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
- ;CHECKS FOR EXISTENCE OF DEFERRED CREDIT ITEMS
- ;DELETES DEFERRED CREDIT ITEMS WITH DATES < DT
- ;UPDATES ZEROTH NODE
- EN ;UPDATES THE DEFERRED FILE FOR A SINGLE PATIENT. REQUIRES 'DFN' AS THE
- ;INTERNAL REFERENCE NUMBER OF THE PATIENT.
- I '$D(^PRPF(470,DFN,4,0)) Q
- S PRQ1=$P(^PRPF(470,DFN,4,0),U,3),PRQ2=$P(^(0),U,4),Q3=1,PRD2=""
- S PRD1=0 F S PRD1=$O(^PRPF(470,DFN,4,PRD1)) Q:PRD1'>0 I $P(^PRPF(470,DFN,4,PRD1,0),U,2)'>DT K ^PRPF(470,DFN,4,PRD1,0) S PRQ2=PRQ2-1 S:PRQ1=PRD1 PRQ1=PRD2 S PRD2=PRD1
- S PRQ4=$P(^PRPF(470,DFN,4,0),U,2) S ^(0)=U_PRQ4_U_PRQ1_U_PRQ2 D KILL Q
- ;
- EN1 ;ADDS NEW ENTRY TO THE DEFERRED CREDIT ITEM FILE
- I '$D(^PRPF(470,DFN,4,0)) S ^(0)="^470.02A"
- S PRQ1=($P(^PRPF(470,DFN,4,0),U,3))+1,PRQ2=($P(^(0),U,4))+1
- S ^PRPF(470,DFN,4,PRQ1,0)=PATRID_U_DEFDATE_U_AMT_U_PATRDA
- S $P(^PRPF(470,DFN,4,0),"^",3,4)=PRQ1_U_PRQ2
- D KILL Q
- EN2 ;UPDATE DEFERRED BALANCES ON ALL PATIENTS
- NEW X,DFN,PR1
- S U="^" D NOW^PRPFQ S DT=X
- S DFN=0 F PR1=1:1 S DFN=$O(^PRPF(470,DFN)) Q:+DFN'=DFN!(DFN="") I $D(^PRPF(470,DFN,4,0)),$P(^(0),U,2)'="A" D EN
- D KILL Q
- ;
- KILL ;THIS LINE DELETES ALL LOCAL VARIABLES CALLED BY THIS ROUTINE EXCEPTDFN
- K PRQ1,PRQ2,PRQ3,PRQ4,PRD1,PRD2 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFDEF 1314 printed Jan 18, 2025@03:02:43 Page 2
- PRPFDEF ;CTB/ALTOONA PATIENT FUNDS DEFERRED CREDIT ;2/25/97 1:44 PM
- V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
- +1 ;CHECKS FOR EXISTENCE OF DEFERRED CREDIT ITEMS
- +2 ;DELETES DEFERRED CREDIT ITEMS WITH DATES < DT
- +3 ;UPDATES ZEROTH NODE
- EN ;UPDATES THE DEFERRED FILE FOR A SINGLE PATIENT. REQUIRES 'DFN' AS THE
- +1 ;INTERNAL REFERENCE NUMBER OF THE PATIENT.
- +2 IF '$DATA(^PRPF(470,DFN,4,0))
- QUIT
- +3 SET PRQ1=$PIECE(^PRPF(470,DFN,4,0),U,3)
- SET PRQ2=$PIECE(^(0),U,4)
- SET Q3=1
- SET PRD2=""
- +4 SET PRD1=0
- FOR
- SET PRD1=$ORDER(^PRPF(470,DFN,4,PRD1))
- if PRD1'>0
- QUIT
- IF $PIECE(^PRPF(470,DFN,4,PRD1,0),U,2)'>DT
- KILL ^PRPF(470,DFN,4,PRD1,0)
- SET PRQ2=PRQ2-1
- if PRQ1=PRD1
- SET PRQ1=PRD2
- SET PRD2=PRD1
- +5 SET PRQ4=$PIECE(^PRPF(470,DFN,4,0),U,2)
- SET ^(0)=U_PRQ4_U_PRQ1_U_PRQ2
- DO KILL
- QUIT
- +6 ;
- EN1 ;ADDS NEW ENTRY TO THE DEFERRED CREDIT ITEM FILE
- +1 IF '$DATA(^PRPF(470,DFN,4,0))
- SET ^(0)="^470.02A"
- +2 SET PRQ1=($PIECE(^PRPF(470,DFN,4,0),U,3))+1
- SET PRQ2=($PIECE(^(0),U,4))+1
- +3 SET ^PRPF(470,DFN,4,PRQ1,0)=PATRID_U_DEFDATE_U_AMT_U_PATRDA
- +4 SET $PIECE(^PRPF(470,DFN,4,0),"^",3,4)=PRQ1_U_PRQ2
- +5 DO KILL
- QUIT
- EN2 ;UPDATE DEFERRED BALANCES ON ALL PATIENTS
- +1 NEW X,DFN,PR1
- +2 SET U="^"
- DO NOW^PRPFQ
- SET DT=X
- +3 SET DFN=0
- FOR PR1=1:1
- SET DFN=$ORDER(^PRPF(470,DFN))
- if +DFN'=DFN!(DFN="")
- QUIT
- IF $DATA(^PRPF(470,DFN,4,0))
- IF $PIECE(^(0),U,2)'="A"
- DO EN
- +4 DO KILL
- QUIT
- +5 ;
- KILL ;THIS LINE DELETES ALL LOCAL VARIABLES CALLED BY THIS ROUTINE EXCEPTDFN
- +1 KILL PRQ1,PRQ2,PRQ3,PRQ4,PRD1,PRD2
- QUIT