Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRRLU

BLRRLU.m

Go to the documentation of this file. 
  1. BLRRLU ;cmi/anch/maw - BLR Reference Lab Utilities ; 02-Nov-2015 13:43 ; MAW
  1.  ;;5.2;IHS LABORATORY;**1027,1035,1037,1040**;NOV 01, 1997;Build 5
  1.  ;;5.2;LR;**1021**;Jul 27, 2006
  1.  ;
  1.  ;
  1.  ;
  1.  ;this routine will be used for items related to the reference lab
  1.  ;project
  1.  ;
  1.  Q
  1.  ;
  1. SITE ;EP - setup the site parameters in BLR MASTER CONTROL
  1.  ;and BLR REFERENCE LAB
  1.  W !,"Now setting up reference lab parameters.."
  1.  S DIC="^BLRRL(",DIC(0)="AEMQZ"
  1.  S DIC("A")="Setup Parameters for which Reference Lab: "
  1.  D ^DIC
  1.  S BLRRL=+Y
  1.  Q:'BLRRL
  1.  S BLRRLE=$P($G(^BLRRL(BLRRL,0)),U)
  1.  ;S DIE=DIC,DA=BLRRL,DR=".02:.07;.09;.11;1:4;6;7;20"  ;cmi/maw 4/3/2008 not used anymore now in BLR MASTER CONTROL
  1.  ;D ^DIE  ;cmi/maw 4/3/2008 not used anymore now in BLR MASTER CONTROL
  1.  K DIE,DR,DIC,DA
  1.  I +$G(^BLRSITE(DUZ(2),BLRRL)) D COPY(BLRRL)
  1.  W !!,"Now setting up GIS HL7 Message Parameters.."
  1.  S BLRMSG=$O(^INTHL7M("B","HL IHS LAB O01 "_BLRRLE,0))
  1.  Q:'BLRMSG
  1.  S DIE="^INTHL7M(",DA=BLRMSG,DR="7.01:7.04"
  1.  D ^DIE
  1.  K DIE,DR,DA
  1.  S DIC="^BLRSITE(",DIC(0)="AEMQZ"
  1.  S DIC("A")="Add this Reference Lab to which Site: "
  1.  D ^DIC
  1.  Q:Y<0
  1.  S DIE=DIC,DA=+Y,DR="3001////"_BLRRL_";3002:3023;3032;3044;3100;3200"  ;cmi/maw 4/3/2008 setup parameters in BLR MASTER CONTROL file
  1.  D ^DIE
  1.  K DIC,DIE,DR,DA
  1.  W !!,"Now setting up Lab HL7 Message Parameter File.."
  1.  I $O(^LAHM(62.48,"B",BLRRLE,0)) D
  1.  . K DD,DO,DIC
  1.  . S BLRHM=$O(^LAHM(62.48,"B",BLRRLE,0))
  1.  . I 'BLRHM W !!,"Error creating entry in LAHM(62.48" Q
  1.  . S DA(1)=BLRHM
  1.  . S DIC="^LAHM(62.48,"_DA(1)_",90,",DIC(0)="L"
  1.  . S DIC("P")=$P(^DD(62.48,90,0),U,2)
  1.  . S BLRRID=$P($G(^INTHL7M(BLRMSG,7)),U,4)_$P($G(^INTHL7M(BLRMSG,7)),U,2)
  1.  . S X=BLRRID
  1.  . D FILE^DICN
  1.  . I '+$G(Y) W !!,"Error creating entry in LAHM(62.48" Q
  1.  . S DIE="^LAHM(62.48,",DA=BLRHM,DR="2///A"
  1.  . D ^DIE
  1.  W !!,"Now activating Reference Lab Interface.."
  1.  D COMPILE^BHLU(BLRMSG)
  1.  Q
  1.  ;
  1. EMC ;-- edit the master control file
  1.  K DIE,DR,DA
  1.  S DIC="^BLRSITE(",DIC(0)="AEMQZ"
  1.  S DIC("A")="Edit which Reference Lab Site: "
  1.  D ^DIC
  1.  Q:Y<0
  1.  S DIE=DIC,DA=+Y,DR="3001:3021;3100;3200"  ;cmi/maw 12/8/2008 setup parameters in BLR MASTER CONTROL file
  1.  D ^DIE
  1.  K DIC,DIE,DR,DA
  1.  Q
  1.  ;
  1. COPY(RL) ;-- copy existing BLRRL settings to BLRSITE
  1.  I $P($G(^BLRSITE(DUZ(2),"RL")),U,18)="" D
  1.  . W !,"Now copying existing settings in BLR REFERENCE LAB file to each division in the BLR MASTER CONTROL FILE"
  1.  N BLREXP
  1.  Q
  1.  ;
  1. HOLD ;-- hold or release labs to pcc
  1.  S BLRRL=$P($G(^BLRSITE(DUZ(2),0)),U)
  1.  S DIE="^BLRRL(",DA=BLRRL,DR=11
  1.  D ^DIE
  1.  I $P($G(^BLRRL(BLRRL,0)),U,11) S BLRHOLD=1
  1.  D JOB^BLRPARAM
  1.  Q
  1.  ;
  1. PURGE ; EP -- purge entries in storage directory
  1.  S BLRRL=$P($G(^BLRSITE(DUZ(2),0)),U)
  1.  I '$G(BLRRL),'$D(ZTQUEUED) D  Q
  1.  . W !!,"No reference lab defined in BLR MASTER CONTROL file"
  1.  S BLRSDIR=$P($G(^BLRRL(BLRRL,0)),U,9)
  1.  S BLRSFL=$P($G(^BLRRL(BLRRL,0)),U,7)
  1.  I $G(BLRSDIR)="",'$D(ZTQUEUED) D  Q
  1.  . W !!,"No storage directory to remove files from"
  1.  S BLRDAYS=$P($G(^BLRRL(BLRRL,0)),U,12)
  1.  I 'BLSDAYS S BLSDAYS=90
  1.  S BLRT=$$BLST(DT,BLSDAYS)
  1.  S BLRTE=$$FMTE^XLFDT(BLST)
  1.  S BLRCDA=0
  1.  W !,"Now cleaning up import/export log file entries older than "_BLRTE
  1.  F  S BLRCDA=$O(^BLRRLG("BDT",BLRCDA)) Q:'BLRCDA!(BLRCDA>BLRT)  D
  1.  . S BLRCIEN=0
  1.  . F  S BLRCIEN=$O(^BLRRLG("BDT",BLRCDA,BLRCIEN)) Q:'BLRCIEN  D
  1.  .. W "."
  1.  .. S BLRFILES(BLRCIEN)=$P($G(^BLRRLG(BLRCIEN,0)),U)
  1.  .. S DIK="^BLRRLG(",DA=BLRCIEN D ^DIK
  1.  W !!,"Now cleaning up host files older than "_BLRTE
  1.  S BLRFLST=$$LIST^%ZISH(BLRSDIR,BLRSFL_"*",.BLRFILES)
  1.  I '$O(BLRFILES("")) D  Q
  1.  . Q:$D(ZTQUEUED)
  1.  . W !!,"No host files to remove"
  1.  S BLRFDA=0 F  S BLRFDA=$O(BLRFILES(BLRFDA)) Q:'BLRFDA  D
  1.  . S BLRFNM=$G(BLRFILES(BLRFDA))
  1.  . I '$D(ZTQUEUED) D
  1.  .. W !,"Removing export file "_BLRFNM_" in directory "_BLRSDIR
  1.  . ;cmi/maw orig
  1.  . ;S BLROS=$P($G(^AUTTSITE(1,0)),U,21)
  1.  . ;I BLROS=1 S X=$$JOBWAIT^%HOSTCMD("rm "_BLRSDIR_BLRFNM)
  1.  . ;I BLROS=2 S X=$ZOS(2,BLRSDIR_BLRFNM)
  1.  . S BLRDMSG=$$DEL^%ZISH(BLRSDIR,BLRFNM)  ;cmi/maw new 4/16/03
  1.  . I '$D(ZTQUEUED) D
  1.  .. W !,"File "_BLRFNM_" removed"
  1.  Q
  1.  ;
  1. PURGESM ;-- purge the shipping manifest over time
  1.  N BLRDAYS,BLRSTART
  1.  I '$D(ZTQUEUED) D  Q:'$G(BLRDAYS)
  1.  . K DIR
  1.  . S DIR(0)="N^1:365",DIR("A")="Purge Shipping Manifests older than how many days "
  1.  . S DIR("B")=90
  1.  . D ^DIR
  1.  . I $D(DIRUT) K Y
  1.  . S BLRDAYS=+$G(Y)
  1.  I '$G(BLRDAYS) S BLRDAYS=90
  1.  S X1=DT,X2=-BLRDAYS
  1.  D C^%DTC
  1.  S BLRSTART=X
  1.  I $P($G(^BLRSITE(DUZ(2),"RL")),U,22) D PURGELSM(BLRSTART) Q
  1.  N BLRRLDA
  1.  S BLRRLDA=0 F  S BLRRLDA=$O(^BLRSHPM(BLRRLDA)) Q:'BLRRLDA  D
  1.  . Q:$P($G(^BLRSHPM(BLRRLDA,0)),U,3)>BLRSTART
  1.  . Q:$P($G(^BLRSHPM(BLRRLDA,11,0)),U,5)>BLRSTART
  1.  . S DIK="^BLRSHPM(",DA=BLRRLDA  D ^DIK
  1.  ;S BLRRLDA=0 F  S BLRRLDA=$O(^BLRSHPM("ADT",BLRRLDA)) Q:'BLRRLDA!(BLRRLDA>BLRSTART)  D
  1.  ;. N BLRRLIEN
  1.  ;. S BLRRLIEN=0 F  S BLRRLIEN=$O(^BLRSHPM("ADT",BLRRLDA,BLRRLIEN)) Q:'BLRRLIEN  D
  1.  ;.. S DIK="^BLRSHPM(",DA=BLRRLIEN D ^DIK
  1.  Q
  1.  ;
  1. PURGELSM(START) ;-- purge the ledi shipping manifest over time
  1.  N BLRDA,BLRIDT,BLRIEN,BLRST,BLRPRG
  1.  S BLRDA=0 F  S BLRDA=$O(^LAHM(62.8,"B",BLRDA)) Q:BLRDA=""  D
  1.  . S BLRIDT=$P(BLRDA,"-",2)
  1.  . S BLRIDT=$$HL7TFM^XLFDT(BLRIDT)
  1.  . Q:BLRIDT>START
  1.  . S BLRIEN=0 F  S BLRIEN=$O(^LAHM(62.8,"B",BLRDA,BLRIEN)) Q:'BLRIEN  D
  1.  .. S BLRPRG=0
  1.  .. I $P($G(^LAHM(62.8,BLRIEN,0)),U,3)=0 S BLRPRG=1
  1.  .. I $P($G(^LAHM(62.8,BLRIEN,0)),U,3)=4 S BLRPRG=1
  1.  .. I $G(BLRPRG)=1 S DIK="^LAHM(62.8,",DA=BLRIEN D ^DIK
  1.  Q
  1.  ;
  1. LOG(FNM,TYP,USER)  ;EP - log the entry
  1.  I $O(^BLRRLG("B",FNM,0)) D  Q BLRLGI
  1.  . S BLRLGI=$O(^BLRRLG("B",FNM,0))
  1.  . S DIE="^BLRRLG(",DA=BLRLGI,DR=".04////"_$$NOW_";.05////"_USER
  1.  . D ^DIE
  1.  . K DIE
  1.  . Q
  1.  K DD,DO,DIC
  1.  S DIC="^BLRRLG(",DIC(0)="L"
  1.  S DIC("DR")=".02////"_$$NOW_";.03///"_TYP_";.05////"_USER
  1.  S X=FNM
  1.  D FILE^DICN
  1.  K DIC
  1.  Q +Y
  1.  ;
  1. LOGM(FNM,ENT)       ; EP -- log the entry in the universal interface file
  1.  S BLRLGI=$O(^BLRRLG("B",FNM,0))
  1.  I 'BLRLGI Q ""
  1.  I $G(ENT),'$O(ENT("")) D  Q BLRLLGI
  1.  . K DD,DO,DIC
  1.  . S DA(1)=BLRLGI
  1.  . S DIC="^BLRRLG("_DA(1)_",1,",X=$G(ENT),DIC(0)="L"
  1.  . S DIC("P")=$P(^DD(9009026.1,1,0),U,2)
  1.  . D FILE^DICN
  1.  . S BLRLLGI=+Y
  1.  S BLRLDA=0 F  S BLRLDA=$O(ENT(BLRLDA)) Q:'BLRLDA  D
  1.  . K DD,DO,DIC
  1.  . S DA(1)=BLRLGI
  1.  . S DIC="^BLRRLG("_DA(1)_",1,",X=BLRLDA,DIC(0)="L"
  1.  . S DIC("P")=$P(^DD(9009026.1,1,0),U,2)
  1.  . D FILE^DICN
  1.  . S BLRLLGI=+Y
  1.  Q $G(BLRLLGI)
  1.  ;
  1. NOW() ;-- get now
  1.  D NOW^%DTC
  1.  Q %
  1.  ;
  1. XREF ;-- reindex the UPIN index if not existent
  1.  Q:$O(^VA(200,"AUPIN",0))
  1.  W !,"Reindexing UPIN cross reference, stand by..."
  1.  S DIK="^VA(200,",DIK(1)="9999999.08^UPIN"
  1.  D ENALL^DIK
  1.  Q
  1.  ;
  1. BLST(DT,DAYS) ;-- return day to purge by
  1.  S X1=DT,X2=-DAYS D C^%DTC
  1.  Q X
  1.  ;
  1. PORD ;-- purge the BLR REFERENCE LAB ORDER ACCESSION file
  1.  N PASK
  1.  S PASK=$$PASK
  1.  Q:'$G(PASK)
  1.  D PRG(PASK)
  1.  K DIK,DA
  1.  Q
  1.  ;
  1. PASK() ;-- ask the purge date
  1.  K %DT
  1.  S %DT="AE",%DT("A")="Purge entries before which date? "
  1.  D ^%DT
  1.  I Y=-1 Q 0
  1.  Q +Y
  1.  Q
  1.  ;
  1. PRG(PSK) ;-- purge entries before this date
  1.  N PDA,PIEN
  1.  S PDA=0 F  S PDA=$O(^BLRRLO("ACC",PDA)) Q:'PDA  D
  1.  . S PIEN=0 F  S PIEN=$O(^BLRRLO("ACC",PDA,PIEN)) Q:'PIEN  D
  1.  .. I $$BEFORE(PDA,PSK) D
  1.  ... I '$D(ZTQUEUED) W "."
  1.  ... S DIK="^BLRRLO(",DA=PIEN D ^DIK
  1.  Q
  1.  ;
  1. BEFORE(PD,PS) ;-- is the accession before the purge date
  1.  N RT,AA,AD,AN,OD
  1.  S RT=$Q(^LRO(68,"C",PD))
  1.  S AA=$QS(RT,4)
  1.  S AD=$QS(RT,5)
  1.  S AN=$QS(RT,6)
  1.  S OD=$P($G(^LRO(68,AA,1,AD,1,AN,0)),U,4)
  1.  Q $S((OD<PS):1,1:0)
  1.  Q
  1.  ;
  1. QPASK ;-- queueable pask
  1.  N PASK
  1.  S PASK=$$BLST(DT,90)
  1.  D PRG(PASK)
  1.  K DIK,DA
  1.  Q
  1.  ;