LRAR04 ; IHS/DIR/AAB - REMOVE OLD DATA FROM PT. FILE 12/12/96 10:16 ; [ 07/22/2002 1:05 PM ]
;;5.2;LR;**1002,1013**;JUL 15, 2002
;;5.2;LAB SERVICE;**111**;Sep 27, 1994
;
; Rewrite 11/96 Hoak --------------->
;
Q ;LRC2=NUMBER OF PT, LRC3=NUMBER OF DATES
MOVE ;
; This is where we make the copies to be archived <----------
;
; Move data from ^LR to ^LAR------>arcive global----------|
; |
S LRCNT=$P(^LR(LRDFN,LRSS,0),U,3,4) ; |
S:LRSS="CH" ^LAR("Z",LRDFN,LRSS,0)="^63.999904D^"_LRCNT ; |
S:LRSS="MI" ^LAR("Z",LRDFN,LRSS,0)="^63.999905DA^"_LRCNT ; |
S %X="^LR(LRDFN,LRSS,LRIDT," ; |
S %Y="^LAR(""Z"",LRDFN,LRSS,LRIDT," ; |
; |
D %XY^%RCR ; <-------------------------------------------------/
;
;
S:LRC1 LRC2=LRC2+1,LRC1=0
S ^LAR("Z",LRDFN,0)=^LR(LRDFN,0)
S ^LAR("Z","B",LRDFN,LRDFN)=""
S ^LAR("NAME",PNM,LRDFN)=""
S ^LAR("SSN",SSN,LRDFN)=""
S LRC3=LRC3+1
QUIT
;
PT ;
S PNM="unk",SSN="unk"
Q:LRDPF<1 D DEM^LRX
S:SSN="" SSN="unk" S:PNM="" PNM="unk"
QUIT
;
;
DFN ;
;from LRARCHIV
;
;
S LRI=0
S LRJT0=$P(^LR(0),U,4)
I '$G(LRDT7) S LRDT7=LR(1)
;
CONTROL ;
S LRDFN=0
Q
;
;
QUERY ;
D DFN
D NOW^%DTC S ^TMP("LR9","ENDX")=%
S LRDFN=0
K ^TMP("LR9")
D NOW^%DTC S ^TMP("LR9","START")=%
S LRQCNT=0
;
; ^LR(13,"CH",7038789.916,0)
;
; This block builds a TMP global of data relevant for the date
; range LRSDTX to LREDT
;
;--->New concept employed; gather only LRDFN(s) in date range
; archive only these
;
S LRV7=LREDT
S LRSDTX=9999999-LR(1)
S LREDT=9999999-LRV7 I $E(LREDT,1,1)=2 S LREDT=LRV7
S LRDFN="^LR(1,0)"
S ^TMP("LR9","RANGE")=LRSDTX_U_LREDT
;
F S LRDFN=$Q(@LRDFN) Q:$P(LRDFN,",")'["LR(" S LR9=$P(LRDFN,",",3) D
. Q:$P(LRDFN,",",2)'["CH"
. S LR8=+$P(LRDFN,"LR(",2) Q:LR8'>0
. I LR9>LRSDTX,LR9<LREDT D
.. I $P(^LR(LR8,0),U,2)=2 S ^TMP("LR9",LR8)=^LR(LR8,0)_U_LR9_U_LREDT_U_+^LR(LR8,"CH",LR9,0) D
... S $P(LRDFN,"LR(",2)=LR8+.1_","_$P(LRDFN,LR8_",",2)
... S LRQCNT=LRQCNT+1
.. S LR5=$L(LRDFN)
.. I $E(LRDFN,LR5,LR5)'=")" S LRDFN=LRDFN_")"
D NOW^%DTC S ^TMP("LR9","END0")=%
Q
DISPLAY ;
W !,"My preliminary screening process reveals ",$G(LRQCNT)," LRDFN(s)."
Q
;
;
LR ;
D DQ1^LRARCHIV
D QUERY
S LRWHICH="CH"
K ^TMP("LRT2")
S LRDFN=0
;
;********************************************************************
; *
; Leave Micro question for next go-round *
; *
;********************************************************************
;
F S LRDFN=$O(^TMP("LR9",LRDFN)) Q:+LRDFN'>0 D I LRDFN'>0 D TEND QUIT
. S LRDPF=$P(^TMP("LR9",LRDFN),U,2) S DFN=$P(^(LRDFN),U,3)
. I +LRDPF=2 S RC1=1 D PT
. I +LRDPF'=2 QUIT
. S LRIDT=$P(^TMP("LR9",LRDFN),U,7)
. S LRSS="CH" D LAB
D LST^LRARCHIV
D QUIT^LRARCHIV
Q
LAB ;
S LRJTX=$P(^LR(0),U,4)
S LRIDT=LRIDT-.1
F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:+LRIDT'>0!(LRIDT>LREDT) D
. I $D(^LR(LRDFN,LRSS,LRIDT,0)) S LRDT7=+^(0)
. S LRI=$G(LRI)+1
. ;D JOBTIME^LRAC12
. W "."
. D LAB1
Q
;
LAB1 ;
D I LRIDT<1 D UPDT Q
. Q:'LRIDT
. I '$D(PNM) D PT
. IF '$D(^LR(LRDFN,LRSS,LRIDT,0)) D QUIT
.. S ^TMP("LRBAD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
. S LRDAT=^LR(LRDFN,LRSS,LRIDT,0)
. IF LRSS="CH",'$P(LRDAT,U,3) D QUIT
.. S ^TMP("LRUNV",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
. IF $O(^LR(LRDFN,LRSS,LRIDT,0))=""!('+$O(^(0))) D QUIT
.. S ^TMP("LRNOD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
;
I $L($P(LRDAT,U,9)) D CHECKX
;
QUIT
;
;----------------------------------------------------------------------
;------Here is where we check the major header and force to perm.
;
CHECKX S LRMH=$P($P(LRDAT,U,9),":") ;Major Header
S LRFG=$P($P(LRDAT,U,9),":",2) ;PAGE
;
; Checking all the test for different major header
;
;
S TEST=.5
F S TEST=$O(^LR(LRDFN,"CH",LRIDT,TEST)) Q:+TEST'>0 D
. Q:$D(^TMP("LRT2",TEST))#2
. D ^LRAR02
;--------------------------------------------------------------------
;
D MOVE
Q
;
TEND ;
W @IOF
W !!,"The SEARCH process is complete."
W !!,$P(LRI/LRJT0*100,".")," Percent of ^LR was searched"
D STAMP^LRX
W !,"Total patient count: ",LRC2,". Specimen count: ",LRC3,! K LRDFN
QUIT
;
UPDT ;
S X=0,LRCNT=0
F I=0:0 S X=$O(^LR(LRDFN,LRSS,X)) Q:X<1 S LRCNT=LRCNT+1
;--------------------------------------------CH-----------MICRO NO BB?
I LRCNT=0 S ^LR(LRDFN,LRSS,0)=$S(LRSS="CH":"^63.04D",1:"^63.05DA") Q
S $P(^LR(LRDFN,LRSS,0),U,4)=LRCNT
Q
RCC ;
;REMOVE CONTROL CHAR.
S X=LRDAT
S LRDAT=""
F I=1:1:$L(X) S LRDAT=LRDAT_$S($A(X,I)>126:"",$A(X,I)>31:$E(X,I),1:"")
S ^LR(LRDFN,LRSS,LRIDT,I1)=LRDAT
QUIT
LRAR04 ; IHS/DIR/AAB - REMOVE OLD DATA FROM PT. FILE 12/12/96 10:16 ; [ 07/22/2002 1:05 PM ]
+1 ;;5.2;LR;**1002,1013**;JUL 15, 2002
+2 ;;5.2;LAB SERVICE;**111**;Sep 27, 1994
+3 ;
+4 ; Rewrite 11/96 Hoak --------------->
+5 ;
+6 ;LRC2=NUMBER OF PT, LRC3=NUMBER OF DATES
QUIT
MOVE ;
+1 ; This is where we make the copies to be archived <----------
+2 ;
+3 ; Move data from ^LR to ^LAR------>arcive global----------|
+4 ; |
+5 ; |
SET LRCNT=$PIECE(^LR(LRDFN,LRSS,0),U,3,4)
+6 ; |
IF LRSS="CH"
SET ^LAR("Z",LRDFN,LRSS,0)="^63.999904D^"_LRCNT
+7 ; |
IF LRSS="MI"
SET ^LAR("Z",LRDFN,LRSS,0)="^63.999905DA^"_LRCNT
+8 ; |
SET %X="^LR(LRDFN,LRSS,LRIDT,"
+9 ; |
SET %Y="^LAR(""Z"",LRDFN,LRSS,LRIDT,"
+10 ; |
+11 ; <-------------------------------------------------/
DO %XY^%RCR
+12 ;
+13 ;
+14 IF LRC1
SET LRC2=LRC2+1
SET LRC1=0
+15 SET ^LAR("Z",LRDFN,0)=^LR(LRDFN,0)
+16 SET ^LAR("Z","B",LRDFN,LRDFN)=""
+17 SET ^LAR("NAME",PNM,LRDFN)=""
+18 SET ^LAR("SSN",SSN,LRDFN)=""
+19 SET LRC3=LRC3+1
+20 QUIT
+21 ;
PT ;
+1 SET PNM="unk"
SET SSN="unk"
+2 IF LRDPF<1
QUIT
DO DEM^LRX
+3 IF SSN=""
SET SSN="unk"
IF PNM=""
SET PNM="unk"
+4 QUIT
+5 ;
+6 ;
DFN ;
+1 ;from LRARCHIV
+2 ;
+3 ;
+4 SET LRI=0
+5 SET LRJT0=$PIECE(^LR(0),U,4)
+6 IF '$GET(LRDT7)
SET LRDT7=LR(1)
+7 ;
CONTROL ;
+1 SET LRDFN=0
+2 QUIT
+3 ;
+4 ;
QUERY ;
+1 DO DFN
+2 DO NOW^%DTC
SET ^TMP("LR9","ENDX")=%
+3 SET LRDFN=0
+4 KILL ^TMP("LR9")
+5 DO NOW^%DTC
SET ^TMP("LR9","START")=%
+6 SET LRQCNT=0
+7 ;
+8 ; ^LR(13,"CH",7038789.916,0)
+9 ;
+10 ; This block builds a TMP global of data relevant for the date
+11 ; range LRSDTX to LREDT
+12 ;
+13 ;--->New concept employed; gather only LRDFN(s) in date range
+14 ; archive only these
+15 ;
+16 SET LRV7=LREDT
+17 SET LRSDTX=9999999-LR(1)
+18 SET LREDT=9999999-LRV7
IF $EXTRACT(LREDT,1,1)=2
SET LREDT=LRV7
+19 SET LRDFN="^LR(1,0)"
+20 SET ^TMP("LR9","RANGE")=LRSDTX_U_LREDT
+21 ;
+22 FOR
SET LRDFN=$QUERY(@LRDFN)
IF $PIECE(LRDFN,",")'["LR("
QUIT
SET LR9=$PIECE(LRDFN,",",3)
Begin DoDot:1
+23 IF $PIECE(LRDFN,",",2)'["CH"
QUIT
+24 SET LR8=+$PIECE(LRDFN,"LR(",2)
IF LR8'>0
QUIT
+25 IF LR9>LRSDTX
IF LR9<LREDT
Begin DoDot:2
+26 IF $PIECE(^LR(LR8,0),U,2)=2
SET ^TMP("LR9",LR8)=^LR(LR8,0)_U_LR9_U_LREDT_U_+^LR(LR8,"CH",LR9,0)
Begin DoDot:3
+27 SET $PIECE(LRDFN,"LR(",2)=LR8+.1_","_$PIECE(LRDFN,LR8_",",2)
+28 SET LRQCNT=LRQCNT+1
End DoDot:3
+29 SET LR5=$LENGTH(LRDFN)
+30 IF $EXTRACT(LRDFN,LR5,LR5)'=")"
SET LRDFN=LRDFN_")"
End DoDot:2
End DoDot:1
+31 DO NOW^%DTC
SET ^TMP("LR9","END0")=%
+32 QUIT
DISPLAY ;
+1 WRITE !,"My preliminary screening process reveals ",$GET(LRQCNT)," LRDFN(s)."
+2 QUIT
+3 ;
+4 ;
LR ;
+1 DO DQ1^LRARCHIV
+2 DO QUERY
+3 SET LRWHICH="CH"
+4 KILL ^TMP("LRT2")
+5 SET LRDFN=0
+6 ;
+7 ;********************************************************************
+8 ; *
+9 ; Leave Micro question for next go-round *
+10 ; *
+11 ;********************************************************************
+12 ;
+13 FOR
SET LRDFN=$ORDER(^TMP("LR9",LRDFN))
IF +LRDFN'>0
QUIT
Begin DoDot:1
+14 SET LRDPF=$PIECE(^TMP("LR9",LRDFN),U,2)
SET DFN=$PIECE(^(LRDFN),U,3)
+15 IF +LRDPF=2
SET RC1=1
DO PT
+16 IF +LRDPF'=2
QUIT
+17 SET LRIDT=$PIECE(^TMP("LR9",LRDFN),U,7)
+18 SET LRSS="CH"
DO LAB
End DoDot:1
IF LRDFN'>0
DO TEND
QUIT
+19 DO LST^LRARCHIV
+20 DO QUIT^LRARCHIV
+21 QUIT
LAB ;
+1 SET LRJTX=$PIECE(^LR(0),U,4)
+2 SET LRIDT=LRIDT-.1
+3 FOR
SET LRIDT=$ORDER(^LR(LRDFN,LRSS,LRIDT))
IF +LRIDT'>0!(LRIDT>LREDT)
QUIT
Begin DoDot:1
+4 IF $DATA(^LR(LRDFN,LRSS,LRIDT,0))
SET LRDT7=+^(0)
+5 SET LRI=$GET(LRI)+1
+6 ;D JOBTIME^LRAC12
+7 WRITE "."
+8 DO LAB1
End DoDot:1
+9 QUIT
+10 ;
LAB1 ;
+1 Begin DoDot:1
+2 IF 'LRIDT
QUIT
+3 IF '$DATA(PNM)
DO PT
+4 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,0))
Begin DoDot:2
+5 SET ^TMP("LRBAD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
End DoDot:2
QUIT
+6 SET LRDAT=^LR(LRDFN,LRSS,LRIDT,0)
+7 IF LRSS="CH"
IF '$PIECE(LRDAT,U,3)
Begin DoDot:2
+8 SET ^TMP("LRUNV",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
End DoDot:2
QUIT
+9 IF $ORDER(^LR(LRDFN,LRSS,LRIDT,0))=""!('+$ORDER(^(0)))
Begin DoDot:2
+10 SET ^TMP("LRNOD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
End DoDot:2
QUIT
End DoDot:1
IF LRIDT<1
DO UPDT
QUIT
+11 ;
+12 IF $LENGTH($PIECE(LRDAT,U,9))
DO CHECKX
+13 ;
+14 QUIT
+15 ;
+16 ;----------------------------------------------------------------------
+17 ;------Here is where we check the major header and force to perm.
+18 ;
CHECKX ;Major Header
SET LRMH=$PIECE($PIECE(LRDAT,U,9),":")
+1 ;PAGE
SET LRFG=$PIECE($PIECE(LRDAT,U,9),":",2)
+2 ;
+3 ; Checking all the test for different major header
+4 ;
+5 ;
+6 SET TEST=.5
+7 FOR
SET TEST=$ORDER(^LR(LRDFN,"CH",LRIDT,TEST))
IF +TEST'>0
QUIT
Begin DoDot:1
+8 IF $DATA(^TMP("LRT2",TEST))#2
QUIT
+9 DO ^LRAR02
End DoDot:1
+10 ;--------------------------------------------------------------------
+11 ;
+12 DO MOVE
+13 QUIT
+14 ;
TEND ;
+1 WRITE @IOF
+2 WRITE !!,"The SEARCH process is complete."
+3 WRITE !!,$PIECE(LRI/LRJT0*100,".")," Percent of ^LR was searched"
+4 DO STAMP^LRX
+5 WRITE !,"Total patient count: ",LRC2,". Specimen count: ",LRC3,!
KILL LRDFN
+6 QUIT
+7 ;
UPDT ;
+1 SET X=0
SET LRCNT=0
+2 FOR I=0:0
SET X=$ORDER(^LR(LRDFN,LRSS,X))
IF X<1
QUIT
SET LRCNT=LRCNT+1
+3 ;--------------------------------------------CH-----------MICRO NO BB?
+4 IF LRCNT=0
SET ^LR(LRDFN,LRSS,0)=$SELECT(LRSS="CH":"^63.04D",1:"^63.05DA")
QUIT
+5 SET $PIECE(^LR(LRDFN,LRSS,0),U,4)=LRCNT
+6 QUIT
RCC ;
+1 ;REMOVE CONTROL CHAR.
+2 SET X=LRDAT
+3 SET LRDAT=""
+4 FOR I=1:1:$LENGTH(X)
SET LRDAT=LRDAT_$SELECT($ASCII(X,I)>126:"",$ASCII(X,I)>31:$EXTRACT(X,I),1:"")
+5 SET ^LR(LRDFN,LRSS,LRIDT,I1)=LRDAT
+6 QUIT
