source: WorldVistAEHR/trunk/r/VISUAL_IMPAIRMENT_SERVICE_TEAM-ANRV/ANRVPOST.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1ANRVPOST ;BHAM/MAM - POST-INIT FOR VERSION 4.0 ; 09 Jun 98 / 8:28 AM
2 ;;4.0; Visual Impairment Service Team ;;12 Jun 98
3EN ; update Entry in the PACKAGE file
4 K DIC,X S X="VISUAL IMPAIRMENT SERVICE",DIC(0)="XZ",DIC="^DIC(9.4," D ^DIC K DIC S X=+Y
5 I X>0,$P(^DIC(9.4,X,0),"^",1)'="VISUAL IMPAIRMENT SERVICE TEAM" S ANRVNM="VISUAL IMPAIRMENT SERVICE TEAM" D NAME
6 K ANRVNM,X,Y,DIC,DA,DR,DIE
7 ;Check to see if data has already been moved
8 I $O(^ANRV(2040,0)) W !!,"It appears that the Visual Impairment Service Team softare V. 4.0 has",!,"already been installed and files have been updated.",! D CLEAN Q
9VIRGIN ;Check for virgin install
10 I '$D(^DIZ(623158,0)) Q
11CONVERT ; convert data from ^DIZ( to ^ANRV(
12 ; VIST Letter
13 S %X="^DIZ(623033,",%Y="^ANRV(2043," D %XY^%RCR S $P(^ANRV(2043,0),"^",2)=2043
14 S ANRVEN=0 F S ANRVEN=$O(^ANRV(2043,ANRVEN)) Q:'ANRVEN S:$D(^ANRV(2043,ANRVEN,1,0)) $P(^(0),"^",2)=2043.01
15 ; VARO Claims
16 S %X="^DIZ(623036,",%Y="^ANRV(2043.5," D %XY^%RCR S $P(^ANRV(2043.5,0),"^",2)="2043.5P"
17 S ANRVEN=0 F S ANRVEN=$O(^ANRV(2043.5,ANRVEN)) Q:'ANRVEN S:$D(^ANRV(2043.5,ANRVEN,1,0)) $P(^(0),"^",2)="2043.51D"
18 ; VIST Eye Diagnosis
19 S %X="^DIZ(623049,",%Y="^ANRV(2041.5," D %XY^%RCR S $P(^ANRV(2041.5,0),"^",2)=2041.5
20 ; VIST Parameters
21 S %X="^DIZ(623050,",%Y="^ANRV(2041," D %XY^%RCR S $P(^ANRV(2041,0),"^",2)="2041P"
22 ; VIST Checklist Options
23 S %X="^DIZ(623053,",%Y="^ANRV(2041.6," D %XY^%RCR S $P(^ANRV(2041.6,0),"^",2)=2041.6
24 ; VIST Benefits and Services Checklist
25 S %X="^DIZ(623061,",%Y="^ANRV(2041.7," D %XY^%RCR S $P(^ANRV(2041.7,0),"^",2)="2041.7P"
26 S ANRVEN=0 F S ANRVEN=$O(^ANRV(2041.7,ANRVEN)) Q:'ANRVEN S:$D(^ANRV(2041.7,ANRVEN,2,0)) $P(^(0),"^",2)="2041.732P"
27 ; VIST Local Benefits and Services
28 S %X="^DIZ(623064,",%Y="^ANRV(2044," D %XY^%RCR S $P(^ANRV(2044,0),"^",2)="2044P"
29 ; VIST Roster
30 S %X="^DIZ(623158,",%Y="^ANRV(2040," D %XY^%RCR S $P(^ANRV(2040,0),"^",2)="2040IP"
31 S ANRVEN=0 F S ANRVEN=$O(^ANRV(2040,ANRVEN)) Q:'ANRVEN D
32 .S:$D(^ANRV(2040,ANRVEN,1,0)) $P(^(0),"^",2)=2040.02
33 .S:$D(^ANRV(2040,ANRVEN,3,0)) $P(^(0),"^",2)="2040.04D"
34 .S:$D(^ANRV(2040,ANRVEN,4,0)) $P(^(0),"^",2)=2040.05
35 .S:$D(^ANRV(2040,ANRVEN,6,0)) $P(^(0),"^",2)="2040.06D"
36 .S:$D(^ANRV(2040,ANRVEN,8,0)) $P(^(0),"^",2)="2040.014DA"
37 .S:$D(^ANRV(2040,ANRVEN,10,0)) $P(^(0),"^",2)="2040.03D"
38 .S:$D(^ANRV(2040,ANRVEN,11,0)) $P(^(0),"^",2)=2040.012
39 .S:$D(^ANRV(2040,ANRVEN,12,0)) $P(^(0),"^",2)=2040.013
40 .S:$D(^ANRV(2040,ANRVEN,14,0)) $P(^(0),"^",2)="2040.07D"
41 .S:$D(^ANRV(2040,ANRVEN,15,0)) $P(^(0),"^",2)="2040.01P"
42 .S:$D(^ANRV(2040,ANRVEN,16,0)) $P(^(0),"^",2)=2040.08
43 .S:$D(^ANRV(2040,ANRVEN,17,0)) $P(^(0),"^",2)=2040.09
44 .S:$D(^ANRV(2040,ANRVEN,18,0)) $P(^(0),"^",2)=2040.1
45 .S:$D(^ANRV(2040,ANRVEN,19,0)) $P(^(0),"^",2)=2040.11
46 .S:$D(^ANRV(2040,ANRVEN,20,0)) $P(^(0),"^",2)=2040.12
47 ; VIST Referral Roster
48 S %X="^DIZ(623160,",%Y="^ANRV(2042.5," D %XY^%RCR S $P(^ANRV(2042.5,0),"^",2)="2042.5P"
49 S ANRVEN=0 F S ANRVEN=$O(^ANRV(2042.5,ANRVEN)) Q:'ANRVEN S:$D(^ANRV(2042.5,ANRVEN,1,0)) $P(^(0),"^",2)="2042.51D"
50 ; VIST Referral Facility
51 S %X="^DIZ(623165,",%Y="^ANRV(2042," D %XY^%RCR S $P(^ANRV(2042,0),"^",2)=2042
52 K ANRVEN
53DELETE ; delete files in ^DIZ(623000 numberspace
54 F ANRVI=623033,623036,623049,623050,623053,623061,623064,623158,623160,623165 S DIU="^DIZ("_ANRVI_",",DIU(0)="DT" D EN^DIU2 K DIU
55 ;
56CLEAN ;Cleanup old entries in 2041.7 which have no corresponding entry in 2040.
57 S ANRVP=0 F S ANRVP=$O(^ANRV(2041.7,ANRVP)) Q:'ANRVP S ANRVP2=+$G(^ANRV(2041.7,+ANRVP,0)) I '$D(^ANRV(2040,+ANRVP2,0)) S DIK="^ANRV(2041.7,",DA=+ANRVP D ^DIK K DIK,DA
58 ;Cleanup old entries in 2042.5 which have no corresponding entry in 2040.
59 S ANRVP=0 F S ANRVP=$O(^ANRV(2042.5,ANRVP)) Q:'ANRVP S ANRVP2=+$G(^ANRV(2042.5,+ANRVP,0)) I '$D(^ANRV(2040,+ANRVP2,0)) S DIK="^ANRV(2042.5,",DA=+ANRVP D ^DIK K DIK,DA
60 ;Cleanup old entries in 2043.5 which have no corresponding entry in 2040.
61 S ANRVP=0 F S ANRVP=$O(^ANRV(2043.5,ANRVP)) Q:'ANRVP S ANRVP2=+$G(^ANRV(2043.5,+ANRVP,0)) I '$D(^ANRV(2040,+ANRVP2,0)) S DIK="^ANRV(2043.5,",DA=+ANRVP D ^DIK K DIK,DA
62 K ANRVP
63QUIT K ANRVI
64 Q
65 ;
66NAME ; reset NAME in PACKAGE file
67 S DIE=9.4,DA=X,DR=".01///"_ANRVNM D ^DIE
68 Q
Note: See TracBrowser for help on using the repository browser.