source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLSTWRL.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.1 KB
Line 
1LRLSTWRL ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST PART 2 ;2/6/91 07:41 ;
2 ;;5.2;LAB SERVICE;**153,201**;Sep 27, 1994
3EN ;from LRLSTWRK
4CONTROL ;
5 S LROK=1,LREND=0
6 W:$E(IOST,1,2)="C-" @IOF
7 D INIT
8 D LOOP1
9 D END
10 Q
11INIT ;
12 S CNT=0
13 S LR("TIME")="$$FMTE^XLFDT($$NOW^XLFDT,""1"")"
14 Q
15LOOP1 ;
16 F LRPGC=1:1:LRNTP S LRPTO=LRPGC-1*LRNTPP D L1
17 Q
18L1 ;
19 Q:$G(LREND)
20 U IO
21 I $G(CNT)=1 D LRSTOP Q:$G(LREND)=1 W @IOF,!
22 W:LRAD'<1 @LR("TIME")
23 D LOOP2
24 Q
25LOOP2 ;
26 F LRAA=1:1:LR(1) D Q:$G(LREND)=1
27 . W !,?20,"SHORT ",$P(^LRO(68,LRAA(LRAA),0),U,1)," ACCESSION"
28 I $D(LRSTAR),$D(LAST),LRSTAR>1,LAST>1 D
29 . W !,"FROM DATE: "
30 . S Y=LRSTAR\1
31 . D DD^LRX
32 . W Y,!,"TO DATE: "
33 . S Y=LAST\1 D DD^LRX W Y,!
34 D HEAD1
35 D LOOP3
36 Q
37HEAD1 ;
38 D ^LRWLHEAD
39 W !
40 D L27
41 Q
42LOOP3 ;
43 S LRAN=0
44 F S LRAN=$O(^TMP($J,LRPGC,LRAN)) Q:LRAN<1!($G(LREND)=1) D L24
45 Q
46L24 ;
47 S LRACC=""
48 F S LRACC=$O(^TMP($J,LRPGC,LRAN,LRACC)) Q:LRACC="" D
49 . S LRDFN=0 Q:$G(LREND)=1 D
50 .. F S LRDFN=$O(^TMP($J,LRPGC,LRAN,LRACC,LRDFN)) Q:LRDFN<1 D
51 ... Q:$G(LREND)=1 D L26
52 Q
53L26 ;
54 Q:$G(LREND)=1
55 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
56 S LRTEST=$O(^TMP($J,LRPGC,LRAN,LRACC,LRDFN,0)),X=^(LRTEST)
57 S LRLLOC=$P(X,U,1)
58 S LRURG=$P(X,U,2)
59 S LRCEN=$P(X,U,5)
60 S T(2)=$P(X,U,6)
61 S T(5)=$P(X,U,8)
62 S LRUID=$P(X,U,9)
63 S LRSPEC=$S($D(^LAB(61,+$P(X,U,4),0)):$E($P(^(0),U,1),1,5),1:"")
64 I +T(2) S Y=+T(2) D DD^LRX S LRCDT=Y_$E(T(2),$L(T(2)))
65 I '+T(2) S LRCDT=T(2)
66 ;Q:$G(LREND)=1
67 F I=1:1:LR(4) W !
68 Q:$G(LREND)=1
69 W $P(LRACC," ",1)," ",$P(LRACC," ",3),?11," ",$E(LRLLOC,1,4),?18," ",$E(SSN,$L(SSN)-3,$L(SSN)),?23," ",$E(PNM,1,15)
70 I 'LR(3) W ! W:LRCEN ?11,"ORD:",LRCEN W ?20," ",LRCDT
71 E W ?40 W:LRCEN "ORD:",LRCEN W " ",LRCDT
72 W !,?11,"UID: ",LRUID
73 D LOOP4
74 Q
75LOOP4 ;
76 F LRTEST=LRPTO+1:1:LRPTO+LRNTPP D
77 . ;I '$D(LRTEST(LRTEST)) S LREND=1 Q
78 . W ?($S(LR(4)>1:7,1:5)*(LRTEST-LRPTO)+35+LR(3))
79 . W $S('$D(^TMP($J,LRPGC,LRAN,LRACC,LRDFN,LRTEST)):"|",1:"") I $D(^(LRTEST)) W $P(^(LRTEST),U,3)
80 W ?($S(LR(4)>1:7,1:5)*(LRNTPP+1)+34+LR(3))
81 W " ",LRSPEC
82 I $Y>(IOSL-7) D LRSTOP Q:$G(LREND)=1 W @IOF W:LRAD'<1 @LR("TIME") D L27
83 I LRDPF=2,'T(5) W " NC"
84 Q
85L27 ;
86 Q:$G(LREND)
87 F I=1:1:10 D L30
88 W !,"ACC #"
89 Q
90LRSTOP ;
91 S CNT=1
92 Q:$E(IOST,1,2)="P-"
93 K DIR
94 S DIR(0)="E"
95 D ^DIR
96 I $D(DUOUT)!($D(DIRUT)) S LREND=1 Q
97 Q
98L15 D ^%ZISC U IO(0) W:$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)) !,"Accession: ",^(.2)," added too many tests to the display."
99 W !,"Need more columns on the display than are available, Either use a wider",!,"device or try fewer accessions (fewer tests may be encountered, resulting in",!,"a narrower display)."
100 Q
101L30 W !,$P("Key:^done = mult test comp.^ pen = mult test incomp.^spen = stat mult incomp.^number = result^.... = incomplete^S... = STAT incomp.^ | = not ordered",U,I)
102 F J=1:1:LRNTPP I $D(LRTEST(LRPTO+J)) S C1=$E(LRTEST(LRPTO+J),I) W ?($S(LR(4)>1:7,1:5)*J+25+I+LR(3)),$S(C1'="":C1,1:".")
103 Q
104END ;from LRLSTWRK
105 W ! W:$E(IOST,1,2)="P-" @IOF
106 K LR,LRCDT,LRURG,LREXPD,LRTS,LRSTAR,LRY,LRSS,LRAD,LRAN,LRAA,LRTEST,LRNTP,LRNTPP,LRPGM,LRSDT,LRSN,LRSPEC,T,ZTSK,LRACC,LRCEN,LRENT,LRFAN,LRIDT,LRLLOC,LRPGC,LRPTO,LRWRD,LREX,^TMP("LR",$J)
107 K %,%H,B,C1,LAST,LREDT,LRLINE,LRWDTL,POP,T1,LRORD,LRTSTS,LRUID
108 K AGE,A,DFN,DIC,DOB,I,J,K,LRLAN,LRDFN,LRDPF,PNM,S2,S3,S4,SEX,SSN,T5,X,Y,Z
109 K LRXX,LROK,T4,OK
110 D ^%ZISC Q
111 ;NTPP=number tests/page, LRPTO=page test offset, LRPGC=page cnt, LRNTP=number of test pages
112 ;LR(1)=# of acc areas, 2=see unverified, 3=wide, 4=spacing
113LRAA ;from LRLSTWRK
114 K LRSTAR,LRAA,W2 F J=0:0 D ^DIC Q:Y<1 D CHKDAT Q:Y<1 S DIC("A")="ANOTHER ACCESSION AREA: " I '$D(W2(+Y)) S LR(1)=LR(1)+1,LRAA(LR(1))=+Y,W2(+Y)="",LRSS(LR(1))=$P(LR,U,2) D:$P(LR,U,3)="Y"&'$D(LRSTAR) STAR^LRWU3
115 K W2,DIC,J,T2 S LREND=(X[U)!(LR(1)=0) Q
116CHKDAT ;from LRLIST
117 S LR=^LRO(68,+Y,0),T=$P(LR,U,3) I T="Y",$E(LRAD,4,7)'="0000" W !,"Accession area selected has a YEARLY Accession date, you didn't choose that." S (LR(1),Y)=-1 Q
118 I T="D",$E(LRAD,4,5)="00"!($E(LRAD,6,7)="00") W !,"Accession area selected has a DAILY Accession date, you didn't choose that." S (LR(1),Y)=-1 Q
119 I T="M",$E(LRAD,4,5)="00"!($E(LRAD,6,7)'="00") W !,"Accession area selected has a MONTHLY Accession date, you didn't choose that." S (LR(1),Y)=-1 Q
120 Q
Note: See TracBrowser for help on using the repository browser.