ENEQPMR3 ;(WCIOFO)/DH-Rapid Close Out ;11/9/1998
;;7.0;ENGINEERING;**15,35,43,47,59**;Aug 17, 1993
;
RCO6 I $D(^ENG("TMP",ENPMWO("P"))) G RCO61
W !!,"You have not identified any PM work orders as exceptions to Rapid Close Out.",!,"At this point, the entire PM worklist will be closed out"
W:ENDEL="Y" ", and the work orders",!,"deleted." W:ENDEL'="Y" "." G RCO7
RCO61 W @IOF,"The following work orders will be unaffected by Rapid Close Out:" S ENY=2,I=0 F K=0:0 S I=$O(^ENG("TMP",ENPMWO("P"),I)) Q:I="" D WRIT
W !,"All other work orders on the ",$S(ENPM="M":"MONTHLY",ENPM["W":"WEEKLY",1:"")," PM list for the ",ENSHOP,!,"Shop for ",$P("JANUARY^FEBRUARY^MARCH^APRIL^MAY^JUNE^JULY^AUGUST^SEPTEMBER^OCTOBER^NOVEMBER^DECEMBER","^",ENPMMN)
W ", "_ENPMYR_$E(ENPMDT,1,2)_$S(ENPM["W":" Week("_ENPMWK_")",1:"")_" are subject to Rapid Close Out."
;
RCO7 S ENFR="",ENTO="ZZ",ENTO("L")=20
W !!,"Would you like to specify starting and stopping points for",!,"Rapid Close Out" S %=2 D YN^DICN G:%<0 ABORT G:%=2 RCO71 I %=0 D RCO7H G RCO7
S J=$O(^ENG(6920,"B",ENPMWO("P"))) G:J'[ENPMWO("P") OUT
RCO701 W !!,"Please enter the starting work order (or the sequential portion thereof)",!,"(ex: '"_J_"' or just '"_+$P(J,"-",3)_"'): "
R X:DTIME G:'$T!($E(X)="^")!(X="") RCO7
S:X?1.2N X=$S(X?1N:"00"_X,1:"0"_X) I X?.N S X=ENPMWO("P")_X
I '$D(^ENG(6920,"B",X)) W !,?5,X_" is not an existing work order. Please try again." G RCO701
S DIC="^ENG(6920,",DIC("S")="I $P(^(0),U,1)[ENPMWO(""P"")",DIC(0)="X" D ^DIC K DIC("S") G:Y'>0 RCO7 S ENFR=$P(Y,U,2) W " ("_ENFR_")"
S ENFR(0)=$O(^ENG(6920,"B",ENFR),-1) S ENFR=$S(ENFR(0)[ENPMWO("P"):ENFR(0),1:ENPMWO("P")_"000")
RCO702 W !!,"Now enter the last work order to be closed (or sequential portion thereof)"
S J=$O(^ENG(6920,"B",ENPMWO("P")_9999),-1)
W !,"(ex: '"_J_"' or just '"_+$P(J,"-",3)_"'): "
R X:DTIME G:'$T!(X="")!($E(X)="^") RCO7
S:X?1.2N X=$S(X?1N:"00"_X,1:"0"_X) I X?.N S X=ENPMWO("P")_X
S X1=$O(^ENG(6920,"B",X,0)) I X1'>0 W !,?5,X_" is not an existing work order. Please try again." G RCO702
I $P($P($G(^ENG(6920,X1,0)),U),"-",3)<$P(ENFR,"-",3) W !,?5,X_" does not follow "_ENFR_"." G RCO702
S DIC("S")="I $P(^(0),U)[ENPMWO(""P""),(+$P($P(^(0),U),""-"",3)>+$P(ENFR,""-"",3))"
D ^DIC K DIC("S") G:Y'>0 RCO7 S ENTO=$P(Y,U,2),ENTO("L")=$L(ENTO) W " ("_ENTO_")"
;
RCO71 K DIC("S"),DIC("A") S DIE="^ENG(6920,",DR="35.2///P;36///^S X=ENCDATE;32///^S X=""COMPLETED"""
W !,"Would you like to free up this terminal" S %=1 D YN^DICN G:%=1 RCO8 I %'=2 G OUT
W !!,"Rapid close out now in progress "
S ENPMWO=$S(ENFR]"":ENFR,1:ENPMWO("P")_"-000")
F ENK=0:0 S ENPMWO=$O(^ENG(6920,"B",ENPMWO)) Q:ENPMWO'[ENPMWO("P")!(ENPMWO]ENTO) I '$D(^ENG("TMP",ENPMWO("P"),ENPMWO)),($L(ENPMWO)'>ENTO("L")) D
. W "." S DA=$O(^ENG(6920,"B",ENPMWO,0)) D POST
. I ENDEL="Y" D DEL
K ^ENG("TMP",ENPMWO("P"))
G OUT
;
RCO8 S ZTDTH=$H,ZTRTN="RCO9^ENEQPMR3",ZTSAVE("EN*")="",ZTSAVE("PMTECH(")="",ZTSAVE("DIE")="",ZTSAVE("DR")="",ZTIO="",ZTDESC="Rapid Close Out (PMI)" D ^%ZTLOAD K ZTSK D ^%ZISC,HOME^%ZIS G OUT
;
RCO9 S ENPMWO=$S(ENFR]"":ENFR,1:ENPMWO("P")_"-000")
F ENK=0:0 S ENPMWO=$O(^ENG(6920,"B",ENPMWO)) Q:ENPMWO'[ENPMWO("P")!(ENPMWO]ENTO) I '$D(^ENG("TMP",ENPMWO("P"),ENPMWO)),($L(ENPMWO)'>ENTO("L")) D
. S DA=$O(^ENG(6920,"B",ENPMWO,0)) D POST
. I ENDEL="Y" D DEL
K ^ENG("TMP",ENPMWO("P"))
;
OUT L -^ENG("PMLIST",ENPMWO("P"))
K EN,ENPMWO,ENK,ENDATE,ENDEL,ENPM,ENPMYR,ENPMMN,ENPMWK,ENSHABR
K ENSHOP,ENY,DA,DR,DIE,DIC,DIK,EN1
K ENFR,ENTO S:$D(ZTQUEUED) ZTREQ="@"
I $D(PMTOT) D COUNT^ENBCPM8
K ENPMDT,ENSHKEY
K:$D(ZTQUEUED) PMTECH
Q
;
WRIT D:ENY>(IOSL-2) HLD W !,?10,I S ENY=ENY+1
Q
;
HLD I $E(IOST,1,2)="C-" R !,"Press <RETURN> to continue...",X:DTIME
S ENY=1 W @IOF
Q
;
POST I $D(^ENG(6920,DA,5)),$P(^(5),U,2)]"" Q
;
; if tech substitution list exists
I $O(PMTECH(0)) D
. N I,CTECH,STECH
. ; loop thru assigned tech multiple of work order (DA)
. S I=0 F S I=$O(^ENG(6920,DA,7,I)) Q:'I D
. . S CTECH=$P($G(^ENG(6920,DA,7,I,0)),U) ; current tech
. . S STECH=$$SUBTEC(CTECH) ; determine substitute (if any)
. . I STECH D CHGTEC(DA,I,STECH) ; make change
;
D ^DIE,PMINV^ENEQPMR4
I $D(DA),$D(^ENG(6920,DA,2)),$P(^(2),U,2)]"" D PMHRS^ENEQPMR4
Q
;
DEL I $E(^ENG(6920,DA,0),1,3)="PM-" S DIK="^ENG(6920," D ^DIK K DIK
Q
;
RCO7H W !!,"If you want to close out only a portion of a PM worklist, you may specify the",!,"first and last work orders that you want Rapid Close Out to operate on."
W !,"NOTE: Rapid Close Out will close the first and the last and everything",!," in between."
Q
ABORT ;Forget it
K ^ENG("TMP",ENPMWO("P"))
G OUT
;
SUBTEC(TEC) ; return substitute tech
; input
; TEC = input tech (internal value)
; PMTECH( = substitution list array
; returns ien of tech to be substituted for the input tech or 0 if none
N I,RET
; loop thru PMTECH( array
S RET=0 ; assume no substitute
I TEC S I=0 F S I=$O(PMTECH(I)) Q:I'>0 D Q:RET
. I PMTECH(I,0)=TEC S RET=PMTECH(I,1) ; substitute found
Q RET
;
CHGTEC(WOIEN,ATIEN,TEC) ; change tech in assigned tech multiple
; input
; WOIEN - work order ien
; ATIEN - assigned tech multiple ien
; TEC - new tech (internal value)
N DA,DIE,DR
S DA=ATIEN
S DA(1)=WOIEN
S DIE="^ENG(6920,"_DA(1)_",7,"
S DR=".01////^S X="_TEC
D ^DIE
Q
;ENEQPMR3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENEQPMR3 5415 printed Dec 13, 2024@01:52:48 Page 2
ENEQPMR3 ;(WCIOFO)/DH-Rapid Close Out ;11/9/1998
+1 ;;7.0;ENGINEERING;**15,35,43,47,59**;Aug 17, 1993
+2 ;
RCO6 IF $DATA(^ENG("TMP",ENPMWO("P")))
GOTO RCO61
+1 WRITE !!,"You have not identified any PM work orders as exceptions to Rapid Close Out.",!,"At this point, the entire PM worklist will be closed out"
+2 if ENDEL="Y"
WRITE ", and the work orders",!,"deleted."
if ENDEL'="Y"
WRITE "."
GOTO RCO7
RCO61 WRITE @IOF,"The following work orders will be unaffected by Rapid Close Out:"
SET ENY=2
SET I=0
FOR K=0:0
SET I=$ORDER(^ENG("TMP",ENPMWO("P"),I))
if I=""
QUIT
DO WRIT
+1 WRITE !,"All other work orders on the ",$SELECT(ENPM="M":"MONTHLY",ENPM["W":"WEEKLY",1:"")," PM list for the ",ENSHOP,!,"Shop for ",$PIECE("JANUARY^FEBRUARY^MARCH^APRIL^MAY^JUNE^JULY^AUGUST^SEPTEMBER^OCTOBER^NOVEMBER^DECEMBER","^",ENPMMN)
+2 WRITE ", "_ENPMYR_$EXTRACT(ENPMDT,1,2)_$SELECT(ENPM["W":" Week("_ENPMWK_")",1:"")_" are subject to Rapid Close Out."
+3 ;
RCO7 SET ENFR=""
SET ENTO="ZZ"
SET ENTO("L")=20
+1 WRITE !!,"Would you like to specify starting and stopping points for",!,"Rapid Close Out"
SET %=2
DO YN^DICN
if %<0
GOTO ABORT
if %=2
GOTO RCO71
IF %=0
DO RCO7H
GOTO RCO7
+2 SET J=$ORDER(^ENG(6920,"B",ENPMWO("P")))
if J'[ENPMWO("P")
GOTO OUT
RCO701 WRITE !!,"Please enter the starting work order (or the sequential portion thereof)",!,"(ex: '"_J_"' or just '"_+$PIECE(J,"-",3)_"'): "
+1 READ X:DTIME
if '$TEST!($EXTRACT(X)="^")!(X="")
GOTO RCO7
+2 if X?1.2N
SET X=$SELECT(X?1N:"00"_X,1:"0"_X)
IF X?.N
SET X=ENPMWO("P")_X
+3 IF '$DATA(^ENG(6920,"B",X))
WRITE !,?5,X_" is not an existing work order. Please try again."
GOTO RCO701
+4 SET DIC="^ENG(6920,"
SET DIC("S")="I $P(^(0),U,1)[ENPMWO(""P"")"
SET DIC(0)="X"
DO ^DIC
KILL DIC("S")
if Y'>0
GOTO RCO7
SET ENFR=$PIECE(Y,U,2)
WRITE " ("_ENFR_")"
+5 SET ENFR(0)=$ORDER(^ENG(6920,"B",ENFR),-1)
SET ENFR=$SELECT(ENFR(0)[ENPMWO("P"):ENFR(0),1:ENPMWO("P")_"000")
RCO702 WRITE !!,"Now enter the last work order to be closed (or sequential portion thereof)"
+1 SET J=$ORDER(^ENG(6920,"B",ENPMWO("P")_9999),-1)
+2 WRITE !,"(ex: '"_J_"' or just '"_+$PIECE(J,"-",3)_"'): "
+3 READ X:DTIME
if '$TEST!(X="")!($EXTRACT(X)="^")
GOTO RCO7
+4 if X?1.2N
SET X=$SELECT(X?1N:"00"_X,1:"0"_X)
IF X?.N
SET X=ENPMWO("P")_X
+5 SET X1=$ORDER(^ENG(6920,"B",X,0))
IF X1'>0
WRITE !,?5,X_" is not an existing work order. Please try again."
GOTO RCO702
+6 IF $PIECE($PIECE($GET(^ENG(6920,X1,0)),U),"-",3)<$PIECE(ENFR,"-",3)
WRITE !,?5,X_" does not follow "_ENFR_"."
GOTO RCO702
+7 SET DIC("S")="I $P(^(0),U)[ENPMWO(""P""),(+$P($P(^(0),U),""-"",3)>+$P(ENFR,""-"",3))"
+8 DO ^DIC
KILL DIC("S")
if Y'>0
GOTO RCO7
SET ENTO=$PIECE(Y,U,2)
SET ENTO("L")=$LENGTH(ENTO)
WRITE " ("_ENTO_")"
+9 ;
RCO71 KILL DIC("S"),DIC("A")
SET DIE="^ENG(6920,"
SET DR="35.2///P;36///^S X=ENCDATE;32///^S X=""COMPLETED"""
+1 WRITE !,"Would you like to free up this terminal"
SET %=1
DO YN^DICN
if %=1
GOTO RCO8
IF %'=2
GOTO OUT
+2 WRITE !!,"Rapid close out now in progress "
+3 SET ENPMWO=$SELECT(ENFR]"":ENFR,1:ENPMWO("P")_"-000")
+4 FOR ENK=0:0
SET ENPMWO=$ORDER(^ENG(6920,"B",ENPMWO))
if ENPMWO'[ENPMWO("P")!(ENPMWO]ENTO)
QUIT
IF '$DATA(^ENG("TMP",ENPMWO("P"),ENPMWO))
IF ($LENGTH(ENPMWO)'>ENTO("L"))
Begin DoDot:1
+5 WRITE "."
SET DA=$ORDER(^ENG(6920,"B",ENPMWO,0))
DO POST
+6 IF ENDEL="Y"
DO DEL
End DoDot:1
+7 KILL ^ENG("TMP",ENPMWO("P"))
+8 GOTO OUT
+9 ;
RCO8 SET ZTDTH=$HOROLOG
SET ZTRTN="RCO9^ENEQPMR3"
SET ZTSAVE("EN*")=""
SET ZTSAVE("PMTECH(")=""
SET ZTSAVE("DIE")=""
SET ZTSAVE("DR")=""
SET ZTIO=""
SET ZTDESC="Rapid Close Out (PMI)"
DO ^%ZTLOAD
KILL ZTSK
DO ^%ZISC
DO HOME^%ZIS
GOTO OUT
+1 ;
RCO9 SET ENPMWO=$SELECT(ENFR]"":ENFR,1:ENPMWO("P")_"-000")
+1 FOR ENK=0:0
SET ENPMWO=$ORDER(^ENG(6920,"B",ENPMWO))
if ENPMWO'[ENPMWO("P")!(ENPMWO]ENTO)
QUIT
IF '$DATA(^ENG("TMP",ENPMWO("P"),ENPMWO))
IF ($LENGTH(ENPMWO)'>ENTO("L"))
Begin DoDot:1
+2 SET DA=$ORDER(^ENG(6920,"B",ENPMWO,0))
DO POST
+3 IF ENDEL="Y"
DO DEL
End DoDot:1
+4 KILL ^ENG("TMP",ENPMWO("P"))
+5 ;
OUT LOCK -^ENG("PMLIST",ENPMWO("P"))
+1 KILL EN,ENPMWO,ENK,ENDATE,ENDEL,ENPM,ENPMYR,ENPMMN,ENPMWK,ENSHABR
+2 KILL ENSHOP,ENY,DA,DR,DIE,DIC,DIK,EN1
+3 KILL ENFR,ENTO
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 IF $DATA(PMTOT)
DO COUNT^ENBCPM8
+5 KILL ENPMDT,ENSHKEY
+6 if $DATA(ZTQUEUED)
KILL PMTECH
+7 QUIT
+8 ;
WRIT if ENY>(IOSL-2)
DO HLD
WRITE !,?10,I
SET ENY=ENY+1
+1 QUIT
+2 ;
HLD IF $EXTRACT(IOST,1,2)="C-"
READ !,"Press <RETURN> to continue...",X:DTIME
+1 SET ENY=1
WRITE @IOF
+2 QUIT
+3 ;
POST IF $DATA(^ENG(6920,DA,5))
IF $PIECE(^(5),U,2)]""
QUIT
+1 ;
+2 ; if tech substitution list exists
+3 IF $ORDER(PMTECH(0))
Begin DoDot:1
+4 NEW I,CTECH,STECH
+5 ; loop thru assigned tech multiple of work order (DA)
+6 SET I=0
FOR
SET I=$ORDER(^ENG(6920,DA,7,I))
if 'I
QUIT
Begin DoDot:2
+7 ; current tech
SET CTECH=$PIECE($GET(^ENG(6920,DA,7,I,0)),U)
+8 ; determine substitute (if any)
SET STECH=$$SUBTEC(CTECH)
+9 ; make change
IF STECH
DO CHGTEC(DA,I,STECH)
End DoDot:2
End DoDot:1
+10 ;
+11 DO ^DIE
DO PMINV^ENEQPMR4
+12 IF $DATA(DA)
IF $DATA(^ENG(6920,DA,2))
IF $PIECE(^(2),U,2)]""
DO PMHRS^ENEQPMR4
+13 QUIT
+14 ;
DEL IF $EXTRACT(^ENG(6920,DA,0),1,3)="PM-"
SET DIK="^ENG(6920,"
DO ^DIK
KILL DIK
+1 QUIT
+2 ;
RCO7H WRITE !!,"If you want to close out only a portion of a PM worklist, you may specify the",!,"first and last work orders that you want Rapid Close Out to operate on."
+1 WRITE !,"NOTE: Rapid Close Out will close the first and the last and everything",!," in between."
+2 QUIT
ABORT ;Forget it
+1 KILL ^ENG("TMP",ENPMWO("P"))
+2 GOTO OUT
+3 ;
SUBTEC(TEC) ; return substitute tech
+1 ; input
+2 ; TEC = input tech (internal value)
+3 ; PMTECH( = substitution list array
+4 ; returns ien of tech to be substituted for the input tech or 0 if none
+5 NEW I,RET
+6 ; loop thru PMTECH( array
+7 ; assume no substitute
SET RET=0
+8 IF TEC
SET I=0
FOR
SET I=$ORDER(PMTECH(I))
if I'>0
QUIT
Begin DoDot:1
+9 ; substitute found
IF PMTECH(I,0)=TEC
SET RET=PMTECH(I,1)
End DoDot:1
if RET
QUIT
+10 QUIT RET
+11 ;
CHGTEC(WOIEN,ATIEN,TEC) ; change tech in assigned tech multiple
+1 ; input
+2 ; WOIEN - work order ien
+3 ; ATIEN - assigned tech multiple ien
+4 ; TEC - new tech (internal value)
+5 NEW DA,DIE,DR
+6 SET DA=ATIEN
+7 SET DA(1)=WOIEN
+8 SET DIE="^ENG(6920,"_DA(1)_",7,"
+9 SET DR=".01////^S X="_TEC
+10 DO ^DIE
+11 QUIT
+12 ;ENEQPMR3
