ENARG23 ;(WIRMFO)/SAB-ARCHIVE EQUIPMENT INVENTORY ;1/10/2001
;;7.0;ENGINEERING;**40,68**;Aug 17, 1993
Q
3 ; loop thru found list and move equipment inventory to global
; input ENDA (ien of Archive Log entry)
S ENJ=$O(^ENAR(6919.3,ENJ)) Q:ENJ'?1.N
S ENZ=^ENAR(6919.3,ENJ,0)
G 3:'$D(^ENG(6914,ENZ,0))
; node 0
S ENB=$G(^ENG(6914,ENZ,0))
; use station number from equipment record if available
S ENA(0)=$P($G(^ENG(6914,ENZ,9)),U,5)
S ENA=$S(ENA(0)]"":ENA(0),1:ENSTA)_"-"_$P(ENB,U) ; add station #
S $P(ENB,U)=ENA
S ENB(6)=$P(ENB,U,6) I ENB(6)]"" S ENB(6)=$$GET1^DIQ(6914,ENZ,.5) I ENB(6)]"" S $P(ENB,U,6)=ENB(6)
S:ENB]"" ^ENAR(6919.3,ENJ,0)=ENB
S:$P(ENB,U)]"" ^ENAR(6919.3,"B",$P(ENB,U),ENJ)=""
K ENB
; node 1
S ENB=$G(^ENG(6914,ENZ,1))
I $P(ENB,U,5)]"" S $P(ENB,U,5)="" ; don't archive MODEL(C) field
I $P(ENB,U,6)]"" S $P(ENB,U,6)="" ; don't archive SERIAL #(C) field
S ENB(1)=$P(ENB,U,1) I ENB(1)]"" S ENB(1)=$P($G(^ENG(6911,ENB(1),0)),U) I ENB(1)]"" S $P(ENB,U,1)=ENB(1)
S ENB(4)=$P(ENB,U,4) I ENB(4)]"" S ENB(4)=$P($G(^ENG("MFG",ENB(4),0)),U) I ENB(4)]"" S $P(ENB,U,4)=ENB(4)
S:ENB]"" ^ENAR(6919.3,ENJ,1)=ENB
K ENB
; node 2
S ENB=$G(^ENG(6914,ENZ,2))
S ENB(1)=$P(ENB,U,1) I ENB(1)]"" S ENB(1)=$$GET1^DIQ(6914,ENZ,10) I ENB(1)]"" S $P(ENB,U,1)=ENB(1)
S ENB(8)=$P(ENB,U,8) I ENB(8)]"" S ENB(8)=$P($G(^ENCSN(6917,ENB(8),0)),U) I ENB(8)]"" S $P(ENB,U,8)=ENB(8)
S ENB(9)=$P(ENB,U,9) I ENB(9)]"" S ENB(9)=$P($G(^ENG(6914.1,ENB(9),0)),U) I ENB(9)]"" S $P(ENB,U,9)=ENB(9)
S ENB(14)=$P(ENB,U,14) I ENB(14)]"" S ENB(14)=$$GET1^DIQ(6914,ENZ,13.5) I ENB(14)]"" S $P(ENB,U,14)=ENB(14)
S:ENB]"" ^ENAR(6919.3,ENJ,2)=ENB
K ENB
; node 3
S ENB=$G(^ENG(6914,ENZ,3))
S ENB(2)=$P(ENB,U,2) I ENB(2)]"" S ENB(2)=$$GET1^DIQ(6914,ENZ,21) I ENB(2)]"" S $P(ENB,U,2)=ENB(2)
S ENB(5)=$P(ENB,U,5) I ENB(5)]"" S ENB(5)=$P($G(^ENG("SP",ENB(5),0)),U) I ENB(5)]"" S $P(ENB,U,5)=ENB(5)
S ENB(12)=$P(ENB,U,12) I ENB(12)]"" S ENB(12)=$P($G(^ENG(6914.8,ENB(12),0)),U,2) I ENB(12)]"" S $P(ENB,U,12)=ENB(12) ; save disp meth name (not code)
S:ENB]"" ^ENAR(6919.3,ENJ,3)=ENB
K ENB
; node 7
S ENB=$G(^ENG(6914,ENZ,7))
S:ENB]"" ^ENAR(6919.3,ENJ,7)=ENB
K ENB
; node 8
S ENB=$G(^ENG(6914,ENZ,8))
S ENB(4)=$P(ENB,U,4) I ENB(4)]"" S ENB(4)=$$GET1^DIQ(6914,ENZ,36) I ENB(4)]"" S $P(ENB,U,4)=ENB(4)
S ENB(6)=$P(ENB,U,6) I ENB(6)]"" S ENB(6)=$P($G(^ENG(6914.3,ENB(6),0)),U) I ENB(6)]"" S $P(ENB,U,6)=ENB(6)
S:ENB]"" ^ENAR(6919.3,ENJ,8)=ENB
K ENB
; node 9
S ENB=$G(^ENG(6914,ENZ,9))
S ENB(6)=$P(ENB,U,6) I ENB(6)]"" S ENB(6)=$P($G(^ENG(6914.4,ENB(6),0)),U) I ENB(6)]"" S $P(ENB,U,6)=ENB(6)
S ENB(7)=$P(ENB,U,7) I ENB(7)]"" S ENB(7)=$P($G(^ENG(6914.6,ENB(7),0)),U) I ENB(7)]"" S $P(ENB,U,7)=ENB(7)
S ENB(8)=$P(ENB,U,8) I ENB(8)]"" S ENB(8)=$P($G(^ENG(6914.7,ENB(8),0)),U) I ENB(8)]"" S $P(ENB,U,8)=ENB(8)
I $P(ENB,U,10)]"" S $P(ENB,U,10)="" ; don't archive DATE OF FAP CO field
S:ENB]"" ^ENAR(6919.3,ENJ,9)=ENB
K ENB
; responsible shop multiple
I $O(^ENG(6914,ENZ,4,0)) D
. S ^ENAR(6919.3,ENJ,4,0)="^6919.31A^"_$P($G(^ENG(6914,ENZ,4,0)),U,3,4)
. S ENZ(1)=0 F S ENZ(1)=$O(^ENG(6914,ENZ,4,ENZ(1))) Q:'ENZ(1) D
. . S ENB=$G(^ENG(6914,ENZ,4,ENZ(1),0))
. . S ENB(1)=$P(ENB,U,1) I ENB(1)]"" S ENB(1)=$P($G(^DIC(6922,ENB(1),0)),U) I ENB(1)]"" S $P(ENB,U,1)=ENB(1)
. . S ENB(2)=$P(ENB,U,2) I ENB(2)]"" S ENB(2)=$P($G(^ENG("EMP",ENB(2),0)),U) I ENB(2)]"" S $P(ENB,U,2)=ENB(2)
. . S:ENB]"" ^ENAR(6919.3,ENJ,4,ENZ(1),0)=ENB
. . S:$P(ENB,U)]"" ^ENAR(6919.3,ENJ,4,"B",$P(ENB,U),ENZ(1))=""
. . S ENB=$G(^ENG(6914,ENZ,4,ENZ(1),1))
. . S:ENB]"" ^ENAR(6919.3,ENJ,4,ENZ(1),1)=ENB
. . ; frequency multiple
. . I $O(^ENG(6914,ENZ,4,ENZ(1),2,0)) D
. . . S ^ENAR(6919.3,ENJ,4,ENZ(1),2,0)="^6919.313S^"_$P($G(^ENG(6914,ENZ,4,ENZ(1),2,0)),U,3,4)
. . . S ENZ(2)=0
. . . F S ENZ(2)=$O(^ENG(6914,ENZ,4,ENZ(1),2,ENZ(2))) Q:'ENZ(2) D
. . . . S ENB=$G(^ENG(6914,ENZ,4,ENZ(1),2,ENZ(2),0))
. . . . S ENB(5)=$P(ENB,U,5) I ENB(5)]"" S ENB(5)=$P($G(^ENG(6914.2,ENB(5),0)),U) I ENB(5)]"" S $P(ENB,U,5)=ENB(5)
. . . . S:ENB]"" ^ENAR(6919.3,ENJ,4,ENZ(1),2,ENZ(2),0)=ENB
; comments wp
I $O(^ENG(6914,ENZ,5,0)) D
. S ^ENAR(6919.3,ENJ,5,0)=$G(^ENG(6914,ENZ,5,0))
. S ENZ(1)=0 F S ENZ(1)=$O(^ENG(6914,ENZ,5,ENZ(1))) Q:'ENZ(1) D
. . S ^ENAR(6919.3,ENJ,5,ENZ(1),0)=$G(^ENG(6914,ENZ,5,ENZ(1),0))
; equipment history multiple
I $O(^ENG(6914,ENZ,6,0)) D
. S ^ENAR(6919.3,ENJ,6,0)="^6919.33A^"_$P($G(^ENG(6914,ENZ,6,0)),U,3,4)
. S ENZ(1)=0 F S ENZ(1)=$O(^ENG(6914,ENZ,6,ENZ(1))) Q:'ENZ(1) D
. . S ENB=$G(^ENG(6914,ENZ,6,ENZ(1),0))
. . S:ENB]"" ^ENAR(6919.3,ENJ,6,ENZ(1),0)=ENB
; spex wp
I $O(^ENG(6914,ENZ,10,0)) D
. S ^ENAR(6919.3,ENJ,10,0)=$G(^ENG(6914,ENZ,10,0))
. S ENZ(1)=0 F S ENZ(1)=$O(^ENG(6914,ENZ,10,ENZ(1))) Q:'ENZ(1) D
. . S ^ENAR(6919.3,ENJ,10,ENZ(1),0)=$G(^ENG(6914,ENZ,10,ENZ(1),0))
; original bar code id multiple
I $O(^ENG(6914,ENZ,12,0)) D
. S ^ENAR(6919.3,ENJ,12,0)="^6919.35^"_$P($G(^ENG(6914,ENZ,12,0)),U,3,4)
. S ENZ(1)=0 F S ENZ(1)=$O(^ENG(6914,ENZ,12,ENZ(1))) Q:'ENZ(1) D
. . S ENB=$G(^ENG(6914,ENZ,12,ENZ(1),0))
. . S:ENB]"" ^ENAR(6919.3,ENJ,12,ENZ(1),0)=ENB
;
;STORE STN-ENTRY # (ENA) IN ARCHIVE LOG (ENDA) MULTIPLE
I ENDA D
. S X=$G(^ENG(6919,ENDA,3,0))
. I X="" S X="^6919.02"
. S $P(X,U,3)=$P(X,U,3)+1
. S $P(X,U,4)=$P(X,U,4)+1
. S ^ENG(6919,ENDA,3,0)=X
. S ^ENG(6919,ENDA,3,ENJ,0)=ENA
. S ^ENG(6919,"AE",$P(ENA,"-",2),ENDA,ENJ)=""
;
;PURGE SYSTEM EQUIPMENT INV.
; first close any open work orders
S ENTXT(1)="Automatically closed when equipment record was archived."
S DA=0 F S DA=$O(^ENG(6920,"G",ENZ,DA)) Q:'DA I $P($G(^ENG(6920,DA,5)),U,2)="" D
. D WP^DIE(6920,DA_",",40,"A","ENTXT")
. S DIE="^ENG(6920,",DR="36///T;32///^S X=""COMPLETED"""
. D ^DIE
K DIE,DR,ENTXT
; now delete equipment record
S DIK="^ENG(6914,",DA=ENZ D ^DIK K DIK
S ENI=ENI+1 W:ENI#16=0 "."
G 3
;
OUT K EN,ENA,ENB,ENI,ENJ,ENK,ENZ,I,J,K,X,X1,X2,Z,%X,%Y Q
;ENARG23
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENARG23 6031 printed Dec 13, 2024@01:51:36 Page 2
ENARG23 ;(WIRMFO)/SAB-ARCHIVE EQUIPMENT INVENTORY ;1/10/2001
+1 ;;7.0;ENGINEERING;**40,68**;Aug 17, 1993
+2 QUIT
3 ; loop thru found list and move equipment inventory to global
+1 ; input ENDA (ien of Archive Log entry)
+2 SET ENJ=$ORDER(^ENAR(6919.3,ENJ))
if ENJ'?1.N
QUIT
+3 SET ENZ=^ENAR(6919.3,ENJ,0)
+4 if '$DATA(^ENG(6914,ENZ,0))
GOTO 3
+5 ; node 0
+6 SET ENB=$GET(^ENG(6914,ENZ,0))
+7 ; use station number from equipment record if available
+8 SET ENA(0)=$PIECE($GET(^ENG(6914,ENZ,9)),U,5)
+9 ; add station #
SET ENA=$SELECT(ENA(0)]"":ENA(0),1:ENSTA)_"-"_$PIECE(ENB,U)
+10 SET $PIECE(ENB,U)=ENA
+11 SET ENB(6)=$PIECE(ENB,U,6)
IF ENB(6)]""
SET ENB(6)=$$GET1^DIQ(6914,ENZ,.5)
IF ENB(6)]""
SET $PIECE(ENB,U,6)=ENB(6)
+12 if ENB]""
SET ^ENAR(6919.3,ENJ,0)=ENB
+13 if $PIECE(ENB,U)]""
SET ^ENAR(6919.3,"B",$PIECE(ENB,U),ENJ)=""
+14 KILL ENB
+15 ; node 1
+16 SET ENB=$GET(^ENG(6914,ENZ,1))
+17 ; don't archive MODEL(C) field
IF $PIECE(ENB,U,5)]""
SET $PIECE(ENB,U,5)=""
+18 ; don't archive SERIAL #(C) field
IF $PIECE(ENB,U,6)]""
SET $PIECE(ENB,U,6)=""
+19 SET ENB(1)=$PIECE(ENB,U,1)
IF ENB(1)]""
SET ENB(1)=$PIECE($GET(^ENG(6911,ENB(1),0)),U)
IF ENB(1)]""
SET $PIECE(ENB,U,1)=ENB(1)
+20 SET ENB(4)=$PIECE(ENB,U,4)
IF ENB(4)]""
SET ENB(4)=$PIECE($GET(^ENG("MFG",ENB(4),0)),U)
IF ENB(4)]""
SET $PIECE(ENB,U,4)=ENB(4)
+21 if ENB]""
SET ^ENAR(6919.3,ENJ,1)=ENB
+22 KILL ENB
+23 ; node 2
+24 SET ENB=$GET(^ENG(6914,ENZ,2))
+25 SET ENB(1)=$PIECE(ENB,U,1)
IF ENB(1)]""
SET ENB(1)=$$GET1^DIQ(6914,ENZ,10)
IF ENB(1)]""
SET $PIECE(ENB,U,1)=ENB(1)
+26 SET ENB(8)=$PIECE(ENB,U,8)
IF ENB(8)]""
SET ENB(8)=$PIECE($GET(^ENCSN(6917,ENB(8),0)),U)
IF ENB(8)]""
SET $PIECE(ENB,U,8)=ENB(8)
+27 SET ENB(9)=$PIECE(ENB,U,9)
IF ENB(9)]""
SET ENB(9)=$PIECE($GET(^ENG(6914.1,ENB(9),0)),U)
IF ENB(9)]""
SET $PIECE(ENB,U,9)=ENB(9)
+28 SET ENB(14)=$PIECE(ENB,U,14)
IF ENB(14)]""
SET ENB(14)=$$GET1^DIQ(6914,ENZ,13.5)
IF ENB(14)]""
SET $PIECE(ENB,U,14)=ENB(14)
+29 if ENB]""
SET ^ENAR(6919.3,ENJ,2)=ENB
+30 KILL ENB
+31 ; node 3
+32 SET ENB=$GET(^ENG(6914,ENZ,3))
+33 SET ENB(2)=$PIECE(ENB,U,2)
IF ENB(2)]""
SET ENB(2)=$$GET1^DIQ(6914,ENZ,21)
IF ENB(2)]""
SET $PIECE(ENB,U,2)=ENB(2)
+34 SET ENB(5)=$PIECE(ENB,U,5)
IF ENB(5)]""
SET ENB(5)=$PIECE($GET(^ENG("SP",ENB(5),0)),U)
IF ENB(5)]""
SET $PIECE(ENB,U,5)=ENB(5)
+35 ; save disp meth name (not code)
SET ENB(12)=$PIECE(ENB,U,12)
IF ENB(12)]""
SET ENB(12)=$PIECE($GET(^ENG(6914.8,ENB(12),0)),U,2)
IF ENB(12)]""
SET $PIECE(ENB,U,12)=ENB(12)
+36 if ENB]""
SET ^ENAR(6919.3,ENJ,3)=ENB
+37 KILL ENB
+38 ; node 7
+39 SET ENB=$GET(^ENG(6914,ENZ,7))
+40 if ENB]""
SET ^ENAR(6919.3,ENJ,7)=ENB
+41 KILL ENB
+42 ; node 8
+43 SET ENB=$GET(^ENG(6914,ENZ,8))
+44 SET ENB(4)=$PIECE(ENB,U,4)
IF ENB(4)]""
SET ENB(4)=$$GET1^DIQ(6914,ENZ,36)
IF ENB(4)]""
SET $PIECE(ENB,U,4)=ENB(4)
+45 SET ENB(6)=$PIECE(ENB,U,6)
IF ENB(6)]""
SET ENB(6)=$PIECE($GET(^ENG(6914.3,ENB(6),0)),U)
IF ENB(6)]""
SET $PIECE(ENB,U,6)=ENB(6)
+46 if ENB]""
SET ^ENAR(6919.3,ENJ,8)=ENB
+47 KILL ENB
+48 ; node 9
+49 SET ENB=$GET(^ENG(6914,ENZ,9))
+50 SET ENB(6)=$PIECE(ENB,U,6)
IF ENB(6)]""
SET ENB(6)=$PIECE($GET(^ENG(6914.4,ENB(6),0)),U)
IF ENB(6)]""
SET $PIECE(ENB,U,6)=ENB(6)
+51 SET ENB(7)=$PIECE(ENB,U,7)
IF ENB(7)]""
SET ENB(7)=$PIECE($GET(^ENG(6914.6,ENB(7),0)),U)
IF ENB(7)]""
SET $PIECE(ENB,U,7)=ENB(7)
+52 SET ENB(8)=$PIECE(ENB,U,8)
IF ENB(8)]""
SET ENB(8)=$PIECE($GET(^ENG(6914.7,ENB(8),0)),U)
IF ENB(8)]""
SET $PIECE(ENB,U,8)=ENB(8)
+53 ; don't archive DATE OF FAP CO field
IF $PIECE(ENB,U,10)]""
SET $PIECE(ENB,U,10)=""
+54 if ENB]""
SET ^ENAR(6919.3,ENJ,9)=ENB
+55 KILL ENB
+56 ; responsible shop multiple
+57 IF $ORDER(^ENG(6914,ENZ,4,0))
Begin DoDot:1
+58 SET ^ENAR(6919.3,ENJ,4,0)="^6919.31A^"_$PIECE($GET(^ENG(6914,ENZ,4,0)),U,3,4)
+59 SET ENZ(1)=0
FOR
SET ENZ(1)=$ORDER(^ENG(6914,ENZ,4,ENZ(1)))
if 'ENZ(1)
QUIT
Begin DoDot:2
+60 SET ENB=$GET(^ENG(6914,ENZ,4,ENZ(1),0))
+61 SET ENB(1)=$PIECE(ENB,U,1)
IF ENB(1)]""
SET ENB(1)=$PIECE($GET(^DIC(6922,ENB(1),0)),U)
IF ENB(1)]""
SET $PIECE(ENB,U,1)=ENB(1)
+62 SET ENB(2)=$PIECE(ENB,U,2)
IF ENB(2)]""
SET ENB(2)=$PIECE($GET(^ENG("EMP",ENB(2),0)),U)
IF ENB(2)]""
SET $PIECE(ENB,U,2)=ENB(2)
+63 if ENB]""
SET ^ENAR(6919.3,ENJ,4,ENZ(1),0)=ENB
+64 if $PIECE(ENB,U)]""
SET ^ENAR(6919.3,ENJ,4,"B",$PIECE(ENB,U),ENZ(1))=""
+65 SET ENB=$GET(^ENG(6914,ENZ,4,ENZ(1),1))
+66 if ENB]""
SET ^ENAR(6919.3,ENJ,4,ENZ(1),1)=ENB
+67 ; frequency multiple
+68 IF $ORDER(^ENG(6914,ENZ,4,ENZ(1),2,0))
Begin DoDot:3
+69 SET ^ENAR(6919.3,ENJ,4,ENZ(1),2,0)="^6919.313S^"_$PIECE($GET(^ENG(6914,ENZ,4,ENZ(1),2,0)),U,3,4)
+70 SET ENZ(2)=0
+71 FOR
SET ENZ(2)=$ORDER(^ENG(6914,ENZ,4,ENZ(1),2,ENZ(2)))
if 'ENZ(2)
QUIT
Begin DoDot:4
+72 SET ENB=$GET(^ENG(6914,ENZ,4,ENZ(1),2,ENZ(2),0))
+73 SET ENB(5)=$PIECE(ENB,U,5)
IF ENB(5)]""
SET ENB(5)=$PIECE($GET(^ENG(6914.2,ENB(5),0)),U)
IF ENB(5)]""
SET $PIECE(ENB,U,5)=ENB(5)
+74 if ENB]""
SET ^ENAR(6919.3,ENJ,4,ENZ(1),2,ENZ(2),0)=ENB
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+75 ; comments wp
+76 IF $ORDER(^ENG(6914,ENZ,5,0))
Begin DoDot:1
+77 SET ^ENAR(6919.3,ENJ,5,0)=$GET(^ENG(6914,ENZ,5,0))
+78 SET ENZ(1)=0
FOR
SET ENZ(1)=$ORDER(^ENG(6914,ENZ,5,ENZ(1)))
if 'ENZ(1)
QUIT
Begin DoDot:2
+79 SET ^ENAR(6919.3,ENJ,5,ENZ(1),0)=$GET(^ENG(6914,ENZ,5,ENZ(1),0))
End DoDot:2
End DoDot:1
+80 ; equipment history multiple
+81 IF $ORDER(^ENG(6914,ENZ,6,0))
Begin DoDot:1
+82 SET ^ENAR(6919.3,ENJ,6,0)="^6919.33A^"_$PIECE($GET(^ENG(6914,ENZ,6,0)),U,3,4)
+83 SET ENZ(1)=0
FOR
SET ENZ(1)=$ORDER(^ENG(6914,ENZ,6,ENZ(1)))
if 'ENZ(1)
QUIT
Begin DoDot:2
+84 SET ENB=$GET(^ENG(6914,ENZ,6,ENZ(1),0))
+85 if ENB]""
SET ^ENAR(6919.3,ENJ,6,ENZ(1),0)=ENB
End DoDot:2
End DoDot:1
+86 ; spex wp
+87 IF $ORDER(^ENG(6914,ENZ,10,0))
Begin DoDot:1
+88 SET ^ENAR(6919.3,ENJ,10,0)=$GET(^ENG(6914,ENZ,10,0))
+89 SET ENZ(1)=0
FOR
SET ENZ(1)=$ORDER(^ENG(6914,ENZ,10,ENZ(1)))
if 'ENZ(1)
QUIT
Begin DoDot:2
+90 SET ^ENAR(6919.3,ENJ,10,ENZ(1),0)=$GET(^ENG(6914,ENZ,10,ENZ(1),0))
End DoDot:2
End DoDot:1
+91 ; original bar code id multiple
+92 IF $ORDER(^ENG(6914,ENZ,12,0))
Begin DoDot:1
+93 SET ^ENAR(6919.3,ENJ,12,0)="^6919.35^"_$PIECE($GET(^ENG(6914,ENZ,12,0)),U,3,4)
+94 SET ENZ(1)=0
FOR
SET ENZ(1)=$ORDER(^ENG(6914,ENZ,12,ENZ(1)))
if 'ENZ(1)
QUIT
Begin DoDot:2
+95 SET ENB=$GET(^ENG(6914,ENZ,12,ENZ(1),0))
+96 if ENB]""
SET ^ENAR(6919.3,ENJ,12,ENZ(1),0)=ENB
End DoDot:2
End DoDot:1
+97 ;
+98 ;STORE STN-ENTRY # (ENA) IN ARCHIVE LOG (ENDA) MULTIPLE
+99 IF ENDA
Begin DoDot:1
+100 SET X=$GET(^ENG(6919,ENDA,3,0))
+101 IF X=""
SET X="^6919.02"
+102 SET $PIECE(X,U,3)=$PIECE(X,U,3)+1
+103 SET $PIECE(X,U,4)=$PIECE(X,U,4)+1
+104 SET ^ENG(6919,ENDA,3,0)=X
+105 SET ^ENG(6919,ENDA,3,ENJ,0)=ENA
+106 SET ^ENG(6919,"AE",$PIECE(ENA,"-",2),ENDA,ENJ)=""
End DoDot:1
+107 ;
+108 ;PURGE SYSTEM EQUIPMENT INV.
+109 ; first close any open work orders
+110 SET ENTXT(1)="Automatically closed when equipment record was archived."
+111 SET DA=0
FOR
SET DA=$ORDER(^ENG(6920,"G",ENZ,DA))
if 'DA
QUIT
IF $PIECE($GET(^ENG(6920,DA,5)),U,2)=""
Begin DoDot:1
+112 DO WP^DIE(6920,DA_",",40,"A","ENTXT")
+113 SET DIE="^ENG(6920,"
SET DR="36///T;32///^S X=""COMPLETED"""
+114 DO ^DIE
End DoDot:1
+115 KILL DIE,DR,ENTXT
+116 ; now delete equipment record
+117 SET DIK="^ENG(6914,"
SET DA=ENZ
DO ^DIK
KILL DIK
+118 SET ENI=ENI+1
if ENI#16=0
WRITE "."
+119 GOTO 3
+120 ;
OUT KILL EN,ENA,ENB,ENI,ENJ,ENK,ENZ,I,J,K,X,X1,X2,Z,%X,%Y
QUIT
+1 ;ENARG23
