LRMRSHRT ;SLC/CJS - MULTI-RULE SHEWHART QUALITY CONTROL ;2/6/91 08:35 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
;IF LRTEST="" DO FOR LRALL, OTHERWISE, "T1^T2^etc."
S LRMWDT=LRAD ;S U="^",LRMWDT=$P(^LRO(68,LRAA,0),U,3),LRMWDT=$S(LRAD="Y":$E(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$E(DT,1,5)_"00","Q"[LRAD:$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
S X1=LRMWDT,X2=-1 D C^%DTC S LRYDT=X
K LRTS,LRTX S LRDFN=+^LRO(68,LRAA,1,LRMWDT,1,LRAN,0),LRIFN=+$P(^LR(LRDFN,0),U,3),LRPIFN=+$P(^LAB(62.3,LRIFN,0),U,3)
S I=0 F S I=$O(^LAB(62.3,LRIFN,1,I)) Q:I<1 S LRTS=^(I,0),P=$P(LRTS,U,4) I P'="" S LRTS(P)=$P(LRTS,U,1,3)
F I=0 F S I=$O(^LAB(62.3,LRPIFN,1,I)) Q:I<1 S LRTX=^(I,0),P=$P(LRTX,U,4) I P'="" S LRTX(P)=$P(LRTX,U,3)
S P="" F I=0:0 S P=$O(LRTS(P)) Q:P="" D LRTEST
K LRYA,LRYC,LRYDT,LRYG,X1,X2,LRSIGN,LRPCNT,LRNUM,LRIFN,LRALL,LRGRP,LRPX,LRPSD,LRPIFN,LRPGRP,LRJCTRSN,LRMWDT,A,DA,DIE,I,J,K Q
LRTEST S LRTS=+LRTS(P),X='$L(LRTEST) F J=0:0 S K=$P(LRTEST,U,J) Q:K="" S X=K=LRTS Q:X=1
Q:'X S LRSS=$P(P,";",1),LRSB=$P(P,";",2),LRSSP=$P(P,";",3),LRSD=$P(LRTS(P),U,3),LRPSD=$S($D(LRTX(P)):LRTX(P),1:"")
S X1="" S:$D(^LR(LRDFN,LRSS,LRIDT,LRSB)) X1=$P(^(LRSB),U,LRSSP)-$P(LRTS(P),U,2),LRSIGN=$S(X1<0:-1,1:1) Q:X1=""
G T4:$D(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0)) I '$D(^LRO(68,LRAA,1,LRYDT,4,LRIFN,1,LRTS,0)) S ^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0)=LRTS_U_0 G T2
S Y=^LRO(68,LRAA,1,LRYDT,4,LRIFN,1,LRTS,0),LRNUM=8 D LRYC S ^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0)=Y
T2 S ^(0)="^68.12PA^"_LRTS_U_$S($D(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,0)):1+$P(^(0),U,4),1:1)
G T4:$D(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,0)) S ^(0)=LRIFN,^(0)="^68.11PA^"_LRIFN_U_$S($D(^LRO(68,LRAA,1,LRMWDT,4,0)):1+$P(^(0),U,4),1:1)
T4 W ! S Y=$S($D(^LRO(68,LRAA,1,LRMWDT,4,LRPIFN,1,LRTS,0)):^(0),1:""),LRPCNT=$P(Y,U,2),LRNUM=9 D LRYC S LRPGRP=LRGRP
S Y=^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0),$P(Y,U,2)=1+$P(Y,U,2),Y=Y_U_X1,^(0)=Y,LRPGRP=$S(LRPCNT=$P(Y,U,2):LRPGRP,1:"") D LRYC
K DR S X=$S(X1<0:-X1,1:X1),LRJCTRSN="",DIE="^LR("_LRDFN_",""CH"",",DA=LRIDT,DA(1)=LRDFN G INCONTRL:X<(2*LRSD)&($L(LRPGRP)="")
I $L(LRPGRP),$L(LRPSD) S LRPX=$P(LRPGRP,U,LRCNT),LRPX=$S(LRPX<0:-LRPX,1:LRPX) G INCONTRL:X<(2*LRSD)&(LRPX<2*LRPSD)
I X>(3*LRSD) S LRJCTRSN="1/3S ",DR=".99///1/3S" D ^DIE
I $L(LRPGRP),$L(LRPSD),$P(LRPGRP,U,LRCNT)>(2*LRPSD) S LRJCTRSN=LRJCTRSN_"2/2S ",DR=".99///2/2S" D ^DIE
G INCONTRL:LRCNT<2 I $P(LRGRP,U,LRCNT-1)>(2*LRSD) S LRJCTRSN=LRJCTRSN_"2/2S ",DR=".99///2/2S" D ^DIE
I $L(LRPGRP),$L(LRPSD) S X=$P(LRPGRP,U,LRCNT) I LRSIGN*X<0 S X=$S(X<1:-X,1:X)/LRPSD+(LRSIGN*X1/LRSD) I X>4 S LRJCTRSN=LRJCTRSN_"R/4S ",DR=".99///R/4S" D ^DIE
I $L(LRGRP) S X=$P(LRGRP,U,LRCNT-1) I LRSIGN*X<0 S X=$S(X<1:-X,1:X)/LRSD+(LRSIGN*X1/LRSD) I X>4 S LRJCTRSN=LRJCTRSN_"R/4S ",DR=".99///R/4S" D ^DIE
I $L(LRPGRP),$L(LRPSD) S N=1,A=LRSD,LRYG=LRGRP,LRALL=0 D LRYG S A=LRPSD,LRYG=LRPGRP D LRYG I LRALL=10 S LRJCTRSN=LRJCTRSN_"10/1S ",DR=".99///10/1S" D ^DIE
G INCONTRL:LRCNT<10 S N=9,A=LRSD,LRYG=LRGRP,LRALL=0 D LRYG I LRALL=9 S LRJCTRSN=LRJCTRSN_"10/1S ",DR=".99///10/1S" D ^DIE
; I $L(LRPGRP),$L(LRPSD) S N=1,A=LRSD,LRYG=LRGRP,LRALL=0 D LRYG S A=LRPSD,LRYG=LRPGRP D LRYG I LRALL=4 S LRJCTRSN=LRJCTRSN_"4/1S ",DR=".99///4/1S" D ^DIE
; G INCONTRL:LRCNT<4 S N=3,A=LRSD,LRYG=LRGRP,LRALL=0 D LRYG I LRALL=4 S LRJCTRSN=LRJCTRSN_"4/1S ",DR=".99///4/1S" D ^DIE
; I $L(LRPGRP),$L(LRPSD) S N=4,A=0,LRYG=LRGRP,LRALL=0 D LRYG S LRYG=LRPGRP D LRYG I LRALL=10 S LRJCTRSN=LRJCTRSN_"10/MX ",DR=".99///10/MX" D ^DIE
; G INCONTRL:LRCNT<10 S N=9,A=0,LRYG=LRGRP,LRALL=0 D LRYG I LRALL=10 S LRJCTRSN=LRJCTRSN_"10/MX ",DR=".99///10/MX" D ^DIE
INCONTRL Q:LRJCTRSN=""
OUTCNTRL S $P(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,0),U,2)=LRJCTRSN
Q
LRYC S LRYC=$P(Y,U,2)+2,LRYA=LRYC-LRNUM S:LRYA<3 LRYA=3 S LRCNT=LRYC-LRYA+1,LRGRP=$P(Y,U,LRYA,LRYC),Y=LRTS_U_LRCNT_U_LRGRP
Q
LRYG F J=LRCNT-N:1:LRCNT Q:$S($P(LRYG,U,J)<0:-1,1:1)'=LRSIGN S:$P(LRYG,U,J)*LRSIGN>A LRALL=LRALL+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMRSHRT 3932 printed Oct 16, 2024@18:18:48 Page 2
LRMRSHRT ;SLC/CJS - MULTI-RULE SHEWHART QUALITY CONTROL ;2/6/91 08:35 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 ;IF LRTEST="" DO FOR LRALL, OTHERWISE, "T1^T2^etc."
+3 ;S U="^",LRMWDT=$P(^LRO(68,LRAA,0),U,3),LRMWDT=$S(LRAD="Y":$E(DT,1,3)_"0000","D"[LRAD:DT,"M"[LRAD:$E(DT,1,5)_"00","Q"[LRAD:$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
SET LRMWDT=LRAD
+4 SET X1=LRMWDT
SET X2=-1
DO C^%DTC
SET LRYDT=X
+5 KILL LRTS,LRTX
SET LRDFN=+^LRO(68,LRAA,1,LRMWDT,1,LRAN,0)
SET LRIFN=+$PIECE(^LR(LRDFN,0),U,3)
SET LRPIFN=+$PIECE(^LAB(62.3,LRIFN,0),U,3)
+6 SET I=0
FOR
SET I=$ORDER(^LAB(62.3,LRIFN,1,I))
if I<1
QUIT
SET LRTS=^(I,0)
SET P=$PIECE(LRTS,U,4)
IF P'=""
SET LRTS(P)=$PIECE(LRTS,U,1,3)
+7 FOR I=0
FOR
SET I=$ORDER(^LAB(62.3,LRPIFN,1,I))
if I<1
QUIT
SET LRTX=^(I,0)
SET P=$PIECE(LRTX,U,4)
IF P'=""
SET LRTX(P)=$PIECE(LRTX,U,3)
+8 SET P=""
FOR I=0:0
SET P=$ORDER(LRTS(P))
if P=""
QUIT
DO LRTEST
+9 KILL LRYA,LRYC,LRYDT,LRYG,X1,X2,LRSIGN,LRPCNT,LRNUM,LRIFN,LRALL,LRGRP,LRPX,LRPSD,LRPIFN,LRPGRP,LRJCTRSN,LRMWDT,A,DA,DIE,I,J,K
QUIT
LRTEST SET LRTS=+LRTS(P)
SET X='$LENGTH(LRTEST)
FOR J=0:0
SET K=$PIECE(LRTEST,U,J)
if K=""
QUIT
SET X=K=LRTS
if X=1
QUIT
+1 if 'X
QUIT
SET LRSS=$PIECE(P,";",1)
SET LRSB=$PIECE(P,";",2)
SET LRSSP=$PIECE(P,";",3)
SET LRSD=$PIECE(LRTS(P),U,3)
SET LRPSD=$SELECT($DATA(LRTX(P)):LRTX(P),1:"")
+2 SET X1=""
if $DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
SET X1=$PIECE(^(LRSB),U,LRSSP)-$PIECE(LRTS(P),U,2)
SET LRSIGN=$SELECT(X1<0:-1,1:1)
if X1=""
QUIT
+3 if $DATA(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0))
GOTO T4
IF '$DATA(^LRO(68,LRAA,1,LRYDT,4,LRIFN,1,LRTS,0))
SET ^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0)=LRTS_U_0
GOTO T2
+4 SET Y=^LRO(68,LRAA,1,LRYDT,4,LRIFN,1,LRTS,0)
SET LRNUM=8
DO LRYC
SET ^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0)=Y
T2 SET ^(0)="^68.12PA^"_LRTS_U_$SELECT($DATA(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,0)):1+$PIECE(^(0),U,4),1:1)
+1 if $DATA(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,0))
GOTO T4
SET ^(0)=LRIFN
SET ^(0)="^68.11PA^"_LRIFN_U_$SELECT($DATA(^LRO(68,LRAA,1,LRMWDT,4,0)):1+$PIECE(^(0),U,4),1:1)
T4 WRITE !
SET Y=$SELECT($DATA(^LRO(68,LRAA,1,LRMWDT,4,LRPIFN,1,LRTS,0)):^(0),1:"")
SET LRPCNT=$PIECE(Y,U,2)
SET LRNUM=9
DO LRYC
SET LRPGRP=LRGRP
+1 SET Y=^LRO(68,LRAA,1,LRMWDT,4,LRIFN,1,LRTS,0)
SET $PIECE(Y,U,2)=1+$PIECE(Y,U,2)
SET Y=Y_U_X1
SET ^(0)=Y
SET LRPGRP=$SELECT(LRPCNT=$PIECE(Y,U,2):LRPGRP,1:"")
DO LRYC
+2 KILL DR
SET X=$SELECT(X1<0:-X1,1:X1)
SET LRJCTRSN=""
SET DIE="^LR("_LRDFN_",""CH"","
SET DA=LRIDT
SET DA(1)=LRDFN
if X<(2*LRSD)&($LENGTH(LRPGRP)="")
GOTO INCONTRL
+3 IF $LENGTH(LRPGRP)
IF $LENGTH(LRPSD)
SET LRPX=$PIECE(LRPGRP,U,LRCNT)
SET LRPX=$SELECT(LRPX<0:-LRPX,1:LRPX)
if X<(2*LRSD)&(LRPX<2*LRPSD)
GOTO INCONTRL
+4 IF X>(3*LRSD)
SET LRJCTRSN="1/3S "
SET DR=".99///1/3S"
DO ^DIE
+5 IF $LENGTH(LRPGRP)
IF $LENGTH(LRPSD)
IF $PIECE(LRPGRP,U,LRCNT)>(2*LRPSD)
SET LRJCTRSN=LRJCTRSN_"2/2S "
SET DR=".99///2/2S"
DO ^DIE
+6 if LRCNT<2
GOTO INCONTRL
IF $PIECE(LRGRP,U,LRCNT-1)>(2*LRSD)
SET LRJCTRSN=LRJCTRSN_"2/2S "
SET DR=".99///2/2S"
DO ^DIE
+7 IF $LENGTH(LRPGRP)
IF $LENGTH(LRPSD)
SET X=$PIECE(LRPGRP,U,LRCNT)
IF LRSIGN*X<0
SET X=$SELECT(X<1:-X,1:X)/LRPSD+(LRSIGN*X1/LRSD)
IF X>4
SET LRJCTRSN=LRJCTRSN_"R/4S "
SET DR=".99///R/4S"
DO ^DIE
+8 IF $LENGTH(LRGRP)
SET X=$PIECE(LRGRP,U,LRCNT-1)
IF LRSIGN*X<0
SET X=$SELECT(X<1:-X,1:X)/LRSD+(LRSIGN*X1/LRSD)
IF X>4
SET LRJCTRSN=LRJCTRSN_"R/4S "
SET DR=".99///R/4S"
DO ^DIE
+9 IF $LENGTH(LRPGRP)
IF $LENGTH(LRPSD)
SET N=1
SET A=LRSD
SET LRYG=LRGRP
SET LRALL=0
DO LRYG
SET A=LRPSD
SET LRYG=LRPGRP
DO LRYG
IF LRALL=10
SET LRJCTRSN=LRJCTRSN_"10/1S "
SET DR=".99///10/1S"
DO ^DIE
+10 if LRCNT<10
GOTO INCONTRL
SET N=9
SET A=LRSD
SET LRYG=LRGRP
SET LRALL=0
DO LRYG
IF LRALL=9
SET LRJCTRSN=LRJCTRSN_"10/1S "
SET DR=".99///10/1S"
DO ^DIE
+11 ; I $L(LRPGRP),$L(LRPSD) S N=1,A=LRSD,LRYG=LRGRP,LRALL=0 D LRYG S A=LRPSD,LRYG=LRPGRP D LRYG I LRALL=4 S LRJCTRSN=LRJCTRSN_"4/1S ",DR=".99///4/1S" D ^DIE
+12 ; G INCONTRL:LRCNT<4 S N=3,A=LRSD,LRYG=LRGRP,LRALL=0 D LRYG I LRALL=4 S LRJCTRSN=LRJCTRSN_"4/1S ",DR=".99///4/1S" D ^DIE
+13 ; I $L(LRPGRP),$L(LRPSD) S N=4,A=0,LRYG=LRGRP,LRALL=0 D LRYG S LRYG=LRPGRP D LRYG I LRALL=10 S LRJCTRSN=LRJCTRSN_"10/MX ",DR=".99///10/MX" D ^DIE
+14 ; G INCONTRL:LRCNT<10 S N=9,A=0,LRYG=LRGRP,LRALL=0 D LRYG I LRALL=10 S LRJCTRSN=LRJCTRSN_"10/MX ",DR=".99///10/MX" D ^DIE
INCONTRL if LRJCTRSN=""
QUIT
OUTCNTRL SET $PIECE(^LRO(68,LRAA,1,LRMWDT,4,LRIFN,0),U,2)=LRJCTRSN
+1 QUIT
LRYC SET LRYC=$PIECE(Y,U,2)+2
SET LRYA=LRYC-LRNUM
if LRYA<3
SET LRYA=3
SET LRCNT=LRYC-LRYA+1
SET LRGRP=$PIECE(Y,U,LRYA,LRYC)
SET Y=LRTS_U_LRCNT_U_LRGRP
+1 QUIT
LRYG FOR J=LRCNT-N:1:LRCNT
if $SELECT($PIECE(LRYG,U,J)<0
QUIT
if $PIECE(LRYG,U,J)*LRSIGN>A
SET LRALL=LRALL+1
+1 QUIT
