Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRPOC

BLRPOC.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1.  ;
  1. POCTSTS(DATA,DIV,LOC,USR,DFN) ; EP
  1.  S DIV=$G(DIV,$G(DUZ(2)))  ; default to user's current division
  1.  N LP,TST,CNT
  1.  S (CNT,LP)=0 F  S LP=$O(^BLRPOC(90479,DIV,1,LP)) Q:'LP  D
  1.  .; If enforce restrict to location is 'yes', check to see if it passes the restriction
  1.  .I $$GET1^DIQ(90479,DIV,.02,"I"),'$$LOCMATCH(LP,+$G(DIV),+$G(LOC)) Q
  1.  .; If enforce restrict to user is 'yes', check to see if it passes the restriction
  1.  .I $$GET1^DIQ(90479,DIV,.03,"I"),'$$USRMATCH(LP,+$G(DIV),+$G(USR)) Q
  1.  .S CNT=CNT+1
  1.  .;S TST=+^BLRPOC(90479,DIV,1,LP,0)
  1.  .S TST=+$G(^BLRPOC(90479,DIV,1,LP,0)) ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
  1.  .I '$$CHKTST(TST) Q    ; Check test for any issues.
  1.  .S DATA(CNT,"tst")=$$GETTST(TST,DFN)
  1.  Q
  1.  ;
  1. GETTST(TST,DFN) ;EP-
  1.  N TSTNM,COL,COLNM,SPEC,REFL,REFH,UNITS,CHKVAL
  1.  S Y=DFN D ^AUPNPAT
  1.  I +$$GET^XPAR("PKG","BLR AGE DETAIL",1,"Q") S AGE=$$AGE^AUPNPAT3(DFN,$$DT^XLFDT,"M")    ; IHS/MSC/MKK - LR*5.2*1038
  1.  S TSTNM=$$GET1^DIQ(60,TST,.01)
  1.  S COL=$$UNQCOL(TST)
  1.  S COLNM=$$GET1^DIQ(62,COL,.01,"I")
  1.  S SPEC=$$GET1^DIQ(62,COL,2,"I")
  1.  S LRSPEC=$$GET1^DIQ(62,COL,2,"I")               ; IHS/MSC/MKK - LR*5.2*1031
  1.  S REFL=$$GET1^DIQ(60.01,SPEC_","_TST_",",1,"I")
  1.  S REFL=$$REFRES(REFL)
  1.  S REFH=$$GET1^DIQ(60.01,SPEC_","_TST_",",2,"I")
  1.  S REFH=$$REFRES(REFH)
  1.  S UNITS=$$GET1^DIQ(60.01,SPEC_","_TST_",",6,"I")
  1.  Q TST_U_TSTNM_U_$$ISPANEL(TST)_U_COL_U_COLNM_U_REFL_U_REFH_U_UNITS
  1.  ;
  1. UNQCOL(IEN) ;EP - RETURN FIRST COLLECTION SAMPLE
  1.  N SMP
  1.  S SMP=+$O(^LAB(60,IEN,3,0))
  1.  ; Q +^LAB(60,IEN,3,SMP,0)
  1.  Q +$G(^LAB(60,IEN,3,SMP,0)) ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
  1.  ;
  1. ISPANEL(IEN) ;EP- Returns boolean flag indicating if test is a panel test
  1.  Q ('+$G(^LAB(60,IEN,.2))&+$O(^LAB(60,IEN,2,0)))
  1.  ;
  1. SAVE(DATA,DFN,ARY) ;EP-
  1.  D SAVER^BLRPOC2     ; IHS/OIT/MKK - LR*5.2*1030
  1.  Q
  1.  ;
  1. 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.
  1.  ;  Loop thru the LAB TEST INCLUDED IN PANEL field of File 60 and call $$GETTST to collect the test information
  1.  N LP,CNT,PTST
  1.  S (CNT,LP)=0 F  S LP=$O(^LAB(60,TST,2,LP)) Q:'LP  D
  1.  .S CNT=CNT+1
  1.  .;S PTST=+^LAB(60,TST,2,LP,0)
  1.  .S PTST=+$G(^LAB(60,TST,2,LP,0)) ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
  1.  .S DATA(CNT,"tst")=$$GETTST(PTST,DFN)
  1.  Q
  1.  ; Returns validated status
  1.  ; Input: TSTIEN - Laboratory Test Pointer to File 60
  1.  ;        COLIEN - Collection Sample Pointer to File 62
  1.  ;        RESULT - Result value to be validated
  1.  ; Output: DATA - 0=not valid; 1=valid
  1. VALIDATE(DATA,TSTIEN,COLIEN,RES,DFN) ; EP
  1.  NEW LRFLOC,LRFIEN,LRDAT,LRNG2,LRNG3,LRNG4,LRNG5,LRFLG,LRERR,LRVER
  1.  NEW AGE,SSN,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,SEX,DEFSPEC
  1.  NEW DUPPER
  1.  M DUPPER=DATA
  1.  S Y=DFN D ^AUPNPAT
  1.  I +$$GET^XPAR("PKG","BLR AGE DETAIL",1,"Q") S AGE=$$AGE^AUPNPAT3(DFN,$$DT^XLFDT,"M")    ; IHS/MSC/MKK - LR*5.2*1038
  1.  S LRFLG=""
  1.  S LRFLOC=$$GET1^DIQ(60,TSTIEN,5,"E")
  1.  I LRFLOC="" S DATA=0,DATA(1)="Test information not found." Q
  1.  S LRFIEN=$P(LRFLOC,";",2)
  1.  I RES["?" D  Q
  1.  .D HELP^DIE(63.04,,LRFIEN,"A","LRVER")
  1.  .S DATA(0)=0 D VALERR(.DATA,.LRVER)
  1.  D CHK^DIE(63.04,LRFIEN,"HE",RES,.LRDAT,"LRERR")
  1.  ;I LRDAT="^" S DATA=0_U_$G(LRERR("DIERR",1,"TEXT",1)) Q
  1.  I LRDAT="^" S DATA(0)=0 D VALERR(.DATA,.LRERR) Q
  1.  S DEFSPEC=$$GET1^DIQ(62,COLIEN,2,"I")
  1.  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
  1.  S LRSPEC0=$G(^LAB(60,TSTIEN,1,$$GET1^DIQ(62,COLIEN,2,"I"),0))
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 -- Take into account RESULT might not be numeric
  1.  NEW OLDRES
  1.  S OLDRES=RES
  1.  S:$E(RES)=">" RES=$P(RES,">",2)+1
  1.  S:$E(RES)="<" RES=$P(RES,"<",2)-1
  1.  ;
  1.  S LRFLG=""                       ; Initialize flag every time
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041 -- Qualitative flag
  1.  NEW QUALFLAG
  1.  S QUALFLAG=0
  1.  D
  1.  . NEW LRDL,LRSB,LRTS,X
  1.  . S LRDL=LRDAT
  1.  . S LRSB=LRFIEN
  1.  . S LRTS=$O(^LAB(60,"C","CH;"_LRSB_";1",0))
  1.  . I $L(LRDL),$L(LRSB),$L(LRSPEC),$L(LRTS) D
  1.  .. S X=$$QUALCHEK^BLRQUALU()
  1.  .. I $G(LRFLG)="A*" S QUALFLAG=1
  1.  I QUALFLAG G VRET Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  S LRNG4=$P(LRSPEC0,U,4),LRNG4=$$REFRES(LRNG4)
  1.  S LRNG5=$P(LRSPEC0,U,5),LRNG5=$$REFRES(LRNG5)
  1.  S LRNG2=$P(LRSPEC0,U,2),LRNG2=$$REFRES(LRNG2)
  1.  S LRNG3=$P(LRSPEC0,U,3),LRNG3=$$REFRES(LRNG3)
  1.  ;
  1.  I $L(LRNG4)&(RES<LRNG4) S LRFLG="L*" G VRET Q
  1.  I $L(LRNG5)&(RES>LRNG5) S LRFLG="H*" G VRET Q
  1.  I $L(LRNG2)&(RES<LRNG2) S LRFLG="L" G VRET Q
  1.  I $L(LRNG3)&(RES>LRNG3) S LRFLG="H"
  1.  ;
  1. 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
  1.  S RES=OLDRES                ; IHS/MSC/MKK - LR*5.2*1031 - Reset RESULT to original value
  1.  ; 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)
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1030
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1.  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)
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041
  1.  Q
  1. VALERR(DATA,ERRARY) ; EP
  1.  N HLP
  1.  S HLP=0 F  S HLP=$O(ERRARY("DIHELP",HLP)) Q:'HLP  D
  1.  .S DATA(HLP)=$G(ERRARY("DIHELP",HLP))
  1.  Q
  1.  ; Return LRDFN for given patient
  1. GUINIT(DATA,USR) ; EP
  1.  S DATA=$$GET1^DIQ(200,USR,1,"E")
  1.  Q
  1. GETPAT(DFN) ;EP
  1.  N LRDFN
  1.  S LRDFN=$G(^DPT(DFN,"LR"))
  1.  S:'LRDFN LRDFN=$$NEWPAT(DFN)
  1.  Q +LRDFN
  1.  ; Create LRDFN for given patient
  1. NEWPAT(DFN) ;EP
  1.  N LRDPF,X,LRDFN,LRDPAF
  1.  S LRDPF="2^DPT(",X="^"_$P(LRDPF,"^",2)_DFN_",""LR"")"
  1.  S LRDFN=$O(^LR("A"),-1) I 'LRDFN S LRDFN=1
  1.  L +^LR(0):99
  1.  D E2^LRDPA
  1.  L -^LR(0)
  1.  S:LRDFN<1 LRDFN=0
  1.  Q LRDFN
  1.  ;
  1.  ; Resolve the reference range in the event that the range is a $S statement.
  1. REFRES(VAL) ; EP
  1.  N CHKVAL,REFVAL
  1.  S REFVAL=""
  1.  S X="S CHKVAL="_VAL D ^DIM
  1.  I $G(X)'="" D
  1.  .X X S REFVAL=CHKVAL
  1.  K X
  1.  Q REFVAL
  1.  ;
  1. URGLST(DATA) ; EP
  1.  N IEN,TST,CNT
  1.  S (TST,CNT)=0 F  S TST=$O(^LAB(62.05,"B",TST)) Q:TST=""  D
  1.  .S IEN=0 F  S IEN=$O(^LAB(62.05,"B",TST,IEN)) Q:'IEN  D
  1.  ..S CNT=CNT+1
  1.  ..S DATA(CNT)=IEN_U_TST
  1.  Q
  1.  ;
  1. NOOLST(DATA) ; EP
  1.  N IEN,ORD,CNT,DEF
  1.  ; Get the default nature of order from file 69.9 (field 150.1)
  1.  S DEF=$$GET1^DIQ(69.9,1,150.1,"I")
  1.  I 'DEF S DEF=$O(^ORD(100.02,"B","WRITTEN",""))
  1.  S (ORD,CNT)=0 F  S ORD=$O(^ORD(100.02,"B",ORD)) Q:ORD=""  D
  1.  .S IEN=0 F  S IEN=$O(^ORD(100.02,"B",ORD,IEN)) Q:'IEN  D
  1.  ..; ----- BEGIN IHS/MSC/BF - IHS Lab Patch 1026
  1.  ..; USE SCREEN LOGIC AS IT IS USED IN THE LRFAST OPTION.
  1.  ..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
  1.  ...S CNT=CNT+1
  1.  ...S DATA(CNT)=IEN_U_ORD_U_$S(IEN=DEF:1,1:"")
  1.  ..; ----- END IHS/MSC/BF - IHS Lab Patch 1026
  1.  Q
  1. LABDESC(DATA,DIV) ; EP
  1.  N CC,CNT,COMIEN
  1.  S DIV=$G(DIV,$G(DUZ(2)))  ; default to user's current division
  1.  S (CC,CNT)=0 F  S CC=$O(^BLRPOC(90479,DIV,4,CC)) Q:'CC  D
  1.  .S CNT=CNT+1
  1.  .;S COMIEN=+^BLRPOC(90479,DIV,4,CC,0)
  1.  .S COMIEN=+$G(^BLRPOC(90479,DIV,4,CC,0))   ; IHS/OIT/MKK - LR*5.2*1026 - Naked Reference fix
  1.  .S DATA(CNT)=$$GETCOM(COMIEN)
  1.  Q
  1. GETCOM(COMIEN) ; EP
  1.  N LDNAME,LDEXP
  1.  S LDNAME=$$GET1^DIQ(62.5,COMIEN,.01,"E")
  1.  S LDEXP=$$GET1^DIQ(62.5,COMIEN,1,"E")
  1.  Q COMIEN_U_LDNAME_U_LDEXP
  1.  ;
  1. BLDARY(LOC,SPEC0,RES,FLG) ; EP
  1.  S LRARY(LOC)=$S(RES="":"pending",1:RES)
  1.  I RES="pending" Q
  1.  I $D(FLG) S $P(LRARY(LOC),U,2)=FLG
  1.  S $P(LRARY(LOC),U,3)="!!!"
  1.  S $P(LRARY(LOC),U,4)=$G(DUZ)
  1.  I $D(SPEC0) S $P(LRARY(LOC),U,5)=SPEC0
  1.  S $P(LRARY(LOC),U,6)=$$NOW^XLFDT      ; IHS/MSC/MKK - LR*5.2*1039 -- LEDI IV Change
  1.  S $P(LRARY(LOC),U,9)=DUZ(2)
  1.  Q
  1.  ;
  1. CHKTST(TEST) ; EP
  1.  N LRLOOP,LRITMIEN,PNLINPNL,SAMP,COLNM,SPEC,BADPTR
  1.  NEW SUBNOACC,SUBNOCOL  ; IHS/OIT/MKK - LR*5.2*1026
  1.  ;
  1.  I $P(^LAB(60,TEST,0),U,3)'="B" Q 0         ; If type is not set to "Both", do not allow entry
  1.  I $P(^LAB(60,TEST,0),U,4)'="CH" Q 0        ; If the subscript is not "CH" do not allow entry
  1.  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
  1.  I '+$O(^LAB(60,TEST,3,0)) Q 0              ; If there is no collection sample, do not return entry. -- LR*5.2*.1026
  1.  S (SUBNOACC,SUBNOCOL)=0                    ; COSMIC test's ATOMIC subtests Accession number &/or a Collection Sample Flags
  1.  ;
  1.  ; If the test is a panel, and has a panel within that panel, do not allow entry
  1.  S (PNLINPNL,BADPTR)=0
  1.  I $$ISPANEL(TEST) D
  1.  .; S LRLOOP=0 F  S LRLOOP=$O(^LAB(60,TEST,2,LRLOOP)) Q:'LRLOOP!(PNLINPNL)!(BADPTR)  D
  1.  .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
  1.  ..S LRITMIEN=$$GET1^DIQ(60.02,LRLOOP_","_TEST,.01,"I")
  1.  ..I $$ISPANEL(LRITMIEN) S PNLINPNL=1 Q
  1.  ..I $$BADPTR(LRITMIEN) S BADPTR=1 Q
  1.  .. 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
  1.  .. I '+$O(^LAB(60,LRITMIEN,3,0)) S SUBNOCOL=1  Q
  1.  ; I PNLINPNL!(BADPTR) Q 0
  1.  I PNLINPNL!(BADPTR)!(SUBNOACC)!(SUBNOCOL) Q 0   ; IHS/OIT/MKK - LR*5.2*1026
  1.  ;
  1.  Q 1
  1.  ;
  1.  ;Check to see if this test has a bad pointer to the ^DD executable logic.
  1. 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
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027 - Valid check for existance of invalid IEN
  1.  NEW WOT
  1.  S WOT=+$P($$GET1^DIQ(60,IEN,5,"E"),";",2)
  1.  Q:WOT<1 1
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1027
  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
  1.  ; 
  1.  Q 0     ; IHS/MSC/BF - IHS Lab Patch 1026
  1.  ;
  1.  ; Check to see if the supplied location is valid for this test
  1.  ; INPUT LIEN - Lab test ien from the BLR BEHO LAB POC file
  1.  ;       DIV  - Division
  1.  ;       LOC  - Location passed in from the LAB POC component
  1. LOCMATCH(LIEN,DIV,LOC) ; EP
  1.  I $D(^BLRPOC(90479,DIV,1,LIEN,3,"B",LOC))!('$D(^BLRPOC(90479,DIV,1,LIEN,3,"B"))) Q 1
  1.  Q 0
  1.  ;
  1.  ;Check to see if the supplied user is valid for the test
  1.  ; INPUT LIEN - Lab test ien from the BLR BEHO LAB POC file
  1.  ;       DIV  - Divsion
  1.  ;       USR  - User number from file 200
  1. USRMATCH(LIEN,DIV,USR) ; EP
  1.  I $D(^BLRPOC(90479,DIV,1,LIEN,4,"B",USR))!('$D(^BLRPOC(90479,DIV,1,LIEN,4,"B"))) Q 1
  1.  Q 0
  1.  ;
  1.  ; Clean up environment
  1. CVARS ; EP
  1.  K ARY,BLRDH,BLRGUI,BLRLOG,BLRPCC,BLRSTOP,BLRQSITE,BLRSTOP,BPCACC,BPCCOM,LRAA,LRARY,LRBLOOD,LRCCOM,LRAHEAD
  1.  K LRDFN,LRDPF,LRDTO,LREAL,LREND,LRGCOM,LRI,LRIDIV,LRJ,LRLABKY,LRLBLBP,LRLLOC,LRLWC,LRNATURE,LRORDR,LRORDTIM
  1.  K LRORDTST,LROUTINE,LRPARAM,LRPCEVSO,LRPLASMA,LRPOVREQ,LRPR,LRSAMP,LRSERUM,LRSPEC,LRSS,LRUNKNOW,LRURG
  1.  K LRURINE,LRUSI,LRVF,LRVIDO,LRVIDOF,LRWLO,LRWLC,RET
  1.  Q