| [613] | 1 | PRPFARC ;CTB/ALTOONA PATIENT FUNDS ARCHIVE ;1/7/98 12:25 PM
|
|---|
| 2 | V ;;3.0;PATIENT FUNDS;**6,7,9**;JUNE 1, 1989
|
|---|
| 3 | N X,MTIO,NAME,PGCOUNT,XPDNM,ZTQUEUED
|
|---|
| 4 | S X="This option will cause all transactions of all cards to be written to tape in alphabetical order" D MSG^PRPFU1
|
|---|
| 5 | K ^TMP($J,"PRPFARC")
|
|---|
| 6 | S PGCOUNT=0
|
|---|
| 7 | S %A="Are You Ready to Begin",%B="",%=1 D ^PRPFYN Q:%'=1
|
|---|
| 8 | S MESSAGE="BUILDING ALPHABETIC CROSS REFERENCE IN ^TMP. ITEMS=PATIENTS"
|
|---|
| 9 | S TREC=$P(^PRPF(470,0),"^",4)
|
|---|
| 10 | G DONE:TREC<1 ; By REW 3*9 QUIT:TREC=0
|
|---|
| 11 | D BEGIN^PRPFU
|
|---|
| 12 | S DA=0 F D S XCOUNT=XCOUNT+COUNT D:'$D(ZTQUEUED) PERCENT^PRPFU Q:'DA
|
|---|
| 13 | . F COUNT=1:1:LREC S DA=$O(^PRPF(470,DA)) Q:'DA S:$D(^DPT(DA,0)) ^TMP($J,"PRPFARC",$P(^DPT(DA,0),"^"),DA)=""
|
|---|
| 14 | . QUIT
|
|---|
| 15 | K X S $P(X," ",40)=""
|
|---|
| 16 | W !!!!,"100% complete."_$P(X," ",1,40),!
|
|---|
| 17 | D:$G(XPDNM)="" KILL^%ZISS
|
|---|
| 18 | HDR W !!,"You now need to enter the header information:"
|
|---|
| 19 | S DIR(0)="FA^3:30",DIR("A")="Select Header Line 1: ",DIR("B")=$S($D(LINE(1)):LINE(1),1:"VA MEDICAL CENTER"),DIR("?")="Enter the first line of the header to be printed on the archive record tape or an '^' to quit"
|
|---|
| 20 | D ^DIR K DIR I $$DIR^PRPFU2 D TERM QUIT
|
|---|
| 21 | S LINE(1)=Y
|
|---|
| 22 | S DIR(0)="FA^3:30",DIR("A")="Select Header Line 2: ",DIR("?")="Enter the second line of the header to be printed on the archive record tape or an '^' to quit" S:$D(LINE(2)) DIR("B")=LINE(2)
|
|---|
| 23 | D ^DIR K DIR I $$DIR^PRPFU2 D TERM QUIT
|
|---|
| 24 | S LINE(2)=Y
|
|---|
| 25 | S DIR(0)="FOA^3:30",DIR("A")="Select Header Line 3: ",DIR("?")="Enter the third line of the header to be printed on the archive record tape or an '^' to quit" S:$D(LINE(3)) DIR("B")=LINE(3)
|
|---|
| 26 | D ^DIR K DIR I Y]"",$$DIR^PRPFU2 D TERM QUIT
|
|---|
| 27 | S LINE(3)=Y
|
|---|
| 28 | W !! F I=1:1:3 W LINE(I),!
|
|---|
| 29 | D NOW^PRPFQ S LINE(4)=%X
|
|---|
| 30 | S DIR("A")="IS THIS OK",DIR(0)="Y" D ^DIR I $$DIR^PRPFU2 D TERM QUIT
|
|---|
| 31 | I 'Y W !!,"OK, you may now edit this information.",! G HDR
|
|---|
| 32 | S %ZIS("A")="Select Tape/HFS Device: "
|
|---|
| 33 | D ^%ZIS I POP D TERM QUIT
|
|---|
| 34 | S MTIO=IO D HOME^%ZIS
|
|---|
| 35 | S PRPF("ARCHIVE")=""
|
|---|
| 36 | U MTIO W "1^PATIENT FUNDS ARCHIVE^"_$$DATE^PRPFU1(DT),!,"2^"_LINE(1),!,"2^"_LINE(2)
|
|---|
| 37 | U MTIO I $G(LINE(3))]"" W !,"2^"_LINE(3)
|
|---|
| 38 | U MTIO W !,"3^~~PRPF~~^"_$P(^PRPF(470,0),"^",4)_"^^"
|
|---|
| 39 | U MTIO W !,"4^NAME^CLAIM^SSN"
|
|---|
| 40 | U MTIO W !,"5^LANDSCAPE^COURIER NEW^24",!
|
|---|
| 41 | S MESSAGE="ARCHIVING PATIENT FUNDS CARDS. ITEMS=PATIENT NAME"
|
|---|
| 42 | S NAME="" F I=0:1 S NAME=$O(^TMP($J,"PRPFARC",NAME)) Q:NAME=""
|
|---|
| 43 | S TREC=I
|
|---|
| 44 | QUIT:TREC=0
|
|---|
| 45 | U IO D BEGIN^PRPFU
|
|---|
| 46 | S NAME="" F U MTIO D S XCOUNT=XCOUNT+COUNT U IO D:'$D(ZTQUEUED) PERCENT^PRPFU Q:NAME=""
|
|---|
| 47 | . F COUNT=1:1:LREC S NAME=$O(^TMP($J,"PRPFARC",NAME)) Q:NAME="" D
|
|---|
| 48 | . . S DA=0 F S DA=$O(^TMP($J,"PRPFARC",NAME,DA)) Q:'DA D
|
|---|
| 49 | . . . S DFN=DA
|
|---|
| 50 | . . . U MTIO D EN2^PRPFCD
|
|---|
| 51 | . . . QUIT
|
|---|
| 52 | . . QUIT
|
|---|
| 53 | . QUIT
|
|---|
| 54 | U MTIO W !!,"ARCHIVE COMPLETED*^^*"
|
|---|
| 55 | D:$G(XPDNM)="" KILL^%ZISS
|
|---|
| 56 | D CLOSE^PRPFU,END^PRPFU
|
|---|
| 57 | DONE D ADD("ARCHIVE",DT)
|
|---|
| 58 | U IO W !!,"ARCHIVE COMPLETED",$C(7)
|
|---|
| 59 | QUIT
|
|---|
| 60 | TERM ;
|
|---|
| 61 | U IO W " OPTION TERMINATED",$C(7) Q
|
|---|
| 62 | ADD(TYPE,THRU) ;ADD ENTRY TO ARCHIVE HISTORY FILE
|
|---|
| 63 | NEW DIC,X,%,%H,%I,DA,DR,DLAYGO
|
|---|
| 64 | D NOW^%DTC S X=%
|
|---|
| 65 | K DD,D0 S DIC="^PRPF(470.9,",DIC(0)="ML",DLAYGO=470.9
|
|---|
| 66 | S DIC("DR")="1///"_TYPE I $D(THRU) S DIC("DR")=DIC("DR")_";2///"_THRU
|
|---|
| 67 | D FILE^DICN
|
|---|
| 68 | QUIT
|
|---|
