LRGEN1 ;SLC/RWF-GENERAL DATA DISPLAY ;2/19/91 10:35 [ 04/23/2003 7:42 AM ]
;;5.2T9;LR;**1004,1006,1013,1015,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**201,221**;Sep 27, 1994
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
S:'$G(LRIDT) LRIDT=1 W:$E(IOST,1,2)="C-" @IOF
S $P(LRDASH,"-",(IOM-1))="",$P(LREQUAL,"=",(IOM-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)
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
;D KVAR^VADPT
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
;----- END IHS MODIFICSTIONS
;
Q
WRTLN W ! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC Q
NX I LRY'<LRWPL D BOT:LRSC=LRIX,HEAD:'LREND Q:LREND I LRSC>1,LRSUB(LRSC)=LRSUB(LRSC-1) D NSET 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
;W !,LRFOOT,?3,$P(LRDAT,"@"),?14,T,?21,S,?24 S LRY=LRY+1,X=$D(^LR(LRDFN,LRSUB,LRIDT,0)),LRX=$X ;IHS/ITSC/TPF 10/1/01 MODIFY DISPLAY PATCH **1013**
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W !,LRFOOT,?3,$P(LRDAT,"@"),?14,T,?21,LRSAMP,?24 S LRY=LRY+1,X=$D(^LR(LRDFN,LRSUB,LRIDT,0)),LRX=$X ;IHS/ITSC/TPF 10/1/01 MODIFY DISPLAY PATCH **1013**
;----- END IHS MODIFICATIONS
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))
S:'$G(LRY) LRY=2 S:'$D(LRPRTF) $P(LRPRTF," ",20)=""
S $P(LRDASH,"-",(IOM-1))="",$P(LREQUAL,"=",(IOM-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
.;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
. W !,"WORK COPY: ",PNM," ",HRCN," Age:",AGE," ",?50,"Prt Date:",LRPDT
.;----- END IHS MODIFICATIONS
. W !,$$CJ^XLFSTR(LRPRTF_" Pg:"_LRPAGE,IOM) 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 W !,$$CJ^XLFSTR("[ *** End Of Report *** ]",IOM),!
S LREND=1
Q
BOT D KEYCOM^LRX:$E(IOST,1,2)'="C-"
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
B1 ;W !,"WORK COPY - DO NOT FILE ",PNM,?60,SSN S LRY=2
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W !,"WORK COPY - DO NOT FILE ",PNM,?60,HRCN S LRY=2
;----- END IHS MODIFICATIONS
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
LRGEN1 ;SLC/RWF-GENERAL DATA DISPLAY ;2/19/91 10:35 [ 04/23/2003 7:42 AM ]
+1 ;;5.2T9;LR;**1004,1006,1013,1015,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**201,221**;Sep 27, 1994
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
+5 IF '$GET(LRIDT)
SET LRIDT=1
IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+6 SET $PIECE(LRDASH,"-",(IOM-1))=""
SET $PIECE(LREQUAL,"=",(IOM-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 DO DT^LRX
DO PT^LRX
DO HEAD
+11 FOR
DO NX
IF LREND!(LRIDT<1)!(LRIDT>LREDT)
QUIT
+12 DO WRTLN
+13 KILL LRDASH,LREQUAL,LRAGE,LRRB,LRTREAT,LRUNKNOW,SEX,AGE
+14 ;D KVAR^VADPT
+15 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+16 DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
+17 ;----- END IHS MODIFICSTIONS
+18 ;
+19 QUIT
WRTLN WRITE !
IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
DO ^%ZISC
QUIT
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
SET LRIDT=+$ORDER(^LR(LRDFN,LRSUB,LRIDT))
IF LRIDT<1!(LRIDT>LREDT)
Begin DoDot:1
+2 IF LRSC>1
IF LRSUB(LRSC)=LRSUB(LRSC-1)
DO NSET
+3 SET LRY=LRWPL
DO BOT
DO LAST
End DoDot:1
QUIT
+4 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
+5 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
+6 IF LRNOP
QUIT
IF $DATA(LRSUB(LRSC+1))
IF LRSUB(LRSC+1)=LRSUB(LRSC)
SET LRSV(LRY)=LRIDT
+7 DO LRPR
+8 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 ;W !,LRFOOT," ",LRDAT S LRY=LRY+1
+9 ;W !,?13,LRSAMP,?20 S X=$D(^LR(LRDFN,LRSUB,LRIDT,0)),LRX=$X,LRY=LRY+1
+10 ;W !,LRFOOT,?3,$P(LRDAT,"@"),?14,T,?21,S,?24 S LRY=LRY+1,X=$D(^LR(LRDFN,LRSUB,LRIDT,0)),LRX=$X ;IHS/ITSC/TPF 10/1/01 MODIFY DISPLAY PATCH **1013**
+11 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+12 ;IHS/ITSC/TPF 10/1/01 MODIFY DISPLAY PATCH **1013**
WRITE !,LRFOOT,?3,$PIECE(LRDAT,"@"),?14,T,?21,LRSAMP,?24
SET LRY=LRY+1
SET X=$DATA(^LR(LRDFN,LRSUB,LRIDT,0))
SET LRX=$X
+13 ;----- END IHS MODIFICATIONS
+14 FOR I=S1:1:S2
Begin DoDot:1
+15 SET X=$SELECT($DATA(^LR(LRDFN,LRSUB,LRIDT,LRND(I))):^(LRND(I)),1:"")
SET LRFFLG=$PIECE(X,U,2)
SET X=$PIECE(X,U)
+16 WRITE ?LRX,@$SELECT(X'=""&$DATA(LRPR(I)):LRPR(I),1:"$J(X,LRCW)")," ",LRFFLG
+17 SET LRX=LRX+3+LRCW
End DoDot:1
+18 QUIT
HEAD IF '$GET(LRIDT)!($GET(LREND))
QUIT
+1 IF '$GET(LRY)
SET LRY=2
IF '$DATA(LRPRTF)
SET $PIECE(LRPRTF," ",20)=""
+2 SET $PIECE(LRDASH,"-",(IOM-1))=""
SET $PIECE(LREQUAL,"=",(IOM-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 ;W !,"WORK COPY: ",PNM," ",SSN," Age:",AGE," ",?50,"Prt Date:",LRPDT
+9 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+10 WRITE !,"WORK COPY: ",PNM," ",HRCN," Age:",AGE," ",?50,"Prt Date:",LRPDT
+11 ;----- END IHS MODIFICATIONS
+12 WRITE !,$$CJ^XLFSTR(LRPRTF_" Pg:"_LRPAGE,IOM)
SET LRY=LRY+1
End DoDot:1
+13 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
+14 IF $LENGTH(LRHDR(LRSC,2))
WRITE !,$SELECT($DATA(LRTHER):" Ther.",1:" Ref")," Range",?17,LRHDR(LRSC,2)
SET LRY=LRY+1
+15 IF $LENGTH(LRHDR(LRSC,1))
WRITE !,?13,"SPEC",?20,LRHDR(LRSC,1)
SET LRY=LRY+1
+16 WRITE !,LREQUAL
SET LRY=LRY+1
+17 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 WRITE !,$$CJ^XLFSTR("[ *** End Of Report *** ]",IOM),!
+1 SET LREND=1
+2 QUIT
BOT IF $EXTRACT(IOST,1,2)'="C-"
DO KEYCOM^LRX
+1 NEW II
+2 WRITE !,LRDASH
+3 IF $GET(LRNOTE)
FOR II=1:1:LRNOTE
SET LRIDT1=LRNOTE(II)
Begin DoDot:1
+4 IF LRY'<LRWPL
DO B1
IF $GET(LREND)
QUIT
SET LRBOT=1
DO HEAD
KILL LRBOT
+5 WRITE !,$CHAR(II+64)
SET J=0
FOR
SET J=$ORDER(^LR(LRDFN,LRSUB,LRIDT1,1,J))
IF J<1
QUIT
Begin DoDot:2
+6 WRITE ?5,^(J,0)
IF $ORDER(^LR(LRDFN,LRSUB,LRIDT1,1,J))
WRITE !
End DoDot:2
End DoDot:1
+7 KILL LRNOTE
SET LRNOTE=0
B1 ;W !,"WORK COPY - DO NOT FILE ",PNM,?60,SSN S LRY=2
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 WRITE !,"WORK COPY - DO NOT FILE ",PNM,?60,HRCN
SET LRY=2
+3 ;----- END IHS MODIFICATIONS
+4 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
+5 QUIT
