Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCGARC

PRCGARC.m

Go to the documentation of this file.
  1. PRCGARC ;WIRMFO@ALTOONA/CTB IFCAP ARCHIVE ;12/10/97 9:48 AM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. D HOME^%ZIS
  1. S PRCF("X")="AS" D ^PRCFSITE Q:'%
  1. S DEVIO=IO,DEVIOST=IOST,DEVXY=IOXY
  1. HDR W !!,"You now need to enter the header information, This is typically",!,"the name and address of your medical center."
  1. 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"
  1. D ^DIR K DIR I $$DIR^PRCGU D TERM QUIT
  1. S LINE(1)=Y
  1. 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)
  1. D ^DIR K DIR I $$DIR^PRCGU D TERM QUIT
  1. S LINE(2)=Y
  1. 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)
  1. D ^DIR K DIR I Y]"",$$DIR^PRCGU D TERM QUIT
  1. S LINE(3)=Y
  1. 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"
  1. S DIR("?",1)="If you select an exact date, I will convert it to the"
  1. S DIR("?",2)="last day of the FISCAL YEAR."
  1. S:$D(THRUDATE) DIR("B")=THRUDATE
  1. D ^DIR K DIR I Y]"",$$DIR^PRCGU D TERM QUIT
  1. I $E(Y,4,5)>9 S Y=($E(Y,1,3)+1)_"0930"
  1. E S Y=$E(Y,1,3)_"0930"
  1. D DD^%DT S THRUDATE=Y
  1. W !! F I=1:1:3 W LINE(I),!
  1. W !,THRUDATE,!
  1. D NOW^%DTC S Y=% D DD^%DT S LINE(4)=Y
  1. S DIR("A")="IS THIS OK",DIR(0)="Y" D ^DIR I $$DIR^PRCGU D TERM QUIT
  1. I 'Y W !!,"OK, you may now edit this information.",! G HDR
  1. U DEVIO W !,"Please hold on while I count the number of documents to be archived."
  1. 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
  1. U DEVIO W !," "_NUMBER_" Documents Found."
  1. S %ZIS("A")="Select Tape/HFS Device: "
  1. D ^%ZIS I POP D TERM,^%ZISC QUIT
  1. S MTIO=IO D HOME^%ZIS
  1. U MTIO W "1^IFCAP ARCHIVE^"_LINE(4),!,"2^"_LINE(1),!,"2^"_LINE(2)
  1. U MTIO I $G(LINE(3))]"" W !,"2^"_LINE(3)
  1. U MTIO W !,"3^~~PRCG~~^"_NUMBER_"^^"_THRUDATE
  1. U MTIO W !,"4^PO_NUMBER^VENDOR"
  1. U MTIO W !,"5^PORTRAIT^COURIER NEW^24",!
  1. S TREC=$P(^PRC(443.9,0),"^",4)
  1. S MESSAGE="ARCHIVING IFCAP RECORDS",ITEMS="documents"
  1. U DEVIO D BEGIN^PRCGU
  1. K LINE
  1. S NEXT=0
  1. X F U MTIO D S XCOUNT=XCOUNT+ZCOUNT U DEVIO D PERCENT^PRCGU Q:NEXT=""
  1. . F ZCOUNT=1:1:5 S NEXT=$O(^PRC(443.9,"AC",NEXT)) Q:NEXT="" D S:IXX>1 ZCOUNT=ZCOUNT+(IXX-1)
  1. . . S NEXTDA=0 F IXX=0:1 S NEXTDA=$O(^PRC(443.9,"AC",NEXT,NEXTDA)) Q:'NEXTDA D
  1. . . . I "13"'[$P($G(^PRC(443.9,NEXTDA,0)),"^",2) QUIT
  1. . . . I $P($G(^PRC(442,NEXTDA,0)),"-")'=PRC("SITE") QUIT
  1. . . . D DOC^PRCGARC1(NEXTDA)
  1. . . . QUIT
  1. . . QUIT
  1. . QUIT
  1. D END^PRCGU
  1. QUIT
  1. TERM W !,"OPTION TERMINATED",*7
  1. QUIT