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

BLRAG05D.m

Go to the documentation of this file. 
  1. BLRAG05D ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ; 18-Jul-2016 15:43 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1031,1037,1039**;NOV 01, 1997;Build 38
  1.  ;
  1.  ;
  1. LROE2 ;
  1.  I $D(^LRO(69,LRODT,1,DA,1)),$P(^(1),U,4)="C" S LRNONE=2,LRCHK=LRCHK+1
  1.  K LRSN
  1.  S (LRSN,LRSN(DA))=+DA
  1.  I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
  1.  ; S M9=$G(M9)+1,LRZX=^LRO(69,LRODT,1,LRSN,0),LRDFN=+LRZX,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN S LRWRDS=LRWRD
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1027
  1.  S M9=$G(M9)+1
  1.  S LRZX=^LRO(69,LRODT,1,LRSN,0)
  1.  S LRDFN=+LRZX
  1.  S LRDPF=$P(^LR(LRDFN,0),U,2)  S DFN=$P(^(0),U,3)
  1.  D PT^LRX
  1.  ;W !,PNM,?30,HRCN
  1.  S LRWRDS=$G(LRWRD)  ;ZSAT: where is this set up?
  1.  ;----- END IHS MODIFICATIONS LR*5.2*1027
  1.  ;W ?45,"Requesting location: ",$P(LRZX,U,7) S Y=$P(LRZX,U,5) D DD^LRX W !,"Date/Time Ordered: ",Y,?45,"By: ",$S($D(^VA(200,+$P(LRZX,U,2),0)):$P(^(0),U),1:"")
  1.  ;S LRSVSN=LRSN D ORDER^LROS S LRSN=LRSVSN
  1.  Q
  1.  ;
  1. YN ;
  1.  Q
  1.  ;
  1. TASK ;
  1.  S IOP=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
  1.  D ^%ZIS
  1.  S LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
  1.  D ^%ZISC
  1.  ;D CLOSE^%ZISUTL("LRLABEL")
  1.  I $D(LRLABLIO),$D(LRLBL) D
  1.  .S ZTRTN="ENT^LRLABLD",ZTDTH=$H,ZTDESC="LAB LABELS",ZTIO=LRLABLIO,ZTSAVE("LRLBL(")=""
  1.  .D ^%ZTLOAD
  1.  K LRLBL
  1.  D ^%ZISC
  1.  D STOP^LRCAPV K LRCOM,LRSPCDSC,LRCCOM,LRTCOM
  1.  Q
  1.  ;
  1.  ;
  1. END K DIR,DIRUT,GOT
  1.  D ^LRORDK,LROEND^LRORDK,STOP^LRCAPV
  1.  Q
  1.  ;
  1.  ;
  1. GOT(ORD,ODT) ;See if all tests have been canceled
  1.  N I,SN,ODT
  1.  S (GOT,ODT,SN)=0
  1.  F  S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1  D
  1.  . S SN=0 F  S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1!(GOT)  D
  1.  . . Q:'$D(^LRO(69,ODT,1,SN,0))
  1.  . . S I=0 F  S I=$O(^LRO(69,ODT,1,SN,2,I)) Q:I<1  I $D(^(I,0)),'$P(^(0),"^",11) S GOT=1 Q
  1.  Q GOT
  1.  ;
  1.  ;
  1. UNL69 ;
  1.  L -^LRO(69,"C",+$G(LRORD))
  1.  TCOMMIT
  1.  Q
  1. UNL69ERR ;
  1.  L -^LRO(69,"C",+$G(LRORD))
  1.  TROLLBACK
  1.  Q
  1.  ;
  1. P15 ;from LRVER,LRVR,LRGV  (P15^LROE1)
  1.  N COMB
  1.  ;S E=0 F  S E=$O(^LRO(69,LRODT,1,LRSN,2,E)) Q:'E  W !,$P(^LAB(60,+^(E,0),0),"^")
  1.  ;store estimated date/time of collection
  1.  ;D TIME^LROE Q:LRCDT<1  S LRUN=$P(LRCDT,"^",2),LRTIM=+LRCDT,LRNT=LRTIM S $P(^LRO(69,LRODT,1,LRSN,0),U,8)=LRTIM
  1.  S LRCDT=$G(BLRCDT)_"^"
  1.  S LRUN=$P(LRCDT,"^",2),LRTIM=+LRCDT,LRNT=LRTIM
  1.  S $P(^LRO(69,LRODT,1,LRSN,0),U,8)=LRTIM
  1.  S:$P($G(^LRO(69,LRODT,1,LRSN,1)),U,1)="" $P(^LRO(69,LRODT,1,LRSN,1),U,1)=LRTIM
  1.  S:($P($G(^LRO(69,LRODT,1,LRSN,1)),U,3)="")&$G(BLRCUSR) $P(^LRO(69,LRODT,1,LRSN,1),U,3)=BLRCUSR
  1.  I '$D(LRCDT) S (LRCDT,LRTIM,LRNT)=$P(^LRO(69,LRODT,1,LRSN,0),U,8),LRUN=""
  1.  ;if lab collect and a collection node, set REPORT ROUTING LOCATION and ORDERING LOCATION, then call P15A for more collection storage
  1.  ;I $P(^LRO(69,LRODT,1,LRSN,0),U,4)="LC",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A Q
  1.  I $P(^LRO(69,LRODT,1,LRSN,0),U,4)'="",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A Q
  1.  S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)
  1.  ;store collection node
  1.  S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2)
  1.  S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
  1.  Q
  1.  ;
  1. P15A ;from LROE1, LRPHEXPT   (P15^LRPHITEM)
  1.  N LRORIFN,LRX712,LRUIDA
  1.  N BLRSETUP
  1.  ;
  1.  Q:'$D(^LRO(69,LRODT,1,LRSN,1))  Q:$L($P(^LRO(69,LRODT,1,LRSN,1),U,4))  S J1=^(1),LRX712=^(0)
  1.  S LRDFN=+LRX712 K LRDPF
  1.  D
  1.  . N LRRB
  1.  . D PT^LRX
  1.  S LROLLOC=$P(LRX712,U,9)
  1.  S LRTREA=+$G(VAIN(3))
  1.  S LRORIFN=$P(LRX712,U,11)
  1.  S LRNT=$$NOW^XLFDT
  1.  ;
  1.  ;S ^LRO(69,LRODT,1,LRSN,1)=$P(J1,U,1,2)_"^"_DUZ_"^"_$P(J1,U,4)_"^^"_$P(J1,U,6)_"^"_$P(J1,U,7)
  1.  S:$P($G(^LRO(69,LRODT,1,LRSN,1)),U,3)="" $P(^LRO(69,LRODT,1,LRSN,1),U,3)=BLRCUSR
  1.  ;
  1.  S $P(^LRO(69,LRODT,1,LRSN,3),U)=LRNT,^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=""
  1.  S (LRAA,LRAD,LRAN,LRTN)=0
  1.  F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:LRTN<1  D
  1.  . I '$D(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q
  1.  . S X=^LRO(69,LRODT,1,LRSN,2,LRTN,0),LRAA=+$P(X,U,4),LRAD=+$P(X,U,3),LRAN=+$P(X,U,5),LRORIFN=$P(X,U,7)
  1.  . S:'$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,1) $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,1)=$G(BLRCDT),$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)=9999999-$G(BLRCDT)
  1.  . S BLRSETUP=$$SETUP^BLRAGUT1()
  1.  . S:$G(MSCRLCLA)="" MSCRLCLA=$G(BLRRLCLA)
  1.  . D P15A^LRPHITEM
  1.  . S BLRRLCLA=MSCRLCLA
  1.  . I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) D
  1.  . . S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=LRNT
  1.  . . S ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
  1.  ;
  1.  I +$G(LRDPF)=2 D
  1.  . N CONTROL
  1.  . S CONTROL=$S($L(LRORIFN):"SC",1:"SN")
  1.  . D NEW^LR7OB1(LRODT,LRSN,CONTROL,,,6)
  1.  ;
  1.  N LRX
  1.  S LRX=""
  1.  F  S LRX=$O(LRUIDA(LRX)) Q:LRX=""  D EN^LA7ADL(LRX)
  1.  Q
  1.  ;
  1. Q15 ; (^LROE2)
  1.  Q:'$D(^LRO(69,LRODT,1,LRSN,0))
  1.  ;store collection data if not collected
  1.  I $D(^LRO(69,LRODT,1,LRSN,1)),$P(^LRO(69,LRODT,1,LRSN,1),"^",4)="U" D
  1.  .I $G(BLRUNC)'=1 S BLRRET="BLRAG05: This specimen has already been marked as UNCOLLECTED." S BLREF=1 Q  ;ZSAT: 5) Continue if uncollected is OK?
  1.  .I $G(BLRUNC)=1 S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^^"_BLRCUSR,DA=LRSN,DA(1)=LRODT,DIE="^LRO(69,"_DA(1)_",1,",DR=16 D ^DIE
  1.  Q:BLREF
  1.  ;store patient confirmation data
  1.  D:(BLRPTCM'="")&(BLRPTCU'="") PTCS(LRODT,LRSN,BLRPTCU,$$NOW^XLFDT(),BLRPTCM)
  1.  S DA=DT,LRDFN=+^LRO(69,LRODT,1,LRSN,0),LRDPF=+$P(^LR(LRDFN,0),U,2)
  1.  ;
  1.  ;if no collection node, go make one
  1.  ;IF '$D(^LRO(69,LRODT,1,LRSN,1)) S LRSTATUS="C",DA=LRODT I '$D(LRSND) D P15 Q:LRCDT<1
  1.  ;updates to collection node
  1.  ;I $D(LRSND),$P(^LRO(69,LRODT,1,LRSN,0),U,4)="",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A G PH
  1.  ;I $D(LRSND) N COMB S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2) S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
  1.  ;
  1. PH G Q16:LRORD Q
  1. Q16 S J=0 D CHECK^LROW2 I J S BLRRET="BLRAG05: The ORDER NUMBER (LRDFN) is in use, contact the site manager.  This order has been CANCELED, you will need to re-order." S BLREF=1 Q
  1. Q16A ;I $D(LRLONG),$D(LRSND) S LRSN=LRSND,^TMP("LROE",$J,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_SSN
  1.  I $D(LRLONG),$D(LRSND) S LRSN=LRSND,^TMP("LROE",$J,"LRORD")=LRORD_U_LRODT_U_LRTIM_U_PNM_U_HRCN  ;IHS/ANMC/CLS 08/18/96
  1.  K DR S LRTSTS=0
  1.  N MSCLRSN
  1.  S LRSN=0 F  S LRSN=$O(LRSN(LRSN)) Q:'LRSN  S MSCLRSN=LRSN D Q17 S LRSN=MSCLRSN
  1.  ;I $D(LRLONG),$D(LRSND) S LRSN=LRSND D LROE^LRFAST S X=^TMP("LROE",$J,"LRORD"),LRORD=+X,LRODT=$P(X,"^",2),LRTIM=$P(X,"^",3),LRLONG="",PNM=$P(X,"^",4),SSN=$P(X,"^",5)
  1.  I 0,$D(LRLONG),$D(LRSND) S LRSN=LRSND D LROE^LRFAST S X=^TMP("LROE",$J,"LRORD"),LRORD=+X,LRODT=$P(X,"^",2),LRTIM=$P(X,"^",3),LRLONG="",PNM=$P(X,"^",4),SSN=$P(X,"^",5),HRCN=$P(X,"^",5)  ;IHS/ANMC/CLS 08/18/96
  1.  Q
  1. Q17 ;S I=$O(^LRO(69,LRODT,1,LRSN,6,0)),J=$O(^(1)) S:'$D(IOM) IOM=80 K LRSPCDSC S:J LRSPCDSC=^(J,0) S:I DA=LRSN,DA(1)=LRODT,DR=6,DIC="^LRO(69,"_LRODT_",1," D EN^DIQ:I D LRSPEC^LROE1
  1.  S I=$O(^LRO(69,LRODT,1,LRSN,6,0)),J=$O(^LRO(69,LRODT,1,LRSN,6,1)) S:'$D(IOM) IOM=80 K LRSPCDSC S:J LRSPCDSC=^LRO(69,LRODT,1,LRSN,6,J,0) S:I DA=LRSN,DA(1)=LRODT,DR=6,DIC="^LRO(69,"_LRODT_",1," D:$D(^LRO(69,LRODT,1,LRSN,0)) LRSPEC^LROE1
  1.  D OLD K ^TMP("LR",$J,"TMP")
  1.  ;store collected status, institution, and xref
  1.  S $P(^LRO(69,LRODT,1,LRSN,1),U,4)="C",$P(^LRO(69,LRODT,1,LRSN,1),U,8)=DUZ(2),^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
  1.  Q
  1.  ;
  1. OLD ;to allow unchanged routines to still work, from LROE1, LRPHSET1  (OLD^LRORDST)
  1.  N LRNT
  1.  D DT^LRORDST,NOW^%DTC
  1.  S LRNT=%
  1.  I $P(LRPARAM,U,4),'$D(LRNOLABL),'$D(LRTJ),0 D ^BLRAG05A  ;ZSAT
  1.  S LRQUIET=1
  1.  D ^BLRAG05B
  1.  ;
  1.  ;if no collection node, go make one
  1.  IF '$D(^LRO(69,LRODT,1,LRSN,1)) S LRSTATUS="C",DA=LRODT D P15 Q:LRCDT<1
  1.  ;updates to collection node
  1.  I $D(LRSND),$P(^LRO(69,LRODT,1,LRSN,0),U,4)'="",$D(^(1)) S LRLLOC=$P(^(0),U,7),LROLLOC=$P(^(0),U,9),LRNT=$S($D(LRNT):LRNT,$D(LRTIM):LRTIM,$D(LRCDT):+LRCDT,1:"") D P15A Q
  1.  I $D(LRSND) N COMB S COMB=$P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7) S ^LRO(69,LRODT,1,LRSN,1)=LRTIM_"^"_LRUN_"^"_BLRCUSR_"^"_LRSTATUS_"^^^"_COMB_"^"_DUZ(2) S:LRSTATUS="C" ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
  1.  Q
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1021
  1. BLRRL ;EP - cmi/anch/maw 8/4/2004 added to check for shipping manifest and print
  1.  ;cmi/anch/maw REF LAB
  1.  ;cmi/anch/maw 9/28/2004 changed to write only when a shipping manifest
  1.  K BLRINS,BLRDXS  ;cmi/7/1/2010 reference lab ledi variables
  1.  K BLRASFLG  ;P1034
  1.  Q:$G(BLRGUI)
  1.  Q:'$G(^BLRSITE(DUZ(2),"RL"))  ;reference lab not set up
  1.  Q:$P($G(^BLRSITE(DUZ(2),"RL")),U,22)
  1.  ;I $D(^TMP("BLRRL",$J)) D
  1.  I $G(LRORD),$O(^BLRRLO("B",LRORD,0)) D  ;p1034
  1.  . N OI
  1.  . S OI=$O(^BLRRLO("B",LRORD,0))
  1.  . Q:'$D(^BLRRLO(OI,3,0))  ;not accessioned yet
  1.  . ;W !,"Printing Shipping Manifests for Reference Lab..."  ;1036 moved to BLRRLEVN
  1.  . ;D PRT^BLRSHPM
  1.  . D SHIPMAN^BLRRLEVN(LRORD,0,0)  ;ihs/cmi/maw 12/17/2014 p1034 store and forward changes
  1.  K BLRINS,BLRASFLG,BLRDXS  ; ihs/cmi/maw p1037
  1.  Q  ; IHS/MSC/MKK - LR*5.2*1039
  1.  ;----- END IHS MODIFICATIONS cmi/anch/maw end REF LAB LR*5.2*1021
  1.  ;
  1. PTCS(BLRDT,BLRSPN,BLRUSER,BLRDTCF,BLRMETH) ;
  1.  ; BLRDT   = (required) order date in external format - pointer to LAB ORDER ENTRY file 69
  1.  ; BLRSPN  = (required) specimen number - pointer to specimen multiple in LAB ORDER ENTRY file 69
  1.  ; BLRUSER = (required) user that did confirmation - pointer to NEW PERSON file 200
  1.  ; BLRDTCF = (optional) Date/Time of user confirmation in external format - defaults to 'today'
  1.  ; BLRMETH = (optional) method of confirmation - free text
  1.  ;
  1.  ;if confirmation date is null, default to NOW
  1.  I $G(BLRDTCF)="" S BLRDTCF=$$HTFM^XLFDT($H)
  1.  E  D
  1.  .;convert external date to FM format
  1.  .S X=BLRDTCF,%DT="XT" D ^%DT S BLRDTCF=Y
  1.  .;default to 'NOW' if invalid date passed in
  1.  .S:$$FR^XLFDT($G(BLRDTCF)) BLRDTCF=$$HTFM^XLFDT($H)
  1.  K BLRM
  1.  S BLRM=""
  1.  S FDA(69.01,BLRSPN_","_+BLRDT_",",21400)=BLRUSER
  1.  S FDA(69.01,BLRSPN_","_+BLRDT_",",21401)=BLRDTCF
  1.  S FDA(69.01,BLRSPN_","_+BLRDT_",",21402)=BLRMETH
  1.  D FILE^DIE("","FDA","BLRM")
  1.  I $D(BLRM("DIERR")) D ERR^BLRAGUT("BLRAG01: "_BLRM("DIERR",1,"TEXT",1)) L -^LRO(69,BLRDT,1,BLRSPN) TROLLBACK  Q
  1.  Q
  1.  ;
  1. ERROR ; EP
  1.  ; D ENTRYAUD^BLRUTIL("ERROR^BLRAG05D 0.0")   ; Store Error data
  1.  ; NEW ERRORMSG
  1.  ; S ERRORMSG="$"_"Z"_"E=""ERROR^BLRAG05D"""  ; BYPASS SAC Checker
  1.  ; S @ERRORMSG  D ^%ZTER
  1.  ;
  1.  ; D ERR("RPMS Error")
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
  1.  NEW ERRSCFL,ERRCODE,LASTGLOR
  1.  S ERRCODE=$$EC^%ZOSV        ; Error Code
  1.  S ERRLGLO=$$LGR^%ZOSV       ; Last Global accessed
  1.  D FORCEIT^BLRUTIL7("ERROR^BLRAG05D")
  1.  D ERR("RPMS Error: "_ERRCODE)
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1039
  1.  Q
  1.  ;
  1. ERR(BLRERR) ;Error processing
  1.  ; BLRERR = Error text OR error code
  1.  ; BLRAGI   = pointer into return global array
  1.  ;
  1.  D UNL69ERR^BLRAG05D
  1.  I +BLRERR S BLRERR=BLRERR+134234112 ;vbObjectError
  1.  S BLRAGI=BLRAGI+1
  1.  S ^TMP("BLRAG",$J,BLRAGI)=2_U_BLRERR_$C(30)
  1.  S BLRAGI=BLRAGI+1
  1.  S ^TMP("BLRAG",$J,BLRAGI)=$C(31)
  1.  Q