- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLSTWRL 4319 printed Feb 18, 2025@23:42:43 Page 2
- 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
- EN ;from LRLSTWRK
- CONTROL ;
- +1 SET LROK=1
- SET LREND=0
- +2 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +3 DO INIT
- +4 DO LOOP1
- +5 DO END
- +6 QUIT
- INIT ;
- +1 SET CNT=0
- +2 SET LR("TIME")="$$FMTE^XLFDT($$NOW^XLFDT,""1"")"
- +3 QUIT
- LOOP1 ;
- +1 FOR LRPGC=1:1:LRNTP
- SET LRPTO=LRPGC-1*LRNTPP
- DO L1
- +2 QUIT
- L1 ;
- +1 if $GET(LREND)
- QUIT
- +2 USE IO
- +3 IF $GET(CNT)=1
- DO LRSTOP
- if $GET(LREND)=1
- QUIT
- WRITE @IOF,!
- +4 if LRAD'<1
- WRITE @LR("TIME")
- +5 DO LOOP2
- +6 QUIT
- LOOP2 ;
- +1 FOR LRAA=1:1:LR(1)
- Begin DoDot:1
- +2 WRITE !,?20,"SHORT ",$PIECE(^LRO(68,LRAA(LRAA),0),U,1)," ACCESSION"
- End DoDot:1
- if $GET(LREND)=1
- QUIT
- +3 IF $DATA(LRSTAR)
- IF $DATA(LAST)
- IF LRSTAR>1
- IF LAST>1
- Begin DoDot:1
- +4 WRITE !,"FROM DATE: "
- +5 SET Y=LRSTAR\1
- +6 DO DD^LRX
- +7 WRITE Y,!,"TO DATE: "
- +8 SET Y=LAST\1
- DO DD^LRX
- WRITE Y,!
- End DoDot:1
- +9 DO HEAD1
- +10 DO LOOP3
- +11 QUIT
- HEAD1 ;
- +1 DO ^LRWLHEAD
- +2 WRITE !
- +3 DO L27
- +4 QUIT
- LOOP3 ;
- +1 SET LRAN=0
- +2 FOR
- SET LRAN=$ORDER(^TMP($JOB,LRPGC,LRAN))
- if LRAN<1!($GET(LREND)=1)
- QUIT
- DO L24
- +3 QUIT
- L24 ;
- +1 SET LRACC=""
- +2 FOR
- SET LRACC=$ORDER(^TMP($JOB,LRPGC,LRAN,LRACC))
- if LRACC=""
- QUIT
- Begin DoDot:1
- +3 SET LRDFN=0
- if $GET(LREND)=1
- QUIT
- Begin DoDot:2
- +4 FOR
- SET LRDFN=$ORDER(^TMP($JOB,LRPGC,LRAN,LRACC,LRDFN))
- if LRDFN<1
- QUIT
- Begin DoDot:3
- +5 if $GET(LREND)=1
- QUIT
- DO L26
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +6 QUIT
- L26 ;
- +1 if $GET(LREND)=1
- QUIT
- +2 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- +3 SET LRTEST=$ORDER(^TMP($JOB,LRPGC,LRAN,LRACC,LRDFN,0))
- SET X=^(LRTEST)
- +4 SET LRLLOC=$PIECE(X,U,1)
- +5 SET LRURG=$PIECE(X,U,2)
- +6 SET LRCEN=$PIECE(X,U,5)
- +7 SET T(2)=$PIECE(X,U,6)
- +8 SET T(5)=$PIECE(X,U,8)
- +9 SET LRUID=$PIECE(X,U,9)
- +10 SET LRSPEC=$SELECT($DATA(^LAB(61,+$PIECE(X,U,4),0)):$EXTRACT($PIECE(^(0),U,1),1,5),1:"")
- +11 IF +T(2)
- SET Y=+T(2)
- DO DD^LRX
- SET LRCDT=Y_$EXTRACT(T(2),$LENGTH(T(2)))
- +12 IF '+T(2)
- SET LRCDT=T(2)
- +13 ;Q:$G(LREND)=1
- +14 FOR I=1:1:LR(4)
- WRITE !
- +15 if $GET(LREND)=1
- QUIT
- +16 WRITE $PIECE(LRACC," ",1)," ",$PIECE(LRACC," ",3),?11," ",$EXTRACT(LRLLOC,1,4),?18," ",$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN)),?23," ",$EXTRACT(PNM,1,15)
- +17 IF 'LR(3)
- WRITE !
- if LRCEN
- WRITE ?11,"ORD:",LRCEN
- WRITE ?20," ",LRCDT
- +18 IF '$TEST
- WRITE ?40
- if LRCEN
- WRITE "ORD:",LRCEN
- WRITE " ",LRCDT
- +19 WRITE !,?11,"UID: ",LRUID
- +20 DO LOOP4
- +21 QUIT
- LOOP4 ;
- +1 FOR LRTEST=LRPTO+1:1:LRPTO+LRNTPP
- Begin DoDot:1
- +2 ;I '$D(LRTEST(LRTEST)) S LREND=1 Q
- +3 WRITE ?($SELECT(LR(4)>1:7,1:5)*(LRTEST-LRPTO)+35+LR(3))
- +4 WRITE $SELECT('$DATA(^TMP($JOB,LRPGC,LRAN,LRACC,LRDFN,LRTEST)):"|",1:"")
- IF $DATA(^(LRTEST))
- WRITE $PIECE(^(LRTEST),U,3)
- End DoDot:1
- +5 WRITE ?($SELECT(LR(4)>1:7,1:5)*(LRNTPP+1)+34+LR(3))
- +6 WRITE " ",LRSPEC
- +7 IF $Y>(IOSL-7)
- DO LRSTOP
- if $GET(LREND)=1
- QUIT
- WRITE @IOF
- if LRAD'<1
- WRITE @LR("TIME")
- DO L27
- +8 IF LRDPF=2
- IF 'T(5)
- WRITE " NC"
- +9 QUIT
- L27 ;
- +1 if $GET(LREND)
- QUIT
- +2 FOR I=1:1:10
- DO L30
- +3 WRITE !,"ACC #"
- +4 QUIT
- LRSTOP ;
- +1 SET CNT=1
- +2 if $EXTRACT(IOST,1,2)="P-"
- QUIT
- +3 KILL DIR
- +4 SET DIR(0)="E"
- +5 DO ^DIR
- +6 IF $DATA(DUOUT)!($DATA(DIRUT))
- SET LREND=1
- QUIT
- +7 QUIT
- L15 DO ^%ZISC
- USE IO(0)
- if $DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2))
- WRITE !,"Accession: ",^(.2)," added too many tests to the display."
- +1 WRITE !,"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)."
- +2 QUIT
- L30 WRITE !,$PIECE("Key:^done = mult test comp.^ pen = mult test incomp.^spen = stat mult incomp.^number = result^.... = incomplete^S... = STAT incomp.^ | = not ordered",U,I)
- +1 FOR J=1:1:LRNTPP
- IF $DATA(LRTEST(LRPTO+J))
- SET C1=$EXTRACT(LRTEST(LRPTO+J),I)
- WRITE ?($SELECT(LR(4)>1:7,1:5)*J+25+I+LR(3)),$SELECT(C1'="":C1,1:".")
- +2 QUIT
- END ;from LRLSTWRK
- +1 WRITE !
- if $EXTRACT(IOST,1,2)="P-"
- WRITE @IOF
- +2 KILL 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",$JOB)
- +3 KILL %,%H,B,C1,LAST,LREDT,LRLINE,LRWDTL,POP,T1,LRORD,LRTSTS,LRUID
- +4 KILL AGE,A,DFN,DIC,DOB,I,J,K,LRLAN,LRDFN,LRDPF,PNM,S2,S3,S4,SEX,SSN,T5,X,Y,Z
- +5 KILL LRXX,LROK,T4,OK
- +6 DO ^%ZISC
- QUIT
- +7 ;NTPP=number tests/page, LRPTO=page test offset, LRPGC=page cnt, LRNTP=number of test pages
- +8 ;LR(1)=# of acc areas, 2=see unverified, 3=wide, 4=spacing
- LRAA ;from LRLSTWRK
- +1 KILL LRSTAR,LRAA,W2
- FOR J=0:0
- DO ^DIC
- if Y<1
- QUIT
- DO CHKDAT
- if Y<1
- QUIT
- SET DIC("A")="ANOTHER ACCESSION AREA: "
- IF '$DATA(W2(+Y))
- SET LR(1)=LR(1)+1
- SET LRAA(LR(1))=+Y
- SET W2(+Y)=""
- SET LRSS(LR(1))=$PIECE(LR,U,2)
- if $PIECE(LR,U,3)="Y"&'$DATA(LRSTAR)
- DO STAR^LRWU3
- +2 KILL W2,DIC,J,T2
- SET LREND=(X[U)!(LR(1)=0)
- QUIT
- CHKDAT ;from LRLIST
- +1 SET LR=^LRO(68,+Y,0)
- SET T=$PIECE(LR,U,3)
- IF T="Y"
- IF $EXTRACT(LRAD,4,7)'="0000"
- WRITE !,"Accession area selected has a YEARLY Accession date, you didn't choose that."
- SET (LR(1),Y)=-1
- QUIT
- +2 IF T="D"
- IF $EXTRACT(LRAD,4,5)="00"!($EXTRACT(LRAD,6,7)="00")
- WRITE !,"Accession area selected has a DAILY Accession date, you didn't choose that."
- SET (LR(1),Y)=-1
- QUIT
- +3 IF T="M"
- IF $EXTRACT(LRAD,4,5)="00"!($EXTRACT(LRAD,6,7)'="00")
- WRITE !,"Accession area selected has a MONTHLY Accession date, you didn't choose that."
- SET (LR(1),Y)=-1
- QUIT
- +4 QUIT