source: WorldVistAEHR/trunk/r/ENGINEERING-EN/ENEQPMR3.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.2 KB
Line 
1ENEQPMR3 ;(WCIOFO)/DH-Rapid Close Out ;11/9/1998
2 ;;7.0;ENGINEERING;**15,35,43,47,59**;Aug 17, 1993
3 ;
4RCO6 I $D(^ENG("TMP",ENPMWO("P"))) G RCO61
5 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"
6 W:ENDEL="Y" ", and the work orders",!,"deleted." W:ENDEL'="Y" "." G RCO7
7RCO61 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
8 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)
9 W ", "_ENPMYR_$E(ENPMDT,1,2)_$S(ENPM["W":" Week("_ENPMWK_")",1:"")_" are subject to Rapid Close Out."
10 ;
11RCO7 S ENFR="",ENTO="ZZ",ENTO("L")=20
12 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
13 S J=$O(^ENG(6920,"B",ENPMWO("P"))) G:J'[ENPMWO("P") OUT
14RCO701 W !!,"Please enter the starting work order (or the sequential portion thereof)",!,"(ex: '"_J_"' or just '"_+$P(J,"-",3)_"'): "
15 R X:DTIME G:'$T!($E(X)="^")!(X="") RCO7
16 S:X?1.2N X=$S(X?1N:"00"_X,1:"0"_X) I X?.N S X=ENPMWO("P")_X
17 I '$D(^ENG(6920,"B",X)) W !,?5,X_" is not an existing work order. Please try again." G RCO701
18 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_")"
19 S ENFR(0)=$O(^ENG(6920,"B",ENFR),-1) S ENFR=$S(ENFR(0)[ENPMWO("P"):ENFR(0),1:ENPMWO("P")_"000")
20RCO702 W !!,"Now enter the last work order to be closed (or sequential portion thereof)"
21 S J=$O(^ENG(6920,"B",ENPMWO("P")_9999),-1)
22 W !,"(ex: '"_J_"' or just '"_+$P(J,"-",3)_"'): "
23 R X:DTIME G:'$T!(X="")!($E(X)="^") RCO7
24 S:X?1.2N X=$S(X?1N:"00"_X,1:"0"_X) I X?.N S X=ENPMWO("P")_X
25 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
26 I $P($P($G(^ENG(6920,X1,0)),U),"-",3)<$P(ENFR,"-",3) W !,?5,X_" does not follow "_ENFR_"." G RCO702
27 S DIC("S")="I $P(^(0),U)[ENPMWO(""P""),(+$P($P(^(0),U),""-"",3)>+$P(ENFR,""-"",3))"
28 D ^DIC K DIC("S") G:Y'>0 RCO7 S ENTO=$P(Y,U,2),ENTO("L")=$L(ENTO) W " ("_ENTO_")"
29 ;
30RCO71 K DIC("S"),DIC("A") S DIE="^ENG(6920,",DR="35.2///P;36///^S X=ENCDATE;32///^S X=""COMPLETED"""
31 W !,"Would you like to free up this terminal" S %=1 D YN^DICN G:%=1 RCO8 I %'=2 G OUT
32 W !!,"Rapid close out now in progress "
33 S ENPMWO=$S(ENFR]"":ENFR,1:ENPMWO("P")_"-000")
34 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
35 . W "." S DA=$O(^ENG(6920,"B",ENPMWO,0)) D POST
36 . I ENDEL="Y" D DEL
37 K ^ENG("TMP",ENPMWO("P"))
38 G OUT
39 ;
40RCO8 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
41 ;
42RCO9 S ENPMWO=$S(ENFR]"":ENFR,1:ENPMWO("P")_"-000")
43 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
44 . S DA=$O(^ENG(6920,"B",ENPMWO,0)) D POST
45 . I ENDEL="Y" D DEL
46 K ^ENG("TMP",ENPMWO("P"))
47 ;
48OUT L -^ENG("PMLIST",ENPMWO("P"))
49 K EN,ENPMWO,ENK,ENDATE,ENDEL,ENPM,ENPMYR,ENPMMN,ENPMWK,ENSHABR
50 K ENSHOP,ENY,DA,DR,DIE,DIC,DIK,EN1
51 K ENFR,ENTO S:$D(ZTQUEUED) ZTREQ="@"
52 I $D(PMTOT) D COUNT^ENBCPM8
53 K ENPMDT,ENSHKEY
54 K:$D(ZTQUEUED) PMTECH
55 Q
56 ;
57WRIT D:ENY>(IOSL-2) HLD W !,?10,I S ENY=ENY+1
58 Q
59 ;
60HLD I $E(IOST,1,2)="C-" R !,"Press <RETURN> to continue...",X:DTIME
61 S ENY=1 W @IOF
62 Q
63 ;
64POST I $D(^ENG(6920,DA,5)),$P(^(5),U,2)]"" Q
65 ;
66 ; if tech substitution list exists
67 I $O(PMTECH(0)) D
68 . N I,CTECH,STECH
69 . ; loop thru assigned tech multiple of work order (DA)
70 . S I=0 F S I=$O(^ENG(6920,DA,7,I)) Q:'I D
71 . . S CTECH=$P($G(^ENG(6920,DA,7,I,0)),U) ; current tech
72 . . S STECH=$$SUBTEC(CTECH) ; determine substitute (if any)
73 . . I STECH D CHGTEC(DA,I,STECH) ; make change
74 ;
75 D ^DIE,PMINV^ENEQPMR4
76 I $D(DA),$D(^ENG(6920,DA,2)),$P(^(2),U,2)]"" D PMHRS^ENEQPMR4
77 Q
78 ;
79DEL I $E(^ENG(6920,DA,0),1,3)="PM-" S DIK="^ENG(6920," D ^DIK K DIK
80 Q
81 ;
82RCO7H 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."
83 W !,"NOTE: Rapid Close Out will close the first and the last and everything",!," in between."
84 Q
85ABORT ;Forget it
86 K ^ENG("TMP",ENPMWO("P"))
87 G OUT
88 ;
89SUBTEC(TEC) ; return substitute tech
90 ; input
91 ; TEC = input tech (internal value)
92 ; PMTECH( = substitution list array
93 ; returns ien of tech to be substituted for the input tech or 0 if none
94 N I,RET
95 ; loop thru PMTECH( array
96 S RET=0 ; assume no substitute
97 I TEC S I=0 F S I=$O(PMTECH(I)) Q:I'>0 D Q:RET
98 . I PMTECH(I,0)=TEC S RET=PMTECH(I,1) ; substitute found
99 Q RET
100 ;
101CHGTEC(WOIEN,ATIEN,TEC) ; change tech in assigned tech multiple
102 ; input
103 ; WOIEN - work order ien
104 ; ATIEN - assigned tech multiple ien
105 ; TEC - new tech (internal value)
106 N DA,DIE,DR
107 S DA=ATIEN
108 S DA(1)=WOIEN
109 S DIE="^ENG(6920,"_DA(1)_",7,"
110 S DR=".01////^S X="_TEC
111 D ^DIE
112 Q
113 ;ENEQPMR3
Note: See TracBrowser for help on using the repository browser.