- LRLISTE ;SLC/RWF/CJS/DALISC/FHS/JBM/DRH - LAB RESULTS LIST, EXTENDED ;2/19/91 10:39
- ;;5.2;LAB SERVICE;**201,318**;Sep 27, 1994
- EN ;
- W !,"Summary List (Supervisers') >>> NOT FOR WARD USE <<<",! K ^TMP($J) D DATE^LRWU G END:Y<1
- S LRAD=Y,LRRDT=$$FMTE^XLFDT(LRAD,"5Z")
- S DIC="^LRO(68,",DIC(0)="AEQZ",LRNL=0,$P(LRDASH,"-",IOM)="",$P(LRDASH(2),"=",IOM)=""
- F J=0:0 D ^DIC Q:Y<1 D CHKDAT^LRLSTWRL Q:Y<1 S DIC("A")="ANOTHER ONE: ",LRNL=LRNL+1,LRAA(LRNL)=+Y,LRAA(LRNL,1)=$P(Y,U,2),LRSS(LRNL)=$P(Y(0),U,2)
- K DIC G EN:LRNL<1
- C R !,"1 ACCESSION NUMBER",!,"2 PATIENT",!,"LIST BY: ",LRX:DTIME G END:LRX["^"!(LRX=""),C:"12"'[LRX!(LRX>2)
- D RANGE
- ALL W !!?5,"Do you wish to see all tests including Common Accessions " S %=1 D YN^DICN G:%=0 ALL G:%=-1 END S:%=1 LRALL=""
- S %ZIS="MQ" D ^%ZIS G END:POP
- I $D(IO("Q")) S ZTRTN="DQ^LRLISTE",ZTIO=ION,ZTDESC="Summary List (Supervisors')",ZTSAVE("LR*")="" D ^%ZTLOAD G END
- C2 ;
- U IO S $P(LRDASH(2),"=",IOM)="" D HDR G L10:LRX=1,L20:LRX=2,END
- L10 I $D(LRALL) F LRAA=1:1:LRNL S L=LRFAN-1 F S L=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,L)) Q:(L>LRLAN)!(L<LRFAN) S ^TMP($J,L,LRAA)=""
- I '$D(LRALL) F LRAA=1:1:LRNL S L=LRFAN-1 F S L=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,L)) Q:(L>LRLAN)!(L<LRFAN) I $O(^(L,4,0)) S ^TMP($J,L,LRAA)=""
- S LRAN=0 F S LRAN=$O(^TMP($J,LRAN)) Q:LRAN<1 S LRAA=0 F S LRAA=$O(^TMP($J,LRAN,LRAA)) Q:LRAA<1 D PR G:$D(DTOUT)!($D(DUOUT)) END
- W !!,"END OF REPORT",! G END
- L20 F LRAA=1:1:LRNL D L22
- S LRPNM=""
- F S LRPNM=$O(^TMP($J,LRPNM)) Q:LRPNM="" S PNM=$P(LRPNM,U),SSN=$P(LRPNM,U,2) D L26 Q:$D(DTOUT)!($D(DUOUT))
- G END
- L22 S LRAN=LRFAN-1 F S LRAN=$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN)) Q:LRAN<1!(LRAN>LRLAN) D L23
- Q
- L23 I '$D(LRALL),'$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) Q
- Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0)) Q:'$D(^(3)) S LRDFN=+^(0),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D DEM^LRX S:$L(PNM) ^TMP($J,PNM_U_SSN,LRAA,LRAN)=DOB Q
- L26 S LRAA=0 F S LRAA=$O(^TMP($J,LRPNM,LRAA)) Q:LRAA<1 D L28 Q:$D(DTOUT)!($D(DUOUT))
- Q
- L28 S LRAN=0 F S LRAN=$O(^TMP($J,LRPNM,LRAA,LRAN)) Q:LRAN<1 D PR Q:$D(DTOUT)!($D(DUOUT))
- Q
- PR Q:'$D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3)) S LRIDT=9999999-^(3),LRDFN=+^(0),LRINT=$P(^(0),U,5),LRODT=$P(^(0),U,4) G PR1:LRAD<1
- PR1 Q:$G(LREND) S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D:$G(LRX)=1 DEM^LRX
- I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
- D LINECHK Q:$G(LREND)=1
- W !,LRDASH,!!,PNM,?40,SSN," ",LRAA(LRAA,1)," ACC: ",$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc") S:IOSL<66 S=S+3 D LINECHK Q:$G(LREND)=1
- I LRINT S LRINT=$S($D(^LRO(69,LRODT,1,LRINT,0)):$P(^(0),U,2),1:"") I LRINT S LRINT=$P(^VA(200,LRINT,0),U,1) W !,"Person placing order: ",LRINT D LINECHK Q:$G(LREND)=1 S:IOSL<66 S=S+1
- I LRLONG,$O(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0)) D
- . K DR,DA S DA(3)=LRAA(LRAA),DA(2)=LRAD,DA(1)=LRAN,DIC="^LRO(68,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",4,",(DR,DA)=0 F S DA=$O(@(DIC_"DA)")) Q:'DA!($D(DTOUT))!($D(DUOUT)) D EN^LRDIQ D LINECHK Q:$G(LREND)=1
- D LINECHK Q:$G(LREND)=1
- W !,?40,$S($D(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORD: "_^(.1),1:"") S:IOSL<66 S=S+1
- IF '$D(^LR(LRDFN,LRSS(LRAA),LRIDT,0)) W !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",! Q
- S LRCP=$P(^LR(LRDFN,LRSS(LRAA),LRIDT,0),"^",5)
- I LRCP="" S LRCP="UNKNOWN"
- S LRSP=$P($G(^LAB(61,LRCP,0)),U) D LINECHK Q:$G(LREND)=1 W:$L(LRSP) ?65,LRSP S:IOSL<66 S=S+1
- D LINECHK Q:$G(LREND)=1 W ! S DIC="^LR("_LRDFN_","""_LRSS(LRAA)_""",",DR="0"_$S(LRLONG:":99999999",1:""),DA=LRIDT S:IOSL<66 S=S+1 D EN^LRDIQ
- Q
- END D ^%ZISC K ^TMP($J),LRPNM,LRDATE,LRLONG,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,%H,C1,D0,DA,DICS,DL,DSC,DX,L,LAST,LRAA,LRAD,LRALL,LRDASH,LRDX,LREDT,LREND,LRFAN,LRIN,LRINT,LRLAN,LRLINE,LRNL,LRSET,LRSS,LRWDTL,LRRDT,LRRPG,LRX,POP,IO("Q"),LRSP
- K DTOUT,DUOUT,DIC,LRCP Q
- HDR I '$D(LRRPG) S LRRPG=1 G HD1
- HD1 W @IOF,!,"SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
- W " >> NOT FOR WARD USE <<" W:$L(LRRDT)=4 ?40,"Report for date: ",$$FMTE^XLFDT(LRAD,1) W !
- W !,"ACCESSION AREA(S) :" F ZZ=1:1:LRNL W LRAA(ZZ,1)," "
- W !,LRDASH(2)
- S LRRPG=LRRPG+1
- S:IOSL<66 S=2
- Q
- LINECHK ;
- I IOST?1"P".E D PAGECHK Q
- I $D(DX(0)) X DX(0)
- I $D(DUOUT) S LREND=1
- ;I S>IOSL-2 S S=0
- Q
- PAGECHK ;
- I IOST?1"P".E&($Y>(IOSL-16)) D HDR ;ONLY FOR USE ON A PRINTER
- Q
- RANGE R !,"(L)ONG OR (S)HORT LISTING: S//",X:DTIME S LRLONG=(X["L") I X["?" W !?5,"Long listing shows verified results where short list does not",! G RANGE
- D LRAN^LRWU3 Q
- ;
- DQ U IO S:$D(ZTQUEUED) ZTREQ="@" G C2
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLISTE 4586 printed Feb 18, 2025@23:42:04 Page 2
- LRLISTE ;SLC/RWF/CJS/DALISC/FHS/JBM/DRH - LAB RESULTS LIST, EXTENDED ;2/19/91 10:39
- +1 ;;5.2;LAB SERVICE;**201,318**;Sep 27, 1994
- EN ;
- +1 WRITE !,"Summary List (Supervisers') >>> NOT FOR WARD USE <<<",!
- KILL ^TMP($JOB)
- DO DATE^LRWU
- if Y<1
- GOTO END
- +2 SET LRAD=Y
- SET LRRDT=$$FMTE^XLFDT(LRAD,"5Z")
- +3 SET DIC="^LRO(68,"
- SET DIC(0)="AEQZ"
- SET LRNL=0
- SET $PIECE(LRDASH,"-",IOM)=""
- SET $PIECE(LRDASH(2),"=",IOM)=""
- +4 FOR J=0:0
- DO ^DIC
- if Y<1
- QUIT
- DO CHKDAT^LRLSTWRL
- if Y<1
- QUIT
- SET DIC("A")="ANOTHER ONE: "
- SET LRNL=LRNL+1
- SET LRAA(LRNL)=+Y
- SET LRAA(LRNL,1)=$PIECE(Y,U,2)
- SET LRSS(LRNL)=$PIECE(Y(0),U,2)
- +5 KILL DIC
- if LRNL<1
- GOTO EN
- C READ !,"1 ACCESSION NUMBER",!,"2 PATIENT",!,"LIST BY: ",LRX:DTIME
- if LRX["^"!(LRX="")
- GOTO END
- if "12"'[LRX!(LRX>2)
- GOTO C
- +1 DO RANGE
- ALL WRITE !!?5,"Do you wish to see all tests including Common Accessions "
- SET %=1
- DO YN^DICN
- if %=0
- GOTO ALL
- if %=-1
- GOTO END
- if %=1
- SET LRALL=""
- +1 SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- GOTO END
- +2 IF $DATA(IO("Q"))
- SET ZTRTN="DQ^LRLISTE"
- SET ZTIO=ION
- SET ZTDESC="Summary List (Supervisors')"
- SET ZTSAVE("LR*")=""
- DO ^%ZTLOAD
- GOTO END
- C2 ;
- +1 USE IO
- SET $PIECE(LRDASH(2),"=",IOM)=""
- DO HDR
- if LRX=1
- GOTO L10
- if LRX=2
- GOTO L20
- GOTO END
- L10 IF $DATA(LRALL)
- FOR LRAA=1:1:LRNL
- SET L=LRFAN-1
- FOR
- SET L=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,L))
- if (L>LRLAN)!(L<LRFAN)
- QUIT
- SET ^TMP($JOB,L,LRAA)=""
- +1 IF '$DATA(LRALL)
- FOR LRAA=1:1:LRNL
- SET L=LRFAN-1
- FOR
- SET L=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,L))
- if (L>LRLAN)!(L<LRFAN)
- QUIT
- IF $ORDER(^(L,4,0))
- SET ^TMP($JOB,L,LRAA)=""
- +2 SET LRAN=0
- FOR
- SET LRAN=$ORDER(^TMP($JOB,LRAN))
- if LRAN<1
- QUIT
- SET LRAA=0
- FOR
- SET LRAA=$ORDER(^TMP($JOB,LRAN,LRAA))
- if LRAA<1
- QUIT
- DO PR
- if $DATA(DTOUT)!($DATA(DUOUT))
- GOTO END
- +3 WRITE !!,"END OF REPORT",!
- GOTO END
- L20 FOR LRAA=1:1:LRNL
- DO L22
- +1 SET LRPNM=""
- +2 FOR
- SET LRPNM=$ORDER(^TMP($JOB,LRPNM))
- if LRPNM=""
- QUIT
- SET PNM=$PIECE(LRPNM,U)
- SET SSN=$PIECE(LRPNM,U,2)
- DO L26
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +3 GOTO END
- L22 SET LRAN=LRFAN-1
- FOR
- SET LRAN=$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN))
- if LRAN<1!(LRAN>LRLAN)
- QUIT
- DO L23
- +1 QUIT
- L23 IF '$DATA(LRALL)
- IF '$ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0))
- QUIT
- +1 if '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,0))
- QUIT
- if '$DATA(^(3))
- QUIT
- SET LRDFN=+^(0)
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO DEM^LRX
- if $LENGTH(PNM)
- SET ^TMP($JOB,PNM_U_SSN,LRAA,LRAN)=DOB
- QUIT
- L26 SET LRAA=0
- FOR
- SET LRAA=$ORDER(^TMP($JOB,LRPNM,LRAA))
- if LRAA<1
- QUIT
- DO L28
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +1 QUIT
- L28 SET LRAN=0
- FOR
- SET LRAN=$ORDER(^TMP($JOB,LRPNM,LRAA,LRAN))
- if LRAN<1
- QUIT
- DO PR
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +1 QUIT
- PR if '$DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,3))
- QUIT
- SET LRIDT=9999999-^(3)
- SET LRDFN=+^(0)
- SET LRINT=$PIECE(^(0),U,5)
- SET LRODT=$PIECE(^(0),U,4)
- if LRAD<1
- GOTO PR1
- PR1 if $GET(LREND)
- QUIT
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- if $GET(LRX)=1
- DO DEM^LRX
- +1 ;ONLY FOR USE ON A PRINTER
- IF IOST?1"P".E&($Y>(IOSL-16))
- DO HDR
- +2 DO LINECHK
- if $GET(LREND)=1
- QUIT
- +3 WRITE !,LRDASH,!!,PNM,?40,SSN," ",LRAA(LRAA,1)," ACC: ",$SELECT($DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.2)):^(.2),1:"no acc")
- if IOSL<66
- SET S=S+3
- DO LINECHK
- if $GET(LREND)=1
- QUIT
- +4 IF LRINT
- SET LRINT=$SELECT($DATA(^LRO(69,LRODT,1,LRINT,0)):$PIECE(^(0),U,2),1:"")
- IF LRINT
- SET LRINT=$PIECE(^VA(200,LRINT,0),U,1)
- WRITE !,"Person placing order: ",LRINT
- DO LINECHK
- if $GET(LREND)=1
- QUIT
- if IOSL<66
- SET S=S+1
- +5 IF LRLONG
- IF $ORDER(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,4,0))
- Begin DoDot:1
- +6 KILL DR,DA
- SET DA(3)=LRAA(LRAA)
- SET DA(2)=LRAD
- SET DA(1)=LRAN
- SET DIC="^LRO(68,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",4,"
- SET (DR,DA)=0
- FOR
- SET DA=$ORDER(@(DIC_"DA)"))
- if 'DA!($DATA(DTOUT))!($DATA(DUOUT))
- QUIT
- DO EN^LRDIQ
- DO LINECHK
- if $GET(LREND)=1
- QUIT
- End DoDot:1
- +7 DO LINECHK
- if $GET(LREND)=1
- QUIT
- +8 WRITE !,?40,$SELECT($DATA(^LRO(68,LRAA(LRAA),1,LRAD,1,LRAN,.1)):" ORD: "_^(.1),1:"")
- if IOSL<66
- SET S=S+1
- +9 IF '$DATA(^LR(LRDFN,LRSS(LRAA),LRIDT,0))
- WRITE !," ACCESSION #: ",LRAN," >>>>ERROR PLEASE NOTIFY SYSTEM MANAGER<<<<<",!
- QUIT
- +10 SET LRCP=$PIECE(^LR(LRDFN,LRSS(LRAA),LRIDT,0),"^",5)
- +11 IF LRCP=""
- SET LRCP="UNKNOWN"
- +12 SET LRSP=$PIECE($GET(^LAB(61,LRCP,0)),U)
- DO LINECHK
- if $GET(LREND)=1
- QUIT
- if $LENGTH(LRSP)
- WRITE ?65,LRSP
- if IOSL<66
- SET S=S+1
- +13 DO LINECHK
- if $GET(LREND)=1
- QUIT
- WRITE !
- SET DIC="^LR("_LRDFN_","""_LRSS(LRAA)_""","
- SET DR="0"_$SELECT(LRLONG:":99999999",1:"")
- SET DA=LRIDT
- if IOSL<66
- SET S=S+1
- DO EN^LRDIQ
- +14 QUIT
- END DO ^%ZISC
- KILL ^TMP($JOB),LRPNM,LRDATE,LRLONG,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,%H,C1,D0,DA,DICS,DL,DSC,DX,L,LAST,LRAA,LRAD,LRALL,LRDASH,LRDX,LREDT,LREND,LRFAN,LRIN,LRINT,LRLAN,LRLINE,LRNL,LRSET,LRSS,LRWDTL,LRRDT,LRRPG,LRX,POP,IO("Q"),LRSP
- +1 KILL DTOUT,DUOUT,DIC,LRCP
- QUIT
- HDR IF '$DATA(LRRPG)
- SET LRRPG=1
- GOTO HD1
- HD1 WRITE @IOF,!,"SUMMARY LIST (SUPERVISORS') FOR DATE: ",LRRDT,?(IOM-12),"PAGE: ",LRRPG,!
- +1 WRITE " >> NOT FOR WARD USE <<"
- if $LENGTH(LRRDT)=4
- WRITE ?40,"Report for date: ",$$FMTE^XLFDT(LRAD,1)
- WRITE !
- +2 WRITE !,"ACCESSION AREA(S) :"
- FOR ZZ=1:1:LRNL
- WRITE LRAA(ZZ,1)," "
- +3 WRITE !,LRDASH(2)
- +4 SET LRRPG=LRRPG+1
- +5 if IOSL<66
- SET S=2
- +6 QUIT
- LINECHK ;
- +1 IF IOST?1"P".E
- DO PAGECHK
- QUIT
- +2 IF $DATA(DX(0))
- XECUTE DX(0)
- +3 IF $DATA(DUOUT)
- SET LREND=1
- +4 ;I S>IOSL-2 S S=0
- +5 QUIT
- PAGECHK ;
- +1 ;ONLY FOR USE ON A PRINTER
- IF IOST?1"P".E&($Y>(IOSL-16))
- DO HDR
- +2 QUIT
- RANGE READ !,"(L)ONG OR (S)HORT LISTING: S//",X:DTIME
- SET LRLONG=(X["L")
- IF X["?"
- WRITE !?5,"Long listing shows verified results where short list does not",!
- GOTO RANGE
- +1 DO LRAN^LRWU3
- QUIT
- +2 ;
- DQ USE IO
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- GOTO C2