LRDIST2.m

LRDIST2 ;SLC/DM - WRITE SUMMARY OF LEVY-JENNINGS LRQC CHART ;2/5/91  13:06 ; [ 04/14/2003  7:41 AM ]

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

 ;;5.2;LAB SERVICE;**108,160,153**;Sep 27, 1994

 ;  REGION 5 ISC/SLC ;  DCM

EN ;W PNM,?35,"  ",SSN,?69,"  ",LRDT0,!!?18,"ACTUAL:",?39,"TARGET:",?65,"VALUE OUTSIDE:"

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

 W PNM,?35,"  ",HRCN,?69,"  ",LRDT0,!!?18,"ACTUAL:",?39,"TARGET:",?65,"VALUE OUTSIDE:"  ;IHS/ANMC/CLS 08/18/96

 ;----- END IHS MODIFICATIONS

 W !?10,"+--------------------+",?35,"+------------+"

 W !?2,"TEST",?11,"MEAN",?19,"SD",?25,"CV",?30,"N",?36,"MEAN",?44,"SD",?50,"FL",?53,"ACCESSION",?69,"2SD",?75,"3SD"

 W !,"---------",?10,"------",?17,"------",?24,"----",?29,"---",?35,"------",?42,"-------",?50,"--",?53,"-------------",?68,"----",?74,"----",!

 Q

ENTD ;from LRDIST1

 K LRFOOT S LRFOOT=0 F LRII=1:1:LRCOUNT D WX

 W $E(LRCHM,1,9) I LRSDNORM=0!LRCTRL&(LRNC>1) S LRCV=0 S:%X'=0 LRCV=LRSD/%X*100 W ?10,$J(%X,6,3),?17,$J(LRSD,6,3),?24,$J(LRCV,4,1)

 I LRSDNORM=0!LRCTRL&(LRNC<2) W:LRNC>0 ?10,$J(LRVAL,6,3) W:LRNC<1 ?14,"**" W ?17,"    **  **"

 I LRCTRL&LRSDNORM S LREM=$P(T,U,2),LRESD=$P(T,U,3),LRECV="" S:LREM LRECV=LRESD/LREM*100 W ?29,$J(LRNC,3) W:LREM'=""&(LRESD'="") ?35,$J(LREM,6,3),?42,$J(LRESD,6,3)

 I LREM=""&(LRESD="") W ?35,"No reference range available" G LREND

 I LRFOOT S I=0 F  S I=$O(LRFOOT(I)) Q:I<1  W ?50,$J(I,2,0),?53,$E(^TMP("LR",$J,"X",LRFOOT(I),4),1,15) S X=^(2) W ?$S(X>LRLM2!(X<LRLM1):74,1:68),X W:$O(LRFOOT(I))>0 !

LREND ;from LRDIST1

 I (LRTN=LRNM)&($O(LRTEST(LRTN))<1) W:$E(IOST,1,2)'="C-" !!!!,"Reviewed by:  ___________________________________  Date: ____________" W:$E(IOST,1,2)="C-" ! Q

 W ! Q

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

 S LRXF="X" I ^TMP("LR",$J,"X",LRII,2)<LRLM1F S LRFOOT=LRFOOT+1,LRFOOT(LRFOOT)=LRII,LRXF=LRFOOT

 I ^TMP("LR",$J,"X",LRII,2)>LRLM2F S LRFOOT=LRFOOT+1,LRFOOT(LRFOOT)=LRII,LRXF=LRFOOT

 Q

LRSD ;from LRDIST1

 S LRSD=-1,%X=-1 Q:N<2

 S %X=N*LRSSX-(LRSX*LRSX)/(N*(N-1)) D SQRT S LRSD=%Y,%X=LRSX/N Q

SQRT ;%Y=SQRT(%X)

 S %Y=0 Q:%X'>0  S %Y=%X+1/2

L S A9=%Y,%Y=%X/A9+A9/2 G L:%Y<A9

 Q

LRDIST2   ;SLC/DM - WRITE SUMMARY OF LEVY-JENNINGS LRQC CHART ;2/5/91  13:06 ; [ 04/14/2003  7:41 AM ]

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

 +2       ;;5.2;LAB SERVICE;**108,160,153**;Sep 27, 1994

 +3       ;  REGION 5 ISC/SLC ;  DCM

EN        ;W PNM,?35,"  ",SSN,?69,"  ",LRDT0,!!?18,"ACTUAL:",?39,"TARGET:",?65,"VALUE OUTSIDE:"

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

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

           WRITE PNM,?35,"  ",HRCN,?69,"  ",LRDT0,!!?18,"ACTUAL:",?39,"TARGET:",?65,"VALUE OUTSIDE:"

 +3       ;----- END IHS MODIFICATIONS

 +4        WRITE !?10,"+--------------------+",?35,"+------------+"

 +5        WRITE !?2,"TEST",?11,"MEAN",?19,"SD",?25,"CV",?30,"N",?36,"MEAN",?44,"SD",?50,"FL",?53,"ACCESSION",?69,"2SD",?75,"3SD"

 +6        WRITE !,"---------",?10,"------",?17,"------",?24,"----",?29,"---",?35,"------",?42,"-------",?50,"--",?53,"-------------",?68,"----",?74,"----",!

 +7        QUIT 

ENTD      ;from LRDIST1

 +1        KILL LRFOOT

           SET LRFOOT=0

           FOR LRII=1:1:LRCOUNT

               DO WX

 +2        WRITE $EXTRACT(LRCHM,1,9)

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

               SET LRCV=0

               IF %X'=0

                   SET LRCV=LRSD/%X*100

               WRITE ?10,$JUSTIFY(%X,6,3),?17,$JUSTIFY(LRSD,6,3),?24,$JUSTIFY(LRCV,4,1)

 +3        IF LRSDNORM=0!LRCTRL&(LRNC<2)

               IF LRNC>0

                   WRITE ?10,$JUSTIFY(LRVAL,6,3)

               IF LRNC<1

                   WRITE ?14,"**"

               WRITE ?17,"    **  **"

 +4        IF LRCTRL&LRSDNORM

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

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

               SET LRECV=""

               IF LREM

                   SET LRECV=LRESD/LREM*100

               WRITE ?29,$JUSTIFY(LRNC,3)

               IF LREM'=""&(LRESD'="")

                   WRITE ?35,$JUSTIFY(LREM,6,3),?42,$JUSTIFY(LRESD,6,3)

 +5        IF LREM=""&(LRESD="")

               WRITE ?35,"No reference range available"

               GOTO LREND

 +6        IF LRFOOT

               SET I=0

               FOR 

                   SET I=$ORDER(LRFOOT(I))

                   IF I<1

                       QUIT 

                   WRITE ?50,$JUSTIFY(I,2,0),?53,$EXTRACT(^TMP("LR",$JOB,"X",LRFOOT(I),4),1,15)

                   SET X=^(2)

                   WRITE ?$SELECT(X>LRLM2!(X<LRLM1):74,1:68),X

                   IF $ORDER(LRFOOT(I))>0

                       WRITE !

LREND     ;from LRDIST1

 +1        IF (LRTN=LRNM)&($ORDER(LRTEST(LRTN))<1)

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

                   WRITE !!!!,"Reviewed by:  ___________________________________  Date: ____________"

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

                   WRITE !

               QUIT 

 +2        WRITE !

           QUIT 

WX         SET LRSTEPS=(LRHIGH-LRLOW)/4

           SET LRLM1=LRLOW-LRSTEPS

           SET LRLM2=LRHIGH+LRSTEPS

           SET LRLM1F=LRLM1+LRSTEPS

           SET LRLM2F=LRLM2-LRSTEPS

           SET N=LRCOUNT

 +1        SET LRXF="X"

           IF ^TMP("LR",$JOB,"X",LRII,2)<LRLM1F

               SET LRFOOT=LRFOOT+1

               SET LRFOOT(LRFOOT)=LRII

               SET LRXF=LRFOOT

 +2        IF ^TMP("LR",$JOB,"X",LRII,2)>LRLM2F

               SET LRFOOT=LRFOOT+1

               SET LRFOOT(LRFOOT)=LRII

               SET LRXF=LRFOOT

 +3        QUIT 

LRSD      ;from LRDIST1

 +1        SET LRSD=-1

           SET %X=-1

           IF N<2

               QUIT 

 +2        SET %X=N*LRSSX-(LRSX*LRSX)/(N*(N-1))

           DO SQRT

           SET LRSD=%Y

           SET %X=LRSX/N

           QUIT 

SQRT      ;%Y=SQRT(%X)

 +1        SET %Y=0

           IF %X'>0

               QUIT 

           SET %Y=%X+1/2

L          SET A9=%Y

           SET %Y=%X/A9+A9/2

           IF %Y<A9

               GOTO L

 +1        QUIT