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

BLRFLTL.m

Go to the documentation of this file. 
  1. BLRFLTL(BLRCMF,BLRVARS,BLRFLDS) ; IHS/DIR/MJL - SILENT DIE CALLS TO UPDATE TRANSACTION LOG ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;LR;**1001,1003,1006,1007,1008,1009,1021,1027,1033**;NOV 01, 1997
  1.  ;
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER ^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER ^BLRFLTL")     ; IHS/OIT/MKK - LR*5.2*1033
  1.  S U="^",BLRFID=9009022,BLRERR=0,BLRICNT=0 S:BLRCMF="C" BLRICNT=1  ;IHS/OIRM TUC/MJL 2/10/98
  1.  D SETVALS
  1.  I 'BLRERR S:'BLRPCC BLRFDA(BLRFID,BLRIEN,BLRF(0,"PCC ERROR FLAG"))="PCC LINK DISABLED" D FILE
  1.  I BLRPCC,'$D(BLRERF),'BLRERR D LOG
  1.  ;D:BLRERR BULERR
  1.  I '(+$G(BLRDTER)),BLRERR D BULERR  ;IHS/DIR TUC/AAB 05/18/98
  1.  D KILL
  1.  Q
  1.  ;
  1. SETVALS ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER SETVALS^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER SETVALS^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  F BLRI=1:1:$L(BLRVARS,"~") S BLRARRAY=0,BLRVRS=$P(BLRVARS,"~",BLRI),BLRVR=$P(BLRVRS,"_",1),BLRVL=$P(BLRVRS,"_",2) D  Q:BLRERR  I 'BLRARRAY,$D(BLRF(0,BLRVR)),BLR(BLRVR)'="" S BLRFDA(BLRFID,BLRIEN,BLRF(0,BLRVR))=BLR(BLRVR)
  1.  .I $E(BLRVR)'="@" D  Q
  1.  ..I BLRVL?.N S BLR(BLRVR)=BLRVL Q
  1.  ..I BLRVL?1"""".E1"""" S BLR(BLRVR)=$E(BLRVL,2,$L(BLRVL)-1) Q
  1.  ..I $E(BLRVL)=U S BLR(BLRVR)=@BLRVL Q
  1.  ..I BLRVL?1U.UN D  Q
  1.  ...I '$D(BLRF(0,BLRVR,"TYPE")) S BLR(BLRVR)=@BLRVL Q
  1.  ...S BLRARRAY=1
  1.  ...I BLRF(0,BLRVR,"TYPE")="M" D MULTI Q
  1.  ...D WORD Q
  1.  ..X "S BLR(BLRVR)="_BLRVL Q
  1.  .S BLRVR=$P(BLRVR,"@",2)
  1.  .I BLRVL?.N S @BLRVR=BLRVL Q
  1.  .I BLRVL?1"""".E1"""" S @BLRVR=$E(BLRVL,2,$L(BLRVL)-1) Q
  1.  .I $E(BLRVL)=U S @BLRVR=@BLRVL Q
  1.  .I BLRVL?1U.UN S @BLRVR=@BLRVL Q
  1.  .X "S @BLRVR="_BLRVL Q
  1.  Q
  1.  ;
  1. MULTI ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER MULTI^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER MULTI^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  I BLRCMF="M",BLRVR="COMMENTS" S BLRMI="" F  S BLRMI=$O(^BLRTXLOG(BLRENT,30,BLRMI)) Q:BLRMI=""  S DA=BLRMI,DA(1)=BLRENT,DIK="^BLRTXLOG("_DA(1)_","_30_"," D ^DIK  ;IHS/OIRM TUC/AAB 2/10/98
  1.  S BLRSFID=BLRFID,BLRSIEN=BLRIEN,BLRFID=BLRF(0,BLRVR,"FILE"),BLRVL=@BLRVL
  1.  ;F BLRIII=1:1:$L(BLRVL,$C(20)) S BLRIEN=(BLRIII+BLRENT)_","_BLRSIEN,(BLRSSTR,BLRFDA(BLRFID,BLRIEN,BLRF(0,BLRVR)))=$P(BLRVL,$C(20),BLRIII)
  1.  F BLRIII=1:1:$L(BLRVL,$C(20)) S BLRICNT=BLRICNT+1,BLRIEN="+"_BLRICNT_","_BLRSIEN,(BLRSSTR,BLRFDA(BLRFID,BLRIEN,BLRF(0,BLRVR)))=$P(BLRVL,$C(20),BLRIII)  ;IHS/OIRM TUC/MJL 2/10/98
  1.  S BLRFID=BLRSFID,BLRIEN=BLRSIEN
  1.  Q
  1.  ;
  1. WORD ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  Q
  1.  ;
  1. FILE ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ;
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER FILE^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER FILE^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  L +^BLRTXLOG(BLRENT):300
  1.  ; If after attempting for 300 seconds the lock fails proceed anyway
  1.  S BLRFDA="BLRFDA"
  1.  D
  1.  .I BLRCMF="C" D UPDATE^DIE("",BLRFDA,BLRENTS,"BLREMSG") Q
  1.  .D UPDATE^DIE("",BLRFDA,"","BLREMSG") Q
  1.  S:$D(BLREMSG) BLRERR=1
  1.  L -^BLRTXLOG(BLRENT) ;IHS/OIRM TUC/MJL 5/21/98
  1.  Q
  1.  ;
  1. GETIEN(BLRSB1,BLRSB2,BLRSB3) ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D
  1.  .I BLRCMF="C" D GETNEW Q
  1.  .I BLRPHASE="O" S BLRCRGL="^BLRTXLOG(""AOT"","_BLRSB1_","_BLRSB2_","_BLRSB3_")",BLRENT=$O(^BLRTXLOG("AOT",BLRSB1,BLRSB2,BLRSB3,""),-1) D:'BLRENT CKORD D:BLRERR EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  .I $D(BLRSB3) S BLRCRGL="^BLRTXLOG(""AOT"","_BLRSB1_","_BLRSB2_","_BLRSB3_")",BLRENT=$O(^BLRTXLOG("AOT",BLRSB1,BLRSB2,BLRSB3,""),-1) D:'BLRENT CKORD D:BLRERR EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  .;S BLRCRGL="^BLRTXLOG(""AAT"","_BLRSB1_","_BLRSB2_")" S BLRENT=$O(^BLRTXLOG("AAT",BLRSB1,BLRSB2,""),-1) D:'BLRENT EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  .;IHS/DIR TUC/AAB 05/07/98
  1.  .S BLRCRGL="^BLRTXLOG(""AAT"","_BLRSB1_","_BLRSB2_")" S BLRENT=$O(^BLRTXLOG("AAT",BLRSB1,BLRSB2,""),-1)
  1.  .D:'BLRENT EMSG Q:BLRERR
  1.  .S BLRCDT=$P(^BLRTXLOG(BLRENT,12),U)
  1.  .I $E(BLRCDT,1,3)=$E(DT,1,3) S BLRIEN=BLRENT_"," Q
  1.  .I ($E(BLRCDT,1,3)+1)'=$E(DT,1,3) S BLRERR=1,BLRDTER=1 Q  ;MORE THAN 1 YEAR AHEAD
  1.  .I $E(BLRCDT,4,5)<11 S BLRERR=1,BLRDTER=1 Q
  1.  .S BLRIEN=BLRENT_"," Q
  1.  Q BLRENT
  1.  ;
  1. GETOGIEN(BLRSB1,BLRSB2,BLRSB3) ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETOGIEN^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER GETOGIEN^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D
  1.  .I BLRCMF="C" D GETNEW Q
  1.  .I '$D(BLRSB3) S BLRCRGL="^BLRTXLOG(""AOG"","_BLRSB1_","_BLRSB2_")",BLRENT=$O(^BLRTXLOG("AOG",BLRSB1,BLRSB2,""),-1) D:'BLRENT EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  .S BLRCRGL="^BLRTXLOG(""AOD"","_BLRSB1_","_BLRSB2_","_BLRSB3_")",BLRENT=$O(^BLRTXLOG("AOD",BLRSB1,BLRSB2,BLRSB3,""),-1) D:'BLRENT EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  Q BLRENT
  1.  ;
  1. GETBIEN(BLRSB1,BLRSB2,BLRSB3) ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETBIEN^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER GETBIEN^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D
  1.  .I BLRCMF="C" D GETNEW Q
  1.  .;I '$D(BLRSB3) S BLRCRGL="^BLRTXLOG(""AOB"","_BLRSB1_","_BLRSB2_")",BLRENT=$O(^BLRTXLOG("AOB",BLRSB1,BLRSB2,""),-1) D:'BLRENT EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  .I '$D(BLRSB3) S BLRCRGL="^BLRTXLOG(""AOB"","_BLRSB1_","_BLRSB2_")",BLRENT=$O(^BLRTXLOG("AOB",BLRSB1,BLRSB2,""),-1) D CHKDT Q  ;IHS/DIR TUC/AAB 05/07/98
  1.  .;S BLRCRGL="^BLRTXLOG(""AOA"","_BLRSB1_","_BLRSB2_","_BLRSB3_")",BLRENT=$O(^BLRTXLOG("AOA",BLRSB1,BLRSB2,BLRSB3,""),-1) D:'BLRENT EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  .S BLRCRGL="^BLRTXLOG(""AOA"","_BLRSB1_","_BLRSB2_","_BLRSB3_")",BLRENT=$O(^BLRTXLOG("AOA",BLRSB1,BLRSB2,BLRSB3,""),-1) D CHKDT Q  ;IHS/DIR TUC/AAB 05/07/98
  1.  Q BLRENT
  1.  ;
  1. CHKDT ; EP - IHS/OIT/MKK -- Need "EP" for SAC -- IHS/DIR TUC/AAB 05/07/98
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER CHKDT^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER CHKDT^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D:'BLRENT EMSG Q:BLRERR
  1.  S BLRCDT=$P(^BLRTXLOG(BLRENT,12),U)
  1.  I $E(BLRCDT,1,3)=$E(DT,1,3) S BLRIEN=BLRENT_"," Q
  1.  I ($E(BLRCDT,1,3)+1)'=$E(DT,1,3) S BLRERR=1,BLRDTER=1 Q  ;MORE THAN 1 YEAR AHEAD
  1.  I $E(BLRCDT,4,5)<11 S BLRERR=1,BLRDTER=1 Q
  1.  S BLRIEN=BLRENT_"," Q
  1.  Q
  1. GETOSIEN(BLRSB1,BLRSB2,BLRSB3)         ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETOSIEN^BLRFLTL")
  1.  D ENTRYAUD^BLRUTIL("ENTER GETOSIEN^BLRFLTL")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D
  1.  .I BLRCMF="C" D GETNEW Q
  1.  .I '$D(BLRSB3) S BLRCRGL="^BLRTXLOG(""AOG"","_BLRSB1_","_BLRSB2_")",BLRENT=$O(^BLRTXLOG("AOG",BLRSB1,BLRSB2,""),-1) D:'BLRENT EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  .S BLRCRGL="^BLRTXLOG(""AOS"","_BLRSB1_","_BLRSB2_","_BLRSB3_")",BLRENT=$O(^BLRTXLOG("AOS",BLRSB1,BLRSB2,BLRSB3,""),-1) D:'BLRENT EMSG Q:BLRERR  S BLRIEN=BLRENT_"," Q
  1.  Q BLRENT
  1.  ;
  1. EMSG ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; Log an error because the crossreference isn't set.
  1.  I 'BLRENT D
  1.  .S BLRERR=1,BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL
  1.  Q
  1.  ;
  1. CKORD ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  S BLRERR=1,BLRENT=^BLRTXLOG("SEQ")+1 ;IHS/DIR/MJL BLRERR=1 7/15/99
  1.  F BLRTRY=1:1:1000 S BLRENT=$O(^BLRTXLOG(BLRENT),-1) Q:'BLRENT  I $P(^BLRTXLOG(BLRENT,11),U,3)=$G(BLR("ORDER NUMBER"),LRORD),$P(^BLRTXLOG(BLRENT,0),U,6)=BLRSB3 S BLRERR=0 Q
  1.  S:BLRERR BLRENT=0 K BLRTRY
  1.  Q
  1.  ;
  1. GETNEW ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ; L +^BLRTXLOG("SEQ")
  1.  L +^BLRTXLOG("SEQ"):5  I '$T  H 5  G GETNEW     ; IHS/OIT/MKK - LR*5.2*1033
  1.  S BLRENT=$G(^BLRTXLOG("SEQ"))
  1.  I 'BLRENT S BLRENT=$O(^BLRTXLOG("@"),-1) I BLRENT,'$D(^BLRTXLOG(1)) S BLRENT=0
  1.  ;IHS/DIR TUC/MJL 12/4/98
  1.  ;S BLRENT=BLRENT+1 S:$D(^BLRTXLOG(BLRENT)) BLRENT=$O(^BLRTXLOG("@"),-1)+1
  1.  ;IHS/DIR TUC/MJL 12/4/98
  1.  F BLRENT=BLRENT+1:1 Q:'$D(^BLRTXLOG(BLRENT))
  1.  S BLRENTS="BLRENTS",BLRENTS(1)=BLRENT,^BLRTXLOG("SEQ")=BLRENT,BLRIEN="+1,"
  1.  L -^BLRTXLOG("SEQ")
  1.  Q
  1.  ;
  1. LOG ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ;S BLRDH=+$H,BLRLTA=$P($G(^BLRSITE(DUZ(2),21,BLRDH,0)),U,2)+1
  1.  S BLRDH=+$H
  1.  ; L +^BLRSITE(BLRQSITE,21,BLRDH,0)
  1.  L +^BLRSITE(BLRQSITE,21,BLRDH,0):5  I '$T  H 5  G LOG     ; IHS/OIT/MKK - LR*5.2*1033
  1.  S BLRLTA=$P($G(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,2)+1
  1.  ;I BLRLTA=1 S %H=$H D YX^%DTC S $P(^BLRSITE(DUZ(2),21,BLRDH,0),U,1)=X
  1.  I BLRLTA=1 S %H=$H D YX^%DTC S $P(^BLRSITE(BLRQSITE,21,BLRDH,0),U,1)=X  ;IHS/DIR TUC/AAB 04/07/98
  1.  ;S ^BLRSITE(DUZ(2),21,BLRDH,BLRLTA)=BLRENT,$P(^BLRSITE(DUZ(2),21,BLRDH,0),U,2)=BLRLTA
  1.  S ^BLRSITE(BLRQSITE,21,BLRDH,BLRLTA)=BLRENT,$P(^BLRSITE(BLRQSITE,21,BLRDH,0),U,2)=BLRLTA  ;IHS/DIR TUC/AAB 04/07/09
  1.  L -^BLRSITE(BLRQSITE,21,BLRDH,0)
  1.  Q
  1.  ;
  1. BULERR ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  NEW ERROR714      ; IHS/OIT/MKK - LR*5.2*1027
  1.  S ERROR714="NO"   ; IHS/OIT/MKK - LR*5.2*1027
  1.  ;BLRTXLOG ERROR
  1.  D:$D(BLREMSG)
  1.  .; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("BULERR^BLRFLTL 1.0","BLREMSG")
  1.  . D ENTRYAUD^BLRUTIL("BULERR^BLRFLTL 1.0","BLREMSG")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  .S (BLRECNT,BLRTCNT)=0 F  S BLRECNT=$O(BLREMSG("DIERR",BLRECNT)) Q:'BLRECNT  D
  1.  ..S BLRTCNT=BLRTCNT+1,BLRERROR(BLRTCNT)="Error code = "_BLREMSG("DIERR",BLRECNT)
  1.  ..S:+$G(BLREMSG("DIERR",BLRECNT))=714 ERROR714="YES"      ; IHS/OIT/MKK - LR*5.2*1027
  1.  ..S BLRELCNT=0 F  S BLRELCNT=$O(BLREMSG("DIERR",BLRECNT,"TEXT",BLRELCNT)) Q:'BLRELCNT  S BLRTCNT=BLRTCNT+1,BLRERROR(BLRTCNT)=BLREMSG("DIERR",BLRECNT,"TEXT",BLRELCNT)
  1.  .K BLRECNT,BLRELCNT
  1.  ;D:$D(BLR)
  1.  D:+$G(BLR("SEQUENCE NUMBER"))  ;IHS/DIR TUC/AAB 03/27/98
  1.  .S BLRV="",BLRTCNT=$G(BLRTCNT,1),BLRERROR(BLRTCNT+1)="",BLRERROR(BLRTCNT+2)="VARIABLES:",BLRERROR(BLRTCNT+3)="",BLRTCNT=BLRTCNT+3
  1.  .S BLRV="" F  S BLRV=$O(BLR(BLRV)) Q:BLRV=""  S BLRTCNT=BLRTCNT+1,BLRERROR(BLRTCNT)=$J("",10)_BLRV_$J("",35-$L(BLRV))_BLR(BLRV)
  1.  S BLRTCNT=$G(BLRTCNT,1)
  1.  F BLRPC=1:1 S BLRESTR=$P($T(PARSE+BLRPC),";",3) Q:BLRESTR=""  D
  1.  .S BLRXQY0=$P(XQY0,U,2) S:$D(BLRTEST1) BLRPT=$P(^LAB(60,BLRTEST1,0),U)
  1.  .S:$D(@($P(BLRESTR,"|",2))) BLRTCNT=BLRTCNT+1,BLRERROR(BLRTCNT)=$P(BLRESTR,"|")_@($P(BLRESTR,"|",2))
  1.  ; S XMB="BLRTXERR",XMTEXT="BLRERROR" S BLRDUZ=DUZ,DUZ=.5 D ^XMB S DUZ=BLRDUZ K ^TMP("XMBTEXT",$J)
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("BULERR^BLRFLTL 2.0","BLRERROR")
  1.  D ENTRYAUD^BLRUTIL("BULERR^BLRFLTL 2.0","BLRERROR")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  S XMB="BLRTXERR"
  1.  S XMTEXT="BLRERROR"
  1.  S XMDUZ=$S(ERROR714="YES":"714 Error",1:"POSTMASTER")
  1.  D ^XMB
  1.  K ^TMP("XMBTEXT",$J)
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1027
  1.  Q
  1.  ;
  1. KILL ; EP - IHS/OIT/MKK -- Need "EP" for SAC
  1.  ;K BLR,BLRARRAY,BLREMSG,BLRENTS,BLRERR,BLRERROR,BLRFDA,BLRI,BLRIEN,BLRIENS,BLRIII,BLRLOGDA,BLRQUIET,BLRSFID,BLRSIEN,BLRT,BLRTCNT,BLRVL,BLRVR,BLRVRS,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1.  K BLR,BLRARRAY,BLREMSG,BLRENTS,BLRERR,BLRERROR,BLRFDA,BLRI,BLRICNT,BLRIEN,BLRIENS,BLRIII,BLRLOGDA,BLRQUIET,BLRSFID,BLRSIEN,BLRT,BLRTCNT,BLRVL,BLRVR,BLRVRS
  1.  K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,BLRESTR,BLRPT,BLRXQY0,BLRPC,BLRMI,BLRDTER  ;IHS/OIRM TUC/MJL 2/10/98
  1.  Q
  1. PARSE ; EP - IHS/OIT/MKK -- Need "EP" for SAC - IHS/DIR TUC/AAB 03/27/98
  1.  ;;Patient Name: |PNM
  1.  ;;Panel/Test: |BLRPT
  1.  ;;Order Number: |LRORD
  1.  ;;Accession Number: |BLRACCN
  1.  ;;DUZ: |DUZ
  1.  ;;DUZ(2): |BLRDUZ2
  1.  ;;BLROPT1: |BLROPT1
  1.  ;;BLROPT(0): |BLROPT(0)
  1.  ;;XQY0: |BLRXQY0
  1.  Q