source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRARCHIV.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1LRARCHIV ;SLC/RWF/DAL/HOAK FIRST ROUTINE FOR PATIENT ARCHIVE ; 12/12/96 10:16 ;
2 ;;5.2;LAB SERVICE;**59,111**;Sep 27, 1994
3 ;
4 ; Taken from--> SET UP O("S") VARIABLES FOR ARCHIVE. ;2/5/91 12:30 ;
5INIT ;
6 ;
7 ;
8 ;
9 K ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
10 ;
11SEARCH ;
12 S OK=1
13 ; Rewrite of basic archive SEARCH function for ^LR data
14 ;
15 ;--> Following the F1 variable tells you where you are
16 ;
17 ;^LAB(69.9,1,6,1,0) = ARCH-1^VAMC^2970318.0941^1^2970318
18 ;
19 ;--> F1=1 or 2 or 3 or 4or 5 depending what step has been done
20 ;
21 ;DATA TYPE: Set of Codes |
22 ; 1:Searching------------------|
23 ; 2:Search done----------------|
24 ; 3:Clear----------------------|
25 ; 4:Purging--------------------|
26 ; 5:Purge done-----------------|
27 ;SERCHING:
28 ; Looks through the entire LR global by patient (LRDFN) for all
29 ; eligible entries by date.
30 ; New functionality also make certain all associated eligiable data is
31 ; forced to a perminant cume page.
32 ;
33 I '$G(F1) G MEET QUIT
34 S OK=1 D RESTART^LRAR06:$G(F1)=1
35 I 'OK D END QUIT
36 ;
37 I $G(F1)>1 W !,"Please finish the Clear and Purge steps first." D QUIT Q
38 ;
39 I $G(F1)=0 S:'$D(^LAB(69.9,1,6,0)) ^LAB(69.9,1,6,0)="^69.9003A^^" D TAPE^LRAR06
40 ;
41 I $G(DA)<1!($G(P1)<1) D QUIT Q
42PAT ;
43 ; Entry for testing--------------------->
44STEPOUT ;
45MEET ;
46 W @IOF,!!,"Welcome to The Search Option for the New Archive Modual",!
47 ;
48 I '$G(P1) S OK=1 D TAPE^LRAR06 I 'OK D END QUIT
49 ;E W !,"A file entry IS NOT present"
50 ;
51 ; Make a list of data or not
52 ;
53 ;
54 W !,"Shall I prepare a list of patients that will have data archived"
55 S %=2 D YN^DICN
56 ;
57QUES I %=0 W !,"Answering YES to this question will produce" D G PAT
58 . W "a list of patients that will have data archived."
59 ;
60 S LRPAT=0 S:%=1 LRPAT=1
61T ;
62 I '$G(P1) W !,"Tape name not defined. Please start again."
63 I QUIT
64 ;
65 S ^LAB(69.9,1,"TAPE")=P1
66 S $P(^LAB(69.9,1,6,P1,0),U,4)=1 ;---SEARCH IS IN PROGRESS
67 S X=1
68 S LRP1=P1
69 D LRSUB1 D DEVICE
70 QUIT
71END ;
72 D QUIT
73 Q
74 ;
75DEVICE ;
76 S %ZIS="Q"
77QUE ;
78 S ZTSAVE("LR*")="",ZTRTN="LR^LRAR04",ZTDESC="Archive search option."
79 S ZTSAVE("LR*")=""
80 S ZTSAVE("^TMP(""LR9""")=""
81 D IO^LRWU
82 QUIT
83DQ1 ;
84 ;
85 K OK,LRI
86 U IO
87 S LRC1=1,LRC2=0,LRC3=0,Y=LR(1)
88 D DD^LRX
89 W @IOF,!,"LAB DATA ARCHIVE for data before ",Y
90 W ". on " D STAMP^LRX S X=1 X ^%ZOSF("PRIORITY")
91 I '$G(LREDT3) D TIME^LRAR06
92 S X2=LREDT3,X1=LR(1) D ^%DTC
93 W !!,"Number of Days To be searched: ",X
94 QUIT
95 ;
96 ; Get test data names from 63.04
97 ;
98LRSUB1 S LRSUB=1
99 F S LRSUB=$O(^DD(63.04,LRSUB)) Q:LRSUB<1 D
100 . I $D(^DD(63.04,LRSUB,0)),'$D(^DD(63.999904,LRSUB)) D
101 .. S LRX0=^DD(63.04,LRSUB,0) S LRX3=$S($D(^(3)):^(3),1:"")
102 .. S ^DD(63.999904,LRSUB,0)=LRX0 S:LRX3'="" ^(3)=LRX3
103 .. S ^DD(63.999904,"B",$P(LRX0,U),LRSUB)=""
104 K X,Y,L1,L2
105 ;
106 ;D ^AAHAGL
107 ;
108 ;QUIT ;****************************************************
109 ;
110 ;
111 ;
112PROCESS ;
113 ;
114 ;
115 K ^LAR("DHZ")
116 ;
117 K ^TMP("LRT2")
118 ;
119 D SET^LRAR03
120 ;
121 ;
122 ;S $P(^LAB(69.9,1,6,P1,0),U,4)=2 L -^LAR
123 QUIT
124LST ;
125 W @IOF
126 S OK=1
127 U IO
128 S LRPAGE=1
129 D HEAD
130 I $G(LRPAT) W !! S PNM="" F S PNM=$O(^LAR("NAME",PNM)) Q:PNM="" D
131 . S LRDFN=0
132 . F S LRDFN=$O(^LAR("NAME",PNM,LRDFN)) Q:+LRDFN'>0!('OK) D
133 .. I $D(^LR(LRDFN,0))#2 N PNM S LRDPF=$P(^LR(LRDFN,0),"^",2) D
134 ... Q:'OK
135 ... S DFN=$P(^LR(LRDFN,0),"^",3)
136 ... D CHKPG Q:'OK D DEM^LRX W !,PNM,?30,SSN
137 .. I '$D(^LR(LRDFN,0))#2 D
138 ... W !!,PNM," LRDFN # "_LRDFN_" Has Been Deleted from ^LR( ",!,$C(7),"SSN = Unknown",!
139 ;
140LISTS ;
141 ;
142 I 'OK S OK=1 G AROUND
143 I IOST'["C-" G AROUND
144 S OK=1
145 I IOST["C-" S DIR(0)="E" D ^DIR
146AROUND F LRQ="^TMP(""LRBAD"")","^TMP(""LRUNV"")","^TMP(""LRNOD"")" Q:LRQ="" D
147 . W @IOF
148 . W !,$$CJ^XLFSTR($S(LRQ["LRBAD":"Entries with bad Data",LRQ["LRUNV":"Entries that were not verified",1:"Entries with no data"),IOM),!!
149 . F S LRQ=$Q(@LRQ) Q:LRQ'["LR" D CHKPG Q:'OK W !,@LRQ
150QUIT ;
151 D KILL^LRAR01 D KVAR^VADPT K F1,LRC1,LRC2,LRC3 U IO(0)
152 ;
153 I $G(LRP1) S $P(^LAB(69.9,1,6,LRP1,0),U,4)=2 ;----SEARCH IS DONE
154 ;
155 K ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
156 QUIT
157CHKPG ;
158 Q:'OK
159 I IOSL-$Y'>3&($E(IOST,1,2)="C-") S DIR(0)="E" D ^DIR K DIR D
160 . W @IOF
161 . I $D(DTOUT)!($D(DUOUT)) S OK=0
162 Q:'OK
163 I IOSL-$Y'>3&($E(IOST,1,2)="P-") S LRPAGE=LRPAGE+1 D HEAD
164 ;
165 QUIT
166HEAD ;
167 W $$RJ^XLFSTR("Page "_LRPAGE,IOM),!
168 Q
169CLEAN ;
170 D CLEAN^LRAR01
171 Q
172PURGE ;
173 D PURGE^LRAR01
174 Q
Note: See TracBrowser for help on using the repository browser.