| 1 | PRPFNQ ;ALTOONA/CTB-PATIENT FUNDS MULTIPLE CARD DRIVER ;15 APR 02
|
|---|
| 2 | V ;;3.0;PATIENT FUNDS;**3,5,6,7,13**;JUNE 1, 1989
|
|---|
| 3 | 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.",!
|
|---|
| 4 | W !!,"Enter the names(s) of cards required, one at a time. "
|
|---|
| 5 | S LIST=1
|
|---|
| 6 | S DIC("A")="Select PATIENT NAME: "
|
|---|
| 7 | 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
|
|---|
| 8 | K DIC
|
|---|
| 9 | I $D(LIST)'=11 W !,*7,"No cards selected, Option is Terminated! " R X:3 K IOP D OUT Q
|
|---|
| 10 | D DATE IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) K BDATE,DTOUT,DUOUT,DIROUT D OUT Q
|
|---|
| 11 | S ZTDESC="PRINT SELECTED PATIENT FUND CARDS",ZTSAVE("DIC")="^PRPF(470," S:$D(BDATE) ZTSAVE("BDATE*")="",ZTRTN="DQ^PRPFNQ",ZTSAVE("LIST*")="" D ^PRPFQ
|
|---|
| 12 | K LIST,%Y,Y
|
|---|
| 13 | QUIT
|
|---|
| 14 | ADD NEW X
|
|---|
| 15 | I $L($G(LIST(LIST))_+Y)>240 S LIST=LIST+1
|
|---|
| 16 | S LIST(LIST)=$G(LIST(LIST))_+Y_"^"
|
|---|
| 17 | QUIT
|
|---|
| 18 | DQ K ^TMP("PRPFAD",$J)
|
|---|
| 19 | F I=1:1:LIST F J=1:1 S N=$P(LIST(I),"^",J) Q:'N S ^TMP("PRPFAD",$J,N)=""
|
|---|
| 20 | S DIC="^PRPF(470,"
|
|---|
| 21 | S IOP=PRIOP
|
|---|
| 22 | S BY=".01",(FR,TO)="",BY(0)="^TMP(""PRPFAD"",$J,",FLDS="[PRPF CARD]",L=0,L(0)=1,DIOEND="K ^TMP(""PRPFAD"",$J)"
|
|---|
| 23 | D EN1^DIP D OUT
|
|---|
| 24 | Q
|
|---|
| 25 | DATE ;IF PARTIAL LIST IS REQUESTED, ASK EARLIEST DATE ELSE S DATE=01/01/1900
|
|---|
| 26 | S DIR(0)="SA^A:ALL;P:PARTIAL",DIR("A")="Partial List or All Tranactions: ",DIR("B")="ALL"
|
|---|
| 27 | 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."
|
|---|
| 28 | D ^DIR K DIR IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q
|
|---|
| 29 | S BDATE=2000101,X=BDATE D CNVD^PRPFQ S BDATE1=X I Y="A" QUIT
|
|---|
| 30 | S DIR(0)="DOA^:DT:EX",DIR("A")="Select Earliest Date to Print on Cards: ",DIR("?")="^D HELP^PRPFNQ" D ^DIR K DIR
|
|---|
| 31 | IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q
|
|---|
| 32 | IF Y>0 S BDATE=+Y-1,X=+Y D CNVD^PRPFQ S BDATE1=X
|
|---|
| 33 | QUIT
|
|---|
| 34 | DOIT S DIC="^PRPF(470,",L=0,(FLDS,BY)="[PRPF RANGE OF CARDS]" D EN1^DIP
|
|---|
| 35 | Q
|
|---|
| 36 | ALL ;PRINT ALL CARDS
|
|---|
| 37 | 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."
|
|---|
| 38 | S %A(2)="Are you sure that you want to run this option now"
|
|---|
| 39 | S %B="A 'Yes' will begin the job, after you select a device. Remember,"
|
|---|
| 40 | S %B(1)="this job will take a while to run. Enter an '^' to terminate the option." D ^PRPFYN Q:%'=1
|
|---|
| 41 | D DATE IF $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) K BDATE,BDATE1,DTOUT,DUOUT,DIROUT D OUT Q
|
|---|
| 42 | 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."
|
|---|
| 43 | K DIS(0) I %=1 S DIS(0)="I $P(^PRPF(470,D0,0),U,2)=""A"""
|
|---|
| 44 | S M="PATIENT" D RNG^PRPFQ I '$D(FR)!('$D(TO)) D OUT Q
|
|---|
| 45 | S BY="[PRPF RANGE OF CARDS]",%=1,%A="OK TO CONTINUE",%B="" D ^PRPFYN Q:%'=1
|
|---|
| 46 | S DIC="^PRPF(470,",L=0,FLDS="[PRPF CARD]" D EN1^DIP
|
|---|
| 47 | 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
|
|---|
| 48 | QUIT
|
|---|
| 49 | RESEARCH ;;SEARCH OF PATIENT FUNDS FOR DATES OF RESTRICTION OVER 6 MONTHS OLD
|
|---|
| 50 | ;HITS ARE STORED IN THE AK CROSSREFERENCE
|
|---|
| 51 | D SELRNG^PRPFQ
|
|---|
| 52 | I PRPFRNG="" D OUT QUIT
|
|---|
| 53 | I PRPFRNG="@" S PRPFRNG2=""
|
|---|
| 54 | E S PRPFRNG2=PRPFRNG
|
|---|
| 55 | S ZTSAVE("PRPFRNG")=PRPFRNG,ZTSAVE("PRPFRNG2")=PRPFRNG2
|
|---|
| 56 | S ZTRTN="DQRES^PRPFNQ",ZTDESC=$P($T(RESEARCH),";",3) D ^PRPFQ,OUT Q
|
|---|
| 57 | DQRES ;DQ POINT FOR RESTRICTION SEARCH
|
|---|
| 58 | I $D(ZTQUEUED) S IOP=PRIOP,ZTREQ="@"
|
|---|
| 59 | K ^TMP("PRPFAK",$J)
|
|---|
| 60 | S X="T-181",%DT="" D ^%DT
|
|---|
| 61 | S X="Please hold on, I'm searching the file now.*" D MSG^PRPFQ
|
|---|
| 62 | 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)=""
|
|---|
| 63 | I $D(^TMP("PRPFAK",$J))<9 S X="No matches found today.*" D MSG^PRPFQ G OUTR
|
|---|
| 64 | 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_""
|
|---|
| 65 | S DIOEND="K ^TMP(""PRPFAK"") W !,""The information contained in this report is protected by the Privacy Act of 1974"""
|
|---|
| 66 | S:PRPFRNG="@" BY="@73,@73:99,.01",FR="@,@",TO=","
|
|---|
| 67 | D EN1^DIP
|
|---|
| 68 | OUTR ;
|
|---|
| 69 | K IOP,PRIOP,PFM,T5,^TMP("PRPFAK",$J) D DIKILL^PRPFQ G ZTKILL^PRPFQ
|
|---|
| 70 | Q
|
|---|
| 71 | HELP W !,"If you enter a date, ALL entries on the card, before that date",!," will be consolidated.",! D HELP^%DTC Q
|
|---|
