BLRSORC ; IHS/DIR/FJE - CRITICAL VALUE TASKED REPORT 8/30/87 17:25 ;
;;5.2;LR;**1038**;NOV 01, 1997;Build 6
;
EEP ; EP - Ersatz EP
D EEP^BLRGMENU
Q
;
; Cloned from the VA Patch LR*5.2*84 LRSORC routine.
;
BEGIN ; EP - Beginning
I $D(ZTQUEUED)<1 D Q
. W !!,?4,"This report can only be run from TASKMAN."
. D PRESSKEY^BLRGMENU(9)
;
GETPARAM ; EP - Get the parameters from the IHS LAB SUPERVISOR TASKED REPORTS PARAMETERS (#90475.7) file
S (GPD0,GPD1)=1
D OPTIONS
D DEVICE
I LREND D END^LRSORC1A Q
Q
;
OPTIONS ;
D GDR,GAA,SORTBY,SELPAT,SELLOC
Q
;
GDR ; EP - Get Date Range from 90475.7
NEW DTRANGE,GOBACK
;
S DTRANGE=+$$GET1^DIQ(90475.73,GPD1_","_GPD0,"Date Range","I")
S GOBACK=$S(DTRANGE=1:7,DTRANGE=2:30,DTRANGE=3:365,1:1)
S LREDT=$$HTFM^XLFDT(+$H-GOBACK)
S LRSDT=$$DT^XLFDT_".5"
Q
;
GAA ; EP - Get Accession Areas from 90475.7, if they exist
NEW GAAD2,GLRAA,GLRAAAB
;
S LRAA=0
Q:$D(^BLRLSRP(GPD0,3,GPD1,1,0))<1
;
S GAAD2=0
F S GAAD2=$O(^BLRLSRP(GPD0,3,GPD1,1,GAAD2)) Q:GAAD2<1 D
. S GLRAA=$G(^BLRLSRP(GPD0,3,GPD1,1,GAAD2,0))
. S GLRAAAB=$$GET1^DIQ(68,GLRAA,"ABBREVIATION")
. Q:$L(GLRAAAB)<1
. ;
. S LRAA(GLRAAAB)=GLRAA
. S LRAA=GLRAA
;
Q
;
SORTBY ; EP - Determine SORT BY parameter
NEW SORTBY
;
S SORTBY=$P($G(^BLRLSRP(GPD0,3,GPD1,3)),U)
S LRSRT=$S($L(SORTBY):SORTBY,1:"P")
Q
;
SELPAT ; EP - ALL Patients by default
S LRPTS=0
Q
;
SELLOC ; EP - Get Locations from 90475.7, if they exist
S LRLCS=0
Q:$D(^BLRLSRP(GPD0,3,GPD1,2,0))<1 ; Retrun if no entries
;
NEW LOCIEN,LOCSUB,LOCSUBAB,CNTLOC
;
S (CNTLOC,LOCSUB)=0
F S LOCSUB=$O(^BLRLSRP(GPD0,3,GPD1,2,LOCSUB)) Q:LOCSUB<1 D
. S LOCIEN=(^BLRLSRP(GPD0,3,GPD1,2,LOCSUB,0))
. S LOCSUBAB=$$GET1^DIQ(44,LOCIEN,"ABBREVIATION")
. Q:$L(LOCSUBAB)<1
. ;
. S CNTLOC=CNTLOC+1
. S LRLCS=CNTLOC
. S LRLCS(LOCSUBAB)=LOCIEN
I $G(LRLCS) S LRLCS("NO ABRV")=""
Q
;
DEVICE ;
S IOP="`"_$P($G(^BLRLSRP(GPD0,3,GPD1,3)),U,2)
S %ZIS="Q"
S ZTSAVE("LR*")=""
D EN^XUTMDEVQ("DQ^BLRSORC","TASKED IHS LAB CRITICAL VALUE REPORT",.ZTSAVE,.%ZIS)
S LREND=1
Q
;
DQ ;
K ^TMP("LR",$J)
S:$D(ZTQUEUED) ZTREQ="@" U IO
S (LRPAG,LREND)=0,$P(LRDASH,"-",IOM)="-"
K %DT S X="N",%DT="T" D ^%DT,DD^LRX S LRDATE=Y
K %DT S X=$P(LRSDT,"."),%DT="X" D ^%DT,DD^LRX S LRSDAT=Y
K %DT S X=LREDT,%DT="X" D ^%DT,DD^LRX S LREDAT=Y
S LRHDR2="For date range: "_LREDAT_" to "_LRSDAT
D BUILD^LRSORC1
D ^LRSORC1A
QUIT
BLRSORC ; IHS/DIR/FJE - CRITICAL VALUE TASKED REPORT 8/30/87 17:25 ;
+1 ;;5.2;LR;**1038**;NOV 01, 1997;Build 6
+2 ;
EEP ; EP - Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ; Cloned from the VA Patch LR*5.2*84 LRSORC routine.
+5 ;
BEGIN ; EP - Beginning
+1 IF $DATA(ZTQUEUED)<1
Begin DoDot:1
+2 WRITE !!,?4,"This report can only be run from TASKMAN."
+3 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+4 ;
GETPARAM ; EP - Get the parameters from the IHS LAB SUPERVISOR TASKED REPORTS PARAMETERS (#90475.7) file
+1 SET (GPD0,GPD1)=1
+2 DO OPTIONS
+3 DO DEVICE
+4 IF LREND
DO END^LRSORC1A
QUIT
+5 QUIT
+6 ;
OPTIONS ;
+1 DO GDR
DO GAA
DO SORTBY
DO SELPAT
DO SELLOC
+2 QUIT
+3 ;
GDR ; EP - Get Date Range from 90475.7
+1 NEW DTRANGE,GOBACK
+2 ;
+3 SET DTRANGE=+$$GET1^DIQ(90475.73,GPD1_","_GPD0,"Date Range","I")
+4 SET GOBACK=$SELECT(DTRANGE=1:7,DTRANGE=2:30,DTRANGE=3:365,1:1)
+5 SET LREDT=$$HTFM^XLFDT(+$HOROLOG-GOBACK)
+6 SET LRSDT=$$DT^XLFDT_".5"
+7 QUIT
+8 ;
GAA ; EP - Get Accession Areas from 90475.7, if they exist
+1 NEW GAAD2,GLRAA,GLRAAAB
+2 ;
+3 SET LRAA=0
+4 IF $DATA(^BLRLSRP(GPD0,3,GPD1,1,0))<1
QUIT
+5 ;
+6 SET GAAD2=0
+7 FOR
SET GAAD2=$ORDER(^BLRLSRP(GPD0,3,GPD1,1,GAAD2))
IF GAAD2<1
QUIT
Begin DoDot:1
+8 SET GLRAA=$GET(^BLRLSRP(GPD0,3,GPD1,1,GAAD2,0))
+9 SET GLRAAAB=$$GET1^DIQ(68,GLRAA,"ABBREVIATION")
+10 IF $LENGTH(GLRAAAB)<1
QUIT
+11 ;
+12 SET LRAA(GLRAAAB)=GLRAA
+13 SET LRAA=GLRAA
End DoDot:1
+14 ;
+15 QUIT
+16 ;
SORTBY ; EP - Determine SORT BY parameter
+1 NEW SORTBY
+2 ;
+3 SET SORTBY=$PIECE($GET(^BLRLSRP(GPD0,3,GPD1,3)),U)
+4 SET LRSRT=$SELECT($LENGTH(SORTBY):SORTBY,1:"P")
+5 QUIT
+6 ;
SELPAT ; EP - ALL Patients by default
+1 SET LRPTS=0
+2 QUIT
+3 ;
SELLOC ; EP - Get Locations from 90475.7, if they exist
+1 SET LRLCS=0
+2 ; Retrun if no entries
IF $DATA(^BLRLSRP(GPD0,3,GPD1,2,0))<1
QUIT
+3 ;
+4 NEW LOCIEN,LOCSUB,LOCSUBAB,CNTLOC
+5 ;
+6 SET (CNTLOC,LOCSUB)=0
+7 FOR
SET LOCSUB=$ORDER(^BLRLSRP(GPD0,3,GPD1,2,LOCSUB))
IF LOCSUB<1
QUIT
Begin DoDot:1
+8 SET LOCIEN=(^BLRLSRP(GPD0,3,GPD1,2,LOCSUB,0))
+9 SET LOCSUBAB=$$GET1^DIQ(44,LOCIEN,"ABBREVIATION")
+10 IF $LENGTH(LOCSUBAB)<1
QUIT
+11 ;
+12 SET CNTLOC=CNTLOC+1
+13 SET LRLCS=CNTLOC
+14 SET LRLCS(LOCSUBAB)=LOCIEN
End DoDot:1
+15 IF $GET(LRLCS)
SET LRLCS("NO ABRV")=""
+16 QUIT
+17 ;
DEVICE ;
+1 SET IOP="`"_$PIECE($GET(^BLRLSRP(GPD0,3,GPD1,3)),U,2)
+2 SET %ZIS="Q"
+3 SET ZTSAVE("LR*")=""
+4 DO EN^XUTMDEVQ("DQ^BLRSORC","TASKED IHS LAB CRITICAL VALUE REPORT",.ZTSAVE,.%ZIS)
+5 SET LREND=1
+6 QUIT
+7 ;
DQ ;
+1 KILL ^TMP("LR",$JOB)
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
+3 SET (LRPAG,LREND)=0
SET $PIECE(LRDASH,"-",IOM)="-"
+4 KILL %DT
SET X="N"
SET %DT="T"
DO ^%DT
DO DD^LRX
SET LRDATE=Y
+5 KILL %DT
SET X=$PIECE(LRSDT,".")
SET %DT="X"
DO ^%DT
DO DD^LRX
SET LRSDAT=Y
+6 KILL %DT
SET X=LREDT
SET %DT="X"
DO ^%DT
DO DD^LRX
SET LREDAT=Y
+7 SET LRHDR2="For date range: "_LREDAT_" to "_LRSDAT
+8 DO BUILD^LRSORC1
+9 DO ^LRSORC1A
+10 QUIT
