BLRAG05 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ; 05-Apr-2016 08:52 ; MKK
;;5.2;IHS LABORATORY;**1031,1034,1039**;NOV 01, 1997;Build 38
;
; 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
;
;accessioning GUI (from LROE)
ACC(BLRY,BLRTSTL,BLRCDT,BLRCUSR,BLRPTCM,BLRPTCU,BLRRO,BLRUNC,BLRPAC,BLRBT,BLRAGINS,BLRRLCLA,BLRAOE) ; BLR ACCESSION rpc
; BLRTSTL = (required) The "TEST POINTERS" portion of this data comes
; element 39 in the return from BLR ALL NON-ACCESSIONED.
; List of test pointers with ICD9 pointers for each
; test/procedure being accessioned separated by ^.
; Each ^ piece is made up of these pipe pieces:
; TEST POINTERS | [ICD9_IEN:ICD9_IEN:...] ^ ...
; Test pointers = pointers to the LAB ORDER ENTRY
; file 69 - DATE:SPECIMEN:TEST
; ICD9_IEN - pointer to ICD DIAGNOSIS file 80
; BLRCDT = (required) Specimen Collection Date in external format
; BLRCUSR = (required) Specimen Collector - pointer to NEW PERSON file 200
; BLRPTCM = (optional) Method of patient confirmation - free-text up
; to 80 characters
; BLRPTCU = (optional) user that performed patient confirmation - pointer
; to NEW PERSON file 200
; BLRRO = (optional) 'Continue if Rollover' Flag?
; 0=(default) return with message if Rollover has
; not happened or is in progress
; 1=continue as if user chose to 'continue anyway'
; BLRUNC = (optional) 'Continue if Uncollected' flag?
; 0=(default) return with message if not collected
; 1=continue as if user chose to 'continue anyway'
; BLRPAC = (optional) 'Continue if previously accessioned' flag
; 0=(default) return with message if previously accessioned
; 1=continue as if user chose to 'continue anyway'
; BLRBT = (optional) Billing Type; P=Patient, C=Client, T=Third Party
; BLRAGINS = Required if Billing Type = T;
; INSURANCE_DATA as returned in BLR COLLECTION INFO:
; INS_NAME^INS_IEN^??^COVERAGE_NUMBER^ELIGIBILITY_DATE^EXP_DATE^
; INS_FILE_POINTER^POLICY_HOLDER_NAME^POLICY^...
; BLRRLCLA = reference lab client account number
; REF LAB CLIENT ACCOUNT NUMBER multiple
; in BLR MASTER CONTROL
; BLRAOE = List of Ask At Order Questions separated by pipe |
; Each pipe piece contains the following ^ pieces:
; <question prompt> ^ <result code> ^ <free-text answer> ^ <test name> (test name if from the LABORATORY TEST file 60
;
; RETURNS:
; ERROR_ID ^ POINTER ^ ACCESSION_OR_MESSAGE ^ UID ^ TEST_NAME
; ERROR_ID = 0=clean
; 1=error against a single record
; processing will continue for remaining tests
; 2=general error - nothing filed
; only 1 record will be in the return array
; POINTER = is from the list of passed in pointers in BLRTSTL
; ACCESSION_OR_MESSAGE =
; a return record will exist for each UID passed in.
; POINTER is from the list of passed in pointers in BLRTSTL
; ACCESSION_OR_MESSAGE = Accession # if a clean return of 0
; ACCESSION_OR_MESSAGE = Text string message for an error=1
; TEST_UID = Test Unique ID
; TEST_NAME = Text from the NAME field of LABORATORY TEST file 60
K LRORIFN,LRNATURE,LREND,LRORDRR
; BLREF = Error flag
K BLRAGI,BLRAGRL,BLREF,BLRAGUI,BLRIFNL,BLRJ,BLRLTMP
K BLREF,BLREFF,BLRMESS,BLRTMP,BLRTST,BLRUIDC,BLRUIDF
S BLRTMP=""
S BLRMESS=""
S BLREF=0
S BLREFF=0
S (BLRGUI,BLRAGUI)=1
D ^XBKVAR S X="ERROR^BLRAG05D",@^%ZOSF("TRAP")
S BLRAGI=0
K ^TMP("BLRAG",$J)
S BLRY="^TMP(""BLRAG"","_$J_")"
S ^TMP("BLRAG",$J,0)="T00020ERROR_ID^T00020POINTERS^T00200ACCESSION_OR_MESSAGE"
S BLRTSTL=$G(BLRTSTL)
S BLRCDT=$G(BLRCDT)
S BLRCUSR=$G(BLRCUSR)
S BLRPTCM=$G(BLRPTCM)
S BLRPTCU=$G(BLRPTCU)
S BLRRO=$G(BLRRO)
S BLRUNC=$G(BLRUNC)
S BLRPAC=$G(BLRPAC)
S BLRBT=$G(BLRBT)
S BLRAGINS=$G(BLRAGINS)
S LRLWC="WC"
S XQY0=^DIC(19,$O(^DIC(19,"B","LROE",0)),0)
I '$G(DUZ(2)) D ERR^BLRAG05D("BLRAG05: You must have a site defined. (NO DUZ(2))") Q
S:$G(BLRRLCLA)="" BLRRLCLA=$P($$CLIENT^BLRAG02(),"|",1)
I $G(BLRRLCLA)="" D ERR^BLRAG05D("BLRAG05: You must have a Client Account Number defined.") Q
S (MSCRLCLA,BLRRLCLA)=$G(BLRRLCLA)
I 0,+$G(BLRRO)'=1,$D(^LAB(69.9,1,"RO")),+$H'=+$P(^("RO"),U) D ERR^BLRAG05D("BLRAG05: ROLLOVER "_$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")_" ACCESSIONING SHOULDN'T BE DONE NOW. Continue anyway?") Q
D BLRTSTL^BLRAG05A(.BLRTSTL) ;make sure all tests for the specimens represented in the input are processed
D ^LRPARAM
;
S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="ITMCOL",BLROPT(0)=$P(XQY0,U) ;IHS/OIRM TUC/AAB 2/1/97
;
D ^LRPARAM
;I $G(LREND) S LREND=0 Q
;
L5 ;
NEXT ;from LROE1
;convert external dates to FM format
; collection date
I BLRCDT'="" D
.S X=BLRCDT,%DT="XT" D ^%DT S BLRCDT=Y
.I $$FR^XLFDT($G(BLRCDT)) D ERR^BLRAG05D("BLRAG05: Invalid Collection Date.") S BLREF=1
;
Q:BLREF=1
;S BLRCDT=$P(BLRCDT,".",1)
;verify patient confirmation input
I $$PTC^BLRAGUT() D
.I $G(BLRPTCM)="" D ERR^BLRAG05D("BLRAG05: Patient Confirmation Method is Required.") S BLREF=1 Q
.I $G(BLRPTCU)="" D ERR^BLRAG05D("BLRAG05: Patient Confirmation User is Required.") S BLREF=1 Q
Q:BLREF
;I $D(LROESTAT) D:$P(LRPARAM,U,14) ^LRCAPV I $G(LREND) K LRLONG,LRPANEL Q
S (LRODT,X,DT)=$$DT^XLFDT(),LRODT0=$$FMTE^XLFDT(DT,5)
S X="T-7",%DT="" D ^%DT S LRTM7=+Y
;
;process TESTs
S BLRCNT=0
F BLRJ=1:1:$L(BLRTSTL,U) D
.S BLRRET=""
.S BLREF=0
. ;
. ;
.I 0 D ;'$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,22) D ;not using LEDI
..S BLRDT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
..S BLRSP=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
..; D REFLABS^BLRAGUT3 ; Store Ref Lab Info into 9009026.3 - IHS/MSC/MKK - LR*5.2*1039
..S BLRTST=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",3)
..;S BLRTSN=$$GET1^DIQ(60,$P($G(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,0)),U,1)_",",.01)
..S BLRTSN=$$TESTNAME^BLRAGUT(+$P($G(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,0)),U,1)) ;get test name
..S (BLRTST60,LRTS)=$P($G(^LRO(69,+$G(BLRDT),1,+$G(BLRSP),2,+$G(BLRTST),0)),U,1) ;get test
..S BLRAGRL=+$G(^BLRSITE(DUZ(2),"RL")) ;get reference lab
..S BLRAGRLN=$P($G(^BLRRL(BLRAGRL,0)),U,1)
..I '+$$CODE^BLRRLEVT(BLRAGRL,BLRTST60) S BLRRET="Test "_BLRTSN_" is not defined in the BLR REFERENCE LAB file for reference lab "_BLRAGRLN_"." S BLREF=1
. ;
.D:'BLREF UID($P(BLRTSTL,U,BLRJ),BLRAGINS,.BLREF,.BLRRET)
.S:BLREF BLREFF=1
.S BLRDT=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",1)
.S BLRSP=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",2)
.D REFLABS^BLRAGUT3 ; Store Ref Lab Info into 9009026.3 - IHS/MSC/MKK - LR*5.2*1039
.S BLRTST=$P($P($P(BLRTSTL,U,BLRJ),"|",1),":",3)
.S (BLRUID,LRUID)=$P($G(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,.3)),U,1)
.S BLRTSN=$P($G(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,0)),U,1)
.;S BLRTSN=$$GET1^DIQ(60,BLRTSN_",",.01)
.S BLRTSN=$$TESTNAME^BLRAGUT(+BLRTSN)
.S BLRAGI=BLRAGI+1 S BLRTMP("BLRAG",$J,BLRAGI)=+BLREF_U_$P(BLRTSTL,U,BLRJ)_U_BLRRET_U_BLRUID_U_BLRTSN
.;S BLRAGI=BLRAGI+1 S ^TMP("BLRAG",$J,BLRAGI)=+BLREF_U_$P(BLRTSTL,U,BLRJ)_U_BLRRET_U_BLRUID_U_BLRTSN
.S ^TMP("BLRAG",$J,0)=$S(+BLREFF:"T00020ERROR_ID",1:"T00020CLEAN")_"^T00020POINTERS^T00200ACCESSION_OR_MESSAGE"
.S BLRAGI="" F S BLRAGI=$O(BLRTMP("BLRAG",$J,BLRAGI)) Q:BLRAGI="" D
..S ^TMP("BLRAG",$J,BLRAGI)=BLRTMP("BLRAG",$J,BLRAGI)
;
D:BLRBT="T" STORDIAG ; Store diagnosis codes if Billing Type = "T" -- IHS/MSC/MKK - LR*5.2*1034
;
K BLRTMP
Q
;
UID(BLRPTR,BLRAGINS,BLREF,BLRRET) ; process single UID
; BLRPTR = pointer to the LAB ORDER ENTRY
; file 69 - DATE:SPECIMEN:TEST|INSURANCE_DATA
; BLRDX = Required if Billing Type = T;
; List of ICD9 ien(s) delimited by colon :
; pointer to the ICD DIAGNOSIS file 80.
; BLREF = returned error flag - set to 1 if an error is encountered
; .BLRRET = <accession #> OR <error message>
D BLRRL^BLRAG05D ; IHS/cmi/maw 9/9/2004 added check for ship manifest
K DIC,LRSND,LRSN
S BLRRET=""
S BLRP69=$P(BLRPTR,"|",1)
S BLRAGDX=$P(BLRPTR,"|",2)
S LRODT=$P(BLRP69,":",1)
S (BLRSN,DA)=$P(BLRP69,":",2)
S BLRTST=$P(BLRP69,":",3)
I '$G(^LRO(69,LRODT,1,DA,2,BLRTST,0)) S BLRRET="BLRAG05: Order pointers do not point to a valid Order Number" S BLREF=1 Q
S LRORD=$P(^LRO(69,LRODT,1,DA,.1),U,1)
I '+$G(LRORD) S BLRRET="BLRAG05: UID does not point to a valid Order Number" S BLREF=1 Q
S M9=0
D BLRRL^BLRAG05D ;cmi/anch/maw 8/4/2004 check for shipping manifest from previous order
I '$D(^LRO(69,"C",LRORD)) S BLRRET="BLRAG05: No order exist with that order number." S BLREF=1 Q
;
K BLRPTRF
S (BLRC1,BLRC3,BLRPTRC,BLRPTRF,LRNONE,M9)=0
S LRCHK=1
D LROE2^BLRAG05D
;
S BLRSNOD=$G(^LRO(69,LRODT,1,DA,0))
S:BLRCDT="" BLRCDT=$P(BLRSNOD,U,1)
S:BLRCUSR="" BLRCUSR=$P(BLRSNOD,U,3)
I (BLRCDT="")!(BLRCUSR="") S BLRRET="BLRAG05: "_$S(BLRCDT="":"Collection date/time ",1:"")_$S((BLRCDT="")&(BLRCUSR=""):"and ",1:"")_$S(BLRCUSR="":"Collector ",1:"")_"not defined." S BLREF=1 Q
I LRNONE=2 I 0,$G(BLRPAC)'=1 S BLRRET="BLRAG05: The order has already been"_$S(LRCHK<1:" partially",1:"")_" accessioned." S BLREF=1 Q
I LRNONE=1 S BLRRET="BLRAG05: No order exists with that number." S BLREF=1 Q
I '$$GOT^BLRAG05D(LRORD,LRODT) S BLRRET="BLRAG05: All tests for this order have been canceled." S BLREF=1 Q
;
TSTART
L +^LRO(69,"C",LRORD):1
I '$T S BLRRET="BLRAG05: Someone else is editing this Order" S BLREF=1 TROLLBACK Q
I '$D(^LRO(69,DT,1,0)) S ^LRO(69,DT,0)=DT,^LRO(69,DT,1,0)="^69.01PA^^",^LRO(69,"B",DT,DT)=""
K %DT
S LRSTATUS="C",%DT("B")=""
S LRCDT=BLRCDT
S LRTIM=+LRCDT
S LRUN=$P(LRCDT,U,2) K LRCDT,LRSN
MORE ; I M9>1 K DIR S DIR("A")="Do you have the entire order",DIR(0)="Y" D ^DIR K DIR S:Y=1 M9=0
;I M9>1 I $G(BLRMSP)'=1 S BLRRET="BLRAG05: Do you have the entire order" D UNL69ERR^BLRAG05D S BLREF=1 Q
S (BLREF,LRSND)=0
S YYYLRORD=LRORD
S LRSND=DA
S LRSN(LRSND)=LRSND,LRSN=LRSND
S BLRODT=LRODT
S BLRSND=LRSND
K LRAA D Q15^BLRAG05D K LRSN
D TASK^BLRAG05D,UNL69^BLRAG05D
D:$G(YYYLRORD)'="" ORDNSTOR^BLRAAORU(YYYLRORD) K YYYLRORD ; IHS/OIT/MKK - LR*5.2*1030 - Store Ask-At-Order Questions
S BLRTNOD=$G(^LRO(69,LRODT,1,LRSND,2,BLRTST,0))
S BLRAA=$P(BLRTNOD,U,4)
S BLRAD=$P(BLRTNOD,U,3)
S BLRAN=$P(BLRTNOD,U,5)
S:BLRAA'="" BLRRET=$P($G(^LRO(68,+$G(BLRAA),1,+$G(BLRAD),1,+$G(BLRAN),.2)),U,1)
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
STORDIAG ; EP - Store the Diagnosis code(s)
NEW BLRAGI,BLRJ,BLRTSTL,ERRS,F60DESC,F60IEN,F60PTR,FDA,ICDSTR,ICDIEN,LRODT,LRSN,LRTN,ORDERN,ORDIEN,STORIEN,STR1,STR2,UID
;
S BLRAGI=0
F S BLRAGI=$O(^TMP("BLRAG",$J,BLRAGI)) Q:BLRAGI<1 D
. S STR1=$G(^TMP("BLRAG",$J,BLRAGI))
. Q:+$P(STR1,"^") ; Quit if Error (Piece 1 > 0)
. ;
. S BLRTSTL=$P(STR1,"^",2)
. S ICDSTR=$P(BLRTSTL,"|",2)
. Q:ICDSTR="" ; Quit if no ICD code
. ;
. S STR2=$P(BLRTSTL,"|")
. S LRODT=$P(STR2,":",1),LRSN=$P(STR2,":",2),LRTN=$P(STR2,":",3)
. S ORDERN=$$GET1^DIQ(69.01,LRSN_","_LRODT,9.5,"I")
. Q:ORDERN<1 ; Quit if no Order #
. ;
. D STORF69D^BLRAG05A(LRODT,LRSN,LRTN,ICDSTR) ; IHS/MSC/MKK - LR*5.2*1039
. ;
. S LRDFN=$$GET1^DIQ(69.01,LRSN_","_LRODT,.01,"I")
. S DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
. ;
. S F60PTR=$$GET1^DIQ(69.03,LRTN_","_LRSN_","_LRODT,.01,"I")
. Q:$$REFLAB^BLRUTIL6(DUZ(2),+F60PTR)<1 ; If Test not MAPPED, do NOT put into 9009026.3
. ;
. S X=$$ORD^BLRRLEDI(ORDERN,DFN) ; Create entry in 9009026.3, if necessary
. ;
. S ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
. Q:ORDIEN<1 ; Quit if Order # NOT in 9009026.3
. ;
. S UID=$$GET1^DIQ(69.03,LRTN_","_LRSN_","_LRODT,13)
. ;
. ; Store ICD code(s) and Tests into DIAGNOSIS field
. F ICDCNT=1:1:$L(ICDSTR,":") D
.. K ERRS,FDA
.. S ICDIEN=$P(ICDSTR,":",ICDCNT)
.. ;
.. ; Skip if UNCODED DIAGNOSIS
.. Q:$$GET1^DIQ(80,ICDIEN,.01)=".9999"!($$GET1^DIQ(80,ICDIEN,.01)="ZZZ.999")
.. ;
.. K ERRS,FDA
.. S FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDIEN
.. S:$L(F60PTR) FDA(9009026.31,"?+1,"_ORDIEN_",",1)=F60PTR
.. D UPDATE^DIE(,"FDA",,"ERRS")
Q
; ----- END IHS/MSC/MKK - LR*5.2*1034
BLRAG05 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ; 05-Apr-2016 08:52 ; MKK
+1 ;;5.2;IHS LABORATORY;**1031,1034,1039**;NOV 01, 1997;Build 38
+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 ;accessioning GUI (from LROE)
ACC(BLRY,BLRTSTL,BLRCDT,BLRCUSR,BLRPTCM,BLRPTCU,BLRRO,BLRUNC,BLRPAC,BLRBT,BLRAGINS,BLRRLCLA,BLRAOE) ; BLR ACCESSION rpc
+1 ; BLRTSTL = (required) The "TEST POINTERS" portion of this data comes
+2 ; element 39 in the return from BLR ALL NON-ACCESSIONED.
+3 ; List of test pointers with ICD9 pointers for each
+4 ; test/procedure being accessioned separated by ^.
+5 ; Each ^ piece is made up of these pipe pieces:
+6 ; TEST POINTERS | [ICD9_IEN:ICD9_IEN:...] ^ ...
+7 ; Test pointers = pointers to the LAB ORDER ENTRY
+8 ; file 69 - DATE:SPECIMEN:TEST
+9 ; ICD9_IEN - pointer to ICD DIAGNOSIS file 80
+10 ; BLRCDT = (required) Specimen Collection Date in external format
+11 ; BLRCUSR = (required) Specimen Collector - pointer to NEW PERSON file 200
+12 ; BLRPTCM = (optional) Method of patient confirmation - free-text up
+13 ; to 80 characters
+14 ; BLRPTCU = (optional) user that performed patient confirmation - pointer
+15 ; to NEW PERSON file 200
+16 ; BLRRO = (optional) 'Continue if Rollover' Flag?
+17 ; 0=(default) return with message if Rollover has
+18 ; not happened or is in progress
+19 ; 1=continue as if user chose to 'continue anyway'
+20 ; BLRUNC = (optional) 'Continue if Uncollected' flag?
+21 ; 0=(default) return with message if not collected
+22 ; 1=continue as if user chose to 'continue anyway'
+23 ; BLRPAC = (optional) 'Continue if previously accessioned' flag
+24 ; 0=(default) return with message if previously accessioned
+25 ; 1=continue as if user chose to 'continue anyway'
+26 ; BLRBT = (optional) Billing Type; P=Patient, C=Client, T=Third Party
+27 ; BLRAGINS = Required if Billing Type = T;
+28 ; INSURANCE_DATA as returned in BLR COLLECTION INFO:
+29 ; INS_NAME^INS_IEN^??^COVERAGE_NUMBER^ELIGIBILITY_DATE^EXP_DATE^
+30 ; INS_FILE_POINTER^POLICY_HOLDER_NAME^POLICY^...
+31 ; BLRRLCLA = reference lab client account number
+32 ; REF LAB CLIENT ACCOUNT NUMBER multiple
+33 ; in BLR MASTER CONTROL
+34 ; BLRAOE = List of Ask At Order Questions separated by pipe |
+35 ; Each pipe piece contains the following ^ pieces:
+36 ; <question prompt> ^ <result code> ^ <free-text answer> ^ <test name> (test name if from the LABORATORY TEST file 60
+37 ;
+38 ; RETURNS:
+39 ; ERROR_ID ^ POINTER ^ ACCESSION_OR_MESSAGE ^ UID ^ TEST_NAME
+40 ; ERROR_ID = 0=clean
+41 ; 1=error against a single record
+42 ; processing will continue for remaining tests
+43 ; 2=general error - nothing filed
+44 ; only 1 record will be in the return array
+45 ; POINTER = is from the list of passed in pointers in BLRTSTL
+46 ; ACCESSION_OR_MESSAGE =
+47 ; a return record will exist for each UID passed in.
+48 ; POINTER is from the list of passed in pointers in BLRTSTL
+49 ; ACCESSION_OR_MESSAGE = Accession # if a clean return of 0
+50 ; ACCESSION_OR_MESSAGE = Text string message for an error=1
+51 ; TEST_UID = Test Unique ID
+52 ; TEST_NAME = Text from the NAME field of LABORATORY TEST file 60
+53 KILL LRORIFN,LRNATURE,LREND,LRORDRR
+54 ; BLREF = Error flag
+55 KILL BLRAGI,BLRAGRL,BLREF,BLRAGUI,BLRIFNL,BLRJ,BLRLTMP
+56 KILL BLREF,BLREFF,BLRMESS,BLRTMP,BLRTST,BLRUIDC,BLRUIDF
+57 SET BLRTMP=""
+58 SET BLRMESS=""
+59 SET BLREF=0
+60 SET BLREFF=0
+61 SET (BLRGUI,BLRAGUI)=1
+62 DO ^XBKVAR
SET X="ERROR^BLRAG05D"
SET @^%ZOSF("TRAP")
+63 SET BLRAGI=0
+64 KILL ^TMP("BLRAG",$JOB)
+65 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
+66 SET ^TMP("BLRAG",$JOB,0)="T00020ERROR_ID^T00020POINTERS^T00200ACCESSION_OR_MESSAGE"
+67 SET BLRTSTL=$GET(BLRTSTL)
+68 SET BLRCDT=$GET(BLRCDT)
+69 SET BLRCUSR=$GET(BLRCUSR)
+70 SET BLRPTCM=$GET(BLRPTCM)
+71 SET BLRPTCU=$GET(BLRPTCU)
+72 SET BLRRO=$GET(BLRRO)
+73 SET BLRUNC=$GET(BLRUNC)
+74 SET BLRPAC=$GET(BLRPAC)
+75 SET BLRBT=$GET(BLRBT)
+76 SET BLRAGINS=$GET(BLRAGINS)
+77 SET LRLWC="WC"
+78 SET XQY0=^DIC(19,$ORDER(^DIC(19,"B","LROE",0)),0)
+79 IF '$GET(DUZ(2))
DO ERR^BLRAG05D("BLRAG05: You must have a site defined. (NO DUZ(2))")
QUIT
+80 IF $GET(BLRRLCLA)=""
SET BLRRLCLA=$PIECE($$CLIENT^BLRAG02(),"|",1)
+81 IF $GET(BLRRLCLA)=""
DO ERR^BLRAG05D("BLRAG05: You must have a Client Account Number defined.")
QUIT
+82 SET (MSCRLCLA,BLRRLCLA)=$GET(BLRRLCLA)
+83 IF 0
IF +$GET(BLRRO)'=1
IF $DATA(^LAB(69.9,1,"RO"))
IF +$HOROLOG'=+$PIECE(^("RO"),U)
DO ERR^BLRAG05D("BLRAG05: ROLLOVER "_$SELECT($PIECE(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")_" ACCESSIONING SHOULDN'T BE DONE NOW. Continue anyway?")
QUIT
+84 ;make sure all tests for the specimens represented in the input are processed
DO BLRTSTL^BLRAG05A(.BLRTSTL)
+85 DO ^LRPARAM
+86 ;
+87 ;IHS/OIRM TUC/AAB 2/1/97
IF $GET(BLROPT)=""!($GET(BLROPT(0))'=$PIECE(XQY0,U))
SET BLROPT="ITMCOL"
SET BLROPT(0)=$PIECE(XQY0,U)
+88 ;
+89 DO ^LRPARAM
+90 ;I $G(LREND) S LREND=0 Q
+91 ;
L5 ;
NEXT ;from LROE1
+1 ;convert external dates to FM format
+2 ; collection date
+3 IF BLRCDT'=""
Begin DoDot:1
+4 SET X=BLRCDT
SET %DT="XT"
DO ^%DT
SET BLRCDT=Y
+5 IF $$FR^XLFDT($GET(BLRCDT))
DO ERR^BLRAG05D("BLRAG05: Invalid Collection Date.")
SET BLREF=1
End DoDot:1
+6 ;
+7 IF BLREF=1
QUIT
+8 ;S BLRCDT=$P(BLRCDT,".",1)
+9 ;verify patient confirmation input
+10 IF $$PTC^BLRAGUT()
Begin DoDot:1
+11 IF $GET(BLRPTCM)=""
DO ERR^BLRAG05D("BLRAG05: Patient Confirmation Method is Required.")
SET BLREF=1
QUIT
+12 IF $GET(BLRPTCU)=""
DO ERR^BLRAG05D("BLRAG05: Patient Confirmation User is Required.")
SET BLREF=1
QUIT
End DoDot:1
+13 IF BLREF
QUIT
+14 ;I $D(LROESTAT) D:$P(LRPARAM,U,14) ^LRCAPV I $G(LREND) K LRLONG,LRPANEL Q
+15 SET (LRODT,X,DT)=$$DT^XLFDT()
SET LRODT0=$$FMTE^XLFDT(DT,5)
+16 SET X="T-7"
SET %DT=""
DO ^%DT
SET LRTM7=+Y
+17 ;
+18 ;process TESTs
+19 SET BLRCNT=0
+20 FOR BLRJ=1:1:$LENGTH(BLRTSTL,U)
Begin DoDot:1
+21 SET BLRRET=""
+22 SET BLREF=0
+23 ;
+24 ;
+25 ;'$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,22) D ;not using LEDI
IF 0
Begin DoDot:2
+26 SET BLRDT=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",1)
+27 SET BLRSP=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",2)
+28 ; D REFLABS^BLRAGUT3 ; Store Ref Lab Info into 9009026.3 - IHS/MSC/MKK - LR*5.2*1039
+29 SET BLRTST=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",3)
+30 ;S BLRTSN=$$GET1^DIQ(60,$P($G(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,0)),U,1)_",",.01)
+31 ;get test name
SET BLRTSN=$$TESTNAME^BLRAGUT(+$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,0)),U,1))
+32 ;get test
SET (BLRTST60,LRTS)=$PIECE($GET(^LRO(69,+$GET(BLRDT),1,+$GET(BLRSP),2,+$GET(BLRTST),0)),U,1)
+33 ;get reference lab
SET BLRAGRL=+$GET(^BLRSITE(DUZ(2),"RL"))
+34 SET BLRAGRLN=$PIECE($GET(^BLRRL(BLRAGRL,0)),U,1)
+35 IF '+$$CODE^BLRRLEVT(BLRAGRL,BLRTST60)
SET BLRRET="Test "_BLRTSN_" is not defined in the BLR REFERENCE LAB file for reference lab "_BLRAGRLN_"."
SET BLREF=1
End DoDot:2
+36 ;
+37 IF 'BLREF
DO UID($PIECE(BLRTSTL,U,BLRJ),BLRAGINS,.BLREF,.BLRRET)
+38 IF BLREF
SET BLREFF=1
+39 SET BLRDT=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",1)
+40 SET BLRSP=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",2)
+41 ; Store Ref Lab Info into 9009026.3 - IHS/MSC/MKK - LR*5.2*1039
DO REFLABS^BLRAGUT3
+42 SET BLRTST=$PIECE($PIECE($PIECE(BLRTSTL,U,BLRJ),"|",1),":",3)
+43 SET (BLRUID,LRUID)=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,.3)),U,1)
+44 SET BLRTSN=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,2,BLRTST,0)),U,1)
+45 ;S BLRTSN=$$GET1^DIQ(60,BLRTSN_",",.01)
+46 SET BLRTSN=$$TESTNAME^BLRAGUT(+BLRTSN)
+47 SET BLRAGI=BLRAGI+1
SET BLRTMP("BLRAG",$JOB,BLRAGI)=+BLREF_U_$PIECE(BLRTSTL,U,BLRJ)_U_BLRRET_U_BLRUID_U_BLRTSN
+48 ;S BLRAGI=BLRAGI+1 S ^TMP("BLRAG",$J,BLRAGI)=+BLREF_U_$P(BLRTSTL,U,BLRJ)_U_BLRRET_U_BLRUID_U_BLRTSN
+49 SET ^TMP("BLRAG",$JOB,0)=$SELECT(+BLREFF:"T00020ERROR_ID",1:"T00020CLEAN")_"^T00020POINTERS^T00200ACCESSION_OR_MESSAGE"
+50 SET BLRAGI=""
FOR
SET BLRAGI=$ORDER(BLRTMP("BLRAG",$JOB,BLRAGI))
IF BLRAGI=""
QUIT
Begin DoDot:2
+51 SET ^TMP("BLRAG",$JOB,BLRAGI)=BLRTMP("BLRAG",$JOB,BLRAGI)
End DoDot:2
End DoDot:1
+52 ;
+53 ; Store diagnosis codes if Billing Type = "T" -- IHS/MSC/MKK - LR*5.2*1034
IF BLRBT="T"
DO STORDIAG
+54 ;
+55 KILL BLRTMP
+56 QUIT
+57 ;
UID(BLRPTR,BLRAGINS,BLREF,BLRRET) ; process single UID
+1 ; BLRPTR = pointer to the LAB ORDER ENTRY
+2 ; file 69 - DATE:SPECIMEN:TEST|INSURANCE_DATA
+3 ; BLRDX = Required if Billing Type = T;
+4 ; List of ICD9 ien(s) delimited by colon :
+5 ; pointer to the ICD DIAGNOSIS file 80.
+6 ; BLREF = returned error flag - set to 1 if an error is encountered
+7 ; .BLRRET = <accession #> OR <error message>
+8 ; IHS/cmi/maw 9/9/2004 added check for ship manifest
DO BLRRL^BLRAG05D
+9 KILL DIC,LRSND,LRSN
+10 SET BLRRET=""
+11 SET BLRP69=$PIECE(BLRPTR,"|",1)
+12 SET BLRAGDX=$PIECE(BLRPTR,"|",2)
+13 SET LRODT=$PIECE(BLRP69,":",1)
+14 SET (BLRSN,DA)=$PIECE(BLRP69,":",2)
+15 SET BLRTST=$PIECE(BLRP69,":",3)
+16 IF '$GET(^LRO(69,LRODT,1,DA,2,BLRTST,0))
SET BLRRET="BLRAG05: Order pointers do not point to a valid Order Number"
SET BLREF=1
QUIT
+17 SET LRORD=$PIECE(^LRO(69,LRODT,1,DA,.1),U,1)
+18 IF '+$GET(LRORD)
SET BLRRET="BLRAG05: UID does not point to a valid Order Number"
SET BLREF=1
QUIT
+19 SET M9=0
+20 ;cmi/anch/maw 8/4/2004 check for shipping manifest from previous order
DO BLRRL^BLRAG05D
+21 IF '$DATA(^LRO(69,"C",LRORD))
SET BLRRET="BLRAG05: No order exist with that order number."
SET BLREF=1
QUIT
+22 ;
+23 KILL BLRPTRF
+24 SET (BLRC1,BLRC3,BLRPTRC,BLRPTRF,LRNONE,M9)=0
+25 SET LRCHK=1
+26 DO LROE2^BLRAG05D
+27 ;
+28 SET BLRSNOD=$GET(^LRO(69,LRODT,1,DA,0))
+29 IF BLRCDT=""
SET BLRCDT=$PIECE(BLRSNOD,U,1)
+30 IF BLRCUSR=""
SET BLRCUSR=$PIECE(BLRSNOD,U,3)
+31 IF (BLRCDT="")!(BLRCUSR="")
SET BLRRET="BLRAG05: "_$SELECT(BLRCDT="":"Collection date/time ",1:"")_$SELECT((BLRCDT="")&(BLRCUSR=""):"and ",1:"")_$SELECT(BLRCUSR="":"Collector ",1:"")_"not defined."
SET BLREF=1
QUIT
+32 IF LRNONE=2
IF 0
IF $GET(BLRPAC)'=1
SET BLRRET="BLRAG05: The order has already been"_$SELECT(LRCHK<1:" partially",1:"")_" accessioned."
SET BLREF=1
QUIT
+33 IF LRNONE=1
SET BLRRET="BLRAG05: No order exists with that number."
SET BLREF=1
QUIT
+34 IF '$$GOT^BLRAG05D(LRORD,LRODT)
SET BLRRET="BLRAG05: All tests for this order have been canceled."
SET BLREF=1
QUIT
+35 ;
+36 TSTART
+37 LOCK +^LRO(69,"C",LRORD):1
+38 IF '$TEST
SET BLRRET="BLRAG05: Someone else is editing this Order"
SET BLREF=1
TROLLBACK
QUIT
+39 IF '$DATA(^LRO(69,DT,1,0))
SET ^LRO(69,DT,0)=DT
SET ^LRO(69,DT,1,0)="^69.01PA^^"
SET ^LRO(69,"B",DT,DT)=""
+40 KILL %DT
+41 SET LRSTATUS="C"
SET %DT("B")=""
+42 SET LRCDT=BLRCDT
+43 SET LRTIM=+LRCDT
+44 SET LRUN=$PIECE(LRCDT,U,2)
KILL LRCDT,LRSN
MORE ; I M9>1 K DIR S DIR("A")="Do you have the entire order",DIR(0)="Y" D ^DIR K DIR S:Y=1 M9=0
+1 ;I M9>1 I $G(BLRMSP)'=1 S BLRRET="BLRAG05: Do you have the entire order" D UNL69ERR^BLRAG05D S BLREF=1 Q
+2 SET (BLREF,LRSND)=0
+3 SET YYYLRORD=LRORD
+4 SET LRSND=DA
+5 SET LRSN(LRSND)=LRSND
SET LRSN=LRSND
+6 SET BLRODT=LRODT
+7 SET BLRSND=LRSND
+8 KILL LRAA
DO Q15^BLRAG05D
KILL LRSN
+9 DO TASK^BLRAG05D
DO UNL69^BLRAG05D
+10 ; IHS/OIT/MKK - LR*5.2*1030 - Store Ask-At-Order Questions
IF $GET(YYYLRORD)'=""
DO ORDNSTOR^BLRAAORU(YYYLRORD)
KILL YYYLRORD
+11 SET BLRTNOD=$GET(^LRO(69,LRODT,1,LRSND,2,BLRTST,0))
+12 SET BLRAA=$PIECE(BLRTNOD,U,4)
+13 SET BLRAD=$PIECE(BLRTNOD,U,3)
+14 SET BLRAN=$PIECE(BLRTNOD,U,5)
+15 IF BLRAA'=""
SET BLRRET=$PIECE($GET(^LRO(68,+$GET(BLRAA),1,+$GET(BLRAD),1,+$GET(BLRAN),.2)),U,1)
+16 QUIT
+17 ;
+18 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
STORDIAG ; EP - Store the Diagnosis code(s)
+1 NEW BLRAGI,BLRJ,BLRTSTL,ERRS,F60DESC,F60IEN,F60PTR,FDA,ICDSTR,ICDIEN,LRODT,LRSN,LRTN,ORDERN,ORDIEN,STORIEN,STR1,STR2,UID
+2 ;
+3 SET BLRAGI=0
+4 FOR
SET BLRAGI=$ORDER(^TMP("BLRAG",$JOB,BLRAGI))
IF BLRAGI<1
QUIT
Begin DoDot:1
+5 SET STR1=$GET(^TMP("BLRAG",$JOB,BLRAGI))
+6 ; Quit if Error (Piece 1 > 0)
IF +$PIECE(STR1,"^")
QUIT
+7 ;
+8 SET BLRTSTL=$PIECE(STR1,"^",2)
+9 SET ICDSTR=$PIECE(BLRTSTL,"|",2)
+10 ; Quit if no ICD code
IF ICDSTR=""
QUIT
+11 ;
+12 SET STR2=$PIECE(BLRTSTL,"|")
+13 SET LRODT=$PIECE(STR2,":",1)
SET LRSN=$PIECE(STR2,":",2)
SET LRTN=$PIECE(STR2,":",3)
+14 SET ORDERN=$$GET1^DIQ(69.01,LRSN_","_LRODT,9.5,"I")
+15 ; Quit if no Order #
IF ORDERN<1
QUIT
+16 ;
+17 ; IHS/MSC/MKK - LR*5.2*1039
DO STORF69D^BLRAG05A(LRODT,LRSN,LRTN,ICDSTR)
+18 ;
+19 SET LRDFN=$$GET1^DIQ(69.01,LRSN_","_LRODT,.01,"I")
+20 SET DFN=$$GET1^DIQ(63,LRDFN,.03,"I")
+21 ;
+22 SET F60PTR=$$GET1^DIQ(69.03,LRTN_","_LRSN_","_LRODT,.01,"I")
+23 ; If Test not MAPPED, do NOT put into 9009026.3
IF $$REFLAB^BLRUTIL6(DUZ(2),+F60PTR)<1
QUIT
+24 ;
+25 ; Create entry in 9009026.3, if necessary
SET X=$$ORD^BLRRLEDI(ORDERN,DFN)
+26 ;
+27 SET ORDIEN=$$FIND1^DIC(9009026.3,,,ORDERN)
+28 ; Quit if Order # NOT in 9009026.3
IF ORDIEN<1
QUIT
+29 ;
+30 SET UID=$$GET1^DIQ(69.03,LRTN_","_LRSN_","_LRODT,13)
+31 ;
+32 ; Store ICD code(s) and Tests into DIAGNOSIS field
+33 FOR ICDCNT=1:1:$LENGTH(ICDSTR,":")
Begin DoDot:2
+34 KILL ERRS,FDA
+35 SET ICDIEN=$PIECE(ICDSTR,":",ICDCNT)
+36 ;
+37 ; Skip if UNCODED DIAGNOSIS
+38 IF $$GET1^DIQ(80,ICDIEN,.01)=".9999"!($$GET1^DIQ(80,ICDIEN,.01)="ZZZ.999")
QUIT
+39 ;
+40 KILL ERRS,FDA
+41 SET FDA(9009026.31,"?+1,"_ORDIEN_",",.01)=ICDIEN
+42 IF $LENGTH(F60PTR)
SET FDA(9009026.31,"?+1,"_ORDIEN_",",1)=F60PTR
+43 DO UPDATE^DIE(,"FDA",,"ERRS")
End DoDot:2
End DoDot:1
+44 QUIT
+45 ; ----- END IHS/MSC/MKK - LR*5.2*1034
