PRCGARC ;WIRMFO@ALTOONA/CTB IFCAP ARCHIVE ;12/10/97 9:48 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D HOME^%ZIS
S PRCF("X")="AS" D ^PRCFSITE Q:'%
S DEVIO=IO,DEVIOST=IOST,DEVXY=IOXY
HDR W !!,"You now need to enter the header information, This is typically",!,"the name and address of your medical center."
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"
D ^DIR K DIR I $$DIR^PRCGU D TERM QUIT
S LINE(1)=Y
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)
D ^DIR K DIR I $$DIR^PRCGU D TERM QUIT
S LINE(2)=Y
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)
D ^DIR K DIR I Y]"",$$DIR^PRCGU D TERM QUIT
S LINE(3)=Y
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"
S DIR("?",1)="If you select an exact date, I will convert it to the"
S DIR("?",2)="last day of the FISCAL YEAR."
S:$D(THRUDATE) DIR("B")=THRUDATE
D ^DIR K DIR I Y]"",$$DIR^PRCGU D TERM QUIT
I $E(Y,4,5)>9 S Y=($E(Y,1,3)+1)_"0930"
E S Y=$E(Y,1,3)_"0930"
D DD^%DT S THRUDATE=Y
W !! F I=1:1:3 W LINE(I),!
W !,THRUDATE,!
D NOW^%DTC S Y=% D DD^%DT S LINE(4)=Y
S DIR("A")="IS THIS OK",DIR(0)="Y" D ^DIR I $$DIR^PRCGU D TERM QUIT
I 'Y W !!,"OK, you may now edit this information.",! G HDR
U DEVIO W !,"Please hold on while I count the number of documents to be archived."
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
U DEVIO W !," "_NUMBER_" Documents Found."
S %ZIS("A")="Select Tape/HFS Device: "
D ^%ZIS I POP D TERM,^%ZISC QUIT
S MTIO=IO D HOME^%ZIS
U MTIO W "1^IFCAP ARCHIVE^"_LINE(4),!,"2^"_LINE(1),!,"2^"_LINE(2)
U MTIO I $G(LINE(3))]"" W !,"2^"_LINE(3)
U MTIO W !,"3^~~PRCG~~^"_NUMBER_"^^"_THRUDATE
U MTIO W !,"4^PO_NUMBER^VENDOR"
U MTIO W !,"5^PORTRAIT^COURIER NEW^24",!
S TREC=$P(^PRC(443.9,0),"^",4)
S MESSAGE="ARCHIVING IFCAP RECORDS",ITEMS="documents"
U DEVIO D BEGIN^PRCGU
K LINE
S NEXT=0
X F U MTIO D S XCOUNT=XCOUNT+ZCOUNT U DEVIO D PERCENT^PRCGU Q:NEXT=""
. F ZCOUNT=1:1:5 S NEXT=$O(^PRC(443.9,"AC",NEXT)) Q:NEXT="" D S:IXX>1 ZCOUNT=ZCOUNT+(IXX-1)
. . S NEXTDA=0 F IXX=0:1 S NEXTDA=$O(^PRC(443.9,"AC",NEXT,NEXTDA)) Q:'NEXTDA D
. . . I "13"'[$P($G(^PRC(443.9,NEXTDA,0)),"^",2) QUIT
. . . I $P($G(^PRC(442,NEXTDA,0)),"-")'=PRC("SITE") QUIT
. . . D DOC^PRCGARC1(NEXTDA)
. . . QUIT
. . QUIT
. QUIT
D END^PRCGU
QUIT
TERM W !,"OPTION TERMINATED",*7
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGARC 3024 printed Dec 13, 2024@02:04:43 Page 2
PRCGARC ;WIRMFO@ALTOONA/CTB IFCAP ARCHIVE ;12/10/97 9:48 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 DO HOME^%ZIS
+3 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
QUIT
+4 SET DEVIO=IO
SET DEVIOST=IOST
SET DEVXY=IOXY
HDR WRITE !!,"You now need to enter the header information, This is typically",!,"the name and address of your medical center."
+1 SET DIR(0)="FA^3:30"
SET DIR("A")="Select Header Line 1: "
SET DIR("B")=$SELECT($DATA(LINE(1)):LINE(1),1:"VA MEDICAL CENTER")
SET DIR("?")="Enter the first line of the header you would like to be printed on the archive record tape or an '^' to quit"
+2 DO ^DIR
KILL DIR
IF $$DIR^PRCGU
DO TERM
QUIT
+3 SET LINE(1)=Y
+4 SET DIR(0)="FA^3:30"
SET DIR("A")="Select Header Line 2: "
SET DIR("?")="Enter the second line of the header you would like to be printed on the archive record tape or an '^' to quit"
if $DATA(LINE(2))
SET DIR("B")=LINE(2)
+5 DO ^DIR
KILL DIR
IF $$DIR^PRCGU
DO TERM
QUIT
+6 SET LINE(2)=Y
+7 SET DIR(0)="FOA^3:30"
SET DIR("A")="Select Header Line 3: "
SET DIR("?")="Enter the third line of the header you would like to be printed on the archive record tape or an '^' to quit"
if $DATA(LINE(3))
SET DIR("B")=LINE(3)
+8 DO ^DIR
KILL DIR
IF Y]""
IF $$DIR^PRCGU
DO TERM
QUIT
+9 SET LINE(3)=Y
+10 SET DIR(0)="D^::E"
SET DIR("A")="Select Fiscal Year of This Archive"
SET DIR("?")="Enter the Fiscal Year selected during the FIND option or an '^' to quit"
+11 SET DIR("?",1)="If you select an exact date, I will convert it to the"
+12 SET DIR("?",2)="last day of the FISCAL YEAR."
+13 if $DATA(THRUDATE)
SET DIR("B")=THRUDATE
+14 DO ^DIR
KILL DIR
IF Y]""
IF $$DIR^PRCGU
DO TERM
QUIT
+15 IF $EXTRACT(Y,4,5)>9
SET Y=($EXTRACT(Y,1,3)+1)_"0930"
+16 IF '$TEST
SET Y=$EXTRACT(Y,1,3)_"0930"
+17 DO DD^%DT
SET THRUDATE=Y
+18 WRITE !!
FOR I=1:1:3
WRITE LINE(I),!
+19 WRITE !,THRUDATE,!
+20 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET LINE(4)=Y
+21 SET DIR("A")="IS THIS OK"
SET DIR(0)="Y"
DO ^DIR
IF $$DIR^PRCGU
DO TERM
QUIT
+22 IF 'Y
WRITE !!,"OK, you may now edit this information.",!
GOTO HDR
+23 USE DEVIO
WRITE !,"Please hold on while I count the number of documents to be archived."
+24 SET N=0
SET NUMBER=0
FOR
SET N=$ORDER(^PRC(443.9,N))
if 'N
QUIT
IF $PIECE($GET(^(N,0)),"^",2)'=2
SET NUMBER=NUMBER+1
+25 USE DEVIO
WRITE !," "_NUMBER_" Documents Found."
+26 SET %ZIS("A")="Select Tape/HFS Device: "
+27 DO ^%ZIS
IF POP
DO TERM
DO ^%ZISC
QUIT
+28 SET MTIO=IO
DO HOME^%ZIS
+29 USE MTIO
WRITE "1^IFCAP ARCHIVE^"_LINE(4),!,"2^"_LINE(1),!,"2^"_LINE(2)
+30 USE MTIO
IF $GET(LINE(3))]""
WRITE !,"2^"_LINE(3)
+31 USE MTIO
WRITE !,"3^~~PRCG~~^"_NUMBER_"^^"_THRUDATE
+32 USE MTIO
WRITE !,"4^PO_NUMBER^VENDOR"
+33 USE MTIO
WRITE !,"5^PORTRAIT^COURIER NEW^24",!
+34 SET TREC=$PIECE(^PRC(443.9,0),"^",4)
+35 SET MESSAGE="ARCHIVING IFCAP RECORDS"
SET ITEMS="documents"
+36 USE DEVIO
DO BEGIN^PRCGU
+37 KILL LINE
+38 SET NEXT=0
X FOR
USE MTIO
Begin DoDot:1
+1 FOR ZCOUNT=1:1:5
SET NEXT=$ORDER(^PRC(443.9,"AC",NEXT))
if NEXT=""
QUIT
Begin DoDot:2
+2 SET NEXTDA=0
FOR IXX=0:1
SET NEXTDA=$ORDER(^PRC(443.9,"AC",NEXT,NEXTDA))
if 'NEXTDA
QUIT
Begin DoDot:3
+3 IF "13"'[$PIECE($GET(^PRC(443.9,NEXTDA,0)),"^",2)
QUIT
+4 IF $PIECE($GET(^PRC(442,NEXTDA,0)),"-")'=PRC("SITE")
QUIT
+5 DO DOC^PRCGARC1(NEXTDA)
+6 QUIT
End DoDot:3
+7 QUIT
End DoDot:2
if IXX>1
SET ZCOUNT=ZCOUNT+(IXX-1)
+8 QUIT
End DoDot:1
SET XCOUNT=XCOUNT+ZCOUNT
USE DEVIO
DO PERCENT^PRCGU
if NEXT=""
QUIT
+9 DO END^PRCGU
+10 QUIT
TERM WRITE !,"OPTION TERMINATED",*7
+1 QUIT
