LRUPT ;AVAMC/REG/WTY - PATIENT TESTS ORDERED BY DATE ;9/25/00 [ 04/15/2003 9:50 AM ]
;;5.2T9;LR;**1004,1006,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**1,153,201,248**;Sep 27, 1994
;
;Reference to ^VA(200 supported by IA #10060
;Reference to ^%ZIS supported by IA #10086
;Reference to ^DIC supported by IA #10006
;
S:$D(LRSS)#2 Z(0)=LRSS S:$D(LRAA)#2 Z(1)=LRAA S:$D(LRAA(1)) Z(2)=LRAA(1)
S LRDPAF=1,IOP="HOME" D ^%ZIS
ASK I $D(Z(0)),Z(0)="BB" S DIC("B")="BLOOD BANK"
K LRSS W ! S DIC=68,DIC(0)="AEMOQZ" D ^DIC K DIC I Y<1 K LRSS,LRAA S:$D(Z(0)) LRSS=Z(0) S:$D(Z(1)) LRAA=Z(1) S:$D(Z(2)) LRAA(1)=Z(2) K Z G END
D REST K Z(0) G ASK
REST S LRSS=$P(Y(0),U,2),Z(3)=$P(Y(0),U,3),LRAA=+Y,LRAA(1)=$P(Y,U,2),Z(8)=$P(Y(0),U,11)
GETP K T W ! S A("A")="Y" K DIC D ^LRDPA Q:LRDFN=-1 Q:'$D(^LR(LRDFN,0))
W !,"Is this the patient " S %=1 D YN^LRU Q:%<1 G:%=2 GETP D SHOW G GETP
SHOW ;W @IOF,!,LRAA(1),?20,LRP," ID: ",SSN I "AUCYEMSP"'[LRSS W " TESTS ORDERED"
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W @IOF,!,LRAA(1),?20,LRP," ID: ",HRCN I "AUCYEMSP"'[LRSS W " TESTS ORDERED" ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
I LRSS="AU" D AUTO Q
I '$D(^LR(LRDFN,LRSS)) W $C(7),!!,"No ",LRAA(1),$S("SPCYEM"'[LRSS:" Tests",1:""),!! Q
D HDR S N=0 F A=1:1 S N=$O(^LR(LRDFN,LRSS,N)) Q:'N I $D(^LR(LRDFN,LRSS,N,0)) S Z(7)=^(0) D S Q:A("A")'?1"Y".E
I A=1 W !?5,"*** No ",LRAA(1)," entries ***",!!
Q
S S Y=+Z(7),Z(4)=$P(Z(7),U,7),(Z(6),Z(12))=$P(Z(7),U,6)
S Z(5)=$P(Z(7),U,5),Z(11)=$S(LRSS="MI":$P(Z(7),U,11),1:"")
S:Z(5) Z(5)=$S($D(^LAB(61,Z(5),0)):$P(^(0),U),1:"UNKNOWN")
I Z(3)["M" S Y=$E(+Z(7),1,3)_$P($P(Z(7),"^",6)," ",2)
I "SPCYEM"[LRSS&(+Z(12)=Z(12)) D
.S Z(12)=LRSS_$E($P(Z(7),"^",10),2,3)_" "_Z(12)
FIX I Z(6)'="" Q:Z(8)'=$P(Z(6)," ") S Z(6)=$P(Z(6)," ",3)
S Z(9)=$S("D"[Z(3)&("BBCH"[LRSS):$E(Y,1,3)_$P($P(Z(7),"^",6)," ",2),Z(3)="Y":$E(Y,1,3)_"0000","M"[Z(3):$E(Y,1,5)_"00","Q"[Z(3):$E(Y,1,3)_"0000"+(($E(Y,4,5)-1)\3*300+100),1:$P(Y,"."))
S LRDATE=$TR($$Y2K^LRX(Y,"5M"),"@"," ")
S (QFLG,FND)=0
D:$Y>21 MORE Q:A("A")'?1"Y".E!('Z(9))!(Z(6)="")
I "SPCYEM"[LRSS D G A
.S Z(5)="" S:Z(4) Z(5)=$P($G(^VA(200,Z(4),0)),"^")
I LRSS="BB",'$D(^LRO(68,LRAA,1,Z(9),1,Z(6),0)) D Q
.W !!,LRDATE,?18,Z(12),?32,$E(Z(5),1,12)
I LRSS'="BB" D I QFLG D DATA Q
.I '$D(^LRO(68,LRAA,1,Z(9),1,Z(6),0)) D Q:QFLG
..; Accession was not found in file 68.
..; Determine if accession is found in next year.
..D YRCHK Q:QFLG
..S FND=1 ;Accession was found in next year
.I LRDFN'=+^LRO(68,LRAA,1,Z(9),1,Z(6),0)!(+^(3)'=+Z(7)) D
..; The LRDFN does not match so let's do further checking
..I FND S QFLG=1 Q ;Year increment was already done so quit
..;Check to see if it's in the next year
..D YRCHK Q:QFLG
..I LRDFN'=+^LRO(68,LRAA,1,Z(9),1,Z(6),0)!(+^(3)'=+Z(7)) S QFLG=1
I LRSS="BB" Q:LRDFN'=+^LRO(68,LRAA,1,Z(9),1,Z(6),0)!(+^(3)'=+Z(7))
S:LRSS="CH" Z(11)=""
I Z(11)>0 D
.S Z(11)=$P(^LAB(62,+Z(11),0),U),Z(11)=$S(Z(11)'=Z(5):Z(11),1:"")
A D DATA
W " ",$E(Z(11),1,10) D @($S("CYEMSP"[LRSS:"AP",1:"DAY"))
Q
YRCHK ;Increment year and look for accession
S X1=$E(Z(9),1,3),X2=$E(Z(9),4,7)
S X1=X1+1,Z(15)=X1_X2
I '$D(^LRO(68,LRAA,1,Z(15),1,Z(6),0)) S QFLG=1 Q
S Z(9)=Z(15) ;It was found in the next year.
Q
DATA W !!,LRDATE,?18,Z(12),?37,$E(Z(5),1,12)
W:QFLG ?58,"Data Unavailable"
Q
DAY Q:'Z(9)!(Z(6)="") S (B,X)=0 F S X=$O(^LRO(68,LRAA,1,Z(9),1,Z(6),4,X)) Q:'X S T(X)=+^(X,0) D:$Y>20 MORE Q:A("A")'?1"Y".E D LIST
Q
LIST S X(0)=$G(^LAB(60,T(X),0)) Q:$P(X(0),U,4)="WK"!($P(X(0),U)="") D Q
.S B=B+1 I B>2 W !
.W ?56,$J(B,3),")",?60,$E($P(X(0),U),1,18)
.I B=1 W ! S LRUID=$P($G(^LRO(68,LRAA,1,Z(9),1,Z(6),.3)),"^") I LRUID'="" W ?13,"UID: "_LRUID
.D REF
MORE Q:A("A")?1"N".E!(A("A")="") R !,"MORE TESTS ? NO// ",A("A"):DTIME Q:A("A")=""!(A("A")[U)!(A("A")?1"N".E) I A("A")'?1"Y".E W $C(7),!,"Answer YES or NO" G MORE
;W @IOF,LRP," SSN: ",SSN D HDR W LRDATE,?18,Z(12) Q
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W @IOF,LRP," HRCN: ",HRCN D HDR W LRDATE,?18,Z(12) Q ;IHS/ANMC/CLS 08/18/96
;----- END IHS MODIFICATIONS
HDR W !,"Spec Date/time",?18,"Acc #" I "AUCYEMSP"'[LRSS W ?32,"Site/specimen" I LRSS'="CY" W ?59,"Tests"
W:"CYEMSP"[LRSS ?37,"PHYSICIAN",?51,"SPECIMEN(S)" W ! Q
AUTO I '$D(^LR(LRDFN,"AU")) W $C(7),!,"No autopsy !!!" Q
S Z(7)=^LR(LRDFN,"AU"),Y=+Z(7),Z(6)=$P(Z(7),U,6) D D^LRU
W !,"Autopsy date/time",?19,"Autopsy #"
W !,$S(Y[1700:"???",1:Y),?23,$S($D(Z(6)):Z(6),1:"??")
Q
AP S C=0 F B=0:1 S C=$O(^LR(LRDFN,LRSS,N,.1,C)) Q:'C D
.W:B !
.W ?51,$E($P(^(C,0),U),1,27)
Q
REF ; if referred test, get referral status
N LREVNT,LRMAN,LRX
S LRMAN="",LREVNT=$$STATUS^LREVENT(LRUID,T(X),LRMAN)
I LREVNT'="" D
.S LRMAN=$P(LREVNT,"^",3) I LRMAN'="" W:B>1 ! W ?35,"Shipping Manifest: "_LRMAN
.S LRX="Referral Status: "_$P(LREVNT,"^")_" ("_$P(LREVNT,"^",2)_")" W !,?(79-$L(LRX)),LRX I B=1 W !
Q
END K LRDPAF,LRP,LRLLOC,SSN,%,A,B,DFN,DIC,DOB,I,K,Z,LRADM,LRADX,LRAWRD
K LRDFN,LRDPF,LREXP,LRFNAM,LRMD,LREND,LRPF,LRPFN,LRS,P,PNM,POP,LRSVC
K LRTEST,LRUID,N,SEX,X,X1,X2,Y,QFLG,FND
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
K HCRN
;----- END IHS MODIFICATIONS
Q
LRUPT ;AVAMC/REG/WTY - PATIENT TESTS ORDERED BY DATE ;9/25/00 [ 04/15/2003 9:50 AM ]
+1 ;;5.2T9;LR;**1004,1006,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**1,153,201,248**;Sep 27, 1994
+3 ;
+4 ;Reference to ^VA(200 supported by IA #10060
+5 ;Reference to ^%ZIS supported by IA #10086
+6 ;Reference to ^DIC supported by IA #10006
+7 ;
+8 IF $DATA(LRSS)#2
SET Z(0)=LRSS
IF $DATA(LRAA)#2
SET Z(1)=LRAA
IF $DATA(LRAA(1))
SET Z(2)=LRAA(1)
+9 SET LRDPAF=1
SET IOP="HOME"
DO ^%ZIS
ASK IF $DATA(Z(0))
IF Z(0)="BB"
SET DIC("B")="BLOOD BANK"
+1 KILL LRSS
WRITE !
SET DIC=68
SET DIC(0)="AEMOQZ"
DO ^DIC
KILL DIC
IF Y<1
KILL LRSS,LRAA
IF $DATA(Z(0))
SET LRSS=Z(0)
IF $DATA(Z(1))
SET LRAA=Z(1)
IF $DATA(Z(2))
SET LRAA(1)=Z(2)
KILL Z
GOTO END
+2 DO REST
KILL Z(0)
GOTO ASK
REST SET LRSS=$PIECE(Y(0),U,2)
SET Z(3)=$PIECE(Y(0),U,3)
SET LRAA=+Y
SET LRAA(1)=$PIECE(Y,U,2)
SET Z(8)=$PIECE(Y(0),U,11)
GETP KILL T
WRITE !
SET A("A")="Y"
KILL DIC
DO ^LRDPA
IF LRDFN=-1
QUIT
IF '$DATA(^LR(LRDFN,0))
QUIT
+1 WRITE !,"Is this the patient "
SET %=1
DO YN^LRU
IF %<1
QUIT
IF %=2
GOTO GETP
DO SHOW
GOTO GETP
SHOW ;W @IOF,!,LRAA(1),?20,LRP," ID: ",SSN I "AUCYEMSP"'[LRSS W " TESTS ORDERED"
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;IHS/ANMC/CLS 08/18/96
WRITE @IOF,!,LRAA(1),?20,LRP," ID: ",HRCN
IF "AUCYEMSP"'[LRSS
WRITE " TESTS ORDERED"
+3 ;----- END IHS MODIFICATIONS
+4 IF LRSS="AU"
DO AUTO
QUIT
+5 IF '$DATA(^LR(LRDFN,LRSS))
WRITE $CHAR(7),!!,"No ",LRAA(1),$SELECT("SPCYEM"'[LRSS:" Tests",1:""),!!
QUIT
+6 DO HDR
SET N=0
FOR A=1:1
SET N=$ORDER(^LR(LRDFN,LRSS,N))
IF 'N
QUIT
IF $DATA(^LR(LRDFN,LRSS,N,0))
SET Z(7)=^(0)
DO S
IF A("A")'?1"Y".E
QUIT
+7 IF A=1
WRITE !?5,"*** No ",LRAA(1)," entries ***",!!
+8 QUIT
S SET Y=+Z(7)
SET Z(4)=$PIECE(Z(7),U,7)
SET (Z(6),Z(12))=$PIECE(Z(7),U,6)
+1 SET Z(5)=$PIECE(Z(7),U,5)
SET Z(11)=$SELECT(LRSS="MI":$PIECE(Z(7),U,11),1:"")
+2 IF Z(5)
SET Z(5)=$SELECT($DATA(^LAB(61,Z(5),0)):$PIECE(^(0),U),1:"UNKNOWN")
+3 IF Z(3)["M"
SET Y=$EXTRACT(+Z(7),1,3)_$PIECE($PIECE(Z(7),"^",6)," ",2)
+4 IF "SPCYEM"[LRSS&(+Z(12)=Z(12))
Begin DoDot:1
+5 SET Z(12)=LRSS_$EXTRACT($PIECE(Z(7),"^",10),2,3)_" "_Z(12)
End DoDot:1
FIX IF Z(6)'=""
IF Z(8)'=$PIECE(Z(6)," ")
QUIT
SET Z(6)=$PIECE(Z(6)," ",3)
+1 SET Z(9)=$SELECT("D"[Z(3)&("BBCH"[LRSS):$EXTRACT(Y,1,3)_$PIECE($PIECE(Z(7),"^",6)," ",2),Z(3)="Y":$EXTRACT(Y,1,3)_"0000","M"[Z(3):$EXTRACT(Y,1,5)_"00","Q"[Z(3):$EXTRACT(Y,1,3)_"0000"+(($EXTRACT(Y,4,5)-1)\3*300+100),1:$PIECE(Y,"."))
+2 SET LRDATE=$TRANSLATE($$Y2K^LRX(Y,"5M"),"@"," ")
+3 SET (QFLG,FND)=0
+4 IF $Y>21
DO MORE
IF A("A")'?1"Y".E!('Z(9))!(Z(6)="")
QUIT
+5 IF "SPCYEM"[LRSS
Begin DoDot:1
+6 SET Z(5)=""
IF Z(4)
SET Z(5)=$PIECE($GET(^VA(200,Z(4),0)),"^")
End DoDot:1
GOTO A
+7 IF LRSS="BB"
IF '$DATA(^LRO(68,LRAA,1,Z(9),1,Z(6),0))
Begin DoDot:1
+8 WRITE !!,LRDATE,?18,Z(12),?32,$EXTRACT(Z(5),1,12)
End DoDot:1
QUIT
+9 IF LRSS'="BB"
Begin DoDot:1
+10 IF '$DATA(^LRO(68,LRAA,1,Z(9),1,Z(6),0))
Begin DoDot:2
+11 ; Accession was not found in file 68.
+12 ; Determine if accession is found in next year.
+13 DO YRCHK
IF QFLG
QUIT
+14 ;Accession was found in next year
SET FND=1
End DoDot:2
IF QFLG
QUIT
+15 IF LRDFN'=+^LRO(68,LRAA,1,Z(9),1,Z(6),0)!(+^(3)'=+Z(7))
Begin DoDot:2
+16 ; The LRDFN does not match so let's do further checking
+17 ;Year increment was already done so quit
IF FND
SET QFLG=1
QUIT
+18 ;Check to see if it's in the next year
+19 DO YRCHK
IF QFLG
QUIT
+20 IF LRDFN'=+^LRO(68,LRAA,1,Z(9),1,Z(6),0)!(+^(3)'=+Z(7))
SET QFLG=1
End DoDot:2
End DoDot:1
IF QFLG
DO DATA
QUIT
+21 IF LRSS="BB"
IF LRDFN'=+^LRO(68,LRAA,1,Z(9),1,Z(6),0)!(+^(3)'=+Z(7))
QUIT
+22 IF LRSS="CH"
SET Z(11)=""
+23 IF Z(11)>0
Begin DoDot:1
+24 SET Z(11)=$PIECE(^LAB(62,+Z(11),0),U)
SET Z(11)=$SELECT(Z(11)'=Z(5):Z(11),1:"")
End DoDot:1
A DO DATA
+1 WRITE " ",$EXTRACT(Z(11),1,10)
DO @($SELECT("CYEMSP"[LRSS:"AP",1:"DAY"))
+2 QUIT
YRCHK ;Increment year and look for accession
+1 SET X1=$EXTRACT(Z(9),1,3)
SET X2=$EXTRACT(Z(9),4,7)
+2 SET X1=X1+1
SET Z(15)=X1_X2
+3 IF '$DATA(^LRO(68,LRAA,1,Z(15),1,Z(6),0))
SET QFLG=1
QUIT
+4 ;It was found in the next year.
SET Z(9)=Z(15)
+5 QUIT
DATA WRITE !!,LRDATE,?18,Z(12),?37,$EXTRACT(Z(5),1,12)
+1 IF QFLG
WRITE ?58,"Data Unavailable"
+2 QUIT
DAY IF 'Z(9)!(Z(6)="")
QUIT
SET (B,X)=0
FOR
SET X=$ORDER(^LRO(68,LRAA,1,Z(9),1,Z(6),4,X))
IF 'X
QUIT
SET T(X)=+^(X,0)
IF $Y>20
DO MORE
IF A("A")'?1"Y".E
QUIT
DO LIST
+1 QUIT
LIST SET X(0)=$GET(^LAB(60,T(X),0))
IF $PIECE(X(0),U,4)="WK"!($PIECE(X(0),U)="")
QUIT
Begin DoDot:1
+1 SET B=B+1
IF B>2
WRITE !
+2 WRITE ?56,$JUSTIFY(B,3),")",?60,$EXTRACT($PIECE(X(0),U),1,18)
+3 IF B=1
WRITE !
SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,Z(9),1,Z(6),.3)),"^")
IF LRUID'=""
WRITE ?13,"UID: "_LRUID
+4 DO REF
End DoDot:1
QUIT
MORE IF A("A")?1"N".E!(A("A")="")
QUIT
READ !,"MORE TESTS ? NO// ",A("A"):DTIME
IF A("A")=""!(A("A")[U)!(A("A")?1"N".E)
QUIT
IF A("A")'?1"Y".E
WRITE $CHAR(7),!,"Answer YES or NO"
GOTO MORE
+1 ;W @IOF,LRP," SSN: ",SSN D HDR W LRDATE,?18,Z(12) Q
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 ;IHS/ANMC/CLS 08/18/96
WRITE @IOF,LRP," HRCN: ",HRCN
DO HDR
WRITE LRDATE,?18,Z(12)
QUIT
+4 ;----- END IHS MODIFICATIONS
HDR WRITE !,"Spec Date/time",?18,"Acc #"
IF "AUCYEMSP"'[LRSS
WRITE ?32,"Site/specimen"
IF LRSS'="CY"
WRITE ?59,"Tests"
+1 IF "CYEMSP"[LRSS
WRITE ?37,"PHYSICIAN",?51,"SPECIMEN(S)"
WRITE !
QUIT
AUTO IF '$DATA(^LR(LRDFN,"AU"))
WRITE $CHAR(7),!,"No autopsy !!!"
QUIT
+1 SET Z(7)=^LR(LRDFN,"AU")
SET Y=+Z(7)
SET Z(6)=$PIECE(Z(7),U,6)
DO D^LRU
+2 WRITE !,"Autopsy date/time",?19,"Autopsy #"
+3 WRITE !,$SELECT(Y[1700:"???",1:Y),?23,$SELECT($DATA(Z(6)):Z(6),1:"??")
+4 QUIT
AP SET C=0
FOR B=0:1
SET C=$ORDER(^LR(LRDFN,LRSS,N,.1,C))
IF 'C
QUIT
Begin DoDot:1
+1 IF B
WRITE !
+2 WRITE ?51,$EXTRACT($PIECE(^(C,0),U),1,27)
End DoDot:1
+3 QUIT
REF ; if referred test, get referral status
+1 NEW LREVNT,LRMAN,LRX
+2 SET LRMAN=""
SET LREVNT=$$STATUS^LREVENT(LRUID,T(X),LRMAN)
+3 IF LREVNT'=""
Begin DoDot:1
+4 SET LRMAN=$PIECE(LREVNT,"^",3)
IF LRMAN'=""
IF B>1
WRITE !
WRITE ?35,"Shipping Manifest: "_LRMAN
+5 SET LRX="Referral Status: "_$PIECE(LREVNT,"^")_" ("_$PIECE(LREVNT,"^",2)_")"
WRITE !,?(79-$LENGTH(LRX)),LRX
IF B=1
WRITE !
End DoDot:1
+6 QUIT
END KILL LRDPAF,LRP,LRLLOC,SSN,%,A,B,DFN,DIC,DOB,I,K,Z,LRADM,LRADX,LRAWRD
+1 KILL LRDFN,LRDPF,LREXP,LRFNAM,LRMD,LREND,LRPF,LRPFN,LRS,P,PNM,POP,LRSVC
+2 KILL LRTEST,LRUID,N,SEX,X,X1,X2,Y,QFLG,FND
+3 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+4 KILL HCRN
+5 ;----- END IHS MODIFICATIONS
+6 QUIT
