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

LRARCHIV.m

Go to the documentation of this file. 
  1. LRARCHIV ;SLC/RWF/DAL/HOAK FIRST ROUTINE FOR PATIENT ARCHIVE ; 12/12/96  10:16 ;
  1.  ;;5.2;LAB SERVICE;**59,111**;Sep 27, 1994
  1.  ;
  1.  ;  Taken from--> SET UP O("S") VARIABLES FOR ARCHIVE. ;2/5/91  12:30 ;
  1. INIT ;
  1.  ;
  1.  ;
  1.  ;
  1.  K ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
  1.  ;
  1.  S OK=1
  1.  ;          Rewrite of basic archive SEARCH function for ^LR data
  1.  ;
  1.  ;--> Following the F1 variable tells you where you are
  1.  ;
  1.  ;^LAB(69.9,1,6,1,0) = ARCH-1^VAMC^2970318.0941^1^2970318
  1.  ;
  1.  ;--> F1=1 or 2 or 3 or 4or 5 depending what step has been done
  1.  ;                                              
  1.  ;DATA TYPE:       Set of Codes                 |
  1.  ;                 1:Searching------------------|               
  1.  ;                 2:Search done----------------|
  1.  ;                 3:Clear----------------------|
  1.  ;                 4:Purging--------------------|
  1.  ;                 5:Purge done-----------------|
  1.  ;SERCHING:
  1.  ;  Looks through the entire LR global by patient (LRDFN) for all
  1.  ;  eligible entries by date.
  1.  ;  New functionality also make certain all associated eligiable data is
  1.  ;  forced to a perminant cume page.
  1.  ;
  1.  I '$G(F1) G MEET QUIT
  1.  S OK=1 D RESTART^LRAR06:$G(F1)=1
  1.  I 'OK D END QUIT
  1.  ;
  1.  I $G(F1)>1 W !,"Please finish the Clear and Purge steps first." D QUIT Q
  1.  ;
  1.  I $G(F1)=0 S:'$D(^LAB(69.9,1,6,0)) ^LAB(69.9,1,6,0)="^69.9003A^^" D TAPE^LRAR06
  1.  ;
  1.  I $G(DA)<1!($G(P1)<1) D QUIT Q
  1. PAT ;
  1.  ;    Entry for testing--------------------->
  1. STEPOUT ;
  1. MEET ;
  1.  W @IOF,!!,"Welcome to The Search Option for the New Archive Modual",!
  1.  ;
  1.  I '$G(P1) S OK=1 D TAPE^LRAR06 I 'OK D END QUIT
  1.  ;E  W !,"A file entry IS NOT present"
  1.  ;
  1.  ;            Make a list of data or not
  1.  ;
  1.  ;
  1.  W !,"Shall I prepare a list of patients that will have data archived"
  1.  S %=2 D YN^DICN
  1.  ;
  1. QUES I %=0 W !,"Answering YES to this question will produce" D  G PAT
  1.  .  W "a list of patients that will have data archived."
  1.  ;
  1.  S LRPAT=0 S:%=1 LRPAT=1
  1. T ;
  1.  I '$G(P1) W !,"Tape name not defined. Please start again."
  1.  I  QUIT
  1.  ;
  1.  S ^LAB(69.9,1,"TAPE")=P1
  1.  S $P(^LAB(69.9,1,6,P1,0),U,4)=1 ;---SEARCH IS IN PROGRESS
  1.  S X=1
  1.  S LRP1=P1
  1.  D LRSUB1 D DEVICE
  1.  QUIT
  1. END ;
  1.  D QUIT
  1.  Q
  1.  ;
  1. DEVICE ;
  1.  S %ZIS="Q"
  1. QUE ;
  1.  S ZTSAVE("LR*")="",ZTRTN="LR^LRAR04",ZTDESC="Archive search option."
  1.  S ZTSAVE("LR*")=""
  1.  S ZTSAVE("^TMP(""LR9""")=""
  1.  D IO^LRWU
  1.  QUIT
  1. DQ1 ;
  1.  ;
  1.  K OK,LRI
  1.  U IO
  1.  S LRC1=1,LRC2=0,LRC3=0,Y=LR(1)
  1.  D DD^LRX
  1.  W @IOF,!,"LAB DATA ARCHIVE for data before ",Y
  1.  W ". on " D STAMP^LRX S X=1 X ^%ZOSF("PRIORITY")
  1.  I '$G(LREDT3) D TIME^LRAR06
  1.  S X2=LREDT3,X1=LR(1) D ^%DTC
  1.  W !!,"Number of Days To be searched: ",X
  1.  QUIT
  1.  ;
  1.  ;      Get test data names from 63.04
  1.  ;
  1. LRSUB1 S LRSUB=1
  1.  F  S LRSUB=$O(^DD(63.04,LRSUB)) Q:LRSUB<1  D
  1.  .  I $D(^DD(63.04,LRSUB,0)),'$D(^DD(63.999904,LRSUB)) D
  1.  ..  S LRX0=^DD(63.04,LRSUB,0) S LRX3=$S($D(^(3)):^(3),1:"")
  1.  ..  S ^DD(63.999904,LRSUB,0)=LRX0 S:LRX3'="" ^(3)=LRX3
  1.  ..  S ^DD(63.999904,"B",$P(LRX0,U),LRSUB)=""
  1.  K X,Y,L1,L2
  1.  ;
  1.  ;D ^AAHAGL
  1.  ;
  1.  ;QUIT  ;****************************************************
  1.  ;
  1.  ;
  1.  ;
  1. PROCESS ;
  1.  ;
  1.  ;
  1.  K ^LAR("DHZ")
  1.  ;
  1.  K ^TMP("LRT2")
  1.  ;
  1.  D SET^LRAR03
  1.  ;
  1.  ;
  1.  ;S $P(^LAB(69.9,1,6,P1,0),U,4)=2 L -^LAR
  1.  QUIT
  1. LST ;
  1.  W @IOF
  1.  S OK=1
  1.  U IO
  1.  S LRPAGE=1
  1.  D HEAD
  1.  I $G(LRPAT) W !! S PNM="" F  S PNM=$O(^LAR("NAME",PNM)) Q:PNM=""  D
  1.  .  S LRDFN=0
  1.  .  F  S LRDFN=$O(^LAR("NAME",PNM,LRDFN)) Q:+LRDFN'>0!('OK)  D
  1.  ..  I $D(^LR(LRDFN,0))#2 N PNM S LRDPF=$P(^LR(LRDFN,0),"^",2) D
  1.  ...  Q:'OK
  1.  ...  S DFN=$P(^LR(LRDFN,0),"^",3)
  1.  ...  D CHKPG Q:'OK  D DEM^LRX W !,PNM,?30,SSN
  1.  ..  I '$D(^LR(LRDFN,0))#2 D
  1.  ...  W !!,PNM," LRDFN # "_LRDFN_" Has Been Deleted from ^LR( ",!,$C(7),"SSN = Unknown",!
  1.  ;
  1. LISTS ;
  1.  ;
  1.  I 'OK S OK=1 G AROUND
  1.  I IOST'["C-" G AROUND
  1.  S OK=1
  1.  I IOST["C-" S DIR(0)="E" D ^DIR
  1. AROUND F LRQ="^TMP(""LRBAD"")","^TMP(""LRUNV"")","^TMP(""LRNOD"")" Q:LRQ=""  D
  1.  .  W @IOF
  1.  .  W !,$$CJ^XLFSTR($S(LRQ["LRBAD":"Entries with bad Data",LRQ["LRUNV":"Entries that were not verified",1:"Entries with no data"),IOM),!!
  1.  .  F  S LRQ=$Q(@LRQ) Q:LRQ'["LR"  D CHKPG Q:'OK  W !,@LRQ
  1. QUIT ;
  1.  D KILL^LRAR01 D KVAR^VADPT K F1,LRC1,LRC2,LRC3 U IO(0)
  1.  ;
  1.  I $G(LRP1) S $P(^LAB(69.9,1,6,LRP1,0),U,4)=2 ;----SEARCH IS DONE
  1.  ;
  1.  K ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
  1.  QUIT
  1. CHKPG ;
  1.  Q:'OK
  1.  I IOSL-$Y'>3&($E(IOST,1,2)="C-") S DIR(0)="E" D ^DIR K DIR D
  1.  .  W @IOF
  1.  .  I $D(DTOUT)!($D(DUOUT)) S OK=0
  1.  Q:'OK
  1.  I IOSL-$Y'>3&($E(IOST,1,2)="P-") S LRPAGE=LRPAGE+1 D HEAD
  1.  ;
  1.  QUIT
  1.  W $$RJ^XLFSTR("Page "_LRPAGE,IOM),!
  1.  Q
  1. CLEAN ;
  1.  D CLEAN^LRAR01
  1.  Q
  1. PURGE ;
  1.  D PURGE^LRAR01 
  1.  Q