- 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
- 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
