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

LRLSTWRL.m

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