source: FOIAVistA/trunk/r/ENGINEERING-EN/ENY2KR.m@ 1015

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

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1ENY2KR ;(WASH ISC)/DH-Individual Y2K Close Out ;6.16.98
2 ;;7.0;ENGINEERING;**51**;Aug 17, 1993
3CO ; close out Y2K worklist
4 N DATE,COST,DIC,DIE,DA,DR,WODA,EQDA,ENX,ENY,ENY2K
5 W @IOF,!,"Closing a Y2K work order normally places the affected piece of equipment in",!,"a Y2K CATEGORY of 'FULLY COMPLIANT' and updates both the Work Order and"
6 W !,"Equipment files."
7 W !!,"In exceptional cases, this option may also be used to remove an item from",!,"the conditionally compliant list without actually closing its Y2K work"
8 W !,"order. If you enter a Y2K CATEGORY of 'NA' rather than 'FC' the system will",!,"automatically delete the Y2K work order. If you enter 'NC' the system will"
9 W !,"delete the work order and prompt you for Y2K ACTION."
10 W !!
11 ;
12CO1 ; get first Y2K work order
13 K ENX R !,"Please enter first Y2K work order to be closed: ",ENX:DTIME I ENX=""!(ENX="^")!('$T) G EXIT
14 D GETWO G:Y'>0 CO1
15 S (DA,WODA)=+Y,ENY2WO=$P(^ENG(6920,DA,0),U)
16 S EQDA=$P($G(^ENG(6920,DA,3)),U,8) I EQDA="" W !," This work order lacks an equipment pointer and is being deleted." D DEL G CO1
17 I '$D(^ENG(6914,EQDA,0)) W !," There is no equipment record for this work order. The work order",!,"is being deleted." D DEL G CO1
18 L +^ENG(6920,DA):1 I '$T W !,"Work order being edited by another user. Please try again later." G CO1
19 D CLSWO G:$D(DIRUT)!($D(DTOUT)) EXIT
20 ;
21CO2 S ENY2WO(1)=$O(^ENG(6920,"B",ENY2WO)) G:$E(ENY2WO(1),1,3)'="Y2-" EXIT I $P($G(^ENG(6920,ENY2WO(1),5)),U,2)]"" S ENY2WO=ENY2WO(1) G CO2
22 ;
23CO3 K ENX W !!,"Next Y2K work order (or sequential portion), '^' to quit: "_ENY2WO(1)_"// " R ENX:DTIME I $E(ENX)="^"!('$T) G EXIT
24 I ENX?1.N S:$L(ENX)<3 X=$S($L(ENX)=1:"00"_ENX,1:"0"_ENX) S ENX=$P(ENY2WO,"-",1,2)_"-"_ENX W !,?10," ("_ENX_")"
25 I ENX="" S ENX=ENY2WO(1)
26 D GETWO G:Y'>0 CO3
27 S (DA,WODA)=+Y,ENY2WO=$P(^ENG(6920,DA,0),U)
28 S EQDA=$P($G(^ENG(6920,DA,3)),U,8) I EQDA="" W !," This work order lacks an equipment pointer and is being deleted." D DEL G CO2
29 I '$D(^ENG(6914,EQDA,0)) W !," There is no equipment record for this work order. The work order",!,"is being deleted." D DEL G CO2
30 L +^ENG(6920,DA):1 I '$T W !,"Another user is editing this work order. Please try again later." G CO2
31 D CLSWO G:$D(DIRUT)!($D(DTOUT)) EXIT
32 G CO2
33 ;
34EXIT K ENSHABR,ENSHOP,EN1,ENLOC,ENY2WO
35 Q
36 ;
37HOLD I $E(IOST,1,2)="C-" R !,"<cr> to continue, '^' to quit...",X:DTIME
38 S ENY=1
39 Q
40 ;
41GETWO ; get a Y2K work order
42 ; expects ENX and returns Y (from ^DIC)
43 S DIC="^ENG(6920,",DIC("S")="I $P(^(0),U)[""Y2-"",$P($G(^(5)),U,2)="""""
44 I $E(ENX,2)="." D I D]"" S X=$E(ENX,3,99),DIC(0)="QE" D IX^DIC Q
45 . S D=""
46 . I $E(ENX)="E" S D="G" Q ; equipment
47 . I $E(ENX)="L" S D="C" Q ; location
48 I $E(ENX)="?" D
49 . W !," You may use 'E.value' to list W.O.s whose EQUIPMENT ID# equals 'value', or"
50 . W !," 'L.value' to list W.O.s whose LOCATION starts with 'value'."
51 S X=ENX,DIC(0)="QEM" D ^DIC
52 Q
53 ;
54CLSWO ; disposition the Y2K work order
55 W !,"EQUIPMENT ID: "_EQDA_" "_$S($P(^ENG(6914,EQDA,0),U,2)]"":$E($P(^(0),U,2),1,20),1:$E($$GET1^DIQ(6914,EQDA,6),1,20))_" "_$E($$GET1^DIQ(6914,EQDA,1),1,20)_" "_$E($$GET1^DIQ(6914,EQDA,4),1,15)
56 K DIR S DIR(0)="6914,71",DIR("B")="FULLY COMPLIANT"
57 D ^DIR K DIR Q:$D(DIRUT)
58 S ENY2K("CAT")=Y I ENY2K("CAT")="CC" W !!,"Data base unchanged." Q
59 I ENY2K("CAT")'="FC" D Q
60 . D DEL
61 . S DIE="^ENG(6914,",DA=EQDA,DR="71///^S X=ENY2K(""CAT"");72///^S X=""@"";72.1///^S X=""@"";73///^S X=""@"";74///^S X=""@"";75///^S X=""@"";77///^S X=""@""" D ^DIE
62 . I ENY2K("CAT")="NC" S DR=76 D ^DIE
63 S DR=$S($D(^DIE("B","ENZY2CLOSE")):"[ENZY2CLOSE]",1:"[ENY2CLOSE]")
64 S DIE="^ENG(6920," D ^DIE I $D(Y) L -^ENG(6920,DA) Q
65 I $P($G(^ENG(6920,DA,5)),U,2)]"",$E(^ENG(6920,DA,0),1,3)="Y2-" D S DA=WODA
66 . S DATE=$P(^ENG(6920,DA,5),U,2),COST=$P(^(5),U,6)+$P(^(5),U,4)+$P($G(^(4)),U,4)
67 . S DA=EQDA,DIE="^ENG(6914,",DR="71///^S X=""FC"";72.1///^S X=DATE;74///^S X=COST" D ^DIE
68 L -^ENG(6920,DA)
69 Q
70 ;
71DEL ; delete work orders without valid equipment pointers and work orders
72 ; which should not be closed ('NC' and 'NA')
73 I $G(EQDA),$D(^ENG(6914,EQDA,0)) S $P(^ENG(6914,EQDA,11),U,8)=""
74 S DIK="^ENG(6920," D ^DIK K DIK
75 Q
76 ;ENY2KR
Note: See TracBrowser for help on using the repository browser.