ENETRAN2 ;(WIRMFO)/DH-Transfer Electronic Work Orders ;5/8/1998
;;7.0;ENGINEERING;**35,53**;Aug 17, 1993
;Expects DA
EN S ENXP=1 D D^ENWOD K ENXP W !!,"Ready to transfer ",$P(^ENG(6920,DA,0),U,1) I $D(^(1)) W ?35,$P(^(1),U,2)
LOCK L +^ENG(6920,DA):5 I '$T W !,*7,"Sorry, this Work Order is being edited by another user. Try later." G ABORT
S DIC="^DIC(6922,",DIC(0)="AEMQ"
S DIC("A")="Transfer to shop ('^'to EXIT, '^D' to DISAPPROVE): "
S DIC("W")="W ?60,Y"
S:$D(ENEWKEY) DIC("B")=ENEWKEY
; set screen to prevent selection of current shop
I $P($G(^ENG(6920,DA,2)),U)]"" S DIC("S")="I Y'="_$P(^ENG(6920,DA,2),U)
D ^DIC K DIC("A"),DIC("B"),DIC("S")
G:X="^D" DISAP G:+Y'>0 ABORT S ENEWKEY=+Y
GETNO I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
N CODE,NUMBER
S CODE=$P(^DIC(6922,ENEWKEY,0),U,2)_$E(DT,2,7)_"-"
L +^ENG(6920,"B"):20 I '$T W !!,*7,"Can't get a new number." G ABORT
F I=1:1 S X=CODE_$S(I<10:"00"_I,I<100:"0"_I,1:I) I '$D(^ENG(6920,"B",X)),'$D(^ENG(6920,"H",X)) S NUMBER=X Q
S DIE="^ENG(6920,",DR="9///"_ENEWKEY_";.01///"_NUMBER_";10///TODAY"
D ^DIE
L -^ENG(6920,"B")
I ENERN'="ALL" K ^TMP($J,"ENEWO",ENERN),^TMP($J,DA) S ENCNT=ENCNT-1
S DR=$S($D(^DIE("B","ENZWOWARDXFER")):"[ENZ",1:"[EN")_"WOWARDXFER]"
EDIT W !!,"Edit this work order" S %=1 D YN^DICN G:%<1 EDIT
I %=1 D ^DIE
I "^^2^"[(U_$P($G(^ENG(6920,DA,4)),U,3)_U) S DR="32///IN PROGRESS" D ^DIE ; set status to 'in progress' when blank or 'pending' (may result in bulletin)
PRINT N WARD,SHOPKEY S WARD=0,SHOPKEY=ENEWKEY
D WOPRNT^ENWONEW
G EXIT
;
DISAP S DIE="^ENG(6920," D EN1^ENWO2 K ^TMP($J,"ENEWO",ENERN),^TMP($J,DA) S ENCNT=ENCNT-1
G EXIT
;
ABORT W !,*7,"Transfer aborted."
W !!,"Press <RETURN> to continue, '^' to escape... " R X:DTIME
S:$E(X)="^" ENEX4=1
EXIT ;Return to ENETRAN1
L -^ENG(6920,DA)
Q
;ENETRAN2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENETRAN2 1844 printed Dec 13, 2024@01:53:11 Page 2
ENETRAN2 ;(WIRMFO)/DH-Transfer Electronic Work Orders ;5/8/1998
+1 ;;7.0;ENGINEERING;**35,53**;Aug 17, 1993
+2 ;Expects DA
EN SET ENXP=1
DO D^ENWOD
KILL ENXP
WRITE !!,"Ready to transfer ",$PIECE(^ENG(6920,DA,0),U,1)
IF $DATA(^(1))
WRITE ?35,$PIECE(^(1),U,2)
LOCK LOCK +^ENG(6920,DA):5
IF '$TEST
WRITE !,*7,"Sorry, this Work Order is being edited by another user. Try later."
GOTO ABORT
+1 SET DIC="^DIC(6922,"
SET DIC(0)="AEMQ"
+2 SET DIC("A")="Transfer to shop ('^'to EXIT, '^D' to DISAPPROVE): "
+3 SET DIC("W")="W ?60,Y"
+4 if $DATA(ENEWKEY)
SET DIC("B")=ENEWKEY
+5 ; set screen to prevent selection of current shop
+6 IF $PIECE($GET(^ENG(6920,DA,2)),U)]""
SET DIC("S")="I Y'="_$PIECE(^ENG(6920,DA,2),U)
+7 DO ^DIC
KILL DIC("A"),DIC("B"),DIC("S")
+8 if X="^D"
GOTO DISAP
if +Y'>0
GOTO ABORT
SET ENEWKEY=+Y
GETNO IF '$DATA(DT)
SET %DT=""
SET X="T"
DO ^%DT
SET DT=Y
+1 NEW CODE,NUMBER
+2 SET CODE=$PIECE(^DIC(6922,ENEWKEY,0),U,2)_$EXTRACT(DT,2,7)_"-"
+3 LOCK +^ENG(6920,"B"):20
IF '$TEST
WRITE !!,*7,"Can't get a new number."
GOTO ABORT
+4 FOR I=1:1
SET X=CODE_$SELECT(I<10:"00"_I,I<100:"0"_I,1:I)
IF '$DATA(^ENG(6920,"B",X))
IF '$DATA(^ENG(6920,"H",X))
SET NUMBER=X
QUIT
+5 SET DIE="^ENG(6920,"
SET DR="9///"_ENEWKEY_";.01///"_NUMBER_";10///TODAY"
+6 DO ^DIE
+7 LOCK -^ENG(6920,"B")
+8 IF ENERN'="ALL"
KILL ^TMP($JOB,"ENEWO",ENERN),^TMP($JOB,DA)
SET ENCNT=ENCNT-1
+9 SET DR=$SELECT($DATA(^DIE("B","ENZWOWARDXFER")):"[ENZ",1:"[EN")_"WOWARDXFER]"
EDIT WRITE !!,"Edit this work order"
SET %=1
DO YN^DICN
if %<1
GOTO EDIT
+1 IF %=1
DO ^DIE
+2 ; set status to 'in progress' when blank or 'pending' (may result in bulletin)
IF "^^2^"[(U_$PIECE($GET(^ENG(6920,DA,4)),U,3)_U)
SET DR="32///IN PROGRESS"
DO ^DIE
PRINT NEW WARD,SHOPKEY
SET WARD=0
SET SHOPKEY=ENEWKEY
+1 DO WOPRNT^ENWONEW
+2 GOTO EXIT
+3 ;
DISAP SET DIE="^ENG(6920,"
DO EN1^ENWO2
KILL ^TMP($JOB,"ENEWO",ENERN),^TMP($JOB,DA)
SET ENCNT=ENCNT-1
+1 GOTO EXIT
+2 ;
ABORT WRITE !,*7,"Transfer aborted."
+1 WRITE !!,"Press <RETURN> to continue, '^' to escape... "
READ X:DTIME
+2 if $EXTRACT(X)="^"
SET ENEX4=1
EXIT ;Return to ENETRAN1
+1 LOCK -^ENG(6920,DA)
+2 QUIT
+3 ;ENETRAN2
