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

BLRAG08.m

Go to the documentation of this file. 
  1. BLRAG08 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;NOV 12, 2012
  1.  ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
  1.  ;
  1.  ;  BLR REF LAB USING LEDI   - UL^BLRAG02      = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
  1.  ;  BLR ICD LOOKUP           - ICDLKUP^BLRAG07 = ICD code lookup
  1.  ;  BLR ORDER REASON LKUP    - ORL^BLRAG07     = return order reasons from file 100.03
  1.  ;  BLR PATIENT LOOKUP       - PTLK^BLRAG04    = Patient Lookup
  1.  ;  BLR PRINTERS AVAILABLE   - DEVICE^BLRAG10  = return available printers from the DEVICE file
  1.  ;  BLR USER LOOKUP          - NP^BLRAG06      = return entries from the NEW PERSON table 200 that are 'active'
  1.  ;
  1.  ;  BLR ACCESSION            - ACC^BLRAG05     = lab accession processor
  1.  ;  BLR ACCESSION PRINT      - ABR^BLRAG02     = reprint accession label or manifest
  1.  ;  BLR ALL NON-ACCESSIONED  - ANA^BLRAG01     = return all non-accessioned lab records
  1.  ;  BLR ALL-ACCESSIONED      - ABD^BLRAG02     = return all accessioned records for given date range
  1.  ;  BLR COLLECTION INFO      - BLC^BLRAG06     = check BLR PT CONFIRM parameter and return insurances for patient
  1.  ;  BLR DELETE TEST          - DELTST^BLRAG08  = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
  1.  ;  BLR ORDER/TEST STATUS    - LROS^BLRAG03    = return order/test status for given patient and date range
  1.  ;
  1.  ;  BLR SHIP CONF            - SC^BLRAG09A     = select a shipping configuration
  1.  ;  BLR MANIFEST BUILD       - BM^BLRAG09B     = build a shipping manifest
  1.  ;  BLR MANIFEST CLOSE/SHIP  - CLSHIP^BLRAG09C = Close/ship a shipping manifest
  1.  ;  BLR MANIFEST DISPLAY     - DISP^BLRAG09G   = screen formatted text for manifest display
  1.  ;  BLR MANIFEST START       - SMONLY^BLRAG09C = Start a shipping manifest only, no building
  1.  ;  BLR MANIFEST TEST ADD    - ADDTEST^BLRAG09C= Add tests to an existing manifest\
  1.  ;  BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
  1.  ;  BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B  = return tests that can be added to a manifest
  1.  ;
  1.  ;Cancel tests - Tests are no longer deleted, instead the status is changed to Not Performed.
  1. DELTST(BLRY,BLRP,BLRRES) ;
  1.  ;  rpc: BLR DELETE TEST
  1.  ;INPUT:
  1.  ;  BLRP    = (required) list of TEST POINTERS to LAB ORDER ENTRY file 69
  1.  ;               BLRDT:BLRSP:BLRTEST^...
  1.  ;               These pointers come from the return from
  1.  ;                 BLR ALL-ACCESSIONED.
  1.  ;  BLRRES  = (required) list of reasons delimited by ^
  1.  ;                         reason_IEN:comment^...
  1.  ;               reason_IEN = pointer to ORDER REASON file 100.03
  1.  ;               comment is free-text
  1.  ;     The 1st entry in the REASONS list will align with the 1st entry in
  1.  ;      the TEST POINTERS, and so on.  So, the REASONS input string is
  1.  ;      expected to be the same length as the TEST POINTERS input string.
  1.  ;
  1.  ;RETURNS:
  1.  ;    General error returns a single entry:
  1.  ;     ERROR_ID^MESSAGE
  1.  ;        2=general error
  1.  ;    Accession related errors return an entry for each lab pointer
  1.  ;    that is passed in:
  1.  ;     ERROR_ID^MESSAGE
  1.  ;        0=clean   0^MESSAGE^BLRD:BLRSP:BLRTEST
  1.  ;        1=error   1^MESSAGE^BLRD:BLRSP:BLRTEST
  1.  ;
  1.  S BLRGUI=1
  1.  S LREND=0
  1.  D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
  1.  S BLRI=0
  1.  K ^TMP("BLRAG",$J)
  1.  S BLRY="^TMP(""BLRAG"","_$J_")"
  1.  S ^TMP("BLRAG",$J,0)="ERROR_ID"
  1.  ;
  1.  N BLRJ
  1.  N BLRDT,BLREF,BLREFF,BLRSP,BLRTEST
  1.  N LRAA,LRAD,LRAN,LRCTST
  1.  I $G(BLRP)="" S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="2^BLRAG08: Null order pointer." Q
  1.  S BLROPT="DELACC"
  1.  D ^LRPARAM Q:$G(LREND)
  1.  I '$D(LRLABKY) S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="2^BLRAG08: You are not authorized to change test status." Q
  1.  S BLREF=0
  1.  F BLRJ=1:1:$L(BLRP,"^") D
  1.  .K LRXX,LRSCNXB
  1.  .S BLRDT=$P($P(BLRP,"^",BLRJ),":",1)
  1.  .S BLRSP=$P($P(BLRP,"^",BLRJ),":",2)
  1.  .S BLRTEST=$P($P(BLRP,"^",BLRJ),":",3)
  1.  .I '$D(^LRO(69,BLRDT,1,BLRSP,2,BLRTEST)) S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^Invalid order pointer.^"_$P(BLRP,"^",BLRJ) S BLREF=1 Q
  1.  .S BLRNODT=^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,0)
  1.  .S LRAA=$P(BLRNODT,U,4)
  1.  .S LRAD=$P(BLRNODT,U,3)
  1.  .S LRAN=$P(BLRNODT,U,5)
  1.  .I $P(BLRRES,U,BLRJ)="" S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^Reason is required. "_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),U,1) S BLREF=1 Q
  1.  .S LRCTST=$P(BLRNODT,U,1) ;points to test in file 68
  1.  .I '$D(^LRO(68,+LRAA,1,+LRAD,1,+LRAN,4,+LRCTST)) S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^Invalid accession/test pointer."_$P(BLRP,"^",BLRJ) S BLREF=1 Q
  1.  .I $$VER() S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^BLRAG08: Test has been verified and cannot be deleted. "_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),U,1) S BLREF=1 Q
  1.  .S (LREND,LRNOP)=0 D FIX I LREND=1 D UNLOCK D END Q
  1.  .D CHG D UNLOCK D END
  1.  .S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=0_U_$P(BLRP,"^",BLRJ)
  1.  ;I '$D(BLRDT)!'$D(BLRSP)!'$D(BLRTEST) D ERR^BLRAGUT("1^BLRAG08: Invalid order pointer^"_$P(BLRP,"^",BLRJ)) Q
  1.  S:'BLREF ^TMP("BLRAG",$J,0)="T00020CLEAN^T00020MESSAGE^LRO69_POINTERS"
  1.  ;S ^TMP("BLRAG",$J,0)="T00020CLEAN^T00020MESSAGE^LRO69_POINTERS"
  1.  Q
  1.  ;
  1. FIX ;get locks and setup variables
  1.  S (LREND,LRNOP)=0,LRNOW=$$NOW^XLFDT
  1.  K LRACC,LRNATURE
  1.  I '$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)),U,2) S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^BLRAG08: Accession has no Test. "_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),U,1) S (BLREF,LREND)=1 Q
  1.  L +^LRO(68,LRAA,1,LRAD,1,LRAN):1 I '$T S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^BLRAG08: Someone else is working on this accession. "_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),U,1) S BLREF=1 S LREND=1 Q
  1.  S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRACN=$P(^(.2),U),LRUID=$P(^(.3),U)
  1.  S LRDFN=+LRX,LRSN=+$P(LRX,U,5),LRODT=+$P(LRX,U,4)
  1.  S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1.  D PT^LRX
  1.  S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
  1.  S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
  1.  L +^LR(LRDFN,LRSS,LRIDT):1 I '$T S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^BLRAG08:Someone else is working on this data. "_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),U,1) L -^LRO(68,LRAA,1,LRAD,1,LRAN):1 S BLREF=1 S LREND=1 Q
  1.  I '$G(^LR(LRDFN,LRSS,LRIDT,0)) S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^BLRAG08: Can't find Lab Data for this accession "_$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),U,1) D UNLOCK S BLREF=1 S LREND=1 Q
  1.  Q
  1. CHG ;
  1.  K DIC
  1.  K LRCCOM S LRCCOM="",LREND=0 I '$D(^LRO(69,BLRDT,1,BLRSP,0))#2 S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)="1^BLRAG08: There is no Order for this Accession^"_$P(BLRP,"^",BLRJ) D UNLOCK,END S BLREF=1 S LREND=1 Q
  1.  S LRCCOM=$E($S('$D(LRLABKY):"*Floor Cancel Reason:",1:"*NP Reason:")_$P($P($G(BLRRES),U,BLRJ),":",2),1,68)
  1.  Q:'$D(^LAB(60,LRCTST,0))#2  S LRTNM=$P(^(0),U)
  1.  S LRORDTST=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRCTST,0),U,9) D SET
  1.  S LREND=0
  1.  Q
  1. SET ;
  1.  S:'$G(LRNOW) LRNOW=$$NOW^XLFDT
  1.  S LRLLOC=$P(^LRO(69,BLRDT,1,BLRSP,0),U,7) D
  1.  . N II,X,LRI,LRSTATUS,OCXTRACE
  1.  . S:$G(LRDBUG) OCXTRACE=1
  1.  . I $D(^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,0))#2,LRCTST=+^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,0) S (LRSTATUS,II(LRCTST))="" D  K II
  1.  . . Q:$P(^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,0),U,11)  S ORIFN=$P(^(0),U,7)
  1.  . . S X=1+$O(^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
  1.  . . S ^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,1.1,X,0)=$P($G(^ORD(100.03,$P($P($G(BLRRES),U,BLRJ),":",1),0)),U,1)_": "_LRCCOM,X=X+1,X(1)=X(1)+1
  1.  . . S ^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,1.1,X,0)=$S($G(LRMERG):"*Merged:",'$D(LRLABKY):"*Cancel by Floor:",1:"*NP Action:")_$$FMTE^XLFDT(LRNOW,"5MZ")
  1.  . . S ^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
  1.  . . I $G(ORIFN),$D(II) D NEW^LR7OB1(BLRDT,BLRSP,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.II,LRSTATUS)
  1.  . . I ORIFN,$$VER^LR7OU1<3 D DC^LRCENDE1
  1.  . . S $P(^LRO(69,BLRDT,1,BLRSP,2,BLRTEST,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
  1.  . . S:$D(^LRO(69,BLRDT,1,BLRSP,"PCE")) ^LRO(69,"AE",DUZ,BLRDT,BLRSP,BLRTEST)=""
  1.  K ORIFN,ORSTS
  1.  I $D(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0))#2,$D(^(4,$G(LRCTST),0))#2 S $P(^(0),U,4,6)=DUZ_U_LRNOW_U_$S($G(LRMERG):"*Merged",1:"*Not Performed") D
  1.  . S LROWDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,3) I LROWDT,LROWDT'=LRAD D ROL Q
  1.  . S LROWDT=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,9)) I LROWDT D ROL
  1.  I $G(LRIDT),$L($G(LRSS)),$L(LRCCOM),$G(^LR(LRDFN,LRSS,LRIDT,0)) D
  1.  . D 63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)
  1.  . D:'$D(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)) XREF^LRVER3A
  1.  D EN^LA7ADL($P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3)),"^")) ; Put in list to check for auto download.
  1.  Q
  1. ROL ;
  1.  Q:+$G(^LRO(68,LRAA,1,LROWDT,1,LRAN,0))'=LRDFN  Q:'$D(^(4,LRCTST,0))#2
  1.  S $P(^LRO(68,LRAA,1,LROWDT,1,LRAN,4,LRCTST,0),U,4,6)=DUZ_U_LRNOW_U_"*Not performed"
  1.  Q
  1. UNLOCK ;
  1.  L -(^LR($G(LRDFN),$G(LRSS),$G(LRIDT)),^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN))) D END Q
  1. END ;
  1.  K LRCCOM0,LRCCOM1,LRCCOMX,LREND,LRI,LRL,LRNATURE,LRNOP,LRSCN,LRMSTATI,LRORDTST,LROWDT,LRPRAC,LRCTST,LRUID
  1.  K Q9,LRXX,DIR,LRCOM,LRAGE,DI,LRCTST,LRACN,LRACN0,LRDOC,LRLL,LRNOW
  1.  K LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LROT,LRROD,LRTT,X4
  1.  ;BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  D KVA^BLRDPT,END^LRTSTJAM  ;IHS/ITSC/TPF 04/17/03
  1.  K HRCN
  1.  ;END IHS MODIFICATIONS
  1.  Q
  1.  ;
  1. 63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ;
  1.  N X,Y,D0,D1,DA,DR,DIC,DIE,LRCCOM0,LRNOECHO,DLAYGO
  1.  S DLAYGO=63,DIC(0)="SL"
  1.  S:'$G(LRNOW) LRNOW=$$NOW^XLFDT
  1.  S LRNOECHO=1
  1.  S LRCCOM0=$E("*"_LRTNM_$S($G(LRMERG):" Merged: ",'$D(LRLABKY):" Floor Canceled: ",1:" Not Performed: ")_$$FMTE^XLFDT(LRNOW,"5FMPZ")_" by "_DUZ,1,68)
  1.  S DA=LRIDT,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""","
  1.  S LRCCOM0=$TR(LRCCOM0,";","-") ; Strip ";" - FileMan uses ";" to parse DR string.
  1.  S DR=".99///^S X="_""""_LRCCOM0_"""" D ^DIE
  1.  Q:LRSS="MI"
  1. 631 K D0,D1,DA,DR,DIC,DIE
  1.  S DIC(0)="SL"
  1.  S DA=LRIDT,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""",",DIC=DIE
  1.  S LRCCOM=$TR(LRCCOM,";","-") ; Strip ";" - FileMan uses ";" to parse DR string.
  1.  S DR=".99///^S X="_""""_LRCCOM_""""
  1.  D ^DIE
  1.  Q
  1.  ;
  1. VER() ;check to see if a test has been verified
  1.  ;0 = no; 1=yes
  1.  N LRDFN,LRIDT,LRRET,LRSS
  1.  S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)
  1.  S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
  1.  S LRRET=$S($P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,4)'="":1,1:0)
  1.  Q LRRET
  1.  ;
  1. TEST ;
  1.  S U="^"
  1.  S DT=$P($$NOW^XLFDT(),".",1)
  1.  S DTIME=9000
  1.  S IOSTBM="$C(27,91)_(+IOTM)_$C(59)_(+IOBM)_$C(114)"
  1.  D DUZ^XUP(2)
  1.  D ^%ZIS
  1.  S BLRY=""
  1.  TSTART
  1.  D DELTST(.BLRY,"3121101:5:1^3121113:1:1","")
  1.  TROLLBACK
  1.  Q