source: FOIAVistA/trunk/r/EEO_COMPLAINT_TRACKING-EEO/EEOIPOS2.m@ 800

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1EEOIPOS2 ;HISC/JWR - POST INIT CLEANUP ;02/08/93 11:15
2 ;;2.0;EEO Complaint Tracking;;Apr 27, 1995
3TEST ;Loop through DA's for file 785 for conversion
4 S (NO,STATE,N5,ADD,ZIP,DA,ICC)=""
5 F S DA=$O(^EEO(785,"ANODE",DA)) Q:DA="" D SET,CLNODE^EEOIPCON W "."
6 G KILL
7SET ;Global sets for new and rearranged fields
8 Q:'$D(^EEO(785,DA,0)) S EEO0=^EEO(785,DA,0),STATE=$P(EEO0,"^",6) S EEO5=$G(^EEO(785,DA,5)),ADD=$P(EEO5,"^",2),ZIP=$P(ADD,",",2),CITY=$P(ADD,",",1)
9 D STRIP K EEO3,EEO1
10 S:$D(^EEO(785,DA,3)) EEO3=^(3) S:$D(^EEO(785,DA,1)) EEO1=^EEO(785,DA,1)
11 D IN1,BASIS
12 Q
13STRIP ;Breaks doun City, State, Zip, and assigns value to Case No field
14 S ZIP=$TR(ZIP," ABCDEFGHIJKLMNOPQRSTUVWXYZ.,")
15 I STATE'="" S $P(^EEO(785,DA,5),"^",4)=STATE
16 I CITY'="" S $P(^EEO(785,DA,5),"^",3)=CITY
17 I ZIP?5N!(ZIP?5N1"-"4N) S $P(^EEO(785,DA,5),"^",5)=ZIP
18 S CASE=$S('$D(^EEO(785,DA,1)):"P",'$P(^(1),"^",3):"P",$E($P(^(1),"^",3),4,5)>9:$E($P(^(1),"^",3),2,3)+1,1:$E($P(^(1),"^",3),2,3))
19 S CASE=CASE_"-"_(DA\100000)_"-"_(100000-(DA-((DA\100000)*100000)))
20 S $P(^EEO(785,DA,5),"^",6)=CASE
21 S (ADD,ZIP,N5,STATE,CITY,CASE,ICC)=""
22 S DIE=785,DR=".07///@;7///@;19///@" D ^DIE
23 Q
24KILL ;Kills some obsolete fields and files, Reindexes certain fields in 785
25 W !!,"DELETING OBSOLETE AND DUPLICATED FIELDS FROM FILE 785 "
26 S DIK="^DD(785,",DA(1)=785 F DA=.07,1,7,17,17.1,17.2,18,18.1,18.2,27,28,30,31,33.5,33.6,33.7,33.8,34,35,36,37,38,39,39.5,39.6,39.7,39.8,40,43 W "." D ^DIK
27 W !,"DELETING OBSOLETE FILES "
28 F FI=787,788,789.2,789.3,789.4,789.6 I $D(^EEO(FI,0)) S DIU="^EEO("_FI_",",DIU(0)="DST" W !," ",FI D EN^DIU2
29 K FI,ANS,DA,DA(1),DIC,DIE,DIK,DR,NO,X
30 W !!!!,"RE-INDEXING 'C','D',& 'E' CROSS REFERENCES (FILE #785)"
31 S DIK="^EEO(785," F DIK(1)=2,1.2,1.3 D ENALL^DIK
32OPT S DIE="^DIC(19," W !!,"PLACING OBSOLETE OPTIONS OUT OF ORDER"
33 F EEOPTION="EEO TASKED UPLINK BULLETIN","EEOREXMIT" D
34 .I $D(^DIC(19,"B",EEOPTION)) S DA=$O(^(EEOPTION,"")) I DA>0 S DR="2///OUT OF ORDER;25///@" D ^DIE
35 D COUNTER^EEOENF
36 W !! D ^EEOIPCON
37 W !!!," *** INITIALIZATION COMPLETE ***",!!!," Remember to Task the EEO TASKED BULLETIN option to run nightly...",!!!!!
38 K DIK,EEO1IN,EEO0,EEO31,EEO5,EEONI,ICC,ZIP,STATE,N5,ADD,CITY Q
39IN1 ;Converts Investigator fields to the new multiple format
40 Q:$G(EEO3)'>0
41 F EEONI=1,2,7,10 I $P($G(EEO3),U,EEONI)'="" D
42 .S EEO31=$P($G(EEO3),U,EEONI) I $D(^EEO(787.5,EEO31)) D PRE
43 .I EEO31<1000,$D(^EEO(787,EEO31)) D
44 ..S X=EEO31,DIC="^EEO(787.5,",DIC(0)="M"
45 ..D ^DIC I Y'>0 S $P(EEO3,U,EEONI)=2126 Q
46 ..S $P(EEO3,U,EEONI)=+Y
47 ..D PRE
48 .;I $P($G(EEO3),U,EEONI)'="" I '$D(^EEO(787.5,$P($G(EEO3),U,EEONI)))&('$D(^EEO(787,$P($G(EEO3),U,EEONI)))) S $P(EEO3,U,EEONI)=2126
49 S (SPIT,EEOINV1,EEOINV2)=""
50 I $P(EEO3,U)'="" S EEOINV1=$P(EEO3,U)_"^"_$P(EEO3,U,3)_"^"_$G(EEOIN(1))_"^^"_$P(EEO3,U,5)_"^"_$P(EEO3,U,2)_"^"_$P(EEO3,U,4)_"^"_$P(EEO3,U,8) S SPIT=1
51 I $P(EEO3,U,7)'="" S EEOINV2=$P(EEO3,U,7)_"^"_$P(EEO3,U,9)_"^"_$G(EEOIN(7))_"^^"_$P(EEO3,U,11)_"^"_$P(EEO3,U,10)_"^"_$P(EEO3,U,13)_"^"_$P(EEO3,U,14) S:SPIT=1 SPIT=2
52 I SPIT>0 S ^EEO(785,DA,11,1,0)=$S($P(EEO3,U)'="":EEOINV1,1:EEOINV2) S ^EEO(785,DA,11,"B",$P(EEO3,U),1)=""
53 I SPIT=2 S ^EEO(785,DA,11,SPIT,0)=EEOINV2 S ^EEO(785,DA,11,"B",$P(EEO3,U,7),2)=""
54 S:SPIT'="" ^EEO(785,DA,11,0)="^785.03P^"_SPIT_"^"_SPIT
55 I $D(^EEO(785,DA,3)) S EEOOINV=$G(^(3)),^(3)="^^"_$P(EEOOINV,U,3)_"^^^"_$P(EEOOINV,U,6)
56 K EEOINV1,EEOINV2,SPIT,INV1,DA1,FIN1,REVI1,RAD,RRD,INV2,DA2,FIN2,REVI2,REVD2,RRD2,N3,EEOOINV
57 Q
58PRE ;Makes type of investigator determination
59 I EEONI=1 S EEO1IN=$P(EEO3,U),EEODOA=$P(EEO3,U,3) D TYPE
60 I EEONI=7 S EEO1IN=$P(EEO3,U,7),EEODOA=$P(EEO3,U,9) D TYPE
61 Q
62BASIS ;Converts basis to new multiple format
63 K BA,IS I $G(EEO1)'="" D
64 .S BA(1)=$P(EEO1,U,5),BA(2)=$P(EEO1,U,7),BA(3)=$P(EEO1,U,8)
65 .F NO=1:1:3 D
66 ..I BA(NO)'="" I $D(^EEO(785.1,BA(NO))) S BA(NO)=$P(^(BA(NO),0),U)
67 .S IS(1)=$P(EEO1,U,4),IS(2)=$P(EEO1,U,9),IS(3)=$P(EEO1,U,10)
68 .F NO=1:1:3 D
69 ..I IS(NO)'="" I $D(^EEO(786,IS(NO))) S IS(NO)=$P(^(IS(NO),0),U)
70SETB .F NO=1:1:3 I $G(BA(NO))'="" D BA
71 .F NO=1:1:3 I $G(IS(NO))'="" D IS
72 K BA1,BA2,BA3,IS1,IS2,IS3,LAB,NO,N1,BA,IS
73 S $P(^EEO(785,DA,2),U,8)=""
74 I $D(^EEO(785,DA,1)) S EEOOIS=$G(^(1)) D
75 .F EX=4,5,7,8,9,10 S $P(EEOOIS,U,EX)=""
76 .S ^EEO(785,DA,1)=EEOOIS
77 K EEOOIS,EX Q
78BA ;Enters converted Basis into file 785
79 S DR="18.5///"_BA(NO),DR(2,785.01)=".01///"_BA(NO)
80DIE S DIE=785 D ^DIE K DR Q
81IS ;Enters converted Issue codes into file 785
82 S DR="17.5///"_IS(NO),DR(2,785.02)=".01///"_IS(NO)_";1///"_$P(EEO1,U,11)
83 D DIE
84 Q
85TYPE S (EEODATE,EEOIN(EEONI))="",EEOCN=0
86 Q:EEODOA'>0
87 Q:'$D(^EEO(787.5,EEO1IN)) I $D(^(EEO1IN,1)) F S EEOCN=$O(^(1,EEOCN)) Q:EEOCN'>0 N AEE S AEE=$G(^(EEOCN,0)) D
88 .I $P(AEE,U,2)<EEODOA&($P(AEE,U,3)>EEODOA!($P(AEE,U,3)="")) I EEODATE'>EEODOA S EEODATE=EEODOA,EEOIN(EEONI)=$P(AEE,U)
89 I $D(^EEO(787.5,EEO1IN,1))&(EEOIN(EEONI)'>0) S EEOIN(EEONI)=$P($G(^(1,1,0)),U)
90 K EEODATE,EEODOA
Note: See TracBrowser for help on using the repository browser.