- LRVR2 ;SLC/CJS - LAB ROUTINE DATA VERIFICATION ; 10/9/87 16:29 ;
- ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- S LRSPEC="",LRVF=0 S:'$D(LREAL) LREAL=1
- V3 G V5:$D(^LR(LRDFN,LRSS,LRIDT,0)),V4:"AP EM"[LRSS
- V3A IF LRSAMP'="" S LRSPEC=$P(^LAB(62,LRSAMP,0),U,2) G:$D(^LAB(61,+LRSPEC,0)) V4
- I LRDPF'=62.3 Q:$D(LRGVP) S DIC="^LAB(61,",DIC(0)="AEOQ" D ^DIC S LRSPEC=+Y IF LRSPEC=-1 W !,"The specimen MUST be defined." Q
- V4 I '$D(^LR(LRDFN,LRSS,0)) S ^LR(LRDFN,LRSS,0)=U_$P(^DD(63,$O(^DD(63,"GL",LRSS,0,0)),0),U,2)_U
- L +^LR(LRDFN,LRSS) S ^LR(LRDFN,LRSS,0)=$P(^LR(LRDFN,LRSS,0),U,1,2)_U_LRIDT_U_(1+$P(^(0),U,4))
- IF "AP EM"[LRSS S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL L -^LR(LRDFN,LRSS) G V5
- S LRVOL="" S:$D(^LRO(69,LRODT,1,LRSN,1)) LRVOL=$P(^(1),U,5) S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_U_U_U_LRSPEC_U_LRAN_U_LRVOL_U_LRMETH_U L -^LR(LRDFN,LRSS)
- V5 I LRDPF=62.3 S LRSPEC=$S($D(^LR(LRDFN,LRSS,LRIDT,0)):$P(^(0),U,5),1:"")
- S LRLDT=LRIDT,LRVF=0 G V6:'$P(^LR(LRDFN,LRSS,LRIDT,0),U,3) S LRVF=1,X=$P(^(0),U,4),T=$P(^(0),U,3)
- W:'X&(LRDPF=62.3) !,"This control has been automatically verified" W:'X&(LRDPF'=62.3) !,"Verified"
- W !,"Some results have been approved by ",$S($D(^VA(200,+X,0)):$P(^(0),U),1:"Unknown"),!," on ",$$FMTE^XLFDT(T)
- V6 I LRDPF'=62.3 S LRSPEC=$P(^LR(LRDFN,LRSS,LRIDT,0),U,5) G V3A:'+LRSPEC
- W:$D(^LAB(61,+LRSPEC,0)) !,"Specimen: ",$P(^(0),U)
- V7 S LRLDT=+$O(^LR(LRDFN,LRSS,LRLDT)) S:LRLDT>LRTM60 LRLDT=-1 G V8:LRLDT<1,V7:'$D(^LR(LRDFN,LRSS,LRLDT,0)) D V9 G:$P(^LR(LRDFN,LRSS,LRLDT,0),U,5)'=LRSPEC!'$P(^(0),U,3)!'$D(LRMA) V7
- V8 S LRNTN=1,LRDAT(2)="",Z2="" I LRLDT>0 S Z2=^LR(LRDFN,"CH",LRLDT,0),X=+Z2,Z=Z2 D DAT S LRDAT(2)=LRDAT
- S Z1=^LR(LRDFN,"CH",LRIDT,0),X=+Z1,Z=Z1 D DAT
- K LRNOVER I LRSS="CH",'LRVF S LRNOVER=""
- I $D(LRNOVER) F I=1:0 S I=$O(^LR(LRDFN,"CH",LRIDT,I)) Q:I<1 S LRNOVER(I)=""
- D ^LRVR3
- K DA,DIC,DIE,DR,LREDIT,LRNG,LRNG2,LRNG3,LRNG4,LRNG5
- Q ;LEAVE LRVR2, BACK TO LRVR1
- DAT N LRX
- S LRX=$$FMTE^XLFDT(X,"5M")
- S LRDAT=$P(LRX,"/",1,2)_" "_$P(LRX,"@",2)_$S($P(Z,U,2)!(X'["."):"r",1:"d") Q
- V9 K LRMA F I=0:0 S I=$O(^TMP("LR",$J,"TMP",I)) Q:I<1 I $D(^LR(LRDFN,LRSS,LRLDT,I)) S LRMA=1 Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVR2 2143 printed Feb 18, 2025@23:48:31 Page 2
- LRVR2 ;SLC/CJS - LAB ROUTINE DATA VERIFICATION ; 10/9/87 16:29 ;
- +1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- +2 SET LRSPEC=""
- SET LRVF=0
- if '$DATA(LREAL)
- SET LREAL=1
- V3 if $DATA(^LR(LRDFN,LRSS,LRIDT,0))
- GOTO V5
- if "AP EM"[LRSS
- GOTO V4
- V3A IF LRSAMP'=""
- SET LRSPEC=$PIECE(^LAB(62,LRSAMP,0),U,2)
- if $DATA(^LAB(61,+LRSPEC,0))
- GOTO V4
- +1 IF LRDPF'=62.3
- if $DATA(LRGVP)
- QUIT
- SET DIC="^LAB(61,"
- SET DIC(0)="AEOQ"
- DO ^DIC
- SET LRSPEC=+Y
- IF LRSPEC=-1
- WRITE !,"The specimen MUST be defined."
- QUIT
- V4 IF '$DATA(^LR(LRDFN,LRSS,0))
- SET ^LR(LRDFN,LRSS,0)=U_$PIECE(^DD(63,$ORDER(^DD(63,"GL",LRSS,0,0)),0),U,2)_U
- +1 LOCK +^LR(LRDFN,LRSS)
- SET ^LR(LRDFN,LRSS,0)=$PIECE(^LR(LRDFN,LRSS,0),U,1,2)_U_LRIDT_U_(1+$PIECE(^(0),U,4))
- +2 IF "AP EM"[LRSS
- SET ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL
- LOCK -^LR(LRDFN,LRSS)
- GOTO V5
- +3 SET LRVOL=""
- if $DATA(^LRO(69,LRODT,1,LRSN,1))
- SET LRVOL=$PIECE(^(1),U,5)
- SET ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_U_U_U_LRSPEC_U_LRAN_U_LRVOL_U_LRMETH_U
- LOCK -^LR(LRDFN,LRSS)
- V5 IF LRDPF=62.3
- SET LRSPEC=$SELECT($DATA(^LR(LRDFN,LRSS,LRIDT,0)):$PIECE(^(0),U,5),1:"")
- +1 SET LRLDT=LRIDT
- SET LRVF=0
- if '$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,3)
- GOTO V6
- SET LRVF=1
- SET X=$PIECE(^(0),U,4)
- SET T=$PIECE(^(0),U,3)
- +2 if 'X&(LRDPF=62.3)
- WRITE !,"This control has been automatically verified"
- if 'X&(LRDPF'=62.3)
- WRITE !,"Verified"
- +3 WRITE !,"Some results have been approved by ",$SELECT($DATA(^VA(200,+X,0)):$PIECE(^(0),U),1:"Unknown"),!," on ",$$FMTE^XLFDT(T)
- V6 IF LRDPF'=62.3
- SET LRSPEC=$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,5)
- if '+LRSPEC
- GOTO V3A
- +1 if $DATA(^LAB(61,+LRSPEC,0))
- WRITE !,"Specimen: ",$PIECE(^(0),U)
- V7 SET LRLDT=+$ORDER(^LR(LRDFN,LRSS,LRLDT))
- if LRLDT>LRTM60
- SET LRLDT=-1
- if LRLDT<1
- GOTO V8
- if '$DATA(^LR(LRDFN,LRSS,LRLDT,0))
- GOTO V7
- DO V9
- if $PIECE(^LR(LRDFN,LRSS,LRLDT,0),U,5)'=LRSPEC!'$PIECE(^(0),U,3)!'$DATA(LRMA)
- GOTO V7
- V8 SET LRNTN=1
- SET LRDAT(2)=""
- SET Z2=""
- IF LRLDT>0
- SET Z2=^LR(LRDFN,"CH",LRLDT,0)
- SET X=+Z2
- SET Z=Z2
- DO DAT
- SET LRDAT(2)=LRDAT
- +1 SET Z1=^LR(LRDFN,"CH",LRIDT,0)
- SET X=+Z1
- SET Z=Z1
- DO DAT
- +2 KILL LRNOVER
- IF LRSS="CH"
- IF 'LRVF
- SET LRNOVER=""
- +3 IF $DATA(LRNOVER)
- FOR I=1:0
- SET I=$ORDER(^LR(LRDFN,"CH",LRIDT,I))
- if I<1
- QUIT
- SET LRNOVER(I)=""
- +4 DO ^LRVR3
- +5 KILL DA,DIC,DIE,DR,LREDIT,LRNG,LRNG2,LRNG3,LRNG4,LRNG5
- +6 ;LEAVE LRVR2, BACK TO LRVR1
- QUIT
- DAT NEW LRX
- +1 SET LRX=$$FMTE^XLFDT(X,"5M")
- +2 SET LRDAT=$PIECE(LRX,"/",1,2)_" "_$PIECE(LRX,"@",2)_$SELECT($PIECE(Z,U,2)!(X'["."):"r",1:"d")
- QUIT
- V9 KILL LRMA
- FOR I=0:0
- SET I=$ORDER(^TMP("LR",$JOB,"TMP",I))
- if I<1
- QUIT
- IF $DATA(^LR(LRDFN,LRSS,LRLDT,I))
- SET LRMA=1
- QUIT
- +1 QUIT