source: FOIAVistA/tag/r/CMOP-PSX/PSXARC.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.8 KB
Line 
1PSXARC ;BIR/HTW-CMOP Master Database Archive [ 07/14/97 1:05 PM ]
2 ;;2.0;CMOP;**1,4,46**;11 Apr 97
3BEGDATE ;GET ARCHIVE DATE
4 K ^TMP("PSX",$J) S LEN=8,CT=1
5 S START=$O(^PSX(552.1,"AC",0)),START1=$E(START,1,5),START=$E(START,4,5)_"/"_$E(START,2,3)
6 S TODAY=$E(DT,1,5)
7 I TODAY=START1 W !,"There are no transmissions to be archived.",! G END
8 S DIR("B")=START
9 ;VMP IOFO-BAY PINES;ELR;PSX*2*46 ADDED EMP TO DIR(0)
10 S DIR(0)="DO^::EMP",DIR("A")="ENTER MONTH/YEAR TO "_$S($G(PSXPURGE)=1:"PURGE ",1:"ARCHIVE ") D ^DIR K DIR
11 G:($G(Y)="")!($D(DIRUT)) END
12 Q:$D(DTOUT) I $D(DUOUT) G BEGDATE
13 I $E(Y,4,5)="00" W !!,"You must enter a month",!! D CLEAR G BEGDATE
14 S PSXD=$E(Y,1,5)_"01",PSXBEE=$E(Y,1,5) X ^DD("DD") S PSXB=Y
15 I TODAY=$E(PSXBEE,1,5) W !!,"You may not archive the current month's data.",!! D CLEAR G BEGDATE
16 ;VMP IOFO-BAY PINES;ELR;PSX*2*46 NEW VERIFY QUESTION
17 I $E(PSXBEE,1,5)>TODAY W !!," You may not archive a future month's data",!! D CLEAR G BEGDATE
18 S DIR("A")="ARE YOU SURE YOU WANT TO "_$S($G(PSXPURGE)=1:"PURGE ",1:"ARCHIVE ")_PSXB
19 S DIR(0)="Y",DIR("B")="NO"
20 D ^DIR K DIR
21 G:($G(Y)="")!($D(DIRUT)) END
22 Q:$D(DTOUT) I $D(DUOUT) D CLEAR G BEGDATE
23 I '$G(Y) D CLEAR G BEGDATE
24 ;Print selected transmissions for OK to archive
25 W !?15,"CMOP MASTER DATABASE "_$S($G(PSXPURGE)=1:"PURGE ",1:"ARCHIVE"),!!
26 F S PSXD=$O(^PSX(552.1,"AC",PSXD)) Q:($G(PSXD)']"")!(PSXD'[PSXBEE) D Q:$G(ANS)]""
27 .S BATCH="" F S BATCH=$O(^PSX(552.1,"AC",PSXD,BATCH)) Q:($G(BATCH)']"") D Q:$G(ANS)]""
28 ..S TOTBAT=$G(TOTBAT)+1
29 ..S BAT=$P(BATCH,"-")_$P(BATCH,"-",2),I5521=$O(^PSX(552.1,"AC",PSXD,BATCH,""))
30 ..I '$D(^PSX(552.1,I5521,0)) K ^PSX(552.1,"AC",PSXD,BATCH,I5521) Q
31 ..S TOTORD=$G(TOTORD)+$P(^PSX(552.1,I5521,1),"^",3)
32 ..S TOTRX=$G(TOTRX)+$P(^PSX(552.1,I5521,1),"^",4)
33 ..S I5524=$O(^PSX(552.4,"B",I5521,""))
34 ..I $G(PSXPURGE)=1 S BAT=I5521
35 ..S ^TMP("PSX",$J,BAT)=I5521_"^"_I5524_"^"_BATCH
36 ..S LEN=LEN+$L(BATCH)+1
37 ..I IOST["C-",($Y>20),($X>63) D Q:$G(ANS)]"" W @IOF
38 ...K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or ""^"" to exit" D ^DIR S:$D(DTOUT)!($D(DUOUT)) (ANS)="^"
39 I '$D(^TMP("PSX",$J)) W !!,"No closed transmissions found for the month requested.",!! G BEGDATE
40 W !,"Total transmissions to be ",$S($G(PSXPURGE)=1:"purged : ",1:"archived: "),TOTBAT
41 W !,"Total orders to be ",$S($G(PSXPURGE)=1:"purged : ",1:"archived : "),TOTORD
42 W !,"Total Rx's to be ",$S($G(PSXPURGE)=1:"purged : ",1:"archived : "),TOTRX
43 K ANS,BAT,BATCH,CT,DIR,I,I5521,I5524,LEN,PAD,PSX,PSXB,PSXD,START
44 K TOTBAT,TOTRX,TOTORD,Y
45 W !!
46 S DIR("A")="Do you want to continue? ",DIR("B")="NO"
47 S DIR(0)="SB^Y:YES;N:NO",DIR("?")="Enter Y if you want to "_$S($G(PSXPURGE)=1:"purge",1:"archive")_" the selected transmission data."
48 D ^DIR K DIR G:$D(DIRUT) END G:("Nn"[$E(Y)) END
49 ;Set default values for home device
50 S PSXIOF=IOF,PSXTAPE=PSXBEE_"1"
51 ; Check archive file for duplicate tape #'s
52TAPECK I $O(^PSXARC("C",PSXTAPE,"")) S PSXTAPE=$E(PSXTAPE,1,5)_$E(PSXTAPE,6)+1 G TAPECK
53 I $G(PSXPURGE)=1 G PURGE
54MOUNT I $G(PSXRPT)=1 U IO(0) W !!,"Please mount tape #: ",PSXTNO
55 I W !,"Press Return when ready..." R XX:DTIME I '$T!($G(XX)["^") S PSXERR=1 Q
56 ;
57TAPE W !! S %ZIS("A")="Select Tape Drive: ",%ZIS("B")=""
58 D ^%ZIS K %ZIS("A") I POP S PSXERR=1 G END
59 I IOST'["MAGTAPE" D ^%ZISC W !,"You must select a MAGTAPE device! " G TAPE
60 X ^%ZOSF("MAGTAPE") S PSXT=IO,PSXTBS=IOBS,PSXTIOF=IOF,PSXAM=IOM,PSXTPAR=IOPAR
61 U PSXT X ^%ZOSF("MTONLINE") I $G(Y)'=1 S PSXERR=1 U IO(0) W !,"Tape drive not online. Please correct and try again.",! K PSXT,PSXTBS,PSXTIOF,PSXAM,PSXTPAR,Y G TAPE
62 K PSXERR
63 U PSXT W @%MT("REW")
64 D END Q:$G(PSXRPT)=1 G ^PSXARC1
65END K BAT,BATCH,DA,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,I,I5521,I5524,PAD,PAD1,POP
66 K PSX,PSXB,PSXD,PSXE,PSXEE,START1,TODAY,XX,Y,PSXPURGE
67 Q
68 ;**********************************************************************
69PURGE ; This option purges the data from files 552.1 (CMOP REFERENCE) and
70 ; 552.4 (CMOP MASTER DATABASE). It will only purge those entries
71 ; that have been marked as archived.
72 F Z=0:0 S Z=$O(^TMP("PSX",$J,Z)) Q:'Z S ZZ=^TMP("PSX",$J,Z) D P1
73 D ^%ZISC
74 K I521,I524,I555,PSXBEE,PSXIOF,PSXPURGE,PSXTAPE
75 K ^TMP("PSX",$J),Z,ZX,ZZ
76 G END
77P1 S I521=$P(ZZ,"^"),I524=$P(ZZ,"^",2),BATCH=$P(ZZ,"^",3)
78 I '$G(I524) G K5521
79 I '$D(^PSX(552.4,I524)) G K5521
80 I '$D(^PSX(552.1,I521,"-9")) W !,"Transmission# "_BATCH_" has not been archived yet and may not be purged." Q
81 I $D(^PSX(552.4,I524,"-9")) K ^PSX(552.4,I524,"-9")
82 S DIK="^PSX(552.4,",DA=I524 D ^DIK K DIK
83K5521 I '$G(I521) Q
84 I '$D(^PSX(552.1,I521)) Q
85 K ^PSX(552.1,I521,"-9")
86 S DIK="^PSX(552.1,",DA=I521 D ^DIK K DIK
87 S I555=$O(^PSXARC("B",BATCH,""))
88 S DIE=555,DA=I555,DR="4////1" D ^DIE K DIE,DA,DR
89 W !,"Transmission #: "_BATCH_" has been purged."
90 Q
91PEN S PSXPURGE=1 G PSXARC
92 Q
93 ;VMP IOFO-BAY PINES;ELR;PSX*2*46
94CLEAR K DIR,DIRUT,DTOUT,DUOUT,PSXB,PSXD,PSXBEE,START,START1,TODAY
95 Q
Note: See TracBrowser for help on using the repository browser.