LRDIST1.m

LRDIST1 ;DALOI/CJS/JMC/RLM-DATA DISTRIBUTION ;2/5/91 13:00 [ 04/14/2003  7:39 AM ]

 ;;5.2T9;LR;**1001,1018**;Nov 17, 2004

 ;;5.2;LAB SERVICE;**108,126,272**;Sep 27, 1994

Q2A S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) G Q2C:LRIDT<1!(LRIDT>LAST),Q2A:'$D(^LR(LRDFN,LRSS,LRIDT,0))!'$L($P(^(0),U,3))!'$D(^(LRSB))

 S LRSPC=$S('LRCTRL:$P(^LR(LRDFN,LRSS,LRIDT,0),U,5),1:"") I LRSPEC'=-1 G:LRSPEC'=LRSPC Q2A

 S LRVAL=+$P(^LR(LRDFN,LRSS,LRIDT,LRSB),U,1) I 'LRVAL,$P(^(LRSB),U,1)'=0,$P(^(LRSB),U,1)'?1."0"1"."1."0" G Q2A ;G:'LRVAL&($P(^(LRSB),U,1)'=0) Q2A

 I LRSDNORM&LRCTRL,R1,LRVAL>LRLOW,LRVAL<LRHIGH S LRSX=LRSX+LRVAL,LRSSX=LRSSX+(LRVAL*LRVAL),LRNC=LRNC+1

 I 'LRSDNORM!'LRCTRL!(LRCTRL&'R1) S LRSX=LRSX+LRVAL,LRSSX=LRSSX+(LRVAL*LRVAL),LRNC=LRNC+1

 S LRCOUNT=LRCOUNT+1,^TMP("LR",$J,"X",LRCOUNT,1)=$P(^LR(LRDFN,LRSS,LRIDT,0),U,1),^TMP("LR",$J,"X",LRCOUNT,4)=$P(^LR(LRDFN,LRSS,LRIDT,0),U,6),^TMP("LR",$J,"X",LRCOUNT,2)=LRVAL,^TMP("LR",$J,"X",LRCOUNT,3)=LRSPC

 S I=0 F  S I=$O(^LR(LRDFN,LRSS,LRIDT,1,I)) Q:I<1  S X=^(I,0),^TMP("LR",$J,"X",LRCOUNT,4,I)=X

 G Q2A:LRCOUNT<LRNSET

Q2C W:LRCOUNT=0 !,"Nothing to plot for ",LRCHM D LREND^LRDIST2:LRFLAG&(LRCOUNT=0) Q:LRCOUNT=0  I LRNC<2,'$D(LRLOW) S LRLOW=LRVAL-2,LRHIGH=LRVAL+2

 I LRNC>1 S N=LRNC D LRSD^LRDIST2 S LRSDD=LRSD S:LRSD=0 LRSDD=1 S LRLOW=%X-(2*LRSDD),LRHIGH=%X+(2*LRSDD)

 IF LRSDNORM=1&LRCTRL S T=$O(^LAB(62.3,DFN,1,"B",+LRTEST(LRTN),0)) I T>0 S T=^LAB(62.3,DFN,1,T,0),X=$P(T,U,2),Y=(2*$P(T,U,3)),LRLOW=X-Y,LRHIGH=X+Y G LRSTEPS:'LRFLAG,ENTD^LRDIST2:LRFLAG

 IF LRSDNORM=1,$D(^LAB(60,+LRTEST(LRTN),1,LRSPEC,0)),$L($P(^(0),U,2)),$L($P(^(0),U,3)) S @("LOW="_$P(^(0),U,2)),@("HIGH="_$P(^(0),U,3)) G LRSTEPS:'LRFLAG,ENTD^LRDIST2:LRFLAG

 I LRFLAG G ENTD^LRDIST2

 IF LRSDNORM=1 W !,"No reference range is available"

LRSTEPS S LRSTEPS=(LRHIGH-LRLOW)/4,LRNEX=LRLOW,LRSTS=LRSTEPS/10,LRLM1=LRLOW-LRSTEPS,LRLM2=LRHIGH+LRSTEPS,LRLM1F=LRLM1+LRSTEPS,LRLM2F=LRLM2-LRSTEPS,N=LRCOUNT

 ;W !,LRCHM,?19," ",PNM,?49," ",SSN,?69," ",LRDT0

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 W !,LRCHM,?19," ",PNM,?49," ",HRCN,?69," ",LRDT0  ;IHS/ANMC/CLS 08/18/96

 ;----- END IHS MODIFICATIONS

 S X=$S($D(^LAB(60,+LRTEST(LRTN),1,LRSPEC,0)):^(0),1:"") W:LRSPEC>0 !,"SITE/SPECIMEN: ",$P(^LAB(61,LRSPEC,0),U,1) W:$L($P(X,U,2)) ?30,"REFERENCE LOW: ",@$P(X,U,2) W:$L($P(X,U,3)) ?55,"REFERENCE HIGH: ",@$P(X,U,3)

 W:$L($P(X,U,11)) ?30,"THERAPEUTIC LOW: ",@$P(X,U,11) W:$L($P(X,U,12)) ?55,"THERAPEUTIC HIGH: ",@$P(X,U,12)

 W ! W:$L($P(X,U,7)) "UNITS: ",$P(X,U,7) W:$L($P(X,U,4)) ?30,"CRITICAL LOW: ",@$P(X,U,4) W:$L($P(X,U,5)) ?55,"CRITICAL HIGH: ",@$P(X,U,5)

 W !,"DATE    VALUE ",$S(LRCTRL:"-3SD",1:"LOW") F LRIY=1:1:5 W $J(LRNEX,10,3) S LRNEX=LRNEX+LRSTEPS

 W "    ",$S(LRCTRL:"+3SD",1:"HIGH") D DASH^LRX

 K LRFOOT S LRFOOT=0 F LRII=1:1:LRCOUNT D Q3^LRDIST3

 D DASH^LRX

Q4 I LRCTRL&LRSDNORM,R1 S LREM=$P(T,U,2),LRESD=$P(T,U,3),LRECV="" S:LREM LRECV=LRESD/LREM*100 W !,"Target:  mean=",$J(LREM,6,3),"    1 SD=",$J(LRESD,6,3),"    1 CV=",$J(LRECV,6,3)

 IF LRSDNORM=0!LRCTRL&(LRNC>1) S LRCV=0 S:%X'=0 LRCV=LRSD/%X*100 W !,"Actual:  mean=",$J(%X,6,3),"    1 SD=",$J(LRSD,6,3),"    1 CV=",$J(LRCV,6,3),!,"N=",LRNC,!,"CAUTION: Time scale is sequential, not proportional.",!!

 I LRCTRL S LRLF=IOSL-$Y-LRFOOT-5 I LRLF>0 F I=1:1:LRLF W !

 I LRFOOT W !,"FLAG   ACCESSION    VALUE OUTSIDE 2SD",?46,"3SD" S I=0 F  S I=$O(LRFOOT(I)) Q:I<1  W !,I,?7,^TMP("LR",$J,"X",LRFOOT(I),4) S X=^(2) W ?$S(X>LRLM2!(X<LRLM1):45,1:34),X D EX

 I LRCTRL W !!,"Reviewed by: ____________________________  Date: __________"

WAIT W:$E(IOST,1,2)="P-" @IOF Q:$E(IOST,1,2)'="C-"  R !,"PRESS '^' TO STOP ",X:DTIME S:X="" X=1 S LREND=".^"[X Q

 Q

EX S J=0 F  S J=$O(^TMP("LR",$J,"X",LRFOOT(I),4,J)) Q:J<1  W !?12,^(J)

 Q

LRDIST1   ;DALOI/CJS/JMC/RLM-DATA DISTRIBUTION ;2/5/91 13:00 [ 04/14/2003  7:39 AM ]

 +1       ;;5.2T9;LR;**1001,1018**;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**108,126,272**;Sep 27, 1994

Q2A        SET LRIDT=$ORDER(^LR(LRDFN,LRSS,LRIDT))

           IF LRIDT<1!(LRIDT>LAST)

               GOTO Q2C

           IF '$DATA(^LR(LRDFN,LRSS,LRIDT,0))!'$LENGTH($PIECE(^(0),U,3))!'$DATA(^(LRSB))

               GOTO Q2A

 +1        SET LRSPC=$SELECT('LRCTRL:$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,5),1:"")

           IF LRSPEC'=-1

               IF LRSPEC'=LRSPC

                   GOTO Q2A

 +2       ;G:'LRVAL&($P(^(LRSB),U,1)'=0) Q2A

           SET LRVAL=+$PIECE(^LR(LRDFN,LRSS,LRIDT,LRSB),U,1)

           IF 'LRVAL

               IF $PIECE(^(LRSB),U,1)'=0

                   IF $PIECE(^(LRSB),U,1)'?1."0"1"."1."0"

                       GOTO Q2A

 +3        IF LRSDNORM&LRCTRL

               IF R1

                   IF LRVAL>LRLOW

                       IF LRVAL<LRHIGH

                           SET LRSX=LRSX+LRVAL

                           SET LRSSX=LRSSX+(LRVAL*LRVAL)

                           SET LRNC=LRNC+1

 +4        IF 'LRSDNORM!'LRCTRL!(LRCTRL&'R1)

               SET LRSX=LRSX+LRVAL

               SET LRSSX=LRSSX+(LRVAL*LRVAL)

               SET LRNC=LRNC+1

 +5        SET LRCOUNT=LRCOUNT+1

           SET ^TMP("LR",$JOB,"X",LRCOUNT,1)=$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,1)

           SET ^TMP("LR",$JOB,"X",LRCOUNT,4)=$PIECE(^LR(LRDFN,LRSS,LRIDT,0),U,6)

           SET ^TMP("LR",$JOB,"X",LRCOUNT,2)=LRVAL

           SET ^TMP("LR",$JOB,"X",LRCOUNT,3)=LRSPC

 +6        SET I=0

           FOR 

               SET I=$ORDER(^LR(LRDFN,LRSS,LRIDT,1,I))

               IF I<1

                   QUIT 

               SET X=^(I,0)

               SET ^TMP("LR",$JOB,"X",LRCOUNT,4,I)=X

 +7        IF LRCOUNT<LRNSET

               GOTO Q2A

Q2C        IF LRCOUNT=0

               WRITE !,"Nothing to plot for ",LRCHM

           IF LRFLAG&(LRCOUNT=0)

               DO LREND^LRDIST2

           IF LRCOUNT=0

               QUIT 

           IF LRNC<2

               IF '$DATA(LRLOW)

                   SET LRLOW=LRVAL-2

                   SET LRHIGH=LRVAL+2

 +1        IF LRNC>1

               SET N=LRNC

               DO LRSD^LRDIST2

               SET LRSDD=LRSD

               IF LRSD=0

                   SET LRSDD=1

               SET LRLOW=%X-(2*LRSDD)

               SET LRHIGH=%X+(2*LRSDD)

 +2        IF LRSDNORM=1&LRCTRL

               SET T=$ORDER(^LAB(62.3,DFN,1,"B",+LRTEST(LRTN),0))

               IF T>0

                   SET T=^LAB(62.3,DFN,1,T,0)

                   SET X=$PIECE(T,U,2)

                   SET Y=(2*$PIECE(T,U,3))

                   SET LRLOW=X-Y

                   SET LRHIGH=X+Y

                   IF 'LRFLAG

                       GOTO LRSTEPS

                   IF LRFLAG

                       GOTO ENTD^LRDIST2

 +3        IF LRSDNORM=1

               IF $DATA(^LAB(60,+LRTEST(LRTN),1,LRSPEC,0))

                   IF $LENGTH($PIECE(^(0),U,2))

                       IF $LENGTH($PIECE(^(0),U,3))

                           SET @("LOW="_$PIECE(^(0),U,2))

                           SET @("HIGH="_$PIECE(^(0),U,3))

                           IF 'LRFLAG

                               GOTO LRSTEPS

                           IF LRFLAG

                               GOTO ENTD^LRDIST2

 +4        IF LRFLAG

               GOTO ENTD^LRDIST2

 +5        IF LRSDNORM=1

               WRITE !,"No reference range is available"

LRSTEPS    SET LRSTEPS=(LRHIGH-LRLOW)/4

           SET LRNEX=LRLOW

           SET LRSTS=LRSTEPS/10

           SET LRLM1=LRLOW-LRSTEPS

           SET LRLM2=LRHIGH+LRSTEPS

           SET LRLM1F=LRLM1+LRSTEPS

           SET LRLM2F=LRLM2-LRSTEPS

           SET N=LRCOUNT

 +1       ;W !,LRCHM,?19," ",PNM,?49," ",SSN,?69," ",LRDT0

 +2       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +3       ;IHS/ANMC/CLS 08/18/96

           WRITE !,LRCHM,?19," ",PNM,?49," ",HRCN,?69," ",LRDT0

 +4       ;----- END IHS MODIFICATIONS

 +5        SET X=$SELECT($DATA(^LAB(60,+LRTEST(LRTN),1,LRSPEC,0)):^(0),1:"")

           IF LRSPEC>0

               WRITE !,"SITE/SPECIMEN: ",$PIECE(^LAB(61,LRSPEC,0),U,1)

           IF $LENGTH($PIECE(X,U,2))

               WRITE ?30,"REFERENCE LOW: ",@$PIECE(X,U,2)

           IF $LENGTH($PIECE(X,U,3))

               WRITE ?55,"REFERENCE HIGH: ",@$PIECE(X,U,3)

 +6        IF $LENGTH($PIECE(X,U,11))

               WRITE ?30,"THERAPEUTIC LOW: ",@$PIECE(X,U,11)

           IF $LENGTH($PIECE(X,U,12))

               WRITE ?55,"THERAPEUTIC HIGH: ",@$PIECE(X,U,12)

 +7        WRITE !

           IF $LENGTH($PIECE(X,U,7))

               WRITE "UNITS: ",$PIECE(X,U,7)

           IF $LENGTH($PIECE(X,U,4))

               WRITE ?30,"CRITICAL LOW: ",@$PIECE(X,U,4)

           IF $LENGTH($PIECE(X,U,5))

               WRITE ?55,"CRITICAL HIGH: ",@$PIECE(X,U,5)

 +8        WRITE !,"DATE    VALUE ",$SELECT(LRCTRL:"-3SD",1:"LOW")

           FOR LRIY=1:1:5

               WRITE $JUSTIFY(LRNEX,10,3)

               SET LRNEX=LRNEX+LRSTEPS

 +9        WRITE "    ",$SELECT(LRCTRL:"+3SD",1:"HIGH")

           DO DASH^LRX

 +10       KILL LRFOOT

           SET LRFOOT=0

           FOR LRII=1:1:LRCOUNT

               DO Q3^LRDIST3

 +11       DO DASH^LRX

Q4         IF LRCTRL&LRSDNORM

               IF R1

                   SET LREM=$PIECE(T,U,2)

                   SET LRESD=$PIECE(T,U,3)

                   SET LRECV=""

                   IF LREM

                       SET LRECV=LRESD/LREM*100

                   WRITE !,"Target:  mean=",$JUSTIFY(LREM,6,3),"    1 SD=",$JUSTIFY(LRESD,6,3),"    1 CV=",$JUSTIFY(LRECV,6,3)

 +1        IF LRSDNORM=0!LRCTRL&(LRNC>1)

               SET LRCV=0

               IF %X'=0

                   SET LRCV=LRSD/%X*100

               WRITE !,"Actual:  mean=",$JUSTIFY(%X,6,3),"    1 SD=",$JUSTIFY(LRSD,6,3),"    1 CV=",$JUSTIFY(LRCV,6,3),!,"N=",LRNC,!,"CAUTION: Time scale is sequential, not proportional.",!!

 +2        IF LRCTRL

               SET LRLF=IOSL-$Y-LRFOOT-5

               IF LRLF>0

                   FOR I=1:1:LRLF

                       WRITE !

 +3        IF LRFOOT

               WRITE !,"FLAG   ACCESSION    VALUE OUTSIDE 2SD",?46,"3SD"

               SET I=0

               FOR 

                   SET I=$ORDER(LRFOOT(I))

                   IF I<1

                       QUIT 

                   WRITE !,I,?7,^TMP("LR",$JOB,"X",LRFOOT(I),4)

                   SET X=^(2)

                   WRITE ?$SELECT(X>LRLM2!(X<LRLM1):45,1:34),X

                   DO EX

 +4        IF LRCTRL

               WRITE !!,"Reviewed by: ____________________________  Date: __________"

WAIT       IF $EXTRACT(IOST,1,2)="P-"

               WRITE @IOF

           IF $EXTRACT(IOST,1,2)'="C-"

               QUIT 

           READ !,"PRESS '^' TO STOP ",X:DTIME

           IF X=""

               SET X=1

           SET LREND=".^"[X

           QUIT 

 +1        QUIT 

EX         SET J=0

           FOR 

               SET J=$ORDER(^TMP("LR",$JOB,"X",LRFOOT(I),4,J))

               IF J<1

                   QUIT 

               WRITE !?12,^(J)

 +1        QUIT