- LRQCC ;SLC/CJS - QUALITY CONTROL FOR BULL ALGORITHM ;2/6/91 14:28 ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- S DIC="^LRO(68,",DIC(0)="AEOQ" D ^DIC Q:Y<1 S LRAA=+Y
- S %DT="AE" W !,"START FROM" D ^%DT Q:Y<0 S LRSDT=Y-1
- C2 S DIC("A")="Select INSTRUMENT: ",DIC("S")="I $D(^(5))",DIC="^LAB(62.4," D ^DIC K DIC Q:Y<1 S LRMACH=+Y,LRMC=^LAB(62.4,LRMACH,5)
- I '$P(^LAB(62.4,LRMACH,5),U,2)!('$P(^(5),U,3))!('$P(^(5),U,4)) W " ??",$C(7),!,"Mean data values are missing in the AUTO INSTRUMENT file for this instrument." G LREND
- S %ZIS="Q" D ^%ZIS G LREND:POP
- I $D(IO("Q")) S ZTRTN="DQ^LRQCC" F I="LRMACH","LRMC","LRSDT","LRAA" S ZTSAVE(I)=""
- I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED" G END
- DQ U IO D LIST D ^%ZISC
- END K %,A,DIC,I,K,N,X,Y,Z,LRMACH,LRMC,LRSDT,LRAA,DIC,%ZIS,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK Q
- LABULL Q:'$D(LRBULL) K LRBULL Q:'$D(LRMACH) Q:'$D(^LAB(62.4,LRMACH,5))
- L +^LRO(68,LRAA,1,DT,3,LRMACH)
- S N=20,U="^",LRTODAY=DT,X1=DT,X2=-1 D C^%DTC S LRSDT=X
- IF $D(^LRO(68,LRAA,1,LRTODAY,3,LRMACH,0)) G C4
- S %DT="",X="T-1" D ^%DT IF '$D(^LRO(68,LRAA,1,Y,3,LRMACH,0)) G C3
- S LRNS=1+$P(^LRO(68,LRAA,1,Y,3,LRMACH,1,0),U,4) IF +^(LRNS,0)'=N S ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,1,0)=^LRO(68,LRAA,1,Y,3,LRMACH,1,LRNS,0) K ^LRO(68,LRAA,1,Y,3,LRMACH,1,LRNS,0) G C3A
- ;;now set 'count' and 'previous x' = ""
- C3 S ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,1,0)=""
- C3A S ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,0)=^LAB(62.4,LRMACH,5),^LRO(68,LRAA,1,LRTODAY,3,0)="^68.07PA^",^(LRMACH,1,0)="^68.08A^"
- C4 S LRMC=^LRO(68,LRAA,1,LRTODAY,3,LRMACH,0),B=1+$P(^(1,0),U,4) G LREND:'$D(^(B,0))!'$D(^LR(LRDFN,"CH",LRIDT,388))
- ;;now set x = 'previous x' + ($S(val<0:-1,1:1) * SQRT(val - grand mean))
- S LREND=0 F I=2:1:4 S LRMP=386+I,LRSI=1 S:'$D(^LR(LRDFN,"CH",LRIDT,LRMP)) LREND=1 Q:LREND S X=$P(^(LRMP),U,1)-$P(LRMC,U,I) S:X<0 LRSI=-1,X=-X D SQRT S LRMM(I)=$J($P(^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0),U,I)+(LRSI*Y),0,6)
- ;;now set count = 1 + count and store calculated values
- G LREND:LREND S ^(0)=(1+^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0))_U_LRMM(2)_U_LRMM(3)_U_LRMM(4)
- ;;if count is less than 20, done for now
- I +^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0)<N G LREND
- ;;set mean = grand mean + $S(x<0:-1,1:1) * ((x/20)**2)
- F I=2:1:4 S LRSI=1 S:$P(^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0),U,I)<0 LRSI=-1 S LRMM(I)=$P(LRMC,U,I)+(LRSI*($P(^(0),U,I)/N)*($P(^(0),U,I)/N))
- S LRNEW=B F I=2:1:4 S LRNEW=LRNEW_U_$J(LRMM(I),4,1)
- ;;back to initial conditions, x and count = ""
- S ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,0)="^68.08A^"_B_U_B,^(B,0)=LRNEW,^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B+1,0)=""
- LIST W !,"DATE",?18,"MCV",?40,"MCH",?62,"MCHC",!,?12 F I=1:1:3 W "# DELTA % "
- C5 S LRSDT=$O(^LRO(68,LRAA,1,LRSDT)),N=20,U="^" G:LRSDT<1 LREND
- G:'$D(^LRO(68,LRAA,1,LRSDT,3,LRMACH,0)) C5 S N=+$P(^LRO(68,LRAA,1,LRSDT,3,LRMACH,1,0),U,4)
- F I=1:1:N S LROLD=^LRO(68,LRAA,1,LRSDT,3,LRMACH,1,I,0) W !,$E(LRSDT,2,7) F J=2:1:4 W ?((J-2)*22+12),$P(LROLD,U,J),?((J-2)*22+18),$J($P(LROLD,U,J)-$P(LRMC,U,J),4,1),?((J-2)*22+24),$J($P(LROLD,U,J)-$P(LRMC,U,J)/$P(LRMC,U,J)*100,5,1)
- G C5
- SQRT ;Y=SQRT(X)
- S Y=0 Q:X'>0 S Y=X+1/2
- L S T=Y,Y=X/T+T/2 G L:Y<T
- Q
- LREND LOCK -^LRO(68,LRAA,1,DT,3,LRMACH)
- K %,A,DIC,I,K,N,X,Y,Z,LRMM,LRMC,LRSI,T,LRSDT,LROLD,LRTODAY
- K %DT,%H,%ZA,%ZB,%ZC,B,LRMP,LRNEW,LRNS,POP,X1,X2,ZTSAVE,ZTSK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRQCC 3333 printed Feb 18, 2025@23:45:37 Page 2
- LRQCC ;SLC/CJS - QUALITY CONTROL FOR BULL ALGORITHM ;2/6/91 14:28 ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 SET DIC="^LRO(68,"
- SET DIC(0)="AEOQ"
- DO ^DIC
- if Y<1
- QUIT
- SET LRAA=+Y
- +3 SET %DT="AE"
- WRITE !,"START FROM"
- DO ^%DT
- if Y<0
- QUIT
- SET LRSDT=Y-1
- C2 SET DIC("A")="Select INSTRUMENT: "
- SET DIC("S")="I $D(^(5))"
- SET DIC="^LAB(62.4,"
- DO ^DIC
- KILL DIC
- if Y<1
- QUIT
- SET LRMACH=+Y
- SET LRMC=^LAB(62.4,LRMACH,5)
- +1 IF '$PIECE(^LAB(62.4,LRMACH,5),U,2)!('$PIECE(^(5),U,3))!('$PIECE(^(5),U,4))
- WRITE " ??",$CHAR(7),!,"Mean data values are missing in the AUTO INSTRUMENT file for this instrument."
- GOTO LREND
- +2 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO LREND
- +3 IF $DATA(IO("Q"))
- SET ZTRTN="DQ^LRQCC"
- FOR I="LRMACH","LRMC","LRSDT","LRAA"
- SET ZTSAVE(I)=""
- +4 IF $DATA(IO("Q"))
- KILL IO("Q")
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"REQUEST QUEUED"
- GOTO END
- DQ USE IO
- DO LIST
- DO ^%ZISC
- END KILL %,A,DIC,I,K,N,X,Y,Z,LRMACH,LRMC,LRSDT,LRAA,DIC,%ZIS,ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK
- QUIT
- LABULL if '$DATA(LRBULL)
- QUIT
- KILL LRBULL
- if '$DATA(LRMACH)
- QUIT
- if '$DATA(^LAB(62.4,LRMACH,5))
- QUIT
- +1 LOCK +^LRO(68,LRAA,1,DT,3,LRMACH)
- +2 SET N=20
- SET U="^"
- SET LRTODAY=DT
- SET X1=DT
- SET X2=-1
- DO C^%DTC
- SET LRSDT=X
- +3 IF $DATA(^LRO(68,LRAA,1,LRTODAY,3,LRMACH,0))
- GOTO C4
- +4 SET %DT=""
- SET X="T-1"
- DO ^%DT
- IF '$DATA(^LRO(68,LRAA,1,Y,3,LRMACH,0))
- GOTO C3
- +5 SET LRNS=1+$PIECE(^LRO(68,LRAA,1,Y,3,LRMACH,1,0),U,4)
- IF +^(LRNS,0)'=N
- SET ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,1,0)=^LRO(68,LRAA,1,Y,3,LRMACH,1,LRNS,0)
- KILL ^LRO(68,LRAA,1,Y,3,LRMACH,1,LRNS,0)
- GOTO C3A
- +6 ;;now set 'count' and 'previous x' = ""
- C3 SET ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,1,0)=""
- C3A SET ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,0)=^LAB(62.4,LRMACH,5)
- SET ^LRO(68,LRAA,1,LRTODAY,3,0)="^68.07PA^"
- SET ^(LRMACH,1,0)="^68.08A^"
- C4 SET LRMC=^LRO(68,LRAA,1,LRTODAY,3,LRMACH,0)
- SET B=1+$PIECE(^(1,0),U,4)
- if '$DATA(^(B,0))!'$DATA(^LR(LRDFN,"CH",LRIDT,388))
- GOTO LREND
- +1 ;;now set x = 'previous x' + ($S(val<0:-1,1:1) * SQRT(val - grand mean))
- +2 SET LREND=0
- FOR I=2:1:4
- SET LRMP=386+I
- SET LRSI=1
- if '$DATA(^LR(LRDFN,"CH",LRIDT,LRMP))
- SET LREND=1
- if LREND
- QUIT
- SET X=$PIECE(^(LRMP),U,1)-$PIECE(LRMC,U,I)
- if X<0
- SET LRSI=-1
- SET X=-X
- DO SQRT
- SET LRMM(I)=$JUSTIFY($PIECE(^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0),U,I)+(LRSI*Y),0,6)
- +3 ;;now set count = 1 + count and store calculated values
- +4 if LREND
- GOTO LREND
- SET ^(0)=(1+^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0))_U_LRMM(2)_U_LRMM(3)_U_LRMM(4)
- +5 ;;if count is less than 20, done for now
- +6 IF +^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0)<N
- GOTO LREND
- +7 ;;set mean = grand mean + $S(x<0:-1,1:1) * ((x/20)**2)
- +8 FOR I=2:1:4
- SET LRSI=1
- if $PIECE(^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B,0),U,I)<0
- SET LRSI=-1
- SET LRMM(I)=$PIECE(LRMC,U,I)+(LRSI*($PIECE(^(0),U,I)/N)*($PIECE(^(0),U,I)/N))
- +9 SET LRNEW=B
- FOR I=2:1:4
- SET LRNEW=LRNEW_U_$JUSTIFY(LRMM(I),4,1)
- +10 ;;back to initial conditions, x and count = ""
- +11 SET ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,0)="^68.08A^"_B_U_B
- SET ^(B,0)=LRNEW
- SET ^LRO(68,LRAA,1,LRTODAY,3,LRMACH,1,B+1,0)=""
- LIST WRITE !,"DATE",?18,"MCV",?40,"MCH",?62,"MCHC",!,?12
- FOR I=1:1:3
- WRITE "# DELTA % "
- C5 SET LRSDT=$ORDER(^LRO(68,LRAA,1,LRSDT))
- SET N=20
- SET U="^"
- if LRSDT<1
- GOTO LREND
- +1 if '$DATA(^LRO(68,LRAA,1,LRSDT,3,LRMACH,0))
- GOTO C5
- SET N=+$PIECE(^LRO(68,LRAA,1,LRSDT,3,LRMACH,1,0),U,4)
- +2 FOR I=1:1:N
- SET LROLD=^LRO(68,LRAA,1,LRSDT,3,LRMACH,1,I,0)
- WRITE !,$EXTRACT(LRSDT,2,7)
- FOR J=2:1:4
- WRITE ?((J-2)*22+12),$PIECE(LROLD,U,J),?((J-2)*22+18),$JUSTIFY($PIECE(LROLD,U,J)-$PIECE(LRMC,U,J),4,1),?((J-2)*22+24),$JUSTIFY($PIECE(LROLD,U,J)-$PIECE(LRMC,U,J)/$PIECE(LRMC,U,J)*100,5,1)
- +3 GOTO C5
- SQRT ;Y=SQRT(X)
- +1 SET Y=0
- if X'>0
- QUIT
- SET Y=X+1/2
- L SET T=Y
- SET Y=X/T+T/2
- if Y<T
- GOTO L
- +1 QUIT
- LREND LOCK -^LRO(68,LRAA,1,DT,3,LRMACH)
- +1 KILL %,A,DIC,I,K,N,X,Y,Z,LRMM,LRMC,LRSI,T,LRSDT,LROLD,LRTODAY
- +2 KILL %DT,%H,%ZA,%ZB,%ZC,B,LRMP,LRNEW,LRNS,POP,X1,X2,ZTSAVE,ZTSK
- +3 QUIT
