source: FOIAVistA/trunk/r/ENGINEERING-EN/ENEQ3.m@ 729

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1ENEQ3 ;WIRMFO/DH,SAB-Equipment Entry Functions ;3.31.98
2 ;;7.0;ENGINEERING;**25,29,35,52**;Aug 17, 1993
3EQMAS ; Multiple Equipment Subsequent (Similar) Records
4 ; in
5 ; ENDAOLD - ien of record to be copied from
6 ; ENMA( - array containing info on how FA Document and
7 ; incoming inspection w.o. should be handled
8 ; ENBULL( - (optional) array of mail group info
9 ; out
10 ; ENNXL - ien of new record, 0 if unsuccessful
11 N EN
12 S ENNXL=0
13 ; lock master
14 L +^ENG(6914,ENDAOLD):10 I '$T D Q
15 . W $C(7),!,"Another user is editing Entry# ",ENDAOLD,". Can't proceed."
16 . S DIR(0)="E" D ^DIR K DIR
17 ; create new record
18 D ENR^ENEQ1 I 'ENNXL D L -^ENG(6914,ENDAOLD) Q
19 . W $C(7),!,ENERR S DIR(0)="E" D ^DIR K DIR,ENERR
20 ; lock new record
21 L +^ENG(6914,ENNXL):10 I '$T D L -^ENG(6914,ENDAOLD) Q
22 . W $C(7),!,"Another user is editing Entry# ",ENNXL,". Can't proceed."
23 . S DIR(0)="E" D ^DIR K DIR
24 ;
25 ; copy master into local array
26 M EN=^ENG(6914,ENDAOLD)
27 ; modify local array for new record
28 ; set up .01 and triggered fields
29 S $P(EN(0),U)=ENNXL
30 S $P(EN(0),U,5,6)=$P(^ENG(6914,ENNXL,0),U,5,6)
31 ; remove data that should not be copied
32 I $D(EN(1)) S $P(EN(1),U,3)=""
33 I $D(EN(2)) F ENI=7,13 S $P(EN(2),U,ENI)=""
34 I $D(EN(3)) F ENI=6,7,10,14 S $P(EN(3),U,ENI)=""
35 K EN(6)
36 I $D(EN(9)) S $P(EN(9),U,10)=""
37 ; move local array to new record
38 M ^ENG(6914,ENNXL)=EN K EN
39 ; re-index new record
40 S DIK="^ENG(6914,",DA=ENNXL D IX1^DIK K DIK
41 ; unlock master
42 L -^ENG(6914,ENDAOLD)
43 ; user edit new record
44 W !!,"Equipment ID: ",ENNXL
45 S DIE="^ENG(6914,",DR="5;24;25;26",DA=ENNXL
46 I $P(^ENG(6914,ENDAOLD,0),U,3)]"" S DR=DR_";2" ; parent system
47 I $D(^ENG(6914,ENNXL,8)),$P(^(8),U,8)]"" S DR=DR_";51" ; replacing
48 D ^DIE I $D(Y)!$D(DTOUT),$P($G(^ENG(6914,DA,1)),U,3)']"" D Q
49 . W $C(7),!,"Time Out or '^' entered and Serial Number was left blank."
50 . W !,"Deleting last entry (",DA,")..."
51 . S DIK="^ENG(6914," D ^DIK K DIK L -^ENG(6914,DA)
52 . S ENNXL=0
53 I $G(ENMA("IIWO")) D IIWO^ENWONEW3(ENNXL)
54 I $G(ENMA("FAP")) S ENEQ("DA")=DA D ^ENFAACQ S DA=ENEQ("DA") K ENEQ("DA")
55 S DA=ENNXL D BULL
56 L -^ENG(6914,ENNXL)
57 Q
58 ;
59BULL ;X-mit new equipment bulletin if mail group established
60 ; Input
61 ; DA - ien of equipment entry
62 ; optional ENBULL( - array indicating mail group availabliity
63 ; undefined nodes not yet evaluated
64 ; ENBULL = true(1) if 'EN NEW EQUIPMENT' established
65 ; ENBULL(station number)=true(1) if
66 ; 'EN NEW EQUIPMENT station number' established
67 Q:'$D(DA) Q:'$D(^ENG(6914,DA,0))
68 N ENSN,XMB,XMDUZ,XMY
69 ; determine station number of equipment entry
70 S ENSN=$$GET1^DIQ(6914,DA,60)
71 ; if blank use default station #
72 I ENSN="" S ENSN=$$GET1^DIQ(6910,1,1)
73 ; get status of station specific mail group if not already done
74 I ENSN]"",'$D(ENBULL(ENSN)) S ENBULL(ENSN)=$$CHKMGRP("EN NEW EQUIPMENT "_ENSN)
75 ; use station specific mail group if available
76 I ENSN]"",ENBULL(ENSN) S XMY("G.EN NEW EQUIPMENT "_ENSN)=""
77 ; if station specific mail group not established then use generic group
78 I '$D(XMY) D
79 . ; get staus of generic mail group if not already done
80 . I $G(ENBULL)']"" S ENBULL=$$CHKMGRP("EN NEW EQUIPMENT")
81 . I ENBULL S XMY("G.EN NEW EQUIPMENT")=""
82 ; send bulletin if a mail group is established
83 I $D(XMY) D
84 . S XMB="EN NEW EQUIPMENT"
85 . S XMB(1)=DA,XMB(2)=$P(^VA(200,DUZ,0),U),XMB(3)=$P(^ENG(6914,DA,0),U,2)
86 . F X=4,5 S XMB(X)=""
87 . I $D(^ENG(6914,DA,1)) S X=$P(^(1),U) S:X>0 XMB(4)=$P(^ENG(6911,X,0),U)
88 . I $D(^ENG(6914,DA,3)) S X=$P(^(3),U,2) S:X>0 XMB(5)=$P(^DIC(49,X,0),U)
89 . S:ENSN]"" XMB(6)=ENSN
90 . F X=4,5,6 S:XMB(X)="" XMB(X)="MISSING"
91 . S X="0^0"
92 . I $P($G(^ENG(6914,DA,0)),U,4)="NX",$P($G(^(8)),U,2) S $P(X,U)=1 ;CapNX
93 . I $P(X,U),+$$CHKFA^ENFAUTL(DA) S $P(X,U,2)=1 ; FAP
94 . S XMB(7)="Item is"_$S($P(X,U):"",1:" NOT")_" capitalized NX."
95 . I $P(X,U) S XMB(7)=XMB(7)_" It was"_$S($P(X,U,2):"",1:" NOT")_" reported to FAP."
96 . S XMDUZ="AEMS/MERS"
97 . D ^XMB
98 Q
99CHKMGRP(ENMG) ; Check Mail Group Extrinsic Variable
100 ; true if mail group exists and has at least one member
101 ; Input Variable
102 ; ENMG - name of mail group to check
103 N ENI,ENOK,ENQ
104 S ENOK=0 ; initialize result flag
105 ; look for mail group
106 S ENI=$$FIND1^DIC(3.8,"","X",ENMG,"B")
107 ; if found look for a member
108 I ENI D
109 . D LIST^DIC(3.81,","_ENI_",","","",1,"","","","","","ENQ")
110 . I $P(ENQ("DILIST",0),U) S ENOK=1 ; has at least one member
111 Q ENOK
112 ;
113LAST ;Last service episode (including PMI)
114 ; called by ENG DJ SCREENs
115 ; in: DA - ien of equipment entry
116 ; out: displays date and work action of last service episode (if any)
117 N ENA,ENB,ENI,ENX
118 Q:'$D(DA)
119 Q:'$D(^ENG(6914,DA,6))
120 S ENI=0 F S ENI=$O(^ENG(6914,DA,6,ENI)) Q:'ENI S ENA=^(ENI,0) I $E($P(ENA,U,3))'="D" D Q
121 . S ENX="Last serviced: "_$E(ENA,4,5)_"/"_$E(ENA,6,7)_"/"_$E(ENA,2,3)
122 . S ENB=$P($P(ENA,U),"-",2) D:ENB]"" S ENX=ENX_" Work Action: "_ENB
123 . . I $D(^ENG(6920.1,"D",ENB)) S ENB(0)=$O(^(ENB,0))
124 . . I $D(ENB(0)),$D(^ENG(6920.1,ENB(0),0)) S ENB=$P(^(0),U)
125 . W !!,ENX
126 Q
127 ;ENEQ3
Note: See TracBrowser for help on using the repository browser.