ENARG21 ;(WIRMFO)/JED/DH/SAB-ARCHIVE WORK ORDERS ;2.25.97
;;7.0;ENGINEERING;**40**;Aug 17, 1993
Q
;
1 ; loop thru found list and move work orders to global
S ENJ=$O(^ENAR(6919.1,ENJ)) Q:ENJ'?1.N
S ENZ=^ENAR(6919.1,ENJ,0)
G 1:'$D(^ENG(6920,ENZ,0))
F ENK=0:1:5 S ENA(ENK)=$G(^ENG(6920,ENZ,ENK)),ENB(ENK)=""
S ENB(0)=ENSTA_"-"_$P(ENA(0),U,1)_U_$P(ENA(0),U,6)
S ENB(0,3)=$P(ENA(1),U) I ENB(0,3)]"" S $P(ENB(0),U,3)=$S($D(^VA(200,ENB(0,3),0)):$P(^(0),U),1:ENB(0,3))
S $P(ENB(1),U,1,4)=$P(ENA(0),U,2,5),$P(ENB(1),U,5,7)=$P(ENA(1),U,2,4),$P(ENB(1),U,8)=$P(ENA(3),U,4),$P(ENB(1),U,9,11)=$P(ENA(2),U,1,3),$P(ENB(1),U,12)=$P(ENA(4),U)
S $P(ENB(2),U,1,3)=$P(ENA(3),U,1,3),$P(ENB(2),U,4,5)=$P(ENA(3),U,6,7),$P(ENB(2),U,6)=$P(ENA(3),U,5),$P(ENB(2),U,7)=$P(ENA(3),U,8)
S $P(ENB(4),U,2)=$P(ENA(5),U,5),$P(ENB(4),U,3)=$P(ENA(4),U,2),$P(ENB(4),U,4,5)=$P(ENA(5),U,3,4),$P(ENB(4),U,6)=$P(ENA(5),U,6),$P(ENB(4),U,7)=$P(ENA(4),U,4),$P(ENB(4),U,8)=$P(ENA(5),U,2)
S ENB(1,3)=$P(ENB(1),U,3) I ENB(1,3)>0,$D(^ENG("SP",ENB(1,3),0)) S $P(ENB(1),U,3)=$P(^(0),U)
S ENB(1,8)=$P(ENB(1),U,8) I ENB(1,8)>0,$D(^DIC(49,ENB(1,8),0)) S $P(ENB(1),U,8)=$P(^(0),U)
S ENB(1,9)=$P(ENB(1),U,9) I ENB(1,9)>0,$D(^DIC(6922,ENB(1,9),0)) S $P(ENB(1),U,9)=$P(^(0),U)
S ENB(1,10)=$P(ENB(1),U,10) I ENB(1,10)>0,$D(^ENG("EMP",ENB(1,10),0)) S $P(ENB(1),U,10)=$P(^(0),U)
S ENB(4,2)=$P(ENB(4),U,2) I ENB(4,2)>0,$D(^DIC(6921,ENB(4,2),0)) S $P(ENB(4),U,2)=$P(^(0),U)
S ENB(4,3)=$P(ENB(4),U,3) I ENB(4,3)>0,$D(^PRCS(410,ENB(4,3),0)) S $P(ENB(4),U,3)=$P(^(0),U)
I $P(ENB(2),U,3)="" S ENB(2,3)=$P(ENA(3),U,9) I ENB(2,3)'="",$D(^ENG("MFG",ENB(2,3),0)) S $P(ENB(2),U,3)=$P(^(0),U)
S ^ENAR(6919.1,"B",$P(ENB(0),U),ENJ)=""
F ENK=0:1:4 S:ENB(ENK)'="" ^ENAR(6919.1,ENJ,ENK)=ENB(ENK)
I $D(^ENG(6920,ENZ,7,0)) S X=^(0),^ENAR(6919.1,ENJ,3,0)="^6919.11A^"_$P(X,U,3,4),ENZ(1)=0 F ENK=1:1 S ENZ(1)=$O(^ENG(6920,ENZ,7,ENZ(1))) Q:ENZ(1)="" S X(ENZ(1))=^(ENZ(1),0) D W S ^ENAR(6919.1,ENJ,3,ENZ(1),0)=X(ENZ(1)) K X
I $D(^ENG(6920,ENZ,8,0)) S X=^(0),^ENAR(6919.1,ENJ,8,0)="^6919.13A^"_$P(X,U,3,4),ENZ(1)=0 F ENK=1:1 S ENZ(1)=$O(^ENG(6920,ENZ,8,ENZ(1))) Q:ENZ(1)="" S X(ENZ(1))=^(ENZ(1),0) D WA S ^ENAR(6919.1,ENJ,8,ENZ(1),0)=X(ENZ(1)) K X
I $D(^ENG(6920,ENZ,6,0)) S X=^(0),^ENAR(6919.1,ENJ,5,0)=X,ENZ(1)=0 F ENK=1:1 S ENZ(1)=$O(^ENG(6920,ENZ,6,ENZ(1))) Q:ENZ(1)="" S X1=^(ENZ(1),0),^ENAR(6919.1,ENJ,5,ENK,0)=X1
S ENSTAT=$P(ENA(4),U,3),^ENAR(6919.1,ENJ,6)=$S(ENSTAT=5:"DISAPPROVED",1:"COMPLETED")_U_$P(ENA(5),U,8)_U_$P(ENA(5),U,7)
;PURGE SYSTEM WORK ORDER
S DIK="^ENG(6920,",DA=ENZ D ^DIK K DIK
S ENI=ENI+1 W:ENI#16=0 "."
G 1
;
W ; expand assigned tech multiple
S X1=$P(X(ENZ(1)),U) I X1'="",$D(^ENG("EMP",X1,0)) S $P(X(ENZ(1)),U)=$P(^(0),U)
S X2=$P(X(ENZ(1)),U,3) I X2'="",$D(^DIC(6922,X2,0)) S $P(X(ENZ(1)),U,3)=$P(^(0),U)
Q
WA ; expand work action multiple
S X1=$P(X(ENZ(1)),U) I X1'="",$D(^ENG(6920.1,X1,0)) S $P(X(ENZ(1)),U)=$P(^(0),U)
Q
;
OUT K EN,ENA,ENB,ENI,ENJ,ENK,ENZ,I,J,K,X,X1,X2,Z,%X,%Y
Q
;ENARG21
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENARG21 3017 printed Dec 13, 2024@01:51:34 Page 2
ENARG21 ;(WIRMFO)/JED/DH/SAB-ARCHIVE WORK ORDERS ;2.25.97
+1 ;;7.0;ENGINEERING;**40**;Aug 17, 1993
+2 QUIT
+3 ;
1 ; loop thru found list and move work orders to global
+1 SET ENJ=$ORDER(^ENAR(6919.1,ENJ))
if ENJ'?1.N
QUIT
+2 SET ENZ=^ENAR(6919.1,ENJ,0)
+3 if '$DATA(^ENG(6920,ENZ,0))
GOTO 1
+4 FOR ENK=0:1:5
SET ENA(ENK)=$GET(^ENG(6920,ENZ,ENK))
SET ENB(ENK)=""
+5 SET ENB(0)=ENSTA_"-"_$PIECE(ENA(0),U,1)_U_$PIECE(ENA(0),U,6)
+6 SET ENB(0,3)=$PIECE(ENA(1),U)
IF ENB(0,3)]""
SET $PIECE(ENB(0),U,3)=$SELECT($DATA(^VA(200,ENB(0,3),0)):$PIECE(^(0),U),1:ENB(0,3))
+7 SET $PIECE(ENB(1),U,1,4)=$PIECE(ENA(0),U,2,5)
SET $PIECE(ENB(1),U,5,7)=$PIECE(ENA(1),U,2,4)
SET $PIECE(ENB(1),U,8)=$PIECE(ENA(3),U,4)
SET $PIECE(ENB(1),U,9,11)=$PIECE(ENA(2),U,1,3)
SET $PIECE(ENB(1),U,12)=$PIECE(ENA(4),U)
+8 SET $PIECE(ENB(2),U,1,3)=$PIECE(ENA(3),U,1,3)
SET $PIECE(ENB(2),U,4,5)=$PIECE(ENA(3),U,6,7)
SET $PIECE(ENB(2),U,6)=$PIECE(ENA(3),U,5)
SET $PIECE(ENB(2),U,7)=$PIECE(ENA(3),U,8)
+9 SET $PIECE(ENB(4),U,2)=$PIECE(ENA(5),U,5)
SET $PIECE(ENB(4),U,3)=$PIECE(ENA(4),U,2)
SET $PIECE(ENB(4),U,4,5)=$PIECE(ENA(5),U,3,4)
SET $PIECE(ENB(4),U,6)=$PIECE(ENA(5),U,6)
SET $PIECE(ENB(4),U,7)=$PIECE(ENA(4),U,4)
SET $PIECE(ENB(4),U,8)=$PIECE(ENA(5),U,2)
+10 SET ENB(1,3)=$PIECE(ENB(1),U,3)
IF ENB(1,3)>0
IF $DATA(^ENG("SP",ENB(1,3),0))
SET $PIECE(ENB(1),U,3)=$PIECE(^(0),U)
+11 SET ENB(1,8)=$PIECE(ENB(1),U,8)
IF ENB(1,8)>0
IF $DATA(^DIC(49,ENB(1,8),0))
SET $PIECE(ENB(1),U,8)=$PIECE(^(0),U)
+12 SET ENB(1,9)=$PIECE(ENB(1),U,9)
IF ENB(1,9)>0
IF $DATA(^DIC(6922,ENB(1,9),0))
SET $PIECE(ENB(1),U,9)=$PIECE(^(0),U)
+13 SET ENB(1,10)=$PIECE(ENB(1),U,10)
IF ENB(1,10)>0
IF $DATA(^ENG("EMP",ENB(1,10),0))
SET $PIECE(ENB(1),U,10)=$PIECE(^(0),U)
+14 SET ENB(4,2)=$PIECE(ENB(4),U,2)
IF ENB(4,2)>0
IF $DATA(^DIC(6921,ENB(4,2),0))
SET $PIECE(ENB(4),U,2)=$PIECE(^(0),U)
+15 SET ENB(4,3)=$PIECE(ENB(4),U,3)
IF ENB(4,3)>0
IF $DATA(^PRCS(410,ENB(4,3),0))
SET $PIECE(ENB(4),U,3)=$PIECE(^(0),U)
+16 IF $PIECE(ENB(2),U,3)=""
SET ENB(2,3)=$PIECE(ENA(3),U,9)
IF ENB(2,3)'=""
IF $DATA(^ENG("MFG",ENB(2,3),0))
SET $PIECE(ENB(2),U,3)=$PIECE(^(0),U)
+17 SET ^ENAR(6919.1,"B",$PIECE(ENB(0),U),ENJ)=""
+18 FOR ENK=0:1:4
if ENB(ENK)'=""
SET ^ENAR(6919.1,ENJ,ENK)=ENB(ENK)
+19 IF $DATA(^ENG(6920,ENZ,7,0))
SET X=^(0)
SET ^ENAR(6919.1,ENJ,3,0)="^6919.11A^"_$PIECE(X,U,3,4)
SET ENZ(1)=0
FOR ENK=1:1
SET ENZ(1)=$ORDER(^ENG(6920,ENZ,7,ENZ(1)))
if ENZ(1)=""
QUIT
SET X(ENZ(1))=^(ENZ(1),0)
DO W
SET ^ENAR(6919.1,ENJ,3,ENZ(1),0)=X(ENZ(1))
KILL X
+20 IF $DATA(^ENG(6920,ENZ,8,0))
SET X=^(0)
SET ^ENAR(6919.1,ENJ,8,0)="^6919.13A^"_$PIECE(X,U,3,4)
SET ENZ(1)=0
FOR ENK=1:1
SET ENZ(1)=$ORDER(^ENG(6920,ENZ,8,ENZ(1)))
if ENZ(1)=""
QUIT
SET X(ENZ(1))=^(ENZ(1),0)
DO WA
SET ^ENAR(6919.1,ENJ,8,ENZ(1),0)=X(ENZ(1))
KILL X
+21 IF $DATA(^ENG(6920,ENZ,6,0))
SET X=^(0)
SET ^ENAR(6919.1,ENJ,5,0)=X
SET ENZ(1)=0
FOR ENK=1:1
SET ENZ(1)=$ORDER(^ENG(6920,ENZ,6,ENZ(1)))
if ENZ(1)=""
QUIT
SET X1=^(ENZ(1),0)
SET ^ENAR(6919.1,ENJ,5,ENK,0)=X1
+22 SET ENSTAT=$PIECE(ENA(4),U,3)
SET ^ENAR(6919.1,ENJ,6)=$SELECT(ENSTAT=5:"DISAPPROVED",1:"COMPLETED")_U_$PIECE(ENA(5),U,8)_U_$PIECE(ENA(5),U,7)
+23 ;PURGE SYSTEM WORK ORDER
+24 SET DIK="^ENG(6920,"
SET DA=ENZ
DO ^DIK
KILL DIK
+25 SET ENI=ENI+1
if ENI#16=0
WRITE "."
+26 GOTO 1
+27 ;
W ; expand assigned tech multiple
+1 SET X1=$PIECE(X(ENZ(1)),U)
IF X1'=""
IF $DATA(^ENG("EMP",X1,0))
SET $PIECE(X(ENZ(1)),U)=$PIECE(^(0),U)
+2 SET X2=$PIECE(X(ENZ(1)),U,3)
IF X2'=""
IF $DATA(^DIC(6922,X2,0))
SET $PIECE(X(ENZ(1)),U,3)=$PIECE(^(0),U)
+3 QUIT
WA ; expand work action multiple
+1 SET X1=$PIECE(X(ENZ(1)),U)
IF X1'=""
IF $DATA(^ENG(6920.1,X1,0))
SET $PIECE(X(ENZ(1)),U)=$PIECE(^(0),U)
+2 QUIT
+3 ;
OUT KILL EN,ENA,ENB,ENI,ENJ,ENK,ENZ,I,J,K,X,X1,X2,Z,%X,%Y
+1 QUIT
+2 ;ENARG21
