121 lines
4.1 KiB
Mathematica
121 lines
4.1 KiB
Mathematica
LRLSTWRL ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST PART 2 ;2/6/91 07:41 ;
|
|
;;5.2;LAB SERVICE;**153,201**;Sep 27, 1994
|
|
EN ;from LRLSTWRK
|
|
CONTROL ;
|
|
S LROK=1,LREND=0
|
|
W:$E(IOST,1,2)="C-" @IOF
|
|
D INIT
|
|
D LOOP1
|
|
D END
|
|
Q
|
|
INIT ;
|
|
S CNT=0
|
|
S LR("TIME")="$$FMTE^XLFDT($$NOW^XLFDT,""1"")"
|
|
Q
|
|
LOOP1 ;
|
|
F LRPGC=1:1:LRNTP S LRPTO=LRPGC-1*LRNTPP D L1
|
|
Q
|
|
L1 ;
|
|
Q:$G(LREND)
|
|
U IO
|
|
I $G(CNT)=1 D LRSTOP Q:$G(LREND)=1 W @IOF,!
|
|
W:LRAD'<1 @LR("TIME")
|
|
D LOOP2
|
|
Q
|
|
LOOP2 ;
|
|
F LRAA=1:1:LR(1) D Q:$G(LREND)=1
|
|
. W !,?20,"SHORT ",$P(^LRO(68,LRAA(LRAA),0),U,1)," ACCESSION"
|
|
I $D(LRSTAR),$D(LAST),LRSTAR>1,LAST>1 D
|
|
. W !,"FROM DATE: "
|
|
. S Y=LRSTAR\1
|
|
. D DD^LRX
|
|
. W Y,!,"TO DATE: "
|
|
. S Y=LAST\1 D DD^LRX W Y,!
|
|
D HEAD1
|
|
D LOOP3
|
|
Q
|
|
HEAD1 ;
|
|
D ^LRWLHEAD
|
|
W !
|
|
D L27
|
|
Q
|
|
LOOP3 ;
|
|
S LRAN=0
|
|
F S LRAN=$O(^TMP($J,LRPGC,LRAN)) Q:LRAN<1!($G(LREND)=1) D L24
|
|
Q
|
|
L24 ;
|
|
S LRACC=""
|
|
F S LRACC=$O(^TMP($J,LRPGC,LRAN,LRACC)) Q:LRACC="" D
|
|
. S LRDFN=0 Q:$G(LREND)=1 D
|
|
.. F S LRDFN=$O(^TMP($J,LRPGC,LRAN,LRACC,LRDFN)) Q:LRDFN<1 D
|
|
... Q:$G(LREND)=1 D L26
|
|
Q
|
|
L26 ;
|
|
Q:$G(LREND)=1
|
|
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
|
|
S LRTEST=$O(^TMP($J,LRPGC,LRAN,LRACC,LRDFN,0)),X=^(LRTEST)
|
|
S LRLLOC=$P(X,U,1)
|
|
S LRURG=$P(X,U,2)
|
|
S LRCEN=$P(X,U,5)
|
|
S T(2)=$P(X,U,6)
|
|
S T(5)=$P(X,U,8)
|
|
S LRUID=$P(X,U,9)
|
|
S LRSPEC=$S($D(^LAB(61,+$P(X,U,4),0)):$E($P(^(0),U,1),1,5),1:"")
|
|
I +T(2) S Y=+T(2) D DD^LRX S LRCDT=Y_$E(T(2),$L(T(2)))
|
|
I '+T(2) S LRCDT=T(2)
|
|
;Q:$G(LREND)=1
|
|
F I=1:1:LR(4) W !
|
|
Q:$G(LREND)=1
|
|
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)
|
|
I 'LR(3) W ! W:LRCEN ?11,"ORD:",LRCEN W ?20," ",LRCDT
|
|
E W ?40 W:LRCEN "ORD:",LRCEN W " ",LRCDT
|
|
W !,?11,"UID: ",LRUID
|
|
D LOOP4
|
|
Q
|
|
LOOP4 ;
|
|
F LRTEST=LRPTO+1:1:LRPTO+LRNTPP D
|
|
. ;I '$D(LRTEST(LRTEST)) S LREND=1 Q
|
|
. W ?($S(LR(4)>1:7,1:5)*(LRTEST-LRPTO)+35+LR(3))
|
|
. W $S('$D(^TMP($J,LRPGC,LRAN,LRACC,LRDFN,LRTEST)):"|",1:"") I $D(^(LRTEST)) W $P(^(LRTEST),U,3)
|
|
W ?($S(LR(4)>1:7,1:5)*(LRNTPP+1)+34+LR(3))
|
|
W " ",LRSPEC
|
|
I $Y>(IOSL-7) D LRSTOP Q:$G(LREND)=1 W @IOF W:LRAD'<1 @LR("TIME") D L27
|
|
I LRDPF=2,'T(5) W " NC"
|
|
Q
|
|
L27 ;
|
|
Q:$G(LREND)
|
|
F I=1:1:10 D L30
|
|
W !,"ACC #"
|
|
Q
|
|
LRSTOP ;
|
|
S CNT=1
|
|
Q:$E(IOST,1,2)="P-"
|
|
K DIR
|
|
S DIR(0)="E"
|
|
D ^DIR
|
|
I $D(DUOUT)!($D(DIRUT)) S LREND=1 Q
|
|
Q
|
|
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."
|
|
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)."
|
|
Q
|
|
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)
|
|
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:".")
|
|
Q
|
|
END ;from LRLSTWRK
|
|
W ! W:$E(IOST,1,2)="P-" @IOF
|
|
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)
|
|
K %,%H,B,C1,LAST,LREDT,LRLINE,LRWDTL,POP,T1,LRORD,LRTSTS,LRUID
|
|
K AGE,A,DFN,DIC,DOB,I,J,K,LRLAN,LRDFN,LRDPF,PNM,S2,S3,S4,SEX,SSN,T5,X,Y,Z
|
|
K LRXX,LROK,T4,OK
|
|
D ^%ZISC Q
|
|
;NTPP=number tests/page, LRPTO=page test offset, LRPGC=page cnt, LRNTP=number of test pages
|
|
;LR(1)=# of acc areas, 2=see unverified, 3=wide, 4=spacing
|
|
LRAA ;from LRLSTWRK
|
|
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
|
|
K W2,DIC,J,T2 S LREND=(X[U)!(LR(1)=0) Q
|
|
CHKDAT ;from LRLIST
|
|
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
|
|
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
|
|
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
|
|
Q
|