source: FOIAVistA/trunk/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFARC.m@ 1535

Last change on this file since 1535 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1PRPFARC ;CTB/ALTOONA PATIENT FUNDS ARCHIVE ;1/7/98 12:25 PM
2V ;;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
18HDR 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
57DONE D ADD("ARCHIVE",DT)
58 U IO W !!,"ARCHIVE COMPLETED",$C(7)
59 QUIT
60TERM ;
61 U IO W " OPTION TERMINATED",$C(7) Q
62ADD(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
Note: See TracBrowser for help on using the repository browser.