PSXARC ;BIR/HTW-CMOP Master Database Archive [ 07/14/97 1:05 PM ]
;;2.0;CMOP;**1,4,46**;11 Apr 97
BEGDATE ;GET ARCHIVE DATE
K ^TMP("PSX",$J) S LEN=8,CT=1
S START=$O(^PSX(552.1,"AC",0)),START1=$E(START,1,5),START=$E(START,4,5)_"/"_$E(START,2,3)
S TODAY=$E(DT,1,5)
I TODAY=START1 W !,"There are no transmissions to be archived.",! G END
S DIR("B")=START
;VMP IOFO-BAY PINES;ELR;PSX*2*46 ADDED EMP TO DIR(0)
S DIR(0)="DO^::EMP",DIR("A")="ENTER MONTH/YEAR TO "_$S($G(PSXPURGE)=1:"PURGE ",1:"ARCHIVE ") D ^DIR K DIR
G:($G(Y)="")!($D(DIRUT)) END
Q:$D(DTOUT) I $D(DUOUT) G BEGDATE
I $E(Y,4,5)="00" W !!,"You must enter a month",!! D CLEAR G BEGDATE
S PSXD=$E(Y,1,5)_"01",PSXBEE=$E(Y,1,5) X ^DD("DD") S PSXB=Y
I TODAY=$E(PSXBEE,1,5) W !!,"You may not archive the current month's data.",!! D CLEAR G BEGDATE
;VMP IOFO-BAY PINES;ELR;PSX*2*46 NEW VERIFY QUESTION
I $E(PSXBEE,1,5)>TODAY W !!," You may not archive a future month's data",!! D CLEAR G BEGDATE
S DIR("A")="ARE YOU SURE YOU WANT TO "_$S($G(PSXPURGE)=1:"PURGE ",1:"ARCHIVE ")_PSXB
S DIR(0)="Y",DIR("B")="NO"
D ^DIR K DIR
G:($G(Y)="")!($D(DIRUT)) END
Q:$D(DTOUT) I $D(DUOUT) D CLEAR G BEGDATE
I '$G(Y) D CLEAR G BEGDATE
;Print selected transmissions for OK to archive
W !?15,"CMOP MASTER DATABASE "_$S($G(PSXPURGE)=1:"PURGE ",1:"ARCHIVE"),!!
F S PSXD=$O(^PSX(552.1,"AC",PSXD)) Q:($G(PSXD)']"")!(PSXD'[PSXBEE) D Q:$G(ANS)]""
.S BATCH="" F S BATCH=$O(^PSX(552.1,"AC",PSXD,BATCH)) Q:($G(BATCH)']"") D Q:$G(ANS)]""
..S TOTBAT=$G(TOTBAT)+1
..S BAT=$P(BATCH,"-")_$P(BATCH,"-",2),I5521=$O(^PSX(552.1,"AC",PSXD,BATCH,""))
..I '$D(^PSX(552.1,I5521,0)) K ^PSX(552.1,"AC",PSXD,BATCH,I5521) Q
..S TOTORD=$G(TOTORD)+$P(^PSX(552.1,I5521,1),"^",3)
..S TOTRX=$G(TOTRX)+$P(^PSX(552.1,I5521,1),"^",4)
..S I5524=$O(^PSX(552.4,"B",I5521,""))
..I $G(PSXPURGE)=1 S BAT=I5521
..S ^TMP("PSX",$J,BAT)=I5521_"^"_I5524_"^"_BATCH
..S LEN=LEN+$L(BATCH)+1
..I IOST["C-",($Y>20),($X>63) D Q:$G(ANS)]"" W @IOF
...K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or ""^"" to exit" D ^DIR S:$D(DTOUT)!($D(DUOUT)) (ANS)="^"
I '$D(^TMP("PSX",$J)) W !!,"No closed transmissions found for the month requested.",!! G BEGDATE
W !,"Total transmissions to be ",$S($G(PSXPURGE)=1:"purged : ",1:"archived: "),TOTBAT
W !,"Total orders to be ",$S($G(PSXPURGE)=1:"purged : ",1:"archived : "),TOTORD
W !,"Total Rx's to be ",$S($G(PSXPURGE)=1:"purged : ",1:"archived : "),TOTRX
K ANS,BAT,BATCH,CT,DIR,I,I5521,I5524,LEN,PAD,PSX,PSXB,PSXD,START
K TOTBAT,TOTRX,TOTORD,Y
W !!
S DIR("A")="Do you want to continue? ",DIR("B")="NO"
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."
D ^DIR K DIR G:$D(DIRUT) END G:("Nn"[$E(Y)) END
;Set default values for home device
S PSXIOF=IOF,PSXTAPE=PSXBEE_"1"
; Check archive file for duplicate tape #'s
TAPECK I $O(^PSXARC("C",PSXTAPE,"")) S PSXTAPE=$E(PSXTAPE,1,5)_$E(PSXTAPE,6)+1 G TAPECK
I $G(PSXPURGE)=1 G PURGE
MOUNT I $G(PSXRPT)=1 U IO(0) W !!,"Please mount tape #: ",PSXTNO
I W !,"Press Return when ready..." R XX:DTIME I '$T!($G(XX)["^") S PSXERR=1 Q
;
TAPE W !! S %ZIS("A")="Select Tape Drive: ",%ZIS("B")=""
D ^%ZIS K %ZIS("A") I POP S PSXERR=1 G END
I IOST'["MAGTAPE" D ^%ZISC W !,"You must select a MAGTAPE device! " G TAPE
X ^%ZOSF("MAGTAPE") S PSXT=IO,PSXTBS=IOBS,PSXTIOF=IOF,PSXAM=IOM,PSXTPAR=IOPAR
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
K PSXERR
U PSXT W @%MT("REW")
D END Q:$G(PSXRPT)=1 G ^PSXARC1
END K BAT,BATCH,DA,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,I,I5521,I5524,PAD,PAD1,POP
K PSX,PSXB,PSXD,PSXE,PSXEE,START1,TODAY,XX,Y,PSXPURGE
Q
;**********************************************************************
PURGE ; This option purges the data from files 552.1 (CMOP REFERENCE) and
; 552.4 (CMOP MASTER DATABASE). It will only purge those entries
; that have been marked as archived.
F Z=0:0 S Z=$O(^TMP("PSX",$J,Z)) Q:'Z S ZZ=^TMP("PSX",$J,Z) D P1
D ^%ZISC
K I521,I524,I555,PSXBEE,PSXIOF,PSXPURGE,PSXTAPE
K ^TMP("PSX",$J),Z,ZX,ZZ
G END
P1 S I521=$P(ZZ,"^"),I524=$P(ZZ,"^",2),BATCH=$P(ZZ,"^",3)
I '$G(I524) G K5521
I '$D(^PSX(552.4,I524)) G K5521
I '$D(^PSX(552.1,I521,"-9")) W !,"Transmission# "_BATCH_" has not been archived yet and may not be purged." Q
I $D(^PSX(552.4,I524,"-9")) K ^PSX(552.4,I524,"-9")
S DIK="^PSX(552.4,",DA=I524 D ^DIK K DIK
K5521 I '$G(I521) Q
I '$D(^PSX(552.1,I521)) Q
K ^PSX(552.1,I521,"-9")
S DIK="^PSX(552.1,",DA=I521 D ^DIK K DIK
S I555=$O(^PSXARC("B",BATCH,""))
S DIE=555,DA=I555,DR="4////1" D ^DIE K DIE,DA,DR
W !,"Transmission #: "_BATCH_" has been purged."
Q
PEN S PSXPURGE=1 G PSXARC
Q
;VMP IOFO-BAY PINES;ELR;PSX*2*46
CLEAR K DIR,DIRUT,DTOUT,DUOUT,PSXB,PSXD,PSXBEE,START,START1,TODAY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXARC 5011 printed Sep 23, 2025@19:19:19 Page 2
PSXARC ;BIR/HTW-CMOP Master Database Archive [ 07/14/97 1:05 PM ]
+1 ;;2.0;CMOP;**1,4,46**;11 Apr 97
BEGDATE ;GET ARCHIVE DATE
+1 KILL ^TMP("PSX",$JOB)
SET LEN=8
SET CT=1
+2 SET START=$ORDER(^PSX(552.1,"AC",0))
SET START1=$EXTRACT(START,1,5)
SET START=$EXTRACT(START,4,5)_"/"_$EXTRACT(START,2,3)
+3 SET TODAY=$EXTRACT(DT,1,5)
+4 IF TODAY=START1
WRITE !,"There are no transmissions to be archived.",!
GOTO END
+5 SET DIR("B")=START
+6 ;VMP IOFO-BAY PINES;ELR;PSX*2*46 ADDED EMP TO DIR(0)
+7 SET DIR(0)="DO^::EMP"
SET DIR("A")="ENTER MONTH/YEAR TO "_$SELECT($GET(PSXPURGE)=1:"PURGE ",1:"ARCHIVE ")
DO ^DIR
KILL DIR
+8 if ($GET(Y)="")!($DATA(DIRUT))
GOTO END
+9 if $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
GOTO BEGDATE
+10 IF $EXTRACT(Y,4,5)="00"
WRITE !!,"You must enter a month",!!
DO CLEAR
GOTO BEGDATE
+11 SET PSXD=$EXTRACT(Y,1,5)_"01"
SET PSXBEE=$EXTRACT(Y,1,5)
XECUTE ^DD("DD")
SET PSXB=Y
+12 IF TODAY=$EXTRACT(PSXBEE,1,5)
WRITE !!,"You may not archive the current month's data.",!!
DO CLEAR
GOTO BEGDATE
+13 ;VMP IOFO-BAY PINES;ELR;PSX*2*46 NEW VERIFY QUESTION
+14 IF $EXTRACT(PSXBEE,1,5)>TODAY
WRITE !!," You may not archive a future month's data",!!
DO CLEAR
GOTO BEGDATE
+15 SET DIR("A")="ARE YOU SURE YOU WANT TO "_$SELECT($GET(PSXPURGE)=1:"PURGE ",1:"ARCHIVE ")_PSXB
+16 SET DIR(0)="Y"
SET DIR("B")="NO"
+17 DO ^DIR
KILL DIR
+18 if ($GET(Y)="")!($DATA(DIRUT))
GOTO END
+19 if $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
DO CLEAR
GOTO BEGDATE
+20 IF '$GET(Y)
DO CLEAR
GOTO BEGDATE
+21 ;Print selected transmissions for OK to archive
+22 WRITE !?15,"CMOP MASTER DATABASE "_$SELECT($GET(PSXPURGE)=1:"PURGE ",1:"ARCHIVE"),!!
+23 FOR
SET PSXD=$ORDER(^PSX(552.1,"AC",PSXD))
if ($GET(PSXD)']"")!(PSXD'[PSXBEE)
QUIT
Begin DoDot:1
+24 SET BATCH=""
FOR
SET BATCH=$ORDER(^PSX(552.1,"AC",PSXD,BATCH))
if ($GET(BATCH)']"")
QUIT
Begin DoDot:2
+25 SET TOTBAT=$GET(TOTBAT)+1
+26 SET BAT=$PIECE(BATCH,"-")_$PIECE(BATCH,"-",2)
SET I5521=$ORDER(^PSX(552.1,"AC",PSXD,BATCH,""))
+27 IF '$DATA(^PSX(552.1,I5521,0))
KILL ^PSX(552.1,"AC",PSXD,BATCH,I5521)
QUIT
+28 SET TOTORD=$GET(TOTORD)+$PIECE(^PSX(552.1,I5521,1),"^",3)
+29 SET TOTRX=$GET(TOTRX)+$PIECE(^PSX(552.1,I5521,1),"^",4)
+30 SET I5524=$ORDER(^PSX(552.4,"B",I5521,""))
+31 IF $GET(PSXPURGE)=1
SET BAT=I5521
+32 SET ^TMP("PSX",$JOB,BAT)=I5521_"^"_I5524_"^"_BATCH
+33 SET LEN=LEN+$LENGTH(BATCH)+1
+34 IF IOST["C-"
IF ($Y>20)
IF ($X>63)
Begin DoDot:3
+35 KILL DIR
SET DIR(0)="FO"
SET DIR("A")="Press RETURN to continue or ""^"" to exit"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET (ANS)="^"
End DoDot:3
if $GET(ANS)]""
QUIT
WRITE @IOF
End DoDot:2
if $GET(ANS)]""
QUIT
End DoDot:1
if $GET(ANS)]""
QUIT
+36 IF '$DATA(^TMP("PSX",$JOB))
WRITE !!,"No closed transmissions found for the month requested.",!!
GOTO BEGDATE
+37 WRITE !,"Total transmissions to be ",$SELECT($GET(PSXPURGE)=1:"purged : ",1:"archived: "),TOTBAT
+38 WRITE !,"Total orders to be ",$SELECT($GET(PSXPURGE)=1:"purged : ",1:"archived : "),TOTORD
+39 WRITE !,"Total Rx's to be ",$SELECT($GET(PSXPURGE)=1:"purged : ",1:"archived : "),TOTRX
+40 KILL ANS,BAT,BATCH,CT,DIR,I,I5521,I5524,LEN,PAD,PSX,PSXB,PSXD,START
+41 KILL TOTBAT,TOTRX,TOTORD,Y
+42 WRITE !!
+43 SET DIR("A")="Do you want to continue? "
SET DIR("B")="NO"
+44 SET DIR(0)="SB^Y:YES;N:NO"
SET DIR("?")="Enter Y if you want to "_$SELECT($GET(PSXPURGE)=1:"purge",1:"archive")_" the selected transmission data."
+45 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
if ("Nn"[$EXTRACT(Y))
GOTO END
+46 ;Set default values for home device
+47 SET PSXIOF=IOF
SET PSXTAPE=PSXBEE_"1"
+48 ; Check archive file for duplicate tape #'s
TAPECK IF $ORDER(^PSXARC("C",PSXTAPE,""))
SET PSXTAPE=$EXTRACT(PSXTAPE,1,5)_$EXTRACT(PSXTAPE,6)+1
GOTO TAPECK
+1 IF $GET(PSXPURGE)=1
GOTO PURGE
MOUNT IF $GET(PSXRPT)=1
USE IO(0)
WRITE !!,"Please mount tape #: ",PSXTNO
+1 IF $TEST
WRITE !,"Press Return when ready..."
READ XX:DTIME
IF '$TEST!($GET(XX)["^")
SET PSXERR=1
QUIT
+2 ;
TAPE WRITE !!
SET %ZIS("A")="Select Tape Drive: "
SET %ZIS("B")=""
+1 DO ^%ZIS
KILL %ZIS("A")
IF POP
SET PSXERR=1
GOTO END
+2 IF IOST'["MAGTAPE"
DO ^%ZISC
WRITE !,"You must select a MAGTAPE device! "
GOTO TAPE
+3 XECUTE ^%ZOSF("MAGTAPE")
SET PSXT=IO
SET PSXTBS=IOBS
SET PSXTIOF=IOF
SET PSXAM=IOM
SET PSXTPAR=IOPAR
+4 USE PSXT
XECUTE ^%ZOSF("MTONLINE")
IF $GET(Y)'=1
SET PSXERR=1
USE IO(0)
WRITE !,"Tape drive not online. Please correct and try again.",!
KILL PSXT,PSXTBS,PSXTIOF,PSXAM,PSXTPAR,Y
GOTO TAPE
+5 KILL PSXERR
+6 USE PSXT
WRITE @%MT("REW")
+7 DO END
if $GET(PSXRPT)=1
QUIT
GOTO ^PSXARC1
END KILL BAT,BATCH,DA,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,I,I5521,I5524,PAD,PAD1,POP
+1 KILL PSX,PSXB,PSXD,PSXE,PSXEE,START1,TODAY,XX,Y,PSXPURGE
+2 QUIT
+3 ;**********************************************************************
PURGE ; This option purges the data from files 552.1 (CMOP REFERENCE) and
+1 ; 552.4 (CMOP MASTER DATABASE). It will only purge those entries
+2 ; that have been marked as archived.
+3 FOR Z=0:0
SET Z=$ORDER(^TMP("PSX",$JOB,Z))
if 'Z
QUIT
SET ZZ=^TMP("PSX",$JOB,Z)
DO P1
+4 DO ^%ZISC
+5 KILL I521,I524,I555,PSXBEE,PSXIOF,PSXPURGE,PSXTAPE
+6 KILL ^TMP("PSX",$JOB),Z,ZX,ZZ
+7 GOTO END
P1 SET I521=$PIECE(ZZ,"^")
SET I524=$PIECE(ZZ,"^",2)
SET BATCH=$PIECE(ZZ,"^",3)
+1 IF '$GET(I524)
GOTO K5521
+2 IF '$DATA(^PSX(552.4,I524))
GOTO K5521
+3 IF '$DATA(^PSX(552.1,I521,"-9"))
WRITE !,"Transmission# "_BATCH_" has not been archived yet and may not be purged."
QUIT
+4 IF $DATA(^PSX(552.4,I524,"-9"))
KILL ^PSX(552.4,I524,"-9")
+5 SET DIK="^PSX(552.4,"
SET DA=I524
DO ^DIK
KILL DIK
K5521 IF '$GET(I521)
QUIT
+1 IF '$DATA(^PSX(552.1,I521))
QUIT
+2 KILL ^PSX(552.1,I521,"-9")
+3 SET DIK="^PSX(552.1,"
SET DA=I521
DO ^DIK
KILL DIK
+4 SET I555=$ORDER(^PSXARC("B",BATCH,""))
+5 SET DIE=555
SET DA=I555
SET DR="4////1"
DO ^DIE
KILL DIE,DA,DR
+6 WRITE !,"Transmission #: "_BATCH_" has been purged."
+7 QUIT
PEN SET PSXPURGE=1
GOTO PSXARC
+1 QUIT
+2 ;VMP IOFO-BAY PINES;ELR;PSX*2*46
CLEAR KILL DIR,DIRUT,DTOUT,DUOUT,PSXB,PSXD,PSXBEE,START,START1,TODAY
+1 QUIT
