ENAR1 ;(WIRMFO)/JED-ARCHIVE MODULE ;4.22.97
;;7.0;ENGINEERING;**40**;Aug 17, 1993
;EXPECTS VARIABLES ENRT,ENGBL ;CALLED BY ENAR ;CALLS ENJC2,ENJDPL,ENJPARAM,ENARG,ENARGO,ENARGR
Q
;;
G ;GATHER RECORDS
I $D(^ENAR(ENGBL,"LOCK")) S ENERR="An ARCHIVE global exists which has not yet been ARCHIVED." G MSG
D GS G:ENGS="010" G2 D @$S(ENGS="1111":"AD",1:"AD3") G:ENERR'=0 MSG I ENGS="010",$D(ENID) S ENTASK=5,ENDA=$P(ENID,",",4) D UP
G2 D G^ENARG G:ENERR'=0 MSG I $D(^ENAR(ENGBL,-1)) W !!,*7,"Records gathering complete" S ^ENAR(ENGBL,"LOCK")="",ENTASK=2 D UP,OUT Q
S ENERR="DATA NOT ACCEPTED." G MSG
A ;ARCHIVE & VERIFY RECORDS
D GS I ENGS'="1111" W !,"Bad news, Your archive global is not as expected" D MSG1 S ENERR="BAD ARCHIVE GLOBAL" K ^ENAR(ENGBL,"LOCK") G MSG
D C^ENAR2 G:ENERR'=0 MSG S ENTASK=3 D UP,A^ENARGO G:ENERR'=0 MSG
S ENTASK=4 D UP W !!,*7,"verify completed" D OUT Q
D ;DELETE ARCHIVE GLOBAL
I $D(^ENAR(ENGBL,"LOCK")) S ENERR="An ARCHIVE global exists which has not yet been ARCHIVED." G MSG
D GS I ENGS="010" W !!,"Your archive global has been deleted already" D OUT Q
I ENGS="1111" D C^ENAR2 G:ENERR'=0 MSG
D1 I $E(ENGS)=1,'$D(ENDA),$D(@ENID) S ENDA=+$P(^ENAR(ENGBL,-1),",",4)
D11 W !,"OK to delete this global" S %=2 D YN^DICN G:%=0 D11 I %'=1 S ENERR="KEEP ARCHIVE GLOBAL" G MSG
D D2 S ENTASK=5 D:$D(ENDA) UP G:ENERR'=0 MSG
W !!,*7,"Archive global deleted" D OUT Q
D2 S:$E(ENGS)=1 ENID=^ENAR(ENGBL,-1)
S DIU=ENGBL,DIU(0)="" D EN^DIU2 K DIU
K ^ENAR(ENGBL)
S ENFN=$S(ENRT=1:"WO ARCHIVE",ENRT=2:"2162 ACCIDENT ARCHIVE",ENRT=3:"EQUIPMENT INV. ARCHIVE",ENRT=4:"PROJECT ARCHIVE",ENRT=5:"CONTROL POINT ARCHIVE"),^ENAR(ENGBL,0)=ENFN_"^"_ENGBL_"^^" Q
R ;RECALL ARCHIVE INFORMATION
I $D(^ENAR(ENGBL,"LOCK")) S ENERR="An ARCHIVE global exists which has not yet been ARCHIVED." G MSG
D GS I ENGS'="010" D AD I ENERR=0,$D(ENID) S ENTASK=5,ENDA=+$P(ENID,",",4) D UP
I $O(^ENAR(ENGBL,0))>0 S ENFN=$S(ENRT=1:"WO ARCHIVE",ENRT=2:"2162 ACCIDENT ARCHIVE",ENRT=3:"EQUIPMENT INV. ARCHIVE",ENRT=4:"PROJECT ARCHIVE",ENRT=5:"CONTROL POINT ARCHIVE") W !,"There is data in your ",ENFN," file." D R1,AD2
G:ENERR'=0 MSG D R^ENARGR I ENERR'=0 G MSG
S ENTASK=6 D UP W !!,"Recall completed" D OUT Q
R1 W !,"Before recalling more records, you must first delete existing data from",!,"your ",ENFN," file." Q
;;
SID ;SELECT ARCHIVE ID
S DIC="^ENG(6919,",DIC(0)="AEQM",DIC("S")="I $D(^(1)),$P(^(1),""^"",1)=ENRT" D ^DIC S:+Y<0 ENERR="I.D. SELECT" S ENDA=+Y K DIC,Y Q
GS ;GLOBAL STATUS
S ENGS=999 I $D(^ENAR(ENGBL)) S ENGS=$D(^ENAR(ENGBL,-1))_$E($D(^(0)))_$S($O(^ENAR(ENGBL,0))>0:"1",1:"0")
Q
AD ;ARCHIVE DATA INFO
W !!,"There is existing data ready for transport or review"
AD1 W !,"Do you want to see the Archive ID information " S %=1 D YN^DICN I %=-1 S ENERR="ARCHIVE ID ABORT" Q
G AD1:%=0 D ID^ENAR2:%=1
AD2 S ENERR=0 W !!!,"OK to remove archive data " S %=1 D YN^DICN G:%=0 AD2 S:%'=1 ENERR="KILL OLD DATA" D:%=1 D2 Q
AD3 W !,"Note: your archive global is not in order",!,"OK to clean it up" S %=1 D YN^DICN S:%'=1 ENERR="RESET ARCHIVE GLOBAL" D:%=1 D2 Q
UP ;UPDATE ARCHIVAL TRANSACTIONS
I '$D(ENTASK)!(ENTASK<1)!(ENTASK>6) S ENERR="NEED ENTASK" Q
S Z=ENDA,%DT="XT",X="N" D ^%DT S ENTIME=Y I '$D(ENEMP) S ENEMP="PROG.MODE" I $D(DUZ),DUZ>0 S ENEMP=$P($P(^VA(200,DUZ,0),U),",")
I $D(^ENG(6919,Z,2,0))'>0 S ^(0)="^6919.01DA^0^0"
L +^ENG(6919,Z,2,0):60
S ENA=$P(^ENG(6919,Z,2,0),U,1,2),ENNXL=$P(^(0),U,3),ENNXT=$P(^(0),U,4)
UP2 S ENNXL=ENNXL+1 I $D(^ENG(6919,Z,2,ENNXL,0))>0 G UP2
S ENNXT=ENNXT+1,ENOUT=ENA_U_ENNXL_U_ENNXT
S ^ENG(6919,Z,2,0)=ENOUT,^ENG(6919,Z,2,ENNXL,0)=ENTIME_"^"_ENTASK_"^"_ENEMP L -^ENG(6919,Z,2,0)
Q
MSG W @IOF,!!,*7,"Process terminated: ",ENERR
OUT K %,ENA,ENDA,ENEMP,ENFN,ENGL,ENGS,ENID,ENNXL,ENNXT,ENOUT,ENTASK,ENTIME,X,Y,X S ENERR=0
MSG1 W !,"<cr> to continue" R ENR:DTIME Q
;
;ENAR1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENAR1 3887 printed Nov 22, 2024@17:01:39 Page 2
ENAR1 ;(WIRMFO)/JED-ARCHIVE MODULE ;4.22.97
+1 ;;7.0;ENGINEERING;**40**;Aug 17, 1993
+2 ;EXPECTS VARIABLES ENRT,ENGBL ;CALLED BY ENAR ;CALLS ENJC2,ENJDPL,ENJPARAM,ENARG,ENARGO,ENARGR
+3 QUIT
+4 ;;
G ;GATHER RECORDS
+1 IF $DATA(^ENAR(ENGBL,"LOCK"))
SET ENERR="An ARCHIVE global exists which has not yet been ARCHIVED."
GOTO MSG
+2 DO GS
if ENGS="010"
GOTO G2
DO @$SELECT(ENGS="1111":"AD",1:"AD3")
if ENERR'=0
GOTO MSG
IF ENGS="010"
IF $DATA(ENID)
SET ENTASK=5
SET ENDA=$PIECE(ENID,",",4)
DO UP
G2 DO G^ENARG
if ENERR'=0
GOTO MSG
IF $DATA(^ENAR(ENGBL,-1))
WRITE !!,*7,"Records gathering complete"
SET ^ENAR(ENGBL,"LOCK")=""
SET ENTASK=2
DO UP
DO OUT
QUIT
+1 SET ENERR="DATA NOT ACCEPTED."
GOTO MSG
A ;ARCHIVE & VERIFY RECORDS
+1 DO GS
IF ENGS'="1111"
WRITE !,"Bad news, Your archive global is not as expected"
DO MSG1
SET ENERR="BAD ARCHIVE GLOBAL"
KILL ^ENAR(ENGBL,"LOCK")
GOTO MSG
+2 DO C^ENAR2
if ENERR'=0
GOTO MSG
SET ENTASK=3
DO UP
DO A^ENARGO
if ENERR'=0
GOTO MSG
+3 SET ENTASK=4
DO UP
WRITE !!,*7,"verify completed"
DO OUT
QUIT
D ;DELETE ARCHIVE GLOBAL
+1 IF $DATA(^ENAR(ENGBL,"LOCK"))
SET ENERR="An ARCHIVE global exists which has not yet been ARCHIVED."
GOTO MSG
+2 DO GS
IF ENGS="010"
WRITE !!,"Your archive global has been deleted already"
DO OUT
QUIT
+3 IF ENGS="1111"
DO C^ENAR2
if ENERR'=0
GOTO MSG
D1 IF $EXTRACT(ENGS)=1
IF '$DATA(ENDA)
IF $DATA(@ENID)
SET ENDA=+$PIECE(^ENAR(ENGBL,-1),",",4)
D11 WRITE !,"OK to delete this global"
SET %=2
DO YN^DICN
if %=0
GOTO D11
IF %'=1
SET ENERR="KEEP ARCHIVE GLOBAL"
GOTO MSG
+1 DO D2
SET ENTASK=5
if $DATA(ENDA)
DO UP
if ENERR'=0
GOTO MSG
+2 WRITE !!,*7,"Archive global deleted"
DO OUT
QUIT
D2 if $EXTRACT(ENGS)=1
SET ENID=^ENAR(ENGBL,-1)
+1 SET DIU=ENGBL
SET DIU(0)=""
DO EN^DIU2
KILL DIU
+2 KILL ^ENAR(ENGBL)
+3 SET ENFN=$SELECT(ENRT=1:"WO ARCHIVE",ENRT=2:"2162 ACCIDENT ARCHIVE",ENRT=3:"EQUIPMENT INV. ARCHIVE",ENRT=4:"PROJECT ARCHIVE",ENRT=5:"CONTROL POINT ARCHIVE")
SET ^ENAR(ENGBL,0)=ENFN_"^"_ENGBL_"^^"
QUIT
R ;RECALL ARCHIVE INFORMATION
+1 IF $DATA(^ENAR(ENGBL,"LOCK"))
SET ENERR="An ARCHIVE global exists which has not yet been ARCHIVED."
GOTO MSG
+2 DO GS
IF ENGS'="010"
DO AD
IF ENERR=0
IF $DATA(ENID)
SET ENTASK=5
SET ENDA=+$PIECE(ENID,",",4)
DO UP
+3 IF $ORDER(^ENAR(ENGBL,0))>0
SET ENFN=$SELECT(ENRT=1:"WO ARCHIVE",ENRT=2:"2162 ACCIDENT ARCHIVE",ENRT=3:"EQUIPMENT INV. ARCHIVE",ENRT=4:"PROJECT ARCHIVE",ENRT=5:"CONTROL POINT ARCHIVE")
WRITE !,"There is data in your ",ENFN," file."
DO R1
DO AD2
+4 if ENERR'=0
GOTO MSG
DO R^ENARGR
IF ENERR'=0
GOTO MSG
+5 SET ENTASK=6
DO UP
WRITE !!,"Recall completed"
DO OUT
QUIT
R1 WRITE !,"Before recalling more records, you must first delete existing data from",!,"your ",ENFN," file."
QUIT
+1 ;;
SID ;SELECT ARCHIVE ID
+1 SET DIC="^ENG(6919,"
SET DIC(0)="AEQM"
SET DIC("S")="I $D(^(1)),$P(^(1),""^"",1)=ENRT"
DO ^DIC
if +Y<0
SET ENERR="I.D. SELECT"
SET ENDA=+Y
KILL DIC,Y
QUIT
GS ;GLOBAL STATUS
+1 SET ENGS=999
IF $DATA(^ENAR(ENGBL))
SET ENGS=$DATA(^ENAR(ENGBL,-1))_$EXTRACT($DATA(^(0)))_$SELECT($ORDER(^ENAR(ENGBL,0))>0:"1",1:"0")
+2 QUIT
AD ;ARCHIVE DATA INFO
+1 WRITE !!,"There is existing data ready for transport or review"
AD1 WRITE !,"Do you want to see the Archive ID information "
SET %=1
DO YN^DICN
IF %=-1
SET ENERR="ARCHIVE ID ABORT"
QUIT
+1 if %=0
GOTO AD1
if %=1
DO ID^ENAR2
AD2 SET ENERR=0
WRITE !!!,"OK to remove archive data "
SET %=1
DO YN^DICN
if %=0
GOTO AD2
if %'=1
SET ENERR="KILL OLD DATA"
if %=1
DO D2
QUIT
AD3 WRITE !,"Note: your archive global is not in order",!,"OK to clean it up"
SET %=1
DO YN^DICN
if %'=1
SET ENERR="RESET ARCHIVE GLOBAL"
if %=1
DO D2
QUIT
UP ;UPDATE ARCHIVAL TRANSACTIONS
+1 IF '$DATA(ENTASK)!(ENTASK<1)!(ENTASK>6)
SET ENERR="NEED ENTASK"
QUIT
+2 SET Z=ENDA
SET %DT="XT"
SET X="N"
DO ^%DT
SET ENTIME=Y
IF '$DATA(ENEMP)
SET ENEMP="PROG.MODE"
IF $DATA(DUZ)
IF DUZ>0
SET ENEMP=$PIECE($PIECE(^VA(200,DUZ,0),U),",")
+3 IF $DATA(^ENG(6919,Z,2,0))'>0
SET ^(0)="^6919.01DA^0^0"
+4 LOCK +^ENG(6919,Z,2,0):60
+5 SET ENA=$PIECE(^ENG(6919,Z,2,0),U,1,2)
SET ENNXL=$PIECE(^(0),U,3)
SET ENNXT=$PIECE(^(0),U,4)
UP2 SET ENNXL=ENNXL+1
IF $DATA(^ENG(6919,Z,2,ENNXL,0))>0
GOTO UP2
+1 SET ENNXT=ENNXT+1
SET ENOUT=ENA_U_ENNXL_U_ENNXT
+2 SET ^ENG(6919,Z,2,0)=ENOUT
SET ^ENG(6919,Z,2,ENNXL,0)=ENTIME_"^"_ENTASK_"^"_ENEMP
LOCK -^ENG(6919,Z,2,0)
+3 QUIT
MSG WRITE @IOF,!!,*7,"Process terminated: ",ENERR
OUT KILL %,ENA,ENDA,ENEMP,ENFN,ENGL,ENGS,ENID,ENNXL,ENNXT,ENOUT,ENTASK,ENTIME,X,Y,X
SET ENERR=0
MSG1 WRITE !,"<cr> to continue"
READ ENR:DTIME
QUIT
+1 ;
+2 ;ENAR1
