source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRIPST.m@ 635

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

initial load of WorldVistAEHR
File size: 6.0 KB
RevLine 
[613]1IMRIPST ;HCIOFO/NCA,FT-Post-Init Immunology Routine ;11/10/97 9:02
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;;Feb 09, 1998
3 Q:+$$VERSION^XPDUTL("IMR")'>0 ;quit if virgin install
4 Q:'$D(^IMR(158.96)) ;quit if post-init has already run
5 D DELFLDS,DELRTN,DELDATA,DELOPT,PROC,NLF,DELFILE,DELIP,F15895
6 D EXTRACT,RESCHED,KILL
7 D ^IMRIPST1
8 Q
9DELFLDS ; delete unused fields from File 158
10 D BMES^XPDUTL("Removing Unused Data Dictionary Fields...")
11 K DA,DIK S DIK="^DD(158,",DA(1)=158 F DA=102.03,102.04,106.01,106.02,106.03,106.04,106.05,106.07,106.08,106.09,106.1,106.11,107.01,107.02,107.03,107.04,107.05,107.06,107.07,107.08 D ^DIK
12 K DA,DIK S DIK="^DD(158.9,",DA(1)=158.9 F DA=.02,.03,.04,.08,.11,.12,.13 D ^DIK
13 K DA,DIK S DIK="^DD(158.921,",DA(1)=158.921,DA=.02 D ^DIK
14 K DA,DIK
15 Q
16 ;
17DELRTN ; delete unused routines
18 D BMES^XPDUTL("Deleting Unused Routines...")
19 F X="IMRLRAD","IMRLRAD1","IMRLRAD2","IMRSRX","IMRSRX1","IMRLRX","IMRLRX1","IMRLRX2","IMRLRX3","IMRNTEG","IMRPOST1","IMRPOST2","IMRPOSTI","IMRPRE1","IMRPREI","IMROPSUR","IMRCDC5" X ^%ZOSF("DEL")
20 Q
21 ;
22DELDATA ; remove data from unused fields in File 158.9
23 ; add Domain file pointer to File 158.9
24 D BMES^XPDUTL("Deleting Unused Data...")
25 D DOMAIN ;get domain pointer value
26 S IMRIEN=0
27 F S IMRIEN=$O(^IMR(158.9,IMRIEN)) Q:'IMRIEN D
28 .S IMRNODE=$G(^IMR(158.9,IMRIEN,0)) Q:IMRNODE=""
29 .F IMRPIECE=2,3,4,8,11,12,13 S $P(IMRNODE,U,IMRPIECE)=""
30 .S ^IMR(158.9,IMRIEN,0)=IMRNODE
31 .I $G(IMRDOMN) S $P(^IMR(158.9,IMRIEN,"DOMAIN"),U,1)=IMRDOMN ;add domain pointer value to 158.9 entry
32 .S IMRIEN1=0
33 .F S IMRIEN1=$O(^IMR(158.9,IMRIEN,2,IMRIEN1)) Q:'IMRIEN1 D
34 ..S IMRIEN2=0
35 ..F S IMRIEN2=$O(^IMR(158.9,IMRIEN,2,IMRIEN1,1,IMRIEN2)) Q:'IMRIEN2 D
36 ...S $P(^IMR(158.9,IMRIEN,2,IMRIEN1,1,IMRIEN2,0),U,2)=""
37 ...Q
38 ..Q
39 .Q
40 K IMRIEN,IMRIEN1,IMRIEN2,IMRNODE,IMRPIECE
41 Q
42 ;
43DELOPT ; remove old unused options
44 D BMES^XPDUTL("Removing Unused Options...")
45 F IMRX="IMRO REPORTS MENU","IMRO BY DX","IMRO BY NAME","IMRO DELETE","IMRO ENTER","IMRO MASTER","IMRO NO DX","IMRO TRANSMIT" D OPT
46 S IMRX="IMRO"
47 F S IMRX=$O(^DIC(19,"B",IMRX)) Q:$E(IMRX,1,4)'="IMRO" D OPT
48 K DA,DIK,IMRX
49 Q
50 ;
51PROC ; Populate fields in File 158
52 D BMES^XPDUTL("Populating Data Fields in File 158...")
53 ; $P(^IMR(158,IMRX1,0),U,36)=DATE OF HIV+ (CAT 1) STATUS
54 ; " 42)=CATEGORY
55 ; " 44)=DATE OF HIV+ (CAT 2) STATUS
56 F IMRX1=0:0 S IMRX1=$O(^IMR(158,IMRX1)) Q:IMRX1<1 S IMRX=$G(^(IMRX1,0)),IMRDT=$P(IMRX,U,36),$P(IMRX,U,44)="",IMRCAT=$P(IMRX,U,42) S:IMRCAT=2 $P(IMRX,U,44)=$S(IMRDT:IMRDT,1:"") S ^IMR(158,IMRX1,0)=IMRX D P1,P2
57 K DA,DFN,I,IMRAAAD,IMRX,IMRX1,IMRDT,IMRCAT,IMRDFN,IMRDOB,IMRDOD,IMRSEX,VADM,X2
58 Q
59 ;
60NLF ; populate new NLF ENTRY field in File 158.9
61 D BMES^XPDUTL("Populating new NLF ENTRY field in File 158.9...")
62 S IMRD2=0
63 F S IMRD2=$O(^IMR(158.9,IMRD2)) Q:'IMRD2 S IMRD1=0 F S IMRD1=$O(^IMR(158.9,IMRD2,3,IMRD1)) Q:'IMRD1 S IMRD0=0 F S IMRD0=$O(^IMR(158.9,IMRD2,3,IMRD1,1,IMRD0)) Q:'IMRD0 D
64 .S IMRLAB=+$G(^IMR(158.9,IMRD2,3,IMRD1,1,IMRD0,0)) Q:'IMRLAB
65 .S IMRWKLD=$$GET1^DIQ(60,IMRLAB,64,"I")
66 .S:IMRWKLD $P(^IMR(158.9,IMRD2,3,IMRD1,1,IMRD0,0),U,2)=IMRWKLD
67 .Q
68 K IMRD0,IMRD1,IMRD2,IMRLAB,IMRWKLD
69 Q
70 ;
71DELFILE ; remove unused File 158.96
72 D BMES^XPDUTL("Removing unused File 158.96 dictionary and data...")
73 S DIU="^IMR(158.96,",DIU(0)="DS" D EN^DIU2
74 Q
75 ;
76EXTRACT ; start data extract
77 D BMES^XPDUTL("Queuing the IMR REGISTRY DATA option to run immediately...")
78 S IMRSD=$P(^IMR(158.9,1,0),U,10)\1
79 S (IMRED,IMRDT)=$$NOW^XLFDT()
80 S $P(^IMR(158.9,1,0),U,9)=IMRED
81 S IMRC=0,IMRSET=0
82 D DQ^IMRDAT
83 K IMRC,IMRDT,IMRED,IMRSD,IMRSET
84 Q
85 ;
86KILL ; Kill variables
87 K DIU,IMRC,IMRCAT,IMRDT,IMRED,IMRIEN,IMRIEN1,IMRIEN2,IMRNODE,IMRPIECE,IMRX,IMRX1,IMRX2,IMRX3,IMRRISK,IMRSD,IMRSET,IMRSEX,XC0,XC1,XC2,XC102,XC110,X
88 Q
89 ;
90P1 ; Check/fix File 158 entries
91 S X=+IMRX D EN1^IMRXOR
92 Q:'$D(^DPT(X,0))
93 S (DFN,IMRDFN)=X D DEM^VADPT
94 S IMRDOD=$P(VADM(6),U,1),IMRSEX=$P(VADM(5),U,1),IMRDOB=$P(VADM(3),U,1)
95 S IMRX=$G(^IMR(158,IMRX1,5))
96 I $P(IMRX,U,19) S $P(IMRX,U,20)=0
97 I '$P(IMRX,U,19) S $P(IMRX,U,19)=$S(IMRDOD:IMRDOD,1:"") S $P(IMRX,U,20)=$S(IMRDOD:1,1:0) ;Populate IMR DATE OF DEATH
98 S ^IMR(158,IMRX1,5)=IMRX
99 D AAAD^IMRIPST1 K IMRAAAD,IMRNODE,X2
100 ;
101RISK ; continue on and set IMR RISK
102 S DA=+IMRX1
103 D ^IMRRISK
104 Q
105P2 ; remove data from fields that were deleted above
106 S $P(^IMR(158,IMRX1,102),U,3)=""
107 S $P(^IMR(158,IMRX1,102),U,4)=""
108 K ^IMR(158,IMRX1,106),^IMR(158,IMRX1,107)
109 Q
110OPT S DA=$O(^DIC(19,"B",IMRX,"")) I DA S DIK="^DIC(19," D ^DIK
111 Q
112RESCHED ; reschedule IMR REGISTRY DATA option in File 19.2
113 D BMES^XPDUTL("Rescheduling the IMR REGISTRY DATA option...")
114 K IMRAR
115 S IMRDA=$O(^DIC(19,"B","IMR REGISTRY DATA",0)) Q:'IMRDA
116 D FIND^DIC(19.2,"","2","Q",IMRDA,"","B","","","IMRAR")
117 S IMRLOOP=0
118 F S IMRLOOP=$O(IMRAR("DILIST",2,IMRLOOP)) Q:'IMRLOOP D
119 .S IMRIEN=+$G(IMRAR("DILIST",2,IMRLOOP)) Q:'IMRIEN
120 .S IMRDATE=$$GET1^DIQ(19.2,IMRIEN,2,"I")
121 .S IMRFREQ=$$GET1^DIQ(19.2,IMRIEN,6,"I")
122 .Q:IMRDATE<$$NOW^XLFDT ;quit if queued time is in past
123 .Q:IMRFREQ="" ;quit if no rescheduling frequency
124 .S IMRFREQ="1D" ;reschedule frequency=daily
125 .S IMRDATE=DT_"."_$P(IMRDATE,".",2)
126 .S IMRNDATE=$$FMADD^XLFDT(IMRDATE,1) ;reschedule for next day
127 .S IMR192(19.2,IMRIEN_",",2)=IMRNDATE
128 .S IMR192(19.2,IMRIEN_",",6)=IMRFREQ
129 .D FILE^DIE("K","IMR192","IMRERR")
130 .Q
131 K IMR192,IMRAR,IMRDA,IMRDATE,IMRFREQ,IMRIEN,IMRLOOP,IMRNDATE
132 Q
133DOMAIN ; Get domain (#4.2) pointer value for IMMUNOLOGY.VA.GOV entry
134 D FIND^DIC(4.2,"","","X","IMMUNOLOGY.VA.GOV","","B","","","IMRIEN","IMRERR")
135 S IMRDOMN=+$G(IMRIEN("DILIST",2,1))
136 K IMRIEN,IMRERR
137 Q
138DELIP ; Delete input templates
139 D BMES^XPDUTL("Deleting unused input templates...")
140 F IMRIP="IMR LPOINTER","IMR PPOINTER" D
141 .K DA,DIK,IMRIEN,IMRERR
142 .D FIND^DIC(.402,"","","X",IMRIP,"","B","","","IMRIEN","IMRERR")
143 .S DA=+$G(IMRIEN("DILIST",2,1))
144 .I DA>0 S DIK="^DIE(" D ^DIK
145 .Q
146 K DA,DIK,IMRIEN,IMRERR,IMRIP
147 Q
148F15895 ; Add VIRAL LOAD entry to File 158.95
149 D BMES^XPDUTL("Adding VIRAL LOAD entry to File 158.95...")
150 S X="VIRAL LOAD"
151 I $D(^IMR(158.95,"B",X)) K X Q
152 K DD,DO
153 S DIC="^IMR(158.95,",DIC(0)="L"
154 D FILE^DICN
155 K DIC,DD,DO,X,Y
156 Q
Note: See TracBrowser for help on using the repository browser.