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

BLRALAF.m

Go to the documentation of this file. 
  1. BLRALAF ;DAOU/ALA-Set Lab Results Flag 
  1.  ;;5.2T9;LR;**1018**;Nov 17, 2004
  1.  ;;5.2;LR;**1013,1015**;Nov 18, 2002
  1.  ;
  1.  ;**Program Description**
  1.  ;  This program will check for the results flag and
  1.  ;  set up all pertinent information in the results file #63
  1.  ;
  1.  ;**PARAMETERS**
  1.  ;  BLRARFL  = Review Flag
  1.  ;  BLRARPHY = Responsible Physician
  1.  ;  BLRACT   = Count of Abnormal Results
  1.  ;  BLRPCT  = Count of Pending Results
  1.  ;  BLRCCT  = Count of Critical Results
  1.  ;  BLRRCT  = Count of Results with no references
  1.  ;
  1. CHK ; Check to see if Accession has results before setting in BLRA queue
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  ; THIS SET MOVED TO CHKNXT+3
  1.  ;S BLRACHK=0
  1.  ;----- END IHS MODIFICATIONS
  1. CHKNXT I $G(LRSS)="",$G(LRAA)'="" S LRSS=$P($G(^LRO(68,LRAA,0)),U,2)  ;IHS/ITSC/TPF 03/18/03 FIX LRSS UNDEFINED ERROR REPORTED AT BLACKFEET COMMUNITY **1016**
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  S BLRACHK=$S(LRSS="CH":1,1:0)  ;BYPASS COMMENTS FOR CH; NOT PERFORMED TESTS WILL HAVE COMMENTS ;START AT 0 FOR MICROS
  1.  ;----- END IHS MODIFICATIONS
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  ;THIS IGNORES ENTRY BY OPTION:
  1.  ;    Itemized routine lab collection" and "Receipt of routine lab collection from wards" as these are not processed at this time. They will be when resulted
  1.  I $G(LRIDT)="",((U_"LRPHEXCPT"_U_"LRPHITEM"_U)[$P(XQY0,U)) Q
  1.  ;----- END IHS MODIFICATIONS
  1.  ;
  1.  S BLRACHK=$O(^LR(LRDFN,LRSS,LRIDT,BLRACHK))  ; FIX #40
  1.  ;I '(BLRACHK>0&(BLRACHK<9009027)) Q
  1.  I BLRACHK=9009027 G CHKNXT
  1.  I BLRACHK<1 Q
  1.  KILL BLRACHK
  1.  ;
  1. PHY ;  Physician setup
  1.  ;  Get the ordering physician
  1.  S BLRAPRAC=$P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,$S(LRSS="MI":7,1:10))
  1.  ; If no requesting person not found then this is a referral patient 
  1.  ; requesting person is not prompted for. 
  1.  Q:'$G(BLRAPRAC)
  1.  ;  If not a participating physician, quit
  1.  I '$D(^BLRALAB(9009027.1,BLRAPRAC)) K BLRAPRAC Q
  1.  ; If physician is INACTIVE, quit -ejn 3/22/02
  1.  I $P($G(^BLRALAB(9009027.1,BLRAPRAC,0)),U,7)="I" Q
  1.  ;  Check what's there
  1.  S BLRADATA=$G(^LR(LRDFN,LRSS,LRIDT,9009027))
  1.  S BLRARFL=+$P(BLRADATA,U,1),BLRARPHY=$P(BLRADATA,U,2)
  1.  ; 
  1.  ;I LRSS="CH"&(BLRARFL)&('$D(LRSA)) K BLRARFL,BLRAPRAC,BLRADATA,BLRARPHY Q
  1.  ;
  1.  ;  If the Clin Chem accession was already reviewed or completed and
  1.  ;  then amended, the status will be set back for completion
  1.  ;  again.  The record of the previous reviewed or completion
  1.  ;  are to be added to the amended values.
  1.  I LRSS="CH"&(BLRARFL)&($D(LRSA)) D RSET
  1.  ;
  1.  I BLRARPHY="" S BLRARPHY=BLRAPRAC
  1.  ;
  1.  ;  Count the number of abnormal and pending results
  1.  S BLRACT=0,BLRPCT=0,BLRCCT=0,BLRRCT=0
  1.  I LRSS="CH" S BLRAJ=1 D
  1.  . D ACC
  1.  . ;F  S BLRAJ=$O(^LR(LRDFN,LRSS,LRIDT,BLRAJ)) Q:'BLRAJ!(BLRAJ=9009027)  D  ; FIX #40
  1.  . F  S BLRAJ=$O(^LR(LRDFN,LRSS,LRIDT,BLRAJ)) Q:'BLRAJ  D
  1.  .. Q:BLRAJ=9009027
  1.  .. I $P($G(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,2)["*" S BLRCCT=BLRCCT+1 Q
  1.  .. I $P($G(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,2)'="" S BLRACT=BLRACT+1
  1.  .. ;I $P($G(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,1)="pending" S BLRPCT=BLRPCT+1  ; FIX #41 for dup pendings
  1.  ;
  1.  ;  If microbiology check for preliminary and set the pending flag
  1.  ;  if set to final, set pending flag to complete
  1.  ;
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  I LRSS="MI" Q:'$D(^LR(LRDFN,LRSS,LRIDT,1))
  1.  ;----- END IHS MODIFICATIONS THIS TAKES CARE OF "EMPTY" MICROS THAT ARE DELETED. IF THE DOCTORS WISH TO SEE MICROS WHICH WERE ORDERS BUT THEN "NOT PERFORMED" COMMENT THIS LINE OUT
  1.  I LRSS="MI" D
  1.  . S BLRAJ=0
  1.  . F  S BLRAJ=$O(^LR(LRDFN,LRSS,LRIDT,3,BLRAJ)) Q:'BLRAJ  D
  1.  .. I $P($G(^LR(LRDFN,LRSS,LRIDT,3,BLRAJ,0)),U,1)'="" S BLRACT=BLRACT+1
  1.  . I $P($G(^LR(LRDFN,LRSS,LRIDT,1)),U,2)="P" S BLRPCT=1
  1.  . I $P($G(^LR(LRDFN,LRSS,LRIDT,1)),U,2)="F" S BLRPCT=0
  1.  . D ACC
  1.  ;
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,1)=BLRARFL
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,2)=BLRARPHY
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,6)=BLRACT
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,7)=BLRPCT
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,8)=BLRCCT
  1.  S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,9)=BLRRCT
  1.  ;
  1.  ;  Set the cross-reference
  1.  D SX^BLRALUT1
  1.  ;
  1.  K BLRACT,BLRPCT,BLRCCT,BLRARFL,BLRARPHY,BLRAJ,BLRNM,BLRADATA,BLRAPRAC
  1.  K BLRPFL,BLRPRDT,BLRPSDT,BLRPSPH,BLRATXT,BLRRCT
  1.  K BREF,RFL,BLRLOW,BLRCLOW,BLRCHI,BLRHI,TST,TST1,SUBTEST,NUM
  1.  Q
  1.  ;
  1. ACC ;  Check the Accession File
  1.  I LRSS'="MI" D
  1.  . S LRORU=$G(^LR(LRDFN,LRSS,LRIDT,"ORU")) Q:LRORU=""
  1.  . I $D(^LRO(68,"C",LRORU)) D
  1.  .. S LRAA=$O(^LRO(68,"C",LRORU,"")) Q:'LRAA
  1.  .. S LRAD=$O(^LRO(68,"C",LRORU,LRAA,"")) Q:'LRAD
  1.  .. S LRAN=$O(^LRO(68,"C",LRORU,LRAA,LRAD,"")) Q:'LRAN
  1.  ;
  1.  NEW TST
  1.  S TST=0
  1.  F NUMTST=0:1 S TST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST)) Q:'TST  D
  1.  .;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  .I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,6)[("*Not Performed") X:LRSS="MI" $S(BLRPCT=0:"S BLRPCT=0",1:"S BLRPCT=BLRPCT-1") Q
  1.  .;----- END IHS MODIFICATIONS
  1.  . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,5)="" D
  1.  .. ;FORMAT OF SET BELOW ^LAB(60,1,0)=WBC^^B^CH^CH;384;1^^0^1^3^^^DD(63.04,384,^^^^1^1^9^^0
  1.  .. ;I.E. GET DATANAME
  1.  .. S LRDN=$P($P($G(^LAB(60,TST,0)),U,5),";",2)
  1.  .. ; Do not combine the 4 if statements below into fewer statements. ;DAOU/DJW 1/23/02
  1.  .. ;----- BEGIN IHS MODIFICATIONS
  1.  .. I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,6)[("*Not Performed") Q
  1.  .. ;----- END IHS MODIFCATIONS
  1.  .. I '$D(LRDN) D PEND Q
  1.  .. I $G(LRDN)="" D PEND Q
  1.  .. I '$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) D PEND Q
  1.  .. I $P($G(^LR(LRDFN,LRSS,LRIDT,LRDN)),U,1)["pending" D PEND Q
  1.  . ; FIX #45 EJN
  1.  . ; Check for lab test references
  1.  . ;LAB(60,D0,2,0)=^60.02P^^  (#200) LAB TEST INCLUDED IN PANEL
  1.  . I $P($G(^LAB(60,TST,1,0)),U,4)'>0 S BLRRCT=BLRRCT+1
  1.  . S TST1=TST D CHKREF
  1.  . ; Check to see if it is a panel, reset BLRRCT for panels
  1.  . I $P($G(^LAB(60,TST,2,0)),U,4)>0 D
  1.  .. S BLRRCT=0
  1.  .. S NUM=0,SUBTST=""
  1.  .. F  S NUM=$O(^LAB(60,TST,2,NUM)) Q:'NUM  D
  1.  ... S SUBTST=$P($G(^LAB(60,TST,2,NUM,0)),U,1)
  1.  ... S TST1=SUBTST D CHKREF
  1.  Q
  1. CHKREF ;
  1.  S BREF=0,RFL=0
  1.  I $G(TST1)="" Q
  1.  F  S BREF=$O(^LAB(60,TST1,1,BREF)) Q:'BREF  D
  1.  . S BLRLOW=$P($G(^LAB(60,TST1,1,BREF,0)),U,2),BLRLOW=$$STRIP^XLFSTR(BLRLOW,"""")
  1.  . S BLRHI=$P($G(^LAB(60,TST1,1,BREF,0)),U,3),BLRHI=$$STRIP^XLFSTR(BLRHI,"""")
  1.  . S BLRCLOW=$P($G(^LAB(60,TST1,1,BREF,0)),U,4),BLRCLOW=$$STRIP^XLFSTR(BLRCLOW,"""")
  1.  . S BLRCHI=$P($G(^LAB(60,TST1,1,BREF,0)),U,5),BLRCHI=$$STRIP^XLFSTR(BLRCHI,"""")
  1.  . I BLRLOW=""&(BLRHI="")&(BLRCLOW="")&(BLRCHI="") S RFL=1
  1.  . I ((BLRLOW?.A)&(BLRLOW'["$S")&(BLRLOW'=""))!((BLRHI?.A)&(BLRHI'["$S")&(BLRHI'="")) S RFL=1
  1.  . I ((BLRCLOW?.A)&(BLRCLOW'["$S")&(BLRCLOW'=""))!((BLRCHI?.A)&(BLRCHI'["$S")&(BLRCHI'="")) S RFL=1
  1.  . I BLRLOW["<"!(BLRLOW[">")!(BLRHI["<")!(BLRHI[">")!(BLRCLOW["<")!(BLRCLOW[">")!(BLRCHI["<")!(BLRCHI[">") S RFL=1
  1.  I RFL>0 S BLRRCT=BLRRCT+1
  1.  Q
  1. PEND ; Add 1 to the pending count
  1.  S BLRPCT=$G(BLRPCT)+1
  1.  I BLRARFL=2 D RSET
  1.  Q
  1. RSET ;  Reset if signed
  1.  S BLRPFL=BLRARFL,BLRPRDT=$P(BLRADATA,U,4)
  1.  D KX^BLRALUT1
  1.  S BLRPSDT=$P(BLRADATA,U,5),BLRPSPH=$P(BLRADATA,U,3)
  1.  S BLRARFL=0,$P(BLRADATA,U,5)="",$P(BLRADATA,U,3)=""
  1.  ;I BLRPFL=2 D
  1.  ;. S BLRATXT="Changed lab results previously signed by "_$P(^VA(200,BLRPSPH,0),U,1)_" on "_$$FMTE^XLFDT(BLRPSDT)
  1.  ;. S BLRNM=$P($G(^LR(LRDFN,LRSS,LRIDT,1,0)),U,3),BLRNM=BLRNM+1
  1.  ;. S $P(^LR(LRDFN,LRSS,LRIDT,1,0),U,3,4)=BLRNM_U_BLRNM
  1.  ;. S ^LR(LRDFN,LRSS,LRIDT,1,BLRNM,0)=BLRATXT
  1.  ;. S ^LR(LRDFN,LRSS,LRIDT,1,"B",$E(BLRATXT,1,30),BLRNM)=""
  1.  Q