BLRPOC ;IHS/MSC/PLS - EHR POC Component support ; 13-Oct-2017 14:04 ; MKK
;;5.2;IHS LABORATORY;**1025,1026,1027,1030,1031,1038,1041**;NOV 01, 1997;Build 23
;
Q
;
POCTSTS(DATA,DIV,LOC,USR,DFN) ; EP
S DIV=$G(DIV,$G(DUZ(2))) ; default to user's current division
N LP,TST,CNT
S (CNT,LP)=0 F S LP=$O(^BLRPOC(90479,DIV,1,LP)) Q:'LP D
.; If enforce restrict to location is 'yes', check to see if it passes the restriction
.I $$GET1^DIQ(90479,DIV,.02,"I"),'$$LOCMATCH(LP,+$G(DIV),+$G(LOC)) Q
.; If enforce restrict to user is 'yes', check to see if it passes the restriction
.I $$GET1^DIQ(90479,DIV,.03,"I"),'$$USRMATCH(LP,+$G(DIV),+$G(USR)) Q
.S CNT=CNT+1
.;S TST=+^BLRPOC(90479,DIV,1,LP,0)
.S TST=+$G(^BLRPOC(90479,DIV,1,LP,0)) ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
.I '$$CHKTST(TST) Q ; Check test for any issues.
.S DATA(CNT,"tst")=$$GETTST(TST,DFN)
Q
;
GETTST(TST,DFN) ;EP-
N TSTNM,COL,COLNM,SPEC,REFL,REFH,UNITS,CHKVAL
S Y=DFN D ^AUPNPAT
I +$$GET^XPAR("PKG","BLR AGE DETAIL",1,"Q") S AGE=$$AGE^AUPNPAT3(DFN,$$DT^XLFDT,"M") ; IHS/MSC/MKK - LR*5.2*1038
S TSTNM=$$GET1^DIQ(60,TST,.01)
S COL=$$UNQCOL(TST)
S COLNM=$$GET1^DIQ(62,COL,.01,"I")
S SPEC=$$GET1^DIQ(62,COL,2,"I")
S LRSPEC=$$GET1^DIQ(62,COL,2,"I") ; IHS/MSC/MKK - LR*5.2*1031
S REFL=$$GET1^DIQ(60.01,SPEC_","_TST_",",1,"I")
S REFL=$$REFRES(REFL)
S REFH=$$GET1^DIQ(60.01,SPEC_","_TST_",",2,"I")
S REFH=$$REFRES(REFH)
S UNITS=$$GET1^DIQ(60.01,SPEC_","_TST_",",6,"I")
Q TST_U_TSTNM_U_$$ISPANEL(TST)_U_COL_U_COLNM_U_REFL_U_REFH_U_UNITS
;
UNQCOL(IEN) ;EP - RETURN FIRST COLLECTION SAMPLE
N SMP
S SMP=+$O(^LAB(60,IEN,3,0))
; Q +^LAB(60,IEN,3,SMP,0)
Q +$G(^LAB(60,IEN,3,SMP,0)) ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
;
ISPANEL(IEN) ;EP- Returns boolean flag indicating if test is a panel test
Q ('+$G(^LAB(60,IEN,.2))&+$O(^LAB(60,IEN,2,0)))
;
SAVE(DATA,DFN,ARY) ;EP-
D SAVER^BLRPOC2 ; IHS/OIT/MKK - LR*5.2*1030
Q
;
PNLTSTS(DATA,TST,DFN) ;EP - Return "tst" list of tests within a panel. If another panel
; is within a panel, those tests will not be returned.
; Loop thru the LAB TEST INCLUDED IN PANEL field of File 60 and call $$GETTST to collect the test information
N LP,CNT,PTST
S (CNT,LP)=0 F S LP=$O(^LAB(60,TST,2,LP)) Q:'LP D
.S CNT=CNT+1
.;S PTST=+^LAB(60,TST,2,LP,0)
.S PTST=+$G(^LAB(60,TST,2,LP,0)) ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
.S DATA(CNT,"tst")=$$GETTST(PTST,DFN)
Q
; Returns validated status
; Input: TSTIEN - Laboratory Test Pointer to File 60
; COLIEN - Collection Sample Pointer to File 62
; RESULT - Result value to be validated
; Output: DATA - 0=not valid; 1=valid
VALIDATE(DATA,TSTIEN,COLIEN,RES,DFN) ; EP
NEW LRFLOC,LRFIEN,LRDAT,LRNG2,LRNG3,LRNG4,LRNG5,LRFLG,LRERR,LRVER
NEW AGE,SSN,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,SEX,DEFSPEC
NEW DUPPER
M DUPPER=DATA
S Y=DFN D ^AUPNPAT
I +$$GET^XPAR("PKG","BLR AGE DETAIL",1,"Q") S AGE=$$AGE^AUPNPAT3(DFN,$$DT^XLFDT,"M") ; IHS/MSC/MKK - LR*5.2*1038
S LRFLG=""
S LRFLOC=$$GET1^DIQ(60,TSTIEN,5,"E")
I LRFLOC="" S DATA=0,DATA(1)="Test information not found." Q
S LRFIEN=$P(LRFLOC,";",2)
I RES["?" D Q
.D HELP^DIE(63.04,,LRFIEN,"A","LRVER")
.S DATA(0)=0 D VALERR(.DATA,.LRVER)
D CHK^DIE(63.04,LRFIEN,"HE",RES,.LRDAT,"LRERR")
;I LRDAT="^" S DATA=0_U_$G(LRERR("DIERR",1,"TEXT",1)) Q
I LRDAT="^" S DATA(0)=0 D VALERR(.DATA,.LRERR) Q
S DEFSPEC=$$GET1^DIQ(62,COLIEN,2,"I")
I '$G(DEFSPEC) S DATA(0)=0,DATA(1)="No default specimen for IEN number "_COLIEN_" in the Collection Sample file. A default specimen must be defined for this entry to use Point of Care lab entry." Q
S LRSPEC0=$G(^LAB(60,TSTIEN,1,$$GET1^DIQ(62,COLIEN,2,"I"),0))
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 -- Take into account RESULT might not be numeric
NEW OLDRES
S OLDRES=RES
S:$E(RES)=">" RES=$P(RES,">",2)+1
S:$E(RES)="<" RES=$P(RES,"<",2)-1
;
S LRFLG="" ; Initialize flag every time
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041 -- Qualitative flag
NEW QUALFLAG
S QUALFLAG=0
D
. NEW LRDL,LRSB,LRTS,X
. S LRDL=LRDAT
. S LRSB=LRFIEN
. S LRTS=$O(^LAB(60,"C","CH;"_LRSB_";1",0))
. I $L(LRDL),$L(LRSB),$L(LRSPEC),$L(LRTS) D
.. S X=$$QUALCHEK^BLRQUALU()
.. I $G(LRFLG)="A*" S QUALFLAG=1
I QUALFLAG G VRET Q
; ----- END IHS/MSC/MKK - LR*5.2*1041
;
S LRNG4=$P(LRSPEC0,U,4),LRNG4=$$REFRES(LRNG4)
S LRNG5=$P(LRSPEC0,U,5),LRNG5=$$REFRES(LRNG5)
S LRNG2=$P(LRSPEC0,U,2),LRNG2=$$REFRES(LRNG2)
S LRNG3=$P(LRSPEC0,U,3),LRNG3=$$REFRES(LRNG3)
;
I $L(LRNG4)&(RES<LRNG4) S LRFLG="L*" G VRET Q
I $L(LRNG5)&(RES>LRNG5) S LRFLG="H*" G VRET Q
I $L(LRNG2)&(RES<LRNG2) S LRFLG="L" G VRET Q
I $L(LRNG3)&(RES>LRNG3) S LRFLG="H"
;
VRET ; S DATA(0)=1_U_$S(LRFLG="H":"1:H",LRFLG="H*":"2:H",LRFLG="L":"1:L",LRFLG="L*":"2:L",1:0)_U_$G(LRDAT(0))_U_$G(LRDAT) Q
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
S RES=OLDRES ; IHS/MSC/MKK - LR*5.2*1031 - Reset RESULT to original value
; S DATA=1,DATA(0)=1_U_$S(LRFLG="H":"1:H",LRFLG="H*":"2:H",LRFLG="L":"1:L",LRFLG="L*":"2:L",1:0)_U_$G(LRDAT(0))_U_$G(LRDAT)
; ----- END IHS/OIT/MKK - LR*5.2*1030
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
S DATA=1,DATA(0)=1_U_$S(LRFLG="A*":"1:A",LRFLG="H":"1:H",LRFLG="H*":"2:H",LRFLG="L":"1:L",LRFLG="L*":"2:L",1:0)_U_$G(LRDAT(0))_U_$G(LRDAT)
; ----- END IHS/MSC/MKK - LR*5.2*1041
Q
VALERR(DATA,ERRARY) ; EP
N HLP
S HLP=0 F S HLP=$O(ERRARY("DIHELP",HLP)) Q:'HLP D
.S DATA(HLP)=$G(ERRARY("DIHELP",HLP))
Q
; Return LRDFN for given patient
GUINIT(DATA,USR) ; EP
S DATA=$$GET1^DIQ(200,USR,1,"E")
Q
GETPAT(DFN) ;EP
N LRDFN
S LRDFN=$G(^DPT(DFN,"LR"))
S:'LRDFN LRDFN=$$NEWPAT(DFN)
Q +LRDFN
; Create LRDFN for given patient
NEWPAT(DFN) ;EP
N LRDPF,X,LRDFN,LRDPAF
S LRDPF="2^DPT(",X="^"_$P(LRDPF,"^",2)_DFN_",""LR"")"
S LRDFN=$O(^LR("A"),-1) I 'LRDFN S LRDFN=1
L +^LR(0):99
D E2^LRDPA
L -^LR(0)
S:LRDFN<1 LRDFN=0
Q LRDFN
;
; Resolve the reference range in the event that the range is a $S statement.
REFRES(VAL) ; EP
N CHKVAL,REFVAL
S REFVAL=""
S X="S CHKVAL="_VAL D ^DIM
I $G(X)'="" D
.X X S REFVAL=CHKVAL
K X
Q REFVAL
;
URGLST(DATA) ; EP
N IEN,TST,CNT
S (TST,CNT)=0 F S TST=$O(^LAB(62.05,"B",TST)) Q:TST="" D
.S IEN=0 F S IEN=$O(^LAB(62.05,"B",TST,IEN)) Q:'IEN D
..S CNT=CNT+1
..S DATA(CNT)=IEN_U_TST
Q
;
NOOLST(DATA) ; EP
N IEN,ORD,CNT,DEF
; Get the default nature of order from file 69.9 (field 150.1)
S DEF=$$GET1^DIQ(69.9,1,150.1,"I")
I 'DEF S DEF=$O(^ORD(100.02,"B","WRITTEN",""))
S (ORD,CNT)=0 F S ORD=$O(^ORD(100.02,"B",ORD)) Q:ORD="" D
.S IEN=0 F S IEN=$O(^ORD(100.02,"B",ORD,IEN)) Q:'IEN D
..; ----- BEGIN IHS/MSC/BF - IHS Lab Patch 1026
..; USE SCREEN LOGIC AS IT IS USED IN THE LRFAST OPTION.
..I '$P(^ORD(100.02,IEN,0),"^",4),'$P(^ORD(100.02,IEN,0),"^",3),('$P(^ORD(100.02,IEN,0),"^",6)),"XB"[$P(^ORD(100.02,IEN,0),"^",5) D
...S CNT=CNT+1
...S DATA(CNT)=IEN_U_ORD_U_$S(IEN=DEF:1,1:"")
..; ----- END IHS/MSC/BF - IHS Lab Patch 1026
Q
LABDESC(DATA,DIV) ; EP
N CC,CNT,COMIEN
S DIV=$G(DIV,$G(DUZ(2))) ; default to user's current division
S (CC,CNT)=0 F S CC=$O(^BLRPOC(90479,DIV,4,CC)) Q:'CC D
.S CNT=CNT+1
.;S COMIEN=+^BLRPOC(90479,DIV,4,CC,0)
.S COMIEN=+$G(^BLRPOC(90479,DIV,4,CC,0)) ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
.S DATA(CNT)=$$GETCOM(COMIEN)
Q
GETCOM(COMIEN) ; EP
N LDNAME,LDEXP
S LDNAME=$$GET1^DIQ(62.5,COMIEN,.01,"E")
S LDEXP=$$GET1^DIQ(62.5,COMIEN,1,"E")
Q COMIEN_U_LDNAME_U_LDEXP
;
BLDARY(LOC,SPEC0,RES,FLG) ; EP
S LRARY(LOC)=$S(RES="":"pending",1:RES)
I RES="pending" Q
I $D(FLG) S $P(LRARY(LOC),U,2)=FLG
S $P(LRARY(LOC),U,3)="!!!"
S $P(LRARY(LOC),U,4)=$G(DUZ)
I $D(SPEC0) S $P(LRARY(LOC),U,5)=SPEC0
S $P(LRARY(LOC),U,6)=$$NOW^XLFDT ; IHS/MSC/MKK - LR*5.2*1039 -- LEDI IV Change
S $P(LRARY(LOC),U,9)=DUZ(2)
Q
;
CHKTST(TEST) ; EP
N LRLOOP,LRITMIEN,PNLINPNL,SAMP,COLNM,SPEC,BADPTR
NEW SUBNOACC,SUBNOCOL ; IHS/OIT/MKK - LR*5.2*1026
;
I $P(^LAB(60,TEST,0),U,3)'="B" Q 0 ; If type is not set to "Both", do not allow entry
I $P(^LAB(60,TEST,0),U,4)'="CH" Q 0 ; If the subscript is not "CH" do not allow entry
I '$D(^LAB(60,TEST,8,$G(DUZ(2)))) Q 0 ; If no accession area is defined for this test at this site, do not process
I '+$O(^LAB(60,TEST,3,0)) Q 0 ; If there is no collection sample, do not return entry. -- LR*5.2*.1026
S (SUBNOACC,SUBNOCOL)=0 ; COSMIC test's ATOMIC subtests Accession number &/or a Collection Sample Flags
;
; If the test is a panel, and has a panel within that panel, do not allow entry
S (PNLINPNL,BADPTR)=0
I $$ISPANEL(TEST) D
.; S LRLOOP=0 F S LRLOOP=$O(^LAB(60,TEST,2,LRLOOP)) Q:'LRLOOP!(PNLINPNL)!(BADPTR) D
.S LRLOOP=0 F S LRLOOP=$O(^LAB(60,TEST,2,LRLOOP)) Q:'LRLOOP!(PNLINPNL)!(BADPTR)!(SUBNOACC)!(SUBNOCOL) D ; IHS Lab Patch 1026 -- Check the subtests as well
..S LRITMIEN=$$GET1^DIQ(60.02,LRLOOP_","_TEST,.01,"I")
..I $$ISPANEL(LRITMIEN) S PNLINPNL=1 Q
..I $$BADPTR(LRITMIEN) S BADPTR=1 Q
.. I '$D(^LAB(60,LRITMIEN,8,$G(DUZ(2)))) S SUBNOACC=1 Q ; IHS/OIT/MKK - LR*5.2*1026 -- Check the subtests as well
.. I '+$O(^LAB(60,LRITMIEN,3,0)) S SUBNOCOL=1 Q
; I PNLINPNL!(BADPTR) Q 0
I PNLINPNL!(BADPTR)!(SUBNOACC)!(SUBNOCOL) Q 0 ; IHS/OIT/MKK - LR*5.2*1026
;
Q 1
;
;Check to see if this test has a bad pointer to the ^DD executable logic.
BADPTR(IEN) ; EP
; I '$D(^DD(63.04,$P($$GET1^DIQ(60,IEN,5,"E"),";",2))) Q 1 ; IHS/MSC/BF - IHS Lab Patch 1026 -- Make sure $P returns numeric
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027 - Valid check for existance of invalid IEN
NEW WOT
S WOT=+$P($$GET1^DIQ(60,IEN,5,"E"),";",2)
Q:WOT<1 1
; ----- END IHS/OIT/MKK - LR*5.2*1027
I '$D(^DD(63.04,$P($$GET1^DIQ(60,IEN,5,"E"),";",2))) Q 1 ; IHS/MSC/BF - IHS Lab Patch 1026 -- Make sure $P returns numeric
;
Q 0 ; IHS/MSC/BF - IHS Lab Patch 1026
;
; Check to see if the supplied location is valid for this test
; INPUT LIEN - Lab test ien from the BLR BEHO LAB POC file
; DIV - Division
; LOC - Location passed in from the LAB POC component
LOCMATCH(LIEN,DIV,LOC) ; EP
I $D(^BLRPOC(90479,DIV,1,LIEN,3,"B",LOC))!('$D(^BLRPOC(90479,DIV,1,LIEN,3,"B"))) Q 1
Q 0
;
;Check to see if the supplied user is valid for the test
; INPUT LIEN - Lab test ien from the BLR BEHO LAB POC file
; DIV - Divsion
; USR - User number from file 200
USRMATCH(LIEN,DIV,USR) ; EP
I $D(^BLRPOC(90479,DIV,1,LIEN,4,"B",USR))!('$D(^BLRPOC(90479,DIV,1,LIEN,4,"B"))) Q 1
Q 0
;
; Clean up environment
CVARS ; EP
K ARY,BLRDH,BLRGUI,BLRLOG,BLRPCC,BLRSTOP,BLRQSITE,BLRSTOP,BPCACC,BPCCOM,LRAA,LRARY,LRBLOOD,LRCCOM,LRAHEAD
K LRDFN,LRDPF,LRDTO,LREAL,LREND,LRGCOM,LRI,LRIDIV,LRJ,LRLABKY,LRLBLBP,LRLLOC,LRLWC,LRNATURE,LRORDR,LRORDTIM
K LRORDTST,LROUTINE,LRPARAM,LRPCEVSO,LRPLASMA,LRPOVREQ,LRPR,LRSAMP,LRSERUM,LRSPEC,LRSS,LRUNKNOW,LRURG
K LRURINE,LRUSI,LRVF,LRVIDO,LRVIDOF,LRWLO,LRWLC,RET
Q
BLRPOC ;IHS/MSC/PLS - EHR POC Component support ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;IHS LABORATORY;**1025,1026,1027,1030,1031,1038,1041**;NOV 01, 1997;Build 23
+2 ;
+3 QUIT
+4 ;
POCTSTS(DATA,DIV,LOC,USR,DFN) ; EP
+1 ; default to user's current division
SET DIV=$GET(DIV,$GET(DUZ(2)))
+2 NEW LP,TST,CNT
+3 SET (CNT,LP)=0
FOR
SET LP=$ORDER(^BLRPOC(90479,DIV,1,LP))
IF 'LP
QUIT
Begin DoDot:1
+4 ; If enforce restrict to location is 'yes', check to see if it passes the restriction
+5 IF $$GET1^DIQ(90479,DIV,.02,"I")
IF '$$LOCMATCH(LP,+$GET(DIV),+$GET(LOC))
QUIT
+6 ; If enforce restrict to user is 'yes', check to see if it passes the restriction
+7 IF $$GET1^DIQ(90479,DIV,.03,"I")
IF '$$USRMATCH(LP,+$GET(DIV),+$GET(USR))
QUIT
+8 SET CNT=CNT+1
+9 ;S TST=+^BLRPOC(90479,DIV,1,LP,0)
+10 ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
SET TST=+$GET(^BLRPOC(90479,DIV,1,LP,0))
+11 ; Check test for any issues.
IF '$$CHKTST(TST)
QUIT
+12 SET DATA(CNT,"tst")=$$GETTST(TST,DFN)
End DoDot:1
+13 QUIT
+14 ;
GETTST(TST,DFN) ;EP-
+1 NEW TSTNM,COL,COLNM,SPEC,REFL,REFH,UNITS,CHKVAL
+2 SET Y=DFN
DO ^AUPNPAT
+3 ; IHS/MSC/MKK - LR*5.2*1038
IF +$$GET^XPAR("PKG","BLR AGE DETAIL",1,"Q")
SET AGE=$$AGE^AUPNPAT3(DFN,$$DT^XLFDT,"M")
+4 SET TSTNM=$$GET1^DIQ(60,TST,.01)
+5 SET COL=$$UNQCOL(TST)
+6 SET COLNM=$$GET1^DIQ(62,COL,.01,"I")
+7 SET SPEC=$$GET1^DIQ(62,COL,2,"I")
+8 ; IHS/MSC/MKK - LR*5.2*1031
SET LRSPEC=$$GET1^DIQ(62,COL,2,"I")
+9 SET REFL=$$GET1^DIQ(60.01,SPEC_","_TST_",",1,"I")
+10 SET REFL=$$REFRES(REFL)
+11 SET REFH=$$GET1^DIQ(60.01,SPEC_","_TST_",",2,"I")
+12 SET REFH=$$REFRES(REFH)
+13 SET UNITS=$$GET1^DIQ(60.01,SPEC_","_TST_",",6,"I")
+14 QUIT TST_U_TSTNM_U_$$ISPANEL(TST)_U_COL_U_COLNM_U_REFL_U_REFH_U_UNITS
+15 ;
UNQCOL(IEN) ;EP - RETURN FIRST COLLECTION SAMPLE
+1 NEW SMP
+2 SET SMP=+$ORDER(^LAB(60,IEN,3,0))
+3 ; Q +^LAB(60,IEN,3,SMP,0)
+4 ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
QUIT +$GET(^LAB(60,IEN,3,SMP,0))
+5 ;
ISPANEL(IEN) ;EP- Returns boolean flag indicating if test is a panel test
+1 QUIT ('+$GET(^LAB(60,IEN,.2))&+$ORDER(^LAB(60,IEN,2,0)))
+2 ;
SAVE(DATA,DFN,ARY) ;EP-
+1 ; IHS/OIT/MKK - LR*5.2*1030
DO SAVER^BLRPOC2
+2 QUIT
+3 ;
PNLTSTS(DATA,TST,DFN) ;EP - Return "tst" list of tests within a panel. If another panel
+1 ; is within a panel, those tests will not be returned.
+2 ; Loop thru the LAB TEST INCLUDED IN PANEL field of File 60 and call $$GETTST to collect the test information
+3 NEW LP,CNT,PTST
+4 SET (CNT,LP)=0
FOR
SET LP=$ORDER(^LAB(60,TST,2,LP))
IF 'LP
QUIT
Begin DoDot:1
+5 SET CNT=CNT+1
+6 ;S PTST=+^LAB(60,TST,2,LP,0)
+7 ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
SET PTST=+$GET(^LAB(60,TST,2,LP,0))
+8 SET DATA(CNT,"tst")=$$GETTST(PTST,DFN)
End DoDot:1
+9 QUIT
+10 ; Returns validated status
+11 ; Input: TSTIEN - Laboratory Test Pointer to File 60
+12 ; COLIEN - Collection Sample Pointer to File 62
+13 ; RESULT - Result value to be validated
+14 ; Output: DATA - 0=not valid; 1=valid
VALIDATE(DATA,TSTIEN,COLIEN,RES,DFN) ; EP
+1 NEW LRFLOC,LRFIEN,LRDAT,LRNG2,LRNG3,LRNG4,LRNG5,LRFLG,LRERR,LRVER
+2 NEW AGE,SSN,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,SEX,DEFSPEC
+3 NEW DUPPER
+4 MERGE DUPPER=DATA
+5 SET Y=DFN
DO ^AUPNPAT
+6 ; IHS/MSC/MKK - LR*5.2*1038
IF +$$GET^XPAR("PKG","BLR AGE DETAIL",1,"Q")
SET AGE=$$AGE^AUPNPAT3(DFN,$$DT^XLFDT,"M")
+7 SET LRFLG=""
+8 SET LRFLOC=$$GET1^DIQ(60,TSTIEN,5,"E")
+9 IF LRFLOC=""
SET DATA=0
SET DATA(1)="Test information not found."
QUIT
+10 SET LRFIEN=$PIECE(LRFLOC,";",2)
+11 IF RES["?"
Begin DoDot:1
+12 DO HELP^DIE(63.04,,LRFIEN,"A","LRVER")
+13 SET DATA(0)=0
DO VALERR(.DATA,.LRVER)
End DoDot:1
QUIT
+14 DO CHK^DIE(63.04,LRFIEN,"HE",RES,.LRDAT,"LRERR")
+15 ;I LRDAT="^" S DATA=0_U_$G(LRERR("DIERR",1,"TEXT",1)) Q
+16 IF LRDAT="^"
SET DATA(0)=0
DO VALERR(.DATA,.LRERR)
QUIT
+17 SET DEFSPEC=$$GET1^DIQ(62,COLIEN,2,"I")
+18 IF '$GET(DEFSPEC)
SET DATA(0)=0
SET DATA(1)="No default specimen for IEN number "_COLIEN_" in the Collection Sample file. A default specimen must be defined for this entry to use Point of Care lab entry."
QUIT
+19 SET LRSPEC0=$GET(^LAB(60,TSTIEN,1,$$GET1^DIQ(62,COLIEN,2,"I"),0))
+20 ;
+21 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 -- Take into account RESULT might not be numeric
+22 NEW OLDRES
+23 SET OLDRES=RES
+24 IF $EXTRACT(RES)=">"
SET RES=$PIECE(RES,">",2)+1
+25 IF $EXTRACT(RES)="<"
SET RES=$PIECE(RES,"<",2)-1
+26 ;
+27 ; Initialize flag every time
SET LRFLG=""
+28 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+29 ;
+30 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041 -- Qualitative flag
+31 NEW QUALFLAG
+32 SET QUALFLAG=0
+33 Begin DoDot:1
+34 NEW LRDL,LRSB,LRTS,X
+35 SET LRDL=LRDAT
+36 SET LRSB=LRFIEN
+37 SET LRTS=$ORDER(^LAB(60,"C","CH;"_LRSB_";1",0))
+38 IF $LENGTH(LRDL)
IF $LENGTH(LRSB)
IF $LENGTH(LRSPEC)
IF $LENGTH(LRTS)
Begin DoDot:2
+39 SET X=$$QUALCHEK^BLRQUALU()
+40 IF $GET(LRFLG)="A*"
SET QUALFLAG=1
End DoDot:2
End DoDot:1
+41 IF QUALFLAG
GOTO VRET
QUIT
+42 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+43 ;
+44 SET LRNG4=$PIECE(LRSPEC0,U,4)
SET LRNG4=$$REFRES(LRNG4)
+45 SET LRNG5=$PIECE(LRSPEC0,U,5)
SET LRNG5=$$REFRES(LRNG5)
+46 SET LRNG2=$PIECE(LRSPEC0,U,2)
SET LRNG2=$$REFRES(LRNG2)
+47 SET LRNG3=$PIECE(LRSPEC0,U,3)
SET LRNG3=$$REFRES(LRNG3)
+48 ;
+49 IF $LENGTH(LRNG4)&(RES<LRNG4)
SET LRFLG="L*"
GOTO VRET
QUIT
+50 IF $LENGTH(LRNG5)&(RES>LRNG5)
SET LRFLG="H*"
GOTO VRET
QUIT
+51 IF $LENGTH(LRNG2)&(RES<LRNG2)
SET LRFLG="L"
GOTO VRET
QUIT
+52 IF $LENGTH(LRNG3)&(RES>LRNG3)
SET LRFLG="H"
+53 ;
VRET ; S DATA(0)=1_U_$S(LRFLG="H":"1:H",LRFLG="H*":"2:H",LRFLG="L":"1:L",LRFLG="L*":"2:L",1:0)_U_$G(LRDAT(0))_U_$G(LRDAT) Q
+1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
+2 ; IHS/MSC/MKK - LR*5.2*1031 - Reset RESULT to original value
SET RES=OLDRES
+3 ; S DATA=1,DATA(0)=1_U_$S(LRFLG="H":"1:H",LRFLG="H*":"2:H",LRFLG="L":"1:L",LRFLG="L*":"2:L",1:0)_U_$G(LRDAT(0))_U_$G(LRDAT)
+4 ; ----- END IHS/OIT/MKK - LR*5.2*1030
+5 ;
+6 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
+7 SET DATA=1
SET DATA(0)=1_U_$SELECT(LRFLG="A*":"1:A",LRFLG="H":"1:H",LRFLG="H*":"2:H",LRFLG="L":"1:L",LRFLG="L*":"2:L",1:0)_U_$GET(LRDAT(0))_U_$GET(LRDAT)
+8 ; ----- END IHS/MSC/MKK - LR*5.2*1041
+9 QUIT
VALERR(DATA,ERRARY) ; EP
+1 NEW HLP
+2 SET HLP=0
FOR
SET HLP=$ORDER(ERRARY("DIHELP",HLP))
IF 'HLP
QUIT
Begin DoDot:1
+3 SET DATA(HLP)=$GET(ERRARY("DIHELP",HLP))
End DoDot:1
+4 QUIT
+5 ; Return LRDFN for given patient
GUINIT(DATA,USR) ; EP
+1 SET DATA=$$GET1^DIQ(200,USR,1,"E")
+2 QUIT
GETPAT(DFN) ;EP
+1 NEW LRDFN
+2 SET LRDFN=$GET(^DPT(DFN,"LR"))
+3 IF 'LRDFN
SET LRDFN=$$NEWPAT(DFN)
+4 QUIT +LRDFN
+5 ; Create LRDFN for given patient
NEWPAT(DFN) ;EP
+1 NEW LRDPF,X,LRDFN,LRDPAF
+2 SET LRDPF="2^DPT("
SET X="^"_$PIECE(LRDPF,"^",2)_DFN_",""LR"")"
+3 SET LRDFN=$ORDER(^LR("A"),-1)
IF 'LRDFN
SET LRDFN=1
+4 LOCK +^LR(0):99
+5 DO E2^LRDPA
+6 LOCK -^LR(0)
+7 IF LRDFN<1
SET LRDFN=0
+8 QUIT LRDFN
+9 ;
+10 ; Resolve the reference range in the event that the range is a $S statement.
REFRES(VAL) ; EP
+1 NEW CHKVAL,REFVAL
+2 SET REFVAL=""
+3 SET X="S CHKVAL="_VAL
DO ^DIM
+4 IF $GET(X)'=""
Begin DoDot:1
+5 XECUTE X
SET REFVAL=CHKVAL
End DoDot:1
+6 KILL X
+7 QUIT REFVAL
+8 ;
URGLST(DATA) ; EP
+1 NEW IEN,TST,CNT
+2 SET (TST,CNT)=0
FOR
SET TST=$ORDER(^LAB(62.05,"B",TST))
IF TST=""
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^LAB(62.05,"B",TST,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+4 SET CNT=CNT+1
+5 SET DATA(CNT)=IEN_U_TST
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
NOOLST(DATA) ; EP
+1 NEW IEN,ORD,CNT,DEF
+2 ; Get the default nature of order from file 69.9 (field 150.1)
+3 SET DEF=$$GET1^DIQ(69.9,1,150.1,"I")
+4 IF 'DEF
SET DEF=$ORDER(^ORD(100.02,"B","WRITTEN",""))
+5 SET (ORD,CNT)=0
FOR
SET ORD=$ORDER(^ORD(100.02,"B",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+6 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(100.02,"B",ORD,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 ; ----- BEGIN IHS/MSC/BF - IHS Lab Patch 1026
+8 ; USE SCREEN LOGIC AS IT IS USED IN THE LRFAST OPTION.
+9 IF '$PIECE(^ORD(100.02,IEN,0),"^",4)
IF '$PIECE(^ORD(100.02,IEN,0),"^",3)
IF ('$PIECE(^ORD(100.02,IEN,0),"^",6))
IF "XB"[$PIECE(^ORD(100.02,IEN,0),"^",5)
Begin DoDot:3
+10 SET CNT=CNT+1
+11 SET DATA(CNT)=IEN_U_ORD_U_$SELECT(IEN=DEF:1,1:"")
End DoDot:3
+12 ; ----- END IHS/MSC/BF - IHS Lab Patch 1026
End DoDot:2
End DoDot:1
+13 QUIT
LABDESC(DATA,DIV) ; EP
+1 NEW CC,CNT,COMIEN
+2 ; default to user's current division
SET DIV=$GET(DIV,$GET(DUZ(2)))
+3 SET (CC,CNT)=0
FOR
SET CC=$ORDER(^BLRPOC(90479,DIV,4,CC))
IF 'CC
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 ;S COMIEN=+^BLRPOC(90479,DIV,4,CC,0)
+6 ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
SET COMIEN=+$GET(^BLRPOC(90479,DIV,4,CC,0))
+7 SET DATA(CNT)=$$GETCOM(COMIEN)
End DoDot:1
+8 QUIT
GETCOM(COMIEN) ; EP
+1 NEW LDNAME,LDEXP
+2 SET LDNAME=$$GET1^DIQ(62.5,COMIEN,.01,"E")
+3 SET LDEXP=$$GET1^DIQ(62.5,COMIEN,1,"E")
+4 QUIT COMIEN_U_LDNAME_U_LDEXP
+5 ;
BLDARY(LOC,SPEC0,RES,FLG) ; EP
+1 SET LRARY(LOC)=$SELECT(RES="":"pending",1:RES)
+2 IF RES="pending"
QUIT
+3 IF $DATA(FLG)
SET $PIECE(LRARY(LOC),U,2)=FLG
+4 SET $PIECE(LRARY(LOC),U,3)="!!!"
+5 SET $PIECE(LRARY(LOC),U,4)=$GET(DUZ)
+6 IF $DATA(SPEC0)
SET $PIECE(LRARY(LOC),U,5)=SPEC0
+7 ; IHS/MSC/MKK - LR*5.2*1039 -- LEDI IV Change
SET $PIECE(LRARY(LOC),U,6)=$$NOW^XLFDT
+8 SET $PIECE(LRARY(LOC),U,9)=DUZ(2)
+9 QUIT
+10 ;
CHKTST(TEST) ; EP
+1 NEW LRLOOP,LRITMIEN,PNLINPNL,SAMP,COLNM,SPEC,BADPTR
+2 ; IHS/OIT/MKK - LR*5.2*1026
NEW SUBNOACC,SUBNOCOL
+3 ;
+4 ; If type is not set to "Both", do not allow entry
IF $PIECE(^LAB(60,TEST,0),U,3)'="B"
QUIT 0
+5 ; If the subscript is not "CH" do not allow entry
IF $PIECE(^LAB(60,TEST,0),U,4)'="CH"
QUIT 0
+6 ; If no accession area is defined for this test at this site, do not process
IF '$DATA(^LAB(60,TEST,8,$GET(DUZ(2))))
QUIT 0
+7 ; If there is no collection sample, do not return entry. -- LR*5.2*.1026
IF '+$ORDER(^LAB(60,TEST,3,0))
QUIT 0
+8 ; COSMIC test's ATOMIC subtests Accession number &/or a Collection Sample Flags
SET (SUBNOACC,SUBNOCOL)=0
+9 ;
+10 ; If the test is a panel, and has a panel within that panel, do not allow entry
+11 SET (PNLINPNL,BADPTR)=0
+12 IF $$ISPANEL(TEST)
Begin DoDot:1
+13 ; S LRLOOP=0 F S LRLOOP=$O(^LAB(60,TEST,2,LRLOOP)) Q:'LRLOOP!(PNLINPNL)!(BADPTR) D
+14 ; IHS Lab Patch 1026 -- Check the subtests as well
SET LRLOOP=0
FOR
SET LRLOOP=$ORDER(^LAB(60,TEST,2,LRLOOP))
IF 'LRLOOP!(PNLINPNL)!(BADPTR)!(SUBNOACC)!(SUBNOCOL)
QUIT
Begin DoDot:2
+15 SET LRITMIEN=$$GET1^DIQ(60.02,LRLOOP_","_TEST,.01,"I")
+16 IF $$ISPANEL(LRITMIEN)
SET PNLINPNL=1
QUIT
+17 IF $$BADPTR(LRITMIEN)
SET BADPTR=1
QUIT
+18 ; IHS/OIT/MKK - LR*5.2*1026 -- Check the subtests as well
IF '$DATA(^LAB(60,LRITMIEN,8,$GET(DUZ(2))))
SET SUBNOACC=1
QUIT
+19 IF '+$ORDER(^LAB(60,LRITMIEN,3,0))
SET SUBNOCOL=1
QUIT
End DoDot:2
End DoDot:1
+20 ; I PNLINPNL!(BADPTR) Q 0
+21 ; IHS/OIT/MKK - LR*5.2*1026
IF PNLINPNL!(BADPTR)!(SUBNOACC)!(SUBNOCOL)
QUIT 0
+22 ;
+23 QUIT 1
+24 ;
+25 ;Check to see if this test has a bad pointer to the ^DD executable logic.
BADPTR(IEN) ; EP
+1 ; I '$D(^DD(63.04,$P($$GET1^DIQ(60,IEN,5,"E"),";",2))) Q 1 ; IHS/MSC/BF - IHS Lab Patch 1026 -- Make sure $P returns numeric
+2 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027 - Valid check for existance of invalid IEN
+3 NEW WOT
+4 SET WOT=+$PIECE($$GET1^DIQ(60,IEN,5,"E"),";",2)
+5 IF WOT<1
QUIT 1
+6 ; ----- END IHS/OIT/MKK - LR*5.2*1027
+7 ; IHS/MSC/BF - IHS Lab Patch 1026 -- Make sure $P returns numeric
IF '$DATA(^DD(63.04,$PIECE($$GET1^DIQ(60,IEN,5,"E"),";",2)))
QUIT 1
+8 ;
+9 ; IHS/MSC/BF - IHS Lab Patch 1026
QUIT 0
+10 ;
+11 ; Check to see if the supplied location is valid for this test
+12 ; INPUT LIEN - Lab test ien from the BLR BEHO LAB POC file
+13 ; DIV - Division
+14 ; LOC - Location passed in from the LAB POC component
LOCMATCH(LIEN,DIV,LOC) ; EP
+1 IF $DATA(^BLRPOC(90479,DIV,1,LIEN,3,"B",LOC))!('$DATA(^BLRPOC(90479,DIV,1,LIEN,3,"B")))
QUIT 1
+2 QUIT 0
+3 ;
+4 ;Check to see if the supplied user is valid for the test
+5 ; INPUT LIEN - Lab test ien from the BLR BEHO LAB POC file
+6 ; DIV - Divsion
+7 ; USR - User number from file 200
USRMATCH(LIEN,DIV,USR) ; EP
+1 IF $DATA(^BLRPOC(90479,DIV,1,LIEN,4,"B",USR))!('$DATA(^BLRPOC(90479,DIV,1,LIEN,4,"B")))
QUIT 1
+2 QUIT 0
+3 ;
+4 ; Clean up environment
CVARS ; EP
+1 KILL ARY,BLRDH,BLRGUI,BLRLOG,BLRPCC,BLRSTOP,BLRQSITE,BLRSTOP,BPCACC,BPCCOM,LRAA,LRARY,LRBLOOD,LRCCOM,LRAHEAD
+2 KILL LRDFN,LRDPF,LRDTO,LREAL,LREND,LRGCOM,LRI,LRIDIV,LRJ,LRLABKY,LRLBLBP,LRLLOC,LRLWC,LRNATURE,LRORDR,LRORDTIM
+3 KILL LRORDTST,LROUTINE,LRPARAM,LRPCEVSO,LRPLASMA,LRPOVREQ,LRPR,LRSAMP,LRSERUM,LRSPEC,LRSS,LRUNKNOW,LRURG
+4 KILL LRURINE,LRUSI,LRVF,LRVIDO,LRVIDOF,LRWLO,LRWLC,RET
+5 QUIT
