- 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
