- LRLSTWRK ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST ;2/19/91 10:44 ;
- ;;5.2;LAB SERVICE;**1004,1013,1031**;NOV 1, 1997
- ;
- ;;VA LR Patch(s): 153,381
- ;
- EN ;
- K ^TMP($J),LRTEST,LR,LRTSTS,LRAA
- D ADATE^LRWU3
- G END^LRLSTWRL:LREND
- S LRAD=Y,DIC="^LRO(68,",DIC(0)="AEMOQ",LR(1)=0,LRTEST(0)=0
- D LRAA^LRLSTWRL G END:LREND,LRLSTWRK:LR(1)<1
- I '$D(LRSTAR) S LREND=0 D LRAN^LRWU3 G END:LREND
- L2 ;
- W !,"Expand panels" S %=2 D YN^DICN
- S LREX=(%=1)
- G END:%=-1
- I %=0 W !,"If yes, each panel encountered will be expanded." G L2
- L2B ;
- W !,"Do you wish to see unverified data"
- S %=2 D YN^DICN
- S LR(2)=(%=1)
- G END:%=-1
- I %=0 W !,"If yes, unverified data may also be displayed." G L2B
- L2A ;
- S LREND=0,LRCEN("W")=0
- R !,"Spacing: 1// ",LR(4):DTIME
- Q:'$T!(LR(4)["^") W:LR(4)["?" !,"Single, Double, Triple spacing, etc."
- G:X["?" L2A S LR(4)=+LR(4) S:LR(4)<1 LR(4)=1
- S %ZIS="QM" D ^%ZIS G END:POP
- I $D(IO("Q")) D G END
- . S ZTRTN="DQ^LRLSTWRK",ZTSAVE("L*")=""
- . D ^%ZTLOAD K ZTSK,ZTRTN,ZTIO,ZTSAVE,IO("Q")
- ENT ;
- U IO D URG^LRX K ^TMP("LR",$J)
- S LRNTPP=((IOM-4)-45)/$S(LR(4)>1:7,1:5)\1,LRNTP=0
- I '$D(LRSTAR) F LRAA=1:1:LR(1) D L11 Q:LREND
- I $D(LRSTAR) F LRAA=1:1:LR(1) D L3 Q:LREND
- I $O(^TMP($J,0))<1 W !!,"NO DATA TO REPORT" G END
- S:LRTEST(0)<LRNTPP LRNTPP=LRTEST(0) G EN^LRLSTWRL
- Q
- L11 W "." S LRAN=LRFAN-1 F K=0:0 S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN=""!(LRAN>LRLAN)!(LRAN'?.N) D L12 Q:LREND
- Q
- L12 Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))#2
- S X=^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0),LRCEN=$S($D(^(.1)):^(.1),1:0),LRACC=$S($D(^(.2)):^(.2),1:"?"),LRIDT=$S($D(^(3)):^(3),1:"")
- S LRUID=$P($G(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),"^")
- S T(2)="",T(5)="",T(3)="",LRDFN=+X,LRSDT=$P(X,U,4)\1,LRSN=+$P(X,U,5),LRLLOC=$P(X,U,7)
- S:LRCEN&'LRCEN("W") LRCEN("W")=1
- I LRIDT'="" D
- . I +LRIDT S T(2)=+LRIDT_$S($P(LRIDT,U,2):"r",1:"d")
- . E S T(2)="No Collect Date/Time"
- . S T(3)=$P(LRIDT,U,4),T(5)=$P(LRIDT,U,3),LRIDT=$P(LRIDT,U,5)
- S II=0 F S II=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,II)) Q:II<1!LREND S X=^(II,0) D L13
- S LR(3)=$S(LR(4)>1:7,1:5)*LRTEST(0)+67+$S('LRCEN("W"):0,1:8)<(IOM-4) S:LR(3) LR(3)=22+$S('LRCEN("W"):0,1:8)
- Q
- L13 S T(1)=$P(X,U,6),LRURG=+$P(X,U,2),LRURG=$S($D(LRURG(LRURG)):LRURG(LRURG),1:""),T(3)=$P(X,U,5),LRTS=+X
- I $G(LRURG)>49,'$P($G(LRPARAM),U,3) Q
- S T(4)=$S(T(3):"done",$L(T(1)):"#"_$J(T(1),3),LRURG["STAT":"Spen",1:" pen"),LRSPEC=$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,5,1,0)):+^(0),1:""),S4=$S($D(^LAB(60,LRTS,0)):$P(^(0),U,5),1:""),T4=T(4)
- D STORE I LREX S LRTEST=LRTS,LRTSTLM=100 D ^LREXPD S JJ=0 F S JJ=$O(LRORD(JJ)) Q:JJ<1 S LRTS=LRORD(JJ),S4=$P(^LAB(60,LRTS,0),U,5) D STORE
- K JJ,LRORD,^TMP("LR",$J,"T") Q
- STORE S:'$D(LRTEST("B",LRTS)) LRTEST(0)=LRTEST(0)+1,LRTEST(LRTEST(0))=$S($D(^LAB(60,LRTS,0)):$P(^(0),U,1),1:"deleted test"),LRTEST("B",LRTS)=LRTEST(0),LRNTP=LRTEST(0)-1\LRNTPP+1
- S LRSS=$P(S4,";",1),S2=$P(S4,";",2),S3=$P(S4,";",3),T(4)=T4
- I $L(S4) D
- . S T(4)=$S(LRURG["STAT":"S...",1:"....")
- . I LRIDT,$D(^LR(LRDFN,LRSS,LRIDT,S2)),$P(^(0),U,3)!LR(2),$L($P(^(S2),U,S3)) S T(4)=$S($P(^(S2),U,S3)'="pending":$P(^(S2),U,S3),1:"pen")
- S ^TMP($J,(LRTEST("B",LRTS)-1\LRNTPP+1),LRAN,LRACC,LRDFN,LRTEST("B",LRTS))=LRLLOC_U_LRURG_U_T(4)_U_LRSPEC_U_LRCEN_U_T(2)_U_LRACC_U_T(5)_U_LRUID
- Q
- END G END^LRLSTWRL
- Q
- YN R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G YN
- L3 S LRAD=$E(LRSTAR,1,3)_"0000"-.00001 F S LRAD=$O(^LRO(68,LRAA(LRAA),1,LRAD)) Q:LRAD<1!(LRAD>LRWDTL) D AC Q:LREND
- AC S T1=LRSTAR-.00001 F S T1=$O(^LRO(68,+LRAA(LRAA),1,+LRAD,1,"E",T1)) Q:T1<1!(LAST>1&(T1\1>LAST)) D AC1
- Q
- AC1 S LRAN=0 F S LRAN=$O(^LRO(68,+LRAA(LRAA),1,LRAD,1,"E",T1,LRAN)) Q:LRAN<1 I $D(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,0)) D L12 Q:LREND
- Q
- DQ S:$D(ZTQUEUED) ZTREQ="@" U IO K ^TMP($J) G ENT
- Q
- LRLSTWRK ;SLC/CJS/DALISC/DRH - BRIEF ACCESSION LIST ;2/19/91 10:44 ;
- +1 ;;5.2;LAB SERVICE;**1004,1013,1031**;NOV 1, 1997
- +2 ;
- +3 ;;VA LR Patch(s): 153,381
- +4 ;
- EN ;
- +1 KILL ^TMP($JOB),LRTEST,LR,LRTSTS,LRAA
- +2 DO ADATE^LRWU3
- +3 IF LREND
- GOTO END^LRLSTWRL
- +4 SET LRAD=Y
- SET DIC="^LRO(68,"
- SET DIC(0)="AEMOQ"
- SET LR(1)=0
- SET LRTEST(0)=0
- +5 DO LRAA^LRLSTWRL
- IF LREND
- GOTO END
- IF LR(1)<1
- GOTO LRLSTWRK
- +6 IF '$DATA(LRSTAR)
- SET LREND=0
- DO LRAN^LRWU3
- IF LREND
- GOTO END
- L2 ;
- +1 WRITE !,"Expand panels"
- SET %=2
- DO YN^DICN
- +2 SET LREX=(%=1)
- +3 IF %=-1
- GOTO END
- +4 IF %=0
- WRITE !,"If yes, each panel encountered will be expanded."
- GOTO L2
- L2B ;
- +1 WRITE !,"Do you wish to see unverified data"
- +2 SET %=2
- DO YN^DICN
- +3 SET LR(2)=(%=1)
- +4 IF %=-1
- GOTO END
- +5 IF %=0
- WRITE !,"If yes, unverified data may also be displayed."
- GOTO L2B
- L2A ;
- +1 SET LREND=0
- SET LRCEN("W")=0
- +2 READ !,"Spacing: 1// ",LR(4):DTIME
- +3 IF '$TEST!(LR(4)["^")
- QUIT
- IF LR(4)["?"
- WRITE !,"Single, Double, Triple spacing, etc."
- +4 IF X["?"
- GOTO L2A
- SET LR(4)=+LR(4)
- IF LR(4)<1
- SET LR(4)=1
- +5 SET %ZIS="QM"
- DO ^%ZIS
- IF POP
- GOTO END
- +6 IF $DATA(IO("Q"))
- Begin DoDot:1
- +7 SET ZTRTN="DQ^LRLSTWRK"
- SET ZTSAVE("L*")=""
- +8 DO ^%ZTLOAD
- KILL ZTSK,ZTRTN,ZTIO,ZTSAVE,IO("Q")
- End DoDot:1
- GOTO END
- ENT ;
- +1 USE IO
- DO URG^LRX
- KILL ^TMP("LR",$JOB)
- +2 SET LRNTPP=((IOM-4)-45)/$SELECT(LR(4)>1:7,1:5)\1
- SET LRNTP=0
- +3 IF '$DATA(LRSTAR)
- FOR LRAA=1:1:LR(1)
- DO L11
- IF LREND
- QUIT
- +4 IF $DATA(LRSTAR)
- FOR LRAA=1:1:LR(1)
- DO L3
- IF LREND
- QUIT
- +5 IF $ORDER(^TMP($JOB,0))<1
- WRITE !!,"NO DATA TO REPORT"
- GOTO END
- +6 IF LRTEST(0)<LRNTPP
- SET LRNTPP=LRTEST(0)
- GOTO EN^LRLSTWRL
- +7 QUIT
- L11 WRITE "."
- SET LRAN=LRFAN-1
- FOR K=0:0
- SET LRAN=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN))
- IF LRAN=""!(LRAN>LRLAN)!(LRAN'?.N)
- QUIT
- DO L12
- IF LREND
- QUIT
- +1 QUIT
- L12 IF '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))#2
- QUIT
- +1 SET X=^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0)
- SET LRCEN=$SELECT($DATA(^(.1)):^(.1),1:0)
- SET LRACC=$SELECT($DATA(^(.2)):^(.2),1:"?")
- SET LRIDT=$SELECT($DATA(^(3)):^(3),1:"")
- +2 SET LRUID=$PIECE($GET(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.3)),"^")
- +3 SET T(2)=""
- SET T(5)=""
- SET T(3)=""
- SET LRDFN=+X
- SET LRSDT=$PIECE(X,U,4)\1
- SET LRSN=+$PIECE(X,U,5)
- SET LRLLOC=$PIECE(X,U,7)
- +4 IF LRCEN&'LRCEN("W")
- SET LRCEN("W")=1
- +5 IF LRIDT'=""
- Begin DoDot:1
- +6 IF +LRIDT
- SET T(2)=+LRIDT_$SELECT($PIECE(LRIDT,U,2):"r",1:"d")
- +7 IF '$TEST
- SET T(2)="No Collect Date/Time"
- +8 SET T(3)=$PIECE(LRIDT,U,4)
- SET T(5)=$PIECE(LRIDT,U,3)
- SET LRIDT=$PIECE(LRIDT,U,5)
- End DoDot:1
- +9 SET II=0
- FOR
- SET II=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,II))
- IF II<1!LREND
- QUIT
- SET X=^(II,0)
- DO L13
- +10 SET LR(3)=$SELECT(LR(4)>1:7,1:5)*LRTEST(0)+67+$SELECT('LRCEN("W"):0,1:8)<(IOM-4)
- IF LR(3)
- SET LR(3)=22+$SELECT('LRCEN("W"):0,1:8)
- +11 QUIT
- L13 SET T(1)=$PIECE(X,U,6)
- SET LRURG=+$PIECE(X,U,2)
- SET LRURG=$SELECT($DATA(LRURG(LRURG)):LRURG(LRURG),1:"")
- SET T(3)=$PIECE(X,U,5)
- SET LRTS=+X
- +1 IF $GET(LRURG)>49
- IF '$PIECE($GET(LRPARAM),U,3)
- QUIT
- +2 SET T(4)=$SELECT(T(3):"done",$LENGTH(T(1)):"#"_$JUSTIFY(T(1),3),LRURG["STAT":"Spen",1:" pen")
- SET LRSPEC=$SELECT($DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,5,1,0)):+^(0),1:"")
- SET S4=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U,5),1:"")
- SET T4=T(4)
- +3 DO STORE
- IF LREX
- SET LRTEST=LRTS
- SET LRTSTLM=100
- DO ^LREXPD
- SET JJ=0
- FOR
- SET JJ=$ORDER(LRORD(JJ))
- IF JJ<1
- QUIT
- SET LRTS=LRORD(JJ)
- SET S4=$PIECE(^LAB(60,LRTS,0),U,5)
- DO STORE
- +4 KILL JJ,LRORD,^TMP("LR",$JOB,"T")
- QUIT
- STORE IF '$DATA(LRTEST("B",LRTS))
- SET LRTEST(0)=LRTEST(0)+1
- SET LRTEST(LRTEST(0))=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U,1),1:"deleted test")
- SET LRTEST("B",LRTS)=LRTEST(0)
- SET LRNTP=LRTEST(0)-1\LRNTPP+1
- +1 SET LRSS=$PIECE(S4,";",1)
- SET S2=$PIECE(S4,";",2)
- SET S3=$PIECE(S4,";",3)
- SET T(4)=T4
- +2 IF $LENGTH(S4)
- Begin DoDot:1
- +3 SET T(4)=$SELECT(LRURG["STAT":"S...",1:"....")
- +4 IF LRIDT
- IF $DATA(^LR(LRDFN,LRSS,LRIDT,S2))
- IF $PIECE(^(0),U,3)!LR(2)
- IF $LENGTH($PIECE(^(S2),U,S3))
- SET T(4)=$SELECT($PIECE(^(S2),U,S3)'="pending":$PIECE(^(S2),U,S3),1:"pen")
- End DoDot:1
- +5 SET ^TMP($JOB,(LRTEST("B",LRTS)-1\LRNTPP+1),LRAN,LRACC,LRDFN,LRTEST("B",LRTS))=LRLLOC_U_LRURG_U_T(4)_U_LRSPEC_U_LRCEN_U_T(2)_U_LRACC_U_T(5)_U_LRUID
- +6 QUIT
- END GOTO END^LRLSTWRL
- +1 QUIT
- YN READ %:DTIME
- IF %=""!(%["N")!(%["Y")
- QUIT
- WRITE !,"Answer 'Y' or 'N': "
- GOTO YN
- L3 SET LRAD=$EXTRACT(LRSTAR,1,3)_"0000"-.00001
- FOR
- SET LRAD=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD))
- IF LRAD<1!(LRAD>LRWDTL)
- QUIT
- DO AC
- IF LREND
- QUIT
- AC SET T1=LRSTAR-.00001
- FOR
- SET T1=$ORDER(^LRO(68,+LRAA(LRAA),1,+LRAD,1,"E",T1))
- IF T1<1!(LAST>1&(T1\1>LAST))
- QUIT
- DO AC1
- +1 QUIT
- AC1 SET LRAN=0
- FOR
- SET LRAN=$ORDER(^LRO(68,+LRAA(LRAA),1,LRAD,1,"E",T1,LRAN))
- IF LRAN<1
- QUIT
- IF $DATA(^LRO(68,+LRAA(LRAA),1,LRAD,1,LRAN,0))
- DO L12
- IF LREND
- QUIT
- +1 QUIT
- DQ IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- USE IO
- KILL ^TMP($JOB)
- GOTO ENT
- +1 QUIT
