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