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