- 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