Routine: PRPFNQ

PRPFNQ ;ALTOONA/CTB-PATIENT FUNDS MULTIPLE CARD DRIVER ;15 APR 02

V ;;3.0;PATIENT FUNDS;**3,5,6,7,13**;JUNE 1, 1989

 N BDATE W *7,!,"REMEMBER, this option requires a printer with a line length of at least",!,"132 characters and a page length of at least 62 lines.",!

 W !!,"Enter the names(s) of cards required, one at a time.  "

 S LIST=1

 S DIC("A")="Select PATIENT NAME: "

A S DIC=470,DIC(0)="AEQM" D ^DIC K DIC("A") I +Y>0  D ADD S DIC("A")="Select Next PATIENT NAME: " G A

 K DIC

 I $D(LIST)'=11 W !,*7,"No cards selected, Option is Terminated! " R X:3 K IOP D OUT Q

 D DATE IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) K BDATE,DTOUT,DUOUT,DIROUT D OUT Q

 S ZTDESC="PRINT SELECTED PATIENT FUND CARDS",ZTSAVE("DIC")="^PRPF(470," S:$D(BDATE) ZTSAVE("BDATE*")="",ZTRTN="DQ^PRPFNQ",ZTSAVE("LIST*")="" D ^PRPFQ

 K LIST,%Y,Y

 QUIT

ADD NEW X

 I $L($G(LIST(LIST))_+Y)>240 S LIST=LIST+1

 S LIST(LIST)=$G(LIST(LIST))_+Y_"^"

 QUIT

DQ K ^TMP("PRPFAD",$J)

 F I=1:1:LIST F J=1:1 S N=$P(LIST(I),"^",J) Q:'N  S ^TMP("PRPFAD",$J,N)=""

 S DIC="^PRPF(470,"

 S IOP=PRIOP

 S BY=".01",(FR,TO)="",BY(0)="^TMP(""PRPFAD"",$J,",FLDS="[PRPF CARD]",L=0,L(0)=1,DIOEND="K ^TMP(""PRPFAD"",$J)"

 D EN1^DIP D OUT

DATE ;IF PARTIAL LIST IS REQUESTED, ASK EARLIEST DATE  ELSE S DATE=01/01/1900

 S DIR(0)="SA^A:ALL;P:PARTIAL",DIR("A")="Partial List or All Tranactions: ",DIR("B")="ALL"

 S DIR("?")="You may enter (A)LL or (P)ARTIAL",DIR("?",1)="Selecting PARTIAL will allow you to print only those transactions",DIR("?",2)="starting with the date you select."

 D ^DIR K DIR IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q

 S BDATE=2000101,X=BDATE D CNVD^PRPFQ S BDATE1=X I Y="A" QUIT

 S DIR(0)="DOA^:DT:EX",DIR("A")="Select Earliest Date to Print on Cards: ",DIR("?")="^D HELP^PRPFNQ" D ^DIR K DIR

 IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q

 IF Y>0 S BDATE=+Y-1,X=+Y D CNVD^PRPFQ S BDATE1=X

 QUIT

DOIT S DIC="^PRPF(470,",L=0,(FLDS,BY)="[PRPF RANGE OF CARDS]" D EN1^DIP

ALL ;PRINT ALL CARDS

 S %A="This option will print a card for each ACTIVE patient, or for ALL patients,",%A(1)="   regardless of status, within the range selected."

 S %A(2)="Are you sure that you want to run this option now"

 S %B="A 'Yes' will begin the job, after you select a device.  Remember,"

 S %B(1)="this job will take a while to run.  Enter an '^' to terminate the option." D ^PRPFYN Q:%'=1

 D DATE IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) K BDATE,BDATE1,DTOUT,DUOUT,DIROUT D OUT Q

 S %A="Do you wish to print only the ACTIVE cards",%B="",%=1 D ^PRPFYN Q:%<0  W !!,"I will now print a card for ",$S(%=1:"ALL ACTIVE ",1:"ALL")," cards."

 K DIS(0) I %=1 S DIS(0)="I $P(^PRPF(470,D0,0),U,2)=""A"""

 S M="PATIENT" D RNG^PRPFQ I '$D(FR)!('$D(TO)) D OUT Q

 S BY="[PRPF RANGE OF CARDS]",%=1,%A="OK TO CONTINUE",%B="" D ^PRPFYN Q:%'=1

 S DIC="^PRPF(470,",L=0,FLDS="[PRPF CARD]" D EN1^DIP

OUT K %,%DT,%H,%I,%W,%X,BDATE,BDATE1,DCC,DFN,DGA1,DG1,DGT,DGX,DIJ,DIOEND,DIOP,DIPT,DIR,DISH,DIYS,DP,F,FLDS,IOX,IOY,L,O,POP,MTR,PAGE,PRPFKEY,PRPFRNG,PRPFRNG2,PTR,W,X,ZTSK

 QUIT

RESEARCH ;;SEARCH OF PATIENT FUNDS FOR DATES OF RESTRICTION OVER 6 MONTHS OLD

 ;HITS ARE STORED IN THE AK CROSSREFERENCE

 D SELRNG^PRPFQ

 I PRPFRNG="" D OUT QUIT

 I PRPFRNG="@" S PRPFRNG2=""

 E  S PRPFRNG2=PRPFRNG

 S ZTSAVE("PRPFRNG")=PRPFRNG,ZTSAVE("PRPFRNG2")=PRPFRNG2

 S ZTRTN="DQRES^PRPFNQ",ZTDESC=$P($T(RESEARCH),";",3) D ^PRPFQ,OUT Q

DQRES ;DQ POINT FOR RESTRICTION SEARCH

 I $D(ZTQUEUED) S IOP=PRIOP,ZTREQ="@"

 K ^TMP("PRPFAK",$J)

 S X="T-181",%DT="" D ^%DT

 S X="Please hold on, I'm searching the file now.*" D MSG^PRPFQ

 S DA=0 F  S DA=$O(^PRPF(470,DA)) Q:'DA  S X=$P($G(^PRPF(470,DA,0)),"^",12) I X]"",X<Y S ^TMP("PRPFAK",$J,DA)=""

 I $D(^TMP("PRPFAK",$J))<9 S X="No matches found today.*" D MSG^PRPFQ G OUTR

 S:$D(PRIOP) IOP=PRIOP S DIC="^PRPF(470,",L=0,L(0)=1,BY="@73:99;S,.01",BY(0)="^TMP(""PRPFAK"",$J,",FLDS="[PRPF OVERDUE PRINT",FR=""_PRPFRNG_"",TO=""_PRPFRNG2_""

 S DIOEND="K ^TMP(""PRPFAK"") W !,""The information contained in this report is protected by the Privacy Act of 1974"""

 S:PRPFRNG="@" BY="@73,@73:99,.01",FR="@,@",TO=","

 D EN1^DIP

OUTR ;

 K IOP,PRIOP,PFM,T5,^TMP("PRPFAK",$J) D DIKILL^PRPFQ G ZTKILL^PRPFQ

HELP W !,"If you enter a date, ALL entries on the card, before that date",!,"  will be consolidated.",! D HELP^%DTC Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFNQ   4319     printed  Feb 18, 2025@23:28:11                                                                                                                                                                                                      Page 2

PRPFNQ    ;ALTOONA/CTB-PATIENT FUNDS MULTIPLE CARD DRIVER ;15 APR 02

V         ;;3.0;PATIENT FUNDS;**3,5,6,7,13**;JUNE 1, 1989

 +1        NEW BDATE

           WRITE *7,!,"REMEMBER, this option requires a printer with a line length of at least",!,"132 characters and a page length of at least 62 lines.",!

 +2        WRITE !!,"Enter the names(s) of cards required, one at a time.  "

 +3        SET LIST=1

 +4        SET DIC("A")="Select PATIENT NAME: "

A          SET DIC=470

           SET DIC(0)="AEQM"

           DO ^DIC

           KILL DIC("A")

           IF +Y>0

               DO ADD

               SET DIC("A")="Select Next PATIENT NAME: "

               GOTO A

 +1        KILL DIC

 +2        IF $DATA(LIST)'=11

               WRITE !,*7,"No cards selected, Option is Terminated! "

               READ X:3

               KILL IOP

               DO OUT

               QUIT

 +3        DO DATE

           IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               KILL BDATE,DTOUT,DUOUT,DIROUT

               DO OUT

               QUIT

 +4        SET ZTDESC="PRINT SELECTED PATIENT FUND CARDS"

           SET ZTSAVE("DIC")="^PRPF(470,"

           if $DATA(BDATE)

               SET ZTSAVE("BDATE*")=""

               SET ZTRTN="DQ^PRPFNQ"

               SET ZTSAVE("LIST*")=""

           DO ^PRPFQ

 +5        KILL LIST,%Y,Y

 +6        QUIT

ADD        NEW X

 +1        IF $LENGTH($GET(LIST(LIST))_+Y)>240

               SET LIST=LIST+1

 +2        SET LIST(LIST)=$GET(LIST(LIST))_+Y_"^"

 +3        QUIT

DQ         KILL ^TMP("PRPFAD",$JOB)

 +1        FOR I=1:1:LIST

               FOR J=1:1

                   SET N=$PIECE(LIST(I),"^",J)

                   if 'N

                       QUIT

                   SET ^TMP("PRPFAD",$JOB,N)=""

 +2        SET DIC="^PRPF(470,"

 +3        SET IOP=PRIOP

 +4        SET BY=".01"

           SET (FR,TO)=""

           SET BY(0)="^TMP(""PRPFAD"",$J,"

           SET FLDS="[PRPF CARD]"

           SET L=0

           SET L(0)=1

           SET DIOEND="K ^TMP(""PRPFAD"",$J)"

 +5        DO EN1^DIP

           DO OUT

 +6        QUIT

DATE      ;IF PARTIAL LIST IS REQUESTED, ASK EARLIEST DATE  ELSE S DATE=01/01/1900

 +1        SET DIR(0)="SA^A:ALL;P:PARTIAL"

           SET DIR("A")="Partial List or All Tranactions: "

           SET DIR("B")="ALL"

 +2        SET DIR("?")="You may enter (A)LL or (P)ARTIAL"

           SET DIR("?",1)="Selecting PARTIAL will allow you to print only those transactions"

           SET DIR("?",2)="starting with the date you select."

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               QUIT

 +4        SET BDATE=2000101

           SET X=BDATE

           DO CNVD^PRPFQ

           SET BDATE1=X

           IF Y="A"

               QUIT

 +5        SET DIR(0)="DOA^:DT:EX"

           SET DIR("A")="Select Earliest Date to Print on Cards: "

           SET DIR("?")="^D HELP^PRPFNQ"

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               QUIT

 +7        IF Y>0

               SET BDATE=+Y-1

               SET X=+Y

               DO CNVD^PRPFQ

               SET BDATE1=X

 +8        QUIT

DOIT       SET DIC="^PRPF(470,"

           SET L=0

           SET (FLDS,BY)="[PRPF RANGE OF CARDS]"

           DO EN1^DIP

 +1        QUIT

ALL       ;PRINT ALL CARDS

 +1        SET %A="This option will print a card for each ACTIVE patient, or for ALL patients,"

           SET %A(1)="   regardless of status, within the range selected."

 +2        SET %A(2)="Are you sure that you want to run this option now"

 +3        SET %B="A 'Yes' will begin the job, after you select a device.  Remember,"

 +4        SET %B(1)="this job will take a while to run.  Enter an '^' to terminate the option."

           DO ^PRPFYN

           if %'=1

               QUIT

 +5        DO DATE

           IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               KILL BDATE,BDATE1,DTOUT,DUOUT,DIROUT

               DO OUT

               QUIT

 +6        SET %A="Do you wish to print only the ACTIVE cards"

           SET %B=""

           SET %=1

           DO ^PRPFYN

           if %<0

               QUIT

           WRITE !!,"I will now print a card for ",$SELECT(%=1:"ALL ACTIVE ",1:"ALL")," cards."

 +7        KILL DIS(0)

           IF %=1

               SET DIS(0)="I $P(^PRPF(470,D0,0),U,2)=""A"""

 +8        SET M="PATIENT"

           DO RNG^PRPFQ

           IF '$DATA(FR)!('$DATA(TO))

               DO OUT

               QUIT

 +9        SET BY="[PRPF RANGE OF CARDS]"

           SET %=1

           SET %A="OK TO CONTINUE"

           SET %B=""

           DO ^PRPFYN

           if %'=1

               QUIT

 +10       SET DIC="^PRPF(470,"

           SET L=0

           SET FLDS="[PRPF CARD]"

           DO EN1^DIP

OUT        KILL %,%DT,%H,%I,%W,%X,BDATE,BDATE1,DCC,DFN,DGA1,DG1,DGT,DGX,DIJ,DIOEND,DIOP,DIPT,DIR,DISH,DIYS,DP,F,FLDS,IOX,IOY,L,O,POP,MTR,PAGE,PRPFKEY,PRPFRNG,PRPFRNG2,PTR,W,X,ZTSK

 +1        QUIT

RESEARCH  ;;SEARCH OF PATIENT FUNDS FOR DATES OF RESTRICTION OVER 6 MONTHS OLD

 +1       ;HITS ARE STORED IN THE AK CROSSREFERENCE

 +2        DO SELRNG^PRPFQ

 +3        IF PRPFRNG=""

               DO OUT

               QUIT

 +4        IF PRPFRNG="@"

               SET PRPFRNG2=""

 +5       IF '$TEST

               SET PRPFRNG2=PRPFRNG

 +6        SET ZTSAVE("PRPFRNG")=PRPFRNG

           SET ZTSAVE("PRPFRNG2")=PRPFRNG2

 +7        SET ZTRTN="DQRES^PRPFNQ"

           SET ZTDESC=$PIECE($TEXT(RESEARCH),";",3)

           DO ^PRPFQ

           DO OUT

           QUIT

DQRES     ;DQ POINT FOR RESTRICTION SEARCH

 +1        IF $DATA(ZTQUEUED)

               SET IOP=PRIOP

               SET ZTREQ="@"

 +2        KILL ^TMP("PRPFAK",$JOB)

 +3        SET X="T-181"

           SET %DT=""

           DO ^%DT

 +4        SET X="Please hold on, I'm searching the file now.*"

           DO MSG^PRPFQ

 +5        SET DA=0

FOR

               SET DA=$ORDER(^PRPF(470,DA))

               if 'DA

                   QUIT

               SET X=$PIECE($GET(^PRPF(470,DA,0)),"^",12)

               IF X]""

                   IF X<Y

                       SET ^TMP("PRPFAK",$JOB,DA)=""

 +6        IF $DATA(^TMP("PRPFAK",$JOB))<9

               SET X="No matches found today.*"

               DO MSG^PRPFQ

               GOTO OUTR

 +7        if $DATA(PRIOP)

               SET IOP=PRIOP

           SET DIC="^PRPF(470,"

           SET L=0

           SET L(0)=1

           SET BY="@73:99;S,.01"

           SET BY(0)="^TMP(""PRPFAK"",$J,"

           SET FLDS="[PRPF OVERDUE PRINT"

           SET FR=""_PRPFRNG_""

           SET TO=""_PRPFRNG2_""

 +8        SET DIOEND="K ^TMP(""PRPFAK"") W !,""The information contained in this report is protected by the Privacy Act of 1974"""

 +9        if PRPFRNG="@"

               SET BY="@73,@73:99,.01"

               SET FR="@,@"

               SET TO=","

 +10       DO EN1^DIP

OUTR      ;

 +1        KILL IOP,PRIOP,PFM,T5,^TMP("PRPFAK",$JOB)

           DO DIKILL^PRPFQ

           GOTO ZTKILL^PRPFQ

 +2        QUIT

HELP       WRITE !,"If you enter a date, ALL entries on the card, before that date",!,"  will be consolidated.",!

           DO HELP^%DTC

           QUIT

PRPFNQ.m