BLSLX ; IHS/CMI/LAB - BLS export data ; [ 02/20/2003 6:40 AM ]
;;5.2;LR;**1015**;NOV 18, 2002
;
;
EN(BLSX) ;EP - called from APCDALVR
I '$G(BLSX) Q
Q:'$$ADDON^BLRUTIL("LR*5.2*1015","BLSLX",DUZ(2)) ;REAL
I '$D(^AUPNVLAB(BLSX)) Q
I $P($G(^AUPNVLAB(BLSX,11)),U,9)'="R" Q
NEW BLSLOINC
S BLSLOINC=$P($G(^AUPNVLAB(BLSX,11)),U,13)
Q:BLSLOINC=""
I '$D(^BLSELL(BLSLOINC)) Q ;not a test cereplex wants
I '$G(BLSRX) I $D(^BLSLX(BLSX,0)),$P(^BLSLX(BLSX,0),U,3)="" Q
S ^BLSLX(BLSX,0)=BLSX_"^"_DT
S ^BLSLX("AEXP",DT,BLSX)="",^BLSLX("B",BLSX,BLSX)=""
L +^BLSLX(0):10
S $P(^BLSLX(0),U,3)=BLSX,$P(^BLSLX(0),U,4)=$P(^BLSLX(0),U,4)+1
L -^BLSLX(0)
K BLSX
Q
;
EXPORT ;EP - loop through BLSLX and export message
I '$D(ZTQUEUED) W !,"Generating HL7 messages for export"
S BLSDA=0 F S BLSDA=$O(^BLSLX("AEXP",BLSDA)) Q:'BLSDA D
. S BLSIEN=0 F S BLSIEN=$O(^BLSLX("AEXP",BLSDA,BLSIEN)) Q:'BLSIEN D
.. S BLSERR=$$R01SS^BHLEVENT(BLSIEN)
.. Q:'INHF
.. I '$D(ZTQUEUED) W "."
.. S DIE="^BLSLX(",DA=BLSIEN,DR=".03////"_DT D ^DIE
.. K DIE,DR
S BLSDEST=$O(^INRHD("B","HL IHS LOINC",0))
Q:'BLSDEST
S BLSDIR=$P($G(^BLRSITE(DUZ(2),5)),U,3)
;S BLSXPD=$P($G(^BLRSITE(DUZ(2),5)),U,2)
S BLSLLI=$P($G(^BLRSITE(DUZ(2),5)),U,5)
S BLSLPI=$P($G(^BLRSITE(DUZ(2),5)),U,6)
I BLSLLI]"" S BLSLL=$$DQ(BLSLLI)
I BLSLPI]"" S BLSLP=$$DQ(BLSLPI)
S BLSPASS=$G(BLSLL)_":"_$G(BLSLP)
I BLSPASS=":" S BLSPASS=""
S BLSFTP=$P($G(^BLRSITE(DUZ(2),5)),U)
S BLSFNM="BLS"_$$FAC(DUZ(2))_$E($$DATE^INHUT($$NOW,1),1,14)_".HL7"
I '$D(ZTQUEUED) D
. W !!,"Now writing export file, this could take up to 5 minutes"
H 300 ;for message generation to occur
D HFSA^BHLU(BLSDEST,BLSDIR,BLSFNM)
I '$D(ZTQUEUED) D
. W !,"Export file "_BLSFNM_" in directory "_BLSDIR_" created"
. W !,"Sending to IP Address "_BLSFTP
D SENDFILE(BLSFNM,BLSDIR,BLSFTP,BLSPASS)
I '$D(ZTQUEUED) D
. W !,"File "_BLSFNM_" sent to "_BLSFTP
D BUL(BLSFTP,BLSDIR,BLSFNM)
Q
;
BUL(FTP,DIR,FNM) ;-- send a bulletin indicating file send
S XMB="BLS EXPORT FILE SENT"
S XMB(1)=FNM
S XMB(2)=DIR
S XMB(3)=FTP
D ^XMB
K XMB
Q
;
RESEND ;EP -- resend a file
S BLSDIR=$P($G(^BLRSITE(DUZ(2),5)),U,3)
S BLSFLST=$$LIST(BLSDIR)
I BLSFLST<1 W !,"No Files in the directory, goodbye" Q
S BLSLSDA=0 F S BLSLSDA=$O(BLSFILES(BLSLSDA)) Q:'BLSLSDA D
. W !,BLSLSDA_" - "_$G(BLSFILES(BLSLSDA))
S DIR(0)="L^1:"_BLSFLST,DIR("A")="Resend which file(s) "
D ^DIR
Q:$D(DIRUT)
S BLSFNMI=Y
F BLSI=1:1:BLSFLST S BLSFLI=$P(BLSFNMI,",",BLSI) Q:BLSFLI="" D
. S BLSFNM=$G(BLSFILES(BLSFLI))
. ;S BLSXPD=$P($G(^BLRSITE(DUZ(2),5)),U,2)
. S BLSFTP=$P($G(^BLRSITE(DUZ(2),5)),U)
. S BLSLLI=$P($G(^BLRSITE(DUZ(2),5)),U,5)
. S BLSLPI=$P($G(^BLRSITE(DUZ(2),5)),U,6)
. I BLSLLI]"" S BLSLL=$$DQ(BLSLLI)
. I BLSLPI]"" S BLSLP=$$DQ(BLSLPI)
. S BLSPASS=$G(BLSLL)_":"_$G(BLSLP)
. I BLSPASS=":" S BLSPASS=""
. W !,"Sending export file "_BLSFNM_" in directory "_BLSDIR
. W !,"Sending to IP Address "_BLSFTP
. D SENDFILE(BLSFNM,BLSDIR,BLSFTP,BLSPASS)
. W !,"File "_BLSFNM_" sent to "_BLSFTP
. D BUL(BLSFTP,BLSDIR,BLSFNM)
Q
;
CLEANUP ;EP -- cleanup files older than parameter days
S BLSDIR=$P($G(^BLRSITE(DUZ(2),5)),U,3)
S BLSDAYS=$P($G(^BLRSITE(DUZ(2),5)),U,4)
I 'BLSDAYS S BLSDAYS=30
S BLST=$$BLST(DT,BLSDAYS)
S BLSTE=$$FMTE^XLFDT(BLST)
S BLSCDA=0
W !,"Now cleaning up export log file entries older than "_BLSTE
F S BLSCDA=$O(^BLSLX("ADXP",BLSCDA)) Q:'BLSCDA!(BLSCDA>BLST) D
. S BLSCIEN=0
. F S BLSCIEN=$O(^BLSLX("ADXP",BLSCDA,BLSCIEN)) Q:'BLSCIEN D
.. W "."
.. S DIK="^BLSLX(",DA=BLSCIEN D ^DIK
W !!,"Now cleaning up host files older than "_BLSTE
S BLSFLST=$$LIST(BLSDIR)
Q:'$O(BLSFILES(""))
S BLSFDA=0 F S BLSFDA=$O(BLSFILES(BLSFDA)) Q:'BLSFDA D
. S BLSFNM=$G(BLSFILES(BLSFDA))
. S BLSFDT=$$HDATE^INHUT($E(BLSFNM,10,17))
. Q:'+$G(BLSFDT)
. Q:BLSFDT>BLST
. W !,"Removing export file "_BLSFNM_" in directory "_BLSDIR
. ;S BLSOS=$P($G(^AUTTSITE(1,0)),U,21)
. ;I BLSOS=1 S X=$$TERMINAL^%HOSTCMD("rm "_BLSDIR_BLSFNM)
. ;I BLSOS=2 S X=$ZOS(2,BLSDIR_BLSFNM)
. ;W !,"File "_BLSFNM_" removed"
.;BEGIN MOD
.S X=$$DEL^%ZISH(BLSDIR,BLSFNM) ;IHS/ITSC/TPF 1/27/2003 REMOVE VENDOR SPECIFIC CODE ABOVE ; X=0 IF SUCCESSFUL
.I 'X W !,"File "_BLSFNM_" removed"
.;END MOD
Q
;
RFILE ;EP - remove files from hfs
S BLSDIR=$P($G(^BLRSITE(DUZ(2),5)),U,3)
S BLSFLST=$$LIST(BLSDIR)
I BLSFLST<1 W !,"No Files in the directory, goodbye" Q
S BLSLSDA=0 F S BLSLSDA=$O(BLSFILES(BLSLSDA)) Q:'BLSLSDA D
. W !,BLSLSDA_" - "_$G(BLSFILES(BLSLSDA))
S DIR(0)="L^1:"_BLSFLST,DIR("A")="Remove which file(s) "
D ^DIR
Q:$D(DIRUT)
S BLSFNMI=Y
F BLSI=1:1:BLSFLST S BLSFLI=$P(BLSFNMI,",",BLSI) Q:BLSFLI="" D
. S BLSFNM=$G(BLSFILES(BLSFLI))
. ;S BLSXPD=$P($G(^BLRSITE(DUZ(2),5)),U,2)
. S BLSFTP=$P($G(^BLRSITE(DUZ(2),5)),U)
. W !,"Removing export file "_BLSFNM_" in directory "_BLSDIR
. ;S BLSOS=$P($G(^AUTTSITE(1,0)),U,21)
. ;I BLSOS=1 S X=$$TERMINAL^%HOSTCMD(BLSDIR_BLSFNM)
. ;I BLSOS=2 S X=$ZOS(2,BLSDIR_BLSFNM)
. ;W !,"File "_BLSFNM_" removed"
.;BEGIN MOD
.S X=$$DEL^%ZISH(BLSDIR,BLSFNM) ;IHS/ITSC/TPF 1/27/2003 REMOVE VENDOR SPECIFIC CODE ABOVE; X=0 IF SUCCESSFUL
.I 'X W !,"File "_BLSFNM_" removed"
.;END MOD
Q
;
SENDFILE(FNM,SDIR,IP,PASS) ;-- this will trigger a send via the sendto command, sendto.pl must exist
S BLSOPS=$P($G(^AUTTSITE(1,0)),U,21)
;I PASS["anonymous" D Q
;. S BLSSEND="sendto -i"_$S(BHLOPS=1:" ",1:" -a ")_IP_" "_SDIR_FNM
;. S X=$$JOBWAIT^%HOSTCMD(BLSSEND)
;S BLSSEND="sendto1 -u -l "_PASS_$S(BLSOPS=1:" ",1:" -a ")_IP_" "_SDIR_FNM
;S X=$$JOBWAIT^%HOSTCMD(BLSSEND)
S RESULT=$$SEND^%ZISH(SDIR,FNM,IP) ;CHANGE REQUIRED BY SAC REQUIREMENTS IHS/ITSC/TPF 02/10/03 RESULT=0 IF SUCCESSFUL
;
Q
;
BLST(DATE,DAYS) ;-- find cleanup date
S X1=DATE,X2=-(DAYS)
D C^%DTC
Q X
;
NOW() ;-- return now in fm dt
D NOW^%DTC
Q %
;
LIST(DIR) ;-- get a list of files in the directory
S Y=$$LIST^%ZISH(DIR,"BLS*",.BLSFILES)
Q $O(BLSFILES(""),-1)
;
FAC(LOC) ;-- return the asufac code
Q $P($G(^AUTTLOC(LOC,0)),U,10)
;
DQ(DEQ) ;-- decrypt the password
N X,X1,X2
S (X1,X2)=5,X=DEQ
D DE^XUSHSHP
Q X
;
BLSLX ; IHS/CMI/LAB - BLS export data ; [ 02/20/2003 6:40 AM ]
+1 ;;5.2;LR;**1015**;NOV 18, 2002
+2 ;
+3 ;
EN(BLSX) ;EP - called from APCDALVR
+1 IF '$GET(BLSX)
QUIT
+2 ;REAL
IF '$$ADDON^BLRUTIL("LR*5.2*1015","BLSLX",DUZ(2))
QUIT
+3 IF '$DATA(^AUPNVLAB(BLSX))
QUIT
+4 IF $PIECE($GET(^AUPNVLAB(BLSX,11)),U,9)'="R"
QUIT
+5 NEW BLSLOINC
+6 SET BLSLOINC=$PIECE($GET(^AUPNVLAB(BLSX,11)),U,13)
+7 IF BLSLOINC=""
QUIT
+8 ;not a test cereplex wants
IF '$DATA(^BLSELL(BLSLOINC))
QUIT
+9 IF '$GET(BLSRX)
IF $DATA(^BLSLX(BLSX,0))
IF $PIECE(^BLSLX(BLSX,0),U,3)=""
QUIT
+10 SET ^BLSLX(BLSX,0)=BLSX_"^"_DT
+11 SET ^BLSLX("AEXP",DT,BLSX)=""
SET ^BLSLX("B",BLSX,BLSX)=""
+12 LOCK +^BLSLX(0):10
+13 SET $PIECE(^BLSLX(0),U,3)=BLSX
SET $PIECE(^BLSLX(0),U,4)=$PIECE(^BLSLX(0),U,4)+1
+14 LOCK -^BLSLX(0)
+15 KILL BLSX
+16 QUIT
+17 ;
EXPORT ;EP - loop through BLSLX and export message
+1 IF '$DATA(ZTQUEUED)
WRITE !,"Generating HL7 messages for export"
+2 SET BLSDA=0
FOR
SET BLSDA=$ORDER(^BLSLX("AEXP",BLSDA))
IF 'BLSDA
QUIT
Begin DoDot:1
+3 SET BLSIEN=0
FOR
SET BLSIEN=$ORDER(^BLSLX("AEXP",BLSDA,BLSIEN))
IF 'BLSIEN
QUIT
Begin DoDot:2
+4 SET BLSERR=$$R01SS^BHLEVENT(BLSIEN)
+5 IF 'INHF
QUIT
+6 IF '$DATA(ZTQUEUED)
WRITE "."
+7 SET DIE="^BLSLX("
SET DA=BLSIEN
SET DR=".03////"_DT
DO ^DIE
+8 KILL DIE,DR
End DoDot:2
End DoDot:1
+9 SET BLSDEST=$ORDER(^INRHD("B","HL IHS LOINC",0))
+10 IF 'BLSDEST
QUIT
+11 SET BLSDIR=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,3)
+12 ;S BLSXPD=$P($G(^BLRSITE(DUZ(2),5)),U,2)
+13 SET BLSLLI=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,5)
+14 SET BLSLPI=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,6)
+15 IF BLSLLI]""
SET BLSLL=$$DQ(BLSLLI)
+16 IF BLSLPI]""
SET BLSLP=$$DQ(BLSLPI)
+17 SET BLSPASS=$GET(BLSLL)_":"_$GET(BLSLP)
+18 IF BLSPASS=":"
SET BLSPASS=""
+19 SET BLSFTP=$PIECE($GET(^BLRSITE(DUZ(2),5)),U)
+20 SET BLSFNM="BLS"_$$FAC(DUZ(2))_$EXTRACT($$DATE^INHUT($$NOW,1),1,14)_".HL7"
+21 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+22 WRITE !!,"Now writing export file, this could take up to 5 minutes"
End DoDot:1
+23 ;for message generation to occur
HANG 300
+24 DO HFSA^BHLU(BLSDEST,BLSDIR,BLSFNM)
+25 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+26 WRITE !,"Export file "_BLSFNM_" in directory "_BLSDIR_" created"
+27 WRITE !,"Sending to IP Address "_BLSFTP
End DoDot:1
+28 DO SENDFILE(BLSFNM,BLSDIR,BLSFTP,BLSPASS)
+29 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+30 WRITE !,"File "_BLSFNM_" sent to "_BLSFTP
End DoDot:1
+31 DO BUL(BLSFTP,BLSDIR,BLSFNM)
+32 QUIT
+33 ;
BUL(FTP,DIR,FNM) ;-- send a bulletin indicating file send
+1 SET XMB="BLS EXPORT FILE SENT"
+2 SET XMB(1)=FNM
+3 SET XMB(2)=DIR
+4 SET XMB(3)=FTP
+5 DO ^XMB
+6 KILL XMB
+7 QUIT
+8 ;
RESEND ;EP -- resend a file
+1 SET BLSDIR=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,3)
+2 SET BLSFLST=$$LIST(BLSDIR)
+3 IF BLSFLST<1
WRITE !,"No Files in the directory, goodbye"
QUIT
+4 SET BLSLSDA=0
FOR
SET BLSLSDA=$ORDER(BLSFILES(BLSLSDA))
IF 'BLSLSDA
QUIT
Begin DoDot:1
+5 WRITE !,BLSLSDA_" - "_$GET(BLSFILES(BLSLSDA))
End DoDot:1
+6 SET DIR(0)="L^1:"_BLSFLST
SET DIR("A")="Resend which file(s) "
+7 DO ^DIR
+8 IF $DATA(DIRUT)
QUIT
+9 SET BLSFNMI=Y
+10 FOR BLSI=1:1:BLSFLST
SET BLSFLI=$PIECE(BLSFNMI,",",BLSI)
IF BLSFLI=""
QUIT
Begin DoDot:1
+11 SET BLSFNM=$GET(BLSFILES(BLSFLI))
+12 ;S BLSXPD=$P($G(^BLRSITE(DUZ(2),5)),U,2)
+13 SET BLSFTP=$PIECE($GET(^BLRSITE(DUZ(2),5)),U)
+14 SET BLSLLI=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,5)
+15 SET BLSLPI=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,6)
+16 IF BLSLLI]""
SET BLSLL=$$DQ(BLSLLI)
+17 IF BLSLPI]""
SET BLSLP=$$DQ(BLSLPI)
+18 SET BLSPASS=$GET(BLSLL)_":"_$GET(BLSLP)
+19 IF BLSPASS=":"
SET BLSPASS=""
+20 WRITE !,"Sending export file "_BLSFNM_" in directory "_BLSDIR
+21 WRITE !,"Sending to IP Address "_BLSFTP
+22 DO SENDFILE(BLSFNM,BLSDIR,BLSFTP,BLSPASS)
+23 WRITE !,"File "_BLSFNM_" sent to "_BLSFTP
+24 DO BUL(BLSFTP,BLSDIR,BLSFNM)
End DoDot:1
+25 QUIT
+26 ;
CLEANUP ;EP -- cleanup files older than parameter days
+1 SET BLSDIR=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,3)
+2 SET BLSDAYS=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,4)
+3 IF 'BLSDAYS
SET BLSDAYS=30
+4 SET BLST=$$BLST(DT,BLSDAYS)
+5 SET BLSTE=$$FMTE^XLFDT(BLST)
+6 SET BLSCDA=0
+7 WRITE !,"Now cleaning up export log file entries older than "_BLSTE
+8 FOR
SET BLSCDA=$ORDER(^BLSLX("ADXP",BLSCDA))
IF 'BLSCDA!(BLSCDA>BLST)
QUIT
Begin DoDot:1
+9 SET BLSCIEN=0
+10 FOR
SET BLSCIEN=$ORDER(^BLSLX("ADXP",BLSCDA,BLSCIEN))
IF 'BLSCIEN
QUIT
Begin DoDot:2
+11 WRITE "."
+12 SET DIK="^BLSLX("
SET DA=BLSCIEN
DO ^DIK
End DoDot:2
End DoDot:1
+13 WRITE !!,"Now cleaning up host files older than "_BLSTE
+14 SET BLSFLST=$$LIST(BLSDIR)
+15 IF '$ORDER(BLSFILES(""))
QUIT
+16 SET BLSFDA=0
FOR
SET BLSFDA=$ORDER(BLSFILES(BLSFDA))
IF 'BLSFDA
QUIT
Begin DoDot:1
+17 SET BLSFNM=$GET(BLSFILES(BLSFDA))
+18 SET BLSFDT=$$HDATE^INHUT($EXTRACT(BLSFNM,10,17))
+19 IF '+$GET(BLSFDT)
QUIT
+20 IF BLSFDT>BLST
QUIT
+21 WRITE !,"Removing export file "_BLSFNM_" in directory "_BLSDIR
+22 ;S BLSOS=$P($G(^AUTTSITE(1,0)),U,21)
+23 ;I BLSOS=1 S X=$$TERMINAL^%HOSTCMD("rm "_BLSDIR_BLSFNM)
+24 ;I BLSOS=2 S X=$ZOS(2,BLSDIR_BLSFNM)
+25 ;W !,"File "_BLSFNM_" removed"
+26 ;BEGIN MOD
+27 ;IHS/ITSC/TPF 1/27/2003 REMOVE VENDOR SPECIFIC CODE ABOVE ; X=0 IF SUCCESSFUL
SET X=$$DEL^%ZISH(BLSDIR,BLSFNM)
+28 IF 'X
WRITE !,"File "_BLSFNM_" removed"
+29 ;END MOD
End DoDot:1
+30 QUIT
+31 ;
RFILE ;EP - remove files from hfs
+1 SET BLSDIR=$PIECE($GET(^BLRSITE(DUZ(2),5)),U,3)
+2 SET BLSFLST=$$LIST(BLSDIR)
+3 IF BLSFLST<1
WRITE !,"No Files in the directory, goodbye"
QUIT
+4 SET BLSLSDA=0
FOR
SET BLSLSDA=$ORDER(BLSFILES(BLSLSDA))
IF 'BLSLSDA
QUIT
Begin DoDot:1
+5 WRITE !,BLSLSDA_" - "_$GET(BLSFILES(BLSLSDA))
End DoDot:1
+6 SET DIR(0)="L^1:"_BLSFLST
SET DIR("A")="Remove which file(s) "
+7 DO ^DIR
+8 IF $DATA(DIRUT)
QUIT
+9 SET BLSFNMI=Y
+10 FOR BLSI=1:1:BLSFLST
SET BLSFLI=$PIECE(BLSFNMI,",",BLSI)
IF BLSFLI=""
QUIT
Begin DoDot:1
+11 SET BLSFNM=$GET(BLSFILES(BLSFLI))
+12 ;S BLSXPD=$P($G(^BLRSITE(DUZ(2),5)),U,2)
+13 SET BLSFTP=$PIECE($GET(^BLRSITE(DUZ(2),5)),U)
+14 WRITE !,"Removing export file "_BLSFNM_" in directory "_BLSDIR
+15 ;S BLSOS=$P($G(^AUTTSITE(1,0)),U,21)
+16 ;I BLSOS=1 S X=$$TERMINAL^%HOSTCMD(BLSDIR_BLSFNM)
+17 ;I BLSOS=2 S X=$ZOS(2,BLSDIR_BLSFNM)
+18 ;W !,"File "_BLSFNM_" removed"
+19 ;BEGIN MOD
+20 ;IHS/ITSC/TPF 1/27/2003 REMOVE VENDOR SPECIFIC CODE ABOVE; X=0 IF SUCCESSFUL
SET X=$$DEL^%ZISH(BLSDIR,BLSFNM)
+21 IF 'X
WRITE !,"File "_BLSFNM_" removed"
+22 ;END MOD
End DoDot:1
+23 QUIT
+24 ;
SENDFILE(FNM,SDIR,IP,PASS) ;-- this will trigger a send via the sendto command, sendto.pl must exist
+1 SET BLSOPS=$PIECE($GET(^AUTTSITE(1,0)),U,21)
+2 ;I PASS["anonymous" D Q
+3 ;. S BLSSEND="sendto -i"_$S(BHLOPS=1:" ",1:" -a ")_IP_" "_SDIR_FNM
+4 ;. S X=$$JOBWAIT^%HOSTCMD(BLSSEND)
+5 ;S BLSSEND="sendto1 -u -l "_PASS_$S(BLSOPS=1:" ",1:" -a ")_IP_" "_SDIR_FNM
+6 ;S X=$$JOBWAIT^%HOSTCMD(BLSSEND)
+7 ;CHANGE REQUIRED BY SAC REQUIREMENTS IHS/ITSC/TPF 02/10/03 RESULT=0 IF SUCCESSFUL
SET RESULT=$$SEND^%ZISH(SDIR,FNM,IP)
+8 ;
+9 QUIT
+10 ;
BLST(DATE,DAYS) ;-- find cleanup date
+1 SET X1=DATE
SET X2=-(DAYS)
+2 DO C^%DTC
+3 QUIT X
+4 ;
NOW() ;-- return now in fm dt
+1 DO NOW^%DTC
+2 QUIT %
+3 ;
LIST(DIR) ;-- get a list of files in the directory
+1 SET Y=$$LIST^%ZISH(DIR,"BLS*",.BLSFILES)
+2 QUIT $ORDER(BLSFILES(""),-1)
+3 ;
FAC(LOC) ;-- return the asufac code
+1 QUIT $PIECE($GET(^AUTTLOC(LOC,0)),U,10)
+2 ;
DQ(DEQ) ;-- decrypt the password
+1 NEW X,X1,X2
+2 SET (X1,X2)=5
SET X=DEQ
+3 DO DE^XUSHSHP
+4 QUIT X
+5 ;
