LRRP5 ;DALOI/JBM/WTY - COLLECTION REPORT ;9/22/00 [ 04/14/2003 1:20 PM ]
;;5.2T9;LR;**1003,1006,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**121,201,248**;Sep 27, 1994
;
;Reference to ^%DT supported by IA #10003
;Reference to ^%ZIS supported by IA #10086
;Reference to ^%ZISC supported by IA #10089
;Reference to ^%ZTLOAD supported by IA #10063
;Reference to ^DIC supported by IA #10006
;Reference to ^DIR supported by IA #10026
;
EN ;
S LREND=0
S DIR(0)="69.01,4",DIR("A")="Type of collection for report? "
S DIR("B")="SEND PATIENT"
D ^DIR
I ($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) S LREND=1 G WRAPUP
S LRRCTYP=Y,LRRCNAM=Y(0)
DATE ;
S %DT="AEX",%DT("A")="Date ordered? : "
D ^%DT I (X=U)!(X="") S LREND=1 G WRAPUP
S LRODT=Y,LRODAT=$$Y2K^LRX(LRODT)
REPTYP ;
W !,"REPORT selection: "
K DIR,X,Y S DIR(0)="S^1:Detailed report;2:Summary report"
D ^DIR
I ($D(DTOUT))!($D(DUOUT)) S LREND=1 G WRAPUP
S LRRPT=+X
DEVICE ;
K IOP,IO("Q") S %ZIS="QP" D ^%ZIS
I POP S LREND=1 G WRAPUP
I $D(IO("Q")) D QUE S LREND=1 G WRAPUP
DQ ;
D INIT
D PROCESS
D CNTSUM
D PRINT^LRRP5A
D WRAPUP
Q
INIT ;
S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J) U IO
S LRDAT=$$Y2K^LRX(DT),(LRPAG,LREND)=0
Q
PROCESS ;For ea. specimen on date selected
; If collection type = requested type
; Get patient name & SSN,order#,collection sample & ordering location
; Store by patient,ssn,order#,collection sample
S LRSN=0
F S LRSN=$O(^LRO(69,LRODT,1,LRSN)) Q:'+LRSN D
.S LRREC=$G(^LRO(69,LRODT,1,LRSN,0)) Q:LRREC=""
.S LRDFN=$P(LRREC,U),LRCTYP=$P(LRREC,U,4),LRLOC=$P(LRREC,U,9)
.Q:(LRDFN="")!(LRRCTYP'=LRCTYP)!(LRLOC="")
.;name/ssn
.S DIC=63,DIC(0)="NXZ",X="`"_LRDFN D ^DIC Q:Y=-1
.S LRDPF=$P(Y(0),U,2),DFN=$P(Y(0),U,3) Q:DFN="" D PT^LRX Q:PNM=""
.;S LRPAT=PNM,LRSSN=SSN S:LRSSN="" LRSSN="NO ENTRY"
.;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
.S LRPAT=PNM,LRSSN=HRCN S:LRSSN="" LRSSN="NO ENTRY" ;IHS/ANMC/CLS 08/18/96
.;----- END IHS MODIFICATIONS
.;order#
.S LRORD=$G(^LRO(69,LRODT,1,LRSN,.1)) Q:LRORD=""
.S LRCLCTD=$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)
.;collection sample
.S LRCS=$P($G(^LRO(69,LRODT,1,LRSN,0)),U,3) Q:LRCS=""
.S DIC=62,DIC(0)="NXZ",X="`"_LRCS D ^DIC Q:Y=-1
.S LRCS1=$P(Y(0),U)
.;location
.S DIC=44,DIC(0)="NXZ",X="`"_LRLOC D ^DIC Q:Y=-1
.S LRLOC=$S(+$L($P(Y(0),U,2)):$P(Y(0),U,2),1:$P(Y,U,2))
.I LRCLCTD="C" D
..S LRCLCTD="[C]"
..S $P(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN,0),U)=1
.E D
..S LRCLCTD=" "
..S $P(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN,0),U,2)=1
.S LRTNN=+$G(^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0))
.; For ea. test
.; Get name & urgency
.; store by patient,ssn,order#,spec,test#
.S LRTN=0
.F S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'+LRTN D
..S LRREC=$G(^LRO(69,LRODT,1,LRSN,2,LRTN,0)) Q:LRREC="" Q:$P(LRREC,"^",11)
..S DIC=60,DIC(0)="NXZ",X="`"_$P(LRREC,U) D ^DIC Q:Y=-1
..S LRTST=$P(Y,U,2),LRIFN=+Y,LRPNAM=$P($G(^LAB(60,LRIFN,.1)),U)
..S:LRPNAM'="" LRTST=LRPNAM
..S LRTST=$E(LRTST,1,7)
..S DIC=62.05,DIC(0)="NXZ",X="`"_$P(LRREC,U,2) D ^DIC Q:Y=-1
..S LRTST=LRTST_"("_$E($P(Y,U,2),1)_")"
..S LRTNN=LRTNN+1,^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,LRTNN)=LRTST
.S ^TMP($J,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0)=LRTNN_U_LRLOC_U_LRCLCTD
Q
CNTSUM ;
N LRC,LRU,LRP,LRREC,LRLOC,LRPAT,LRSSN
S LRLOC=""
F S LRLOC=$O(^TMP($J,"LOCTOT",LRLOC)) Q:LRLOC="" D
.S LRPAT="",LRPATCNT=0
.F S LRPAT=$O(^TMP($J,"LOCTOT",LRLOC,LRPAT)) Q:LRPAT="" D
..S LRSSN=""
..F S LRSSN=$O(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN)) Q:LRSSN="" D
...S LRREC=$G(^TMP($J,"LOCTOT",LRLOC,LRPAT,LRSSN,0))
...Q:'$L(LRREC)
...S LRPATCNT=LRPATCNT+1
...S LRC=+$P(LRREC,U),LRU=+$P(LRREC,U,2)
...S LRP=$S((LRC)&(LRU):4,('LRC)&(LRU):3,1:2)
...S $P(^(0),U,LRP)=$P($G(^TMP($J,"LOCTOT",LRLOC,0)),U,LRP)+1
.S $P(^TMP($J,"LOCTOT",LRLOC,0),U)=LRPATCNT
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR
S:($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) LREND=1
Q
WRAPUP ;
D:($E(IOST,1,2)="C-")&('LREND) PAUSE
W @IOF D:'$D(ZTQUEUED) ^%ZISC
K ^TMP($J),LRPATCNT,LRTGLNAM,LRTGLORD,LRCLCTD,LRTNN,LRTAB
K DTOUT,DUOUT,DIRUT,DIROUT,X,Y,%,%ZIS,DIC,VADM,VA,VAERR,DFN,%Y,%DT,I,PO
;K DIR,PNM,SSN,LRODAT,LRDAT,LRPAG,LRCTYP,LRRCTYP,LRRCNAM,LRDUMY,LRIFN
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
K DIR,PNM,SSN,HRCN,LRODAT,LRDAT,LRPAG,LRCTYP,LRRCTYP,LRRCNAM,LRDUMY,LRIFN ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
K LRTN,LRTST,LRURG,LRLOC,LRPAT,LRSSN,LRREC,LRORD,LRDFN,LRODT,LRDPF,LRWRD
K LRSN,LRPNAM,LRSPC,LREND,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTDESC,AGE,DOB,SEX
K LRLCNT,LRBUF,LRBLANK,LRCS3,LRRPT,LRCS1,ZTREQ
Q
QUE ;
K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
S ZTDESC="LRRP5 - COLLECTION REPORT",ZTRTN="DQ^LRRP5"
S ZTSAVE("LR*")="" D ^%ZTLOAD
W:$D(ZTSK) !!,"Report queued"
W:'$D(ZTSK) !!,"Report canceled!"
D HOME^%ZIS
Q
LRRP5 ;DALOI/JBM/WTY - COLLECTION REPORT ;9/22/00 [ 04/14/2003 1:20 PM ]
+1 ;;5.2T9;LR;**1003,1006,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**121,201,248**;Sep 27, 1994
+3 ;
+4 ;Reference to ^%DT supported by IA #10003
+5 ;Reference to ^%ZIS supported by IA #10086
+6 ;Reference to ^%ZISC supported by IA #10089
+7 ;Reference to ^%ZTLOAD supported by IA #10063
+8 ;Reference to ^DIC supported by IA #10006
+9 ;Reference to ^DIR supported by IA #10026
+10 ;
EN ;
+1 SET LREND=0
+2 SET DIR(0)="69.01,4"
SET DIR("A")="Type of collection for report? "
+3 SET DIR("B")="SEND PATIENT"
+4 DO ^DIR
+5 IF ($DATA(DTOUT)#2)!($DATA(DUOUT)#2)!($DATA(DIRUT)#2)
SET LREND=1
GOTO WRAPUP
+6 SET LRRCTYP=Y
SET LRRCNAM=Y(0)
DATE ;
+1 SET %DT="AEX"
SET %DT("A")="Date ordered? : "
+2 DO ^%DT
IF (X=U)!(X="")
SET LREND=1
GOTO WRAPUP
+3 SET LRODT=Y
SET LRODAT=$$Y2K^LRX(LRODT)
REPTYP ;
+1 WRITE !,"REPORT selection: "
+2 KILL DIR,X,Y
SET DIR(0)="S^1:Detailed report;2:Summary report"
+3 DO ^DIR
+4 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET LREND=1
GOTO WRAPUP
+5 SET LRRPT=+X
DEVICE ;
+1 KILL IOP,IO("Q")
SET %ZIS="QP"
DO ^%ZIS
+2 IF POP
SET LREND=1
GOTO WRAPUP
+3 IF $DATA(IO("Q"))
DO QUE
SET LREND=1
GOTO WRAPUP
DQ ;
+1 DO INIT
+2 DO PROCESS
+3 DO CNTSUM
+4 DO PRINT^LRRP5A
+5 DO WRAPUP
+6 QUIT
INIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^TMP($JOB)
USE IO
+2 SET LRDAT=$$Y2K^LRX(DT)
SET (LRPAG,LREND)=0
+3 QUIT
PROCESS ;For ea. specimen on date selected
+1 ; If collection type = requested type
+2 ; Get patient name & SSN,order#,collection sample & ordering location
+3 ; Store by patient,ssn,order#,collection sample
+4 SET LRSN=0
+5 FOR
SET LRSN=$ORDER(^LRO(69,LRODT,1,LRSN))
IF '+LRSN
QUIT
Begin DoDot:1
+6 SET LRREC=$GET(^LRO(69,LRODT,1,LRSN,0))
IF LRREC=""
QUIT
+7 SET LRDFN=$PIECE(LRREC,U)
SET LRCTYP=$PIECE(LRREC,U,4)
SET LRLOC=$PIECE(LRREC,U,9)
+8 IF (LRDFN="")!(LRRCTYP'=LRCTYP)!(LRLOC="")
QUIT
+9 ;name/ssn
+10 SET DIC=63
SET DIC(0)="NXZ"
SET X="`"_LRDFN
DO ^DIC
IF Y=-1
QUIT
+11 SET LRDPF=$PIECE(Y(0),U,2)
SET DFN=$PIECE(Y(0),U,3)
IF DFN=""
QUIT
DO PT^LRX
IF PNM=""
QUIT
+12 ;S LRPAT=PNM,LRSSN=SSN S:LRSSN="" LRSSN="NO ENTRY"
+13 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+14 ;IHS/ANMC/CLS 08/18/96
SET LRPAT=PNM
SET LRSSN=HRCN
IF LRSSN=""
SET LRSSN="NO ENTRY"
+15 ;----- END IHS MODIFICATIONS
+16 ;order#
+17 SET LRORD=$GET(^LRO(69,LRODT,1,LRSN,.1))
IF LRORD=""
QUIT
+18 SET LRCLCTD=$PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)
+19 ;collection sample
+20 SET LRCS=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),U,3)
IF LRCS=""
QUIT
+21 SET DIC=62
SET DIC(0)="NXZ"
SET X="`"_LRCS
DO ^DIC
IF Y=-1
QUIT
+22 SET LRCS1=$PIECE(Y(0),U)
+23 ;location
+24 SET DIC=44
SET DIC(0)="NXZ"
SET X="`"_LRLOC
DO ^DIC
IF Y=-1
QUIT
+25 SET LRLOC=$SELECT(+$LENGTH($PIECE(Y(0),U,2)):$PIECE(Y(0),U,2),1:$PIECE(Y,U,2))
+26 IF LRCLCTD="C"
Begin DoDot:2
+27 SET LRCLCTD="[C]"
+28 SET $PIECE(^TMP($JOB,"LOCTOT",LRLOC,LRPAT,LRSSN,0),U)=1
End DoDot:2
+29 IF '$TEST
Begin DoDot:2
+30 SET LRCLCTD=" "
+31 SET $PIECE(^TMP($JOB,"LOCTOT",LRLOC,LRPAT,LRSSN,0),U,2)=1
End DoDot:2
+32 SET LRTNN=+$GET(^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0))
+33 ; For ea. test
+34 ; Get name & urgency
+35 ; store by patient,ssn,order#,spec,test#
+36 SET LRTN=0
+37 FOR
SET LRTN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRTN))
IF '+LRTN
QUIT
Begin DoDot:2
+38 SET LRREC=$GET(^LRO(69,LRODT,1,LRSN,2,LRTN,0))
IF LRREC=""
QUIT
IF $PIECE(LRREC,"^",11)
QUIT
+39 SET DIC=60
SET DIC(0)="NXZ"
SET X="`"_$PIECE(LRREC,U)
DO ^DIC
IF Y=-1
QUIT
+40 SET LRTST=$PIECE(Y,U,2)
SET LRIFN=+Y
SET LRPNAM=$PIECE($GET(^LAB(60,LRIFN,.1)),U)
+41 IF LRPNAM'=""
SET LRTST=LRPNAM
+42 SET LRTST=$EXTRACT(LRTST,1,7)
+43 SET DIC=62.05
SET DIC(0)="NXZ"
SET X="`"_$PIECE(LRREC,U,2)
DO ^DIC
IF Y=-1
QUIT
+44 SET LRTST=LRTST_"("_$EXTRACT($PIECE(Y,U,2),1)_")"
+45 SET LRTNN=LRTNN+1
SET ^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1,LRTNN)=LRTST
End DoDot:2
+46 SET ^TMP($JOB,"PAT",LRPAT,LRSSN,LRORD,LRCS1,0)=LRTNN_U_LRLOC_U_LRCLCTD
End DoDot:1
+47 QUIT
CNTSUM ;
+1 NEW LRC,LRU,LRP,LRREC,LRLOC,LRPAT,LRSSN
+2 SET LRLOC=""
+3 FOR
SET LRLOC=$ORDER(^TMP($JOB,"LOCTOT",LRLOC))
IF LRLOC=""
QUIT
Begin DoDot:1
+4 SET LRPAT=""
SET LRPATCNT=0
+5 FOR
SET LRPAT=$ORDER(^TMP($JOB,"LOCTOT",LRLOC,LRPAT))
IF LRPAT=""
QUIT
Begin DoDot:2
+6 SET LRSSN=""
+7 FOR
SET LRSSN=$ORDER(^TMP($JOB,"LOCTOT",LRLOC,LRPAT,LRSSN))
IF LRSSN=""
QUIT
Begin DoDot:3
+8 SET LRREC=$GET(^TMP($JOB,"LOCTOT",LRLOC,LRPAT,LRSSN,0))
+9 IF '$LENGTH(LRREC)
QUIT
+10 SET LRPATCNT=LRPATCNT+1
+11 SET LRC=+$PIECE(LRREC,U)
SET LRU=+$PIECE(LRREC,U,2)
+12 SET LRP=$SELECT((LRC)&(LRU):4,('LRC)&(LRU):3,1:2)
+13 SET $PIECE(^(0),U,LRP)=$PIECE($GET(^TMP($JOB,"LOCTOT",LRLOC,0)),U,LRP)+1
End DoDot:3
End DoDot:2
+14 SET $PIECE(^TMP($JOB,"LOCTOT",LRLOC,0),U)=LRPATCNT
End DoDot:1
+15 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
+2 IF ($DATA(DTOUT)#2)!($DATA(DUOUT)#2)!($DATA(DIRUT)#2)
SET LREND=1
+3 QUIT
WRAPUP ;
+1 IF ($EXTRACT(IOST,1,2)="C-")&('LREND)
DO PAUSE
+2 WRITE @IOF
IF '$DATA(ZTQUEUED)
DO ^%ZISC
+3 KILL ^TMP($JOB),LRPATCNT,LRTGLNAM,LRTGLORD,LRCLCTD,LRTNN,LRTAB
+4 KILL DTOUT,DUOUT,DIRUT,DIROUT,X,Y,%,%ZIS,DIC,VADM,VA,VAERR,DFN,%Y,%DT,I,PO
+5 ;K DIR,PNM,SSN,LRODAT,LRDAT,LRPAG,LRCTYP,LRRCTYP,LRRCNAM,LRDUMY,LRIFN
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+7 ;IHS/ANMC/CLS 08/18/96
KILL DIR,PNM,SSN,HRCN,LRODAT,LRDAT,LRPAG,LRCTYP,LRRCTYP,LRRCNAM,LRDUMY,LRIFN
+8 ;----- END IHS MODIFICATIONS
+9 KILL LRTN,LRTST,LRURG,LRLOC,LRPAT,LRSSN,LRREC,LRORD,LRDFN,LRODT,LRDPF,LRWRD
+10 KILL LRSN,LRPNAM,LRSPC,LREND,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTDESC,AGE,DOB,SEX
+11 KILL LRLCNT,LRBUF,LRBLANK,LRCS3,LRRPT,LRCS1,ZTREQ
+12 QUIT
QUE ;
+1 KILL IO("Q")
IF '$DATA(ZTIO)
IF $DATA(ION)
IF ION=""
SET ZTIO=""
+2 SET ZTDESC="LRRP5 - COLLECTION REPORT"
SET ZTRTN="DQ^LRRP5"
+3 SET ZTSAVE("LR*")=""
DO ^%ZTLOAD
+4 IF $DATA(ZTSK)
WRITE !!,"Report queued"
+5 IF '$DATA(ZTSK)
WRITE !!,"Report canceled!"
+6 DO HOME^%ZIS
+7 QUIT
