source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCGARC.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1PRCGARC ;WIRMFO@ALTOONA/CTB IFCAP ARCHIVE ;12/10/97 9:48 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D HOME^%ZIS
5 S PRCF("X")="AS" D ^PRCFSITE Q:'%
6 S DEVIO=IO,DEVIOST=IOST,DEVXY=IOXY
7HDR W !!,"You now need to enter the header information, This is typically",!,"the name and address of your medical center."
8 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 you would like to be printed on the archive record tape or an '^' to quit"
9 D ^DIR K DIR I $$DIR^PRCGU D TERM QUIT
10 S LINE(1)=Y
11 S DIR(0)="FA^3:30",DIR("A")="Select Header Line 2: ",DIR("?")="Enter the second line of the header you would like to be printed on the archive record tape or an '^' to quit" S:$D(LINE(2)) DIR("B")=LINE(2)
12 D ^DIR K DIR I $$DIR^PRCGU D TERM QUIT
13 S LINE(2)=Y
14 S DIR(0)="FOA^3:30",DIR("A")="Select Header Line 3: ",DIR("?")="Enter the third line of the header you would like to be printed on the archive record tape or an '^' to quit" S:$D(LINE(3)) DIR("B")=LINE(3)
15 D ^DIR K DIR I Y]"",$$DIR^PRCGU D TERM QUIT
16 S LINE(3)=Y
17 S DIR(0)="D^::E",DIR("A")="Select Fiscal Year of This Archive",DIR("?")="Enter the Fiscal Year selected during the FIND option or an '^' to quit"
18 S DIR("?",1)="If you select an exact date, I will convert it to the"
19 S DIR("?",2)="last day of the FISCAL YEAR."
20 S:$D(THRUDATE) DIR("B")=THRUDATE
21 D ^DIR K DIR I Y]"",$$DIR^PRCGU D TERM QUIT
22 I $E(Y,4,5)>9 S Y=($E(Y,1,3)+1)_"0930"
23 E S Y=$E(Y,1,3)_"0930"
24 D DD^%DT S THRUDATE=Y
25 W !! F I=1:1:3 W LINE(I),!
26 W !,THRUDATE,!
27 D NOW^%DTC S Y=% D DD^%DT S LINE(4)=Y
28 S DIR("A")="IS THIS OK",DIR(0)="Y" D ^DIR I $$DIR^PRCGU D TERM QUIT
29 I 'Y W !!,"OK, you may now edit this information.",! G HDR
30 U DEVIO W !,"Please hold on while I count the number of documents to be archived."
31 S N=0,NUMBER=0 F S N=$O(^PRC(443.9,N)) Q:'N I $P($G(^(N,0)),"^",2)'=2 S NUMBER=NUMBER+1
32 U DEVIO W !," "_NUMBER_" Documents Found."
33 S %ZIS("A")="Select Tape/HFS Device: "
34 D ^%ZIS I POP D TERM,^%ZISC QUIT
35 S MTIO=IO D HOME^%ZIS
36 U MTIO W "1^IFCAP ARCHIVE^"_LINE(4),!,"2^"_LINE(1),!,"2^"_LINE(2)
37 U MTIO I $G(LINE(3))]"" W !,"2^"_LINE(3)
38 U MTIO W !,"3^~~PRCG~~^"_NUMBER_"^^"_THRUDATE
39 U MTIO W !,"4^PO_NUMBER^VENDOR"
40 U MTIO W !,"5^PORTRAIT^COURIER NEW^24",!
41 S TREC=$P(^PRC(443.9,0),"^",4)
42 S MESSAGE="ARCHIVING IFCAP RECORDS",ITEMS="documents"
43 U DEVIO D BEGIN^PRCGU
44 K LINE
45 S NEXT=0
46X F U MTIO D S XCOUNT=XCOUNT+ZCOUNT U DEVIO D PERCENT^PRCGU Q:NEXT=""
47 . F ZCOUNT=1:1:5 S NEXT=$O(^PRC(443.9,"AC",NEXT)) Q:NEXT="" D S:IXX>1 ZCOUNT=ZCOUNT+(IXX-1)
48 . . S NEXTDA=0 F IXX=0:1 S NEXTDA=$O(^PRC(443.9,"AC",NEXT,NEXTDA)) Q:'NEXTDA D
49 . . . I "13"'[$P($G(^PRC(443.9,NEXTDA,0)),"^",2) QUIT
50 . . . I $P($G(^PRC(442,NEXTDA,0)),"-")'=PRC("SITE") QUIT
51 . . . D DOC^PRCGARC1(NEXTDA)
52 . . . QUIT
53 . . QUIT
54 . QUIT
55 D END^PRCGU
56 QUIT
57TERM W !,"OPTION TERMINATED",*7
58 QUIT
Note: See TracBrowser for help on using the repository browser.