BLRALBL ;DAOU/ALA-Build list data for ListMan
;;5.2T9;LR;**1013,1015,1018**;Nov 17, 2004
;;5.2;LR;**1013,1015**;Nov 18, 2002
;
;**Program Description**
; Go through the cross-reference and build an
; array for ListMan
;
; Input Parameter
; DUZ = User IEN
;
SELF ; Get result for self
K ^TMP("BLRA",$J) S BLRAHDR="*** MAIN SCREEN ***"
S BLRADUZ=DUZ D FND
;
TSUR ; Check for temporary surrogates
; A temporary surrogate had a date range limit
;
; Parameters
; BSTDT = Start Date
; BENDT = End Date
;
S BLRADUZ=""
F S BLRADUZ=$O(^BLRALAB(9009027.1,"AB",DUZ,BLRADUZ)) Q:BLRADUZ="" D
. S BSTDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)
. S BENDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)
. I BENDT=""!(BSTDT="") Q
. I DT'<BSTDT&(DT'>BENDT) D FND
;
PSUR ;EP - Left in for Chinle site which may still have perm surrogates
; Change for issue #12 ejn - 3/22/02
; Check for permanent surrogates
;K ^TMP("BLRA",$J) S BLRAHDR="***OTHER PROVIDERS***"
S BLRADUZ=""
F S BLRADUZ=$O(^BLRALAB(9009027.1,"AB",DUZ,BLRADUZ)) Q:BLRADUZ="" D
. S BSTDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)
. S BENDT=$P($G(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)
. I BSTDT=""&(BENDT="") D FND
Q
;
FND ; Find results
;
; Parameters
; BLRADUZ = Provider IEN
; BLRAS = Result Status
; BLRVD = Negative Reverse Date
; BLRAP = Lab Patient IEN
; BLRIDT = Reverse Date
; BLRSS = Lab Accession Subscript
; BLRADATA = Lab ES Data
; BLRAAB = Number of abnormal results
; BLRAPD = Number of pending results
; BLRADTT = Lab Accession Collection Date/time
; BLRAOPH = Ordering Provider
; BLRARPHY = Responsible Provider
; BLRACCN = Accession Number
; BLRAPFL = Lab Patient File Number
; BLRAPIEN = Patient IEN
; BLRAPNM = Patient Name
;
S BLRAS=""
F S BLRAS=$O(^LR("BLRA",BLRADUZ,BLRAS)) Q:BLRAS=2!(BLRAS="") D
. S BLRVD=""
. F S BLRVD=$O(^LR("BLRA",BLRADUZ,BLRAS,BLRVD)) Q:BLRVD="" D
.. S BLRIDT=$P(BLRVD,"-",2)
.. S BLRAP=""
.. F S BLRAP=$O(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP)) Q:BLRAP="" D
... ;S BLRIDT=$P(BLRVD,"-",2),BLRSS=$G(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP))
...;----- BEGIN IHS MODIFICATIONS LR*5.2
...S BLRSS=""
...F S BLRSS=$O(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP,BLRSS)) Q:BLRSS="" D
....;W !,BLRVD," ",BLRAP," ",BLRSS
....;S BLRIDT=$P(BLRVD,"-",2)
....;----- END IHS MODIFICATIONS
.... S BLRA0=$G(^LR(BLRAP,BLRSS,BLRIDT,0))
.... ;
.... S BLRADATA=$G(^LR(BLRAP,BLRSS,BLRIDT,9009027))
.... Q:BLRADATA="" ;IHS/ITSC/TPF IF NO DATA DON'T PROCESS 07/23/2002
.... ;W !,BLRVD," ",BLRAP," ",BLRSS
.... S BLRAAB=+$P(BLRADATA,U,6),BLRAPD=+$P(BLRADATA,U,7)
.... S BLRCRTL=+$P(BLRADATA,U,8),BLRARPHY=$P(BLRADATA,U,2)
.... S BLRRCT=+$P(BLRADATA,U,9)
.... ;
.... S BLRADTT=$P(BLRA0,U,1),BLRAOPH=$P(BLRA0,U,$S(BLRSS="MI":7,1:10))
.... S BLRACCN=$P(BLRA0,U,6)
.... S BLRAPFL=$P($G(^LR(BLRAP,0)),U,2),BLRAPIEN=$P(^(0),U,3)
.... S BLRAPNM=$$GET1^DIQ(BLRAPFL,BLRAPIEN,.01,"E")
.... ;
.... S BLRASTAT=$S(BLRCRTL'=0:"CRIT",BLRAAB'=0:"ABN",BLRRCT'=0:"N/A",1:"NOR"),BLRASTA=BLRASTAT
.... I BLRASTAT="CRIT" S BLRASTAT="AA"
.... ;
.... I $G(BLRASRT)="" D
..... ;S ^TMP("BLRA",$J,BLRASTAT,BLRVD,BLRAP)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")
..... ;----- BEGIN IHS MODIFICATIONS LR*5.2
..... S ^TMP("BLRA",$J,BLRASTAT,BLRVD,BLRAP,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")
..... ;----- END IHS MODIFICATIONS
..... Q:$G(BLRACCN)="" ;IHS/ITSC/TPF 03/26/02 TEMPORARY FIX PER CNR (CARL RANDALL MITRTEK)
..... S ^TMP("BLRA",$J,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT
....;
.... I $G(BLRASRT)="P" D
..... S ^TMP("BLRA",$J,BLRAPNM,BLRASTAT,BLRVD,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")
..... S ^TMP("BLRA",$J,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT
Q
;
CSUP ;EP
; Check for all subordinates of a Clinician Supervisor
K ^TMP("BLRA",$J) S BLRAHDR="***SUBORDINATE PROVIDERS***"
S BLRADUZ=""
F S BLRADUZ=$O(^BLRALAB(9009027.1,"C",DUZ,BLRADUZ)) Q:BLRADUZ="" D FND
Q
;
PATS ;EP
; Patient sort
S BLRASRT="P"
D SELF
Q
BLRALBL ;DAOU/ALA-Build list data for ListMan
+1 ;;5.2T9;LR;**1013,1015,1018**;Nov 17, 2004
+2 ;;5.2;LR;**1013,1015**;Nov 18, 2002
+3 ;
+4 ;**Program Description**
+5 ; Go through the cross-reference and build an
+6 ; array for ListMan
+7 ;
+8 ; Input Parameter
+9 ; DUZ = User IEN
+10 ;
SELF ; Get result for self
+1 KILL ^TMP("BLRA",$JOB)
SET BLRAHDR="*** MAIN SCREEN ***"
+2 SET BLRADUZ=DUZ
DO FND
+3 ;
TSUR ; Check for temporary surrogates
+1 ; A temporary surrogate had a date range limit
+2 ;
+3 ; Parameters
+4 ; BSTDT = Start Date
+5 ; BENDT = End Date
+6 ;
+7 SET BLRADUZ=""
+8 FOR
SET BLRADUZ=$ORDER(^BLRALAB(9009027.1,"AB",DUZ,BLRADUZ))
IF BLRADUZ=""
QUIT
Begin DoDot:1
+9 SET BSTDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)
+10 SET BENDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)
+11 IF BENDT=""!(BSTDT="")
QUIT
+12 IF DT'<BSTDT&(DT'>BENDT)
DO FND
End DoDot:1
+13 ;
PSUR ;EP - Left in for Chinle site which may still have perm surrogates
+1 ; Change for issue #12 ejn - 3/22/02
+2 ; Check for permanent surrogates
+3 ;K ^TMP("BLRA",$J) S BLRAHDR="***OTHER PROVIDERS***"
+4 SET BLRADUZ=""
+5 FOR
SET BLRADUZ=$ORDER(^BLRALAB(9009027.1,"AB",DUZ,BLRADUZ))
IF BLRADUZ=""
QUIT
Begin DoDot:1
+6 SET BSTDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,2)
+7 SET BENDT=$PIECE($GET(^BLRALAB(9009027.1,BLRADUZ,1,DUZ,0)),U,3)
+8 IF BSTDT=""&(BENDT="")
DO FND
End DoDot:1
+9 QUIT
+10 ;
FND ; Find results
+1 ;
+2 ; Parameters
+3 ; BLRADUZ = Provider IEN
+4 ; BLRAS = Result Status
+5 ; BLRVD = Negative Reverse Date
+6 ; BLRAP = Lab Patient IEN
+7 ; BLRIDT = Reverse Date
+8 ; BLRSS = Lab Accession Subscript
+9 ; BLRADATA = Lab ES Data
+10 ; BLRAAB = Number of abnormal results
+11 ; BLRAPD = Number of pending results
+12 ; BLRADTT = Lab Accession Collection Date/time
+13 ; BLRAOPH = Ordering Provider
+14 ; BLRARPHY = Responsible Provider
+15 ; BLRACCN = Accession Number
+16 ; BLRAPFL = Lab Patient File Number
+17 ; BLRAPIEN = Patient IEN
+18 ; BLRAPNM = Patient Name
+19 ;
+20 SET BLRAS=""
+21 FOR
SET BLRAS=$ORDER(^LR("BLRA",BLRADUZ,BLRAS))
IF BLRAS=2!(BLRAS="")
QUIT
Begin DoDot:1
+22 SET BLRVD=""
+23 FOR
SET BLRVD=$ORDER(^LR("BLRA",BLRADUZ,BLRAS,BLRVD))
IF BLRVD=""
QUIT
Begin DoDot:2
+24 SET BLRIDT=$PIECE(BLRVD,"-",2)
+25 SET BLRAP=""
+26 FOR
SET BLRAP=$ORDER(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP))
IF BLRAP=""
QUIT
Begin DoDot:3
+27 ;S BLRIDT=$P(BLRVD,"-",2),BLRSS=$G(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP))
+28 ;----- BEGIN IHS MODIFICATIONS LR*5.2
+29 SET BLRSS=""
+30 FOR
SET BLRSS=$ORDER(^LR("BLRA",BLRADUZ,BLRAS,BLRVD,BLRAP,BLRSS))
IF BLRSS=""
QUIT
Begin DoDot:4
+31 ;W !,BLRVD," ",BLRAP," ",BLRSS
+32 ;S BLRIDT=$P(BLRVD,"-",2)
+33 ;----- END IHS MODIFICATIONS
+34 SET BLRA0=$GET(^LR(BLRAP,BLRSS,BLRIDT,0))
+35 ;
+36 SET BLRADATA=$GET(^LR(BLRAP,BLRSS,BLRIDT,9009027))
+37 ;IHS/ITSC/TPF IF NO DATA DON'T PROCESS 07/23/2002
IF BLRADATA=""
QUIT
+38 ;W !,BLRVD," ",BLRAP," ",BLRSS
+39 SET BLRAAB=+$PIECE(BLRADATA,U,6)
SET BLRAPD=+$PIECE(BLRADATA,U,7)
+40 SET BLRCRTL=+$PIECE(BLRADATA,U,8)
SET BLRARPHY=$PIECE(BLRADATA,U,2)
+41 SET BLRRCT=+$PIECE(BLRADATA,U,9)
+42 ;
+43 SET BLRADTT=$PIECE(BLRA0,U,1)
SET BLRAOPH=$PIECE(BLRA0,U,$SELECT(BLRSS="MI":7,1:10))
+44 SET BLRACCN=$PIECE(BLRA0,U,6)
+45 SET BLRAPFL=$PIECE($GET(^LR(BLRAP,0)),U,2)
SET BLRAPIEN=$PIECE(^(0),U,3)
+46 SET BLRAPNM=$$GET1^DIQ(BLRAPFL,BLRAPIEN,.01,"E")
+47 ;
+48 SET BLRASTAT=$SELECT(BLRCRTL'=0:"CRIT",BLRAAB'=0:"ABN",BLRRCT'=0:"N/A",1:"NOR")
SET BLRASTA=BLRASTAT
+49 IF BLRASTAT="CRIT"
SET BLRASTAT="AA"
+50 ;
+51 IF $GET(BLRASRT)=""
Begin DoDot:5
+52 ;S ^TMP("BLRA",$J,BLRASTAT,BLRVD,BLRAP)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$S(BLRAPD=0:"YES",1:"PEND")
+53 ;----- BEGIN IHS MODIFICATIONS LR*5.2
+54 SET ^TMP("BLRA",$JOB,BLRASTAT,BLRVD,BLRAP,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$SELECT(BLRAPD=0:"YES",1:"PEND")
+55 ;----- END IHS MODIFICATIONS
+56 ;IHS/ITSC/TPF 03/26/02 TEMPORARY FIX PER CNR (CARL RANDALL MITRTEK)
IF $GET(BLRACCN)=""
QUIT
+57 SET ^TMP("BLRA",$JOB,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT
End DoDot:5
+58 ;
+59 IF $GET(BLRASRT)="P"
Begin DoDot:5
+60 SET ^TMP("BLRA",$JOB,BLRAPNM,BLRASTAT,BLRVD,BLRSS)=BLRACCN_U_BLRAPNM_U_BLRADTT_U_BLRARPHY_U_BLRASTA_U_$SELECT(BLRAPD=0:"YES",1:"PEND")
+61 SET ^TMP("BLRA",$JOB,"ZNODE",BLRACCN)=BLRAP_U_BLRSS_U_BLRIDT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+62 QUIT
+63 ;
CSUP ;EP
+1 ; Check for all subordinates of a Clinician Supervisor
+2 KILL ^TMP("BLRA",$JOB)
SET BLRAHDR="***SUBORDINATE PROVIDERS***"
+3 SET BLRADUZ=""
+4 FOR
SET BLRADUZ=$ORDER(^BLRALAB(9009027.1,"C",DUZ,BLRADUZ))
IF BLRADUZ=""
QUIT
DO FND
+5 QUIT
+6 ;
PATS ;EP
+1 ; Patient sort
+2 SET BLRASRT="P"
+3 DO SELF
+4 QUIT
