- 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 Jan 18, 2025@03:05:55 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