- 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 Mar 13, 2025@20:56:16 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
