PRPFDEF.m

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 ---PRPFDEF   1314     printed  Apr 09, 2024@21:05                                                                                                                                                                                                        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