Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAR04

LRAR04.m

Go to the documentation of this file. 
  1. 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
  1.  ;;5.2;LAB SERVICE;**111**;Sep 27, 1994
  1.  ;
  1.  ;    Rewrite 11/96 Hoak --------------->
  1.  ;
  1.  Q  ;LRC2=NUMBER OF PT, LRC3=NUMBER OF DATES
  1. MOVE ;
  1.  ;  This is where we make the copies to be archived  <----------
  1.  ;
  1.  ;      Move data from ^LR to ^LAR------>arcive global----------|
  1.  ;                                                              |
  1.  S LRCNT=$P(^LR(LRDFN,LRSS,0),U,3,4) ;                          |
  1.  S:LRSS="CH" ^LAR("Z",LRDFN,LRSS,0)="^63.999904D^"_LRCNT ;      |
  1.  S:LRSS="MI" ^LAR("Z",LRDFN,LRSS,0)="^63.999905DA^"_LRCNT ;     |
  1.  S %X="^LR(LRDFN,LRSS,LRIDT," ;                                 |
  1.  S %Y="^LAR(""Z"",LRDFN,LRSS,LRIDT," ;                          |
  1.  ;                                                              |
  1.  D %XY^%RCR ; <-------------------------------------------------/
  1.  ;
  1.  ;
  1.  S:LRC1 LRC2=LRC2+1,LRC1=0
  1.  S ^LAR("Z",LRDFN,0)=^LR(LRDFN,0)
  1.  S ^LAR("Z","B",LRDFN,LRDFN)=""
  1.  S ^LAR("NAME",PNM,LRDFN)=""
  1.  S ^LAR("SSN",SSN,LRDFN)=""
  1.  S LRC3=LRC3+1
  1.  QUIT
  1.  ;
  1. PT ;
  1.  S PNM="unk",SSN="unk"
  1.  Q:LRDPF<1  D DEM^LRX
  1.  S:SSN="" SSN="unk" S:PNM="" PNM="unk"
  1.  QUIT
  1.  ;
  1.  ;
  1. DFN ;
  1.  ;from LRARCHIV
  1.  ;
  1.  ;
  1.  S LRI=0
  1.  S LRJT0=$P(^LR(0),U,4)
  1.  I '$G(LRDT7) S LRDT7=LR(1)
  1.  ;
  1. CONTROL ;
  1.  S LRDFN=0
  1.  Q
  1.  ;
  1.  ;
  1. QUERY ;
  1.  D DFN
  1.  D NOW^%DTC S ^TMP("LR9","ENDX")=%
  1.  S LRDFN=0
  1.  K ^TMP("LR9")
  1.  D NOW^%DTC S ^TMP("LR9","START")=%
  1.  S LRQCNT=0
  1.  ;
  1.  ;        ^LR(13,"CH",7038789.916,0)
  1.  ;
  1.  ;  This block builds a TMP global of data relevant for the date
  1.  ;  range LRSDTX to LREDT
  1.  ;
  1.  ;--->New concept employed; gather only LRDFN(s) in date range
  1.  ;    archive only these
  1.  ;
  1.  S LRV7=LREDT
  1.  S LRSDTX=9999999-LR(1)
  1.  S LREDT=9999999-LRV7 I $E(LREDT,1,1)=2 S LREDT=LRV7
  1.  S LRDFN="^LR(1,0)"
  1.  S ^TMP("LR9","RANGE")=LRSDTX_U_LREDT
  1.  ;
  1.  F  S LRDFN=$Q(@LRDFN) Q:$P(LRDFN,",")'["LR("  S LR9=$P(LRDFN,",",3) D
  1.  .  Q:$P(LRDFN,",",2)'["CH"
  1.  .  S LR8=+$P(LRDFN,"LR(",2) Q:LR8'>0
  1.  .  I LR9>LRSDTX,LR9<LREDT D
  1.  ..  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
  1.  ...  S $P(LRDFN,"LR(",2)=LR8+.1_","_$P(LRDFN,LR8_",",2)
  1.  ...  S LRQCNT=LRQCNT+1
  1.  ..  S LR5=$L(LRDFN)
  1.  ..  I $E(LRDFN,LR5,LR5)'=")" S LRDFN=LRDFN_")"
  1.  D NOW^%DTC S ^TMP("LR9","END0")=%
  1.  Q
  1. DISPLAY ;
  1.  W !,"My preliminary screening process reveals ",$G(LRQCNT)," LRDFN(s)."
  1.  Q
  1.  ;
  1.  ;
  1. LR ;
  1.  D DQ1^LRARCHIV
  1.  D QUERY
  1.  S LRWHICH="CH"
  1.  K ^TMP("LRT2")
  1.  S LRDFN=0
  1.  ;
  1.  ;********************************************************************
  1.  ;                                                                   *
  1.  ;      Leave Micro question for next go-round                       *
  1.  ;                                                                   *
  1.  ;********************************************************************
  1.  ;
  1.  F  S LRDFN=$O(^TMP("LR9",LRDFN)) Q:+LRDFN'>0  D  I LRDFN'>0 D TEND QUIT
  1.  .  S LRDPF=$P(^TMP("LR9",LRDFN),U,2) S DFN=$P(^(LRDFN),U,3)
  1.  .  I +LRDPF=2 S RC1=1 D PT
  1.  .  I +LRDPF'=2 QUIT
  1.  .  S LRIDT=$P(^TMP("LR9",LRDFN),U,7)
  1.  .  S LRSS="CH" D LAB
  1.  D LST^LRARCHIV
  1.  D QUIT^LRARCHIV
  1.  Q
  1. LAB ;
  1.  S LRJTX=$P(^LR(0),U,4)
  1.  S LRIDT=LRIDT-.1
  1.  F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:+LRIDT'>0!(LRIDT>LREDT)  D
  1.  .  I $D(^LR(LRDFN,LRSS,LRIDT,0)) S LRDT7=+^(0)
  1.  .  S LRI=$G(LRI)+1
  1.  .  ;D JOBTIME^LRAC12
  1.  .  W "."
  1.  .  D LAB1
  1.  Q
  1.  ;
  1. LAB1 ;
  1.  D  I LRIDT<1 D UPDT Q
  1.  .  Q:'LRIDT
  1.  .  I '$D(PNM) D PT
  1.  .  IF '$D(^LR(LRDFN,LRSS,LRIDT,0)) D  QUIT
  1.  ..  S ^TMP("LRBAD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
  1.  .  S LRDAT=^LR(LRDFN,LRSS,LRIDT,0)
  1.  .  IF LRSS="CH",'$P(LRDAT,U,3) D  QUIT
  1.  ..  S ^TMP("LRUNV",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
  1.  .  IF $O(^LR(LRDFN,LRSS,LRIDT,0))=""!('+$O(^(0))) D  QUIT
  1.  ..  S ^TMP("LRNOD",LRDFN,LRSS,LRIDT)=PNM_" "_LRIDT
  1.  ;
  1.  I $L($P(LRDAT,U,9)) D CHECKX
  1.  ;
  1.  QUIT
  1.  ;
  1.  ;----------------------------------------------------------------------
  1.  ;------Here is where we check the major header  and force to perm.
  1.  ;
  1. CHECKX S LRMH=$P($P(LRDAT,U,9),":")  ;Major Header
  1.  S LRFG=$P($P(LRDAT,U,9),":",2)  ;PAGE
  1.  ;
  1.  ;     Checking all the test for different major header
  1.  ;
  1.  ;
  1.  S TEST=.5
  1.  F  S TEST=$O(^LR(LRDFN,"CH",LRIDT,TEST)) Q:+TEST'>0  D
  1.  .  Q:$D(^TMP("LRT2",TEST))#2
  1.  .  D ^LRAR02
  1.  ;--------------------------------------------------------------------
  1.  ;
  1.  D MOVE
  1.  Q
  1.  ;
  1. TEND ;
  1.  W @IOF
  1.  W !!,"The SEARCH process is complete."
  1.  W !!,$P(LRI/LRJT0*100,".")," Percent of ^LR was searched"
  1.  D STAMP^LRX
  1.  W !,"Total patient count: ",LRC2,". Specimen count: ",LRC3,! K LRDFN
  1.  QUIT
  1.  ;
  1. UPDT ;
  1.  S X=0,LRCNT=0
  1.  F I=0:0 S X=$O(^LR(LRDFN,LRSS,X)) Q:X<1  S LRCNT=LRCNT+1
  1.  ;--------------------------------------------CH-----------MICRO NO BB?
  1.  I LRCNT=0 S ^LR(LRDFN,LRSS,0)=$S(LRSS="CH":"^63.04D",1:"^63.05DA") Q
  1.  S $P(^LR(LRDFN,LRSS,0),U,4)=LRCNT
  1.  Q
  1. RCC ;
  1.  ;REMOVE CONTROL CHAR.
  1.  S X=LRDAT
  1.  S LRDAT=""
  1.  F I=1:1:$L(X) S LRDAT=LRDAT_$S($A(X,I)>126:"",$A(X,I)>31:$E(X,I),1:"")
  1.  S ^LR(LRDFN,LRSS,LRIDT,I1)=LRDAT
  1.  QUIT