| [613] | 1 | LRLSTWRL ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST PART 2 ;2/6/91 07:41 ;
|
|---|
| 2 | ;;5.2;LAB SERVICE;**153,201**;Sep 27, 1994
|
|---|
| 3 | EN ;from LRLSTWRK
|
|---|
| 4 | CONTROL ;
|
|---|
| 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
|
|---|
| 11 | INIT ;
|
|---|
| 12 | S CNT=0
|
|---|
| 13 | S LR("TIME")="$$FMTE^XLFDT($$NOW^XLFDT,""1"")"
|
|---|
| 14 | Q
|
|---|
| 15 | LOOP1 ;
|
|---|
| 16 | F LRPGC=1:1:LRNTP S LRPTO=LRPGC-1*LRNTPP D L1
|
|---|
| 17 | Q
|
|---|
| 18 | L1 ;
|
|---|
| 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
|
|---|
| 25 | LOOP2 ;
|
|---|
| 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
|
|---|
| 37 | HEAD1 ;
|
|---|
| 38 | D ^LRWLHEAD
|
|---|
| 39 | W !
|
|---|
| 40 | D L27
|
|---|
| 41 | Q
|
|---|
| 42 | LOOP3 ;
|
|---|
| 43 | S LRAN=0
|
|---|
| 44 | F S LRAN=$O(^TMP($J,LRPGC,LRAN)) Q:LRAN<1!($G(LREND)=1) D L24
|
|---|
| 45 | Q
|
|---|
| 46 | L24 ;
|
|---|
| 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
|
|---|
| 53 | L26 ;
|
|---|
| 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
|
|---|
| 75 | LOOP4 ;
|
|---|
| 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
|
|---|
| 85 | L27 ;
|
|---|
| 86 | Q:$G(LREND)
|
|---|
| 87 | F I=1:1:10 D L30
|
|---|
| 88 | W !,"ACC #"
|
|---|
| 89 | Q
|
|---|
| 90 | LRSTOP ;
|
|---|
| 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
|
|---|
| 98 | L15 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
|
|---|
| 101 | L30 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
|
|---|
| 104 | END ;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
|
|---|
| 113 | LRAA ;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
|
|---|
| 116 | CHKDAT ;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
|
|---|
