BLRAG02 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ; MAY 23, 2013 1500; SAT
;;5.2;IHS LABORATORY;**1031,1032**;NOV 01, 1997;Build 185
;
;return all accessioned lab records - RPC
ABD(BLRY,BLRBDT,BLREDT,BLRDFN,BLRDEV) ;return all accessioned records for given date range - RPC
; RPC Name is BLR ALL-ACCESSIONED
;INPUT
; BLRBDT = (optional) Begin Date in external date form
; defaults to 'today'
; BLREDT = (optional) End Date in external date form
; defaults to BLRBDT
; BLRDFN = (optional) return all accessioned lab records for this
; given patient only
; return for all patients of this parameters is not defined
; BLRDEV = Printer for Manifest reprinting - IEN pointer to the DEVICE file
; No printing will occur if null or undefined in the DEVICE file
;
;return all accessioned records for given date range - RPC
; DFN = patient IEN, pointer to VA PATIENT file 2
; PNAME = patient name as defined in the NAME field .01
; of the Va PATIENT file 2
; ACCESSION_# = as defined in the ACCESSION file 68
; UID = as defined in the LAB ORDER ENTRY file 69
; TEST_NAME = as defined in the NAME field .01 of the
; LABORATORY TEST file 60
; COLLECTION_STATUS = as defined under the SPECIMEN Multiple in the
; LAB ORDER ENTRY file 69
; REF_LAB_NAME = as defined in the REF LAB NAME FOR SHIP MANIFEST
; field in the BLR MASTER CONTROL file
; Client_# = all Client account numbers as defined in the
; BLR MASTER CONTROL file 9009029 separated by pipe |
; CHART_# = patient HCRN for area
; COLLECTION_DATE_TIME = date/time of specimen collection external format
; PROVIDER_NAM = name of person signing for the order
; LRO69_POINTERS = list of TEST POINTERS to LAB ORDER ENTRY file 69
; BLRDT:BLRSP:BLRTEST
; BLRDT = Date pointer to the LAB ORDER ENTRY file 69
; BLRSP = Specimen pointer to the LAB ORDER ENTRY FILE 69
; BLRTEST = Test pointer to the LAB ORDER ENTRY FILE 69
; ACCESSION_AREA_IEN = Accession Area pointer to file 68
; ACCESSION_AREA_NAM = Accession Area name from file 68
; ORDER_NUMBER = Unique order number to identify the specimen
;
N BLR60NAM,BLR62NAM,BLRSPNS,BLRTOP
N BLRCS
N BLRACCNO,BLRDT,BLRHCRN,BLRI,BLRIFNL,BLRJ,BLRK,BLRLCNT,BLRLI,BLRLRDFN,BLRLST,BLRLSTI,BLROI
N BLRLTMP,BLRNODS,BLRNODT,BLROERR,BLROLOC,BLRPADD
N BLRPHRN,BLRPNAM,BLRSEX,BLRSP,BLRT,BLRTI,BLRTMP
K ^TMP("BLRAG02",$J) ;used to keep records for same patient together
S (BLRPAD1,BLRPAD2,BLRPAD3,BLRPADC,BLRPADS,BLRPADZ,BLRTMP)=""
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
K BLRIFNL,BLRLTMP
S (BLRI,BLRLCNT,BLROI,BLRTI)=0
K ^TMP("BLRAG",$J)
S BLRY="^TMP(""BLRAG"","_$J_")"
S ^TMP("BLRAG",$J,0)="ERROR_ID"
S BLRTMP=""
;
;if begin date is null, default to today
I $G(BLRBDT)="" S BLRBDT=$$HTFM^XLFDT($H,1)
E D
.;convert external date to FM format
.S X=BLRBDT,%DT="XT" D ^%DT S BLRBDT=$P(Y,".")
.;default to 'today' if invalid date passed in
.S:$$FR^XLFDT($G(BLRBDT)) BLRBDT=$$HTFM^XLFDT($H,1)
;
;if end date is null, default to begin date
I $G(BLREDT)="" S BLREDT=BLRBDT
E D
.;convert external date to FM format
.S X=BLREDT,%DT="XT" D ^%DT S BLREDT=$P(Y,".")
.;default to begin date if invalid date passed in
.S:$$FR^XLFDT($G(BLREDT)) BLREDT=BLRBDT
S BLRDFN=$G(BLRDFN)
;
K BLRDTCK S BLRDTCK=""
;
;Only need to look at beginning based on BLRBDT for Yearly, Monthly, and Quarterly transforms.
; If the date range crosses years, months,or quarters, the Daily will catch them.
;look for accessions with yearly ACCESSION TRANSFORMS
S BLRDATE=$E(BLRBDT,1,3)_"0000" S BLRDTCK(BLRDATE)=""
S BLRAFMSC="" F S BLRAFMSC=$O(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC)) Q:BLRAFMSC="" D ABDA
;
;look for accessions with monthly ACCESSION TRANSFORMS
S BLRDATE=$E(BLRBDT,1,5)_"00"
I '$D(BLRDTCK(BLRDATE)) D
.S BLRDTCK(BLRDATE)=""
.S BLRAFMSC="" F S BLRAFMSC=$O(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC)) Q:BLRAFMSC="" D ABDA
;
;look for accessions with quarterly ACCESSION TRANSFORMS
S BLRTN=+($E(BLRBDT,4,5)\3) S BLRTN=(BLRTN*3)+1 S BLRDATE=$E(BLRBDT,1,3)_$S(BLRTN<10:"0",1:"")_BLRTN_"00"
I '$D(BLRDTCK(BLRDATE)) D
.S BLRDTCK(BLRDATE)=""
.S BLRAFMSC="" F S BLRAFMSC=$O(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC)) Q:BLRAFMSC="" D ABDA
;
;look for accessions in given date range (daily ACCESSION TRANSFORMS)
S BLRDATE=BLRBDT-1 F S BLRDATE=$O(^LRO(69,"AFMSC",BLRDATE)) Q:BLRDATE'>0 Q:BLRDATE>BLREDT D
.I '$D(BLRDTCK(BLRDATE)) D
..S BLRAFMSC="" F S BLRAFMSC=$O(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC)) Q:BLRAFMSC="" D ABDA
;
D ABDHD
S BLRJ="" F S BLRJ=$O(^TMP("BLRAG02",$J,BLRJ)) Q:BLRJ="" D
.S BLRK="" F S BLRK=$O(^TMP("BLRAG02",$J,BLRJ,BLRK)) Q:BLRK="" D
..S BLRI=BLRI+1
..S ^TMP("BLRAG",$J,BLRI)=^TMP("BLRAG02",$J,BLRJ,BLRK)
;
;S BLRI=BLRI+1
;S ^TMP("BLRAG",$J,BLRI)=$C(31)
Q
;
ABDA ;
S BLRDT=$P(BLRAFMSC,"|",1) ; Order Date
S BLRSP=$P(BLRAFMSC,"|",2) ; Order Specimen
S BLRT=$P(BLRAFMSC,"|",3) ; Order Test
;
S BLRORD=$P($G(^LRO(69,BLRDT,1,BLRSP,.1)),U,1) ; Order #
Q:$G(BLRORD)="" ; Quit if no Order #
;
S BLRNODS1=$G(^LRO(69,BLRDT,1,BLRSP,1)) ; specimen mult collection node
S BLRCTIM=$P(BLRNODS1,U,1) ; Collection Time
Q:+BLRCTIM<1 ; Quit if Collection time is null
;
Q:$P(BLRCTIM,".")<$P(BLRBDT,".")!($P(BLRCTIM,".")>$P(BLREDT,".")) ; IHS/MSC/MKK - BLR*5.2*1032 -- Quit if collection date not today, no matter the Accession Area.
;
S BLRNODS=$G(^LRO(69,BLRDT,1,BLRSP,0)) ; specimen mult node
S BLR62NAM=$P($G(^LAB(62,+$P(BLRNODS,U,3),0)),U,1) ; Collection Sample
;
S LRDOC=""
S (BLRDOC,X)=$P(BLRNODS,U,6) D DOC^LRX
S BLRDOCN=$E(LRDOC,1,25) ; Provider
S BLRCS=$P($G(^LRO(69,BLRDT,1,BLRSP,1)),U,4) ; Collection status
S BLROLOC=$P(BLRNODS,U,9) ; Ordering Location
;
S BLRNODT=$G(^LRO(69,BLRDT,1,BLRSP,2,BLRT,0)) ; test mult node
I $P(BLRNODT,U,3)'="" D ; Accession Date
.I $P(BLRNODT,U,9)'="CA" D ; Status
..I ($E($P(BLRNODT,U,3),6,7)="00")!(($P(BLRNODT,U,3)>=BLRBDT)&($P(BLRNODT,U,3)<=BLREDT)) D ;accession date is in range
...S BLRLRDFN=$P(BLRNODS,U,1) ; lab data IEN
...S BLRLRNOD=$G(^LR(BLRLRDFN,0)) ; Lab Data file Patient node
...I $P(BLRLRNOD,U,2)=2 D
....S BLRPDFN=$P(BLRLRNOD,U,3) ; patient IEN
....I BLRDFN'="" Q:BLRDFN'=BLRPDFN ; IFF passed in DFN, then only collect data for that patient
....;
....S BLRPNAM=$P(^DPT(BLRPDFN,0),U,1) ; patient name
....S BLRACCNI=$P(BLRNODT,U,5) ; accession number (internal pointer to file 68)
....S BLRAREA=$P(BLRNODT,U,4) ; accession area
....S BLRAREAN=$P($G(^LRO(68,BLRAREA,0)),U,1) ; accession area name
....S BLRDATE=$P(BLRNODT,U,3) ; accession date
....S BLRACCNO=$P($G(^LRO(68,BLRAREA,1,BLRDATE,1,BLRACCNI,.2)),U,1) ; Accession Number string
....S BLRUID=$P($G(^LRO(69,BLRDT,1,BLRSP,2,BLRT,.3)),U,1) ; UID
....; S BLR60NAM=$$GET1^DIQ(60,$P(BLRNODT,U,1)_",",.01) ; test name
....S BLR60NAM=$$TESTNAME^BLRAGUT(+$P(BLRNODT,U,1)) ;get test name
....S BLRHCRN=$$HRCN^BDGF2(BLRPDFN,DUZ(2)) ; chart number - HCRN
....S BLR68TST=$O(^LRO(68,BLRAREA,1,BLRDATE,1,BLRACCNI,4,"B",$P(BLRNODT,U,1),0))
....S BLRRLNAM=$P($G(^BLRSITE(DUZ(2),"RL")),U,20) ; lab name
....S BLRCLN=$P($G(^LRO(69,BLRDT,1,BLRSP,2,BLRT,"MSC")),U,1) ; client number
....;
....;S BLRMAN=$P($G(^LRO(68,BLRAREA,1,BLRDATE,1,BLRACCNI,4,BLR68TST,0)),U,10)
....;S BLRINV=$$GET1^DIQ(62.8,BLRMAN_",",.01) ; invoice number
....;S BLRCONF=$$GET1^DIQ(62.8,BLRMAN_",",.02) ; shipping configuration
....;S BLRSTAT=$$GET1^DIQ(62.8,BLRMAN_",",.03) ; shipping status
....;
....S BLRTI=BLRTI+1
....;
....; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
....S ^TMP("BLRAG02",$J,BLRPDFN,BLRTI)=BLRPDFN_U_BLRPNAM_U_BLRACCNO_U_BLRUID_U_BLR60NAM_U_BLRCS_U_BLRRLNAM_U_BLRCLN_U_BLRHCRN_U_$$FMTE^XLFDT(BLRCTIM,"5M")_U_BLRDOCN_U_BLRDT_":"_BLRSP_":"_BLRT_U_BLRAREA_U_BLRAREAN_U_BLRORD
;
Q
;
ABDHD ;
S BLRTMP="T00020DFN^T00020PNAME^T00020ACCESSION_#^T00020UID^T00020TEST_NAME^T00020COLLECTION_STATUS^"
S BLRTMP=BLRTMP_"T00020REF_LAB_NAME^T00020Client_#^T00020CHART_#^T00020COLLECTION_DATE_TIME^"
S BLRTMP=BLRTMP_"T00020PROVIDER_NAM^T00020LRO69_POINTERS^T00020ACCESSION_AREA_IEN^T00020ACCESSION_AREA_NAM^"
S BLRTMP=BLRTMP_"T00020ORDER_NUMBER"
S ^TMP("BLRAG",$J,0)=BLRTMP
Q
;
CLIENT() ;
N BLRCN,BLRRET
S BLRRET=""
S BLRCN=$O(^BLRSITE(DUZ(2),"RLCA",0))
S:BLRCN'="" BLRRET=$G(^BLRSITE(DUZ(2),"RLCA",BLRCN,0))
I BLRCN'="" F S BLRCN=$O(^BLRSITE(DUZ(2),"RLCA",BLRCN)) Q:BLRCN'>0 D
.S BLRRET=BLRRET_"|"_$G(^BLRSITE(DUZ(2),"RLCA",BLRCN,0))
Q BLRRET
;
ABR(BLRY,BLRUID,BLRLMF,BLRDEV) ;reprint accession label or manifest - RPC
; RPC Name is BLR ACCESSION PRINT
; .BLRY = returned pointer to appointment data
;INPUT:
; BLRUID = UIDs of accession to reprint delimited by ^
; BLRLMF = label or manifest flag 0=label (default); 1=manifest
; BLRDEV = Printer for Manifest printing - IEN pointer to the DEVICE file
;RETURNS:
; ERROR_ID = 0=clean
;
N BLRC1,BLRC2,BLRC3,BLRERR,BLRI,BLRJ,BLRUID1
N LRAA,LRAD,LRAN,LRODT,LRSN
S BLRERR=0
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
K BLRIFNL,BLRLTMP
S BLRI=0
K ^TMP("BLRAG",$J)
S BLRY="^TMP(""BLRAG"","_$J_")"
S ^TMP("BLRAG",$J,0)="ERRORID"
I $G(BLRLMF)="" S BLRLMF=0 ;default to label
I '+$G(BLRUID) D ERR^BLRAGUT("BLRAG02: Invalid UID") Q
;
I BLRLMF S IOP="`"_+$G(BLRDEV) D ^%ZIS
F BLRJ=1:1:$L(BLRUID,"^") D
.S BLRUID1=$P(BLRUID,"^",BLRJ)
.S:'$D(^LRO(68,"C",BLRUID1)) BLRUID1=$P($G(^LRO(69,+$P(BLRUID1,":",1),1,+$P(BLRUID1,":",2),2,+$P(BLRUID1,":",3),.3)),"^",1)
.Q:BLRUID1=""
.S LRAA=$O(^LRO(68,"C",BLRUID1,0)) Q:LRAA=""
.S LRAD=$O(^LRO(68,"C",BLRUID1,LRAA,0)) Q:LRAD=""
.S LRAN=$O(^LRO(68,"C",BLRUID1,LRAA,LRAD,0)) Q:LRAN=""
.I 'BLRLMF D ;print labels
..S BLRDEVN=$P($G(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3) ;do not use passed in printer for labels; only manifest printer is passed in
..S BLRDEV=$O(^%ZIS(1,"B",BLRDEVN,0))
..I BLRDEV>0 D
...D LBLTYP^BLRAG02A ;D LBLTYP^LRLABLD
...S IOP=$P($G(^%ZIS(1,BLRDEV,0)),U,1)
...D ^%ZIS
...Q:POP
...S LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
...U IO
...D PRINT^LRLABXT
...D ^%ZISC
.I BLRLMF D ;print manifests
.. D RPRT(+$O(^BLRSHPM("B",BLRUID1,0)),$G(BLRDEV))
I BLRDEV>0 S ^TMP("BLRAG",$J,0)="CLEAN" S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=0
I BLRDEV<1 S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=1
Q
;
RPRT(RIEN,BLRDEV) ;-- reprint
U $$DEV($G(BLRDEV))
N BLRDA
S BLRDA=0 F S BLRDA=$O(^BLRSHPM(RIEN,11,BLRDA)) Q:'BLRDA D
. W !,$G(^BLRSHPM(RIEN,11,BLRDA,0))
D ^%ZISC
Q
;
DEV(BLRDEV) ;-- device handler
; Return updated IO
; Return -1 error if device not defined at ^BLRSITE(<site>,"RL")
S DEV=""
I $G(BLRDEV)'="" S DEV=BLRDEV
;I DEV'="" S DEV=$$GET1^DIQ(3.5,BLRDEV_",",.01)
S:DEV="" DEV=$S($P($G(^BLRSITE(DUZ(2),"RL")),U,2)]"":$P($G(^BLRSITE(DUZ(2),"RL")),U,2),1:"") ;blr master control file
I DEV="" Q -1
S IOP="`"_DEV
D ^%ZIS
Q IO
;
UL(BLRY) ; rpc to return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
; RPC: BLR REF LAB USING LEDI
;Returns:
; (0) REF LAB USING LEDI? = 0='no'=CACHE (default); 1='yes'=ENSEMBLE
; (1) REF LAB BILLING TYPE = C=client
; P=patient
; T=third party
; (2) CURRENT USER IEN = pointer to VA PATIENT file 2
; (3) CURRENT USER NAME = value of NAME field in VA PATIENT
; (4) PT CONFIRM = Patient Confirmation enabled
; 0='no' (default); 1='yes'
; (5) USE INS SEQ = value of REF LAB USE INSURANCE SEQ
; 0='no' (default); 1='yes'
; (6) CLIENT ACC LIST = list of values from the
; REF LAB CLIENT ACCOUNT NUMBER multiple
; in BLR MASTER CONTROL separated by pipe |
; (7) DEF DEV MANIFEST = REF LAB DEV FOR SHIP MANIFEST
; default printer for Shipping Manifest
; ien pointer to the DEVICE file
;
;N BLRDOM,BLRENT,BLRPAR
K ^TMP("BLRAG",$J)
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
S BLRY="^TMP(""BLRAG"","_$J_")"
S ^TMP("BLRAG",$J,0)="ERROR_ID"
N BLRBILL,BLRCANI,BLRCANL,BLRISEQ,BLRLEDI,BLRPTCF,BLRRET,BLRSITE,BLRUSERN
S BLRCANL=""
I '+$G(DUZ) D ERR^BLRAGUT("BLRAG02: Invalid user defined.") Q
S BLRSITE=$G(^BLRSITE(DUZ(2),"RL"))
S BLRLEDI=+$P(BLRSITE,U,22) ; REF LAB USING LEDI?
S BLRBILL=$P(BLRSITE,U,15) ; REF LAB BILLING TYPE
S BLRRET=$P($G(^BLRSITE(DUZ(2),"RL")),U,22)
S BLRDEVM=$P(BLRSITE,U,2) ;get default printer for Shipping Manifest
S BLRUSERN=$$GET1^DIQ(200,DUZ_",",.01) ;get user name
S BLRPTCF=$$PTC^BLRAGUT() ;get patient confirmation flag
S BLRISEQ=+$P(BLRSITE,U,21) ;get REF LAB USE INSURANCE SEQ
S BLRCANI=$O(^BLRSITE(DUZ(2),"RLCA",0)) S:BLRCANI>0 BLRCANL=$P($G(^BLRSITE(DUZ(2),"RLCA",BLRCANI,0)),U,1)
I BLRCANI>0 F S BLRCANI=$O(^BLRSITE(DUZ(2),"RLCA",BLRCANI)) Q:BLRCANI'>0 S BLRCANL=BLRCANL_"|"_$P($G(^BLRSITE(DUZ(2),"RLCA",BLRCANI,0)),U,1)
S ^TMP("BLRAG",$J,0)="T00020USING_LEDI?^T00020BILLING_TYPE^T00020CURRENT_USER_IEN^T00020CURRENT_USER_NAME^T00020PT_CONFIRM^T00020USE_INS_SEQ^T00100CLIENT_ACC_LIST^T00020DEF_DEV_MANIFEST"
S ^TMP("BLRAG",$J,1)=+BLRLEDI_U_$G(BLRBILL)_U_DUZ_U_BLRUSERN_U_BLRPTCF_U_BLRISEQ_U_BLRCANL_U_BLRDEVM
Q
BLRAG02 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ; MAY 23, 2013 1500; SAT
+1 ;;5.2;IHS LABORATORY;**1031,1032**;NOV 01, 1997;Build 185
+2 ;
+3 ;return all accessioned lab records - RPC
ABD(BLRY,BLRBDT,BLREDT,BLRDFN,BLRDEV) ;return all accessioned records for given date range - RPC
+1 ; RPC Name is BLR ALL-ACCESSIONED
+2 ;INPUT
+3 ; BLRBDT = (optional) Begin Date in external date form
+4 ; defaults to 'today'
+5 ; BLREDT = (optional) End Date in external date form
+6 ; defaults to BLRBDT
+7 ; BLRDFN = (optional) return all accessioned lab records for this
+8 ; given patient only
+9 ; return for all patients of this parameters is not defined
+10 ; BLRDEV = Printer for Manifest reprinting - IEN pointer to the DEVICE file
+11 ; No printing will occur if null or undefined in the DEVICE file
+12 ;
+13 ;return all accessioned records for given date range - RPC
+14 ; DFN = patient IEN, pointer to VA PATIENT file 2
+15 ; PNAME = patient name as defined in the NAME field .01
+16 ; of the Va PATIENT file 2
+17 ; ACCESSION_# = as defined in the ACCESSION file 68
+18 ; UID = as defined in the LAB ORDER ENTRY file 69
+19 ; TEST_NAME = as defined in the NAME field .01 of the
+20 ; LABORATORY TEST file 60
+21 ; COLLECTION_STATUS = as defined under the SPECIMEN Multiple in the
+22 ; LAB ORDER ENTRY file 69
+23 ; REF_LAB_NAME = as defined in the REF LAB NAME FOR SHIP MANIFEST
+24 ; field in the BLR MASTER CONTROL file
+25 ; Client_# = all Client account numbers as defined in the
+26 ; BLR MASTER CONTROL file 9009029 separated by pipe |
+27 ; CHART_# = patient HCRN for area
+28 ; COLLECTION_DATE_TIME = date/time of specimen collection external format
+29 ; PROVIDER_NAM = name of person signing for the order
+30 ; LRO69_POINTERS = list of TEST POINTERS to LAB ORDER ENTRY file 69
+31 ; BLRDT:BLRSP:BLRTEST
+32 ; BLRDT = Date pointer to the LAB ORDER ENTRY file 69
+33 ; BLRSP = Specimen pointer to the LAB ORDER ENTRY FILE 69
+34 ; BLRTEST = Test pointer to the LAB ORDER ENTRY FILE 69
+35 ; ACCESSION_AREA_IEN = Accession Area pointer to file 68
+36 ; ACCESSION_AREA_NAM = Accession Area name from file 68
+37 ; ORDER_NUMBER = Unique order number to identify the specimen
+38 ;
+39 NEW BLR60NAM,BLR62NAM,BLRSPNS,BLRTOP
+40 NEW BLRCS
+41 NEW BLRACCNO,BLRDT,BLRHCRN,BLRI,BLRIFNL,BLRJ,BLRK,BLRLCNT,BLRLI,BLRLRDFN,BLRLST,BLRLSTI,BLROI
+42 NEW BLRLTMP,BLRNODS,BLRNODT,BLROERR,BLROLOC,BLRPADD
+43 NEW BLRPHRN,BLRPNAM,BLRSEX,BLRSP,BLRT,BLRTI,BLRTMP
+44 ;used to keep records for same patient together
KILL ^TMP("BLRAG02",$JOB)
+45 SET (BLRPAD1,BLRPAD2,BLRPAD3,BLRPADC,BLRPADS,BLRPADZ,BLRTMP)=""
+46 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+47 KILL BLRIFNL,BLRLTMP
+48 SET (BLRI,BLRLCNT,BLROI,BLRTI)=0
+49 KILL ^TMP("BLRAG",$JOB)
+50 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
+51 SET ^TMP("BLRAG",$JOB,0)="ERROR_ID"
+52 SET BLRTMP=""
+53 ;
+54 ;if begin date is null, default to today
+55 IF $GET(BLRBDT)=""
SET BLRBDT=$$HTFM^XLFDT($HOROLOG,1)
+56 IF '$TEST
Begin DoDot:1
+57 ;convert external date to FM format
+58 SET X=BLRBDT
SET %DT="XT"
DO ^%DT
SET BLRBDT=$PIECE(Y,".")
+59 ;default to 'today' if invalid date passed in
+60 IF $$FR^XLFDT($GET(BLRBDT))
SET BLRBDT=$$HTFM^XLFDT($HOROLOG,1)
End DoDot:1
+61 ;
+62 ;if end date is null, default to begin date
+63 IF $GET(BLREDT)=""
SET BLREDT=BLRBDT
+64 IF '$TEST
Begin DoDot:1
+65 ;convert external date to FM format
+66 SET X=BLREDT
SET %DT="XT"
DO ^%DT
SET BLREDT=$PIECE(Y,".")
+67 ;default to begin date if invalid date passed in
+68 IF $$FR^XLFDT($GET(BLREDT))
SET BLREDT=BLRBDT
End DoDot:1
+69 SET BLRDFN=$GET(BLRDFN)
+70 ;
+71 KILL BLRDTCK
SET BLRDTCK=""
+72 ;
+73 ;Only need to look at beginning based on BLRBDT for Yearly, Monthly, and Quarterly transforms.
+74 ; If the date range crosses years, months,or quarters, the Daily will catch them.
+75 ;look for accessions with yearly ACCESSION TRANSFORMS
+76 SET BLRDATE=$EXTRACT(BLRBDT,1,3)_"0000"
SET BLRDTCK(BLRDATE)=""
+77 SET BLRAFMSC=""
FOR
SET BLRAFMSC=$ORDER(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC))
IF BLRAFMSC=""
QUIT
DO ABDA
+78 ;
+79 ;look for accessions with monthly ACCESSION TRANSFORMS
+80 SET BLRDATE=$EXTRACT(BLRBDT,1,5)_"00"
+81 IF '$DATA(BLRDTCK(BLRDATE))
Begin DoDot:1
+82 SET BLRDTCK(BLRDATE)=""
+83 SET BLRAFMSC=""
FOR
SET BLRAFMSC=$ORDER(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC))
IF BLRAFMSC=""
QUIT
DO ABDA
End DoDot:1
+84 ;
+85 ;look for accessions with quarterly ACCESSION TRANSFORMS
+86 SET BLRTN=+($EXTRACT(BLRBDT,4,5)\3)
SET BLRTN=(BLRTN*3)+1
SET BLRDATE=$EXTRACT(BLRBDT,1,3)_$SELECT(BLRTN<10:"0",1:"")_BLRTN_"00"
+87 IF '$DATA(BLRDTCK(BLRDATE))
Begin DoDot:1
+88 SET BLRDTCK(BLRDATE)=""
+89 SET BLRAFMSC=""
FOR
SET BLRAFMSC=$ORDER(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC))
IF BLRAFMSC=""
QUIT
DO ABDA
End DoDot:1
+90 ;
+91 ;look for accessions in given date range (daily ACCESSION TRANSFORMS)
+92 SET BLRDATE=BLRBDT-1
FOR
SET BLRDATE=$ORDER(^LRO(69,"AFMSC",BLRDATE))
IF BLRDATE'>0
QUIT
IF BLRDATE>BLREDT
QUIT
Begin DoDot:1
+93 IF '$DATA(BLRDTCK(BLRDATE))
Begin DoDot:2
+94 SET BLRAFMSC=""
FOR
SET BLRAFMSC=$ORDER(^LRO(69,"AFMSC",BLRDATE,BLRAFMSC))
IF BLRAFMSC=""
QUIT
DO ABDA
End DoDot:2
End DoDot:1
+95 ;
+96 DO ABDHD
+97 SET BLRJ=""
FOR
SET BLRJ=$ORDER(^TMP("BLRAG02",$JOB,BLRJ))
IF BLRJ=""
QUIT
Begin DoDot:1
+98 SET BLRK=""
FOR
SET BLRK=$ORDER(^TMP("BLRAG02",$JOB,BLRJ,BLRK))
IF BLRK=""
QUIT
Begin DoDot:2
+99 SET BLRI=BLRI+1
+100 SET ^TMP("BLRAG",$JOB,BLRI)=^TMP("BLRAG02",$JOB,BLRJ,BLRK)
End DoDot:2
End DoDot:1
+101 ;
+102 ;S BLRI=BLRI+1
+103 ;S ^TMP("BLRAG",$J,BLRI)=$C(31)
+104 QUIT
+105 ;
ABDA ;
+1 ; Order Date
SET BLRDT=$PIECE(BLRAFMSC,"|",1)
+2 ; Order Specimen
SET BLRSP=$PIECE(BLRAFMSC,"|",2)
+3 ; Order Test
SET BLRT=$PIECE(BLRAFMSC,"|",3)
+4 ;
+5 ; Order #
SET BLRORD=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,.1)),U,1)
+6 ; Quit if no Order #
IF $GET(BLRORD)=""
QUIT
+7 ;
+8 ; specimen mult collection node
SET BLRNODS1=$GET(^LRO(69,BLRDT,1,BLRSP,1))
+9 ; Collection Time
SET BLRCTIM=$PIECE(BLRNODS1,U,1)
+10 ; Quit if Collection time is null
IF +BLRCTIM<1
QUIT
+11 ;
+12 ; IHS/MSC/MKK - BLR*5.2*1032 -- Quit if collection date not today, no matter the Accession Area.
IF $PIECE(BLRCTIM,".")<$PIECE(BLRBDT,".")!($PIECE(BLRCTIM,".")>$PIECE(BLREDT,"."))
QUIT
+13 ;
+14 ; specimen mult node
SET BLRNODS=$GET(^LRO(69,BLRDT,1,BLRSP,0))
+15 ; Collection Sample
SET BLR62NAM=$PIECE($GET(^LAB(62,+$PIECE(BLRNODS,U,3),0)),U,1)
+16 ;
+17 SET LRDOC=""
+18 SET (BLRDOC,X)=$PIECE(BLRNODS,U,6)
DO DOC^LRX
+19 ; Provider
SET BLRDOCN=$EXTRACT(LRDOC,1,25)
+20 ; Collection status
SET BLRCS=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,1)),U,4)
+21 ; Ordering Location
SET BLROLOC=$PIECE(BLRNODS,U,9)
+22 ;
+23 ; test mult node
SET BLRNODT=$GET(^LRO(69,BLRDT,1,BLRSP,2,BLRT,0))
+24 ; Accession Date
IF $PIECE(BLRNODT,U,3)'=""
Begin DoDot:1
+25 ; Status
IF $PIECE(BLRNODT,U,9)'="CA"
Begin DoDot:2
+26 ;accession date is in range
IF ($EXTRACT($PIECE(BLRNODT,U,3),6,7)="00")!(($PIECE(BLRNODT,U,3)>=BLRBDT)&($PIECE(BLRNODT,U,3)<=BLREDT))
Begin DoDot:3
+27 ; lab data IEN
SET BLRLRDFN=$PIECE(BLRNODS,U,1)
+28 ; Lab Data file Patient node
SET BLRLRNOD=$GET(^LR(BLRLRDFN,0))
+29 IF $PIECE(BLRLRNOD,U,2)=2
Begin DoDot:4
+30 ; patient IEN
SET BLRPDFN=$PIECE(BLRLRNOD,U,3)
+31 ; IFF passed in DFN, then only collect data for that patient
IF BLRDFN'=""
IF BLRDFN'=BLRPDFN
QUIT
+32 ;
+33 ; patient name
SET BLRPNAM=$PIECE(^DPT(BLRPDFN,0),U,1)
+34 ; accession number (internal pointer to file 68)
SET BLRACCNI=$PIECE(BLRNODT,U,5)
+35 ; accession area
SET BLRAREA=$PIECE(BLRNODT,U,4)
+36 ; accession area name
SET BLRAREAN=$PIECE($GET(^LRO(68,BLRAREA,0)),U,1)
+37 ; accession date
SET BLRDATE=$PIECE(BLRNODT,U,3)
+38 ; Accession Number string
SET BLRACCNO=$PIECE($GET(^LRO(68,BLRAREA,1,BLRDATE,1,BLRACCNI,.2)),U,1)
+39 ; UID
SET BLRUID=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,2,BLRT,.3)),U,1)
+40 ; S BLR60NAM=$$GET1^DIQ(60,$P(BLRNODT,U,1)_",",.01) ; test name
+41 ;get test name
SET BLR60NAM=$$TESTNAME^BLRAGUT(+$PIECE(BLRNODT,U,1))
+42 ; chart number - HCRN
SET BLRHCRN=$$HRCN^BDGF2(BLRPDFN,DUZ(2))
+43 SET BLR68TST=$ORDER(^LRO(68,BLRAREA,1,BLRDATE,1,BLRACCNI,4,"B",$PIECE(BLRNODT,U,1),0))
+44 ; lab name
SET BLRRLNAM=$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,20)
+45 ; client number
SET BLRCLN=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,2,BLRT,"MSC")),U,1)
+46 ;
+47 ;S BLRMAN=$P($G(^LRO(68,BLRAREA,1,BLRDATE,1,BLRACCNI,4,BLR68TST,0)),U,10)
+48 ;S BLRINV=$$GET1^DIQ(62.8,BLRMAN_",",.01) ; invoice number
+49 ;S BLRCONF=$$GET1^DIQ(62.8,BLRMAN_",",.02) ; shipping configuration
+50 ;S BLRSTAT=$$GET1^DIQ(62.8,BLRMAN_",",.03) ; shipping status
+51 ;
+52 SET BLRTI=BLRTI+1
+53 ;
+54 ; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
+55 SET ^TMP("BLRAG02",$JOB,BLRPDFN,BLRTI)=BLRPDFN_U_BLRPNAM_U_BLRACCNO_U_BLRUID_U_BLR60NAM_U_BLRCS_U_BLRRLNAM_U_BLRCLN_U_BLRHCRN_U_$$FMTE^XLFDT(BLRCTIM,"5M")_U_BLRDOCN_U_BLRDT_":"_BLRSP_":"_BLRT_U_BLRAREA_U_BLRAREAN
_U_BLRORD
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+56 ;
+57 QUIT
+58 ;
ABDHD ;
+1 SET BLRTMP="T00020DFN^T00020PNAME^T00020ACCESSION_#^T00020UID^T00020TEST_NAME^T00020COLLECTION_STATUS^"
+2 SET BLRTMP=BLRTMP_"T00020REF_LAB_NAME^T00020Client_#^T00020CHART_#^T00020COLLECTION_DATE_TIME^"
+3 SET BLRTMP=BLRTMP_"T00020PROVIDER_NAM^T00020LRO69_POINTERS^T00020ACCESSION_AREA_IEN^T00020ACCESSION_AREA_NAM^"
+4 SET BLRTMP=BLRTMP_"T00020ORDER_NUMBER"
+5 SET ^TMP("BLRAG",$JOB,0)=BLRTMP
+6 QUIT
+7 ;
CLIENT() ;
+1 NEW BLRCN,BLRRET
+2 SET BLRRET=""
+3 SET BLRCN=$ORDER(^BLRSITE(DUZ(2),"RLCA",0))
+4 IF BLRCN'=""
SET BLRRET=$GET(^BLRSITE(DUZ(2),"RLCA",BLRCN,0))
+5 IF BLRCN'=""
FOR
SET BLRCN=$ORDER(^BLRSITE(DUZ(2),"RLCA",BLRCN))
IF BLRCN'>0
QUIT
Begin DoDot:1
+6 SET BLRRET=BLRRET_"|"_$GET(^BLRSITE(DUZ(2),"RLCA",BLRCN,0))
End DoDot:1
+7 QUIT BLRRET
+8 ;
ABR(BLRY,BLRUID,BLRLMF,BLRDEV) ;reprint accession label or manifest - RPC
+1 ; RPC Name is BLR ACCESSION PRINT
+2 ; .BLRY = returned pointer to appointment data
+3 ;INPUT:
+4 ; BLRUID = UIDs of accession to reprint delimited by ^
+5 ; BLRLMF = label or manifest flag 0=label (default); 1=manifest
+6 ; BLRDEV = Printer for Manifest printing - IEN pointer to the DEVICE file
+7 ;RETURNS:
+8 ; ERROR_ID = 0=clean
+9 ;
+10 NEW BLRC1,BLRC2,BLRC3,BLRERR,BLRI,BLRJ,BLRUID1
+11 NEW LRAA,LRAD,LRAN,LRODT,LRSN
+12 SET BLRERR=0
+13 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+14 KILL BLRIFNL,BLRLTMP
+15 SET BLRI=0
+16 KILL ^TMP("BLRAG",$JOB)
+17 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
+18 SET ^TMP("BLRAG",$JOB,0)="ERRORID"
+19 ;default to label
IF $GET(BLRLMF)=""
SET BLRLMF=0
+20 IF '+$GET(BLRUID)
DO ERR^BLRAGUT("BLRAG02: Invalid UID")
QUIT
+21 ;
+22 IF BLRLMF
SET IOP="`"_+$GET(BLRDEV)
DO ^%ZIS
+23 FOR BLRJ=1:1:$LENGTH(BLRUID,"^")
Begin DoDot:1
+24 SET BLRUID1=$PIECE(BLRUID,"^",BLRJ)
+25 IF '$DATA(^LRO(68,"C",BLRUID1))
SET BLRUID1=$PIECE($GET(^LRO(69,+$PIECE(BLRUID1,":",1),1,+$PIECE(BLRUID1,":",2),2,+$PIECE(BLRUID1,":",3),.3)),"^",1)
+26 IF BLRUID1=""
QUIT
+27 SET LRAA=$ORDER(^LRO(68,"C",BLRUID1,0))
IF LRAA=""
QUIT
+28 SET LRAD=$ORDER(^LRO(68,"C",BLRUID1,LRAA,0))
IF LRAD=""
QUIT
+29 SET LRAN=$ORDER(^LRO(68,"C",BLRUID1,LRAA,LRAD,0))
IF LRAN=""
QUIT
+30 ;print labels
IF 'BLRLMF
Begin DoDot:2
+31 ;do not use passed in printer for labels; only manifest printer is passed in
SET BLRDEVN=$PIECE($GET(^LAB(69.9,1,3.5,+DUZ(2),0)),U,3)
+32 SET BLRDEV=$ORDER(^%ZIS(1,"B",BLRDEVN,0))
+33 IF BLRDEV>0
Begin DoDot:3
+34 ;D LBLTYP^LRLABLD
DO LBLTYP^BLRAG02A
+35 SET IOP=$PIECE($GET(^%ZIS(1,BLRDEV,0)),U,1)
+36 DO ^%ZIS
+37 IF POP
QUIT
+38 SET LRLABLIO=ION_";"_IOST_";"_IOM_";"_IOSL
+39 USE IO
+40 DO PRINT^LRLABXT
+41 DO ^%ZISC
End DoDot:3
End DoDot:2
+42 ;print manifests
IF BLRLMF
Begin DoDot:2
+43 DO RPRT(+$ORDER(^BLRSHPM("B",BLRUID1,0)),$GET(BLRDEV))
End DoDot:2
End DoDot:1
+44 IF BLRDEV>0
SET ^TMP("BLRAG",$JOB,0)="CLEAN"
SET BLRI=BLRI+1
SET ^TMP("BLRAG",$JOB,BLRI)=0
+45 IF BLRDEV<1
SET BLRI=BLRI+1
SET ^TMP("BLRAG",$JOB,BLRI)=1
+46 QUIT
+47 ;
RPRT(RIEN,BLRDEV) ;-- reprint
+1 USE $$DEV($GET(BLRDEV))
+2 NEW BLRDA
+3 SET BLRDA=0
FOR
SET BLRDA=$ORDER(^BLRSHPM(RIEN,11,BLRDA))
IF 'BLRDA
QUIT
Begin DoDot:1
+4 WRITE !,$GET(^BLRSHPM(RIEN,11,BLRDA,0))
End DoDot:1
+5 DO ^%ZISC
+6 QUIT
+7 ;
DEV(BLRDEV) ;-- device handler
+1 ; Return updated IO
+2 ; Return -1 error if device not defined at ^BLRSITE(<site>,"RL")
+3 SET DEV=""
+4 IF $GET(BLRDEV)'=""
SET DEV=BLRDEV
+5 ;I DEV'="" S DEV=$$GET1^DIQ(3.5,BLRDEV_",",.01)
+6 ;blr master control file
IF DEV=""
SET DEV=$SELECT($PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,2)]"":$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,2),1:"")
+7 IF DEV=""
QUIT -1
+8 SET IOP="`"_DEV
+9 DO ^%ZIS
+10 QUIT IO
+11 ;
UL(BLRY) ; rpc to return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
+1 ; RPC: BLR REF LAB USING LEDI
+2 ;Returns:
+3 ; (0) REF LAB USING LEDI? = 0='no'=CACHE (default); 1='yes'=ENSEMBLE
+4 ; (1) REF LAB BILLING TYPE = C=client
+5 ; P=patient
+6 ; T=third party
+7 ; (2) CURRENT USER IEN = pointer to VA PATIENT file 2
+8 ; (3) CURRENT USER NAME = value of NAME field in VA PATIENT
+9 ; (4) PT CONFIRM = Patient Confirmation enabled
+10 ; 0='no' (default); 1='yes'
+11 ; (5) USE INS SEQ = value of REF LAB USE INSURANCE SEQ
+12 ; 0='no' (default); 1='yes'
+13 ; (6) CLIENT ACC LIST = list of values from the
+14 ; REF LAB CLIENT ACCOUNT NUMBER multiple
+15 ; in BLR MASTER CONTROL separated by pipe |
+16 ; (7) DEF DEV MANIFEST = REF LAB DEV FOR SHIP MANIFEST
+17 ; default printer for Shipping Manifest
+18 ; ien pointer to the DEVICE file
+19 ;
+20 ;N BLRDOM,BLRENT,BLRPAR
+21 KILL ^TMP("BLRAG",$JOB)
+22 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+23 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
+24 SET ^TMP("BLRAG",$JOB,0)="ERROR_ID"
+25 NEW BLRBILL,BLRCANI,BLRCANL,BLRISEQ,BLRLEDI,BLRPTCF,BLRRET,BLRSITE,BLRUSERN
+26 SET BLRCANL=""
+27 IF '+$GET(DUZ)
DO ERR^BLRAGUT("BLRAG02: Invalid user defined.")
QUIT
+28 SET BLRSITE=$GET(^BLRSITE(DUZ(2),"RL"))
+29 ; REF LAB USING LEDI?
SET BLRLEDI=+$PIECE(BLRSITE,U,22)
+30 ; REF LAB BILLING TYPE
SET BLRBILL=$PIECE(BLRSITE,U,15)
+31 SET BLRRET=$PIECE($GET(^BLRSITE(DUZ(2),"RL")),U,22)
+32 ;get default printer for Shipping Manifest
SET BLRDEVM=$PIECE(BLRSITE,U,2)
+33 ;get user name
SET BLRUSERN=$$GET1^DIQ(200,DUZ_",",.01)
+34 ;get patient confirmation flag
SET BLRPTCF=$$PTC^BLRAGUT()
+35 ;get REF LAB USE INSURANCE SEQ
SET BLRISEQ=+$PIECE(BLRSITE,U,21)
+36 SET BLRCANI=$ORDER(^BLRSITE(DUZ(2),"RLCA",0))
IF BLRCANI>0
SET BLRCANL=$PIECE($GET(^BLRSITE(DUZ(2),"RLCA",BLRCANI,0)),U,1)
+37 IF BLRCANI>0
FOR
SET BLRCANI=$ORDER(^BLRSITE(DUZ(2),"RLCA",BLRCANI))
IF BLRCANI'>0
QUIT
SET BLRCANL=BLRCANL_"|"_$PIECE($GET(^BLRSITE(DUZ(2),"RLCA",BLRCANI,0)),U,1)
+38 SET ^TMP("BLRAG",$JOB,0)="T00020USING_LEDI?^T00020BILLING_TYPE^T00020CURRENT_USER_IEN^T00020CURRENT_USER_NAME^T00020PT_CONFIRM^T00020USE_INS_SEQ^T00100CLIENT_ACC_LIST^T00020DEF_DEV_MANIFEST"
+39 SET ^TMP("BLRAG",$JOB,1)=+BLRLEDI_U_$GET(BLRBILL)_U_DUZ_U_BLRUSERN_U_BLRPTCF_U_BLRISEQ_U_BLRCANL_U_BLRDEVM
+40 QUIT
