- 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 Jan 18, 2025@02:54:01 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