157 lines
6.0 KiB
Mathematica
157 lines
6.0 KiB
Mathematica
IMRIPST ;HCIOFO/NCA,FT-Post-Init Immunology Routine ;11/10/97 9:02
|
|
;;2.1;IMMUNOLOGY CASE REGISTRY;;Feb 09, 1998
|
|
Q:+$$VERSION^XPDUTL("IMR")'>0 ;quit if virgin install
|
|
Q:'$D(^IMR(158.96)) ;quit if post-init has already run
|
|
D DELFLDS,DELRTN,DELDATA,DELOPT,PROC,NLF,DELFILE,DELIP,F15895
|
|
D EXTRACT,RESCHED,KILL
|
|
D ^IMRIPST1
|
|
Q
|
|
DELFLDS ; delete unused fields from File 158
|
|
D BMES^XPDUTL("Removing Unused Data Dictionary Fields...")
|
|
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
|
|
K DA,DIK S DIK="^DD(158.9,",DA(1)=158.9 F DA=.02,.03,.04,.08,.11,.12,.13 D ^DIK
|
|
K DA,DIK S DIK="^DD(158.921,",DA(1)=158.921,DA=.02 D ^DIK
|
|
K DA,DIK
|
|
Q
|
|
;
|
|
DELRTN ; delete unused routines
|
|
D BMES^XPDUTL("Deleting Unused Routines...")
|
|
F X="IMRLRAD","IMRLRAD1","IMRLRAD2","IMRSRX","IMRSRX1","IMRLRX","IMRLRX1","IMRLRX2","IMRLRX3","IMRNTEG","IMRPOST1","IMRPOST2","IMRPOSTI","IMRPRE1","IMRPREI","IMROPSUR","IMRCDC5" X ^%ZOSF("DEL")
|
|
Q
|
|
;
|
|
DELDATA ; remove data from unused fields in File 158.9
|
|
; add Domain file pointer to File 158.9
|
|
D BMES^XPDUTL("Deleting Unused Data...")
|
|
D DOMAIN ;get domain pointer value
|
|
S IMRIEN=0
|
|
F S IMRIEN=$O(^IMR(158.9,IMRIEN)) Q:'IMRIEN D
|
|
.S IMRNODE=$G(^IMR(158.9,IMRIEN,0)) Q:IMRNODE=""
|
|
.F IMRPIECE=2,3,4,8,11,12,13 S $P(IMRNODE,U,IMRPIECE)=""
|
|
.S ^IMR(158.9,IMRIEN,0)=IMRNODE
|
|
.I $G(IMRDOMN) S $P(^IMR(158.9,IMRIEN,"DOMAIN"),U,1)=IMRDOMN ;add domain pointer value to 158.9 entry
|
|
.S IMRIEN1=0
|
|
.F S IMRIEN1=$O(^IMR(158.9,IMRIEN,2,IMRIEN1)) Q:'IMRIEN1 D
|
|
..S IMRIEN2=0
|
|
..F S IMRIEN2=$O(^IMR(158.9,IMRIEN,2,IMRIEN1,1,IMRIEN2)) Q:'IMRIEN2 D
|
|
...S $P(^IMR(158.9,IMRIEN,2,IMRIEN1,1,IMRIEN2,0),U,2)=""
|
|
...Q
|
|
..Q
|
|
.Q
|
|
K IMRIEN,IMRIEN1,IMRIEN2,IMRNODE,IMRPIECE
|
|
Q
|
|
;
|
|
DELOPT ; remove old unused options
|
|
D BMES^XPDUTL("Removing Unused Options...")
|
|
F IMRX="IMRO REPORTS MENU","IMRO BY DX","IMRO BY NAME","IMRO DELETE","IMRO ENTER","IMRO MASTER","IMRO NO DX","IMRO TRANSMIT" D OPT
|
|
S IMRX="IMRO"
|
|
F S IMRX=$O(^DIC(19,"B",IMRX)) Q:$E(IMRX,1,4)'="IMRO" D OPT
|
|
K DA,DIK,IMRX
|
|
Q
|
|
;
|
|
PROC ; Populate fields in File 158
|
|
D BMES^XPDUTL("Populating Data Fields in File 158...")
|
|
; $P(^IMR(158,IMRX1,0),U,36)=DATE OF HIV+ (CAT 1) STATUS
|
|
; " 42)=CATEGORY
|
|
; " 44)=DATE OF HIV+ (CAT 2) STATUS
|
|
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
|
|
K DA,DFN,I,IMRAAAD,IMRX,IMRX1,IMRDT,IMRCAT,IMRDFN,IMRDOB,IMRDOD,IMRSEX,VADM,X2
|
|
Q
|
|
;
|
|
NLF ; populate new NLF ENTRY field in File 158.9
|
|
D BMES^XPDUTL("Populating new NLF ENTRY field in File 158.9...")
|
|
S IMRD2=0
|
|
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
|
|
.S IMRLAB=+$G(^IMR(158.9,IMRD2,3,IMRD1,1,IMRD0,0)) Q:'IMRLAB
|
|
.S IMRWKLD=$$GET1^DIQ(60,IMRLAB,64,"I")
|
|
.S:IMRWKLD $P(^IMR(158.9,IMRD2,3,IMRD1,1,IMRD0,0),U,2)=IMRWKLD
|
|
.Q
|
|
K IMRD0,IMRD1,IMRD2,IMRLAB,IMRWKLD
|
|
Q
|
|
;
|
|
DELFILE ; remove unused File 158.96
|
|
D BMES^XPDUTL("Removing unused File 158.96 dictionary and data...")
|
|
S DIU="^IMR(158.96,",DIU(0)="DS" D EN^DIU2
|
|
Q
|
|
;
|
|
EXTRACT ; start data extract
|
|
D BMES^XPDUTL("Queuing the IMR REGISTRY DATA option to run immediately...")
|
|
S IMRSD=$P(^IMR(158.9,1,0),U,10)\1
|
|
S (IMRED,IMRDT)=$$NOW^XLFDT()
|
|
S $P(^IMR(158.9,1,0),U,9)=IMRED
|
|
S IMRC=0,IMRSET=0
|
|
D DQ^IMRDAT
|
|
K IMRC,IMRDT,IMRED,IMRSD,IMRSET
|
|
Q
|
|
;
|
|
KILL ; Kill variables
|
|
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
|
|
Q
|
|
;
|
|
P1 ; Check/fix File 158 entries
|
|
S X=+IMRX D EN1^IMRXOR
|
|
Q:'$D(^DPT(X,0))
|
|
S (DFN,IMRDFN)=X D DEM^VADPT
|
|
S IMRDOD=$P(VADM(6),U,1),IMRSEX=$P(VADM(5),U,1),IMRDOB=$P(VADM(3),U,1)
|
|
S IMRX=$G(^IMR(158,IMRX1,5))
|
|
I $P(IMRX,U,19) S $P(IMRX,U,20)=0
|
|
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
|
|
S ^IMR(158,IMRX1,5)=IMRX
|
|
D AAAD^IMRIPST1 K IMRAAAD,IMRNODE,X2
|
|
;
|
|
RISK ; continue on and set IMR RISK
|
|
S DA=+IMRX1
|
|
D ^IMRRISK
|
|
Q
|
|
P2 ; remove data from fields that were deleted above
|
|
S $P(^IMR(158,IMRX1,102),U,3)=""
|
|
S $P(^IMR(158,IMRX1,102),U,4)=""
|
|
K ^IMR(158,IMRX1,106),^IMR(158,IMRX1,107)
|
|
Q
|
|
OPT S DA=$O(^DIC(19,"B",IMRX,"")) I DA S DIK="^DIC(19," D ^DIK
|
|
Q
|
|
RESCHED ; reschedule IMR REGISTRY DATA option in File 19.2
|
|
D BMES^XPDUTL("Rescheduling the IMR REGISTRY DATA option...")
|
|
K IMRAR
|
|
S IMRDA=$O(^DIC(19,"B","IMR REGISTRY DATA",0)) Q:'IMRDA
|
|
D FIND^DIC(19.2,"","2","Q",IMRDA,"","B","","","IMRAR")
|
|
S IMRLOOP=0
|
|
F S IMRLOOP=$O(IMRAR("DILIST",2,IMRLOOP)) Q:'IMRLOOP D
|
|
.S IMRIEN=+$G(IMRAR("DILIST",2,IMRLOOP)) Q:'IMRIEN
|
|
.S IMRDATE=$$GET1^DIQ(19.2,IMRIEN,2,"I")
|
|
.S IMRFREQ=$$GET1^DIQ(19.2,IMRIEN,6,"I")
|
|
.Q:IMRDATE<$$NOW^XLFDT ;quit if queued time is in past
|
|
.Q:IMRFREQ="" ;quit if no rescheduling frequency
|
|
.S IMRFREQ="1D" ;reschedule frequency=daily
|
|
.S IMRDATE=DT_"."_$P(IMRDATE,".",2)
|
|
.S IMRNDATE=$$FMADD^XLFDT(IMRDATE,1) ;reschedule for next day
|
|
.S IMR192(19.2,IMRIEN_",",2)=IMRNDATE
|
|
.S IMR192(19.2,IMRIEN_",",6)=IMRFREQ
|
|
.D FILE^DIE("K","IMR192","IMRERR")
|
|
.Q
|
|
K IMR192,IMRAR,IMRDA,IMRDATE,IMRFREQ,IMRIEN,IMRLOOP,IMRNDATE
|
|
Q
|
|
DOMAIN ; Get domain (#4.2) pointer value for IMMUNOLOGY.VA.GOV entry
|
|
D FIND^DIC(4.2,"","","X","IMMUNOLOGY.VA.GOV","","B","","","IMRIEN","IMRERR")
|
|
S IMRDOMN=+$G(IMRIEN("DILIST",2,1))
|
|
K IMRIEN,IMRERR
|
|
Q
|
|
DELIP ; Delete input templates
|
|
D BMES^XPDUTL("Deleting unused input templates...")
|
|
F IMRIP="IMR LPOINTER","IMR PPOINTER" D
|
|
.K DA,DIK,IMRIEN,IMRERR
|
|
.D FIND^DIC(.402,"","","X",IMRIP,"","B","","","IMRIEN","IMRERR")
|
|
.S DA=+$G(IMRIEN("DILIST",2,1))
|
|
.I DA>0 S DIK="^DIE(" D ^DIK
|
|
.Q
|
|
K DA,DIK,IMRIEN,IMRERR,IMRIP
|
|
Q
|
|
F15895 ; Add VIRAL LOAD entry to File 158.95
|
|
D BMES^XPDUTL("Adding VIRAL LOAD entry to File 158.95...")
|
|
S X="VIRAL LOAD"
|
|
I $D(^IMR(158.95,"B",X)) K X Q
|
|
K DD,DO
|
|
S DIC="^IMR(158.95,",DIC(0)="L"
|
|
D FILE^DICN
|
|
K DIC,DD,DO,X,Y
|
|
Q
|