LRARCR2 ; IHS/DIR/AAB - CLONED WKLD REP GENERATOR-BUILD FOR ARCHIVING ; [ 5/8/95 ]
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**59**;Aug 31, 1995
;same as LRCAPR2 except archived wkld file
S:$D(ZTQUEUED) ZTREQ="@"
K ^TMP("LRAR",$J) D DATE,^LRARCR3
Q
DATE ;
I LRTO<LRFR S X=LRFR,LRFR=LRTO,LRTO=X
S LRST=LRFR-.000001
F S LRST=$O(^LRO(68,LRAA,1,LRST)) Q:'LRST!(LRST>LRTO) D
. S LRNT=0
. F S LRNT=$O(^LRO(68,LRAA,1,LRST,1,LRNT)) Q:'LRNT D ACC
Q
ACC ;
S LRACCREC=$G(^LRO(68,LRAA,1,LRST,1,LRNT,0)) Q:LRACCREC=""
S LRFIL=+$P(LRACCREC,U,2) Q:'LRFIL Q:(LRFIL>67.0)&(LRFIL<67.9999)
S LRLTYP=$P(LRACCREC,U,11)
S LRPATOK=$$CHKPAT(LRIOPAT,LRLTYP,LRFIL) Q:'+LRPATOK
S LRPTYP=$E(LRPATOK,2)
S LRLC=+$P(LRACCREC,U,13) I LRLOC Q:'$D(LRLOC(LRLC))!(LRLC<1)
S:+LRLC LRLC=$P($G(^SC(LRLC,0)),U) S:LRLC="" LRLC="*MISSING LOC*"
S LRAANO=$S($D(^LRO(68,LRAA,1,LRST,1,LRNT,.2)):^(.2),1:"NO ACCN")
S LRSTCS=$G(^LRO(68,LRAA,1,LRST,1,LRNT,5,1,0)) Q:'LRSTCS
I LRSP Q:'$P(LRSTCS,U) Q:'$D(LRSP($P(LRSTCS,U)))
I LRCOL Q:'$P(LRSTCS,U,2) Q:'$D(LRCOL($P(LRSTCS,U,2)))
S LRTST=0
F S LRTST=$O(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST)) Q:'LRTST D TEST
Q
TEST ;
I LRTSTS,'$D(LRTSTS(LRTST)) Q
Q:'$D(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,0))#2 S LRNX=^(0) Q:'$P(LRNX,U,5)
S LRNX5=$P(LRNX,U,5),LRNX5D=$P(LRNX5,"."),LRURG=$P(LRNX,U,2)
I $G(LRSTAT) Q:LRURG="" Q:'$D(LRSTAT(LRURG))#2
S LRURGNAM=$S(LRURG="":"",$D(LRSTAT(LRURG))#2:LRSTAT(LRURG),1:"")
S LRTEST=$$TST(LRTST)
S LRNX5=$S($L(LRTOV,".")=1:$P(LRNX5,"."),1:LRNX5)
S LRCPN=0 D LRCC
Q
LRCC ;
S LRCPN=$O(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,1,LRCPN)) Q:'LRCPN S LRNODE=$G(^(LRCPN,0)) G:'LRNODE LRCC
I LRSITSEL,'$D(LRSITSEL(+$P(LRNODE,U,8))) G LRCC
I LRCAPS,'$D(LRCAPS(+LRNODE)) G LRCC
S LRCAPNAM=$$WKLDNAME^LRARCU(+LRNODE)
I (LRRTYP=2)&('LRCAPFLG) G LRCC
I (LRRTYP=3)&(LRCAPFLG) G LRCC
S:(LRCAPFLG)&($E(LRTEST)'="+") LRTEST="+"_LRTEST
S LRCP=LRCAPNUM G:'LRCP LRCC
S LRDOT="."_$P(LRCP,".",2)
S LRTESTCP=$E(LRTEST_" ",1,8)_" ["_LRCP_"]"
I LRCPSX,'$D(LRCPSX(LRDOT)) G LRCC
S LRMACN=+$O(^LAB(64.2,"F",LRDOT,0))
S LRMAC=$S($L($G(^LAB(64.2,LRMACN,0))):$P(^(0),U),1:"ERROR"_LRMACN)
S:'$D(^TMP("LRAR",$J,"TST/TOT")) ^("TST/TOT")=0 S ^("TST/TOT")=^("TST/TOT")+1
S:'$D(^TMP("LRAR",$J,"TST",LRTEST)) ^(LRTEST)=0 S ^(LRTEST)=^(LRTEST)+1
S:'$D(^TMP("LRAR",$J,"TST",LRTEST,LRLC)) ^(LRLC)=0 S ^(LRLC)=^(LRLC)+1
S:'$D(^TMP("LRAR",$J,"TST",LRTEST,LRLC,LRCP)) ^(LRCP)=0 S ^(LRCP)=^(LRCP)+1,J=^(LRCP)
S ^TMP("LRAR",$J,"TST",LRTEST,LRLC,LRCP,LRAANO,(J+1))=LRNX5_U_LRMAC_U_LRURGNAM
S:'$D(^TMP("LRAR",$J,"TST/LOC",LRLC)) ^(LRLC)=0 S ^(LRLC)=^(LRLC)+1
S:'$D(^TMP("LRAR",$J,"TST/LRM",LRMAC)) ^(LRMAC)=0 S ^(LRMAC)=^(LRMAC)+1
S:'$D(^TMP("LRAR",$J,"TST/LRM",LRMAC,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1
I LRCNTL D
. S:'$D(^TMP("LRAR",$J,"TST/CTL",LRMAC)) ^(LRMAC)=0 S ^(LRMAC)=^(LRMAC)+1
. S:'$D(^TMP("LRAR",$J,"TST/CTL",LRMAC,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1
I LRURGNAM'="" D
. S:'$D(^TMP("LRAR",$J,"TST/URG",LRPTYP,LRURGNAM)) ^(LRURGNAM)=0 S ^(LRURGNAM)=^(LRURGNAM)+1
. S:'$D(^TMP("LRAR",$J,"TST/URG",LRPTYP,LRURGNAM,LRTEST)) ^(LRTEST)=0 S ^(LRTEST)=^(LRTEST)+1
. S:'$D(^TMP("LRAR",$J,"TST/URG","A",LRURGNAM)) ^(LRURGNAM)=0 S ^(LRURGNAM)=^(LRURGNAM)+1
. S:'$D(^TMP("LRAR",$J,"TST/URG","A",LRURGNAM,LRTEST)) ^(LRTEST)=0 S ^(LRTEST)=^(LRTEST)+1
S:'$D(^TMP("LRAR",$J,"DATE",LRNX5D)) ^(LRNX5D)=0 S ^(LRNX5D)=^(LRNX5D)+1
S:'$D(^TMP("LRAR",$J,"DATE",LRNX5D,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1
S:'$D(^TMP("LRAR",$J,"DAY",LRNX5D)) ^(LRNX5D)=0 S ^(LRNX5D)=^(LRNX5D)+1
S:'$D(^TMP("LRAR",$J,"DAY",LRNX5D,LRMAC)) ^(LRMAC)=0 S ^(LRMAC)=^(LRMAC)+1
S:'$D(^TMP("LRAR",$J,"DAY",LRNX5D,LRMAC,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1,J=^(LRTESTCP)
G LRCC
Q
TST(X) ; this returns the print test name otherwise the test name.
N LRDA
;tests are truncated if greater than 7 chars long
S LRDA=$G(X) Q:'LRDA "Unknown"
Q:'$D(^LAB(60,LRDA,0))#2 "Unknown"
Q:$P($G(^LAB(60,LRDA,.1)),U)'="" $P($G(^(.1)),U)
Q $S($L($P(^LAB(60,LRDA,0),U))>7:$E($P(^LAB(60,LRDA,0),U),1,6)_"*",1:$P(^LAB(60,LRDA,0),U))
CHKPAT(LRIOPAT,LRLTYP,LRFIL) ; return flag indicating if this record is for
; a patient type selected for this report and if so, what type.
S LRCNTL=$S(LRFIL=62.3:1,1:0)
I ("OW"[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["I") Q "1I" ; Inpatient
I ("OW"'[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["O") Q "1O" ; Outpatient
I (LRIOPAT["R") Q "1R" ; Other
Q 0
LRARCR2 ; IHS/DIR/AAB - CLONED WKLD REP GENERATOR-BUILD FOR ARCHIVING ; [ 5/8/95 ]
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
+3 ;same as LRCAPR2 except archived wkld file
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 KILL ^TMP("LRAR",$JOB)
DO DATE
DO ^LRARCR3
+6 QUIT
DATE ;
+1 IF LRTO<LRFR
SET X=LRFR
SET LRFR=LRTO
SET LRTO=X
+2 SET LRST=LRFR-.000001
+3 FOR
SET LRST=$ORDER(^LRO(68,LRAA,1,LRST))
IF 'LRST!(LRST>LRTO)
QUIT
Begin DoDot:1
+4 SET LRNT=0
+5 FOR
SET LRNT=$ORDER(^LRO(68,LRAA,1,LRST,1,LRNT))
IF 'LRNT
QUIT
DO ACC
End DoDot:1
+6 QUIT
ACC ;
+1 SET LRACCREC=$GET(^LRO(68,LRAA,1,LRST,1,LRNT,0))
IF LRACCREC=""
QUIT
+2 SET LRFIL=+$PIECE(LRACCREC,U,2)
IF 'LRFIL
QUIT
IF (LRFIL>67.0)&(LRFIL<67.9999)
QUIT
+3 SET LRLTYP=$PIECE(LRACCREC,U,11)
+4 SET LRPATOK=$$CHKPAT(LRIOPAT,LRLTYP,LRFIL)
IF '+LRPATOK
QUIT
+5 SET LRPTYP=$EXTRACT(LRPATOK,2)
+6 SET LRLC=+$PIECE(LRACCREC,U,13)
IF LRLOC
IF '$DATA(LRLOC(LRLC))!(LRLC<1)
QUIT
+7 IF +LRLC
SET LRLC=$PIECE($GET(^SC(LRLC,0)),U)
IF LRLC=""
SET LRLC="*MISSING LOC*"
+8 SET LRAANO=$SELECT($DATA(^LRO(68,LRAA,1,LRST,1,LRNT,.2)):^(.2),1:"NO ACCN")
+9 SET LRSTCS=$GET(^LRO(68,LRAA,1,LRST,1,LRNT,5,1,0))
IF 'LRSTCS
QUIT
+10 IF LRSP
IF '$PIECE(LRSTCS,U)
QUIT
IF '$DATA(LRSP($PIECE(LRSTCS,U)))
QUIT
+11 IF LRCOL
IF '$PIECE(LRSTCS,U,2)
QUIT
IF '$DATA(LRCOL($PIECE(LRSTCS,U,2)))
QUIT
+12 SET LRTST=0
+13 FOR
SET LRTST=$ORDER(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST))
IF 'LRTST
QUIT
DO TEST
+14 QUIT
TEST ;
+1 IF LRTSTS
IF '$DATA(LRTSTS(LRTST))
QUIT
+2 IF '$DATA(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,0))#2
QUIT
SET LRNX=^(0)
IF '$PIECE(LRNX,U,5)
QUIT
+3 SET LRNX5=$PIECE(LRNX,U,5)
SET LRNX5D=$PIECE(LRNX5,".")
SET LRURG=$PIECE(LRNX,U,2)
+4 IF $GET(LRSTAT)
IF LRURG=""
QUIT
IF '$DATA(LRSTAT(LRURG))#2
QUIT
+5 SET LRURGNAM=$SELECT(LRURG="":"",$DATA(LRSTAT(LRURG))#2:LRSTAT(LRURG),1:"")
+6 SET LRTEST=$$TST(LRTST)
+7 SET LRNX5=$SELECT($LENGTH(LRTOV,".")=1:$PIECE(LRNX5,"."),1:LRNX5)
+8 SET LRCPN=0
DO LRCC
+9 QUIT
LRCC ;
+1 SET LRCPN=$ORDER(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,1,LRCPN))
IF 'LRCPN
QUIT
SET LRNODE=$GET(^(LRCPN,0))
IF 'LRNODE
GOTO LRCC
+2 IF LRSITSEL
IF '$DATA(LRSITSEL(+$PIECE(LRNODE,U,8)))
GOTO LRCC
+3 IF LRCAPS
IF '$DATA(LRCAPS(+LRNODE))
GOTO LRCC
+4 SET LRCAPNAM=$$WKLDNAME^LRARCU(+LRNODE)
+5 IF (LRRTYP=2)&('LRCAPFLG)
GOTO LRCC
+6 IF (LRRTYP=3)&(LRCAPFLG)
GOTO LRCC
+7 IF (LRCAPFLG)&($EXTRACT(LRTEST)'="+")
SET LRTEST="+"_LRTEST
+8 SET LRCP=LRCAPNUM
IF 'LRCP
GOTO LRCC
+9 SET LRDOT="."_$PIECE(LRCP,".",2)
+10 SET LRTESTCP=$EXTRACT(LRTEST_" ",1,8)_" ["_LRCP_"]"
+11 IF LRCPSX
IF '$DATA(LRCPSX(LRDOT))
GOTO LRCC
+12 SET LRMACN=+$ORDER(^LAB(64.2,"F",LRDOT,0))
+13 SET LRMAC=$SELECT($LENGTH($GET(^LAB(64.2,LRMACN,0))):$PIECE(^(0),U),1:"ERROR"_LRMACN)
+14 IF '$DATA(^TMP("LRAR",$JOB,"TST/TOT"))
SET ^("TST/TOT")=0
SET ^("TST/TOT")=^("TST/TOT")+1
+15 IF '$DATA(^TMP("LRAR",$JOB,"TST",LRTEST))
SET ^(LRTEST)=0
SET ^(LRTEST)=^(LRTEST)+1
+16 IF '$DATA(^TMP("LRAR",$JOB,"TST",LRTEST,LRLC))
SET ^(LRLC)=0
SET ^(LRLC)=^(LRLC)+1
+17 IF '$DATA(^TMP("LRAR",$JOB,"TST",LRTEST,LRLC,LRCP))
SET ^(LRCP)=0
SET ^(LRCP)=^(LRCP)+1
SET J=^(LRCP)
+18 SET ^TMP("LRAR",$JOB,"TST",LRTEST,LRLC,LRCP,LRAANO,(J+1))=LRNX5_U_LRMAC_U_LRURGNAM
+19 IF '$DATA(^TMP("LRAR",$JOB,"TST/LOC",LRLC))
SET ^(LRLC)=0
SET ^(LRLC)=^(LRLC)+1
+20 IF '$DATA(^TMP("LRAR",$JOB,"TST/LRM",LRMAC))
SET ^(LRMAC)=0
SET ^(LRMAC)=^(LRMAC)+1
+21 IF '$DATA(^TMP("LRAR",$JOB,"TST/LRM",LRMAC,LRTESTCP))
SET ^(LRTESTCP)=0
SET ^(LRTESTCP)=^(LRTESTCP)+1
+22 IF LRCNTL
Begin DoDot:1
+23 IF '$DATA(^TMP("LRAR",$JOB,"TST/CTL",LRMAC))
SET ^(LRMAC)=0
SET ^(LRMAC)=^(LRMAC)+1
+24 IF '$DATA(^TMP("LRAR",$JOB,"TST/CTL",LRMAC,LRTESTCP))
SET ^(LRTESTCP)=0
SET ^(LRTESTCP)=^(LRTESTCP)+1
End DoDot:1
+25 IF LRURGNAM'=""
Begin DoDot:1
+26 IF '$DATA(^TMP("LRAR",$JOB,"TST/URG",LRPTYP,LRURGNAM))
SET ^(LRURGNAM)=0
SET ^(LRURGNAM)=^(LRURGNAM)+1
+27 IF '$DATA(^TMP("LRAR",$JOB,"TST/URG",LRPTYP,LRURGNAM,LRTEST))
SET ^(LRTEST)=0
SET ^(LRTEST)=^(LRTEST)+1
+28 IF '$DATA(^TMP("LRAR",$JOB,"TST/URG","A",LRURGNAM))
SET ^(LRURGNAM)=0
SET ^(LRURGNAM)=^(LRURGNAM)+1
+29 IF '$DATA(^TMP("LRAR",$JOB,"TST/URG","A",LRURGNAM,LRTEST))
SET ^(LRTEST)=0
SET ^(LRTEST)=^(LRTEST)+1
End DoDot:1
+30 IF '$DATA(^TMP("LRAR",$JOB,"DATE",LRNX5D))
SET ^(LRNX5D)=0
SET ^(LRNX5D)=^(LRNX5D)+1
+31 IF '$DATA(^TMP("LRAR",$JOB,"DATE",LRNX5D,LRTESTCP))
SET ^(LRTESTCP)=0
SET ^(LRTESTCP)=^(LRTESTCP)+1
+32 IF '$DATA(^TMP("LRAR",$JOB,"DAY",LRNX5D))
SET ^(LRNX5D)=0
SET ^(LRNX5D)=^(LRNX5D)+1
+33 IF '$DATA(^TMP("LRAR",$JOB,"DAY",LRNX5D,LRMAC))
SET ^(LRMAC)=0
SET ^(LRMAC)=^(LRMAC)+1
+34 IF '$DATA(^TMP("LRAR",$JOB,"DAY",LRNX5D,LRMAC,LRTESTCP))
SET ^(LRTESTCP)=0
SET ^(LRTESTCP)=^(LRTESTCP)+1
SET J=^(LRTESTCP)
+35 GOTO LRCC
+36 QUIT
TST(X) ; this returns the print test name otherwise the test name.
+1 NEW LRDA
+2 ;tests are truncated if greater than 7 chars long
+3 SET LRDA=$GET(X)
IF 'LRDA
QUIT "Unknown"
+4 IF '$DATA(^LAB(60,LRDA,0))#2
QUIT "Unknown"
+5 IF $PIECE($GET(^LAB(60,LRDA,.1)),U)'=""
QUIT $PIECE($GET(^(.1)),U)
+6 QUIT $SELECT($LENGTH($PIECE(^LAB(60,LRDA,0),U))>7:$EXTRACT($PIECE(^LAB(60,LRDA,0),U),1,6)_"*",1:$PIECE(^LAB(60,LRDA,0),U))
CHKPAT(LRIOPAT,LRLTYP,LRFIL) ; return flag indicating if this record is for
+1 ; a patient type selected for this report and if so, what type.
+2 SET LRCNTL=$SELECT(LRFIL=62.3:1,1:0)
+3 ; Inpatient
IF ("OW"[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["I")
QUIT "1I"
+4 ; Outpatient
IF ("OW"'[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["O")
QUIT "1O"
+5 ; Other
IF (LRIOPAT["R")
QUIT "1R"
+6 QUIT 0
