- LRUPS ;AVAMC/REG/WTY - PATIENT SPEC LOOK-UP ;3/20/01
- ;;5.2;LAB SERVICE;**72,248,259,322,362**;Sep 27, 1994;Build 11
- ;Removed space between "No data" at tag EN
- ;
- GETP W ! K LRAN,DIC S X="",DFN=-1,DIC(0)="EQM",(LRX,LRDPF)="" D DPA^LRDPA
- I DFN=-1 S LRAN=-1 Q
- I N LRAY
- I '$D(LRPFLG) N LRPFLG S LRPFLG=0
- I LRSS="AU" G AU
- EN I '$D(^LR(LRDFN,LRSS))!($P($G(^LR(LRDFN,LRSS,0)),U,3)<1) W $C(7),!!,"No data for ",PNM G GETP
- S (LRI,LRLIDT,E)=0 S:'$D(LRABV) LRABV=0
- I "CYEMSP"'[LRSS W !!,"Count #",?10,"Accession #",?29,"Date",?45,"Site/specimen"
- E W !!,"Specimen(s)",?30,"Count #",?40,"Accession #",?55,"Date Obtained"
- S C=0
- F S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI!(E) D
- .S X=$G(^LR(LRDFN,LRSS,LRI,0)) Q:X="" S LRAC=$P(X,U,6)
- .I $P(LRAC," ")=LRABV!(LRABV=0) D WT:C#5=0 Q:E D
- ..S LRAY=$P(LRAC," ",2)
- ..I LRPFLG,LRAY'=$E(LRAD,2,3) Q
- ..S C=C+1,LRAN=+$P(LRAC," ",3)
- ..S LRAN(C)=LRI_U_LRAN,LRLIDT=LRI
- ..S Y=$P(X,U),LRST=$P(X,U,5) D D^LRU,@($S("CYEMSP"[LRSS:"SP",1:"CY"))
- I 'C W !!,"No specimens entered for "_LRH(0) G GETP
- I C=1 S LRI=+LRAN(1),Y(0)=^LR(LRDFN,LRSS,LRI,0),LRTK=+Y(0) G L
- ACC W !?11,"Choose Count #(1-",C,"): " R X:DTIME I X=""!(X[U) S LRAN=-1 Q
- I X'?1N.N W $C(7),!!,"Enter numbers only",!! G ACC
- OK I '$D(LRAN(X)) W " Doesn't exist for ",PNM G ACC
- GOT S LRI=+LRAN(X),Y(0)=^LR(LRDFN,LRSS,LRI,0),LRTK=+Y(0)
- L S LRAC=$P(Y(0),U,6),LRAN=+$P(LRAC," ",3),Y=$P(Y(0),U) D D^LRU W !!," Accession #: ",LRAC W:Y'[1700 " Date Obtained: ",Y,! S LRWW=$S(Y'[1700:Y,1:"")
- Q
- WT I C>0 W !,"More accessions " S %=2 D YN^LRU S E=$S(%=1:0,1:1) Q
- Q
- SP W !?30,"(",$J(C,2),")",?40,LRAC,?55,Y I '$P(X,"^",11) W " not verified"
- S LRST=0 F A=0:1 S LRST=$O(^LR(LRDFN,LRSS,LRI,.1,LRST)) Q:'LRST W:$D(^(LRST,0)) !,$P(^(0),"^")
- Q
- CY W !?2,"(",$J(C,2),")",?10,LRAC,?25,Y W:LRST ?45,$S($D(^LAB(61,LRST,0)):$E($P(^(0),U),1,34),1:"") Q
- AU S LRND=$G(^LR(LRDFN,"AU"))
- I '$L(LRND) W $C(7),!!,"No autopsy entry for ",LRP,!! S LRAN="?" Q
- S LRAC=$P(LRND,U,6)
- I $P(LRAC," ")'=LRABV W $C(7),!!,"No autopsy accession" S LRAN="?" Q
- S LRAY=$P(LRAC," ",2)
- I LRPFLG,LRAY'=$E(LRAD,2,3) D Q
- .W $C(7),!!,"No autopsy accession for "_LRH(0) S LRAN="?"
- S LRAN=+$P(LRAC," ",3)
- I 'LRAN S LRAN=-1 W $C(7),!!,"No autopsy # for ",LRP Q
- S Y=+LRND D D^LRU W !,"Autopsy performed: ",Y," Acc # ",LRAC
- Q
- EN1 ;from LRAPMOD, LRSPRPT, LRSPT
- W ! K DIC,LRAN S DIC(0)="EQM",(LRX,LRDPF)="" D DPA^LRDPA I DFN=-1 S LRAN=-1 Q
- G I
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPS 2449 printed Jan 18, 2025@03:22:43 Page 2
- LRUPS ;AVAMC/REG/WTY - PATIENT SPEC LOOK-UP ;3/20/01
- +1 ;;5.2;LAB SERVICE;**72,248,259,322,362**;Sep 27, 1994;Build 11
- +2 ;Removed space between "No data" at tag EN
- +3 ;
- GETP WRITE !
- KILL LRAN,DIC
- SET X=""
- SET DFN=-1
- SET DIC(0)="EQM"
- SET (LRX,LRDPF)=""
- DO DPA^LRDPA
- +1 IF DFN=-1
- SET LRAN=-1
- QUIT
- I NEW LRAY
- +1 IF '$DATA(LRPFLG)
- NEW LRPFLG
- SET LRPFLG=0
- +2 IF LRSS="AU"
- GOTO AU
- EN IF '$DATA(^LR(LRDFN,LRSS))!($PIECE($GET(^LR(LRDFN,LRSS,0)),U,3)<1)
- WRITE $CHAR(7),!!,"No data for ",PNM
- GOTO GETP
- +1 SET (LRI,LRLIDT,E)=0
- if '$DATA(LRABV)
- SET LRABV=0
- +2 IF "CYEMSP"'[LRSS
- WRITE !!,"Count #",?10,"Accession #",?29,"Date",?45,"Site/specimen"
- +3 IF '$TEST
- WRITE !!,"Specimen(s)",?30,"Count #",?40,"Accession #",?55,"Date Obtained"
- +4 SET C=0
- +5 FOR
- SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
- if 'LRI!(E)
- QUIT
- Begin DoDot:1
- +6 SET X=$GET(^LR(LRDFN,LRSS,LRI,0))
- if X=""
- QUIT
- SET LRAC=$PIECE(X,U,6)
- +7 IF $PIECE(LRAC," ")=LRABV!(LRABV=0)
- if C#5=0
- DO WT
- if E
- QUIT
- Begin DoDot:2
- +8 SET LRAY=$PIECE(LRAC," ",2)
- +9 IF LRPFLG
- IF LRAY'=$EXTRACT(LRAD,2,3)
- QUIT
- +10 SET C=C+1
- SET LRAN=+$PIECE(LRAC," ",3)
- +11 SET LRAN(C)=LRI_U_LRAN
- SET LRLIDT=LRI
- +12 SET Y=$PIECE(X,U)
- SET LRST=$PIECE(X,U,5)
- DO D^LRU
- DO @($SELECT("CYEMSP"[LRSS:"SP",1:"CY"))
- End DoDot:2
- End DoDot:1
- +13 IF 'C
- WRITE !!,"No specimens entered for "_LRH(0)
- GOTO GETP
- +14 IF C=1
- SET LRI=+LRAN(1)
- SET Y(0)=^LR(LRDFN,LRSS,LRI,0)
- SET LRTK=+Y(0)
- GOTO L
- ACC WRITE !?11,"Choose Count #(1-",C,"): "
- READ X:DTIME
- IF X=""!(X[U)
- SET LRAN=-1
- QUIT
- +1 IF X'?1N.N
- WRITE $CHAR(7),!!,"Enter numbers only",!!
- GOTO ACC
- OK IF '$DATA(LRAN(X))
- WRITE " Doesn't exist for ",PNM
- GOTO ACC
- GOT SET LRI=+LRAN(X)
- SET Y(0)=^LR(LRDFN,LRSS,LRI,0)
- SET LRTK=+Y(0)
- L SET LRAC=$PIECE(Y(0),U,6)
- SET LRAN=+$PIECE(LRAC," ",3)
- SET Y=$PIECE(Y(0),U)
- DO D^LRU
- WRITE !!," Accession #: ",LRAC
- if Y'[1700
- WRITE " Date Obtained: ",Y,!
- SET LRWW=$SELECT(Y'[1700:Y,1:"")
- +1 QUIT
- WT IF C>0
- WRITE !,"More accessions "
- SET %=2
- DO YN^LRU
- SET E=$SELECT(%=1:0,1:1)
- QUIT
- +1 QUIT
- SP WRITE !?30,"(",$JUSTIFY(C,2),")",?40,LRAC,?55,Y
- IF '$PIECE(X,"^",11)
- WRITE " not verified"
- +1 SET LRST=0
- FOR A=0:1
- SET LRST=$ORDER(^LR(LRDFN,LRSS,LRI,.1,LRST))
- if 'LRST
- QUIT
- if $DATA(^(LRST,0))
- WRITE !,$PIECE(^(0),"^")
- +2 QUIT
- CY WRITE !?2,"(",$JUSTIFY(C,2),")",?10,LRAC,?25,Y
- if LRST
- WRITE ?45,$SELECT($DATA(^LAB(61,LRST,0)):$EXTRACT($PIECE(^(0),U),1,34),1:"")
- QUIT
- AU SET LRND=$GET(^LR(LRDFN,"AU"))
- +1 IF '$LENGTH(LRND)
- WRITE $CHAR(7),!!,"No autopsy entry for ",LRP,!!
- SET LRAN="?"
- QUIT
- +2 SET LRAC=$PIECE(LRND,U,6)
- +3 IF $PIECE(LRAC," ")'=LRABV
- WRITE $CHAR(7),!!,"No autopsy accession"
- SET LRAN="?"
- QUIT
- +4 SET LRAY=$PIECE(LRAC," ",2)
- +5 IF LRPFLG
- IF LRAY'=$EXTRACT(LRAD,2,3)
- Begin DoDot:1
- +6 WRITE $CHAR(7),!!,"No autopsy accession for "_LRH(0)
- SET LRAN="?"
- End DoDot:1
- QUIT
- +7 SET LRAN=+$PIECE(LRAC," ",3)
- +8 IF 'LRAN
- SET LRAN=-1
- WRITE $CHAR(7),!!,"No autopsy # for ",LRP
- QUIT
- +9 SET Y=+LRND
- DO D^LRU
- WRITE !,"Autopsy performed: ",Y," Acc # ",LRAC
- +10 QUIT
- EN1 ;from LRAPMOD, LRSPRPT, LRSPT
- +1 WRITE !
- KILL DIC,LRAN
- SET DIC(0)="EQM"
- SET (LRX,LRDPF)=""
- DO DPA^LRDPA
- IF DFN=-1
- SET LRAN=-1
- QUIT
- +2 GOTO I