LRGEN1 ;SLC/RWF-GENERAL DATA DISPLAY ;2/19/91 10:35
;;5.2;LAB SERVICE;**201,221,438,471**;Sep 27, 1994;Build 1
DQ ;dequeued from LRGEN
N LRPDT,LRPTF,LRPAGE
S LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
S LRPRTF="Report Range [ "_$$FMTE^XLFDT($P(LRSDT,"."),"5MZ")_" - "_$$FMTE^XLFDT(9999999-$P(LREDT,"."),"5MZ")_" ]"
K LRNOTE,LRSV S (LRPAGE,LRNOTE,LREND)=0,LRIOM=80
S:'$G(LRIDT) LRIDT=1 W:$E(IOST,1,2)="C-" @IOF
S $P(LRDASH,"-",(LRIOM-1))="",$P(LREQUAL,"=",(LRIOM-1))=""
S LRWPL=IOSL-(3*LRIX)/LRIX
S:$D(ZTQUEUED) ZTREQ="@" U IO
S LRCW=LRCW-3,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
S LREDT=$$AEDT(LRDFN,LRSUB,LRIDT,LREDT,LRTP)
D DT^LRX,PT^LRX,HEAD
F D NX Q:LREND!(LRIDT<1)!(LRIDT>LREDT)
D WRTLN
K LRDASH,LREQUAL,LRAGE,LRRB,LRTREAT,LRUNKNOW,SEX,AGE,LRLAST,LRIOM
D KVAR^VADPT
Q
WRTLN W ! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
AEDT(LRD,LRS,LRI,LRE,LRT) ;return Actual End DaTe
;(DFN,SUB{e.g.: "CH"},entered start date,entered end date,type)
N LREA,LRX,LRZ,LRN,LRR S (LREA,LRX)=LRI
F S LRX=$O(^LR(LRD,LRS,LRX)) Q:LRX<1!(LRX>LRE) D
. S LRZ=$S($D(^LR(LRD,LRS,LRX,0)):^(0),1:"") Q:'$P(LRZ,U,3) I LRT,LRT'=$P(LRZ,U,5) Q
. S LRN=1,LRR=0 F S LRR=+$O(LRND(LRR)) Q:LRR<1 S:$D(^LR(LRD,LRS,LRX,LRND(LRR))) LRN=0
. Q:LRN S LREA=LRX
Q LREA ;return last qualifying LRIDT
NX I LRY'<LRWPL D BOT:LRSC=LRIX,HEAD:'LREND Q:LREND I LRSC>1,LRSUB(LRSC)=LRSUB(LRSC-1) D NSET Q
I LRIDT>1,$S(+$O(^LR(LRDFN,LRSUB,LRIDT))<1:1,+$O(^(LRIDT))>LREDT:1,1:0),LRSC<LRIX S LRY=LRWPL Q
S:LRIDT>1 LRIDT=+$O(^LR(LRDFN,LRSUB,LRIDT)) I LRIDT<1!(LRIDT>LREDT) D Q
. I LRSC>1,LRSUB(LRSC)=LRSUB(LRSC-1) D NSET
. S LRY=LRWPL D BOT,LAST
S Z=$S($D(^LR(LRDFN,LRSUB,LRIDT,0)):^(0),1:"") Q:'$P(Z,U,3) I LRTP,LRTP'=$P(Z,U,5) Q
S LRNOP=1,II=0 F S II=+$O(LRND(II)) Q:II<1 S:$D(^LR(LRDFN,LRSUB,LRIDT,LRND(II))) LRNOP=0
Q:LRNOP I $D(LRSUB(LRSC+1)),LRSUB(LRSC+1)=LRSUB(LRSC) S LRSV(LRY)=LRIDT
D LRPR
Q
NSET S LRSSP=0 F S LRSSP=+$O(LRSV(LRSSP)) Q:LRSSP<1 S LRIDT=LRSV(LRSSP),Z=^LR(LRDFN,LRSUB,LRIDT,0) D LRPR
S LRIDT=LRIDT(LRSC-1),LRY=LRWPL
Q
LRPR N LRSAMP
S X=+Z,LRTN=$P(Z,U,5),LRSAMP="?" S:LRTN'="" LRSAMP=$S($D(^LAB(61,LRTN,0)):$E(^(0),1,3),1:"?")
S LRDAT=$$FMTE^XLFDT(X,"5MZ")
S T=" "
S:X["." T=" "_$E(X_"00000",9,10)_":"_$E(X_"0000",11,12)_" "
S LRFOOT=" "
I $O(^LR(LRDFN,LRSUB,LRIDT,1,0))>0 D
. S:'$D(LRNOTE(-1,LRIDT)) LRNOTE=$G(LRNOTE)+1,LRNOTE(LRNOTE)=LRIDT,LRNOTE(-1,LRIDT)=LRNOTE S LRFOOT=$C(LRNOTE(-1,LRIDT)+64)
W !,LRFOOT," ",LRDAT S LRY=LRY+1
W !,?13,LRSAMP,?20 S X=$D(^LR(LRDFN,LRSUB,LRIDT,0)),LRX=$X,LRY=LRY+1
F I=S1:1:S2 D
. S X=$S($D(^LR(LRDFN,LRSUB,LRIDT,LRND(I))):^(LRND(I)),1:""),LRFFLG=$P(X,U,2),X=$P(X,U)
. W ?LRX,@$S(X'=""&$D(LRPR(I)):LRPR(I),1:"$J(X,LRCW)")," ",LRFFLG
. S LRX=LRX+3+LRCW
Q
HEAD Q:'$G(LRIDT)!($G(LREND)) I '$D(LRIOM) S LRIOM=80
S:'$G(LRY) LRY=2 S:'$D(LRPRTF) $P(LRPRTF," ",20)=""
S $P(LRDASH,"-",(LRIOM-1))="",$P(LREQUAL,"=",(LRIOM-1))=""
S LREND=0 I '$G(LRBOT) F Q:LREND D HD1 Q:'(LRIDT<1!(LRIDT>LREDT)) S LREND=1 F II=1:1:LRIX I LRIDT(II)>0,LRIDT(II)<LREDT S LREND=0 Q
Q:$G(LREND)
S:'$D(LRPDT) LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
I $G(LRSC)=1 D
. S LRPAGE=$G(LRPAGE)+1,LRY=2 W @IOF
. W !,"WORK COPY: ",PNM," ",SSN," Age:",AGE," ",?50,"Prt Date:",LRPDT
. W !,$$CJ^XLFSTR(LRPRTF_" Pg:"_LRPAGE,LRIOM) S LRY=LRY+1
S X=9999999-$O(^LR(LRDFN,"CH",LRIDT)) W !! W:'$L($G(LRHDR(LRSC,1))) ?13,"SPEC" W ?20,LRHDR(LRSC) S LRY=LRY+2
I $L(LRHDR(LRSC,2)) W !,$S($D(LRTHER):" Ther.",1:" Ref")," Range",?17,LRHDR(LRSC,2) S LRY=LRY+1
I $L(LRHDR(LRSC,1)) W !,?13,"SPEC",?20,LRHDR(LRSC,1) S LRY=LRY+1
W !,LREQUAL S LRY=LRY+1
Q
HD1 Q:$G(LREND)
S LRIDT(LRSC)=LRIDT,LRSC=$S(LRSC<LRIX:LRSC+1,1:1),LRIDT=$G(LRIDT(LRSC)) Q:'LRIDT S S1=LRIX(LRSC)+1,S2=LRIX(LRSC+1)
I LRSC=1 K LRNOTE,LRSV S LRNOTE=0
I LRSUB'=LRSUB(LRSC) S LRSUB=LRSUB(LRSC) K LRSV
Q
LAST Q:$G(LRLAST) W !,$$CJ^XLFSTR("[ *** End Of Report *** ]",LRIOM),!
S LREND=1,LRLAST=1 D B2
Q
BOT ;D KEYCOM^LRX:$E(IOST,1,2)'="C-"
I $E(IOST,1,2)'="C-" D
. W !,LREQUAL
. W !!," ------------------------------ COMMENTS ------------------------------"
. W !," Key: 'L' = reference Low, 'H' = reference Hi, '*' = critical range"
N II
W !,LRDASH
I $G(LRNOTE) F II=1:1:LRNOTE S LRIDT1=LRNOTE(II) D
. ;I LRY'<LRWPL D B1 Q:$G(LREND) S LRBOT=1 D HEAD K LRBOT
. W !,$C(II+64) S J=0 F S J=$O(^LR(LRDFN,LRSUB,LRIDT1,1,J)) Q:J<1 D
. . W ?5,^(J,0) W:$O(^LR(LRDFN,LRSUB,LRIDT1,1,J)) !
K LRNOTE S LRNOTE=0
S LREND=$S(+$O(^LR(LRDFN,LRSUB,LRIDT))<1:1,+$O(^(LRIDT))>LREDT:1,1:0) I LREND D LAST Q
B1 W !,"WORK COPY - DO NOT FILE ",PNM,?60,SSN S LRY=2
I $E(IOST,1,2)="C-" W !?20," PRESS '^' TO STOP REPORT " R X:DTIME S:X="" X=1 S LREND=".^"[X Q:$G(LREND)
Q
B2 ;Return to menu
I $E(IOST,1,2)="C-" W !?20," PRESS 'Enter' TO RETURN TO THE MENU " R X:DTIME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRGEN1 4891 printed Nov 22, 2024@17:24:58 Page 2
LRGEN1 ;SLC/RWF-GENERAL DATA DISPLAY ;2/19/91 10:35
+1 ;;5.2;LAB SERVICE;**201,221,438,471**;Sep 27, 1994;Build 1
DQ ;dequeued from LRGEN
+1 NEW LRPDT,LRPTF,LRPAGE
+2 SET LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
+3 SET LRPRTF="Report Range [ "_$$FMTE^XLFDT($PIECE(LRSDT,"."),"5MZ")_" - "_$$FMTE^XLFDT(9999999-$PIECE(LREDT,"."),"5MZ")_" ]"
+4 KILL LRNOTE,LRSV
SET (LRPAGE,LRNOTE,LREND)=0
SET LRIOM=80
+5 if '$GET(LRIDT)
SET LRIDT=1
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+6 SET $PIECE(LRDASH,"-",(LRIOM-1))=""
SET $PIECE(LREQUAL,"=",(LRIOM-1))=""
+7 SET LRWPL=IOSL-(3*LRIX)/LRIX
+8 if $DATA(ZTQUEUED)
SET ZTREQ="@"
USE IO
+9 SET LRCW=LRCW-3
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+10 SET LREDT=$$AEDT(LRDFN,LRSUB,LRIDT,LREDT,LRTP)
+11 DO DT^LRX
DO PT^LRX
DO HEAD
+12 FOR
DO NX
if LREND!(LRIDT<1)!(LRIDT>LREDT)
QUIT
+13 DO WRTLN
+14 KILL LRDASH,LREQUAL,LRAGE,LRRB,LRTREAT,LRUNKNOW,SEX,AGE,LRLAST,LRIOM
+15 DO KVAR^VADPT
+16 QUIT
WRTLN WRITE !
if $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
QUIT
AEDT(LRD,LRS,LRI,LRE,LRT) ;return Actual End DaTe
+1 ;(DFN,SUB{e.g.: "CH"},entered start date,entered end date,type)
+2 NEW LREA,LRX,LRZ,LRN,LRR
SET (LREA,LRX)=LRI
+3 FOR
SET LRX=$ORDER(^LR(LRD,LRS,LRX))
if LRX<1!(LRX>LRE)
QUIT
Begin DoDot:1
+4 SET LRZ=$SELECT($DATA(^LR(LRD,LRS,LRX,0)):^(0),1:"")
if '$PIECE(LRZ,U,3)
QUIT
IF LRT
IF LRT'=$PIECE(LRZ,U,5)
QUIT
+5 SET LRN=1
SET LRR=0
FOR
SET LRR=+$ORDER(LRND(LRR))
if LRR<1
QUIT
if $DATA(^LR(LRD,LRS,LRX,LRND(LRR)))
SET LRN=0
+6 if LRN
QUIT
SET LREA=LRX
End DoDot:1
+7 ;return last qualifying LRIDT
QUIT LREA
NX IF LRY'<LRWPL
if LRSC=LRIX
DO BOT
if 'LREND
DO HEAD
if LREND
QUIT
IF LRSC>1
IF LRSUB(LRSC)=LRSUB(LRSC-1)
DO NSET
QUIT
+1 IF LRIDT>1
IF $SELECT(+$ORDER(^LR(LRDFN,LRSUB,LRIDT))<1:1,+$ORDER(^(LRIDT))>LREDT:1,1:0)
IF LRSC<LRIX
SET LRY=LRWPL
QUIT
+2 if LRIDT>1
SET LRIDT=+$ORDER(^LR(LRDFN,LRSUB,LRIDT))
IF LRIDT<1!(LRIDT>LREDT)
Begin DoDot:1
+3 IF LRSC>1
IF LRSUB(LRSC)=LRSUB(LRSC-1)
DO NSET
+4 SET LRY=LRWPL
DO BOT
DO LAST
End DoDot:1
QUIT
+5 SET Z=$SELECT($DATA(^LR(LRDFN,LRSUB,LRIDT,0)):^(0),1:"")
if '$PIECE(Z,U,3)
QUIT
IF LRTP
IF LRTP'=$PIECE(Z,U,5)
QUIT
+6 SET LRNOP=1
SET II=0
FOR
SET II=+$ORDER(LRND(II))
if II<1
QUIT
if $DATA(^LR(LRDFN,LRSUB,LRIDT,LRND(II)))
SET LRNOP=0
+7 if LRNOP
QUIT
IF $DATA(LRSUB(LRSC+1))
IF LRSUB(LRSC+1)=LRSUB(LRSC)
SET LRSV(LRY)=LRIDT
+8 DO LRPR
+9 QUIT
NSET SET LRSSP=0
FOR
SET LRSSP=+$ORDER(LRSV(LRSSP))
if LRSSP<1
QUIT
SET LRIDT=LRSV(LRSSP)
SET Z=^LR(LRDFN,LRSUB,LRIDT,0)
DO LRPR
+1 SET LRIDT=LRIDT(LRSC-1)
SET LRY=LRWPL
+2 QUIT
LRPR NEW LRSAMP
+1 SET X=+Z
SET LRTN=$PIECE(Z,U,5)
SET LRSAMP="?"
if LRTN'=""
SET LRSAMP=$SELECT($DATA(^LAB(61,LRTN,0)):$EXTRACT(^(0),1,3),1:"?")
+2 SET LRDAT=$$FMTE^XLFDT(X,"5MZ")
+3 SET T=" "
+4 if X["."
SET T=" "_$EXTRACT(X_"00000",9,10)_":"_$EXTRACT(X_"0000",11,12)_" "
+5 SET LRFOOT=" "
+6 IF $ORDER(^LR(LRDFN,LRSUB,LRIDT,1,0))>0
Begin DoDot:1
+7 if '$DATA(LRNOTE(-1,LRIDT))
SET LRNOTE=$GET(LRNOTE)+1
SET LRNOTE(LRNOTE)=LRIDT
SET LRNOTE(-1,LRIDT)=LRNOTE
SET LRFOOT=$CHAR(LRNOTE(-1,LRIDT)+64)
End DoDot:1
+8 WRITE !,LRFOOT," ",LRDAT
SET LRY=LRY+1
+9 WRITE !,?13,LRSAMP,?20
SET X=$DATA(^LR(LRDFN,LRSUB,LRIDT,0))
SET LRX=$X
SET LRY=LRY+1
+10 FOR I=S1:1:S2
Begin DoDot:1
+11 SET X=$SELECT($DATA(^LR(LRDFN,LRSUB,LRIDT,LRND(I))):^(LRND(I)),1:"")
SET LRFFLG=$PIECE(X,U,2)
SET X=$PIECE(X,U)
+12 WRITE ?LRX,@$SELECT(X'=""&$DATA(LRPR(I)):LRPR(I),1:"$J(X,LRCW)")," ",LRFFLG
+13 SET LRX=LRX+3+LRCW
End DoDot:1
+14 QUIT
HEAD if '$GET(LRIDT)!($GET(LREND))
QUIT
IF '$DATA(LRIOM)
SET LRIOM=80
+1 if '$GET(LRY)
SET LRY=2
if '$DATA(LRPRTF)
SET $PIECE(LRPRTF," ",20)=""
+2 SET $PIECE(LRDASH,"-",(LRIOM-1))=""
SET $PIECE(LREQUAL,"=",(LRIOM-1))=""
+3 SET LREND=0
IF '$GET(LRBOT)
FOR
if LREND
QUIT
DO HD1
if '(LRIDT<1!(LRIDT>LREDT))
QUIT
SET LREND=1
FOR II=1:1:LRIX
IF LRIDT(II)>0
IF LRIDT(II)<LREDT
SET LREND=0
QUIT
+4 if $GET(LREND)
QUIT
+5 if '$DATA(LRPDT)
SET LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"5MZ")
+6 IF $GET(LRSC)=1
Begin DoDot:1
+7 SET LRPAGE=$GET(LRPAGE)+1
SET LRY=2
WRITE @IOF
+8 WRITE !,"WORK COPY: ",PNM," ",SSN," Age:",AGE," ",?50,"Prt Date:",LRPDT
+9 WRITE !,$$CJ^XLFSTR(LRPRTF_" Pg:"_LRPAGE,LRIOM)
SET LRY=LRY+1
End DoDot:1
+10 SET X=9999999-$ORDER(^LR(LRDFN,"CH",LRIDT))
WRITE !!
if '$LENGTH($GET(LRHDR(LRSC,1)))
WRITE ?13,"SPEC"
WRITE ?20,LRHDR(LRSC)
SET LRY=LRY+2
+11 IF $LENGTH(LRHDR(LRSC,2))
WRITE !,$SELECT($DATA(LRTHER):" Ther.",1:" Ref")," Range",?17,LRHDR(LRSC,2)
SET LRY=LRY+1
+12 IF $LENGTH(LRHDR(LRSC,1))
WRITE !,?13,"SPEC",?20,LRHDR(LRSC,1)
SET LRY=LRY+1
+13 WRITE !,LREQUAL
SET LRY=LRY+1
+14 QUIT
HD1 if $GET(LREND)
QUIT
+1 SET LRIDT(LRSC)=LRIDT
SET LRSC=$SELECT(LRSC<LRIX:LRSC+1,1:1)
SET LRIDT=$GET(LRIDT(LRSC))
if 'LRIDT
QUIT
SET S1=LRIX(LRSC)+1
SET S2=LRIX(LRSC+1)
+2 IF LRSC=1
KILL LRNOTE,LRSV
SET LRNOTE=0
+3 IF LRSUB'=LRSUB(LRSC)
SET LRSUB=LRSUB(LRSC)
KILL LRSV
+4 QUIT
LAST if $GET(LRLAST)
QUIT
WRITE !,$$CJ^XLFSTR("[ *** End Of Report *** ]",LRIOM),!
+1 SET LREND=1
SET LRLAST=1
DO B2
+2 QUIT
BOT ;D KEYCOM^LRX:$E(IOST,1,2)'="C-"
+1 IF $EXTRACT(IOST,1,2)'="C-"
Begin DoDot:1
+2 WRITE !,LREQUAL
+3 WRITE !!," ------------------------------ COMMENTS ------------------------------"
+4 WRITE !," Key: 'L' = reference Low, 'H' = reference Hi, '*' = critical range"
End DoDot:1
+5 NEW II
+6 WRITE !,LRDASH
+7 IF $GET(LRNOTE)
FOR II=1:1:LRNOTE
SET LRIDT1=LRNOTE(II)
Begin DoDot:1
+8 ;I LRY'<LRWPL D B1 Q:$G(LREND) S LRBOT=1 D HEAD K LRBOT
+9 WRITE !,$CHAR(II+64)
SET J=0
FOR
SET J=$ORDER(^LR(LRDFN,LRSUB,LRIDT1,1,J))
if J<1
QUIT
Begin DoDot:2
+10 WRITE ?5,^(J,0)
if $ORDER(^LR(LRDFN,LRSUB,LRIDT1,1,J))
WRITE !
End DoDot:2
End DoDot:1
+11 KILL LRNOTE
SET LRNOTE=0
+12 SET LREND=$SELECT(+$ORDER(^LR(LRDFN,LRSUB,LRIDT))<1:1,+$ORDER(^(LRIDT))>LREDT:1,1:0)
IF LREND
DO LAST
QUIT
B1 WRITE !,"WORK COPY - DO NOT FILE ",PNM,?60,SSN
SET LRY=2
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE !?20," PRESS '^' TO STOP REPORT "
READ X:DTIME
if X=""
SET X=1
SET LREND=".^"[X
if $GET(LREND)
QUIT
+2 QUIT
B2 ;Return to menu
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE !?20," PRESS 'Enter' TO RETURN TO THE MENU "
READ X:DTIME
+2 QUIT
