| 1 | PRCGARC ;WIRMFO@ALTOONA/CTB IFCAP ARCHIVE ;12/10/97 9:48 AM
|
|---|
| 2 | V ;;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
|
|---|
| 7 | HDR 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
|
|---|
| 46 | X 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
|
|---|
| 57 | TERM W !,"OPTION TERMINATED",*7
|
|---|
| 58 | QUIT
|
|---|
