- LRDIST ;SLC/CJS - DATA DISTRIBUTION ;2/20/91 10:09 ;
- ;;5.2;LAB SERVICE;**64,71,160,108,153**;Sep 27, 1994
- D DT^LRX K DIC D ^LRDPA G END:(LRDFN=-1)!$D(DUOUT)!$D(DTOUT)
- ENT ;from LRQC
- I $O(^LR(LRDFN,0))="" W !,"NO LAB DATA ON THIS PATIENT!",$C(7) Q
- D ENT1
- END S:$D(ZTQUEUED) ZTREQ="@"
- D ^%ZISC K A,A9,DFN,DIC,DOB,I,K,LAST,LRORD,LRCHM,LRCOUNT,LRCTRL,LRCW,LRDPF
- K LRCV,LREDT,LREND,LRFLAG,LRFOOT,LRHIGH,LRIDT,LRII,LRIY,LRLM1,LRLM1F,LRLM2,LRLM2F
- K LRLOW,LRM,LRTEST,LRNC,LRNEX,LRNM,LRNSET,LRNT,LRNTN,LRNX,LROK
- K LRPANEL,LRSB,LRSDNORM,LRSDT,LRSPC,LRSPEC,LRSS,LRSSP,LRSSX,LRSTEPS
- K ^TMP("LR",$J,"X"),LRSTS,LRSUB,LRSX,LRTN,LRVAL,LRWRD,N,PNM,SSN,X,Y,Z
- K LRCV,LRECV,LREM,LRESD,LRLF,LRSD,LRSDD,LRTAB,LRXF,LRTEC,LRTM60,LRTS,LRTX,LRUSI,LRVF,LRVOL,LRVRM,LRWDTL,LRXD,LRXDH,LRXDP,S2,T1
- K LRDFN,DUOUT,DTOUT,R1,LRACD,LRAOD,LRCDT,LRCFL,LRDAT,LRDEL,LRDV,LRDVF,LREAL,LREDIT,LREXEC,LRFAN,LRFFLG,LRFP,LRGVP,LRINI,LRIOZERO,LRLAN,LRLCT,LRMD,LRMETH,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRODT,LROUTINE,LRPER,LRPLOC,LRSAMP,LRSN,LRSSQ,LRSTAR
- Q
- ENT1 S LRCW=8,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
- S LRFLAG="",LRCTRL=$S(LRDPF=62.3:1,1:0) I LRCTRL F I=0:0 W !,"Display cumulative summary (NO, displays graph)" S %=1 D YN^DICN Q:% W " Answer 'Y'es or 'N'o."
- I LRCTRL Q:%<0 S:%=1 LRFLAG=1,LRSDNORM=1
- K LREDT D ^LRWU3 Q:LREND
- S LRNSET=80,N=LRNSET
- L2 F I=0:0 W !,"How many time points? ",LRNSET,"//" R X:DTIME Q:X[U!'$L(X)!(X\1=X&(X'<1)) W " Enter a number"
- Q:X[U S:X'="" LRNSET=X S N=LRNSET
- L3 K ^TMP("LR",$J,"TMP"),^TMP("LR",$J,"X"),X,LRORD,DIC,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK S LRSPEC=-1,DIC(0)="AEOQZ" I LRDPF'=62.3 S DIC="^LAB(61,",DIC("A")="Select SITE/SPECIMEN: ANY//" D ^DIC G:$D(DUOUT) END S LRSPEC=+Y
- L4 S LRSS="CH" K DIC("A") S:'LRFLAG LRSDNORM=0 IF (LRSPEC>0!LRCTRL)&'LRFLAG W !,"Plot relative to ",$S(LRCTRL:"expected",1:"normal")," values (if available)" S %=1 D YN^DICN Q:%=-1 G L4:%=0 S:%=1 LRSDNORM=1
- S:N<2 N=30 S LRSSP=0,DIC="^LAB(60,",DIC("S")="I $P(^(0),U,4)=""CH"""_$S(LRCTRL:"",1:$S('$D(^XUSEC("LRSUPER",DUZ)):",""N""'[$P(^(0),U,3)",1:"")) D ^DIC G LREND:Y<1
- IF $L($P(^LAB(60,+Y,.1),U,5)) W !,"ASK FOR TESTS INDIVIDUALLY" Q
- TX S LRSSP=LRSSP+1,LRTEST(LRSSP)=+Y_U_Y(0) D ^DIC G TX:Y>0
- S LRNX=0,LRPANEL=0 K ^TMP("LR",$J,"X"),X,^TMP("LR",$J,"TMP"),LRORD,DIC F I=1:1 Q:'$D(LRTEST(I)) S X=LRTEST(I),(LRNTN,LRNT)=I,(S1,J)=0,LRCFL="" D EX2
- K LRTEST,^TMP("LR",$J,"TMP") S I=0 F S I=$O(LRORD(I)) Q:I<1 S J=LRORD(I),LRTEST(I)=$O(^LAB(60,"C","CH;"_J_";1",0))_U_$P(^LAB(60,$O(^(0)),0),U,1)_U_J,LRNM=I
- K %ZIS S %ZIS="Q" D ^%ZIS Q:POP
- I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^LRDIST",ZTSAVE("LR*")="" D ^%ZTLOAD G L3
- D LIST U IO(0) G L3
- LIST U IO D DT^LRX S LREND=0
- I LRFLAG D ^LRDIST2
- S LRTN=0 F S LRTN=$O(LRTEST(LRTN)) Q:LRTN<1 D L40 K:LREND ^TMP("LR",$J,"X"),X,LRTEST Q:LREND
- Q
- L40 S LRSB=$P(LRTEST(LRTN),U,3),LRCHM=$P(LRTEST(LRTN),U,2),LRCHM(.1)=$S($D(^LAB(60,+LRTEST(LRTN),.1)):$P(^(.1),U,3),1:""),N=LRNSET
- S LRIDT=9999999-LRSDT,LAST=9999999-$S(LREDT<1:0,1:LREDT),LRCOUNT=0,LRSX=0,LRSSX=0,LRNC=0 K LRLOW,LRHIGH
- S R1=0 IF LRSDNORM=1&LRCTRL S T=$O(^LAB(62.3,DFN,1,"B",+LRTEST(LRTN),0))
- I LRSDNORM=1,LRCTRL I T>0 S T=^LAB(62.3,DFN,1,T,0),X=$P(T,U,2),Y=(3*$P(T,U,3)),LRLOW=X-Y,LRHIGH=X+Y,R1=1 I '$L($P(T,U,2))!('$L($P(T,U,3))) W !,"Expected values not available for "_$P(LRTEST(LRTN),U,2),! Q
- D ^LRDIST1
- Q
- LREND K DIC Q
- DQ S:$D(ZTQUEUED) ZTREQ="@" S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX D LIST G END
- OR ;OE/RR entry point
- Q:'$D(ORVP)
- ;-------------------------------------------------------------------
- ; Patch LR*5.2*62 Need PNM, SSN etc....DRH
- ;S:'$G(DFN) DFN=+ORVP S LRDFN=$G(^DPT(DFN,"LR")) Q:'$G(LRDFN) D DEM^LRX
- ;Commented OR+4 To fix patch LR*5.2*64
- ;-------------------------------------------------------------------
- K LR,LRABV,LRAX,LRBLOOD,LRCAPA,LRDPAF,LRDT0,LRH,LRSF,LRT,LRU,LRWHO
- S KILL=1 I '$D(LRPARAM) D EN^LRPARAM S KILL=0
- D DT^LRX K DIC S LREND=0,DFN=+ORVP,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2) D END^LRDPA Q:LRDFN<1
- D ENT
- I 'KILL K LRBLOOD,LRDT0,LRORN,LRPARAM,LRPLASMA,LRSERUM,LRUNKNOW,LRURINE
- K KILL Q
- EX2 ;
- S LRSUB=$P(X,U,6) I $D(^LAB(60,+X,4)),$P(^(4),"^",2) S LRCFL=LRCFL_$P(^(4),"^",2)_U
- I $L(LRSUB) S S2=$P(LRSUB,";",2) D:'$D(^TMP("LR",$J,"TMP",S2)) ORD Q
- S S1=S1+1,S1(S1)=X,S1(S1,1)=J
- S J=0 F S J=$O(^LAB(60,+S1(S1),2,J)) Q:J<1 S Y=+^(J,0),X=Y_U_^LAB(60,Y,0) D EX2
- S X=S1(S1),J=S1(S1,1),S1=S1-1
- Q
- ORD S LRNX=LRNX+1,LRORD(LRNX)=S2,^TMP("LR",$J,"TMP",S2)=+X S:$P(X,U,18) LRM(S2)=+X,LRMX(+X)="" Q
- ;LRNX is set by caller
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRDIST 4590 printed Feb 18, 2025@23:39:49 Page 2
- LRDIST ;SLC/CJS - DATA DISTRIBUTION ;2/20/91 10:09 ;
- +1 ;;5.2;LAB SERVICE;**64,71,160,108,153**;Sep 27, 1994
- +2 DO DT^LRX
- KILL DIC
- DO ^LRDPA
- if (LRDFN=-1)!$DATA(DUOUT)!$DATA(DTOUT)
- GOTO END
- ENT ;from LRQC
- +1 IF $ORDER(^LR(LRDFN,0))=""
- WRITE !,"NO LAB DATA ON THIS PATIENT!",$CHAR(7)
- QUIT
- +2 DO ENT1
- END if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 DO ^%ZISC
- KILL A,A9,DFN,DIC,DOB,I,K,LAST,LRORD,LRCHM,LRCOUNT,LRCTRL,LRCW,LRDPF
- +2 KILL LRCV,LREDT,LREND,LRFLAG,LRFOOT,LRHIGH,LRIDT,LRII,LRIY,LRLM1,LRLM1F,LRLM2,LRLM2F
- +3 KILL LRLOW,LRM,LRTEST,LRNC,LRNEX,LRNM,LRNSET,LRNT,LRNTN,LRNX,LROK
- +4 KILL LRPANEL,LRSB,LRSDNORM,LRSDT,LRSPC,LRSPEC,LRSS,LRSSP,LRSSX,LRSTEPS
- +5 KILL ^TMP("LR",$JOB,"X"),LRSTS,LRSUB,LRSX,LRTN,LRVAL,LRWRD,N,PNM,SSN,X,Y,Z
- +6 KILL LRCV,LRECV,LREM,LRESD,LRLF,LRSD,LRSDD,LRTAB,LRXF,LRTEC,LRTM60,LRTS,LRTX,LRUSI,LRVF,LRVOL,LRVRM,LRWDTL,LRXD,LRXDH,LRXDP,S2,T1
- +7 KILL LRDFN,DUOUT,DTOUT,R1,LRACD,LRAOD,LRCDT,LRCFL,LRDAT,LRDEL,LRDV,LRDVF,LREAL,LREDIT,LREXEC,LRFAN,LRFFLG,LRFP,LRGVP,LRINI,LRIOZERO,LRLAN,LRLCT,LRMD,LRMETH,LRNG,LRNG2,LRNG3,LRNG4,LRNG5,LRODT,LROUTINE,LRPER,LRPLOC,LRSAMP,LRSN,LRSSQ,LRSTAR
- +8 QUIT
- ENT1 SET LRCW=8
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- +1 SET LRFLAG=""
- SET LRCTRL=$SELECT(LRDPF=62.3:1,1:0)
- IF LRCTRL
- FOR I=0:0
- WRITE !,"Display cumulative summary (NO, displays graph)"
- SET %=1
- DO YN^DICN
- if %
- QUIT
- WRITE " Answer 'Y'es or 'N'o."
- +2 IF LRCTRL
- if %<0
- QUIT
- if %=1
- SET LRFLAG=1
- SET LRSDNORM=1
- +3 KILL LREDT
- DO ^LRWU3
- if LREND
- QUIT
- +4 SET LRNSET=80
- SET N=LRNSET
- L2 FOR I=0:0
- WRITE !,"How many time points? ",LRNSET,"//"
- READ X:DTIME
- if X[U!'$LENGTH(X)!(X\1=X&(X'<1))
- QUIT
- WRITE " Enter a number"
- +1 if X[U
- QUIT
- if X'=""
- SET LRNSET=X
- SET N=LRNSET
- L3 KILL ^TMP("LR",$JOB,"TMP"),^TMP("LR",$JOB,"X"),X,LRORD,DIC,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
- SET LRSPEC=-1
- SET DIC(0)="AEOQZ"
- IF LRDPF'=62.3
- SET DIC="^LAB(61,"
- SET DIC("A")="Select SITE/SPECIMEN: ANY//"
- DO ^DIC
- if $DATA(DUOUT)
- GOTO END
- SET LRSPEC=+Y
- L4 SET LRSS="CH"
- KILL DIC("A")
- if 'LRFLAG
- SET LRSDNORM=0
- IF (LRSPEC>0!LRCTRL)&'LRFLAG
- WRITE !,"Plot relative to ",$SELECT(LRCTRL:"expected",1:"normal")," values (if available)"
- SET %=1
- DO YN^DICN
- if %=-1
- QUIT
- if %=0
- GOTO L4
- if %=1
- SET LRSDNORM=1
- +1 if N<2
- SET N=30
- SET LRSSP=0
- SET DIC="^LAB(60,"
- SET DIC("S")="I $P(^(0),U,4)=""CH"""_$SELECT(LRCTRL:"",1:$SELECT('$DATA(^XUSEC("LRSUPER",DUZ)):",""N""'[$P(^(0),U,3)",1:""))
- DO ^DIC
- if Y<1
- GOTO LREND
- +2 IF $LENGTH($PIECE(^LAB(60,+Y,.1),U,5))
- WRITE !,"ASK FOR TESTS INDIVIDUALLY"
- QUIT
- TX SET LRSSP=LRSSP+1
- SET LRTEST(LRSSP)=+Y_U_Y(0)
- DO ^DIC
- if Y>0
- GOTO TX
- +1 SET LRNX=0
- SET LRPANEL=0
- KILL ^TMP("LR",$JOB,"X"),X,^TMP("LR",$JOB,"TMP"),LRORD,DIC
- FOR I=1:1
- if '$DATA(LRTEST(I))
- QUIT
- SET X=LRTEST(I)
- SET (LRNTN,LRNT)=I
- SET (S1,J)=0
- SET LRCFL=""
- DO EX2
- +2 KILL LRTEST,^TMP("LR",$JOB,"TMP")
- SET I=0
- FOR
- SET I=$ORDER(LRORD(I))
- if I<1
- QUIT
- SET J=LRORD(I)
- SET LRTEST(I)=$ORDER(^LAB(60,"C","CH;"_J_";1",0))_U_$PIECE(^LAB(60,$ORDER(^(0)),0),U,1)_U_J
- SET LRNM=I
- +3 KILL %ZIS
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +4 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="DQ^LRDIST"
- SET ZTSAVE("LR*")=""
- DO ^%ZTLOAD
- GOTO L3
- +5 DO LIST
- USE IO(0)
- GOTO L3
- LIST USE IO
- DO DT^LRX
- SET LREND=0
- +1 IF LRFLAG
- DO ^LRDIST2
- +2 SET LRTN=0
- FOR
- SET LRTN=$ORDER(LRTEST(LRTN))
- if LRTN<1
- QUIT
- DO L40
- if LREND
- KILL ^TMP("LR",$JOB,"X"),X,LRTEST
- if LREND
- QUIT
- +3 QUIT
- L40 SET LRSB=$PIECE(LRTEST(LRTN),U,3)
- SET LRCHM=$PIECE(LRTEST(LRTN),U,2)
- SET LRCHM(.1)=$SELECT($DATA(^LAB(60,+LRTEST(LRTN),.1)):$PIECE(^(.1),U,3),1:"")
- SET N=LRNSET
- +1 SET LRIDT=9999999-LRSDT
- SET LAST=9999999-$SELECT(LREDT<1:0,1:LREDT)
- SET LRCOUNT=0
- SET LRSX=0
- SET LRSSX=0
- SET LRNC=0
- KILL LRLOW,LRHIGH
- +2 SET R1=0
- IF LRSDNORM=1&LRCTRL
- SET T=$ORDER(^LAB(62.3,DFN,1,"B",+LRTEST(LRTN),0))
- +3 IF LRSDNORM=1
- IF LRCTRL
- IF T>0
- SET T=^LAB(62.3,DFN,1,T,0)
- SET X=$PIECE(T,U,2)
- SET Y=(3*$PIECE(T,U,3))
- SET LRLOW=X-Y
- SET LRHIGH=X+Y
- SET R1=1
- IF '$LENGTH($PIECE(T,U,2))!('$LENGTH($PIECE(T,U,3)))
- WRITE !,"Expected values not available for "_$PIECE(LRTEST(LRTN),U,2),!
- QUIT
- +4 DO ^LRDIST1
- +5 QUIT
- LREND KILL DIC
- QUIT
- DQ if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- DO LIST
- GOTO END
- OR ;OE/RR entry point
- +1 if '$DATA(ORVP)
- QUIT
- +2 ;-------------------------------------------------------------------
- +3 ; Patch LR*5.2*62 Need PNM, SSN etc....DRH
- +4 ;S:'$G(DFN) DFN=+ORVP S LRDFN=$G(^DPT(DFN,"LR")) Q:'$G(LRDFN) D DEM^LRX
- +5 ;Commented OR+4 To fix patch LR*5.2*64
- +6 ;-------------------------------------------------------------------
- +7 KILL LR,LRABV,LRAX,LRBLOOD,LRCAPA,LRDPAF,LRDT0,LRH,LRSF,LRT,LRU,LRWHO
- +8 SET KILL=1
- IF '$DATA(LRPARAM)
- DO EN^LRPARAM
- SET KILL=0
- +9 DO DT^LRX
- KILL DIC
- SET LREND=0
- SET DFN=+ORVP
- SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
- DO END^LRDPA
- if LRDFN<1
- QUIT
- +10 DO ENT
- +11 IF 'KILL
- KILL LRBLOOD,LRDT0,LRORN,LRPARAM,LRPLASMA,LRSERUM,LRUNKNOW,LRURINE
- +12 KILL KILL
- QUIT
- EX2 ;
- +1 SET LRSUB=$PIECE(X,U,6)
- IF $DATA(^LAB(60,+X,4))
- IF $PIECE(^(4),"^",2)
- SET LRCFL=LRCFL_$PIECE(^(4),"^",2)_U
- +2 IF $LENGTH(LRSUB)
- SET S2=$PIECE(LRSUB,";",2)
- if '$DATA(^TMP("LR",$JOB,"TMP",S2))
- DO ORD
- QUIT
- +3 SET S1=S1+1
- SET S1(S1)=X
- SET S1(S1,1)=J
- +4 SET J=0
- FOR
- SET J=$ORDER(^LAB(60,+S1(S1),2,J))
- if J<1
- QUIT
- SET Y=+^(J,0)
- SET X=Y_U_^LAB(60,Y,0)
- DO EX2
- +5 SET X=S1(S1)
- SET J=S1(S1,1)
- SET S1=S1-1
- +6 QUIT
- ORD SET LRNX=LRNX+1
- SET LRORD(LRNX)=S2
- SET ^TMP("LR",$JOB,"TMP",S2)=+X
- if $PIECE(X,U,18)
- SET LRM(S2)=+X
- SET LRMX(+X)=""
- QUIT
- +1 ;LRNX is set by caller
- +2 QUIT