BLRAG01 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
;
; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
;
; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
;
; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest
; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
;
;return all non-accessioned lab records - RPC
ANA(BLRY,BLRDFN,BLRUSRDY) ;return appointment data for given patient - RPC
; RPC Name is BLR ALL NON-ACCESSIONED
;INPUT:
; .BLRY = returned pointer to appointment data
; BLRDFN = (optional) return all non-accessioned lab records for this
; given patient only
; return for all patients of this parameter
; is not defined
; BLRUSRDY = Temporary User Override of the BLR DAYS TO ACCESSION XPAR Parameter
;
;RETURNS:
; (0) DFN
; (1) PNAME
; (2) HRN
; (3) DOB
; (5) IFN
; (6) Grp
; (7) ActTm
; (8) StrtTm
; (9) StopTm
; (10) Sts
; (11) Sig
; (12) Nrs
; (13) Clk
; (14) PrvID
; (15) PrvNam
; (16) ActDA
; (17) Flag
; (18) DCType
; (19) ChrtRev
; (20) DEA#
; (21) <NOT USED>
; (22) SCHEDULE
; (23) ORDER_TEXT
; (24) DETAIL_TEXT
; (25) STREET_LINE1
; (26) STREET_LINE2
; (27) STREET_LINE3
; (28) CITY
; (29) STATE
; (30) ZIP
; (31) SEX
; (32) COLLECTION_TYPE
; (33) DATE_TIME_ORDERED
; (34) LAB_ORDER_#
; (35) TEST_NAME
; (36) COLLECTION_SAMPLE
; (37) SPECIMENS
; (38) SSN
; (39) ACCESSION_#
; (40) LRO69_POINTERS
; (41)LAB_INSTRUCTS
;
N BLR60NAM,BLR62NAM,BLRSPNS,BLRTOP
N BLRACCNO
N BLRDT,BLRI,BLRIFNL,BLRJ,BLRK,BLRLCNT,BLRLI,BLRLRDFN,BLRLST,BLRLSTI,BLROI
N BLRLTMP,BLRNODS,BLRNODT,BLROERR,BLROLOC,BLRPADD
N BLRPHRN,BLRPNAM,BLRSEX,BLRSP,BLRT,BLRTI,BLRSSN,BLRTMP
NEW BLRSDAYS,LRDFN,PASTDAYS,FUTUDAYS
;
; ^TMP("BLRAG01",$J,DFN,<BLRTI counter>)=data
K ^TMP("BLRAG01",$J) ;used to keep records for same patient together
S (BLRACCNO,BLRPAD1,BLRPAD2,BLRPAD3,BLRPADC,BLRPADS,BLRPADZ,BLRSSN,BLRTMP)=""
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
K BLRIFNL,BLRLTMP
S (BLRI,BLRLCNT,BLROI,BLRTI)=0
S BLRDFN=$G(BLRDFN)
K ^TMP("BLRAG",$J)
S BLRY="^TMP(""BLRAG"","_$J_")"
; LRO69_POINTERS = pointers to the LAB ORDER ENTRY file 69; BLRDT:BLRSP:BLRTEST; passed into BLR DELETE TEST
S BLRTMP($J,0)="ERROR_ID"
;
; Use the 'Return Days To Accession' XPAR Parameter to determine how many days to go back and forward.
; If the parameter is zero, use 90 Days.
D RETDTA^BLRAG10(.BLRSDAYS) ; Get 'Return Days To Accession' XPAR Parameter
S:+$G(BLRUSRDY) BLRSDAYS=BLRUSRDY ; If user over-ride passed in, then use that
;
; Set 'How many days in the past' Variable
S PASTDAYS=$S(BLRSDAYS:$$HTFM^XLFDT(+$H-(BLRSDAYS+1)),1:$$HTFM^XLFDT(+$H-91))
;
; Set 'How many days in the future' Variable
S FUTUDAYS=+$O(^LRO(69,"AA"),-1) ; Get "last" Date in Lab Order Entry (#69) file
S FUTUDAYS=$S(BLRSDAYS:$$HTFM^XLFDT(+$H+BLRSDAYS),FUTUDAYS>$$DT^XLFDT:FUTUDAYS,1:$$HTFM^XLFDT(+$H+89))
;
S LRDFN=$S(+$G(BLRDFN):+$G(^DPT(BLRDFN,"LR")),1:0) ; Set LRDFN variable
;
I LRDFN D
. S BLRDT=PASTDAYS
. F S BLRDT=$O(^LRO(69,"D",LRDFN,BLRDT)) Q:BLRDT'>0!(BLRDT>FUTUDAYS) D ; date level
..S BLRSP=0 F S BLRSP=$O(^LRO(69,"D",LRDFN,BLRDT,BLRSP)) Q:BLRSP'>0 D ; specimen mult level
...D ANA1(BLRDT,BLRSP,.BLRTI)
;
I LRDFN<1 D
. S BLRDT=PASTDAYS
. F S BLRDT=$O(^LRO(69,BLRDT)) Q:BLRDT'>0!(BLRDT>FUTUDAYS) D ; date level
..S BLRSP=0 F S BLRSP=$O(^LRO(69,BLRDT,1,BLRSP)) Q:BLRSP'>0 D ; specimen mult level
...D ANA1(BLRDT,BLRSP,.BLRTI)
;
D ANAHD
S BLRJ="" F S BLRJ=$O(^TMP("BLRAG01",$J,BLRJ)) Q:BLRJ="" D
.S BLRK="" F S BLRK=$O(^TMP("BLRAG01",$J,BLRJ,BLRK)) Q:BLRK="" D
..S BLRI=BLRI+1
..S ^TMP("BLRAG",$J,BLRI)=^TMP("BLRAG01",$J,BLRJ,BLRK)
;
;S BLRI=BLRI+1
;S ^TMP("BLRAG",$J,BLRI)=$C(31)
K ^TMP("BLRAG01",$J)
Q
;
ANA1(BLRDT,BLRSP,BLRTI) ;
; BLRDT = date in FM format; pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT
; BLRSP = Specimen pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT,1,BLRSP
; BLRTI = counter for global array entries
S BLRNODS=$G(^LRO(69,BLRDT,1,BLRSP,0)) ;get specimen mult node
Q:$G(BLRNODS)=""
Q:$P(BLRNODS,U,4)="LC" ;do not include LAB COLLECT
S BLRSPNS="" ; list of specimen names delimited by pipe |
S BLRK=0 F S BLRK=$O(^LRO(69,BLRDT,1,BLRSP,4,BLRK)) Q:BLRK'>0 D
.S BLRTOP=$P($G(^LRO(69,BLRDT,1,BLRSP,4,BLRK,0)),U,1)
.S BLRSPNS=$S(BLRSPNS'="":"|",1:"")_$$GET1^DIQ(61,BLRTOP_",",.01)
S BLR62NAM=$P($G(^LAB(62,+$P(BLRNODS,U,3),0)),U,1)
S BLRORD=$P($G(^LRO(69,BLRDT,1,BLRSP,.1)),U,1)
Q:$G(BLRORD)=""
S BLRT=0 F S BLRT=$O(^LRO(69,BLRDT,1,BLRSP,2,BLRT)) Q:BLRT'>0 D ;test mult level
.S BLRNODT=$G(^LRO(69,BLRDT,1,BLRSP,2,BLRT,0)) ;get test mult node
.I $P(BLRNODT,U,3)="",$P(BLRNODT,U,9)'="CA" D ;If no accession date ...
..S BLRLRDFN=$P(BLRNODS,U,1) ;get lab data IEN
..S BLRLRND=$G(^LR(BLRLRDFN,0))
..I $P(BLRLRND,U,2)=2 D
...; S BLR60NAM=$$GET1^DIQ(60,+$P(BLRNODT,U,1)_",",.01) ;get test name
...S BLR60NAM=$$TESTNAME^BLRAGUT(+$P(BLRNODT,U,1)) ;get test name
...K BLRINST S BLRINST=""
...D INST(+$P(BLRNODT,U,1),+$P(BLRNODS,U,3),.BLRINST) ;get lab instructions
...S BLRPDFN=$P(BLRLRND,U,3) ;get patient IEN
...I ('$G(BLRDFN))!(BLRDFN=BLRPDFN) D
....S BLRPNAM=$P(^DPT(BLRPDFN,0),U,1) ;get patient name
....S BLRPHRN=$$HRN^AUPNPAT(BLRPDFN,DUZ(2)) ;get patient HRN
....S BLRPDOB=$$DOB^AUPNPAT(BLRPDFN) ;get patient DOB
....S BLRPSEX=$$SEX^AUPNPAT(BLRPDFN) ;get patient gender
....S BLRPADD=$G(^DPT(BLRPDFN,.11)) ;get patient address node
....S BLRSSN=$$SSN^AUPNPAT(BLRPDFN) ;get patient SSN
....S BLROERR=$P(BLRNODT,U,7) ;get order IEN
....S BLRACCNO=$$GACE69^BLRAGUT(BLRDT,BLRSP,BLRT) ;get accession number
....S BLRIFNL(1)=BLROERR
....K BLRDLST,BLRFLST
....S (BLRDLST,BLRFLST)=""
....D GET4V11^ORWORR(.BLRFLST,"",0,.BLRIFNL)
....D DETAIL^ORWOR(.BLRDLST,BLROERR)
....S BLRTI=BLRTI+1
....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRPDFN_U_BLRPNAM_U_BLRPHRN_U_BLRPDOB_U
....S BLRTMP=""
....S BLRLSTI=$O(BLRFLST(0))
....S BLRTMP=$E($P(BLRFLST(BLRLSTI),U,1),2,$L(BLRFLST(BLRLSTI)))
....F BLRJ=2:1:18 D
.....S $P(BLRTMP,U,BLRJ)=$P(BLRFLST(BLRLSTI),U,BLRJ)
....S BLRTI=BLRTI+1
....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRTMP_U
....F S BLRLSTI=$O(BLRFLST(BLRLSTI)) Q:BLRLSTI="" D
.....S BLRTI=BLRTI+1
.....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=$E(BLRFLST(BLRLSTI),2,$L(BLRFLST(BLRLSTI)))
....S BLRTI=BLRTI+1,^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=U
....S BLRLSTI=0 F S BLRLSTI=$O(^TMP("ORTXT",$J,BLRLSTI)) Q:BLRLSTI="" D
.....S BLRTI=BLRTI+1
.....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=^TMP("ORTXT",$J,BLRLSTI)_"|"
....S BLRTMP1=U_$P(BLRPADD,U,1)_U_$P(BLRPADD,U,2)_U_$P(BLRPADD,U,3)_U_$P(BLRPADD,U,4)_U_$P(BLRPADD,U,5)_U
....S BLRTMP1=BLRTMP1_$P(BLRPADD,U,6)_U_BLRPSEX_U_$P(BLRNODS,U,4)_U_$P(BLRNODS,U,5)_U
....S BLRTMP1=BLRTMP1_BLRORD_U_BLR60NAM_U_BLR62NAM_U_BLRSPNS_U_BLRSSN_U_BLRACCNO_U_BLRDT_":"_BLRSP_":"_BLRT_U
....S BLRTI=BLRTI+1
....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRTMP1
....S BLRTMP1=""
....S BLRD="" F S BLRD=$O(BLRINST(BLRD)) Q:BLRD="" S BLRTI=BLRTI+1 S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRINST(BLRD)_"|"
....S BLRTI=BLRTI+1,^TMP("BLRAG01",$J,BLRPDFN,BLRTI)="~~~"_$C(30)
Q
;
ANAHD ;
; 0 1 2 3
S BLRTMP="T00020DFN^T00020PNAME^T00020HRN^T00020DOB^"
; 4 5 6 7 8 9
S BLRTMP=BLRTMP_"T00020IFN^T00020Grp^T00020ActTm^T00020StrtTm^T00020StopTm^T00020Sts^"
; 10 11 12 13 14 15
S BLRTMP=BLRTMP_"T00020Sig^T00020Nrs^T00020Clk^T00020PrvID^T00020PrvNam^T00020ActDA^"
; 16 17 18 19 20 21
S BLRTMP=BLRTMP_"T00020Flag^T00020DCType^T00020ChrtRev^T00020DEA#^^T00020SCHEDULE^"
; 22 23
S BLRTMP=BLRTMP_"T00900ORDER_TEXT^T00900DETAIL_TEXT^"
; 24 25 26 27 28 29 30
S BLRTMP=BLRTMP_"T00020STREET_LINE1^T00020STREET_LINE2^T00020STREET_LINE3^T00020CITY^T00020STATE^T00020ZIP^T00020SEX^"
; 31 32 33 34 35
S BLRTMP=BLRTMP_"T00020COLLECTION_TYPE^T00020DATE_TIME_ORDERED^T00020LAB_ORDER_#^T00020TEST_NAME^T00020COLLECTION_SAMPLE^"
; 36 37 38 39 40
S BLRTMP=BLRTMP_"T00020SPECIMENS^T00020SSN^T00020ACCESSION_#^T00020LRO69_POINTERS^T00500LAB_INSTRUCTS"
S ^TMP("BLRAG",$J,0)=BLRTMP_"~~~"_$C(30)
Q
;
INST(BLRLRDFN,BLRCS,BLRRET) ; get lab instructions for given lab test and collection sample
; BLRLRDFN = pointer to LABORATORY TEST file 60
; BLRCS = pointer to COLLECTION SAMPLE file 62
; BLRRET = returned lab instructions array
; BLRRET(COUNT)=TEXT
N BLRD,BLRCSIEN
S BLRRET=""
S BLRCSIEN=$O(^LAB(60,BLRLRDFN,3,"B",BLRCS,0))
Q:BLRCSIEN=""
S BLRD=0 F S BLRD=$O(^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD)) Q:BLRD'>0 D
.S BLRRET(BLRD)=^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD,0)
Q
;
PTC(BLRY) ; rpc to return the value of the BLR PT CONFIRM parameter
; RPC: BLR PT CONFIRM ENABLED
; Returns Patient Confirmation enabled; 0='no' (default); 1='yes'
N BLRDOM,BLRENT,BLRI,BLRPAR
K ^TMP("BLRAG",$J)
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
S BLRI=0
S BLRY="^TMP(""BLRAG"","_$J_")"
S ^TMP("BLRAG",$J,BLRI)="T00020PT_CONFIRM"_$C(30)
S BLRDOM=$$GET1^DIQ(8989.3,"1,",.01,"I")
S BLRENT=BLRDOM_";"_"DIC(4.2,"
S BLRPAR=$O(^XTV(8989.51,"B","BLR PT CONFIRM",0))
S BLRRET=$$GET^XPAR(BLRENT,BLRPAR,1,"Q")
S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$S(BLRRET'="":BLRRET,1:0)_$C(30)
;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
Q
;
PTCS(BLRY,BLRDT,BLRSPN,BLRUSER,BLRDTCF,BLRMETH) ;rpc to store Patient Confirmation data to the Specimen Multiple of the LAB ORDER ENTRY file
; RPC: BLR PT CONFIRM STORE
; BLRDT = (required) order date in external format - pointer to LAB ORDER ENTRY file 69
; BLRSPN = (required) specimen number - pointer to specimen multiple in LAB ORDER ENTRY file 69
; BLRUSER = (required) user that did confirmation - pointer to NEW PERSON file 200
; BLRDTCF = (optional) Date/Time of user confirmation in external format - defaults to 'today'
; BLRMETH = (optional) method of confirmation - free text
N BLRI,BLRM
K ^TMP("BLRAG",$J)
D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
S BLRI=0
S BLRY="^TMP(""BLRAG"","_$J_")"
S ^TMP("BLRAG",$J,BLRI)="T00020ERROR_ID" ;0=clean; Text=error
;convert external date to FM format
S X=$G(BLRDT),%DT="XT" D ^%DT S BLRDT=$P(Y,".")
;error if invalid date passed in
I $$FR^XLFDT($G(BLRDT)) D ERR^BLRAGUT("BLRAG01: Invalid order date.") Q
I '$G(BLRSPN) D ERR^BLRAGUT("BLRAG01: Invalid Specimen Number.") Q
I '$G(BLRUSER)!'$D(^VA(200,BLRUSER)) D ERR^BLRAGUT("BLRAG01: Invalid User.") Q
S BLRORD=$P(^LRO(69,BLRDT,1,BLRSPN,.1),U,1)
I '$D(^LRO(69,BLRDT,1,BLRSPN))!(BLRORD="") D ERR^BLRAGUT("BLRAG01: Invalid Order.") Q
;;
TSTART
L +^LRO(69,"C",+$G(BLRORD)):1
;L +^LRO(69,BLRDT,1,BLRSPN):5
I '$T TROLLBACK D ERR^BLRAGUT("BLRAG01: File being modified elsewhere.") Q
;if confirmation date is null, default to NOW
I $G(BLRDTCF)="" S BLRDTCF=$$HTFM^XLFDT($H)
E D
.;convert external date to FM format
.S X=BLRDTCF,%DT="XT" D ^%DT S BLRDTCF=Y
.;default to 'NOW' if invalid date passed in
.S:$$FR^XLFDT($G(BLRDTCF)) BLRDTCF=$$HTFM^XLFDT($H)
K BLRM
S BLRM=""
S FDA(69.01,BLRSPN_","_+BLRDT_",",21400)=BLRUSER
S FDA(69.01,BLRSPN_","_+BLRDT_",",21401)=BLRDTCF
S FDA(69.01,BLRSPN_","_+BLRDT_",",21402)=BLRMETH
D FILE^DIE("","FDA","BLRM")
I $D(BLRM("DIERR")) D ERR^BLRAGUT("BLRAG01: "_BLRM("DIERR",1,"TEXT",1)) L -^LRO(69,BLRDT,1,BLRSPN) TROLLBACK Q
; L -^LRO(69,BLRDT,1,BLRSPN)
D UNL69
TCOMMIT
;;
S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=0_$C(30)
;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
Q
;
UNL69 ;
L -^LRO(69,"C",+$G(LRORD))
Q
BLRAG01 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
+1 ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
+2 ;
+3 ; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
+4 ; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
+5 ; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
+6 ; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
+7 ; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
+8 ; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
+9 ;
+10 ; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
+11 ; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
+12 ; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
+13 ; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
+14 ; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
+15 ; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
+16 ; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
+17 ;
+18 ; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
+19 ; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
+20 ; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
+21 ; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
+22 ; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
+23 ; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest
+24 ; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
+25 ; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
+26 ;
+27 ;return all non-accessioned lab records - RPC
ANA(BLRY,BLRDFN,BLRUSRDY) ;return appointment data for given patient - RPC
+1 ; RPC Name is BLR ALL NON-ACCESSIONED
+2 ;INPUT:
+3 ; .BLRY = returned pointer to appointment data
+4 ; BLRDFN = (optional) return all non-accessioned lab records for this
+5 ; given patient only
+6 ; return for all patients of this parameter
+7 ; is not defined
+8 ; BLRUSRDY = Temporary User Override of the BLR DAYS TO ACCESSION XPAR Parameter
+9 ;
+10 ;RETURNS:
+11 ; (0) DFN
+12 ; (1) PNAME
+13 ; (2) HRN
+14 ; (3) DOB
+15 ; (5) IFN
+16 ; (6) Grp
+17 ; (7) ActTm
+18 ; (8) StrtTm
+19 ; (9) StopTm
+20 ; (10) Sts
+21 ; (11) Sig
+22 ; (12) Nrs
+23 ; (13) Clk
+24 ; (14) PrvID
+25 ; (15) PrvNam
+26 ; (16) ActDA
+27 ; (17) Flag
+28 ; (18) DCType
+29 ; (19) ChrtRev
+30 ; (20) DEA#
+31 ; (21) <NOT USED>
+32 ; (22) SCHEDULE
+33 ; (23) ORDER_TEXT
+34 ; (24) DETAIL_TEXT
+35 ; (25) STREET_LINE1
+36 ; (26) STREET_LINE2
+37 ; (27) STREET_LINE3
+38 ; (28) CITY
+39 ; (29) STATE
+40 ; (30) ZIP
+41 ; (31) SEX
+42 ; (32) COLLECTION_TYPE
+43 ; (33) DATE_TIME_ORDERED
+44 ; (34) LAB_ORDER_#
+45 ; (35) TEST_NAME
+46 ; (36) COLLECTION_SAMPLE
+47 ; (37) SPECIMENS
+48 ; (38) SSN
+49 ; (39) ACCESSION_#
+50 ; (40) LRO69_POINTERS
+51 ; (41)LAB_INSTRUCTS
+52 ;
+53 NEW BLR60NAM,BLR62NAM,BLRSPNS,BLRTOP
+54 NEW BLRACCNO
+55 NEW BLRDT,BLRI,BLRIFNL,BLRJ,BLRK,BLRLCNT,BLRLI,BLRLRDFN,BLRLST,BLRLSTI,BLROI
+56 NEW BLRLTMP,BLRNODS,BLRNODT,BLROERR,BLROLOC,BLRPADD
+57 NEW BLRPHRN,BLRPNAM,BLRSEX,BLRSP,BLRT,BLRTI,BLRSSN,BLRTMP
+58 NEW BLRSDAYS,LRDFN,PASTDAYS,FUTUDAYS
+59 ;
+60 ; ^TMP("BLRAG01",$J,DFN,<BLRTI counter>)=data
+61 ;used to keep records for same patient together
KILL ^TMP("BLRAG01",$JOB)
+62 SET (BLRACCNO,BLRPAD1,BLRPAD2,BLRPAD3,BLRPADC,BLRPADS,BLRPADZ,BLRSSN,BLRTMP)=""
+63 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+64 KILL BLRIFNL,BLRLTMP
+65 SET (BLRI,BLRLCNT,BLROI,BLRTI)=0
+66 SET BLRDFN=$GET(BLRDFN)
+67 KILL ^TMP("BLRAG",$JOB)
+68 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
+69 ; LRO69_POINTERS = pointers to the LAB ORDER ENTRY file 69; BLRDT:BLRSP:BLRTEST; passed into BLR DELETE TEST
+70 SET BLRTMP($JOB,0)="ERROR_ID"
+71 ;
+72 ; Use the 'Return Days To Accession' XPAR Parameter to determine how many days to go back and forward.
+73 ; If the parameter is zero, use 90 Days.
+74 ; Get 'Return Days To Accession' XPAR Parameter
DO RETDTA^BLRAG10(.BLRSDAYS)
+75 ; If user over-ride passed in, then use that
IF +$GET(BLRUSRDY)
SET BLRSDAYS=BLRUSRDY
+76 ;
+77 ; Set 'How many days in the past' Variable
+78 SET PASTDAYS=$SELECT(BLRSDAYS:$$HTFM^XLFDT(+$HOROLOG-(BLRSDAYS+1)),1:$$HTFM^XLFDT(+$HOROLOG-91))
+79 ;
+80 ; Set 'How many days in the future' Variable
+81 ; Get "last" Date in Lab Order Entry (#69) file
SET FUTUDAYS=+$ORDER(^LRO(69,"AA"),-1)
+82 SET FUTUDAYS=$SELECT(BLRSDAYS:$$HTFM^XLFDT(+$HOROLOG+BLRSDAYS),FUTUDAYS>$$DT^XLFDT:FUTUDAYS,1:$$HTFM^XLFDT(+$HOROLOG+89))
+83 ;
+84 ; Set LRDFN variable
SET LRDFN=$SELECT(+$GET(BLRDFN):+$GET(^DPT(BLRDFN,"LR")),1:0)
+85 ;
+86 IF LRDFN
Begin DoDot:1
+87 SET BLRDT=PASTDAYS
+88 ; date level
FOR
SET BLRDT=$ORDER(^LRO(69,"D",LRDFN,BLRDT))
IF BLRDT'>0!(BLRDT>FUTUDAYS)
QUIT
Begin DoDot:2
+89 ; specimen mult level
SET BLRSP=0
FOR
SET BLRSP=$ORDER(^LRO(69,"D",LRDFN,BLRDT,BLRSP))
IF BLRSP'>0
QUIT
Begin DoDot:3
+90 DO ANA1(BLRDT,BLRSP,.BLRTI)
End DoDot:3
End DoDot:2
End DoDot:1
+91 ;
+92 IF LRDFN<1
Begin DoDot:1
+93 SET BLRDT=PASTDAYS
+94 ; date level
FOR
SET BLRDT=$ORDER(^LRO(69,BLRDT))
IF BLRDT'>0!(BLRDT>FUTUDAYS)
QUIT
Begin DoDot:2
+95 ; specimen mult level
SET BLRSP=0
FOR
SET BLRSP=$ORDER(^LRO(69,BLRDT,1,BLRSP))
IF BLRSP'>0
QUIT
Begin DoDot:3
+96 DO ANA1(BLRDT,BLRSP,.BLRTI)
End DoDot:3
End DoDot:2
End DoDot:1
+97 ;
+98 DO ANAHD
+99 SET BLRJ=""
FOR
SET BLRJ=$ORDER(^TMP("BLRAG01",$JOB,BLRJ))
IF BLRJ=""
QUIT
Begin DoDot:1
+100 SET BLRK=""
FOR
SET BLRK=$ORDER(^TMP("BLRAG01",$JOB,BLRJ,BLRK))
IF BLRK=""
QUIT
Begin DoDot:2
+101 SET BLRI=BLRI+1
+102 SET ^TMP("BLRAG",$JOB,BLRI)=^TMP("BLRAG01",$JOB,BLRJ,BLRK)
End DoDot:2
End DoDot:1
+103 ;
+104 ;S BLRI=BLRI+1
+105 ;S ^TMP("BLRAG",$J,BLRI)=$C(31)
+106 KILL ^TMP("BLRAG01",$JOB)
+107 QUIT
+108 ;
ANA1(BLRDT,BLRSP,BLRTI) ;
+1 ; BLRDT = date in FM format; pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT
+2 ; BLRSP = Specimen pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT,1,BLRSP
+3 ; BLRTI = counter for global array entries
+4 ;get specimen mult node
SET BLRNODS=$GET(^LRO(69,BLRDT,1,BLRSP,0))
+5 IF $GET(BLRNODS)=""
QUIT
+6 ;do not include LAB COLLECT
IF $PIECE(BLRNODS,U,4)="LC"
QUIT
+7 ; list of specimen names delimited by pipe |
SET BLRSPNS=""
+8 SET BLRK=0
FOR
SET BLRK=$ORDER(^LRO(69,BLRDT,1,BLRSP,4,BLRK))
IF BLRK'>0
QUIT
Begin DoDot:1
+9 SET BLRTOP=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,4,BLRK,0)),U,1)
+10 SET BLRSPNS=$SELECT(BLRSPNS'="":"|",1:"")_$$GET1^DIQ(61,BLRTOP_",",.01)
End DoDot:1
+11 SET BLR62NAM=$PIECE($GET(^LAB(62,+$PIECE(BLRNODS,U,3),0)),U,1)
+12 SET BLRORD=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,.1)),U,1)
+13 IF $GET(BLRORD)=""
QUIT
+14 ;test mult level
SET BLRT=0
FOR
SET BLRT=$ORDER(^LRO(69,BLRDT,1,BLRSP,2,BLRT))
IF BLRT'>0
QUIT
Begin DoDot:1
+15 ;get test mult node
SET BLRNODT=$GET(^LRO(69,BLRDT,1,BLRSP,2,BLRT,0))
+16 ;If no accession date ...
IF $PIECE(BLRNODT,U,3)=""
IF $PIECE(BLRNODT,U,9)'="CA"
Begin DoDot:2
+17 ;get lab data IEN
SET BLRLRDFN=$PIECE(BLRNODS,U,1)
+18 SET BLRLRND=$GET(^LR(BLRLRDFN,0))
+19 IF $PIECE(BLRLRND,U,2)=2
Begin DoDot:3
+20 ; S BLR60NAM=$$GET1^DIQ(60,+$P(BLRNODT,U,1)_",",.01) ;get test name
+21 ;get test name
SET BLR60NAM=$$TESTNAME^BLRAGUT(+$PIECE(BLRNODT,U,1))
+22 KILL BLRINST
SET BLRINST=""
+23 ;get lab instructions
DO INST(+$PIECE(BLRNODT,U,1),+$PIECE(BLRNODS,U,3),.BLRINST)
+24 ;get patient IEN
SET BLRPDFN=$PIECE(BLRLRND,U,3)
+25 IF ('$GET(BLRDFN))!(BLRDFN=BLRPDFN)
Begin DoDot:4
+26 ;get patient name
SET BLRPNAM=$PIECE(^DPT(BLRPDFN,0),U,1)
+27 ;get patient HRN
SET BLRPHRN=$$HRN^AUPNPAT(BLRPDFN,DUZ(2))
+28 ;get patient DOB
SET BLRPDOB=$$DOB^AUPNPAT(BLRPDFN)
+29 ;get patient gender
SET BLRPSEX=$$SEX^AUPNPAT(BLRPDFN)
+30 ;get patient address node
SET BLRPADD=$GET(^DPT(BLRPDFN,.11))
+31 ;get patient SSN
SET BLRSSN=$$SSN^AUPNPAT(BLRPDFN)
+32 ;get order IEN
SET BLROERR=$PIECE(BLRNODT,U,7)
+33 ;get accession number
SET BLRACCNO=$$GACE69^BLRAGUT(BLRDT,BLRSP,BLRT)
+34 SET BLRIFNL(1)=BLROERR
+35 KILL BLRDLST,BLRFLST
+36 SET (BLRDLST,BLRFLST)=""
+37 DO GET4V11^ORWORR(.BLRFLST,"",0,.BLRIFNL)
+38 DO DETAIL^ORWOR(.BLRDLST,BLROERR)
+39 SET BLRTI=BLRTI+1
+40 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRPDFN_U_BLRPNAM_U_BLRPHRN_U_BLRPDOB_U
+41 SET BLRTMP=""
+42 SET BLRLSTI=$ORDER(BLRFLST(0))
+43 SET BLRTMP=$EXTRACT($PIECE(BLRFLST(BLRLSTI),U,1),2,$LENGTH(BLRFLST(BLRLSTI)))
+44 FOR BLRJ=2:1:18
Begin DoDot:5
+45 SET $PIECE(BLRTMP,U,BLRJ)=$PIECE(BLRFLST(BLRLSTI),U,BLRJ)
End DoDot:5
+46 SET BLRTI=BLRTI+1
+47 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRTMP_U
+48 FOR
SET BLRLSTI=$ORDER(BLRFLST(BLRLSTI))
IF BLRLSTI=""
QUIT
Begin DoDot:5
+49 SET BLRTI=BLRTI+1
+50 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=$EXTRACT(BLRFLST(BLRLSTI),2,$LENGTH(BLRFLST(BLRLSTI)))
End DoDot:5
+51 SET BLRTI=BLRTI+1
SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=U
+52 SET BLRLSTI=0
FOR
SET BLRLSTI=$ORDER(^TMP("ORTXT",$JOB,BLRLSTI))
IF BLRLSTI=""
QUIT
Begin DoDot:5
+53 SET BLRTI=BLRTI+1
+54 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=^TMP("ORTXT",$JOB,BLRLSTI)_"|"
End DoDot:5
+55 SET BLRTMP1=U_$PIECE(BLRPADD,U,1)_U_$PIECE(BLRPADD,U,2)_U_$PIECE(BLRPADD,U,3)_U_$PIECE(BLRPADD,U,4)_U_$PIECE(BLRPADD,U,5)_U
+56 SET BLRTMP1=BLRTMP1_$PIECE(BLRPADD,U,6)_U_BLRPSEX_U_$PIECE(BLRNODS,U,4)_U_$PIECE(BLRNODS,U,5)_U
+57 SET BLRTMP1=BLRTMP1_BLRORD_U_BLR60NAM_U_BLR62NAM_U_BLRSPNS_U_BLRSSN_U_BLRACCNO_U_BLRDT_":"_BLRSP_":"_BLRT_U
+58 SET BLRTI=BLRTI+1
+59 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRTMP1
+60 SET BLRTMP1=""
+61 SET BLRD=""
FOR
SET BLRD=$ORDER(BLRINST(BLRD))
IF BLRD=""
QUIT
SET BLRTI=BLRTI+1
SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRINST(BLRD)_"|"
+62 SET BLRTI=BLRTI+1
SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)="~~~"_$CHAR(30)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+63 QUIT
+64 ;
ANAHD ;
+1 ; 0 1 2 3
+2 SET BLRTMP="T00020DFN^T00020PNAME^T00020HRN^T00020DOB^"
+3 ; 4 5 6 7 8 9
+4 SET BLRTMP=BLRTMP_"T00020IFN^T00020Grp^T00020ActTm^T00020StrtTm^T00020StopTm^T00020Sts^"
+5 ; 10 11 12 13 14 15
+6 SET BLRTMP=BLRTMP_"T00020Sig^T00020Nrs^T00020Clk^T00020PrvID^T00020PrvNam^T00020ActDA^"
+7 ; 16 17 18 19 20 21
+8 SET BLRTMP=BLRTMP_"T00020Flag^T00020DCType^T00020ChrtRev^T00020DEA#^^T00020SCHEDULE^"
+9 ; 22 23
+10 SET BLRTMP=BLRTMP_"T00900ORDER_TEXT^T00900DETAIL_TEXT^"
+11 ; 24 25 26 27 28 29 30
+12 SET BLRTMP=BLRTMP_"T00020STREET_LINE1^T00020STREET_LINE2^T00020STREET_LINE3^T00020CITY^T00020STATE^T00020ZIP^T00020SEX^"
+13 ; 31 32 33 34 35
+14 SET BLRTMP=BLRTMP_"T00020COLLECTION_TYPE^T00020DATE_TIME_ORDERED^T00020LAB_ORDER_#^T00020TEST_NAME^T00020COLLECTION_SAMPLE^"
+15 ; 36 37 38 39 40
+16 SET BLRTMP=BLRTMP_"T00020SPECIMENS^T00020SSN^T00020ACCESSION_#^T00020LRO69_POINTERS^T00500LAB_INSTRUCTS"
+17 SET ^TMP("BLRAG",$JOB,0)=BLRTMP_"~~~"_$CHAR(30)
+18 QUIT
+19 ;
INST(BLRLRDFN,BLRCS,BLRRET) ; get lab instructions for given lab test and collection sample
+1 ; BLRLRDFN = pointer to LABORATORY TEST file 60
+2 ; BLRCS = pointer to COLLECTION SAMPLE file 62
+3 ; BLRRET = returned lab instructions array
+4 ; BLRRET(COUNT)=TEXT
+5 NEW BLRD,BLRCSIEN
+6 SET BLRRET=""
+7 SET BLRCSIEN=$ORDER(^LAB(60,BLRLRDFN,3,"B",BLRCS,0))
+8 IF BLRCSIEN=""
QUIT
+9 SET BLRD=0
FOR
SET BLRD=$ORDER(^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD))
IF BLRD'>0
QUIT
Begin DoDot:1
+10 SET BLRRET(BLRD)=^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD,0)
End DoDot:1
+11 QUIT
+12 ;
PTC(BLRY) ; rpc to return the value of the BLR PT CONFIRM parameter
+1 ; RPC: BLR PT CONFIRM ENABLED
+2 ; Returns Patient Confirmation enabled; 0='no' (default); 1='yes'
+3 NEW BLRDOM,BLRENT,BLRI,BLRPAR
+4 KILL ^TMP("BLRAG",$JOB)
+5 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+6 SET BLRI=0
+7 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
+8 SET ^TMP("BLRAG",$JOB,BLRI)="T00020PT_CONFIRM"_$CHAR(30)
+9 SET BLRDOM=$$GET1^DIQ(8989.3,"1,",.01,"I")
+10 SET BLRENT=BLRDOM_";"_"DIC(4.2,"
+11 SET BLRPAR=$ORDER(^XTV(8989.51,"B","BLR PT CONFIRM",0))
+12 SET BLRRET=$$GET^XPAR(BLRENT,BLRPAR,1,"Q")
+13 SET BLRI=BLRI+1
SET ^TMP("BLRAG",$JOB,BLRI)=$SELECT(BLRRET'="":BLRRET,1:0)_$CHAR(30)
+14 ;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
+15 QUIT
+16 ;
PTCS(BLRY,BLRDT,BLRSPN,BLRUSER,BLRDTCF,BLRMETH) ;rpc to store Patient Confirmation data to the Specimen Multiple of the LAB ORDER ENTRY file
+1 ; RPC: BLR PT CONFIRM STORE
+2 ; BLRDT = (required) order date in external format - pointer to LAB ORDER ENTRY file 69
+3 ; BLRSPN = (required) specimen number - pointer to specimen multiple in LAB ORDER ENTRY file 69
+4 ; BLRUSER = (required) user that did confirmation - pointer to NEW PERSON file 200
+5 ; BLRDTCF = (optional) Date/Time of user confirmation in external format - defaults to 'today'
+6 ; BLRMETH = (optional) method of confirmation - free text
+7 NEW BLRI,BLRM
+8 KILL ^TMP("BLRAG",$JOB)
+9 DO ^XBKVAR
SET X="ERROR^BLRAGUT"
SET @^%ZOSF("TRAP")
+10 SET BLRI=0
+11 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
+12 ;0=clean; Text=error
SET ^TMP("BLRAG",$JOB,BLRI)="T00020ERROR_ID"
+13 ;convert external date to FM format
+14 SET X=$GET(BLRDT)
SET %DT="XT"
DO ^%DT
SET BLRDT=$PIECE(Y,".")
+15 ;error if invalid date passed in
+16 IF $$FR^XLFDT($GET(BLRDT))
DO ERR^BLRAGUT("BLRAG01: Invalid order date.")
QUIT
+17 IF '$GET(BLRSPN)
DO ERR^BLRAGUT("BLRAG01: Invalid Specimen Number.")
QUIT
+18 IF '$GET(BLRUSER)!'$DATA(^VA(200,BLRUSER))
DO ERR^BLRAGUT("BLRAG01: Invalid User.")
QUIT
+19 SET BLRORD=$PIECE(^LRO(69,BLRDT,1,BLRSPN,.1),U,1)
+20 IF '$DATA(^LRO(69,BLRDT,1,BLRSPN))!(BLRORD="")
DO ERR^BLRAGUT("BLRAG01: Invalid Order.")
QUIT
+21 ;;
+22 TSTART
+23 LOCK +^LRO(69,"C",+$GET(BLRORD)):1
+24 ;L +^LRO(69,BLRDT,1,BLRSPN):5
+25 IF '$TEST
TROLLBACK
DO ERR^BLRAGUT("BLRAG01: File being modified elsewhere.")
QUIT
+26 ;if confirmation date is null, default to NOW
+27 IF $GET(BLRDTCF)=""
SET BLRDTCF=$$HTFM^XLFDT($HOROLOG)
+28 IF '$TEST
Begin DoDot:1
+29 ;convert external date to FM format
+30 SET X=BLRDTCF
SET %DT="XT"
DO ^%DT
SET BLRDTCF=Y
+31 ;default to 'NOW' if invalid date passed in
+32 IF $$FR^XLFDT($GET(BLRDTCF))
SET BLRDTCF=$$HTFM^XLFDT($HOROLOG)
End DoDot:1
+33 KILL BLRM
+34 SET BLRM=""
+35 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21400)=BLRUSER
+36 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21401)=BLRDTCF
+37 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21402)=BLRMETH
+38 DO FILE^DIE("","FDA","BLRM")
+39 IF $DATA(BLRM("DIERR"))
DO ERR^BLRAGUT("BLRAG01: "_BLRM("DIERR",1,"TEXT",1))
LOCK -^LRO(69,BLRDT,1,BLRSPN)
TROLLBACK
QUIT
+40 ; L -^LRO(69,BLRDT,1,BLRSPN)
+41 DO UNL69
+42 TCOMMIT
+43 ;;
+44 SET BLRI=BLRI+1
SET ^TMP("BLRAG",$JOB,BLRI)=0_$CHAR(30)
+45 ;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
+46 QUIT
+47 ;
UNL69 ;
+1 LOCK -^LRO(69,"C",+$GET(LRORD))
+2 QUIT
